Trailing-Edge
-
PDP-10 Archives
-
decus_20tap4_198111
-
decus/20-0133/biorth.mac
There is 1 other file named biorth.mac in the archive. Click here to see a list.
SUBTTL B. SCHREIBER
SEARCH JOBDAT,UUOSYM,MACTEN,SCNMAC
.DIREC .XTABM
.DIRECT .OKOVL ;MACRO %50A WILL GET NUMBER ERROR
;ON <ASCII/ /> OTHERWISE
SALL
;BIORTH VERSION
BIOVER==2 ;MAJOR VERSION
BIOEDT==7 ;EDIT LEVEL
BIOMIN==0 ;MINOR VERSION
BIOWHO==0 ;WHO?
DEFINE CTITLE (WORD1,TEXT,MAJVER,VEREDT)
<WORD1 'TEXT'MAJVER(VEREDT)>
CTITLE (TITLE,<BIORTH -- PROGRAM TO CHART BIORHYTHMS %>,\BIOVER,\BIOEDT)
LOC .JBVER
%%BIOV==:VRSN. (BIO)
EXP %%BIOV
;SHOW UNIVERSAL VERSION NUMBERS
%%JOBD==%%JOBD ;JOBDAT
%%UUOS==:%%UUOS ;UUOSYM
%%MACT==:%%MACT ;MACTEN
%%SCNM==:%%SCNM ;SCNMAC
;REQUEST REST OF LOADING
.TEXT &/SEGMENT:LOW/SEARCH REL:ALCOR,REL:SCN7B,REL:HELPER,SYS:FORLIB&
SUBTTL ASSEMBLY / ACCUMULATOR DEFINITIONS
ND LN$PDL,^D200 ;PDL SIZE
ND MY$NAM,'BIORTH' ;MY NAME
ND MY$PFX,'BIO' ;MY MESSAGE PREFIX
ND MX$CRT,4 ;NEARNESS TO MIDDLE TO BE CONSIDERED CRITICAL
ND PLTWID,^D60 ;WIDTH OF PLOT
PLTZER==PLTWID/2;MIDDLE OF PLOT
ND PLTBSZ,PLTWID/5+1 ;# WORDS REQUIRED TO STORE ONE LINE
ND ICYCLE,^D33 ;DAYS/INTELLECTUAL CYCLE
ND ECYCLE,^D28 ;DAYS/EMOTIONAL CYCLE
ND PCYCLE,^D23 ;DAYS/PHYSICAL CYCLE
ND FT$OPT,0 ;NON-ZERO TO SCAN SWITCH.INI
ND FT$DDT,0 ;NON-ZERO FOR DEBUGGING
;DEFINE THE ACCUMULATORS
DEFINE AC$ (X)
<X=ZZ
ZZ==ZZ+1
X=X>
ZZ==0
AC$ (X) ;ARGUMENTS FROM FORTRAN SUBRS (SOMETIMES)
AC$ (T1) ;T1-4 ARE TEMPORARY
AC$ (T2)
AC$ (T3)
AC$ (T4)
AC$ (P1) ;P1-4 ARE PERMANENT--MUST BE PRESERVED
AC$ (P2)
AC$ (P3)
AC$ (P4)
AC$ (F) ;FLAGS
AC$ (D) ;DATE
N==P3 ;NUMBER/WORD FROM SCAN
C==P4 ;CHARACTER FROM SCAN
P=17 ;PUSHDOWN LIST PTR
SUBTTL FLAG DEFINITIONS
;FLAGS IN LH OF F
DEFINE FLAG$ (FLG)
<FL$'FLG==ZZ
ZZ==ZZ_-1
FL$'FLG==FL$'FLG>
ZZ==(1B0)
FLAG$ (FIL) ;ON IF PLOTTING TO A FILE
FLAG$ (HVB) ;ON WHEN HAVE A BIRTHDAY
FLAG$ (BKW) ;ON IF PLOTTING BACKWARDS IN TIME
FLAG$ (CRT) ;ON IF FOUND TO BE A CRITICAL DAY
;I/O CHANNELS
;0 ;NEVER USED BY ME
OUTC==1 ;FOR OUTPUT
;OPDEFINES
OPDEF CALL [PUSHJ P,] ;SUBROUTINE CALL
OPDEF FLOAT. [FSC 233] ;FLOAT # IN AC
;OTHER STUFF
ATSIGN==(1B13) ;THE INDIRECT BIT
SUBTTL ERROR MACRO DEFINITIONS
;ERROR. ($FLGS,$PFX,$MSG)
;
;$FLGS IS THE COMBINITATION OF THE FOLLOWING BITS:
EF$ERR==0 ;ERROR--PREFIX MSG WITH ?, RETURN CONTROL AFTER CALL
EF$FTL==400 ;FATAL ERROR--ABORT AND RESTART
EF$WRN==200 ;WARNING MESSAGE--CONTINUE
EF$INF==100 ;INFORMATIVE MESSAGE--CONTINUE
EF$NCR==40 ;NO FREE CRLF AFTER MESSAGE
DEFINE ETYP ($TYP)
<ZZ==ZZ+1
EF$'$TYP==ZZ>
ZZ==0 ;TYPE CODES ARE FROM 1-37
ETYP (DEC) ;TYPE T1 IN DECIMAL AT END OF MESSAGE
ETYP (OCT) ;TYPE T1 IN OCTAL AT END OF MESSAGE
ETYP (SIX) ;TYPE T1 IN SIXBIT AT END OF MESSAGE
ETYP (PPN) ;TYPE T1 AS A PPN AT END OF MESSAGE
ETYP (STR) ;T1 PTS TO ASCIZ STR TO TYPE AT END OF MESSAGE
ETYP (FIL) ;T1 PTS TO SCAN FILE BLOCK TO TYPE AT END OF MSG
ETYP (DAT) ;TYPE T1 AS A DATE AT END OF MESSAGE
EF$MAX==ZZ ;MAX ERROR TYPE
IFG ZZ-37,<PRINTX ?TOO MANY ERROR TYPES>
;$PFX IS THE 3-LETTER PREFIX FOR THE MESSAGE
;$MSG IS THE MESSAGE ITSELF
NOOP== (CAI) ;DEFINE NO-MEMORY-REFERENCE RIGHT-HAND NOOP
DEFINE ERROR. ($FLGS,$PFX,$MSG)
<CALL EHNDLR
XWD NOOP+<$FLGS>,[''$PFX'',,[ASCIZ @$MSG@ ] ]
>
;WARN. FLGS,PFX,MSG
DEFINE WARN. ($FLGS,$PFX,$MSG)
<ERROR. (EF$WRN!$FLGS,$PFX,$MSG)>
;INFO. FLGS,PFX,MSG
DEFINE INFO. ($FLGS,$PFX,$MSG)
<ERROR. (EF$INF!$FLGS,$PFX,$MSG)>
DEFINE M$FAIL ($PFX,$MSG)
<E$$'$PFX: ERROR. (EF$FTL,$PFX,$MSG)>
SUBTTL OTHER MACRO DEFINITIONS
;SAVE$ SAVES DATA ON THE STACK
DEFINE SAVE$ (X)
<XLIST
IRP X,<PUSH P,X>
LIST>
;RESTR$ RESTORES DATA FROM THE STACK
DEFINE RESTR$ (X)
<XLIST
IRP X,<POP P,X>
LIST>
;MACRO TO ALLOCATE STORAGE IN THE LOW SEGMENT DATA BASE
DEFINE U ($NAME,$WORDS<1>)
<$NAME: BLOCK $WORDS>
;STRNG$ (STRING) SENDS STRING TO OUTPUT THROUGH .TSTRG
DEFINE STRNG$ (S)
<MOVEI T1,[ASCIZ \S\]
CALL .TSTRG##>
;ASCIZ$ (STRING) CREATES XLISTED ASCIZ STRING TO KEEP LISTING PRETTY
DEFINE ASCIZ$ (S)
<XLIST
ASCIZ \S\
LIST>
SUBTTL MAIN-LINE PROGRAM
RELOC 0
BIORTH: TDZA T1,T1 ;FLAG NORMAL START
MOVEI T1,1 ;FLAG CCL START
MOVEM T1,OFFSET ;SAVE FOR SCAN
STORE 17,0,16,0 ;CLEAR ACS
STORE 17,FW$ZER,LW$ZER,0 ;AND CORE WHICH SHOULD BE CLEARED
RESET ;STOP EXTERNAL I/O WHICH MAY BE IN PROGRESS
SKIPA P,.+1 ;SETUP PDL
INIPDP: IOWD LN$PDL,PDLIST
CALL .RECOR## ;RESET CORE ALLOCATION
MOVE T1,ISCNBL ;GET ISCAN BLOCK
CALL .ISCAN## ;INITIALIZE THE COMMAND SCANNER
MOVEM T1,ISCNVL ;REMEMBER WHAT ISCAN RETURNS
SKIPN OFFSET ;CCL ENTRY?
SKIPE TLDVER ;OR ALREADY TOLD VERSION?
JRST BIOR.0 ;ONE OR THE OTHER
STRNG$ <BIORTH %> ;NO--DO IT NOW
MOVE T1,.JBVER
CALL .TVERW##
CALL .TCRLF##
BIOR.0: HRROI T1,.GTJLT ;GET LOGIN TIME
GETTAB T1, ;FOR DATE-TIME STUFF
SETZ T1, ;(OLD MON)
MOVEM T1,LOGTIM ;...
SETOM TLDVER ;SO WE ONLY TELL VERSION ONE TIME
RESTRT: MOVE T1,VSCNBL ;GET ARG BLOCK FOR .VSCAN
CALL .VSCAN## ;DO THE WORK
CALL .MONRT## ;EXIT TO MONITOR
JRST RESTRT ;GO RESTART
TWOPI: EXP 6.28318 ;PI*2
SUBTTL ARGUMENT BLOCKS FOR ISCAN AND VSCAN
ISCNBL: XWD 5, .+1
IOWD N$CMDS,CMDLST
XWD OFFSET,MY$PFX
EXP 0
EXP 0
XWD DOPRMP,0
;ARG BLOCK FOR .VSCAN
VSCNBL: XWD 7, .+1
IOWD VSWTL,VSWTN
XWD VSWTD,VSWTM
XWD 0,VSWTP
EXP -1 ;USE MY NAME FOR HELP
XWD 2,BEGNDT ;SO PLOT/BEGIN:XX/END:XX WILL WORK
XWD 0,PBEGND ;DUMMY
EXP 0
;SCAN CALLS HERE TO PROMPT -- T1 NEGATIVE IF CONTINUATION
DOPRMP: SKIPL T1 ;FIRST?
SKIPA T1,PRMPTM ;YES--LOAD UP MESSAGE
MOVSI T1,'# ' ;NO--LOAD UP CONTINUATION
PJRST .TSIXN## ;GO TYPE IT
PRMPTM: XWD MY$PFX,'> '
CMDLST: EXP MY$NAM
N$CMDS==.-CMDLST
SUBTTL SWITCH TABLE
DEFINE SWTCHS,<
SP BEGIN,BEGNDT,.DATIM,,FS.NUE!FS.VRQ
SP *BIRTHD,,$BIRTHDAY,,
SP *CHART,,$CHART,,
SP COMPAT,,$COMPAT,,
IFN FT$DDT,<
SP DDT,,$DDT,,
>;END IFN FT$DDT
SP END,ENDATE,.DATIM,,FS.NUE!FS.VRQ
SP *PLOT,,$PLOT,,
>
DOSCAN (VSWT)
SUBTTL MISC. COMMANDS
$BIRTHDAY:
TLZ F,FL$HVB ;HAVE NO BIRTHDAY
JUMPLE C,E$$NBG ;GUARD AGAINST HALT IN SCAN
CALL .DATIM ;READ IT
HLLZM N,BIRTHD ;SAVE BIRTHDAY
TLO F,FL$HVB ;HAVE A BIRTHDAY
JRST .POPJ1## ;SKIP BACK TO AVOID STORE
IFN FT$DDT,<
$DDT: STRNG$ <DDT
>
AOS (P) ;SO CAN POPJ FROM DDT
SKIPE T1,.JBDDT ;GET DDT ADDR
JRST (T1) ;AND GO TO IT
WARN. 0,DNL,<DDT NOT LOADED>
POPJ P,
>;END IFN FT$DDT
SUBTTL COMPUTE COMPATIBILITIES
$COMPAT:CALL .SAVE2## ;PRESERVE
AOS (P) ;SO SCAN DOESN'T STORE
CALL .CLRBF## ;EAT REST
SETZ T1, ;DUMMY ARG BLOK FOR QSCAN
CALL .QSCAN## ;INIT A LINE
JFCL ;WILL PROMPT ANYWHAY
STRNG$ <BIRTHDATE 1: >
CALL .DATIM
HLRZ P1,N ;ONLY WANT THE DATE
CALL .CLRBF## ;EAT WHAT MAY BE LEFT
SETZ T1,
CALL .QSCAN##
JFCL
STRNG$ <BIRTHDATE 2: >
CALL .DATIM
HLRZ P2,N ;AND DITTO HERE
CALL .CLRBF## ;CLEAR ANY LEFT
MOVEI T1,ICYCLE ;COMPUTE THE PERCENTAGES
CALL CMPTFN ;...
MOVEM T1,IPOS
MOVEI T1,ECYCLE
CALL CMPTFN
MOVEM T1,EPOS
MOVEI T1,PCYCLE
CALL CMPTFN
MOVEM T1,PPOS
STRNG$ <INTELLECTUAL COMPATIBILITY = >
MOVE T1,IPOS
CALL .TPCNT ;TYPE DECIMAL AND PERCENT AND CRLF
STRNG$ <EMOTIONAL COMPATIBILITY = >
MOVE T1,EPOS
CALL .TPCNT
STRNG$ <PHYSICAL COMPATIBILITY = >
MOVE T1,PPOS
CALL .TPCNT
STRNG$ <TOTAL COMPATIBILITY = >
MOVE T1,IPOS
ADD T1,EPOS
ADD T1,PPOS
IDIVI T1,3 ;AVERAGE
CALL .TPCNT
POPJ P,
SUBTTL COMPUTE THE COMPATIBILITY FUNCTION
;CALL HERE WITH P1=BIRTHDATE IN RH
; P2=BIRTHDATE IN RH
; T1=CYCLE LENGTH
;
;RETURN WITH T1=COMPATIBILITY PERCENTAGE
CMPTFN: HLRZ T2,NOW ;USE NOW TO COMPUTE DIFF
SUB T2,P1 ;# DAYS ALIVE
MOVM T2,T2 ;ALLOW WHATEVER
IDIVI T2,(T1) ;GET DAYS INTO CYCLE
MOVE T2,T3 ;SAVE REMAINDER
HLRZ T3,NOW
SUB T3,P2
MOVM T3,T3
IDIVI T3,(T1) ;DAYS INTO CYCLE
SUB T2,T4 ;DIFF
MOVM T2,T2 ;GET THE MAGNITUDE
IMULI T2,^D200 ;* 200
FLOAT. T2, ;MAKE IT REAL
FLOAT. T1, ;CYCLE ALSO
FDVR T2,T1 ;200*DIFF/CYCLE LENGTH
MOVSI T1,(100.0) ;GET ONE HUNDRED
FSBR T1,T2 ;100-ABOVE
SKIPGE T1 ;IF NEGATIVE
MOVNS T1 ;MAKE IT POSITIVE
FADRI T1,(0.5) ;ROUND IT UP
PJRST IFX.1## ;FIX AND RETURN
;.TPCNT -- TYPE DECIMAL # , "%", AND CRLF
.TPCNT: CALL .TDECW## ;TYPE DECIMAL
MOVEI T1,"%" ;GET A PERCENT
CALL .TCHAR## ;BOOT IT
PJRST .TCRLF## ;NEW LINE AND EXIT
SUBTTL PLOT THE CYCLES
$PLOT:
$CHART:
CALL .SAVE2## ;SAVE REGISTERS
AOS (P) ;SKIP SCAN STORE ON WAY BACK
TLNN F,FL$HVB ;MUST HAVE A BIRTHDAY
E$$NBG: ERROR. EF$FTL,NBG,<NO BIRTHDAY GIVEN>
TLZ F,FL$FIL!FL$BKW!FL$CRT ;NOT TO FILE,NOT BACKWARDS,AND NOT CRIT.
JUMPLE C,PLOT.0 ;JUMP IF NO FILE SPEC
CALL .FILIN## ;YES--READ IT
SKIPN F.NAM##-1 ;NULL DEVICE/
SKIPE F.NAM## ;OR NULL FILENAME?
SKIPA ;NO--THERE IS REALLY A SPEC
JRST PLOT.0 ;MUST HAVE JUST BEEN SWITCHES
MOVEI T1,FILSPC ;GET THE SPEC
MOVEI T2,.FXLEN ;AND LENGTH
CALL .GTSPC## ;COPY IT OVER
MOVSI T1,'LPT' ;FILL IN DEFAULTS
SKIPN FILSPC+.FXDEV ;FOR DEVICE
MOVEM T1,FILSPC+.FXDEV
MOVE T1,[SIXBIT/BIORTH/] ;FOR FILENAME
SKIPN FILSPC+.FXNAM
SETOM FILSPC+.FXNMM
SKIPN FILSPC+.FXNAM
MOVEM T1,FILSPC+.FXNAM
HRLOI T1,'LPT' ;AND EXTENSION
SKIPN FILSPC+.FXEXT
MOVEM T1,FILSPC+.FXEXT
MOVEI T1,FILSPC ;POINT AT IT
CALL OPENIO ;OPEN CHANNEL
CAI OUTC,@OBHR(.IOASC) ;
SETZ T1, ;DEFAULT # BUFFERS
MOVE T2,[XWD OPNBLK,OBHR]
CALL .ALCBF## ;ALLOCATE BUFFERS
TLO F,FL$FIL ;FLAG TO A FILE
MOVEI T1,CHROUT ;SETUP ROUTINE
CALL .TYOCH## ;WITH SCAN
SAVE$ T1 ;REMEMBER OLD ONE
PLOT.0: HLLZS ENDATE ;CLEAR SO WE ONLY LOOK AT DAYS, NOT HOURS
CALL .GTNOW ;USE TODAY
SKIPN D,BEGNDT ;UNLESS /BEGIN WAS GIVEN
MOVE D,T1 ;POSITION DATE
HLLZS D ;ONLY LOOK AT DATE
MOVSI T1,377776 ;A VERY LARGE DATE
TLNN F,FL$FIL ;UNLESS OUTPUTTING TO A FILE
JRST PLOT0B ;NO--GO FOREVER
HLLZ T1,D ;THEN START WITH BEGINNING DATE
ADD T1,[XWD ^D31,0] ;AND GO FOR A MONTH
PLOT0B: SKIPN ENDATE ;MAKE SURE END SPECIFIED
MOVEM T1,ENDATE ;NO--MAKE IT VERY LARGE
CAMLE D,ENDATE ;BEGINNING MUST BE BEFORE END
TLO F,FL$BKW ;OR ELSE WE ARE GOING BACKWARDS IN TIME
STRNG$ <
BIORHYTHM CHART FOR BIRTHDATE: >
MOVE T1,BIRTHD ;GET THE BIRTHDAY
CALL .TDATX ;TYPE DAY OF WEEK AND DATE
STRNG$ <
E - EMOTIONAL CYCLE -- 28 DAYS
I - INTELLECUTAL CYCLE -- 33 DAYS
P - PHYSICAL CYCLE -- 23 DAYS
# INDICATES CRITICAL DAY
>
STRNG$ < LOW CRITICAL HIGH
>
CALL .TCRLF## ;NEW LINES
PLOT.1: STORE T1,PLTBUF,PLTBUF+PLTBSZ-1,<ASCII/ /> ;INIT TO BLANKS
MOVEI T1,ICYCLE ;DO I CYCLE
CALL COMPOS ;COMPOSE POSITION
MOVEM T1,IPOS
CALL CRTCHK ;SEE IF CRITICAL
MOVEI T1,ECYCLE ;DO E CYCLE
CALL COMPOS
MOVEM T1,EPOS
CALL CRTCHK ;SEE IF CRITICAL
MOVEI T1,PCYCLE
CALL COMPOS
MOVEM T1,PPOS
CALL CRTCHK ;SEE IF CRITICAL
MOVEI T1,"!" ;SETUP THE BORDERS
MOVEI T2,0 ;...
CALL PUTPLC ;LEFT SIDE
MOVEI T2,PLTZER ;THE MIDDLE
CALL PUTPLC
MOVEI T2,PLTWID ;RIGHT SIDE
CALL PUTPLC ;...
MOVEI T1,"#" ;IN CASE CRITICAL
MOVEI T2,PLTWID+1 ;...
TLZE F,FL$CRT ;CRITICAL?
CALL PUTPLC ;YES--MARK IN CHART
MOVSI P1,-LN$PCH ;GET A LOOPER
PLOT.2: HLRZ T1,PCHTBL(P1) ;GET CHAR TO PLOT
HRRZ T2,PCHTBL(P1) ;AND ADDR OF POS
MOVE T2,(T2) ;GET POS
CALL PUTPLC ;PLOT IT
AOBJN P1,PLOT.2 ;DO ALL
PLOT.5:
MOVE T1,D ;GET DATE
CALL .TDATX ;TYPE DAY AND DATE
CALL .TSPAC## ;AND A SPACE
MOVEI T1,PLTBUF ;BUFFER ADDR
CALL .TSTRG## ;SEND IT
CALL .TCRLF## ;NEW LINE
MOVSI T1,1 ;GET ONE IN LH
TLNE F,FL$BKW ;GOING BACKWARDS?
JRST [SUB D,T1 ;YES--DO THAT
CAML D,ENDATE;DONE YET?
JRST PLOT.1 ;NO--CONTINUE
JRST PLOT.9] ;YES--GO QUIT
ADD D,T1 ;NEXT DAY
PLOT.6: CAMG D,ENDATE ;REACHED THE END YET?
JRST PLOT.1 ;..
PLOT.9: TLZN F,FL$FIL ;YES--OUTPUTTING TO A FILE?
POPJ P, ;NO--DONE
CLOSE OUTC, ;YES--CLOSE FILE
RELEASE OUTC, ;...
MOVEI T1,OBHR ;RELEASE BUFFERS
CALL .FREBF##
RESTR$ T1 ;GET SCAN ROUTINE
PJRST .TYOCH## ;RESTORE AND RETURN
PCHTBL: XWD "I",IPOS ;INTELLECTUAL
XWD "E",EPOS ;EMOTIONAL
XWD "P",PPOS ;PHYSICAL
LN$PCH==.-PCHTBL
CRTCHK: SUBI T1,PLTZER ;SEE IF NEAR THE MIDDLE
MOVMS T1 ;GET ONLY THE MAGNITUDE
CAIG T1,MX$CRT ;CAN IT BE CRITICAL?
TLO F,FL$CRT ;YES--FLAG FOR PRINTER
POPJ P, ;DONE
COMPOS: FLOAT. T1, ;FLOAT CYCLE LENGTH
MOVE T2,TWOPI ;GET 2*PI
FDVR T2,T1 ;2*PI/CYCLE LENGTH
MOVEM T2,TEMP ;SAVE IT
HLRZ T1,D ;GET DAY WE ARE WORKING ON
HLRZ T2,BIRTHD ;AND BIRTHDAY
SUBI T1,(T2) ;DIFFERENCE
PUSHJ P,FLT.1## ;FLOAT IT
FMPRM T1,TEMP ;* ABOVE RESULT AND SAVE IT
MOVEI 16,1+[EXP <-1,,0>,TEMP] ;ARG BLOCK
CALL SIN.## ;GET THE SINE
MOVEM X,TEMP ;SAVE IT
MOVSI T1,(1.0) ;ADD ONE TO IT
FADRM T1,TEMP ;...
MOVEI T1,PLTWID ;GET PLOT WIDTH
FLOAT. T1, ;MAKE IT REAL
FMPRM T1,TEMP
MOVSI T1,(2.0) ;GET A TWO
EXCH T1,TEMP ;POSITION
FDVRM T1,TEMP ;DIVIDE BY TWO
MOVSI T1,(0.5) ;GET 1/2
FADRB T1,TEMP ;ADD THAT IN ALSO
PJRST IFX.1## ;FIX AND RETURN
;PUTPLC -- PUT CHAR IN PLOT BUFFER
;CALL: MOVEI T1,CHAR
; MOVEI T2,POS
; CALL PUTPLC
;USES T1-4
PUTPLC: IDIVI T2,5 ;T2=WORD, T3=POS IN WORD
MOVSI T4,(POINT 7) ;START TO FORM BYTE PTR
HRRI T4,PLTBUF(T2) ;FINISH IT
IBP T4 ;INC ONE
SOJGE T3,.-1 ;DO ALL
DPB T1,T4 ;STORE CHAR
POPJ P,
SUBTTL SUBROUTINES FOR COMMAND INPUT -- GET DATE/TIME
;.DATIF -- ROUTINE TO SCAN DATE AND TIME ARGUMENT IN FUTURE
;.DATIG -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIF/.DATIG
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIF: PUSHJ P,.TIAUC## ;PRIME THE PUMP
.DATIG: SETZM FLFUTR ;CLEAR FUTURE RELATIVE
SETZM FLFUTD ;SET DEFAULT
AOS FLFUTD ; TO FUTURE
CAIE C,"+" ;SEE IF FUTURE RELATIVE
JRST DATIF1 ;NO--JUST GET DATE-TIME
AOS FLFUTR ;YES--SET FUTURE REL FLAG
PUSHJ P,.TIAUC## ;GET ANOTHER CHARACTER
DATIF1: PUSHJ P,DATIM ;GET DATE/TIME
CAMGE N,NOW ;SEE IF IN FUTURE
JRST E$$NFT ;NO--NOT FUTURE ERROR
POPJ P, ;RETURN
;.DATIP -- ROUTINE TO SCAN DATE AND TIME ARGUMENT IN THE PAST
;.DATIQ -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIP/.DATIQ
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIP: PUSHJ P,.TIAUC## ;PRIME THE PUMP
.DATIQ: SETZM FLFUTR ;CLEAR PAST RELATIVE
SETOM FLFUTD ;SET DEFAULT TO PAST
CAIE C,"-" ;SEE IF PAST RELATIVE
JRST DATIP1 ;NO--JUST GET DATE-TIME
SOS FLFUTR ;YES--SET PAST REL FLAG
PUSHJ P,.TIAUC## ;GET ANOTHER CHARACTER
DATIP1: PUSHJ P,DATIM ;GET DATE/TIME
CAMLE N,NOW ;SEE IF IN PAST
JRST E$$NPS ;NO--NOT PAST ERROR
POPJ P, ;RETURN
;.DATIM -- ROUTINE TO SCAN DATE AND TIME ARGUMENT
;.DATIC -- DITTO (CHARACTER ALREADY IN C)
;CALL: PUSHJ P,.DATIM/.DATIC
; RETURN WITH VALUE IN INTERNAL FORMAT IN N
;USES T1-4 UPDATES C (SEPARATOR)
.DATIM: PUSHJ P,.TIAUC## ;PRIME THE PUMP
.DATIC: SETZM FLFUTR ;CLEAR RELATIVE FLAG
SETZM FLFUTD ;CLEAR DEFAULT FLAG
CAIE C,"+" ;SEE IF FUTURE RELATIVE
JRST DATIC1 ;NO--PROCEED
AOS FLFUTR ;YES--SET FLAG
JRST DATIC2 ;AND PROCEED
DATIC1: CAIE C,"-" ;SEE IF PAST RELATIVE
PJRST DATIM ;NO--JUST GET ABS DATE
SOS FLFUTR ;YES--SET FLAG
DATIC2: PUSHJ P,.TIAUC## ;GET NEXT CHAR
;AND FALL INTO DATE/TIME GETTER
;DATIM -- ROUTINE TO INPUT DATE/TIME
;CALL: SET FLFUTR TO -1 IF PAST RELATIVE, 0 IF ABSOLUTE, +1 IF FUTURE RELATIVE
; SIMILARLY FOR FLFUTD TO INDICATE DEFAULT DIRECTION IF FLFUTR=0
; GET NEXT CHARACTER IN C
; PUSHJ P,DATIM
;RETURN WITH TRUE DATE/TIME IN N IN INTERNAL SPECIAL FORMAT
; SETS NOW TO CURRENT DATE/TIME
;USES T1-4, UPDATES C
;
;TYPE-IN FORMATS:
; (THE LEADING +- IS HANDLED BY CALLER)
;
; [ [ DAY IN WEEK ] ]
; [ [ NNND ] ]
; [ [ [ MM-DD [-Y ] ] : ] [HH[:MM[:SS]]] ]
; [ [ [ MMM-DD [-YY ] ] ] ]
; [ [ [ DD-MMM [-YYYY] ] ] ]
; [ MNEMONIC ]
;WHERE:
; D LETTER D
; DD DAY IN MONTH (1-31)
; HH HOURS (00-23)
; MM MONTH IN YEAR (1-12)
; OR MINUTES (00-59)
; MMM MNEMONIC MONTH OR ABBREV.
; SS SECONDS (0-59)
; Y LAST DIGIT OF THIS DECADE
; YY LAST TWO DIGITS OF THIS CENTURY
; YYYY YEAR
; DAY IN WEEK IS MNEMONIC OR ABBREVIATION
; MNEMONIC IS A SET OF PREDEFINED TIMES
;DESCRIBED ABOVE
;FALL HERE FROM .DATIC
DATIM: SKIPE T1,FLFUTR ;SEE IF FORCED DIRECTION
MOVEM T1,FLFUTD ; YES--THAT IMPLIES DEFAULT
SETOM VAL1 ;CLEAR RESULT WORDS
MOVE T1,[VAL1,,VAL2]
BLT T1,VAL9 ; ..
PUSHJ P,.GTNOW ;GET CURRENT DATE/TIME
MOVEM T1,NOW ;SAVE FOR LATER TO BE CONSISTENT
CAIL C,"0" ;SEE IF DIGIT
CAILE C,"9" ; ..
JRST .+2 ;NO--MNEMONIC FOR SOMETHING
JRST DATIMD ;YES--GO GET DECIMAL
;HERE IF STARTING WITH ALPHA, MIGHT BE DAY, MONTH, OR MNEMONIC
PUSHJ P,.SIXSC## ;GET SIXBIT WORD
JUMPE N,E$$DTM ;ILLEGAL SEPARATOR IF ABSENT
MOVE T1,MNDPTR ;POINT TO FULL TABLE
PUSHJ P,.NAME## ;LOOKUP IN TABLE
JRST E$$UDN ;ERROR IF NOT KNOWN
MOVEI N,(T1) ;GET
SUBI N,DAYS ; DAY INDEX
CAIL N,7 ;SEE IF DAY OF WEEK
JRST DATIMM ;NO--LOOK ON
;HERE WHEN DAY OF WEEK RECOGNIZED
SKIPN T1,FLFUTD ;GET DEFAULT DIRECTION
JRST E$$NPF ;ERROR IF NONE
MOVEM T1,FLFUTR ;SET AS FORCED DIRECTION
HLRZ T2,NOW ;GET DAYS
IDIVI T2,7 ;GET DAY OF WEEK
SUB N,T3 ;GET FUTURE DAYS FROM NOW
SKIPGE N ;IF NEGATIVE,
ADDI N,7 ; MAKE LATER THIS WEEK
HLLZ T1,NOW ;CLEAR CURRENT
SKIPL FLFUTD ;SEE IF FUTURE
TROA T1,-1 ;YES--SET MIDNIGHT MINUS EPSILON
SUBI N,7 ;NO--MAKE PAST
HRLZ N,N ;POSITION TO LEFT HALF
ADD N,T1 ;MODIFY CURRENT DATE/TIME
DATIMW: PUSH P,N ;SAVE DATE
PUSHJ P,DATIC ;GO CHECK TIME
HRRZ N,(P) ;NO--USE VALUE IN DATE
POP P,T1 ;RESTORE DATE
HLL N,T1 ; TO ANSWER
JRST DATIMX ;CHECK ANSWER AND RETURN
;HERE IF MONTH OR MNEMONIC
DATIMM: MOVEI N,(T1) ;GET MONTH
SUBI N,MONTHS-1 ; AS 1-12
CAILE N,^D12 ;SEE IF MONTH
JRST DATIMN ;NO--MUST BE MNEMONIC
MOVEM N,VAL6 ;YES--STORE MONTH
CAIE C,"-" ;MUST BE DAY NEXT
JRST E$$MDD ;NO--ERROR
PUSHJ P,.DECNW## ;YES--GET IT
JUMPLE N,E$$NND ;ERROR IF NEGATIVE
CAILE N,^D31 ;VERIFY IN RANGE
JRST E$$DFL ;ERROR IF TOO LARGE
MOVEM N,VAL5 ;SAVE AWAY
JRST DATIY0 ;AND GET YEAR IF PRESENT
;HERE IF MNEMONIC
DATIMN: HRRZ T2,T1 ;GET COPY
CAIN T2,SPLGTM ;SEE IF "LOGIN"
SKIPG N,LOGTIM ;AND WE KNOW IT
SKIPA ;NO--PROCEED
JRST DATIMX ;YES--GO GIVE ANSWER
CAIN T2,SPNOON ;SEE IF "NOON"
JRST [HLLZ N,NOW ;YES--GET TODAY
HRRI N,1B18 ;SET TO NOON
JRST DATIMW] ;GO FINISH UP
CAIN T2,SPMIDN ;SEE IF "MIDNIGHT"
JRST [HLLZ N,NOW ;GET TODAY
JRST DATIMO] ;GO SET TO MIDNIGHT
SUBI T2,SPCDAY ;SUBTRACT OFFSET TO SPECIAL DAYS
CAILE T2,2 ;SEE IF ONE OF THREE
JRST E.MDS ;NO--UNSUPPORTED
HLRZ N,NOW ;YES--GET TODAY
ADDI N,-1(T2) ;OFFSET IT
HRLZS N ;POSITION FOR ANSWER
DATIMO: SKIPL FLFUTD ;SEE IF FUTURE
TRO N,-1 ;YES--SET TO MIDNIGHT MINUS EPSILON
JRST DATIMW ;AND GO FINISH UP
;HERE IF UNSUPPORTED MNEMONIC
E.MDS: MOVE T1,(T1) ;GET NAME OF SWITCH
ERROR. EF$FTL!EF$SIX,MDS,<MNEMONIC DATE/TIME SWITCH NOT IMPLEMENTED>
;HERE IF STARTING WITH DECIMAL NUMBER
DATIMD: PUSHJ P,.DECNC## ;YES--GO GET FULL NUMBER
JUMPL N,E$$NND ;ILLEGAL IF NEGATIVE
CAIE C,"D" ;SEE IF DAYS
JRST DATIN ;NO--MUST BE -
MOVE T1,FLFUTD ;YES--RELATIVE SO GET FORCING FUNCTION
MOVEM T1,FLFUTR ; AND FORCE IT
JUMPE T1,E$$NPF ;ERROR IF DIRECTION UNCLEAR
CAIL N,1B18 ;VERIFY NOT HUGE
JRST E$$DFL ;ERROR--TOO LARGE
MOVEM N,VAL5 ;SAVE RELATIVE DATE
PUSHJ P,.TIAUC## ;GET NEXT CHARACTER (SKIP D)
PUSHJ P,DATIC ;GO CHECK FOR TIME
MOVEI N,0 ;0 IF NONE
HRL N,VAL5 ;INCLUDE DAYS IN LH
JRST DATITR ;GO DO RELATIVE RETURN
;HERE WHEN DIGITS SEEN WITHOUT A FOLLOWING D
DATIN: CAIE C,"-" ;SEE IF DAY/MONTH COMBO
JRST DATIT ;NO--MUST BE INTO TIME
CAILE N,^D31 ;MUST BE LESS THAN 31
JRST E$$DFL ;NO--ERROR
JUMPE N,E$$DFZ ;VERIFY NOT ZERO
MOVEM N,VAL5 ;SAVE VALUE
PUSHJ P,.TIAUC## ;SKIP OVER MINUS
CAIL C,"0" ;SEE IF DIGIT NEXT
CAILE C,"9" ; ..
JRST DATMMM ;NO-- MUST BE MNEMONIC MONTH
PUSHJ P,.DECNC## ;YES-- MUST BE MM-DD FORMAT
JUMPLE N,E$$NND ;BAD IF LE 0
CAILE N,^D31 ;VERIFY LE 31
JRST E$$DFL ;BAD
EXCH N,VAL5 ;SWITCH VALUES
CAILE N,^D12 ;VERIFY MONTH OK
JRST E$$DFL ;BAD
JRST DATMM1 ;GO STORE MONTH
;HERE WHEN TIME SEEN BY ITSELF
DATIT: PUSHJ P,DATIG ;GET REST OF TIME
HALT . ;CAN NOT GET HERE
SKIPN FLFUTR ;SEE IF RELATIVE
JRST DATIRN ;NO--GO HANDLE AS ABS.
;HERE WITH DISTANCE IN N
DATITR: SKIPGE FLFUTR ;IF PAST,
MOVN N,N ; COMPLEMENT DISTANCE
ADD N,NOW ;ADD TO CURRENT DATE/TIME
JRST DATIMX ;CHECK ANSWER AND RETURN
;HERE WHEN DD- SEEN AND MNEMONIC MONTH COMING
DATMMM: PUSHJ P,.SIXSC## ;GET MNEMONIC
MOVE T1,MONPTR ;GET POINTER TO MONTH TABLE
PUSHJ P,.NAME## ;LOOKUP IN TABLE
JRST E$$UDM ;NO GOOD
MOVEI N,(T1) ;GET MONTH
SUBI N,MONTHS-1 ; AS 1-12
;HERE WITH MONTH INDEX (1-12) IN T1
DATMM1: MOVEM N,VAL6 ;SAVE FOR LATER
DATIY0: CAIE C,"-" ;SEE IF YEAR NEXT
JRST DATIRA ;NO--GO HANDLE TIME
;HERE WHEN YEAR NEXT AS ONE, TWO, OR FOUR DIGITS
SETZB N,T1 ;CLEAR DIGIT AND RESULT COUNTERS
DATIY: PUSHJ P,.TIAUC## ;GET NEXT DIGIT
CAIL C,"0" ;SEE IF NUMERIC
CAILE C,"9" ; ..
JRST DATIY1 ;NO--MUST BE DONE
IMULI N,^D10 ;ADVANCE RESULT
ADDI N,-"0"(C) ;INCLUDE THIS DIGIT
AOJA T1,DATIY ;LOOP FOR MORE, COUNTING DIGIT
DATIY1: JUMPE T1,E$$ILR ;ERROR IF NO DIGITS
CAIE T1,3 ;ERROR IF 3 DIGITS
CAILE T1,4 ;OK IF 1,2, OR 4
JRST E$$ILR ;ERROR IF GT 4 DIGITS
MOVE T2,N ;GET RESULT
IDIVI T2,^D100 ;SEP. CENTURY
IDIVI T3,^D10 ;SEP. DECADE
CAIG T1,2 ;IF ONE OR TWO DIGITS,
SETOM T2 ; FLAG NO CENTURY KNOWN
CAIN T1,1 ;IF ONE DIGIT,
SETOM T3 ; FLAG NO DECADE KNOWN
MOVEM T4,VAL7 ;SAVE UNITS
MOVEM T3,VAL8 ;SAVE DECADE
MOVEM T2,VAL9 ;SAVE CENTURY
;HERE WITH VAL5-9 CONTAINING DAY, MONTH, YEAR, DECADE, CENTURY
DATIRA: SOS VAL5 ;MAKE DAYS 0-30
SOS VAL6 ;MAKE MONTHS 0-11
PUSHJ P,DATIC ;GET TIME IF PRESENT
SKIPG FLFUTD ;IGNORE ABSENCE
JRST DATIRN ; UNLESS FUTURE
;HERE IF FUTURE WITHOUT TIME
MOVEI T1,^D59 ;SET TO
MOVEM T1,VAL2 ; 23:59:59
MOVEM T1,VAL3 ; ..
MOVEI T1,^D23 ; ..
MOVEM T1,VAL4 ; ..
;HERE WITH VAL2-9 CONTAINING PARSE OR -1 IF TO BE FILLED IN
; STRATEGY IS TO FILL-IN HOLES LESS SIGNIFICANT THAN
; MOST SIGN. FIELD WITH 0; AND TO FILL IN MORE SIGNIFICANT
; HOLES WITH CURRENT VALUE. THEN IF WRONG DIRECTION FROM
; NOW, ADD/SUB ONE TO FIELD JUST ABOVE MOST SIGNIFICANT DIFFERENT
; (FIELD CARRY NOT NEEDED SINCE IT WILL HAPPEN IMPLICITLY).
DATIRN: PUSHJ P,.TICAN## ;MAKE SURE NEXT CHAR IS SEPARATOR
SKIPA ;YES--OK
JRST E.ILSC## ;NO--FLAG ERROR BEFORE DEFAULTING
MOVE T1,NOW ;GET CURRENT DATE/TIME
PUSHJ P,.CNTDT ;CONVERT TO EASY FORMAT
MOVE T3,T1 ;SAVE MSTIME
IDIVI T3,^D1000 ; AS SECONDS
ADD T2,[^D1900*^D12*^D31] ;MAKE REAL
MOVEI T4,8 ;TRY 8 FIELDS
DATIRB: MOVE T1,T2 ;POSITION REMAINDER
IDIV T1,[1
^D60
^D60*^D60
1
^D31
^D31*^D12
^D31*^D12*^D10
^D31*^D12*^D10*^D10]-1(T4) ;SPLIT THIS FIELD FROM REST
SKIPL VAL1(T4) ;SEE IF DEFAULT
JRST [TLNN T3,-1 ;NO--FLAG TO ZERO DEFAULTS
HRL T3,T4 ; SAVING INDEX OF LAST DEFAULT
JRST DATRIC] ;AND CONTINUE LOOP
SETZM VAL1(T4) ;DEFAULT TO
TLNN T3,-1 ;SEE IF NEED CURRENT
MOVEM T1,VAL1(T4) ;YES--SET THAT INSTEAD
DATRIC: CAME T1,VAL1(T4) ;SEE IF SAME AS CURRENT
JRST DATIRD ;NO--REMEMBER FOR LATER
CAIN T4,4 ;SEE IF TIME FOR TIME
HRRZ T2,T3 ;YES--GET IT
SOJG T4,DATIRB ;LOOP UNTIL ALL DONE
;HERE WHEN FILLED IN CURRENT FOR SIGNIFICANT DEFAULTS
DATIRD: SKIPGE VAL1(T4) ;SEE IF DEFAULT
SETZM VAL1(T4) ;CLEAR DEFAULT
SOJG T4,DATIRD ;LOOP UNTIL DONE
HLRZ N,T3 ;RECOVER LAST SIGN. DEFAULT-1
JUMPE N,DATIRR ;DONE IF NONE
PUSHJ P,DATIRM ;MAKE CURRENT DATE, TIME
MOVE T4,FLFUTD ;GET DEFAULT DIRECTION
XCT [CAMGE T1,NOW
JFCL
CAMLE T1,NOW]+1(T4) ;SEE IF OK
JRST DATIRR ;YES--GO RETURN
SKIPG FLFUTD ;NO--SEE WHICH DIRECTION
SOSA VAL2(N) ;PAST
AOS VAL2(N) ;FUTURE
DATIRR: PUSHJ P,DATIRM ;REMAKE ANSWER
MOVE N,T1 ;MOVE TO ANSWER
;HERE WITH FINAL RESULT, CHECK FOR OK
RADIX 10
DATIMX: MOVEI T1,.TDTTM ;SET DATE-TIME
MOVEM T1,.LASWD## ; OUTPUTER
CAMGE N,[<1900-1859>*365+<1900-1859>/4+<31-18>+31,,0]
JRST E$$DOR ;OUT OF RANGE
MOVEM N,.NMUL## ;STORE IN .NMUL
POPJ P, ;**RETURN
RADIX 8
M$FAIL (DOR,Date/time out of range)
;SUBROUTINE TO MAKE DATE/TIME
DATIRM: MOVE T1,VAL4 ;GET HOURS
IMULI T1,^D60 ;MAKE INTO MINS
ADD T1,VAL3 ;ADD MINS
IMULI T1,^D60 ;MAKE INTO SECS
ADD T1,VAL2 ;ADD SECS
IMULI T1,^D1000 ;MAKE INTO MILLISECS
MOVE T2,VAL9 ;GET CENTURIES
IMULI T2,^D10 ;MAKE INTO DECADES
ADD T2,VAL8 ;ADD DECADES
IMULI T2,^D10 ;MAKE INTO YEARS
ADD T2,VAL7 ;ADD YEARS
IMULI T2,^D12 ;MAKE INTO MONTHS
ADD T2,VAL6 ;ADD MONTHS
IMULI T2,^D31 ;MAKE INTO DAYS
ADD T2,VAL5 ;ADD DAYS
SUB T2,[^D1900*^D12*^D31] ;REDUCE TO SYSTEM RANGE
PJRST .CNVDT ;CONVERT TO INTERNAL FORM AND RETURN
;SUBROUTINE TO GET TIME IF SPECIFIED
;RETURNS CPOPJ IF NO TIME, SKIP RETURN IF TIME
; WITH TIME IN RH(N) AS FRACTION OF DAY
;USES T1-4, N
DATIC: CAIE C,":" ;SEE IF TIME NEXT
POPJ P, ;NO--MISSING TIME
PUSHJ P,.DECNW## ;GET DECIMAL NUMBER FOR TIME
;HERE WITH FIRST TIME FIELD IN N
DATIG: JUMPL N,E$$NND ;ERROR IF NEGATIVE
CAIL N,^D24 ; AND GE 24,
JRST E$$DFL ;GIVE ERROR--TOO LARGE
MOVEM N,VAL4 ;SAVE HOURS
CAIE C,":" ;SEE IF MINUTES COMING
JRST DATID ;NO--DONE
PUSHJ P,.DECNW## ;YES--GET IT
CAIL N,^D60 ;SEE IF IN RANGE
JRST E$$DFL ;NO--GIVE ERROR
JUMPL N,E$$NND ;ERROR IF NEG
MOVEM N,VAL3 ;SAVE MINUTES
CAIE C,":" ;SEE IF SEC. COMING
JRST DATID ;NO--DONE
PUSHJ P,.DECNW## ;GET SECONDS
CAIL N,^D60 ;CHECK RANGE
JRST E$$DFL ;NO--GIVE ERROR
JUMPL N,E$$NND ;ERROR IF NEG
MOVEM N,VAL2 ;SAVE SECONDS
;HERE WITH TIME IN VAL2-4
DATID: SKIPGE T1,VAL4 ;GET HOURS
MOVEI T1,0 ; UNLESS ABSENT
IMULI T1,^D60 ;CONV TO MINS
SKIPL VAL3 ;IF MINS PRESENT,
ADD T1,VAL3 ; ADD MINUTES
IMULI T1,^D60 ;CONV TO SECS
SKIPL VAL2 ;IF SECS PRESENT,
ADD T1,VAL2 ; ADD SECONDS
MOVEI T2,0 ;CLEAR OTHER HALF
ASHC T1,-^D17 ;MULT BY 2**18
DIVI T1,^D24*^D3600 ;DIVIDE BY SECONDS/DAY
MOVE N,T1 ;RESULT IS FRACTION OF DAY IN RH
JRST .POPJ1## ;RETURN
;DATE/TIME ERRORS
M$FAIL (NFT,Date/time must be in the future)
M$FAIL (NPS,Date/time must be in the past)
M$FAIL (NND,Negative number in date/time)
M$FAIL (NPF,Not known whether past or future in date/time)
M$FAIL (DFL,Field too large in date/time)
M$FAIL (DFZ,Field zero in date/time)
M$FAIL (UDM,Unrecognized month in date/time)
M$FAIL (ILR,Illegal year format in date/time)
M$FAIL (UDN,Unrecognized name in date/time)
M$FAIL (MDD,Missing day in date/time)
M$FAIL (DTM,Value missing in date/time)
;MNEMONIC WORDS IN DATE/TIME SCAN
DEFINE XX($1),<
EXP <SIXBIT /$1/>>
DAYS: XX WEDNESDAY
XX THURSDAY
XX FRIDAY
XX SATURDAY
XX SUNDAY
XX MONDAY
XX TUESDAY
MONTHS: XX JANUARY
XX FEBRUARY
XX MARCH
XX APRIL
XX MAY
XX JUNE
XX JULY
XX AUGUST
XX SEPTEMBER
XX OCTOBER
XX NOVEMBER
XX DECEMBER
SPCDAY: XX YESTERDAY
XX TODAY
XX TOMORROW
SPLGTM: XX LOGIN
SPNOON: XX NOON
SPMIDN: XX MIDNIGHT
SPDATM: XX LUNCH
XX DINNER
LSPDTM==.-DAYS
;POINTERS
MONPTR: IOWD ^D12,MONTHS
MNDPTR: IOWD LSPDTM,DAYS
SUBTTL ROUTINES TO COVERT DATE/TIME FORMATS
;.CNTDT -- SUBROUTINE TO CONVERT FROM INTERNAL DATE/TIME FORMAT
;CALL: MOVE T1,DATE/TIME
; PUSHJ P,.CNTDT
; RETURN WITH T1=TIME IN MS., T2=DATE IN SYSTEM FORMAT (.LT. 0 IF ARG .LT. 0)
;BASED ON IDEAS BY JOHN BARNABY, DAVID ROSENBERG, PETER CONKLIN
;USES T1-4
.CNTDT: PUSH P,T1 ;SAVE TIME FOR LATER
JUMPL T1,CNTDT6 ;DEFEND AGAINST JUNK INPUT
HLRZ T1,T1 ;GET DATE PORTION (DAYS SINCE 1858)
RADIX 10 ;**** NOTE WELL ****
ADDI T1,<1857-1500>*365+<1857-1500>/4-<1857-1500>/100+<1857-1500>/400+31+28+31+30+31+30+31+31+30+31+17
;T1=DAYS SINCE JAN 1, 1501
IDIVI T1,400*365+400/4-400/100+400/400
;SPLIT INTO QUADRACENTURY
LSH T2,2 ;CONVERT TO NUMBER OF QUARTER DAYS
IDIVI T2,<100*365+100/4-100/100>*4+400/400
;SPLIT INTO CENTURY
IORI T3,3 ;DISCARD FRACTIONS OF DAY
IDIVI T3,4*365+1 ;SEPARATE INTO YEARS
LSH T4,-2 ;T4=NO DAYS THIS YEAR [311]
LSH T1,2 ;T1=4*NO QUADRACENTURIES [311]
ADD T1,T2 ;T1=NO CENTURIES [311]
IMULI T1,100 ;T1=100*NO CENTURIES [311]
ADDI T1,1501(T3) ;T1 HAS YEAR, T4 HAS DAY IN YEAR [311]
MOVE T2,T1 ;COPY YEAR TO SEE IF LEAP YEAR
TRNE T2,3 ;IS THE YEAR A MULT OF 4? [311]
JRST CNTDT0 ;NO--JUST INDICATE NOT A LEAP YEAR [311]
IDIVI T2,100 ;SEE IF YEAR IS MULT OF 100 [311]
SKIPN T3 ;IF NOT, THEN LEAP [311]
TRNN T2,3 ;IS YEAR MULT OF 400? [311]
TDZA T3,T3 ;YES--LEAP YEAR AFTER ALL [311]
CNTDT0: MOVEI T3,1 ;SET LEAP YEAR FLAG [311]
;T3 IS 0 IF LEAP YEAR
;UNDER RADIX 10 **** NOTE WELL ****
CNTDT1: SUBI T1,1900 ;SET TO SYSTEM ORIGIN
IMULI T1,31*12 ;CHANGE TO SYSTEM PSEUDO DAYS
JUMPN T3,CNTDT2 ;IF NOT LEAP YEAR, PROCEED
CAIGE T4,31+29 ;LEAP YEAR--SEE IF BEYOND FEB 29
JRST CNTDT5 ;NO--JUST INCLUDE IN ANSWER
SOS T4 ;YES--BACK OFF ONE DAY
CNTDT2: MOVSI T2,-11 ;LOOP FOR 11 MONTHS
CNTDT3: CAMGE T4,MONTAB+1(T2) ;SEE IF BEYOND THIS MONTH
JRST CNTDT4 ;YES--GO FINISH UP
ADDI T1,31 ;NO--COUNT SYSTEM MONTH
AOBJN T2,CNTDT3 ;LOOP THROUGH NOVEMBER
CNTDT4: SUB T4,MONTAB(T2) ;GET DAYS IN THIS MONTH
CNTDT5: ADD T1,T4 ;INCLUDE IN FINAL RESULT
CNTDT6: EXCH T1,(P) ;SAVE ANSWER, GET TIME
TLZ T1,-1 ;CLEAR DATE
MUL T1,[24*60*60*1000] ;CONVERT TO MILLI-SEC.
ASHC T1,17 ;POSITION RESULT
POP P,T2 ;RECOVER DATE
POPJ P, ;RETURN
;.GTNOW -- COMPUTE CURRENT TIME IN SPECIAL FORMAT
;CALL: PUSHJ P,.GTNOW
;RETURNS WITH RESULT IN T1
;USES T2, T3, T4
;GETTAB CONVERTED TO JSYS SINCE THE GETTAB WAS FAILING
;BY PAUL ROBINSON, WESLEYAN UNIV. DECUS CONVERSION PROGRAMMER JULY'80
OPDEF GTAD [JSYS ^O227]
.GTNOW: ;MOVX T1,%CNDTM ;ASK MONITOR [310]
;GETTAB T1, ; FOR ANSWER [310]
IFE T1-1,<GTAD> ;JSYS USES AC 1
IFN T1-1,<PUSH P,1 ;SAVE AC 1
GTAD ;GET DATE/TIME
MOVE T1,1 ;PUT IT WHERE IT'S WANTED
POP P,1 ;RESTORE AC 1
>; END IFN
CAMN T1,[EXP -1] ;JSYS RETURNS -1 IF DOESN'T KNOW TIME
ERROR. EF$FTL,CGN,<CAN'T GET 'NOW' FROM MONITOR>
JRST GETNWX ;GO GIVE RESULT
;UNDER RADIX 10 **** NOTE WELL ****
;FALL HERE FROM .GTNOW
;.CNVDT -- CONVERT ARBITRARY DATE TO SPECIAL FORMAT
;CALL: MOVE T1,TIME IN MILLISEC.
; MOVE T2,DATE IN SYSTEM FORMAT (Y*12+M)*31+DAY SINCE 1/1/64
; PUSHJ P,.CNVDT
;RETURNS WITH RESULT IN T1 (.GT.0; OR -1 IF BEYOND SEPT. 27,2217)
; NOTE THAT IN SPECIAL FORMAT, THE LEFT HALF DIVIDED
; BY 7 GIVES THE DAY OF THE WEEK (0=WED.)
;USES T2, T3, T4
.CNVDT: PUSHJ P,.SAVE1## ;PRESERVE P1
PUSH P,T1 ;SAVE TIME FOR LATER
IDIVI T2,12*31 ;T2=YEARS-1900
CAILE T2,2217-1900 ;SEE IF BEYOND 2217
JRST GETNW2 ;YES--RETURN -1
IDIVI T3,31 ;T3=MONTHS-JAN, T4=DAYS-1
ADD T4,MONTAB(T3) ;T4=DAYS-JAN 1
MOVEI P1,0 ;LEAP YEAR ADDITIVE IF JAN, FEB
CAIL T3,2 ;CHECK MONTH
MOVEI P1,1 ;ADDITIVE IF MAR-DEC
MOVE T1,T2 ;SAVE YEARS FOR REUSE
ADDI T2,3 ;OFFSET SINCE LEAP YEAR DOES NOT GET COUNTED
IDIVI T2,4 ;HANDLE REGULAR LEAP YEARS
CAIE T3,3 ;SEE IF THIS IS LEAP YEAR
MOVEI P1,0 ;NO--WIPE OUT ADDITIVE
ADDI T4,<1900-1859>*365+<1900-1859>/4+<31-18>+31(T2)
;T4=DAYS BEFORE JAN 1,1900 +SINCE JAN 1
; +ALLOWANCE FOR ALL LEAP YEARS SINCE 64
MOVE T2,T1 ;RESTORE YEARS SINCE 1900
IMULI T2,365 ;DAYS SINCE 1900
ADD T4,T2 ;T4=DAYS EXCEPT FOR 100 YR. FUDGE
HRREI T2,-100-1(T1) ;T2=YEARS SINCE 2001
JUMPLE T2,GETNW1 ;ALL DONE IF NOT YET 2001
IDIVI T2,100 ;GET CENTURIES SINCE 2001
SUB T4,T2 ;ALLOW FOR LOST LEAP YEARS
CAIE T3,99 ;SEE IF THIS IS A LOST L.Y.
GETNW1: ADD T4,P1 ;ALLOW FOR LEAP YEAR THIS YEAR
CAILE T4,^O377777 ;SEE IF TOO BIG
GETNW2: SETOM T4 ;YES--SET -1
POP P,T1 ;GET MILLISEC TIME
MOVEI T2,0 ;CLEAR OTHER HALF
ASHC T1,-17 ;POSITION
DIV T1,[24*60*60*1000] ;CONVERT TO 1/2**18 DAYS
HRL T1,T4 ;INCLUDE DATE
GETNWX: POPJ P, ;RETURN
;UNDER RADIX 10 **** NOTE WELL ****
MONTAB: EXP 0,31,59,90,120,151,181,212,243,273,304,334,365
RADIX 8
SUBTTL DATE/TIME OUTPUT
;.TDTTM -- TYPE DATE AND TIME IN UNIVERSAL FORMAT
;CALL: MOVE T1,DATE/TIME IN UNIVERSAL FORMAT
; CALL .TDTTM
;USES T1-4
.TDTTM: PUSHJ P,.CNTDT ;DISASSEMBLE
SAVE$ T1 ;SAVE TIME
MOVE T1,T2 ;POSITION DATE
PUSHJ P,.TDATE ;TYPE DATE
PUSHJ P,.TCOLN## ;AND A COLON
RESTR$ T1 ;GET TIME
PJRST .TTIME## ;TYPE IT AND RETURN
;.TDATX -- TYPE DAY AND DATE IN UNIVERSAL FORMAT
;CALL: MOVE T1,DATE/TIME IN UNIVERSAL FORMAT
; CALL .TDATX
;USES T1-4
.TDATX: PUSH P,T1 ;REMEMBER UNIVERSAL DATE/TIME
HLRZS T1 ;POSITION DATE TO RIGHT HALF
IDIVI T1,7 ;FIGURE DAY OF WEEK
MOVEI T1,DAYOFW(T2) ;GET STRING ADDRESS
CALL .TSTRG## ;SEND DAY STRING
POP P,T1 ;GET DATE BACK
CALL .CNTDT ;DISSASSEMBLE
MOVE T1,T2 ;POSITION DATE
; PJRST .TDATE ;TYPE AND RETURN
;.TDATE -- TYPE DATE IN STANDARD FORMAT OF DD-MMM-YY
;CALL: MOVEI T1,DATE IN SYSTEM FORMAT FROM DATE UUO
; PUSHJ P,.TDATE
;USES T1-4
.TDATE: PUSHJ P,.SAVE1## ;SAVE P1
IDIVI T1,^D31 ;GET DAYS
MOVE T4,T1 ;SAVE REST
MOVEI T1,1(T2) ;GET DAYS AS 1-31
MOVEI T2," " ;FILL WITH SPACE
PUSHJ P,.TDEC2## ;TYPE IN DECIMAL
IDIVI T4,^D12 ;GET MONTHS
MOVEI T1,[ASCIZ /-Jan/
ASCIZ /-Feb/
ASCIZ /-Mar/
ASCIZ /-Apr/
ASCIZ /-May/
ASCIZ /-Jun/
ASCIZ /-Jul/
ASCIZ /-Aug/
ASCIZ /-Sep/
ASCIZ /-Oct/
ASCIZ /-Nov/
ASCIZ /-Dec/](P1) ;GET ASCII
PUSHJ P,.TSTRG## ;TYPE IT
MOVEI T1,(T4) ;GET YEAR SINCE 1900
IDIVI T1,^D100 ;GET JUST YEARS IN CENTURY
MOVEI T1,"-" ;GET A SIGN
CALL .TCHAR## ;SEND IT
MOVE T1,T2 ;POSITION YEARS
MOVEI T2,"0" ;FILL WITH A ZERO
PJRST .TDEC2## ;TYPE AND RETURN
DAYOFW: ASCII /WED /
ASCII /THU /
ASCII /FRI /
ASCII /SAT /
ASCII /SUN /
ASCII /MON /
ASCII /TUE /
SUBTTL OPEN I/O CHANNELS
;OPENIO
;CALL: MOVEI T1,<FDB ADDR>
; CALL OPENIO
; CAI CHANNEL,BUFADR ;@ IF OUTPUT, (MODE)
; *ALL IS WELL*
OPENIO: HRL T1,0(P) ;REMEMBER CALLER
AOS 0(P) ;SKIP ARGS ON RETURN
CALL .SAVE3## ;PRESERVE REGISTERS
MOVS P1,T1 ;COPY ARGUMENTS
MOVE P2,(P1) ;GET REST OF THEM
MOVSI T1,.FXLEN ;SETUP FOR .STOPB
HLR T1,P1 ;...
MOVEI T2,OPNBLK ;
MOVE T3,[XWD .RBTIM+1,LKPBLK] ;
MOVEI T4,PTHBLK
CALL .STOPB## ;CONVERT TO OPEN/LOOKUP BLOCKS
JRST WLDERR ;NO WILDCARDING!
MOVEI T1,.RBTIM ;SETUP COUNT
MOVEM T1,LKPBLK+.RBCNT
LDB T1,[POINT 4,P2,17] ;GET MODE
MOVEM T1,OPNBLK ;STORE IN OPEN BLOCK
HRRZ T1,P2 ;BUFFER HEADER ADDRESS
TLNE P2,ATSIGN ;READ OR WRITE?
MOVSS T1 ;WRITING, POSITON FOR IT
MOVEM T1,OPNBLK+.OPBUF;STORE
LDB P3,[POINT 4,P2,12] ;GET I/O CHANNEL
LSH P3,5 ;POSITION
MOVSS P3 ;IN CHANNEL POSITION
MOVE T1,[OPEN OPNBLK];FORM INSTR
OR T1,P3 ;FINISH
XCT T1 ;TRY TO OPEN DEVICE
JRST OPENER ;CAN'T--BOMB OUT
MOVE T1,P3 ;REGET I/O CHANNEL
TLNE P2,ATSIGN ;READ/WRITE?
TLOA T1,(ENTER) ;WRITE
TLO T1,(LOOKUP) ;READ
HRRI T1,LKPBLK ;COMPLETE INSTR
XCT T1 ;FIND/WRITE THE FILE
JRST LKENER ;OOPS
POPJ P, ;OK--RETURN
$POPJ2: AOS (P) ;SKIP 2
$POPJ1: AOS (P) ;SKIP 1
$POPJ: POPJ P, ;SKIP 0
;OPENIO ERRORS
OPENER: HLRZ T1,P1 ;COPY FDB ADDR
ERROR. EF$FTL!EF$FIL,COD,<CAN'T OPEN DEVICE, FILE >
WLDERR: HLRZ T1,P1 ;GET FDB
ERROR. EF$FTL!EF$FIL,WFI,<WILDCARD FILESPEC ILLEGAL, FILE >
LKENER: HRRZ T1,LKPBLK+.RBEXT;GET FAIL CODE
ERROR. EF$ERR!EF$OCT!EF$NCR,LER,<LOOKUP/ENTER ERROR(>
STRNG$ <) FILE >
HLRZ T1,P1
CALL .TFBLK## ;TYPE SCAN BLOCK
CALL .TCRLF## ;NEW LINE
JRST ERRFTL ;GO DIE
;CALL HERE WITH CHAR IN T1 TO OUTPUT
CHROUT: SOSG OBHR+.BFCTR ;ROOM?
JRST CHRO.1 ;NO
CHRO.0: IDPB T1,OBHR+.BFPTR ;YES--STORE IT
POPJ P,
CHRO.1: CALL XCTIO ;DO IT
OUT OUTC, ;XCT'D
HALT .+1 ;SNH
JRST CHRO.0 ;STORE CHAR
SUBTTL XCTIO EXECUTES IN/OUT UUO WITH ERROR HANDLING
;XCTIO
;CALL: CALL XCTIO
; <INSTR TO XCT> ;IN/OUT UUO
; *EOF/EOT RETURN*
; *NORMAL RETURN*
XCTIO: XCT @0(P) ;DO THE INSTR
JRST $POPJ2 ;OK--SKIP 2 AND RETURN
SAVE$ T1 ;OOPS--SAVE T1
MOVE T1,@-1(P) ;GET INSTR WE FAILED ON
AOS -1(P) ;SKIP INSTR ON WAY BACK
AND T1,[17B12] ;ERROR--GET THE CHANNEL
OR T1,[GETSTS T2] ;GET ERRROR BITS
XCT T1
TRNE T2,IO.EOF!IO.EOT;END OF SOMETHING?
JRST TPOPJ ;YES
EXCH T1,T2 ;NO--GET BITS IN RIGHT PLACE, SAVE I/O INSTR
HRR T2,T1 ;PUT BITS IN THE INSTR
SAVE$ T2 ;SAVE I/O INSTR A SEC
WARN. EF$NCR!EF$OCT,IOE,<I/O ERROR - STATUS=>
; STRNG$ <, FILE >
; LDB T1,[POINT 4,(P),12] ;GET CHANNEL
; MOVE T1,[EXP INPSPC,OUTSPC]-1(T1) ;GET FDB ADDRESS
; CALL .TFBLK## ;TYPE FILE
STRNG$ < - CONTINUING
>
RESTR$ T1 ;GET INSTR BACK
TRZ T1,IO.ERR ;CLEAR ERROR BITS
TLZ T1,002000 ;GETSTS BECOMES SETSTS
XCT T1
TPOPJ1: RESTR$ T1 ;GET T1 AGAIN
AOSA (P)
TPOPJ: RESTR$ T1
POPJ P,
SUBTTL ERROR HANDLER
;EHNDLR -- HANDLE ALL ERRORS
;THE ONLY CALL IS THRU THE ERROR. MACRO
EHNDLR: CALL SAVACS ;SAVE THE ACS
MOVE P1,@0(P) ;GET FLAGS AND ADDRESSES
SKIPN @.TYOCH## ;IS SCAN TTCALLING?
JRST [SETZM ERRTYX ;YES--CLEAR FLAG
JRST EHND.0] ;AND SKIP ON
SETZ T1, ;NO--SO MAKE IT
CALL .TYOCH## ;TELL SCAN
MOVEM T1,ERRTYX ;REMEMBER/SET FLAG
EHND.0: MOVEI T1,"?" ;ASSUME AN ERROR
TLNE P1,EF$WRN ;CHECK WARNING
MOVEI T1,"%" ;YES
TLNE P1,EF$INF ;IF BOTH OFF NOW THEN INFO
MOVEI T1,"[" ;GOOD THING WE CHECKED
CALL .TCHAR## ;OUTPUT THE START OF MESSAGE
MOVSI T1,MY$PFX ;SET UP MY PREFIX
HLR T1,(P1) ;GET MESSAGE PREFIX
CALL .TSIXN## ;OUTPUT THE PREFIXES
CALL .TSPAC## ;AND A SPACE
HRRZ T1,(P1) ;GET STRING ADDRESS
CALL .TSTRG## ;SEND IT
MOVE T1,SAVAC+T1 ;GET ORIGINAL T1 IN CASE TYPEOUT DESIRED
LDB T2,[POINT 5,P1,17] ;GET TYPED OUT DESIRED
CAILE T2,EF$MAX ;CHECK LEGAL
MOVEI T2,0 ;NOOOP
CALL @ERRTAB(T2) ;CALL THE ROUTINE
TLNE P1,EF$NCR ;IF NO CRLF THEN DON'T CLOSE INFO
JRST EHND.1 ;NO--DON'T CHECK
MOVEI T1,"]" ;PREPARE TO CLOSE INFO
TLNE P1,EF$INF ;CHECK FOR INFO
CALL .TCHAR## ;SEND INFO CLOSE
TLNN P1,EF$NCR ;NO CARRIAGE RETURN?
CALL .TCRLF## ;YES--SEND ONE
EHND.1: SKIPN T1,ERRTYX ;DID WE RESET SCAN?
JRST EHND.2 ;NO
CALL .TYOCH## ;AND RESTORE IT
SETZM ERRTYX ;CLEAR FLAG
EHND.2: TLNE P1,EF$FTL ;NOW CHECK FATAL
JRST ERRFTL ;YES--GO DIE
;FALL INTO RESACS
;RESACS -- RESTORE ALL ACS FROM SAVAC AREA
; CALL RESACS
; *ACS RESTORED FROM SAVAC*
RESACS: MOVEM 17,SAVAC+17 ;SAVE 17 TO RESTORE INTO IT
MOVSI 17,SAVAC
BLT 17,17 ;REGISTERS ARE RESTORED
POPJ P, ;RETURN
ERRTAB: .POPJ## ;CODE 0 -- NO ACTION
.TDECW## ;CODE 1 -- TYPE T1 IN DECIMAL
.TOCTW## ;CODE 2 -- TYPE T1 IN OCTAL
.TSIXN## ;CODE 3 -- TYPE T1 IN SIXBIT
.TPPNW## ;CODE 4 -- TYPE T1 AS PPN
.TSTRG## ;CODE 5 -- T1 POINTS TO ASCIZ STRING
.TFBLK## ;CODE 6 -- T1 POINTS AT FDB
.TDATX ;CODE 7 -- TYPE T1 AS DAY/DATE
;HERE TO DIE--
ERRFTL: SAVE$ .JBFF ;SAVE JBFF OVER RESET
RESET ;KILL ALL FILES
RESTR$ .JBFF ;GET JOBFF BACK
MOVE P,INIPDP ;RESET PDL
CALL .CLRBF## ;CLEAR ANY TYPE AHEAD OR UNEATEN COMMANDS
SKIPE OFFSET ;CCL ENTRY
CALL .MONRT## ;YES--EXIT 1,
JRST RESTRT ;AND RESTART ON CONTINUE
;SAVAC -- SAVE ALL ACS
;CALL -- PUSHJ P,SAVACS
; *ACS SAVED IN SAVAC* BEWARE!!
SAVACS: MOVEM 17,SAVAC+17 ;SAVE ONE
MOVEI 17,SAVAC
BLT 17,SAVAC+16
MOVE 17,SAVAC+17
POPJ P, ;ACS ARE SAVED
SUBTTL STORAGE
;STORAGE THAT REMAINS BETWEEN RUNS
U (ISCNVL) ;VALUE FROM .ISCAN
U (TLDVER) ;-1 WHEN TYPED VERSION TO TTY
U (OFFSET) ;STARTING OFFSET
U (LOGTIM) ;JOB LOGIN TIME
FW$ZER==. ;FIRST WORD ZEROED
U (PDLIST,LN$PDL) ;PUSHDOWN LIST
U (SAVAC,20) ;SAVE ACS HERE
U (PLTBUF,PLTBSZ+1) ;FORM A LINE HERE
U (FLFUTD) ;FLAGS FOR DATE-TIME GETTER
U (FLFUTR)
U (NOW) ;CURRENT DATE/TIME
U (VAL1) ;DON'T SEPARATE VALX
U (VAL2)
U (VAL3)
U (VAL4)
U (VAL5)
U (VAL6)
U (VAL7)
U (VAL8)
U (VAL9)
U (TEMP) ;TEMP
U (IPOS)
U (EPOS)
U (PPOS)
U (FILSPC,.FXLEN) ;SCAN FILE SPEC
U (OPNBLK,3) ;OPEN BLOCK
U (LKPBLK,.RBTIM) ;LOOKUP/ENTER BLOCK
U (PTHBLK,^D9) ;PATH BLOCK
U (ERRTYX) ;FLAG FOR EHNDLR
U (IBHR,3) ;INPUT BUFFER HEADER
U (OBHR,3) ;OUTPUT BUFFER HEADER
SCN$FZ==. ;FIRST WORD ZEROED AT CLRANS
SCN$LZ==.-1 ;LAST WORD ZEROED AT CLRANS
SCN$FO==. ;FIRST WORD MINUS ONNED AT CLRANS
U (BIRTHD) ;/BIRTHDAY ARG
U (BEGNDT) ;/BEGIN
U (ENDATE) ;/END
U (PBEGND) ;PXXX SWITCHES (NOT USED)
SCN$LO==.-1 ;LAST WORD ONNED AT CLRANS
LW$ZER==.-1 ;LAST WORD ZEROED AT STARTUP
END BIORTH