; Dates operations
;
; (C)1989 By MEDA COMP, INC.
;
;-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.
;
; I can be reached at:
; Meda Comp Computer Systems
; 18587 Sigma Rd. #220
; San Antonio Tx 78258
; (210) 490-9008
; 8am-5pm
;
;
EXTERN $IDTIM,$DSTOI,$ODTIM,$FLSET
;
;
.OFINI
.OFDEF ASCIIB,12 ;ascii work area
.OFSIZ IMPSIZ
XCMEM IMPSIZ ; Check for enough memory
CLEAR @A4,IMPSIZ
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 REG,DEST
1$$ = 2+^D10*<REG-1>
CLR DEST
MOVW 1$$(A3),DEST
ANDW #^H000F,1$$(A3) ;mask off all but last 4 bits
ENDM
;
; Move the address field from the Nth parameter block off the
; BASIC XCALL parameters list into DEST
;
DEFINE BADRS REG,DEST
1$$ = 4+^D10*<REG-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 REG,DEST
1$$ = 8+^D10*<REG-1>
MOVL 1$$(A3),DEST
ENDM
;
DATES:
MOV SP,A5 ; Save the stack pointer
CALL GETFUN ; Get function in to D0
CMP D0,#1
JEQ CONVRT ; Convert DATE1 to DATE2
CMP D0,#2
JEQ COMPDT ; COMPUTE DATE2 = DATE1+ DAYS
CMP D0,#3
JEQ DIFFDT ; COMPUTE DAYS = DATE1- DATE2
CMP D0,#4
JEQ COMPYW ; COMPUTE DATE = YEAR,YWEEK,DOW
CMP D0,#5
JEQ COMPMW ; COMPUTE DATE = YEAR,MONTH,MWEEK,DOW
CMP D0,#6
JEQ COMPEM ; COMPUTE DATE = END OF MONTH
CMP D0,#7
JEQ IODTIM ; $ODTIM INTERFACE
CMP D0,#8.
JEQ IIDTIM ; $IDTIM INTERFACE
JMP FUNERR
EXIT: ;return to caller
BADRS 2,A2
MOVW D5,@A2 ;set return flag
MOV A5,SP ;restore stack pointer
RTN ;return to caller
CONVRT: ; Convert from any format to any format
CMPW @A3,#4 ;4 args?
JNE ARGERR ; no
CALL GETID1 ; convert DATE1 to internal format D2
CALL PUTIDT ; convert INTERNAL D2 to DATE2
BR EXIT ; return to caller
COMPDT: ; Function 2. DATE2 = DATE1+DAYS
CMPW @A3,#5 ;5 vars passed?
JNE ARGERR ; no
CALL GETID1 ;DATE1 to internal in D2
MOV #5,D0
CALL SETXC
CALL XVALUE ;days to add in D1
ADD D1,D2 ; D2=D2+D1
CALL PUTIDT
BR EXIT
DIFFDT: ; Function 3. DAYS = DATE2-DATE1
CMPW @A3,#5 ;5 args?
JNE ARGERR ; no
CALL GETID1 ;date1 to internal D2
MOV D2,D3 ;save date1
CALL GETID2 ;date2 to internal D2
SUB D3,D2 ;get diff
MOV #5,D0 ;xc.var #
CALL SETXC ;get param
CMPW D6,#X.Flt ;arg float?
JNE TYPERR ; no
FLTOF D2,@A2 ;Put floating point arg
BR EXIT
COMPYW: ; Compute Date from YEAR,YWEEK,DOW
CMPW @A3,#4 ;4 vars sent?
JNE ARGERR ; no
MOV #3,D5
BTYPE 3,D0
TST D0 ;is DATE1 unformated?
JNE EXIT ; no
BSIZE 3,D0
CMP D0,#5 ;is DATE1 at least 5 bytes?
JLT EXIT ; no
BADRS 3,A2
MOV #257.,D7 ;mask D7 to 0101 MMDD
MOVB 2(A2),D7 ;move in year
CALL $DSTOI ;D7 = Julian for 01/01/19 cur year
MOV D7,D2 ; move it to D2
CALL DOW ;D1 has DOW of 01/01/19 cur year
SUB D1,D2 ; sub DOW for 01/01/19 cur year
CLR D7 ; D7=0
MOVB 4(A2),D7 ; D7=YWEEK
DECW D7 ; D7=YWEEK-1
MUL D7,#7 ; D7=(YWEEK-1)*7
ADD D7,D2 ; D2=START'I'JUL+(YWEEK-1)*7
ADDB 3(A2),D2
CALL PUTIDT
CLR D5
JMP EXIT
COMPMW: ; Compute Date from YEAR,MONTH,MWEEK,DOW
CMPW @A3,#4
JNE ARGERR
BTYPE 3,D0
TST D0
JNE EXIT
BSIZE 3,D0
CMP D0,#6
JLT EXIT
BADRS 3,A2
MOV #256.,D7 ;day 1 to D7
MOVB @A2,D7 ;month to D7
SWAP D7 ;shift them to high order bytes
MOVB 2(A2),D7 ;year to D7 (D7 now in alpha sep format )
CALL $DSTOI ;D7 has julian day 1 of month, year
MOV D7,D2 ; move it to D2
CALL DOW ;D1 has DOW of 01/month/year
SUB D1,D2 ; sub DOW
CLR D7 ; D7=0
MOVB 5(A2),D7 ; D7=MWEEK
DECW D7 ; D7=MWEEK-1
MUL D7,#7 ; D7=(MWEEK-1)*7
ADD D7,D2 ; D2=START'I'JUL+(MWEEK-1)*7
ADDB 3(A2),D2
CALL PUTIDT
JMP EXIT
COMPEM: ;DATE2 = DATE1 changed to last day of the month
CMPW @A3,#4
JNE ARGERR
CALL GETID1 ;convert DATE1 to internal format (D2)
MOV D2,D7
CALL DITOS ;convert to separate format and get last day
ROL D7,#8
MOVB D6,D7
ROR D7,#8
CALL $DSTOI
MOV D7,D2
CALL PUTIDT ;convert seperated to DATE2
JMP EXIT
IODTIM:
; XCALL DATES, 7, FLAGS, [STR'DATE or FILE CHAN], IDATE, ITIME
; (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)
;
CMPW @A3,#5 ;5 args?
JNE ARGERR ; no
MOV #3,D0
CALL SETXC
CMPW X.Typ(A3)[D0],#X.Str ;is return var a string?
JNE TYPERR
CMP X.Siz(A3)[D0],#46
JLO SIZERR ; no
BR 20$ ;TEMP SKIP OF FILESET
BTST #15.,D3 ;OUTPUT TO FILE?
BEQ 20$ ;NO
BTYPE 5,D0
BSIZE 5,D5
; CALL GETNUM ;GET FILE CHANNEL NUMBER
MOV D3,D5
CALL $FLSET ;FIND FILE'S DDB
BEQ 20$ ;EVERYTHING'S OK, PROCEED
MOV #6,D5 ;ERROR #6 BAD CHANNEL NUMBER
JMP EXIT ;ABORT WITH ERROR
20$: CALL $ODTIM
CLR D5 ;$ODTIM has no error conditions
JMP EXIT ;return to caller
;
;various calls
;
FLGIN: MOV #2,D0 ;xcall var# ( FLAGS )
CALL SETXC
CALL XVALUE
MOV D1,D5
RTN ;back to call
BIN4OU: CMPW D6,#X.Bin ;binary?
JNE TYPERR ; no
CMP D7,#4 ;4 bytes long?
JNE SIZERR ; no
MOV D1,@A2 ;mov it to @A2
RTN
SETXC: CLR D6
DEC D0
MUL D0,#X.Off
MOVW X.Typ(A3)[D0],D6
ANDW #^H000F,D6 ;mask off all but last 4 bits
MOV X.Siz(A3)[D0],D7
MOV X.Adr(A3)[D0],A2
RTN
ADJDAY:
ROR D1,#8
ADDB #2,D1 ;MON=2 SUNDAY = 8
CMPB D1,#8
BLO 1$
MOVB #1,D1
1$: ROL D1,#8 ;SUN=1 SAT = 7
RTN
;
;
IIDTIM:
; XCALL DATES, 8, FLAGS, ADATE, output IDATE, output ITIME
; (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
;
CMPW @A3,#5 ;5 arguments?
JNE ARGERR ; no
CALL FLGIN ;FLAGS to D5
BADRS 3,A2 ;index input
CALL $IDTIM ;call subroutine
BNE 1$ ;branch on error
MOV #4,D0 ;var #
CALL SETXC ;get param
MOV D3,D1
CALL ADJDAY ;0=MON 6=SUN to 1=MON 7=SAT
CALL BIN4OU ;IDATE out
MOV #5,D0 ;var #
CALL SETXC ;get param
MOV D4,D1
CALL BIN4OU ;ITIME out
CLR D5 ;clr return flags
JMP EXIT ;RETURN TO CALLER
1$: MOV #2,D5
JMP EXIT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; gets DATE1 and DATE2 in internal format ;
;_______________________________________________;
; ;
GETID1: ;get first date in internal format ;
SAVE A2,D0,D3,D4,D7 ;
MOV #3,D0 ;
BR GETIDT ;
GETID2: ;get second date in internal format ;
SAVE A2,D0,D3,D4,D7 ;
MOV #4,D0 ;
GETIDT: ;convert a date to internal format ;
CALL GETDAT ;
REST A2,D0,D3,D4,D7 ;
RTN ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; ;
; put inernal format date into DATE2 ;
;_______________________________________________;
; ;
PUTIDT:
SAVE A2,D5,D4
MOV #4,D0 ;xc.var# ( DATE2 )
CALL SETXC
PUTDAT: TJMP D6
OFFSET PUTBX ;seperated format date
OFFSET PUTASC ;string mm/dd/yy or mm/dd/yyyy
OFFSET PUTFLT ;julian
OFFSET PUTBIN ;4 byte yyyymmdd format
;assume unform or binary
PUTBX:
CMPW D7,#3 ;at least 3 bytes?
JLO SIZERR ; no
;Unformated (X) or binary, 1st 3 bytes are always: MONTH,DAY,YEAR
MOV D7,D0 ;save size of var
MOV D2,D7 ;
CALL DITOS
CMPW D0,#7 ;do we want days in month?
BLO 1$ ; no
PUSHB D6 ;save days in month
1$: MOV D7,D3
MOVB D7,2(A2) ; SET YEAR
SWAP D7
MOVB D7,@A2 ; SET MONTH
RORW D7,#8
MOVB D7,1(A2) ; SET DAY
CMPW D0,#4 ;need more than MONTH,DAY,YEAR?
JLO PUTEXT ; no
MOV D2,D7
CALL DOW ;DOW to D1
MOVB D1,3(A2) ;move in DOW
CMPW D0,#5 ;do we want the week of the year
JLO PUTEXT ;no
;YWEEK=INT((NOW-START+START'DOW)/7)+1
MOV #257.,D7 ;day 1 mon 1 to D7
SWAP D7 ; shift to high order
MOVB D3,D7 ;year to low order
CALL $DSTOI ; D7=START julian days for jan 1 present year
MOV D2,D5 ; D5=NOW julian days for present date
SUB D7,D5 ;
CALL DOW ;get DOW into D1
ADDW D1,D5 ;add in the day of the week
DEC D5 ;adjust
DIV D5,#7
INCB D5
MOVB D5,4(A2) ;
CMP D0,#6
BLO PUTEXT
;MWEEK=INT((NOW-START+START'DOW)/7)+1
MOV D3,D7
AND #16777215.,D7
OR #16777216.,D7 ; SET DAY=01
CALL $DSTOI ; D7=START cur month
CALL DOW ; D1 has day of the week cur month
ADDB 1(A2),D1 ; add in the day of the month
SUB #2,D1
DIV D1,#7
INCB D1
MOVB D1,5(A2)
CMP D0,#7
BLO PUTEXT
MDAYS:
POPB D6
MOVB D6,6(A2)
PUTEXT:
REST A2,D5,D4
RTN
PUTASC:
;INTERNAL date in D2 to ASCII date in DATE2
CMP D7,#8 ;is string at least 8 bytes
JLO SIZERR ; no
MOV D2,D7 ;internal to reg
CALL DITOS ;D7 has date seperated
MOV D7,D3 ;IDATE for $ODTIM
MOV #840.,D5 ;flags for $ODTIM
CALL $ODTIM ;
JMP PUTEXT
PUTFLT:
;INTERNAL to FLOAT is just Long Word to Float
FLTOF D2,@A2
JMP PUTEXT
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
PUTBIN: ;special format bin4 yyyymmdd
CMPW D7,#4 ;4 bytes?
JNE SIZERR ; no
MOV #4,D0 ;set counter
MOV D2,D7 ;internal to reg
CALL DITOS ;D7 has date seperated
CLR D0 ;clear work reg
CLR D1 ;clear accumulator
MOVB D7,D0 ;year to D0
ADDW #1900,D0 ;assume 20th century
MUL D0,#10000 ;adjust 4 left
MOV D0,D1 ;move to accumulator
SWAP D7 ;month to first byte
CLR D0 ;clear work reg
MOVB D7,D0 ;month to D0
MUL D0,#100 ;adjust 2 left
ADDW D0,D1 ;month to accumlator
RORW D7,#8 ;day to first byte
CLR D0
MOVB D7,D0
ADD D0,D1 ;add day
MOV #4,D0 ;set counter
1$: MOVB D1,(A2)+ ;move a byte
ROR D1,#8 ;shift right a byte
SOB D0,1$ ;do it again
BR PUTEXT ;return to caller
GETFUN:
; Get function number D0
CLR D0
CALL XVALUE
MOV D1,D0
RTN
XVALUE: XCVALU D0
JNE TYPERR
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
SUB #CNTURY,D7
DIV D7,#1461.
CLR D3
MOVW D7,D3
ADDW D3,D3
ADDW D3,D3
CLRW D7
SWAP D7
DIV D7,#365.
ADDW D7,D3
CLR D4
MOVW D3,D4
TSTW D7 ;Leap year?
BEQ 1$ ; Yes
LEA A2,NORMYR ;Index normal year and day tables
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 ; Days in month to D6
5$: REST D2,D3,D4,A2,A3
RTN
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
;
GETDAT:
CALL SETXC
TJMP D6
OFFSET GTDBX ;seperated format date
OFFSET GTDASC ;string mm/dd/yy or mm/dd/yyyy
OFFSET GTDFLT ;julian
OFFSET GTDBIN ;4 byte yyyymmdd format
GTDBX:
; Unformatted 1st 3 bytes are always MONTH,DAY,YEAR
; Basic stores em backwards
CLR D7 ;clear storage
MOVB 1(A2),D7 ;day to D7
RORW D7,#8 ;shift right 8 bytes
MOVB @A2,D7 ;month to D7
SWAP D7 ;mov to high order bytes of Lwrd
MOVB 2(A2),D7 ;year to D7
TST D7 ;was date 0?
BNE GTDEXT ; no
GDATEI: GDATEI D2 ;today in internal format
RTN ; use todays date
;D7 now in ALPHA seperated format but DOW is invalid.
;Don't need it.
GTDEXT: CALL $DSTOI ;call for ALPHA internal format. ( Julian )
MOV D7,D2 ;D2 has date in ALPHA internal format
RTN
GTDASC:
;ASCII to ALPHA INTERNAL
CMP D7,#8 ;string at least 8 bytes?
JLO SIZERR ; no
MOVB 8(A2),D1 ;save byte after string
CLRB 8(A2) ;make sure null byte for termination
MOV #2,D5 ;don't scan for time
PUSH A2
CALL $IDTIM
SETNE D2
POP A2
MOVB D1,8(A2)
MOVW #1,D5
TSTB D2
JNE EXIT ;error
CLRW D5 ;clear error
MOV D3,D7
BR GTDEXT
;end of ASCII to ALPHA INTERNAL
GTDBIN: ;special format bin4 yyyymmdd
;we know type is binary
CMP X.Siz(A3)[D0],#4
JNE SIZERR ; no
CALL XVALUE
PUSH
CLR @SP
PUSH
CLR @SP
PUSH ;get storage
CLR @SP
MOV SP,A2 ;index storage with A2
DCVT 0,OT$MEM ;ASCII rep of bin4 date to ASCIIB
SUB #2,A2 ;index day
GTDEC ;day to D1
CLR D0
MOVB D1,D0 ;day to D7
ROLW D0,#8 ;shift day left
SUB #4,A2 ;index month
CLRB 2(A2)
GTDEC ;month to D1
MOVB D1,D0 ;month to D7
SWAP D0 ;shift to high word
SUB #6,A2 ;index year
CLRB 4(A2)
GTDEC ;year to D1 yyyy
SUBW #1900,D1 ;assume this century
MOVB D1,D0 ;date is now in alpha seperated format
MOV D0,D7
POP
POP
POP ;restore stack pointer
JMP GTDEXT ;
;
DOW: ;Convert true julian in D7 to day of the week ( 1=sun 7=sat )
;assuming 20th century and return it in D1
MOV D7,D1
SUB #CNTURY,D1
ADD #2,D1 ;adjust so DOW will divide
DIV D1,#7 ;DOW is in high order of D1
CLRW D1 ;clear all but DOW
SWAP D1 ;DOW is low order of D1
;DOW ( 0 - 6 ) ( sat - sun )
TSTB D1 ;is sat
BNE 1$ ; no
MOVB #7,D1 ; DOW is 1 - 7 ( sun - sat )
1$: RTN
;
; Abort routine for improper arguments passed to SBR
;
DEFINE ERROR TEXT
TYPE <? 'TEXT'>
JMP ABORT
ENDM
ADRERR: ERROR Odd address given as WORD or LONG
ARGERR: ERROR improper number of arguments
TYPERR: ERROR argument type error
SIZERR: ERROR argument size error
FUNERR: ERROR function out of range (1..8)
CHNERR: ERROR error locating file channel
ABORT: TYPECR < in DATES.SBR>
MOV JOBCUR,A6
ORW #J.CCC,JOBSTS(A6)
EXIT
