Trailing-Edge
-
PDP-10 Archives
-
BB-J713A-BM
-
language-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 Irwin L. Goverman/ILG/LSS/MLB/PJT/WLH/DC 25-Sept-79
;
;
; COPYRIGHT (c) 1975,1976,1977,1978,1979
; DIGITAL EQUIPMENT CORPORATION
;
; 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 WHICH IS NOT SUPPLIED BY
; DIGITAL.
SALL ;SUPPRESS MACRO EXPANSION
SEARCH GLXMAC ;OPEN SYMBOLS NEEDED
PROLOG(GLXSCN,SCN) ;PART OF LIBRARY, ETC...
SCNEDT==37 ;VERSION OF MODULE
;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. Table of Contents......................................... 2
; 2. Revision History.......................................... 3
; 3. Local Definitions......................................... 5
; 4. Module Storage............................................ 6
; 5. S%INIT -- Initialize the GLXSCN Module.................. 7
; 6. S%ERR - ERROR TYPEOUT ROUTINE............................. 8
; 7. S%ERR -- ERROR MESSAGES FROM COMND................. 8
; 8. S%INTR -- Interrupt Level Breakout Routine.............. 9
; 9. S%CMND -- Scan a command................................ 10
; 10. S%EXIT -- Exit Address for Interrupt Breakout....... 11
; 11. S%SIXB -- Convert ASCII to SIXBIT................... 12
; 12. CNVSIX -- CONVERT ATOM BUFFER TO SIXBIT............. 12
; 13. RETYPE -- Retype current line including the prompt...... 19
; 14. TYPRMT -- Retype the prompt if there is one............. 19
; 15. TYLINE -- Retype the line until current position........ 19
; 16. Atom Buffer Routines / INILCH - Init Atom Buffer.......... 26
; 17. Atom Buffer Routines / STOLCH - Store Character in Atom Buffer 26
; 18. Atom Buffer Routines / CHKLCH - Return Number of Characters 26
; 19. Atom Buffer Routines / TIELCH - Terminate Atom Buffer With NULL 26
; 20. CMCIN -- Read One Character for Processing.............. 27
; 21. HELPER -- Do caller supplied and default HELP text...... 30
; 22. DOHLP -- Do caller supplied HELP text................... 30
; 23. CMAMB -- Handle Ambiguous Typein........................ 30
; 24. Command Function / .CMINI - Init the scanner and do ^H.... 33
; 25. Command Function / .CMSWI - Parse a SWITCH................ 34
; 26. Command Function / .CMKEY - Parse a KEYWORD............... 35
; 27. Command Function / .CMTXT - Parse Arbitrary Text to Action Character 39
; 28. Function .CMNOI -- Parse a NOISE-WORD................... 39
; 29. Command Function / .CMCFM - Command Confirmation (end-of-line) 40
; 30. Command Function / .CMNUM - Parse an INTEGER in any base.. 42
; 31. Command Function / .CMNUX - Parse an INTEGER in any base (special break) 42
; 32. Command Function / .CMDEV - Parse a DEVICE specification.. 45
; 33. Command Function / .CMQST - Parse a QUOTED STRING......... 45
; 34. Command Function / .CMNOD - Parse a NODE Specification.... 46
; 35. PATHIN Routine to Parse TOPS-10 Path Specification....... 49
; 36. PATH SUPPORT ROUTINES..................................... 51
; 37. S%SCMP -- String Comparison Routine..................... 55
; 38. S%TBLK -- Table lookup routine.......................... 57
; 39. S%TBAD -- Table Add Routine......................... 60
; 40. S%TBDL -- Table Delete Routine...................... 61
SUBTTL Revision History
COMMENT \
Edit GCO Reason
---- --- -------------------------------------------
0001 Create GLXSCN module
0002 Fix a number of interrupt race problems and
start adding ESCape sequence code
0003 Add support for parsing of a string; fix bug in
.CMINI which caused prompts not at left margin
0004 019 Add code for CR.COD and change S%ERR to return
string. Add ERRBUF for the error messages.
0005 021 Use all the new terminal I/O routines in GLXKBD.
0006 Install S%INTR to request interrupt breakout.
0007 030 Fix S%INTR,S%CMND, and add S%EXIT for interrupt exit
address. Change call to S%INTR.
0010 Fix S%CMND to Allow Multiple File Specs to be separated
by Commas (i.e DSK:FIL1,DSK:FIL2,etc)
Also Changed FILBRK and PPNBRK sets to allow Full Path
specifications (Path Not currently implemented)
Added routine CMRPTH to Get [p,pn,foo,foo,...]
0011 037 Allow recognition on typed node name to be
interpreted as a field terminator.
0012 Make Fix to Edit 10 for Multiple File Specs.
Allow only DEV:FILNAM.EXE[P,PN,PATH,...] as filespec
0013 039 Change HELP text for .CMUSR function.
0014 Correct Path Specification added in edit 0010
0015 Code Clean up for ambiguous commands
0016 Make ^H work properly for commands with extra arguments
0017 Raise all LC to UC when comparing noise
words. Changes made around label CMNOI4.
0020 G044 Add new Routines S%TBAD and S%TBDL for adding and
deleting entries from command tables
0021 Fix S%TBAD Bug
0022 FIX .CMDEV and Let Node function do Parse Only on Names
Also Make -10 NOPARS be ITEXT
0023 Fix S%TBLK, to save the P's
0024 Fix .CMNOD to save SIXBIT value when CM%PO is set
0025 Make S%SIXB to read sixbit strings from ascii strings
0026 If only one element in a Keyword or Switch Table do not
Type out "one of the following" ..but put out a " ".
0027 Change name of ERRBUF to SAVBUF and make it Global. Saving
of Stopcodes on the -20 will use this area.
0030 Change SAVE to $SAVE
0031 Make S%CMND return true if CM%NOP is set on the -20
0032 CORRECT EXTRA LINE TYPEOUT IN HELP TEXT
0033 DO NOT ALLOW NULL NODE NAMES
0034 Change all messages to Upper and lower case and change
Unrecognized Control Character to Ambiguous
0035 Support CM%BRK and output to other than terminal
0036 Change calling convention of NUMIN
0037 Add support for .CMTAD
\ ;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
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,TEXT)<
SKIPA T1,[XWD CODE,[ITEXT (<TEXT>)]]
XLIST
SKIPA
JRST XCOMNE
LIST
SALL
> ;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 Date and Time Data Base
TOPS10 <
DEFINE DAYERR,<
X IDT,<Invalid Date Field Specified>
X ITF,<Invalid Time Field Specified>
X DOR,<Date/time out of range>
X DTM,<Value missing in date/time>
X MDD,<Missing day in date/time>
X DFZ,<Field zero in date/time>
X MDS,<Mnemonic date/time switch not implemented>
X DFL,<Field too large in date/time>
X ILR,<Illegal year format in date/time>
X NND,<Negative number in date/time>
X NPF,<Not known whether past or future in date/time>
X RDP,<Relative Date Parse Required>
>;END DAYERR
.ZZ==0
DEFINE X(A,B),<
E..'A==.ZZ
.ZZ==.ZZ+1>
DAYERR ;GENERATE THE CODES
DEFINE X(A,B),<
E$$'A: MOVEI 1,E..'A ;GET THE ERROR
PJRST ERRRTN> ;SETUP ERROR RETURN
XLIST
SALL
DAYERR ;GENERATE THE ROUTINES
LIST
ERRRTN: MOVEM S1,LSTERR ;SAVE THE LAST ERROR
$RETF ;RETURN FALSE
DEFINE X(A,B),<
[ASCIZ\B\]>
XLIST
SALL
DERTBL: DAYERR ;GENERATE MESSAGE TABLE
LIST
DAYTBL: $STAB
KEYTAB(2,<FRIDAY>)
KEYTAB(5,<MONDAY>)
KEYTAB(3,<SATURDAY>)
KEYTAB(4,<SUNDAY>)
KEYTAB(1,<THURSDAY>)
KEYTAB(6,<TUESDAY>)
KEYTAB(0,<WEDNESDAY>)
$ETAB
MONTBL: $STAB
KEYTAB(^D4,<APRIL>)
KEYTAB(^D8,<AUGUST>)
KEYTAB(^D12,<DECEMBER>)
KEYTAB(^D2,<FEBRUARY>)
KEYTAB(^D1,<JANUARY>)
KEYTAB(^D7,<JULY>)
KEYTAB(^D6,<JUNE>)
KEYTAB(^D3,<MARCH>)
KEYTAB(^D5,<MAY>)
KEYTAB(^D11,<NOVEMBER>)
KEYTAB(^D10,<OCTOBER>)
KEYTAB(^D9,<SEPTEMBER>)
$ETAB
>;END TOPS10
SUBTTL Module Storage
$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 RETURNED FROM NOPARS
$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
$DATA ITARG1 ;ITEXT ARGUMENT 1
$DATA ITARG2 ;ITEXT ARGUMENT 2
$DATA ITARG3 ;ITEXT ARGUMENT 3
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 VAL1 ;DEFINE VALUES FOR THE DATA
$DATA VAL2 ;BLOCK FOR SECONDS
$DATA VAL3 ;BLOCK FOR MINUTES
$DATA VAL4 ;BLOCK FOR HOURS
$DATA VAL5 ;BLOCK FOR DAYS
$DATA VAL6 ;BLOCK FOR MONTHS
$DATA VAL7 ;BLOCK FOR YEARS
$DATA VAL8 ;BLOCK FOR DECADES
$DATA VAL9 ;BLOCK FOR CENTRIES
$DATA DAYNUM ;DAY NUMBER VALUE "D"
$DATA SECOND ;SECONDS
$DATA MINUTE ;MINUTES
$DATA HOURS ;HOURS
$DATA DAYS ;DAYS
$DATA NOW ;CURRENT DATE AND TIME
$DATA TIMPTR ;POINTER FOR THE TIME
$DATA TIMCNT ;COUNT FOR TIME BUFFER CHARACTERS
$DATA LSTCHR ;LAST CHARACTER SEEN
$DATA FLFUTD ;FUTURE TIME FLAG
$DATA FLFUTR ;FUTURE TIME HOLDER
$DATA TIMSAV ;TIME SAVE ADDRESS
$DATA STRDAT,5 ;LEAVE ROOM FOR DATA
$DATA STRPTR ;POINTER TO THE BLOCK
>;END TOPS10 CONDITIONAL
$DATA INTRPT ;FLAG FOR S%INTR
TOPS20 <
$DATA BLKSAV ;COMMAND BLOCK ADDRESS
$DATA BUFCNT ;SIZE OF COMMAND BUFFER
>;END TOPS20 CONDITIONAL
SUBTTL S%INIT -- Initialize the GLXSCN Module
TOPS10 <
S%INIT: 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
$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 ADDRESS OF ERROR
JUMPE S1,.RETF ;NO MESSAGE RETURN FALSE
$TEXT (<-1,,SAVBUF>,<^I/(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
;NOPARSE ERROR CODES
NPXNSW==1
NPXNOM==2
NPXNUL==3
NPXINW==4
NPXNC==5
NPXICN==6
NPXIDT==7
NPXNQS==10
NPXAMB==11
NPXNMT==12
NPXCMA==13
NPXNNC==14 ;TOO MANY CHARACTERS IN NODE NAME
NPXNNI==15 ;ILLEGAL CHARACTER IN NODE NAME
NPXNSN==16 ;NO SUCH NODE
NPXIPS==17 ;Invalid Path Specification
NPXIFS==20 ;Invalid File Specification
NPXIUS==21 ;Invalid User Specification
NPXDGS==22 ;DEVICE NAME GREATER THAN 6 CHARACTERS ARE INVALID
NPXDNE==23 ;DEVICE DOESN'T EXIST
NPXDIO==24 ;DEVICE CAN NOT DO INPUT OR OUTPUT
NPXBDF==25 ;BAD DATE/TIME FORMAT
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: 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
;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: ALWAYS,
; 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 T2, ;ASSUME TRUE RETURN
SKIPN INTRPT ;DID INTERRUPT OCCUR SKIP COMND
COMND ;DO THE COMMAND JSYS
ERJMP [SETO T2, ;SET FALSE RETURN
JRST CMND.3] ;AND CONTINUE ON
CMND.3: SETZ T3, ;SET FLAG
EXCH T3,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 T3 ;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 T2, ;YES, RETURN FALSE
LOAD S1,.CMFNP(T1),CM%FNC ;GET FUNCTION DONE
MOVEM S1,CRBLK+CR.COD ;SAVE IT
JUMPL T2,.RETF ;RETURN FALSE IF NCESSARY
$RETT ;ELSE, RETURN TRUE
> ;END TOPS20 CONDITIONAL
TOPS10 <
;!!!!!NOTE WELL - THIS CONDITIONAL RUNS TO THE END OF COMND ROUTINE
S%CMND: MOVEM 0,CMDACS ;SAVE THE COMMAND ACS
MOVE 0,[XWD 1,CMDACS+1] ;SET UP BLT POINTER
BLT 0,CMDACS+17 ;SAVE THE ACS
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: MOVEM T1,LSTERR ;SAVE ERROR CODE
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
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: PUSHJ P,CRLF ;TYPE CRLF TO GET TO LEFT MARGIN
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
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
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,CMRATT ;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]
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 CMRATR ;YES
PUSHJ P,STOLCH ;BUILD KEYWORD STRING
JRST CMRAT1
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]
CAIN T1,.CHLFD ;END OF LINE?
TXO F,CM%EOC ;YES, MEANS END OF COMMAND
POPJ P,0
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
CMCN2B: MOVEI S1,TI ;GET LOCATION OF TEXTI BLOCK
PUSHJ P,K%TXTI ;DO INTERNAL TEXTI
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
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: MOVEI S1,[ASCIZ /
or/]
TXNE F,CMQUE2 ;IN ALTERNATE HELP POSSIBILITIES?
PUSHJ P,CMDSTO
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 K%SOUT ;AND TYPE IT
SUBTTL CMAMB -- Handle Ambiguous Typein
CMAMB: TXZN F,CM%ESC ;ESC SEEN?
NOPARS (NPXAMB,Ambiguous)
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 K%SOUT ;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 (NPXNSW,Unrecognizable Switch Construction)]
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(NPXNOM,No KEYWORD Match)
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 (NPXNUL,KEYWORD Expected)] ;FAIL IF NULL
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 (NPXINW,Bad Noise Word) ;NO, PROBABLY BAD NOISE WORD
SUBTTL Command Function / .CMCFM - Command Confirmation (end-of-line)
XCMCFM: PUSHJ P,CMCFM0 ;DO THE WORK
NOPARS(NPXNC,CONFIRMATION Required)
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 (NPXICN,Numeric Character Expected)
;NUMBER BREAK SET, ALLOWS +, -, NUMBERS
NUMBRK: 777777,,777760
777654,,001760
400000,,000760
400000,,000760
NUXBRK: 777777,,777760
777654,,001760
777777,,777760
777777,,777760
SUBTTL NUMIN -- 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
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
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
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
MOVE S1,.CMABP(P2) ;ADDRESS OF BUFFER
MOVEM S1,ITARG1 ;SAVE ARGUMENT
PUSHJ P,CMCIN ;CHECK TERMINATOR
CAIE T1,":" ;DEVICE?
NOPARS(NPXIDT,<Invalid Device ^Q/ITARG1/ Device Specifications Requires a :>)
TXNE F,CM%PO ;PARSE ONLY ON FIELD
JRST XCOMXR ;YES..RETURN O.K.
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
PUSHJ P,CNVSIX ;CONVERT FIELD TO SIXBIT
SKIPT ;O.K. S1/ FIELD NAME
NOPARS(NPXDGS,<DEVICE Name ^Q/ITARG1/: is Greater Than Six Characters>)
DEVCHR S2, ;SEE IF IT EXISTS
SKIPN S2 ;VALID DATA
NOPARS(NPXDNE,<DEVICE Name ^Q/ITARG1/: Does Not Exist>)
TXNE S2,DV.IN!DV.OUT ;CHECK IF CAN DO INPUT OR OUTPUT
PJRST XCOMXR ;YES..RETURN O.K.
NOPARS(NPXDIO,<DEVICE ^Q/ITARG1/: can not 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(NPXNQS,Quoted String Expected)
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
MOVEI S1,[ASCIZ /node name/]
TXNE F,CMQUES ;DID HE TYPE A QUESTION MARK?
PUSHJ P,HELPER ;YES, TYPE THE HELP TEXT(S)
JXN F,CM%ESC,[PUSHJ P,CMDCH ;DO RECOGNITION IF REQUESTED
PUSHJ P,TIELCH;TIE ATOM BUFFER
JRST XNOD1] ;RETURN IN LINE
XNOD1: 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
JUMPF XNOD2 ;LOST, TRY AS A SIXBIT NAME
MOVEM S2,CRBLK+CR.RES ;SAVE AS RESULT
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!
MOVE T3,CRBLK+CR.RES ;NODE NUMER WE JUST PARSED
TXNE F,CM%PO ;PARSE ONLY?
JRST XCOMXI ;YES, JUST RETURN WITH RESULT
MOVE T1,[XWD .NDRNN,T2] ; MAKE SURE THAT THIS NODE NUMBER EXISTS
MOVEI T2,2 ;2 ARGS
NODE. T1, ;TRY IT FOR EXISTANCE
JRST ILLNOD ;IT DOESN'T!
JRST XCOMXI ;A GOOD NODE NUMBER, RETURN
XNOD2: MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
PUSHJ P,CNVSIX ;CONVERT BUFFER TO SIXBIT
SKIPT ;O.K.. CONTINUE
ILLNOD: NOPARS (NPXNNC,Improper Node Name)
MOVEM S2,CRBLK+CR.RES ;SAVE SIXBIT NAME IN RESULT FIELD
XNOD3: TXNE F,CM%PO ;PARSE ONLY?
PJRST XCOMXR ;YES..RETURN NOW
MOVE T2,ATBPTR ;GET POINTER TO END OF ATOM BUFFER
IBP T2 ;POINT AT TERMINATOR
CAME S1,T2 ;OUR POINTER END THE SAME PLACE?
NOPARS (NPXNNI,Node Name Expected)
XNOD4: MOVEI T2,2 ;2 ARGS
MOVE T3,S2 ;GET NODE NAME RETURNED
MOVEM S2,ITARG1 ;SAVE NODE NAME
MOVE T1,[XWD .NDRNN,T2]
NODE. T1,0
NOPARS(NPXNSN,<Node ^W/ITARG1/ Not a Valid Node>)
MOVEM T1,CRBLK+CR.RES ;STORE NUMBER
JRST XCOMXI ;AND 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 (NPXIFS,Invalid File Specification)
MOVE T2,ATBPTR ;GET POINTER TO ATOM BUFFER END
IBP T2 ;BUMP PAST TERMINATOR
CAME T2,XXXPTR ;DOES IT MATCH?
NOPARS (NPXIFS,Invalid File Specification)
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
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
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 (NPXNMT,Invalid Token Found) ;NO MATCH OF 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,RDPATH ;GET CURRENT PATH 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 ;FOR PROJECT AND PROGRAMMER NUMBERS
LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;MUST BE COMMA
POPJ P,0 ;FAIL -- PPN NOT NUMERIC
SKIPN S2 ;WAS ANSWER 0?
HLR S2,PTHBLK+.PTPPN ;YES -- LOAD DEFAULT
HRLM S2,(P2) ;STORE IN DESTINATION
MOVEI S2,^D8 ;SET OCTAL RADIX
PUSHJ P,NUMIN
LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;MUST BE COMMA OR BRACKET
CAIN T1,"]"
SKIPA
POPJ P,0 ;FAIL -- PPN INCORECT
SKIPN S2 ;WAS ANSWER 0
HRR S2,PTHBLK+.PTPPN ;YES -- LOAD DEFAULT
HRRM S2,(P2) ;STORE IN DESTINATION
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
; 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 (NPXIUS,Invalid User Specification)
MOVE T1,XXXPTR ;Ensure Entire atom was parsed
CAME T1,ATBPTR
NOPARS (NPXIUS,Invalid User Specification)
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 (NPXCMA,Comma was Expected) ;FAIL
;DATE AND/OR TIME
;FLAGS IN ARG SPECIFY WHICH
XCMTAD: MOVE Q1,FNARG ;GET ARG
PUSHJ P,CMRSPC ;READ FIRST FIELD
JXN F,CMQUES,CMTADH ;DO HELP IF REQUESTED
JXN F,CMDEFF,CMTAD1 ;JUMP IF NOW HAVE FIELD DEFAULT
; TXC Q1,CM%IDA+CM%ITM ;DATE AND TIME BOTH?
; TXCN Q1,CM%IDA+CM%ITM
; JRST [MOVEI T1," " ;YES, PUT SPACE IN ATOM BUFFER
; PUSHJ P,STOLCH
; PUSHJ P,CMRSPC ;READ SECOND FIELD
; JXN F,CMQUES,CMTADH ;DO HELP
; JRST .+1]
CMTAD1: PUSHJ P,DATIM ;GET DATE AND TIME
JUMPT CMTAD2 ;CONTINUE ON
MOVEI S2,@DERTBL(S1) ;GET MESSAGE ADDRESS
MOVEM S2,ITARG1 ;SAVE THE ARGUMENT
NOPARS (NPXBDF,<^T/@ITARG1/>)
CMTAD2: TXNE Q1,CM%NCI ;CONVERT TO INTERNAL FORMAT?
JRST CMTAD3 ;NO .. STORE DATA IN USER BLOCK
MOVEM S1,CRBLK+CR.RES ;STORE RESULT
JRST XCOMXR ;OK, TAD ALREADY IN T2
CMTAD3: MOVEM S1,NOW ;SAVE THE TIME FOR NOW
PUSHJ P,CMPDAT ;GET THE VALUE
MOVE S1,VAL9 ;GET CENTURY
IMULI S1,^D100 ;MAKE IT YEARS
MOVE S2,VAL8 ;GET DECADES
IMULI S2,^D10 ;MAKE YEARS ALSO
ADD S2,S1 ;COMBINE THEM
ADD S2,VAL7 ;GET THE YEAR FIELD
HRL S1,S2 ;PLACE IN LEFT HALF
HRR S1,VAL6 ;GET THE MONTH
MOVEM S1,0(Q1) ;SAVE IN THE BLOCK
HRLZ S1,VAL5 ;GET THE MONTH
MOVEM S1,1(Q1) ;SAVE THE SECOND WORD
MOVE S1,SECONDS ;GET SECONDS
HRRZM S1,2(Q1) ;RIGHT HALF OF THIRD WORD
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
SUBTTL DATIM -- DATE AND TIME PARSER
;These routines are called by the .CMTAD function of GLXSCN
;for processing date and time data
;
;
; CALL S1/ POINTER TO THE STRING
; S2/ NUMBER OF CHARACTERS IN BUFFER
;
;
; RETURN TRUE S1/ UDT FOR THE TIME
; RETURN FALSE ERROR CODE IN S1
DATIM: PUSHJ P,.SAVE1 ;SAVE P1
MOVE S1,.CMABP(P2) ;POINT TO ATOM BUFFER
MOVE S2,.CMABC(P2) ;COUNT IN THE ATOM BUFFER
SUB S2,ATBSIZ ;GET THE ACTUAL COUNT
DMOVEM S1,TIMPTR ;SAVE POINTER AND COUNT
SETZM FLFUTD ;CLEAR THE FUTURE
SETZM FLFUTR ;CLEAR THE VALUES
SETOM VAL1 ;SET DEFAULT VALUES
MOVE S1,[VAL1,,VAL2] ;GET BLT POINTER
BLT S1,VAL9 ;DEFAULT ALL VALUES
PUSHJ P,I%NOW ;GET THE CURRENT DATE AND TIME
MOVEM S1,NOW ;SAVE THE TIME
MOVE S1,FNARG ;GET THE ARGS
PUSHJ P,GETCHR ;GET A CHARACTER
CAIN S1,"+" ;WAS IT A +
PJRST PLSRTN ;CHECK PLUS ROUTINE
CAIN S1,"-" ;WAS IT A MINUS
PJRST MINRTN ;MINUS ROUTINE
CAIL S1,"0" ;LESS THAN 0
CAILE S1,"9" ;LESS THAN 9
PJRST DATPAR ;NO TRY PARSING THE DATE
PUSHJ P,DECBPT ;BACK UP TO FIRST CHARACTER
PUSHJ P,DECNUM ;GET THE NUMBER
JUMPF E$$IDT ;INVALID DATE AND TIME
MOVEM S1,DAYNUM ;SAVE THE NUMBER
SKIPN S2,LSTCHR ;GET LAST CHARACTER
PJRST DATI.1 ;SETUP FOR TIMPAR
CAIN S2,"D" ;CHECK IF DAYS
JRST DAYRTN ;PROCESS THE DAYS
CAIE S2,":" ;
PJRST ALTDAT ;TRY THE ALTERNATE DATE FORMS
DATI.1: MOVE S1,.CMABP(P2) ;POINT TO ATOM BUFFER
MOVE S2,.CMABC(P2) ;COUNT IN THE ATOM BUFFER
SUB S2,ATBSIZ ;GET THE ACTUAL COUNT
DMOVEM S1,TIMPTR ;GET BACK TO START
DATI.2: PUSHJ P,TIMPAR ;PARSE THE TIME
JUMPF .POPJ ;ERROR..RETURN
PJRST CMPDAT ;COMPUTE THE DATE AND RETURN
SUBTTL TIMPAR -- PARSE THE TIME FIELD
;This routine will parse a time and return
;
;RETURN: S1/ TIME IN SECONDS
; S2/ FRACTION OF DAY IN RH
TIMPAR: MOVE S1,FNARG ;GET THE ARGUMENT FLAGS
TXNN S1,CM%ITM ;TIME WANTED?
PJRST E$$ITF ;TIME FIELD INVALID
SETZM SECOND ;CLEAR SECONDS
SETZM MINUTE ;CLEAR MINUTES
SETZM HOURS ;CLEAR HOURS
PUSHJ P,DECNUM ;GET A DECIMAL NUMBER
JUMPF E$$ITF ;INVALID DATE AND TIME FUNCTION
JUMPL S1,E$$ITF ;INVALID DATE AND TIME
MOVEM S1,DAYNUM ;SAVE THE NUMBER
MOVEM S1,SECOND ;SAVE AS SECONDS
MOVE S2,LSTCHR ;GET LAST CHARACTER
CAIN S2,"D" ;WAS IT A D(DAYS)
PJRST E$$RDP ;REQUIRES RELATIVE DATE CHECK
CAIE S2,":" ;WAS IT A COLON
PJRST FINTIM ;FINISH OFF THE TIME
PUSHJ P,DECNUM ;GET THE NEXT FIELD
JUMPF E$$ITF ;INVALID DATE AND TIME FUNCTION
JUMPL S1,E$$ITF ;INVALID DATE AND TIME
EXCH S1,SECOND ;GET THE SECONDS AS MINUTES
MOVEM S1,MINUTE ;SAVE THE MINUTES
MOVE S1,LSTCHR ;GET THE LAST CHARACTER
CAIE S1,":" ;WAS IT A COLON
PJRST FINTIM ;FINISH OFF THE TIME
PUSHJ P,DECNUM ;GET A DECIMAL NUMBER
JUMPF E$$ITF ;INVALID DATE AND TIME FUNCTION
JUMPL S1,E$$ITF ;INVALID DATE AND TIME
EXCH S1,SECOND ;SAVE AS SECONDS
EXCH S1,MINUTE ;SAVE AS MINUTES
MOVEM S1,HOURS ;SAVE AS HOURS
FINTIM: MOVE S1,SECOND ;GET THE SECONDS
CAIL S1,^D60 ;LESS THAN 60
PJRST E$$ITF ;INVALID DATE AND TIME
MOVEM S1,VAL2 ;SAVE THE SECONDS
MOVE S1,MINUTE ;GET THE MINUTES
CAIL S1,^D60 ;CHECK LESS THAN 60
PJRST E$$ITF ;INVALID DATE AND TIME
MOVEM S1,VAL3 ;SAVE THE MINUTES
MOVE S1,HOURS ;GET THE HOURS
CAIL S1,^D24 ;LESS THAN 24
PJRST E$$ITF ;INVALID DATE AND TIME
MOVEM S1,VAL4 ;SAVE THE HOURS
IMULI S1,^D60 ;CONVERT TO MINUTES
ADD S1,VAL3 ;ADD IN THE MINUTES
IMULI S1,^D60 ;CONVERT TO SECONDS
ADD S1,VAL2 ;ADD IN THE SECONDS
SETZM T1 ;CLEAR OTHER HALF
MOVE S2,S1 ;GET THE VALUE
ASHC S2,-^D17 ;MULTIPLY BY 2**18
DIVI S2,^D24*^D3600 ;DIVIDE BY SECONDS PER DAY
;GET FRACTION OF A DAY IN RH
$RETT ;RETURN TRUE
SUBTTL PLSRTN -- PROCESS DATE WITH "+"
SUBTTL MINRTN -- PROCESS DATE WITH "-"
SUBTTL DAYRTN -- PROCESS DAY "D"
PLSRTN: AOS FLFUTD ;INDICATE IN THE FUTURE
SKIPA ;GET TIME
MINRTN: SOS FLFUTD ;INDICATE IN THE PAST
MINI.1: PUSHJ P,TIMPAR ;PARSE THE TIME
JUMPT RELDAY ;O.K. COMPUTE RELATIVE DAY
CAIN S1,E..RDP ;CHECK FOR RELATIVE DATE ERROR
JRST DAYRTN ;YES CHECK OUT DATE
$RETF ;NO..PASS ERROR BACK
RELDAY: SKIPGE FLFUTD ;CHECK THE TIME
MOVN S2,S2 ;PAST.. COMPLEMENT THE TIME
ADD S2,NOW ;GET THE VALUE
MOVE S1,S2 ;GET THE TIME
PJRST DATEXT ;EXIT WITH DATE
DAYRTN: SETZM LSTERR ;CLEAR LAST ERROR
HRLZ S2,DAYNUM ;GET THE NUMBER
SOSG TIMCNT ;ANY CHARACTERS LEFT?
PJRST RELDAY ;NO..COMPUTE THE DAY
PUSHJ P,GETCHR ;GET A CHARACTER
JUMPF E$$IDT ;INVALID DATE TIME
CAIE S1,":" ;BETTER BE A COLON
PJRST E$$IDT ;NO..BAD DATE/TIME
HRLZ S2,DAYNUM ;GET THE NUMBER
SKIPGE FLFUTD ;CHECK THE TIME
MOVN S2,S2 ;PAST.. COMPLEMENT THE TIME
ADDM S2,NOW ;GET THE VALUE
PJRST MINI.1 ;YES.. NOW GET DATE
SUBTTL CMPDAT -- COMPUTE THE DATE FROM VALUES
;This routine will default fields with the current values of time
;for those fields that were not input
;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).
CMPDAT: MOVE S1,NOW ;GET CURRENT DATE/TIME
PUSHJ P,CNTDT## ;CONVERT TO EASY FORMAT
;RETURN S1 TIME IN SECONDS
; S2 TIME IN SYSTEM FORMAT
MOVEM S1,SECONDS ;SAVE THE VALUE OF SECONDS
ADD S2,[^D1964*^D12*^D31] ;MAKE REAL
MOVEI T2,8 ;TRY 8 FIELDS
CMPD.1: MOVE S1,S2 ;POSITION REMAINDER
IDIV S1,ADJTBL-1(T2) ;GET THE ADJUSTMENT
SKIPL VAL1(T2) ;SEE IF DEFAULT
JRST [TLNN T1,-1 ;NO--FLAG TO ZERO DEFAULTS
HRL T1,T2 ; SAVING INDEX OF LAST DEFAULT
JRST CMPD.2] ;AND CONTINUE LOOP
SETZM VAL1(T2) ;DEFAULT TO ZERO
TLNN T1,-1 ;SEE IF NEED CURRENT
MOVEM S1,VAL1(T2) ;YES--SET THAT INSTEAD
CMPD.2: CAME S1,VAL1(T2) ;SEE IF SAME AS CURRENT
JRST CMPD.3 ;NO--REMEMBER FOR LATER
CAIN T2,4 ;SEE IF TIME FOR TIME
HRRZ S2,T1 ;YES--GET IT
SOJG T2,CMPD.1 ;LOOP UNTIL ALL DONE
;HERE WHEN FILLED IN CURRENT FOR SIGNIFICANT DEFAULTS
CMPD.3: SKIPGE VAL1(T2) ;SEE IF DEFAULT
SETZM VAL1(T2) ;CLEAR DEFAULT
SOJG T2,CMPD.3 ;LOOP UNTIL DONE
HLRZ P1,T1 ;RECOVER LAST SIGN. DEFAULT-1
JUMPE P1,CMPD.4 ;DONE IF NONE
PUSHJ P,MAKDAT ;MAKE CURRENT DATE, TIME
MOVE T2,FLFUTD ;GET DEFAULT DIRECTION
XCT [CAMGE S1,NOW
JFCL
CAMLE S1,NOW]+1(T2) ;SEE IF OK
JRST CMPD.4 ;YES--GO RETURN
SKIPG FLFUTD ;NO--SEE WHICH DIRECTION
SOSA VAL2(P1) ;PAST
AOS VAL2(P1) ;FUTURE
CMPD.4: PUSHJ P,MAKDAT ;REMAKE ANSWER
MOVE P1,T1 ;MOVE TO ANSWER
PJRST DATEXT ;DATE EXIT AND RETURN
SUBTTL DATEXT -- DATE EXIT ROUTINE
;THIS ROUTINE WILL CHECK DATE AND RETURN
RADIX 10
DATEXT: TRC S1,-1 ;COMPLEMENT THE LEFT SIDE
TRCN S1,-1 ;CHECK IF -1
AOS S1 ;BUMP S1
CAML S1,[<1964-1859>*365+<1964-1859>/4+<31-18>+31,,0] ;CHECK RANGE
$RETT ;RETURN TRUE
RADIX 8
PJRST E$$DOR ;DATE AND TIME OUT OF RANGE
SUBTTL MAKDAT -- ROUTINE TO MAKE A DATE AND TIME
;THIS ROUTINE WILL TAKE THE VALUES IN VAL1-VAL9 AND
;GENERATE A UDT
MAKDAT: MOVE S1,VAL4 ;GET HOURS
IMULI S1,^D60 ;MAKE INTO MINS
ADD S1,VAL3 ;ADD MINS
IMULI S1,^D60 ;MAKE INTO SECS
ADD S1,VAL2 ;ADD SECS
IMULI S1,^D1000 ;MAKE INTO MILLISECS
MOVE S2,VAL9 ;GET CENTURIES
IMULI S2,^D10 ;MAKE INTO DECADES
ADD S2,VAL8 ;ADD DECADES
IMULI S2,^D10 ;MAKE INTO YEARS
ADD S2,VAL7 ;ADD YEARS
IMULI S2,^D12 ;MAKE INTO MONTHS
ADD S2,VAL6 ;ADD MONTHS
IMULI S2,^D31 ;MAKE INTO DAYS
ADD S2,VAL5 ;ADD DAYS
SUB S2,[^D1964*^D12*^D31] ;REDUCE TO SYSTEM RANGE
DMOVE T1,S1 ;SETUP THE ARGUMENTS
PJRST CNVDT ;CONVERT TO INTERNAL FORM AND RETURN
;ADJUSTMENT FACTORS FOR EACH TIME ELEMENT
ADJTBL: EXP 1
EXP ^D60
EXP ^D60*^D60
EXP 1
EXP ^D31
EXP ^D31*^D12
EXP ^D31*^D12*^D10
EXP ^D31*^D12*^D10*^D10
SUBTTL DATPAR -- PARSE A DATE/DAY FIELD
;This routine will parse a date and save the values of the
;fields that are found
;
;CALL S1/ NUMBER
DATPAR: MOVE S1,FNARG ;GET THE ARGUMENT FLAGS
TXNN S1,CM%IDA ;DATE WANTED?..
PJRST E$$IDT ;INVALID DATE FUNCTION
MOVE S2,LSTCHR ;GET THE LAST CHARACTER
CAIN S2,"-" ;SEPERATOR?
PJRST ALTDAT ;YES.. TRY ALTERNATE DATE FORM
PUSHJ P,DECBPT ;DECREMENT THE BYTE POINTER
PUSHJ P,GETSTG ;GET A STRING
SKIPT ;O.K. CONTINUE ON
PJRST E$$DTM ;VALUE MISSING IN DATE AND TIME
MOVE P1,S1 ;SAVE THE STRING POINTER
MOVEM S1,STRPTR ;SAVE THE STRING POINTER
MOVEI S1,DAYTBL ;GET THE DAYS TABLE
MOVE S2,P1 ;GET THE POINTER
PUSHJ P,S%TBLK ;CHECK THE TABLE
TXNE S2,TL%NOM!TL%AMB ;IS IT AMBIGUOUS OR NO MATCH
JRST datp.5 ;TRY MONTHS OR MNEMONICS
HRRZ P1,(S1) ;GET THE VALUE
HLRZ S2,NOW ;GET DAYS
IDIVI S2,7 ;GET DAY OF WEEK
SUB P1,T1 ;GET FUTURE DAYS FROM NOW
SKIPGE P1 ;IF NEGATIVE,
ADDI P1,7 ; MAKE LATER THIS WEEK
HLLZ S1,NOW ;CLEAR CURRENT
SKIPL FLFUTD ;SEE IF FUTURE
TROA S1,-1 ;YES--SET MIDNIGHT MINUS EPSILON
SUBI P1,7 ;NO--MAKE PAST
HRLZ P1,P1 ;POSITION TO LEFT HALF
ADD P1,S1 ;MODIFY CURRENT DATE/TIME
DATP.1: MOVEM P1,TIMSAV ;SAVE THE TIME
SKIPG TIMCNT ;ANY MORE CHARACTERS
JRST [ MOVE S1,TIMSAV ;GET THE SAVED TIME
JRST DATP.3] ;FINISH OFF THE TIME
MOVE S1,LSTCHR ;CHECK THE LAST CHARACTER
CAIE S1,":" ;WAS IT A :
JRST E$$IDT ;GENERATE AN ERROR
DATP.2: PUSHJ P,TIMPAR ;PARSE THE TIME FIELD
SKIPT ;SKIP IF TRUE
PJRST E$$ITF ;INVALID TIME FIELD
HLL S1,TIMSAV ; TO ANSWER
HRR S1,S2 ;PLACE THE PORTION OF DAY IN RH
DATP.3: SKIPG FLFUTR ;SKIP IF FUTURE
JRST DATP.4 ;ADJUST PAST RESULT
CAMGE S1,NOW ;IF NOT FUTURE, MUST HAVE
;WANTED A WEEK FROM TODAY,
;BUT EARLIER IN THE DAY.
ADD S1,[7,,0] ;MAKE TIME NEXT WEEK
JRST DATEXT ;CHECK AND RETURN
DATP.4: MOVE S2,S1 ;SIMILAR TEST FOR PAST
ADD S2,[7,,0] ;ADD A WEEK TO PAST TIME
CAMG S2,NOW ;WAS TIME OVER A WEEK AGO?
MOVE S1,S2 ;YES, USE NEW ONE
JRST DATEXT ;CHECK ANSWER AND RETURN
DATP.5: PUSHJ P,MONPAR ;TRY TO PARSE A MONTH
JUMPF MNMPAR ;TRY A MNEMONIC
MOVE S1,LSTCHR ;GET THE LAST CHARACTER
CAIE S1,"-" ;MUST BE DAY NEXT
PJRST E$$MDS ;MISSING DAY IN DATE /TIME
PUSHJ P,DECNUM ;GET DECIMAL NUMBER
JUMPLE S1,E$$NND ;NEGATIVE NUMBER
CAILE S1,^D31 ;VERIFY IN RANGE
JRST E$$DFL ;ERROR IF TOO LARGE
MOVEM S1,VAL5 ;SAVE AWAY
PJRST YEARPR ;PARSE THE YEAR
SUBTTL ALTDAT -- PARSE ALTERNATE DATE FORM
;This routine will check dates in the form DD-MMM-YY
; MM-DD-YY
ALTDAT: CAILE S1,^D31 ;IS IT A VALID DAY?
PJRST E$$DFL ;NO..GIVE ERROR
SKIPN P1 ;CHECK IF ZERO?
PJRST E$$DFZ ;FIELD ZERO IN DATE/TIME
MOVEM S1,VAL5 ;SAVE VALUE
PUSHJ P,GETCHR ;SKIP OVER MINUS
JUMPF E$$IDT ;INVALID DATE AND TIME
CAIL S1,"0" ;SEE IF DIGIT NEXT
CAILE S1,"9" ; ..
JRST ALTD.1 ;SETUP FOR MONTH
PUSHJ P,DECNUM ;YES-- MUST BE MM-DD FORMAT
JUMPLE S1,E$$NND ;BAD IF LE 0
CAILE S1,^D31 ;VERIFY LE 31
JRST E$$DFL ;BAD
EXCH S1,VAL5 ;SWITCH VALUES
CAILE S1,^D12 ;VERIFY MONTH OK
JRST E$$DFL ;BAD
MOVEM S1,VAL6 ;SAVE THE MONTH
PJRST YEARPR ;NOW PARSE THE YEAR
ALTD.1: PUSHJ P,DECBPT ;BACKUP POINTER
PUSHJ P,GETSTG ;GET THE STRING
JUMPF E$$IDT ;INVALID DATE AND TIME
MOVE P1,S1 ;SAVE THE POINTER
PUSHJ P,MONPAR ;CHECK FOR MONTH
JUMPF .POPJ ;ERROR..RETURN
PJRST YEARPR ;PARSE THE YEAR
SUBTTL MONPAR -- ROUTINE TO CHECK FOR A MONTH
MONPAR: MOVE S1,FNARG ;GET THE ARGUMENT FLAGS
TXNN S1,CM%IDA ;DATE WANTED?..
PJRST E$$IDT ;INVALID DATE FUNCTION
MOVEI S1,MONTBL ;GET THE DAYS TABLE
MOVE S2,P1 ;GET THE POINTER
PUSHJ P,S%TBLK ;CHECK THE TABLE
TXNE S2,TL%NOM!TL%AMB ;IS IT AMBIGUOUS OR NO MATCH
$RETF ;RETURN FALSE
HRRZ P1,(S1) ;GET MONTH INDEX
MOVEM P1,VAL6 ;YES--STORE MONTH
$RETT ;RETURN TRUE
SUBTTL YEARPR -- PARSE THE YEAR
;THIS ROUTINE WILL PARSE A YEAR
YEARPR: MOVE S1,LSTCHR ;GET THE LAST CHARACTER
CAIE S1,"-" ;SEE IF YEAR NEXT
JRST YEAR.3 ;NO--GO HANDLE TIME
;HERE WHEN YEAR NEXT AS ONE, TWO, OR FOUR DIGITS
SETZB T3,T4 ;CLEAR DIGIT AND RESULT COUNTERS
YEAR.1: PUSHJ P,GETCHR ;GET NEXT DIGIT
CAIL S1,"0" ;SEE IF NUMERIC
CAILE S1,"9" ; ..
JRST YEAR.2 ;NO--MUST BE DONE
IMULI T3,^D10 ;ADVANCE RESULT
ADDI T3,-"0"(S1) ;INCLUDE THIS DIGIT
AOJA T4,YEAR.1 ;LOOP FOR MORE, COUNTING DIGIT
YEAR.2: JUMPE T4,E$$ILR ;ERROR IF NO DIGITS
CAIE T4,3 ;ERROR IF 3 DIGITS
CAILE T4,4 ;OK IF 1,2, OR 4
JRST E$$ILR ;ERROR IF GT 4 DIGITS
MOVE S2,T3 ;GET RESULT
IDIVI S2,^D100 ;SEP. CENTURY
IDIVI T1,^D10 ;SEP. DECADE
CAIG T4,2 ;IF ONE OR TWO DIGITS,
SETOM S2 ; FLAG NO CENTURY KNOWN
CAIN T4,1 ;IF ONE DIGIT,
SETOM T1 ; FLAG NO DECADE KNOWN
MOVEM T2,VAL7 ;SAVE UNITS
MOVEM T1,VAL8 ;SAVE DECADE
MOVEM S2,VAL9 ;SAVE CENTURY
;HERE WITH VAL5-9 CONTAINING DAY, MONTH, YEAR, DECADE, CENTURY
YEAR.3: SOS VAL5 ;MAKE DAYS 0-30
SOS VAL6 ;MAKE MONTHS 0-11
SKIPG TIMCNT ;ANY MORE CHARACTERS
JRST YEAR.5 ;NO..FINISH TIME NOW
MOVE S1,LSTCHR ;CHECK THE LAST CHARACTER
CAIE S1,":" ;WAS IT A :
JRST E$$IDT ;GENERATE AN ERROR
YEAR.4: PUSHJ P,TIMPAR ;GET THE TIME
SKIPT ;SKIP IF TRUE
PJRST E$$ITF ;INVALID TIME FIELD
PJRST CMPDAT ;COMPUTE THE DATE AND RETURN
;HERE IF FUTURE WITHOUT TIME
YEAR.5: SKIPG FLFUTD ;FUTURE TIME?
PJRST CMPDAT ;NO.. JUST GET DATE NOW
MOVEI S1,^D59 ;SET TO
MOVEM S1,VAL2 ; 23:59:59
MOVEM S1,VAL3 ; ..
MOVEI S1,^D23 ; ..
MOVEM S1,VAL4 ; ..
PJRST CMPDAT ;COMPUTE THE DATE
SUBTTL CNVDT -- CONVERT DATE TO UDT
;THIS ROUTINE WILL MAKE A UDT OUT OF AN ARBITRAY DATE
;
;CALL S1/ TIME IN SECONDS
; S2/ DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64
;
;RETURN S1/ UDT
;
;NOTE: LEFT HALF DIVIDED BY 7 GIVES THE DAY OF THE WEEK
RADIX 10
;UNDER RADIX 10 **** NOTE WELL ****
CNVDT:: PUSHJ P,.SAVET ;PRESERVE T3
PUSH P,S1 ;SAVE TIME FOR LATER
IDIVI S2,12*31 ;S2=YEARS-1964
CAILE S2,2217-1964 ;SEE IF BEYOND 2217
JRST GETNW2 ;YES--RETURN -1
IDIVI T1,31 ;T1=MONTHS-JAN, T2=DAYS-1
ADD T2,MONTAB(T1) ;T2=DAYS-JAN 1
MOVEI T3,0 ;LEAP YEAR ADDITIVE IF JAN, FEB
CAIL T1,2 ;CHECK MONTH
MOVEI T3,1 ;ADDITIVE IF MAR-DEC
MOVE S1,S2 ;SAVE YEARS FOR REUSE
ADDI S2,3 ;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED
IDIVI S2,4 ;HANDLE REGULAR LEAP YEARS
CAIE T1,3 ;SEE IF THIS IS LEAP YEAR
MOVEI T3,0 ;NO--WIPE OUT ADDITIVE
ADDI T2,<1964-1859>*365+<1964-1859>/4+<31-18>+31(S2)
;T2=DAYS BEFORE JAN 1,1964 +SINCE JAN 1
; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64
MOVE S2,S1 ;RESTORE YEARS SINCE 1964
IMULI S2,365 ;DAYS SINCE 1964
ADD T2,S2 ;T2=DAYS EXCEPT FOR 100 YR. FUDGE
HRREI S2,64-100-1(S1) ;S2=YEARS SINCE 2001
JUMPLE S2,GETNW1 ;ALL DONE IF NOT YET 2001
IDIVI S2,100 ;GET CENTURIES SINCE 2001
SUB T2,S2 ;ALLOW FOR LOST LEAP YEARS
CAIE T1,99 ;SEE IF THIS IS A LOST L.Y.
GETNW1: ADD T2,T3 ;ALLOW FOR LEAP YEAR THIS YEAR
CAILE T2,^O377777 ;SEE IF TOO BIG
GETNW2: SETOM T2 ;YES--SET -1
POP P,S1 ;GET MILLISEC TIME
MOVEI S2,0 ;CLEAR OTHER HALF
ASHC S1,-17 ;POSITION
DIV S1,[24*60*60*1000] ;CONVERT TO 1/2**18 DAYS
CAMLE S2,[^D24*^D60*^D60*^D1000/2] ; OVER 1/2 TO NEXT?
ADDI S1,1 ;YES, SHOULD ACTUALLY ROUND UP
HRL S1,T2 ;INCLUDE DATE
GETNWX: POPJ P, ;RETURN
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
RADIX 8
SUBTTL MNMPAR -- PARSE MNEMONICS
;THIS ROUTINE WILL CHECK FOR MNEMONICS
MNMPAR: PJRST E$$IDT ;INVALID DATE AND TIME
COMMENT \
HRRZ S2,S1 ;GET COPY
CAIN S2,SPLGTM ;SEE IF "LOGIN"
SKIPG P1,LOGTIM ;AND WE KNOW IT
SKIPA ;NO--PROCEED
JRST DATEXT ;YES--GO GIVE ANSWER
CAIN S2,SPNOON ;SEE IF "NOON"
JRST [HLLZ P1,NOW ;YES--GET TODAY
HRRI P1,1B18 ;SET TO NOON
JRST DATP.1] ;GO FINISH UP
CAIN S2,SPMIDN ;SEE IF "MIDNIGHT"
JRST [HLLZ P1,NOW ;GET TODAY
JRST DATIMO] ;GO SET TO MIDNIGHT
SUBI S2,SPCDAY ;SUBTRACT OFFSET TO SPECIAL DAYS
CAILE S2,2 ;SEE IF ONE OF THREE
JRST E.MDS ;NO--UNSUPPORTED
HLRZ P1,NOW ;YES--GET TODAY
ADDI P1,-1(S2) ;OFFSET IT
HRLZS P1 ;POSITION FOR ANSWER
DATIMO: SKIPL FLFUTD ;SEE IF FUTURE
TRO P1,-1 ;YES--SET TO MIDNIGHT MINUS EPSILON
JRST DATP.1 ;AND GO FINISH UP
;HERE IF UNSUPPORTED MNEMONIC
E.MDS: MOVE P1,(S1) ;GET NAME OF SWITCH
PJRST E$$MDS ;MNEMONIC DATE/TIME NOT IMPLEMENTED
DEFINE XX($1),<
EXP <SIXBIT /$1/>>
SPCDAY: XX YESTERDAY
XX TODAY
XX TOMORROW
SPLGTM: XX LOGIN
SPNOON: XX NOON
SPMIDN: XX MIDNIGHT
SPDATM: XX LUNCH
XX DINNER
LSPDTM==.-SPCDAY
\;END OF COMMENT
SUBTTL GETCHR -- GET A CHARACTER FROM TIME FIELD
;This Routine will return a character from the time field
;
;RETURN TRUE: S1/ CHARACTER
;
;RETURN FALSE: NO MORE DATA
GETCHR: SOSGE TIMCNT ;ANY CHARACTERS LEFT?
PJRST GETC.1 ;ERROR..RETURN
ILDB S1,TIMPTR ;GET A CHARACTER
CAIL S1,"a" ;LOWER CASE A
CAILE S1,"z" ;LOWER CASE Z
SKIPA ;MUST BE O.K.
SUBI S1,40 ;MAKE UPPER CASE
MOVEM S1,LSTCHR ;SAVE LAST CHARACTER
$RETT ;RETURN TRUE
GETC.1: SETZM LSTCHR ;CLEAR LAST CHARACTER
$RETF ;RETURN FALSE
SUBTTL DECNUM -- GET A DECIMAL NUMBER
;This routine will return a decimal number from the time field
;
;RETURN TRUE S1/ DECIMAL NUMBER
DECNUM: SKIPG TIMCNT ;ANY CHARACTERS LEFT
$RETF ;NONE.. RETURN FALSE
MOVE S1,TIMPTR ;GET THE POINTER
MOVEI S2,^D10 ;GET THE RADIX (DECIMAL)
PUSHJ P,NUMIN ;GET THE NUMBER
JUMPF .POPJ ;ERROR...RETURN
DECN.1: IBP TIMPTR ;BUMP THE TIME POINTER
CAMN S1,TIMPTR ;ARE WE AT THE RIGHT PLACE
JRST DECN.2 ;YES.. FINISH UP
SOS TIMCNT ;DECREMENT TIME COUNT
JRST DECN.1 ;KEEP GOING
DECN.2: MOVE S1,S2 ;PLACE NUMBER IN S1
LDB S2,TIMPTR ;GET LAST CHARACTER
CAIL S2,"a" ;LOWER CASE A
CAILE S2,"z" ;LOWER CASE Z
SKIPA ;MUST BE O.K.
SUBI S2,40 ;MAKE UPPER CASE
MOVEM S2,LSTCHR ;SAVE LAST CHARACTER
$RETT ;RETURN TRUE
SUBTTL DECBPT -- DECREMENT THE BYTE POINTER
;THIS ROUTINE WILL DECREMENT THE TIME BYTE POINTER
DECBPT: MOVE S1,TIMPTR ;GET CURRENT POINTER
PUSHJ P,DBP ;DECREMENT THE BYTE POINTER
MOVEM S1,TIMPTR ;SAVE THE POINTER
AOS TIMCNT ;BUMP THE CHARACTER COUNT
$RETT ;RETURN
SUBTTL GETSTG -- GET A STRING TO WORK FROM
;THIS ROUTINE WILL GET A STRING FROM THE INPUT BUFFER AND BREAK ON
;A SEPERATOR
; RETURN S1/ POINTER TO THE STRING
GETSTG: PUSHJ P,.SAVE1 ;SAVE AN AC
SETZM STRDAT ;CLEAR STRING DATA
HRLI P1,STRDAT ;ADDRESS OF FIRST ONE
HRRI P1,1+STRDAT ;GET THE SECONDE WORD
BLT P1,4+STRDAT ;CLEAR THE DATA
HRLI P1,(POINT 7) ;GET POINTER
HRRI P1,STRDAT ;AND ADDRESS
GETS.1: PUSHJ P,GETCHR ;GET A CHARACTER
JUMPF GETS.3 ;NO MORE.. FINISH AND RETURN
CAIE S1,40 ;IS IT A BLANK?
CAIN S1,"-" ;OR A SEPERATOR
JRST GETS.3 ;YES..CHECK IF SEEN ANYTHING
CAIN S1,":" ;WAS IT A SEPERATOR?
JRST GETS.3 ;YES..CHECK IS SEEN ANYTHING
CAIL S1,"A"+40 ;LOWER CASE A
CAILE S1,"Z"+40 ;OR GREATER THAN LC Z
SKIPA ;IGNORE ADJUSTMENT
SUBI S1,40 ;MAKE IT UPPER CASE
CAIL S1,"0" ;IS IT 0 NUMBER OR UPPER CASE
CAILE S1,"Z" ;CHECK CHARACTER
JRST GETS.3 ;SETUP THE RETURN
GETS.2: IDPB S1,P1 ;SAVE THE CHARACTER
JRST GETS.1 ;GET NEXT ONE
GETS.3: SKIPN STRDAT ;ANY DATA SETUP?
$RETF ;NO..RETURN FALSE
MOVE S1,[POINT 7,STRDAT] ;GET POINTER TO DATA
$RETT ;RETURN TRUE
;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,<
?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
SETZ S1, ;CLEAR S1
CAIN S2,TADDX1 ;WAS IT TABLE IS FULL
MOVEI S1,ERTBF$ ;TABLE IS FULL
CAIN S2,TADDX2 ;ENTRY ALREADY IN TABLE
MOVEI S1,EREIT$ ;ENTRY ALREADY IN TABLE
JUMPN S1,.RETF ;NON-ZERO..RETURN FALSE
$STOP(UTR,UNRECOGNIZED TABLE ADD RETURN CODE)
>;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
SETZ S1, ;CLEAR S1
CAIN S2,TDELX1 ;WAS IT TABLE IS FULL
MOVX S1,ERTBF$ ;TABLE IS FULL
CAIN S2,TDELX2 ;ENTRY ALREADY IN TABLE
MOVX S1,ERITE$ ;ENTRY ALREADY IN TABLE
JUMPN S1,.RETF ;NON-ZERO..RETURN FALSE
PJRST S..UTR ;UNRECOGNIZED TABLE RETURN CODE
>;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
SCN%L: ;LABEL THE LITERAL POOL
END