Trailing-Edge
-
PDP-10 Archives
-
cuspjul86upd_bb-jf24a-bb
-
10,7/galaxy/glxlib/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/CTK/LWS 1-Mar-84
;
;
; COPYRIGHT (c) 1975,1976,1977,1978,1979,1980,1981,1982,
; 1983,1984,1985,1986
; DIGITAL EQUIPMENT CORPORATION
; ALL RIGHTS RESERVED.
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED
; AND COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE
; AND WITH THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS
; SOFTWARE OR ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR
; OTHERWISE MADE AVAILABLE TO ANY OTHER PERSON. NO TITLE TO
; AND OWNERSHIP OF THE SOFTWARE IS HEREBY TRANSFERRED.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE
; WITHOUT NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT
; BY DIGITAL EQUIPMENT CORPORATION.
;
; DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY
; OF ITS SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY
; DIGITAL.
SALL ;SUPPRESS MACRO EXPANSION
SEARCH GLXMAC ;OPEN SYMBOLS NEEDED
PROLOG(GLXSCN,SCN) ;PART OF LIBRARY, ETC...
SCNEDT==131 ;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. Date and Time Data Base................................... 6
; 5. Module Storage............................................ 7
; 6. S%INIT -- Initialize the GLXSCN Module.................. 8
; 7. S%ERR - ERROR TYPEOUT ROUTINE............................. 9
; 8. S%ERR -- ERROR MESSAGES FROM COMND................. 9
; 9. S%INTR -- Interrupt Level Breakout Routine.............. 10
; 10. S%CMND -- Scan a command................................ 11
; 11. S%EXIT -- Exit Address for Interrupt Breakout....... 12
; 12. S%SIXB -- Convert ASCII to SIXBIT................... 13
; 13. CNVSIX -- CONVERT ATOM BUFFER TO SIXBIT............. 13
; 14. S%NUMI -- NUMBER INPUT ROUTINE...................... 14
; 15. S%DATI Date input routine................................ 15
; 16. RETYPE -- Retype current line including the prompt...... 22
; 17. TYPRMT -- Retype the prompt if there is one............. 22
; 18. TYLINE -- Retype the line until current position........ 22
; 19. Atom Buffer Routines / INILCH - Init Atom Buffer.......... 29
; 20. Atom Buffer Routines / STOLCH - Store Character in Atom Buffer 29
; 21. Atom Buffer Routines / CHKLCH - Return Number of Characters 29
; 22. Atom Buffer Routines / TIELCH - Terminate Atom Buffer With NULL 29
; 23. CMCIN -- Read One Character for Processing.............. 30
; 24. HELPER -- Do caller supplied and default HELP text...... 33
; 25. DOHLP -- Do caller supplied HELP text................... 33
; 26. CMAMB -- Handle Ambiguous Typein........................ 33
; 27. Command Function / .CMINI - Init the scanner and do ^H.... 36
; 28. Command Function / .CMSWI - Parse a SWITCH................ 37
; 29. Command Function / .CMKEY - Parse a KEYWORD............... 38
; 30. Command Function / .CMTXT - Parse Arbitrary Text to Action Character 42
; 31. Function .CMNOI -- Parse a NOISE-WORD................... 42
; 32. Command Function / .CMCFM - Command Confirmation (end-of-line) 43
; 33. Command Function / .CMNUM - Parse an INTEGER in any base.. 45
; 34. Command Function / .CMNUX - Parse an INTEGER in any base (special break) 45
; 35. Command Function / .CMDEV - Parse a DEVICE specification.. 47
; 36. Command Function / .CMQST - Parse a QUOTED STRING......... 48
; 37. Command Function / .CMNOD - Parse a NODE Specification.... 49
; 38. PATHIN Routine to Parse TOPS-10 Path Specification....... 52
; 39. PATH SUPPORT ROUTINES..................................... 54
; 40. DATIM -- DATE AND TIME PARSER...................... 58
; 41. TIMPAR -- PARSE THE TIME FIELD...................... 59
; 42. PLSRTN -- PROCESS DATE WITH "+"..................... 60
; 43. MINRTN -- PROCESS DATE WITH "-"..................... 60
; 44. DAYRTN -- PROCESS DAY "D"........................... 60
; 45. CMPDAT -- COMPUTE THE DATE FROM VALUES.............. 61
; 46. DATEXT -- DATE EXIT ROUTINE......................... 62
; 47. MAKDAT -- ROUTINE TO MAKE A DATE AND TIME........... 62
; 48. DATPAR -- PARSE A DATE/DAY FIELD.................... 63
; 49. ALTDAT -- PARSE ALTERNATE DATE FORM................. 64
; 50. MONPAR -- ROUTINE TO CHECK FOR A MONTH.............. 65
; 51. YEARPR -- PARSE THE YEAR............................ 66
; 52. CNVDT -- CONVERT DATE TO UDT....................... 67
; 53. MNMPAR -- PARSE MNEMONICS........................... 68
; 54. GETCHR -- GET A CHARACTER FROM TIME FIELD........... 69
; 55. DECNUM -- GET A DECIMAL NUMBER...................... 69
; 56. DECBPT -- DECREMENT THE BYTE POINTER................ 69
; 57. GETSTG -- GET A STRING TO WORK FROM................. 70
; 58. CMDOUT -- CHARACTER OUTPUT FOR TERMINALS AND FILES.. 72
; 59. CMDSTO -- STRING OUTPUT TO FILE AND TERMINAL........ 72
; 60. S%SCMP -- String Comparison Routine..................... 73
; 61. S%TBLK -- Table lookup routine.......................... 75
; 62. S%TBAD -- Table Add Routine......................... 78
; 63. S%TBDL -- Table Delete Routine...................... 79
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
0040 Fix bug in PATHIN to allow defaulting like [,]
Change CMRFLD to test break character set before checking
special characters like ? and ESCAPE.
0041 Add entry for S%NUMI to parse integer
0042 Add entry for S%DATI to parse date/time
0043 Change CMPDAT to use T3 instead of P1 to prevent
illegal memory reference
0044 Change XCMDEV to require :, and do escape recognition
Change XCMNOD to require :: or _ as delimiter,
and to supply :: as the default.
0045 Fix XCMDEV, XCMNOD to not throw away char following :
or :: so DISM ST GAL0:/REM , etc, etc work again
0046 Fix some caps in XCMDEV
0047 Dump help text if JFN is NULIO
Don't display "or" for help if none is specified
0050 Rework error processing to use standard galaxy errors
0051 Fix date/time parsing code for TOPS10
0052 Add special case checking for Control-Z (TOPS-10 style
program exit character.
0053 Zero out $DATA space for this module.
0054 Don't type CRLF at TYPRMT unless TTY not at column zero.
0055 Make TYPRMT a noop if output device (.CMIOJ) not TTY.
0056 Fix indirect files, allow continuation lines in them, etc.
0057 Fix XCMTAD so it handles date/time fields before end of
line. [QAR 10-4894]
0060 Fix XCMTOK so it understands TOPS20-style string pointers.
0061 Have XDATIM check for future and past times and call
.DATIF and .DATIP accordingly. Also need to blast
the fake colon since no time should be specified
(MIDNIGHT and NOON)
0062 Rearrange AC usage at CMND.2 to avoid a TOPS20 Release 4
bug which clobbers T2.
0063 3/25/81 Get rid of fake colon. Change DATIC to check for space
and tab instead of colon. Remove colon adding code from
XCMTAD.
0064 4/1/81 Allow DATIC to accept colons still.
0065 4/2/81 Make parsing date/times work (separate 'em with space)
0066 5/4/81 Make XDATIM set true before calling DATNCI.
Have .DATIF and .DATIP check (-) and (+) for error.
0067 6/22/81 Make [,] return logged in PPN instead of current path.
Try to solve date/time scanning problems by eating the
extra space inserted @ DATIT.
0070 9/9/81 Fix GLXSCN bug at CMRAT2+7 :change JUMPG T1,CMRATT to
JUMPG T1,CMRATR so that we put the character back into
the atom buffer
0071 Make the S%DATI routines apply to both the -10 and
-20.
0072 Make date/time parsing work with " " and ":" separators.
0073 1371 Handle CM%NSF.
0074 1456 Do some majic to fix ^U'ed command that receives IPCF
interrupt. Save some ACs and restore same when interrupting.
Also set a couple if indeed in a ^U state. T10 only.
;**;Begin Galaxy 4.1 code maintence
0075 12 Digit octal numbers sign bit is dropped by S%NUMI
SPR 10-33455 27-SEP-83/CTK
0076 Fix problem when parsing "-" as a token. Always skip
spaces following, EOL or not.
0077 Don't allow defaulted filnames for indirect files.
Don't ABS when indirect file is too long to put in buffer.
0100 Fix problems parsing numeric field that has "+" or
"-" embedded.
3-Jan-84 /LWS/WD
0101 Make a $ALTERNATE that points to a $CRLF always work.
4-Jan-84 /LWS/WD
0102 Don't let ":" be a valid device name. /LWS
0103 10020 Fix problem where $DEFAULTing wasn't being done
correctly for tokens when CRLF was typed instead
of the token.
3-Apr-84 /LWS thanks to WXD
0106 10066 General cleanup and enhancements of TOPS-10 features:
1. Allow parsing of wildcarded PPNs. If CM%WLD is on,
return a two word block containing the PPN and mask.
2. Separate directory and user parsing functions.
3. Allow control-F and ESCAPE recognition to terminate
a PPN or directory parse.
4. Allow trailing square brackets on PPNs and directories
to be omitted if at end of line.
5. Allow [-] syntax in a directory spec.
6. Do path defaulting correctly.
7. Narrow minded programmer prevented the defaulting
of file names from working if an extension was typed.
8. Remove duplicate sixbit parse routine (FTOKEN).
CNVSIX works just fine.
9. Directory, filespec, or PPN error messages can
contain trailing junk if the number of characters
previously parsed was longer than those that caused
the current error because the atom buffer was not
terminated with a nul.
10. Account string parsing breaks on valid characters.
Allow all characters in the range of 40 to 176.
4-Aug-84 /DPM
0107 10070 Correct logic used to back up byte pointers when
pointers other than 7-bits are being used.
9-Aug-84 /DPM
0110 ?????
0111 10105 Add entry points S%U2DT (CNTDT) and S%DT2U (CNVDT).
12-OCT-84 /LWS
0112 10122 Add network filespec parsing routines.
15-Nov-84 /DPR
0113 10152 Save S1 around calls to CMDOUT since it is not guaranteed
to be saved by GLXLIB's K%BOUT.
21-Feb-85 /NT
0114 10177 Allow help requests when parsing wildcarded PPNs.
21-Mar-85 /DRB
0115 10205 Fix PPN parsing. QAR #10-868046.
7-May-85 /DPM
0116 10265 Recognize CM%WLA and allow accounting-style wildcarding
when parsing PPNs.
30-Jul-85 /DPM
117 10269 Incorporate a few fixes from TOPS-20 %6 COMND.MAC
1. Allow question mark in .CMTXT and .CMUQS fields.
2. Advance to next field when ESCAPE typed following
a token or user (PPN).
3. Handle ? in .CMFLD functions where ? is not a
break character (not fixed on the -20 yet).
120 10272 Don't try to type a prompt if the job is detached.
12-Aug-85 /DPM
121 10274 Handle PPN defaulting in .CMUSR function.
17-Aug-85 /DPM
122 10275 Don't allow a project or programmer number to be zero
when parsing a PPN.
21-Aug-85 /DPM
123 Change node name parsing to accept node names starting
with a number (e.g. "2LATE") as SIXBIT.
11-Oct-85 /CJA
124 10354 Don't use AC 17 as a BLT pointer in routine COMN1.
7-Jan-86 /NT
125 10360 Don't clobber TF in COMN1.
13-Jan-86 /RCB
126 10367 Parse full path spec with .CMDIR function.
20-Jan-86 /CJA
127 10368 Handle indirect command files (via "@") on the -10 correctly.
21-Jan-86 /JAD
130 10405 Add support for TB%ABR in S%TBAD and S%TBDL
10-May-86 /TL
131 10410 Fix spurrious <CR> appearing in unquoted strings term by CR.
24-May-86 /TL
\ ;END OF REVISION HISTORY
; Entry Points found in this module
ENTRY S%INIT ;INIT THE COMMAND SCANNER MODULE
ENTRY S%CMND ;SCAN A COMMAND
ENTRY S%SCMP ;COMPARE TWO STRINGS
ENTRY S%TBLK ;LOOK UP A STRING IN A TABLE
ENTRY S%ERR ;TYPE OUT SCANNER'S LAST ERROR
ENTRY S%INTR ;INTERRUPT BREAKOUT
ENTRY S%EXIT ;INTERRUPT DEBRK ADDRESS FOR COMND
ENTRY S%TBAD ;ADD ENTRY TO COMMAND TABLES
ENTRY S%TBDL ;DELETE ENTRY FROM COMMAND TABLES
ENTRY S%SIXB ;CONVERT ASCII STRING TO SIXBIT VALUE
ENTRY S%NUMI ;CONVERT ASCII STRING TO NUMBER
ENTRY S%DATI ;CONVERT ASCIZ STRING TO DATE
ENTRY S%U2DT ;CONVERT UDT TO SEPARATE DATE AND TIME
ENTRY S%DT2U ;CONVERT SEPARATE DATE AND TIME TO UDT
SUBTTL Local Definitions
; Special Accumulator definitions
P5==P4+1 ;S%CMND NEEDS LOTS OF ACS
F==14 ;FLAG AC
Q1==15 ;
Q2==16 ;DON'T DEFINE Q3 OR Q4
; Bad parse return macro
DEFINE NOPARS(CODE) <
PJRST [MOVEI T1,ER'CODE'$
PJRST XCOMNE]
> ;END OF NOPARS DEFINITION
; Special bit testing macros
DEFINE JXN(AC,FLD,ADDR)<
TXNN AC,FLD
XLIST
SKIPA
JRST ADDR
LIST
SALL
> ;END OF JXN DEFINITION
DEFINE JXE(AC,FLD,ADDR)<
TXNE AC,FLD
XLIST
SKIPA
JRST ADDR
LIST
SALL
> ;END OF JXE DEFINITION
DEFINE RETSKP<JRST [AOS 0(P)
POPJ P,] >
; Bit table - 36. Words long with word N containing 1B<N>
XX==0
BITS: XLIST
REPEAT ^D36,<EXP 1B<XX>
XX==XX+1>
LIST
SUBTTL Module Storage
GLOB <.LGERR,.LGEPC> ;GLOBAL ERROR LOCATIONS
$DATA SCNBEG,0 ;START OF ZEROABLE $DATA SPACE
$DATA ATBPTR ;ATOM BUFFER POINTER (END)
$DATA ATBSIZ ;ATOM BUFFER SIZE
$DATA STKFEN ;FENCE FOR STACK RESTORATION
$DATA FNARG ;FUNCTION ARGUMENT
$DATA CMCCM,2 ;SAVED CC CODES
$DATA CMRBRK ;POINTER TO BREAK SET TABLE
$DATA CMCSF ;SAVED FLAGS
$DATA CMCSAC,7 ;SAVED ACS DURING S%TXTI FROM S%CMND
$DATA CMCSC ;
$DATA CMCBLF ;
$DATA TBA ;TABLE ARGUMENTS
$DATA STRG ;TEMP STRING POINTER
$DATA REMSTR ;"REMEMBER"ED STRING
$DATA XXXPTR ;RE-USABLE STRING POINTER STORAGE
$DATA FDFSIZ ;Size of users FD string buffer
$DATA FDFPTR ;Pointer to users FD string buffer
$DATA BEGPTR ;Pointer to beginning of parsed field
$DATA ENDPTR ;Pointer to end of parsed field
$DATA PRSDND ;Flag parsed node name
$DATA PRSDAC ;Flag parsed access string
$DATA PRSDDV ;Flag parsed device name
$DATA PRSDNM ;Flag parsed file name
$DATA PRSDEX ;Flag parsed file extension
$DATA PRSDGN ;Flag parsed generation number
$DATA PRSDDR ;Flag parsed directory
$DATA CRBLK,CR.SIZ ;RETURNED BLOCK OF ANSWERS
$DATA TABDON ;END OF TAB FOR "?"
$DATA TABSIZ ;SIZE OF TAB LARGER THAN LARGEST KEYWORD
$DATA LSTERR ;ERROR CODE OF FIRST PARSE FAILURE
$DATA LSTEPC ;PC OF FIRST PARSE FAILURE
$DATA BIGSIZ ;LENGTH OF LONGEST KEYWORD
$DATA PWIDTH ;TERMINAL'S WIDTH
$DATA CURPOS ;LINE POSITION OF CURSOR
$DATA Q3SAVE ;NO Q3 EXISTS
$DATA IFOB ;INDIRECT FILESPEC FOB
$DATA IIFN ;IFN OF INDIRECT FILE
$DATA TI,.RDSIZ ;S%TXTI ARGUMENT BLOCK
$GDATA SAVBUF,ERRBSZ ;BUFFER FOR ERROR MESSAGES
;S%ERR AND SCRATCH
TOPS10 <
$DATA CMDACS,20 ;AC SAVE AREA FOR COMMAND
$DATA PPNWRD ;PPN WORD
$DATA PPNMSK ;PPN MASK
$DATA INCMND ;FLAG FOR IN COMMAND STATE
$DATA TBADDR ;ADDRESS OF COMMAND TABLE
$DATA ENTADR ;ADDRESS OF ENTRY FOR TABLE
$DATA SPCBRK ;SPECIAL BREAK MASK
$DATA JFNWRD ;WORD CONTAINING THE JFNS
$DATA ACFLG ;FLAG TO VALIDATE INTERRUPT SAVED ACs
$DATA A07T16,10 ;BLOCK TO SAVE ACS FROM 7 TO 16
; DURING K%TXTI IN CASE OF INTERRUPT
>;END TOPS10 CONDITIONAL
$DATA INTRPT ;FLAG FOR S%INTR
TOPS20 <
$DATA BLKSAV ;COMMAND BLOCK ADDRESS
$DATA BUFCNT ;SIZE OF COMMAND BUFFER
>;END TOPS20 CONDITIONAL
$DATA SCNEND,0 ;END OF ZEROABLE $DATA SPACE
SUBTTL S%INIT -- Initialize the GLXSCN Module
TOPS10 <
S%INIT: MOVE S1,[SCNBEG,,SCNBEG+1] ;BLT PTR TO ZEROABLE $DATA SPACE
SETZM SCNBEG ;ZERO OUT FIRST LOC
BLT S1,SCNEND-1 ;AND ZOOM OUT THE REST
MOVSI S2,'TTY' ;LOAD TTY NAME
IONDX. S2, ;GET THE I/O INDEX
JFCL ;IGNORE THE ERROR
MOVX S1,.TOWID ;GET TERMINAL WIDTH FUNCTION
MOVE T1,[2,,S1] ;ARG POINTER
TRMOP. T1, ;GET THE NUMBER
MOVEI T1,^D72 ;USE A DEFAULT
MOVEM T1,PWIDTH ;AND SAVE IT
SETZM ACFLG ;INITIALLY NO SAVED INTERRUPT ACS
$RETT ;AND RETURN
> ;END TOPS10 CONDITIONAL
TOPS20 <
S%INIT: $RETT ;RETURN
> ;END TOPS20 CONDITIONAL
SUBTTL S%ERR - ERROR TYPEOUT ROUTINE
SUBTTL S%ERR -- ERROR MESSAGES FROM COMND
;CALL PUSHJ P,S%ERR
;
;RETURN TRUE: S1/ ADDRESS OF MESSAGE--ASCIZ
;
;RETURN FALSE: NO MESSAGE
TOPS10 <
S%ERR: HRRZ S1,LSTERR ;GET THE LAST ERROR
JUMPE S1,.RETF ;NO MESSAGE RETURN FALSE
$TEXT (<-1,,SAVBUF>,<^E/S1/^0>) ;OUTPUT THE MESSAGE
MOVEI S1,SAVBUF ;ADDRESS OF MESSAGE
$RETT ;RETURN TRUE
> ;END TOPS10 CONDITIONAL
TOPS20 <
S%ERR: HRROI S1,SAVBUF ;POINTER TO BUFFER
MOVE S2,[.FHSLF,,-1] ;OUR LAST ERROR
HRLZI T1,-ERRBSZ*5 ;MAXIMUM NUMBER OF CHARACTERS
ERSTR ;TYPE OUT THE ERROR STRING
$RETF ;UNDEFINED ERROR NUMBER
$RETF ;BAD DESTINATION DESIGNATOR
MOVEI S1,SAVBUF ;POINT TO THE MESSAGE
$RETT ;RETURN TRUE
> ;END TOPS20 CONDITIONAL
SUBTTL S%INTR -- Interrupt Level Breakout Routine
;S%INTR should be called at interrupt level to request that command
; breakout as soon as possible and to mark that interrupt occurred.
; CALL: S1/ PC Address at Interrupt
;
; RETURN TRUE: In COMND S1/ SPACE LEFT IN INPUT BUFFER
;
; RETURN FALSE: Not in COMND
;
S%INTR: SETOM INTRPT ;SET THE FLAG
TOPS10 <
SKIPN INCMND ;ARE WE IN COMND
$RETF ;NO..RETURN FALSE
MOVE S1,RD##+.RDDBC ;COUNT OF SPACE LEFT
$RETT ;RETURN TRUE
>;END TOPS10 CONDITIONAL
TOPS20 <
TXNE S1,1B5 ;IN EXEC MODE?
$RETF ;NO..USER MODE..RETURN FALSE
HRRZS S1 ;GET ONLY RIGHT HALF
CAIL S1,CMND.2 ;IS PC IN COMND JSYS
CAIL S1,CMND.3 ;THEN BETWEEN TWO LABELS
$RETF ;NO..RETURN FALSE
MOVE S1,BLKSAV ;GET ADDRESS OF COMMAND BLOCK
MOVE S1,.CMCNT(S1) ;GET BUFFER SIZE IN S1
$RETT ;YES..COMND..RETURN TRUE
>;END TOPS20 CONDITIONAL
SUBTTL S%CMND -- Scan a command
;LOCAL FLAGS (RH OF F)
CMQUES==1B18 ;? TYPED
CMSWF==1B19 ;BEG OF SWITCH SEEN
CMUSRF==1B20 ;USER NAME REQUIRED
CMDEFF==1B21 ;DEFAULT FIELD GIVEN
CMCFF==1B22 ;^F RECOGNIZED FIELD
CMQUE2==1B23 ;IN SECOND OR SUBSEQUENT HELP POSSIBILITY
CMBOL==1B24 ;FIELD IS AT BEG OF LINE
CMTF1==1B25 ;INTERNAL TEMP FLAG
CMINDF==1B26 ;DOING GTJFN ON INDIRECT FILE
;FLAGS IN FUNCTION DISPATCH TABLE
CMNOD==1B0 ;NO DEFAULT POSSIBLE
NOIBCH=="(" ;NOISE WORD BEG CHARACTER
NOIECH==")" ;NOISE WORD END CHARACTER
CMSWCH=="/" ;SWITCH CHARACTER
CMSWTM==":" ;SWITCH TERMINATOR
CMHLPC=="?" ;HELP CHARACTER
CMCOM1=="!" ;COMMENT CHARACTER
CMCOM2==";" ;FULL LINE COMMENT CHARACTER
CMDEFC=="#" ;DEFAULT FIELD CHARACTER
CMFREC=="F"-100 ;FIELD RECOGNITION CHARACTER
CMINDC=="@" ;INDIRECT FILE CHARACTER
CMRDOC=="H"-100 ;REDO COMMAND CHARACTER
CMQTCH=="""" ;CHARACTER FOR QUOTED STRINGS
CMCONC=="-" ;LINE CONTINUATION CHARACTER
SUBTTL S%EXIT -- Exit Address for Interrupt Breakout
;THE ADDRESS OF S%EXIT IS PLACED IN THE INTERRUPT PC TO FORCE RETURN
;TO THAT ADDRESS AT INTERRUPT IN COMND THAT WE WANT TO BREAKOUT OF.
;THE NECESSARY CLEANUP WILL BE DONE SO S%CMND CAN RETURN.
TOPS20 <
S%EXIT: PJRST CMND.3 ;FIX UP RETURN
>;END TOPS20 CONDITIONAL
TOPS10 <
S%EXIT:
;Restore some AC's from before K%TXTI if necessary
SKIPN ACFLG ;Want to restore some AC's?
JRST EXIT.1 ;No, skip this part
HRLZI 0,A07T16 ;Source address
HRRI 0,7 ;Destination address
BLT 0,16 ;Restore some AC's
SETZM ACFLG ;Restore only once
; Now if we are comming from a ^U, we need to fix some things up
EXIT.1: MOVE 0,.CMCNT(P2) ;Get origional count of buffer
CAME 0,RD##+.RDDBC ;Save as what is left?
PJRST XCOMXI ;No, must not be ^U
MOVE P3,0 ;Set the count to the origional
MOVE P4,.CMBFP(P2) ;Set to beginning of user buffer
SETZ P5, ;No characters to be parsed
TXZ F,CM%ESC ;No way we can have ^U terminated
; with an escape
PJRST XCOMXI ;SETUP PROPER RETURN
>;END TOPS10 CONDITIONAL
SUBTTL S%SIXB -- Convert ASCII to SIXBIT
;
;S1/ ASCII BYTE POINTER Returned updated
;S2/ SIXBIT value
S%SIXB: TLCE S1,-1 ;Left half of ptr = 0?
TLCN S1,-1 ;... or -1 ?
JRST [HRLI S1,(POINT 7,) ;Yes, Make up pointer for caller
JRST S%SIX1] ;Re enter flow
HRRI S1,@S1 ;Compute effective addr
TLZ S1,(@(17)) ;Remove indirection and index
S%SIX1: PUSHJ P,CNVSIX ;Do the work
$RETT ;Always return true
SUBTTL CNVSIX -- CONVERT ATOM BUFFER TO SIXBIT
;Internal entry point
;Same calling args
;Returns false if more than 6 chars are passed
CNVSIX: PUSHJ P,.SAVET ;Preserve the caller's T's
MOVEI T2,6 ;GET MAX NUMBER OF CHARACTERS IN NAME
MOVE T4,[POINT 6,S2] ; BP TO NODE STORAGE
SETZM S2 ;START FRESH
CNVS.1: ILDB T3,S1 ;GET NEXT CHARACTER FROM ATOM BUFFER
CAIL T3,"A"+40 ;LESS THAN LC A
CAILE T3,"Z"+40 ;OR GREATER THAN LC Z
SKIPA ;YES, NOT A LC CHARACTER
SUBI T3,40 ;NO, ITS LC, MAKE IT UC
CAIL T3,"0" ;RANGE
CAILE T3,"9" ; CHECK
CAIL T3,"A" ; THE
CAILE T3,"Z" ; CHARACTER
$RETT ;NO GOOD--RETURN
SUBI T3,"A"-'A' ;SIXBITIZE
IDPB T3,T4 ;FILL OUT SIXBIT NODE NAME
SOJGE T2,CNVS.1 ;HAVE WE SEEN ENOUGH CHARACTERS?
$RETF ;ERROR..RETURN FALSE
SUBTTL S%NUMI -- NUMBER INPUT ROUTINE
;THIS ROUTINE WILL PARSE A NUMBER FROM A STRING AND RETURN THE
;VALUE
;
;CALL S1/ POINTER TO THE STRING
; S2/ RADIX
;
;RETURN TRUE:
; S1/ UPDATED POINTER
; S2/ NUMBER
S%NUMI: CAIL S2,^D2 ;CHECK FOR PROPER RADIX
CAILE S2,^D10
$RETE (RAD) ;INVALID RADIX
PUSHJ P,NUMIN
$RETIT ;RETURN IF TRUE
$RETE (NUM) ;BAD NUMBER
NUMIN: PUSHJ P,.SAVE3 ;GET 2 SCRATCH ACS
SETZ P2, ;CLEAR SIGN MODIFIER
NUMI.1: ILDB P1,S1 ;GET FIRST CHARACTER
CAIN P1," " ;A BLANK?
JRST NUMI.1 ;YES, IGNORE IT
CAIN P1,"-" ;IS IT MINUS SIGN?
JRST [JUMPN P2,.RETF ;ONLY ALLOW ONE SIGN
MOVX P2,-1 ;SET NEGITIVE
JRST NUMI.1] ;GET NEXT CHARACTER
CAIN P1,"+" ;IS IT PLUS SIGN?
JRST [JUMPN P2,.RETF ;ONLY ALLOW ONE SIGN
MOVX P2,+1 ;SET POSITIVE
JRST NUMI.1] ;GET NEXT CHARACTER
CAIG P1,"0"-1(S2) ;TOO BIG
CAIGE P1,"0" ;OR TOO SMALL?
$RETF ;YES, TAKE FAILURE RETURN
SETZ P3,0 ;CLEAR THE RESULT
NUMI.2:
;**;[75]ADD 3 LINES AT NUMI.2:+0L 27-SEP-83/CTK
CAXN S2,^D8 ;[75] RADIX 8 ???
LSH P3,3 ;[75] YES, USE SHIFT INSTEAD OF MULTIPLY
CAXE S2,^D8 ;[75] NON-RADIX 8 ??
IMULI P3,0(S2) ;SHIFT OVER 1 DIGIT
ADDI P3,-"0"(P1) ;AND ADD IN THIS ONE
ILDB P1,S1 ;GET NEXT CHAR
CAIG P1,"0"-1(S2) ;IN RANGE?
CAIGE P1,"0"
JRST NUMI.3 ;FINISH OFF AND RETURN
JRST NUMI.2 ;YES, REPEAT
NUMI.3: SKIPGE P2 ;SHOULD BE NEGATIVE?
MOVNS P3 ;MAKE IT NEGATIVE
MOVE S2,P3 ;GET THE VALUE
$RETT ;RETURN TRUE
SUBTTL S%DATI Date input routine
;THIS ROUTINE WILL PARSE DATE/TIME STRING
;AND RETURN A UDT
; CALL S1/ POINTER TO ASCIZ DATE/TIME STRING
; S2/ FLAGS (CM%IDA!CM%ITM!CM%NCI+Address)
; RETURN S1/ UPDATED POINTER
; S2/ UDT
;IF CM%NCI with an address (not in ACs) the time will also
;be returned in a three word block at address
S%DATI: PUSHJ P,.SAVET ;PRESERVE TEMPORARIES
PJRST XDATIM ;PARSE THE FIELXD ANXD RETURN
;The S%CMND routine provides a command scanner interface similar to the
; TOPS-20 COMND JSYS.
;CALL IS: S1/ Pointer to Command State Block
; S2/ Pointer to list of Function Descriptor Blocks
; See GLXMAC or MONSYM for a description of these
;TRUE RETURN: S1/ Length of Command Reply block
; S2/ Address of the Command Reply block
TOPS20 <
S%CMND: MOVEM S1,BLKSAV ;SAVE THE COMMAND BLOCK ADDRESS
MOVE S1,.CMCNT(S1) ;GET SIZE OF THE BUFFER
MOVEM S1,BUFCNT ;SAVE BUFFER COUNT
MOVE S1,BLKSAV ;RESTORE S1
PUSH P,.CMFLG(S1) ;SAVE THE REPARSE ADDRESS
PUSH P,S1 ;SAVE ADDRESS OF CSB
HLLZS .CMFLG(S1) ;AND ZERO OUT REPARSE ADDRESS
PUSHJ P,CMND.2 ;DO THE COMMAND JSYS
POP P,S2 ;GET CSB ADDRESS
POP P,S1 ;GET THE REPARSE ADDRESS
HRRM S1,.CMFLG(S2) ;RESET THE REPARSE ADR
TRNN S1,-1 ;IS THERE ONE?
JRST CMND.1 ;NO, RETURN NORMALLY
MOVX S2,CM%RPT ;YES, GET REPARSE BIT
TDNE S2,CRBLK+CR.FLG ;WAS IT SET???
HRRM S1,0(P) ;YES, STORE REPARSE ADDRESS FOR RETURN
CMND.1: MOVEI S1,CR.SIZ ;LOAD SIZE OF COMMAND RESPONSE BLOCK
MOVEI S2,CRBLK ;LOAD ADDRESS OF COMMAND RESP. BLK.
POPJ P, ;AND PROPAGATE T/F RETURN FROM CMND.2
CMND.2: PUSHJ P,.SAVET ;SAVE T1-T4
SETZ T3, ;ASSUME TRUE RETURN
SKIPN INTRPT ;DID INTERRUPT OCCUR SKIP COMND
COMND ;DO THE COMMAND JSYS
ERJMP [SETO T3, ;SET FALSE RETURN
JRST CMND.3] ;AND CONTINUE ON
CMND.3: SETZ T2, ;SET FLAG
EXCH T2,INTRPT ;GET CURRENT FLAG AND RESET
MOVE T4,BLKSAV ;ADDRESS OF COMMAND BLOCK
MOVE T4,.CMCNT(T4) ;ROOM LEFT IN BUFFER
CAMGE T4,BUFCNT ;DID WE HAVE ANY DATA
JRST CMND.4 ;YES..IGNORE INTERRUPT FLAG
SKIPE T2 ;INTERRUPT BEFORE COMMAND
TXO S1,CM%INT ;YES..SET INTERRUPT FLAG
CMND.4: MOVEM S1,CRBLK+CR.FLG ;SAVE FLAGS
MOVEM S2,CRBLK+CR.RES ;SAVE DATA FIELD
MOVEM T1,CRBLK+CR.PDB ;SAVE PDB ADDRESS
; TXNE S1,CM%NOP ;NO PARSE?
; SETO T3, ;YES, RETURN FALSE
LOAD S1,.CMFNP(T1),CM%FNC ;GET FUNCTION DONE
MOVEM S1,CRBLK+CR.COD ;SAVE IT
JUMPL T3,.RETF ;RETURN FALSE IF COMND FAILED
$RETT ;ELSE, RETURN TRUE
> ;END TOPS20 CONDITIONAL
TOPS10 <
;!!!!!NOTE WELL - THIS CONDITIONAL RUNS TO THE END OF COMND ROUTINE
S%CMND: SETZM LSTERR ;CLEAR LAST ERROR INDICATOR
MOVEM 0,CMDACS ;SAVE THE COMMAND ACS
MOVE 0,[XWD 1,CMDACS+1] ;SET UP BLT POINTER
BLT 0,CMDACS+17 ;SAVE THE ACS
MOVEI 0,@0(P) ;GET CALLING PC ADDRESS
MOVEM 0,LSTEPC ;SAVE IN CASE OF NOPARSE
MOVE 0,CMDACS ;RESTORE 0
PUSHJ P,XCOMND ;DO THE WORK
HRRZ T4,.CMFLG(P2) ;GET REPARSE ADDRESS IF ANY
JUMPE T4,COMN1 ;NONE..JUST RETURN
TXNN F,CM%RPT ;REPARSE NEEDED..
JRST COMN1 ;NO..JUST RESTORE AND RETURN
HRRZ T3,CMDACS+17 ;GET STACK LOCATION
HRRM T4,@T3 ;YES..RETURN TO REPARSE
COMN1: SETZM INCMND ;CLEAR IN COMMAND STATE
MOVE T1,[CMDACS+T2,,T2] ;SETUP TO RESTORE ACS
BLT T1,17 ;RESTORE T2-17
MOVE T1,CMDACS+T1 ;GET T1 BACK AS WELL
POPJ P,0 ;THEN 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
;**;[76] Insert 1 line at XCOM2+13L. 21-Dec-83 /LWS
PUSHJ P,INILCH ;[76] SKIP SPACES
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,CHKCFM ;[101] SEE IF THERE IS A CONFIRM IN THE LIST
SKIPA ;[101] NO, REISSUE PROMPT
JRST XCOM4 ;[101] YES, PROCESS IT
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
;[101] CHKCFM - ROUTINE TO SEE IF A .CMCFM FUNCTION APPEARS ON THE USER'S LIST
;[101] ACCEPTS P1/ POINTER TO USER'S FUNCTION BLOCK
;[101] CALL CHKCFM
;[101] RETURNS +1: IF THERE IS NO .CMCFM ON THE LIST, P1 UNCHANGED
;[101] +2: IF A .CMCFM IS ON THE LIST, P1 IS UPDATED FOR THAT BLOCK
;[101] USES T1.
CHKCFM: STKVAR <LSTPTR> ;[101] TO SAVE P1
MOVEM P1,LSTPTR ;[101] SAVE P1 IN CASE WE NEED TO RESTORE IT
CHKCFL: LOAD T1,.CMFNP(P1),CM%FNC ;[101] GET FUNCTION CODE FROM BLOCK
CAIN T1,.CMCFM ;[101] CONFIRM?
RETSKP ;[101] YES, RETURN SKIP, P1 POINTS TO ITS BLOCK
LOAD T1,.CMFNP(P1),CM%LST ;[101] GET THE POINTER TO THE NEXT BLOCK
HRRM T1,P1 ;[101] UPDATE P1 TO THE NEXT BLOCK
JUMPN T1,CHKCFL ;[101] LOOP AND CHECK BLOCK IF IT EXISTS
MOVE P1,LSTPTR ;[101] BUT IF AT END, RESTORE OLD VALUE OF P1
POPJ P, ;[101] AND RETURN NONSKIP
ENDSV.
;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
;[100] RESET EVERYTHING SUCH THAT FIELD CAN BE REREAD.
;[100] THIS ROUTINE IS USEFUL IF FIELD IS READ, AND THEN WE DECIDE WE WANT
;[100] TO REREAD IT WITH A DIFFERENT LENGTH OR BREAK SET SPECIFIED.
CMFSET: PUSHJ P,CMRSET ;[100] PUT MAIN POINTER TO BEGINNING OF FIELD
PUSHJ P,INILCH ;[100] RESET POINTER TO ATOM BUFFER
TXZ F,CM%ESC+CM%EOC+CMCFF+CMQUES ;[100] RESET PARSET
POPJ P, ;[100]
;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
FIXESC: PUSHJ P,CMCIN ;READ CHARACTER AFTER FIELD
FIXES1: TXNN F,CM%ESC ;ESCAPE AFTER FIELD?
PUSHJ P,CMDIP ;NO, PUT IT BACK
XCOMXR: TXNE F,CM%ESC ;RECOG CHARACTER TERMINATED?
PUSHJ P,CMDCH ;YES, FLUSH IT
XCOMXI: TXZ F,CM%RPT ;CLEAR THE REPARSE FLAG
TXZN F,CM%ESC ;FIELD TERMINATED WITH RECOG?
JRST XCOMX1 ;NO
TXNE F,CMCFF ;^F RECOG?
JRST XCOMRF ;YES, GET MORE INPUT BEFORE RETURNING
TXO F,CM%ESC ;SET FLAG
MOVEI T1," " ;TERMINATE TYPESCRIPT WITH SPACE
PUSHJ P,CMDIB
XCOMX1: SETZ S1, ;CLEAR S1
EXCH S1,INTRPT ;GET THE CURRENT FLAG AND RESET
SKIPE S1 ;DID WE HAVE AN INTERRUPT
TXO F,CM%INT ;YES..SET RETURN FLAG
CAMGE P3,.CMCNT(P2) ;DID WE HAVE ANY PROCESSING
TXZ F,CM%INT ;YES..CLEAR POSSIBLE INTERRUPT FLAG
MOVEM P3,.CMCNT(P2) ;UPDATE VARIABLES
MOVEM P4,.CMPTR(P2)
MOVEM P5,.CMINC(P2)
XCOMX2: MOVE P,STKFEN ;RESET STACK
DMOVE S1,CMCCM ;GET SAVED CC MODES
PUSHJ P,K%WCOC ;RESTORE THEM
MOVEM P1,CRBLK+CR.PDB ;RETURN PTR TO FUNCTION BLOCK USED
TXZ F,CM%FFL ;FLUSH FUNCTION FLAGS
HLLM F,.CMFLG(P2) ;RETURN FLAGS
MOVEM P2,CRBLK+CR.FLG ;STORE BLK ADDRESS
HLLM F,CRBLK+CR.FLG ;AND THE FLAGS
HRRZ T1,CRBLK+CR.PDB ;GET THE CURRENT PDB
LOAD S1,.CMFNP(T1),CM%FNC ;GET FUNCTION CODE
MOVEM S1,CRBLK+CR.COD ;SAVE THE CODE
MOVEI S1,CR.SIZ ;LOAD SIZE OF RETURNED BLOCK
MOVEI S2,CRBLK ;AND ITS LOCATION
$RETT ;AND TAKE A GOOD RETURN
;FAILURE RETURNS - FAILED TO PARSE
XCOMNE: SKIPN LSTERR ;ANY ERRORS YET?
MOVEM T1,LSTERR ;NO..SAVE ONLY THE FIRST
XCOMNP: JXN F,CMQUES,CMRTYP ;IF IN HELP, DON'T RETURN NOW
PUSHJ P,CMRSET ;RESET FIELD VARIABLES
MOVEM P5,.CMINC(P2) ;FIX USER BLOCK
LOAD T1,.CMFNP(P1),CM%LST ;GET PTR TO NEXT FN BLOCK
HRRM T1,P1 ;SAVE IT
JUMPN T1,XCOMN0 ;DISPATCH IF THERE IS ANOTHER FUNCTION
TXO F,CM%NOP ;NO OTHER POSSIBILITIES, SAY NO PARSE
MOVE T1,LSTEPC ;GET THE LAST ERROR PC
MOVEM T1,.LGEPC ;SAVE FOR ERROR ROUTINE
MOVE T1,LSTERR ;SET GLOBAL ERROR INDICATORS
MOVEM T1,.LGERR
JRST XCOMX2
;HERE AFTER EACH HELP OUTPUT
CMRTYP: PUSHJ P,CMRSET ;RESET FIELD VARIABLES
LOAD T1,.CMFNP(P1),CM%LST ;GET NEXT FUNCTION IN LIST
HRRM T1,P1
TXO F,CMQUES+CMQUE2 ;NOTE IN SECOND HELP POSSIBILITY
JUMPN T1,XCOMN0 ;DO SUBSEQUENT HELPS
;[32] MOVEI S1,.CHLFD ;START NEW LINE
;[32] PUSHJ P,CMDOUT
HLR P1,P1 ;END OF LIST, REINIT IT
SOS P5 ;FLUSH QMARK FROM INPUT
TXZ F,CMQUES+CMQUE2 ;NOTE NOT IN HELP
PUSHJ P,RETYPE ;RETYPE LINE
JRST XCOMN0 ;RESTART PARSE OF CURRENT FIELD
XCOMEO: TXO F,CM%NOP ;SET NO PARSE
MOVEI S2,CRBLK
MOVE P,STKFEN ;FIXUP STACK
$RETF
SUBTTL RETYPE -- Retype current line including the prompt
RETYPE: PUSHJ P,TYPRMT ;RETYPE THE PROMPT
PUSHJ P,TYLINE ;RETYPE THE LINE THUS FAR
$RETT ;AND RETURN
SUBTTL TYPRMT -- Retype the prompt if there is one
TYPRMT: HRRZ S1,.CMIOJ(P2) ;Get output designator
CAIE S1,.PRIOU ;TTY?
$RETT ;No, just return then
PUSHJ P,K%TPOS ;Get horizontal position of terminal
JUMPF TYPR.0 ;DON'T PROMPT IF DETACHED
SKIPE S1 ;At column zero?
PUSHJ P,CRLF ;No, type crlf
TYPR.0: 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
MOVEI T1," " ;[127] TERMINATE PRECEDING FIELD
PUSHJ P,CMDIBQ ;[127]
CMIND1: MOVE S1,IIFN ;GET IFN
PUSHJ P,F%IBYT ;GET A BYTE
;**;[77] Insert 1 line at CMIND1+1L. 28-Dec-83 /LWS
JUMPE P3,CMINE1 ;[77] JUMP IF BUFFER FULL
JUMPF CMIND2 ;IF FAILS FIND OUT WHY
JUMPE S2,CMIND1 ;Ignore nulls (Grrr...!!)
CAIN S2,CMCONC ;Possible line continuation?
JRST [ MOVE S1,IIFN ;Yes, see if EOL next
PUSHJ P,F%IBYT ;Get next char
JUMPF [ MOVEI T1,CMCONC ;EOF... stuff the hyphen
PUSHJ P,CMDIBQ ; ..
JRST CMIND2] ;Close file and finish up
CAIE S2,CMRDOC ;Ignore ^H
CAIN S2,.CHCRT ; and CR
JRST .
CAIN S2,.CHLFD ;Line feed?
JRST .+1 ;Yes, stuff it and forget the hyphen
MOVEI T1,CMCONC ;No, I guess the hyphen was real, then
PUSHJ P,CMDIBQ ; so put it into the guy's buffer
JRST .+1] ;Now handle the next char
CAIE S2,CMRDOC ;IGNORE ^H
CAIN S2,.CHCRT ;IGNORE CR
JRST CMIND1
CAIE S2,.CHLFD ;CONVERT EOL TO SPACE
CAIN S2,.CHESC ;DITTO ESC (BUT THERE SHOULDN'T BE ANY)
MOVEI S2," "
MOVE T1,S2 ;COPY CHARACTER
PUSHJ P,CMDIBQ ;PUT CHAR IN BUFFER WITHOUT TYPEOUT
JRST CMIND1
CMIND2: MOVE S1,IIFN ;CLOSE OFF THE FILE NOW
PUSHJ P,F%REL ;
MOVEI T1,.CHLFD ;TIE OFF LINE
PUSHJ P,CMDIBQ
JRST XCOMRP ;REPARSE LINE AS NOW CONSTITUTED
CMINDE: PUSHJ P,I%IOFF ;TURN OFF INTERRUPTS
$TEXT(T%TTY,<^M^J?Problem with Indirect File: ^E/[-1]/>)
PUSHJ P,I%ION ;THEN TURN THEM BACK ON
TXO F,CM%NOP ;RETURN FAILURE, NO CHECK ALTERNATIVES
JRST XCOMX2
;**;[77] Insert 3 lines after CMINDE+4L. 28-Dec-83 /LWS
CMINE1: MOVE S1,IIFN ;[77] GET INDIRECT FILE IFN
PUSHJ P,F%REL ;[77] RELEASE THE FILE
NOPARS (IFB) ;[77] GIVE THE ERROR MESSAGE
;****************************************
;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
;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 "]")
PJRST CMRPP1 ;ENTER COMMON PPN/PATH TERMINATION CODE
PTHBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
777714,,001760 ;ALLOW , - 0-9
400000,,000360 ;BREAK ON "]" ALLOW UC AND "["
400000,,000760 ;ALLOW LC
;READ NETWORK 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,...]
CMRNFL: MOVEI T1,NFLBRK
PUSHJ P,CMRFLD ;GET NODE::DEV:NAME.EXT
; TXZE F,CMQUES ;IF HELP (?)
; JRST CMRNFL ;THAT IS A WILD CHAR SO KEEP GOING
MOVE T1,P4 ;GET POINTER TO LAST BYTE PARSED
ILDB T1,T1 ;GET TERMINATOR
CAIN T1,"""" ;IF QUOTED STRING
JRST [PUSHJ P,CMRQUO ;READ IT IN
POPJ P, ;SOMETHING WRONG
JRST CMRNFL] ;LOOP FOR MORE
CAIE T1,"[" ;PPN ?
POPJ P,0 ;NO, DONE
PUSHJ P,CMRNPT ;YES -- GET DIRECTORY
JRST CMRNFL ;COULD BE MORE TO FOLLOW
NFLBRK: 777777,,777760 ;BREAK ON ALL CC
747544,,000120 ;ALLOW . 0-9 :-$*%<>;
400000,,000740 ;ALLOW UC _
400000,,000760 ;ALLOW LC
;CMRPTH Routine to Read a possible TOPS-10 Path Specification from buffer
CMRNPT: MOVEI T1,NPTBRK ;POINT TO PATH BREAK SET
PUSHJ P,CMRFLD ;GET PATH (UP TO "]")
TXNE F,CMQUES ;RETURN IF HELP REQUESTED
POPJ P,
; TXZE F,CMQUES ;HELP (?)
; JRST CMRNPT ;WILD CHAR, KEEP IT
MOVE T1,P4 ;GET POINTER TO LAST CHARACTER
ILDB T1,T1 ;GET TERMINATOR
CAIN T1,"]" ;END OF PATH?
JRST CMRN.1 ;YES -- STORE TERMINATOR AND RETURN
JXN F,CM%ESC,CMAMB ;DING IF ESCAPE TYPED
POPJ P,0 ;ELSE RETURN
CMRN.1: PUSHJ P,CMCIN ;GET TERMINATOR
PUSHJ P,STOLCH ;STORE IN ATOM
POPJ P,0
NPTBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
747504,,001760 ;ALLOW , 0-9, -$*%.
400000,,000340 ;BREAK ON "]" ALLOW UC AND "[" AND _
400000,,000760 ;ALLOW LC
;Read quoted string in the Atom Buffer, keeping the quotes
; String delimited by ", "" means literal "
CMRQUO: TXNE F,CMDEFF ;Have a default?
RETSKP ;Yes
PUSHJ P,CMCIN ;Get first character
CAIN T1,CMHLPC ;First character is help?
JRST [TXO F,CMQUES ;Yes
RETSKP]
CAIE T1,CMQTCH ;Start of string?
POPJ P, ;No, fail
JRST CMRQU2 ;Store the leading quote
CMRQU1: PUSHJ P,CMCIN ;Read next character
CAIN T1,.CHLFD ;Line end unexpectedly?
PJRST CMDIP ;Yes, put back the LF and RETURN fail
CAIE T1,CMQTCH ;Another quote?
JRST CMRQU2 ;No, go store the character
PUSHJ P,CMCIN ;Yes, peek at the next one
CAIN T1,CMQTCH ;A pair of quotes?
JRST CMRQU2 ;Yes, store one
PUSHJ P,CMDIP ;No, put back next character
MOVEI T1,CMQTCH ;Get a quote character
PUSHJ P,STOLCH ;Store in the buffer
PUSHJ P,TIELCH ;Tie off the Atom Buffer
RETSKP ;Good return
CMRQU2: PUSHJ P,STOLCH ;Store next character in Atom Buffer
JRST CMRQU1 ;Loop for more
;[100] CMRFLN READS EXACTLY N CHARACTERS. IN OTHER WORDS, THE N + 1ST CHARACTER
;[100] IS A BREAK CHARACTER, NO MATTER WHAT IT IS.
;[100]
;[100] ACCEPTS: T1/ -N
CMRFLN: MOVEM T1,CMRBRK ;[100] SET UP SPECIAL COUNT AS BREAK MASK
PJRST CMRFLO ;[100] JOIN COMMON CODE
;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
CMRFLO: TXNE F,CMDEFF ;[100] DEFAULT GIVEN?
JRST CMRATT ;[100] YES, ALREADY IN BUFFER
CMRAT1: PUSHJ P,CMROOM ;[100] MAKE SURE ROOM FOR ANOTHER CHARACTER
PUSHJ P,CMCIN ;[100] GET A CHAR
SKIPG CMRBRK ;[100] BREAK SET GIVEN?
JRST CMRAT3 ;[100] NO, KEEP READING REGARDLESS OF CHARACTER
MOVE T2,T1 ;GET COPY OF CHAR
IDIVI T2,40 ;COMPUTE INDEX TO BIT MASK
MOVE T3,BITS(t3)
ADD T2,CMRBRK
TDNE T3,0(T2) ;BREAK CHARACTER?
JRST CMRAT2 ;YES
CMRAT3: TXZ F,CM%ESC!CMCFF!CM%EOC!CMQUES ;CLEAR SPECIAL CHARACTER
PUSHJ P,STOLCH ;[100] BUILD KEYWORD STRING
JRST CMRAT1
CMRAT2: CAIN T1,.CHCNZ ;Control-Z ?
JRST [PUSHJ P,STOLCH ;Yes - store character in buffer
JRST CMRATT] ;And return
CAIE T1,CMFREC ;^F RECOGNITION?
CAIN T1,.CHESC ;ESC?
JRST [PUSHJ P,CHKLCH ;YES, RETURN IF ANYTHING NOW
JUMPG T1,CMRATT ;IN ATOM BFR
JRST CMAMB] ;AMBIGUOUS
CAIE T1," " ;SPACE OR TAB?
CAIN T1,.CHTAB
JRST [PUSHJ P,CHKLCH ;YES, RETURN IF ANYTHING
JUMPG T1,CMRATR ;IN ATOM BFR
JRST CMRAT1] ;OTHERWISE IGNORE
CAIN T1,.CHLFD ;OR EOL?
JRST CMRATR ;YES
CAIN T1,CMHLPC ;HELP REQUEST?
JRST [TXO F,CMQUES ;YES, FLAG
JRST CMRATT]
CMRATR: PUSHJ P,CMDIP ;PUT CHARACTER BACK IN BUFFER
CMRATT: PJRST TIELCH ;TIE OFF ATOM BUFFER AND RETURN
;[100] CMROOM DECIDES IF WE CAN READ ANOTHER CHARACTER
CMROOM: SKIPLE CMRBRK ;[100] BREAK SET GIVEN?
POPJ P, ;[100] YES, SO KEEP READING
AOSG CMRBRK ;[100] NO, COUNT. HAVE WE READ ENOUGH?
POPJ P, ;[100] COUNT NOT EXHAUSTED, KEEP READING.
MOVEI T1,[EXP -1,-1,-1,-1] ;[100]
MOVEM T1,CMRBRK ;[100] COUNT EXHAUSTED, FOR BREAK ON ANYTHING
POPJ P, ;[100] GO READ NEXT CHARACTER IN CASE ITS "?".
;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
CMCINT: CAIN T1,CMFREC ;^F?
JRST [TXO F,CM%ESC+CMCFF ;YES
POPJ P,0]
CAIN T1,.CHESC ;ESC?
JRST [TXO F,CM%ESC ;YES
POPJ P,0]
CAIE T1,.CHCNZ ;Control-Z ?
CAIN T1,.CHLFD ;END OF LINE?
TXO F,CM%EOC ;YES, MEANS END OF COMMAND
POPJ P,0
CMDIN: PUSHJ P,CMCIN ;GET NEXT CHAR
TXNE F,CM%ESC ;IS IT THE RECOGNIZER?
POPJ P, ;YES, ALL SET
PUSHJ P,CMDIP ;NO, PUT IT BACK IN BUFFER
SETZ T1, ;NO CHAR
POPJ P,
CMCIN1: MOVEM F,CMCSF ;SAVE F
SETZM CMCBLF ;INIT ACCUMULATED FLAGS
MOVE T1,[XWD P1,CMCSAC] ;PREPARE FOR BLT
BLT T1,CMCSAC+3 ;SAVE P1-P4
;*** REMOVE RD%RND FOR NOW 6/22/78
MOVX T1,RD%BRK+RD%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 ;
MOVEI T1,[EXP 1B6+1B27,1B31,0,0] ;Control F, Escape, Question mark
MOVEM T1,TI+.RDBRK ;Store The break mask
MOVEM P4,TI+.RDBKL ;STORE CURRENT PTR FOR BACK UP LIMIT
MOVEM P3,CMCSC ;SAVE CURRENT COUNT
SUB P3,P5 ;ADJUST COUNT FOR ADVANCE INPUT
MOVEM P3,TI+.RDDBC ;AND STORE FOR THE TEXT INPUT
SKIPE P5 ;PUSH POINTER PAST CURRENT INPUT
IBP P4 ;
SOJG P5,.-1 ;
MOVEM P4,TI+.RDDBP ;STORE FOR INPUT
CMCIN2: MOVE S1,.CMIOJ(P2) ;GET THE JFNS
MOVEM S1,TI+.RDIOJ ;STORE FOR TEXTI
SKIPG P3 ;ROOM IN BUFFER FOR MORE INPUT?
$STOP(TMT,Too much text) ;NO
HRLZI S1,7 ;GET SOURCE
HRRI S1,A07T16 ;GET DESTIONATION
BLT S1,A07T16+7 ;SAVE SOME ACS
SETOM ACFLG ;REMEMBER THEY ARE IMPORTANT
MOVEI S1,TI ;GET LOCATION OF TEXTI BLOCK
PUSHJ P,K%TXTI ;DO INTERNAL TEXTI
SETZM ACFLG ;THE SAVED ACS ARE NO LONGER IMPORTANT
JUMPF [MOVEI S1,EREOF$
JRST XCOMEO]
IOR F,TI+.RDFLG ;GET FLAGS
IORB F,CMCBLF ;ACCUMULATE FLAGS (RD%BLR)
LDB T1,TI+.RDDBP ;GET LAST CHAR
MOVE P4,TI+.RDDBP ;REMEMBER POINTER
MOVE P3,TI+.RDDBC ;AND COUNT
TXNE F,RD%BFE ;BUFFER EMPTY?
JRST CMCIN3 ;YES, RETURN
JUMPE T1,CMCIN3 ;JUMP IF NULL
CAIE T1,.CHLFD ;AN ACTION CHAR?
CAIN T1,.CHESC
JRST CMCIN3 ;YES
CAIE T1,CMHLPC
CAIN T1,CMFREC ;^F?
JRST CMCIN3 ;YES
CAIE T1,.CHCNZ ;Control-Z ?
JRST CMCIN2 ;NO, GET MORE INPUT
CMCIN3: TXNE F,RD%BLR ;BACKUP LIMIT REACHED?
JRST CMCIN4 ;YES, CLEANUP AND REPARSE
TXNE F,RD%BFE ;BUFFER EMPTY
SKIPN INTRPT ;INTERRUPT OCCUR
SKIPA ;NO..CHECK REST
JRST CMCIN4 ;YES..SETUP TO RETURN
MOVE P5,CMCSC ;RECOVER PREVIOUS COUNT
SUB P5,P3 ;COMPUTE CHARACTERS JUST APPENDED
MOVSI T1,CMCSAC ;RESTORE ACS P1-P4, F
HRRI T1,P1
BLT T1,P4
MOVE F,CMCSF
POPJ P,0
;HERE ON RETURN FROM TEXTI WHICH REACHED BACKUP LIMIT OR WHICH RETURNED
;BECAUSE BUFFER EMPTY. MUST REPARSE LINE. RESTORE ACS, BUT LEAVE
;MAIN POINTER AS RETURNED BY TEXTI.
CMCIN4: DMOVE P1,CMCSAC ;RESTORE P1&P2
MOVE F,CMCSF ;RESTORE F
SKIPE INTRPT ;WAS THERE AN INTERRUPT CALL?
TXO F,CM%INT ;YES, LIGHT THE FLAG
SETZM INTRPT ;CLEAR CALL FLAG
JRST XCOMRP ;RETURN REPEAT PARSE
;SKIP LEADING TABS OR SPACES
CMSKSP: PUSHJ P,CMCIN ;GET A CHAR
CAIE T1," " ;SPACE OR TAB?
CAIN T1,.CHTAB
JRST CMSKSP ;YES, KEEP LOOKING
PJRST CMDIP ;NO, PUT IT BACK
;LOCAL ROUTINE - SUBTRACT ASCII BYTE PTRS
; T1, T2/ ASCII BYTE PTRS
; PUSHJ P,SUBBP
; RETURNS +1 ALWAYS,
; T1/ T1-T2
SUBBP: HRRZ T3,T1 ;COMPUTE 5*(A1-A2)+(P2-P1)/7
SUBI T3,0(T2)
IMULI T3,5 ;COMPUTE NUMBER CHARS IN THOSE WORDS
LDB T1,[POINT 6,T1,5]
LDB T2,[POINT 6,T2,5]
SUBM T2,T1
IDIVI T1,7
ADD T1,T3
POPJ P,0
;LOCAL ROUTINE - DELETE LAST CHAR INPUT
CMDCH: MOVE S1,P4
PUSHJ P,DBP ;DECREMENT BYTE PTR
MOVEM S1,P4
AOS P3 ;ADJUST SPACE COUNT
SETZ P5,0 ;CAN'T BE ANY WAITING INPUT
POPJ P,0
;LOCAL ROUTINE - DECREMENT INPUT POINTER
CMDIP: LDB T1,P4 ;CHECK THE CHARACTER
CAIE T1,.CHLFD ;IS IT <LF>?
JRST CMDIP1 ;NO, NOTHING SPECIAL
MOVE S1,P4 ;YES, SEE IF <CR> PRECEEDED IT
PUSHJ P,DBP ;BECAUSE CMCIN MAY HAVE "SKIPPED" <CR>
LDB S1,S1 ;GET PRECEEDING CHARACTER
CAIN S1,.CHCRT ;IS IT AN INVISIBLE <CR>?
PUSHJ P,CMDIP2 ;YES, BACK UP OVER IT TOO (PAST LEFT EDGE?)
CMDIP1: CAIE T1,CMFREC ;A RECOG REQUEST CHAR?
CAIN T1,.CHESC
TXZ F,CM%ESC+CMCFF ;YES, RESET FLAGS
CMDIP2: 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: PUSH P,S1 ;SAVE BYTE POINTER
MOVNI S1,1 ;-1 TO BACKUP ONE
ADJBP S1,(P) ;ADJUST
POP P,(P) ;PRUNE STACK
POPJ P, ;RETURN
SUBTTL HELPER -- Do caller supplied and default HELP text
;HELPER types out the caller supplied help text, if any, and then it types
; the default help type unless it was suppressed. Return is via CMRTYP
; to retype the current line.
;
;Call: S1/ address of default HELP text
;
;T Ret: always
HELPER: PUSH P,S1 ;SAVE S1
PUSHJ P,DOHLP ;DO CALLER SUPPLIED HELP IF ANY
TXNE F,CM%SDH ;ARE WE SUPPRESSING DEFAULT HELP?
JRST HELP.1 ;YES, SKIP PRINTING IT
MOVEI S1," " ;LOAD A BLANK
PUSHJ P,CMDOUT ;PRINT IT
MOVE S1,0(P) ;GET THE MESSAGE
PUSHJ P,CMDSTO ;PRINT IT
HELP.1: POP P,S1 ;GET THE STACK BACK
PJRST CMRTYP ;RETYPE THE LINE
SUBTTL DOHLP -- Do caller supplied HELP text
DOHLP: TXNN F,CMQUE2 ;IN ALTERNATE HELP POSSIBILITIES?
JRST DOHL2 ;NO, SEE IF USER HELP WAS GIVEN
TXNE F,CM%HPP ;USER HELP SPECIFIED?
JRST DOHL1 ;YES, DISPLAY "OR"
TXNE F,CM%SDH ;SUPPRESSING DEFAULT HELP
POPJ P,0 ;YES, JUST RETURN
DOHL1: MOVEI S1,[ASCIZ /
or/]
PUSHJ P,CMDSTO
DOHL2: TXNN F,CM%HPP ;HAVE HELP POINTER?
POPJ P,0 ;NO
MOVEI S1," "
PUSHJ P,CMDOUT ;SPACE BEFORE USER TEXT
MOVE S1,.CMHLP(P1) ;YES, GET IT
PJRST CMDSTO ;AND TYPE IT
SUBTTL CMAMB -- Handle Ambiguous Typein
CMAMB: TXZN F,CM%ESC ;ESC SEEN?
NOPARS (AMB) ;Ambiguous switch or keyword
PUSHJ P,CMDCH ;FLUSH RECOG CHAR FROM BUFFER
MOVEI S1,.CHBEL ;INDICATE AMBIGUOUS
PUSHJ P,CMDOUT
JRST XCOMRF ;GET MORE INPUT AND RESTART
;OUTPUT STRING FROM CURRENT CONTEXT
XMCOUT: PUSH P,S1 ;Save the character
PUSHJ P,CMDOUT ;OUTPUT A CHARACTER
POP P,S1 ;Restore it
CAIE S1,^D9
JRST XMCS.2
XMCS.1: MOVE S1,CURPOS
ADDI S1,8
IDIVI S1,8
IMULI S1,8
MOVEM S1,CURPOS
SKIPA
XMCS.2: AOS CURPOS ;MAINTAIN POSITION
POPJ P,0
CRLF: SETZM CURPOS ;AT LEFT MARGIN
MOVEI S1,[BYTE (7) .CHCRT,.CHLFD,0]
PJRST CMDSTO ;AND TYPE IT
;CHECK ALL BYTE PTRS
; T1/ PTR TO LIST OF ADDRESSES, TERMINATED BY 0
CHKABP: $SAVE Q1 ;SAVE ACS
$SAVE Q2 ;THAT WE USE
MOVEM T1,Q1 ;SAVE LIST PTR
CHKAB1: MOVE Q2,0(Q1) ;GET NEXT ADDRESS
JUMPE Q2,.RETT ;DONE ON 0
ADDI Q2,0(P2) ;MAKE PTR TO BLOCK
MOVE S1,0(Q2) ;GET BYTE PTR
PUSHJ P,CHKBP ;CHECK AND NORMALIZE
MOVEM S1,0(Q2) ;PUT IT BACK
AOJA Q1,CHKAB1 ;DO NEXT
;CHECK A BYTE PTR
; S1/ BYTE PTR - IF LH IS -1, PTR IS FIXED
CHKBP: HLRZ S2,S1
CAIN S2,-1
HRLI S1,(POINT 7)
LDB S2,[POINT 6,S1,11] ;GET BYTE SIZE
IBP S1 ;INCREMENT AND DECREMENT TO NORMALIZE
PJRST DBP
SUBTTL Command Function / .CMINI - Init the scanner and do ^H
XCMINI: HLRZ T1,.CMIOJ(P2) ;DOING INPUT FROM TERMINAL?
CAXE T1,.PRIIN ;..
JRST CMINI4 ;NO, SKIP REPAIR
PUSHJ P,TYPRMT ;GO TYPE A PROMPT
CAMN P4,.CMBFP(P2) ;BUFFER EMPTY?
JRST CMINI4 ;YES, NO REDO POSSIBLE
LDB T1,P4 ;CHECK LAST CHAR
CAIN T1,.CHLFD ;END OF LINE?
JRST CMINI4 ;YES, LAST COMMAND OK, NO REDO
PUSHJ P,K%BIN ;GET FIRST CHARACTER
CAIN S1,CMRDOC ;IS IT REDO?
JRST CMINI5 ;YES
PUSHJ P,K%BACK ;NO, BACKUP OVER IT
CMINI4: MOVE T1,P4 ;RESET LINE VARIABLES
MOVE T2,.CMBFP(P2)
MOVEM T2,P4
PUSHJ P,SUBBP ;COMPUTE CHARACTERS IN LINE
ADDM T1,P3 ;UPDATE SPACE COUNT
SETZ P5,0 ;RESET ADVANCE COUNT
JRST XCOMXI ;RETURN GOOD
CMINI5: MOVE P3,.CMCNT(P2) ;RESET VARIABLES TO CURR FIELD
MOVE P4,.CMPTR(P2)
LDB T1,P4 ;IF LAST CHARACTER WAS <CR>
CAIN T1,.CHCRT
PUSHJ P,CMDCH ;DELETE FROM INPUT BUFFER
SETZ P5,0 ;NO INPUT
PUSHJ P,RETYPE ;RETYPE
JRST XCOMRP ;RETURN TO REPARSE
SUBTTL Command Function / .CMSWI - Parse a SWITCH
;SWITCH - LIKE KEYWORD BUT PRECEEDED BY SLASH
XCMSWI: TXO F,CMSWF ;NOTE DOING SWITCH
TXNE F,CMDEFF ;DEFAULT GIVEN?
JRST CMKEY0 ;YES, SLASH ALREADY ASSUMED
PUSHJ P,CMCIN ;GET FIRST CHAR
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIN T1,CMHLPC ;HELP?
JRST [SETZ T1,0
MOVE T2,ATBPTR
IDPB T1,T2
MOVE T1,FNARG ;GET TABLE PTR
MOVEI T1,1(T1) ;POINT TO FIRST TABLE ENTRY
JRST CMQ2] ;TYPE OPTIONS
CAIE T1,CMSWCH ;THE SWITCH CHARACTER?
JRST [PUSHJ P,CMDIP ;NO, PUT IT BACK
NOPARS (NSW)] ;Not a switch
JRST CMKEY0 ;CONTINUE LIKE KEYWORD
SUBTTL Command Function / .CMKEY - Parse a KEYWORD
XCMKEY: TXZ F,CMSWF ;NOT SWITCH
CMKEY0:
KEYW1: PUSHJ P,CMRATM ;READ THE FIELD INTO LOCAL BUFFER
MOVE T1,FNARG ;GET TABLE HEADER ADDRESS
MOVE T2,.CMABP(P2) ;POINT TO KEYWORD BUFFER
PUSHJ P,XTLOOK ;LOOKUP
TXNE F,CMQUES ;HAD "?"
JRST CMQ1 ;YES, GO TYPE ALTERNATIVES
TXNE T2,TL%NOM ;NO MATCH?
NOPARS(NOM) ;Not a switch or keyword
JXN T2,TL%AMB,CMAMB ; ??? AMBIGUOUS
MOVEM T1,Q1 ;SAVE TABLE INDEX
HLRZ T2,0(Q1) ;GET TABLE ENTRY ADDRESS
PUSHJ P,CHKTBS ;GET TABLE ENTRY FLAGS
JXE T1,CM%ABR,KEYW03 ;IF NO LINK TO FULL TEXT, USE THIS ENTRY
HRRZ Q1,0(Q1) ;GET ENTRY FOR WHICH THIS IS AN ABBREV
HLRZ T2,0(Q1) ;GET ADDRESS OF ITS STRING
PUSHJ P,CHKTBS ;GET A BYTE POINTER TO IT
KEYW03: PUSHJ P,CHKLCH ;GET NUMBER OF CHARACTERS TYPED
MOVE T3,T1 ;GET CHARS TYPED
ADJBP T3,T2 ;SKIP THAT MANY OF FULL KEYWORD
MOVEM Q1,CRBLK+CR.RES ;RESULT IS INDEX OF (UNABBREV) ENTRY
JXE F,CM%ESC,KEYW4 ;DONE IF NO REC WANTED
MOVEM T3,Q1 ;SAVE PTR TO REMAINDER OF STRING
PUSHJ P,CMDCH ;FLUSH RECOG CHARACTER
KEYW2: ILDB T1,Q1 ;TYPE REMAINDER OF KEYWORD
JUMPE T1,KEYW3 ;DONE
PUSHJ P,CMDIB ;APPEND COMPLETION TO BUFFER
CAIN T1,CMSWTM ;A SWITCH TERMINATOR?
JRST [TXZ F,CM%ESC ;YES, OVERRIDES ESC
TXO F,CM%SWT ;NOTE SWITCH TERMINAOTR
TXNN F,CMSWF ;IN SWITCH?
PUSHJ P,CMDIP ;NO, PUT TERMINATOR BACK
JRST XCOMXI] ;DONE
JRST KEYW2
KEYW3: JXE F,CMSWF,XCOMXI ;DONE IF NOT SWITCH
MOVE Q1,FNARG ;CHECK FUNCTION FLAGS
JXE Q1,CM%VRQ,XCOMXI ;DONE IF NO VALUE REQUIRED
MOVEI T1,CMSWTM ;INCLUDE COLON IN RECOGNITION
PUSHJ P,CMDIB
TXO F,CM%SWT ;NOTE SWITCH TERMINATOR
JRST XCOMX1 ;INHIBIT ADDITIONAL SPACE
KEYW4: PUSHJ P,CHKLCH ;SEE IF ATOM NON-NULL
JUMPE T1,[NOPARS (NUL)] ;Null switch or keyword
JXE F,CMSWF,XCOMXI ;DONE IF NOT SWITCH
PUSHJ P,CMSKSP ;SKIP SPACES
PUSHJ P,CMCIN ;GET NON-BLANK CHAR
CAIN T1,CMSWTM ;SWITCH TERMINATOR?
JRST [TXO F,CM%SWT ;YES, NOTE
JRST XCOMXI] ;DONE
PUSHJ P,CMDIP ;NO, PUT IT BACK
MOVE Q1,FNARG
JXN Q1,CM%VRQ,XCOMNP ;FAIL IF VALUE WAS REQUIRED
JRST XCOMXI ;OTHERWISE OK
;"?" TYPED, FIRST PARTIAL MATCH FOUND. TYPE ALL PARTIAL MATCHES
CMQ1: JXN T2,TL%NOM,[
JXN F,CMQUE2,CMRTYP ;DO NOTHING IF NOT FIRST ALTERNATIVE
MOVEI S1,[ASCIZ / keyword (no defined keywords match this input)/]
PUSHJ P,CMDSTO ;TYPE MESSAGE
JRST CMRTYP] ;RETYPE LINE AND CONTINUE
CMQ2: MOVEM T1,Q2 ;SAVE TABLE INDEX
PUSHJ P,DOHLP ;DO USER HELP IF ANY
TXNE F,CM%SDH ;DEFAULT HELP SUPPRESSED?
JRST CMRTYP ;YES, DONE
MOVE T1,FNARG ;GET TABLE PTR
HLRZ Q1,0(T1) ;GET TABLE SIZE
MOVE S1,Q1 ;SAVE SIZE OF THE TABLE
ADDI Q1,1(T1) ;COMPUTE TABLE END ADDRESS FOR BELOW
CAIN S1,1 ;ONLY ONE ELEMENT IN TABLE
JRST CMQ5 ;YES.. BYPASS TEXT AND OUTPUT BLANK
MOVEI S1,[ASCIZ / one of the following:/]
PUSHJ P,CMDSTO ;TYPE IT
PUSHJ P,CRLF ;AND A CRLF
CMTAB0: SOJ Q2,0 ;GETS INCREMENTED BEFORE EACH APPLICATION
MOVEM Q2,Q3SAVE ;SAVE SO IT CAN BE REINITIALIZED
SETZM TABSIZ ;START WITH TAB SIZE OF 0
CMTAB1: PUSHJ P,CMNXTE ;GET TO NEXT VALID KEYWORD IN TABLE
JUMPF CMTAB2 ;NO MORE IN TABLE
PUSHJ P,CMGTLN ;CALCULATE LENGTH OF KEYWORD
CAML T1,TABSIZ ;LONGEST SEEN SO FAR?
MOVEM T1,TABSIZ ;YES, REMEMBER IT
JRST CMTAB1 ;LOOK AT REST
CMTAB2: MOVE T1,TABSIZ
MOVEM T1,BIGSIZ ;REMEMBER LENGTH OF LONGEST KEYWORD
MOVEI S1,2 ;LEAVE AT LEAST 2 SPACES
ADDM S1,TABSIZ ;BETWEEN ITEMS
MOVE Q2,Q3SAVE ;RESTART TABLE POINTER FOR ACTUAL LISTING
CMQ3: PUSHJ P,CMNXTE ;GET TO NEXT KEYWORD
JUMPF CMRTYP ;NO MORE, REPEAT COMMAND SO FAR AND CONTINUE
CMQ4: MOVEI S1,"/" ;LOAD A SLASH
TXNE F,CMSWF ;ARE WE DOING SWITCHES?
PUSHJ P,CMDOUT ;YES, TYPE THE SLASH
PUSH P,T1 ;SAVE ADDRESS OF TABLE ENTRY
PUSHJ P,CMGTLN ;COMPUTE ITS LENGTH
ADDM T1,CURPOS ;MOVE CURRENT POSITION FORWARD
POP P,S1 ;RESTORE POINTER
PUSHJ P,CMDSTO ;TYPE IT
PUSHJ P,CMNXTE ;GET TO NEXT KEYWORD
JUMPF CMRTYP ;NO MORE, REPEAT COMMAND SO FAR AND CONTINUE
PUSHJ P,NXTKEY ;AND POSITION FOR THE NEXT ONE
JRST CMQ4 ;TRY NEXT
CMQ5: MOVEI S1," " ;GET A BLANK
PUSHJ P,CMDOUT ;OUTPUT A CHARACTER
JRST CMTAB0 ;CONTINUE HELP PROCESSING
;ROUTINE WHICH TAKES POINTER TO TABLE IN Q2, POINTER TO END OF TABLE
;IN Q1, AND RETURNS POINTER TO KEYWORD NAME IN T1. SKIPS UNLESS TABLE
;IS EXHAUSTED. ONLY CONSIDERS PRINTABLE KEYWORDS, AND UPDATES Q2.
CMNXTE: AOS Q2 ;LOOK AT NEXT TABLE ENTRY
CAML Q2,Q1 ;BEYOND END OF TABLE?
$RETF ;YES, FINISHED LIST
HLRZ T2,0(Q2) ;GET STRING PTR FOR IT
PUSHJ P,CHKTBS ;GET FLAGS FROM STRING
JXN T1,CM%INV+CM%NOR,CMNXTE ;SKIP ENTRY IF INVISIBLE OR NOREC
MOVE T1,.CMABP(P2) ;PTR TO PARTIAL KEYWORD
PUSHJ P,USTCMP ;COMPARE
JUMPE T1,CMNXT1 ;OK IF EXACT MATCH
JXE T1,SC%SUB,.RETF ;DONE IF NOT SUBSTRING
CMNXT1: HLRZ T2,0(Q2) ;GET PTR TO STRING FOR THIS ENTRY
PUSHJ P,CHKTBS
MOVE T1,T2
$RETT ;RETURN TRUE!!
;ROUTINE TO CALL BEFORE TYPING KEYWORD IN RESPONSE TO "?". GIVE
;IT USER'S BYTE POINTER IN T1. IT DECIDES WHETHER KEYWORD WILL FIT
;ON THIS LINE, AND STARTS NEW LINE IF NOT. IT THEN OUTPUTS A TAB,
;FOLLOWED BY SWITCH DELIMITER (IF KEYWORD IS A SWITCH).
NXTKEY: PUSHJ P,.SAVET ;DON'T CLOBBER USER'S BYTE POINTER
MOVE T2,CURPOS ;GET OUR CURRENT POSITION
PUSHJ P,[CMTAB: ADD T2,TABSIZ ;FIGURE OUT MAXIMUM PLACE TAB CAN MOVE US TO
IDIV T2,TABSIZ ;SCALE DOWN TO REALLY WHERE
IMUL T2,TABSIZ ;TAB WILL BRING US TO
POPJ P,0]
ADD T2,BIGSIZ ;MAKE SURE WE HAVE ROOM FOR ANOTHER COLUMN
CAMLE T2,PWIDTH ;ROOM FOR ANOTHER KEYWORD ON THIS LINE?
PJRST CRLF ;NO, TYPE A CRLF AND RETURN
PJRST TYPTAB ;YES, GET TO NEXT TAB STOP
;ROUTINE TO TYPE TAB OF SIZE TABSIZ. IT ASSUMES HARDWARE TABS ARE OF
;SIZE 8 AND TRIES TO TYPE AS MANY REAL TABS AS IT CAN, AND THEN SPACES
;OVER REST OF THE WAY.
TYPTAB: MOVE T2,CURPOS ;SEE WHERE WE'RE STARTING ON LINE
PUSHJ P,CMTAB ;SEE WHERE WE WANT TO GET TO
MOVEM T2,TABDON ;REMEMBER WHERE WE WANT TO GET TO
TYPTB1: MOVE T1,CURPOS ;GET WHERE WE ARE
ADDI T1,8 ;HARDWARE TAB MIGHT GO THIS FAR
TRZ T1,7 ;BUT MAYBE NOT QUITE
CAMLE T1,TABDON ;WILL HARDWARE TAB GO TOO FAR?
JRST TYPTB2 ;YES
MOVEI S1,.CHTAB
PUSHJ P,XMCOUT ;AND TYPE IT
JRST TYPTB1 ;LOOP FOR AS MANY HARDWARE TABS AS WE CAN GET AWAY WITH
TYPTB2: MOVE T1,CURPOS
CAML T1,TABDON ;ARE WE THERE YET?
POPJ P,0 ;YES, SO TAB IS TYPED
MOVEI S1," " ;NO, SO SPACE OVER
PUSHJ P,XMCOUT
JRST TYPTB2 ;AND LOOP FOR REST OF SPACES
;ROUTINE TAKING POINTER TO KEYWORD IN T1. RETURNS KEYWORD LENGTH IN
;T1. GIVES EXTRA 1 FOR SWITCH, ASSUMING A SLASH WILL PREFIX ITS
;PRINTOUT.
CMGTLN: MOVEI T4,0 ;COUNT OF NUMBER OF CHARACTERS NEEDED FOR THIS KEYWORD
CMGT.1: ILDB T2,T1 ;PICK UP NEXT CHARACTER FROM KEYWORD
CAIE T2,0 ;ASSUME KEYWORD ENDS ON NULL
AOJA T4,CMGT.1 ;NOT OVER YET, ACCUMULATE ITS LENGTH
TXNE F,CMSWF ;IS THIS A SWITCH?
AOJ T4,0 ;YES, DELIMITER TAKES UP ANOTHER SPACE
MOVE T1,T4 ;RETURN LENGTH IN T1
POPJ P,0
SUBTTL Command Function / .CMTXT - Parse Arbitrary Text to Action Character
XCMTXT: PUSHJ P,CMRSTR ;READ TEXT
JXN F,CMQUES,[
TXNN F,CMQUE2 ;IFIN MIDDLE OF HELP LIST, ? DOES HELP
JUMPN T1,XCMTQ ;USUALLY "?" IS JUST PART OF TEXT
PUSHJ P,DOHLP ;DO USER HELP
HRROI T1,[ASCIZ / text string/]
TXNN F,CM%SDH
PUSHJ P,CMDSTO;TYPE HELP UNLESS SUPPRESSED
JRST CMRTYP] ;NO DEFAULT MESSAGE
JXN F,CM%ESC,CMAMB ;DING IF HE TRIES TO DO RECOGNITION
JRST XCOMXI ;DONE
XCMTQ: MOVEI T1,CMHLPC ;PUT QUESTION MARK IN TEXT
PUSHJ P,STOLCH
PUSHJ P,TIELCH ;TIE OFF ATOM BUFFER INCASE LAST CHR
TXZ F,CMQUES ;FORGET WE'RE IN HELP STATE
JRST XCMTXT ;READ REST OF TET
SUBTTL Function .CMNOI -- Parse a NOISE-WORD
XCMNOI: MOVE S1,FNARG ;GET STRING PTR
PUSHJ P,CHKBP ;CHECK AND NORMALIZE
MOVEM S1,XXXPTR
TXNN F,CM%PFE ;PREVIOUS FIELD ENDED WITH ESC?
JRST CMNOI3 ;NO
TXO F,CM%ESC ;YES, MEANS THIS ONE DID TOO
MOVEI T1,NOIBCH ;TYPE NOISE BEG CHAR
PUSHJ P,CMDIB ; AND PUT IT IN BUFFER
CMNOI2: ILDB T1,XXXPTR ;GET NEXT NOISE CHAR
JUMPN T1,[PUSHJ P,CMDIB ;PUT IT IN BUFFER IF NOT END OF STRING
JRST CMNOI2]
MOVEI T1,NOIECH ;END OF STRING, TYPE END CHAR
PUSHJ P,CMDIB
JRST XCOMXI ;EXIT
;PREVIOUS FIELD NOT TERMINATED WITH ESC - PASS NOISE WORD IF TYPED
CMNOI3: PUSHJ P,CMSKSP ;BYPASS SPACES
PUSHJ P,CMCIN ;GET FIRST CHAR
CAIE T1,NOIBCH ;NOISE BEG CHAR?
JRST [PUSHJ P,CMDIP ;NO, NOT A NOISE WORD, PUT IT BACK
JRST XCOMXI] ;RETURN OK
CMNOI4: PUSHJ P,CMCIN ;GET NEXT NOISE CHAR
CAIE T1,CMFREC ;^F?
CAIN T1,.CHESC ;ESC?
JRST [PUSHJ P,CMDCH ;YES, FLUSH IT
JRST CMNOI2] ;COMPLETE NOISE WORD FOR USER
ILDB T2,XXXPTR ;COMPARE WITH GIVEN STRING
CAIL T1,"A"+40 ;RAISE CASING FOR COMPARE
CAILE T1,"Z"+40
SKIPA
SUBI T1,40
CAIL T2,"A"+40
CAILE T2,"Z"+40
SKIPA
SUBI T2,40
CAMN T1,T2
JRST CMNOI4 ;STILL SAME AS EXPECTED
CAIN T1,NOIECH ;NOT SAME, STRING ENDED TOGETHER?
JUMPE T2,XCOMXI ;YES, EXIT OK
NOPARS (INW) ;Invalid guide word
SUBTTL Command Function / .CMCFM - Command Confirmation (end-of-line)
XCMCFM: PUSHJ P,CMCFM0 ;DO THE WORK
NOPARS(NC) ;Not confirmed
JRST XCOMXI ;OK
CMCFM0: PUSHJ P,CMCIN ;GET CHAR
CAIE T1,.CHTAB ;BLANK?
CAIN T1," "
JRST CMCFM0 ;YES, IGNORE
MOVEI S1,[ASCIZ /confirm with carriage return/]
CAIN T1,CMHLPC ;HELP?
PUSHJ P,HELPER ;YES, GIVE IT
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIE T1,.CHLFD ;NL (NEW LINE, I.E. LINEFEED)
POPJ P,0 ;NO, FAIL
RETSKP ;YES
;FLOATING POINT NUMBER
XCMFLT: $STOP(SFP,Scanning floating point not implemented)
REPEAT 0,<
MOVEI T1,FLTBRK ;USE SPECIAL BREAK SET
PUSHJ P,CMRFLD ;READ FIELD
MOVEI S1,[ASCIZ /number/]
TXNE F,CMQUES ;QUESTION MARK?
PUSHJ P,HELPER ;YES, HELP!
MOVE T1,.CMABP(P2) ;NUMBER NOW IN ATOM BUFFER, GET PTR
MOVEM T1,T1
IMCALL .FLIN
JRST [MOVEM T3,T2 ;FAILED, RETURN ERROR CODE
JRST XCOMNP]
JRST CMNUMR ;DO NUMBER CLEANUP AND RETURN
;FLOATING POINT BREAK SET MASK, ALLOWS +, -, ., E, NUMBERS
FLTBRK: 777777,,777760
777644,,001760
400000,,000760
400000,,000760
>;END OF REPEAT 0
SUBTTL Command Function / .CMNUM - Parse an INTEGER in any base
SUBTTL Command Function / .CMNUX - Parse an INTEGER in any base (special break)
XCMNUX: SKIPA T1,[NUXBRK] ;USE SPECIAL BREAK SET
XCMNUM: MOVEI T1,NUMBRK ;USE REGULAR BREAK SET
PUSHJ P,CMRFLD ;READ FIELD
TXNE F,CMQUES ;SAW "?"
JRST CMNUMH ;YES
XCMNX1: MOVE S1,.CMABP(P2) ;[100] 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
LOAD S2,.CMFNP(P1),CM%FNC ;[100] GET FUNCTION CODE
CAIE S2,.CMNUX ;[100] A .CMNUX FUNCTION?
JRST CMNUM1 ;[100] NO, INVALID CHARACTER IN NUMBER
MOVE T2,S1 ;[100] GET POINTER FROM NIN IN T2
MOVE T1,.CMABP(P2) ;[100] AND GET ATOM BUFFER POINTER IN T1
PUSHJ P,SUBBP ;[100] FIND NEG NUMBER OF BYTES ACTUALLY READ
AOJ T1, ;[100] DON'T INCLUDE THE TERMINATOR
PUSH P,T1 ;[100] AND SAVE IT
PUSHJ P,CMFSET ;[100] RESET ALL POINTERS
POP P,T1 ;[100] AND GET BACK NUMBER OF BYTES READ BY NIN
PUSHJ P,CMRFLN ;[100] AND REREAD THE FIELD UP TO TERM NIN SAW
JRST XCMNX1 ;[100] NOW TRY NIN AGAIN.
CMNUM1: NOPARS (ICN) ;Invalid numeric character
;NUMBER BREAK SET, ALLOWS +, -, NUMBERS
NUMBRK: 777777,,777760
777654,,001760
400000,,000760
400000,,000760
NUXBRK: 777777,,777760
777654,,001760
777777,,777760
777777,,777760
CMNUMH: PUSHJ P,DOHLP ;DO USER SUPPLIED MESSAGE
JXN F,CM%SDH,CMRTYP ;SUPPRESS DEFAULT HELP IF REQUESTED
HRRZ T2,FNARG ;GET BASE
CAIL T2,^D2 ;LEGAL?
CAILE T2,^D10
$STOP(IBN,Illegal base for number)
CAIN T2,^D10 ;DECIMAL?
JRST CMNH10 ;YES
CAIN T2,^D8 ;OCTAL?
JRST CMNH8 ;YES
MOVEI S1,[ASCIZ / a number in base /]
PUSHJ P,CMDSTO ;ARBITRARY BASE
HRRZ T1,.CMIOJ(P2)
HRRZ T2,FNARG
MOVEI T3,^D10
ADDI T2,"0" ;CONVERT BASE TO ASCII
MOVE S1,T2 ;COPY THE BASE OVER
PUSHJ P,CMDOUT ;AND TYPE IT
SUBI T2,"0" ;CONVERT IT BACK
JRST CMRTYP ;RETYPE LINE AND CONTINUE
CMNH8: MOVEI S1,[ASCIZ / octal number/]
JRST CMNH
CMNH10: MOVEI S1,[ASCIZ / decimal number/]
CMNH: PUSHJ P,CMDSTO
JRST CMRTYP
SUBTTL Command Function / .CMDEV - Parse a DEVICE specification
XCMDEV: MOVEI T1,DEVBRK ;GET DEVICE BREAK SET
PUSHJ P,CMRFLD ;GET THE FIELD
MOVEI S1,[ASCIZ /Device name/]
TXNE F,CMQUES ;TYPE A QUESTION MARK?
PUSHJ P,HELPER ;YES, CALL THE HELPER
TXNE F,CM%ESC ;WANT RECOGNITION HERE?
JRST [PUSHJ P,CMDIP ;BACKUP OVER RECOGNIZER
PUSHJ P,CMCIN ;GET IT BACK
PUSH P,T1 ;SAVE IT A SEC
PUSHJ P,CMDCH ;DELETE THE RECOGNIZER
MOVEI T1,":" ;GET OUR TERMINATOR
PUSHJ P,CMDIB ;PUT IT IN
POP P,T1 ;GET BACK TERMINATOR
PUSHJ P,CMDIBQ ;PUT THAT IN, TOO, NO TYPEOUT
PUSHJ P,CMDIP ;BACK OVER RECOGNIZER
PUSHJ P,CMDIP ;AND BACK OVER :, TOO
JRST CMDEV0] ;REENTER THE FLOW
CMDEV0: MOVE S1,.CMABP(P2) ;ADDRESS OF BUFFER
;**;[102] Insert 3 lines after CMDEV0+0L. /LWS
ILDB S2,S1 ;[102] GET FIRST BYTE
CAIN S2,0 ;[102] NULL?
NOPARS(NDN) ;[102] YES,,SORRY
PUSHJ P,CMCIN ;READ THE TERMINATOR
CAIN T1,":" ;IS IT THERE?
JRST CMDEV1 ;YES, KEEP GOING
TXNN F,CM%NSF ;ANY SUFFIX REQUIRED?
NOPARS(DVT) ;Invalid device terminator
PUSHJ P,CMDIP ;NO SUFFIX REQUIRED, SPIT OUT TERMINATOR
CMDEV1: PUSHJ P,CMDIN ;PRIME THE PUMP
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
PUSHJ P,CNVSIX ;CONVERT FIELD TO SIXBIT
SKIPT ;O.K. S1/ FIELD NAME
NOPARS(DGS) ;Device name too large
TXNE F,CM%PO ;PARSE ONLY ON FIELD ?
JRST XCOMXR ;YES..RETURN O.K.
DEVCHR S2, ;SEE IF IT EXISTS
SKIPN S2 ;VALID DATA
NOPARS(DNE)
TXNE S2,DV.IN!DV.OUT ;CHECK IF CAN DO INPUT OR OUTPUT
PJRST XCOMXR ;YES..RETURN O.K.
NOPARS(DIO) ;Cant do input or output
DEVBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
757754,,001760 ;BREAK ON :, ALLOW 0-9
400000,,000740 ;ALLOW UC
400000,,000760 ;ALLOW LC
SUBTTL Command Function / .CMQST - Parse a QUOTED STRING
XCMQST: PUSHJ P,CMRQST ;READ THE STRING
NOPARS(NQS) ;Not a quoted string
MOVEI S1,[ASCIZ /quoted string/]
TXNE F,CMQUES ;QUESTION MARK TYPED?
PUSHJ P,HELPER ;YES, GIVE HELP
TXZ F,CM%ESC+CMCFF ;CLEAR IN CASE USED INSIDE STRING
JRST FIXESC ;CHECK FOR ESCAPE AND RETURN
;UNQUOTED STRING - TAKES BIT MASK (4 WORDS * 32 BITS) TO SPECIFY BREAKS.
XCMUQS: JXE F,CMQUES,CMUQS1 ;? BEEN TYPED ALREADY?
PUSHJ P,DOHLP ;YES - DO USER HELP
HRROI T1,[ASCIZ / unquoted string/]
TXNN F,CM%SDH ;SUPPRESS DEFAULT?
PUSHJ P,CMDSTO ;NO, DO IT
JRST CMRTYP
CMUQS1: PUSHJ P,CMCIN ;GET A CHAR
MOVE T3,T1 ;COPY CHARACTER
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
CAIN T3,CMHLPC ;TERMINATED WITH HELP CHAR?
JRST [PUSHJ P,DOHLP ;YES, DO USER HELP
JRST CMRTYP] ;AND RETYPE LINE
TXZ F,CM%ESC+CMCFF ;CLEAR FLAGS
PUSHJ P,CMCINT ;SEE IF ESCAPE OR ^F TYPED
JRST FIXES1 ;NO - TERMINATE NORMALLY
PUSHJ P,CMDIP ;YES, PUT CHAR BACK
TXO F,CM%ESC ;SET FLAG
MOVEI T1," " ;TERMINATE TYPESCRIPT WITH SPACE
PUSHJ P,CMDIB
PUSHJ P,CMDIP ;DON'T REALLY PARSE THE SPACE UNTIL NEXT FIELD!
JRST XCOMX1
;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,ACTBRK ;POINT TO BREAK MASK
PUSHJ P,CMRFLD ;READ FIELD
JRST CMFLD1 ;FINISH LIKE ARBITRARY FIELD
ACTBRK: 777777,,777760 ;BREAK ON ALL CONTROLS
000000,,000000 ;ALLOW CHARACTERS
000000,,000000 ; IN THE RANGE OF
000000,,000060 ; OCTAL 40 TO 176
SUBTTL Command Function / .CMNOD - Parse a NODE Specification
XCMNOD: PUSHJ P,CMRATM ;GET AN ATOM
TXNE F,CMQUES ;DID HE TYPE A QUESTION MARK?
PUSHJ P,NODHLP ;YES, TYPE THE HELP TEXT(S)
TXNE F,CM%ESC ;WANT RECOGNITION?
JRST [PUSHJ P,CMDIP ;YES, BACK UP TO RECOGNIZER
PUSHJ P,CMCIN ;GET THE RECOGNIZER
PUSH P,T1 ;SAVE IT
PUSHJ P,CMDCH ;DELETE IT
MOVEI T1,":" ;GET TERMINATOR
PUSHJ P,CMDIB ;PUT IT IN
PUSHJ P,CMDIB ;TWICE
POP P,T1 ;GET BACK RECOGNIZER
PUSHJ P,CMDIBQ ;PUT THAT BACK IN, NO TYPEOUT
PUSHJ P,CMDIP ;BACK UP OVER RECOGNIZER
PUSHJ P,CMDIP ;AND OVER 1 :
PUSHJ P,CMDIP ;AND OVER THE OTHER
JRST CMNOD1] ;REENETER FLOW
CMNOD1: MOVE S1,.CMABP(P2) ;GET THE BYTE POINTER
ILDB S2,S1 ;GET THE FIRST BYTE
SKIPN S2 ;BETTER NOT BE NULL
JRST ILLNOD ;IMPROPER NODE NAME
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
MOVEI S2,^D8 ;TRY AS AN OCTAL NUMBER
PUSHJ P,NUMIN ;READ IT
JUMPF CMNODS ;LOSES, TRY SIXBIT
MOVE T2,ATBPTR ;GET POINTER TO END OF ATOM BUFFER
IBP T2 ;POINT AT TERMINATOR
CAMN S1,T2 ;OUR POINTER END THE SAME PLACE?
JRST CMNOD2 ;YES, WIN! ELSE TRY SIXBIT
CMNODS: MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
PUSHJ P,CNVSIX ;CONVERT BUFFER TO SIXBIT
SKIPT ;O.K.. CONTINUE
ILLNOD: NOPARS (NNC) ;Invalid node name
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!
CMNOD2: MOVEM S2,CRBLK+CR.RES ;SAVE AS RESULT (SIXBIT OR #)
PUSHJ P,CMCIN ;GET NEXT CHAR AFTER FIELD
CAIN T1,":" ;BEGINING OF TERMINATOR?
JRST CMNOD3 ;GOT ONE : GO LOOK FOR THE OTHER
CAIN T1,"_" ;NO, HOW ABOUT OTHER STYLE
JRST CMNOD4 ;LOOKS GOOD KEEP GOING
TXNN F,CM%NSF ;NO SUFFIX REQUIRED?
JRST ILLNO1 ;NOPE, QUIT (IE: IT WAS REQUIRED)
PUSHJ P,CMDIP ;BACK UP OVER THE TERMINATOR
JRST CMNOD4 ;AND FINISH UP
CMNOD3: PUSHJ P,CMCIN ;READ NEXT CHAR AFTER THE :
CAIN T1,CMHLPC ;IS IT ?
PUSHJ P,NODHLP ;YES, GIVE SOME HELP
TXNE F,CM%ESC ;WANT RECOGNITION?
JRST [PUSH P,T1 ;SAVE RECOGNIZER
PUSHJ P,CMDCH ;DELETE IT
MOVEI T1,":" ;GET EXTRA DELIMITER
PUSHJ P,CMDIB ;PUT IT IN BUFFER
POP P,T1 ;GET BACK RECOGNIZER
PUSHJ P,CMDIBQ ;PUT THAT IN, NO TYPEOUT
PUSHJ P,CMDIP ;BACK OVER RECOGNIZER
JRST CMNOD4] ;BACK IN LINE
CAIE T1,":" ;IS IT THE SECOND : ?
ILLNO1: NOPARS(INT) ;Invalid node terminator
CMNOD4: PUSHJ P,CMDIN ;PRIME THE CHARACTER PUMP
TXNE F,CM%PO ;PARSE ONLY?
JRST XCOMXR ;YES, JUST RETURN WITH RESULT
MOVE T1,[XWD .NDRNN,T2] ; MAKE SURE THAT THIS NODE NUMBER EXISTS
MOVEI T2,2 ;2 ARGS
MOVE T3,CRBLK+CR.RES ;NODE NUMER WE JUST PARSED
NODE. T1, ;TRY IT FOR EXISTANCE
NOPARS(NSN) ;No such node
JRST XCOMXR ;A GOOD NODE NUMBER, RETURN
;HERE IF ? TYPED DURING NODE NAME PARSE
NODHLP: TXO F,CMQUES ;NOTE IT
MOVEI S1,[ASCIZ /Node name/] ;THE DEFAULT TEXT
PUSHJ P,HELPER ;HELP THE USER
POPJ P, ;NEVER GET HERE (HELPER DOESN'T RETURN)
;INDIRECT FILESPEC (INTERNAL CALL)
CMATFI:
TXO F,CMINDF ;NOTE GETTING INDIRECT FILE
JRST XCMIFI ;AND HANDLE AS INPUT FILE
XCMOFI:
XCMIFI:
XCMFIL: LOAD S1,.CMGJB(P2),CM%GJB ;GET ADDR OF FD
LOAD S1,.FDLEN(S1),FD.TYP ;GET FD TYPE
PUSH P,S1 ;SAVE FOR LATER
CAIN S1,.FDNET ;IF WANTS NETWORK FILESPEC
PUSHJ P,CMRNFL ;THEN SCAN ONE
MOVE S1,(P) ;GET FD TYPE AGAIN
CAIE S1,.FDNET ;ELSE,
PUSHJ P,CMRFIL ;SCAN NATIVE 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: MOVE S1,(P) ;GET FD TYPE AGAIN
CAIN S1,.FDNET ;IF NETWORK FILESPEC PARSING
JRST XFIL.2 ;DO IT
PUSHJ P,FILIN ;GET FILE SPEC
NOPARS(IFS) ;Invalid file spec
JRST XFIL.3 ;JOIN COMMON CODE
XFIL.2: PUSHJ P,NFILIN ;GET NETWORK FILE SPEC
NOPARS(IFS) ;INVALID FILE SPEC
XFIL.3: POP P,(P) ;CLEAR FD TYPE FROM STACK
MOVE T2,ATBPTR ;GET POINTER TO ATOM BUFFER END
IBP T2 ;BUMP PAST TERMINATOR
CAME T2,XXXPTR ;DOES IT MATCH?
NOPARS(IFS) ;Invalid file spec
TXZE F,CMINDF ;ARE WE DOING INDIRECT FILE?
RETSKP ;YES , RETURN FOR PROCESSING
JRST XCOMXI ;OTHERWISE, DONE
FILIN: PUSHJ P,.SAVE1 ;SAVE A REG
LOAD S2,.CMGJB(P2),CM%GJB ;GET ADDR OF FD
MOVEM S2,CRBLK+CR.RES ;SAVE IT FOR CALLER
MOVE P1,S2 ;AND REMEMBER IT
MOVX S1,FDXSIZ ;NOW ZERO IT OUT
STORE S1,.FDLEN(S2),FD.LEN ;STORE LENGTH INTO FD
MOVEI S1,.FDNAT ;GET NATIVE FD TYPE
STORE S1,.FDLEN(S2),FD.TYP ;STORE THE TYPE
SKIPN S1,.FDSTR(P1) ;SEE IF USER SUPPLIED A DEFAULT DEVICE
MOVSI S1,'DSK' ;NO, SUPPLY DEFAULT DEVICE
MOVEM S1,.FDSTR(P1) ;STORE DEFAULT DEVICE
MOVE S1,.CMABP(P2) ;GET ATOM BUFFER POINTER
MOVEM S1,XXXPTR ;STORE IT
PUSHJ P,CNVSIX ;GET A SIXBIT WORD
;**;[77] Insert 2 lines after FILIN+13L. 28-Dec-83 /LWS
TXNE F,CMINDF ;[77] IN INDIRECT FILE?
JUMPE S2,.POPJ ;[77] YES,,DON'T ALLOW DEFAULT FILEN
LDB T2,S1 ;GET TERMINATOR
CAIE T2,":" ;IS FIRST PART A DEVICE
JRST FILI.1 ;NO
MOVEM S2,.FDSTR(P1) ;STORE STRUCTURE NAME
PUSHJ P,CNVSIX ;GET A SIXBIT WORD
LDB T2,S1 ;AND TERMINATING CHARACTER
FILI.1: SKIPE S2 ;IF NO FILE NAME, LOOK FOR EXTENSTION
MOVEM S2,.FDNAM(P1) ;STORE NAME
CAIE T2,"." ;IS THERE AN EXTENSION?
JRST FILI.3 ;NO
PUSHJ P,CNVSIX ;GET A SIXBIT WORD
LDB T2,S1 ;AND TERMINATING CHARACTER
MOVEM S2,.FDEXT(P1) ;SAVE EXTENSION
FILI.3: MOVEM S1,XXXPTR ;UPDATE BYTE POINTER
CAIE T2,"[" ;HAVE WE GOT A PPN?
JRST .POPJ1 ;NO--ALL DONE
PUSHJ P,DBP ;DECREMENT IT
MOVE T1,S1 ;PLACE POINTER BACK IN T1
MOVEI T2,.FDPPN(P1) ;POINT TO DESTINATION
HRLI T2,<FDXSIZ-.FDPPN> ;AND SET MAXIMUM SFD DEPTH
PUSHJ P,PATHIN ;PARSE THE PATH
PJRST TIELCH ;FAILED--TERMINATE ATOM BUFFER
IBP XXXPTR ;AND BUMP PAST TERMINATOR
JRST .POPJ1 ;ALL DONE
; Here to parse a network file specification of the form:
;
; node"user passw acct"::device:[directory]file.name;generation
;
; Example:
;
; MARS"SMITH SPLIT A-1234"::SYS$SYSTEM:[SYSHLP]RUNOFF.HLP;1
;
NFILIN: MOVE S1,.CMABP(P2) ;Get atom buffer pointer
MOVEM S1,XXXPTR ;Save away
ILDB S1,S1 ;Get first character
JUMPE S1,[CAIN T1,.CHLFD ;If it is null
JRST .+1 ;And at EOL, we have a valid filespec
NOPARS(IFS)] ;Else, not a valid filespec
LOAD T1,.CMGJB(P2),CM%GJB ;Get address of FD
MOVEM T1,CRBLK+CR.RES ;Save for caller
LOAD T2,.FDLEN(T1),FD.LEN ;Get length of FD
SUBI T2,.FDFIL ;Minus the length field
IMULI T2,5 ;Times 5 characters per word
SUBI T2,1 ;Need to save space for null at end
MOVEM T2,FDFSIZ ;Save away
ADDI T1,.FDFIL ;Where to store string
HRLI T1,(POINT 7,0) ;Make into a byte pointer
MOVEM T1,FDFPTR ;Save away
SETZM LSTERR ;Save first file parsing error code
SETZM PRSDND ;Clear some flags
SETZM PRSDAC
SETZM PRSDDV
SETZM PRSDNM
SETZM PRSDEX
SETZM PRSDGN
SETZM PRSDDR
NFL.1: MOVE S1,XXXPTR ;Current Field begins here
MOVEM S1,BEGPTR ;Save for later
MOVEI T2,NFLDLM ;Get field delimiter break table
PUSHJ P,NFLSPN ;Span to end-of-field
MOVE S1,XXXPTR ;Pointer to end-of-filed
MOVEM S1,ENDPTR ;Save it
CAIN T1,":" ;Colon?
JRST NFL.3 ;Go parse a node or device
CAIN T1,"." ;Dot?
JRST NFL.4 ;Go parse a file name
CAIE T1,"[" ;Square brackets?
CAIN T1,74 ;Or angle brackets?
JRST NFL.5 ;Go parse directory
CAIN T1,";" ;Semi-colon?
JRST NFL.6 ;Go parse a generation number
CAIN T1,"""" ;Quote?
JRST NFL.7 ;Go parse access string
CAIN T1,0 ;Null?
JRST NFL.8 ;Go finish up parse
NOPARS(IFS) ;Bad file spec then
NFL.2: SETZ S1,
IDPB S1,FDFPTR ;Make sure a null terminates FD buffer
RETSKP ;Give good return
; Here when delimiter is ":". Could be a device or node name
NFL.3: MOVE S1,XXXPTR ;Could be node or device
ILDB S2,S1 ;Get next character
CAIE S2,":" ;Another colon?
JRST [PUSHJ P,NFL.DV ;No, go copy the device name
JRST NFL.1] ;And loop for next field
MOVEM S1,XXXPTR ;New atom buffer pointer
MOVEM S1,ENDPTR ;New end-of-field pointer
PUSHJ P,NFL.ND ;Go copy the node name
JRST NFL.1 ;And loop for next field
; Here when delimiter was ".". Could be a file name or extension
NFL.4: SKIPN PRSDNM ;Could it be a file name?
JRST [PUSHJ P, NFL.NM ;Yes, go copy it
JRST NFL.1] ;And loop for next field
SKIPN PRSDEX ;Or, could it be an extension?
JRST [PUSHJ P,NFL.EX ;Yes, go copy it
JRST NFL.1] ;And loop for next field
NOPARS(IFS) ;Must be bad syntax
; Here when delimiter was "[" or angle bracket. Could be a naked
; directory, a file name, and extension, or a generation number. After
; deciding and parsing that field, go parse the directory that follows.
NFL.5: MOVE S1,BEGPTR ;Is this the beginning of field?
IBP S1
CAMN S1,ENDPTR
JRST [MOVE S1,T1 ;Yes, copy the delimiter to FD buffer
PUSHJ P,NFLCHR
PUSHJ P,NFL.DR ;Then, parse the directory
JRST NFL.1] ;And loop for next field
SKIPN PRSDNM ;No, Could be a file name?
JRST [PUSHJ P,NFL.NM ;Yes, copy copy it
LDB T1,ENDPTR ;Get back delimiter
PUSHJ P,NFL.DR ;Then, parse the directory
JRST NFL.1] ;And loop for next field
SKIPN PRSDEX ;Or, it could be file extension?
JRST [PUSHJ P,NFL.EX ;Yes, copy it
LDB T1,ENDPTR ;Get back delimiter
PUSHJ P,NFL.DR ;Then, parse the directory
JRST NFL.1] ;And loop for next field
SKIPN PRSDGN ;Or, it could be the generation number
JRST [PUSHJ P,NFL.GN ;Yes, copy it
LDB T1,ENDPTR ;Get back delimiter
PUSHJ P,NFL.DR ;Then, parse the directory
JRST NFL.1] ;And loop for next field
NOPARS(IFS) ;Must be bad syntax
; Here when delimiter was ";". Parse an extension
NFL.6: PUSHJ P,NFL.EX ;Copy the file extension
JRST NFL.1 ;Then loop for next field
; Here when delimiter was a quote. Could be a fully quoted file spec
; or the access string following a node name
NFL.7: MOVE S1,BEGPTR ;Is this the beginning of field?
IBP S1
CAME S1,ENDPTR
JRST [PUSHJ P,NFL.ND ;No, so copy the node name
LDB T1,ENDPTR ;Get back delimiter
PUSHJ P,NFL.AC ;Then the access info
JRST NFL.1] ;Then loop for next field
PUSHJ P,NFLQST ;Else a quoted filespec, copy as is
ILDB S1,XXXPTR ;Get next character
SKIPN S1 ;Better be null
JRST NFL.2 ;Yes, so finish off
NOPARS(IFS) ;Syntax error
; Here when delimiter was null. We may have a file name, extension,
; or generation number. After deciding and parsing it, go clean up.
NFL.8: MOVE S1,BEGPTR ;Is this the beginning of field?
IBP S1
CAMN S1,ENDPTR
JRST NFL.2 ;Yes, finish up
SKIPN PRSDNM ;No, Could be a file name?
JRST [PUSHJ P,NFL.NM ;Yes, copy copy it
JRST NFL.2] ;And finish up
SKIPN PRSDEX ;Or, it could be file extension?
JRST [PUSHJ P,NFL.EX ;Yes, copy it
JRST NFL.2] ;And finish up
SKIPN PRSDGN ;Or, it could be the generation number
JRST [PUSHJ P,NFL.GN ;Yes, copy it
JRST NFL.2] ;And finish up
NOPARS(IFS) ;Must be bad syntax
; Copy a node name from atom buffer to FD buffer
NFL.ND: SKIPE PRSDND ;Already seen one?
SKIPE PRSDAC ;No, but if seen access string
CAIA ;All okay
JRST NFLND1 ;Not valid
MOVEI T2,NFLDND ;Break mask table
PUSHJ P,NFLCPY ;Copy to FD buffer
JRST NFLND1 ;Invalid systax
SETOM PRSDND ;Flag that we saw one
POPJ P, ;All done
NFLND1: NOPARS(IND)
; Copy a access string from atom buffer to FD buffer
NFL.AC: SKIPE PRSDAC ;Already seen one?
JRST NFLAC1 ;Not valid
MOVEI T2,NFLDAC ;Break mask table
MOVEI S2,"""" ;Get delimiter
PUSHJ P,NFLSTR ;Copy to FD buffer
JRST NFLAC1 ;Invalid systax
SETOM PRSDAC ;Flag that we saw one
POPJ P, ;All done
NFLAC1: NOPARS(IAC)
; Copy a device name from atom buffer to FD buffer
NFL.DV: SKIPE PRSDDV ;Already seen one?
JRST NFLDV1 ;Not valid
MOVEI T2,NFLDDV ;Break mask table
PUSHJ P,NFLCPY ;Copy to FD buffer
JRST NFLDV1 ;Invalid systax
SETOM PRSDDV ;Flag that we saw one
POPJ P, ;All done
NFLDV1: NOPARS(IDV)
; Copy a file name from atom buffer to FD buffer
NFL.NM: SKIPE PRSDNM ;Already seen one?
JRST NFLNM1 ;Not valid
MOVEI T2,NFLDNM ;Break mask table
PUSHJ P,NFLCPY ;Copy to FD buffer
JRST NFLNM1 ;Invalid systax
SETOM PRSDNM ;Flag that we saw one
POPJ P, ;All done
NFLNM1: NOPARS(INA)
; Copy a extension from atom buffer to FD buffer
NFL.EX: SKIPE PRSDEX ;Already seen one?
JRST NFLEX1 ;Not valid
MOVEI T2,NFLDNM ;Break mask table
PUSHJ P,NFLCPY ;Copy to FD buffer
JRST NFLEX1 ;Invalid systax
SETOM PRSDEX ;Flag that we saw one
POPJ P, ;All done
NFLEX1: NOPARS(IEX)
; Copy a generation number from atom buffer to FD buffer
NFL.GN: SKIPE PRSDGN ;Already seen one?
JRST NFLGN1 ;Not valid
MOVEI T2,NFLDGN ;Break mask table
PUSHJ P,NFLCPY ;Copy to FD buffer
JRST NFLGN1 ;Invalid systax
SETOM PRSDGN ;Flag that we saw one
POPJ P, ;All done
NFLGN1: NOPARS(IGN)
; Copy a directory from atom buffer to FD buffer
NFL.DR: SKIPE PRSDDR ;Already seen one?
JRST NFLDR1 ;Not valid
MOVEI T2,NFLDDR ;Break mask table
CAIN T1,"[" ;If delimiter was square bracket
SKIPA S2,["]"] ;Scan to square bracket
MOVEI S2,76 ;Else scan to angle bracket
PUSHJ P,NFLSTR ;Copy to FD buffer
JRST NFLDR1 ;Invalid systax
SETOM PRSDDR ;Flag that we saw one
POPJ P, ;All done
NFLDR1: NOPARS(IDR)
NFLDLM: 777777,,777760 ;Break mask for filespec field delimiting
100010,,001600 ; Break on control characters and ":.;[
000000,,000400
000000,,000000
NFLDND: 777777,,777760 ;Break mask for node name parsing
777774,,000760 ; Break on non-alphanumeric
400000,,000760
400000,,000760
NFLDAC: 777777,,777760 ;Break mask for access string parsing
000000,,000000 ; Break on non-graphic characters
000000,,000000
000000,,000060
NFLDDV: 777777,,777760 ;Break mask for device name parsing
757774,,000760 ; Break on NOT (alphanumeric or $_)
400000,,000740
400000,,000760
NFLDNM: 777777,,777760 ;Break mask for file name/extention parsing
747554,,001760 ; Break on NOT (alphanumeric or -$_*%)
400000,,000740
400000,,000760
NFLDGN: 777777,,777760 ;Break mask for generation parsing
777574,,001760 ; Break on non-numeric
777777,,777760
777777,,777760
NFLDDR: 777777,,777760 ;Break mask for directory parsing
747504,,001760 ; Break on NOT (alphanumeric or .-$_*%)
400000,,000740
400000,,000760
; Copy a character to the FD buffer (if there is room)
NFLCHR: SOSGE FDFSIZ ;Room left?
POPJ P, ;No, just return
IDPB S1,FDFPTR ;Append character to buffer
POPJ P, ;Return
; Copy a quoted string. Terminated by NULL or ".
NFLQST: ILDB S1,XXXPTR ;Get next character
JUMPE S1,.POPJ ;If null, done
CAIE S1,"""" ;Close quote?
JRST [PUSHJ P,NFLCHR ;No, put in FD buffer
JRST NFLQST] ;And loop
MOVE S1,XXXPTR ;Get pointer
ILDB S1,S1 ;Get next character
CAIE S1,"""" ;Another quote?
POPJ P, ;No, done
ILDB S1,XXXPTR ;Yes, that means a single "
PUSHJ P,NFLCHR ;Put it in the FD buffer
JRST NFLQST ;And loop
; Copy a string until: 1) Delimiter seen, 2) Null character seen.
;
; S2/ delimiter
;
; Returns CPOPJ if null seen before delimiter
; CPOPJ1 if delimiter seen
NFLSTR: ILDB S1,XXXPTR ;Get next character
JUMPE S1,.POPJ ;If null, return now
PUSHJ P,NFLCHR ;Put in FD buffer
CAME S1,S2 ;Was it the delimiter we were looking for?
JRST NFLSTR ;No, loop
JRST .POPJ1 ;Yes, skip return
RETSKP
; Scan the Atom buffer for a break character.
; T2/ address of break table
;
; Returns POPJ with T1 containing the break character, and XXXPTR
; updated.
NFLSPN: ILDB S1,XXXPTR ;Get next character
MOVE T1,S1 ;Save a copy
IDIVI S1,40 ;Divide into word and bit number
MOVE S2,BITS(S2) ;Get bit mask
ADD S1,T2 ;Address in break table
TDNE S2,(S1) ;Break character?
POPJ P, ;Yes, return
JRST NFLSPN ;No, continue looking
; Copy from atom buffer (BEGPTR) to FD buffer until end of field (ENDPTR) or
; break character.
; T2/ address of break table
;
; Return POPJ if a break seen (character in T1), POPJ1 if ENDPTR reached
NFLCPY: ILDB S1,BEGPTR ;Get a character
PUSHJ P,NFLCHR ;Copy to FD buffer
MOVE S2,BEGPTR ;Get copy of byte pointer
CAMN S2,ENDPTR ;At end of field?
JRST .POPJ1 ;Yes, return
MOVE T1,S1 ;Save copy of character
IDIVI S1,40 ;Divide into word and bit number
MOVE S2,BITS(S2) ;Get bit mask
ADD S1,T2 ;Address in break table
TDNE S2,(S1) ;Break character?
POPJ P, ;Yes, return
JRST NFLCPY ;No, loop for more
;FILESPEC HELP
CMFHLP: TXNE F,CMINDF ;IS IT AN INDIRECT FILE?
JRST [HRROI T1,[ASCIZ / filespec of indirect file/]
JRST CMFH1] ;SPECIAL HELP IF INDIRECT FILESPEC
PUSHJ P,DOHLP ;DO USER MESSAGE
JXN F,CM%SDH,CMRTYP ;SUPPRESS DEFAULT HELP IF REQUESTED
LOAD T2,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
CAXE T2,.CMIFI ;INPUT FILE?
SKIPA S1,[EXP [ASCIZ / output filespec/]] ;NO, OUTPUT
MOVEI S1,[ASCIZ \ input filespec\] ;YES,INPUT
CMFH1: PUSHJ P,CMDSTO
JRST CMRTYP
;TOKEN - ARBITRARY SYMBOL AS SPECIFIED BY FN DATA
XCMTOK: MOVE Q1,FNARG ;GET STRING ADDRESS
TLC Q1,-1 ;TOPS20-style string pointer?
TLCN Q1,-1 ; ..
HRLI Q1,(POINT 7,) ;Yes, fix up
TXNN F,CMDEFF ;USING DEFAULT STRING?
JRST CMTOK1 ;NO
MOVE Q2,Q1 ;GET TOKEN POINTER IN Q2
MOVE Q1,.CMABP(P2) ;GET POINTER TO ATOM BUFFER (DEFAULT STRING)
XCMTK1: ILDB T1,Q2 ;GET NEXT CHARACTER FROM TOKEN
JUMPE T1,XCOMXI ;SUCCESS IF END OF STRING
ILDB T2,Q1 ;GET CHAR FROM DEFAULT STRING
CAMN T2,T1 ;MATCH?
JRST XCMTK1 ;YES, CONTINUE
NOPARS (NMT) ;NO, DOES NOT MATCH TOKEN
CMTOK1: ILDB Q2,Q1 ;GET NEXT CHAR IN STRING
JUMPE Q2,[PUSHJ P,TIELCH ;SUCCESS IF END OF STRING
JRST FIXESC]
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
HRROI S1,[ASCIZ / "/]
PUSHJ P,CMDSTO
MOVE S1,FNARG
PUSHJ P,CMDSTO
MOVEI S1,""""
PUSHJ P,CMDOUT
JRST CMRTYP]
NOPARS (NMT) ;Does not match token
SUBTTL PATHIN Routine to Parse TOPS-10 Path Specification
; PATHIN may be called to Parse a Path Specification in the Atom Buffer
; it builds a Path Block up to 6 words in length depending
; on the depth specified in T2 on the call.
; CALL T1/ Byte Pointer to String
; T2/ Length of Destination,,Destination Address
; Uses T1-T4 and XXXPTR
; Destination must not be an AC and Depth must be Less Than 6
; True Return is a Skip Return
; With: PPN and Path Stored Via Calling Arg in T2
; XXXPTR Pointing to Terminating byte ("]") in String
; Error Return is a non skip Return
PATHIN: ILDB S1,T1 ;LOAD FIRST BYTE
CAIE S1,"[" ;MUST BE BRACKET
POPJ P, ;NO
PUSHJ P,.SAVE1 ;SAVE P1
HLRZ P1,T2 ;GET DESIRED LENGTH
CAILE P1,<FDXSIZ-.FDPPN> ;TOO LARGE?
MOVEI P1,<FDXSIZ-.FDPPN> ;YES--ADJUST A BIT
MOVNS P1 ;NEGATE
HRLZS P1 ;PUT IN LH
HRRI P1,(T2) ;POINT TO THE PPN STORAGE
MOVE S1,T1 ;GET BYTE POINTER
ILDB S1,S1 ;AND NEXT CHARACTER
CAIE S1,"-" ;DEFAULT PATH?
JRST PATH.1 ;NO
IBP T1 ;ADVANCE
IBP T1 ;POINT PAST THE DASH
MOVEM T1,XXXPTR ;SAVE
JRST PATH.3 ;ONWARD
PATH.1: PUSHJ P,PPNPRS ;PARSE PPN
POPJ P, ;NO GOOD
MOVEM S1,XXXPTR ;SAVE IN CASE OF PPN FAILURE
AOBJP P1,PATH.3 ;ADVANCE
PATH.2: LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;SFD ON THE WAY?
JRST PATH.4 ;NO
MOVE S1,XXXPTR ;GET BYTE POINTER
PUSHJ P,CNVSIX ;GET A SIXBIT WORD
JUMPE S2,.POPJ ;NULL SFDS ARE ILLEGAL
MOVEM S2,(P1) ;STORE SFD NAME
MOVEM S1,XXXPTR ;UPDATE BYTE POINTER
AOBJN P1,PATH.2 ;YES--LOOP
PATH.3: LDB T1,XXXPTR ;GET TERMINATOR
PATH.4: CAIE T1,"]" ;END OF PATH?
POPJ P, ;NO
JUMPGE P1,PATH.5 ;JUMP IF FULL SFD SPEC
SETZM (P1) ;CLEAR 'TILL END OF
AOBJN P1,.-1 ; USER'S ARGUMENT BLOCK
PATH.5: JRST .POPJ1 ;RETURN
; RDPPN
; Read PPN for this job into PPNWRD
RDPPN: SETZM PPNWRD ;CLEAR PPN WORD
SETZM PPNMSK ;CLEAR PPN MASK
HRROI S1,.GTPPN ;WANT PPN
GETTAB S1, ;GO AND GET IT
SETZ S1, ;???
MOVEM S1,PPNWRD ;SAVE IT
POPJ P,0 ;RETURN
; PARSE A USER ID (PPN)
; NOTE: SETTING CM%WLD AND GIVING THE ADDRESS OF A
; TWO WORD ARGUMENT BLOCK WILL CAUSE THE PARSED
; PPN AND MASK TO BE STORED IN SAID BLOCK.
XCMUSR: PUSHJ P,CMRPPN ;VALIDATE PPN STRING
MOVEI S1,[ASCIZ/[project,programmer]/]
TXNE F,CMQUES ;QUESTION MARK TYPED?
PUSHJ P,HELPER ;YES, GIVE HELP
TXNN F,CM%ESC ;ESCAPE TYPED?
JRST XUSR.1 ;NO
PUSHJ P,CMDCH ;ALLOW ESCAPE AS TERMINATOR
PUSHJ P,TIELCH ;TERMINATE ATOM BUFFER WITH A NULL
XUSR.1: MOVE T1,.CMABP(P2) ;POINT TO ATOM
MOVEI T2,CRBLK+CR.RES ;POINT TO DESTINATION
PUSHJ P,PPNINP ;PARSE A POSSIBLY WILDCARDED PPN
NOPARS (IUS) ;INVALID USER SPECIFIED
MOVE T1,XXXPTR ;ENSURE ENTIRE ATOM WAS PARSED
CAME T1,ATBPTR ;BYTE POINTERS MUST BE THE SAME
NOPARS (IUS) ;INVALID USER SPECIFIED
JRST XCOMXI ;DONE NOW
CMRPPN: PUSHJ P,CMCIN ;GET THE FIRST CHARACTER OF INPUT
CAIN T1,CMHLPC ;IS IT THE HELP CHARACTER?
JRST [TXO F,CMQUES ;YES, SAY WE NEED SOME HELP
POPJ P,] ;TAKE THE ERROR (HELP) RETURN
PUSHJ P,CMDIP ;NO, JUST PUT IT BACK IN THE BUFFER
MOVE TF,FNARG ;GET FUNCTION ARGUMENTS
MOVEI T1,PPNBRK ;POINT TO NORMAL BREAK SET
TXNE TF,CM%WLD ;WANT WILDCARDING?
MOVEI T1,PPWBRK ;YES
TXNE TF,CM%WLA ;WANT WILDCARDING (ACCOUNTING-STYLE)?
MOVEI T1,PPABRK ;YES
PUSHJ P,CMRFLD ;READ FIELD
CMRPP1: TXNE F,CMQUES ;WANT HELP?
POPJ P, ;YES
TXNE F,CM%ESC!CMCFF ;RECOGNITION OF SOME SORT?
JRST CMRPP3 ;YES
PUSHJ P,CMCIN ;GET TERMINATING CHARACTER
CAIE T1,"]" ;NORMAL ENDING?
JRST CMRPP2 ;NO
PUSHJ P,STOLCH ;STORE BRACKET
PUSHJ P,CMCIN ;GET NEXT CHARACTER
CAIN T1,CMHLPC ;IS IT THE HELP CHARACTER?
JRST [TXO F,CMQUES ;YES, SAY WE NEED HELP
POPJ P,] ;TAKE THE ERROR (HELP) RETURN
TXNN F,CM%ESC!CMCFF ;RECOGNITION?
PUSHJ P,CMDIP ;NO--BACK UP OVER THE CHARACTER
POPJ P, ;RETURN
CMRPP2: TXNN F,CM%EOC ;EOL WITH NO TRAILING BRACKET?
POPJ P, ;NO
MOVEI T1,"]" ;GET TERMINATOR
PUSHJ P,STOLCH ;STORE IT
PJRST CMDIP ;BACKUP AND RETURN
CMRPP3: PUSHJ P,CMDIP ;BACKUP
PUSHJ P,CMCIN ;GET TERMINATING CHARACTER
PUSH P,T1 ;SAVE CHARACTER
PUSHJ P,CMDCH ;DELETE THE RECOGNIZER
MOVEI T1,"]" ;GET OUR TERMINATOR
PUSHJ P,STOLCH ;STUFF IN ATOM BUFFER
PUSHJ P,CMDIB ;AND IN COMMAND BUFFER
POP P,T1 ;GET BACK TERMINATOR
PJRST CMDIBQ ;STORE IN CMD BUFFER AND RETURN
; NORMAL PPN BREAK MASK
PPNBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
777734,,001760 ;BREAK ON PUNCTUATION, ALLOW , 0-9
777777,,777360 ;BREAK ON UC A-Z, ], ALLOW [
777777,,777760 ;BREAK ON LC A-Z
; WILDCARD PPN BREAK MASK
PPWBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
777534,,001740 ;BREAK ON PUNCTUATION, ALLOW * ? , 0-9
777777,,777360 ;BREAK ON UC A-Z, ], ALLOW [
777777,,777760 ;BREAK ON LC A-Z
; WILDCARD PPN (ACCOUNTING-STYLE) BREAK MASK
PPABRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
727534,,001740 ;BREAK ON PUNCTUATION, ALLOW # % * ? , 0-9
777777,,777360 ;BREAK ON UC A-Z, ], ALLOW [
777777,,777760 ;BREAK ON LC A-Z
PPNINP: ILDB S1,T1 ;LOAD FIRST BYTE
CAIN S1,"[" ;MUST BE BRACKET
PUSHJ P,PPNPRS ;PARSE PPN
POPJ P, ;NO GOOD
MOVEM S1,XXXPTR ;STORE UPDATED POINTER
LDB S1,S1 ;GET TERMINATOR
CAIE S1,"]" ;END OK?
POPJ P, ;NO
TXNE F,CMDEFF ;WAS FIELD DEFAULTED?
IBP XXXPTR ;YES--UPDATE BYTE POINTER
MOVE T1,(T2) ;RECLAIM PPN
MOVE S1,FNARG ;GET FUNCTION SPECIFIC ARGUMENT WORD
TXNN S1,CM%WLD!CM%WLA ;WANT WILDCARD MASK?
JRST .POPJ1 ;NO
HRRZS S1 ;KEEP ONLY THE ADDRESS
CAIG S1,17 ;IN THE ACS?
$RETE (NCI) ;LOSER
MOVE S2,PPNMSK ;GET MASK
MOVEM T1,0(S1) ;SAVE PPN WORD
MOVEM S2,1(S1) ;SAVE PPN MASK
JRST .POPJ1 ;RETURN
; ROUTINE TO PARSE A PPN
; NOTE: THIS DOESN'T HANDLE BRACKETS, ONLY PROJ#,PROG#
PPNPRS: PUSHJ P,RDPPN ;GET CURRENT PPN
MOVEM T1,XXXPTR ;SAVE IN CASE OF PPN FAILURE
MOVE S1,T1 ;GET THE POINTER
ILDB T1,T1 ;GET FIRST CHARACTER
CAIN T1,"#" ;NEVER VALID ON PROJECT NUMBER
POPJ P, ;GIVE UP
PUSHJ P,OCTWLD ;GET PROJECT NUMBER
SKIPT ;ANYTHING PARSED?
HLL S2,PPNWRD ;USE DEFAULT
PUSHJ P,PPNZER ;WAS A ZERO TYPED?
POPJ P, ;PROJECT ZERO ILLEGAL
HLLM S2,(T2) ;SAVE PROJECT NUMBER
HRLM S2,PPNMSK ;SAVE MASK
LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;MUST BE COMMA
POPJ P,0 ;FAIL -- PPN NOT NUMERIC
PUSHJ P,OCTWLD ;GET PROGRAMMER NUMBER
SKIPT ;ANYTHING PARSED?
HRL S2,PPNWRD ;USE DEFAULT
PUSHJ P,PPNZER ;WAS A ZERO TYPED?
POPJ P, ;PROGRAMMER ZERO ILLEGAL
HLRM S2,0(T2) ;SAVE PROGRAMMER NUMBER
HRRM S2,PPNMSK ;SAVE MASK
JRST .POPJ1 ;RETURN
; CHECK FOR A SINGLE ZERO BEING TYPED
PPNZER: TRNN S2,-1 ;WAS AT LEAST ONE NON-WILD DIGIT TYPED?
SKIPA ;NO
TLNE S2,-1 ;WAS A ZERO TYPED?
AOS (P) ;NO
POPJ P, ;RETURN
; INPUT A POSSIBLY WILD OCTAL HALF-WORD QUANTITY
; ON RETURN, S1 = TERMINATING BYTE POINTER, S2 = NUMBER,,MASK
OCTWLD: PUSHJ P,.SAVE1 ;SAVE P1
MOVE P1,S1 ;COPY BYTE POINTER
MOVEI S2,777777 ;CLEAR RESULT AND INIT MASK
ILDB S1,P1 ;GET A CHARACTER
CAIN S1,"%" ;ALL PROGRAMMER NUMBERS?
JRST OCTW.6 ;YES
CAIN S1,"#" ;DEFAULT PROGRAMMER NUMBER?
JRST OCTW.5 ;YES
CAIN S1,"*" ;ALL DIGITS WILD?
JRST OCTW.4 ;YES
CAIN S1,"?" ;WILD DIGIT?
JRST OCTW.3 ;YES
CAIL S1,"0" ;RANGE CHECK
CAILE S1,"7" ; FOR AN OCTAL DIGIT
SKIPA ;NOTHING PARSED
JRST OCTW.2 ;ONWARD
MOVE S1,P1 ;GET UPDATED BYTE POINTER
$RETF ;AND RETURN
OCTW.1: ILDB S1,P1 ;GET A CHARACTER
CAIN S1,"?" ;WILD DIGIT?
JRST OCTW.3 ;YES
CAIL S1,"0" ;RANGE CHECK
CAILE S1,"7" ; FOR AN OCTAL DIGIT
JRST OCTW.7 ;NO GOOD--FINISH UP
OCTW.2: TDZ S2,[700000,,700000] ;PREVENT OVERFLOW
LSH S2,3 ;SHIFT RESULT AND MASK
SUBI S1,"0" ;CONVERT ASCII TO OCTAL
TLO S1,7 ;GET MASK
TSO S2,S1 ;INCLUDE DIGIT AND MASK
JRST OCTW.1 ;LOOP
OCTW.3: TDZ S2,[700000,,700000] ;PREVENT OVERFLOW
LSH S2,3 ;SHIFT RESULT AND MASK
TLO S2,7 ;DIGIT WAS WILD
JRST OCTW.1 ;LOOP FOR ANOTHER DIGIT
OCTW.4: ILDB S1,P1 ;ADVANCE BYTE POINTER
MOVEI S2,0 ;SET FULL WILDCARD MASK
JRST OCTW.7 ;FINISH UP
OCTW.5: SKIPA S2,[-2,,-1] ;SET RESULT AND MASK FOR [10,#]
OCTW.6: MOVNI S2,1 ;SET RESULT AND MASK FOR [10,%]
ILDB S1,P1 ;ADVANCE BYTE POINTER
OCTW.7: MOVE S1,P1 ;GET UPDATED BYTE POINTER
$RETT ;RETURN
; DIRECTORY
XCMDIR: PUSHJ P,CMRPTH ;GET PATH SPEC INTO ATOM
MOVEI S1,[ASCIZ/[path]/] ;HELP TEXT
TXNE F,CMQUES ;QUESTION MARK TYPED?
PUSHJ P,HELPER ;YES, GIVE HELP
TXNN F,CM%ESC ;ESCAPE TYPED?
JRST XDIR.1 ;NO
PUSHJ P,CMDCH ;ALLOW ESCAPE AS TERMINATOR
PUSHJ P,TIELCH ;TERMINATE ATOM BUFFER WITH A NULL
XDIR.1: MOVE T1,.CMABP(P2) ;POINT TO ATOM
SKIPN T2,FNARG ;GET POSSIBLE ADDRESS OF BLOCK TO STORE PATH
MOVEI T2,CRBLK+CR.RES ;POINT TO DESTINATION IF STORING PPN ONLY
HRRZM T2,CRBLK+CR.RES ;SAVE PTR TO RESULT (MAYBE OVERWRIT W/PPN)
HRLI T2,<FDXSIZ-.FDPPN> ;AND SET MAXIMUM SFD DEPTH
PUSHJ P,PATHIN ;PARSE PATH
SKIPA ;FAILED
JRST XDIR.2 ;ONWARD
PUSHJ P,TIELCH ;TIE OFF ATOM BUFFER FOR CLEAN ERROR TEXT
NOPARS (IPS) ;INVALID PATH SPECIFICATION
XDIR.2: MOVE T1,XXXPTR ;ENSURE ENTIRE ATOM WAS PARSED
CAME T1,ATBPTR ;BYTE POINTERS MUST BE THE SAME
NOPARS (IPS) ;INVALID PATH 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 (CMA) ;Not a comma
;DATE AND/OR TIME
;FLAGS IN ARG SPECIFY WHICH
XCMTAD: MOVE Q1,FNARG ;GET ARG
MOVEI T1,DAYBRK ;POINT TO DATE BREAK SET
TXNE Q1,CM%IDA ;WANT A DATE?
PUSHJ P,CMRFLD ;YES..READ DATE FIELD
JXN F,CMQUES,CMTADH ;DO HELP IF REQUESTED
JXN F,CMDEFF,CMTAD1 ;JUMP IF NOW HAVE FIELD DEFAULT
JXN F,CM%ESC,CMAMB ;DING IF ESCAPE WAS TYPED
TXNN Q1,CM%ITM ;WANT THE TIME?
JRST CMTAD1 ;NO..PROCEED
TXNN Q1,CM%IDA ;Did we parse a date also?
JRST CMTAD2 ; No, it was just time
PUSHJ P,CMCIN ; Get the break character
CAIN T1,":" ; Was it a colon?
JRST CMTAD0 ; Yes, go put it back
MOVEI T1," " ; Make sure it was a space
PUSHJ P,STOLCH ; . . . that ended the field
CMTAD0: PUSHJ P,CMDIP ; Put the break character back
CMTAD2: MOVEI T1,TIMBRK ;POINT TO TIME BREAK SET
PUSHJ P,CMRFLD ;READ THE FIELD
JXN F,CMQUES,CMTADH ;DO HELP
JXN F,CM%ESC,CMAMB ;DING IF ESCAPE WAS TYPED
CMTAD1: MOVE S1,.CMABP(P2) ;POINT TO THE ATOM
MOVE S2,FNARG ;GET THE FLAGS
PUSHJ P,XDATIM ;GET PROPER ARGS
MOVE T1,S1 ;GET POSSIBLE ERROR CODE
;OR UPDATED POINTER
JUMPF XCOMNE ;PROCESS ERROR IF ANY
LDB T1,T1 ;GET THE TERMINATING BYTE
SKIPE T1 ;MUST BE A NULL
NOPARS(IDT) ;ELSE INVALID DATE/TIME
MOVEM S2,CRBLK+CR.RES ;STORE RESULT
JRST XCOMXR
;TIME/DATE HELP
CMTADH: PUSHJ P,DOHLP ;DO USER TEXT
JXN F,CM%SDH,CMRTYP ;CHECK SUPPRESS DEFAULT
LOAD T1,Q1,<CM%IDA+CM%ITM> ;GET FLAGS
MOVE S1,[[ASCIZ //]
[ASCIZ / time/]
[ASCIZ / date/]
[ASCIZ / date and time/]](T1)
PUSHJ P,CMDSTO ;PRINT APPROPRIATE MESSAGE
JRST CMRTYP
DAYBRK: 777777,,777760 ;Break on all control
777654,,001760 ;Allow + - 0-9
400000,,000760 ;Allow A-Z
400000,,000760 ;Allow a-z
TIMBRK: 777777,,777760 ;Break on all control
777774,,000760 ;Allow 0-9 and :
777777,,777760 ;Break on A-Z
777777,,777760 ;Break on a-z
;LOCAL ROUTINE TO SETUP BYTE PTR TO TABLE STRING AND GET FLAGS
; T2/ ADDRESS OF STRING
; PUSHJ P,CHKTBS
; T1/ FLAGS
; T2/ BYTE POINTER TO STRING
CHKTBS: HRLI T2,(POINT 7) ;SETUP P AND S FIELDS
SKIPE T1,0(T2) ;CHECK FIRST WORD OF STRING
TXNE T1,177B6 ;FIRST CHAR 0 AND WORD NOT ALL-0?
TDZA T1,T1 ;NO, MAKE FLAGS ALL 0
AOS T2 ;YES, HAVE FLAGS, ADJUST BYTE PTR
POPJ P,0
> ;END TOPS10 CONDITIONAL
SUBTTL CMDOUT -- CHARACTER OUTPUT FOR TERMINALS AND FILES
;THIS ROUTINE WILL DUMP A CHARACTER TO THE TERMINAL OR A FILE
;DEPENDING ON THE JFN IN THE TEXTI ARGUMENT BLOCK
IFN FTUUOS,<
CMDOUT: HRRZ S2,JFNWRD ;GET OUTPUT JFN
CAXN S2,.NULIO ;NULL?
$RETT ;JUST IGNORE IT
CAXN S2,.PRIOU ;PRIMARY OUTPUT TERMINAL?
PJRST K%BOUT ;OUTPUT IT
MOVE S2,S1 ;GET THE CHARACTER
HRRZ S1,JFNWRD ;GET THE OUTPUT JFN
PUSHJ P,F%OBYT ;DUMP THE CHARACTER
JUMPT .POPJ ;O.K.. RETURN
$TEXT (T%TTY,<^M^J?File Output Failed ^E/[-1]/>)
TXO F,CM%NOP ;RETURN FAILURE, NO CHECK ALTERNATIVES
JRST XCOMX2
SUBTTL CMDSTO -- STRING OUTPUT TO FILE AND TERMINAL
;This routine will check the output JFN and pass the data to
;the file, terminal or null
CMDSTO: HRRZ S2,JFNWRD ;GET OUTPUT JFN
CAXN S2,.NULIO ;NULL?
$RETT ;JUST RETURN
CAXN S2,.PRIOU ;PRIMARY OUTPUT?
PJRST K%SOUT ;YES.. DUMP THE STRING
MOVE T1,S1 ;GET THE STRING POINTER
STRO.1: ILDB S1,T1 ;GET A BYTE
JUMPE S1,.RETT ;RETURN TRUE
PUSHJ P,CMDOUT ;DUMP THE CHARACTER
JRST STRO.1 ;GET NEXT ONE
>;END FTUUOS
SUBTTL S%SCMP -- String Comparison Routine
;CALL IS: S1/ TEST STRING POINTER
; S2/ BASE STRING POINTER
;TRUE RETURN: S1/ COMPARE CODE:
; 1B0 (SC%LSS) - TEST STRING LESS THAN BASE STRING
; 1B1 (SC%SUB) - TEST STRING SUBSET OF BASE STRING
; 1B2 (SC%GTR) - TEST STRING GREATER THAN BASE STRING
; N.O.T.A. MEANS EXACT MATCH
; S2/ UPDATED BASE STRING POINTER, USEFUL IN CASE TEST STRING
; WAS SUBSET
TOPS20 <
S%SCMP: STCMP ;DO THE JSYS
$RETT ;AND RETURN
> ;END TOPS20 CONDITIONAL
TOPS10 <
S%SCMP: PUSHJ P,.SAVET ;SAVE T REGS
DMOVE T1,S1 ;COPY ARGUMENTS
HLRZ T3,T1
CAIN T3,-1
HRLI T1,(POINT 7)
HLRZ T3,T2
CAIN T3,-1
HRLI T2,(POINT 7)
PUSHJ P,USTCMP ;DO THE WORK
DMOVE S1,T1 ;PUT THE ARGUMENTS BACK
$RETT
;STILL IN TOPS10 CONDITIONAL
;STRING COMPARE ROUTINE - REFERENCES PREVIOUS CONTEXT.
; T1/ TEST STRING POINTER
; T2/ BASE STRING POINTER
; PUSHJ P,USTCMP
;RETURN AS FOR .STCMP
USTCMP::ILDB T3,T1 ;GET NEXT BYTE FROM EACH STRING
CAIL T3,"A"+40 ;LC LETTER?
JRST [CAIG T3,"Z"+40
SUBI T3,40 ;YES, CONVERT TO UC
JRST .+1]
ILDB T4,T2
CAIL T4,"A"+40 ;LC LETTER?
JRST [CAIG T4,"Z"+40
SUBI T4,40 ;YES, CONVERT TO UC
JRST .+1]
CAME T3,T4 ;STILL EQUAL?
JRST STRC2 ;NO, GO SEE WHY
JUMPN T3,USTCMP ;KEEP GOING IF NOT END OF STRING
SETZ T1, ;STRINGS ENDED TOGETHER, EXACT MATCH.
POPJ P,0 ;RETURN 0
STRC2: JUMPE T3,[MOVX T1,SC%SUB ;TEST STRING ENDED, IS A SUBSET
ADD T2,[7B5] ;DECREMENT BASE POINTER ONE BYTE
POPJ P,0]
CAMG T3,T4 ;STRINGS UNEQUAL
SKIPA T1,[SC%LSS] ;TEST STRING LESS
MOVX T1,SC%GTR ;TEST STRING GREATER
POPJ P,0
> ;END TOPS10 CONDITIONAL
SUBTTL S%TBLK -- Table lookup routine
;CALL IS: S1/ ADDRESS OF TABLE HEADER WORD
; S2/ STRING POINTER TO STRING TO BE FOUND
;
;TRUE RETURN: S1/ ADDRESS OF ENTRY WHICH MATCHED OR WHERE ENTRY WOULD BE
; IF IT WERE IN TABLE
; S2/ RECOGNITION CODE:
; 1B0 (TL%NOM) - NO MATCH
; 1B1 (TL%AMB) - AMBIGUOUS
; 1B2 (TL%ABR) - UNIQUE ABBREVIATION
; 1B3 (TL%EXM) - EXACT MATCH
TOPS20 <
S%TBLK: PUSH P,T1 ;SAVE T1
TBLUK ;DO THE JSYS
POP P,T1 ;RESTORE T1
$RETT ;AND RETURN
> ;END TOPS20 CONDITIONAL
TOPS10 <
S%TBLK: PUSHJ P,.SAVET ;SAVE SOME REGISTERS
DMOVE T1,S1 ;COPY INPUT ARGUMENTS
PUSHJ P,XTLOOK ;DO THE WORK
DMOVE S1,T1 ;RE-COPY ARGUMENTS
$RETT ;AND RETURN
;WORKER ROUTINE - MAY BE CALLED INTERNALLY.
; RETURNS +1 SUCCESS, ACS AS ABOVE
;INTERNAL AC USAGE:
; T1/ TEST STRING FROM CALL
; T2/ STRING FROM TABLE
; T3/ CLOBBERED BY USTCMP
; T4/ " "
; P1/ CURRENT TABLE INDEX
; P2/ ADDRESS OF TABLE INDEXED BY P1 - USED FOR INDIRECTION
; P3/ INDEX INCREMENT FOR LOG SEARCH
; P4/ SIZE OF TABLE
XTLOOK::PUSHJ P,.SAVE4 ;PRESERVE ACS
$SAVE P5
HLRZ T3,T2 ;CHECK STRING POINTER
CAIE T3,-1 ;LH 0 OR -1?
CAIN T3,0
HRLI T2,(POINT 7) ;YES, FILL IN
MOVEM T2,STRG
MOVEI P2,1(T1) ;CONSTRUCT ADDRESS OF FIRST ENTRY
HRLI P2,P1 ;MAKE IT INDEXED BY P1
HLRZ P4,0(T1) ;GET PRESENT SIZE
MOVE P3,P4 ;INITIAL INCREMENT IS SIZE
MOVE P1,P4 ;SET INITIAL INDEX TO SIZE/2
ASH P1,-1
JUMPE P4,TABLKX ;IF TABLE EMPTY THEN NO MATCH
TABLK0: HLRZ T2,@P2 ;GET STRING ADR FROM TABLE
PUSHJ P,CHKTBS ;CONSTRUCT POINTER
MOVE T1,STRG ;GET TEST STRING
PUSHJ P,USTCMP ;COMPARE
JUMPN T1,TABLK1 ;JUMP IF NOT EXACTLY EQUAL
TABLKF: HLRZ T2,@P2 ;GET STRING ADDRESS
PUSHJ P,CHKTBS ;GET FLAGS
JXN T1,CM%NOR,TABLKM ;MAKE IT AMBIG IF NOREC ENTRY
MOVX T2,TL%EXM ;EXACTLY EQUAL, RETURN CODE
JRST TABLKA
TABLKM: SKIPA T2,[TL%AMB] ;AMBIGUOUS RETURN
TABLKX: MOVX T2,TL%NOM ;NO MATCH RETURN
TABLKA: MOVEI T1,@P2 ;RETURN ADR WHERE ENTRY IS OR SHOULD BE
POPJ P,
;STRING MAY BE UNEQUAL OR A SUBSET, SEE WHICH
TABLK1: JXE T1,SC%SUB,TABLKN ;UNEQUAL, GO SETUP NEXT PROBE
TABLK3: MOVEM T2,REMSTR ;SUBSTRING, SAVE REMAINDER
JUMPE P1,TABLK2 ;JUMP IF THIS FIRST ENTRY IN TABLE
MOVEI T1,@P2 ;CHECK NEXT HIGHER ENTRY IN TABLE
HLRZ T2,-1(T1) ;GET ITS STRING ADDRESS
PUSHJ P,CHKTBS ;BUILD BYTE PTR
MOVE T1,STRG ;GET TEST STRING
PUSHJ P,USTCMP ;TEST PREVIOUS ENTRY
JUMPE T1,[SOJA P1,TABLKF] ;EXACTLY EQUAL, DONE. FIX INDEX.
JXN T1,SC%GTR,TABLK2 ;IF LESS THEN HAVE FOUND HIGHEST SUBSTR
SOJA P1,TABLK3 ;STILL A SUBSTR, CHECK HIGHER
;NOW POINT AT HIGHEST ENTRY WHICH IS A SUBSTR. IF THERE IS AN EXACT
;MATCH, IT IS BEFORE ALL SUBSETS AND HAS ALREADY BEEN FOUND
TABLK2: MOVEI T1,@P2 ;CHECK NEXT ENTRY FOR AMBIGUOUS
CAIL P1,-1(P4) ;NOW AT LAST ENTRY IN TABLE?
JRST TBLK2A ;YES, THIS ENTRY IS DISTINCT
HLRZ T2,1(T1) ;GET STRING ADR OF NEXT ENTRY
PUSHJ P,CHKTBS ;BUILD BYTE PTR
MOVE T1,STRG ;GET TEST STRING
PUSHJ P,USTCMP ;COMPARE NEXT LOWER ENTRY
JUMPE T1,[$STOP(BTF,Bad table format)] ;EXACT MATCH,TABLE IS BAD
JXN T1,SC%SUB,TABLKM ;NEXT ENTRY NOT DISTINCT, DO AMBIG RETURN
TBLK2A: HLRZ T2,@P2 ;CHECK FLAGS FOR THIS ENTRY
PUSHJ P,CHKTBS
JXN T1,CM%NOR,TABLKM ;FAIL IF NOREC BIT SET
MOVX T2,TL%ABR ;GIVE LEGAL ABBREVIATION RETURN
MOVE T3,REMSTR ;RETURN PTR TO REMAINDER OF STRING
JRST TABLKA
;HERE WHEN PROBE NOT EQUAL
TABLKN: CAIG P3,1 ;INCREMENT NOW 1?
JRST [JXN T1,SC%LSS,TABLKX ;YES, NO MATCH FOUND
AOJA P1,TABLKX] ;IF STRING GREATER, BUMP ADR FOR INSERT
AOS P3 ;NEXT INC = <INC+1>/2
ASH P3,-1
TXNE T1,SC%GTR ;IF LAST PROBE LOW, ADD INCREMENT
ADD P1,P3
TXNE T1,SC%LSS
SUB P1,P3 ;LAST PROBE HIGH, SUBTRACT INCR
TBLKN1: CAIL P1,0(P4) ;AFTER END OF TABLE?
JRST [MOVX T1,SC%LSS ;YES, FAKE PROBE TOO HIGH
JRST TABLKN]
JUMPGE P1,TABLK0 ;IF STILL WITHIN TABLE RANGE, GO PROBE
MOVX T1,SC%GTR ;BEFORE START OF TABLE, FAKE LOW PROBE
JRST TABLKN
> ;END TOPS10 CONDITIONAL
SUBTTL S%TBAD -- Table Add Routine
;THIS ROUTINE IS DESIGNED TO ADD AN ENTRY TO A COMMAND
;TABLE AND IS CALLED WITH THE FOLLOWING INFO
;
; CALL WITH: S1/ FLAG!ADDRESS OF TABLE HEADER
; S2/ ADDRESS OF ENTRY TO BE ADDED
;
; FLAG MAY BE TB%ABR - TABLE CONTAINS ABBREVIATIONS
;
;
; 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 ;TRAP THE ERROR JUMP
$RETT ;RETURN TRUE
TBAD.1: MOVEI S1,.FHSLF ;GET THE LAST ERROR
GETER ;GET THE LAST ERROR
HRRZ S2,S2 ;GET JUST THE CODE
MOVEI S1,EREIT$ ;ENTRY ALREADY IN TABLE
CAIN S2,TADDX1 ;WAS IT TABLE IS FULL
MOVEI S1,ERTBF$ ;TABLE IS FULL
$RETF
>;END TOPS20 CONDITIONAL
TOPS10 <
S%TBAD: PUSHJ P,.SAVET ;SAVE THE T REGS
MOVEM S1,TBADDR ;SAVE TABLE ADDRESS
MOVEM S2,ENTADR ;SAVE ENTRY ADDRESS
HLRZ T2,S2 ;GET A COPY OF STRING ADDRESS
PUSHJ P,CHKTBS ;GET POINTER TO START OF STRING
TXZ S1,TB%ABR ;DELETE ABBREVIATION FLAG FOR S%TBLK
MOVE S2,T2 ;SET UP FOR CALL TO S%TBLK
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
TXZ S2,TB%ABR ;DELETE ABBREVIATION FLAG (IFIW)
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
MOVE T2,TBADDR ;GET ADR OF TABLE (AND FLAGS)
TXNE T2,TB%ABR ;ABRV'S PRESENT?
PUSHJ P,TAADJ ;YES, ADJUST THE 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/ FLAG!ADDRESS OF TABLE HEADER
; S2/ ADDRESS OF ENTRY TO BE DELETED
;
; FLAG MAY BE TB%ABR - TABLE CONTAINS ABBREVIATIONS
;
;
; 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 ;TRAP THE ERROR JUMP
$RETT ;RETURN TRUE
TBDL.1: MOVEI S1,.FHSLF ;GET THE LAST ERROR
GETER ;GET THE LAST ERROR
HRRZ S2,S1 ;GET JUST THE CODE
MOVX S1,ERTBF$ ;TABLE IS FULL
CAIN S2,TDELX2 ;ENTRY ALREADY IN TABLE
MOVX S1,ERITE$ ;ENTRY ALREADY IN TABLE
$RETF
>;END TOPS20 CONDITIONAL
TOPS10 <
S%TBDL: TXNN S1,TB%ABR ;GOT ABBREVIATIONS IN TABLE?
JRST TBDEL1 ;NO, NOT MUCH TO DO
PUSHJ P,CHKABR ;YES, IS THIS ENTRY AN ABBREVIATION
PUSHJ P,REMABR ;NO, REMOVE ANY OF IT'S ABBREVIATIONS
TBDEL1: PUSHJ P,.SAVET ;SAVE THE T REGS
STKVAR <TBA0,ENT>
MOVEM S1,TBA0
MOVEM S2,ENT
TXZ S1,TB%ABR ;DON'T NEED FLAGS (EXT ADDR)
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
MOVE S1,ENT ;GET ENTRY WE'RE DELETING
MOVE S2,TBA0 ;AND START OF TABLE
TXNE S2,TB%ABR ;GOT ABBREVIATIONS?
PUSHJ P,TDADJ ;YES, ADJUST OLD POINTERS
$RETT ;RETURN TRUE
ENDSV.
;REMOVE ANY ABBREVIATIONS FOR THIS KEYWORD
; S1/ADDRESS OF TABLE HEADER WORD
; S2/ADDRESS OF ENTRY WE DELETED
;
;RETURNS:
; S2/ NEW ADDRESS OF ENTRY AFTER IT'S ABREVIATIONS WERE REMOVED
REMABR: $SAVE <S1,T1,T2>
STKVAR <TBA0,TBSLOT,TB3,TB4>
MOVEM S1,TBA0
MOVEM S2,TBSLOT
MOVEM T1,TB3
MOVEM T2,TB4
TXZ S1,TB%ABR
HLRZ T1,0(S1) ;GET NUMBER OF ENTRIES IN USE
ADD T1,S1 ;COMPUTE END OF USED TABLE SPACE
MOVEI T2,1(S1) ;GET ADDRESS AFTER HEADER WORD
REMADJ: CAMLE T2,T1 ;END OF TABLE?
JRST REMAD2 ;YES, DONE
MOVE S2,T2 ;GET ADDRESS OF CURRENT ENTRY
PUSHJ P,CHKABR ;DOUBLE CHECK ENTRY, IS IT AN ABBREV?
JRST REMAD1 ;NO, DO NOTHING WITH IT
HRRZ S2,0(T2) ;GET DATA PORTION OF THIS ENTRY
CAME S2,TBSLOT ;MATCH ADDR OF ENTRY WE'RE CHECKING?
JRST REMAD1 ;NO
MOVE S1,TBA0 ;TM%ABR+ADDRESS
MOVE S2,T2 ;THIS ENTRY - DELETE IT
PUSHJ P,TBDEL1 ;DELETE THIS ABBREVIATION
SOS TBSLOT ;THE SLOT HAS MOVED
;(ABRV MUST PRECEED FULLWORD IN TABLE)
SOJA T1,REMADJ ;AS HAS THE END OF THE TABLE. LOOP.
REMAD1: AOJA T2,REMADJ ;TRY NEXT
REMAD2: MOVE S2,TBSLOT ;RETURN NEW ADDRESS
ENDSV.
;CHECK CURRENT ENTRY TO SEE IF IT'S AN ABBREVIATION
; S2/KEYWORD TO CHECK
;RETURN:
; NON-SKIP ;NOT
; SKIP ;IS
CHKABR: $SAVE <S1>
HLRZ S1,0(S2) ;GET ADDRESS OF ENTRY
SKIPE S1,0(S1) ;CHECK FIRST WORD OF STRING
TXNE S1,177B6 ;FIRST CHAR 0 AND WORD NOT ALL 0
$RET ;NOT AN ABBREVIATION - NO FLAGS
TXNE S1,CM%ABR ;ABBREVIATION?
AOS (P) ;YES
$RET ;DONE
;TABLE ADJUSTMENT ROUTINES
;HANDLES INCREMENTING (ADD) OR DECREMENTING (DELETE) POINTERS TO KEYWORDS
;FOR ABBREVIATED KEYWORDS
;
;CALL WITH S1/ADDRESS OF SLOT BEING PROCESSED
; S2/START OF TABLE ADDRESS
;
; PUSHJ P,TDADJ ;TBDEL
; PUSHJ P,TAADJ ;TBADD
TAADJ: TDZA T1,T1 ;MARK AS ADDING
TDADJ: SETO T1, ;MARK AS DELETING
$SAVE <S1,S2,T1,T2>
STKVAR <TBSLOT,TBA0,TBFLAG>
MOVEM S1,TBSLOT
MOVEM S2,TBA0
MOVEM T1,TBFLAG
TXZ S2,TB%ABR ;CLEAR IFIW
HLRZ T2,0(S2) ;GET NUMBER OF ENTRIES IN USE
ADD T2,S2 ;COMPUTE END OF USED TABLE SPACE
TBADJ1: AOS S2 ;POINT AT NEXT ENTRY
CAMLE S2,T2 ;END OF TABLE?
$RET ;YES, DONE
HLRZ S1,0(S2) ;GET ADDRESS OF ENTRY
SKIPE T1,0(S1) ;CHECK FIRST WORD OF STRING
TXNE T1,177B6 ;FIRST CHAR 0 AND WORD NO ALL-0?
JRST TBADJ1 ;NOT AN ABBREVIATION, TRY NEXT ENTRY
TXNN T1,CM%ABR ;CHECK SOME MORE, ABBREVIATION FLAG?
JRST TBADJ1 ;NO
HRRZ S1,0(S2) ;YES, GET DATA (POINTER TO FULL WD)
CAMGE S1,TBSLOT ;DOES CHANGE MATTER?
JRST TBADJ1 ;NO
SKIPE TBFLAG ;ADDING OR DELETING?
SOSA 0(S2) ;DELETING, DECREMENT POINTER
AOS 0(S2) ;ADDING, INCREMENT POINTER
JRST TBADJ1 ;TRY NEXT ENTRY
ENDSV.
>;END TOPS10 CONDITIONAL
SUBTTL CNTDT,CNVDT DATE/TIME CONVERSION ROUTINES
;CNTDT CONVERTS UDT TO TWO WORD DATE/TIME
;ACCEPTS S1/ UDT
;RETURNS S1/ TIME IN MILLISECONDS
; S2/ DATE IN SYSTEM FORMAT
S%U2DT:
CNTDT:: PUSHJ P,.SAVET ;SAVE THE TEMPS WE USE
MOVE T1,S1 ;PUT UDT IN S1
PUSHJ P,.CNTDT ;CONVERT IT
DMOVE S1,T1 ;RETURN SECONDS SINCE MIDNIGHT
$RETT ;AND DATE IN SYSTEM FORMAT
;CNVDT CONVERTS TWO WORD DATE/TIME TO UDT
;ACCEPTS S1/ TIME IN MILLISECONDS
; S2/ DATE IN SYSTEM FORMAT
;RETURNS S1/ UDT
S%DT2U:
CNVDT:: PUSHJ P,.SAVET ;SAVE THE TEMPS WE USE
DMOVE T1,S1 ;GET SECONDS AND DATE
PUSHJ P,.CNVDT
MOVE S1,T1 ;RETURN THE UDT
$RETT
SUBTTL XDATIM DATE/TIME PARSING ROUTINES FOR TOPS10
;DEFINE SPECIAL ACs REQUIRED BY THESE ROUTINES
C==13 ;LAST CHARACTER AC
N==14 ;THE RESULT GOES HERE
E==15 ;NOT USED
.FP==16 ;FRAME POINTER
;XDATIM CONVERTS AN ASCII STRING TO INTERNAL FORMAT DATE (UDT)
;ACCEPTS S1/ POINTER TO ASCII STRING
; S2/ (CM%IDA!CM%ITM!CM%NCI+Address)
;RETURNS TRUE S1/ UPDATED POINTER
; S2/ UDT
; FALSE S1/ ERROR CODE
XDATIM: $SAVE <C,N,E,.FP> ;SAVE SPECIAL REGS
MOVEM P,.FP ;SAVE THE PDL
TLC S1,777777 ;MAKE -1 A REAL POINTER
TLCN S1,777777
HRLI S1,(POINT 7)
TXNE S2,CM%FUT ;Future time wanted?
JRST [PUSHJ P,.DATIF ;Yes, scan future time
JRST XDAT.1] ;Go join finish code
TXNE S2,CM%PST ;Past time wanted?
JRST [PUSHJ P,.DATIP ;Yes, scan past time
JRST XDAT.1] ;Go join finish code
PUSHJ P,.DATIM ;Do the work for the default case
XDAT.1: MOVE T1,S2 ;POSITION THE FLAGS
SKIPE FLFUTR ; If time relative
JRST XDAT.2 ; There is no need to convert
PUSH P,S1 ; Save the byte pointer
TOPS10 <
MOVX S1,%CNGMT ; Offset to GMT
GETTAB S1, ; Read it
SETZ S1, ; Not there
ADDM S1,N ; Convert to GMT
>;;End TOPS10 Conditional
TOPS20 <
MOVX S1,.SFTMZ ; Get the local time zone
TMON ; . . .
MOVX S1,<^D3600> ; Get the number of seconds/hour
IMUL S1,S2 ; Calculate number of seconds
$CALL .SC2UD ; Convert to UDT format
ADDM S1,N ; Convert local time to GMT
>;;End TOPS20 Conditional
POP P,S1 ; Restore the byte pointer
XDAT.2: MOVE S2,N ;GET THE ANSWER
SETOM TF ;We are true so far...
TXNE T1,CM%NCI ;WANT ONLY UDT?
$CALL DATNCI ;NO..ALSO RETURN 3 WORD BLOCK
$RET ;AND RETURN
;DEFINE AN ERROR PROCESSING ROUTINE TO GET US BACK TO CALLER
.ERMSG: MOVEM TF,.LGEPC ;SAVE THE PC
MOVEM S1,.LGERR ;SAVE THE ERROR
MOVE P,.FP ;RESTORE THE PDL
MOVX TF,FALSE
POPJ P,0
;DEFINE A LOCAL ROUTINE TO GET THE NEXT CHARACTER FROM STRING
.TIALT: ILDB C,S1 ;GET THE NEXT CHARACTER
POPJ P,
SUBTTL DATNCI ROUTINE TO RETURN 3 WORD TIME BLOCK
;DATNCI WILL BE CALLED IF CM%NCI WAS SET ON THE CALL
DATNCI: HRRZ T1,T1 ;GET THE DESTINATION ADDRESS
CAIG T1,17 ;CANT BE IN THE ACs
$RETE (NCI) ;ELSE THATs AN ERROR
MOVE T2,VAL9 ;GET CENTURY
IMULI T2,^D100 ;MAKE IT YEARS
MOVE T3,VAL8 ;GET DECADES
IMULI T3,^D10 ;MAKE YEARS ALSO
ADD T3,T2 ;COMBINE THEM
ADD T3,VAL7 ;GET THE YEAR FIELD
HRL T2,T3 ;PLACE IN LEFT HALF
HRR T2,VAL6 ;GET THE MONTH
MOVEM T2,0(T1) ;SAVE IN THE BLOCK
HRLZ T2,VAL5 ;DAY OF THE MONTH TO LEFT HALF
MOVEM T2,1(T1) ;SAVE THE DAY OF MONTH
HLRZ T2,S2 ;GET ONLY THE DATE
IDIVI T2,7 ;CONVERT TO DAY OF WEEK
ADDI T3,2 ;MAKE MONDAY = 0
CAIL T3,7 ;SATURDAY = 6
SUBI T3,7
HRRM T3,1(T1) ;SAVE DAY OF THE WEEK
MOVE T2,VAL4 ;GET HOURS
IMULI T2,^D60 ;CONVERT TO MINUTES
ADD T2,VAL3 ;ADD THE MINUTES
IMULI T2,^D60 ;CONVERT TO SECONDS
ADD T2,VAL2 ;ADD THE SECONDS
MOVEM T2,2(T1) ;SAVE THIRD WORD
$RETT
SUBTTL DATIM MACROS AND STORAGE DECLARATION
ECHO$W==0 ;MAKE NULL CONDITIONAL
;DEFINE THE ERROR PROCESSING MACROS
DEFINE M$FAIN(COD,TXT) <M$FAIL(<COD>,<TXT>)>
DEFINE M$FAIL(COD,TXT) <
ND ER'COD'$,ERIDT$ ;;DEFAULT TO INVALID DATE TIME
E$$'COD': JSP TF,[MOVEI S1,ER'COD'$
JRST .ERMSG]>
;DEFINE THE GLOBAL STORAGE REFERENCED BY THESE ROUTINES
GLOB LOGTIM ;TIME JOB WAS LOGGED IN
;DEFINE THE LOCAL STORAGE USED BY THESE ROUTINES
$DATA VAL1 ;DEFAULT VALUES FLAG
$DATA VAL2 ;SECONDS
$DATA VAL3 ;MINUTES
$DATA VAL4 ;HOURS
$DATA VAL5 ;DAY OF MONTH (0 - 30)
$DATA VAL6 ;MONTH OF YEAR (0 - 11)
$DATA VAL7 ;YEAR
$DATA VAL8 ;DECADE
$DATA VAL9 ;CENTURY
$DATA NOW
$DATA FLFUTD
$DATA FLFUTR
$DATA FLNULL
$DATA FLNEG
$DATA MASK
$DATA .LASWD
$DATA .NMUL
SUBTTL SUBROUTINES FOR COMMAND INPUT -- GET DATE/TIME
;.DATIF -- ROUTINE TO SCAN DATE AND TIME ARGUMENT IN FUTURE
;.DATIG -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIF/.DATIG
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIF: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DATIG: SETZM FLFUTR ;CLEAR FUTURE RELATIVE
SETZM FLFUTD ;SET DEFAULT
AOS FLFUTD ; TO FUTURE
CAIE C,"+" ;SEE IF FUTURE RELATIVE
JRST DATIF1 ;NO--JUST GET DATE-TIME
AOS FLFUTR ;YES--SET FUTURE REL FLAG
PUSHJ P,.TIAUC ;GET ANOTHER CHARACTER
DATIF1: CAIN C,"-" ;Confused user?
JRST DATIF2 ;Yes, skip the real stuff
PUSHJ P,DATIM ;GET DATE/TIME
CAMGE N,NOW ;SEE IF IN FUTURE
DATIF2: JRST E$$NFT ;NO--NOT FUTURE ERROR
POPJ P, ;RETURN
;.DATIP -- ROUTINE TO SCAN DATE AND TIME ARGUMENT IN THE PAST
;.DATIQ -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIP/.DATIQ
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIP: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DATIQ: SETZM FLFUTR ;CLEAR PAST RELATIVE
SETOM FLFUTD ;SET DEFAULT TO PAST
CAIE C,"-" ;SEE IF PAST RELATIVE
JRST DATIP1 ;NO--JUST GET DATE-TIME
SOS FLFUTR ;YES--SET PAST REL FLAG
PUSHJ P,.TIAUC ;GET ANOTHER CHARACTER
DATIP1: CAIN C,"+" ;Confused user?
JRST DATIP2 ;Yes, skip normal stuff
PUSHJ P,DATIM ;GET DATE/TIME
CAMLE N,NOW ;SEE IF IN PAST
DATIP2: JRST E$$NPS ;NO--NOT PAST ERROR
POPJ P, ;RETURN
;.DATIM -- ROUTINE TO SCAN DATE AND TIME ARGUMENT
;.DATIC -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIM/.DATIC
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIM: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DATIC: SETZM FLFUTR ;CLEAR RELATIVE FLAG
SETZM FLFUTD ;CLEAR DEFAULT FLAG
CAIE C,"+" ;SEE IF FUTURE RELATIVE
JRST DATIC1 ;NO--PROCEED
AOS FLFUTR ;YES--SET FLAG
JRST DATIC2 ;AND PROCEED
DATIC1: CAIE C,"-" ;SEE IF PAST RELATIVE
PJRST DATIM ;NO--JUST GET ABS DATE
SOS FLFUTR ;YES--SET FLAG
DATIC2: PUSHJ P,.TIAUC ;GET NEXT CHAR
;AND FALL INTO DATE/TIME GETTER
;DATIM -- ROUTINE TO INPUT DATE/TIME
;CALL: SET FLFUTR TO -1 IF PAST RELATIVE, 0 IF ABSOLUTE, +1 IF FUTURE RELATIVE
; SIMILARLY FOR FLFUTD TO INDICATE DEFAULT DIRECTION IF FLFUTR=0
; GET NEXT CHARACTER IN C
; PUSHJ P,DATIM
;RETURN WITH TRUE DATE/TIME IN N IN INTERNAL SPECIAL FORMAT
; SETS NOW TO CURRENT DATE/TIME
;USES T1-4, UPDATES C
;
;TYPE-IN FORMATS:
; (THE LEADING +- IS HANDLED BY CALLER)
;
; [ [ DAY IN WEEK ] ]
; [ [ NNND ] ]
; [ [ [ MM-DD [-Y ] ] : ] [HH[:MM[:SS]]] ]
; [ [ [ MMM-DD [-YY ] ] ] ]
; [ [ [ DD-MMM [-YYYY] ] ] ]
; [ MNEMONIC ]
;WHERE:
; D LETTER D
; DD DAY IN MONTH (1-31)
; HH HOURS (00-23)
; MM MONTH IN YEAR (1-12)
; OR MINUTES (00-59)
; MMM MNEMONIC MONTH OR ABBREV.
; SS SECONDS (0-59)
; Y LAST DIGIT OF THIS DECADE
; YY LAST TWO DIGITS OF THIS CENTURY
; YYYY YEAR
; DAY IN WEEK IS MNEMONIC OR ABBREVIATION
; MNEMONIC IS A SET OF PREDEFINED TIMES
;DESCRIBED ABOVE
;FALL HERE FROM .DATIC
DATIM: SKIPE T1,FLFUTR ;SEE IF FORCED DIRECTION
MOVEM T1,FLFUTD ; YES--THAT IMPLIES DEFAULT
SETOM VAL1 ;CLEAR RESULT WORDS
MOVE T1,[VAL1,,VAL2]
BLT T1,VAL9 ; ..
PUSH P,S1 ; Save S1
$CALL I%NOW ;GET CURRENT DATE/TIME
MOVE T1,S1 ; Transfer the time
POP P,S1 ; Restore the various flags
MOVEM T1,NOW ;SAVE FOR LATER TO BE CONSISTENT
CAIL C,"0" ;SEE IF DIGIT
CAILE C,"9" ; ..
JRST .+2 ;NO--MNEMONIC FOR SOMETHING
JRST DATIMD ;YES--GO GET DECIMAL
;HERE IF STARTING WITH ALPHA, MIGHT BE DAY, MONTH, OR MNEMONIC
PUSHJ P,.SIXSC ;GET SIXBIT WORD
JUMPE N,E$$DTM ;ILLEGAL SEPARATOR IF ABSENT [274]
MOVE T1,MNDPTR ;POINT TO FULL TABLE
PUSHJ P,.NAME ;LOOKUP IN TABLE
JRST E$$UDN ;ERROR IF NOT KNOWN
MOVEI N,(T1) ;GET
SUBI N,DAYS ; DAY INDEX
CAIL N,7 ;SEE IF DAY OF WEEK
JRST DATIMM ;NO--LOOK ON
;HERE WHEN DAY OF WEEK RECOGNIZED
SKIPN T1,FLFUTD ;GET DEFAULT DIRECTION
JRST E$$NPF ;ERROR IF NONE
MOVEM T1,FLFUTR ;SET AS FORCED DIRECTION
HLRZ T2,NOW ;GET DAYS
IDIVI T2,7 ;GET DAY OF WEEK
SUB N,T3 ;GET FUTURE DAYS FROM NOW
SKIPGE N ;IF NEGATIVE,
ADDI N,7 ; MAKE LATER THIS WEEK
HLLZ T1,NOW ;CLEAR CURRENT
SKIPL FLFUTD ;SEE IF FUTURE
TROA T1,-1 ;YES--SET MIDNIGHT MINUS EPSILON
SUBI N,7 ;NO--MAKE PAST
HRLZ N,N ;POSITION TO LEFT HALF
ADD N,T1 ;MODIFY CURRENT DATE/TIME
DATIMW: PUSH P,N ;SAVE DATE
PUSHJ P,DATIC ;GO CHECK TIME
HRRZ N,(P) ;NO--USE VALUE IN DATE
POP P,T1 ;RESTORE DATE
HLL N,T1 ; TO ANSWER
;**; [576] Delete one line @ DATIMW + 5L, add lines at same
;**; [576] location. LLN, 9-Sep-76
SKIPG FLFUTR ;[576] SKIP IF FUTURE
JRST DATIMK ;[576] ADJUST PAST RESULT
CAMGE N,NOW ;[576] IF NOT FUTURE, MUST HAVE
;[576] WANTED A WEEK FROM TODAY,
;[576] BUT EARLIER IN THE DAY.
ADD N,[7,,0] ;[576] MAKE TIME NEXT WEEK
JRST DATIMX ;[576] CHECK AND RETURN
DATIMK: MOVE T2,N ;[576] SIMILAR TEST FOR PAST
ADD T2,[7,,0] ;[576] ADD A WEEK TO PAST TIME
CAMG T2,NOW ;[576] WAS TIME OVER A WEEK AGO?
MOVE N,T2 ;[576] YES, USE NEW ONE
JRST DATIMX ;[576] CHECK ANSWER AND RETURN
;HERE IF MONTH OR MNEMONIC
DATIMM: MOVEI N,(T1) ;GET MONTH
SUBI N,MONTHS-1 ; AS 1-12
CAILE N,^D12 ;SEE IF MONTH
JRST DATIMN ;NO--MUST BE MNEMONIC
MOVEM N,VAL6 ;YES--STORE MONTH
CAIE C,"-" ;MUST BE DAY NEXT
JRST E$$MDD ;NO--ERROR
PUSHJ P,.DECNW ;YES--GET IT
JUMPLE N,E$$NND ;ERROR IF NEGATIVE
CAILE N,^D31 ;VERIFY IN RANGE
JRST E$$DFL ;ERROR IF TOO LARGE
MOVEM N,VAL5 ;SAVE AWAY
JRST DATIY0 ;AND GET YEAR IF PRESENT
;HERE IF MNEMONIC
DATIMN: HRRZ T2,T1 ;GET COPY [305]
CAIN T2,SPLGTM ;SEE IF "LOGIN" [505]
SKIPG N,LOGTIM ;AND WE KNOW IT [505]
SKIPA ;NO--PROCEED [505]
JRST DATIMX ;YES--GO GIVE ANSWER [505]
CAIN T2,SPNOON ;SEE IF "NOON" [520]
JRST [HLLZ N,NOW ;YES--GET TODAY [520]
HRRI N,1B18 ;SET TO NOON [520]
PUSHJ P,DATIM1 ;Go to clean up input
JRST DATIMW] ;GO FINISH UP [520]
CAIN T2,SPMIDN ;SEE IF "MIDNIGHT" [520]
JRST [HLLZ N,NOW ;GET TODAY [520]
PUSHJ P,DATIM1 ;Go to clean up input
JRST DATIMO] ;GO SET TO MIDNIGHT [520]
SUBI T2,SPCDAY ;SUBTRACT OFFSET TO SPECIAL DAYS [305]
CAILE T2,2 ;SEE IF ONE OF THREE [305]
JRST E.MDS ;NO--UNSUPPORTED [305]
HLRZ N,NOW ;YES--GET TODAY [305]
ADDI N,-1(T2) ;OFFSET IT [305]
HRLZS N ;POSITION FOR ANSWER [305]
DATIMO: SKIPL FLFUTD ;SEE IF FUTURE [305]
TRO N,-1 ;YES--SET TO MIDNIGHT MINUS EPSILON [305]
JRST DATIMW ;AND GO FINISH UP [305]
;HERE IF UNSUPPORTED MNEMONIC
E.MDS: MOVE N,(T1) ;GET NAME OF SWITCH
M$FAIL (MDS,Mnemonic date/time switch not implemented)
;The purpose of this next routine is to fix a problem created by XDATIM.
;In order to allow the user to type the date and time without the ":"
;normally required by SCAN (from where this code was taken) between the
;date and time, XDATIM places a colon in the string. This fails if
;a mnemonic such as NOON and MIDNIGHT is typed. This routine rips
;that out.
DATIM1: CAIN C," " ;Is there a space next
PUSHJ P,.TIAUC ;Yes, get the next character from the buffer
POPJ P, ;And return
;HERE IF STARTING WITH DECIMAL NUMBER
DATIMD: PUSHJ P,.DECNC ;YES--GO GET FULL NUMBER
JUMPL N,E$$NND ;ILLEGAL IF NEGATIVE
CAIE C,"D" ;SEE IF DAYS
JRST DATIN ;NO--MUST BE -
MOVE T1,FLFUTD ;YES--RELATIVE SO GET FORCING FUNCTION
MOVEM T1,FLFUTR ; AND FORCE IT
JUMPE T1,E$$NPF ;ERROR IF DIRECTION UNCLEAR
CAIL N,1B18 ;VERIFY NOT HUGE
JRST E$$DFL ;ERROR--TOO LARGE
MOVEM N,VAL5 ;SAVE RELATIVE DATE
PUSHJ P,.TIAUC ;GET NEXT CHARACTER (SKIP D)
PUSHJ P,DATIC ;GO CHECK FOR TIME
MOVEI N,0 ;0 IF NONE
HRL N,VAL5 ;INCLUDE DAYS IN LH
JRST DATITR ;GO DO RELATIVE RETURN
;HERE WHEN DIGITS SEEN WITHOUT A FOLLOWING D
DATIN: CAIE C,"-" ;SEE IF DAY/MONTH COMBO
JRST DATIT ;NO--MUST BE INTO TIME
CAILE N,^D31 ;MUST BE LESS THAN 31
JRST E$$DFL ;NO--ERROR
JUMPE N,E$$DFZ ;VERIFY NOT ZERO
MOVEM N,VAL5 ;SAVE VALUE
PUSHJ P,.TIAUC ;SKIP OVER MINUS
CAIL C,"0" ;SEE IF DIGIT NEXT
CAILE C,"9" ; ..
JRST DATMMM ;NO-- MUST BE MNEMONIC MONTH
PUSHJ P,.DECNC ;YES-- MUST BE MM-DD FORMAT
JUMPLE N,E$$NND ;BAD IF LE 0
CAILE N,^D31 ;VERIFY LE 31
JRST E$$DFL ;BAD
EXCH N,VAL5 ;SWITCH VALUES
CAILE N,^D12 ;VERIFY MONTH OK
JRST E$$DFL ;BAD
JRST DATMM1 ;GO STORE MONTH
;HERE WHEN TIME SEEN BY ITSELF
DATIT: CAIN C," " ;Last character a space?
PUSHJ P,.TIALT ;Space over it
PUSHJ P,DATIG ;GET REST OF TIME
M$FAIL(IDT,The comment said this can never happen)
SKIPN FLFUTR ;SEE IF RELATIVE
JRST DATIRN ;NO--GO HANDLE AS ABS.
;HERE WITH DISTANCE IN N
DATITR: SKIPGE FLFUTR ;IF PAST,
MOVN N,N ; COMPLEMENT DISTANCE
ADD N,NOW ;ADD TO CURRENT DATE/TIME
JRST DATIMX ;CHECK ANSWER AND RETURN
;HERE WHEN DD- SEEN AND MNEMONIC MONTH COMING
DATMMM: PUSHJ P,.SIXSC ;GET MNEMONIC
MOVE T1,MONPTR ;GET POINTER TO MONTH TABLE
PUSHJ P,.NAME ;LOOKUP IN TABLE
JRST E$$UDM ;NO GOOD
MOVEI N,(T1) ;GET MONTH
SUBI N,MONTHS-1 ; AS 1-12
;HERE WITH MONTH INDEX (1-12) IN T1
DATMM1: MOVEM N,VAL6 ;SAVE FOR LATER
DATIY0: CAIE C,"-" ;SEE IF YEAR NEXT
JRST DATIRA ;NO--GO HANDLE TIME
;HERE WHEN YEAR NEXT AS ONE, TWO, OR FOUR DIGITS
SETZB N,T1 ;CLEAR DIGIT AND RESULT COUNTERS
DATIY: PUSHJ P,.TIAUC ;GET NEXT DIGIT
CAIL C,"0" ;SEE IF NUMERIC
CAILE C,"9" ; ..
JRST DATIY1 ;NO--MUST BE DONE
IMULI N,^D10 ;ADVANCE RESULT
ADDI N,-"0"(C) ;INCLUDE THIS DIGIT
AOJA T1,DATIY ;LOOP FOR MORE, COUNTING DIGIT
DATIY1: JUMPE T1,E$$ILR ;ERROR IF NO DIGITS
CAIE T1,3 ;ERROR IF 3 DIGITS
CAILE T1,4 ;OK IF 1,2, OR 4
JRST E$$ILR ;ERROR IF GT 4 DIGITS
MOVE T2,N ;GET RESULT
IDIVI T2,^D100 ;SEP. CENTURY
IDIVI T3,^D10 ;SEP. DECADE
CAIG T1,2 ;IF ONE OR TWO DIGITS,
SETOM T2 ; FLAG NO CENTURY KNOWN
CAIN T1,1 ;IF ONE DIGIT,
SETOM T3 ; FLAG NO DECADE KNOWN
MOVEM T4,VAL7 ;SAVE UNITS
MOVEM T3,VAL8 ;SAVE DECADE
MOVEM T2,VAL9 ;SAVE CENTURY
;HERE WITH VAL5-9 CONTAINING DAY, MONTH, YEAR, DECADE, CENTURY
DATIRA: SOS VAL5 ;MAKE DAYS 0-30
SOS VAL6 ;MAKE MONTHS 0-11
PUSHJ P,DATIC ;GET TIME IF PRESENT
SKIPG FLFUTD ;IGNORE ABSENCE
JRST DATIRN ; UNLESS FUTURE
;HERE IF FUTURE WITHOUT TIME
MOVEI T1,^D59 ;SET TO
MOVEM T1,VAL2 ; 23:59:59
MOVEM T1,VAL3 ; ..
MOVEI T1,^D23 ; ..
MOVEM T1,VAL4 ; ..
;HERE WITH VAL2-9 CONTAINING PARSE OR -1 IF TO BE FILLED IN
; STRATEGY IS TO FILL-IN HOLES LESS SIGNIFICANT THAN
; MOST SIGN. FIELD WITH 0; AND TO FILL IN MORE SIGNIFICANT
; HOLES WITH CURRENT VALUE. THEN IF WRONG DIRECTION FROM
; NOW, ADD/SUB ONE TO FIELD JUST ABOVE MOST SIGNIFICANT DIFFERENT
; (FIELD CARRY NOT NEEDED SINCE IT WILL HAPPEN IMPLICITLY).
DATIRN: PUSHJ P,.TICAN ;MAKE SURE NEXT CHAR IS SEPARATOR [542]
SKIPA ;YES--OK [542]
JRST E$$ILC ;NO--FLAG ERROR BEFORE DEFAULTING [542]
MOVE T1,NOW ;GET CURRENT DATE/TIME
PUSHJ P,.CNTDT ;CONVERT TO EASY FORMAT
MOVE T3,T1 ;SAVE MSTIME
IDIVI T3,^D1000 ; AS SECONDS
ADD T2,[^D1964*^D12*^D31] ;MAKE REAL
MOVEI T4,8 ;TRY 8 FIELDS [250]
DATIRB: MOVE T1,T2 ;POSITION REMAINDER
IDIV T1,[1
^D60
^D60*^D60
1
^D31
^D31*^D12
^D31*^D12*^D10
^D31*^D12*^D10*^D10]-1(T4) ;SPLIT THIS FIELD FROM REST [250]
SKIPL VAL1(T4) ;SEE IF DEFAULT [250]
JRST [TLNN T3,-1 ;NO--FLAG TO ZERO DEFAULTS [250]
HRL T3,T4 ; SAVING INDEX OF LAST DEFAULT [250]
JRST DATRIC] ;AND CONTINUE LOOP
SETZM VAL1(T4) ;DEFAULT TO ZERO [250]
TLNN T3,-1 ;SEE IF NEED CURRENT [250]
MOVEM T1,VAL1(T4) ;YES--SET THAT INSTEAD [250]
DATRIC: CAME T1,VAL1(T4) ;SEE IF SAME AS CURRENT [250]
JRST DATIRD ;NO--REMEMBER FOR LATER
CAIN T4,4 ;SEE IF TIME FOR TIME [250]
HRRZ T2,T3 ;YES--GET IT
SOJG T4,DATIRB ;LOOP UNTIL ALL DONE [250]
;HERE WHEN FILLED IN CURRENT FOR SIGNIFICANT DEFAULTS
DATIRD: SKIPGE VAL1(T4) ;SEE IF DEFAULT [250]
SETZM VAL1(T4) ;CLEAR DEFAULT [250]
SOJG T4,DATIRD ;LOOP UNTIL DONE [250]
HLRZ N,T3 ;RECOVER LAST SIGN. DEFAULT-1 [250]
JUMPE N,DATIRR ;DONE IF NONE [250]
PUSHJ P,DATIRM ;MAKE CURRENT DATE, TIME
MOVE T4,FLFUTD ;GET DEFAULT DIRECTION
XCT [CAMGE T1,NOW
JFCL
CAMLE T1,NOW]+1(T4) ;SEE IF OK
JRST DATIRR ;YES--GO RETURN
SKIPG FLFUTD ;NO--SEE WHICH DIRECTION
SOSA VAL2(N) ;PAST
AOS VAL2(N) ;FUTURE
DATIRR: PUSHJ P,DATIRM ;REMAKE ANSWER
MOVE N,T1 ;MOVE TO ANSWER
;HERE WITH FINAL RESULT, CHECK FOR OK
RADIX 10
DATIMX: MOVEI T1,.TDTTM ;SET DATE-TIME [314]
MOVEM T1,.LASWD ; OUTPUTER [314]
CAML N,[<1964-1859>*365+<1964-1859>/4+<31-18>+31,,0] ;[261]
PJRST STRNML ;STORE IN .NMUL AND RETURN [314]
RADIX 8
M$FAIL (DOR,Date/time out of range)
;SUBROUTINE TO MAKE DATE/TIME
DATIRM: MOVE T1,VAL4 ;GET HOURS
IMULI T1,^D60 ;MAKE INTO MINS
ADD T1,VAL3 ;ADD MINS
IMULI T1,^D60 ;MAKE INTO SECS
ADD T1,VAL2 ;ADD SECS
IMULI T1,^D1000 ;MAKE INTO MILLISECS
MOVE T2,VAL9 ;GET CENTURIES
IMULI T2,^D10 ;MAKE INTO DECADES
ADD T2,VAL8 ;ADD DECADES
IMULI T2,^D10 ;MAKE INTO YEARS
ADD T2,VAL7 ;ADD YEARS
IMULI T2,^D12 ;MAKE INTO MONTHS
ADD T2,VAL6 ;ADD MONTHS
IMULI T2,^D31 ;MAKE INTO DAYS
ADD T2,VAL5 ;ADD DAYS
SUB T2,[^D1964*^D12*^D31] ;REDUCE TO SYSTEM RANGE
PJRST .CNVDT ;CONVERT TO INTERNAL FORM AND RETURN
;SUBROUTINE TO GET TIME IF SPECIFIED
;RETURNS CPOPJ IF NO TIME, SKIP RETURN IF TIME
; WITH TIME IN RH(N) AS FRACTION OF DAY
;USES T1-4, N
DATIC: CAIE C," " ;Have a tab?
CAIN C," " ;or a space?
JRST DATI1 ;Yes, continue on
CAIE C,":" ;Colon? (living in the past)
POPJ P, ;NO--MISSING TIME
DATI1: PUSHJ P,.DECNW ;GET DECIMAL NUMBER FOR TIME
;HERE WITH FIRST TIME FIELD IN N
DATIG: JUMPL N,E$$NND ;ERROR IF NEGATIVE [326]
CAIL N,^D24 ; AND GE 24,
JRST E$$DFL ;GIVE ERROR--TOO LARGE
MOVEM N,VAL4 ;SAVE HOURS
CAIE C,":" ;SEE IF MINUTES COMING
JRST DATID ;NO--DONE
PUSHJ P,.DECNW ;YES--GET IT
CAIL N,^D60 ;SEE IF IN RANGE
JRST E$$DFL ;NO--GIVE ERROR
JUMPL N,E$$NND ;ERROR IF NEG
MOVEM N,VAL3 ;SAVE MINUTES
CAIE C,":" ;SEE IF SEC. COMING
JRST DATID ;NO--DONE
PUSHJ P,.DECNW ;GET SECONDS
CAIL N,^D60 ;CHECK RANGE
JRST E$$DFL ;NO--GIVE ERROR
JUMPL N,E$$NND ;ERROR IF NEG
MOVEM N,VAL2 ;SAVE SECONDS
;HERE WITH TIME IN VAL2-4
DATID: SKIPGE T1,VAL4 ;GET HOURS
MOVEI T1,0 ; UNLESS ABSENT
IMULI T1,^D60 ;CONV TO MINS
SKIPL VAL3 ;IF MINS PRESENT,
ADD T1,VAL3 ; ADD MINUTES
IMULI T1,^D60 ;CONV TO SECS
SKIPL VAL2 ;IF SECS PRESENT,
ADD T1,VAL2 ; ADD SECONDS
MOVEI T2,0 ;CLEAR OTHER HALF
ASHC T1,-^D17 ;MULT BY 2**18
DIVI T1,^D24*^D3600 ;DIVIDE BY SECONDS/DAY
MOVE N,T1 ;RESULT IS FRACTION OF DAY IN RH
JRST .POPJ1 ;RETURN
;DATE/TIME ERRORS
M$FAIL (ILC,Illegal character in date/time)
M$FAIL (NFT,Date/time must be in the future)
M$FAIL (NPS,Date/time must be in the past)
M$FAIL (NND,Negative number in date/time)
M$FAIL (NPF,Not known whether past or future in date/time)
M$FAIL (DFL,Field too large in date/time)
M$FAIL (DFZ,Field zero in date/time)
M$FAIL (UDM,Unrecognized month in date/time)
M$FAIL (ILR,Illegal year format in date/time)
M$FAIL (UDN,Unrecognized name in date/time)
M$FAIL (MDD,Missing day in date/time)
M$FAIL (DTM,Value missing in date/time)
;MNEMONIC WORDS IN DATE/TIME SCAN
DEFINE XX($1),<
EXP <SIXBIT /$1/>>
DAYS: XX WEDNESDAY
XX THURSDAY
XX FRIDAY
XX SATURDAY
XX SUNDAY
XX MONDAY
XX TUESDAY
MONTHS: XX JANUARY
XX FEBRUARY
XX MARCH
XX APRIL
XX MAY
XX JUNE
XX JULY
XX AUGUST
XX SEPTEMBER
XX OCTOBER
XX NOVEMBER
XX DECEMBER
SPCDAY: XX YESTERDAY
XX TODAY
XX TOMORROW
SPLGTM: XX LOGIN
SPNOON: XX NOON
SPMIDN: XX MIDNIGHT
SPDATM: XX LUNCH
XX DINNER
LSPDTM==.-DAYS
;POINTERS
MONPTR: IOWD ^D12,MONTHS
MNDPTR: IOWD LSPDTM,DAYS
;.NAME -- LOOKUP NAME IN TABLE ALLOWING FOR UNIQUE ABBREVIATIONS
;ALWAYS CHECK FOR EXACT MATCH FIRST.
;CALL: MOVE N,NAME
; MOVE T1,[IOWD LENGTH,START OF TABLE]
; PUSHJ P,.NAME
; ERROR RETURN IF UNKNOWN OR DUPLICATE
; AND WITH T1.LT.0 IF NOT MATCH, .GT.0 IF SEVERAL MATCHES
; SKIP RETURN IF FOUND WITH T1 POINTING TO ENTRY
; AND WITH LH(T1)=0 IF ABBREVIATION, OR T1.LT.0 IF EXACT MATCH
;USES T2, T3, T4
.NAME: MOVE T2,N ;SET NAME FOR ROUTINE
PJRST .LKNAM ;GO HANDLE IT
;.DECNW -- INPUT A DECIMAL WORD FROM COMMAND STRING
;.DECNC -- DITTO (CHARACTER ALREADY IN C)
;IF IT STARTS WITH #, THEN OCTAL TYPEIN
;TERMINATES AT FIRST NON-DECIMAL CHARACTER
;THROWS AWAY ANY CHARACTERS BEFORE THE LAST 10 OR SO
;CALL: PUSHJ P,.DECNC/.DECNW
; RETURN WITH WORD IN N
;USES T1 UPDATES C (SEPARATOR)
.DECNW: PUSHJ P,.TIAUC ;PRIME THE PUMP
.DECNC: PUSHJ P,.CKNEG ;CHECK IF NEGATIVE
DECIN1: CAIL C,"0" ;SEE IF DECIMAL
CAILE C,"9" ; ..
PJRST DECMUL ;NO--AT END, SO HANDLE SUFFIX
IMULI N,^D10 ;YES--MULTIPLY NUMBER
ADDI N,-"0"(C) ;INCORPORATE DIGIT
PUSHJ P,.TIAUC ;GET NEXT CHARACTER
JRST DECIN1 ;LOOP BACK FOR MORE
;DECMUL -- HANDLE DECIMAL SUFFIX MULTIPLIER
; K,M,G FOR 10**3,6,9
;CALL: MOVE N,NUMBER
; PUSHJ P,DECMUL
; RETURN WITH NUMBER MULTIPLIED BY SUFFIX
;USES T1 (MULTIPLIER--RETURNED) UPDATES C (SEPARATOR)
DECMUL: CAIN C,"." ;SEE IF FORCING DECIMAL [273]
PUSHJ P,.TIAUC ;YES--GET NEXT CHARACTER [273]
MOVEI T1,.TDECW ;SET DECIMAL FORMAT [314]
MOVEM T1,.LASWD ; FOR ERROR PRINTING [314]
MOVEI T1,1 ;INITIALIZE SUFFIX MULTIPLIER
CAIN C,"K" ;K = 1 000
MOVEI T1,^D1000
CAIN C,"M" ;M = 1 000 000
MOVE T1,[^D1000000]
CAIN C,"G" ;G =1 000 000 000
MOVE T1,[^D1000000000]
IMUL N,T1 ;APPLY TO NUMBER
CAILE T1,1 ;SEE IF SUFFIX
PUSHJ P,.TIAUC ;YES--GET ONE MORE CHARACTER
PJRST .SENEG ;SEE IF NEGATIVE AND RETURN
;.SENEG -- SEE IF NEGATIVE FOUND BY .CKNEG AND APPLY IT
;CALL: MOVE N,VALUE SO FAR
; PUSHJ P,.SENEG
;RETURNS WITH N COMPLEMENTED IF NUMBER PRECEEDED BY -
.SENEG: SKIPE FLNEG ;SEE IF NEGATIVE
MOVNS N ;YES--COMPLEMENT RESULT
IFN ECHO$W,<
PUSHJ P,NAMER
>
;HERE TO EXIT FROM MOST ONE WORD INPUT ROUTINES TO
;STORE A COPY OF THE RESULT IN .NMUL FOR LONG TERM STORAGE
;PURPOSES SUCH AS SOME ERROR MESSAGES
STRNML: MOVEM N,.NMUL ;STORE VALUE FOR ERROR PRINTER [314]
POPJ P, ;RETURN
;.CKNEG -- CHECK IF NEGATIVE NUMBER COMING
;ALSO CLEARS N
;CALL: MOVEI C,NEXT CHAR
; PUSHJ P,.CKNEG
;USES NO ACS
.CKNEG: SETZB N,FLNEG ;CLEAR N AND NEGATIVE FLAG
CAIE C,"-" ;CHECK IF NEGATIVE NUMBER
POPJ P, ;NO--RETURN
SETOM FLNEG ;YES--SET FLAG
PJRST .TIAUC ;GET NEXT CHAR AND RETURN
;.SIXSW -- INPUT A SIXBIT WORD FROM COMMAND STRING
;.SIXSC -- DITTO (CHARACTER ALREADY IN C)
;TERMINATES AT FIRST NON-ALPHANUMERIC CHARACTER
;THROWS AWAY ANY CHARACTERS BEYOND THE FIRST SIX
;CALL: PUSHJ P,.SIXSC/.SIXSW
; RETURN WITH WORD IN N
;USES T1 UPDATES C (SEPARATOR)
.SIXSW: PUSHJ P,.TIAUC ;PRIME THE PUMP
.SIXSC: MOVEI N,0 ;CLEAR NAME
MOVEI T1,.TSIXN ;SET SIXBIT FORMAT [314]
MOVEM T1,.LASWD ; FOR ERROR PRINTING [314]
MOVE T1,[POINT 6,N] ;INITIALIZE BYTE POINTER FOR WORD
SIXS1: PUSHJ P,.TICAN ;SEE IF CHARACTER IS ALPHA-NUMERIC
JRST STRNML ;STORE IN .NMUL AND RETURN [314]
SUBI C," "-' ' ;CONVERT TO SIXBIT
TLNE T1,(77B5) ;DON'T OVERFLOW
IDPB C,T1 ;STORE CHARACTER
PUSHJ P,.TIAUC ;GO GET ANOTHER CHARACTER
JRST SIXS1 ;LOOP BACK TO PROCESS IT
SUBTTL SUBROUTINES FOR COMMAND INPUT -- GET NEXT CHARACTER
;.TICAN -- CHECK CHARACTER FOR ALPHA-NUMERIC
;ALPHA-NUMERIC IS A-Z OR 0-9
;CALL: MOVEI C,ASCII CHARACTER
; PUSHJ P,.TICAN
; RETURN IF NOT ALPHA-NUMERIC
; SKIP RETURN IF ALPHA-NUMERIC
;PRESERVES ALL ACS
.TICAN: CAIL C,"A"+40 ;SEE IF
CAILE C,"Z"+40 ; LOWER CASE ALPHA
SKIPA ;NO--CONTINUE CHECKS
JRST .POPJ1 ;YES--GIVE ALPHA RETURN
CAIL C,"0" ;SEE IF BELOW NUMERICS
CAILE C,"Z" ;OR IF ABOVE ALPHABETICS
POPJ P, ;YES--RETURN
CAILE C,"9" ;SEE IF NUMERIC
CAIL C,"A" ;OR IF ALPHABETIC
AOS (P) ;YES--SKIP RETURN
POPJ P, ;RETURN
;.TIAUC -- INPUT ONE COMMAND CHARACTER HANDLING LOWER CASE CONVERSION
;CALL: PUSHJ P,.TIAUC
; RESULT IN C
;USES NO ACS
.TIAUC: PUSHJ P,.TIALT ;GO GET NEXT CHAR
;.TIMUC -- CONVERT LOWER CASE CHARACTER TO UPPER CASE
;CALL: MOVEI C,CHARACTER
; PUSHJ P,.TIMUC
; RETURN WITH UPDATED C
;USES NO ACS
.TIMUC: CAIGE C,"A"+40 ;SEE IF LOWER CASE
POPJ P, ;NO--RETURN
CAIG C,"Z"+40
SUBI C,40 ;YES--CONVERT
POPJ P, ;RETURN
;DEFINE SOME DUMMY ROUTINES NORMALLY USED FOR ERROR PROCESSING
.TSIXN:
.TDTTM:
.TDECW:
.TOCTW:
SUBTTL .CNTDT -- GENERALIZED DATE/TIME SUBROUTINE
;.CNTDT -- SUBROUTINE TO CONVERT FROM INTERNAL DATE/TIME FORMAT
;CALL: MOVE T1,DATE/TIME
; PUSHJ P,.CNTDT
; RETURN WITH T1=TIME IN MS., T2=DATE IN SYSTEM FORMAT (.LT. 0 IF ARG .LT. 0)
;BASED ON IDEAS BY JOHN BARNABY, DAVID ROSENBERG, PETER CONKLIN
;USES T1-4
.CNTDT: PUSH P,T1 ;SAVE TIME FOR LATER
JUMPL T1,CNTDT6 ;DEFEND AGAINST JUNK INPUT
HLRZ T1,T1 ;GET DATE PORTION (DAYS SINCE 1858)
RADIX 10 ;**** NOTE WELL ****
ADDI T1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17
;T1=DAYS SINCE JAN 1, 1501 [311]
IDIVI T1,400*365+400/4-400/100+400/400
;SPLIT INTO QUADRACENTURY [311]
LSH T2,2 ;CONVERT TO NUMBER OF QUARTER DAYS [311]
IDIVI T2,<100*365+100/4-100/100>*4+400/400
;SPLIT INTO CENTURY [311]
IORI T3,3 ;DISCARD FRACTIONS OF DAY [311]
IDIVI T3,4*365+1 ;SEPARATE INTO YEARS [311]
LSH T4,-2 ;T4=NO DAYS THIS YEAR [311]
LSH T1,2 ;T1=4*NO QUADRACENTURIES [311]
ADD T1,T2 ;T1=NO CENTURIES [311]
IMULI T1,100 ;T1=100*NO CENTURIES [311]
ADDI T1,1501(T3) ;T1 HAS YEAR, T4 HAS DAY IN YEAR [311]
MOVE T2,T1 ;COPY YEAR TO SEE IF LEAP YEAR
TRNE T2,3 ;IS THE YEAR A MULT OF 4? [311]
JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR [311]
IDIVI T2,100 ;SEE IF YEAR IS MULT OF 100 [311]
SKIPN T3 ;IF NOT, THEN LEAP [311]
TRNN T2,3 ;IS YEAR MULT OF 400? [311]
TDZA T3,T3 ;YES--LEAP YEAR AFTER ALL [311]
CNTDT0: MOVEI T3,1 ;SET LEAP YEAR FLAG [311]
;T3 IS 0 IF LEAP YEAR
;UNDER RADIX 10 **** NOTE WELL ****
CNTDT1: SUBI T1,1964 ;SET TO SYSTEM ORIGIN
IMULI T1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS
JUMPN T3,CNTDT2 ;IF NOT LEAP YEAR, PROCEED
CAIGE T4,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29
JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER
SOS T4 ;YES--BACK OFF ONE DAY
CNTDT2: MOVSI T2,-11 ;LOOP FOR 11 MONTHS
CNTDT3: CAMGE T4,MONTAB+1(T2) ;SEE IF BEYOND THIS MONTH
JRST CNTDT4 ;YES--GO FINISH UP
ADDI T1,31 ;NO--COUNT SYSTEM MONTH
AOBJN T2,CNTDT3 ;LOOP THROUGH NOVEMBER
CNTDT4: SUB T4,MONTAB(T2) ;GET DAYS IN THIS MONTH
CNTDT5: ADD T1,T4 ;INCLUDE IN FINAL RESULT
CNTDT6: EXCH T1,(P) ;SAVE ANSWER, GET TIME
TLZ T1,-1 ;CLEAR DATE
MUL T1,[24*60*60*1000] ;CONVERT TO MILLI-SEC.
ASHC T1,17 ;POSITION RESULT
POP P,T2 ;RECOVER DATE
POPJ P, ;RETURN
;UNDER RADIX 10 **** NOTE WELL ****
;.CNVDT -- CONVERT ARBITRARY DATE TO SPECIAL FORMAT
;CALL: MOVE T1,TIME IN MILLISEC.
; MOVE T2,DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64
; PUSHJ P,.CNVDT
;RETURNS WITH RESULT IN T1 (.GT.0; OR -1 IF BEYOND SEPT. 27,2217)
; NOTE THAT IN SPECIAL FORMAT, THE LEFT HALF DIVIDED
; BY 7 GIVES THE DAY OF THE WEEK (0=WED.)
;USES T2, T3, T4
.CNVDT: PUSHJ P,.SAVE1 ;PRESERVE P1
PUSH P,T1 ;SAVE TIME FOR LATER
IDIVI T2,12*31 ;T2=YEARS-1964
CAILE T2,2217-1964 ;SEE IF BEYOND 2217
JRST GETNW2 ;YES--RETURN -1
IDIVI T3,31 ;T3=MONTHS-JAN, T4=DAYS-1
ADD T4,MONTAB(T3) ;T4=DAYS-JAN 1
MOVEI P1,0 ;LEAP YEAR ADDITIVE IF JAN, FEB
CAIL T3,2 ;CHECK MONTH
MOVEI P1,1 ;ADDITIVE IF MAR-DEC
MOVE T1,T2 ;SAVE YEARS FOR REUSE
ADDI T2,3 ;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED
IDIVI T2,4 ;HANDLE REGULAR LEAP YEARS
CAIE T3,3 ;SEE IF THIS IS LEAP YEAR
MOVEI P1,0 ;NO--WIPE OUT ADDITIVE
ADDI T4,<1964-1859>*365+<1964-1859>/4+<31-18>+31(T2)
;T4=DAYS BEFORE JAN 1,1964 +SINCE JAN 1
; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64
MOVE T2,T1 ;RESTORE YEARS SINCE 1964
IMULI T2,365 ;DAYS SINCE 1964
ADD T4,T2 ;T4=DAYS EXCEPT FOR 100 YR. FUDGE
HRREI T2,64-100-1(T1) ;T2=YEARS SINCE 2001
JUMPLE T2,GETNW1 ;ALL DONE IF NOT YET 2001
IDIVI T2,100 ;GET CENTURIES SINCE 2001
SUB T4,T2 ;ALLOW FOR LOST LEAP YEARS
CAIE T3,99 ;SEE IF THIS IS A LOST L.Y.
GETNW1: ADD T4,P1 ;ALLOW FOR LEAP YEAR THIS YEAR
CAILE T4,^O377777 ;SEE IF TOO BIG
GETNW2: SETOM T4 ;YES--SET -1
POP P,T1 ;GET MILLISEC TIME
MOVEI T2,0 ;CLEAR OTHER HALF
ASHC T1,-17 ;POSITION
DIV T1,[24*60*60*1000] ;CONVERT TO 1/2**18 DAYS
;**;[574] Insert @ GETNW2+6L JNG 4-May-76
CAMLE T2,[^D24*^D60*^D60*^D1000/2] ;[574] OVER 1/2 TO NEXT?
ADDI T1,1 ;[574] YES, SHOULD ACTUALLY ROUND UP
HRL T1,T4 ;INCLUDE DATE
GETNWX: POPJ P, ;RETURN
;UNDER RADIX 10 **** NOTE WELL ****
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
;BACK TO OUR FAVORITE RADIX
RADIX 8
SUBTTL .LKNAM -- ROUTINES TO GET AND PUT IN A COUNTED LIST
;.LKNAM -- LOOKUP NAME IN TABLE ALLOWING FOR UNIQUE ABBREVIATIONS
;ALWAYS CHECK FOR EXACT MATCH FIRST.
;CALL: MOVE T1,[IOWD LENGTH,START OF TABLE]
; MOVE T2,NAME
; PUSHJ P,.LKNAM
; ERROR RETURN IF UNKNOWN OR DUPLICATE
; AND WITH T1.LT.0 IF NOT MATCH, .GT.0 IF SEVERAL MATCHES
; SKIP RETURN IF FOUND WITH T1 POINTING TO ENTRY
; AND WITH LH(T1)=0 IF ABBREVIATION, OR T1.LT.0 IF EXACT MATCH
;USES T3, T4
;PRESERVES T2
.LKNAM: JUMPGE T1,[SETOM T1 ;FLAG UNKNOWN
POPJ P,] ;ERROR RETURN
PUSHJ P,.SAVE2 ;SAVE P1, P2
PUSH P,T1 ;SAVE ARGUMENT
MOVE T3,T2 ;SET ARG TO MASK MAKER
PUSHJ P,.MKMSK ;MAKE MASK
MOVE T2,T3 ;RESTORE NAME
MOVE P1,T1 ;SAVE FOR MATCHING
POP P,T1 ;RECOVER ARGUMENT
SETOM P2 ;SET ABBREVIATION MATCH COUNTER
AOS T1 ;POSITION POINTER
NAME1: MOVE T3,(T1) ;FETCH TABLE ENTRY
TLNE T3,(3B1) ;NOTE THAT * IS 12 IN SIXBIT
JRST NAME2 ;NOT FORCED MATCH
LSH T3,6 ;SEE IF IT MATCHES
XOR T3,T2 ;EVEN IN AN ABBR.
TRZ T3,77 ;CLEAR LAST CHAR SINCE WE DON'T KNOW IT
AND T3,P1 ; ..
JUMPE T3,.POPJ1 ;YES--GIVE MATCH RETURN
JRST NAME3 ;NO--LOOP
NAME2: XOR T3,T2 ;SEE IF EXACT MATCH
JUMPE T3,.POPJ1 ;YES--A WINNER
AND T3,P1 ;SEE IF A SUITABLE ABBREVIATION
JUMPN T3,NAME3 ;NO--LOOP BACK FOR MORE
MOVE T4,T1 ;SALT AWAY THE LOCATION JUST IN CASE
AOS P2 ;YES--COUNT
NAME3: AOBJN T1,NAME1 ;ADVANCE--LOOP IF NOT DONE YET
HRRZ T1,T4 ;RESTORE LOCATION OF A WINNER
JUMPE P2,.POPJ1 ;DONE--JUMP IF ONE ABBREVIATION
MOVE T1,P2 ;GIVE FLAG TO CALLER
POPJ P, ;NONE OR TWO, SO FAIL
;.MKMSK -- MAKE MASK CORRESPONDING TO NON-BLANKS IN SIXBIT WORD
;CALL: MOVE T3,WORD
;CALL: MOVE T3,WORD
; PUSHJ P,.MKMSK
;RETURN WITH MASK IN T1
;USES T2
.MKMSK: MOVEI T1,0 ;CLEAR MASK
MOVSI T2,(77B5) ;START AT LEFT END
MAKMS1: TDNE T3,T2 ;SEE IF SPACE HERE
IOR T1,T2 ;NO--IMPROVE MASK
LSH T2,-6 ;MOVE RIGHT ONE CHAR
JUMPN T2,MAKMS1 ;LOOP UNTIL DONE
POPJ P, ;RETURN
SCN%L: ;LABEL THE LITERAL POOL
END