; 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 ; ; ^x0001000C - CALC (65548) ; INSTR = math expression ; ; ; ^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 ; n = 9. Save misspelled word and its correction ; ; ^x0007000n - LIBRARY (458752) ; n = 1. Initialize, open for read, lookup_key ; n = 2. Return next line of text from module ; n = 3. Close text library ; n = 4. Initialize, open for write, lookup_key ; n = 5. Write next line of text to module ; n = 6. Write end-of-module record ; ;-- ; 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 ; David Deley Sep. 1990 V7.2 more spelling checker and fixes for VMS 5.3 bug ; David Deley Dec. 1991 V8.1 DES encryption removed. ; David Deley Feb. 1992 V8.2 Spell check 'Accept' could fail with access violation in ALLOCATE_NODE (caught by HANDLER) ;------------------------------------------------------------------------------ ; 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 ; SAVE_CORRECTION ! Save misspelled word and its correction ; 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 ; ; Text libraries ; LIBRARIAN ; LBR_INIT ; LBR_CLOSE ; LBR_READNEXT ; LBR_WRITENEXT ; LBR_REPLACE ; ;------------------------------------------------------------------------------ .TITLE EDX_CALLUSER $CHFDEF ;Include CHF$ definitions $CLIMSGDEF $DSCDEF ;Define DSC$ descriptor definitions $FABDEF ;Include FAB$ definitions $LNMDEF ;Include LNM$ definitions $LBRDEF ;Include LBR$ definitions $NAMDEF ;Include NAM$ definitions $RMSDEF ;Include RMS$ definitions $SSDEF ;Include SS$ system condition code definitions $STSDEF $XABDATDEF $XABDEF $XABFHCDEF ;Constants SPACE = ^x20 ;Ascii space character 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) SET_MESSAGE_FLAGS=2 ;Code for recursive call to set message flags .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 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 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, #<7-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 LBRIAN-1$ ; 7 = LIBRARIAN 2$: PUSHL #EDX__UNKNCODE ;Unknown item code CALLS #1,EDX_SIGNAL ;Signal internal error RETURN CASSYS: ;Case 0001xxxx system code numbers CASEL R6, #1, #<12-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 CALCUL-2$ ;12 = CALCULATOR 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 CALCUL: ;! PUSHL INSTR ;! CALLS #1,G^CALC3 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: RETURN ;encrypt removed ENCRPT: RETURN ;encrypt removed EDXSRT: CALLS #0,EDX_SORT RETURN EDXSPL: CALLS #0,EDX_SPELL RETURN LBRIAN: CALLS #0,LIBRARIAN 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 /8.2/ IDENT: .ASCII /8.2/ 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 ;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 ;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. ; 21 Check VAXTPU version #. If VAXTPU 2.4 or above then UPDATE(MESSAGE_WINDOW) ; This fixes bug in VMS 5.3 so next message will appear properly ; a. Check TPU VERSION & UPDATE. If 2.4 or above then UPDATE(MESSAGE_WINDOW). ; 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'),"")/ .ALIGN LONG UPDMSGCMD: .ASCID /IF GET_INFO(SYSTEM,'DISPLAY') THEN UPDATE(MESSAGE_WINDOW) ENDIF;/ ;------------------------------------------------------------------------------ .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 ;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 ; Now do special check for VMS 5.3 bug. If running VAXTPU 2.4 or above, ; then make call to update(message_window) BEFORE sending message to message buffer. ; Someday when they fix this bug we'll branch if VAXTPU above where bug is fixed. CMPL G^TPU$GL_VERSION,#2 ;Check for TPU version #2 BLSS 2$ ;Branch if TPU version #1 CMPL G^TPU$GL_UPDATE,#4 ;Check for TPU update #4 BLSS 2$ ;Branch if TPU 2.0,2.1,2.2 PUSHAQ UPDMSGCMD ;update(message_window) CALLS #1,G^TPU$EXECUTE_COMMAND ;FIX VMS 5.3 BUG ;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 ;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 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 ;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$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),- (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),# ;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 #,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 #,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 (R9),R4 ;Move file size to R4 TSTW (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 #,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 #,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 #,R9,DSC$A_POINTER(R2) ;Base address of DIRBLK + offset = start address for date string PUSHL #0 ;cvtflg PUSHAL (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 #,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 | ; ----------------------------------------- ; | buffer address | ; ----------------------------------------- ; | TBLIND | ; -----------------------------------------(original stack pointer) ; | ; 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 ;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 #,SP ;Allocate memory on stack MOVL SP,R9 ;Store base address in R9 ;Initialize descriptor MOVL #BUFLEN, (R9) ;Length MOVB #DSC$K_DTYPE_T, (R9) ;Type MOVB #DSC$K_CLASS_S, (R9) ;Class MOVL R9, (R9) ;Address ;Translate DCL symbol PUSHAL (R9) ;Table indicator PUSHAW (R9) ;Return length PUSHAL (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 (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 ;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 ;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 ; 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, (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 ; 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 #,(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 #,(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 #,(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 #,(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 #,(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 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 | (R9) ; ----------------------------------------- ; | buffer address | (R9) ; ----------------------------------------- ; | (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 SUBL2 #,SP ;ALLOCATE MEMORY ON STACK MOVL SP,R9 ;Store base address in R9 MOVW #SRT_MAXLRL, (R9) ;Length ;INITIALIZE DESCRIPTOR MOVB #DSC$K_DTYPE_T, (R9) ;Type MOVB #DSC$K_CLASS_S, (R9) ;Class MOVL R9, (R9) ;Address PUSHAW (R9) ;length by reference will go into descriptor PUSHAQ (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 (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 ;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 = , - ; Output file name DNM = , - NAM = DICNAMIO, - FAC = , - ; Block I/O write operation SHR = 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 = , - ; Output file name DNM = , - FOP = , - FAC = , - SHR = , - ;UPI must be set says the book RTV = -1 ;keep all pointers PERSDICFAB: ; Personal dictionary $FAB FNM = , - DNM = , - FAC = , - SHR = 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, #<9-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 SAVCOR-1$ ; 9 = Save misspelled word and its correction 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 SAVCOR: PUSHL INSTR CALLS #1,SAVE_CORRECTION 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 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) (length COROUTLEN) ; | . | ; | . | ; | | ; -----------------------------------------(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 .ALIGN LONG FAOCOROUT: .ASCID /!3UL !3UL !AC/ COROUTLEN=8+255 ;longest word we can handle here is 255 characters (hex FF) .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY SPELL_TEXTLINE,^M 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 ;set up response string to EDX MOVL SP,R0 ;Save address of descriptor SUBL2 #,SP ;Build temp descriptor MOVL SP,R2 ;Save address of descriptor in R2 MOVW #COROUTLEN, 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 ; check misspelled word list for possible suggested correction PUSHAL NEWNODE ;new node return address PUSHAB COMPARE_NODE ;compare node routine PUSHL R0 ;our word to search for (address of descriptor) PUSHAL SAVCOR_TREE ;tree of saved corrections CALLS #4,G^LIB$LOOKUP_TREE ;search for the word BLBS R0,250$ ;word found ;correction word not found, make response without it PUSHL WORD_LENGTH(R11) ;length of misspelled word PUSHL WORD_START(R11) ;starting offset of misspelled word PUSHL R2 ;Outbuf (by descriptor) PUSHL R2 ;Outlen PUSHAQ FAOSPLOUT ;Ctrstr without suggested correction (by descriptor) CALLS #5,G^SYS$FAO ;Write size to outline BRB 290$ ;correction word found, make response and include it. 250$: MOVL NEWNODE,R0 ;address of node where suggested correction is ADDL2 #10,R0 ;address of misspelled ASCIC word MOVZWL (R0),R1 ;R1 = length of misspelled word ADDL2 #2,R0 ;+2 for word length ADDL2 R1,R0 ;R0 = address of ASCIC correct word PUSHL R0 ;address of counted ASCII string (or garbage) PUSHL WORD_LENGTH(R11) ;length of misspelled word PUSHL WORD_START(R11) ;starting offset of misspelled word PUSHL R2 ;Outbuf (by descriptor) PUSHL R2 ;Outlen PUSHAQ FAOCOROUT ;Ctrstr with suggested correction (by descriptor) CALLS #6,G^SYS$FAO ;Write size to outline ;final output string 290$: PUSHL R3 ;address of output string MOVZWL (R2),-(SP) ;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 ;; 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 is 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 NOP ;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 incase word is last word of previous page overlaping onto 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 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 ; 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,# ;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 ;; 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,# ;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 "." ; ; EDX DUMP_DICTIONARY calls this to get the next word from the dictionary. ; It calls specifying rows=1, columns=0. If columns=0 is specified, ; then one word (the next word in line) is placed in the output buffer ; and the output buffer length set to 80. ; ; ; MEMORY ALLOCATED ON STACK: ; ----------------------------------------- ; | OUTSTR BUFFER | (R10) ; | . | ; | . | ; | . | ; | . | ; | . | ; ----------------------------------------- ; ;-- MAX_WORD_SIZE=80 ;maximum size of word (returned to EDX DUMP_DICTIONARY) .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY DIC_BROWSE_FILL,^M ; 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) ADDL2 #MAX_WORD_SIZE,R0 ;allocate 80 more so min is at least 80 (necessary for dump_dictionary) SUBL2 R0,SP ;allocate memory on stack to bulid OUTSTR 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,# ;see if word longer than screen length left BLEQ 140$ ;continue if not PUSHL R2 MOVC3 #,(R9),(R10)[R2] ;insert word into OUTSTR POPL R2 ADDL2 #,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) TSTL (SP) ;test for zero length column size (used by EDX DUMP_DICTIONARY) BNEQ 202$ ; MOVL #MAX_WORD_SIZE,(SP) ;if 0, set length to 80 202$: 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 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 ;new node return address TREE_HEAD: .LONG 0 ;accepted word tree SAVCOR_TREE: .LONG 0 ;saved corrections tree .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 ;++ ; SAVE_CORRECTION ; ; Functional Description: ; Constructs a balanced binary tree of misspelled words and their ; correction. The VMS library routine LIB$INSERT_TREE is used to ; build the tree. After declaring a word misspelled, SPELL_TEXTLINE ; uses the VMS library routine LIB$LOOKUP_TREE to search this tree ; for a match. If a match is found the correct spelling is returned ; to EDX. EDX then asks the user if he wishes to make the correction. ; ; 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 #1,SAVE_CORRECTION ; ; Inputs: ; 4(AP) - Descriptor of string containing misspelled word and correct ; word. The format of the string is misspelled word followed ; by a single space followed by the correct word. ; ; Outline: ; 1. Memory is allocated on the stack. The length of the input string ; plus for string counts plus descriptor plus longword align stack. ; 2. The string is parsed. ; a. Search for the first non-blank character ; error if we encounter end of string. ; zero counter of length of first word. ; skip two spaces in stack memory for length of first word ; we will fill in later. ; b. loop (parse of first word) ; copy character to stack memory & upcase characer if necessary ; move to next character. ; increment counter of length of first word ; increment pointer into input string and into stack memory ; error if end of string ; exit loop if character is space. (delimiter between words) ; endloop ; c. skip one character in stack memory. This is where count of ; next word will go after we find how long the next word is. ; save memory location where count goes. ; d. search for next non-blank character ; error if we encounter end of string ; e. zero counter of length of second word ; loop (parse of second word) ; copy character to stack memory & upcase character if necessary ; move to next character. ; increment count length of word ; increment pointer into input string and into stack memory ; exit loop if character is space or end of string. ; endloop ; copy word length (1 byte) to saved memory location. ; ; 3. Stack memory now has string in proper form. All uppercase, ; two bytes giving the length of the first word, followed by ; the word, followed by one byte giving the length of the ; second word, followed by the second word. ; ; Add to tree. ; ; Memory Map (Memory allocated on stack): ; -----------------------------------------(R11) (descriptor for string #1) ; | class | dtype | length #1 | ; ----------------------------------------- ; | address string #1 | ; ----------------------------------------- ; | class | dtype | length #2 |(descriptor for string #2) ; ----------------------------------------- ; | address string #2 | ; ----------------------------------------- ; | String #1 | ; | . | ; | . | ; ----------------------------------------- ; | String #2 | ; | . | ; | . | ; ----------------------------------------- ; |(original stack pinter) ; Registars: ; R6 - Length of word count ; R7 - Pointer into input string ; R8 - Pointer to one byte beyond end of input string ; R9 - Pointer into stack memory ; R10 - Flag. 0=parsing first word, 1=parsing second word ; R11 - Base address of stack memory ; ;- .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY SAVE_CORRECTION,^M ; 1. Memory is allocated on the stack. The length of the input string ; plus two descriptors (16 bytes) plus longword align the stack. MOVZWL @4(AP),R0 ;R0=length of input string SUBL2 R0,SP ;allocate memory for string SUBL2 #<8+8>,SP ;allocate more memory for 2 string descriptors BICB2 #^B0011,SP ;longword align stack pointer MOVL SP,R11 ;store base address of stack memory ADDL3 #<8+8>,R11,R9 ;pointer into stack memory of string #1 MOVB #DSC$K_DTYPE_T, DSC$B_DTYPE(R11) ;Type (descriptor #1) MOVB #DSC$K_CLASS_S, DSC$B_CLASS(R11) ;Class MOVL R9, DSC$A_POINTER(R11) ;address MOVB #DSC$K_DTYPE_T, (R11) ;Type (descriptor #2) MOVB #DSC$K_CLASS_S, (R11) ;Class MOVL 4(AP),R7 ;R7=address of string descriptor MOVL 4(R7),R7 ;R7=address into input string ADDL3 R0,R7,R8 ;R8=address of one byte beyond end of input string CLRL R6 ;Length of word count CLRL R10 ;Flag. 0=parsing first word ; 2. The string is parsed. ;Skip over leading blanks 10$: CMPL R7,R8 BNEQ 11$ PUSHL #0 ;ERROR. Premature end of string CALLS #1,FMTOUTSTR RET 11$: CMPB (R7),#SPACE BNEQ 20$ INCL R7 ;Pointer into input string BRB 10$ ;Parse off word 20$: CMPL R7,R8 ;pointer into input string with end of string BEQL 50$ ;end of word found 21$: MOVZBL (R7),R0 ;character from input string CMPB R0,#SPACE BEQL 50$ ;delimiter between words found CMPB R0,#^A"a" ;check for lowercase letter BLSS 40$ CMPB R0,#^A"z" BGTR 40$ ;(should not be non-alphabetic character) SUBB2 #32,R0 ;convert lowercase to uppercase 40$: MOVB R0,(R9) INCL R9 ;Pointer into stack memory INCL R7 ;Pointer into input string INCL R6 ;Length of word count BRB 20$ 50$: TSTL R10 BGTR 100$ ;Get ready to parse off second word. INCL R10 MOVW R6,DSC$W_LENGTH(R11) ;Save length of first word parsed off CLRL R6 ;Zero second word count MOVL R9,(R11);Store address of string#2 BRB 10$ ;go parse off second word ;finish second word. Store length. 100$: MOVW R6,(R11) ;Store length of second word ;Now store in tree JSB INITVMZONE PUSHAQ 8(R11) ;address of descriptor of string#2 [user data] PUSHAL NEWNODE ;new node return address PUSHAB ALLOCATE_NODE ;allocate node routine PUSHAB COMPARE_NODE ;compare node routine PUSHAL BTFLAGS ;no duplicates PUSHL R11 ;descriptor of string#1 PUSHAL SAVCOR_TREE ;tree head for the binary tree of saved corrections CALLS #7,G^LIB$INSERT_TREE ;add the word PUSHL R0 CALLS #1,FMTOUTSTR RET ;------------------------------------------------------------------------------ ;; For debugging purposes: ;; .ENTRY TRAVERSE_TREE,^M<> ;; PUSHAB PRINT_NODE ;; PUSHAL SAVCOR_TREE ;; 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 (#2 or #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) - [optional user data] If non-zero, address of string descriptor ; of string #2. ; ; 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#1 LENGTH | balance | ; ----------------------------------------- ; | STRING#1 | 12(R10) ; | . | ; | . | ; ----------------------------------------- ; | String #2 |length #2| (optional string#2) ; | . +---------| ; | . | ; ----------------------------------------- ; ; 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, +1 byte + length of ; string#2 if present). ; ;Registar usage: ; R10 = address of node memory block ; R9 = address of string descriptor ;-- .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY ALLOCATE_NODE,^M 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) (+1+length of string#2 if present) CMPL (AP),#3 BLSS 10$ ;branch if string#2 not given TSTL 12(AP) ;test for string#2 BEQL 10$ ADDW2 @12(AP),(SP) ;add length of string#2 INCW (SP) ;add one more byte for string #2 (where length goes) 10$: 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,20$ ;branch on success PUSHL R0 ;else we're in trouble... PUSHL R0 CALLS #1,EDX_SIGNAL CALLS #1,FMTOUTSTR RET 20$: 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 CMPL (AP),#3 BLSS 40$ ;branch if string#2 not given TSTL 12(AP) ;test for string#2 BEQL 40$ MOVZWL (R9),R0 ;calculate address for string #2 ADDL2 R0,R10 ;(IDENT 8.2 bugfix) MOVZBL @12(AP),R0 ;Length of string#2 MOVB R0,12(R10) ;set length byte of string#2 INCL R10 MOVL 12(AP),R9 ;address of string#2 descriptor MOVC3 R0,@4(R9),12(R10) ;fill in string #2 40$: 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 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 = , - DNM = , - NAM = ADDPDICNAM, - FAC = , - SHR = , - 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 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 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 ;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,#,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$L_ESA(R9) ;Expanded file name string address ADDL3 R9,#,- 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 ;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 (R5); Address of resultant filename string MOVZBL (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 (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 ;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 ;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 (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 ;Allocate zero filled memory on stack SUBL2 #,SP ;Allocate memory on stack MOVL SP,R9 ;Store base address. We'll use this memory for the FAB/NAM block PUSHR #^M MOVC5 #0,(SP),#^x00,#,(R9) ; Zero allocated memory POPR #^M ;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 ;Allocate zero filled memory on stack SUBL2 #,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,#,(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 ;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 ;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 | ; -----------------------------------------(item list for sys$trnlnm) ; | LNM$_STRING | BUFLEN | ; ----------------------------------------- ; | Address of BUFFER | ; ----------------------------------------- ; | Address of RETLEN | ; ----------------------------------------- ; | 0 | ; -----------------------------------------(original stack pointer) ; | ; ;------------------------------------------------------------------------------ .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 ;Allocate memory on stack SUBL2 #,SP ;Move stack pointer over memory we claim MOVL SP,R9 ;Store base address. ;Initialize item list MOVW #BUFLEN,(R9) ;Buffer length MOVW #LNM$_STRING,(R9) ;Item code MOVL R9,(R9) ;Address of BUFFER MOVAL (R9),(R9) ;Address of RETLEN CLRL (R9) ;End of item list ;Translate logical name MOVL #LNM$M_CASE_BLIND,-(SP) ;Attr MOVL SP,R0 ;Address of above (by reference) PUSHAL (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 (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 | ; ----------------------------------------- ; | buffer address | ; ----------------------------------------- ; | TBLIND | ; -----------------------------------------(original stack pointer) ; | ; ;-- .ENTRY SHOW_SYMBOL,^M ;Allocate memory on stack SUBL2 #,SP ;Move stack pointer over memory we claim MOVL SP,R9 ;Store base address. ;Initialize descriptor MOVW #BUFLEN, (R9) ;Length MOVB #DSC$K_DTYPE_T, (R9) ;Type MOVB #DSC$K_CLASS_S, (R9) ;Class MOVL R9, (R9) ;Address ;Translate DCL symbol PUSHAL (R9) ;Table indicator PUSHAW (R9) ;Return length PUSHAL (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 (R9),R0 ;length of output string PUSHL R0 ;length of output string PUSHL (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 | ; ----------------------------------------- ; | buffer address | ; ----------------------------------------- ;-- .ENTRY TRA_EBC_ASC,^M<> ;Allocate memory on stack SUBL2 #,SP ;Move stack pointer over memory we claim MOVL SP,R9 ;Store base address. ;Initialize descriptor MOVW @INSTR, (R9) ;Length MOVB #DSC$K_DTYPE_T, (R9) ;Type MOVB #DSC$K_CLASS_S, (R9) ;Class MOVL R9, (R9) ;Address PUSHAQ (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 (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 | ; ----------------------------------------- ; | buffer address | ; ----------------------------------------- ;-- .ENTRY TRA_ASC_EBC,^M<> ;Allocate memory on stack SUBL2 #,SP ;Move stack pointer over memory we claim MOVL SP,R9 ;Store base address. ;Initialize descriptor MOVW @INSTR, (R9) ;Length MOVB #DSC$K_DTYPE_T, (R9) ;Type MOVB #DSC$K_CLASS_S, (R9) ;Class MOVL R9, (R9) ;Address PUSHAQ (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 (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 LIBRARIAN .PSECT DATA RD,WRT,NOEXE,LONG,PIC,NOSHR LBR_INDEX: .LONG 0 ;Library Control Index LBR_RFA: .QUAD 0 ;Current Library Module. 0 if none. .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY LIBRARIAN,^M<> ;458752+n ;Case entry code ;R6 = Entry code passed by caller 10$: CASEB R6, #1, #<6-1> ;Case entry point to jump to 1$: .WORD LBRIOR-1$,- ; 1 = Initialize, Open for read, Lookup_key LBRIOW-1$,- ; 2 = Initialize, Open for write, Lookup_key LBRCLO-1$,- ; 3 = Close text library LBRRNX-1$,- ; 4 = Read next line from module LBRWNX-1$,- ; 5 = Write next line to module LBRINS-1$ ; 6 = Insert (/replace) new module into library PUSHL #EDX__UNKNCODE ;Unknown item code CALLS #1,EDX_SIGNAL ;Signal internal error RET ;and return LBRIOR: PUSHL #LBR$C_READ ;Open library for read CALLS #1,LBR_INIT RET LBRIOW: PUSHL #LBR$C_UPDATE ;Open library for write (update) CALLS #1,LBR_INIT RET LBRCLO: CALLS #0,LBR_CLOSE ;Close library & release internal memory RET LBRRNX: CALLS #0,LBR_READNEXT ;Read next line from module RET LBRWNX: CALLS #0,LBR_WRITENEXT ;Write next line to module RET LBRINS: CALLS #0,LBR_REPLACE ;Insert (/replace) new module into library RET ;------------------------------------------------------------------------------ ;++ ; ; LBR_INIT ; ; Functional Description: ; Initialize librarian, open text library for read or write access ; as specified in argument 4(AP), locate module. ; ; Returns: ; If error parsing INSTR, signal parse erorr and return 0. ; If error calling LBR$INI_CONTROL, signal error and return 0. ; If error calling LBR$OPEN, signal error and return 0. ; If error calling LBR$LOOKUP_KEY: ; If error was LBR$KEYNOTFND, return 2. ; This may be OK if inserting a new module. ; This may not be OK if we're trying to read a module. ; Any other error: ; signal error and return 0. ; If no errors: ; LBR_RFA = RFA of module found by LBR$LOOKUP_KEY ; Return 1. ; ; Calling Sequence: ; CALLS #1,LBR_INIT ; ; Inputs: ; (AP) = 1. One argument follows ; 4(AP) = LBR$C_READ or LBR$C_UPDATE depending upon whether this ; is open for read access or open for write access. ; (by value. Passed to LBR$INI_CONTROL as "func" parameter.) ; ; INSTR = Contains text library filename followed by a space character ; followed by the module name to extract ; INSTR = " " ; ; Outline: ; 1. Initialize librarian - LBR$INI_CONTROL ; 2. Open text library ; a. Parse off filename from INSTR ; b. Call LBR$OPEN ; 3. Locate module within text library ; a. Parse off module name ; b. Call LBR$LOOKUP_KEY ; 4. Call LBR$SET_LOCATE to set locate mode ; ; ; MEMORY ALLOCATED ON STACK: ; ----------------------------------------- (descriptor for string) ; | class | dtype | string length | (R10) ; ----------------------------------------- ; | buffer address | ; ----------------------------------------- ;-- .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY LBR_INIT,^M ; Allocate memory on stack SUBL #8,SP ;allocate memory on stack MOVL SP,R10 ;save address of memory ; Parse INSTR for filename MOVQ @INSTR,(R10) ;Copy over string descriptor LOCC #SPACE, #80, @4(R10) ;search for space char delimiting filename from module. R1 = address of found character BNEQ 2$ ;Branch if space found BRW 97$ ;Space not found 2$: SUBL2 4(R10),R1 ;Length of filename MOVW R1,(R10) ;Set length of filename MOVB #DSC$K_DTYPE_T,DSC$B_DTYPE(R10) ;Fill in Type MOVB #DSC$K_CLASS_S,DSC$B_CLASS(R10) ;Fill in Class ; Initialize library control structure PUSHL #LBR$C_TYP_TXT ;Text library PUSHL 4(AP) ;LBR$C_READ or LBR$C_UPDATE PUSHAL 4(SP) ;LBR$C_TYP_TXT (by reference) PUSHAL 4(SP) ;LBR$C_READ or LBR$C_UPDATE (by reference) PUSHAL LBR_INDEX ;Library control index (returned) CALLS #3,G^LBR$INI_CONTROL ;Initialize library control structure BLBS R0,5$ ;continue on success BRW 99$ ;if error signal error and return 0 ; Open library file 5$: PUSHL R10 ;Descriptor of filename PUSHAL LBR_INDEX ;library control index CALLS #2,G^LBR$OPEN ;open library BLBC R0,95$ ;if error signal error and return 0 ; Set record access to locate mode PUSHAL LBR_INDEX ;library control index CALLS #1,G^LBR$SET_LOCATE ;set record access to locate mode BLBS R0,7$ ;continue on success BRW 96$ ;branch on error ; Parse INSTR for module_name 7$: MOVZWL (R10),R0 ;Length of filename name INCL R0 ;Include space ADDL2 R0,4(R10) ;Set address of module name SUBW3 R0,@INSTR,(R10) ;Set length of module name 8$: TSTW (R10) BLEQ 97$ ;no module-name ;; CMPB 4(R10),#SPACE ;more than one space? (FOR CONSISTENCY DON'T TRIM HERE OR WE'LL HAVE ;; BNEQ 10$ ;no, continue TO DO IT EVERYWHERE. TRIM IS DONE IN EDX TPU) ;; INCL 4(R10) ;else move forward one char ;; DECW (R10) ;; BRB 8$ ; Lookup_key 10$: PUSHAL LBR_RFA ;pointer to text module if found. (Record File Address) PUSHL R10 ;Descriptor of module name PUSHAL LBR_INDEX ;Library control index CALLS #3,G^LBR$LOOKUP_KEY ;Look for module in library BLBC R0,11$ ;branch if not normal success PUSHL #1 ;else Return 1 (module found) BRB 100$ ;exit 11$: CMPL R0,#LBR$_KEYNOTFND ;test for 'key not found' BNEQ 99$ CLRQ LBR_RFA ;no current library module PUSHL #2 ;Key not found status BRB 100$ ;Error opening specified text library. Signal error open, then signal error 95$: PUSHL R0 ;Save error on stack PUSHL R10 ;Text library file name PUSHL #1 ;one FAO argument PUSHL #EDX__ERROPEN ;Error opening file CALLS #3,EDX_SIGNAL ;Signal error open BRB 94$ ;then signal error (error on stack) 97$: MOVL #EDX__NOMODNAM,R0 ;No input module name. Space not found. 99$: PUSHL R0 ;error status 94$: CALLS #1,EDX_SIGNAL ;signal error status 93$: PUSHL #0 ;retcode. return 0 100$: CALLS #1,FMTOUTSTR ;format output string RET ;unusual error during lbr$set_locate. Signal error, close library, return 0 96$: PUSHL R0 ;error status CALLS #1,EDX_SIGNAL ;signal error status PUSHAL LBR_INDEX ;Library control index CALLS #1,G^LBR$CLOSE ;close library BLBC R0,99$ ;on error closing, signal close error and return 0 BRB 93$ ;else return 0 ;------------------------------------------------------------------------------ ;++ ; ; LBR_CLOSE ; ; Functional Description: ; Closes text library freeing up internal storage used by librarian. ; Resets LBR_RFA to indicate there is no current library module. ; ; Calling Sequence: ; CALLS #0,LBR_CLOSE ; ; Inputs: ; LBR_INDEX - set by LBR_INIT ;-- .ENTRY LBR_CLOSE,^M<> CLRQ LBR_RFA ;no current library module PUSHAL LBR_INDEX ;Library control index CALLS #1,G^LBR$CLOSE ;close library PUSHL R0 ;status CALLS #1,FMTOUTSTR ;set OUTSTR RET ;------------------------------------------------------------------------------ ;++ ; ; LBR_READNEXT ; ; Functional Description: ; Returns next line from text module. Assumed LBR_INIREAD already ; called to initialize library. ; ; Calling Sequence: ; CALLS #0,LBR_READNEXT ; ; Inputs: ; LBR_INDEX - set by LBR_INIREAD ; ; Outputs: ; OUTSTR - Next line from module within text library. ; ; ; MEMORY ALLOCATED ON STACK: ; ----------------------------------------- (descriptor for string) ; | class | dtype | string length | (R10) ; ----------------------------------------- ; | buffer address | ; ----------------------------------------- ;-- .ENTRY LBR_READNEXT,^M SUBL2 #8,SP ;allocate memory MOVL SP,R10 ;Save address of memory MOVW #0,DSC$W_LENGTH(R10) ;Zero length MOVB #DSC$K_DTYPE_T,DSC$B_DTYPE(R10) ;Fill in descriptor Type MOVB #DSC$K_CLASS_S,DSC$B_CLASS(R10) ;Fill in descriptor Class MOVL #0,DSC$A_POINTER(R10) ;Zero address PUSHL R10 ;Address of descriptor (outbufdes) PUSHL #0 ;inbufdes (not used) PUSHAL LBR_INDEX ;library control index CALLS #3,G^LBR$GET_RECORD ;Get next record from module MOVQ (R10),-(SP) ;descriptor PUSHL R0 ;retcode CALLS #3,FMTOUTSTR ;format output string 99$: RET ;------------------------------------------------------------------------------ ;++ ; ; LBR_WRITENEXT ; ; Functional Description: ; Write next line to text module. Assumed LBR_INIWRITE already ; called to initialize library. ; ; Calling Sequence: ; CALLS #0,LBR_WRITENEXT ; ; Inputs: ; INSTR - Next line to write to module ; LBR_INDEX - set by LBR_INIWRITE ; ;-- .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY LBR_WRITENEXT,^M SUBL2 #8,SP ;allocate memory MOVL SP,R10 ;Save address of memory MOVW #0,DSC$W_LENGTH(R10) ;Zero length MOVB #DSC$K_DTYPE_T,DSC$B_DTYPE(R10) ;Fill in descriptor Type MOVB #DSC$K_CLASS_S,DSC$B_CLASS(R10) ;Fill in descriptor Class MOVL #0,DSC$A_POINTER(R10) ;Zero address PUSHAQ LBR_RFA ;record's file address (RFA) of module header PUSHL INSTR ;Address of descriptor of string to write to module (bufdes) PUSHAL LBR_INDEX ;library control index CALLS #3,G^LBR$PUT_RECORD ;Write next record to module MOVQ (R10),-(SP) ;descriptor PUSHL R0 ;retcode CALLS #3,FMTOUTSTR ;format output string 99$: RET ;------------------------------------------------------------------------------ ;++ ; ; LBR_REPLACE ; ; Functional Description: ; Insert (/replace) text module into library. ; ; Usage: ; The sequence for inserting a text module is as follows: ; CALL LBR_INIT( LBR$C_UPDATE ) ; IF (STATUS = 2) THEN ; ASK USER FOR PERMISSION TO REPLACE EXISTING MODULE; ; LOOP ; CALL LBR_WRITENEXT !Pass lines of text to library creating module ; ENDLOOP ; CALL LBR_REPLACE !Insert new module into library index ; !(If previous module existed, it is deleted at this time) ; ; Calling Sequence: ; CALLS #0,LBR_REPLACE ; ; Inputs: ; LBR_INDEX - Library Control Index. Set by LBR_INIT by LBR$INI_CONTROL ; LBR_RFA - Current Library Module. Set by LBR_INIT by LBR$LOOKUP_KEY ; INSTR - Name of text module to insert. ; ; Outline: ; The sequence is similar to the DCL command $ LIBRARY/TEXT/INSERT ; See INPUTTXT.LIS in facility LIBRAR ; If LBR_RFA = 0, then this is an 'insert new module' ; else this is a 'replace module' and LBR_RFA is the old module to delete. ; ; MEMORY ALLOCATED ON STACK: ; ----------------------------------------- (Quadword) ; | old module txtrfa | (R10) ; - - ; | | ; ----------------------------------------- ;-- .PSECT CODE NOWRT,EXE,PIC,LONG,SHR .ENTRY LBR_REPLACE,^M<> ; Write end-of-module record PUSHAL LBR_INDEX ;Library control index CALLS #1,G^LBR$PUT_END ;write end-of-module record BLBC R0,90$ ; See if module name already exists SUBL #8,SP ;allocate memory on stack MOVL SP,R10 ;save address of memory PUSHL R10 ;pointer to text module if found. (txtrfa) PUSHL INSTR ;Address of descriptor of module name to insert PUSHAL LBR_INDEX ;Library control index CALLS #3,G^LBR$LOOKUP_KEY ;Look for module in library BLBS R0,10$ ;branch if old-module found CMPL R0,#LBR$_KEYNOTFND ;check that it was 'key not found' error BNEQ 90$ CLRQ (R10) ;no old module in library 10$: PUSHAQ LBR_RFA ;new-module PUSHL R10 ;old-module PUSHL INSTR ;key-name PUSHAL LBR_INDEX ;Library control index CALLS #4,G^LBR$REPLACE_KEY ;Insert new module in library BLBC R0,90$ ;branch on error ; Delete old module data if there was an old module TSTL (R10) ;test for old module BNEQ 20$ ;branch if old module exists TSTL 4(R10) ;further test for old module BEQL 30$ ;branch if no old module to delete 20$: PUSHL R10 ;old-module txtrfa PUSHAL LBR_INDEX ;Library Control Index CALLS #2,G^LBR$DELETE_DATA ;Delete old module BLBS R0,30$ ;branch on success ;Error deleting old-module. Signal error and continue to close library. PUSHL R0 ;else signal error status and continue CALLS #1,EDX_SIGNAL ; 30$: CALLS #0,LBR_CLOSE ;close library BLBC R0,91$ PUSHL #1 CALLS #1,FMTOUTSTR RET ;normal exit here ;Signal status, close library, signal if error closing library, and return 0 90$: PUSHL R0 ;error status CALLS #1,EDX_SIGNAL ;signal error status CALLS #0,LBR_CLOSE ;close library BLBS R0,92$ 91$: PUSHL R0 ;Signal status and return 0 CALLS #1,EDX_SIGNAL 92$: PUSHL #0 CALLS #1,FMTOUTSTR RET ;------------------------------------------------------------------------------ .END