.MCALL	.MODULE
.MODULE	DATE,VERSION=06,COMMENT=<DATE,DATE4Y/SYSLIB>,IDENT=NO,LIB=YES

; Copyright (c) 1998 by Mentec, Inc., Nashua, NH.
; All rights reserved
;
; This software is furnished under a license for use only on a
; single computer system and  may  be  copied  only  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 except for  use  on  such
; system and to one who agrees to these license  terms.  Title
; to  and  ownership of the software shall at all times remain
; in Mentec, Inc.
;
; The information in this document is subject to change without
; notice and should not be construed as a commitment by Digital
; Equipment Corporation, or Mentec, Inc.
;
; Digital and Mentec  assume  no  responsibility for the use or
; reliability of its software on equipment which is not supplied
; by Digital  or Mentec,  and listed  in the  Software  Product
; Description.
;+
;COND
;	EIS$I	(0)	use SOB macro
;		 1	use SOB instruction
;
;	SLIB$M	(0)	Generate standard SYSLIB routine
;	SLIB$M	 1	Generate U mode part of Supervisor library
;	SLIB$M	 2	Generate S mode part of Supervisor library
;
;	SLIB$M values are referenced using symbols of the form *PART
;			in conditional startements.
;
;	If SLIB$M <> 0, EIS$I is forced to 1
;-
.IIF NDF EIS$I EIS$I=0
.IIF NDF SLIB$M SLIB$M=0
.IIF NE SLIB$M EIS$I=1

OPART	= SLIB$M			;0 = generate if building old library
UPART	= SLIB$M-1			;0 = generate if building User part
SPART	= SLIB$M-2			;0 = generate if building Supy part
OSPART	= OPART*SPART			;0 = generate ... old or Supy
OUPART	= OPART*UPART			;0 = generate ... old or User
;+
; RT-11 SYSTEM LIBRARY (SYSLIB) SUBROUTINE 
;
; CALLABLE ENTRIES: DATE, DATE4Y
;
; FUNCTIONAL DESCRIPTION:
;
; Subroutines DATE and DATE4Y can be used to obtain an ASCII date 
; string that corresponds to either the current system date, or to 
; an optional specified date.
;
;
; CALLING SEQUENCE:
;
;	CALL DATE( STRING [,DATEWD])
;
;   or	CALL DATE4Y( STRIN4 [,DATEWD])
;
;
; PASSED ARGUMENTS:
;
;	STRING	- BYTE array or CHARACTER string of 9 characters
;   or	STRIN4	- BYTE array or CHARACTER string of 11 characters
;
;	DATEWD	- INTEGER*2 date word in RT-11 format
;
;
; RETURNED ARGUMENT VALUES:
;
;	STRING	- BYTE or CHARACTER string with date with 2-digit year
;	STRIN4	- BYTE or CHARACTER string with date with 4-digit year
;
;
; FUNCTION RETURN VALUE:
;
;	<none>
;
;
; EXTERNAL REFERENCES:
;
;	IDATE	- (also a FORTRAN-callable SYSLIB subroutine)
;
;
; MACRO REFERENCES:
;
;	.ASSUME
;	.CKXX
	.SBTTL	DATE - FORTRAN-callable system subroutine

.IF	EQ	OSPART
	.GLOBL	IDATE
.ENDC;	EQ	OSPART
.IF	EQ	OUPART
	.GLOBL	$SYSLB, $NXADR
	.WEAK	$MSARG
.ENDC;	EQ	OUPART

.IIF EQ EIS$I	.MCALL	SOB
	.MCALL	.ASSUME, .CKXX


	.CKXX	<SPA, SPB, SPC>		; TRACK the STACK
			S.ORG =: 1000

	.PSECT	SYS$I,I
			CK.SPA=S.ORG
			CK.SPB=CK.SPA

SEP	=:	'-			; Separator around month name
BLANK	=:	040			; Filler for invalid dat return
MONTHS	=:	12.			; Months in a year
CENTURY	=:	100.			; Years in a century

.IF	EQ	OUPART
	.SBTTL	DATE and DATE4Y code

	.ENABL	LSB

DATE4Y::MOVB	(PC)+,R2		; Declare 4-digit year mode
					; ***This depends on next
					; instruction low byte being 2***
DATE::	CLR	R2			; Declare 2-digit year mode
	MOV	#4,R1			; arg count for call to IDATE
	MOV	(R5)+,R4		; Get arg count
	CALL	$NXADR			; get 1st arg - string address
	BCC	10$			; trap out if not supplied.
	TRAP	$MSARG			; error abort
	RETURN

10$:	MOV	R0,R3			; otherwise save it in R3
	CALL	$NXADR			; look for 2nd arg - optional date wrd
	SBC	R1			; reduce count if not supplied.
.ENDC;	EQ	OUPART
.IF	EQ	UPART
	MOV	#CENTS,R4		; pass address of CENTS to S mode
	MOV	#IG$MNM-MONLEN,R5	; pass address of names to S mode
	JMP	DATE4$			; go to S mode code

.ENDC;	EQ	UPART
	.DSABL	LSB
	.ENABL	LSB
.IF	EQ	SPART

	.ENABL	LSB
DATE4$::
	MOV	R5,-(SP)		; save names address
			CK.SPA ,-2,S.NAME
	MOV	R4,-(SP)		; save CENTS address
			CK.SPA ,-2,S.CENT
