Trailing-Edge
-
PDP-10 Archives
-
BB-H138F-BM_1988
-
7-sources/cpascn.mac
There are 7 other files named cpascn.mac in the archive. Click here to see a list.
TITLE CPASCN -- Command Scanner Interface for CMDPAR
SUBTTL Irwin L. Goverman/ILG/LSS/MLB/PJT/WLH/DC 25-Sept-79
;
;
;
; COPYRIGHT (C) DIGITAL EQUIPMENT CORPORATION 1975, 1986.
; ALL RIGHTS RESERVED.
;
; THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND
; COPIED ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH
; THE INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR
; ANY OTHER COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE
; AVAILABLE TO ANY OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE
; SOFTWARE IS HEREBY TRANSFERRED.
;
; THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT
; NOTICE AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL
; EQUIPMENT CORPORATION.
;
; DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF
; ITS SOFTWARE ON EQUIPMENT THAT IS NOT SUPPLIED BY DIGITAL.
;
SALL ;SUPPRESS MACRO EXPANSION
SEARCH CPASYM,CMDPAR ;OPEN SYMBOLS NEEDED
PROLOG(CPASCN)
;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 CPASCN
;
;
; SECTION PAGE
; 1. Table of Contents......................................... 2
; 2. Revision History.......................................... 3
; 3. Local Definitions......................................... 5
; 4. Module Storage............................................ 6
; 5. S%INIT -- Initialize the CPASCN Module.................. 7
; 6. S%ERR - ERROR TYPEOUT ROUTINE............................. 8
; 7. S%ERR -- ERROR MESSAGES FROM COMND................. 8
; 9. S%CMND -- Scan a command................................ 10
; 10. S%EXIT -- Exit Address for Interrupt Breakout....... 11
; 11. S%SIXB -- Convert ASCII to SIXBIT................... 12
; 12. CNVSIX -- CONVERT ATOM BUFFER TO SIXBIT............. 12
; 13. RETYPE -- Retype current line including the prompt...... 19
; 14. TYPRMT -- Retype the prompt if there is one............. 19
; 15. TYLINE -- Retype the line until current position........ 19
; 16. Atom Buffer Routines / INILCH - Init Atom Buffer.......... 26
; 17. Atom Buffer Routines / STOLCH - Store Character in Atom Buffer 26
; 18. Atom Buffer Routines / CHKLCH - Return Number of Characters 26
; 19. Atom Buffer Routines / TIELCH - Terminate Atom Buffer With NULL 26
; 20. CMCIN -- Read One Character for Processing.............. 27
; 21. HELPER -- Do caller supplied and default HELP text...... 30
; 22. DOHLP -- Do caller supplied HELP text................... 30
; 23. CMAMB -- Handle Ambiguous Typein........................ 30
; 24. Command Function / .CMINI - Init the scanner and do ^H.... 33
; 25. Command Function / .CMSWI - Parse a SWITCH................ 34
; 26. Command Function / .CMKEY - Parse a KEYWORD............... 35
; 27. Command Function / .CMTXT - Parse Arbitrary Text to Action Character 39
; 28. Function .CMNOI -- Parse a NOISE-WORD................... 39
; 29. Command Function / .CMCFM - Command Confirmation (end-of-line) 40
; 30. Command Function / .CMNUM - Parse an INTEGER in any base.. 42
; 31. Command Function / .CMNUX - Parse an INTEGER in any base (special break) 42
; 32. Command Function / .CMDEV - Parse a DEVICE specification.. 45
; 33. Command Function / .CMQST - Parse a QUOTED STRING......... 45
; 34. Command Function / .CMNOD - Parse a NODE Specification.... 46
; 35. PATHIN Routine to Parse TOPS-10 Path Specification....... 49
; 36. PATH SUPPORT ROUTINES..................................... 51
; 37. S%SCMP -- String Comparison Routine..................... 55
; 38. S%TBLK -- Table lookup routine.......................... 57
; 39. S%TBAD -- Table Add Routine......................... 60
; 40. S%TBDL -- Table Delete Routine...................... 61
SUBTTL Revision History
COMMENT \
Edit GCO Reason
---- --- -------------------------------------------
0001 Create CPASCN 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 CPAKBD.
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
0023 Fix S%TBLK, to save the P's
0024 Fix .CMNOD to save SIXBIT value when CM%PO is set
0025 Make S%SIXB to read sixbit strings from ascii strings
0026 If only one element in a Keyword or Switch Table do not
Type out "one of the following" ..but put out a " ".
0027 Change name of ERRBUF to SAVBUF and make it Global. Saving
of Stopcodes on the -20 will use this area.
0030 Change SAVE to $SAVE
0031 Make S%CMND return true if CM%NOP is set on the -20
0032 CORRECT EXTRA LINE TYPEOUT IN HELP TEXT
0033 DO NOT ALLOW NULL NODE NAMES
0034 Change all messages to Upper and lower case and change
Unrecognized Control Character to Ambiguous
0035 Support CM%BRK and output to other than terminal
0036 Change calling convention of NUMIN
0037 Add support for .CMTAD
\ ;END OF REVISION HISTORY
; Entry Points found in this module
ENTRY S%INIT ;INIT THE COMMAND SCANNER MODULE
ENTRY S%CMND ;SCAN A COMMAND
ENTRY S%SCMP ;COMPARE TWO STRINGS
ENTRY S%TBLK ;LOOK UP A STRING IN A TABLE
ENTRY S%ERR ;TYPE OUT SCANNER'S LAST ERROR
ENTRY S%EXIT ;INTERRUPT DEBRK ADDRESS FOR COMND
ENTRY S%TBAD ;ADD ENTRY TO COMMAND TABLES
ENTRY S%TBDL ;DELETE ENTRY FROM COMMAND TABLES
ENTRY S%SIXB ;CONVERT ASCII STRING TO SIXBIT VALUE
SUBTTL Local Definitions
; Special Accumulator definitions
P5==P4+1 ;S%CMND NEEDS LOTS OF ACS
F==14 ;FLAG AC
Q1==15 ;
Q2==16 ;DON'T DEFINE Q3 OR Q4
; Bad parse return macro
DEFINE NOPARS(CODE,TEXT)<
SKIPA T1,[XWD CODE,[ASCIZ\TEXT\]]
XLIST
SKIPA
JRST XCOMNE
LIST
SALL
> ;END OF NOPARS DEFINITION
; Special bit testing macros
DEFINE JXN(AC,FLD,ADDR)<
TXNN AC,FLD
XLIST
SKIPA
JRST ADDR
LIST
SALL
> ;END OF JXN DEFINITION
DEFINE JXE(AC,FLD,ADDR)<
TXNE AC,FLD
XLIST
SKIPA
JRST ADDR
LIST
SALL
> ;END OF JXE DEFINITION
DEFINE RETSKP<JRST [AOS 0(P)
POPJ P,] >
SUBTTL Module Storage
$IMPURE
; Bit table - 36. Words long with word N containing 1B<N>
XX==0
BITS: XLIST
REPEAT ^D36,<EXP 1B<XX>
XX==XX+1>
LIST
$DATA ATBPTR ;ATOM BUFFER POINTER (END)
$DATA ATBSIZ ;ATOM BUFFER SIZE
$DATA STKFEN ;FENCE FOR STACK RESTORATION
$DATA FNARG ;FUNCTION ARGUMENT
$DATA CMCCM,2 ;SAVED CC CODES
$DATA CMRBRK ;POINTER TO BREAK SET TABLE
$DATA CMCSF ;SAVED FLAGS
$DATA CMCSAC,7 ;SAVED ACS DURING S%TXTI FROM S%CMND
$DATA CMCSC ;
$DATA CMCBLF ;
$DATA TBA ;TABLE ARGUMENTS
$DATA STRG ;TEMP STRING POINTER
$DATA REMSTR ;"REMEMBER"ED STRING
$DATA XXXPTR ;RE-USABLE STRING POINTER STORAGE
$DATA CRBLK,CR.SIZ ;RETURNED BLOCK OF ANSWERS
$DATA TABDON ;END OF TAB FOR "?"
$DATA TABSIZ ;SIZE OF TAB LARGER THAN LARGEST KEYWORD
$DATA LSTERR ;ERROR CODE RETURNED FROM NOPARS
$DATA BIGSIZ ;LENGTH OF LONGEST KEYWORD
$DATA PWIDTH ;TERMINAL'S WIDTH
$DATA CURPOS ;LINE POSITION OF CURSOR
$DATA Q3SAVE ;NO Q3 EXISTS
$DATA IFOB ;INDIRECT FILESPEC FOB
$DATA IIFN ;IFN OF INDIRECT FILE
$DATA TI,.RDSIZ ;S%TXTI ARGUMENT BLOCK
$GDATA SAVBUF,ERRBSZ ;BUFFER FOR ERROR MESSAGES
;S%ERR AND SCRATCH
TOPS10 <
$DATA CMDACS,20 ;AC SAVE AREA FOR COMMAND
$DATA PTHBLK,.PTMAX ;STORAGE FOR JOB PATH
$DATA INCMND ;FLAG FOR IN COMMAND STATE
$DATA TBADDR ;ADDRESS OF COMMAND TABLE
$DATA ENTADR ;ADDRESS OF ENTRY FOR TABLE
$DATA SPCBRK ;SPECIAL BREAK MASK
$DATA JFNWRD ;WORD CONTAINING THE JFNS
$DATA VAL1 ;DEFINE VALUES FOR THE DATA
$DATA VAL2 ;BLOCK FOR SECONDS
$DATA VAL3 ;BLOCK FOR MINUTES
$DATA VAL4 ;BLOCK FOR HOURS
$DATA VAL5 ;BLOCK FOR DAYS
$DATA VAL6 ;BLOCK FOR MONTHS
$DATA VAL7 ;BLOCK FOR YEARS
$DATA VAL8 ;BLOCK FOR DECADES
$DATA VAL9 ;BLOCK FOR CENTRIES
$DATA DAYNUM ;DAY NUMBER VALUE "D"
$DATA SECOND ;SECONDS
$DATA MINUTE ;MINUTES
$DATA HOURS ;HOURS
$DATA DAYS ;DAYS
$DATA NOW ;CURRENT DATE AND TIME
$DATA TIMPTR ;POINTER FOR THE TIME
$DATA TIMCNT ;COUNT FOR TIME BUFFER CHARACTERS
$DATA LSTCHR ;LAST CHARACTER SEEN
$DATA FLFUTD ;FUTURE TIME FLAG
$DATA FLFUTR ;FUTURE TIME HOLDER
$DATA TIMSAV ;TIME SAVE ADDRESS
$DATA STRDAT,5 ;LEAVE ROOM FOR DATA
$DATA STRPTR ;POINTER TO THE BLOCK
>;END TOPS10 CONDITIONAL
$DATA INTRPT ;FLAG FOR S%INTR
TOPS20 <
$DATA BLKSAV ;COMMAND BLOCK ADDRESS
$DATA BUFCNT ;SIZE OF COMMAND BUFFER
>;END TOPS20 CONDITIONAL
SUBTTL Date and Time Data Base
$PURE
TOPS10 <
DEFINE DAYERR,<
X IDT,<Invalid Date Field Specified>
X ITF,<Invalid Time Field Specified>
X DOR,<Date/time out of range>
X DTM,<Value missing in date/time>
X MDD,<Missing day in date/time>
X DFZ,<Field zero in date/time>
X MDS,<Mnemonic date/time switch not implemented>
X DFL,<Field too large in date/time>
X ILR,<Illegal year format in date/time>
X NND,<Negative number in date/time>
X NPF,<Not known whether past or future in date/time>
X RDP,<Relative Date Parse Required>
>;END DAYERR
.ZZ==0
DEFINE X(A,B),<
E..'A==.ZZ
.ZZ==.ZZ+1>
DAYERR ;GENERATE THE CODES
DEFINE X(A,B),<
E$$'A: MOVEI 1,E..'A ;GET THE ERROR
PJRST ERRRTN> ;SETUP ERROR RETURN
XLIST
SALL
DAYERR ;GENERATE THE ROUTINES
LIST
ERRRTN: MOVEM S1,LSTERR ;SAVE THE LAST ERROR
$RETF ;RETURN FALSE
DEFINE X(A,B),<
[ASCIZ\B\]>
XLIST
SALL
DERTBL: DAYERR ;GENERATE MESSAGE TABLE
LIST
DAYTBL: $STAB
KEYTAB(2,<FRIDAY>)
KEYTAB(5,<MONDAY>)
KEYTAB(3,<SATURDAY>)
KEYTAB(4,<SUNDAY>)
KEYTAB(1,<THURSDAY>)
KEYTAB(6,<TUESDAY>)
KEYTAB(0,<WEDNESDAY>)
$ETAB
MONTBL: $STAB
KEYTAB(^D4,<APRIL>)
KEYTAB(^D8,<AUGUST>)
KEYTAB(^D12,<DECEMBER>)
KEYTAB(^D2,<FEBRUARY>)
KEYTAB(^D1,<JANUARY>)
KEYTAB(^D7,<JULY>)
KEYTAB(^D6,<JUNE>)
KEYTAB(^D3,<MARCH>)
KEYTAB(^D5,<MAY>)
KEYTAB(^D11,<NOVEMBER>)
KEYTAB(^D10,<OCTOBER>)
KEYTAB(^D9,<SEPTEMBER>)
$ETAB
>;END TOPS10
SUBTTL S%INIT -- Initialize the CPASCN Module
TOPS10 <
S%INIT: MOVSI S2,'TTY' ;LOAD TTY NAME
IONDX. S2, ;GET THE I/O INDEX
JFCL ;IGNORE THE ERROR
MOVX S1,.TOWID ;GET TERMINAL WIDTH FUNCTION
MOVE T1,[2,,S1] ;ARG POINTER
TRMOP. T1, ;GET THE NUMBER
MOVEI T1,^D72 ;USE A DEFAULT
MOVEM T1,PWIDTH ;AND SAVE IT
$RETT ;AND RETURN
> ;END TOPS10 CONDITIONAL
TOPS20 <
S%INIT: $RETT ;RETURN
> ;END TOPS20 CONDITIONAL
SUBTTL S%ERR - ERROR TYPEOUT ROUTINE
SUBTTL S%ERR -- ERROR MESSAGES FROM COMND
;CALL $CALL S%ERR
;
;RETURN TRUE: S1/ ADDRESS OF MESSAGE--ASCIZ
;
;RETURN FALSE: NO MESSAGE
TOPS10 <
S%ERR: HRRZ S1,LSTERR ;GET ADDRESS OF ERROR
JUMPE S1,.RETF ;NO MESSAGE RETURN FALSE
$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%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
CMTOKF==1B27 ;TOK CONFORMING TO SOME ENTRY OF FDB LIST FOUND
;FLAGS IN FUNCTION DISPATCH TABLE
CMNOD==1B0 ;NO DEFAULT POSSIBLE
NOIBCH=="(" ;NOISE WORD BEG CHARACTER
NOIECH==")" ;NOISE WORD END CHARACTER
CMSWCH=="/" ;SWITCH CHARACTER
CMSWTM==":" ;SWITCH TERMINATOR
CMHLPC=="?" ;HELP CHARACTER
CMCOM1=="!" ;COMMENT CHARACTER
CMCOM2==";" ;FULL LINE COMMENT CHARACTER
CMDEFC=="#" ;DEFAULT FIELD CHARACTER
CMFREC=="F"-100 ;FIELD RECOGNITION CHARACTER
CMINDC=="@" ;INDIRECT FILE CHARACTER
CMRDOC=="H"-100 ;REDO COMMAND CHARACTER
CMQTCH=="""" ;CHARACTER FOR QUOTED STRINGS
CMCONC=="-" ;LINE CONTINUATION CHARACTER
;NOPARSE ERROR CODES
NPXNSW==1
NPXNOM==2
NPXNUL==3
NPXINW==4
NPXNC==5
NPXICN==6
NPXIDT==7
NPXNQS==10
NPXAMB==11
NPXNMT==12
NPXCMA==13
NPXNNC==14 ;TOO MANY CHARACTERS IN NODE NAME
NPXNNI==15 ;ILLEGAL CHARACTER IN NODE NAME
NPXNSN==16 ;NO SUCH NODE
NPXIPS==17 ;Invalid Path Specification
NPXIFS==20 ;Invalid File Specification
NPXIUS==21 ;Invalid User Specification
NPXDGS==22 ;DEVICE NAME GREATER THAN 6 CHARACTERS ARE INVALID
NPXDNE==23 ;DEVICE DOESN'T EXIST
NPXDIO==24 ;DEVICE CAN NOT DO INPUT OR OUTPUT
NPXBDF==25 ;BAD DATE/TIME FORMAT
SUBTTL S%EXIT -- Exit Address for Interrupt Breakout
;THE ADDRESS OF S%EXIT IS PLACED IN THE INTERRUPT PC TO FORCE RETURN
;TO THAT ADDRESS AT INTERRUPT IN COMND THAT WE WANT TO BREAKOUT OF.
;THE NECESSARY CLEANUP WILL BE DONE SO S%CMND CAN RETURN.
TOPS20 <
S%EXIT: PJRST CMND.3 ;FIX UP RETURN
>;END TOPS20 CONDITIONAL
TOPS10 <
S%EXIT: PJRST XCOMXI ;SETUP PROPER RETURN
>;END TOPS10 CONDITIONAL
SUBTTL S%SIXB -- Convert ASCII to SIXBIT
;
;S1/ ASCII BYTE POINTER Returned updated
;S2/ SIXBIT value
S%SIXB: TLCE S1,-1 ;Left half of ptr = 0?
TLCN S1,-1 ;... or -1 ?
JRST [HRLI S1,(POINT 7,) ;Yes, Make up pointer for caller
JRST S%SIX1] ;Re enter flow
HRRI S1,@S1 ;Compute effective addr
TLZ S1,(@(17)) ;Remove indirection and index
S%SIX1: $CALL 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: $CALL .SAVET ;Preserve the caller's T's
MOVEI T2,6 ;GET MAX NUMBER OF CHARACTERS IN NAME
MOVE T4,[POINT 6,S2] ; BP TO NODE STORAGE
SETZM S2 ;START FRESH
CNVS.1: ILDB T3,S1 ;GET NEXT CHARACTER FROM ATOM BUFFER
CAIL T3,"A"+40 ;LESS THAN LC A
CAILE T3,"Z"+40 ;OR GREATER THAN LC Z
SKIPA ;YES, NOT A LC CHARACTER
SUBI T3,40 ;NO, ITS LC, MAKE IT UC
CAIL T3,"0" ;IS THE CHARACTER
CAILE T3,"Z" ;NUMERIC OR UPPER CASE?
$RETT ;RETURN TRUE..END OF FIELD
CAILE T3,"9" ;...
CAIL T3,"A" ;...
CAIA ;GOOD CHARACTER, JUST SAVE IT
$RETT ;RETURN TRUE..END OF FIELD
SUBI T3,"A"-'A' ;SIXBITIZE
IDPB T3,T4 ;FILL OUT SIXBIT NODE NAME
SOJGE T2,CNVS.1 ;HAVE WE SEEN ENOUGH CHARACTERS?
$RETF ;ERROR..RETURN FALSE
;The S%CMND routine provides a command scanner interface similar to the
; TOPS-20 COMND JSYS.
;CALL IS: S1/ Pointer to Command State Block
; S2/ Pointer to list of Function Descriptor Blocks
; See CPASYM or MONSYM for a description of these
;TRUE RETURN: ALWAYS,
; S1/ Length of Command Reply block
; S2/ Address of the Command Reply block
TOPS20 <
S%CMND: MOVEM S1,BLKSAV ;SAVE THE COMMAND BLOCK ADDRESS
MOVE S1,.CMCNT(S1) ;GET SIZE OF THE BUFFER
MOVEM S1,BUFCNT ;SAVE BUFFER COUNT
MOVE S1,BLKSAV ;RESTORE S1
PUSH P,.CMFLG(S1) ;SAVE THE REPARSE ADDRESS
PUSH P,S1 ;SAVE ADDRESS OF CSB
HLLZS .CMFLG(S1) ;AND ZERO OUT REPARSE ADDRESS
$CALL 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: $CALL .SAVET ;SAVE T1-T4
SETZ T2, ;ASSUME TRUE RETURN
SKIPN INTRPT ;DID INTERRUPT OCCUR SKIP COMND
COMND% ;DO THE COMMAND JSYS
ERJMP [SETO T2, ;SET FALSE RETURN
JRST CMND.3] ;AND CONTINUE ON
CMND.3: SETZ T3, ;SET FLAG
EXCH T3,INTRPT ;GET CURRENT FLAG AND RESET
MOVE T4,BLKSAV ;ADDRESS OF COMMAND BLOCK
MOVE T4,.CMCNT(T4) ;ROOM LEFT IN BUFFER
CAMGE T4,BUFCNT ;DID WE HAVE ANY DATA
JRST CMND.4 ;YES..IGNORE INTERRUPT FLAG
SKIPE T3 ;INTERRUPT BEFORE COMMAND
TXO S1,CM%INT ;YES..SET INTERRUPT FLAG
CMND.4: MOVEM S1,CRBLK+CR.FLG ;SAVE FLAGS
MOVEM S2,CRBLK+CR.RES ;SAVE DATA FIELD
MOVEM T1,CRBLK+CR.PDB ;SAVE PDB ADDRESS
; TXNE S1,CM%NOP ;NO PARSE?
; SETO T2, ;YES, RETURN FALSE
HRRZ S1,3 ;RH (ac3) = parse block used.
LOAD S1,.CMFNP(S1),CM%FNC ;GET FUNCTION DONE
MOVEM S1,CRBLK+CR.COD ;SAVE IT
JUMPL T2,.RETF ;RETURN FALSE IF NECESSARY
$RETT ;ELSE, RETURN TRUE
> ;END TOPS20 CONDITIONAL
TOPS10 <
;!!!!!NOTE WELL - THIS CONDITIONAL RUNS TO THE END OF COMND ROUTINE
S%CMND: MOVEM 0,CMDACS ;SAVE THE COMMAND ACS
MOVE 0,[XWD 1,CMDACS+1] ;SET UP BLT POINTER
BLT 0,CMDACS+17 ;SAVE THE ACS
MOVE 0,CMDACS ;RESTORE 0
$CALL XCOMND ;DO THE WORK
HRRZ T4,.CMFLG(P2) ;GET REPARSE ADDRESS IF ANY
JUMPE T4,COMN1 ;NONE..JUST RETURN
TXNN F,CM%RPT ;REPARSE NEEDED..
JRST COMN1 ;NO..JUST RESTORE AND RETURN
HRRZ T3,CMDACS+17 ;GET STACK LOCATION
HRRM T4,@T3 ;YES..RETURN TO REPARSE
COMN1: SETZM INCMND ;CLEAR IN COMMAND STATE
MOVSI 17,CMDACS+T1 ;SETUP TO RESTORE ACS
HRRI 17,T1 ;RESTORE FROM T1
BLT 17,17 ;RESTORE THE ACS
POPJ P,0 ;NO RETURN
XCOMND: MOVEM S1,P2 ;SAVE BLOCK PTR
MOVEM S2,P1 ;SAVE FN BLOCK PTR
HRL P1,P1 ;SAVE COPY OF ORIGINAL
MOVEM P,STKFEN ;SAVE CURRENT STACK AS FENCE
MOVE T1,.CMIOJ(P2) ;GET THE JFN WORD
MOVEM T1,JFNWRD ;SAVE THE JFN WORD
MOVEI T1,[.CMRTY ;LIST OF BYTE POINTERS TO CHECK
.CMBFP
.CMPTR
.CMABP
0] ;MARK OF END OF LIST
$CALL 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!CMTOKF ;WILL SOON KNOW IF PREC FLD ENDED IN ESC
;[%43] INDIC TOKEN NOT FND YET
TXZE F,CM%ESC ;PREV FLD HAD ESC? INCL SPEC CASE OF ESC AFT SELF-ENDING TOK (EG. "" STRING)
TXO F,CM%PFE ;YES
$CALL 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
$CALL 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
$CALL INILCH ;SKIP SPACES AND INIT ATOM BUFFER
$CALL CMCIN ;GET INITIAL INPUT
CAIN T1,CMCONC ;POSSIBLE LINE CONTINUATION?
JRST [$CALL CMCIN ;YES, SEE IF NL FOLLOWS
CAIE T1,.CHLFD
$CALL CMRSET ;NO, RESET FIELD
$CALL CMCIN ;RE-READ FIRST CHAR
JRST .+1] ;CONTINUE
CAIN T1,CMCOM2 ;COMMENT?
JRST CMCMT2 ;YES
CAIN T1,CMCOM1
JRST CMCMT1 ;YES
CAIN T1,.CHLFD ;EOL BEGINS FIELD?
JRST [$CALL 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
$CALL CMRSET
SETZ P5,0 ;YES, EMPTY LINE. IGNORE
$CALL TYPRMT ;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: $CALL CMDIP ;PUT CHAR BACK
XCOM4: LOAD T1,.CMFNP(P1),CM%FNC ;GET FUNCTION CODE
JRST @CFNTAB(T1) ;DO IT
;ESC OR ^F AT BEG OF FIELD
XCOM5: TXNN F,CM%DPP ;YES, HAVE DEFAULT STRING?
JRST XCOM3 ;NO
$CALL CMDCH ;FLUSH RECOG CHAR
XCOM6: HLRZ Q1,P1 ;GET PTR TO FIRST FLD BLOCK
MOVE S1,.CMDEF(Q1) ;GET DEFAULT STRING PTR
$CALL 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
$CALL 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
$CALL CMDIBQ ;YES, APPEND ESC TO BUFFER
$CALL CMRSET ;RESET LINE VARIABLES
JRST XCOMN0] ;TREAT AS ORDINARY INPUT
$CALL STOLCH ;STOR CHAR IN ATOM BUFFER
TXNE F,CM%ESC ;RECOGNIZING?
$CALL 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: $CALL CMCIN ;GET NEXT CHAR
CAIN T1,CMCONC ;POSSIBLE LINE CONTINUATION?
JRST [$CALL 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 [$CALL 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: $CALL CMRSET ;RESET VARIABLES TO BEGINNING OF FIELD
$CALL CMCIN1 ;GET MORE INPUT
HLR P1,P1 ;RESET ALTERNATIVE LIST
JRST XCOMN0
;RESET VARIABLES TO BEGINNING OF CURRENT FIELD
CMRSET: SUB P5,P3 ;RESET VARIABLES TO BGN OF FIELD
ADD P5,.CMCNT(P2) ;KEEP ALL CURRENT INPUT
MOVE P3,.CMCNT(P2)
MOVE P4,.CMPTR(P2)
POPJ P,0
;STANDARD EXITS
;RETURN AND REPEAT PARSE BECAUSE USER DELETED BACK INTO ALREADY
;PARSED TEXT
XCOMRP: TXNE F,CM%INT ;INTERRUPT EXIT
JRST XCOMXI ;SETUP RETURN
TXO F,CM%RPT ;REQUEST REPEAT
MOVE T1,P4 ;COMPUTE NUMBER CHARS IN BUFFER
MOVE T2,.CMBFP(P2)
MOVEM T2,P4 ;RESET PTR TO TOP OF BUFFER
$CALL SUBBP ;COMPUTE PTR-TOP
MOVEM T1,P5 ;SET AS NUMBER CHARS FOLLOWING PTR
ADDM T1,P3 ;RESET COUNT TO TOP OF BUFFER
JRST XCOMX1 ;OTHERWISE UPDATE VARIABLES AND EXIT
;GOOD RETURN
XCOMXR: TXNE F,CM%ESC ;RECOG CHARACTER TERMINATED?
$CALL CMDCH ;YES, FLUSH IT
XCOMXI:
TXZ F,CM%RPT ;CLEAR THE REPARSE FLAG
JUMPG P5,[ ;[%42] SOMETHING THERE ALREADY IF JUMP
MOVE T2,P4 ;[%42] GET PTR TO IT
ILDB T1,T2 ;[%42] SEE WHAT IT IS
CAIN T1,.CHESC ;[%42] IS IT ESCAPE?
JRST XCXESC ;[%42] YES
JRST .+1] ;[%42] NO
TXZN F,CM%ESC ;FIELD TERMINATED WITH RECOG?
JRST XCOMX1 ;NO
TXNE F,CMCFF ;^F RECOG?
JRST XCOMRF ;YES, GET MORE INPUT BEFORE RETURNING
XCXESC: TXO F,CM%ESC ;SET FLAG
MOVEI T1," " ;TERMINATE TYPESCRIPT WITH SPACE
$CALL 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
$CALL K%WCOC ;RESTORE THEM
MOVEM P1,CRBLK+CR.PDB ;RETURN PTR TO FUNCTION BLOCK USED
TXZ F,CM%FFL ;FLUSH FUNCTION FLAGS
HLLM F,.CMFLG(P2) ;RETURN FLAGS
MOVEM P2,CRBLK+CR.FLG ;STORE BLK ADDRESS
HLLM F,CRBLK+CR.FLG ;AND THE FLAGS
HRRZ T1,CRBLK+CR.PDB ;GET THE CURRENT PDB
LOAD S1,.CMFNP(T1),CM%FNC ;GET FUNCTION CODE
MOVEM S1,CRBLK+CR.COD ;SAVE THE CODE
MOVEI S1,CR.SIZ ;LOAD SIZE OF RETURNED BLOCK
MOVEI S2,CRBLK ;AND ITS LOCATION
$RETT ;AND TAKE A GOOD RETURN
;FAILURE RETURNS - FAILED TO PARSE
XCOMNE: MOVEM T1,LSTERR ;SAVE ERROR CODE
XCOMNP: JXN F,CMQUES,CMRTYP ;IF IN HELP, DON'T RETURN NOW
$CALL 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, PRESUME NO PARSE
TXNN F,CMTOKF ;[%43] TOKEN FND? IF SO DEFAULT STR IRRELEV
TXNN F,CM%DPP ;DEFAULT STRING?
JRST XCOMX2 ;NO DEFAULT STRING OR TOKEN FOUND
XCOMDF: MOVE P,STKFEN ;RESTORE TOP-LEVEL CONTEXT
TXZ F,CM%ESC+CM%NOP+CM%EOC+CM%RPT+CM%SWT+CMBOL+CMCFF+CMDEFF+CMINDF
;INIT FLAGS
HLRS P1 ;RESUME WITH 1ST FUNCT CODE
JRST XCOM6 ;...AFTER COPYING DEFAU STR TO BUF
;HERE AFTER EACH HELP OUTPUT
CMRTYP: $CALL 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] $CALL CMDOUT
HLR P1,P1 ;END OF LIST, REINIT IT
SOS P5 ;FLUSH QMARK FROM INPUT
TXZ F,CMQUES+CMQUE2 ;NOTE NOT IN HELP
$CALL 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:
$CALL CRLF ;TYPE CRLF TO GET TO LEFT MARGIN
$CALL TYPRMT ;RETYPE THE PROMPT
$CALL TYLINE ;RETYPE THE LINE THUS FAR
$RETT ;AND RETURN
SUBTTL TYPRMT -- Retype the prompt if there is one
TYPRMT:
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
$CALL 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
$CALL 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
$CALL CMDOUT
JRST TYLI.3
;****************************************
;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
$CALL CMRFLD ;GET DEV:NAME.EXT
MOVE T1,P4 ;GET POINTER TO LAST BYTE PARSED
ILDB T1,T1 ;GET TERMINATOR
CAIN T1,"[" ;PPN ?
$CALL CMRPTH ;YES -- GET DIRECTORY
POPJ P,0
FILBRK: 777777,,777760 ;BREAK ON ALL CC
777764,,000760 ;ALLOW . 0-9 :
400000,,000760 ;ALLOW UC
400000,,000760 ;ALLOW LC
;USERNAME BREAK SET. BREAKS ON EVERYTHING EXCEPT DOT AND ALPHABETICS.
USRBRK: 777777,,777760 ;BREAK ON ALL CONTROLS
777744,,001760 ;ALLOW - . 0-9
400000,,000760 ;ALLOW UC
400000,,000760 ;ALLOW LC
;READ TO END OF LINE
EOLBRK: 1B<.CHLFD> ;END OF LINE ONLY
EXP 0,0,0 ;THREE WORDS OF 0'S
;CMRPTH Routine to Read TOPS-10 Path Specification from buffer
CMRPTH: MOVEI T1,PTHBRK ;POINT TO PATH BREAK SET
$CALL CMRFLD ;GET PATH (UP TO "]")
TXNE F,CMQUES ;RETURN IF HELP REQUESTED
POPJ P,0
MOVE T1,P4 ;GET POINTER TO LAST CHARACTER
ILDB T1,T1 ;GET TERMINATOR
CAIN T1,"]" ;END OF PATH?
JRST CMRP.1 ;YES -- STORE TERMINATOR AND RETURN
JXN F,CM%ESC,CMAMB ;DING IF ESCAPE TYPED
POPJ P,0 ;ELSE RETURN
CMRP.1: $CALL CMCIN ;GET TERMINATOR
$CALL STOLCH ;STORE IN ATOM
POPJ P,0
PTHBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
777734,,001760 ;ALLOW , 0-9
400000,,000360 ;BREAK ON "]" ALLOW UC AND "["
400000,,000760 ;ALLOW LC
;GENERAL FIELD PARSE ROUTINE - TAKES BREAK SET MASK
; T1/ ADDRESS OF 4-WORD BREAK SET MASK
; $CALL CMRFLD
; RETURNS +1, FIELD COPIED TO ATOM BUFFER, TERMINATOR BACKED UP
CMRFLD: MOVEM T1,CMRBRK ;SAVE BREAK TABLE ADDRESS
TXNE F,CMDEFF ;DEFAULT GIVEN?
JRST CMRATT ;YES, ALREADY IN BUFFER
CMRAT1: $CALL CMCIN ;GET A CHAR
CAIE T1,CMFREC ;^F RECOGNITION?
CAIN T1,.CHESC ;ESC?
JRST [$CALL CHKLCH ;YES, RETURN IF ANYTHING NOW
JUMPG T1,CMRATT ;IN ATOM BFR
JRST CMAMB] ;AMBIGUOUS
CAIE T1," " ;SPACE OR TAB?
CAIN T1,.CHTAB
JRST [$CALL CHKLCH ;YES, RETURN IF ANYTHING
JUMPG T1,CMRATT ;IN ATOM BFR
JRST CMRAT1] ;OTHERWISE IGNORE
CAIN T1,.CHLFD ;OR EOL?
JRST CMRATR ;YES
CAIN T1,CMHLPC ;HELP REQUEST?
JRST [TXO F,CMQUES ;YES, FLAG
JRST CMRATT]
move T2,t1 ;get copy of char
IDIVI T2,40 ;COMPUTE INDEX TO BIT MASK
MOVE T3,BITS(t3)
ADD T2,CMRBRK
TDNE T3,0(t2) ;BREAK CHARACTER?
JRST CMRATR ;YES
$CALL STOLCH ;BUILD KEYWORD STRING
TXO F,CMTOKF ;[%43] INDIC VALID TOKEN FND
JRST CMRAT1
CMRATR: $CALL CMDIP ;PUT CHARACTER BACK IN BUFFER
CMRATT: PJRST TIELCH ;TIE OFF ATOM BUFFER AND RETURN
;ATOM READ FOR SPECIAL FIELDS - DOES NOT ALLOW RECOGNITION
;READ FIELD TO CR
CMRSTR: TXZA F,CMTF1 ;FLAG NO TERMINATE ON SPACE
; .. ;CONTINUE IN CMRSPC
;READ FIELD TO SPACE OR CR
CMRSPC: TXO F,CMTF1 ;FLAG TERMINATE ON SPACE
TXNE F,CMDEFF ;HAVE FIELD ALREADY?
POPJ P,0 ;YES
CMRSP1: $CALL 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
$CALL 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
$CALL 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
$CALL 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: $CALL CMCIN ;READ NEXT CHAR
TXZ F,CM%ESC!CMCFF ;NOT CTL CHAR WHEN PART OF QUOTED STRING
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
$CALL CMCIN ;YES, PEEK AT ONE AFTER
CAIN T1,CMQTCH ;PAIR OF QUOTES?
JRST CMRQS2 ;YES, STORE ONE
$CALL CMDIP ;NO, PUT BACK NEXT CHAR
$CALL TIELCH ;TIE OFF ATOM BUFFER
RETSKP ;GOOD
CMRQS2: $CALL 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?
$STOP(ABS,Atom buffer too small) ;NO
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
; $CALL CMCIN
; RETURNS +1 ALWAYS, T1/ CHARACTER
CMCIN: SOJL P5,[SETZ P5,0 ;MAKE INPUT EXACTLY EMPTY
$CALL CMCIN1 ;NONE LEFT, GO GET MORE
JRST CMCIN]
ILDB T1,P4 ;GET NEXT ONE
SOS P3 ;UPDATE FREE COUNT
CAIN T1,.CHCRT ;IS IT A CARRIAGE RETURN?
JRST CMCIN ;YES, IGNORE IT
CAIN T1,CMFREC ;^F?
JRST [TXO F,CM%ESC+CMCFF ;YES
POPJ P,0]
CAIN T1,.CHESC ;ESC?
JRST [TXO F,CM%ESC ;YES
POPJ P,0]
CAIN T1,.CHLFD ;END OF LINE?
TXO F,CM%EOC ;YES, MEANS END OF COMMAND
POPJ P,0
CMCIN1: MOVEM F,CMCSF ;SAVE F
SETZM CMCBLF ;INIT ACCUMULATED FLAGS
MOVE T1,[XWD P1,CMCSAC] ;PREPARE FOR BLT
BLT T1,CMCSAC+3 ;SAVE P1-P4
;*** REMOVE RD%RND FOR NOW 6/22/78
MOVX T1,RD%BRK+RD%PUN+RD%BEL+RD%JFN+RD%BBG ;SETUP FLAGS
; REMOVE CM%NJF 9/20/79 MLB SYMBOL USED FOR CM%BRK
; TXNE F,CM%NJF ;WERE JFN'S PASSED?
; TXZ T1,RD%JFN ;NO, PASS THAT FACT
TXNE F,CM%RAI ;RAISE INPUT REQUESTED?
TXO T1,RD%RAI ;YES, PASS IT
MOVEM T1,TI+.RDFLG ;STORE FLAGS FOR TEXTI
MOVX T1,.RDBKL ;GET NUMBER OF WORDS TO PASS
MOVEM T1,TI+.RDCWB ;AND STORE IT
MOVE T1,.CMRTY(P2) ;SETUP ^R BUFFER
MOVEM T1,TI+.RDRTY ;FOR TXTI
MOVE T1,.CMBFP(P2) ;SETUP TOP OF BUFFER
MOVEM T1,TI+.RDBFP ;
SETZM TI+.RDBRK ;NO SPECIAL BREAK MASK
MOVEM P4,TI+.RDBKL ;STORE CURRENT PTR FOR BACK UP LIMIT
MOVEM P3,CMCSC ;SAVE CURRENT COUNT
SUB P3,P5 ;ADJUST COUNT FOR ADVANCE INPUT
MOVEM P3,TI+.RDDBC ;AND STORE FOR THE TEXT INPUT
SKIPE P5 ;PUSH POINTER PAST CURRENT INPUT
IBP P4 ;
SOJG P5,.-1 ;
MOVEM P4,TI+.RDDBP ;STORE FOR INPUT
CMCIN2: MOVE S1,.CMIOJ(P2) ;GET THE JFNS
MOVEM S1,TI+.RDIOJ ;STORE FOR TEXTI
SKIPG P3 ;ROOM IN BUFFER FOR MORE INPUT?
$STOP(TMT,Too much text) ;NO
CMCN2B: MOVEI S1,TI ;GET LOCATION OF TEXTI BLOCK
$CALL K%TXTI ;DO INTERNAL TEXTI
JUMPF [MOVEI S1,EREOF$
JRST XCOMEO]
IOR F,TI+.RDFLG ;GET FLAGS
IORB F,CMCBLF ;ACCUMULATE FLAGS (RD%BLR)
LDB T1,TI+.RDDBP ;GET LAST CHAR
MOVE P4,TI+.RDDBP ;REMEMBER POINTER
MOVE P3,TI+.RDDBC ;AND COUNT
TXNE F,RD%BFE ;BUFFER EMPTY?
JRST CMCIN3 ;YES, RETURN
JUMPE T1,CMCIN3 ;JUMP IF NULL
CAIE T1,.CHLFD ;AN ACTION CHAR?
CAIN T1,.CHESC
JRST CMCIN3 ;YES
CAIE T1,CMHLPC
CAIN T1,CMFREC ;^F?
JRST CMCIN3 ;YES
JRST CMCIN2 ;NO, GET MORE INPUT
CMCIN3: TXNE F,RD%BLR ;BACKUP LIMIT REACHED?
JRST CMCIN4 ;YES, CLEANUP AND REPARSE
TXNE F,RD%BFE ;BUFFER EMPTY
SKIPN INTRPT ;INTERRUPT OCCUR
SKIPA ;NO..CHECK REST
JRST CMCIN4 ;YES..SETUP TO RETURN
MOVE P5,CMCSC ;RECOVER PREVIOUS COUNT
SUB P5,P3 ;COMPUTE CHARACTERS JUST APPENDED
MOVSI T1,CMCSAC ;RESTORE ACS P1-P4, F
HRRI T1,P1
BLT T1,P4
MOVE F,CMCSF
POPJ P,0
;HERE ON RETURN FROM TEXTI WHICH REACHED BACKUP LIMIT OR WHICH RETURNED
;BECAUSE BUFFER EMPTY. MUST REPARSE LINE. RESTORE ACS, BUT LEAVE
;MAIN POINTER AS RETURNED BY TEXTI.
CMCIN4: DMOVE P1,CMCSAC ;RESTORE P1&P2
MOVE F,CMCSF ;RESTORE F
SKIPE INTRPT ;WAS THERE AN INTERRUPT CALL?
TXO F,CM%INT ;YES, LIGHT THE FLAG
SETZM INTRPT ;CLEAR CALL FLAG
JRST XCOMRP ;RETURN REPEAT PARSE
;SKIP LEADING TABS OR SPACES
CMSKSP: $CALL 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
; $CALL 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
$CALL DBP ;DECREMENT BYTE PTR
MOVEM S1,P4
AOS P3 ;ADJUST SPACE COUNT
SETZ P5,0 ;CAN'T BE ANY WAITING INPUT
POPJ P,0
;LOCAL ROUTINE - DECREMENT INPUT POINTER
CMDIP: LDB T1,P4 ;CHECK THE CHARACTER
CAIE T1,CMFREC ;A RECOG REQUEST CHAR?
CAIN T1,.CHESC
TXZ F,CM%ESC+CMCFF ;YES, RESET FLAGS
MOVE S1,P4 ;GET POINTER
$CALL 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
$CALL CMDOUT ;TYPE IT
CMDIBQ: SETZ P5,0 ;CLEAR ADVANCE COUNT
SOSGE P3 ;ROOM?
$STOP(ABS,Atom buffer too small) ;NO
IDPB T1,P4 ;APPEND BYTE TO USER'S BUFFER
POPJ P,0
;LOCAL ROUTINE - DECREMENT BYTE POINTER
;CALL S1/ BYTE POINTER
DBP: SOS S1 ;BACK OFF ONE WORD
IBP S1 ;AND THEN GO FORWARD 4 TIMES
IBP S1
IBP S1
IBP S1
$RETT ;THEN RETURN
SUBTTL HELPER -- Do caller supplied and default HELP text
;HELPER types out the caller supplied help text, if any, and then it types
; the default help type unless it was suppressed. Return is via CMRTYP
; to retype the current line.
;
;Call: S1/ address of default HELP text
;
;T Ret: always
HELPER: PUSH P,S1 ;SAVE S1
$CALL 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
$CALL CMDOUT ;PRINT IT
MOVE S1,0(P) ;GET THE MESSAGE
$CALL CMDSTO ;PRINT IT
HELP.1: POP P,S1 ;GET THE STACK BACK
PJRST CMRTYP ;RETYPE THE LINE
SUBTTL DOHLP -- Do caller supplied HELP text
DOHLP: MOVEI S1,[ASCIZ /
or/]
TXNE F,CMQUE2 ;IN ALTERNATE HELP POSSIBILITIES?
$CALL CMDSTO
TXNN F,CM%HPP ;HAVE HELP POINTER?
POPJ P,0 ;NO
MOVEI S1," "
$CALL CMDOUT ;SPACE BEFORE USER TEXT
MOVE S1,.CMHLP(P1) ;YES, GET IT
PJRST K%SOUT ;AND TYPE IT
SUBTTL CMAMB -- Handle Ambiguous Typein
CMAMB: TXZN F,CM%ESC ;ESC SEEN?
NOPARS (NPXAMB,Ambiguous)
$CALL CMDCH ;FLUSH RECOG CHAR FROM BUFFER
MOVEI S1,.CHBEL ;INDICATE AMBIGUOUS
$CALL CMDOUT
JRST XCOMRF ;GET MORE INPUT AND RESTART
;OUTPUT STRING FROM CURRENT CONTEXT
XMCOUT: $CALL CMDOUT ;OUTPUT A CHARACTER
CAIE S1,^D9
JRST XMCS.2
XMCS.1: MOVE S1,CURPOS
ADDI S1,8
IDIVI S1,8
IMULI S1,8
MOVEM S1,CURPOS
SKIPA
XMCS.2: AOS CURPOS ;MAINTAIN POSITION
POPJ P,0
CRLF: SETZM CURPOS ;AT LEFT MARGIN
MOVEI S1,[BYTE (7) .CHCRT,.CHLFD,0]
PJRST K%SOUT ;AND TYPE IT
;CHECK ALL BYTE PTRS
; T1/ PTR TO LIST OF ADDRESSES, TERMINATED BY 0
CHKABP: $SAVE Q1 ;SAVE ACS
$SAVE Q2 ;THAT WE USE
MOVEM T1,Q1 ;SAVE LIST PTR
CHKAB1: MOVE Q2,0(Q1) ;GET NEXT ADDRESS
JUMPE Q2,.RETT ;DONE ON 0
ADDI Q2,0(P2) ;MAKE PTR TO BLOCK
MOVE S1,0(Q2) ;GET BYTE PTR
$CALL 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
$CALL 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
$CALL K%BIN ;GET FIRST CHARACTER
CAIN S1,CMRDOC ;IS IT REDO?
JRST CMINI5 ;YES
$CALL K%BACK ;NO, BACKUP OVER IT
CMINI4: MOVE T1,P4 ;RESET LINE VARIABLES
MOVE T2,.CMBFP(P2)
MOVEM T2,P4
$CALL 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
$CALL CMDCH ;DELETE FROM INPUT BUFFER
SETZ P5,0 ;NO INPUT
$CALL 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
$CALL 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 [$CALL CMDIP ;NO, PUT IT BACK
NOPARS (NPXNSW,Unrecognizable Switch Construction)]
JRST CMKEY0 ;CONTINUE LIKE KEYWORD
SUBTTL Command Function / .CMKEY - Parse a KEYWORD
XCMKEY: TXZ F,CMSWF ;NOT SWITCH
CMKEY0:
KEYW1: $CALL CMRATM ;READ THE FIELD INTO LOCAL BUFFER
MOVE T1,FNARG ;GET TABLE HEADER ADDRESS
MOVE T2,.CMABP(P2) ;POINT TO KEYWORD BUFFER
$CALL XTLOOK ;LOOKUP
TXNE F,CMQUES ;HAD "?"
JRST CMQ1 ;YES, GO TYPE ALTERNATIVES
TXNE T2,TL%NOM ;NO MATCH?
NOPARS(NPXNOM,No KEYWORD Match)
JXN T2,TL%AMB,CMAMB ; ??? AMBIGUOUS
MOVEM T1,T2 ;SAVE TABLE INDEX
MOVEM T1,CRBLK+CR.RES ;AS RESULT
JXE F,CM%ESC,KEYW4 ;DONE IF NO REC WANTED
MOVEM T3,Q1 ;SAVE PTR TO REMAINDER OF STRING
$CALL CMDCH ;FLUSH RECOG CHARACTER
KEYW2: ILDB T1,Q1 ;TYPE REMAINDER OF KEYWORD
JUMPE T1,KEYW3 ;DONE
$CALL 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?
$CALL 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
$CALL CMDIB
TXO F,CM%SWT ;NOTE SWITCH TERMINATOR
JRST XCOMX1 ;INHIBIT ADDITIONAL SPACE
KEYW4: $CALL CHKLCH ;SEE IF ATOM NON-NULL
JUMPE T1,[NOPARS (NPXNUL,KEYWORD Expected)] ;FAIL IF NULL
JXE F,CMSWF,XCOMXI ;DONE IF NOT SWITCH
$CALL CMSKSP ;SKIP SPACES
$CALL CMCIN ;GET NON-BLANK CHAR
CAIN T1,CMSWTM ;SWITCH TERMINATOR?
JRST [TXO F,CM%SWT ;YES, NOTE
JRST XCOMXI] ;DONE
$CALL 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)/]
$CALL CMDSTO ;TYPE MESSAGE
JRST CMRTYP] ;RETYPE LINE AND CONTINUE
CMQ2: MOVEM T1,Q2 ;SAVE TABLE INDEX
$CALL 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:/]
$CALL CMDSTO ;TYPE IT
$CALL 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: $CALL CMNXTE ;GET TO NEXT VALID KEYWORD IN TABLE
JUMPF CMTAB2 ;NO MORE IN TABLE
$CALL 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: $CALL 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?
$CALL CMDOUT ;YES, TYPE THE SLASH
PUSH P,T1 ;SAVE ADDRESS OF TABLE ENTRY
$CALL CMGTLN ;COMPUTE ITS LENGTH
ADDM T1,CURPOS ;MOVE CURRENT POSITION FORWARD
POP P,S1 ;RESTORE POINTER
$CALL CMDSTO ;TYPE IT
$CALL CMNXTE ;GET TO NEXT KEYWORD
JUMPF CMRTYP ;NO MORE, REPEAT COMMAND SO FAR AND CONTINUE
$CALL NXTKEY ;AND POSITION FOR THE NEXT ONE
JRST CMQ4 ;TRY NEXT
CMQ5: MOVEI S1," " ;GET A BLANK
$CALL 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
$CALL 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
$CALL 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
$CALL 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: $CALL .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
$CALL 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
$CALL 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
$CALL 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: $CALL CMRSTR ;READ STRING
MOVEI S1,[ASCIZ /text string/]
TXNE F,CMQUES ;QUESTION MARK TYPED?
$CALL HELPER ;YES, GIVE HELP
JRST XCOMXI ;DONE
SUBTTL Function .CMNOI -- Parse a NOISE-WORD
XCMNOI: MOVE S1,FNARG ;GET STRING PTR
$CALL 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
$CALL 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
$CALL CMDIB
JRST XCOMXI ;EXIT
;PREVIOUS FIELD NOT TERMINATED WITH ESC - PASS NOISE WORD IF TYPED
CMNOI3: $CALL CMSKSP ;BYPASS SPACES
$CALL CMCIN ;GET FIRST CHAR
CAIE T1,NOIBCH ;NOISE BEG CHAR?
JRST [$CALL CMDIP ;NO, NOT A NOISE WORD, PUT IT BACK
JRST XCOMXI] ;RETURN OK
CMNOI4: $CALL CMCIN ;GET NEXT NOISE CHAR
CAIE T1,CMFREC ;^F?
CAIN T1,.CHESC ;ESC?
JRST [$CALL CMDCH ;YES, FLUSH IT
JRST CMNOI2] ;COMPLETE NOISE WORD FOR USER
ILDB T2,XXXPTR ;COMPARE WITH GIVEN STRING
CAIL T1,"A"+40 ;RAISE CASING FOR COMPARE
CAILE T1,"Z"+40
SKIPA
SUBI T1,40
CAIL T2,"A"+40
CAILE T2,"Z"+40
SKIPA
SUBI T2,40
CAMN T1,T2
JRST CMNOI4 ;STILL SAME AS EXPECTED
CAIN T1,NOIECH ;NOT SAME, STRING ENDED TOGETHER?
JUMPE T2,XCOMXI ;YES, EXIT OK
NOPARS (NPXINW,Bad Noise Word) ;NO, PROBABLY BAD NOISE WORD
SUBTTL Command Function / .CMCFM - Command Confirmation (end-of-line)
XCMCFM: $CALL CMCFM0 ;DO THE WORK
NOPARS(NPXNC,CONFIRMATION Required)
JRST XCOMXI ;OK
CMCFM0: $CALL CMCIN ;GET CHAR
CAIE T1,.CHTAB ;BLANK?
CAIN T1," "
JRST CMCFM0 ;YES, IGNORE
MOVEI S1,[ASCIZ /confirm with carriage return/]
CAIN T1,CMHLPC ;HELP?
$CALL 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:
MOVEI T1,FLTBRK ;USE SPECIAL BREAK SET
$CALL CMRFLD ;READ FIELD
MOVEI S1,[ASCIZ /number/]
TXNE F,CMQUES ;QUESTION MARK?
$CALL HELPER ;YES, HELP!
MOVE S1,.CMABP(P2) ;NUMBER NOW IN ATOM BUFFER, GET PTR
$CALL FLIN ;EAT REAL #
JUMPF CMNUM1 ;OOPS, DIDNT PARSE
JRST CMNUMR ;DO NUMBER CLEANUP AND RETURN
;FLOATING POINT BREAK SET MASK, ALLOWS +, -, ., E, NUMBERS
FLTBRK: 777777,,777760
777644,,001760
400000,,000760
400000,,000760
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
$CALL CMRFLD ;READ FIELD
TXNE F,CMQUES ;SAW "?"
JRST CMNUMH ;YES
MOVE S1,.CMABP(P2) ;SETUP NIN
MOVE S2,FNARG ;GET RADIX
$CALL NUMIN ;PARSE THE NUMBER
JUMPF CMNUM1 ;NO PARSE
CMNUMR: MOVEM S2,CRBLK+CR.RES ;STORE RESULT
MOVE T2,ATBPTR
IBP T2 ;BUMP PTR PAST TERMINATOR
CAMN S1,T2 ;NIN SAW WHOLE FIELD?
JRST [MOVE T2,CRBLK+CR.RES
JRST XCOMXR] ; YES, RECOVER RESULT AND RETURN
CMNUM1: NOPARS (NPXICN,Numeric Character Expected)
;NUMBER BREAK SET, ALLOWS +, -, NUMBERS
NUMBRK: 777777,,777760
777654,,001760
400000,,000760
400000,,000760
NUXBRK: 777777,,777760
777654,,001760
777777,,777760
777777,,777760
SUBTTL NUMIN -- NUMBER INPUT ROUTINE
;THIS ROUTINE WILL PARSE A NUMBER FROM A STRING AND RETURN THE
;VALUE
;
;CALL S1/ POINTER TO THE STRING
; S2/ RADIX
;
;RETURN TRUE:
; S1/ UPDATED POINTER
; S2/ NUMBER
NUMIN: $CALL .SAVE3 ;GET 2 SCRATCH ACS
SETZ P2, ;CLEAR SIGN MODIFIER
NUMI.1: ILDB P1,S1 ;GET FIRST CHARACTER
CAIN P1," " ;A BLANK?
JRST NUMI.1 ;YES, IGNORE IT
CAIN P1,"-" ;IS IT MINUS SIGN?
JRST [JUMPN P2,.RETF ;ONLY ALLOW ONE SIGN
MOVX P2,-1 ;SET NEGITIVE
JRST NUMI.1] ;GET NEXT CHARACTER
CAIN P1,"+" ;IS IT PLUS SIGN?
JRST [JUMPN P2,.RETF ;ONLY ALLOW ONE SIGN
MOVX P2,+1 ;SET POSITIVE
JRST NUMI.1] ;GET NEXT CHARACTER
CAIG P1,"0"-1(S2) ;TOO BIG
CAIGE P1,"0" ;OR TOO SMALL?
$RETF ;YES, TAKE FAILURE RETURN
SETZ P3,0 ;CLEAR THE RESULT
NUMI.2: IMULI P3,0(S2) ;SHIFT OVER 1 DIGIT
ADDI P3,-"0"(P1) ;AND ADD IN THIS ONE
ILDB P1,S1 ;GET NEXT CHAR
CAIG P1,"0"-1(S2) ;IN RANGE?
CAIGE P1,"0"
JRST NUMI.3 ;FINISH OFF AND RETURN
JRST NUMI.2 ;YES, REPEAT
NUMI.3: SKIPGE P2 ;SHOULD BE NEGATIVE?
MOVNS P3 ;MAKE IT NEGATIVE
MOVE S2,P3 ;GET THE VALUE
$RETT ;RETURN TRUE
CMNUMH: $CALL 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 /]
$CALL 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
$CALL 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: $CALL CMDSTO
JRST CMRTYP
SUBTTL Command Function / .CMDEV - Parse a DEVICE specification
XCMDEV: MOVEI T1,DEVBRK ;GET DEVICE BREAK SET
$CALL CMRFLD ;GET THE FIELD
MOVEI S1,[ASCIZ /device name/]
TXNE F,CMQUES ;TYPE A QUESTION MARK?
$CALL HELPER ;YES, CALL THE HELPER
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
MOVE S1,.CMABP(P2) ;ADDRESS OF BUFFER
$CALL CMCIN ;CHECK TERMINATOR
CAIE T1,":" ;DEVICE?
NOPARS(NPXIDT,<Invalid Device -- Device Specifications Requires a :>)
TXNE F,CM%PO ;PARSE ONLY ON FIELD
JRST XCOMXR ;YES..RETURN O.K.
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
$CALL CNVSIX ;CONVERT FIELD TO SIXBIT
SKIPT ;O.K. S1/ FIELD NAME
NOPARS(NPXDGS,<Device Name is Greater Than Six Characters>)
DEVCHR S2, ;SEE IF IT EXISTS
SKIPN S2 ;VALID DATA
NOPARS(NPXDNE,<DEVICE Name Does Not Exist>)
TXNE S2,DV.IN!DV.OUT ;CHECK IF CAN DO INPUT OR OUTPUT
PJRST XCOMXR ;YES..RETURN O.K.
NOPARS(NPXDIO,<DEVICE can not do INPUT or OUTPUT>)
DEVBRK: 777777,,777760 ;BREAK ON ALL CONTROL CHARACTERS
757754,,001760 ;BREAK ON : ALLOW 0-9
400000,,000740 ;ALLOW UC
400000,,000760 ;ALLOW LC
SUBTTL Command Function / .CMQST - Parse a QUOTED STRING
XCMQST: $CALL CMRQST ;READ THE STRING
NOPARS(NPXNQS,Quoted String Expected)
MOVEI S1,[ASCIZ /quoted string/]
TXNE F,CMQUES ;QUESTION MARK TYPED?
$CALL HELPER ;YES, GIVE HELP
JRST XCOMXI
;UNQUOTED STRING - TAKES BIT MASK (4 WORDS * 32 BITS) TO SPECIFY BREAKS.
XCMUQS:
CMUQS1: $CALL CMCIN ;GET A CHAR
IDIVI T1,^D32 ;COMPUTE INDEX TO BIT ARRAY
MOVE T2,BITS(T2)
ADD T1,FNARG
TDNN T2,0(T1) ;BIT ON?
JRST CMUQS1 ;NO, KEEP GOING
$CALL CMDIP ;YES, PUT CHAR BACK
JRST XCOMXI ;DONE
;ARBITRARY FIELD
XCMFLD: $CALL CMRATM
CMFLD1: TXNE F,CMQUES ;"?" SEEN?
JRST [$CALL DOHLP ;YES, DO USER MESSAGE
JRST CMRTYP]
JRST XCOMXR ;LEAVE FIELD IN ATOM BUFFER
;ACCOUNT
XCMACT: MOVEI T1,USRBRK ;SAME BREAK SET AS USER NAME FIELD
$CALL CMRFLD ;READ FIELD
JRST CMFLD1 ;FINISH LIKE ARBITRARY FIELD
SUBTTL Command Function / .CMNOD - Parse a NODE Specification
XCMNOD: $CALL CMRATM ;GET AN ATOM
MOVEI S1,[ASCIZ /node name/]
TXNE F,CMQUES ;DID HE TYPE A QUESTION MARK?
$CALL HELPER ;YES, TYPE THE HELP TEXT(S)
JXN F,CM%ESC,[PUSHJ P,CMDCH ;DO RECOGNITION IF REQUESTED
PUSHJ P,TIELCH;TIE ATOM BUFFER
JRST XNOD1] ;RETURN IN LINE
XNOD1: MOVE S1,.CMABP(P2) ;GET THE BYTE POINTER
ILDB S2,S1 ;GET THE FIRST BYTE
SKIPN S2 ;BETTER NOT BE NULL
JRST ILLNOD ;IMPROPER NODE NAME
MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
MOVEI S2,^D8 ;TRY AS AN OCTAL NUMBER
$CALL NUMIN ;READ IT
JUMPF XNOD2 ;LOST, TRY AS A SIXBIT NAME
MOVEM S2,CRBLK+CR.RES ;SAVE AS RESULT
MOVE T2,ATBPTR ;GET POINTER TO END OF ATOM BUFFER
IBP T2 ;POINT AT TERMINATOR
CAME S1,T2 ;OUR POINTER END THE SAME PLACE?
JRST ILLNOD ;NO, LOSE!
MOVE T3,CRBLK+CR.RES ;NODE NUMER WE JUST PARSED
TXNE F,CM%PO ;PARSE ONLY?
JRST XCOMXI ;YES, JUST RETURN WITH RESULT
MOVE T1,[XWD .NDRNN,T2] ; MAKE SURE THAT THIS NODE NUMBER EXISTS
MOVEI T2,2 ;2 ARGS
NODE. T1, ;TRY IT FOR EXISTANCE
JRST ILLNOD ;IT DOESN'T!
JRST XCOMXI ;A GOOD NODE NUMBER, RETURN
XNOD2: MOVE S1,.CMABP(P2) ;POINT AT THE ATOM BUFFER
$CALL CNVSIX ;CONVERT BUFFER TO SIXBIT
SKIPT ;O.K.. CONTINUE
ILLNOD: NOPARS (NPXNNC,Improper Node Name)
MOVEM S2,CRBLK+CR.RES ;SAVE SIXBIT NAME IN RESULT FIELD
XNOD3: TXNE F,CM%PO ;PARSE ONLY?
PJRST XCOMXR ;YES..RETURN NOW
MOVE T2,ATBPTR ;GET POINTER TO END OF ATOM BUFFER
IBP T2 ;POINT AT TERMINATOR
CAME S1,T2 ;OUR POINTER END THE SAME PLACE?
NOPARS (NPXNNI,Node Name Expected)
XNOD4: MOVEI T2,2 ;2 ARGS
MOVE T3,S2 ;GET NODE NAME RETURNED
MOVE T1,[XWD .NDRNN,T2]
NODE. T1,0
NOPARS(NPXNSN,<Node Name is Not a Valid Node>)
MOVEM T1,CRBLK+CR.RES ;STORE NUMBER
JRST XCOMXI ;AND RETURN
;FILE SPEC
XCMOFI:
XCMIFI:
XCMFIL: $CALL CMRFIL ;GET FILE SPECIFICATION
JXN F,CMQUES,CMFHLP ;IF THEY WANT HELP, GIVE IT TO THEM
JXN F,CM%ESC,[PUSHJ P,CMDCH ;ALLOW ESCAPE AS VALID TERMINATOR
PUSHJ P,TIELCH
JRST XFIL.1 ] ;RETURN IN LINE
XFIL.1: $CALL FILIN ;GET FILE SPEC
NOPARS (NPXIFS,Invalid File Specification)
MOVE T2,ATBPTR ;GET POINTER TO ATOM BUFFER END
IBP T2 ;BUMP PAST TERMINATOR
CAME T2,XXXPTR ;DOES IT MATCH?
NOPARS (NPXIFS,Invalid File Specification)
JRST XCOMXI ;OTHERWISE, DONE
FILIN: $CALL .SAVE1 ;SAVE A REG
LOAD S2,.CMGJB(P2),CM%GJB ;GET ADDR OF FD
MOVEM S2,CRBLK+CR.RES ;SAVE IT FOR CALLER
MOVE P1,S2 ;AND REMEMBER IT
MOVX S1,FDXSIZ ;NOW ZERO IT OUT
STORE S1,.FDLEN(S2),FD.LEN ;STORE LENGTH INTO FD
SKIPN S1,.FDSTR(P1) ;SEE IF USER SUPPLIED A DEFAULT DEVICE
MOVSI S1,'DSK' ;NO, SUPPLY DEFAULT DEVICE
STORE S1,.FDSTR(P1) ;STORE DEFAULT DEVICE
MOVE T1,.CMABP(P2) ;GET ATOM BUFFER POINTER
MOVEM T1,XXXPTR ;STORE IT
$CALL FTOKEN ;GET FIRST FILE TOKEN
CAIE T2,':' ;IS FIRST PART A DEVICE
JRST FILI.1 ;NO
MOVEM T1,.FDSTR(P1) ;STORE STRUCTURE NAME
$CALL FTOKEN ;YES, LOAD NEXT TOKEN
FILI.1: JUMPN T1,FILI.2 ;IF WE HAVE SOMETHING, IT MUST BE FILENAM
CAIE T2,'[' ;IF NOT, EXPECT A PPN HERE
JRST FILI.4 ;CHECK FOR SUFFICIENT FILE-SPEC
MOVE S1,XXXPTR ;GET POINTER TO PPN
$CALL DBP ;DECREMENT POINTER
MOVE T1,S1 ;GET THE POINTER
MOVEI T2,.FDPPN(P1) ;POINT TO DESTINATION
HRLI T2,5 ;AND SET MAXIMUM DEPTH FOR SFD'S
$CALL PATHIN ;PARSE PATH
POPJ P, ;PASS ON FAILURE
$CALL FTOKEN ;AND GET NEXT PART
FILI.2: SKIPE T1 ;IF NO FILE NAME, LOOK FOR EXTENSTION
STORE T1,.FDNAM(P1) ;STORE NAME
CAIE T2,'.' ;IS THERE AN EXTENSION?
JRST FILI.3 ;NO
$CALL FTOKEN ;GET EXTENSION
STORE T1,.FDEXT(P1) ;AND STORE IT
FILI.3: CAIE T2,'[' ;HAVE WE GOT A PPN?
JRST FILI.4 ;CHECK FOR SUFFICIENT FILE-SPEC
MOVE S1,XXXPTR ;RELOAD THE POINTER
$CALL DBP ;DECREMENT IT
MOVE T1,S1 ;PLACE POINTER BACK IN T1
MOVEI T2,.FDPPN(P1) ;POINT TO DESTINATION
HRLI T2,5 ;AND SET MAXIMUM SFD DEPTH
$CALL PATHIN ;PARSE THE PATH
POPJ P, ;RETURN A FAILURE
IBP XXXPTR ;AND BUMP PAST TERMINATOR
FILI.4: SKIPN .FDNAM(P1) ;MAKE SURE THERE IS A NAME
POPJ P, ;NO NAME, BAD FILE SPEC
RETSKP ;TAKE GOOD RETURN
FTOKEN: SETZM T1 ;CLEAR RESULT
MOVE T3,[POINT 6,T1] ;AND POINT TO STORAGE AREA
FTOK.1: ILDB T2,XXXPTR ;GET A BYTE
$CALL C7TO6 ;CONVERT TO SIXBIT
CAIG T2,'Z' ;IS IT IN RANGE?
CAIGE T2,'0' ;
POPJ P,0 ;NO
CAILE T2,'9' ;
CAIL T2,'A' ;
SKIPA
POPJ P,0
TXNE T3,<INSVL.(77,BP.POS)> ;IS THERE ROOM?
IDPB T2,T3 ;YES,STORE IT
JRST FTOK.1 ;TRY ANOTHER
C7TO6: CAIL T2,"a" ;IS IT LC?
SUBI T2,40 ;YES
SUBI T2," " ;CONVERT TO SIXBIT
ANDI T2,77 ;MASK IT AND
POPJ P, ;RETURN
;FILESPEC HELP
CMFHLP: $CALL 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: $CALL CMDSTO
JRST CMRTYP
;TOKEN - ARBITRARY SYMBOL AS SPECIFIED BY FN DATA
XCMTOK: MOVE Q1,FNARG ;GET STRING ADDRESS
CMTOK1: ILDB Q2,Q1 ;GET NEXT CHAR IN STRING
JUMPE Q2,[PUSHJ P,TIELCH ;SUCCESS IF END OF STRING
JRST XCOMXI]
CMTOK2: $CALL CMCIN ;GET NEXT CHAR OF INPUT
CAMN T1,Q2 ;MATCH?
JRST [$CALL STOLCH ;YES, APPEND TO ATOM BUFFER
JRST CMTOK1] ;CONTINUE
JXN F,CM%ESC,CMAMB ;AMBIGUOUS
CAIN T1,CMHLPC ;HELP REQUEST?
JRST [$CALL DOHLP ;YES
JXN F,CM%SDH,CMRTYP
MOVEI S1,"""" ;TYPE "token"
$CALL CMDOUT
MOVE S1,FNARG
$CALL CMDSTO
MOVEI S1,""""
$CALL CMDOUT
JRST CMRTYP]
NOPARS (NPXNMT,Invalid Token Found) ;NO MATCH OF TOKEN
SUBTTL PATHIN Routine to Parse TOPS-10 Path Specification
; PATHIN may be called to Parse a Path Specification in the Atom Buffer
; it builds a Path Block up to 6 words in length depending
; on the depth specified in T2 on the call.
; CALL T1/ Byte Pointer to String
; T2/ Length of Destination,,Destination Address
; Uses T1-T4 and XXXPTR
; Destination must not be an AC and Depth must be Less Than 6
; True Return is a Skip Return
; With: PPN and Path Stored Via Calling Arg in T2
; XXXPTR Pointing to Terminating byte ("]") in String
; Error Return is a non skip Return
PATHIN: ILDB S1,T1 ;LOAD FIRST BYTE
CAIE S1,"[" ;MUST BE BRACKET
POPJ P,0 ;ELSE FAIL
$CALL .SAVE2 ;PRESERVE P1-P2
HRRZ P2,T2 ;GET DESTINATION ADDRESS
HRLI P2,P1 ;P2 IS NOW DESTINATION(P1)
AOBJP T2,.+1 ;ADD ONE TO INCLUDE PPN WITH SFD'S
HLLZ P1,T2 ;GET DEPTH IN P1 LEFT HALF
MOVN P1,P1 ;P1 IS NOW AOBJN POINTER
$CALL RDPATH ;GET CURRENT PATH IN PTHBLK
MOVEM T1,XXXPTR ;SAVE IN CASE OF PPN FAILURE
MOVE S1,T1 ;GET THE POINTER
MOVEI S2,^D8 ;SET OCTAL RADIX
$CALL NUMIN ;FOR PROJECT AND PROGRAMMER NUMBERS
LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;MUST BE COMMA
POPJ P,0 ;FAIL -- PPN NOT NUMERIC
SKIPN S2 ;WAS ANSWER 0?
HLR S2,PTHBLK+.PTPPN ;YES -- LOAD DEFAULT
HRLM S2,(P2) ;STORE IN DESTINATION
MOVEI S2,^D8 ;SET OCTAL RADIX
$CALL NUMIN
LDB T1,S1 ;GET TERMINATOR
CAIE T1,"," ;MUST BE COMMA OR BRACKET
CAIN T1,"]"
SKIPA
POPJ P,0 ;FAIL -- PPN INCORECT
SKIPN S2 ;WAS ANSWER 0
HRR S2,PTHBLK+.PTPPN ;YES -- LOAD DEFAULT
HRRM S2,(P2) ;STORE IN DESTINATION
MOVEM S1,XXXPTR ;STORE UPDATED POINTER
MOVE T1,(P2) ;RECLAIM PPN
JRST PATH.2 ;LOOK FOR SFD'S
PATH.1: $CALL FTOKEN ;GET TOKEN
PATH.2:SKIPN T1 ;IF FIELD IS ZERO
MOVE T1,PTHBLK+.PTPPN(P1) ;LOAD DEFAULT
JUMPE T1,.POPJ ;FAIL IF DEFAULT WAS 0
MOVEM T1,@P2 ;STORE RESULT
LDB S1,XXXPTR ;GET TERMINATOR
CAIN S1,"]" ;AT END OF PATH?
JRST PATH.3 ;YES -- CLEAR REST OF PATH
CAIE S1,"," ;VALID SEPARATOR?
POPJ P,0 ;NO -- GIVE FAILURE RETURN
AOBJN P1,PATH.1 ;REPEAT UNTIL MAXIMUM DEPTH
POPJ P,0 ;TO DEEP -- GIVE FAILURE
PATH.3: AOBJP P1,PATH.4 ;CLEAR REST OF PATH
SETZM @P2 ;CLEAR REST OF DESTINATION
JRST PATH.3
PATH.4: RETSKP ;GIVE GOOD RETURN
SUBTTL PATH SUPPORT ROUTINES
; RDPATH Routine to Read Path for channel or job
; CALL Using No Arguments
; RETURN With Job's Path in PTHBLK
RDPATH: MOVEI S1,.PTMAX ;CLEAR ANSWER AREA
MOVEI S2,PTHBLK
$CALL .ZCHNK
SETOM PTHBLK ;REQUEST PATH FOR CURRENT JOB
MOVE S1,[.PTMAX,PTHBLK] ;POINT TO BLOCK
PATH. S1,
SETZM PTHBLK ;OOPS -- FAILED
POPJ P,0 ;RETURN
; PPN (EITHER DIRECTORY OR USER NAME FUNCTION)
XCMDIR:
XCMUSR: ;EQUIVALENT
$CALL CMRPTH ;GET PATH SPEC INTO ATOM
MOVEI S1,[ASCIZ/[Project,Programmer]/]
JXN F,CMQUES,HELPER ;GIVE HELP IF REQUESTED
JXN F,CM%ESC,[PUSHJ P,CMDCH ;ALLOW ESCAPE AS TERMINATOR
PUSHJ P,TIELCH
JRST XUSR.1] ;RETURN IN LINE
XUSR.1: MOVE T1,.CMABP(P2) ;POINT TO ATOM
MOVEI T2,CRBLK+CR.RES ;POINT TO DESTINATION
$CALL PATHIN ;PARSE PATH
NOPARS (NPXIUS,Invalid User Specification)
MOVE T1,XXXPTR ;Ensure Entire atom was parsed
CAME T1,ATBPTR
NOPARS (NPXIUS,Invalid User Specification)
JRST XCOMXI ;DONE NOW
;COMMA, ARBITRARY CHARACTER
XCMCMA: MOVEI T1,"," ;SETUP COMMA AS CHARACTER TO FIND
MOVEM T1,FNARG
CMCHR: $CALL 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 [$CALL DOHLP
JXN F,CM%SDH,CMRTYP ;JUMP IF SUPPRESSING HELP
MOVEI S1,"""" ;TYPE "char"
$CALL CMDOUT
HRRZ S1,FNARG
$CALL CMDOUT
MOVEI S1,""""
$CALL CMDOUT
JRST CMRTYP]
NOPARS (NPXCMA,Comma was Expected) ;FAIL
;DATE AND/OR TIME
;FLAGS IN ARG SPECIFY WHICH
XCMTAD: MOVE Q1,FNARG ;GET ARG
$CALL CMRSPC ;READ FIRST FIELD
JXN F,CMQUES,CMTADH ;DO HELP IF REQUESTED
JXN F,CMDEFF,CMTAD1 ;JUMP IF NOW HAVE FIELD DEFAULT
; TXC Q1,CM%IDA+CM%ITM ;DATE AND TIME BOTH?
; TXCN Q1,CM%IDA+CM%ITM
; JRST [MOVEI T1," " ;YES, PUT SPACE IN ATOM BUFFER
; $CALL STOLCH
; $CALL CMRSPC ;READ SECOND FIELD
; JXN F,CMQUES,CMTADH ;DO HELP
; JRST .+1]
CMTAD1: $CALL DATIM ;GET DATE AND TIME
JUMPT CMTAD2 ;CONTINUE ON
MOVEI T1,@DERTBL(S1) ;GET MESSAGE ADDRESS
HRLI T1,NPXBDF ;SET CODE TOO
JRST XCOMNE ;EXIT WITH MSG
CMTAD2: TXNE Q1,CM%NCI ;CONVERT TO INTERNAL FORMAT?
JRST CMTAD3 ;NO .. STORE DATA IN USER BLOCK
MOVEM S1,CRBLK+CR.RES ;STORE RESULT
JRST XCOMXR ;OK, TAD ALREADY IN T2
CMTAD3: MOVEM S1,NOW ;SAVE THE TIME FOR NOW
$CALL CMPDAT ;GET THE VALUE
MOVE S1,VAL9 ;GET CENTURY
IMULI S1,^D100 ;MAKE IT YEARS
MOVE S2,VAL8 ;GET DECADES
IMULI S2,^D10 ;MAKE YEARS ALSO
ADD S2,S1 ;COMBINE THEM
ADD S2,VAL7 ;GET THE YEAR FIELD
HRL S1,S2 ;PLACE IN LEFT HALF
HRR S1,VAL6 ;GET THE MONTH
MOVEM S1,0(Q1) ;SAVE IN THE BLOCK
HRLZ S1,VAL5 ;GET THE MONTH
MOVEM S1,1(Q1) ;SAVE THE SECOND WORD
MOVE S1,SECONDS ;GET SECONDS
HRRZM S1,2(Q1) ;RIGHT HALF OF THIRD WORD
JRST XCOMXR
;TIME/DATE HELP
CMTADH: $CALL 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)
$CALL CMDSTO ;PRINT APPROPRIATE MESSAGE
JRST CMRTYP
SUBTTL DATIM -- DATE AND TIME PARSER
;These routines are called by the .CMTAD function of CPASCN
;for processing date and time data
;
;
; CALL S1/ POINTER TO THE STRING
; S2/ NUMBER OF CHARACTERS IN BUFFER
;
;
; RETURN TRUE S1/ UDT FOR THE TIME
; RETURN FALSE ERROR CODE IN S1
DATIM: $CALL .SAVE1 ;SAVE P1
MOVE S1,.CMABP(P2) ;POINT TO ATOM BUFFER
MOVE S2,.CMABC(P2) ;COUNT IN THE ATOM BUFFER
SUB S2,ATBSIZ ;GET THE ACTUAL COUNT
DMOVEM S1,TIMPTR ;SAVE POINTER AND COUNT
SETZM FLFUTD ;CLEAR THE FUTURE
SETZM FLFUTR ;CLEAR THE VALUES
SETOM VAL1 ;SET DEFAULT VALUES
MOVE S1,[VAL1,,VAL2] ;GET BLT POINTER
BLT S1,VAL9 ;DEFAULT ALL VALUES
$CALL I%NOW ;GET THE CURRENT DATE AND TIME
MOVEM S1,NOW ;SAVE THE TIME
MOVE S1,FNARG ;GET THE ARGS
$CALL GETCHR ;GET A CHARACTER
CAIN S1,"+" ;WAS IT A +
PJRST PLSRTN ;CHECK PLUS ROUTINE
CAIN S1,"-" ;WAS IT A MINUS
PJRST MINRTN ;MINUS ROUTINE
CAIL S1,"0" ;LESS THAN 0
CAILE S1,"9" ;LESS THAN 9
PJRST DATPAR ;NO TRY PARSING THE DATE
$CALL DECBPT ;BACK UP TO FIRST CHARACTER
$CALL DECNUM ;GET THE NUMBER
JUMPF E$$IDT ;INVALID DATE AND TIME
MOVEM S1,DAYNUM ;SAVE THE NUMBER
SKIPN S2,LSTCHR ;GET LAST CHARACTER
PJRST DATI.1 ;SETUP FOR TIMPAR
CAIN S2,"D" ;CHECK IF DAYS
JRST DAYRTN ;PROCESS THE DAYS
CAIE S2,":" ;
PJRST ALTDAT ;TRY THE ALTERNATE DATE FORMS
DATI.1: MOVE S1,.CMABP(P2) ;POINT TO ATOM BUFFER
MOVE S2,.CMABC(P2) ;COUNT IN THE ATOM BUFFER
SUB S2,ATBSIZ ;GET THE ACTUAL COUNT
DMOVEM S1,TIMPTR ;GET BACK TO START
DATI.2: $CALL TIMPAR ;PARSE THE TIME
JUMPF .POPJ ;ERROR..RETURN
PJRST CMPDAT ;COMPUTE THE DATE AND RETURN
SUBTTL TIMPAR -- PARSE THE TIME FIELD
;This routine will parse a time and return
;
;RETURN: S1/ TIME IN SECONDS
; S2/ FRACTION OF DAY IN RH
TIMPAR: MOVE S1,FNARG ;GET THE ARGUMENT FLAGS
TXNN S1,CM%ITM ;TIME WANTED?
PJRST E$$ITF ;TIME FIELD INVALID
SETZM SECOND ;CLEAR SECONDS
SETZM MINUTE ;CLEAR MINUTES
SETZM HOURS ;CLEAR HOURS
$CALL DECNUM ;GET A DECIMAL NUMBER
JUMPF E$$ITF ;INVALID DATE AND TIME FUNCTION
JUMPL S1,E$$ITF ;INVALID DATE AND TIME
MOVEM S1,DAYNUM ;SAVE THE NUMBER
MOVEM S1,SECOND ;SAVE AS SECONDS
MOVE S2,LSTCHR ;GET LAST CHARACTER
CAIN S2,"D" ;WAS IT A D(DAYS)
PJRST E$$RDP ;REQUIRES RELATIVE DATE CHECK
CAIE S2,":" ;WAS IT A COLON
PJRST FINTIM ;FINISH OFF THE TIME
$CALL DECNUM ;GET THE NEXT FIELD
JUMPF E$$ITF ;INVALID DATE AND TIME FUNCTION
JUMPL S1,E$$ITF ;INVALID DATE AND TIME
EXCH S1,SECOND ;GET THE SECONDS AS MINUTES
MOVEM S1,MINUTE ;SAVE THE MINUTES
MOVE S1,LSTCHR ;GET THE LAST CHARACTER
CAIE S1,":" ;WAS IT A COLON
PJRST FINTIM ;FINISH OFF THE TIME
$CALL DECNUM ;GET A DECIMAL NUMBER
JUMPF E$$ITF ;INVALID DATE AND TIME FUNCTION
JUMPL S1,E$$ITF ;INVALID DATE AND TIME
EXCH S1,SECOND ;SAVE AS SECONDS
EXCH S1,MINUTE ;SAVE AS MINUTES
MOVEM S1,HOURS ;SAVE AS HOURS
FINTIM: MOVE S1,SECOND ;GET THE SECONDS
CAIL S1,^D60 ;LESS THAN 60
PJRST E$$ITF ;INVALID DATE AND TIME
MOVEM S1,VAL2 ;SAVE THE SECONDS
MOVE S1,MINUTE ;GET THE MINUTES
CAIL S1,^D60 ;CHECK LESS THAN 60
PJRST E$$ITF ;INVALID DATE AND TIME
MOVEM S1,VAL3 ;SAVE THE MINUTES
MOVE S1,HOURS ;GET THE HOURS
CAIL S1,^D24 ;LESS THAN 24
PJRST E$$ITF ;INVALID DATE AND TIME
MOVEM S1,VAL4 ;SAVE THE HOURS
IMULI S1,^D60 ;CONVERT TO MINUTES
ADD S1,VAL3 ;ADD IN THE MINUTES
IMULI S1,^D60 ;CONVERT TO SECONDS
ADD S1,VAL2 ;ADD IN THE SECONDS
SETZM T1 ;CLEAR OTHER HALF
MOVE S2,S1 ;GET THE VALUE
ASHC S2,-^D17 ;MULTIPLY BY 2**18
DIVI S2,^D24*^D3600 ;DIVIDE BY SECONDS PER DAY
;GET FRACTION OF A DAY IN RH
$RETT ;RETURN TRUE
SUBTTL PLSRTN -- PROCESS DATE WITH "+"
SUBTTL MINRTN -- PROCESS DATE WITH "-"
SUBTTL DAYRTN -- PROCESS DAY "D"
PLSRTN: AOS FLFUTD ;INDICATE IN THE FUTURE
SKIPA ;GET TIME
MINRTN: SOS FLFUTD ;INDICATE IN THE PAST
MINI.1: $CALL TIMPAR ;PARSE THE TIME
JUMPT RELDAY ;O.K. COMPUTE RELATIVE DAY
CAIN S1,E..RDP ;CHECK FOR RELATIVE DATE ERROR
JRST DAYRTN ;YES CHECK OUT DATE
$RETF ;NO..PASS ERROR BACK
RELDAY: SKIPGE FLFUTD ;CHECK THE TIME
MOVN S2,S2 ;PAST.. COMPLEMENT THE TIME
ADD S2,NOW ;GET THE VALUE
MOVE S1,S2 ;GET THE TIME
PJRST DATEXT ;EXIT WITH DATE
DAYRTN: SETZM LSTERR ;CLEAR LAST ERROR
HRLZ S2,DAYNUM ;GET THE NUMBER
SOSG TIMCNT ;ANY CHARACTERS LEFT?
PJRST RELDAY ;NO..COMPUTE THE DAY
$CALL GETCHR ;GET A CHARACTER
JUMPF E$$IDT ;INVALID DATE TIME
CAIE S1,":" ;BETTER BE A COLON
PJRST E$$IDT ;NO..BAD DATE/TIME
HRLZ S2,DAYNUM ;GET THE NUMBER
SKIPGE FLFUTD ;CHECK THE TIME
MOVN S2,S2 ;PAST.. COMPLEMENT THE TIME
ADDM S2,NOW ;GET THE VALUE
PJRST MINI.1 ;YES.. NOW GET DATE
SUBTTL CMPDAT -- COMPUTE THE DATE FROM VALUES
;This routine will default fields with the current values of time
;for those fields that were not input
;HERE WITH VAL2-9 CONTAINING PARSE OR -1 IF TO BE FILLED IN
; STRATEGY IS TO FILL-IN HOLES LESS SIGNIFICANT THAN
; MOST SIGN. FIELD WITH 0; AND TO FILL IN MORE SIGNIFICANT
; HOLES WITH CURRENT VALUE. THEN IF WRONG DIRECTION FROM
; NOW, ADD/SUB ONE TO FIELD JUST ABOVE MOST SIGNIFICANT DIFFERENT
; (FIELD CARRY NOT NEEDED SINCE IT WILL HAPPEN IMPLICITLY).
CMPDAT: MOVE S1,NOW ;GET CURRENT DATE/TIME
$CALL CNTDT ;CONVERT TO EASY FORMAT
;RETURN S1 TIME IN SECONDS
; S2 TIME IN SYSTEM FORMAT
MOVEM S1,SECONDS ;SAVE THE VALUE OF SECONDS
ADD S2,[^D1964*^D12*^D31] ;MAKE REAL
MOVEI T2,8 ;TRY 8 FIELDS
CMPD.1: MOVE S1,S2 ;POSITION REMAINDER
IDIV S1,ADJTBL-1(T2) ;GET THE ADJUSTMENT
SKIPL VAL1(T2) ;SEE IF DEFAULT
JRST [TLNN T1,-1 ;NO--FLAG TO ZERO DEFAULTS
HRL T1,T2 ; SAVING INDEX OF LAST DEFAULT
JRST CMPD.2] ;AND CONTINUE LOOP
SETZM VAL1(T2) ;DEFAULT TO ZERO
TLNN T1,-1 ;SEE IF NEED CURRENT
MOVEM S1,VAL1(T2) ;YES--SET THAT INSTEAD
CMPD.2: CAME S1,VAL1(T2) ;SEE IF SAME AS CURRENT
JRST CMPD.3 ;NO--REMEMBER FOR LATER
CAIN T2,4 ;SEE IF TIME FOR TIME
HRRZ S2,T1 ;YES--GET IT
SOJG T2,CMPD.1 ;LOOP UNTIL ALL DONE
;HERE WHEN FILLED IN CURRENT FOR SIGNIFICANT DEFAULTS
CMPD.3: SKIPGE VAL1(T2) ;SEE IF DEFAULT
SETZM VAL1(T2) ;CLEAR DEFAULT
SOJG T2,CMPD.3 ;LOOP UNTIL DONE
HLRZ P1,T1 ;RECOVER LAST SIGN. DEFAULT-1
JUMPE P1,CMPD.4 ;DONE IF NONE
$CALL MAKDAT ;MAKE CURRENT DATE, TIME
MOVE T2,FLFUTD ;GET DEFAULT DIRECTION
XCT [CAMGE S1,NOW
JFCL
CAMLE S1,NOW]+1(T2) ;SEE IF OK
JRST CMPD.4 ;YES--GO RETURN
SKIPG FLFUTD ;NO--SEE WHICH DIRECTION
SOSA VAL2(P1) ;PAST
AOS VAL2(P1) ;FUTURE
CMPD.4: $CALL MAKDAT ;REMAKE ANSWER
MOVE P1,T1 ;MOVE TO ANSWER
PJRST DATEXT ;DATE EXIT AND RETURN
SUBTTL DATEXT -- DATE EXIT ROUTINE
;THIS ROUTINE WILL CHECK DATE AND RETURN
RADIX 10
DATEXT: TRC S1,-1 ;COMPLEMENT THE LEFT SIDE
TRCN S1,-1 ;CHECK IF -1
AOS S1 ;BUMP S1
CAML S1,[<1964-1859>*365+<1964-1859>/4+<31-18>+31,,0] ;CHECK RANGE
$RETT ;RETURN TRUE
RADIX 8
PJRST E$$DOR ;DATE AND TIME OUT OF RANGE
SUBTTL MAKDAT -- ROUTINE TO MAKE A DATE AND TIME
;THIS ROUTINE WILL TAKE THE VALUES IN VAL1-VAL9 AND
;GENERATE A UDT
MAKDAT: MOVE S1,VAL4 ;GET HOURS
IMULI S1,^D60 ;MAKE INTO MINS
ADD S1,VAL3 ;ADD MINS
IMULI S1,^D60 ;MAKE INTO SECS
ADD S1,VAL2 ;ADD SECS
IMULI S1,^D1000 ;MAKE INTO MILLISECS
MOVE S2,VAL9 ;GET CENTURIES
IMULI S2,^D10 ;MAKE INTO DECADES
ADD S2,VAL8 ;ADD DECADES
IMULI S2,^D10 ;MAKE INTO YEARS
ADD S2,VAL7 ;ADD YEARS
IMULI S2,^D12 ;MAKE INTO MONTHS
ADD S2,VAL6 ;ADD MONTHS
IMULI S2,^D31 ;MAKE INTO DAYS
ADD S2,VAL5 ;ADD DAYS
SUB S2,[^D1964*^D12*^D31] ;REDUCE TO SYSTEM RANGE
DMOVE T1,S1 ;SETUP THE ARGUMENTS
PJRST CNVDT ;CONVERT TO INTERNAL FORM AND RETURN
;ADJUSTMENT FACTORS FOR EACH TIME ELEMENT
ADJTBL: EXP 1
EXP ^D60
EXP ^D60*^D60
EXP 1
EXP ^D31
EXP ^D31*^D12
EXP ^D31*^D12*^D10
EXP ^D31*^D12*^D10*^D10
SUBTTL DATPAR -- PARSE A DATE/DAY FIELD
;This routine will parse a date and save the values of the
;fields that are found
;
;CALL S1/ NUMBER
DATPAR: MOVE S1,FNARG ;GET THE ARGUMENT FLAGS
TXNN S1,CM%IDA ;DATE WANTED?..
PJRST E$$IDT ;INVALID DATE FUNCTION
MOVE S2,LSTCHR ;GET THE LAST CHARACTER
CAIN S2,"-" ;SEPERATOR?
PJRST ALTDAT ;YES.. TRY ALTERNATE DATE FORM
$CALL DECBPT ;DECREMENT THE BYTE POINTER
$CALL GETSTG ;GET A STRING
SKIPT ;O.K. CONTINUE ON
PJRST E$$DTM ;VALUE MISSING IN DATE AND TIME
MOVE P1,S1 ;SAVE THE STRING POINTER
MOVEM S1,STRPTR ;SAVE THE STRING POINTER
MOVEI S1,DAYTBL ;GET THE DAYS TABLE
MOVE S2,P1 ;GET THE POINTER
$CALL S%TBLK ;CHECK THE TABLE
TXNE S2,TL%NOM!TL%AMB ;IS IT AMBIGUOUS OR NO MATCH
JRST datp.5 ;TRY MONTHS OR MNEMONICS
HRRZ P1,(S1) ;GET THE VALUE
HLRZ S2,NOW ;GET DAYS
IDIVI S2,7 ;GET DAY OF WEEK
SUB P1,T1 ;GET FUTURE DAYS FROM NOW
SKIPGE P1 ;IF NEGATIVE,
ADDI P1,7 ; MAKE LATER THIS WEEK
HLLZ S1,NOW ;CLEAR CURRENT
SKIPL FLFUTD ;SEE IF FUTURE
TROA S1,-1 ;YES--SET MIDNIGHT MINUS EPSILON
SUBI P1,7 ;NO--MAKE PAST
HRLZ P1,P1 ;POSITION TO LEFT HALF
ADD P1,S1 ;MODIFY CURRENT DATE/TIME
DATP.1: MOVEM P1,TIMSAV ;SAVE THE TIME
SKIPG TIMCNT ;ANY MORE CHARACTERS
JRST [ MOVE S1,TIMSAV ;GET THE SAVED TIME
JRST DATP.3] ;FINISH OFF THE TIME
MOVE S1,LSTCHR ;CHECK THE LAST CHARACTER
CAIE S1,":" ;WAS IT A :
JRST E$$IDT ;GENERATE AN ERROR
DATP.2: $CALL TIMPAR ;PARSE THE TIME FIELD
SKIPT ;SKIP IF TRUE
PJRST E$$ITF ;INVALID TIME FIELD
HLL S1,TIMSAV ; TO ANSWER
HRR S1,S2 ;PLACE THE PORTION OF DAY IN RH
DATP.3: SKIPG FLFUTR ;SKIP IF FUTURE
JRST DATP.4 ;ADJUST PAST RESULT
CAMGE S1,NOW ;IF NOT FUTURE, MUST HAVE
;WANTED A WEEK FROM TODAY,
;BUT EARLIER IN THE DAY.
ADD S1,[7,,0] ;MAKE TIME NEXT WEEK
JRST DATEXT ;CHECK AND RETURN
DATP.4: MOVE S2,S1 ;SIMILAR TEST FOR PAST
ADD S2,[7,,0] ;ADD A WEEK TO PAST TIME
CAMG S2,NOW ;WAS TIME OVER A WEEK AGO?
MOVE S1,S2 ;YES, USE NEW ONE
JRST DATEXT ;CHECK ANSWER AND RETURN
DATP.5: $CALL MONPAR ;TRY TO PARSE A MONTH
JUMPF MNMPAR ;TRY A MNEMONIC
MOVE S1,LSTCHR ;GET THE LAST CHARACTER
CAIE S1,"-" ;MUST BE DAY NEXT
PJRST E$$MDS ;MISSING DAY IN DATE /TIME
$CALL DECNUM ;GET DECIMAL NUMBER
JUMPLE S1,E$$NND ;NEGATIVE NUMBER
CAILE S1,^D31 ;VERIFY IN RANGE
JRST E$$DFL ;ERROR IF TOO LARGE
MOVEM S1,VAL5 ;SAVE AWAY
PJRST YEARPR ;PARSE THE YEAR
SUBTTL ALTDAT -- PARSE ALTERNATE DATE FORM
;This routine will check dates in the form DD-MMM-YY
; MM-DD-YY
ALTDAT: CAILE S1,^D31 ;IS IT A VALID DAY?
PJRST E$$DFL ;NO..GIVE ERROR
SKIPN P1 ;CHECK IF ZERO?
PJRST E$$DFZ ;FIELD ZERO IN DATE/TIME
MOVEM S1,VAL5 ;SAVE VALUE
$CALL GETCHR ;SKIP OVER MINUS
JUMPF E$$IDT ;INVALID DATE AND TIME
CAIL S1,"0" ;SEE IF DIGIT NEXT
CAILE S1,"9" ; ..
JRST ALTD.1 ;SETUP FOR MONTH
$CALL DECNUM ;YES-- MUST BE MM-DD FORMAT
JUMPLE S1,E$$NND ;BAD IF LE 0
CAILE S1,^D31 ;VERIFY LE 31
JRST E$$DFL ;BAD
EXCH S1,VAL5 ;SWITCH VALUES
CAILE S1,^D12 ;VERIFY MONTH OK
JRST E$$DFL ;BAD
MOVEM S1,VAL6 ;SAVE THE MONTH
PJRST YEARPR ;NOW PARSE THE YEAR
ALTD.1: $CALL DECBPT ;BACKUP POINTER
$CALL GETSTG ;GET THE STRING
JUMPF E$$IDT ;INVALID DATE AND TIME
MOVE P1,S1 ;SAVE THE POINTER
$CALL MONPAR ;CHECK FOR MONTH
JUMPF .POPJ ;ERROR..RETURN
PJRST YEARPR ;PARSE THE YEAR
SUBTTL MONPAR -- ROUTINE TO CHECK FOR A MONTH
MONPAR: MOVE S1,FNARG ;GET THE ARGUMENT FLAGS
TXNN S1,CM%IDA ;DATE WANTED?..
PJRST E$$IDT ;INVALID DATE FUNCTION
MOVEI S1,MONTBL ;GET THE DAYS TABLE
MOVE S2,P1 ;GET THE POINTER
$CALL S%TBLK ;CHECK THE TABLE
TXNE S2,TL%NOM!TL%AMB ;IS IT AMBIGUOUS OR NO MATCH
$RETF ;RETURN FALSE
HRRZ P1,(S1) ;GET MONTH INDEX
MOVEM P1,VAL6 ;YES--STORE MONTH
$RETT ;RETURN TRUE
SUBTTL YEARPR -- PARSE THE YEAR
;THIS ROUTINE WILL PARSE A YEAR
YEARPR: MOVE S1,LSTCHR ;GET THE LAST CHARACTER
CAIE S1,"-" ;SEE IF YEAR NEXT
JRST YEAR.3 ;NO--GO HANDLE TIME
;HERE WHEN YEAR NEXT AS ONE, TWO, OR FOUR DIGITS
SETZB T3,T4 ;CLEAR DIGIT AND RESULT COUNTERS
YEAR.1: $CALL GETCHR ;GET NEXT DIGIT
CAIL S1,"0" ;SEE IF NUMERIC
CAILE S1,"9" ; ..
JRST YEAR.2 ;NO--MUST BE DONE
IMULI T3,^D10 ;ADVANCE RESULT
ADDI T3,-"0"(S1) ;INCLUDE THIS DIGIT
AOJA T4,YEAR.1 ;LOOP FOR MORE, COUNTING DIGIT
YEAR.2: JUMPE T4,E$$ILR ;ERROR IF NO DIGITS
CAIE T4,3 ;ERROR IF 3 DIGITS
CAILE T4,4 ;OK IF 1,2, OR 4
JRST E$$ILR ;ERROR IF GT 4 DIGITS
MOVE S2,T3 ;GET RESULT
IDIVI S2,^D100 ;SEP. CENTURY
IDIVI T1,^D10 ;SEP. DECADE
CAIG T4,2 ;IF ONE OR TWO DIGITS,
SETOM S2 ; FLAG NO CENTURY KNOWN
CAIN T4,1 ;IF ONE DIGIT,
SETOM T1 ; FLAG NO DECADE KNOWN
MOVEM T2,VAL7 ;SAVE UNITS
MOVEM T1,VAL8 ;SAVE DECADE
MOVEM S2,VAL9 ;SAVE CENTURY
;HERE WITH VAL5-9 CONTAINING DAY, MONTH, YEAR, DECADE, CENTURY
YEAR.3: SOS VAL5 ;MAKE DAYS 0-30
SOS VAL6 ;MAKE MONTHS 0-11
SKIPG TIMCNT ;ANY MORE CHARACTERS
JRST YEAR.5 ;NO..FINISH TIME NOW
MOVE S1,LSTCHR ;CHECK THE LAST CHARACTER
CAIE S1,":" ;WAS IT A :
JRST E$$IDT ;GENERATE AN ERROR
YEAR.4: $CALL TIMPAR ;GET THE TIME
SKIPT ;SKIP IF TRUE
PJRST E$$ITF ;INVALID TIME FIELD
PJRST CMPDAT ;COMPUTE THE DATE AND RETURN
;HERE IF FUTURE WITHOUT TIME
YEAR.5: SKIPG FLFUTD ;FUTURE TIME?
PJRST CMPDAT ;NO.. JUST GET DATE NOW
MOVEI S1,^D59 ;SET TO
MOVEM S1,VAL2 ; 23:59:59
MOVEM S1,VAL3 ; ..
MOVEI S1,^D23 ; ..
MOVEM S1,VAL4 ; ..
PJRST CMPDAT ;COMPUTE THE DATE
SUBTTL CNVDT -- CONVERT DATE TO UDT
;THIS ROUTINE WILL MAKE A UDT OUT OF AN ARBITRAY DATE
;
;CALL S1/ TIME IN SECONDS
; S2/ DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64
;
;RETURN S1/ UDT
;
;NOTE: LEFT HALF DIVIDED BY 7 GIVES THE DAY OF THE WEEK
RADIX 10
;UNDER RADIX 10 **** NOTE WELL ****
CNVDT:: $CALL .SAVET ;PRESERVE T3
PUSH P,S1 ;SAVE TIME FOR LATER
IDIVI S2,12*31 ;S2=YEARS-1964
CAILE S2,2217-1964 ;SEE IF BEYOND 2217
JRST GETNW2 ;YES--RETURN -1
IDIVI T1,31 ;T1=MONTHS-JAN, T2=DAYS-1
ADD T2,MONTAB(T1) ;T2=DAYS-JAN 1
MOVEI T3,0 ;LEAP YEAR ADDITIVE IF JAN, FEB
CAIL T1,2 ;CHECK MONTH
MOVEI T3,1 ;ADDITIVE IF MAR-DEC
MOVE S1,S2 ;SAVE YEARS FOR REUSE
ADDI S2,3 ;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED
IDIVI S2,4 ;HANDLE REGULAR LEAP YEARS
CAIE T1,3 ;SEE IF THIS IS LEAP YEAR
MOVEI T3,0 ;NO--WIPE OUT ADDITIVE
ADDI T2,<1964-1859>*365+<1964-1859>/4+<31-18>+31(S2)
;T2=DAYS BEFORE JAN 1,1964 +SINCE JAN 1
; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64
MOVE S2,S1 ;RESTORE YEARS SINCE 1964
IMULI S2,365 ;DAYS SINCE 1964
ADD T2,S2 ;T2=DAYS EXCEPT FOR 100 YR. FUDGE
HRREI S2,64-100-1(S1) ;S2=YEARS SINCE 2001
JUMPLE S2,GETNW1 ;ALL DONE IF NOT YET 2001
IDIVI S2,100 ;GET CENTURIES SINCE 2001
SUB T2,S2 ;ALLOW FOR LOST LEAP YEARS
CAIE T1,99 ;SEE IF THIS IS A LOST L.Y.
GETNW1: ADD T2,T3 ;ALLOW FOR LEAP YEAR THIS YEAR
CAILE T2,^O377777 ;SEE IF TOO BIG
GETNW2: SETOM T2 ;YES--SET -1
POP P,S1 ;GET MILLISEC TIME
MOVEI S2,0 ;CLEAR OTHER HALF
ASHC S1,-17 ;POSITION
DIV S1,[24*60*60*1000] ;CONVERT TO 1/2**18 DAYS
CAMLE S2,[^D24*^D60*^D60*^D1000/2] ; OVER 1/2 TO NEXT?
ADDI S1,1 ;YES, SHOULD ACTUALLY ROUND UP
HRL S1,T2 ;INCLUDE DATE
GETNWX: POPJ P, ;RETURN
RADIX 8
SUBTTL CNTDT - Convert UDT to TOPS-10 DATE UUO Time and Seconds
; This routine gratefully stolen from SCAN
;
;Call: MOVE S1,DATE/TIME
; PUSHJ P,.CNTDT
; Return with T1=Seconds since Midnight, 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,S1 ;SAVE TIME FOR LATER
JUMPL S1,CNTDT6 ;DEFEND AGAINST JUNK INPUT
HLRZ S1,S1 ;GET DATE PORTION (DAYS SINCE 1858)
RADIX 10 ;**** NOTE WELL ****
ADDI S1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17
;S1=DAYS SINCE JAN 1, 1501
IDIVI S1,400*365+400/4-400/100+400/400
;SPLIT INTO QUADRACENTURY
LSH S2,2 ;CONVERT TO NUMBER OF QUARTER DAYS
IDIVI S2,<100*365+100/4-100/100>*4+400/400
;SPLIT INTO CENTURY
IORI T1,3 ;DISCARD FRACTIONS OF DAY
IDIVI T1,4*365+1 ;SEPARATE INTO YEARS
LSH T2,-2 ;T2=NO DAYS THIS YEAR
LSH S1,2 ;S1=4*NO QUADRACENTURIES
ADD S1,S2 ;S1=NO CENTURIES
IMULI S1,100 ;S1=100*NO CENTURIES
ADDI S1,1501(T1) ;S1 HAS YEAR, S2 HAS DAY IN YEAR
MOVE S2,S1 ;COPY YEAR TO SEE IF LEAP YEAR
TRNE S2,3 ;IS THE YEAR A MULT OF 4?
JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR
IDIVI S2,100 ;SEE IF YEAR IS MULT OF 100
SKIPN T1 ;IF NOT, THEN LEAP
TRNN S2,3 ;IS YEAR MULT OF 400?
TDZA T1,T1 ;YES--LEAP YEAR AFTER ALL
CNTDT0: MOVEI T1,1 ;SET LEAP YEAR FLAG
;T1 IS 0 IF LEAP YEAR
;UNDER RADIX 10 **** NOTE WELL ****
CNTDT1: SUBI S1,1964 ;SET TO SYSTEM ORIGIN
IMULI S1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS
JUMPN T1,CNTDT2 ;IF NOT LEAP YEAR, PROCEED
CAIGE T2,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29
JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER
SOS T2 ;YES--BACK OFF ONE DAY
CNTDT2: MOVSI S2,-11 ;LOOP FOR 11 MONTHS
CNTDT3: CAMGE T2,MONTAB+1(S2) ;SEE IF BEYOND THIS MONTH
JRST CNTDT4 ;YES--GO FINISH UP
ADDI S1,31 ;NO--COUNT SYSTEM MONTH
AOBJN S2,CNTDT3 ;LOOP THROUGH NOVEMBER
CNTDT4: SUB T2,MONTAB(S2) ;GET DAYS IN THIS MONTH
CNTDT5: ADD S1,T2 ;INCLUDE IN FINAL RESULT
CNTDT6: SKIPGE S1 ;TEST FOR JUNK
SETZ S1,0
EXCH S1,(P) ;SAVE ANSWER, GET TIME
TLZ S1,-1 ;CLEAR DATE
MULI S1,<EXP 24*60*60> ;CONVERT TO SECONDS/DAY
DIV S1,[1B17] ;SHIFT BINARY POINT
CAIL S2,<EXP 1B18> ;ROUND UP?
ADDI S1,1 ;YES, DO SO
POP P,S2 ;RECOVER DATE
$RETT ;RETURN
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
RADIX 8 ;BACK TO USUAL RADIX
SUBTTL MNMPAR -- PARSE MNEMONICS
;THIS ROUTINE WILL CHECK FOR MNEMONICS
MNMPAR: PJRST E$$IDT ;INVALID DATE AND TIME
COMMENT \
HRRZ S2,S1 ;GET COPY
CAIN S2,SPLGTM ;SEE IF "LOGIN"
SKIPG P1,LOGTIM ;AND WE KNOW IT
SKIPA ;NO--PROCEED
JRST DATEXT ;YES--GO GIVE ANSWER
CAIN S2,SPNOON ;SEE IF "NOON"
JRST [HLLZ P1,NOW ;YES--GET TODAY
HRRI P1,1B18 ;SET TO NOON
JRST DATP.1] ;GO FINISH UP
CAIN S2,SPMIDN ;SEE IF "MIDNIGHT"
JRST [HLLZ P1,NOW ;GET TODAY
JRST DATIMO] ;GO SET TO MIDNIGHT
SUBI S2,SPCDAY ;SUBTRACT OFFSET TO SPECIAL DAYS
CAILE S2,2 ;SEE IF ONE OF THREE
JRST E.MDS ;NO--UNSUPPORTED
HLRZ P1,NOW ;YES--GET TODAY
ADDI P1,-1(S2) ;OFFSET IT
HRLZS P1 ;POSITION FOR ANSWER
DATIMO: SKIPL FLFUTD ;SEE IF FUTURE
TRO P1,-1 ;YES--SET TO MIDNIGHT MINUS EPSILON
JRST DATP.1 ;AND GO FINISH UP
;HERE IF UNSUPPORTED MNEMONIC
E.MDS: MOVE P1,(S1) ;GET NAME OF SWITCH
PJRST E$$MDS ;MNEMONIC DATE/TIME NOT IMPLEMENTED
DEFINE XX($1),<
EXP <SIXBIT /$1/>>
SPCDAY: XX YESTERDAY
XX TODAY
XX TOMORROW
SPLGTM: XX LOGIN
SPNOON: XX NOON
SPMIDN: XX MIDNIGHT
SPDATM: XX LUNCH
XX DINNER
LSPDTM==.-SPCDAY
\;END OF COMMENT
SUBTTL GETCHR -- GET A CHARACTER FROM TIME FIELD
;This Routine will return a character from the time field
;
;RETURN TRUE: S1/ CHARACTER
;
;RETURN FALSE: NO MORE DATA
GETCHR: SOSGE TIMCNT ;ANY CHARACTERS LEFT?
PJRST GETC.1 ;ERROR..RETURN
ILDB S1,TIMPTR ;GET A CHARACTER
CAIL S1,"a" ;LOWER CASE A
CAILE S1,"z" ;LOWER CASE Z
SKIPA ;MUST BE O.K.
SUBI S1,40 ;MAKE UPPER CASE
MOVEM S1,LSTCHR ;SAVE LAST CHARACTER
$RETT ;RETURN TRUE
GETC.1: SETZM LSTCHR ;CLEAR LAST CHARACTER
$RETF ;RETURN FALSE
SUBTTL DECNUM -- GET A DECIMAL NUMBER
;This routine will return a decimal number from the time field
;
;RETURN TRUE S1/ DECIMAL NUMBER
DECNUM: SKIPG TIMCNT ;ANY CHARACTERS LEFT
$RETF ;NONE.. RETURN FALSE
MOVE S1,TIMPTR ;GET THE POINTER
MOVEI S2,^D10 ;GET THE RADIX (DECIMAL)
$CALL NUMIN ;GET THE NUMBER
JUMPF .POPJ ;ERROR...RETURN
DECN.1: IBP TIMPTR ;BUMP THE TIME POINTER
CAMN S1,TIMPTR ;ARE WE AT THE RIGHT PLACE
JRST DECN.2 ;YES.. FINISH UP
SOS TIMCNT ;DECREMENT TIME COUNT
JRST DECN.1 ;KEEP GOING
DECN.2: MOVE S1,S2 ;PLACE NUMBER IN S1
LDB S2,TIMPTR ;GET LAST CHARACTER
CAIL S2,"a" ;LOWER CASE A
CAILE S2,"z" ;LOWER CASE Z
SKIPA ;MUST BE O.K.
SUBI S2,40 ;MAKE UPPER CASE
MOVEM S2,LSTCHR ;SAVE LAST CHARACTER
$RETT ;RETURN TRUE
SUBTTL DECBPT -- DECREMENT THE BYTE POINTER
;THIS ROUTINE WILL DECREMENT THE TIME BYTE POINTER
DECBPT: MOVE S1,TIMPTR ;GET CURRENT POINTER
$CALL DBP ;DECREMENT THE BYTE POINTER
MOVEM S1,TIMPTR ;SAVE THE POINTER
AOS TIMCNT ;BUMP THE CHARACTER COUNT
$RETT ;RETURN
SUBTTL GETSTG -- GET A STRING TO WORK FROM
;THIS ROUTINE WILL GET A STRING FROM THE INPUT BUFFER AND BREAK ON
;A SEPERATOR
; RETURN S1/ POINTER TO THE STRING
GETSTG: $CALL .SAVE1 ;SAVE AN AC
SETZM STRDAT ;CLEAR STRING DATA
HRLI P1,STRDAT ;ADDRESS OF FIRST ONE
HRRI P1,1+STRDAT ;GET THE SECONDE WORD
BLT P1,4+STRDAT ;CLEAR THE DATA
HRLI P1,(POINT 7) ;GET POINTER
HRRI P1,STRDAT ;AND ADDRESS
GETS.1: $CALL GETCHR ;GET A CHARACTER
JUMPF GETS.3 ;NO MORE.. FINISH AND RETURN
CAIE S1,40 ;IS IT A BLANK?
CAIN S1,"-" ;OR A SEPERATOR
JRST GETS.3 ;YES..CHECK IF SEEN ANYTHING
CAIN S1,":" ;WAS IT A SEPERATOR?
JRST GETS.3 ;YES..CHECK IS SEEN ANYTHING
CAIL S1,"A"+40 ;LOWER CASE A
CAILE S1,"Z"+40 ;OR GREATER THAN LC Z
SKIPA ;IGNORE ADJUSTMENT
SUBI S1,40 ;MAKE IT UPPER CASE
CAIL S1,"0" ;IS IT 0 NUMBER OR UPPER CASE
CAILE S1,"Z" ;CHECK CHARACTER
JRST GETS.3 ;SETUP THE RETURN
GETS.2: IDPB S1,P1 ;SAVE THE CHARACTER
JRST GETS.1 ;GET NEXT ONE
GETS.3: SKIPN STRDAT ;ANY DATA SETUP?
$RETF ;NO..RETURN FALSE
MOVE S1,[POINT 7,STRDAT] ;GET POINTER TO DATA
$RETT ;RETURN TRUE
;LOCAL ROUTINE TO SETUP BYTE PTR TO TABLE STRING AND GET FLAGS
; T2/ ADDRESS OF STRING
; $CALL 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
TOPS10 <
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
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
>;END TOPS10
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: $CALL .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)
$CALL 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
; $CALL 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: $CALL .SAVET ;SAVE SOME REGISTERS
DMOVE T1,S1 ;COPY INPUT ARGUMENTS
$CALL 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:: $CALL .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
$CALL CHKTBS ;CONSTRUCT POINTER
MOVE T1,STRG ;GET TEST STRING
$CALL USTCMP ;COMPARE
JUMPN T1,TABLK1 ;JUMP IF NOT EXACTLY EQUAL
TABLKF: HLRZ T2,@P2 ;GET STRING ADDRESS
$CALL 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
$CALL CHKTBS ;BUILD BYTE PTR
MOVE T1,STRG ;GET TEST STRING
$CALL 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
$CALL CHKTBS ;BUILD BYTE PTR
MOVE T1,STRG ;GET TEST STRING
$CALL 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
$CALL CHKTBS
JXN T1,CM%NOR,TABLKM ;FAIL IF NOREC BIT SET
MOVX T2,TL%ABR ;GIVE LEGAL ABBREVIATION RETURN
MOVE T3,REMSTR ;RETURN PTR TO REMAINDER OF STRING
JRST TABLKA
;HERE WHEN PROBE NOT EQUAL
TABLKN: CAIG P3,1 ;INCREMENT NOW 1?
JRST [JXN T1,SC%LSS,TABLKX ;YES, NO MATCH FOUND
AOJA P1,TABLKX] ;IF STRING GREATER, BUMP ADR FOR INSERT
AOS P3 ;NEXT INC = <INC+1>/2
ASH P3,-1
TXNE T1,SC%GTR ;IF LAST PROBE LOW, ADD INCREMENT
ADD P1,P3
TXNE T1,SC%LSS
SUB P1,P3 ;LAST PROBE HIGH, SUBTRACT INCR
TBLKN1: CAIL P1,0(P4) ;AFTER END OF TABLE?
JRST [MOVX T1,SC%LSS ;YES, FAKE PROBE TOO HIGH
JRST TABLKN]
JUMPGE P1,TABLK0 ;IF STILL WITHIN TABLE RANGE, GO PROBE
MOVX T1,SC%GTR ;BEFORE START OF TABLE, FAKE LOW PROBE
JRST TABLKN
> ;END TOPS10 CONDITIONAL
SUBTTL S%TBAD -- Table Add Routine
;THIS ROUTINE IS DESIGNED TO ADD AN ENTRY TO A COMMAND
;TABLE AND IS CALLED WITH THE FOLLOWING INFO
;
; CALL WITH: S1/ ADDRESS OF TABLE HEADER
; S2/ ADDRESS OF ENTRY TO BE ADDED
;
;
; RETURNS TRUE: S1/ ADDRESS IN TABLE OF NEW ENTRY IN AC1
;
; RETURNS FALSE: S1/ ERROR CODE
;
;POSSIBLE ERRORS: ERTBF$ -- TABLE IS FULL
; EREIT$ -- ENTRY ALREADY IN TABLE
;
;
TOPS20 <
S%TBAD: TBADD% ;DO THE JSYS
ERJMP TBAD.1 ;TRAB THE ERROR JUMP
$RETT ;RETURN TRUE
TBAD.1: MOVEI S1,.FHSLF ;GET THE LAST ERROR
GETER% ;GET THE LAST ERROR
HRRZ S2,S2 ;GET JUST THE CODE
SETZ S1, ;CLEAR S1
CAIN S2,TADDX1 ;WAS IT TABLE IS FULL
MOVEI S1,ERTBF$ ;TABLE IS FULL
CAIN S2,TADDX2 ;ENTRY ALREADY IN TABLE
MOVEI S1,EREIT$ ;ENTRY ALREADY IN TABLE
JUMPN S1,.RETF ;NON-ZERO..RETURN FALSE
$STOP(UTR,UNRECOGNIZED TABLE ADD RETURN CODE)
>;END TOPS20 CONDITIONAL
TOPS10 <
S%TBAD: $CALL .SAVET ;SAVE THE T REGS
MOVEM S1,TBADDR ;SAVE TABLE ADDRESS
MOVEM S2,ENTADR ;SAVE ENTRY ADDRESS
HLRZ S2,S2 ;BUILD STRING POINTER FOR STRING
HRLI S2,(POINT 7,0) ;FINISH OFF POINTER
$CALL S%TBLK ;CHECK FOR ENTRY IN TABLE
TXNE S2,TL%EXM ;ENTRY IN TABLE
$RETE(EIT) ;ENTRY ALREADY IN TABLE
;S1 ADDRESS WHERE TO PLACE THE ENTRY
MOVE S2,TBADDR ;GET ADDRESS OF TABLE
HLRZ T2,0(S2) ;GET NUMBER OF ENTRIES IN USE
AOS T2 ;BUMP THE COUNT
HRRZ T1,0(S2) ;GET THE TABLE SIZE
CAMLE T2,T1 ;ROOM IN TABLE
$RETE(TBF) ;TABLE IS FULL
HRLM T2,0(S2) ;UPDATE THE ENTRY COUNT
ADD T2,S2 ;COMPUTE NEW END OF TABLE
TBAD.1: CAML S1,T2 ;AT HOLE:
JRST [ MOVE T1,ENTADR ;YES..INSERT THE ENTRY
MOVEM T1,0(S1) ;PLACE IN TABLE
$RETT] ;RETURN TRUE
MOVE T1,-1(T2) ;MOVE TABLE TO CREATE HOLE
MOVEM T1,0(T2) ;PLACE IN NEW LOCATION
SOJA T2,TBAD.1 ;CHECK NEXT ENTRY
>;END TOPS10 CONDITIONAL
SUBTTL S%TBDL -- Table Delete Routine
;THIS ROUTINE IS DESIGNED TO DELETE AN ENTRY TO A COMMAND
;TABLE AND IS CALLED WITH THE FOLLOWING INFO
;
; CALL WITH: S1/ ADDRESS OF TABLE HEADER
; S2/ ADDRESS OF ENTRY TO BE DELETED
;
;
; RETURNS TRUE: S1/ ADDRESS IN TABLE OF NEW ENTRY IN AC1
;
; RETURNS FALSE: S1/ ERROR CODE
;
;POSSIBLE ERRORS: ERTBF$ -- TABLE IS FULL
; ERITE$ -- INVALID TABLE ENTRY
;
;
TOPS20 <
S%TBDL: TBDEL% ;DO THE JSYS
ERJMP TBDL.1 ;TRAB THE ERROR JUMP
$RETT ;RETURN TRUE
TBDL.1: MOVEI S1,.FHSLF ;GET THE LAST ERROR
GETER% ;GET THE LAST ERROR
HRRZ S2,S1 ;GET JUST THE CODE
SETZ S1, ;CLEAR S1
CAIN S2,TDELX1 ;WAS IT TABLE IS FULL
MOVX S1,ERTBF$ ;TABLE IS FULL
CAIN S2,TDELX2 ;ENTRY ALREADY IN TABLE
MOVX S1,ERITE$ ;ENTRY ALREADY IN TABLE
JUMPN S1,.RETF ;NON-ZERO..RETURN FALSE
$STOP (UTR,<unrecognized table return code>)
>;END TOPS20 CONDITIONAL
TOPS10 <
S%TBDL: $CALL .SAVET ;SAVE THE T REGS
HLRZ T2,0(S1) ;GET USED COUNT
MOVE T1,T2 ;PLACE IN T1
SOSGE T1 ;DECREMENT..SKIP IF NOT ZERO
$RETE(TBF) ;FALSE RETURN..TABLE IS FULL
ADD T2,S1 ;COMPUTE END OF TABLE
CAILE S2,(S1) ;ENTRY IN TABLE
CAMLE S2,T2 ;MAKE SURE
$RETE(ITE) ;INVALID TABLE ENTRY
HRLM T1,0(S1) ;SAVE COUNT
JUMPE T1,TBDL.1 ;TABLE EMPTY
HRLI S2,1(S2) ;COMPACT TABLE
BLT S2,-1(T2) ;MOVE THE TABLE
TBDL.1: SETZM 0(T2) ;CLEAR EMPTY WORD AT END
$RETT ;RETURN TRUE
>;END TOPS10 CONDITIONAL
SCN%L: ;LABEL THE LITERAL POOL
PRGEND
TITLE CPAFLO -- PARSES AND CONVERTS FLOATING PT NUMS
SEARCH CPASYM
TOPS10 < ;FLOAT ROUTINE NEEDED ON 10 ONLY
PROLOG(CPAFLO)
;THE SYNTAX ANALYSIS FOR THE SINGLE AND DOUBLE PRECISION INPUT
;IS STATE TABLE DRIVEN. EACH NEW INPUT CHARACTER IS CONVERTED TO
;A CHARACTER TYPE AND COMBINED WITH THE OLD "STATE". THIS RESULT
;IS THEN LOOKED UP IN THE TABLE "NXTSTA" TO GET THE NEW STATE AND
;AN INDEX INTO THE "XCTTAB" TABLE TO DISPATCH FOR THE INPUT
;CHARACTER. THE STATE TABLE LOGIC AND THE DISPATCH ROUTINES BUILD
;THREE RESULTS: A DOUBLE PRECISION INTEGER(IN B,C) FOR THE FRACTIONAL
;PART OF THE RESULT, AN INTEGER(IN XP) FOR THE EXPONENT AFTER
;"D" OR "E", AND A COUNTER(IN "X") TO KEEP TRACK OF THE DECIMAL POINT.
;WHEN A TERMINATING CHARACTER IS FOUND, THE DOUBLE PRECISION INTEGER
;IS NORMALIZED TO THE LEFT TO GIVE A DOUBLE PRECISION FRACTION.
;THE DECIMAL POINT POSITION(FROM "X")OR THE IMPLIED DECIMAL POINT
;POSITION FROM THE FORMAT STATEMENT, THE "D" OR "E" EXPONENT, AND ANY
;SCALING FROM THE FORMAT STATEMENT ARE COMBINED INTO A DECIMAL
;EXPONENT. THIS DECIMAL EXPONENT IS USED AS AN INDEX INTO A POWER
;OF TEN TABLE (KEPT IN DOUBLE PRECISION INTEGER PLUS EXPONENT FORM
;SO INTERMEDIATE RESULTS WILL HAVE 8 MORE BITS OF PRECISION THAN
;FINAL RESULTS) TO MULTIPLY THE DOUBLE PRECISION FRACTION. THIS
;RESULT IS THEN ROUNDED TO GIVE A SINGLE PRECISION,
;PDP6/KI10 DOUBLE PRECISION RESULT.
;OVERFLOWS RETURN THE LARGEST POSSIBLE
;NUMBER (WITH CORRECT SIGN), WHILE UNDERFLOWS RETURN 0. NO ERROR
;MESSAGE IS GIVEN FOR EITHER OVER OR UNDERFLOW.
;OLD ACCUMULATOR DEFINITIONS
F==0 ;FLAG AC
T1==1
ST==2 ;STATES (USES ST+1 TOO)
;ST USED UP TO ENDF/ A&B AFTER THAT
A==2 ;RET DIRECTLY IN THIS AC
B==3 ;RESULT RETURNED IN A OR A AND B
C==4 ;B,C, AND D ARE USED AS A MULTIPLE PRECISION
D==5 ; REGISTER FOR DOUBLE PRECISION OPERATIONS
E==6 ;EXTRA AC
; THESE AC'S MUST BE PRESERVED
XP==7 ;EXPONENT AFTER D OR E
BXP==10 ;BINARY EXP
X==11 ;COUNTS DIGITS AFTER POINT
;RIGHT HALF FLAGS IN AC "F"
DOTFL==1 ;DOT SEEN
MINFR==2 ;NEGATIVE FRACTION
MINEXP==4 ;NEGATIVE EXPONENT
EXPFL==10 ;EXPONENT SEEN IN DATA (MAY BE 0)
DPFLG==20 ;VARIABLE IS DOUBLE PRECISION
EEFLG==40 ;VARIABLE IS EXTENDED EXPONENT
LOCFLG==DOTFL+MINFR+MINEXP+EXPFL+DPFLG+EEFLG
;INPUT CHARACTER TYPES
CRTYP==1 ;CARRIAGE RETURN
DOTTYP==2 ;DECIMAL POINT
DIGTYP==3 ;DIGITS 0-9
SPCTYP==4 ;SPACE OR TAB
EXPTYP==5 ;D OR E
PLSTYP==6 ;PLUS SIGN (+)
MINTYP==7 ;MINUS SIGN (-)
;ANYTHING ELSE IS TYPE 0
$IMPURE
IN.PTR: 0 ;BP TO FL NUM
SUBTTL PROCEDURE TO PARSE AND CONVERT FLOATING PT NUM
$PURE
FLIN::
; ARGUMENTS:
; 1 = BYTE PTR TO ASCIZ NUMBER
; RETURNS:
; TRUE/FALSE
; 1 = UPDATED BP
; 2 = COMPUTED VALUE
PUSH P,7 ;SAVE PERM AC'S
PUSH P,10
PUSH P,11
MOVEM 1,IN.PTR ;PERMANIZE INPUT ARG
SETZB C,D ;INIT D.P. FRACTION
SETZB ST,XP ;INIT STATE AND DECIMAL EXPONENT
SETZB X,F ;INIT "DIGITS AFTER POINT" COUNTER & FLAGS
JRST GETCH1 ;[354] PROCESS FIELD
GETNXT:
LSH ST,-^D30 ;MOVE STATE TO BITS 30-32
GETCH1: ILDB T1,IN.PTR ;GET NEXT CHAR
JUMPE T1,ENDF ;HIT NUL YET? IF SO, DONE
GETCH2: CAIL T1,"0" ;CHECK FOR NUMBER
CAILE T1,"9"
JRST CHRTYP ;NO, TRY OTHER
SUBI T1,"0" ;CONVERT TO NUMBER
GOT1: IORI ST,DIGTYP ;SET TYPE
GOTST: LSHC ST,-2 ;DIVIDE BY NUMBER OF BYTES IN WORD
TLNE ST+1,(1B0) ;TEST WHICH HALF
SKIPA ST,NXTSTA(ST) ;RIGHT HALF (BYTES 2 OR 3)
HLRZ ST,NXTSTA(ST) ;UNFORTUNATELY BYTES 0 OR 1
TLNN ST+1,(1B1) ;WHICH QUADRANT
LSH ST,-9 ;BYTES 0 OR 2
ANDI ST,777 ;LEAVE ONLY RIGHT MOST QUARTER
ROT ST,-3 ;PUT DISPATCH ADDRESS IN BITS 32-35
; AND NEW STATE IN BITS 0-2
XCT XCTTAB(ST) ;DISPATCH OR EXECUTE
JRST GETNXT ;RETURN FOR NEXT CHAR.
XCTTAB: JRST ILLCH ; (00) ILLEGAL CHAR
JRST BLNKIN ; (01) CR-LF
IORI F,DOTFL ; (02) PERIOD
JRST DIG ; (03) DIGIT BEFORE POINT
JRST BLNKIN ; (04) BLANK OR TAB
JRST GETNXT ; (05) RETURN FOR NEXT CHAR.
IORI F,MINFR ; (06) NEGATIVE FRACTION
IORI F,MINEXP ; (07) NEGATIVE EXP
SOJA X,DIGAFT ; (10) DIGIT AFTER POINT
JRST DIGEXP ; (11) EXPONENT
JRST ILLCH ; (12) DELIMITER TO BACK UP OVER
CHRTYP: CAIN T1,"+" ;CONVERT INPUT CHARS TO CHARACTER TYPE
IORI ST,PLSTYP
CAIN T1,"-"
IORI ST,MINTYP
CAIE T1," " ;SPACE
CAIN T1," " ;TAB
IORI ST,SPCTYP
CAIE T1,"." ;DECIMAL POINT?
JRST NOTDOT ;NO
IORI ST,DOTTYP
NOTDOT: CAIE T1,"D"
CAIN T1,"E"
JRST GOTEXP
CAIE T1,"d" ;[652] LOWER CASE D?
CAIN T1,"e" ;[652] LOWER CASE E?
JRST GOTEXP ;YES
JRST GOTST ;NO
GOTEXP: IORI ST,EXPTYP ;SET STATUS FOR EXPONENT
JRST GOTST ;GO DISPATCH ON OLD STATE AND CHAR TYPE
DIGAFT:
DIG: JUMPN C,DPDIG ;NEED D.P. YET?
CAMLE D,MAGIC ;NO, WILL MUL AND ADD CAUSE OVERFLOW?
JRST DPDIG ;MAYBE, SO DO IT IN DOUBLE PRECISION
IMULI D,12 ;NO, MULTIPLY BY 10 SINGLE PRECISION
ADD D,T1 ;ADD DIGIT INTO NUMBER
JRST GETNXT ;GO GET NEXT CHARACTER
DPDIG: CAMLE C,MAGIC ;WILL MULTIPLY AND ADD CAUSE OVERFLOW?
AOJA X,DIGRET ;YES
IMULI C,12 ;MULTIPLY HIGH D.P. FRACTION BY 10
MULI D,12 ;MULTIPLY LOW D.P. FRACTION BY 10
ADD C,D ;ADD HI PART OF LO PRODUCT INTO RESULT
MOVE D,E ;GET LO PART OF LO PRODUCT
TLO D,(1B0) ;STOP OVERFLOW IF CARRY INTO HI WORD
ADD D,T1 ;ADD DIGIT INTO FRACTION
TLZN D,(1B0) ;SKIP IF NO CARRY INTO HI WORD
ADDI C,1 ;PROPOGATE CARRY INTO HI WORD
DIGRET: JRST GETNXT ;GET NEXT CHAR
MAGIC: <377777777777-9>/^D10 ;LARGEST NUM PRIOR TO MULTIPLY AND ADD
DIGEXP:
IORI F,EXPFL ;SET FLAG TO SAY WE'VE SEEN EXPONENT
IMULI XP,12 ;MULTIPLY BY TEN
ADD XP,T1 ;ADD IN NEXT DIGIT
JRST GETNXT ;GET NEXT CHAR
; ? ,CR , . ,0-9, ,D E, + , - ,
NXTSTA: BYTE (9)
000,010,022,031,050,000,051,061,
000,011,022,031,041,053,054,074,
000,012,120,102,042,053,054,074,
000,013,120,114,043,000,054,074,
000,014,120,114,044,000,120,120
ILLCH: ;[354]
POP P,11
POP P,10
POP P,7
$RETF
BLNKIN: SETZ T1, ;SET TO NULL CHAR
JRST ENDF
SUBTTL BUILD THE FLOATING VALUE NOW
ENDF: ;HERE WHEN ENTIRE FIELD PARSED
DMOVE A,C ;MOVE 2-WORD RESULT TO BOTTOM AC'S
TXNE F,MINEXP ;WAS D OR E EXPONENT NEGATIVE?
MOVNS XP ;YES, SO NEGATE IT
ADD X,XP ;ADD EXPONENT FROM D OR E
NORM: MOVEI BXP,106 ;INIT BINARY EXPON FOR D.P. INTEGER
JUMPN A,NORM1 ;XFER IF AT LEAST ONE 1 IN HIGH HALF
EXCH A,B ;HIGH HALF ZERO, MOVE LOW HALF TO HIGH,
;AND CLEAR LOW HALF
SUBI BXP,^D35 ;AND ADJUST EXPONENT FOR 35 SHIFTS
NORM1: JUMPE A,ZERO ;LEAVE IF BOTH WORDS ZERO
MOVE D,A ;COPY 1ST WORD
JFFO D,NORM2 ;JUST IN CASE
JRST ZERO ;EE CLEARS OUT EVERYTHING
NORM2: ASHC A,-1(E) ;NORMALIZE D.P. INTEGER WITH BIN POINT
;BETWEEN BITS 0 AND 1 IN HIGH WORD
SUBI BXP,-1(E) ;AND ADJUST EXPON TO ALLOW FOR SHIFTING
JUMPE X,ENDF6 ;IF DECIMAL EXP=0, NO MUL BY 10 NEEDED
ENDF3: MOVM D,X ;GET MAG OF DEC EXP
CAILE D,%HIMAX ;LESS THAN MAX TABLE ENTRY?
JRST BADXP2 ;NO. MUCH TOO BIG!
MOVM D,X ;GET MAGNITUDE OF DECIMAL EXPONENT
CAILE D,%PTLEN ;BETWEEN 0 AND MAX. TABLE ENTRY?
MOVEI D,%PTLEN ;NO, MAKE IT SO
SKIPGE X ;AND RESTORE CORRECT SIGN
MOVNS D
SUB X,D ;LEAVE ANY EXCESS EXPONENT IN X
DPMUL: MUL B,%HITEN(D) ;LO FRAC TIMES HI POWER OF TEN(RESULT IN B,C)
MOVE E,B ;GET HI PART OF PREVIOUS PRODUCT OUT OF WAY
MOVE B,A ;COPY HI PART OF FRACTION
MUL B,%LOTEN(D) ;HI FRAC TIMES LO POWER OF TEN
TLO E,(1B0)
ADD E,B ;SUM OF HI PARTS OF CROSS PRODUCTS TO AC T
MUL A,%HITEN(D) ;HI FRACTION TIMES HI POWER OF TEN
TLON E,(1B0) ;DID CARRY OCCUR? ALLOW FOR NEXT CARRY
ADDI A,1 ;CARRY FROM ADDING CROSS PRODUCTS
ADD B,E ;ADD CROSS PRODUCTS TO LO PART
; OF (HI FRAC TIMES HI POW TEN)
TLZN B,(1B0)
AOJA A,ENDF5 ;AND PROPOGATE A CARRY, IF ANY
ENDF5: TLNE A,(1B1) ;NORMALIZED? 1.0 GTR RESULT GE 0.25
JRST ENDF5A ;YES, RESULT GE 0.5
ASHC A,1 ;NO, SHIFT LEFT ONE PLACE
SUBI BXP,1 ;AND ADJUST EXPONENT
ENDF5A: MOVE D,%EXP10(D) ;GET BINARY EXPONENT
ADD BXP,D ;ADJUST BINARY EXPONENT
JUMPN X,ENDF3 ;CONTINUE IF ANY MORE DEC EXP LEFT
ENDF6: TLO A,(1B0) ;START ROUNDING (ALLOW FOR OVERFLOW)
TXNE F,DPFLG ;DOUBLE PRECISION?
JRST DPRND ;[563] TO DPRND
SPRND: ADDI A,200 ;NO, ROUND IN HIGH WORD
TRZ A,377 ;GET RID OF USELESS (UNUSED) BITS
MOVEI B,0 ; DITTO
ENDF7: TLZE A,(1B0) ;CARRY PROPOGATE TO BIT 0?
JRST ENDF7A ;NO
ASHC A,-1 ;YES, RENORMALIZE TO RIGHT
ADDI BXP,1 ;AND ADJUST BINARY EXPONENT
TLO A,(1B1) ;AND TURN ON HI FRACTION BIT
ENDF7A: TXNE F,EEFLG ;EXTENDED EXPONENT?
JRST EERET ;YES. RETURN DIFFERENT FORMAT
CAIGE BXP,200 ;OUT OF RANGE
CAMGE BXP,[-200]
JRST BADEXP ;YES. RETURN ZERO OR INFINITY
ADDI BXP,200 ;ADD IN EXCESS 200
ASHC A,-8 ;NO, LEAVE ROOM FOR EXPONENT
DPB BXP,[POINT 9,A,8] ;INSERT EXPONENT INTO HI WORD
RETURN: TXNE F,MINFR ;RESULT NEGATIVE?
DMOVN A,A ;YES. SO NEGATE RESULT
MOVE 1,IN.PTR ;RET UPD BYTE PTR
DMOVE 2,A ;AND COMPUTED VALUE
POP P,11
POP P,10
POP P,7
$RETT
EERET: CAIGE BXP,2000 ;OUT OF RANGE?
CAMGE BXP,[-2000]
JRST BADEXP ;YES. RETURN ZERO OR INFINITY
ADDI BXP,2000 ;ADD IN EXCESS 2000
ASHC A,-^D11 ;SHIFT TO MAKE ROOM FOR EXP
DPB BXP,[POINT 12,A,11];DEPOSIT THE EXPONENT
JRST RETURN
BADEXP: HRLOI A,377777 ;SET NUMBER TO LARGEST POSSIBLE
HRLOI B,377777 ;FOR PDP-6 OR KI10
JUMPG BXP,RETURN ;DONE IF EXPONENT .GT. ZERO
ZERO: SETZB A,B ;IF NEGATIVE, SET TO ZERO
JRST RETURN
BADXP2: JUMPL X,ZERO ;RETURN ZERO IF DEC EXP NEGATIVE
MOVEI A,3777 ;GET VERY LARGE EXP
HRLOI A,377777 ;GET LARGEST FRACTION
HRLOI B,377777
JRST RETURN
;HERE FOR DOUBLE PRECISION ROUNDING
DPRND: TLO B,(1B0) ;START ROUNDING (ALLOW FOR CARRYS)
TXNE F,EEFLG ;EXTENDED EXPONENT?
ADDI B,2000 ;YES. DO SPECIAL ROUNDING
TXNN F,EEFLG ;CHECK AGAIN
ADDI B,200 ;LOW WORD ROUNDING FOR PDP-6 OR KI10
TLZN B,(1B0) ;DID CARRY PROPOGATE TO SIGN?
AOJA A,ENDF7 ;YES, ADD CARRY INTO HIGH WORD
JRST ENDF7 ;AND GO RENORMALIZE IF NECESSARY
SUBTTL DATA TO SUPPORT CONVERSION
;POWER OF TEN TABLE IN DOUBLE PRECISION
;INTEGER FORMAT. EACH ENTRY CONSISTS OF TWO WORDS,
;EACH WITH 35 BITS OF FRACTION (SIGNS ARE EXCLUDED).
;THE BINARY POINT IS BETWEEN BITS 0 AND 1 OF THE
;HI ORDER WORD. THE EXPONENT (EXCESS 200) FOR THE 70 BIT
;FRACTION IS STORED IN THE SHORT TABLE CALLED "EXPTEN".
DEFINE .TAB. (A)<
NUMBER 732-1000,357347511265,056017357445 ;D-50
NUMBER 736-1000,225520615661,074611525567
NUMBER 741-1000,273044761235,213754053126
NUMBER 744-1000,351656155504,356747065753
NUMBER 750-1000,222114704413,025260341563
NUMBER 753-1000,266540065515,332534432117
NUMBER 756-1000,344270103041,121263540542
NUMBER 762-1000,216563051724,322660234336
NUMBER 765-1000,262317664312,007434303426
NUMBER 770-1000,337003641374,211343364333
NUMBER 774-1000,213302304735,325716130611 ;D-40
NUMBER 777-1000,256162766125,113301556754
NUMBER 002,331617563552,236162112546 ;D-38
NUMBER 006,210071650242,242707256537
NUMBER 011,252110222313,113471132270
NUMBER 014,324532266776,036407360744
NUMBER 020,204730362276,323044526460
NUMBER 023,246116456756,207655654173
NUMBER 026,317542172552,051631227232
NUMBER 032,201635314542,132077636440
NUMBER 035,242204577672,360517606150 ;D-30
NUMBER 040,312645737651,254643547601
NUMBER 043,375417327624,030014501541
NUMBER 047,236351506674,217007711035
NUMBER 052,306044030453,262611673245
NUMBER 055,367455036566,237354252117
NUMBER 061,232574123152,043523552261
NUMBER 064,301333150004,254450504735
NUMBER 067,361622002005,327562626124
NUMBER 073,227073201203,246647575664
NUMBER 076,274712041444,220421535242 ;D-20
NUMBER 101,354074451755,264526064512
NUMBER 105,223445672164,220725640716
NUMBER 110,270357250621,265113211102
NUMBER 113,346453122766,042336053323
NUMBER 117,220072763671,325412633104
NUMBER 122,264111560650,112715401725
NUMBER 125,341134115022,135500702312
NUMBER 131,214571460113,172410431376
NUMBER 134,257727774136,131112537676
NUMBER 137,333715773165,357335267655 ;D-10
NUMBER 143,211340575011,265512262714
NUMBER 146,253630734214,043034737477
NUMBER 151,326577123257,053644127417
NUMBER 155,206157364055,173306466552
NUMBER 160,247613261070,332170204304
NUMBER 163,321556135307,020626245365
NUMBER 167,203044672274,152375747331
NUMBER 172,243656050753,205075341217
NUMBER 175,314631463146,146314631463 ;D-01
A: NUMBER 201,200000000000,0 ;D00
NUMBER 204,240000000000,0
NUMBER 207,310000000000,0
NUMBER 212,372000000000,0
NUMBER 216,234200000000,0
NUMBER 221,303240000000,0
NUMBER 224,364110000000,0
NUMBER 230,230455000000,0
NUMBER 233,276570200000,0
NUMBER 236,356326240000,0
NUMBER 242,225005744000,0 ;D+10
NUMBER 245,272207335000,0
NUMBER 250,350651224200,0
NUMBER 254,221411634520,0
NUMBER 257,265714203644,0
NUMBER 262,343277244615,0
NUMBER 266,216067446770,040000000000
NUMBER 271,261505360566,050000000000
NUMBER 274,336026654723,262000000000
NUMBER 300,212616214044,117200000000
NUMBER 303,255361657055,143040000000 ;D+20
NUMBER 306,330656232670,273650000000
NUMBER 312,207414740623,165311000000
NUMBER 315,251320130770,122573200000
NUMBER 320,323604157166,147332040000
NUMBER 324,204262505412,000510224000
NUMBER 327,245337226714,200632271000
NUMBER 332,316627074477,241000747200
NUMBER 336,201176345707,304500460420
NUMBER 341,241436037271,265620574524
NUMBER 344,311745447150,043164733651 ;D+30
NUMBER 347,374336761002,054022122623
NUMBER 353,235613266501,133413263574
NUMBER 356,305156144221,262316140533
NUMBER 361,366411575266,037001570662
NUMBER 365,232046056261,323301053417
NUMBER 370,300457471736,110161266323
NUMBER 373,360573410325,332215544010
NUMBER 377,226355145205,250330436405 ;D+38
NUMBER 402,274050376447,022416546106
NUMBER 405,353062476160,327122277527 ;D+40
NUMBER 411,222737506706,206363367627
NUMBER 414,267527430470,050060265574
NUMBER 417,345455336606,062074343133
NUMBER 423,217374313163,337245615771
NUMBER 426,263273376020,327117161367
NUMBER 431,340152275425,014743015665
NUMBER 435,214102366355,050055710521
NUMBER 440,257123064050,162071272646
NUMBER 443,332747701062,216507551417
NUMBER 447,210660730537,231114641751 ;D+50
NUMBER 452,253035116667,177340012344
>
DEFINE NUMBER (A,B,C) <B>
TENTAB: .TAB. %HITEN
DEFINE NUMBER (A,B,C) <C>
.TAB. %LOTEN
%PTLEN==%HITEN-TENTAB ;CALCULATE NUMBER OF TABLE ENTRIES BEFORE "TENS"
DEFINE NUMBER (A,B,C) <A-200>
.TAB. %EXP10
DEFINE HITABL <
%%EXP==0
HIEXP 21, 0106, 330656232670, 273650000000
HIEXP 31, 0147, 374336761002, 054022122623
HIEXP 42, 0214, 267527430470, 050060265574
HIEXP 52, 0255, 325644342445, 137230015035
HIEXP 63, 0322, 233446460731, 230310256731
HIEXP 73, 0363, 265072116565, 045110433533
HIEXP 84, 0430, 203616042160, 325266273336
HIEXP 94, 0471, 231321375525, 337205744040
HIEXP 105, 0535, 337172572336, 007545174114
HIEXP 115, 0577, 201742476560, 254305755624
HIEXP 126, 0643, 275056630405, 050037577756
HIEXP 136, 0704, 334103204270, 352046213536
HIEXP 147, 0751, 240125245530, 066753037575
HIEXP 158, 1015, 351045347212, 074316542737
HIEXP 168, 1057, 207525153773, 310102120644
HIEXP 179, 1123, 305327273020, 343641442602
HIEXP 189, 1164, 345647674501, 121102720144
HIEXP 200, 1231, 247161432765, 330455055455
HIEXP 210, 1272, 302527746114, 232735577633
HIEXP 221, 1337, 215510706516, 363467704427
HIEXP 231, 1400, 244711331533, 105545654076
HIEXP 242, 1444, 357747123347, 374251221667
HIEXP 252, 1506, 213527073575, 262011603207
HIEXP 263, 1552, 313176275662, 023427342311
HIEXP 273, 1613, 354470426352, 214122564267
HIEXP 284, 1660, 254120203313, 021677205125
HIEXP 295, 1724, 372412614644, 074374052054
HIEXP 305, 1766, 221645055640, 266335117623
HIEXP 316, 2032, 324146136354, 344313410130
HIEXP 326, 2073, 367020634251, 325055547056
>
%HIMAX==^D326
DEFINE HIEXP (DEXP,BEXP,HIWRD,LOWRD) <
XWD BEXP,^D<DEXP>
EXP HIWRD
EXP LOWRD
%%EXP==%%EXP+1
>
%DEXP: HITABL
%BEXP==%DEXP+1
> ;END TOPS10 CONDITIONAL FOR CPAFLO
END