Trailing-Edge
-
PDP-10 Archives
-
tops20-v7-ft-dist2-clock
-
galaxy-sources/glxscn.mac
There are 26 other files named glxscn.mac in the archive. Click here to see a list.
TITLE GLXSCN -- Command Scanner Interface for GALAXY
SUBTTL Preliminaries
; COPYRIGHT (c) DIGITAL EQUIPMENT CORPORATION 1975, 1988.
; ALL RIGHTS RESERVED.
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED
; ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE
; INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER
; COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY
; OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY
; TRANSFERRED.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE
; AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT
; CORPORATION.
;
; DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS
; SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
SALL ;SUPPRESS MACRO EXPANSION
SEARCH GLXMAC ;OPEN SYMBOLS NEEDED
PROLOG(GLXSCN,SCN) ;PART OF LIBRARY, ETC...
SCNMAN==:0 ;Maintenance edit number
SCNDEV==:111 ;Development edit number
VERSIN (SCN) ;Generate edit number
;This module emulates the command scanning routines (COMND JSYS) found
; in the TOPS-20 operating system. (Somewhat)
Subttl Table of Contents
; Table of Contents for GLXSCN
;
; Section Page
;
;
; 1. Revision History . . . . . . . . . . . . . . . . . . . 3
; 2. Local Definitions . . . . . . . . . . . . . . . . . . 5
; 3. Module Storage . . . . . . . . . . . . . . . . . . . . 6
; 4. S%INIT - Initialize the GLXSCN Module . . . . . . . . 7
; 5. S%ERR - ERROR TYPEOUT ROUTINE . . . . . . . . . . . . 8
; 6. S%INTR - Interrupt Level Breakout Routine . . . . . . 9
; 7. S%CMND - Scan a command . . . . . . . . . . . . . . . 10
; 8. S%EXIT - Exit Address for Interrupt Breakout . . . . . 11
; 9. S%SIXB - Convert ASCII to SIXBIT . . . . . . . . . . . 12
; 10. S%NUMI - NUMBER INPUT ROUTINE . . . . . . . . . . . . 13
; 11. S%DATI Date input routine . . . . . . . . . . . . . . 14
; 12. RETYPE - Retype current line including the prompt . . 21
; 13. Atom Buffer Routines / INILCH - Init Atom Buffer . . . 28
; 14. CMCIN - Read One Character for Processing . . . . . . 29
; 15. HELPER - Do caller supplied and default HELP text . . 32
; 16. Command Function / .CMINI - Init the scanner and do ^H 35
; 17. Command Function / .CMSWI - Parse a SWITCH . . . . . . 36
; 18. Command Function / .CMKEY - Parse a KEYWORD . . . . . 37
; 19. Command Function / .CMTXT - Parse Arbitrary Text to Ac 41
; 20. Command Function / .CMCFM - Command Confirmation (end- 42
; 21. Command Function / .CMNUM - Parse an INTEGER in any ba 44
; 22. Command Function / .CMDEV - Parse a DEVICE specificati 46
; 23. Command Function / .CMQST - Parse a QUOTED STRING . . 47
; 24. Command Function / .CMNOD - Parse a NODE Specification 48
; 25. PATHIN Routine to Parse TOPS-10 Path Specification . . 51
; 26. PATH SUPPORT ROUTINES . . . . . . . . . . . . . . . . 53
; 27. CMDOUT - CHARACTER OUTPUT FOR TERMINALS AND FILES . . 58
; 28. S%SCMP - String Comparison Routine . . . . . . . . . . 59
; 29. S%TBLK - Table lookup routine . . . . . . . . . . . . 61
; 30. S%TBAD - Table Add Routine . . . . . . . . . . . . . . 64
; 31. S%TBDL - Table Delete Routine . . . . . . . . . . . . 65
; 32. CNTDT,CNVDT DATE/TIME CONVERSION ROUTINES . . . . . . 66
; 33. XDATIM DATE/TIME PARSING ROUTINES FOR TOPS10 . . . . . 67
; 34. DATNCI ROUTINE TO RETURN 3 WORD TIME BLOCK . . . . . . 68
; 35. DATIM MACROS AND STORAGE DECLARATION . . . . . . . . . 69
; 36. SUBROUTINES FOR COMMAND INPUT - GET DATE/TIME . . . . 70
; 37. SUBROUTINES FOR COMMAND INPUT - GET NEXT CHARACTER . . 84
; 38. .CNTDT - GENERALIZED DATE/TIME SUBROUTINE . . . . . . 85
; 39. .LKNAM - ROUTINES TO GET AND PUT IN A COUNTED LIST . . 89
SUBTTL Revision History
COMMENT \
74 4.2.1456
Do some majic to fix ^U'ed command that receives IPCF interrupt.
Save some ACs and restore same when interrupting. Also set a couple
if indeed in a ^U state. T10 only.
***** Release 4.2 -- begin maintenance edits *****
***** Release 5.0 -- begin development edits *****
100 5.1002 28-Dec-82
Move to new development area. Clean up edit organization. Update TOC.
***** Release 5.0 -- begin maintenance edits *****
105 Increment maintenance edit level for version 5 of GALAXY.
***** Release 6.0 -- begin development edits *****
110 6.1037 26-Oct-87
Move sources from G5: to G6:
111 6.1225 8-Mar-88
Update copyright notice.
\ ;End of Revision History
; Entry Points found in this module
ENTRY S%INIT ;INIT THE COMMAND SCANNER MODULE
ENTRY S%CMND ;SCAN A COMMAND
ENTRY S%SCMP ;COMPARE TWO STRINGS
ENTRY S%TBLK ;LOOK UP A STRING IN A TABLE
ENTRY S%ERR ;TYPE OUT SCANNER'S LAST ERROR
ENTRY S%INTR ;INTERRUPT BREAKOUT
ENTRY S%EXIT ;INTERRUPT DEBRK ADDRESS FOR COMND
ENTRY S%TBAD ;ADD ENTRY TO COMMAND TABLES
ENTRY S%TBDL ;DELETE ENTRY FROM COMMAND TABLES
ENTRY S%SIXB ;CONVERT ASCII STRING TO SIXBIT VALUE
ENTRY S%NUMI ;CONVERT ASCII STRING TO NUMBER
ENTRY S%DATI ;CONVERT ASCIZ STRING TO DATE
SUBTTL Local Definitions
; Special Accumulator definitions
P5==P4+1 ;S%CMND NEEDS LOTS OF ACS
F==14 ;FLAG AC
Q1==15 ;
Q2==16 ;DON'T DEFINE Q3 OR Q4
; Bad parse return macro
DEFINE NOPARS(CODE) <
PJRST [MOVEI T1,ER'CODE'$
PJRST XCOMNE]
> ;END OF NOPARS DEFINITION
; Special bit testing macros
DEFINE JXN(AC,FLD,ADDR)<
TXNN AC,FLD
XLIST
SKIPA
JRST ADDR
LIST
SALL
> ;END OF JXN DEFINITION
DEFINE JXE(AC,FLD,ADDR)<
TXNE AC,FLD
XLIST
SKIPA
JRST ADDR
LIST
SALL
> ;END OF JXE DEFINITION
DEFINE RETSKP<JRST [AOS 0(P)
POPJ P,] >
; Bit table - 36. Words long with word N containing 1B<N>
XX==0
BITS: XLIST
REPEAT ^D36,<EXP 1B<XX>
XX==XX+1>
LIST
SUBTTL Module Storage
GLOB <.LGERR,.LGEPC> ;GLOBAL ERROR LOCATIONS
$DATA SCNBEG,0 ;START OF ZEROABLE $DATA SPACE
$DATA ATBPTR ;ATOM BUFFER POINTER (END)
$DATA ATBSIZ ;ATOM BUFFER SIZE
$DATA STKFEN ;FENCE FOR STACK RESTORATION
$DATA FNARG ;FUNCTION ARGUMENT
$DATA CMCCM,2 ;SAVED CC CODES
$DATA CMRBRK ;POINTER TO BREAK SET TABLE
$DATA CMCSF ;SAVED FLAGS
$DATA CMCSAC,7 ;SAVED ACS DURING S%TXTI FROM S%CMND
$DATA CMCSC ;
$DATA CMCBLF ;
$DATA TBA ;TABLE ARGUMENTS
$DATA STRG ;TEMP STRING POINTER
$DATA REMSTR ;"REMEMBER"ED STRING
$DATA XXXPTR ;RE-USABLE STRING POINTER STORAGE
$DATA CRBLK,CR.SIZ ;RETURNED BLOCK OF ANSWERS
$DATA TABDON ;END OF TAB FOR "?"
$DATA TABSIZ ;SIZE OF TAB LARGER THAN LARGEST KEYWORD
$DATA LSTERR ;ERROR CODE OF FIRST PARSE FAILURE
$DATA LSTEPC ;PC OF FIRST PARSE FAILURE
$DATA BIGSIZ ;LENGTH OF LONGEST KEYWORD
$DATA PWIDTH ;TERMINAL'S WIDTH
$DATA CURPOS ;LINE POSITION OF CURSOR
$DATA Q3SAVE ;NO Q3 EXISTS
$DATA IFOB ;INDIRECT FILESPEC FOB
$DATA IIFN ;IFN OF INDIRECT FILE
$DATA TI,.RDSIZ ;S%TXTI ARGUMENT BLOCK
$GDATA SAVBUF,ERRBSZ ;BUFFER FOR ERROR MESSAGES
;S%ERR AND SCRATCH
TOPS10 <
$DATA CMDACS,20 ;AC SAVE AREA FOR COMMAND
$DATA PTHBLK,.PTMAX ;STORAGE FOR JOB PATH
$DATA INCMND ;FLAG FOR IN COMMAND STATE
$DATA TBADDR ;ADDRESS OF COMMAND TABLE
$DATA ENTADR ;ADDRESS OF ENTRY FOR TABLE
$DATA SPCBRK ;SPECIAL BREAK MASK
$DATA JFNWRD ;WORD CONTAINING THE JFNS
$DATA ACFLG ;FLAG TO VALIDATE INTERRUPT SAVED ACs
$DATA A07T16,10 ;BLOCK TO SAVE ACS FROM 7 TO 16
; DURING K%TXTI IN CASE OF INTERRUPT
>;END TOPS10 CONDITIONAL
$DATA INTRPT ;FLAG FOR S%INTR
TOPS20 <
$DATA BLKSAV ;COMMAND BLOCK ADDRESS
$DATA BUFCNT ;SIZE OF COMMAND BUFFER
>;END TOPS20 CONDITIONAL
$DATA SCNEND,0 ;END OF ZEROABLE $DATA SPACE
SUBTTL S%INIT - Initialize the GLXSCN Module
TOPS10 <
S%INIT: MOVE S1,[SCNBEG,,SCNBEG+1] ;BLT PTR TO ZEROABLE $DATA SPACE
SETZM SCNBEG ;ZERO OUT FIRST LOC
BLT S1,SCNEND-1 ;AND ZOOM OUT THE REST
MOVSI S2,'TTY' ;LOAD TTY NAME
IONDX. S2, ;GET THE I/O INDEX
JFCL ;IGNORE THE ERROR
MOVX S1,.TOWID ;GET TERMINAL WIDTH FUNCTION
MOVE T1,[2,,S1] ;ARG POINTER
TRMOP. T1, ;GET THE NUMBER
MOVEI T1,^D72 ;USE A DEFAULT
MOVEM T1,PWIDTH ;AND SAVE IT
SETZM ACFLG ;INITIALLY NO SAVED INTERRUPT ACS
$RETT ;AND RETURN
> ;END TOPS10 CONDITIONAL
TOPS20 <
S%INIT: $RETT ;RETURN
> ;END TOPS20 CONDITIONAL
SUBTTL S%ERR - ERROR TYPEOUT ROUTINE
SUBTTL S%ERR - ERROR MESSAGES FROM COMND
;CALL PUSHJ P,S%ERR
;
;RETURN TRUE: S1/ ADDRESS OF MESSAGE--ASCIZ
;
;RETURN FALSE: NO MESSAGE
TOPS10 <
S%ERR: HRRZ S1,LSTERR ;GET THE LAST ERROR
JUMPE S1,.RETF ;NO MESSAGE RETURN FALSE
$TEXT (<-1,,SAVBUF>,<^E/S1/^0>) ;OUTPUT THE MESSAGE
MOVEI S1,SAVBUF ;ADDRESS OF MESSAGE
$RETT ;RETURN TRUE
> ;END TOPS10 CONDITIONAL
TOPS20 <
S%ERR: HRROI S1,SAVBUF ;POINTER TO BUFFER
MOVE S2,[.FHSLF,,-1] ;OUR LAST ERROR
HRLZI T1,-ERRBSZ*5 ;MAXIMUM NUMBER OF CHARACTERS
ERSTR ;TYPE OUT THE ERROR STRING
$RETF ;UNDEFINED ERROR NUMBER
$RETF ;BAD DESTINATION DESIGNATOR
MOVEI S1,SAVBUF ;POINT TO THE MESSAGE
$RETT ;RETURN TRUE
> ;END TOPS20 CONDITIONAL
SUBTTL S%INTR - Interrupt Level Breakout Routine
;S%INTR should be called at interrupt level to request that command
; breakout as soon as possible and to mark that interrupt occurred.
; CALL: S1/ PC Address at Interrupt
;
; RETURN TRUE: In COMND S1/ SPACE LEFT IN INPUT BUFFER
;
; RETURN FALSE: Not in COMND
;
S%INTR: SETOM INTRPT ;SET THE FLAG
TOPS10 <
SKIPN INCMND ;ARE WE IN COMND
$RETF ;NO..RETURN FALSE
MOVE S1,RD##+.RDDBC ;COUNT OF SPACE LEFT
$RETT ;RETURN TRUE
>;END TOPS10 CONDITIONAL
TOPS20 <
TXNE S1,1B5 ;IN EXEC MODE?
$RETF ;NO..USER MODE..RETURN FALSE
HRRZS S1 ;GET ONLY RIGHT HALF
CAIL S1,CMND.2 ;IS PC IN COMND JSYS
CAIL S1,CMND.3 ;THEN BETWEEN TWO LABELS
$RETF ;NO..RETURN FALSE
MOVE S1,BLKSAV ;GET ADDRESS OF COMMAND BLOCK
MOVE S1,.CMCNT(S1) ;GET BUFFER SIZE IN S1
$RETT ;YES..COMND..RETURN TRUE
>;END TOPS20 CONDITIONAL
SUBTTL S%CMND - Scan a command
;LOCAL FLAGS (RH OF F)
CMQUES==1B18 ;? TYPED
CMSWF==1B19 ;BEG OF SWITCH SEEN
CMUSRF==1B20 ;USER NAME REQUIRED
CMDEFF==1B21 ;DEFAULT FIELD GIVEN
CMCFF==1B22 ;^F RECOGNIZED FIELD
CMQUE2==1B23 ;IN SECOND OR SUBSEQUENT HELP POSSIBILITY
CMBOL==1B24 ;FIELD IS AT BEG OF LINE
CMTF1==1B25 ;INTERNAL TEMP FLAG
CMINDF==1B26 ;DOING GTJFN ON INDIRECT FILE
;FLAGS IN FUNCTION DISPATCH TABLE
CMNOD==1B0 ;NO DEFAULT POSSIBLE
NOIBCH=="(" ;NOISE WORD BEG CHARACTER
NOIECH==")" ;NOISE WORD END CHARACTER
CMSWCH=="/" ;SWITCH CHARACTER
CMSWTM==":" ;SWITCH TERMINATOR
CMHLPC=="?" ;HELP CHARACTER
CMCOM1=="!" ;COMMENT CHARACTER
CMCOM2==";" ;FULL LINE COMMENT CHARACTER
CMDEFC=="#" ;DEFAULT FIELD CHARACTER
CMFREC=="F"-100 ;FIELD RECOGNITION CHARACTER
CMINDC=="@" ;INDIRECT FILE CHARACTER
CMRDOC=="H"-100 ;REDO COMMAND CHARACTER
CMQTCH=="""" ;CHARACTER FOR QUOTED STRINGS
CMCONC=="-" ;LINE CONTINUATION CHARACTER
SUBTTL S%EXIT - Exit Address for Interrupt Breakout
;THE ADDRESS OF S%EXIT IS PLACED IN THE INTERRUPT PC TO FORCE RETURN
;TO THAT ADDRESS AT INTERRUPT IN COMND THAT WE WANT TO BREAKOUT OF.
;THE NECESSARY CLEANUP WILL BE DONE SO S%CMND CAN RETURN.
TOPS20 <
S%EXIT: PJRST CMND.3 ;FIX UP RETURN
>;END TOPS20 CONDITIONAL
TOPS10 <
S%EXIT:
;Restore some AC's from before K%TXTI if necessary
SKIPN ACFLG ;Want to restore some AC's?
JRST EXIT.1 ;No, skip this part
HRLZI 0,A07T16 ;Source address
HRRI 0,7 ;Destination address
BLT 0,16 ;Restore some AC's
SETZM ACFLG ;Restore only once
; Now if we are comming from a ^U, we need to fix some things up
EXIT.1: MOVE 0,.CMCNT(P2) ;Get origional count of buffer
CAME 0,RD##+.RDDBC ;Save as what is left?
PJRST XCOMXI ;No, must not be ^U
MOVE P3,0 ;Set the count to the origional
MOVE P4,.CMBFP(P2) ;Set to beginning of user buffer
SETZ P5, ;No characters to be parsed
TXZ F,CM%ESC ;No way we can have ^U terminated
; with an escape
PJRST XCOMXI ;SETUP PROPER RETURN
>;END TOPS10 CONDITIONAL
SUBTTL S%SIXB - Convert ASCII to SIXBIT
;
;S1/ ASCII BYTE POINTER Returned updated
;S2/ SIXBIT value
S%SIXB: TLCE S1,-1 ;Left half of ptr = 0?
TLCN S1,-1 ;... or -1 ?
JRST [HRLI S1,(POINT 7,) ;Yes, Make up pointer for caller
JRST S%SIX1] ;Re enter flow
HRRI S1,@S1 ;Compute effective addr
TLZ S1,(@(17)) ;Remove indirection and index
S%SIX1: PUSHJ P,CNVSIX ;Do the work
$RETT ;Always return true
SUBTTL CNVSIX - CONVERT ATOM BUFFER TO SIXBIT
;Internal entry point
;Same calling args
;Returns false if more than 6 chars are passed
CNVSIX: PUSHJ P,.SAVET ;Preserve the caller's T's
MOVEI T2,6 ;GET MAX NUMBER OF CHARACTERS IN NAME
MOVE T4,[POINT 6,S2] ; BP TO NODE STORAGE
SETZM S2 ;START FRESH
CNVS.1: ILDB T3,S1 ;GET NEXT CHARACTER FROM ATOM BUFFER
CAIL T3,"A"+40 ;LESS THAN LC A
CAILE T3,"Z"+40 ;OR GREATER THAN LC Z
SKIPA ;YES, NOT A LC CHARACTER
SUBI T3,40 ;NO, ITS LC, MAKE IT UC
CAIL T3,"0" ;IS THE CHARACTER
CAILE T3,"Z" ;NUMERIC OR UPPER CASE?
$RETT ;RETURN TRUE..END OF FIELD
CAILE T3,"9" ;...
CAIL T3,"A" ;...
CAIA ;GOOD CHARACTER, JUST SAVE IT
$RETT ;RETURN TRUE..END OF FIELD
SUBI T3,"A"-'A' ;SIXBITIZE
IDPB T3,T4 ;FILL OUT SIXBIT NODE NAME
SOJGE T2,CNVS.1 ;HAVE WE SEEN ENOUGH CHARACTERS?
$RETF ;ERROR..RETURN FALSE
SUBTTL S%NUMI - NUMBER INPUT ROUTINE
;THIS ROUTINE WILL PARSE A NUMBER FROM A STRING AND RETURN THE
;VALUE
;
;CALL S1/ POINTER TO THE STRING
; S2/ RADIX
;
;RETURN TRUE:
; S1/ UPDATED POINTER
; S2/ NUMBER
S%NUMI: CAIL S2,^D2 ;CHECK FOR PROPER RADIX
CAILE S2,^D10
$RETE (RAD) ;INVALID RADIX
PUSHJ P,NUMIN
$RETIT ;RETURN IF TRUE
$RETE (NUM) ;BAD NUMBER
NUMIN: PUSHJ P,.SAVE3 ;GET 2 SCRATCH ACS
SETZ P2, ;CLEAR SIGN MODIFIER
NUMI.1: ILDB P1,S1 ;GET FIRST CHARACTER
CAIN P1," " ;A BLANK?
JRST NUMI.1 ;YES, IGNORE IT
CAIN P1,"-" ;IS IT MINUS SIGN?
JRST [JUMPN P2,.RETF ;ONLY ALLOW ONE SIGN
MOVX P2,-1 ;SET NEGITIVE
JRST NUMI.1] ;GET NEXT CHARACTER
CAIN P1,"+" ;IS IT PLUS SIGN?
JRST [JUMPN P2,.RETF ;ONLY ALLOW ONE SIGN
MOVX P2,+1 ;SET POSITIVE
JRST NUMI.1] ;GET NEXT CHARACTER
CAIG P1,"0"-1(S2) ;TOO BIG
CAIGE P1,"0" ;OR TOO SMALL?
$RETF ;YES, TAKE FAILURE RETURN
SETZ P3,0 ;CLEAR THE RESULT
NUMI.2: IMULI P3,0(S2) ;SHIFT OVER 1 DIGIT
ADDI P3,-"0"(P1) ;AND ADD IN THIS ONE
ILDB P1,S1 ;GET NEXT CHAR
CAIG P1,"0"-1(S2) ;IN RANGE?
CAIGE P1,"0"
JRST NUMI.3 ;FINISH OFF AND RETURN
JRST NUMI.2 ;YES, REPEAT
NUMI.3: SKIPGE P2 ;SHOULD BE NEGATIVE?
MOVNS P3 ;MAKE IT NEGATIVE
MOVE S2,P3 ;GET THE VALUE
$RETT ;RETURN TRUE
SUBTTL S%DATI Date input routine
;THIS ROUTINE WILL PARSE DATE/TIME STRING
;AND RETURN A UDT
; CALL S1/ POINTER TO ASCIZ DATE/TIME STRING
; S2/ FLAGS (CM%IDA!CM%ITM!CM%NCI+Address)
; RETURN S1/ UPDATED POINTER
; S2/ UDT
;IF CM%NCI with an address (not in ACs) the time will also
;be returned in a three word block at address
S%DATI: PUSHJ P,.SAVET ;PRESERVE TEMPORARIES
PJRST XDATIM ;PARSE THE FIELXD ANXD RETURN
;The S%CMND routine provides a command scanner interface similar to the
; TOPS-20 COMND JSYS.
;CALL IS: S1/ Pointer to Command State Block
; S2/ Pointer to list of Function Descriptor Blocks
; See GLXMAC or MONSYM for a description of these
;TRUE RETURN: S1/ Length of Command Reply block
; S2/ Address of the Command Reply block
TOPS20 <
S%CMND: MOVEM S1,BLKSAV ;SAVE THE COMMAND BLOCK ADDRESS
MOVE S1,.CMCNT(S1) ;GET SIZE OF THE BUFFER
MOVEM S1,BUFCNT ;SAVE BUFFER COUNT
MOVE S1,BLKSAV ;RESTORE S1
PUSH P,.CMFLG(S1) ;SAVE THE REPARSE ADDRESS
PUSH P,S1 ;SAVE ADDRESS OF CSB
HLLZS .CMFLG(S1) ;AND ZERO OUT REPARSE ADDRESS
PUSHJ P,CMND.2 ;DO THE COMMAND JSYS
POP P,S2 ;GET CSB ADDRESS
POP P,S1 ;GET THE REPARSE ADDRESS
HRRM S1,.CMFLG(S2) ;RESET THE REPARSE ADR
TRNN S1,-1 ;IS THERE ONE?
JRST CMND.1 ;NO, RETURN NORMALLY
MOVX S2,CM%RPT ;YES, GET REPARSE BIT
TDNE S2,CRBLK+CR.FLG ;WAS IT SET???
HRRM S1,0(P) ;YES, STORE REPARSE ADDRESS FOR RETURN
CMND.1: MOVEI S1,CR.SIZ ;LOAD SIZE OF COMMAND RESPONSE BLOCK
MOVEI S2,CRBLK ;LOAD ADDRESS OF COMMAND RESP. BLK.
POPJ P, ;AND PROPAGATE T/F RETURN FROM CMND.2
CMND.2: PUSHJ P,.SAVET ;SAVE T1-T4
SETZ T3, ;ASSUME TRUE RETURN
SKIPN INTRPT ;DID INTERRUPT OCCUR SKIP COMND
COMND ;DO THE COMMAND JSYS
ERJMP [SETO T3, ;SET FALSE RETURN
JRST CMND.3] ;AND CONTINUE ON
CMND.3: SETZ T2, ;SET FLAG
EXCH T2,INTRPT ;GET CURRENT FLAG AND RESET
MOVE T4,BLKSAV ;ADDRESS OF COMMAND BLOCK
MOVE T4,.CMCNT(T4) ;ROOM LEFT IN BUFFER
CAMGE T4,BUFCNT ;DID WE HAVE ANY DATA
JRST CMND.4 ;YES..IGNORE INTERRUPT FLAG
SKIPE T2 ;INTERRUPT BEFORE COMMAND
TXO S1,CM%INT ;YES..SET INTERRUPT FLAG
CMND.4: MOVEM S1,CRBLK+CR.FLG ;SAVE FLAGS
MOVEM S2,CRBLK+CR.RES ;SAVE DATA FIELD
MOVEM T1,CRBLK+CR.PDB ;SAVE PDB ADDRESS
; TXNE S1,CM%NOP ;NO PARSE?
; SETO T3, ;YES, RETURN FALSE
LOAD S1,.CMFNP(T1),CM%FNC ;GET FUNCTION DONE
MOVEM S1,CRBLK+CR.COD ;SAVE IT
JUMPL T3,.RETF ;RETURN FALSE IF COMND FAILED
$RETT ;ELSE, RETURN TRUE
> ;END TOPS20 CONDITIONAL
TOPS10 <
;!!!!!NOTE WELL - THIS CONDITIONAL RUNS TO THE END OF COMND ROUTINE
S%CMND: SETZM LSTERR ;CLEAR LAST ERROR INDICATOR
MOVEM 0,CMDACS ;SAVE THE COMMAND ACS
MOVE 0,[XWD 1,CMDACS+1] ;SET UP BLT POINTER
BLT 0,CMDACS+17 ;SAVE THE ACS
MOVEI 0,@0(P) ;GET CALLING PC ADDRESS
MOVEM 0,LSTEPC ;SAVE IN CASE OF NOPARSE
MOVE 0,CMDACS ;RESTORE 0
PUSHJ P,XCOMND ;DO THE WORK
HRRZ T4,.CMFLG(P2) ;GET REPARSE ADDRESS IF ANY
JUMPE T4,COMN1 ;NONE..JUST RETURN
TXNN F,CM%RPT ;REPARSE NEEDED..
JRST COMN1 ;NO..JUST RESTORE AND RETURN
HRRZ T3,CMDACS+17 ;GET STACK LOCATION
HRRM T4,@T3 ;YES..RETURN TO REPARSE
COMN1: SETZM INCMND ;CLEAR IN COMMAND STATE
MOVSI 17,CMDACS+T1 ;SETUP TO RESTORE ACS
HRRI 17,T1 ;RESTORE FROM T1
BLT 17,17 ;RESTORE THE ACS
POPJ P,0 ;NO RETURN
XCOMND: MOVEM S1,P2 ;SAVE BLOCK PTR
MOVEM S2,P1 ;SAVE FN BLOCK PTR
HRL P1,P1 ;SAVE COPY OF ORIGINAL
MOVEM P,STKFEN ;SAVE CURRENT STACK AS FENCE
MOVE T1,.CMIOJ(P2) ;GET THE JFN WORD
MOVEM T1,JFNWRD ;SAVE THE JFN WORD
MOVEI T1,[.CMRTY ;LIST OF BYTE POINTERS TO CHECK
.CMBFP
.CMPTR
.CMABP
0] ;MARK OF END OF LIST
PUSHJ P,CHKABP ;CHECK ALL BYTE PTRS
MOVE P3,.CMCNT(P2) ;SETUP ACTIVE VARIABLES
MOVE P4,.CMPTR(P2)
MOVE P5,.CMINC(P2)
HLLZ F,.CMFLG(P2) ;GET 'GIVEN' FLAGS
TXZ F,CM%PFE
TXZE F,CM%ESC ;PREVIOUS FIELD HAD ESC?
TXO F,CM%PFE ;YES
PUSHJ P,K%RCOC ;GET COC MODES
DMOVEM S1,CMCCM ;SAVE THEM
TXZ S1,3B<CMFREC*2+1> ;NO ECHO ^F
TXZ S1,3B<CMRDOC*2+1> ;OR ^H
TXO S1,3B<.CHLFD*2+1> ;PROPER HANDLING OF NL
TXZ S2,3B<.CHESC*2+1-^D36> ;SET ESC TO NO ECHO
PUSHJ P,K%WCOC ;AND WRITE THEM BACK
SETOM INCMND ;MARK THAT IN COMND
SKIPE INTRPT ;DID WE HAVE AN INTERRUPT
PJRST S%EXIT ;YES..RETURN NOW
; ..
; ..
XCOMN0: MOVE P,STKFEN ;NORMALIZE STACK IN CASE ABORTED ROUTINES
TXZ F,CM%ESC+CM%NOP+CM%EOC+CM%RPT+CM%SWT+CMBOL+CMCFF+CMDEFF+CMINDF ;INIT FLAGS
CAMN P4,.CMBFP(P2) ;AT BEG OF LINE?
TXO F,CMBOL ;YES
XCOM1: LOAD T1,.CMFNP(P1),CM%FFL ;GET FUNCTION FLAGS
STORE T1,F,CM%FFL ;KEEP WITH OTHER FLAGS
HLRZ Q1,P1 ;GET CM%DPP FLAG FROM FIRST BLOCK ONLY
XOR F,.CMFNP(Q1)
TXZ F,CM%DPP
XOR F,.CMFNP(Q1)
TXNN F,CM%BRK ;IS THERE A BREAK MASK SETUP
JRST XCOM2 ;NO.. CONTINUE ON
MOVE T1,.CMBRK(P1) ;GET ADDRESS OF BREAK SET
MOVEM T1,SPCBRK ;SAVE AS SPECIAL BREAK
XCOM2: MOVE T1,.CMDAT(P1) ;GET FUNCTION DATA IF ANY
MOVEM T1,FNARG ;KEEP LOCALLY
LOAD T1,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
CAIL T1,0 ;VALIDATE FN CODE
CAIL T1,MAXCFN
$STOP(BFC,Bad function code)
MOVE T1,CFNTAB(T1) ;GET TABLE ENTRY FOR IT
JXN T1,CMNOD,XCOM4 ;DISPATCH NOW IF NO DEFAULT POSSIBLE
PUSHJ P,INILCH ;SKIP SPACES AND INIT ATOM BUFFER
PUSHJ P,CMCIN ;GET INITIAL INPUT
CAIN T1,CMCONC ;POSSIBLE LINE CONTINUATION?
JRST [PUSHJ P,CMCIN ;YES, SEE IF NL FOLLOWS
CAIE T1,.CHLFD
PUSHJ P,CMRSET ;NO, RESET FIELD
PUSHJ P,CMCIN ;RE-READ FIRST CHAR
JRST .+1] ;CONTINUE
CAIN T1,CMCOM2 ;COMMENT?
JRST CMCMT2 ;YES
CAIN T1,CMCOM1
JRST CMCMT1 ;YES
CAIN T1,CMINDC ;INDIRECT INDICATOR?
JRST [TXNN F,CM%XIF ;YES, INDIRECT FILES ALLOWED?
JRST CMIND ;YES, DO IT
JRST .+1] ;NO, KEEP CHARACTER AS ORDINARY INPUT
CAIN T1,.CHLFD ;EOL BEGINS FIELD?
JRST [PUSHJ P,CMDIP ;YES, PUT IT BACK
LOAD T1,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
CAIN T1,.CMCFM ;CONFIRM?
JRST XCOM4 ;YES, DO IT
TXNE F,CM%DPP ;HAVE DEFAULT?
JRST XCOM6 ;YES, USE IT
TXNN F,CMBOL ;AT BGN OF BFR?
JRST XCOM4 ;NO, TRY NULL FIELD
PUSHJ P,CMRSET
SETZ P5,0 ;YES, EMPTY LINE. IGNORE
PUSHJ P,RETYPE ;REDO PROMPT
JRST XCOMN0] ;TRY AGAIN
CAIE T1,.CHESC ;ESC AT BEG OF FIELD?
CAIN T1,CMFREC
JRST XCOM5 ;^F AT BEG OF FIELD
; CAIN T1,CMDEFC ;OR DEFAULT REQUEST?
; JRST XCOM5 ;YES
XCOM3: PUSHJ P,CMDIP ;PUT CHAR BACK
XCOM4: LOAD T1,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
JRST @CFNTAB(T1) ;DO IT
;ESC OR ^F AT BEG OF FIELD
XCOM5: TXNN F,CM%DPP ;YES, HAVE DEFAULT STRING?
JRST XCOM3 ;NO
PUSHJ P,CMDCH ;FLUSH RECOG CHAR
XCOM6: HLRZ Q1,P1 ;GET PTR TO FIRST FLD BLOCK
MOVE S1,.CMDEF(Q1) ;GET DEFAULT STRING PTR
PUSHJ P,CHKBP ;CHECK POINTER
MOVEM S1,Q1
TXO F,CMDEFF ;NOTE FIELD ALREADY IN ATOM BFR
XCOM7: ILDB T1,Q1
JUMPE T1,[PUSHJ P,CHKLCH ;CHECK FOR NULL DEFAULT STRING
CAIG T1,0
$STOP(BDS,Bad Default String) ;NULL STRING ILLEGAL
PUSHJ P,TIELCH ;END OF STRING, TIE OFF ATOM BUFFER
TXNE F,CMCFF ;^F RECOG?
JRST XCOMRF ;YES, GO GET MORE INPUT
JXE F,CM%ESC,XCOM4 ;GO DIRECT TO FUNCTION IF NO RECOG
MOVEI T1,.CHESC
PUSHJ P,CMDIBQ ;YES, APPEND ESC TO BUFFER
PUSHJ P,CMRSET ;RESET LINE VARIABLES
JRST XCOMN0] ;TREAT AS ORDINARY INPUT
PUSHJ P,STOLCH ;STOR CHAR IN ATOM BUFFER
TXNE F,CM%ESC ;RECOGNIZING?
PUSHJ P,CMDIB ;YES, CHAR TO MAIN BUFFER ALSO
JRST XCOM7
;COMMENT
CMCMT2: SETO T1, ;SAY NO TERMINATOR OTHER THAN EOL
CMCMT1: MOVEM T1,Q2 ;REMEMBER MATCHING TERMINATOR
CMCOM: PUSHJ P,CMCIN ;GET NEXT CHAR
CAIN T1,CMCONC ;POSSIBLE LINE CONTINUATION?
JRST [PUSHJ P,CMCIN ;YES, CHECK FOR NL FOLLOWING
CAIN T1,.CHLFD
JRST CMCOM ;YES, STAY IN COMMENT
JRST .+1] ;NO, EXAMINE CHARACTER
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIN T1,.CHLFD ;END OF LINE?
JRST [PUSHJ P,CMDIP ;YES, PUT IT BACK
JRST XCOM1] ;DO WHATEVER
CAMN T1,Q2 ;MATCHING TERMINATOR?
JRST XCOM1 ;YES, END OF COMMENT
JRST CMCOM ;NO, KEEP LOOKING
;TABLE OF COMND FUNCTIONS
CFNTAB: PHASE 0
.CMKEY::!XCMKEY ;KEYWORD
.CMNUM::!XCMNUM ;INTEGER
.CMNOI::!XCMNOI+CMNOD ;NOISE WORD
.CMSWI::!XCMSWI ;SWITCH
.CMIFI::!XCMIFI ;INPUT FILE
.CMOFI::!XCMOFI ;OUTPUT FILE
.CMFIL::!XCMFIL ;GENERAL FILESPEC
.CMFLD::!XCMFLD ;ARBITRARY FIELD
.CMCFM::!XCMCFM ;CONFIRM
.CMDIR::!XCMDIR ;DIRECTORY NAME
.CMUSR::!XCMUSR ;USER NAME
.CMCMA::!XCMCMA ;COMMA
.CMINI::!XCMINI+CMNOD ;INITIALIZE COMMAND
.CMFLT::!XCMFLT ;FLOATING POINT NUMBER
.CMDEV::!XCMDEV ;DEVICE NAME
.CMTXT::!XCMTXT ;TEXT
.CMTAD::!XCMTAD ;TIME AND DATE
.CMQST::!XCMQST ;QUOTED STRING
.CMUQS::!XCMUQS+CMNOD ;UNQUOTED STRING
.CMTOK::!XCMTOK ;TOKEN
.CMNUX::!XCMNUX ;NUMBER DELIMITED BY NON-DIGIT
.CMACT::!XCMACT ;ACCOUNT
.CMNOD::!XCMNOD ;NODE NAME
DEPHASE
MAXCFN==.-CFNTAB
;HERE TO GET MORE INPUT AND RETRY FIELD
XCOMRF: PUSHJ P,CMRSET ;RESET VARIABLES TO BEGINNING OF FIELD
PUSHJ P,CMCIN1 ;GET MORE INPUT
HLR P1,P1 ;RESET ALTERNATIVE LIST
JRST XCOMN0
;RESET VARIABLES TO BEGINNING OF CURRENT FIELD
CMRSET: SUB P5,P3 ;RESET VARIABLES TO BGN OF FIELD
ADD P5,.CMCNT(P2) ;KEEP ALL CURRENT INPUT
MOVE P3,.CMCNT(P2)
MOVE P4,.CMPTR(P2)
POPJ P,0
;STANDARD EXITS
;RETURN AND REPEAT PARSE BECAUSE USER DELETED BACK INTO ALREADY
;PARSED TEXT
XCOMRP: TXNE F,CM%INT ;INTERRUPT EXIT
JRST XCOMXI ;SETUP RETURN
TXO F,CM%RPT ;REQUEST REPEAT
MOVE T1,P4 ;COMPUTE NUMBER CHARS IN BUFFER
MOVE T2,.CMBFP(P2)
MOVEM T2,P4 ;RESET PTR TO TOP OF BUFFER
PUSHJ P,SUBBP ;COMPUTE PTR-TOP
MOVEM T1,P5 ;SET AS NUMBER CHARS FOLLOWING PTR
ADDM T1,P3 ;RESET COUNT TO TOP OF BUFFER
JRST XCOMX1 ;OTHERWISE UPDATE VARIABLES AND EXIT
;GOOD RETURN
XCOMXR: TXNE F,CM%ESC ;RECOG CHARACTER TERMINATED?
PUSHJ P,CMDCH ;YES, FLUSH IT
XCOMXI: TXZ F,CM%RPT ;CLEAR THE REPARSE FLAG
TXZN F,CM%ESC ;FIELD TERMINATED WITH RECOG?
JRST XCOMX1 ;NO
TXNE F,CMCFF ;^F RECOG?
JRST XCOMRF ;YES, GET MORE INPUT BEFORE RETURNING
TXO F,CM%ESC ;SET FLAG
MOVEI T1," " ;TERMINATE TYPESCRIPT WITH SPACE
PUSHJ P,CMDIB
XCOMX1: SETZ S1, ;CLEAR S1
EXCH S1,INTRPT ;GET THE CURRENT FLAG AND RESET
SKIPE S1 ;DID WE HAVE AN INTERRUPT
TXO F,CM%INT ;YES..SET RETURN FLAG
CAMGE P3,.CMCNT(P2) ;DID WE HAVE ANY PROCESSING
TXZ F,CM%INT ;YES..CLEAR POSSIBLE INTERRUPT FLAG
MOVEM P3,.CMCNT(P2) ;UPDATE VARIABLES
MOVEM P4,.CMPTR(P2)
MOVEM P5,.CMINC(P2)
XCOMX2: MOVE P,STKFEN ;RESET STACK
DMOVE S1,CMCCM ;GET SAVED CC MODES
PUSHJ P,K%WCOC ;RESTORE THEM
MOVEM P1,CRBLK+CR.PDB ;RETURN PTR TO FUNCTION BLOCK USED
TXZ F,CM%FFL ;FLUSH FUNCTION FLAGS
HLLM F,.CMFLG(P2) ;RETURN FLAGS
MOVEM P2,CRBLK+CR.FLG ;STORE BLK ADDRESS
HLLM F,CRBLK+CR.FLG ;AND THE FLAGS
HRRZ T1,CRBLK+CR.PDB ;GET THE CURRENT PDB
LOAD S1,.CMFNP(T1),CM%FNC ;GET FUNCTION CODE
MOVEM S1,CRBLK+CR.COD ;SAVE THE CODE
MOVEI S1,CR.SIZ ;LOAD SIZE OF RETURNED BLOCK
MOVEI S2,CRBLK ;AND ITS LOCATION
$RETT ;AND TAKE A GOOD RETURN
;FAILURE RETURNS - FAILED TO PARSE
XCOMNE: SKIPN LSTERR ;ANY ERRORS YET?
MOVEM T1,LSTERR ;NO..SAVE ONLY THE FIRST
XCOMNP: JXN F,CMQUES,CMRTYP ;IF IN HELP, DON'T RETURN NOW
PUSHJ P,CMRSET ;RESET FIELD VARIABLES
MOVEM P5,.CMINC(P2) ;FIX USER BLOCK
LOAD T1,.CMFNP(P1),CM%LST ;GET PTR TO NEXT FN BLOCK
HRRM T1,P1 ;SAVE IT
JUMPN T1,XCOMN0 ;DISPATCH IF THERE IS ANOTHER FUNCTION
TXO F,CM%NOP ;NO OTHER POSSIBILITIES, SAY NO PARSE
MOVE T1,LSTEPC ;GET THE LAST ERROR PC
MOVEM T1,.LGEPC ;SAVE FOR ERROR ROUTINE
MOVE T1,LSTERR ;SET GLOBAL ERROR INDICATORS
MOVEM T1,.LGERR
JRST XCOMX2
;HERE AFTER EACH HELP OUTPUT
CMRTYP: PUSHJ P,CMRSET ;RESET FIELD VARIABLES
LOAD T1,.CMFNP(P1),CM%LST ;GET NEXT FUNCTION IN LIST
HRRM T1,P1
TXO F,CMQUES+CMQUE2 ;NOTE IN SECOND HELP POSSIBILITY
JUMPN T1,XCOMN0 ;DO SUBSEQUENT HELPS
;[32] MOVEI S1,.CHLFD ;START NEW LINE
;[32] PUSHJ P,CMDOUT
HLR P1,P1 ;END OF LIST, REINIT IT
SOS P5 ;FLUSH QMARK FROM INPUT
TXZ F,CMQUES+CMQUE2 ;NOTE NOT IN HELP
PUSHJ P,RETYPE ;RETYPE LINE
JRST XCOMN0 ;RESTART PARSE OF CURRENT FIELD
XCOMEO: TXO F,CM%NOP ;SET NO PARSE
MOVEI S2,CRBLK
MOVE P,STKFEN ;FIXUP STACK
$RETF
SUBTTL RETYPE - Retype current line including the prompt
RETYPE: PUSHJ P,TYPRMT ;RETYPE THE PROMPT
PUSHJ P,TYLINE ;RETYPE THE LINE THUS FAR
$RETT ;AND RETURN
SUBTTL TYPRMT - Retype the prompt if there is one
TYPRMT: HRRZ S1,.CMIOJ(P2) ;Get output designator
CAIE S1,.PRIOU ;TTY?
$RETT ;No, just return then
PUSHJ P,K%TPOS ;Get horizontal position of terminal
SKIPF ;Unknown, assume needs CRLF
SKIPE S1 ;At column zero?
PUSHJ P,CRLF ;No, type crlf
SKIPE Q1,.CMRTY(P2) ;GET ^R PTR IF ANY
TYPR.1: CAMN Q1,.CMBFP(P2) ;UP TO TOP OF BFR?
$RETT ;DONE WITH PROMPT, RETURN
ILDB S1,Q1 ;TYPE ^R BFR
JUMPE S1,.RETT ;RETURN IF END OF STRING
PUSHJ P,CMDOUT ;ELSE, OUTPUT THE CHARACTER
JRST TYPR.1 ;AND LOOP
SUBTTL TYLINE - Retype the line until current position
TYLINE: MOVE Q1,.CMBFP(P2) ;GET MAIN BFR PTR
TYLI.1: CAMN Q1,P4 ;UP TO CURRENT PTR?
JRST TYLI.2 ;YES, GO DO ADVANCE INPUT
ILDB S1,Q1 ;TYPE OUT COMMAND BFR
PUSHJ P,CMDOUT
JRST TYLI.1
TYLI.2: MOVE Q2,P5 ;GET INPUT COUNT
TYLI.3: SOJL Q2,[SETZ T1,0 ;ALL INPUT PRINTED, TIE OFF
IDPB T1,Q1 ;BUFFER
POPJ P,0]
ILDB S1,Q1
PUSHJ P,CMDOUT
JRST TYLI.3
;INDIRECT FILE HANDLING
CMIND: TXNE F,CMQUE2 ;NO SECOND HELP POSSIBILITIES?
JRST XCOMNP ;GUESS NOT
PUSHJ P,CMATFI ;GET A JFN ON THE INDIRECT FILE
JRST CMINDE ;FAILED
PUSHJ P,CMCFM0 ;DO A CONFIRM
JRST [MOVEI S1,[ASCIZ /
?Indirect file not confirmed.
/]
PUSHJ P,CMDSTO
TXO F,CM%NOP
JRST XCOMX2]
LOAD S1,.CMGJB(P2),CM%GJB ;GET ADDR OF FD
SKIPN S2,.FDSTR(S1) ;IF DEVICE HAS NOT BEEN SPECIFIED,
MOVSI S2,'DSK' ;DEFAULT TO DISK
MOVEM S2,.FDSTR(S1) ;
SKIPN S2,.FDEXT(S1) ;AND DEFAULT THE EXTENSION
MOVSI S2,'CMD' ;TO ".CMD"
MOVEM S2,.FDEXT(S1) ;
STORE S1,IFOB+FOB.FD ;STORE IT
MOVX S1,FB.LSN!<INSVL.(7,FB.BSZ)> ;IGNORE LINE NUMBERS
STORE S1,IFOB+FOB.CW ;STORE
MOVEI S1,2 ;SHORT FOB
MOVEI S2,IFOB ;AND ITS ADDRESS
PUSHJ P,F%IOPN ;OPEN FOR INPUT
JUMPF CMINDE ;IF FAILS,TELL WHY
MOVEM S1,IIFN ;STORE IFN
PUSHJ P,CMRSET ;FLUSH INDIRECT FILESPEC FROM BUFFER
CMIND1: MOVE S1,IIFN ;GET IFN
PUSHJ P,F%IBYT ;GET A BYTE
JUMPF CMIND2 ;IF FAILS FIND OUT WHY
JUMPE S2,CMIND1 ;Ignore nulls (Grrr...!!)
CAIN S2,CMCONC ;Possible line continuation?
JRST [ MOVE S1,IIFN ;Yes, see if EOL next
PUSHJ P,F%IBYT ;Get next char
JUMPF [ MOVEI T1,CMCONC ;EOF... stuff the hyphen
PUSHJ P,CMDIBQ ; ..
JRST CMIND2] ;Close file and finish up
CAIE S2,CMRDOC ;Ignore ^H
CAIN S2,.CHCRT ; and CR
JRST .
CAIN S2,.CHLFD ;Line feed?
JRST .+1 ;Yes, stuff it and forget the hyphen
MOVEI T1,CMCONC ;No, I guess the hyphen was real, then
PUSHJ P,CMDIBQ ; so put it into the guy's buffer
JRST .+1] ;Now handle the next char
CAIE S2,CMRDOC ;IGNORE ^H
CAIN S2,.CHCRT ;IGNORE CR
JRST CMIND1
CAIE S2,.CHLFD ;CONVERT EOL TO SPACE
CAIN S2,.CHESC ;DITTO ESC (BUT THERE SHOULDN'T BE ANY)
MOVEI S2," "
MOVE T1,S2 ;COPY CHARACTER
PUSHJ P,CMDIBQ ;PUT CHAR IN BUFFER WITHOUT TYPEOUT
JRST CMIND1
CMIND2: MOVE S1,IIFN ;CLOSE OFF THE FILE NOW
PUSHJ P,F%REL ;
MOVEI T1,.CHLFD ;TIE OFF LINE
PUSHJ P,CMDIBQ
JRST XCOMRP ;REPARSE LINE AS NOW CONSTITUTED
CMINDE: PUSHJ P,I%IOFF ;TURN OFF INTERRUPTS
$TEXT(T%TTY,<^M^J?Problem with Indirect File: ^E/[-1]/>)
PUSHJ P,I%ION ;THEN TURN THEM BACK ON
TXO F,CM%NOP ;RETURN FAILURE, NO CHECK ALTERNATIVES
JRST XCOMX2
;****************************************
;COMND - LOCAL SUBROUTINES
;****************************************
;READ NEXT FIELD ATOM
;ASSUMES ATOM BUFFER ALREADY SETUP
CMRATM: MOVEI T1,FLDBRK ;USE STANDARD FIELD BREAK SET
TXNE F,CM%BRK ;WAS THERE A BREAK SET PROVIDED?
MOVE T1,SPCBRK ;YES.. USE SPECIAL BREAK SET
PJRST CMRFLD ;PARSE THE FIELD
FLDBRK: 777777,,777760 ;ALL CONTROL CHARS
777754,,001760 ;ALL EXCEPT - , NUMBERS
400000,,000760 ;ALL EXCEPT UC ALPHABETICS
400000,,000760 ;ALL EXCEPT LC ALPHABETICS
;READ FILESPEC FIELD - FILESPEC PUNCTUATION CHARACTERS
;ARE LEGAL (: . < > ) WITH EXCEPTION OF "," WHICH IS HANDLED
;WITH [P,PN] AS SPECIAL CASE
;ACCEPT FILESPECS IN THE FORM OF "DEV:FILNAM.EXT[P,PN,PATH,...]
CMRFIL: MOVEI T1,FILBRK
PUSHJ P,CMRFLD ;GET DEV:NAME.EXT
MOVE T1,P4 ;GET POINTER TO LAST BYTE PARSED
ILDB T1,T1 ;GET TERMINATOR
CAIN T1,"[" ;PPN ?
PUSHJ P,CMRPTH ;YES -- GET DIRECTORY
POPJ P,0
FILBRK: 777777,,777760 ;BREAK ON ALL CC
777764,,000760 ;ALLOW . 0-9 :
400000,,000760 ;ALLOW UC
400000,,000760 ;ALLOW LC
;USERNAME BREAK SET. BREAKS ON EVERYTHING EXCEPT DOT AND ALPHABETICS.
USRBRK: 777777,,777760 ;BREAK ON ALL CONTROLS
777744,,001760 ;ALLOW - . 0-9
400000,,000760 ;ALLOW UC
400000,,000760 ;ALLOW LC
;READ TO END OF LINE
EOLBRK: 1B<.CHLFD> ;END OF LINE ONLY
EXP 0,0,0 ;THREE WORDS OF 0'S
;CMRPTH Routine to Read TOPS-10 Path Specification from buffer
CMRPTH: MOVEI T1,PTHBRK ;POINT TO PATH BREAK SET
PUSHJ P,CMRFLD ;GET PATH (UP TO "]")
TXNE F,CMQUES ;RETURN IF HELP REQUESTED
POPJ P,0
MOVE T1,P4 ;GET POINTER TO LAST CHARACTER
ILDB T1,T1 ;GET TERMINATOR
CAIN T1,"]" ;END OF PATH?
JRST CMRP.1 ;YES -- STORE TERMINATOR AND RETURN
JXN F,CM%ESC,CMAMB ;DING IF ESCAPE TYPED
POPJ P,0 ;ELSE RETURN
CMRP.1: PUSHJ P,CMCIN ;GET TERMINATOR
PUSHJ P,STOLCH ;STORE IN ATOM
POPJ P,0
PTHBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
777734,,001760 ;ALLOW , 0-9
400000,,000360 ;BREAK ON "]" ALLOW UC AND "["
400000,,000760 ;ALLOW LC
;GENERAL FIELD PARSE ROUTINE - TAKES BREAK SET MASK
; T1/ ADDRESS OF 4-WORD BREAK SET MASK
; PUSHJ P,CMRFLD
; RETURNS +1, FIELD COPIED TO ATOM BUFFER, TERMINATOR BACKED UP
CMRFLD: MOVEM T1,CMRBRK ;SAVE BREAK TABLE ADDRESS
TXNE F,CMDEFF ;DEFAULT GIVEN?
JRST CMRATT ;YES, ALREADY IN BUFFER
CMRAT1: PUSHJ P,CMCIN ;GET A CHAR
MOVE T2,T1 ;GET COPY OF CHAR
IDIVI T2,40 ;COMPUTE INDEX TO BIT MASK
MOVE T3,BITS(t3)
ADD T2,CMRBRK
TDNE T3,0(T2) ;BREAK CHARACTER?
JRST CMRAT2 ;YES
PUSHJ P,STOLCH ;BUILD KEYWORD STRING
JRST CMRAT1
CMRAT2: CAIN T1,.CHCNZ ;Control-Z ?
JRST [PUSHJ P,STOLCH ;Yes - store character in buffer
JRST CMRATT] ;And return
CAIE T1,CMFREC ;^F RECOGNITION?
CAIN T1,.CHESC ;ESC?
JRST [PUSHJ P,CHKLCH ;YES, RETURN IF ANYTHING NOW
JUMPG T1,CMRATT ;IN ATOM BFR
JRST CMAMB] ;AMBIGUOUS
CAIE T1," " ;SPACE OR TAB?
CAIN T1,.CHTAB
JRST [PUSHJ P,CHKLCH ;YES, RETURN IF ANYTHING
JUMPG T1,CMRATR ;IN ATOM BFR
JRST CMRAT1] ;OTHERWISE IGNORE
CAIN T1,.CHLFD ;OR EOL?
JRST CMRATR ;YES
CAIN T1,CMHLPC ;HELP REQUEST?
JRST [TXO F,CMQUES ;YES, FLAG
JRST CMRATT]
CMRATR: PUSHJ P,CMDIP ;PUT CHARACTER BACK IN BUFFER
CMRATT: PJRST TIELCH ;TIE OFF ATOM BUFFER AND RETURN
;ATOM READ FOR SPECIAL FIELDS - DOES NOT ALLOW RECOGNITION
;READ FIELD TO CR
CMRSTR: TXZA F,CMTF1 ;FLAG NO TERMINATE ON SPACE
; .. ;CONTINUE IN CMRSPC
;READ FIELD TO SPACE OR CR
CMRSPC: TXO F,CMTF1 ;FLAG TERMINATE ON SPACE
TXNE F,CMDEFF ;HAVE FIELD ALREADY?
POPJ P,0 ;YES
CMRSP1: PUSHJ P,CMCIN ;GET CHAR
CAIN T1,CMHLPC ;HELP?
JRST [TXO F,CMQUES ;YES
POPJ P,0]
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIE T1,.CHTAB
CAIN T1," " ;END OF FIELD?
JRST [JXE F,CMTF1,.+1 ;CONTINUE IF NOT TERMINATING ON BLANK
PUSHJ P,CHKLCH ;SEE IF ANY NON-BLANK SEEN
JUMPE T1,CMRSP1 ;JUMP IF LEADING BLANK
JRST CMRATT] ;TERMINATING BLANK
CAIN T1,.CHLFD ;END OF LINE?
JRST CMRATR ;YES
PUSHJ P,STOLCH ;NO, CHAR TO ATOM BUFFER
JRST CMRSP1 ;CONTINUE
;READ QUOTED STRING INTO ATOM BUFFER
;STRING DELIMITED BY ", "" MEANS LITERAL "
CMRQST: TXNE F,CMDEFF ;HAVE DEFAULT?
RETSKP ;YES
PUSHJ P,CMCIN ;GET FIRST CHAR
CAIN T1,CMHLPC ;FIRST CHAR IS HELP?
JRST [TXO F,CMQUES ;YES
RETSKP]
CAIE T1,CMQTCH ;START OF STRING?
POPJ P,0 ;NO, FAIL
CMRQS1: PUSHJ P,CMCIN ;READ NEXT CHAR
CAIN T1,.CHLFD ;LINE ENDED UNEXPECTEDLY?
JRST [PJRST CMDIP] ;YES, PUT LF BACK AND RETURN FAIL
CAIE T1,CMQTCH ;ANOTHER QUOTE?
JRST CMRQS2 ;NO, GO STORE CHARACTER
PUSHJ P,CMCIN ;YES, PEEK AT ONE AFTER
CAIN T1,CMQTCH ;PAIR OF QUOTES?
JRST CMRQS2 ;YES, STORE ONE
PUSHJ P,CMDIP ;NO, PUT BACK NEXT CHAR
PUSHJ P,TIELCH ;TIE OFF ATOM BUFFER
RETSKP ;GOOD
CMRQS2: PUSHJ P,STOLCH ;STOR CHAR IN ATOM BUFFER
JRST CMRQS1 ;KEEP LOOKING
SUBTTL Atom Buffer Routines / INILCH - Init Atom Buffer
INILCH: MOVE T1,.CMABP(P2) ;GET PTR
MOVEM T1,ATBPTR
MOVE T1,.CMABC(P2) ;GET SIZE
MOVEM T1,ATBSIZ
PJRST CMSKSP ;FLUSH INITIAL SPACES
SUBTTL Atom Buffer Routines / STOLCH - Store Character in Atom Buffer
STOLCH: SOSGE ATBSIZ ;ROOM?
$STOP(ABS,Atom buffer too small) ;NO
IDPB T1,ATBPTR
POPJ P,0
SUBTTL Atom Buffer Routines / CHKLCH - Return Number of Characters
CHKLCH: MOVE T1,.CMABC(P2) ;GET ORIG COUNT
SUB T1,ATBSIZ ;COMPUTE DIFFERENCE
POPJ P,0
SUBTTL Atom Buffer Routines / TIELCH - Terminate Atom Buffer With NULL
TIELCH: SKIPG ATBSIZ ;ROOM FOR NULL?
PUSHJ P,S..ABS ;NO, LOSE
SETZ T1,0
MOVE T3,ATBPTR ;GET POINTER
IDPB T1,T3 ;DEPOSIT WITHOUT CHANGING PTR
POPJ P,0
SUBTTL CMCIN - Read One Character for Processing
;APPEND TEXT TO BUFFER IF NECESSARY WITH INTERNAL TEXTI
; PUSHJ P,CMCIN
; RETURNS +1 ALWAYS, T1/ CHARACTER
CMCIN: SOJL P5,[SETZ P5,0 ;MAKE INPUT EXACTLY EMPTY
PUSHJ P,CMCIN1 ;NONE LEFT, GO GET MORE
JRST CMCIN]
ILDB T1,P4 ;GET NEXT ONE
SOS P3 ;UPDATE FREE COUNT
CAIN T1,.CHCRT ;IS IT A CARRIAGE RETURN?
JRST CMCIN ;YES, IGNORE IT
CAIN T1,CMFREC ;^F?
JRST [TXO F,CM%ESC+CMCFF ;YES
POPJ P,0]
CAIN T1,.CHESC ;ESC?
JRST [TXO F,CM%ESC ;YES
POPJ P,0]
CAIE T1,.CHCNZ ;Control-Z ?
CAIN T1,.CHLFD ;END OF LINE?
TXO F,CM%EOC ;YES, MEANS END OF COMMAND
POPJ P,0
CMDIN: PUSHJ P,CMCIN ;GET NEXT CHAR
TXNE F,CM%ESC ;IS IT THE RECOGNIZER?
POPJ P, ;YES, ALL SET
PUSHJ P,CMDIP ;NO, PUT IT BACK IN BUFFER
SETZ T1, ;NO CHAR
POPJ P,
CMCIN1: MOVEM F,CMCSF ;SAVE F
SETZM CMCBLF ;INIT ACCUMULATED FLAGS
MOVE T1,[XWD P1,CMCSAC] ;PREPARE FOR BLT
BLT T1,CMCSAC+3 ;SAVE P1-P4
;*** REMOVE RD%RND FOR NOW 6/22/78
MOVX T1,RD%BRK+RD%PUN+RD%BEL+RD%JFN+RD%BBG ;SETUP FLAGS
; REMOVE CM%NJF 9/20/79 MLB SYMBOL USED FOR CM%BRK
; TXNE F,CM%NJF ;WERE JFN'S PASSED?
; TXZ T1,RD%JFN ;NO, PASS THAT FACT
TXNE F,CM%RAI ;RAISE INPUT REQUESTED?
TXO T1,RD%RAI ;YES, PASS IT
MOVEM T1,TI+.RDFLG ;STORE FLAGS FOR TEXTI
MOVX T1,.RDBKL ;GET NUMBER OF WORDS TO PASS
MOVEM T1,TI+.RDCWB ;AND STORE IT
MOVE T1,.CMRTY(P2) ;SETUP ^R BUFFER
MOVEM T1,TI+.RDRTY ;FOR TXTI
MOVE T1,.CMBFP(P2) ;SETUP TOP OF BUFFER
MOVEM T1,TI+.RDBFP ;
SETZM TI+.RDBRK ;NO SPECIAL BREAK MASK
MOVEM P4,TI+.RDBKL ;STORE CURRENT PTR FOR BACK UP LIMIT
MOVEM P3,CMCSC ;SAVE CURRENT COUNT
SUB P3,P5 ;ADJUST COUNT FOR ADVANCE INPUT
MOVEM P3,TI+.RDDBC ;AND STORE FOR THE TEXT INPUT
SKIPE P5 ;PUSH POINTER PAST CURRENT INPUT
IBP P4 ;
SOJG P5,.-1 ;
MOVEM P4,TI+.RDDBP ;STORE FOR INPUT
CMCIN2: MOVE S1,.CMIOJ(P2) ;GET THE JFNS
MOVEM S1,TI+.RDIOJ ;STORE FOR TEXTI
SKIPG P3 ;ROOM IN BUFFER FOR MORE INPUT?
$STOP(TMT,Too much text) ;NO
HRLZI S1,7 ;GET SOURCE
HRRI S1,A07T16 ;GET DESTIONATION
BLT S1,A07T16+7 ;SAVE SOME ACS
SETOM ACFLG ;REMEMBER THEY ARE IMPORTANT
MOVEI S1,TI ;GET LOCATION OF TEXTI BLOCK
PUSHJ P,K%TXTI ;DO INTERNAL TEXTI
SETZM ACFLG ;THE SAVED ACS ARE NO LONGER IMPORTANT
JUMPF [MOVEI S1,EREOF$
JRST XCOMEO]
IOR F,TI+.RDFLG ;GET FLAGS
IORB F,CMCBLF ;ACCUMULATE FLAGS (RD%BLR)
LDB T1,TI+.RDDBP ;GET LAST CHAR
MOVE P4,TI+.RDDBP ;REMEMBER POINTER
MOVE P3,TI+.RDDBC ;AND COUNT
TXNE F,RD%BFE ;BUFFER EMPTY?
JRST CMCIN3 ;YES, RETURN
JUMPE T1,CMCIN3 ;JUMP IF NULL
CAIE T1,.CHLFD ;AN ACTION CHAR?
CAIN T1,.CHESC
JRST CMCIN3 ;YES
CAIE T1,CMHLPC
CAIN T1,CMFREC ;^F?
JRST CMCIN3 ;YES
CAIE T1,.CHCNZ ;Control-Z ?
JRST CMCIN2 ;NO, GET MORE INPUT
CMCIN3: TXNE F,RD%BLR ;BACKUP LIMIT REACHED?
JRST CMCIN4 ;YES, CLEANUP AND REPARSE
TXNE F,RD%BFE ;BUFFER EMPTY
SKIPN INTRPT ;INTERRUPT OCCUR
SKIPA ;NO..CHECK REST
JRST CMCIN4 ;YES..SETUP TO RETURN
MOVE P5,CMCSC ;RECOVER PREVIOUS COUNT
SUB P5,P3 ;COMPUTE CHARACTERS JUST APPENDED
MOVSI T1,CMCSAC ;RESTORE ACS P1-P4, F
HRRI T1,P1
BLT T1,P4
MOVE F,CMCSF
POPJ P,0
;HERE ON RETURN FROM TEXTI WHICH REACHED BACKUP LIMIT OR WHICH RETURNED
;BECAUSE BUFFER EMPTY. MUST REPARSE LINE. RESTORE ACS, BUT LEAVE
;MAIN POINTER AS RETURNED BY TEXTI.
CMCIN4: DMOVE P1,CMCSAC ;RESTORE P1&P2
MOVE F,CMCSF ;RESTORE F
SKIPE INTRPT ;WAS THERE AN INTERRUPT CALL?
TXO F,CM%INT ;YES, LIGHT THE FLAG
SETZM INTRPT ;CLEAR CALL FLAG
JRST XCOMRP ;RETURN REPEAT PARSE
;SKIP LEADING TABS OR SPACES
CMSKSP: PUSHJ P,CMCIN ;GET A CHAR
CAIE T1," " ;SPACE OR TAB?
CAIN T1,.CHTAB
JRST CMSKSP ;YES, KEEP LOOKING
PJRST CMDIP ;NO, PUT IT BACK
;LOCAL ROUTINE - SUBTRACT ASCII BYTE PTRS
; T1, T2/ ASCII BYTE PTRS
; PUSHJ P,SUBBP
; RETURNS +1 ALWAYS,
; T1/ T1-T2
SUBBP: HRRZ T3,T1 ;COMPUTE 5*(A1-A2)+(P2-P1)/7
SUBI T3,0(T2)
IMULI T3,5 ;COMPUTE NUMBER CHARS IN THOSE WORDS
LDB T1,[POINT 6,T1,5]
LDB T2,[POINT 6,T2,5]
SUBM T2,T1
IDIVI T1,7
ADD T1,T3
POPJ P,0
;LOCAL ROUTINE - DELETE LAST CHAR INPUT
CMDCH: MOVE S1,P4
PUSHJ P,DBP ;DECREMENT BYTE PTR
MOVEM S1,P4
AOS P3 ;ADJUST SPACE COUNT
SETZ P5,0 ;CAN'T BE ANY WAITING INPUT
POPJ P,0
;LOCAL ROUTINE - DECREMENT INPUT POINTER
CMDIP: LDB T1,P4 ;CHECK THE CHARACTER
CAIE T1,CMFREC ;A RECOG REQUEST CHAR?
CAIN T1,.CHESC
TXZ F,CM%ESC+CMCFF ;YES, RESET FLAGS
MOVE S1,P4 ;GET POINTER
PUSHJ P,DBP ;DECREMENT IT
MOVEM S1,P4 ;PUT IT BACK
AOS P5 ;ADJUST COUNTS
AOS P3
POPJ P,0
;LOCAL ROUTINE - DEPOSIT INTO INPUT BUFFER
CMDIB: MOVE S1,T1 ;COPY THE CHARACTER
PUSHJ P,CMDOUT ;TYPE IT
CMDIBQ: SETZ P5,0 ;CLEAR ADVANCE COUNT
SOSGE P3 ;ROOM?
PUSHJ P,S..ABS ;NO
IDPB T1,P4 ;APPEND BYTE TO USER'S BUFFER
POPJ P,0
;LOCAL ROUTINE - DECREMENT BYTE POINTER
;CALL S1/ BYTE POINTER
DBP: SOS S1 ;BACK OFF ONE WORD
IBP S1 ;AND THEN GO FORWARD 4 TIMES
IBP S1
IBP S1
IBP S1
$RETT ;THEN RETURN
SUBTTL HELPER - Do caller supplied and default HELP text
;HELPER types out the caller supplied help text, if any, and then it types
; the default help type unless it was suppressed. Return is via CMRTYP
; to retype the current line.
;
;Call: S1/ address of default HELP text
;
;T Ret: always
HELPER: PUSH P,S1 ;SAVE S1
PUSHJ P,DOHLP ;DO CALLER SUPPLIED HELP IF ANY
TXNE F,CM%SDH ;ARE WE SUPPRESSING DEFAULT HELP?
JRST HELP.1 ;YES, SKIP PRINTING IT
MOVEI S1," " ;LOAD A BLANK
PUSHJ P,CMDOUT ;PRINT IT
MOVE S1,0(P) ;GET THE MESSAGE
PUSHJ P,CMDSTO ;PRINT IT
HELP.1: POP P,S1 ;GET THE STACK BACK
PJRST CMRTYP ;RETYPE THE LINE
SUBTTL DOHLP - Do caller supplied HELP text
DOHLP: TXNN F,CMQUE2 ;IN ALTERNATE HELP POSSIBILITIES?
JRST DOHL2 ;NO, SEE IF USER HELP WAS GIVEN
TXNE F,CM%HPP ;USER HELP SPECIFIED?
JRST DOHL1 ;YES, DISPLAY "OR"
TXNE F,CM%SDH ;SUPPRESSING DEFAULT HELP
POPJ P,0 ;YES, JUST RETURN
DOHL1: MOVEI S1,[ASCIZ /
or/]
PUSHJ P,CMDSTO
DOHL2: TXNN F,CM%HPP ;HAVE HELP POINTER?
POPJ P,0 ;NO
MOVEI S1," "
PUSHJ P,CMDOUT ;SPACE BEFORE USER TEXT
MOVE S1,.CMHLP(P1) ;YES, GET IT
PJRST CMDSTO ;AND TYPE IT
SUBTTL CMAMB - Handle Ambiguous Typein
CMAMB: TXZN F,CM%ESC ;ESC SEEN?
NOPARS (AMB) ;Ambiguous switch or keyword
PUSHJ P,CMDCH ;FLUSH RECOG CHAR FROM BUFFER
MOVEI S1,.CHBEL ;INDICATE AMBIGUOUS
PUSHJ P,CMDOUT
JRST XCOMRF ;GET MORE INPUT AND RESTART
;OUTPUT STRING FROM CURRENT CONTEXT
XMCOUT: PUSHJ P,CMDOUT ;OUTPUT A CHARACTER
CAIE S1,^D9
JRST XMCS.2
XMCS.1: MOVE S1,CURPOS
ADDI S1,8
IDIVI S1,8
IMULI S1,8
MOVEM S1,CURPOS
SKIPA
XMCS.2: AOS CURPOS ;MAINTAIN POSITION
POPJ P,0
CRLF: SETZM CURPOS ;AT LEFT MARGIN
MOVEI S1,[BYTE (7) .CHCRT,.CHLFD,0]
PJRST CMDSTO ;AND TYPE IT
;CHECK ALL BYTE PTRS
; T1/ PTR TO LIST OF ADDRESSES, TERMINATED BY 0
CHKABP: $SAVE Q1 ;SAVE ACS
$SAVE Q2 ;THAT WE USE
MOVEM T1,Q1 ;SAVE LIST PTR
CHKAB1: MOVE Q2,0(Q1) ;GET NEXT ADDRESS
JUMPE Q2,.RETT ;DONE ON 0
ADDI Q2,0(P2) ;MAKE PTR TO BLOCK
MOVE S1,0(Q2) ;GET BYTE PTR
PUSHJ P,CHKBP ;CHECK AND NORMALIZE
MOVEM S1,0(Q2) ;PUT IT BACK
AOJA Q1,CHKAB1 ;DO NEXT
;CHECK A BYTE PTR
; S1/ BYTE PTR - IF LH IS -1, PTR IS FIXED
CHKBP: HLRZ S2,S1
CAIN S2,-1
HRLI S1,(POINT 7)
LDB S2,[POINT 6,S1,11] ;GET BYTE SIZE
IBP S1 ;INCREMENT AND DECREMENT TO NORMALIZE
PJRST DBP
SUBTTL Command Function / .CMINI - Init the scanner and do ^H
XCMINI: HLRZ T1,.CMIOJ(P2) ;DOING INPUT FROM TERMINAL?
CAXE T1,.PRIIN ;..
JRST CMINI4 ;NO, SKIP REPAIR
PUSHJ P,TYPRMT ;GO TYPE A PROMPT
CAMN P4,.CMBFP(P2) ;BUFFER EMPTY?
JRST CMINI4 ;YES, NO REDO POSSIBLE
LDB T1,P4 ;CHECK LAST CHAR
CAIN T1,.CHLFD ;END OF LINE?
JRST CMINI4 ;YES, LAST COMMAND OK, NO REDO
PUSHJ P,K%BIN ;GET FIRST CHARACTER
CAIN S1,CMRDOC ;IS IT REDO?
JRST CMINI5 ;YES
PUSHJ P,K%BACK ;NO, BACKUP OVER IT
CMINI4: MOVE T1,P4 ;RESET LINE VARIABLES
MOVE T2,.CMBFP(P2)
MOVEM T2,P4
PUSHJ P,SUBBP ;COMPUTE CHARACTERS IN LINE
ADDM T1,P3 ;UPDATE SPACE COUNT
SETZ P5,0 ;RESET ADVANCE COUNT
JRST XCOMXI ;RETURN GOOD
CMINI5: MOVE P3,.CMCNT(P2) ;RESET VARIABLES TO CURR FIELD
MOVE P4,.CMPTR(P2)
LDB T1,P4 ;IF LAST CHARACTER WAS <CR>
CAIN T1,.CHCRT
PUSHJ P,CMDCH ;DELETE FROM INPUT BUFFER
SETZ P5,0 ;NO INPUT
PUSHJ P,RETYPE ;RETYPE
JRST XCOMRP ;RETURN TO REPARSE
SUBTTL Command Function / .CMSWI - Parse a SWITCH
;SWITCH - LIKE KEYWORD BUT PRECEEDED BY SLASH
XCMSWI: TXO F,CMSWF ;NOTE DOING SWITCH
TXNE F,CMDEFF ;DEFAULT GIVEN?
JRST CMKEY0 ;YES, SLASH ALREADY ASSUMED
PUSHJ P,CMCIN ;GET FIRST CHAR
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIN T1,CMHLPC ;HELP?
JRST [SETZ T1,0
MOVE T2,ATBPTR
IDPB T1,T2
MOVE T1,FNARG ;GET TABLE PTR
MOVEI T1,1(T1) ;POINT TO FIRST TABLE ENTRY
JRST CMQ2] ;TYPE OPTIONS
CAIE T1,CMSWCH ;THE SWITCH CHARACTER?
JRST [PUSHJ P,CMDIP ;NO, PUT IT BACK
NOPARS (NSW)] ;Not a switch
JRST CMKEY0 ;CONTINUE LIKE KEYWORD
SUBTTL Command Function / .CMKEY - Parse a KEYWORD
XCMKEY: TXZ F,CMSWF ;NOT SWITCH
CMKEY0:
KEYW1: PUSHJ P,CMRATM ;READ THE FIELD INTO LOCAL BUFFER
MOVE T1,FNARG ;GET TABLE HEADER ADDRESS
MOVE T2,.CMABP(P2) ;POINT TO KEYWORD BUFFER
PUSHJ P,XTLOOK ;LOOKUP
TXNE F,CMQUES ;HAD "?"
JRST CMQ1 ;YES, GO TYPE ALTERNATIVES
TXNE T2,TL%NOM ;NO MATCH?
NOPARS(NOM) ;Not a switch or keyword
JXN T2,TL%AMB,CMAMB ; ??? AMBIGUOUS
MOVEM T1,T2 ;SAVE TABLE INDEX
MOVEM T1,CRBLK+CR.RES ;AS RESULT
JXE F,CM%ESC,KEYW4 ;DONE IF NO REC WANTED
MOVEM T3,Q1 ;SAVE PTR TO REMAINDER OF STRING
PUSHJ P,CMDCH ;FLUSH RECOG CHARACTER
KEYW2: ILDB T1,Q1 ;TYPE REMAINDER OF KEYWORD
JUMPE T1,KEYW3 ;DONE
PUSHJ P,CMDIB ;APPEND COMPLETION TO BUFFER
CAIN T1,CMSWTM ;A SWITCH TERMINATOR?
JRST [TXZ F,CM%ESC ;YES, OVERRIDES ESC
TXO F,CM%SWT ;NOTE SWITCH TERMINAOTR
TXNN F,CMSWF ;IN SWITCH?
PUSHJ P,CMDIP ;NO, PUT TERMINATOR BACK
JRST XCOMXI] ;DONE
JRST KEYW2
KEYW3: JXE F,CMSWF,XCOMXI ;DONE IF NOT SWITCH
MOVE Q1,FNARG ;CHECK FUNCTION FLAGS
JXE Q1,CM%VRQ,XCOMXI ;DONE IF NO VALUE REQUIRED
MOVEI T1,CMSWTM ;INCLUDE COLON IN RECOGNITION
PUSHJ P,CMDIB
TXO F,CM%SWT ;NOTE SWITCH TERMINATOR
JRST XCOMX1 ;INHIBIT ADDITIONAL SPACE
KEYW4: PUSHJ P,CHKLCH ;SEE IF ATOM NON-NULL
JUMPE T1,[NOPARS (NUL)] ;Null switch or keyword
JXE F,CMSWF,XCOMXI ;DONE IF NOT SWITCH
PUSHJ P,CMSKSP ;SKIP SPACES
PUSHJ P,CMCIN ;GET NON-BLANK CHAR
CAIN T1,CMSWTM ;SWITCH TERMINATOR?
JRST [TXO F,CM%SWT ;YES, NOTE
JRST XCOMXI] ;DONE
PUSHJ P,CMDIP ;NO, PUT IT BACK
MOVE Q1,FNARG
JXN Q1,CM%VRQ,XCOMNP ;FAIL IF VALUE WAS REQUIRED
JRST XCOMXI ;OTHERWISE OK
;"?" TYPED, FIRST PARTIAL MATCH FOUND. TYPE ALL PARTIAL MATCHES
CMQ1: JXN T2,TL%NOM,[
JXN F,CMQUE2,CMRTYP ;DO NOTHING IF NOT FIRST ALTERNATIVE
MOVEI S1,[ASCIZ / keyword (no defined keywords match this input)/]
PUSHJ P,CMDSTO ;TYPE MESSAGE
JRST CMRTYP] ;RETYPE LINE AND CONTINUE
CMQ2: MOVEM T1,Q2 ;SAVE TABLE INDEX
PUSHJ P,DOHLP ;DO USER HELP IF ANY
TXNE F,CM%SDH ;DEFAULT HELP SUPPRESSED?
JRST CMRTYP ;YES, DONE
MOVE T1,FNARG ;GET TABLE PTR
HLRZ Q1,0(T1) ;GET TABLE SIZE
MOVE S1,Q1 ;SAVE SIZE OF THE TABLE
ADDI Q1,1(T1) ;COMPUTE TABLE END ADDRESS FOR BELOW
CAIN S1,1 ;ONLY ONE ELEMENT IN TABLE
JRST CMQ5 ;YES.. BYPASS TEXT AND OUTPUT BLANK
MOVEI S1,[ASCIZ / one of the following:/]
PUSHJ P,CMDSTO ;TYPE IT
PUSHJ P,CRLF ;AND A CRLF
CMTAB0: SOJ Q2,0 ;GETS INCREMENTED BEFORE EACH APPLICATION
MOVEM Q2,Q3SAVE ;SAVE SO IT CAN BE REINITIALIZED
SETZM TABSIZ ;START WITH TAB SIZE OF 0
CMTAB1: PUSHJ P,CMNXTE ;GET TO NEXT VALID KEYWORD IN TABLE
JUMPF CMTAB2 ;NO MORE IN TABLE
PUSHJ P,CMGTLN ;CALCULATE LENGTH OF KEYWORD
CAML T1,TABSIZ ;LONGEST SEEN SO FAR?
MOVEM T1,TABSIZ ;YES, REMEMBER IT
JRST CMTAB1 ;LOOK AT REST
CMTAB2: MOVE T1,TABSIZ
MOVEM T1,BIGSIZ ;REMEMBER LENGTH OF LONGEST KEYWORD
MOVEI S1,2 ;LEAVE AT LEAST 2 SPACES
ADDM S1,TABSIZ ;BETWEEN ITEMS
MOVE Q2,Q3SAVE ;RESTART TABLE POINTER FOR ACTUAL LISTING
CMQ3: PUSHJ P,CMNXTE ;GET TO NEXT KEYWORD
JUMPF CMRTYP ;NO MORE, REPEAT COMMAND SO FAR AND CONTINUE
CMQ4: MOVEI S1,"/" ;LOAD A SLASH
TXNE F,CMSWF ;ARE WE DOING SWITCHES?
PUSHJ P,CMDOUT ;YES, TYPE THE SLASH
PUSH P,T1 ;SAVE ADDRESS OF TABLE ENTRY
PUSHJ P,CMGTLN ;COMPUTE ITS LENGTH
ADDM T1,CURPOS ;MOVE CURRENT POSITION FORWARD
POP P,S1 ;RESTORE POINTER
PUSHJ P,CMDSTO ;TYPE IT
PUSHJ P,CMNXTE ;GET TO NEXT KEYWORD
JUMPF CMRTYP ;NO MORE, REPEAT COMMAND SO FAR AND CONTINUE
PUSHJ P,NXTKEY ;AND POSITION FOR THE NEXT ONE
JRST CMQ4 ;TRY NEXT
CMQ5: MOVEI S1," " ;GET A BLANK
PUSHJ P,CMDOUT ;OUTPUT A CHARACTER
JRST CMTAB0 ;CONTINUE HELP PROCESSING
;ROUTINE WHICH TAKES POINTER TO TABLE IN Q2, POINTER TO END OF TABLE
;IN Q1, AND RETURNS POINTER TO KEYWORD NAME IN T1. SKIPS UNLESS TABLE
;IS EXHAUSTED. ONLY CONSIDERS PRINTABLE KEYWORDS, AND UPDATES Q2.
CMNXTE: AOS Q2 ;LOOK AT NEXT TABLE ENTRY
CAML Q2,Q1 ;BEYOND END OF TABLE?
$RETF ;YES, FINISHED LIST
HLRZ T2,0(Q2) ;GET STRING PTR FOR IT
PUSHJ P,CHKTBS ;GET FLAGS FROM STRING
JXN T1,CM%INV+CM%NOR,CMNXTE ;SKIP ENTRY IF INVISIBLE OR NOREC
MOVE T1,.CMABP(P2) ;PTR TO PARTIAL KEYWORD
PUSHJ P,USTCMP ;COMPARE
JUMPE T1,CMNXT1 ;OK IF EXACT MATCH
JXE T1,SC%SUB,.RETF ;DONE IF NOT SUBSTRING
CMNXT1: HLRZ T2,0(Q2) ;GET PTR TO STRING FOR THIS ENTRY
PUSHJ P,CHKTBS
MOVE T1,T2
$RETT ;RETURN TRUE!!
;ROUTINE TO CALL BEFORE TYPING KEYWORD IN RESPONSE TO "?". GIVE
;IT USER'S BYTE POINTER IN T1. IT DECIDES WHETHER KEYWORD WILL FIT
;ON THIS LINE, AND STARTS NEW LINE IF NOT. IT THEN OUTPUTS A TAB,
;FOLLOWED BY SWITCH DELIMITER (IF KEYWORD IS A SWITCH).
NXTKEY: PUSHJ P,.SAVET ;DON'T CLOBBER USER'S BYTE POINTER
MOVE T2,CURPOS ;GET OUR CURRENT POSITION
PUSHJ P,[CMTAB: ADD T2,TABSIZ ;FIGURE OUT MAXIMUM PLACE TAB CAN MOVE US TO
IDIV T2,TABSIZ ;SCALE DOWN TO REALLY WHERE
IMUL T2,TABSIZ ;TAB WILL BRING US TO
POPJ P,0]
ADD T2,BIGSIZ ;MAKE SURE WE HAVE ROOM FOR ANOTHER COLUMN
CAMLE T2,PWIDTH ;ROOM FOR ANOTHER KEYWORD ON THIS LINE?
PJRST CRLF ;NO, TYPE A CRLF AND RETURN
PJRST TYPTAB ;YES, GET TO NEXT TAB STOP
;ROUTINE TO TYPE TAB OF SIZE TABSIZ. IT ASSUMES HARDWARE TABS ARE OF
;SIZE 8 AND TRIES TO TYPE AS MANY REAL TABS AS IT CAN, AND THEN SPACES
;OVER REST OF THE WAY.
TYPTAB: MOVE T2,CURPOS ;SEE WHERE WE'RE STARTING ON LINE
PUSHJ P,CMTAB ;SEE WHERE WE WANT TO GET TO
MOVEM T2,TABDON ;REMEMBER WHERE WE WANT TO GET TO
TYPTB1: MOVE T1,CURPOS ;GET WHERE WE ARE
ADDI T1,8 ;HARDWARE TAB MIGHT GO THIS FAR
TRZ T1,7 ;BUT MAYBE NOT QUITE
CAMLE T1,TABDON ;WILL HARDWARE TAB GO TOO FAR?
JRST TYPTB2 ;YES
MOVEI S1,.CHTAB
PUSHJ P,XMCOUT ;AND TYPE IT
JRST TYPTB1 ;LOOP FOR AS MANY HARDWARE TABS AS WE CAN GET AWAY WITH
TYPTB2: MOVE T1,CURPOS
CAML T1,TABDON ;ARE WE THERE YET?
POPJ P,0 ;YES, SO TAB IS TYPED
MOVEI S1," " ;NO, SO SPACE OVER
PUSHJ P,XMCOUT
JRST TYPTB2 ;AND LOOP FOR REST OF SPACES
;ROUTINE TAKING POINTER TO KEYWORD IN T1. RETURNS KEYWORD LENGTH IN
;T1. GIVES EXTRA 1 FOR SWITCH, ASSUMING A SLASH WILL PREFIX ITS
;PRINTOUT.
CMGTLN: MOVEI T4,0 ;COUNT OF NUMBER OF CHARACTERS NEEDED FOR THIS KEYWORD
CMGT.1: ILDB T2,T1 ;PICK UP NEXT CHARACTER FROM KEYWORD
CAIE T2,0 ;ASSUME KEYWORD ENDS ON NULL
AOJA T4,CMGT.1 ;NOT OVER YET, ACCUMULATE ITS LENGTH
TXNE F,CMSWF ;IS THIS A SWITCH?
AOJ T4,0 ;YES, DELIMITER TAKES UP ANOTHER SPACE
MOVE T1,T4 ;RETURN LENGTH IN T1
POPJ P,0
SUBTTL Command Function / .CMTXT - Parse Arbitrary Text to Action Character
XCMTXT: PUSHJ P,CMRSTR ;READ STRING
MOVEI S1,[ASCIZ /text string/]
TXNE F,CMQUES ;QUESTION MARK TYPED?
PUSHJ P,HELPER ;YES, GIVE HELP
JRST XCOMXI ;DONE
SUBTTL Function .CMNOI - Parse a NOISE-WORD
XCMNOI: MOVE S1,FNARG ;GET STRING PTR
PUSHJ P,CHKBP ;CHECK AND NORMALIZE
MOVEM S1,XXXPTR
TXNN F,CM%PFE ;PREVIOUS FIELD ENDED WITH ESC?
JRST CMNOI3 ;NO
TXO F,CM%ESC ;YES, MEANS THIS ONE DID TOO
MOVEI T1,NOIBCH ;TYPE NOISE BEG CHAR
PUSHJ P,CMDIB ; AND PUT IT IN BUFFER
CMNOI2: ILDB T1,XXXPTR ;GET NEXT NOISE CHAR
JUMPN T1,[PUSHJ P,CMDIB ;PUT IT IN BUFFER IF NOT END OF STRING
JRST CMNOI2]
MOVEI T1,NOIECH ;END OF STRING, TYPE END CHAR
PUSHJ P,CMDIB
JRST XCOMXI ;EXIT
;PREVIOUS FIELD NOT TERMINATED WITH ESC - PASS NOISE WORD IF TYPED
CMNOI3: PUSHJ P,CMSKSP ;BYPASS SPACES
PUSHJ P,CMCIN ;GET FIRST CHAR
CAIE T1,NOIBCH ;NOISE BEG CHAR?
JRST [PUSHJ P,CMDIP ;NO, NOT A NOISE WORD, PUT IT BACK
JRST XCOMXI] ;RETURN OK
CMNOI4: PUSHJ P,CMCIN ;GET NEXT NOISE CHAR
CAIE T1,CMFREC ;^F?
CAIN T1,.CHESC ;ESC?
JRST [PUSHJ P,CMDCH ;YES, FLUSH IT
JRST CMNOI2] ;COMPLETE NOISE WORD FOR USER
ILDB T2,XXXPTR ;COMPARE WITH GIVEN STRING
CAIL T1,"A"+40 ;RAISE CASING FOR COMPARE
CAILE T1,"Z"+40
SKIPA
SUBI T1,40
CAIL T2,"A"+40
CAILE T2,"Z"+40
SKIPA
SUBI T2,40
CAMN T1,T2
JRST CMNOI4 ;STILL SAME AS EXPECTED
CAIN T1,NOIECH ;NOT SAME, STRING ENDED TOGETHER?
JUMPE T2,XCOMXI ;YES, EXIT OK
NOPARS (INW) ;Invalid guide word
SUBTTL Command Function / .CMCFM - Command Confirmation (end-of-line)
XCMCFM: PUSHJ P,CMCFM0 ;DO THE WORK
NOPARS(NC) ;Not confirmed
JRST XCOMXI ;OK
CMCFM0: PUSHJ P,CMCIN ;GET CHAR
CAIE T1,.CHTAB ;BLANK?
CAIN T1," "
JRST CMCFM0 ;YES, IGNORE
MOVEI S1,[ASCIZ /confirm with carriage return/]
CAIN T1,CMHLPC ;HELP?
PUSHJ P,HELPER ;YES, GIVE IT
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIE T1,.CHLFD ;NL (NEW LINE, I.E. LINEFEED)
POPJ P,0 ;NO, FAIL
RETSKP ;YES
;FLOATING POINT NUMBER
XCMFLT: $STOP(SFP,Scanning floating point not implemented)
REPEAT 0,<
MOVEI T1,FLTBRK ;USE SPECIAL BREAK SET
PUSHJ P,CMRFLD ;READ FIELD
MOVEI S1,[ASCIZ /number/]
TXNE F,CMQUES ;QUESTION MARK?
PUSHJ P,HELPER ;YES, HELP!
MOVE T1,.CMABP(P2) ;NUMBER NOW IN ATOM BUFFER, GET PTR
MOVEM T1,T1
IMCALL .FLIN
JRST [MOVEM T3,T2 ;FAILED, RETURN ERROR CODE
JRST XCOMNP]
JRST CMNUMR ;DO NUMBER CLEANUP AND RETURN
;FLOATING POINT BREAK SET MASK, ALLOWS +, -, ., E, NUMBERS
FLTBRK: 777777,,777760
777644,,001760
400000,,000760
400000,,000760
>;END OF REPEAT 0
SUBTTL Command Function / .CMNUM - Parse an INTEGER in any base
SUBTTL Command Function / .CMNUX - Parse an INTEGER in any base (special break)
XCMNUX: SKIPA T1,[NUXBRK] ;USE SPECIAL BREAK SET
XCMNUM: MOVEI T1,NUMBRK ;USE REGULAR BREAK SET
PUSHJ P,CMRFLD ;READ FIELD
TXNE F,CMQUES ;SAW "?"
JRST CMNUMH ;YES
MOVE S1,.CMABP(P2) ;SETUP NIN
MOVE S2,FNARG ;GET RADIX
PUSHJ P,NUMIN ;PARSE THE NUMBER
JUMPF CMNUM1 ;NO PARSE
CMNUMR: MOVEM S2,CRBLK+CR.RES ;STORE RESULT
MOVE T2,ATBPTR
IBP T2 ;BUMP PTR PAST TERMINATOR
CAMN S1,T2 ;NIN SAW WHOLE FIELD?
JRST [MOVE T2,CRBLK+CR.RES
JRST XCOMXR] ; YES, RECOVER RESULT AND RETURN
CMNUM1: NOPARS (ICN) ;Invalid numeric character
;NUMBER BREAK SET, ALLOWS +, -, NUMBERS
NUMBRK: 777777,,777760
777654,,001760
400000,,000760
400000,,000760
NUXBRK: 777777,,777760
777654,,001760
777777,,777760
777777,,777760
CMNUMH: PUSHJ P,DOHLP ;DO USER SUPPLIED MESSAGE
JXN F,CM%SDH,CMRTYP ;SUPPRESS DEFAULT HELP IF REQUESTED
HRRZ T2,FNARG ;GET BASE
CAIL T2,^D2 ;LEGAL?
CAILE T2,^D10
$STOP(IBN,Illegal base for number)
CAIN T2,^D10 ;DECIMAL?
JRST CMNH10 ;YES
CAIN T2,^D8 ;OCTAL?
JRST CMNH8 ;YES
MOVEI S1,[ASCIZ / a number in base /]
PUSHJ P,CMDSTO ;ARBITRARY BASE
HRRZ T1,.CMIOJ(P2)
HRRZ T2,FNARG
MOVEI T3,^D10
ADDI T2,"0" ;CONVERT BASE TO ASCII
MOVE S1,T2 ;COPY THE BASE OVER
PUSHJ P,CMDOUT ;AND TYPE IT
SUBI T2,"0" ;CONVERT IT BACK
JRST CMRTYP ;RETYPE LINE AND CONTINUE
CMNH8: MOVEI S1,[ASCIZ / octal number/]
JRST CMNH
CMNH10: MOVEI S1,[ASCIZ / decimal number/]
CMNH: PUSHJ P,CMDSTO
JRST CMRTYP
SUBTTL Command Function / .CMDEV - Parse a DEVICE specification
XCMDEV: MOVEI T1,DEVBRK ;GET DEVICE BREAK SET
PUSHJ P,CMRFLD ;GET THE FIELD
MOVEI S1,[ASCIZ /Device name/]
TXNE F,CMQUES ;TYPE A QUESTION MARK?
PUSHJ P,HELPER ;YES, CALL THE HELPER
TXNE F,CM%ESC ;WANT RECOGNITION HERE?
JRST [PUSHJ P,CMDIP ;BACKUP OVER RECOGNIZER
PUSHJ P,CMCIN ;GET IT BACK
PUSH P,T1 ;SAVE IT A SEC
PUSHJ P,CMDCH ;DELETE THE RECOGNIZER
MOVEI T1,":" ;GET OUR TERMINATOR
PUSHJ P,CMDIB ;PUT IT IN
POP P,T1 ;GET BACK TERMINATOR
PUSHJ P,CMDIBQ ;PUT THAT IN, TOO, NO TYPEOUT
PUSHJ P,CMDIP ;BACK OVER RECOGNIZER
PUSHJ P,CMDIP ;AND BACK OVER :, TOO
JRST CMDEV0] ;REENTER THE FLOW
CMDEV0: MOVE S1,.CMABP(P2) ;ADDRESS OF BUFFER
PUSHJ P,CMCIN ;READ THE TERMINATOR
CAIN T1,":" ;IS IT THERE?
JRST CMDEV1 ;YES, KEEP GOING
TXNN F,CM%NSF ;ANY SUFFIX REQUIRED?
NOPARS(DVT) ;Invalid device terminator
PUSHJ P,CMDIP ;NO SUFFIX REQUIRED, SPIT OUT TERMINATOR
CMDEV1: PUSHJ P,CMDIN ;PRIME THE PUMP
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
PUSHJ P,CNVSIX ;CONVERT FIELD TO SIXBIT
SKIPT ;O.K. S1/ FIELD NAME
NOPARS(DGS) ;Device name too large
TXNE F,CM%PO ;PARSE ONLY ON FIELD ?
JRST XCOMXR ;YES..RETURN O.K.
DEVCHR S2, ;SEE IF IT EXISTS
SKIPN S2 ;VALID DATA
NOPARS(DNE)
TXNE S2,DV.IN!DV.OUT ;CHECK IF CAN DO INPUT OR OUTPUT
PJRST XCOMXR ;YES..RETURN O.K.
NOPARS(DIO) ;Cant do input or output
DEVBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
757754,,001760 ;BREAK ON :, ALLOW 0-9
400000,,000740 ;ALLOW UC
400000,,000760 ;ALLOW LC
SUBTTL Command Function / .CMQST - Parse a QUOTED STRING
XCMQST: PUSHJ P,CMRQST ;READ THE STRING
NOPARS(NQS) ;Not a quoted string
MOVEI S1,[ASCIZ /quoted string/]
TXNE F,CMQUES ;QUESTION MARK TYPED?
PUSHJ P,HELPER ;YES, GIVE HELP
JRST XCOMXI
;UNQUOTED STRING - TAKES BIT MASK (4 WORDS * 32 BITS) TO SPECIFY BREAKS.
XCMUQS:
CMUQS1: PUSHJ P,CMCIN ;GET A CHAR
IDIVI T1,^D32 ;COMPUTE INDEX TO BIT ARRAY
MOVE T2,BITS(T2)
ADD T1,FNARG
TDNN T2,0(T1) ;BIT ON?
JRST CMUQS1 ;NO, KEEP GOING
PUSHJ P,CMDIP ;YES, PUT CHAR BACK
JRST XCOMXI ;DONE
;ARBITRARY FIELD
XCMFLD: PUSHJ P,CMRATM
CMFLD1: TXNE F,CMQUES ;"?" SEEN?
JRST [PUSHJ P,DOHLP ;YES, DO USER MESSAGE
JRST CMRTYP]
JRST XCOMXR ;LEAVE FIELD IN ATOM BUFFER
;ACCOUNT
XCMACT: MOVEI T1,USRBRK ;SAME BREAK SET AS USER NAME FIELD
PUSHJ P,CMRFLD ;READ FIELD
JRST CMFLD1 ;FINISH LIKE ARBITRARY FIELD
SUBTTL Command Function / .CMNOD - Parse a NODE Specification
XCMNOD: PUSHJ P,CMRATM ;GET AN ATOM
TXNE F,CMQUES ;DID HE TYPE A QUESTION MARK?
PUSHJ P,NODHLP ;YES, TYPE THE HELP TEXT(S)
TXNE F,CM%ESC ;WANT RECOGNITION?
JRST [PUSHJ P,CMDIP ;YES, BACK UP TO RECOGNIZER
PUSHJ P,CMCIN ;GET THE RECOGNIZER
PUSH P,T1 ;SAVE IT
PUSHJ P,CMDCH ;DELETE IT
MOVEI T1,":" ;GET TERMINATOR
PUSHJ P,CMDIB ;PUT IT IN
PUSHJ P,CMDIB ;TWICE
POP P,T1 ;GET BACK RECOGNIZER
PUSHJ P,CMDIBQ ;PUT THAT BACK IN, NO TYPEOUT
PUSHJ P,CMDIP ;BACK UP OVER RECOGNIZER
PUSHJ P,CMDIP ;AND OVER 1 :
PUSHJ P,CMDIP ;AND OVER THE OTHER
JRST CMNOD1] ;REENETER FLOW
CMNOD1: MOVE S1,.CMABP(P2) ;GET THE BYTE POINTER
ILDB S2,S1 ;GET THE FIRST BYTE
SKIPN S2 ;BETTER NOT BE NULL
JRST ILLNOD ;IMPROPER NODE NAME
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
MOVEI S2,^D8 ;TRY AS AN OCTAL NUMBER
PUSHJ P,NUMIN ;READ IT
JUMPT CMNOD2 ;WINS, CHECK LEGALITY
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
PUSHJ P,CNVSIX ;CONVERT BUFFER TO SIXBIT
SKIPT ;O.K.. CONTINUE
ILLNOD: NOPARS (NNC) ;Invalid node name
CMNOD2: MOVEM S2,CRBLK+CR.RES ;SAVE AS RESULT (SIXBIT OR #)
MOVE T2,ATBPTR ;GET POINTER TO END OF ATOM BUFFER
IBP T2 ;POINT AT TERMINATOR
CAME S1,T2 ;OUR POINTER END THE SAME PLACE?
JRST ILLNOD ;NO, LOSE!
PUSHJ P,CMCIN ;GET NEXT CHAR AFTER FIELD
CAIN T1,":" ;BEGINING OF TERMINATOR?
JRST CMNOD3 ;GOT ONE : GO LOOK FOR THE OTHER
CAIN T1,"_" ;NO, HOW ABOUT OTHER STYLE
JRST CMNOD4 ;LOOKS GOOD KEEP GOING
TXNN F,CM%NSF ;NO SUFFIX REQUIRED?
JRST ILLNO1 ;NOPE, QUIT (IE: IT WAS REQUIRED)
PUSHJ P,CMDIP ;BACK UP OVER THE TERMINATOR
JRST CMNOD4 ;AND FINISH UP
CMNOD3: PUSHJ P,CMCIN ;READ NEXT CHAR AFTER THE :
CAIN T1,CMHLPC ;IS IT ?
PUSHJ P,NODHLP ;YES, GIVE SOME HELP
TXNE F,CM%ESC ;WANT RECOGNITION?
JRST [PUSH P,T1 ;SAVE RECOGNIZER
PUSHJ P,CMDCH ;DELETE IT
MOVEI T1,":" ;GET EXTRA DELIMITER
PUSHJ P,CMDIB ;PUT IT IN BUFFER
POP P,T1 ;GET BACK RECOGNIZER
PUSHJ P,CMDIBQ ;PUT THAT IN, NO TYPEOUT
PUSHJ P,CMDIP ;BACK OVER RECOGNIZER
JRST CMNOD4] ;BACK IN LINE
CAIE T1,":" ;IS IT THE SECOND : ?
ILLNO1: NOPARS(INT) ;Invalid node terminator
CMNOD4: PUSHJ P,CMDIN ;PRIME THE CHARACTER PUMP
TXNE F,CM%PO ;PARSE ONLY?
JRST XCOMXR ;YES, JUST RETURN WITH RESULT
MOVE T1,[XWD .NDRNN,T2] ; MAKE SURE THAT THIS NODE NUMBER EXISTS
MOVEI T2,2 ;2 ARGS
MOVE T3,CRBLK+CR.RES ;NODE NUMER WE JUST PARSED
NODE. T1, ;TRY IT FOR EXISTANCE
NOPARS(NSN) ;No such node
JRST XCOMXR ;A GOOD NODE NUMBER, RETURN
;HERE IF ? TYPED DURING NODE NAME PARSE
NODHLP: TXO F,CMQUES ;NOTE IT
MOVEI S1,[ASCIZ /Node name/] ;THE DEFAULT TEXT
PUSHJ P,HELPER ;HELP THE USER
POPJ P, ;NEVER GET HERE (HELPER DOESN'T RETURN)
;INDIRECT FILESPEC (INTERNAL CALL)
CMATFI:
TXO F,CMINDF ;NOTE GETTING INDIRECT FILE
JRST XCMIFI ;AND HANDLE AS INPUT FILE
XCMOFI:
XCMIFI:
XCMFIL: PUSHJ P,CMRFIL ;GET FILE SPECIFICATION
JXN F,CMQUES,CMFHLP ;IF THEY WANT HELP, GIVE IT TO THEM
JXN F,CM%ESC,[PUSHJ P,CMDCH ;ALLOW ESCAPE AS VALID TERMINATOR
PUSHJ P,TIELCH
JRST XFIL.1 ] ;RETURN IN LINE
XFIL.1: PUSHJ P,FILIN ;GET FILE SPEC
NOPARS(IFS) ;Invalid file spec
MOVE T2,ATBPTR ;GET POINTER TO ATOM BUFFER END
IBP T2 ;BUMP PAST TERMINATOR
CAME T2,XXXPTR ;DOES IT MATCH?
NOPARS(IFS) ;Invalid file spec
TXZE F,CMINDF ;ARE WE DOING INDIRECT FILE?
RETSKP ;YES , RETURN FOR PROCESSING
JRST XCOMXI ;OTHERWISE, DONE
FILIN: PUSHJ P,.SAVE1 ;SAVE A REG
LOAD S2,.CMGJB(P2),CM%GJB ;GET ADDR OF FD
MOVEM S2,CRBLK+CR.RES ;SAVE IT FOR CALLER
MOVE P1,S2 ;AND REMEMBER IT
MOVX S1,FDXSIZ ;NOW ZERO IT OUT
STORE S1,.FDLEN(S2),FD.LEN ;STORE LENGTH INTO FD
MOVEI S1,.FDNAT ;GET NATIVE FD TYPE
STORE S1,.FDLEN(S2),FD.TYP ;STORE THE TYPE
SKIPN S1,.FDSTR(P1) ;SEE IF USER SUPPLIED A DEFAULT DEVICE
MOVSI S1,'DSK' ;NO, SUPPLY DEFAULT DEVICE
STORE S1,.FDSTR(P1) ;STORE DEFAULT DEVICE
MOVE T1,.CMABP(P2) ;GET ATOM BUFFER POINTER
MOVEM T1,XXXPTR ;STORE IT
PUSHJ P,FTOKEN ;GET FIRST FILE TOKEN
CAIE T2,':' ;IS FIRST PART A DEVICE
JRST FILI.1 ;NO
MOVEM T1,.FDSTR(P1) ;STORE STRUCTURE NAME
PUSHJ P,FTOKEN ;YES, LOAD NEXT TOKEN
FILI.1: JUMPN T1,FILI.2 ;IF WE HAVE SOMETHING, IT MUST BE FILENAM
CAIE T2,'[' ;IF NOT, EXPECT A PPN HERE
JRST FILI.4 ;CHECK FOR SUFFICIENT FILE-SPEC
MOVE S1,XXXPTR ;GET POINTER TO PPN
PUSHJ P,DBP ;DECREMENT POINTER
MOVE T1,S1 ;GET THE POINTER
MOVEI T2,.FDPPN(P1) ;POINT TO DESTINATION
HRLI T2,5 ;AND SET MAXIMUM DEPTH FOR SFD'S
PUSHJ P,PATHIN ;PARSE PATH
POPJ P, ;PASS ON FAILURE
PUSHJ P,FTOKEN ;AND GET NEXT PART
FILI.2: SKIPE T1 ;IF NO FILE NAME, LOOK FOR EXTENSTION
STORE T1,.FDNAM(P1) ;STORE NAME
CAIE T2,'.' ;IS THERE AN EXTENSION?
JRST FILI.3 ;NO
PUSHJ P,FTOKEN ;GET EXTENSION
STORE T1,.FDEXT(P1) ;AND STORE IT
FILI.3: CAIE T2,'[' ;HAVE WE GOT A PPN?
JRST FILI.4 ;CHECK FOR SUFFICIENT FILE-SPEC
MOVE S1,XXXPTR ;RELOAD THE POINTER
PUSHJ P,DBP ;DECREMENT IT
MOVE T1,S1 ;PLACE POINTER BACK IN T1
MOVEI T2,.FDPPN(P1) ;POINT TO DESTINATION
HRLI T2,5 ;AND SET MAXIMUM SFD DEPTH
PUSHJ P,PATHIN ;PARSE THE PATH
POPJ P, ;RETURN A FAILURE
IBP XXXPTR ;AND BUMP PAST TERMINATOR
FILI.4: SKIPN .FDNAM(P1) ;MAKE SURE THERE IS A NAME
POPJ P, ;NO NAME, BAD FILE SPEC
RETSKP ;TAKE GOOD RETURN
FTOKEN: SETZM T1 ;CLEAR RESULT
MOVE T3,[POINT 6,T1] ;AND POINT TO STORAGE AREA
FTOK.1: ILDB T2,XXXPTR ;GET A BYTE
PUSHJ P,C7TO6 ;CONVERT TO SIXBIT
CAIG T2,'Z' ;IS IT IN RANGE?
CAIGE T2,'0' ;
POPJ P,0 ;NO
CAILE T2,'9' ;
CAIL T2,'A' ;
SKIPA
POPJ P,0
TXNE T3,<INSVL.(77,BP.POS)> ;IS THERE ROOM?
IDPB T2,T3 ;YES,STORE IT
JRST FTOK.1 ;TRY ANOTHER
C7TO6: CAIL T2,"a" ;IS IT LC?
SUBI T2,40 ;YES
SUBI T2," " ;CONVERT TO SIXBIT
ANDI T2,77 ;MASK IT AND
POPJ P, ;RETURN
;FILESPEC HELP
CMFHLP: TXNE F,CMINDF ;IS IT AN INDIRECT FILE?
JRST [HRROI T1,[ASCIZ / filespec of indirect file/]
JRST CMFH1] ;SPECIAL HELP IF INDIRECT FILESPEC
PUSHJ P,DOHLP ;DO USER MESSAGE
JXN F,CM%SDH,CMRTYP ;SUPPRESS DEFAULT HELP IF REQUESTED
LOAD T2,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
CAXE T2,.CMIFI ;INPUT FILE?
SKIPA S1,[EXP [ASCIZ / output filespec/]] ;NO, OUTPUT
MOVEI S1,[ASCIZ \ input filespec\] ;YES,INPUT
CMFH1: PUSHJ P,CMDSTO
JRST CMRTYP
;TOKEN - ARBITRARY SYMBOL AS SPECIFIED BY FN DATA
XCMTOK: MOVE Q1,FNARG ;GET STRING ADDRESS
TLC Q1,-1 ;TOPS20-style string pointer?
TLCN Q1,-1 ; ..
HRLI Q1,(POINT 7,) ;Yes, fix up
CMTOK1: ILDB Q2,Q1 ;GET NEXT CHAR IN STRING
JUMPE Q2,[PUSHJ P,TIELCH ;SUCCESS IF END OF STRING
JRST XCOMXI]
CMTOK2: PUSHJ P,CMCIN ;GET NEXT CHAR OF INPUT
CAMN T1,Q2 ;MATCH?
JRST [PUSHJ P,STOLCH ;YES, APPEND TO ATOM BUFFER
JRST CMTOK1] ;CONTINUE
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIN T1,CMHLPC ;HELP REQUEST?
JRST [PUSHJ P,DOHLP ;YES
JXN F,CM%SDH,CMRTYP
MOVEI S1,"""" ;TYPE "token"
PUSHJ P,CMDOUT
MOVE S1,FNARG
PUSHJ P,CMDSTO
MOVEI S1,""""
PUSHJ P,CMDOUT
JRST CMRTYP]
NOPARS (NMT) ;Does not match token
SUBTTL PATHIN Routine to Parse TOPS-10 Path Specification
; PATHIN may be called to Parse a Path Specification in the Atom Buffer
; it builds a Path Block up to 6 words in length depending
; on the depth specified in T2 on the call.
; CALL T1/ Byte Pointer to String
; T2/ Length of Destination,,Destination Address
; Uses T1-T4 and XXXPTR
; Destination must not be an AC and Depth must be Less Than 6
; True Return is a Skip Return
; With: PPN and Path Stored Via Calling Arg in T2
; XXXPTR Pointing to Terminating byte ("]") in String
; Error Return is a non skip Return
PATHIN: ILDB S1,T1 ;LOAD FIRST BYTE
CAIE S1,"[" ;MUST BE BRACKET
POPJ P,0 ;ELSE FAIL
PUSHJ P,.SAVE2 ;PRESERVE P1-P2
HRRZ P2,T2 ;GET DESTINATION ADDRESS
HRLI P2,P1 ;P2 IS NOW DESTINATION(P1)
AOBJP T2,.+1 ;ADD ONE TO INCLUDE PPN WITH SFD'S
HLLZ P1,T2 ;GET DEPTH IN P1 LEFT HALF
MOVN P1,P1 ;P1 IS NOW AOBJN POINTER
PUSHJ P,RDPPN ;GET CURRENT PPN IN PTHBLK
MOVEM T1,XXXPTR ;SAVE IN CASE OF PPN FAILURE
MOVE S1,T1 ;GET THE POINTER
MOVEI S2,^D8 ;SET OCTAL RADIX
PUSHJ P,NUMIN ;GET PROJECT NUMBER
SKIPT
HLR S2,PTHBLK+.PTPPN ;USE DEFAULT PROJECT NUMBER
HRLM S2,(P2)
LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;MUST BE COMMA
POPJ P,0 ;FAIL -- PPN NOT NUMERIC
MOVEI S2,^D8 ;SET OCTAL RADIX
PUSHJ P,NUMIN ;GET PROGRAMMER NUMBER
SKIPT
HRR S2,PTHBLK+.PTPPN ;USE DEFAULT PROGRAMMER NUMBER
HRRM S2,0(P2)
LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;MUST BE COMMA OR BRACKET
CAIN T1,"]"
SKIPA
POPJ P,0 ;FAIL -- PPN INCORECT
MOVEM S1,XXXPTR ;STORE UPDATED POINTER
MOVE T1,(P2) ;RECLAIM PPN
JRST PATH.2 ;LOOK FOR SFD'S
PATH.1: PUSHJ P,FTOKEN ;GET TOKEN
PATH.2:SKIPN T1 ;IF FIELD IS ZERO
MOVE T1,PTHBLK+.PTPPN(P1) ;LOAD DEFAULT
JUMPE T1,.POPJ ;FAIL IF DEFAULT WAS 0
MOVEM T1,@P2 ;STORE RESULT
LDB S1,XXXPTR ;GET TERMINATOR
CAIN S1,"]" ;AT END OF PATH?
JRST PATH.3 ;YES -- CLEAR REST OF PATH
CAIE S1,"," ;VALID SEPARATOR?
POPJ P,0 ;NO -- GIVE FAILURE RETURN
AOBJN P1,PATH.1 ;REPEAT UNTIL MAXIMUM DEPTH
POPJ P,0 ;TO DEEP -- GIVE FAILURE
PATH.3: AOBJP P1,PATH.4 ;CLEAR REST OF PATH
SETZM @P2 ;CLEAR REST OF DESTINATION
JRST PATH.3
PATH.4: RETSKP ;GIVE GOOD RETURN
SUBTTL PATH SUPPORT ROUTINES
; RDPATH Routine to Read Path for channel or job
; CALL Using No Arguments
; RETURN With Job's Path in PTHBLK
RDPATH: MOVEI S1,.PTMAX ;CLEAR ANSWER AREA
MOVEI S2,PTHBLK
PUSHJ P,.ZCHNK
SETOM PTHBLK ;REQUEST PATH FOR CURRENT JOB
MOVE S1,[.PTMAX,,PTHBLK] ;POINT TO BLOCK
PATH. S1,
SETZM PTHBLK ;OOPS -- FAILED
POPJ P,0 ;RETURN
; RDPPN routine to read PPN for channel or job
; CALL using no arguments
; RETURN with Job's PPN in PTHBLK
RDPPN: MOVEI S1,.PTMAX ;CLEAR ANSWER AREA
MOVEI S2,PTHBLK
PUSHJ P,.ZCHNK
HRROI S1,.GTPPN ;Want PPN
GETTAB S1, ;Go and get it
SETZB S1,PTHBLK ;Rats
MOVEM S1,PTHBLK+.PTPPN ;Save it
POPJ P,0 ;Return
; PPN (EITHER DIRECTORY OR USER NAME FUNCTION)
XCMDIR:
XCMUSR: ;EQUIVALENT
PUSHJ P,CMRPTH ;GET PATH SPEC INTO ATOM
MOVEI S1,[ASCIZ/[Project,Programmer]/]
JXN F,CMQUES,HELPER ;GIVE HELP IF REQUESTED
JXN F,CM%ESC,[PUSHJ P,CMDCH ;ALLOW ESCAPE AS TERMINATOR
PUSHJ P,TIELCH
JRST XUSR.1] ;RETURN IN LINE
XUSR.1: MOVE T1,.CMABP(P2) ;POINT TO ATOM
MOVEI T2,CRBLK+CR.RES ;POINT TO DESTINATION
PUSHJ P,PATHIN ;PARSE PATH
NOPARS (IUS) ;Invalid user specified
MOVE T1,XXXPTR ;Ensure Entire atom was parsed
CAME T1,ATBPTR
NOPARS (IUS) ;Invalid user specified
JRST XCOMXI ;DONE NOW
;COMMA, ARBITRARY CHARACTER
XCMCMA: MOVEI T1,"," ;SETUP COMMA AS CHARACTER TO FIND
MOVEM T1,FNARG
CMCHR: PUSHJ P,CMCIN ;GET A CHAR
CAIE T1,.CHTAB ;BLANK?
CAIN T1," "
JRST CMCHR ;YES, IGNORE
HRRZ T2,FNARG ;GET SPECIFIED CHAR
CAMN T1,T2 ;THE RIGHT ONE?
JRST XCOMXI ;YES, WIN
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIN T1,CMHLPC ;HELP?
JRST [PUSHJ P,DOHLP
JXN F,CM%SDH,CMRTYP ;JUMP IF SUPPRESSING HELP
MOVEI S1,"""" ;TYPE "char"
PUSHJ P,CMDOUT
HRRZ S1,FNARG
PUSHJ P,CMDOUT
MOVEI S1,""""
PUSHJ P,CMDOUT
JRST CMRTYP]
NOPARS (CMA) ;Not a comma
;DATE AND/OR TIME
;FLAGS IN ARG SPECIFY WHICH
XCMTAD: MOVE Q1,FNARG ;GET ARG
MOVEI T1,DAYBRK ;POINT TO DATE BREAK SET
TXNE Q1,CM%IDA ;WANT A DATE?
PUSHJ P,CMRFLD ;YES..READ DATE FIELD
JXN F,CMQUES,CMTADH ;DO HELP IF REQUESTED
JXN F,CMDEFF,CMTAD1 ;JUMP IF NOW HAVE FIELD DEFAULT
JXN F,CM%ESC,CMAMB ;DING IF ESCAPE WAS TYPED
TXNN Q1,CM%ITM ;WANT THE TIME?
JRST CMTAD1 ;NO..PROCEED
TXNN Q1,CM%IDA ;Did we parse a date also?
JRST CMTAD2 ; No, it was just time
PUSHJ P,CMCIN ; Get the break character
CAIN T1,":" ; Was it a colon?
JRST CMTAD0 ; Yes, go put it back
MOVEI T1," " ; Make sure it was a space
PUSHJ P,STOLCH ; . . . that ended the field
CMTAD0: PUSHJ P,CMDIP ; Put the break character back
CMTAD2: MOVEI T1,TIMBRK ;POINT TO TIME BREAK SET
PUSHJ P,CMRFLD ;READ THE FIELD
JXN F,CMQUES,CMTADH ;DO HELP
JXN F,CM%ESC,CMAMB ;DING IF ESCAPE WAS TYPED
CMTAD1: MOVE S1,.CMABP(P2) ;POINT TO THE ATOM
MOVE S2,FNARG ;GET THE FLAGS
PUSHJ P,XDATIM ;GET PROPER ARGS
MOVE T1,S1 ;GET POSSIBLE ERROR CODE
;OR UPDATED POINTER
JUMPF XCOMNE ;PROCESS ERROR IF ANY
LDB T1,T1 ;GET THE TERMINATING BYTE
SKIPE T1 ;MUST BE A NULL
NOPARS(IDT) ;ELSE INVALID DATE/TIME
MOVEM S2,CRBLK+CR.RES ;STORE RESULT
JRST XCOMXR
;TIME/DATE HELP
CMTADH: PUSHJ P,DOHLP ;DO USER TEXT
JXN F,CM%SDH,CMRTYP ;CHECK SUPPRESS DEFAULT
LOAD T1,Q1,<CM%IDA+CM%ITM> ;GET FLAGS
MOVE S1,[[ASCIZ //]
[ASCIZ / time/]
[ASCIZ / date/]
[ASCIZ / date and time/]](T1)
PUSHJ P,CMDSTO ;PRINT APPROPRIATE MESSAGE
JRST CMRTYP
DAYBRK: 777777,,777760 ;Break on all control
777654,,001760 ;Allow + - 0-9
400000,,000760 ;Allow A-Z
400000,,000760 ;Allow a-z
TIMBRK: 777777,,777760 ;Break on all control
777774,,000760 ;Allow 0-9 and :
777777,,777760 ;Break on A-Z
777777,,777760 ;Break on a-z
;LOCAL ROUTINE TO SETUP BYTE PTR TO TABLE STRING AND GET FLAGS
; T2/ ADDRESS OF STRING
; PUSHJ P,CHKTBS
; T1/ FLAGS
; T2/ BYTE POINTER TO STRING
CHKTBS: HRLI T2,(POINT 7) ;SETUP P AND S FIELDS
SKIPE T1,0(T2) ;CHECK FIRST WORD OF STRING
TXNE T1,177B6 ;FIRST CHAR 0 AND WORD NOT ALL-0?
TDZA T1,T1 ;NO, MAKE FLAGS ALL 0
AOS T2 ;YES, HAVE FLAGS, ADJUST BYTE PTR
POPJ P,0
> ;END TOPS10 CONDITIONAL
SUBTTL CMDOUT - CHARACTER OUTPUT FOR TERMINALS AND FILES
;THIS ROUTINE WILL DUMP A CHARACTER TO THE TERMINAL OR A FILE
;DEPENDING ON THE JFN IN THE TEXTI ARGUMENT BLOCK
IFN FTUUOS,<
CMDOUT: HRRZ S2,JFNWRD ;GET OUTPUT JFN
CAXN S2,.NULIO ;NULL?
$RETT ;JUST IGNORE IT
CAXN S2,.PRIOU ;PRIMARY OUTPUT TERMINAL?
PJRST K%BOUT ;OUTPUT IT
MOVE S2,S1 ;GET THE CHARACTER
HRRZ S1,JFNWRD ;GET THE OUTPUT JFN
PUSHJ P,F%OBYT ;DUMP THE CHARACTER
JUMPT .POPJ ;O.K.. RETURN
$TEXT (T%TTY,<^M^J?File Output Failed ^E/[-1]/>)
TXO F,CM%NOP ;RETURN FAILURE, NO CHECK ALTERNATIVES
JRST XCOMX2
SUBTTL CMDSTO - STRING OUTPUT TO FILE AND TERMINAL
;This routine will check the output JFN and pass the data to
;the file, terminal or null
CMDSTO: HRRZ S2,JFNWRD ;GET OUTPUT JFN
CAXN S2,.NULIO ;NULL?
$RETT ;JUST RETURN
CAXN S2,.PRIOU ;PRIMARY OUTPUT?
PJRST K%SOUT ;YES.. DUMP THE STRING
MOVE T1,S1 ;GET THE STRING POINTER
STRO.1: ILDB S1,T1 ;GET A BYTE
JUMPE S1,.RETT ;RETURN TRUE
PUSHJ P,CMDOUT ;DUMP THE CHARACTER
JRST STRO.1 ;GET NEXT ONE
>;END FTUUOS
SUBTTL S%SCMP - String Comparison Routine
;CALL IS: S1/ TEST STRING POINTER
; S2/ BASE STRING POINTER
;TRUE RETURN: S1/ COMPARE CODE:
; 1B0 (SC%LSS) - TEST STRING LESS THAN BASE STRING
; 1B1 (SC%SUB) - TEST STRING SUBSET OF BASE STRING
; 1B2 (SC%GTR) - TEST STRING GREATER THAN BASE STRING
; N.O.T.A. MEANS EXACT MATCH
; S2/ UPDATED BASE STRING POINTER, USEFUL IN CASE TEST STRING
; WAS SUBSET
TOPS20 <
S%SCMP: STCMP ;DO THE JSYS
$RETT ;AND RETURN
> ;END TOPS20 CONDITIONAL
TOPS10 <
S%SCMP: PUSHJ P,.SAVET ;SAVE T REGS
DMOVE T1,S1 ;COPY ARGUMENTS
HLRZ T3,T1
CAIN T3,-1
HRLI T1,(POINT 7)
HLRZ T3,T2
CAIN T3,-1
HRLI T2,(POINT 7)
PUSHJ P,USTCMP ;DO THE WORK
DMOVE S1,T1 ;PUT THE ARGUMENTS BACK
$RETT
;STILL IN TOPS10 CONDITIONAL
;STRING COMPARE ROUTINE - REFERENCES PREVIOUS CONTEXT.
; T1/ TEST STRING POINTER
; T2/ BASE STRING POINTER
; PUSHJ P,USTCMP
;RETURN AS FOR .STCMP
USTCMP::ILDB T3,T1 ;GET NEXT BYTE FROM EACH STRING
CAIL T3,"A"+40 ;LC LETTER?
JRST [CAIG T3,"Z"+40
SUBI T3,40 ;YES, CONVERT TO UC
JRST .+1]
ILDB T4,T2
CAIL T4,"A"+40 ;LC LETTER?
JRST [CAIG T4,"Z"+40
SUBI T4,40 ;YES, CONVERT TO UC
JRST .+1]
CAME T3,T4 ;STILL EQUAL?
JRST STRC2 ;NO, GO SEE WHY
JUMPN T3,USTCMP ;KEEP GOING IF NOT END OF STRING
SETZ T1, ;STRINGS ENDED TOGETHER, EXACT MATCH.
POPJ P,0 ;RETURN 0
STRC2: JUMPE T3,[MOVX T1,SC%SUB ;TEST STRING ENDED, IS A SUBSET
ADD T2,[7B5] ;DECREMENT BASE POINTER ONE BYTE
POPJ P,0]
CAMG T3,T4 ;STRINGS UNEQUAL
SKIPA T1,[SC%LSS] ;TEST STRING LESS
MOVX T1,SC%GTR ;TEST STRING GREATER
POPJ P,0
> ;END TOPS10 CONDITIONAL
SUBTTL S%TBLK - Table lookup routine
;CALL IS: S1/ ADDRESS OF TABLE HEADER WORD
; S2/ STRING POINTER TO STRING TO BE FOUND
;
;TRUE RETURN: S1/ ADDRESS OF ENTRY WHICH MATCHED OR WHERE ENTRY WOULD BE
; IF IT WERE IN TABLE
; S2/ RECOGNITION CODE:
; 1B0 (TL%NOM) - NO MATCH
; 1B1 (TL%AMB) - AMBIGUOUS
; 1B2 (TL%ABR) - UNIQUE ABBREVIATION
; 1B3 (TL%EXM) - EXACT MATCH
TOPS20 <
S%TBLK: PUSH P,T1 ;SAVE T1
TBLUK ;DO THE JSYS
POP P,T1 ;RESTORE T1
$RETT ;AND RETURN
> ;END TOPS20 CONDITIONAL
TOPS10 <
S%TBLK: PUSHJ P,.SAVET ;SAVE SOME REGISTERS
DMOVE T1,S1 ;COPY INPUT ARGUMENTS
PUSHJ P,XTLOOK ;DO THE WORK
DMOVE S1,T1 ;RE-COPY ARGUMENTS
$RETT ;AND RETURN
;WORKER ROUTINE - MAY BE CALLED INTERNALLY.
; RETURNS +1 SUCCESS, ACS AS ABOVE
;INTERNAL AC USAGE:
; T1/ TEST STRING FROM CALL
; T2/ STRING FROM TABLE
; T3/ CLOBBERED BY USTCMP
; T4/ " "
; P1/ CURRENT TABLE INDEX
; P2/ ADDRESS OF TABLE INDEXED BY P1 - USED FOR INDIRECTION
; P3/ INDEX INCREMENT FOR LOG SEARCH
; P4/ SIZE OF TABLE
XTLOOK::PUSHJ P,.SAVE4 ;PRESERVE ACS
$SAVE P5
HLRZ T3,T2 ;CHECK STRING POINTER
CAIE T3,-1 ;LH 0 OR -1?
CAIN T3,0
HRLI T2,(POINT 7) ;YES, FILL IN
MOVEM T2,STRG
MOVEI P2,1(T1) ;CONSTRUCT ADDRESS OF FIRST ENTRY
HRLI P2,P1 ;MAKE IT INDEXED BY P1
HLRZ P4,0(T1) ;GET PRESENT SIZE
MOVE P3,P4 ;INITIAL INCREMENT IS SIZE
MOVE P1,P4 ;SET INITIAL INDEX TO SIZE/2
ASH P1,-1
JUMPE P4,TABLKX ;IF TABLE EMPTY THEN NO MATCH
TABLK0: HLRZ T2,@P2 ;GET STRING ADR FROM TABLE
PUSHJ P,CHKTBS ;CONSTRUCT POINTER
MOVE T1,STRG ;GET TEST STRING
PUSHJ P,USTCMP ;COMPARE
JUMPN T1,TABLK1 ;JUMP IF NOT EXACTLY EQUAL
TABLKF: HLRZ T2,@P2 ;GET STRING ADDRESS
PUSHJ P,CHKTBS ;GET FLAGS
JXN T1,CM%NOR,TABLKM ;MAKE IT AMBIG IF NOREC ENTRY
MOVX T2,TL%EXM ;EXACTLY EQUAL, RETURN CODE
JRST TABLKA
TABLKM: SKIPA T2,[TL%AMB] ;AMBIGUOUS RETURN
TABLKX: MOVX T2,TL%NOM ;NO MATCH RETURN
TABLKA: MOVEI T1,@P2 ;RETURN ADR WHERE ENTRY IS OR SHOULD BE
POPJ P,
;STRING MAY BE UNEQUAL OR A SUBSET, SEE WHICH
TABLK1: JXE T1,SC%SUB,TABLKN ;UNEQUAL, GO SETUP NEXT PROBE
TABLK3: MOVEM T2,REMSTR ;SUBSTRING, SAVE REMAINDER
JUMPE P1,TABLK2 ;JUMP IF THIS FIRST ENTRY IN TABLE
MOVEI T1,@P2 ;CHECK NEXT HIGHER ENTRY IN TABLE
HLRZ T2,-1(T1) ;GET ITS STRING ADDRESS
PUSHJ P,CHKTBS ;BUILD BYTE PTR
MOVE T1,STRG ;GET TEST STRING
PUSHJ P,USTCMP ;TEST PREVIOUS ENTRY
JUMPE T1,[SOJA P1,TABLKF] ;EXACTLY EQUAL, DONE. FIX INDEX.
JXN T1,SC%GTR,TABLK2 ;IF LESS THEN HAVE FOUND HIGHEST SUBSTR
SOJA P1,TABLK3 ;STILL A SUBSTR, CHECK HIGHER
;NOW POINT AT HIGHEST ENTRY WHICH IS A SUBSTR. IF THERE IS AN EXACT
;MATCH, IT IS BEFORE ALL SUBSETS AND HAS ALREADY BEEN FOUND
TABLK2: MOVEI T1,@P2 ;CHECK NEXT ENTRY FOR AMBIGUOUS
CAIL P1,-1(P4) ;NOW AT LAST ENTRY IN TABLE?
JRST TBLK2A ;YES, THIS ENTRY IS DISTINCT
HLRZ T2,1(T1) ;GET STRING ADR OF NEXT ENTRY
PUSHJ P,CHKTBS ;BUILD BYTE PTR
MOVE T1,STRG ;GET TEST STRING
PUSHJ P,USTCMP ;COMPARE NEXT LOWER ENTRY
JUMPE T1,[$STOP(BTF,Bad table format)] ;EXACT MATCH,TABLE IS BAD
JXN T1,SC%SUB,TABLKM ;NEXT ENTRY NOT DISTINCT, DO AMBIG RETURN
TBLK2A: HLRZ T2,@P2 ;CHECK FLAGS FOR THIS ENTRY
PUSHJ P,CHKTBS
JXN T1,CM%NOR,TABLKM ;FAIL IF NOREC BIT SET
MOVX T2,TL%ABR ;GIVE LEGAL ABBREVIATION RETURN
MOVE T3,REMSTR ;RETURN PTR TO REMAINDER OF STRING
JRST TABLKA
;HERE WHEN PROBE NOT EQUAL
TABLKN: CAIG P3,1 ;INCREMENT NOW 1?
JRST [JXN T1,SC%LSS,TABLKX ;YES, NO MATCH FOUND
AOJA P1,TABLKX] ;IF STRING GREATER, BUMP ADR FOR INSERT
AOS P3 ;NEXT INC = <INC+1>/2
ASH P3,-1
TXNE T1,SC%GTR ;IF LAST PROBE LOW, ADD INCREMENT
ADD P1,P3
TXNE T1,SC%LSS
SUB P1,P3 ;LAST PROBE HIGH, SUBTRACT INCR
TBLKN1: CAIL P1,0(P4) ;AFTER END OF TABLE?
JRST [MOVX T1,SC%LSS ;YES, FAKE PROBE TOO HIGH
JRST TABLKN]
JUMPGE P1,TABLK0 ;IF STILL WITHIN TABLE RANGE, GO PROBE
MOVX T1,SC%GTR ;BEFORE START OF TABLE, FAKE LOW PROBE
JRST TABLKN
> ;END TOPS10 CONDITIONAL
SUBTTL S%TBAD - Table Add Routine
;THIS ROUTINE IS DESIGNED TO ADD AN ENTRY TO A COMMAND
;TABLE AND IS CALLED WITH THE FOLLOWING INFO
;
; CALL WITH: S1/ ADDRESS OF TABLE HEADER
; S2/ ADDRESS OF ENTRY TO BE ADDED
;
;
; RETURNS TRUE: S1/ ADDRESS IN TABLE OF NEW ENTRY IN AC1
;
; RETURNS FALSE: S1/ ERROR CODE
;
;POSSIBLE ERRORS: ERTBF$ -- TABLE IS FULL
; EREIT$ -- ENTRY ALREADY IN TABLE
;
;
TOPS20 <
S%TBAD: TBADD ;DO THE JSYS
ERJMP TBAD.1 ;TRAB THE ERROR JUMP
$RETT ;RETURN TRUE
TBAD.1: MOVEI S1,.FHSLF ;GET THE LAST ERROR
GETER ;GET THE LAST ERROR
HRRZ S2,S2 ;GET JUST THE CODE
MOVEI S1,EREIT$ ;ENTRY ALREADY IN TABLE
CAIN S2,TADDX1 ;WAS IT TABLE IS FULL
MOVEI S1,ERTBF$ ;TABLE IS FULL
$RETF
>;END TOPS20 CONDITIONAL
TOPS10 <
S%TBAD: PUSHJ P,.SAVET ;SAVE THE T REGS
MOVEM S1,TBADDR ;SAVE TABLE ADDRESS
MOVEM S2,ENTADR ;SAVE ENTRY ADDRESS
HLRZ S2,S2 ;BUILD STRING POINTER FOR STRING
HRLI S2,(POINT 7,0) ;FINISH OFF POINTER
PUSHJ P,S%TBLK ;CHECK FOR ENTRY IN TABLE
TXNE S2,TL%EXM ;ENTRY IN TABLE
$RETE(EIT) ;ENTRY ALREADY IN TABLE
;S1 ADDRESS WHERE TO PLACE THE ENTRY
MOVE S2,TBADDR ;GET ADDRESS OF TABLE
HLRZ T2,0(S2) ;GET NUMBER OF ENTRIES IN USE
AOS T2 ;BUMP THE COUNT
HRRZ T1,0(S2) ;GET THE TABLE SIZE
CAMLE T2,T1 ;ROOM IN TABLE
$RETE(TBF) ;TABLE IS FULL
HRLM T2,0(S2) ;UPDATE THE ENTRY COUNT
ADD T2,S2 ;COMPUTE NEW END OF TABLE
TBAD.1: CAML S1,T2 ;AT HOLE:
JRST [ MOVE T1,ENTADR ;YES..INSERT THE ENTRY
MOVEM T1,0(S1) ;PLACE IN TABLE
$RETT] ;RETURN TRUE
MOVE T1,-1(T2) ;MOVE TABLE TO CREATE HOLE
MOVEM T1,0(T2) ;PLACE IN NEW LOCATION
SOJA T2,TBAD.1 ;CHECK NEXT ENTRY
>;END TOPS10 CONDITIONAL
SUBTTL S%TBDL - Table Delete Routine
;THIS ROUTINE IS DESIGNED TO DELETE AN ENTRY TO A COMMAND
;TABLE AND IS CALLED WITH THE FOLLOWING INFO
;
; CALL WITH: S1/ ADDRESS OF TABLE HEADER
; S2/ ADDRESS OF ENTRY TO BE DELETED
;
;
; RETURNS TRUE: S1/ ADDRESS IN TABLE OF NEW ENTRY IN AC1
;
; RETURNS FALSE: S1/ ERROR CODE
;
;POSSIBLE ERRORS: ERTBF$ -- TABLE IS FULL
; ERITE$ -- INVALID TABLE ENTRY
;
;
TOPS20 <
S%TBDL: TBDEL ;DO THE JSYS
ERJMP TBDL.1 ;TRAB THE ERROR JUMP
$RETT ;RETURN TRUE
TBDL.1: MOVEI S1,.FHSLF ;GET THE LAST ERROR
GETER ;GET THE LAST ERROR
HRRZ S2,S1 ;GET JUST THE CODE
MOVX S1,ERTBF$ ;TABLE IS FULL
CAIN S2,TDELX2 ;ENTRY ALREADY IN TABLE
MOVX S1,ERITE$ ;ENTRY ALREADY IN TABLE
$RETF
>;END TOPS20 CONDITIONAL
TOPS10 <
S%TBDL: PUSHJ P,.SAVET ;SAVE THE T REGS
HLRZ T2,0(S1) ;GET USED COUNT
MOVE T1,T2 ;PLACE IN T1
SOSGE T1 ;DECREMENT..SKIP IF NOT ZERO
$RETE(TBF) ;FALSE RETURN..TABLE IS FULL
ADD T2,S1 ;COMPUTE END OF TABLE
CAILE S2,(S1) ;ENTRY IN TABLE
CAMLE S2,T2 ;MAKE SURE
$RETE(ITE) ;INVALID TABLE ENTRY
HRLM T1,0(S1) ;SAVE COUNT
JUMPE T1,TBDL.1 ;TABLE EMPTY
HRLI S2,1(S2) ;COMPACT TABLE
BLT S2,-1(T2) ;MOVE THE TABLE
TBDL.1: SETZM 0(T2) ;CLEAR EMPTY WORD AT END
$RETT ;RETURN TRUE
>;END TOPS10 CONDITIONAL
SUBTTL CNTDT,CNVDT DATE/TIME CONVERSION ROUTINES
;CNTDT CONVERTS UDT TO TWO WORD DATE/TIME
;ACCEPTS S1/ UDT
;RETURNS S1/ TIME IN MILLISECONDS
; S2/ DATE IN SYSTEM FORMAT
CNTDT:: PUSHJ P,.SAVET ;SAVE THE TEMPS WE USE
MOVE T1,S1 ;PUT UDT IN S1
PUSHJ P,.CNTDT ;CONVERT IT
DMOVE S1,T1 ;RETURN SECONDS SINCE MIDNIGHT
$RETT ;AND DATE IN SYSTEM FORMAT
;CNVDT CONVERTS TWO WORD DATE/TIME TO UDT
;ACCEPTS S1/ TIME IN MILLISECONDS
; S2/ DATE IN SYSTEM FORMAT
;RETURNS S1/ UDT
CNVDT:: PUSHJ P,.SAVET ;SAVE THE TEMPS WE USE
DMOVE T1,S1 ;GET SECONDS AND DATE
PUSHJ P,.CNVDT
MOVE S1,T1 ;RETURN THE UDT
$RETT
SUBTTL XDATIM DATE/TIME PARSING ROUTINES FOR TOPS10
;DEFINE SPECIAL ACs REQUIRED BY THESE ROUTINES
C==13 ;LAST CHARACTER AC
N==14 ;THE RESULT GOES HERE
E==15 ;NOT USED
.FP==16 ;FRAME POINTER
;XDATIM CONVERTS AN ASCII STRING TO INTERNAL FORMAT DATE (UDT)
;ACCEPTS S1/ POINTER TO ASCII STRING
; S2/ (CM%IDA!CM%ITM!CM%NCI+Address)
;RETURNS TRUE S1/ UPDATED POINTER
; S2/ UDT
; FALSE S1/ ERROR CODE
XDATIM: $SAVE <C,N,E,.FP> ;SAVE SPECIAL REGS
MOVEM P,.FP ;SAVE THE PDL
TLC S1,777777 ;MAKE -1 A REAL POINTER
TLCN S1,777777
HRLI S1,(POINT 7)
TXNE S2,CM%FUT ;Future time wanted?
JRST [PUSHJ P,.DATIF ;Yes, scan future time
JRST XDAT.1] ;Go join finish code
TXNE S2,CM%PST ;Past time wanted?
JRST [PUSHJ P,.DATIP ;Yes, scan past time
JRST XDAT.1] ;Go join finish code
PUSHJ P,.DATIM ;Do the work for the default case
XDAT.1: MOVE T1,S2 ;POSITION THE FLAGS
SKIPE FLFUTR ; If time relative
JRST XDAT.2 ; There is no need to convert
PUSH P,S1 ; Save the byte pointer
TOPS10 <
MOVX S1,%CNGMT ; Offset to GMT
GETTAB S1, ; Read it
SETZ S1, ; Not there
ADDM S1,N ; Convert to GMT
>;;End TOPS10 Conditional
TOPS20 <
MOVX S1,.SFTMZ ; Get the local time zone
TMON ; . . .
MOVX S1,<^D3600> ; Get the number of seconds/hour
IMUL S1,S2 ; Calculate number of seconds
$CALL .SC2UD ; Convert to UDT format
ADDM S1,N ; Convert local time to GMT
>;;End TOPS20 Conditional
POP P,S1 ; Restore the byte pointer
XDAT.2: MOVE S2,N ;GET THE ANSWER
SETOM TF ;We are true so far...
TXNE T1,CM%NCI ;WANT ONLY UDT?
$CALL DATNCI ;NO..ALSO RETURN 3 WORD BLOCK
$RET ;AND RETURN
;DEFINE AN ERROR PROCESSING ROUTINE TO GET US BACK TO CALLER
.ERMSG: MOVEM TF,.LGEPC ;SAVE THE PC
MOVEM S1,.LGERR ;SAVE THE ERROR
MOVE P,.FP ;RESTORE THE PDL
MOVX TF,FALSE
POPJ P,0
;DEFINE A LOCAL ROUTINE TO GET THE NEXT CHARACTER FROM STRING
.TIALT: ILDB C,S1 ;GET THE NEXT CHARACTER
POPJ P,
SUBTTL DATNCI ROUTINE TO RETURN 3 WORD TIME BLOCK
;DATNCI WILL BE CALLED IF CM%NCI WAS SET ON THE CALL
DATNCI: HRRZ T1,T1 ;GET THE DESTINATION ADDRESS
CAIG T1,17 ;CANT BE IN THE ACs
$RETE (NCI) ;ELSE THATs AN ERROR
MOVE T2,VAL9 ;GET CENTURY
IMULI T2,^D100 ;MAKE IT YEARS
MOVE T3,VAL8 ;GET DECADES
IMULI T3,^D10 ;MAKE YEARS ALSO
ADD T3,T2 ;COMBINE THEM
ADD T3,VAL7 ;GET THE YEAR FIELD
HRL T2,T3 ;PLACE IN LEFT HALF
HRR T2,VAL6 ;GET THE MONTH
MOVEM T2,0(T1) ;SAVE IN THE BLOCK
HRLZ T2,VAL5 ;DAY OF THE MONTH TO LEFT HALF
MOVEM T2,1(T1) ;SAVE THE DAY OF MONTH
HLRZ T2,S2 ;GET ONLY THE DATE
IDIVI T2,7 ;CONVERT TO DAY OF WEEK
ADDI T3,2 ;MAKE MONDAY = 0
CAIL T3,7 ;SATURDAY = 6
SUBI T3,7
HRRM T3,1(T1) ;SAVE DAY OF THE WEEK
MOVE T2,VAL4 ;GET HOURS
IMULI T2,^D60 ;CONVERT TO MINUTES
ADD T2,VAL3 ;ADD THE MINUTES
IMULI T2,^D60 ;CONVERT TO SECONDS
ADD T2,VAL2 ;ADD THE SECONDS
MOVEM T2,2(T1) ;SAVE THIRD WORD
$RETT
SUBTTL DATIM MACROS AND STORAGE DECLARATION
ECHO$W==0 ;MAKE NULL CONDITIONAL
;DEFINE THE ERROR PROCESSING MACROS
DEFINE M$FAIN(COD,TXT) <M$FAIL(<COD>,<TXT>)>
DEFINE M$FAIL(COD,TXT) <
ND ER'COD'$,ERIDT$ ;;DEFAULT TO INVALID DATE TIME
E$$'COD': JSP TF,[MOVEI S1,ER'COD'$
JRST .ERMSG]>
;DEFINE THE GLOBAL STORAGE REFERENCED BY THESE ROUTINES
GLOB LOGTIM ;TIME JOB WAS LOGGED IN
;DEFINE THE LOCAL STORAGE USED BY THESE ROUTINES
$DATA VAL1 ;DEFAULT VALUES FLAG
$DATA VAL2 ;SECONDS
$DATA VAL3 ;MINUTES
$DATA VAL4 ;HOURS
$DATA VAL5 ;DAY OF MONTH (0 - 30)
$DATA VAL6 ;MONTH OF YEAR (0 - 11)
$DATA VAL7 ;YEAR
$DATA VAL8 ;DECADE
$DATA VAL9 ;CENTURY
$DATA NOW
$DATA FLFUTD
$DATA FLFUTR
$DATA FLNULL
$DATA FLNEG
$DATA MASK
$DATA .LASWD
$DATA .NMUL
SUBTTL SUBROUTINES FOR COMMAND INPUT - GET DATE/TIME
;.DATIF -- ROUTINE TO SCAN DATE AND TIME ARGUMENT IN FUTURE
;.DATIG -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIF/.DATIG
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIF: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DATIG: SETZM FLFUTR ;CLEAR FUTURE RELATIVE
SETZM FLFUTD ;SET DEFAULT
AOS FLFUTD ; TO FUTURE
CAIE C,"+" ;SEE IF FUTURE RELATIVE
JRST DATIF1 ;NO--JUST GET DATE-TIME
AOS FLFUTR ;YES--SET FUTURE REL FLAG
PUSHJ P,.TIAUC ;GET ANOTHER CHARACTER
DATIF1: CAIN C,"-" ;Confused user?
JRST DATIF2 ;Yes, skip the real stuff
PUSHJ P,DATIM ;GET DATE/TIME
CAMGE N,NOW ;SEE IF IN FUTURE
DATIF2: JRST E$$NFT ;NO--NOT FUTURE ERROR
POPJ P, ;RETURN
;.DATIP -- ROUTINE TO SCAN DATE AND TIME ARGUMENT IN THE PAST
;.DATIQ -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIP/.DATIQ
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIP: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DATIQ: SETZM FLFUTR ;CLEAR PAST RELATIVE
SETOM FLFUTD ;SET DEFAULT TO PAST
CAIE C,"-" ;SEE IF PAST RELATIVE
JRST DATIP1 ;NO--JUST GET DATE-TIME
SOS FLFUTR ;YES--SET PAST REL FLAG
PUSHJ P,.TIAUC ;GET ANOTHER CHARACTER
DATIP1: CAIN C,"+" ;Confused user?
JRST DATIP2 ;Yes, skip normal stuff
PUSHJ P,DATIM ;GET DATE/TIME
CAMLE N,NOW ;SEE IF IN PAST
DATIP2: JRST E$$NPS ;NO--NOT PAST ERROR
POPJ P, ;RETURN
;.DATIM -- ROUTINE TO SCAN DATE AND TIME ARGUMENT
;.DATIC -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIM/.DATIC
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIM: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DATIC: SETZM FLFUTR ;CLEAR RELATIVE FLAG
SETZM FLFUTD ;CLEAR DEFAULT FLAG
CAIE C,"+" ;SEE IF FUTURE RELATIVE
JRST DATIC1 ;NO--PROCEED
AOS FLFUTR ;YES--SET FLAG
JRST DATIC2 ;AND PROCEED
DATIC1: CAIE C,"-" ;SEE IF PAST RELATIVE
PJRST DATIM ;NO--JUST GET ABS DATE
SOS FLFUTR ;YES--SET FLAG
DATIC2: PUSHJ P,.TIAUC ;GET NEXT CHAR
;AND FALL INTO DATE/TIME GETTER
;DATIM -- ROUTINE TO INPUT DATE/TIME
;CALL: SET FLFUTR TO -1 IF PAST RELATIVE, 0 IF ABSOLUTE, +1 IF FUTURE RELATIVE
; SIMILARLY FOR FLFUTD TO INDICATE DEFAULT DIRECTION IF FLFUTR=0
; GET NEXT CHARACTER IN C
; PUSHJ P,DATIM
;RETURN WITH TRUE DATE/TIME IN N IN INTERNAL SPECIAL FORMAT
; SETS NOW TO CURRENT DATE/TIME
;USES T1-4, UPDATES C
;
;TYPE-IN FORMATS:
; (THE LEADING +- IS HANDLED BY CALLER)
;
; [ [ DAY IN WEEK ] ]
; [ [ NNND ] ]
; [ [ [ MM-DD [-Y ] ] : ] [HH[:MM[:SS]]] ]
; [ [ [ MMM-DD [-YY ] ] ] ]
; [ [ [ DD-MMM [-YYYY] ] ] ]
; [ MNEMONIC ]
;WHERE:
; D LETTER D
; DD DAY IN MONTH (1-31)
; HH HOURS (00-23)
; MM MONTH IN YEAR (1-12)
; OR MINUTES (00-59)
; MMM MNEMONIC MONTH OR ABBREV.
; SS SECONDS (0-59)
; Y LAST DIGIT OF THIS DECADE
; YY LAST TWO DIGITS OF THIS CENTURY
; YYYY YEAR
; DAY IN WEEK IS MNEMONIC OR ABBREVIATION
; MNEMONIC IS A SET OF PREDEFINED TIMES
;DESCRIBED ABOVE
;FALL HERE FROM .DATIC
DATIM: SKIPE T1,FLFUTR ;SEE IF FORCED DIRECTION
MOVEM T1,FLFUTD ; YES--THAT IMPLIES DEFAULT
SETOM VAL1 ;CLEAR RESULT WORDS
MOVE T1,[VAL1,,VAL2]
BLT T1,VAL9 ; ..
PUSH P,S1 ; Save S1
$CALL I%NOW ;GET CURRENT DATE/TIME
MOVE T1,S1 ; Transfer the time
POP P,S1 ; Restore the various flags
MOVEM T1,NOW ;SAVE FOR LATER TO BE CONSISTENT
CAIL C,"0" ;SEE IF DIGIT
CAILE C,"9" ; ..
JRST .+2 ;NO--MNEMONIC FOR SOMETHING
JRST DATIMD ;YES--GO GET DECIMAL
;HERE IF STARTING WITH ALPHA, MIGHT BE DAY, MONTH, OR MNEMONIC
PUSHJ P,.SIXSC ;GET SIXBIT WORD
JUMPE N,E$$DTM ;ILLEGAL SEPARATOR IF ABSENT [274]
MOVE T1,MNDPTR ;POINT TO FULL TABLE
PUSHJ P,.NAME ;LOOKUP IN TABLE
JRST E$$UDN ;ERROR IF NOT KNOWN
MOVEI N,(T1) ;GET
SUBI N,DAYS ; DAY INDEX
CAIL N,7 ;SEE IF DAY OF WEEK
JRST DATIMM ;NO--LOOK ON
;HERE WHEN DAY OF WEEK RECOGNIZED
SKIPN T1,FLFUTD ;GET DEFAULT DIRECTION
JRST E$$NPF ;ERROR IF NONE
MOVEM T1,FLFUTR ;SET AS FORCED DIRECTION
HLRZ T2,NOW ;GET DAYS
IDIVI T2,7 ;GET DAY OF WEEK
SUB N,T3 ;GET FUTURE DAYS FROM NOW
SKIPGE N ;IF NEGATIVE,
ADDI N,7 ; MAKE LATER THIS WEEK
HLLZ T1,NOW ;CLEAR CURRENT
SKIPL FLFUTD ;SEE IF FUTURE
TROA T1,-1 ;YES--SET MIDNIGHT MINUS EPSILON
SUBI N,7 ;NO--MAKE PAST
HRLZ N,N ;POSITION TO LEFT HALF
ADD N,T1 ;MODIFY CURRENT DATE/TIME
DATIMW: PUSH P,N ;SAVE DATE
PUSHJ P,DATIC ;GO CHECK TIME
HRRZ N,(P) ;NO--USE VALUE IN DATE
POP P,T1 ;RESTORE DATE
HLL N,T1 ; TO ANSWER
;**; [576] Delete one line @ DATIMW + 5L, add lines at same
;**; [576] location. LLN, 9-Sep-76
SKIPG FLFUTR ;[576] SKIP IF FUTURE
JRST DATIMK ;[576] ADJUST PAST RESULT
CAMGE N,NOW ;[576] IF NOT FUTURE, MUST HAVE
;[576] WANTED A WEEK FROM TODAY,
;[576] BUT EARLIER IN THE DAY.
ADD N,[7,,0] ;[576] MAKE TIME NEXT WEEK
JRST DATIMX ;[576] CHECK AND RETURN
DATIMK: MOVE T2,N ;[576] SIMILAR TEST FOR PAST
ADD T2,[7,,0] ;[576] ADD A WEEK TO PAST TIME
CAMG T2,NOW ;[576] WAS TIME OVER A WEEK AGO?
MOVE N,T2 ;[576] YES, USE NEW ONE
JRST DATIMX ;[576] CHECK ANSWER AND RETURN
;HERE IF MONTH OR MNEMONIC
DATIMM: MOVEI N,(T1) ;GET MONTH
SUBI N,MONTHS-1 ; AS 1-12
CAILE N,^D12 ;SEE IF MONTH
JRST DATIMN ;NO--MUST BE MNEMONIC
MOVEM N,VAL6 ;YES--STORE MONTH
CAIE C,"-" ;MUST BE DAY NEXT
JRST E$$MDD ;NO--ERROR
PUSHJ P,.DECNW ;YES--GET IT
JUMPLE N,E$$NND ;ERROR IF NEGATIVE
CAILE N,^D31 ;VERIFY IN RANGE
JRST E$$DFL ;ERROR IF TOO LARGE
MOVEM N,VAL5 ;SAVE AWAY
JRST DATIY0 ;AND GET YEAR IF PRESENT
;HERE IF MNEMONIC
DATIMN: HRRZ T2,T1 ;GET COPY [305]
CAIN T2,SPLGTM ;SEE IF "LOGIN" [505]
SKIPG N,LOGTIM ;AND WE KNOW IT [505]
SKIPA ;NO--PROCEED [505]
JRST DATIMX ;YES--GO GIVE ANSWER [505]
CAIN T2,SPNOON ;SEE IF "NOON" [520]
JRST [HLLZ N,NOW ;YES--GET TODAY [520]
HRRI N,1B18 ;SET TO NOON [520]
PUSHJ P,DATIM1 ;Go to clean up input
JRST DATIMW] ;GO FINISH UP [520]
CAIN T2,SPMIDN ;SEE IF "MIDNIGHT" [520]
JRST [HLLZ N,NOW ;GET TODAY [520]
PUSHJ P,DATIM1 ;Go to clean up input
JRST DATIMO] ;GO SET TO MIDNIGHT [520]
SUBI T2,SPCDAY ;SUBTRACT OFFSET TO SPECIAL DAYS [305]
CAILE T2,2 ;SEE IF ONE OF THREE [305]
JRST E.MDS ;NO--UNSUPPORTED [305]
HLRZ N,NOW ;YES--GET TODAY [305]
ADDI N,-1(T2) ;OFFSET IT [305]
HRLZS N ;POSITION FOR ANSWER [305]
DATIMO: SKIPL FLFUTD ;SEE IF FUTURE [305]
TRO N,-1 ;YES--SET TO MIDNIGHT MINUS EPSILON [305]
JRST DATIMW ;AND GO FINISH UP [305]
;HERE IF UNSUPPORTED MNEMONIC
E.MDS: MOVE N,(T1) ;GET NAME OF SWITCH
M$FAIL (MDS,Mnemonic date/time switch not implemented)
;The purpose of this next routine is to fix a problem created by XDATIM.
;In order to allow the user to type the date and time without the ":"
;normally required by SCAN (from where this code was taken) between the
;date and time, XDATIM places a colon in the string. This fails if
;a mnemonic such as NOON and MIDNIGHT is typed. This routine rips
;that out.
DATIM1: CAIN C," " ;Is there a space next
PUSHJ P,.TIAUC ;Yes, get the next character from the buffer
POPJ P, ;And return
;HERE IF STARTING WITH DECIMAL NUMBER
DATIMD: PUSHJ P,.DECNC ;YES--GO GET FULL NUMBER
JUMPL N,E$$NND ;ILLEGAL IF NEGATIVE
CAIE C,"D" ;SEE IF DAYS
JRST DATIN ;NO--MUST BE -
MOVE T1,FLFUTD ;YES--RELATIVE SO GET FORCING FUNCTION
MOVEM T1,FLFUTR ; AND FORCE IT
JUMPE T1,E$$NPF ;ERROR IF DIRECTION UNCLEAR
CAIL N,1B18 ;VERIFY NOT HUGE
JRST E$$DFL ;ERROR--TOO LARGE
MOVEM N,VAL5 ;SAVE RELATIVE DATE
PUSHJ P,.TIAUC ;GET NEXT CHARACTER (SKIP D)
PUSHJ P,DATIC ;GO CHECK FOR TIME
MOVEI N,0 ;0 IF NONE
HRL N,VAL5 ;INCLUDE DAYS IN LH
JRST DATITR ;GO DO RELATIVE RETURN
;HERE WHEN DIGITS SEEN WITHOUT A FOLLOWING D
DATIN: CAIE C,"-" ;SEE IF DAY/MONTH COMBO
JRST DATIT ;NO--MUST BE INTO TIME
CAILE N,^D31 ;MUST BE LESS THAN 31
JRST E$$DFL ;NO--ERROR
JUMPE N,E$$DFZ ;VERIFY NOT ZERO
MOVEM N,VAL5 ;SAVE VALUE
PUSHJ P,.TIAUC ;SKIP OVER MINUS
CAIL C,"0" ;SEE IF DIGIT NEXT
CAILE C,"9" ; ..
JRST DATMMM ;NO-- MUST BE MNEMONIC MONTH
PUSHJ P,.DECNC ;YES-- MUST BE MM-DD FORMAT
JUMPLE N,E$$NND ;BAD IF LE 0
CAILE N,^D31 ;VERIFY LE 31
JRST E$$DFL ;BAD
EXCH N,VAL5 ;SWITCH VALUES
CAILE N,^D12 ;VERIFY MONTH OK
JRST E$$DFL ;BAD
JRST DATMM1 ;GO STORE MONTH
;HERE WHEN TIME SEEN BY ITSELF
DATIT: CAIN C," " ;Last character a space?
PUSHJ P,.TIALT ;Space over it
PUSHJ P,DATIG ;GET REST OF TIME
M$FAIL(IDT,The comment said this can never happen)
SKIPN FLFUTR ;SEE IF RELATIVE
JRST DATIRN ;NO--GO HANDLE AS ABS.
;HERE WITH DISTANCE IN N
DATITR: SKIPGE FLFUTR ;IF PAST,
MOVN N,N ; COMPLEMENT DISTANCE
ADD N,NOW ;ADD TO CURRENT DATE/TIME
JRST DATIMX ;CHECK ANSWER AND RETURN
;HERE WHEN DD- SEEN AND MNEMONIC MONTH COMING
DATMMM: PUSHJ P,.SIXSC ;GET MNEMONIC
MOVE T1,MONPTR ;GET POINTER TO MONTH TABLE
PUSHJ P,.NAME ;LOOKUP IN TABLE
JRST E$$UDM ;NO GOOD
MOVEI N,(T1) ;GET MONTH
SUBI N,MONTHS-1 ; AS 1-12
;HERE WITH MONTH INDEX (1-12) IN T1
DATMM1: MOVEM N,VAL6 ;SAVE FOR LATER
DATIY0: CAIE C,"-" ;SEE IF YEAR NEXT
JRST DATIRA ;NO--GO HANDLE TIME
;HERE WHEN YEAR NEXT AS ONE, TWO, OR FOUR DIGITS
SETZB N,T1 ;CLEAR DIGIT AND RESULT COUNTERS
DATIY: PUSHJ P,.TIAUC ;GET NEXT DIGIT
CAIL C,"0" ;SEE IF NUMERIC
CAILE C,"9" ; ..
JRST DATIY1 ;NO--MUST BE DONE
IMULI N,^D10 ;ADVANCE RESULT
ADDI N,-"0"(C) ;INCLUDE THIS DIGIT
AOJA T1,DATIY ;LOOP FOR MORE, COUNTING DIGIT
DATIY1: JUMPE T1,E$$ILR ;ERROR IF NO DIGITS
CAIE T1,3 ;ERROR IF 3 DIGITS
CAILE T1,4 ;OK IF 1,2, OR 4
JRST E$$ILR ;ERROR IF GT 4 DIGITS
MOVE T2,N ;GET RESULT
IDIVI T2,^D100 ;SEP. CENTURY
IDIVI T3,^D10 ;SEP. DECADE
CAIG T1,2 ;IF ONE OR TWO DIGITS,
SETOM T2 ; FLAG NO CENTURY KNOWN
CAIN T1,1 ;IF ONE DIGIT,
SETOM T3 ; FLAG NO DECADE KNOWN
MOVEM T4,VAL7 ;SAVE UNITS
MOVEM T3,VAL8 ;SAVE DECADE
MOVEM T2,VAL9 ;SAVE CENTURY
;HERE WITH VAL5-9 CONTAINING DAY, MONTH, YEAR, DECADE, CENTURY
DATIRA: SOS VAL5 ;MAKE DAYS 0-30
SOS VAL6 ;MAKE MONTHS 0-11
PUSHJ P,DATIC ;GET TIME IF PRESENT
SKIPG FLFUTD ;IGNORE ABSENCE
JRST DATIRN ; UNLESS FUTURE
;HERE IF FUTURE WITHOUT TIME
MOVEI T1,^D59 ;SET TO
MOVEM T1,VAL2 ; 23:59:59
MOVEM T1,VAL3 ; ..
MOVEI T1,^D23 ; ..
MOVEM T1,VAL4 ; ..
;HERE WITH VAL2-9 CONTAINING PARSE OR -1 IF TO BE FILLED IN
; STRATEGY IS TO FILL-IN HOLES LESS SIGNIFICANT THAN
; MOST SIGN. FIELD WITH 0; AND TO FILL IN MORE SIGNIFICANT
; HOLES WITH CURRENT VALUE. THEN IF WRONG DIRECTION FROM
; NOW, ADD/SUB ONE TO FIELD JUST ABOVE MOST SIGNIFICANT DIFFERENT
; (FIELD CARRY NOT NEEDED SINCE IT WILL HAPPEN IMPLICITLY).
DATIRN: PUSHJ P,.TICAN ;MAKE SURE NEXT CHAR IS SEPARATOR [542]
SKIPA ;YES--OK [542]
JRST E$$ILC ;NO--FLAG ERROR BEFORE DEFAULTING [542]
MOVE T1,NOW ;GET CURRENT DATE/TIME
PUSHJ P,.CNTDT ;CONVERT TO EASY FORMAT
MOVE T3,T1 ;SAVE MSTIME
IDIVI T3,^D1000 ; AS SECONDS
ADD T2,[^D1964*^D12*^D31] ;MAKE REAL
MOVEI T4,8 ;TRY 8 FIELDS [250]
DATIRB: MOVE T1,T2 ;POSITION REMAINDER
IDIV T1,[1
^D60
^D60*^D60
1
^D31
^D31*^D12
^D31*^D12*^D10
^D31*^D12*^D10*^D10]-1(T4) ;SPLIT THIS FIELD FROM REST [250]
SKIPL VAL1(T4) ;SEE IF DEFAULT [250]
JRST [TLNN T3,-1 ;NO--FLAG TO ZERO DEFAULTS [250]
HRL T3,T4 ; SAVING INDEX OF LAST DEFAULT [250]
JRST DATRIC] ;AND CONTINUE LOOP
SETZM VAL1(T4) ;DEFAULT TO ZERO [250]
TLNN T3,-1 ;SEE IF NEED CURRENT [250]
MOVEM T1,VAL1(T4) ;YES--SET THAT INSTEAD [250]
DATRIC: CAME T1,VAL1(T4) ;SEE IF SAME AS CURRENT [250]
JRST DATIRD ;NO--REMEMBER FOR LATER
CAIN T4,4 ;SEE IF TIME FOR TIME [250]
HRRZ T2,T3 ;YES--GET IT
SOJG T4,DATIRB ;LOOP UNTIL ALL DONE [250]
;HERE WHEN FILLED IN CURRENT FOR SIGNIFICANT DEFAULTS
DATIRD: SKIPGE VAL1(T4) ;SEE IF DEFAULT [250]
SETZM VAL1(T4) ;CLEAR DEFAULT [250]
SOJG T4,DATIRD ;LOOP UNTIL DONE [250]
HLRZ N,T3 ;RECOVER LAST SIGN. DEFAULT-1 [250]
JUMPE N,DATIRR ;DONE IF NONE [250]
PUSHJ P,DATIRM ;MAKE CURRENT DATE, TIME
MOVE T4,FLFUTD ;GET DEFAULT DIRECTION
XCT [CAMGE T1,NOW
JFCL
CAMLE T1,NOW]+1(T4) ;SEE IF OK
JRST DATIRR ;YES--GO RETURN
SKIPG FLFUTD ;NO--SEE WHICH DIRECTION
SOSA VAL2(N) ;PAST
AOS VAL2(N) ;FUTURE
DATIRR: PUSHJ P,DATIRM ;REMAKE ANSWER
MOVE N,T1 ;MOVE TO ANSWER
;HERE WITH FINAL RESULT, CHECK FOR OK
RADIX 10
DATIMX: MOVEI T1,.TDTTM ;SET DATE-TIME [314]
MOVEM T1,.LASWD ; OUTPUTER [314]
CAML N,[<1964-1859>*365+<1964-1859>/4+<31-18>+31,,0] ;[261]
PJRST STRNML ;STORE IN .NMUL AND RETURN [314]
RADIX 8
M$FAIL (DOR,Date/time out of range)
;SUBROUTINE TO MAKE DATE/TIME
DATIRM: MOVE T1,VAL4 ;GET HOURS
IMULI T1,^D60 ;MAKE INTO MINS
ADD T1,VAL3 ;ADD MINS
IMULI T1,^D60 ;MAKE INTO SECS
ADD T1,VAL2 ;ADD SECS
IMULI T1,^D1000 ;MAKE INTO MILLISECS
MOVE T2,VAL9 ;GET CENTURIES
IMULI T2,^D10 ;MAKE INTO DECADES
ADD T2,VAL8 ;ADD DECADES
IMULI T2,^D10 ;MAKE INTO YEARS
ADD T2,VAL7 ;ADD YEARS
IMULI T2,^D12 ;MAKE INTO MONTHS
ADD T2,VAL6 ;ADD MONTHS
IMULI T2,^D31 ;MAKE INTO DAYS
ADD T2,VAL5 ;ADD DAYS
SUB T2,[^D1964*^D12*^D31] ;REDUCE TO SYSTEM RANGE
PJRST .CNVDT ;CONVERT TO INTERNAL FORM AND RETURN
;SUBROUTINE TO GET TIME IF SPECIFIED
;RETURNS CPOPJ IF NO TIME, SKIP RETURN IF TIME
; WITH TIME IN RH(N) AS FRACTION OF DAY
;USES T1-4, N
DATIC: CAIE C," " ;Have a tab?
CAIN C," " ;or a space?
JRST DATI1 ;Yes, continue on
CAIE C,":" ;Colon? (living in the past)
POPJ P, ;NO--MISSING TIME
DATI1: PUSHJ P,.DECNW ;GET DECIMAL NUMBER FOR TIME
;HERE WITH FIRST TIME FIELD IN N
DATIG: JUMPL N,E$$NND ;ERROR IF NEGATIVE [326]
CAIL N,^D24 ; AND GE 24,
JRST E$$DFL ;GIVE ERROR--TOO LARGE
MOVEM N,VAL4 ;SAVE HOURS
CAIE C,":" ;SEE IF MINUTES COMING
JRST DATID ;NO--DONE
PUSHJ P,.DECNW ;YES--GET IT
CAIL N,^D60 ;SEE IF IN RANGE
JRST E$$DFL ;NO--GIVE ERROR
JUMPL N,E$$NND ;ERROR IF NEG
MOVEM N,VAL3 ;SAVE MINUTES
CAIE C,":" ;SEE IF SEC. COMING
JRST DATID ;NO--DONE
PUSHJ P,.DECNW ;GET SECONDS
CAIL N,^D60 ;CHECK RANGE
JRST E$$DFL ;NO--GIVE ERROR
JUMPL N,E$$NND ;ERROR IF NEG
MOVEM N,VAL2 ;SAVE SECONDS
;HERE WITH TIME IN VAL2-4
DATID: SKIPGE T1,VAL4 ;GET HOURS
MOVEI T1,0 ; UNLESS ABSENT
IMULI T1,^D60 ;CONV TO MINS
SKIPL VAL3 ;IF MINS PRESENT,
ADD T1,VAL3 ; ADD MINUTES
IMULI T1,^D60 ;CONV TO SECS
SKIPL VAL2 ;IF SECS PRESENT,
ADD T1,VAL2 ; ADD SECONDS
MOVEI T2,0 ;CLEAR OTHER HALF
ASHC T1,-^D17 ;MULT BY 2**18
DIVI T1,^D24*^D3600 ;DIVIDE BY SECONDS/DAY
MOVE N,T1 ;RESULT IS FRACTION OF DAY IN RH
JRST .POPJ1 ;RETURN
;DATE/TIME ERRORS
M$FAIL (ILC,Illegal character in date/time)
M$FAIL (NFT,Date/time must be in the future)
M$FAIL (NPS,Date/time must be in the past)
M$FAIL (NND,Negative number in date/time)
M$FAIL (NPF,Not known whether past or future in date/time)
M$FAIL (DFL,Field too large in date/time)
M$FAIL (DFZ,Field zero in date/time)
M$FAIL (UDM,Unrecognized month in date/time)
M$FAIL (ILR,Illegal year format in date/time)
M$FAIL (UDN,Unrecognized name in date/time)
M$FAIL (MDD,Missing day in date/time)
M$FAIL (DTM,Value missing in date/time)
;MNEMONIC WORDS IN DATE/TIME SCAN
DEFINE XX($1),<
EXP <SIXBIT /$1/>>
DAYS: XX WEDNESDAY
XX THURSDAY
XX FRIDAY
XX SATURDAY
XX SUNDAY
XX MONDAY
XX TUESDAY
MONTHS: XX JANUARY
XX FEBRUARY
XX MARCH
XX APRIL
XX MAY
XX JUNE
XX JULY
XX AUGUST
XX SEPTEMBER
XX OCTOBER
XX NOVEMBER
XX DECEMBER
SPCDAY: XX YESTERDAY
XX TODAY
XX TOMORROW
SPLGTM: XX LOGIN
SPNOON: XX NOON
SPMIDN: XX MIDNIGHT
SPDATM: XX LUNCH
XX DINNER
LSPDTM==.-DAYS
;POINTERS
MONPTR: IOWD ^D12,MONTHS
MNDPTR: IOWD LSPDTM,DAYS
;.NAME -- LOOKUP NAME IN TABLE ALLOWING FOR UNIQUE ABBREVIATIONS
;ALWAYS CHECK FOR EXACT MATCH FIRST.
;CALL: MOVE N,NAME
; MOVE T1,[IOWD LENGTH,START OF TABLE]
; PUSHJ P,.NAME
; ERROR RETURN IF UNKNOWN OR DUPLICATE
; AND WITH T1.LT.0 IF NOT MATCH, .GT.0 IF SEVERAL MATCHES
; SKIP RETURN IF FOUND WITH T1 POINTING TO ENTRY
; AND WITH LH(T1)=0 IF ABBREVIATION, OR T1.LT.0 IF EXACT MATCH
;USES T2, T3, T4
.NAME: MOVE T2,N ;SET NAME FOR ROUTINE
PJRST .LKNAM ;GO HANDLE IT
;.DECNW -- INPUT A DECIMAL WORD FROM COMMAND STRING
;.DECNC -- DITTO (CHARACTER ALREADY IN C)
;IF IT STARTS WITH #, THEN OCTAL TYPEIN
;TERMINATES AT FIRST NON-DECIMAL CHARACTER
;THROWS AWAY ANY CHARACTERS BEFORE THE LAST 10 OR SO
;CALL: PUSHJ P,.DECNC/.DECNW
; RETURN WITH WORD IN N
;USES T1 UPDATES C (SEPARATOR)
.DECNW: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DECNC: PUSHJ P,.CKNEG ;CHECK IF NEGATIVE
DECIN1: CAIL C,"0" ;SEE IF DECIMAL
CAILE C,"9" ; ..
PJRST DECMUL ;NO--AT END, SO HANDLE SUFFIX
IMULI N,^D10 ;YES--MULTIPLY NUMBER
ADDI N,-"0"(C) ;INCORPORATE DIGIT
PUSHJ P,.TIAUC ;GET NEXT CHARACTER
JRST DECIN1 ;LOOP BACK FOR MORE
;DECMUL -- HANDLE DECIMAL SUFFIX MULTIPLIER
; K,M,G FOR 10**3,6,9
;CALL: MOVE N,NUMBER
; PUSHJ P,DECMUL
; RETURN WITH NUMBER MULTIPLIED BY SUFFIX
;USES T1 (MULTIPLIER--RETURNED) UPDATES C (SEPARATOR)
DECMUL: CAIN C,"." ;SEE IF FORCING DECIMAL [273]
PUSHJ P,.TIAUC ;YES--GET NEXT CHARACTER [273]
MOVEI T1,.TDECW ;SET DECIMAL FORMAT [314]
MOVEM T1,.LASWD ; FOR ERROR PRINTING [314]
MOVEI T1,1 ;INITIALIZE SUFFIX MULTIPLIER
CAIN C,"K" ;K = 1 000
MOVEI T1,^D1000
CAIN C,"M" ;M = 1 000 000
MOVE T1,[^D1000000]
CAIN C,"G" ;G =1 000 000 000
MOVE T1,[^D1000000000]
IMUL N,T1 ;APPLY TO NUMBER
CAILE T1,1 ;SEE IF SUFFIX
PUSHJ P,.TIAUC ;YES--GET ONE MORE CHARACTER
PJRST .SENEG ;SEE IF NEGATIVE AND RETURN
;.SENEG -- SEE IF NEGATIVE FOUND BY .CKNEG AND APPLY IT
;CALL: MOVE N,VALUE SO FAR
; PUSHJ P,.SENEG
;RETURNS WITH N COMPLEMENTED IF NUMBER PRECEEDED BY -
.SENEG: SKIPE FLNEG ;SEE IF NEGATIVE
MOVNS N ;YES--COMPLEMENT RESULT
IFN ECHO$W,<
PUSHJ P,NAMER
>
;HERE TO EXIT FROM MOST ONE WORD INPUT ROUTINES TO
;STORE A COPY OF THE RESULT IN .NMUL FOR LONG TERM STORAGE
;PURPOSES SUCH AS SOME ERROR MESSAGES
STRNML: MOVEM N,.NMUL ;STORE VALUE FOR ERROR PRINTER [314]
POPJ P, ;RETURN
;.CKNEG -- CHECK IF NEGATIVE NUMBER COMING
;ALSO CLEARS N
;CALL: MOVEI C,NEXT CHAR
; PUSHJ P,.CKNEG
;USES NO ACS
.CKNEG: SETZB N,FLNEG ;CLEAR N AND NEGATIVE FLAG
CAIE C,"-" ;CHECK IF NEGATIVE NUMBER
POPJ P, ;NO--RETURN
SETOM FLNEG ;YES--SET FLAG
PJRST .TIAUC ;GET NEXT CHAR AND RETURN
;.SIXSW -- INPUT A SIXBIT WORD FROM COMMAND STRING
;.SIXSC -- DITTO (CHARACTER ALREADY IN C)
;TERMINATES AT FIRST NON-ALPHANUMERIC CHARACTER
;THROWS AWAY ANY CHARACTERS BEYOND THE FIRST SIX
;CALL: PUSHJ P,.SIXSC/.SIXSW
; RETURN WITH WORD IN N
;USES T1 UPDATES C (SEPARATOR)
.SIXSW: PUSHJ P,.TIAUC ;PRIME THE PUMP
.SIXSC: MOVEI N,0 ;CLEAR NAME
MOVEI T1,.TSIXN ;SET SIXBIT FORMAT [314]
MOVEM T1,.LASWD ; FOR ERROR PRINTING [314]
MOVE T1,[POINT 6,N] ;INITIALIZE BYTE POINTER FOR WORD
SIXS1: PUSHJ P,.TICAN ;SEE IF CHARACTER IS ALPHA-NUMERIC
JRST STRNML ;STORE IN .NMUL AND RETURN [314]
SUBI C," "-' ' ;CONVERT TO SIXBIT
TLNE T1,(77B5) ;DON'T OVERFLOW
IDPB C,T1 ;STORE CHARACTER
PUSHJ P,.TIAUC ;GO GET ANOTHER CHARACTER
JRST SIXS1 ;LOOP BACK TO PROCESS IT
SUBTTL SUBROUTINES FOR COMMAND INPUT - GET NEXT CHARACTER
;.TICAN -- CHECK CHARACTER FOR ALPHA-NUMERIC
;ALPHA-NUMERIC IS A-Z OR 0-9
;CALL: MOVEI C,ASCII CHARACTER
; PUSHJ P,.TICAN
; RETURN IF NOT ALPHA-NUMERIC
; SKIP RETURN IF ALPHA-NUMERIC
;PRESERVES ALL ACS
.TICAN: CAIL C,"A"+40 ;SEE IF
CAILE C,"Z"+40 ; LOWER CASE ALPHA
SKIPA ;NO--CONTINUE CHECKS
JRST .POPJ1 ;YES--GIVE ALPHA RETURN
CAIL C,"0" ;SEE IF BELOW NUMERICS
CAILE C,"Z" ;OR IF ABOVE ALPHABETICS
POPJ P, ;YES--RETURN
CAILE C,"9" ;SEE IF NUMERIC
CAIL C,"A" ;OR IF ALPHABETIC
AOS (P) ;YES--SKIP RETURN
POPJ P, ;RETURN
;.TIAUC -- INPUT ONE COMMAND CHARACTER HANDLING LOWER CASE CONVERSION
;CALL: PUSHJ P,.TIAUC
; RESULT IN C
;USES NO ACS
.TIAUC: PUSHJ P,.TIALT ;GO GET NEXT CHAR
;.TIMUC -- CONVERT LOWER CASE CHARACTER TO UPPER CASE
;CALL: MOVEI C,CHARACTER
; PUSHJ P,.TIMUC
; RETURN WITH UPDATED C
;USES NO ACS
.TIMUC: CAIGE C,"A"+40 ;SEE IF LOWER CASE
POPJ P, ;NO--RETURN
CAIG C,"Z"+40
SUBI C,40 ;YES--CONVERT
POPJ P, ;RETURN
;DEFINE SOME DUMMY ROUTINES NORMALLY USED FOR ERROR PROCESSING
.TSIXN:
.TDTTM:
.TDECW:
.TOCTW:
SUBTTL .CNTDT - GENERALIZED DATE/TIME SUBROUTINE
;.CNTDT -- SUBROUTINE TO CONVERT FROM INTERNAL DATE/TIME FORMAT
;CALL: MOVE T1,DATE/TIME
; PUSHJ P,.CNTDT
; RETURN WITH T1=TIME IN MS., T2=DATE IN SYSTEM FORMAT (.LT. 0 IF ARG .LT. 0)
;BASED ON IDEAS BY JOHN BARNABY, DAVID ROSENBERG, PETER CONKLIN
;USES T1-4
.CNTDT: PUSH P,T1 ;SAVE TIME FOR LATER
JUMPL T1,CNTDT6 ;DEFEND AGAINST JUNK INPUT
HLRZ T1,T1 ;GET DATE PORTION (DAYS SINCE 1858)
RADIX 10 ;**** NOTE WELL ****
ADDI T1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17
;T1=DAYS SINCE JAN 1, 1501 [311]
IDIVI T1,400*365+400/4-400/100+400/400
;SPLIT INTO QUADRACENTURY [311]
LSH T2,2 ;CONVERT TO NUMBER OF QUARTER DAYS [311]
IDIVI T2,<100*365+100/4-100/100>*4+400/400
;SPLIT INTO CENTURY [311]
IORI T3,3 ;DISCARD FRACTIONS OF DAY [311]
IDIVI T3,4*365+1 ;SEPARATE INTO YEARS [311]
LSH T4,-2 ;T4=NO DAYS THIS YEAR [311]
LSH T1,2 ;T1=4*NO QUADRACENTURIES [311]
ADD T1,T2 ;T1=NO CENTURIES [311]
IMULI T1,100 ;T1=100*NO CENTURIES [311]
ADDI T1,1501(T3) ;T1 HAS YEAR, T4 HAS DAY IN YEAR [311]
MOVE T2,T1 ;COPY YEAR TO SEE IF LEAP YEAR
TRNE T2,3 ;IS THE YEAR A MULT OF 4? [311]
JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR [311]
IDIVI T2,100 ;SEE IF YEAR IS MULT OF 100 [311]
SKIPN T3 ;IF NOT, THEN LEAP [311]
TRNN T2,3 ;IS YEAR MULT OF 400? [311]
TDZA T3,T3 ;YES--LEAP YEAR AFTER ALL [311]
CNTDT0: MOVEI T3,1 ;SET LEAP YEAR FLAG [311]
;T3 IS 0 IF LEAP YEAR
;UNDER RADIX 10 **** NOTE WELL ****
CNTDT1: SUBI T1,1964 ;SET TO SYSTEM ORIGIN
IMULI T1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS
JUMPN T3,CNTDT2 ;IF NOT LEAP YEAR, PROCEED
CAIGE T4,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29
JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER
SOS T4 ;YES--BACK OFF ONE DAY
CNTDT2: MOVSI T2,-11 ;LOOP FOR 11 MONTHS
CNTDT3: CAMGE T4,MONTAB+1(T2) ;SEE IF BEYOND THIS MONTH
JRST CNTDT4 ;YES--GO FINISH UP
ADDI T1,31 ;NO--COUNT SYSTEM MONTH
AOBJN T2,CNTDT3 ;LOOP THROUGH NOVEMBER
CNTDT4: SUB T4,MONTAB(T2) ;GET DAYS IN THIS MONTH
CNTDT5: ADD T1,T4 ;INCLUDE IN FINAL RESULT
CNTDT6: EXCH T1,(P) ;SAVE ANSWER, GET TIME
TLZ T1,-1 ;CLEAR DATE
MUL T1,[24*60*60*1000] ;CONVERT TO MILLI-SEC.
ASHC T1,17 ;POSITION RESULT
POP P,T2 ;RECOVER DATE
POPJ P, ;RETURN
;UNDER RADIX 10 **** NOTE WELL ****
;.CNVDT -- CONVERT ARBITRARY DATE TO SPECIAL FORMAT
;CALL: MOVE T1,TIME IN MILLISEC.
; MOVE T2,DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64
; PUSHJ P,.CNVDT
;RETURNS WITH RESULT IN T1 (.GT.0; OR -1 IF BEYOND SEPT. 27,2217)
; NOTE THAT IN SPECIAL FORMAT, THE LEFT HALF DIVIDED
; BY 7 GIVES THE DAY OF THE WEEK (0=WED.)
;USES T2, T3, T4
.CNVDT: PUSHJ P,.SAVE1 ;PRESERVE P1
PUSH P,T1 ;SAVE TIME FOR LATER
IDIVI T2,12*31 ;T2=YEARS-1964
CAILE T2,2217-1964 ;SEE IF BEYOND 2217
JRST GETNW2 ;YES--RETURN -1
IDIVI T3,31 ;T3=MONTHS-JAN, T4=DAYS-1
ADD T4,MONTAB(T3) ;T4=DAYS-JAN 1
MOVEI P1,0 ;LEAP YEAR ADDITIVE IF JAN, FEB
CAIL T3,2 ;CHECK MONTH
MOVEI P1,1 ;ADDITIVE IF MAR-DEC
MOVE T1,T2 ;SAVE YEARS FOR REUSE
ADDI T2,3 ;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED
IDIVI T2,4 ;HANDLE REGULAR LEAP YEARS
CAIE T3,3 ;SEE IF THIS IS LEAP YEAR
MOVEI P1,0 ;NO--WIPE OUT ADDITIVE
ADDI T4,<1964-1859>*365+<1964-1859>/4+<31-18>+31(T2)
;T4=DAYS BEFORE JAN 1,1964 +SINCE JAN 1
; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64
MOVE T2,T1 ;RESTORE YEARS SINCE 1964
IMULI T2,365 ;DAYS SINCE 1964
ADD T4,T2 ;T4=DAYS EXCEPT FOR 100 YR. FUDGE
HRREI T2,64-100-1(T1) ;T2=YEARS SINCE 2001
JUMPLE T2,GETNW1 ;ALL DONE IF NOT YET 2001
IDIVI T2,100 ;GET CENTURIES SINCE 2001
SUB T4,T2 ;ALLOW FOR LOST LEAP YEARS
CAIE T3,99 ;SEE IF THIS IS A LOST L.Y.
GETNW1: ADD T4,P1 ;ALLOW FOR LEAP YEAR THIS YEAR
CAILE T4,^O377777 ;SEE IF TOO BIG
GETNW2: SETOM T4 ;YES--SET -1
POP P,T1 ;GET MILLISEC TIME
MOVEI T2,0 ;CLEAR OTHER HALF
ASHC T1,-17 ;POSITION
DIV T1,[24*60*60*1000] ;CONVERT TO 1/2**18 DAYS
;**;[574] Insert @ GETNW2+6L JNG 4-May-76
CAMLE T2,[^D24*^D60*^D60*^D1000/2] ;[574] OVER 1/2 TO NEXT?
ADDI T1,1 ;[574] YES, SHOULD ACTUALLY ROUND UP
HRL T1,T4 ;INCLUDE DATE
GETNWX: POPJ P, ;RETURN
;UNDER RADIX 10 **** NOTE WELL ****
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
;BACK TO OUR FAVORITE RADIX
RADIX 8
SUBTTL .LKNAM - ROUTINES TO GET AND PUT IN A COUNTED LIST
;.LKNAM -- LOOKUP NAME IN TABLE ALLOWING FOR UNIQUE ABBREVIATIONS
;ALWAYS CHECK FOR EXACT MATCH FIRST.
;CALL: MOVE T1,[IOWD LENGTH,START OF TABLE]
; MOVE T2,NAME
; PUSHJ P,.LKNAM
; ERROR RETURN IF UNKNOWN OR DUPLICATE
; AND WITH T1.LT.0 IF NOT MATCH, .GT.0 IF SEVERAL MATCHES
; SKIP RETURN IF FOUND WITH T1 POINTING TO ENTRY
; AND WITH LH(T1)=0 IF ABBREVIATION, OR T1.LT.0 IF EXACT MATCH
;USES T3, T4
;PRESERVES T2
.LKNAM: JUMPGE T1,[SETOM T1 ;FLAG UNKNOWN
POPJ P,] ;ERROR RETURN
PUSHJ P,.SAVE2 ;SAVE P1, P2
PUSH P,T1 ;SAVE ARGUMENT
MOVE T3,T2 ;SET ARG TO MASK MAKER
PUSHJ P,.MKMSK ;MAKE MASK
MOVE T2,T3 ;RESTORE NAME
MOVE P1,T1 ;SAVE FOR MATCHING
POP P,T1 ;RECOVER ARGUMENT
SETOM P2 ;SET ABBREVIATION MATCH COUNTER
AOS T1 ;POSITION POINTER
NAME1: MOVE T3,(T1) ;FETCH TABLE ENTRY
TLNE T3,(3B1) ;NOTE THAT * IS 12 IN SIXBIT
JRST NAME2 ;NOT FORCED MATCH
LSH T3,6 ;SEE IF IT MATCHES
XOR T3,T2 ;EVEN IN AN ABBR.
TRZ T3,77 ;CLEAR LAST CHAR SINCE WE DON'T KNOW IT
AND T3,P1 ; ..
JUMPE T3,.POPJ1 ;YES--GIVE MATCH RETURN
JRST NAME3 ;NO--LOOP
NAME2: XOR T3,T2 ;SEE IF EXACT MATCH
JUMPE T3,.POPJ1 ;YES--A WINNER
AND T3,P1 ;SEE IF A SUITABLE ABBREVIATION
JUMPN T3,NAME3 ;NO--LOOP BACK FOR MORE
MOVE T4,T1 ;SALT AWAY THE LOCATION JUST IN CASE
AOS P2 ;YES--COUNT
NAME3: AOBJN T1,NAME1 ;ADVANCE--LOOP IF NOT DONE YET
HRRZ T1,T4 ;RESTORE LOCATION OF A WINNER
JUMPE P2,.POPJ1 ;DONE--JUMP IF ONE ABBREVIATION
MOVE T1,P2 ;GIVE FLAG TO CALLER
POPJ P, ;NONE OR TWO, SO FAIL
;.MKMSK -- MAKE MASK CORRESPONDING TO NON-BLANKS IN SIXBIT WORD
;CALL: MOVE T3,WORD
;CALL: MOVE T3,WORD
; PUSHJ P,.MKMSK
;RETURN WITH MASK IN T1
;USES T2
.MKMSK: MOVEI T1,0 ;CLEAR MASK
MOVSI T2,(77B5) ;START AT LEFT END
MAKMS1: TDNE T3,T2 ;SEE IF SPACE HERE
IOR T1,T2 ;NO--IMPROVE MASK
LSH T2,-6 ;MOVE RIGHT ONE CHAR
JUMPN T2,MAKMS1 ;LOOP UNTIL DONE
POPJ P, ;RETURN
SCN%L: ;LABEL THE LITERAL POOL
END