.ENDC;	EQ	SPART
.IF	EQ	OSPART
	MOV	R0,-(SP)		; move adrs of date word to IDATE list
			CK.SPA ,-2

; (if there's nothing there, it shouldn't hurt anything.  The main thing
;  here is to keep the stack orderly.)
					; Here the argument list entries
					; each point to themselves.  This
					; depends on IDATE using each entry
					; address value once...
	.REPT	3
	TST	-(SP)			; get next list slot
			CK.SPA ,-2
	MOV	SP,@SP			; each address points to itself
	.ENDR
	MOV	R1,-(SP)		; set arg list count
			CK.SPA ,-2
	MOV	SP,R5			; R5 now points to arg list
	MOV	R3,-(SP)		; save target ptr (in R3)
			CK.SPA ,-2
	MOV	R2,-(SP)		; save 2/4 digit mode flag
			CK.SPA ,-2
	CALL	IDATE			; get date info

	MOV	(SP)+,R2		; restore 2/4 digit mode flag
			CK.SPA ,+2
	MOV	(SP)+,R0		; restore target ptr (in R0)
			CK.SPA ,+2
	TST	(SP)+			; skip count
			CK.SPA ,+2
	MOV	@SP,R1			; get month
			CK.SPC=CK.SPA

; R1 contains the month number

	BEQ	30$			; return blanks if no date specified
	CMP	R1,#MONTHS		; Is it ridiculous?
	BGT	30$			; Yes, error
; Date is good.  Make an appropriate date string.

.IIF	EQ	OPART		.Assume	MONLEN EQ 3
	ASL	R1			; multiply by
	ADD	(SP)+,R1		;  3
			CK.SPC ,+2
	MOV	(SP)+,R3		; get day
			CK.SPC ,+2
	CALL	CONV			; convert into target
	MOVB	#SEP,(R0)+		; drop in dash
.IF	EQ	SPART
			.Assume	S.ORG EQ S.NAME+2
	ADD	2(SP),R1		; calculate ptr into month table
.IFF;	EQ	SPART
	ADD	#IG$MNM-MONLEN,R1	; calculate ptr into month table
.ENDC;	EQ	SPART
					; 0th-month not in table
.IIF	EQ	OPART		.Assume	MONLEN EQ 3
	.REPT	3			; move to target
	MOVB	(R1)+,(R0)+		;  *
	.ENDR
	MOVB	#SEP,(R0)+		; drop in dash
	MOV	(SP)+,R3		; get year
			CK.SPC ,+2
					; now fall thru into convert, and exit
	TST	(SP)+			; pop off RT-11 dateword arg
			CK.SPC ,+2

.IF	EQ	SPART
	MOV	(SP)+,R1		; Point to century
			CK.SPC S.CENT,+2
	TST	(SP)+			;align stack
			CK.SPC ,+2
.IFF;	EQ	SPART
	MOV	#CENTS,R1		; Point to century
.ENDC;	EQ	SPART
	CMP	R3,#CENTURY		; is year > 100? (> 1900)
	BLO	10$			; branch if so
	SUB	#CENTURY,R3		; otherwise adjust to 21st century.
	ADD	R2,R1			; Point to NEXT century
10$:	TSTB	R2			; 4-digit year desired?
	BEQ	CONV			; branch if not.
	MOVB	(R1)+,(R0)+		; move in century 1000's digit
	MOVB	(R1)+,(R0)+		; move in century 100's digit

; This routine converts a number between 0 and 99 into a two-digit
; string.  This is accomplished by placing the value in the high
; byte and dividing it by 10.  10 is repeatedly subtracted from the
; high byte while adding 1 to the low byte (all in the SUB instruction).
; This is done until one too many subtractions have occurred.  The ADD 
; instruction both compensates for this, and adds necessary bits to make 
; the bytes ASCII equivalents of the REMAINDER (high) and QUOTIENT (low).

CONV:	SWAB	R3			; position quotient and dividend
20$:	SUB	#<10.*400-1>,R3		; divide by 10
	BPL	20$			; subtract until negative
	ADD	#<10.*400-1>+"00,R3	; went too far, backup one
	MOVB	R3,(R0)+		; insert ten's digit
	SWAB	R3			; get unit's digit
	MOVB	R3,(R0)+		; insert in target
			CK.SPC S.ORG
	RETURN				; leave

; Date is invalid.  Return blank string.

30$:	MOV	#9.,R1			; assume 9 blanks needed.
	ADD	R2,R1			; two more blanks if 4-digit-year mode
40$:	MOVB	#BLANK,(R0)+
	SOB	R1,40$
.IF	EQ	SPART
	ADD	#12.,SP			; pop off idate args and data addrs
			CK.SPA ,+12.
.IFF;	EQ	SPART
	ADD	#8.,SP			; pop off idate args
			CK.SPA ,+8.
.ENDC;	EQ	SPART
			CK.SPA S.ORG
	RETURN				; with blank date string

	.DSABL	LSB
.ENDC;	EQ	OSPART
.IF	EQ	OUPART
.SBTTL	Pure DATE Data

	.PSECT	SYS$S,D			; Pure data - Month & century names

CENTS:	.ASCII	/1920/			; 2-digit Century prefixes 19 & 20
IG$MNM::.ASCII	/JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC/
MONLEN	=: .-IG$MNM/MONTHS		; Chars in a month name
	.EVEN
.ENDC;	EQ	OUPART

	.END