;* Updated on 16-Oct-89 at 9:03 PM by Ami Bar-Yadin; edit time: 0:06:03 *;
; Dates operations
VMAJOR=1
VMINOR=2
VEDIT=107.
;
; [107] 16-Oct-89 Ami Bar-Yadin
; A bug in Function 8 ($IDTIM interface) was accidentaly discovered
;
; (C)1988 By Ami Bar-Yadin.
; AMUS ID: AMI/AM
;
;-All commercial rights reserved, etc.
;-No warranties and/or guarranties of any kind, etc.
;-Not responsible for damages resulting from the use of this program, etc.
;-My employer (United Fashions) has nothing to do with this program and
; should not be blamed for it.
;
; I can be reached at:
; United Fashions of Texas, Inc.
; 200 Ash Ave.
; McAllen, TX 78501
; (512) 631-2277/2276
; 8am-6pm
;
;
; Date formats:
; ASCII ADATE,S,8 ("01/05/83") S,8
;
; Seperated XDATE X,{3..7}
; MONTH,B,1
; DAY,B,1
; YEAR,B,1
; DOW,B,1 1=MON..7=SUN
; YWEEK,B,1 Week of year 1-52
; MWEEK,B,1 Week of month 1-5
; MDAYS,B,1 Days in month 1-31
;
; Internal IDATE,B,4 True Julian B,4
; AlphaBASE BDATE,B,3 Same as seperated X,3 above
; 16 bit CDATE,B,2 Century Julian B,2
; Julian JDATE,F Yearly Julian F
; (assuming current year)
;
;
; SPECIAL CASE:
; ============
; A floating point 0 will be converted to today's date on input.
; For example:
; XCALL DATES,1,RESULT,0,A$
; Will return A$ with today's date.
; However:
; XCALL DATES,1,RESULT,TODAY,F
; (Where TODAY is todays date in any format)
; Will ALWAYS return a non-zero.
;
;
; FUNCTIONS:
; 1 XCALL DATES,1,RESULT,date,date
; Convert from any format to any format
; XCALL DATES,1,RESULT,ADATE,SDATE
; will convert an ASCII date to standard date
;
; 2 XCALL DATES,2,RESULT,date1,date2,days
; Will compute date2 = date1 + days
;
; 3 XCALL DATES,3,RESULT,date1,date2,days
; Will compute days = date1 - date2
;
; 4 XCALL DATES,4,RESULT,date1,date2
; Will compute date given year, week, and DOW
; date1 given as BDATE,X,5 or X,6
;
; 5 XCALL DATES,5,RESULT,date1,date2
; Will compute date given year, month, week and DOW
; date1 given as BDATE,X,6
;
; 6 XCALL DATES,6,RESULT,date1,date2
; Will compute date2=last day of month in date1
;
; 7 XCALL DATES,7,RESULT,DATE,TIME,FLAGS,OUTPUT UFFER or FILE#
; (interface) $ODTIM: Output Date and Time (Time last)
; Entry: D3=Date, D4=time (0=use sys)(separated), D5=format flags,A2->out
; Return: A2->nxt char (if used)
;
; 8 XCALL DATES,8,RESULT,INPUT,FLAGS,OUTPUT DATE,OUTPUT TIME
; (interface) $IDTIM: Input Date and/or Time (if both, time must be first)
; Entry: A2->Input string, D5(bit 0)=1:no date,(bit 1)=1:no time
; Return: D3=date (separated), D4=time (separated), A2->nxt chr
; N set:error
;
; 9 XCALL DATES,9,RESULT,DATE,LODATE,HIDATE,DATEOK
; Check if DATE is between LODATE and HIDATE (inclusive)
; ie. DATEOK is <>0 if LODATE <= DATE <= HIDATE
; NOTE: DATEOK must be a floating point variable.
;
;
; RESULT (F) CODES:
; 0 ALL OK
; 1 FUNCTION NUMBER OUT OF RANGE (1..9)
; 2 ERROR IN CONVERSION OF INPUT DATE
; 3 INVALID FORMAT FOR DATE
; 4 IMPROPER NUMBER/TYPE OF PARAMETERS
; 5 INVALID FORMAT FOR DAYS
; 6 ERROR LOCATING FILE CHANNEL
;
SYM
OBJNAM .SBR
SEARCH SYS
SEARCH SYSSYM
RADIX 16.
DEFAULT $$MFLG,PV$RSM
DEFAULT $$SFLG,PH$REE!PH$REU
PHDR -1,$$MFLG,$$SFLG
EXTERN $IDTIM,$DSTOI,$ODTIM,$FLSET
;
;
CNTURY = 2415021. ; CONVERT IDATE<-->CDATE
; SOME BASIC XCALL INTERFACING MACROS
;
; Move the type field from the Nth parameter block off the
; BASIC XCALL parameters list into DEST
;
DEFINE BTYPE N,DEST
1$$ = 2+^D10*<N-1>
CLR DEST
MOVW 1$$(A3),DEST
ENDM
;
;
; Move the address field from the Nth parameter block off the
; BASIC XCALL parameters list into DEST
;
DEFINE BADRS N,DEST
1$$ = 4+^D10*<N-1>
MOVL 1$$(A3),DEST
ENDM
;
;
; Move the size field from the Nth parameter block off the
; BASIC XCALL parameters list into DEST
;
DEFINE BSIZE N,DEST
1$$ = 8+^D10*<N-1>
MOVL 1$$(A3),DEST
ENDM
;
DATES:
MOV SP,A5 ; SAVE STACK POINTER
CALL SETUP
CALL GETFUN ; GET FUNCTION VALUE (D0) 1..9
DEC D0 ; adjust to 0..8
CMP D0,#8.
BHI 30$
ASL D0,#1
LEA A6,FTBL
CLR D7
MOVW 0(A6)[~D0],D7
ADD D7,A6
JMP @A6
30$:
MOV #1,D1
EXIT: BADRS 2,A0 ; SET RESULT CODE
FLTOF D1,@A0
MOV A5,SP
RTN
DEFINE FUNCT ENTRY
WORD ENTRY-FTBL
ENDM
FTBL:
FUNCT CONVRT
FUNCT COMPDT
FUNCT COMPDY
FUNCT COMPYW
FUNCT COMPMW
FUNCT COMPEM
FUNCT IODTIM
FUNCT IIDTIM
FUNCT RNGEDT
WORD 0
CONVRT:
MOV #4,D1
CMPW @A3,#4
JNE EXIT
CALL GETIDT ; CONVERT DATE1 TO INTERNAL FORMAT (D2)
CALL PUTIDT ; CONVERT INTERNAL (D2) TO DATE2
CLR D1
BR EXIT ; SET RESULT AND EXIT
COMPDT:
MOV #4,D1
CMPW @A3,#5
JNE EXIT
CALL GETIDT ; CONVERT DATE1 TO INTERNAL FORMAT (D2)
CALL GETDAY ; GET NUMBER OF DAYS (D3)
ADD D3,D2 ; D2=D2+D3
CALL PUTIDT
CLR D1
BR EXIT
COMPDY:
MOV #4,D1
CMPW @A3,#5
JNE EXIT
CALL GETIDT
CALL GETID2 ; GET 2ND DATE (D3)
SUB D3,D2
CALL PUTDAY ; SET NO OF DAYS (D2)
CLR D1
BR EXIT
COMPYW:
MOV #4,D1
CMPW @A3,#4
JNE EXIT
MOV #3,D1
BTYPE 3,D0
TST D0
JNE EXIT
BSIZE 3,D0
CMP D0,#5
JLT EXIT
BADRS 3,A2
MOV #01010000,D7
MOVB 2(A2),D7
CALL $DSTOI
MOV D7,D3 ; D3=START'I'JUL
SUB #CNTURY,D7
DIV D7,#7
SWAP D7
MOV D7,D4 ; D4=START'DOW
; I'JUL=START'I'JUL+(YWEEK-1)*7+DOW-START'DOW
CLR D7 ; D7=0
MOVB 4(A2),D7 ; D7=YWEEK
DECB D7 ; D7=YWEEK-1
MUL D7,#7 ; D7=(YWEEK-1)*7
ADD D3,D7 ; D7=START'I'JUL+(YWEEK-1)*7
CLR D3
MOVB 3(A2),D3 ; D3=DOW
DEC D3 ; (PUT DOW IN 0..6 RANGE)
ADD D3,D7 ; D7=START'I'JUL+(YWEEK-1)*7+DOW
MOVB D4,D3
SUB D3,D7 ; D7=START'I'JUL+(YWEEK-1)*7+DOW-START'DOW
MOV D7,D2
CALL PUTIDT
CLR D1
JMP EXIT
COMPMW:
MOV #4,D1
CMPW @A3,#4
JNE EXIT
MOV #3,D1
BTYPE 3,D0
TST D0
JNE EXIT
BSIZE 3,D0
CMP D0,#6
JLT EXIT
BADRS 3,A2
MOV #0100,D7
MOVB @A2,D7
SWAP D7
MOVB 2(A2),D7
CALL $DSTOI
MOV D7,D3 ; D3=START'I'JUL
SUB #CNTURY,D7
DIV D7,#7
SWAP D7
CLR D4
MOVB D7,D4 ; D4=START'DOW
; IF D'DOW=0 MWEEK=MWEEK-1
; I'JUL=START'I'JUL+MWEEK*7+DOW-START'DOW
CLR D7 ; D7=0
MOVB 5(A2),D7 ; D7=MWEEK
; TST D4
; BEQ 1$
DECB D7
1$: MUL D7,#7 ; D7=MWEEK*7
ADD D3,D7 ; D7=START'I'JUL+MWEEK*7
CLR D3
MOVB 3(A2),D3 ; D3=DOW
DEC D3 ; (PUT DOW IN 0..6 RANGE)
ADD D3,D7 ; D7=START'I'JUL+MWEEK*7+DOW
MOVB D4,D3
SUB D3,D7 ; D7=START'I'JUL+MWEEK*7+DOW-START'DOW
MOV D7,D2
CALL PUTIDT
CLR D1
JMP EXIT
COMPEM:
MOV #4,D1
CMPW @A3,#4
JNE EXIT
CALL GETIDT ; CONVERT DATE1 TO INTERNAL FORMAT (D2)
MOV D2,D7
CALL DITOS ; CONVERT TO SEPERATE FORMAT
ADD #000010000,D7 ; MONTH=MONTH+1
AND #000FFFFFF,D7 ; DAY=0
CALL $DSTOI ; CONVERT BACK TO INTERNAL
MOV D7,D2
CALL PUTIDT ; CONVERT INTERNAL (D2) TO DATE2
CLR D1
JMP EXIT ; SET RESULT AND EXIT
IODTIM:
; 7 XCALL DATES,7,RESULT,DATE,TIME,FLAGS[,BUFFER or FILE#]
; (interface) $ODTIM: Output Date and Time (Time last)
; Entry: D3=Date, D4=time (0=use sys)(separated), D5=format flags,A2->out
; Return: A2->nxt char (if used)
;
MOV #4,D1 ; ISSUE ERROR IF LESS THAN FIVE
CMPW @A3,#5
JLO EXIT
CMPW @A3,#6 ; OR MORE THAN SIX ARGUMENTS
JHI EXIT
CALL GETIDT ; CONVERT DATE1 TO INTERNAL FORMAT (D2)
MOV D2,D7
CALL DITOS ; CONVERT TO SEPERATE FORMAT
PUSH D7
MOV D2,D7
SUB #CNTURY,D7
DIV D7,#7
SWAP D7
AND #0FF,D7 ; MASK ALL BUT DOW
MOVB D7,3(SP) ; SET DOW
BADRS 4,A2
BTYPE 4,D0
BSIZE 4,D5
CALL GETNUM ;GET TIME ARG (D4)
TST D3 ; if time=0
BNE 10$
GTIMES D3 ; get system time
10$: PUSH D3
BADRS 5,A2
BTYPE 5,D0
BSIZE 5,D5
CALL GETNUM ;GET FLAGS ARG (D5)
PUSH D3
BADRS 6,A2 ;GET BUFFER ADDRESS OR FILE NUMBER ARG
BTST #15.,D3 ;OUTPUT TO FILE?
BEQ 20$ ;NO
BTYPE 5,D0
BSIZE 5,D5
CALL GETNUM ;GET FILE CHANNEL NUMBER
MOV D3,D1
CALL $FLSET ;FIND FILE'S DDB
BEQ 20$ ;EVERYTHING'S OK, PROCEED
MOV #6,D1 ;ERROR #6 BAD CHANNEL NUMBER
JMP EXIT ;ABORT WITH ERROR
20$: POP D5 ;LOAD ARGS INTO PROPER REGISTERS
POP D4 ; D3=DATE, D4=TIME, D5=FLAGS
POP D3
CALL $ODTIM
CLR D1 ;$ODTIM HAS NO ERROR CONDITIONS
JMP EXIT ;RETURN TO CALLER
IIDTIM:
; 8 XCALL DATES,7,RESULT,INPUT,FLAGS,OUTPUT DATE,OUTPUT TIME
; (interface) $IDTIM: Input Date and/or Time (if both, time must be first)
; Entry: A2->Input string, D5(bit 0)=1:no date,(bit 1)=1:no time
; Return: D3=date (separated), D4=time (separated), A2->nxt chr
; N set:error
; OUTPUT DATE AND TIME MUST BE B,4
;
;
;
MOV #4,D1 ; ISSUE ERROR IF NOT SIX ARGUMENTS
CMPW @A3,#6
JNE EXIT
BADRS 4,A2
BTYPE 4,D0
BSIZE 4,D5
CALL GETNUM ;GET FLAGS ARG (D5)
MOV D3,D5
BADRS 3,A2
CALL $IDTIM
BMI 1$
BADRS 5,A1
MOV D3,@A1
BADRS 6,A1
MOV D4,@A1
CLR D1 ;EVERYTHING OK
JMP EXIT ;RETURN TO CALLER
1$: MOV #2,D1
JMP EXIT
RNGEDT:
; 9 XCALL DATES,9,RESULT,DATE,LODATE,HIDATE,DATEOK
; Check if DATE is between LODATE and HIDATE (inclusive)
; ie. DATEOK is <>0 if LODATE <= DATE <= HIDATE
;
BADRS 3,A2 ; get DATE
BTYPE 3,D0
BSIZE 3,D5
CALL GETDAT
PUSH D2 ; save DATE
BADRS 4,A2 ; get LODATE
BTYPE 4,D0
BSIZE 4,D5
CALL GETDAT
POP D0 ; get DATE
CMP D2,D0 ; compare LODATE to DATE
BHI 50$ ; LODATE > DATE; DATE out of range
PUSH D0 ; save DATE
BADRS 5,A2 ; get HIDATE
BTYPE 5,D0
BSIZE 5,D5
CALL GETDAT
MOV #-1,D1 ; assume DATE is in range
POP D0 ; get DATE
CMP D2,D0 ; compare HIDATE to DATE
BHIS 99$ ; HIDATE >= DATE; DATE ok
50$: CLR D1
99$: BADRS 6,A0 ; SET RESULT CODE
FLTOF D1,@A0
CLR D1
JMP EXIT
GETIDT:
; CONVERT DATE1 TO INTERNAL (D2)
SAVE A2,D0,D3,D4,D7
BADRS 3,A2
BTYPE 3,D0
BSIZE 3,D5
CALL GETDAT
REST A2,D0,D3,D4,D7
CLR D1
RTN
GETID2:
; CONVERT DATE2 TO INTERNAL (D3)
SAVE A2,D0,D2,D4,D7
BADRS 4,A2
BTYPE 4,D0
BSIZE 4,D5
CALL GETDAT
MOV D2,D3
REST A2,D0,D2,D4,D7
RTN
PUTIDT:
; CONVERT INTERNAL (D2) TO DATE2
SAVE A2,D0,D2,D3,D4,D5
BADRS 4,A2
BTYPE 4,D5
BSIZE 4,D0
CMP D5,#2
JEQ PTDASC
CMP D5,#4
JEQ PTDF
CMP D5,#6
JEQ PTDB
MOV #3,D1
TST D5
JNE EXIT
; UNFORMATTED (X), 1ST 3 BYTES ARE ALWAYS: MONTH,DAY,YEAR
PTDX: MOV D2,D7
CALL DITOS
MOV D7,D3
PUSH D6 ; # OF DAYS IN MONTH
MOVB D7,2(A2) ; SET YEAR
SWAP D7
MOVB D7,@A2 ; SET MONTH
RORW D7,#8
MOVB D7,1(A2) ; SET DAY
CMP D0,#4
JLO PTDEXT
MOV D2,D7
SUB #CNTURY,D7
DIV D7,#7
SWAP D7
AND #0FF,D7 ; MASK ALL BUT DOW
INCB D7 ; (PUT DOW IN 1..7 RANGE)
MOVB D7,3(A2) ; SET DOW
CMP D0,#5
JLO PTDEXT
;YWEEK=INT((NOW-START+START'DOW)/7)+1
MOV D3,D7
AND #0000FFFF,D7
OR #01010000,D7 ; SET MONTH AND DAY=01/01
CALL $DSTOI ; D7=START
MOV D2,D5 ; D5=NOW
SUB D7,D5
SUB #CNTURY,D7
DIV D7,#7
SWAP D7
AND #0FF,D7 ; MASK ALL BUT DOW
ADD D7,D5
DIV D5,#7
INCB D5
MOVB D5,4(A2)
CMP D0,#6
BLO PTDEXT
;MWEEK=INT((NOW-START+START'DOW)/7)+1
MOV D3,D7
AND #00FFFFFF,D7
OR #01000000,D7 ; SET DAY=01
CALL $DSTOI ; D7=START
MOV D2,D5 ; D5=NOW
SUB D7,D5
SUB #CNTURY,D7
DIV D7,#7
SWAP D7
AND #0FF,D7 ; MASK ALL BUT DOW
ADD D7,D5
DIV D5,#7
MOVB D5,5(A2)
; TSTB D7
; BEQ 1$
INCB 5(A2)
1$:
CMP D0,#7
BLO PTDEXT
;MDAYS
MOV @SP,D6
MOVB D6,6(A2)
PTDEXT: POP
CLR D1
REST A2,D0,D2,D3,D4,D5
RTN
PTDASC: MOV D2,D7
CALL DITOS
MOV D7,D3
MOV #840.,D5
CALL $ODTIM
CMP D0,#8
BLE PTDEXT
CLRB @A2
JMP PTDEXT
PTDB: CMP D0,#3
JEQ PTDX ; B,3 SAME AS X,3
MOV A2,D3
BTST #0,D3
JNE ADRERR
CMP D0,#4
BEQ PTDB4
; ASSUME B,2 FORMAT
MOV D2,D3
SUB #CNTURY,D3
MOVW D3,@A2 ; SET DAYS
JMP PTDEXT
PTDB4: MOV D2,D3
SWAP D3 ; TO FIT BASIC'S B,4 FORMAT
MOV D3,@A2
JMP PTDEXT
PTDF: MOV D2,D7
CALL DITOS
AND #0000FFFF,D7
OR #01010000,D7 ; SET MONTH AND DAY=01/01
CALL $DSTOI
MOV D2,D3
SUB D7,D3
INC D3
FLTOF D3,@A2
JMP PTDEXT
GETDAY:
; GET NUMBER OF DAYS (D3)
SAVE A2,D0,D5
BADRS 5,A2
BTYPE 5,D0
BSIZE 5,D5
CALL GETNUM
REST A2,D0,D5
RTN
GETNUM:
CMP D0,#4 ;CHECK IF ARG IS FLOATING POINT
BNE 1$
FFTOL @A2,D3 ;CONVERT FLOATING POINT ARG
BR 3$ ;BRANCH TO ROUTINE EXIT
1$: MOV #5,D1 ;(ASSUME ERROR#5)
CMP D0,#6 ;CHECK IF ARG IS BINARY
JNE EXIT ;ABORT PROGRAM WITH ERROR IF IMPROPER TYPE
CMP D5,#5 ;CHECK LENGTH OF ARG IN BYTES
JEQ EXIT ;ABORT PROGRAM WITH ERROR IF TOO LONG
ADD D5,A2 ;COMPUTE POINTER TO BYTE PAST ARG
CLR D3 ;CLEAR DESTINATION
2$: LSL D3,#8 ;PREPEARE FOR NEXT BYTE
MOVB -(A2),D3 ;LOAD NEXT BYTE
SOB D5,2$ ;LOOP UNTIL DONE
3$: CLR D1 ;NO ERRORS
RTN
PUTDAY:
; SET NUMBER OF DAYS (D2)
SAVE A2,D0,D2,D5
BADRS 5,A2
BTYPE 5,D0
BSIZE 5,D5
CALL PUTNUM
REST A2,D0,D2,D5
RTN
PUTNUM:
CMP D0,#4
BNE 0$
FLTOF D2,@A2
BR 2$
0$: MOV #5,D1
TST D0
JNE EXIT
CMP D5,#5
JEQ EXIT
1$: MOVB D2,(A2)+
LSR D2,#8
SOB D5,1$
2$: CLR D1
RTN
SETUP:
; SETUP
RTN
GETFUN:
; GET FUNCTION NUMBER (D0)
PUSH A2
BADRS 1,A2
FFTOL @A2,D0
POP A2
RTN
;
DITOS:
; CONVERT INTERNAL DATE (D7) TO SEPERATED DATE (D7),
; SET D6 TO NUMBER OF DAYS IN MONTH
; D2=MONTH
; D3=DAY
; D4=YEAR
;
SAVE D2,D3,D4,A2,A3
CMP D7,#CNTURY
BHIS 0$
CLR D7
BR 10$
0$: SUB #CNTURY,D7
10$: DIV D7,#05B5
CLR D3
MOVW D7,D3
ADDW D3,D3
ADDW D3,D3
CLRW D7
SWAP D7
DIV D7,#016D
ADDW D7,D3
CLR D4
MOVW D3,D4
TSTW D7
BEQ 1$
LEA A2,NORMYR
LEA A3,NORMDS
SWAP D7
BR 2$
1$: LEA A2,LEAPYR
LEA A3,LEAPDS
SWAP D7
INCW D7
2$: MOVW #-1,D3
3$: INCW D3
CMPW D7,(A2)+
BCC 3$
CLR D2
MOVW D3,D2
SUB #4,A2
SUBW @A2,D7
CLR D3
MOVW D7,D3
INC D3
; DY MN DW YR
CLR D7 ; D7=00 00 00 00
MOVB D3,D7 ; D7=00 00 00 D3
RORW D7,#8 ; D7=00 00 D3 00
MOVB D2,D7 ; D7=00 00 D3 D2
SWAP D7 ; D7=D3 D2 00 00
MOVB D4,D7 ; D7=D3 D2 00 D4
MOVB -1(A3)[~D2],D6
REST D2,D3,D4,A2,A3
RTN
RADIX 10.
NORMYR: WORD 0,31,59,90,120,151,181,212,243,273,304,334,365
LEAPYR: WORD 0,31,60,91,121,152,182,213,244,274,305,335,366
NORMDS: BYTE 31,28,31,30,31,30,31,31,30,31,30,31
LEAPDS: BYTE 31,29,31,30,31,30,31,31,30,31,30,31
RADIX 16.
;
GETDAT: CMP D0,#2
JEQ GTDASC
CMP D0,#4
JEQ GTDF
CMP D0,#6
JEQ GTDB
MOV #3,D1
TST D0
JNE EXIT
; UNFORMATTED (X), 1ST 3 BYTES ARE ALWAYS: MONTH,DAY,YEAR
GTDX: CLR D7
MOVB 1(A2),D7
RORW D7,#8
MOVB @A2,D7
SWAP D7
MOVB 2(A2),D7
GTDEXT: TST D7
BEQ 1$
CALL $DSTOI
1$: MOV D7,D2
RTN
GTDASC: MOVB 8(A2),D1
CLRB 8(A2)
MOV #2,D5
PUSH A2
CALL $IDTIM
SETNE D2
POP A2
MOVB D1,8(A2)
MOV #2,D1
TSTB D2
JNE EXIT
MOV D3,D7
JMP GTDEXT
GTDB: CMP D5,#3
JEQ GTDX
MOV A2,D2
BTST #0,D2
JNE ADRERR
CMP D5,#4
BEQ GTDB4
CLR D2
MOVW @A2,D2
ADD #CNTURY,D2
RTN
GTDB4: MOV @A2,D2
SWAP D2 ; CONVERT FROM BASIC'S B,4 FORMAT
RTN
GTDF: FFTOL @A2,D2
BEQ 1$
DEC D2
GDATES D7 ; GET TODAY'S DATE
AND #0000FFFF,D7
OR #01010000,D7 ; SET MONTH AND DAY=01/01
CALL $DSTOI
ADD D7,D2
RTN
1$: GDATEI D2
RTN
;
ADRERR: TYPECR <?Odd address given to DATES.SBR as WORD or LONG>
EXIT
;
END