Macintosh-SW/mac-rom
1
0
Fork 0
mirror of https://github.com/elliotnunn/mac-rom.git synced 2024-06-30 20:29:33 +00:00
Code Issues Projects Releases Wiki Activity
minitest
mac-rom/Toolbox/ScriptMgr/ScriptMgrUtilDate.a

3378 lines
109 KiB
Plaintext
Raw Permalink Normal View History

Bring in CubeE sources Resource forks are included only for .rsrc files. These are DeRezzed into their data fork. 'ckid' resources, from the Projector VCS, are not included. The Tools directory, containing mostly junk, is also excluded.
2017-09-17 09:09:04 +00:00
;
; File: ScriptMgrUtilDate.a (formerly SMgrUtilDate.a)
;
; Contains: Script Manager date/time utilities
;
; Written by: MED Mark Davis
; JLT
; LDC Lee Collins
; PKE Peter Edberg
;
; Copyright: <09> 1987-1992 by Apple Computer, Inc. All rights reserved.
;
; This file is used in these builds: ROM, disk
;
; Change History (most recent first):
;
; <SM5> 11/12/92 PN Get rid of <20> 020 conditionals for ROM builds
; <SM4> 11/6/92 SWC Changed PackMacs.a->Packages.a.
; <15> 6/12/92 FM remove MacsBug symbols and obsolete smgrKeepMacsBugSymbols
; conditional. Replaced long divisions w/ a macro that uses a
; divu.l instruction for 020 cpus and a subroutine otherwise.
; Removed if 0 then code from division routine.
; <14> 4/30/92 FM Remove conditional smgrUsesStdExit
; <13> 3/16/92 csd #1017570,<gbm>:
; Removed the MoveHHi call on the itl0 and itl1 resources to avoid
; System heap fragmentation.
; <12> 2/19/91 PKE smb,#DTS FT: ToggleDate trashes one word past the end of its
; <09>VAR lSecs: LongDateTime<6D> parameter (reported by a developer).
; <11> 2/15/91 PKE JSM,#54736: Redo conditionals to move change <10> to Post 7.0.
; Object compare identical to <9>.
; <10> 1/28/91 JH PKE,#54736: Changed InitDateCache so that the date separators
; are now part of the cache. Then fixed String2Date to use these
; separators and not be quite so forgiving about allowed
; separators. Now if a separator is used that is not part of the
; cache before a number is found the routine returns invalid date.
; If a non-cached separator is found after a number the routine
; continues, but a warning result is returned. Also changed
; ValidLong so that it won't allow numbers > 32768.
; <9> 9/14/90 BG Removed <8>. 040s are now behaving more reliably.
; <8> 7/17/90 BG Added EclipseNOPs for flakey 040s.
; <7> 7/5/90 PKE NEEDED FOR SIXPACK: Rearranged InitDateCache to fix old problem:
; itl0 and itl1 may be purged before we try to use them.
; <6> 6/1/90 PKE Just cleaned up some comments, formatting, and superfluous
; definitions.
; <5> 5/5/90 PKE Updated 3 previously overlooked <20>SysVers<72> symbols to
; ((smgrSysVers >= $605) OR (smgrROMVers >= 2)) so we can build
; with new ScriptPriv.a.
; <4> 4/10/90 PKE Deleted conditionalized definitions of forRom, SysVers and
; TestScriptManager. Fixed tabs. Replaced local definition of
; _FixDiv with include of FixMath.a. Used smgrSysVers,
; smgrROMVers, and smgrUseStdExit symbols instead of SysVers and
; buildLevel. Removed remaining MacsBug symbols for 7.0.
; <3> 3/4/90 PKE Changed _UprText to _UpperText to match new Traps.a.
; <2> 2/22/90 PKE Replaced obsolete _LwrStringToUpr opword with _UprText. Updated
; header to BBS format.
; <1> 12/18/89 CCH Adding for the first time into BBS. Changed include 'inc.sum.a'
; to load 'StandardEqu.d'. Updated file name references.
;
; (BBS versions above, EASE versions below:)
; <2.5> 11/6/89 PKE NEEDED FOR 6.0.5!! (since 2.4 change is conditionalized for 7.0,
; the file can be used as is, except that you might need to add
; back the load 'nEqu.d') -Bug fixes for InitDateCache and
; String2Date needed for HyperCard. InitDateCache: Fixed CopyArray
; to use correct register (A4) for source pointer, and to
; initialize all relevant bytes of length register (D0).
; String2Date: if first relevant (i.e., day or month name) alpha
; token is a month name, we now search the day name list if we
; find another alpha token (fixes BRC #54946). Rearranged Cache
; structure to fix invalid use of month/day name index. Note that
; the invalid index use in String2Date happened to work before
; because of the incorrect source pointer use in CopyArray, but it
; was incomprehensible.
; <2.4> 9/18/89 PKE Replace _GetScript call in InitDateCache with direct access to
; ScriptRecord, since we may not have GetScript yet; this is also
; an optimization.
; <2.3> 8/26/89 PKE Cleaned up some conditionals, moved a comment.
; <2.2> 8/22/89 SES Removed references to nFiles.
; <2.1> 6/30/89 PKE NEEDED FOR AURORA: Use OPWORD _LwrStringToUpr for LwrString with
; uppercase function; use _LwrStringToUpr instead of UprString in
; ToggleDate (ToggleDate may now move memory, but the 2.0
; documentation didn't indicate whether or not it moved memory).
; For ROMs on 020 or greater machines, get rid of LongDiv and move
; divs.l inline. Use constant NoonHr for 12 where appropriate.
; (all of these changes from code review).
; <2.0> 6/23/89 PKE In String2Date, change conditionals so Lee's heuristic for dates
; near the beginning or end of the century is used for 7.0 as well
; as ROM; skip definition of buildLevel (done in ScriptPriv.a).
; <1.9> 6/13/89 PKE (ROM & 7.0 only) Fix bug introduced by 1.6 below: In
; InitDateCache, lock itl0 & itl1 around direct or indirect calls
; to Block2String, which now calls LwrString and can move memory.
; <1.8> 6/9/89 PKE Fix InitDateCache bug that could trash random memory (BRC
; #50472).
; <1.7> 6/4/89 PKE Modify ValidDate and ToggleDate to check genCdevRangeBit flag
; and restrict valid dates to the Gregorian range 1920-2019 (or
; equivalent range in another calendar), as in General CDEV. Note:
; these changes were originally checked in on 5/25/89 as version
; 1.6, but the EASE version list didn't get updated. Consequently,
; (1) that version couldn't be checked out, and (2) the next
; checkout/checkin sequence resulted in the new version 1.6 below,
; which didn't have these changes.
; <1.6> 5/30/89 PKE (New ROMs & System 7.0 only) Replace UprString calls in routines
; that already move memory with calls to enhanced LwrString for
; localizable uppercasing.
; <1.5> 5/2/89 PKE Change CPU test in LongDiv to work properly for 68030 (BRC
; 35696); for ROM, replace test with conditionals that select the
; right code.
; <1.4> 4/7/89 PKE Modified ValidDate to compare LongDateRec fields from pm to era
; (was from era to weekOfYear, but undocumented): fixes the "2/29"
; problem in ToggleDate. Eliminated the ValidDate code
; (ROM/BigBang only) restricting hour to 0-11 if twelveHourBit
; set; check pm field instead, so hour will always be 0-23.
; Modified ToggleDate to mask out togFlags bits for LongDateRec
; fields it can't deal with; to place tighter restrictions on
; toggling by char in numeric fields (only $30-$39 and $b0-$b9
; allowed); and to handle 12-hour time in various ways with the
; addition of 3 flag bits. Fixed bug in LongSecs2Date for negative
; LongSecs.
; <1.3> 2/21/89 PKE Replaced with RomProj version, which already had system and Rom
; sources merged.
; (EASE ROMproj history below)
; <1.5> 2/21/89 PKE Fix up includes: always use include 'inc.sum.a'.
; <1.4> 2/14/89 PKE Updated to use MPW 3.0 final ScriptEqu.a equate names
; <1.3> 2/3/89 PKE Merged with current system sources (CCH's 01/16/1989 merge of
; 6.0.3 and 7.0 sources, done in RES.sys:smgr)
; <1.2> 11/14/88 PKE Synchronize EASE and Projector
; <1.1> 11/11/88 CCH Fixed Header.
; <1.0> 11/9/88 CCH Adding to EASE.
; (old EASE ROMproj history below)
; <1.8> 10/27/88 LDC Mods by Carl Hewitt and Brian McGhie in the process of putting
; Script Manager in ROM
; (EASE SYSproj history below)
; <1.2> 2/14/89 PKE Updated to use MPW 3.0 final ScriptEqu.a equates
; <1.1> 1/16/89 CCH Merged 6.0.3 final sources into 7.0.
; <1.0> 11/16/88 CCH Added to EASE.
; (pre-EASE history below)
; 10/12/88 ldc removed longDay, etc.
; 10/10/88 ldc include 'inc.sum.d'
; 9/30/88 ldc Added check for 12 hour time using #12HourBit in ValidDate
; 9/27/88 ldc Changed heuristic for determining when input year less than 100
; belongs in previous, current or next century
; 7/25/88 ldc Changed error equ names per Keithen
; 5/19/88 ldc Standardized routine exits
; * above changes for ROM or buildLevel >= 2 *
; 2/22/88 med Use token length instead of abbrevLen for matching months,
; daysOfWeek
; 2/22/88 med Use MatchString for time testing.
; 1/13/88 med Added LongDiv routine for 64/32 -> r32,q32
; 1/13/88 med Changed LongDateTime to type Comp throughout
; 1/12/88 med Changed String2Date, Date2String to use LongDateRec, ValidDate
; 1/12/88 med Added dispatch for ValidDate, added field flag bits
; 1/11/88 med Fix BC
; 1/11/88 med Fix day of week if divs overflow
; 1/11/88 med Fix range bug (<1600) with Long dates
; 1/5/88 med Major revamp of String2Time and Time2String for compression
; 1/4/88 med Statements were outside of With TBlock
; 11/21/87 med Asm adds extra bytes to front of dc.x
; 11/20/87 med dy100 to big as divisor, must hack around, misc fixes
; 11/17/87 med Added c version of LongDate2Secs, LongSecs2Date; started
; assemblyizing
; 9/2/87 med Check for white space as separator
; 8/25/87 med Added check for 12AM
; 8/24/87 med Stop getting time if time string is found OR (not AND) 3
; elements
; 8/24/87 med DayFound was missing (a6).
; 8/24/87 med Caught case of null string.
; 8/22/87 med Added fix for 24:xx:xx time
; 8/22/87 med Added test for alternate space
; 8/22/87 med Removed seconds parameter entirely, since it never would work
; right
; 8/22/87 med Removed use of A5 as temp register. Not a wise idea, Jim
; 8/21/87 med Stash seconds in var paramter in String2Date, String2Time
; 8/21/87 med Added header and minor changes to resourcize the procedures
; 8/11/87 JLT String2Date/Time only affects date/time fields in var
; DateTimeRec parameter
; 8/10/87 JLT Speeded up Compare and MatchString
; 8/10/87 JLT Told Tokenizer to return strings and wrote faster ValidLong
; routine
; 8/9/87 JLT Replaced trap calls with JSR's
; 8/9/87 JLT Wrote InitCache to do pre-initialization of String2Date and
; String2Time
; 8/8/87 JLT LongSecstoDate is written
; 8/7/87 JLT String2Date and String2Time return number of seconds, and
; location of string were date/time stopped
; 8/5/87 JLT Errors and warning codes added to String2Date and String2Time
; 7/29/87 JLT String2Date routine written
; 7/28/87 JLT String2Time routine written
; 7/23/87 JLT Compare, Block2String and MatchString modified to have no var
; parameters
; 7/22/87 JLT Block2String modified to not to load in leading spaces, length
; bug fixed
; 7/20/87 JLT Final version of PortionText done
; 7/13/87 JLT Portion Text written
; 7/1/87 JLT Final version of GetNeighborhood and SearchText is reached
; 6/30/87 JLT GetNeighborhood; SearchText now calls GetNeighborhood
; 6/29/87 JLT SearchText
; 6/20/87 MD ConvertTable written
; 6/20/87 MD Compare, Block2String and MatchString support routines written
; for pascal String2Date
;___________________________________________________________________________________________________
; To Do:
; eyeballing algorithm could speed up calendar calculations
;___________________________________________________________________________________________________
PRINT OFF ; jh, <10>
IF &type('CPU')='UNDEFINED' THEN ; <06/30/89 pke>
CPU: equ 0 ; <06/30/89 pke>
ENDIF ; <06/30/89 pke>
load 'StandardEqu.d'
include 'ScriptPriv.a'
include 'SANEMacs.a'
include 'Packages.a'
FixMathNonPortable equ 1 ; We require Mac Plus or newer <4>
include 'FixMath.a' ; to get _FixDiv <4>
import StdUnlink
PRINT ON
FixCacheAndStr2Date equ 0 ; do for 7.1 & new ROMs <11>
;FixCacheAndStr2Date equ ((smgrSysVers >= $710) OR (smgrROMVers >= 2)) ; do for 7.1 & new ROMs <11>
; Assorted In-line constants
secsInDay equ 86400 ; seconds in one day
maxDate equ $CE ; max date range is $0000,00EA,D380,0000
minDate equ -$EB ; these correspond to -30000,30000
NoonHr equ 12
genCdevRangeLo equ 504921600 ; secs for 1920-Jan-01 00:00:00
genCdevRangeHi equ $DA319179 ; =3660681599, secs for 2019-Dec-31 23:59:59
;____________________________________________________________
; Long division macro macro. For 020 machines we can use an instruction
; for efficiency.
macro
LongDiv
machine mc68020
divs.l d2,d0:d1 ; do it
endm
proc
export MonthStarts,LeapStarts,secsInDayX,maxOldDate,maxVal
mLimit equ 1000 ; limit for searching
MonthStarts dc.w 0,31,59,90,120,151,181,212,243,273,304,334,mLimit
LeapStarts dc.w 0,31,60,91,121,152,182,213,244,274,305,335,mLimit
secsInDayHack dc.x "86400.0"
secsInDayX equ *-10 ; skip first two byts--asm bug <11/21/87med>
maxDateHack dc.x "4294967295.0"
maxOldDate equ *-10
maxVal dc.w 0,150,13,35,24,60,60,7,400,60
endproc
;============================================================
; FUNCTION ValidDate (VAR date : LongDateRec;
; flags: Longint;
; var newSecs: LongDateTime,
; selector: Longint): DateField;
; LABEL
; 999;
; VAR
; i: DateField;
; dateTime2: LongDateRec;
;============================================================
ValidDate proc export
ValidDateRec record {oldA6},decr
resultSize equ 2
result ds.w 1 ; DateField
argSize equ *-8
date ds.l 1 ; @LongDateREc
flags ds.l 1 ; long
newSecs ds.l 1 ; @newSecs
selector ds.l 1 ; long
return ds.l 1
oldA6 ds.l 1
dateTime2 ds LongDateRec
localFrame equ *
endr
rResult equ d3
rNewSecs equ a2
rDateTime2 equ a3
rDate equ a4
ValidDateRegs reg rResult/rNewSecs/rDateTime2/rDate
with ValidDateRec,LongDateRec,LongDateField
import maxOldDate
CheckSelector
link a6,#localFrame
movem.l ValidDateRegs,-(sp) ; save regs
; pea procName
; _DebugStr
; ValidDate := yearField; {assume bad}
; LongDate2Secs(date, newSecs);
; if (BAnd(oldDateFlag,flags) <> 0) then
; if ((newSecs < 0) or (newSecs > maxOldDate)) then goto 999;
move.w #yearField,rResult ; assume bad
move.l newSecs(a6),rNewSecs ; arg
lea dateTime2(a6),rDateTime2 ; reg arg
move.l date(a6),rDate ; ditto
move.l rDate,-(sp) ; pass @date
move.l rNewSecs,-(sp) ; pass @newSecs
_LongDate2Secs ; get values in array
move.l flags(a6),d0 ; get flags for testing
btst.l #smallDateBit,d0 ; limited version?
beq.s @InRange ; no, skip test
tst.l (rNewSecs) ; negative? (high long <> 0 => quad used
bne.s @ValidExit ; yes, bail
btst.l #genCdevRangeBit,d0 ; limited to 1920-2019?
beq.s @InRange ; if not, skip following test
cmp.l #genCdevRangeLo,4(rNewSecs) ; before 1920?
bcs.s @ValidExit ; bail if so
cmp.l #genCdevRangeHi,4(rNewSecs) ; after 2019?
bhi.s @ValidExit ; bail if so
@InRange
; LongSecs2Date(newSecs, dateTime2);
move.l rNewSecs,-(sp) ; pass @newSecs
move.l rDateTime2,-(sp) ; pass @dateTime2 for loading
_LongSecs2Date ; call
; FOR i := eraField TO secondField DO
; IF date.list[i] <> dateTime2.list[i] THEN
; BEGIN
; ValidDate := i;
; GOTO 999;
; END;
; ValidDate := validDateFields;
move.l flags(a6),d2 ; get flags for testing <1/11/88med>
move.w #validDateFields,rResult ; assume ok
; Go from end to beginning
adda.l #pm+2,rDate ; -(rDate) will start with pm field
adda.l #pm+2,rDateTime2 ; -(rDateTime2) starts with pm field
move.l #pmField,d1 ; counter & bit mask index
@ValidLoop
move.w -(rDateTime2),d0 ;
cmp.w -(rDate),d0 ; same?
dbne d1,@ValidLoop ; loop until not equal
beq.s @ValidExit ; ok, exit
btst d1,d2 ; field bit on? <1/11/88med>
dbne d1,@ValidLoop ; loop until set <1/11/88med>
beq.s @ValidExit ; bit not set, done <1/11/88med>
move.w d1,rResult ; now return bad field number
;999 :
@ValidExit
move.w rResult,result(a6) ; return result
movem.l (sp)+,ValidDateRegs ; restore registers to their original value
checkA6 ; check stack
move.w #argSize, d0 ; for StdUnlink
bra StdUnlink ; standard exit
endWith
endProc
;{============================================================
; ToggleDate Code
; ============================================================}
; const
; validDateFields = -1;
; maxOldDate = 4294967295.0;
;============================================================
; ToggleResults = (toggleUndefined, {function undefined}
; toggleOk, {worked ok}
; toggleBadField, {field not supported}
; toggleBadDelta, {delta = -1/1}
; toggleUnknown {unknown error}
; {others later: use r-});
;
;
;============================================================
;
; Function ToggleDate ( VAR mySecs: LongDateTime;
; field: DateField;
; delta: DateDelta;
; ch: Integer;
; params: TogglePB;
; selector:Longint): ToggleResults;
; LABEL
; 777,888,900,999;
; VAR
; dateTime0,
; dateTime1,
;; maxVal: LongDateRec;
; newDate: LongDateTime;
;; succField,
; badField: DateField;
;; j,
; baseValue,
; hundreds: Integer;
; rtPtr: ^ResType;
; myLong: Longint;
; tempStr: Str255;
; curChar: Char;
;
; BEGIN
;============================================================
ToggleDate proc export
ToggleDateRec record {oldA6},decr
resultSize equ 2
funcResult ds.w 1
argSize equ *-8
mySecsPtr ds.l 1
field ds.w 1
delta ds.w 1
ch ds.w 1
paramsPtr ds.l 1
selector ds.l 1
return ds.l 1
oldA6 ds.l 1
dateTime0 ds LongDateRec
dateTime1 ds LongDateRec
dateTime2 ds LongDateRec
newDate ds LongDateTime
myTogFlags ds.l 1 ; modified copy of togFlags
localFrame equ *
endr
rDateFieldPtr equ a2
rDateSuccPtr equ a3
rMaxValPtr equ a4
rDelta equ d3
rField equ d4
rCounter equ d5
rBaseValue equ d5 ; doesn't overlap
rChar equ d6
rHundreds equ d7
ToggleDateRegs reg a2-a4/d3-d7
with ToggleDateRec,LongDateRec,LongDateField,ToggleResults,TogglePB
import maxOldDate,maxVal
CheckSelector
link a6,#localFrame
movem.l ToggleDateRegs,-(sp) ; save regs
; pea procName
; _DebugStr
move.b delta(a6),rDelta ; get delta
ext.w rDelta ; wordize
clr.l rField ; wordize
move.b field(a6),rField ; get field
move.w rField,d0 ; temp for field
add.w d0,d0 ; double for internal use
lea dateTime0(a6,d0.w),rDateFieldPtr ; date field poitner
lea maxVal,rMaxValPtr ; maxval table
move.l paramsPtr(a6),a0 ; paramsPtr^
move.l togFlags(a0),d0 ; get copy of togFlags
andi.w #$07F,d0 ; mask out bits for LongDateRec
; fields we can't deal with<74>
btst.l #togDelta12HourBit,d0 ; but if 12-hour range for delta
beq.s @doneForcePmBit ; (no -skip)
ori.w #$400,d0 ; then force pm bit on
@doneForcePmBit ; finished adjusting togFlags
move.l d0,myTogFlags(a6) ; save for ValidDate calls
move.l mySecsPtr(a6),-(sp) ; pass @mySecs
pea dateTime0(a6) ; pass @dateTime0
_LongSecs2Date
; ToggleDate := toggleBadDelta; {assume bad}
; if (delta < -1) or (delta > 1) then goto 999;
tst.w dateTime0.era(a6) ; BC? <1/11/88med>
blt UnknownError ; out of range
move.w #toggleErr3,funcResult(a6) ; assume out-of-range error
move.l myTogFlags(a6),d0 ; get flags
btst.l #smallDateBit,d0 ; 1904-2040 range desired?
beq.s @doneTogRangeCheck ; if not, skip these tests
move.l mySecsPtr(a6),a0 ; get ptr to longSecs
tst.l (a0) ; is high longword used?
bne ToggleExit ; if so, bail
btst.l #genCdevRangeBit,d0 ; 1920-2019 range desired?
beq.s @doneTogRangeCheck ; if not, skip year adjustment
; force year (in any calendar) into range equivalent to Gregorian 1920-2019
cmp.l #genCdevRangeLo,4(a0) ; before 1920?
bcs.s @togRangeLow ; if so, go fix
cmp.l #genCdevRangeHi,4(a0) ; after 2019?
bls.s @doneTogRangeCheck ; if not, we're done adjusting
sub.w #100,dateTime0.year(a6) ; after 2019, sub 100 from year
bra.s @doneTogRangeCheck
@togRangeLow:
add.w #100,dateTime0.year(a6) ; before 1920, add 100 to year
@doneTogRangeCheck:
move.w #toggleBadDelta,funcResult(a6) ; assume bad
move.w rDelta,d0 ; temp for compare
sub.w #1,d0 ; > 1?
bgt.s @ToggleExit3 ; yes, bail
add.w #2,d0 ; < -1 ?
blt.s @ToggleExit3 ; yes? bail
;
; if (field = pmField) then if (delta <> 0) then begin
; LongSecs2Date(mySecs, dateTime0); ****
; dateTime0.hour := (dateTime0.hour+12) mod 24;
; LongDate2Secs(dateTime0,mySecs);
; goto 900;
; end;
move.w #toggleBadField,funcResult(a6) ; assume bad
cmp.w #pmField,rField ; special case?
bne.s @NotSpecialPM ; no, skip
tst.w rDelta ; zero? (tested above)
beq.s @FieldRangeOk ; skip special if so
bra SwapAmPm ; invertpm, exit
@ToggleExit3
bra ToggleExit ; for long skip & jump
@NotSpecialPM
; ToggleDate := toggleBadField; {assume bad}
; if ((field < yearField) or (field > secondField)) then goto 999;
cmp.w #yearField,rField ; out of range?
blt.s @ToggleExit3 ; bail
cmp.w #secondField,rField ; out of range?
bgt.s @ToggleExit3 ; bail
@FieldRangeOk
; WITH maxVal DO ****
; BEGIN
; year := 150;
; {if (BAnd(oldDateFlag,params.flags) = 0) then year := 10000;}
; month := 13;
; day := 35;
; hour := 24;
; minute := 60;
; second := 60;
; dayOfWeek := 7;
; dayOfYear := 400;
; weekOfYear := 60;
; END;
; LongSecs2Date(mySecs, dateTime0); ****
; if delta = 0 then begin {character type-in}
; curChar := char(ch);
; if field = pmField then begin
; with params do
; if dateTime0.hour < 12
; then rtPtr := @pmChars
; else rtPtr := @amChars;
tst.w rDelta ; zero, character typeing?
bne NoCharInput ; no, skip
move.w #toggleBadChar,funcResult(a6) ; assume bad
lea ch(a6),a0 ; ptr
move.l #2,d0 ; length
_UpperText ; _LwrString with uppercase function <3>
move.w (a0),rChar ; copy
beq.s @ToggleExit3 ; skip null
cmp.w #pmField,rField ; special case
bne.s @NoSpecPM2 ; no, skip
move.l paramsPtr(a6),a0 ; params
add.w #pmChars,a0 ; right pointer
cmp.w #NoonHr,dateTime0.hour(a6) ; am?
blt.s @1 ; no, skip
add.w #amChars-pmChars,a0 ; now pm
@1
; for j := 1 to 4 do
; if rtPtr^[j] = curChar then begin
; dateTime0.hour := (dateTime0.hour+12) mod 24;
; LongDate2Secs(dateTime0,mySecs);
; goto 900;
; end
; end;
; NOTE THAT THE FOLLOWING ASSUMES CHARS ARE 1 BYTE !!!
move.l #3,d1 ; dbra
@MatchLoop
cmp.b (a0)+,rChar ; got match?
dbeq d1,@MatchLoop ; no, skip
beq SwapAmPm ; swap if equal
@NoSpecPM2
; myLong := BAnd(ord(curChar),$F);
; {StringToNum(tempStr,myLong); so we are international!}
; baseValue := dateTime0.list[field];
; hundreds := baseValue - (baseValue mod 100);
move.w #toggleBadNum,funcResult(a6) ; assume bad
; NOTE THAT THE FOLLOWING MAKES NON-INTERNATIONAL ASSUMPTIONS ABOUT DIGIT CODES !!!
cmp.w #$FF,rChar ; too big?
bhi ToggleExit2 ; yes, bail
andi.w #$7F,rChar ; move $b0-$b9 to $30-$39
cmp.w #$30,rChar ; too small?
blo ToggleExit2 ; yes, bail
cmp.w #$39,rChar ; too big?
bhi ToggleExit2 ; yes, bail
and.b #$F,rChar ; get numeric value of digit
move.w (rDateFieldPtr),rBaseValue ; get base value
; if toggling hours in twelve-hour mode, convert hour (0-23) to 12-hour range (1-12)
cmp.w #hourField,rField ; toggling hours?
bne.s @doneHourShiftDown ; skip if not
move.l myTogFlags(a6),d1 ;
btst.l #togChar12HourBit,d1 ; 12-hour mode?
beq.s @doneHourShiftDown ; skip if not
btst.l #togCharZCycleBit,d1 ; zero-cycle?
beq.s @hourShiftDown0 ; if not, 0 & 12 are special
cmp.w #NoonHr,rBaseValue ;
blt.s @doneHourShiftDown ;
sub.w #NoonHr,rBaseValue ;
bra.s @doneHourShiftDown ;
@hourShiftDown0 ;
cmp.w #NoonHr,rBaseValue ; hour <= 12?
ble.s @hourShiftDown1 ; if so, go test for hour=0
sub.w #NoonHr,rBaseValue ; otherwise, hour -= 12
bra.s @doneHourShiftDown ;
@hourShiftDown1
tst.w rBaseValue ; hour = 0?
bne.s @doneHourShiftDown ; skip if not
move.l #NoonHr,rBaseValue ; if so, hour = 12
@doneHourShiftDown ;
move.w rBaseValue,d1 ; copy
ext.l d1 ; longize
divs #100,d1 ; get remainder
swap d1 ; now here
move.w rBaseValue,rHundreds ; copy
sub.w d1,rHundreds ; e.g. 1967 -> 1900
sub.w rHundreds,rBaseValue ; 1967 -> 67
bge.s @CharRightSign ; positive?
neg.w rChar ; no, fix
@CharRightSign
; while true do begin
; baseValue := (baseValue * 10) mod 100;
; dateTime0.list[field] := hundreds + baseValue + myLong;
; if ValidDate(dateTime0, params.flags, newDate) = validDateFields
; then goto 888;
; if (baseValue = 0) then begin
; if (myLong = 0) then goto 777;
; baseValue := myLong;
; myLong := 0;
; end;
; end;
; end;
@NumLoop
muls #10,rBaseValue ; * 10
cmp.w #100,rBaseValue ; > 100?
blt.s @BaseOk ; skip if ok
divs #100,rBaseValue ; mod 100
swap rBaseValue ; now mod
@BaseOk
move.w rHundreds,d0 ; hundreds
add.w rBaseValue,d0 ; base
add.w rChar,d0 ; char value
; if toggling hours in twelve-hour mode, convert time back to 12-hour range.
cmp.w #hourField,rField ; toggling hours?
bne.s @doneHourShiftUp ; skip if not
move.l myTogFlags(a6),d1 ;
btst.l #togChar12HourBit,d1 ; 12-hour mode?
beq.s @doneHourShiftUp ; skip if not
; process 12-hour time
btst.l #togCharZCycleBit,d1 ; zero-cycle (0..11) time?
beq.s @hourShiftUp0 ; if not, go do 12,1..11 time
; process 0..11 time
cmp.w #NoonHr,d0 ; check bounds
bge.s @hourShiftUpErr ; if bad, set err
tst.w dateTime0.pm(a6) ; am/pm?
beq.s @doneHourShiftUp ; if am, done
add.w #NoonHr,d0 ; if pm, shift up
bra.s @doneHourShiftUp ;
@hourShiftUp0 ; process 12,1..11 time
tst.w d0 ; check lo bounds
beq.s @hourShiftUpErr ; if =0, bad
tst.w dateTime0.pm(a6) ; am/pm?
beq.s @hourShiftUp1 ; if am, go fix hour=12
; pm
cmp.w #NoonHr,d0 ; check hour
beq.s @doneHourShiftUp ; if hour=12, leave alone.
bgt.s @hourShiftUpErr ; if hour>12, err (needed?)
add.w #NoonHr,d0 ; otherwise, add 12
bra.s @doneHourShiftUp ;
@hourShiftUp1 ; am
cmp.w #NoonHr,d0 ; check hour
bgt.s @hourShiftUpErr ; if >12, err
blt.s @doneHourShiftUp ; if <12, done
clr.w d0 ; otherwise, set hour=0
bra.s @doneHourShiftUp ;
@hourShiftUpErr ; error handling
move.w #-1,d0 ; make an err
@doneHourShiftUp ;
move.w d0,(rDateFieldPtr) ; set date time record
bsr xValidDate ; is it ok?
blt SetNewDate ; yes, done
cmp.w #yearField,rField ; toggling years?
bne.s @doneTogYearAdjust ; no, skip this stuff
move.l myTogFlags(a6),d0 ; get flags
btst.l #smallDateBit,d0 ; 1904-2040 range desired?
beq.s @doneTogYearAdjust ; if not, skip these tests
btst.l #genCdevRangeBit,d0 ; 1920-2019 range desired?
beq.s @doneTogYearAdjust ; if not, skip these tests
tst.l newDate(a6) ; check high longword
bmi.s @togAdjustUp ; if year < 1904, go fix
bne.s @togAdjustDown ; if year > 2040, go fix
; now check low longword for 1920-2019 range
cmp.l #genCdevRangeLo,newDate+4(a6) ; year < 1920?
bcs.s @togAdjustUp ; if so, go fix
cmp.l #genCdevRangeHi,newDate+4(a6) ; year > 2019?
bls.s @doneTogYearAdjust ; if not, we're done adjusting
@togAdjustDown:
sub.w #100,(rDateFieldPtr) ; after 2019, sub 100 from year
bra.s @togRecheckValid
@togAdjustUp:
add.w #100,(rDateFieldPtr) ; before 1920, add 100 to year
@togRecheckValid:
bsr.s xValidDate ; is it ok?
blt SetNewDate ; yes, done
@doneTogYearAdjust:
tst.w rBaseValue ; base empty?
IF FixCacheAndStr2Date THEN ; <10><11>
bne @NumLoop ; no, continue <1-8-91,jh> .w added here
ELSE ; <10>
bne.s @NumLoop ; no, continue
ENDIF ; <10>
tst.w rChar ; char empty?
beq.s ToggleExit2 ; done, bail
move.w rChar,rBaseValue ; set it
clr.w rChar ; signal done next time
IF FixCacheAndStr2Date THEN ; <10><11>
bra @NumLoop ; done <1-8-91, jh> changed to .w
ELSE ; <10>
bra.s @NumLoop ; done
ENDIF ; <10>
;----------
ToggleExit2
bra ToggleExit ; done
;----------
SwapAmPm
move.w dateTime0.hour(a6),d0 ; get value
sub.w #12,d0 ; day/night swap
bge.s @1 ; ok
add.w #24,d0 ; now ok
@1
move.w d0,dateTime0.hour(a6) ; fix
pea dateTime0(a6) ; pass @dateTime0
move.l mySecsPtr(a6),-(sp) ; pass @mySecs
_LongDate2Secs
bra ReturnOk ; exit.
;----------
xValidDate
clr.w -(sp) ; allocate return
pea dateTime0(a6) ; pass @datetime0
move.l myTogFlags(a6),-(sp) ; pass adjusted togFlags
pea newDate(a6) ; pass @newDate
_ValidDate ; call it
move.w (sp)+,d0 ; pop result
rts
;----------
; note: don't care about speed, just space
CopyDate0to1
lea dateTime0(a6),a0 ; source
lea dateTime1(a6),a1 ; dest
CopyDateA0toA1
move.w #LongDateRecSize/2-1,d0 ; dbra counter
CopyDateLoop
move.w (a0)+,(a1)+ ; copy
dbra d0,CopyDateLoop ; until done
rts
;----------
NoCharInput
; datetime1 := dateTime0;
; dateTime0.list[field] := dateTime0.list[field] + delta;
; badField := ValidDate(dateTime0, params.flags, newDate);
; if badField = validDateFields then goto 888;
bsr.s CopyDate0to1 ; copy over
add.w rDelta,(rDateFieldPtr) ; add delta
bsr.s xValidDate ; is it ok?
blt.s SetNewDate ; yes, done
; IF badField >= field THEN {try finer field}
; BEGIN
; succField := succ(field);
; FOR j := 1 TO maxVal.list[succField] DO
; BEGIN
; dateTime0.list[succField] := dateTime0.list[succField] - 1;
; IF ValidDate(dateTime0, params.flags, newDate) = validDateFields THEN
; GOTO 888;
; END;
; END;
cmp.w #pmField,d0 ; If bad field is pm,
bne.s @donePmAdjust ;
move.w #hourField,d0 ; say that it is hour instead
@donePmAdjust
cmp.w rField,d0 ;
ble.s @NoFiner ; badfield<=field, don't try finer
add.w d0,d0 ; word offset for bad field
lea dateTime0(a6,d0.w),rDateSuccPtr ; pointer to bad field
move.w 0(rMaxValPtr,d0.w),rCounter ; get maximum value
@FinerLoop
sub.w #1,(rDateSuccPtr) ; drop
bsr.s xValidDate ; is it ok?
dblt rCounter,@FinerLoop ; til done
blt.s SetNewDate ; yes, exit
@NoFiner
; dateTime0 := dateTime1;
; if delta < 0
; then dateTime0.list[field] := dateTime0.list[field] + maxVal.list[field]
; else dateTime0.list[field] := dateTime0.list[field] - maxVal.list[field];
lea dateTime1(a6),a0 ; source
lea dateTime0(a6),a1 ; dest
bsr.s CopyDateA0toA1 ; date0 := date1
move.w rField,d0 ; double for word array
add.w d0,d0 ; double
move.w 0(rMaxValPtr,d0),rCounter ; get value
move.w rCounter,d0 ; temp value for adding
tst.w rDelta ; <0?
blt.s @DeltaNegative ; yes, d0 ok
neg d0 ; reverse
@DeltaNegative
add.w d0,(rDateFieldPtr) ; bump the other direction
; for j := 0 to maxVal.List[field] do begin
; dateTime0.list[field] := dateTime0.list[field] + delta;
; if ValidDate(dateTime0, params.flags, newDate) = validDateFields then goto 888;
; end;
@BackwardsLoop
add.w rDelta,(rDateFieldPtr) ; bump
bsr.s xValidDate ; is it ok?
dblt rCounter,@BackwardsLoop ; yes, exit
blt.s SetNewDate ; with correct date from ValidDate
; Couldn't deal with it. bail
;777:
; ToggleDate := toggleUnknown;
; goto 999;
UnknownError
moveq #toggleUnknown,d0 ; unknown error
bra.s ToggleResult ; bail
SetNewDate
;888:
; mySecs := newDate;
lea newDate(a6),a0 ; source
move.l mySecsPtr(a6),a1 ; dest
move.w #4-1,d0 ; word count, -1 for dbra <12>
bsr.s CopyDateLoop ; copy date
;900:
; ToggleDate := toggleOk;
ReturnOk
moveq #toggleOk,d0 ; good return
ToggleResult
move.w d0,funcResult(a6) ; return result
;999:
; END;
;;999 :
ToggleExit
movem.l (sp)+,ToggleDateRegs ; restore registers to their original value
checkA6 ; check stack
move #argSize, d0 ; for StdUnlink
bra StdUnlink ; standard exit
endWith
endProc
;============================================================================
; LongDate Tables & equates
;============================================================================
;typedef short YearStarts[13];
;typedef double LongDate;
dy400 equ 146097 ; days in quadcentury
dy100 equ 36524 ; days in non-leap century--must be even!
dy4 equ 1461 ; days in quad year
dy1 equ 365 ; days in non-leap year
dy2001 equ 35430 ; days between jan1,1904 and jan1,2001
sd1 equ 86400 ; seconds in day
dow2001 equ 1 ; day of week for Jan 1,2001
;============================================================================
;pascal void LongDate2Secs (longDate, longSecs, selector)
; LongDateRec* longDate;
; LongDate* longSecs;
; long selector;
; register long days, years, secs, months;
; register short leapYear = 0;
;============================================================================
LongDate2Secs proc export
LD2SRec record {oldA6},decr
resultSize equ 0
argSize equ *-8
longDate ds.l 1
longSecs ds.l 1
selector ds.l 1
argBottom equ *
return ds.l 1
oldA6 ds.l 1
mulDest ds LongDateTime
leapYear ds.w 1
srcLong ds.l 1
localFrame equ *
endr
RD2SRegs reg a2/d3-d7
; d3 years
; d4 months
; d5 days
; d6 secs
; d7 temp
with LD2SRec,LongDateRec
import MonthStarts,LeapStarts
CheckSelector
link a6,#localFrame
movem.l RD2SRegs,-(sp) ; save regs
; pea procName
; _DebugStr
; initial values
; years = longDate->year - 2001;
; months = longDate->month-1;
; days = 0;
; secs = longDate->second + (longDate->minute + longDate->hour * 60) * (long) 60;
move.l longDate(a6),a2 ; longDatePtr
; add BC <1/11/88med>
lea longDateRec.era(a2),a0 ; for unloading <1/11/88med>
move.w (a0)+,d1 ; get era
move.w (a0)+,d3 ; year
tst.w d1 ; era < 0?
bge.s @EraAD ; no, skip
sub.w #1,d3 ; no year zero
neg.w d3 ; now negative
@EraAd
sub.w #2001,d3 ; - 2001
move.w (a0)+,d4 ; months
add.w #2,a0 ; skip day, for later
sub.w #1,d4 ; - 1
clr.l d5 ; days = 0
move.w (a0)+,d6 ; hour
muls #60,d6 ; * 60 (word: don't worry about overflow)
add.w (a0)+,d6 ; minute
muls #60,d6 ; * 60 (long)
move.w (a0)+,d1 ; second
ext.l d1 ; extend to add to long
add.l d1,d6 ; value for seconds
clr.b leapYear(a6) ; leapyear = 0
; if (months > 11)
; { years += (months / 12);
; months %= 12;
; }
move.w #12,d7 ; comparison value
cmp.w d7,d4 ; turn 12+ months into years
blo.s @MonthsOk ; bail if ok already
ext.l d4 ; longize for divide
divs d7,d4 ; mod & div
add.w d4,d3 ; years = years + div
swap d4 ; months = mod
tst.w d4 ; mod negative?
bge.s @MonthsOk ; if rem < 0 then mod = mod + divisor, div = div - 1
sub.w #1,d3 ; div = div - 1
add.w d7,d4 ; mod = mod + divisor
@MonthsOk
; if (years >= 400 | years <= -400)
; { days += dy400 * (years / 400);
; years %= 400;
; }
; if (years < 0)
; { years += 400;
; days -= dy400;
; }
; if (years == 399) leapYear += 2;
move.w #400,d7 ; comparison value
cmp.w d7,d3 ; year out of bounds?
blo.s @YearsPositive ; no, continue
bgt.s @YearBig400 ; too big (otherwise negative)
move.w d7,d0 ; d0=400
add.w d3,d0 ; d3 < -400?
bge.s @YearNegative ; no, continue
@YearBig400
ext.l d3 ; long for divide
divs d7,d3 ; get mod & quo
move.w d3,d1 ; divisor
swap d3 ; years = rem
ext.l d1 ; longize
move.l d1,-(sp) ; pass it
move.l #dy400,-(sp) ; pass it
pea mulDest(a6) ; pass address of result
_LongMul
add.l mulDest+4(a6),d5 ; days +=
@YearOk400
tst.w d3 ; < 0?
bge.s @YearsPositive ; no, skip <1/11/88med>
@YearNegative
add.w d7,d3 ; fix years
sub.l #dy400,d5 ; fix days
@YearsPositive
subq.w #1,d7 ; get last year in cycle
cmp.w d7,d3 ; at last year?
bne.s @LeapOk400 ; no, skip
move.b #2,leapYear(a6) ; leapyear += 2
@LeapOk400
; years and months now guaranteed to be positive!
; if (years >= 100)
; { days += dy100 * (years / 100);
; years %= 100;
; }
; if (years == 99) leapYear -= 1;
move.w #100,d7 ; comparison value
cmp.w d7,d3 ; year out of bounds?
blo.s @YearOk100 ; no, continue
ext.l d3 ; long for divide
divu d7,d3 ; get mod & quo
move.w d3,d1 ; divisor
swap d3 ; years = rem
mulu #dy100/2,d1 ; partial multiply, since it is too big
asl.l #1,d1 ; rest of the way
add.l d1,d5 ; days +=
@YearOk100
subq.w #1,d7 ; get last year in cycle
cmp.w d7,d3 ; at last year?
bne.s @LeapOk100 ; no, skip
sub.b #1,leapYear(a6) ; leapyear -= 1
@LeapOk100
; if (years >= 4)
; { days += dy4 * (years / 4);
; years %= 4;
; }
; if (years == 3) leapYear += 1;
moveq #4,d7 ; comparison value
cmp.w d7,d3 ; year out of bounds?
blo.s @YearOk4 ; no, continue
ext.l d3 ; longize for divide
divu d7,d3 ; get mod & quo
move.w d3,d1 ; quotient
swap d3 ; years = rem
mulu #dy4,d1 ; quick mul
add.l d1,d5 ; days +=
@YearOk4
subq.w #1,d7 ; get last year in cycle
cmp.w d7,d3 ; at last year?
bne.s @LeapOk4 ; no, skip
add.b #1,leapYear(a6) ; leapyear += 1
@LeapOk4
; days += years * d1;
mulu #dy1,d3 ; quick mul, dont need d3
add.l d3,d5 ; days +=
; days += MonthStarts[months];
; if (leapYear > 0)
; { if (months > 1)
; { days += 1;
; }
; }
lea MonthStarts,a0 ; get months array
tst.b leapYear(a6) ; leap?
ble.s @LeapOk ; no
lea LeapStarts,a0 ; adjust
@LeapOk
add.w d4,d4 ; for word offset
clr.l d0 ; longize
move.w 0(a0,d4.w),d0 ; get days in year
add.l d0,d5 ; add days in year
; if (longDate->day !=0) days += longDate->day;
; else if (longDate->dayOfYear != 0) days += longDate->dayOfYear;
; else
; { temp = (days - dow2001) % 7;
; if (temp < 0) temp += 7;
; days += (longDate->weekOfYear - 1) * 7 - temp + longDate->dayOfWeek + 1;
; }
; days += d2001 - 1;
move.w day(a2),d0 ; get day
bne.s @GotDay ; ok, skip
move.w dayOfYear(a2),d0 ; get day of year
bne.s @GotDay ; ok, skip
move.w weekOfYear(a2),d0 ; get week of year
sub.w #1,d0 ; make zero based
muls #7,d0 ; get days
move.l d5,d1 ; get days to year
sub.l #dow2001,d1 ; normalize for year 2001
divs #7,d1 ; get first day of year
swap d1 ; d1 = (d5-dow2001) % 7
tst.w d1 ; negative (rem)
bge.s @1 ; no, ok
add.w #7,d1 ; rem -> mod
@1
sub.w d1,d0 ; remove first day
add.w dayOfWeek(a2),d0 ; add day of week
add.w #1,d0 ; make 1 based (soon to be removed)
@GotDay
ext.l d0 ; normal
add.l #dy2001-1,d0 ; adjust
add.l d0,d5 ; now in days
; *longSecs = secs + days * secsInDayX;
move.l d5,-(sp) ; pass days
move.l #secsInDay,-(sp) ; pass secs in day
move.l longSecs(a6),-(sp) ; pass dest address
_LongMul
clr.l d1 ; for foolish addx syntax
move.l longSecs(a6),a0 ; addr of result
move.l (a0)+,d0 ; get high
add.l d6,(a0) ; add to low part
addx.l d1,d0 ; add to high part
move.l d0,-(a0) ; stick back in
IF 0 THEN
lea srcLong(a6),a1 ; address of source
move.l a1,-(sp) ; pass source address
move.l d5,(a1) ; source = long days
lea secsInDayX,a0 ; constant
move.l longSecs(a6),a1 ; dst address
move.l a1,-(sp) ; pass address
move.l (a0)+,(a1)+ ; copy
move.l (a0)+,(a1)+ ; copy
move.w (a0)+,(a1)+ ; copy
FMULL ; dst = source * dest
lea srcLong(a6),a1 ; address of source
move.l a1,-(sp) ; pass source address
move.l d6,(a1) ; source = secs
move.l longSecs(a6),-(sp) ; pass dst address
FADDL ; dst2 = extended
ENDIF
; done, so exit gracefully
movem.l (sp)+,RD2SRegs ; restore registers to their original value
checkA6 ; check stack
move.w #argSize, d0 ; for StdUnlink
bra StdUnlink ; Standard exit
endWith
endProc
;============================================================================
;pascal void LongSecs2Date (longSecs, longDate, selector)
; LongDate* longSecs;
; LongDateRec* longDate;
; long selector;
;============================================================================
LongSecs2Date proc export
LS2DRec record {oldA6},decr
resultSize equ 0
argSize equ *-8
longSecs ds.l 1
longDate ds.l 1
selector ds.l 1
return ds.l 1
oldA6 ds.l 1
fExt ds.x 1
fLong ds.l 1
mulDest ds LongDateTime
localFrame equ *
endr
; a2 LongDatePtr
; d3 years
; d4 leapyear
; d5 days
; d6 secs
; d7 temp
; leapyear contains 3 bits:
; bit 0: not end of century
; bit 1: end of quadcentury
; bit 2: end of quadyear
; so the year is a leap year if leapyear > 4: (qy + (qc or nc))
RS2DRegs reg a2/d3-d7
with LS2DRec,LongDateRec
import MonthStarts,LeapStarts,secsInDayX
CheckSelector
link a6,#localFrame
movem.l RS2DRegs,-(sp) ; save regs
; pea procName ; save
; _DebugStr
; initial values
; register long days, years, secs, dow, i, temp;
; register short leapYear = 1;
; register YearStarts*
; myStarts;
;
; days = *longSecs / secsInDayX;
; secs = *longSecs - secsInDayX * days;
move.l longDate(a6),a2 ; longDatePtr
moveq #1,d4 ; leapyear = 1
; divide a sixty-four by a 32 and produce quotient and remainder in d5, d6
move.l longSecs(a6),a0 ; get @source
move.l (a0)+,d0 ; get top
move.l (a0)+,d1 ; get bottom
cmp.l #maxDate,d0 ; too big?
blo.s @DateInRange ; no, keep going
bge.s @OutOfRangeDate ; fix
cmp.l #minDate,d0 ; now try bottom <was d2, fixed 4/07/89 pke>
bge.s @DateInRange ; ok, continue
@OutOfRangeDate
clr.l d0 ; assume zero date, cant help it
clr.l d1 ; ditto (just drop through, don't care about performance)
@DateInRange
move.l #secsInDay,d2 ; divisor
LongDiv ; results in rd1,qd0
move.l d1,d5 ; get quotient
move.l d0,d6 ; get remainder
; if secs < 0 then secs = secs + secsInDayX, days = days - 1;
bge.s @SecsPlus ; no, continue
add.l #sd1,d6 ; secs +
sub.l #1,d5 ; days -
@SecsPlus
; dow = (days + 5) % 7;
; if (dow < 0) dow += 7;
; longDate->dayOfWeek = dow+1;
move.l d5,d0 ; temp d0
add.l #5,d0 ; +5
divs #7,d0 ; (d5+5)/7
bvc.s @Mod7Ok ; mod ok, skip
; fix days if overflow <1/11/88med>
divs #16807,d0 ; divide by large power of 7
swap d0 ; get modulo
ext.l d0 ; longize
divs #7,d0 ; (d5+5)/7
@Mod7Ok
swap d0 ; modulo
tst.w d0 ; <0?
bge.s @DofWPlus ; skip if not
add.w #7,d0 ; fix
@DofWPlus
add.w #1,d0 ; make 1 based
lea dayOfWeek(a2),a0 ; for walking through array
move.w d0,(a0) ; set day of week
; longDate->second = secs % 60;
; secs /= 60;
; longDate->minute = secs % 60;
; longDate->hour = secs / 60;
move.w #60,d0 ; common factor
divu d0,d6 ; /60
swap d6 ; modulo
move.w d6,-(a0) ; save seconds in record
clr.w d6 ; longize for after swap <11/23/87med>
swap d6 ; recover divisor
divu d0,d6 ; /60
move.w d6,d0 ; save quo
swap d6 ; modulo
move.w d6,-(a0) ; save minutes in record
move.w d0,-(a0) ; save hours in record
lea pm(a2),a0 ; for storing
cmp.w #NoonHr,d0 ; am/pm?
sge d0 ; set bottom byte
neg.b d0 ; top byte already zero
move.w d0,(a0)+ ; set pm state
clr.l (a0)+ ; clear ldReserved
; days = days - dy2001;
; years = 0;
sub.l #dy2001,d5 ; normalize
clr.l d3 ; years = 0
; if (days >= dy400 | days <= -400)
; { years += 400 * (days / dy400);
; days %= dy400;
; }
; if (days < 0)
; { days += dy400;
; years -= 400;
; }
move.l #dy400,d7 ; temp comparison value
cmp.l d7,d5 ; in range?
blo.s @In400Range ; yes, skip
bgt.s @Adjust400 ; no, adjust
move.l d7,d0 ; temp
add.l d5,d0 ; > dy400?
bge.s @Adjust400Neg ; yes, just fix negation
@Adjust400
move.l d7,d2 ; divisor
move.l d5,d1 ; dividend
slt d0 ; now extend long to quad
ext.w d0 ; more
ext.l d0 ; and more
LongDiv ; results in rd1,qd0
muls #400,d1 ; get years = quotient * 400
add.l d1,d3 ; add in
move.l d0,d5 ; set remainder
; tst.l d5 ; remainder negative?
bge.s @In400Range ; no, continue
@Adjust400Neg
add.l #dy400,d5 ; bump up
sub.l #400,d3 ; fix years
@In400Range
; days are now safely positive
; temp = 0;
; if (days > dy100)
; { temp += 100 * (days / dy100);
; days %= dy100;
; if (temp == 400)
; { temp -= 100;
; days += d100;
; }
; }
; if (temp == 300) leapYear += 2;
; note: d5 is long from above.
clr.w d0 ; temp years
move.l #dy100,d7 ; comparison value
cmp.l d7,d5 ; in range?
blt.s @InRange100 ; yes, skip
move.l d5,d1 ; days
divu #dy100,d5 ; days/dy100
move.w d5,d0 ; quotient
clr.w d5 ; longize for after swap
swap d5 ; remainder=modulo
mulu #100,d0 ; 100 * (days / dy100)- don't need to add
cmp.w #300,d0 ; (years are word) leap?
blt.s @InRange100 ; no, continue
beq.s @Leap100 ; too big
sub.l #100,d0 ; back one century
add.l #dy100,d5 ; bump days up
@Leap100
add.b #2,d4 ; bump flag up
@InRange100
add.w d0,d3 ; add in to days <11/20/87med>
; years +=temp; ****
; temp = 4 * (days / dy4); ****
; days %= dy4;
; if (temp == 96) leapYear -= 1;
; years += temp;
; don't test for range of 4 years, very unlikely
; note: d5 is long from above. Do NOT sign extend.
divu #dy4,d5 ; div days
move.w d5,d0 ; quo
asl.w #2,d0 ; *4
swap d5 ; rem=mod
cmp.w #96,d0 ; end of cycle?
bne.s @InRange4 ; no, skip
sub.b #1,d4 ; bump down, at end
@InRange4
add.l d0,d3 ; years +=
; temp = (days / d1);
; days %= d1;
; if (temp < 3)
; { leapYear += 4;
; if (temp == 4)
; { temp -= 1;
; days += d1;
; }
; }
; years += temp;
ext.l d5 ; for division
divu #dy1,d5 ; get number of years in 4 yr cycle
move.w d5,d0 ; temp = quo
swap d5 ; days = remainder
cmp.w #3,d0 ; leap year?
blt.s @InRange1 ; no, skip
beq.s @Leap1 ; yes, simple case
sub.w #1,d0 ; back up a year
add.w #dy1,d5 ; correct days
@Leap1
add.b #4,d4 ; possible leap year
@InRange1
add.w d0,d3 ; years
; longDate->dayOfYear = days+1;
; {algorithm changed in asm!}
; temp = (days - longDate->dayOfWeek) % 7;
; if (temp < 0) temp += 7;
; longDate->weekOfYear = (days + temp - longDate->dayOfWeek) / 7 + 1;
; longDate->era = 0; /* for now */
move.w d5,d0 ; get days in year
add.w #1,d0 ; one-based
move.w d0,dayOfYear(a2) ; save
move.w d5,d1 ; days
ext.l d1 ; prepare to di(vid)e
divu #7,d1 ; days are unsigned
move.w d1,d0 ; save weeks
swap d1 ; get quo=rem for unsigned
cmp.w dayOfWeek(a2),d1 ; if remainder day <= day of week, add 1
blt.s @WeekOk ; ow bail (dow is 1 based, so < )
add.w #1,d0 ; fix
@WeekOk
add.w #1,d0 ; make 1 based
move.w d0,weekOfYear(a2) ; save
; if (leapYear > 4)
; {
; for (i = 0; LeapStarts[i] <= days; ++i);
; days -= LeapStarts[i-1];
; }
; else
; {
; for (i = 0; MonthStarts[i] <= days; ++i);
; days -= MonthStarts[i-1];
; }
lea MonthStarts,a0 ; assume not leap
cmp.b #4,d4 ; leap?
ble.s @ArrayOk ; no, continue
lea LeapStarts,a0 ; fix
@ArrayOk
move.l #-1,d0 ; init month
@FindMonthLoop
add.w #1,d0 ; inc month
cmp.w (a0)+,d5 ; in range yet?
bge.s @FindMonthLoop ; no, keep going (d5 limited, must terminate)
; longDate->year = years + 2001;
; longDate->month = i;
; longDate->day = days+1;
; add BC <1/11/88med>
lea era(a2),a1 ; for loading <1/11/88med>
clr.w d1 ; assume AD <1/11/88med>
add.w #2001,d3 ; add offset <11/20/87med>
bgt.s @EraOK ; skip if AD (> 0) <1/11/88med>
moveq #-1,d1 ; set BCq <1/11/88med>
neg d3 ; now positive (BC) <1/11/88med>
add.w #1,d3 ; no year zero
@EraOk
move.w d1,(a1)+ ; set era <1/11/88med>
move.w d3,(a1)+ ; set year
move.w d0,(a1)+ ; set month
sub.w -4(a0),d5 ; days in month (zero based
add.w #1,d5 ; now 1 based
move.w d5,(a1)+ ; day, and we are done
; done, so exit gracefully
movem.l (sp)+,RS2DRegs ; restore registers to their original value
checkA6 ; check stack
move.w #argSize, d0 ; for StdUnlink
bra StdUnlink ; standard exit
endWith
endProc
;============================================================================
; String & Date conversions
;============================================================================
WhiteSpace EQU 1 ; token number for white space
AlphaToken EQU 4 ; token number for string
NumericToken EQU 5 ; token number for number
AltNumericToken equ $B ; alternate token type for numbers <9/2/87med>
NonAlphNumToken EQU 16 ; token numbers starting here correspond to non-alpha numeric tokens
NilToken EQU $7F ; token number for nil
MaxTokens EQU 32 ; number of tokens for which there is space
omdy EQU 0 ; date order constants
odmy EQU 1
oymd EQU 2
omyd EQU 3
odym EQU 4
oydm EQU 5
; long date order constants defined in PackMacs.a <10/12/88ldc>
invalidPart EQU $80000000
Str15 EQU 16 ; length of string[15]
IF FixCacheAndStr2Date THEN ; <10><11>
Str4 EQU 5 ; length of string[4] added for more space-efficient cache <1-8-91jh><10>
Str8 EQU 9 ; length of string[8] ditto <1-8-91jh><10>
ENDIF ; <10>
DayMonthLen equ 15 ; length of days and months
IF FixCacheAndStr2Date THEN ; <10><11>
TimeLen equ 4 ; length of time strings
ELSE
TimeLen equ 15 ; length of time strings
ENDIF
NumDays EQU 7 ; length of various arrays
NumMonths EQU 12
IF FixCacheAndStr2Date THEN ; <10><11>
NumTimeStrings equ 4
ELSE
NumTimeStrings equ 3 ; number of time strings
ENDIF
DayList EQU NumDays*Str15
MonthList EQU NumMonths*Str15
NumStrBytes EQU 300
IF FixCacheAndStr2Date THEN ; <10><11>
;;-------BEGIN <1-8-90, jh> equates for extend itl1
; new itl1 extensions
itl1Version equ localRtn+2
itl1Format equ itl1Version+2
calendarcode equ itl1Format+2
extraDaysOffset equ calendarcode+2
extraDaysLength equ extraDaysOffset+4
extraMonthsOffset equ extraDaysLength+4
extraMonthsLength equ extraMonthsOffset+4
abbrevDaysOffset equ extraMonthsLength+4
abbrevDaysLength equ abbrevDaysOffset+4
abbrevMonthsOffset equ abbrevDaysLength+4
abbrevMonthsLength equ abbrevMonthsOffset+4
extraSepsOffset equ abbrevMonthsLength+4
extraSepsLength equ extraSepsOffset+4
; For any of the above offsets there will be data down here in all cases this
; data will have the STR# format (i.e. word for string count followed by an
; array of pstring)
extformatkey equ $A89F
maxExtraSeps equ 10 ; count of extra seps in cache, must be at least 1!! <10>
IF maxExtraSeps<1 THEN ; <10>
aerror &concat('maxExtraSeps wrong: ',&i2s(maxExtraSeps)) ; <10>
ENDIF ; <10>
itl1stCount equ 4 ; 0..4 st's in itl1
;;-----------END <1-8-91, jh> equates for extended itl1
ENDIF ; <10>
monthReplace EQU 0 ; offsets to CvtTable
reorder EQU 18
theYear EQU 0 ; offset to elements of arrays in CvtTable.reorder
theMonth EQU 1
theDay EQU 2
IF 0 THEN ; already defined
tokenOK EQU 0 ; tokenizer result constants
tokenOverflow EQU 1
stringOverflow EQU 2
badDelim EQU 3
unknownToken EQU 4
TokenRec RECORD 0,INCR ;
theToken ds.w 1 ; TokenType
position ds.l 1 ; Ptr into original source
length ds.l 1 ; length of text in original source
stringPosition ds.l 1 ; StringPtr to copy of identifier
tokenRecSize equ *
ENDR
tokenBlock RECORD 0
source DS.L 1
sourceLength DS.L 1
tokenList DS.L 1
tokenLength DS.L 1
tokenCount DS.L 1
stringList DS.L 1
stringLength DS.L 1
stringCount DS.L 1
doString DS.B 1
doAppend DS.B 1
doAlphaNumeric DS.B 1
doNest DS.B 1
leftDelims DS.W 4
rightDelims DS.W 4
leftComment DS.W 4
rightComment DS.W 4
escapeCode DS.W 1
ENDR
ENDIF
;========================IMPORTANT NOTE,POTENTIAL DANGER===================================
;
; The Data structure below is actually 6 bytes longer than the size of a
; DateCacheRecord. Initially, I fixed it so that the Record fit within 512 bytes
; but that change forced very large patches to String2Date and String2Time in the
; aurora and esprit ROMs.
;
; Since these patches were large and required a fair amount of change to ScriptMgrROMPatch.a
; we rethought fixing the cache so that it fit into 512 bytes and instead opted
; for keeping the fields in identical offsets.
;
; This is not as bad as it sounds (although it is bad, let there be no doubt about that)
; since the last 32 bytes of a tokenBlock are reserved and at this time (7.0 and earlier)
; are neither read from nor written to. For that reason, the fact that the declaration
; below is 6 bytes longer than the memory provided for it is only a forgiveable bit
; of forgetfulness.
;
; However, do NOT read or write any values past the itlResource field of the token block.
; And do NOT do what inside mac and the published headers say to do which is zero out
; the last 32 bytes of the token block. Doing that will TRASH memory. DON'T DO IT.
;========================================================================================
Cache RECORD 0
version ds.w 1
CurrentDate DS LongDateRec
BaseDate DS LongDateRec
theDays DS.B DayList
theMonths DS.B MonthList
IF FixCacheAndStr2Date THEN ; <10><11>
theEveStr DS.B Str4 ;use new string definitions to make room for altseps
theMornStr DS.B Str4 ;
the24hrAMStr DS.B Str4 ;
the24hrPMStr DS.B Str4 ;
countAltSeps DS.W 1 ;number of separator tokens <1-8-91, jh>
AltSeps DS.W maxExtraSeps ;contains an array of separator tokens <1-8-91, jh>
filler DS.B 6
ELSE ; <10>
theEveStr DS.B Str15
theMornStr DS.B Str15
the24hrStr DS.B Str15
ENDIF ; <10>
theTimeSep DS.W 1
theDateSep DS.W 1
theDateOrder DS.b 1
longDateOrder ds.b 1
theAbbrLen DS.W 1
TBlock DS tokenBlock
CacheSize equ *
theTimeStrings equ theEveStr
ENDR
MaxInteger equ $00008000 ; <10>
;============================================================================
; Utility Routines
;============================================================================
;======================================================================
; Function ValidLong(aStr: Str255): Longint; <2.5>
; Input stringPtr: ptr in A0
; Output theLong ($80000000 if invalid) in D0
; returns a valid longint, positive. Number sets status register
;======================================================================
ValidLong proc export
movem.l d3/d4,-(sp)
move.l #$80000000,d0 ; assume bad
clr.l d4
move.b (A0)+,d4 ; get length
ble.s @BailValid ; bail if not there
clr.l d1 ; longize
move.b (a0)+,d1 ; new value
sub.b #'0',d1 ; adjust
subq.b #1,D4 ; adjust string length
move.l d1,d2 ; initialize total
bra.s @FastEntry ; enter loop in middle
@FastPathLoop
; multiply by 10
add.l d2,d2 ; double
move.l d2,d3 ; save copy
lsl.l #2,d2 ; now * 8
add.l d3,d2 ; now * 10, at a cost of 6+4+12+6=28 10x = 2x + 4<>2x
add.l d1,d2 ; accumulate
@FastEntry
move.b (a0)+,d1 ; new value
sub.b #'0',d1 ; adjust
dbra d4,@FastPathLoop ; yes, continue
@DoneFastPath
IF FixCacheAndStr2Date THEN ; <10><11>
cmp.l #MaxInteger,d2 ; is it greater than 32768?
bhi.s @BailValid ; yes, so it is too high, bail
ENDIF ; <10>
move.l d2,d0 ; return result and set status register
@BailValid
tst.l d0
@Exit
movem.l (sp)+,d3/d4
rts
endProc
;======================================================================
; Procedure Block2String
; Input textPtr: ptr in A0
; textLen: word in D0
; var dstStr: strNN in A1 ; not necessarily Str15 <10>
; leadSpaces: boolean in D1
; altSpace: byte in d2 <8/22/87med>
; Function Copy text to pascal string, stopping at null byte,
; stripping leading spaces, and uppercasing <1/5/88med>
; Uses A0-1,D0-2
;======================================================================
Block2String proc export
move.l d3,-(sp) ; save d3 <8/22/87med>
move.l a1,-(sp) ; save destination string for later <1/5/88med>
move.b d2,d3 ; use for alternate space <8/22/87med>
move.b d1,d2 ; move lead spaces into d2
; pin length
clr.l d1 ; assume zero
tst.l d0 ; length 0 or negative?
ble.s @QuickExit ; exit now
not.b d1 ; d2 = 255
cmp.l d1,d0 ; too big?
ble.s @NoPin ; no, keep going (catches negatives)
move.l d1,d0 ; pin at value
@NoPin
move.l a1,-(sp) ; save length position
move.l d0,d1 ; save length
add.l #1,a1 ; skip length for now
tst.b d2 ; discard leading spaces?
beq.b @CopySpaces ; no, copy everything
bra.b @DiscardSpaces ; yes, discard leading spaces
@DSLoopStart
subq.b #1,d1 ; found leading space, resultant string will be shorter by 1
@DiscardSpaces
move.b (a0)+,d2 ; get next character
cmp.b #' ',d2 ; is it a space
beq.s @1 ; keep looping <8/22/87med>
cmp.b d3,d2 ; alternate space? <8/22/87med>
@1
dbne d0,@DSLoopStart ; if yes, and we haven't exhausted string, loop
beq.b @QuickExit ; whoops! string was all spaces, return null string.
tst.b d2 ; set status register to current character
bne.b @LoopEnd ; copy string.
@CopySpaces
move.b (a0)+,d2 ; get byte
bra.s @LoopEnd ; dbra setting
@CopyBytes
move.b d2,(a1)+ ; copy
move.b (a0)+,d2 ; get byte
@LoopEnd
dbeq d0,@CopyBytes ; copy
bne.b @SkipZero ; continue if not null
sub.b d0,d1 ; readjust length as null was found
@SkipZero
; fix length, exit
move.l (sp)+,a1 ; recover length
@QuickExit
move.b d1,(a1) ; set it
move.l (sp)+,a0 ; restore string address
CLR.L D0
MOVE.B (A0)+,D0 ; UprString wants textPtr and length in D0. Get it from
; string and adjust A0 to string's text at same time
_UpperText ; _LwrString with uppercase function <3>
move.l (sp)+,d3 ; restore d3 <8/22/87med>
rts
endproc
;======================================================================
; routine Compare
; input a0 source pointer
; a1 destination pointer
; d0.w source length (>= 0)
; d1.w destination length (>=0)
; output d0.w =0 if match <>0 if not
; ccr set according to d1
; matches if source is an initial substring of destination
;======================================================================
Compare PROC EXPORT
CMP.w D1,D0 ; word length
BGT.S NotFound ; if source > destination, skip
SUBQ.w #1,D0 ; word length
;; BMI.S NotFound ; destination is never null, so omit this test. <2/23/88med>
CompareLoop
CMPM.B (A0)+,(A1)+
LoopEnd
DBNE D0,CompareLoop
;; BNE.S NotFound
CLR.L D0
BRA.S Exit
NotFound
MOVEQ #-1,D0
Exit
RTS
ENDPROC
;======================================================================
; FUNCTION MatchString (textPtr : Ptr; textLen: Integer; textMinLen: Integer;
; strArrPtr : Ptr; strArrMaxLen: Integer;
; strArrCount: Integer) : Integer; external;
; function Finds the longest match between the text and an
; initial portion of a string in the array.
; return is the number of the match (1 based), -1 if not found
;======================================================================
MatchStrFrame record {oldA6},decrement
result ds.w 1
textPtr ds.l 1
textLen ds.w 1
textMinLen ds.w 1
strArrPtr ds.l 1
strArrMaxLen ds.w 1
strArrCount ds.w 1
return ds.l 1
oldA6 ds.l 1
args equ result-return-4
endr
MatchStrRegs reg a2-a4/d3-d5
MatchString proc export
with MatchStrFrame
link a6,#Frame ; allocate
movem.l MatchStrRegs,-(sp) ; save regs
move.l textPtr(a6),a3 ; get textPtr
move.w textLen(a6),d3 ; get len
move.l strArrPtr(a6),a4 ; get string array
IF NOT FixCacheAndStr2Date THEN ; <10><11>
; moved the following into loop since we must reset every time
; around if dealing with variable length pstrings <1-8-91jh>
move.w strArrMaxLen(a6),d4 ; get max str length
ENDIF ; <10>
move.w strArrCount(a6),d5 ; get count
bra.s @EndLoop ; for dbra
@MainLoop
IF FixCacheAndStr2Date THEN ; <10><11>
; if 0 we have variable length pstrings in the array and handle
; differently, see below <1-8-91jh>
move.w strArrMaxLen(a6),d4 ; get max str length
ENDIF ; <10>
; call compare with array entry
move.l a3,a0 ; pass ptr1
move.l d3,d0 ; pass len1
clr.l d1 ; wordize
move.b (a4)+,d1 ; get length
IF FixCacheAndStr2Date THEN ; <10><11>
tst.w d4 ; if d4.w=0 then we need to remember the actual string
; length for each string and now the strArrMaxLen as
; above <1-9-91, jh>
bne.s @UsingStrArrMaxLen ; valid length in d4.2 so we don't need to remember
; the real length <1-9-91, jh>
move.b d1,d4 ; remember # of characters so we can move to next string <1-8-91 jh>
@UsingStrArrMaxLen ; added label to branch to <1-9-91, jh>
ENDIF ; <10>
move.l a4,a1 ; pass start of text
; move compare to in-line, add min length test <2/23/88med>
CMP.w D1,D0 ; word length
BGT.S @NextString ; if len actual > len template, skip
beq.s @TryCompare ; lens equal, try anyway
cmp.w textMinLen(a6),d0 ; len actual < abbrev len?
blt.s @NextString ; do next
@TryCompare
SUBQ.w #1,D0 ; word length
blt.s @NextString ; actual string is null
@CompareLoop
CMPM.B (A0)+,(A1)+
DBNE D0,@CompareLoop
beq.s @GotString ; exit <2/23/88med>
@NextString
add.w d4,a4 ; get to next string
@EndLoop
dbra d5,@MainLoop ; loop til done
bra.s @Exit ; bail with d5 = -1.
@GotString
; return number of string, 1 based
sub.w strArrCount(a6),d5 ; get difference <2/23/88med>
neg.w d5 ; now right direction <2/23/88med>
@Exit
move.w d5,result(a6)
movem.l (sp)+,MatchStrRegs ; restore regs
move.w #args, d0 ; for StdUnlink
bra StdUnlink ; standard exit
endWith
endProc
;============================================================================
InitDateCache FUNC EXPORT
;
; function InitDateCache(theCache: CachePtr): OSErr;
;
; InitDateCache will initialize the items in the DateCacheRecord pointed to by theCache^
; and set the initialized item to true
;
IF FixCacheAndStr2Date THEN ; <10><11>
SaveRegs REG A2-A4/D3-d7 ; use d5,d6,d7 in our code to cache separators <1-10-91, jh>
ELSE ; <10>
SaveRegs REG A2-A4/D3/D4
ENDIF ; <10>
InitCacheRec RECORD {A6link},decr
Result DS.W 1 ; offset to function result (integer)
paramBegin EQU *
theCache DS.L 1 ; pointer to the cache record
selector ds.l 1 ; added for resource <8/21/87med>
paramEnd EQU *
return DS.L 1
A6link DS.L 1
theTokens DS.B 2*TokenRec.tokenRecSize
Intl0 DS.L 1 ; handle, not pointer
Intl1 DS.L 1 ; handle, not pointer
altSpace ds.w 1 ; use top byte
aLongDate ds LongDateTime ; <1/12/88med>
IF FixCacheAndStr2Date THEN ; <10><11>
temp4bytes ds.l 1 ;4 bytes to cache temp string <1-10-91,jh>
ENDIF ; <10>
localsize EQU *
ENDR
WITH InitCacheRec,LongDateField
parametersize EQU paramBegin - paramEnd ; size of parameter space on stack
LINK A6,#localsize ; Establish local frame and variables
MOVEM.L SaveRegs,-(SP) ; saved used registers
CLR.W Result(A6) ; clear function result
MOVE.L theCache(A6),A2 ; cache addr
move.b #' ',altSpace(a6) ; assume no alt space
with SMgrRecord,ScriptRecord
subq.w #2,sp ; space for IntlScript result
_IntlScript
move.w (sp)+,d0 ; we know this script is ok
lsl.w #2,d0 ; make it a long offset
GetSMgrCore a0 ; get SMgrRecord pointer
move.l smgrEntry(a0,d0.w),a0 ; get ScriptRecord pointer
tst.b scriptRight(a0) ;
endwith
beq.s @NoAltSpace ; no <8/22/87med>
move.b #' '+$80,altSpace(a6) ; use alt space.
@NoAltSpace
WITH Cache
lea aLongDate(a6),a0 ; @temp
clr.l (a0)+ ; no high
move.l Time,(a0)+ ; low = current
pea aLongDate(a6) ; extended
pea CurrentDate(A2) ; get current date from system global<61>
; <20>time and convert to date
_LongSecs2Date
lea aLongDate(a6),a0 ; @temp
clr.l (a0)+ ; no high
clr.l (a0)+ ; low = current
pea aLongDate(a6) ; extended
pea BaseDate(A2) ; get base date and convert to date
_LongSecs2Date
; IUGetIntl(0): Handle
CLR.L -(SP)
CLR.W -(SP)
_IUGetIntl
MOVE.L (SP)+,Intl0(A6)
move.w ResErr,d0 ; did intl0 load in all right <1/5/88med>
BEQ.S GotIntl0Ok ; if so, go on
MOVE.W d0,Result(A6)
BRA Exit
GotIntl0Ok
MOVE.L Intl0(A6),A3
; Lock itl0 across Block2String calls (which can now move memory)
move.l a3,a0
_HLock
MOVE.L (A3),A3 ; now a3 is pointer to itl0
; Block2String(eveStr,theEveStr,4,true)
LEA eveStr(A3),A0 ; get international 0 record for evening string
LEA theEveStr(A2),A1
MOVEQ #4,D0
MOVE.B #1,D1
move.b altSpace(a6),d2 ; pass alt string <8/22/87med>
JSR Block2String ; convert packed array of char into<74>
; <20>string with no leading spaces
; Block2String(mornStr,theMornStr,4,true)
LEA mornStr(A3),A0 ; get international 0 record for morning string
LEA theMornStr(A2),A1
MOVEQ #4,D0
MOVE.B #1,D1
move.b altSpace(a6),d2 ; pass alt string <8/22/87med>
JSR Block2String ; convert packed array of char into<74>
; <20>string with no leading spaces
; Block2String(time1Stuff,the24hrStr,1,true)
IF FixCacheAndStr2Date THEN ; <10><11>
lea timeSuff(a3),A0 ; AM trailer for 24 hour time
lea the24hrAMStr(a2),a1 ; position in cache
moveq #4,d0 ; max four bytes per trailer
ELSE ; <10>
LEA timeSuff(A3),A0 ; get international 0 record for 24 hour string
LEA the24hrStr(A2),A1
MOVEQ #1,D0
ENDIF ; <10>
MOVE.B #1,D1
move.b altSpace(a6),d2 ; pass alt string <8/22/87med>
JSR Block2String ; convert packed array of char into<74>
; <20>string with no leading spaces
IF FixCacheAndStr2Date THEN ; <10><11>
lea timeSuff+4(a3),A0 ; PM trailer for 24 hour time
lea the24hrPMStr(a2),a1 ; position in cache
moveq #4,d0 ; max four bytes per trailer
MOVE.B #1,D1
move.b altSpace(a6),d2 ; pass alt string <8/22/87med>
JSR Block2String ; convert packed array of char into<74>
ENDIF ; <10>
MOVE.B timeSep(A3),theTimeSep(A2) ; get time separator from intl 0
MOVE.B dateOrder(A3),theDateOrder(A2)
MOVE.B dateSep(A3),(theTimeSep + 1)(A2)
; Now unlock itl0
move.l Intl0(A6),a0
_HUnlock
; This was moved from above to prevent itl0 and itl1 handles from being purged <7>
; before we lock them.
; IUGetIntl(1): Handle
CLR.L -(SP)
MOVE.W #1,-(SP)
_IUGetIntl
MOVE.L (SP)+,Intl1(A6)
TST.W ResErr ; did intl1 load in all right
BEQ.S GotIntl1 ; if so, go on
MOVE.W ResErr,Result(A6)
BRA Exit
GotIntl1
MOVE.L Intl1(A6),A3
; Lock itl1 across Copy Array calls; it calls Block2String, which can now move memory
move.l a3,a0
_HLock
MOVE.L (A3),A3 ; now a3 is pointer to itl1
; Get the long date order and convert <8/24/87med>
; false => dmy, true => mdy; otherwise fancy stuff
; see constants defined above: omdy, odmy, etc.
move.l #omdy,d1 ; assume false
clr.w d0 ; wordize
move.b lngDateFmt(a3),d0 ; get long format
beq.s @GotLong ; done
move.l #odmy,d1 ; assume true
cmp.b #$FF,d0 ; true?
beq.s @GotLong ; yes, got it
; if we are looking at the long date, only the day and year are important,
; since the dayOfWeek and month are both strings. Walk through the format until
; we find either one or the other
@LongFmtLoop
move.b d0,d2 ; get bottom half-nybble
and.b #3,d2 ; got it
cmp.b #longDay,d2 ; day?
beq.s @GotLong ; yes, return #odmy
cmp.b #longYear,d2 ; year?
beq.s @LongYearFirst ; go for it
lsr.b #2,d0 ; strip bottom
bne.s @LongFmtLoop ; repeat until done
@LongYearFirst
move.l #oymd,d1 ; year first (also if none found)
@GotLong
move.b d1,longDateOrder(a2) ; set it
; continue <8/24/87med>
MOVE.B abbrLen(A3),theAbbrLen(A2) ; get abbrLen
; changed order for more convenience in the later routine <2/23/88med>
lea months(a3),a4 ; source of days <2/23/88med>
LEA theMonths(A2),a1 ; destination names of the day and months
MOVE.L #(numMonths - 1),D3 ; load day and months from intl 1 rec into space
jsr CopyArray ; copy days
lea days(a3),a4 ; source of days <2/23/88med>
LEA theDays(A2),a1 ; destination names of the day and months
MOVE.L #(numDays - 1),D3 ; load day and months from intl 1 rec into space
jsr CopyArray ; copy days
IF FixCacheAndStr2Date THEN ; <10><11>
; Begin addition where we try to cache any valid st0 through st4 strings <10>
; and any alternative separators included in the extended itl1
; note that these separators are not cached as strings but as tokens produced by IntlTokenize
; jh, 1-8-91
; Notes on the loop:
; An itl1 has 5 fields that are declared as PACKED ARRAY[1..4] OF CHAR
; This field contain valid separators for the long date format
; This loop walks through those arrays, and converts valid separators into pascal
; strings; those strings are then converted to tokens and potentially cached in the subroutine TokenizeSepAndCache
; Register usage in the loop:
; a0-used to pass address of separator string to TokenizeSepAndCache
; a1-used briefly in the beginning to copy the date separator obtained previously from the itl0 into the cache
; a2-just like the rest of this code holds pointer to the cache
; a3-contains pointer to itl1
; a4-points at the ST arrays is
; d0-used to hold characters so they can be compared to null and space
; d1-used as a scratch register
; d3 - loop control for inner loop
; d4 - used to hold count of characters placed in temp4bytes, for that reason used to pass length of string to TokenizeSepAndCache
; d6 - loop control for outer loop
; d7 - holds available cache space
move.w #maxExtraSeps,d7 ;hold onto the maximum tokens allowed
clr.w CountAltSeps(a2) ;clear the count
; get the itl resource and stash it in parameter block
WITH TBlock
clr.l -(sp) ; return handle
move.w #4,-(sp) ; get itl4
_IUGetIntl
move.l (sp)+,itlResource(a2) ; store itl resource
ENDWITH
beq @FatalError ; couldn't get it give up
lea st0(a3),a4 ;load start of 4-byte char blocks
move.l #4,d6 ; 5 ST strings to look at
@startSTLoop
clr.l d4 ; clear our offset into temp4bytes
move.w #3,d3
lea temp4bytes(a6),a1 ;get our temp string address
@char4loop
move.b (a4)+,d0
beq.s @looptotop ; yes its null so just continue
cmp.b #32,d0 ; space ?
beq.s @looptotop ; yes don't copy it, but continue
move.b d0,(a1)+
addq #1,d4 ;increment our offset
@looptotop
dbra d3,@char4loop ;loop back
tst.w d4 ; if d4 > 0 we have some sort of string
beq.s @looptoTopST ; its 0 so look at the next st[x]
;if we got a string we want to turn it into a Token here and then stick the token into
; our cache
moveq #1,d5 ; only one token permitted
;now we need to tokenize this separator and check to see if it is in the cache
lea temp4bytes(a6),A0 ; load the address of the source text into A0 which is where the subroutine expects it
bsr TokenizeSep ; branch to subroutine
bne.s @looptoTopST ; something went wrong with that one
bsr CompareAndCache; check the token against the cache
ble.s @DoneWithItls ; if we have run out of cache, quit this
@looptoTopST
dbra d6,@startSTloop
;now we've copied the old st0-st4 separators, its time to check and see if we are
;dealing with an extended itl1 that might have some more separators added
cmp.w #extformatkey,localRtn(a3) ;is local routine $A89F ($A89F (unimplemented trap)
; is used here to flag this itl1 as an extended itl1)
bne.s @DoneWithItls ;nope, so branch around extra sep copying code
move.l extraSepsOffset(a3),d1 ;ok move the offset into d1
beq.s @DoneWithItls ;moved a 0 nothing is actually here so give it up
move.l extraSepsLength(a3),d0 ;how long is this array
ble.s @DoneWithItls ;negative or 0 means nothing is really here so get out
add.l a3,d1 ;add offset to ptr to itl1
move.l d1,a4 ;move result to a4
move.w (a4)+,d3 ;move the count of extra separators to d3,
subq #1,d3 ;for dbra
clr.l d4 ;clear d4 for safety
moveq #1,D5 ;D5 carrys number of token recs allowed into subroutine
@extraSepLoop
move.b (a4)+,d4 ;A0 points at the length byte, put that in d4 and increment a0 to point at actual string
move.l a4,a0 ;TokenizeSep expects source in a0
bsr TokenizeSep ; branch to subroutine
bne.s @extraSepLoop ; NE is tokenizer failed
bsr CompareAndCache ; tokenizer was OK so compare the token and potentially cache it
ble.s @DoneWithItls ; if we have run out of cache, quit this
add d4,a4 ; increment to next string
dbra d3,@extraSepLoop
@DoneWithItls
;;;;;;;;;;;;;;;;;;;;;;;;;;;;end addition
;jh, 1-8-91 <10>
;;;;;;;;;;;;;;;;;;;;;;;;;;end addition
ENDIF ; <10>
; Now unlock itl1
move.l Intl1(A6),a0
_HUnlock
IF NOT FixCacheAndStr2Date THEN ; <10><11>
; load the tokenizer parameter block for later
WITH TBlock
LEA theTokens(A6),A0 ; spaces for tokens in local frame
MOVE.L A0,tokenList(A2)
move.l #2,d0 ; less filling <1/4/88med>
MOVE.L d0,tokenLength(A2) ; no more than 2 tokens, please
CLR.L tokenCount(A2)
CLR.L DoString(A2) ; clear out DoString, DoAppend, DoAlphaNumeric, and DoNest
LEA leftDelims(A2),A0
MOVE.W #(decimalCode-leftDelims)/2,D0 ; load NilToken into leftDelims, rightDelims, leftComment, <1/4/88med>
@LOOP0
MOVE.W #NilToken,(A0)+ ; RightComment, EscapeCode & decimal code
DBRA D0,@LOOP0
; get the itl resource and stash it in parameter block <1/4/88med>
clr.l -(sp) ; return handle
move.w #4,-(sp) ; get itl4
_IUGetIntl
move.l (sp)+,itlResource(a2) ; store itl resource
; get the token corresponding to the time separator
LEA theTimeSep(A2),A0
MOVE.L A0,source(A2) ; inside With TBlock <1/4/88med>
move.l #2,d0 ; less filling <1/4/88med>
MOVE.L d0,sourceLength(A2) ; inside With TBlock <1/4/88med>
ENDWITH ; TBlock
; IntlTokenize(@TBlock): signedByte;
CLR.B -(SP)
PEA TBlock(A2)
_IntlTokenize ; tokenize text
TST.B (A7)+ ; check if ok
BEQ.S GotSeparators ; if so, handle the token
ELSE ; new way calls our subroutine <10>
LEA theTimeSep(A2),A0 ;get ready for tokenize sub routine
moveq #2,d5 ;we allow two tokens
move.l #2,d4 ; length into d4
bsr TokenizeSep ;
beq.s GotSeparators ; OK so back to the old code
@FatalError ;added label so I could branch here from new code <10>
ENDIF
MOVE.W #fatalDateTime,Result(A6) ; if not, exit procedure and return fatal error
BRA.S Exit
GotSeparators
MOVE.W theTokens(A6),theTimeSep(A2)
MOVE.W (theTokens + TokenRec.tokenRecSize)(A6),theDateSep(A2) ; store date and time sep tokens
MOVE.L #MaxTokens,TBlock.tokenLength(A2) ; no more than 2 tokens, please
Exit
MOVEM.L (SP)+,SaveRegs ; restore registers to their original value
move.w #parametersize, d0 ; for StdUnlink
bra StdUnlink ; standard exit
; little subroutine for code savings
; a4 is source pointer
; a1 is dest pointer
; d3 is byte length
CopyArray
move.l a1,d4 ; dest ptr <2/23/88med>
@LOOP MOVE.L A4,A0 ; move string from intl 1 rec <2.5>
MOVE.L d4,A1 ; into local frame <2/23/88med>
moveq #0,d0 ; Block2String wants a long! <2.5>
MOVE.B (A0)+,D0 ; with length from first byte of string
MOVEQ #1,D1 ; with no local frame
move.b altSpace(a6),d2 ; pass alt string <8/22/87med>
JSR Block2String
ADD.L #Str15,d4 ; get next string to transfer
ADD.w #Str15,A4 ; into next string in local frame <2.5>
DBRA D3,@LOOP
rts
IF FixCacheAndStr2Date THEN ; { <10><11>
;-----------------------------------------------------------------------------------
; TokenizeSep
; This subroutine is called to tokenize any separator we have found and store the
; resulting token in the datecache
; registers
; INPUT
; A0 - ptr to the source text
; A2 - which holds a ptr to the cache which contains a token paramblock
; D5 - number of tokens allowed
; D4 - length of source text
; TRASHED
; A1,D0,D1
; sets NE if Tokenizer fails
;-------------------------------------------------------------------------------------
TokenizeSep
; load the tokenizer parameter block for later
WITH TBlock
LEA theTokens(A6),A1 ; spaces for tokens in local frame
MOVE.L A1,tokenList(A2)
MOVE.L d5,tokenLength(A2) ; number of tokens allowed (shouldn't be more than 2)
CLR.L tokenCount(A2)
CLR.L DoString(A2) ; clear out DoString, DoAppend, DoAlphaNumeric, and DoNest
LEA leftDelims(A2),A1
MOVE.W #(decimalCode-leftDelims)/2,D0 ; load NilToken into leftDelims, rightDelims, leftComment
@LOOP0
MOVE.W #NilToken,(A1)+ ; RightComment, EscapeCode & decimal code
DBRA D0,@LOOP0
; get the address of the source from a1
MOVE.L A0,source(A2) ; inside With TBlock
MOVE.L d4,sourceLength(A2) ; d4 holds the length
ENDWITH ; TBlock
; IntlTokenize(@TBlock): signedByte;
CLR.B -(SP)
PEA TBlock(A2)
_IntlTokenize ; tokenize text
tst.b (sp)+ ; test the result and set the return bit
rts
;---------------------------------------------------------------------------------------------------
; CompareAndCache
; Once we've sucessfully tokenized one of the separators we use this routine to compare
; the new token against the stuff already in the cache
; if the new token is not there it is cached
;
; REGISTERS
; INPUT
; a2 - Ptr to cache
; d7.w - token slots available in cache
; TRASHED
; d0,d1,a1
; SETS cc AT EXIT BASED ON UPDATED d7.w
;-------------------------------------------------------------------------------------------------
CompareAndCache
WITH TBlock
; so we have a token type in theTokenRec
lea AltSeps(a2),a1 ; get destination in a1
move.w countAltSeps(a2),d0 ; number of tokens in d0
beq.s @storeToken ; none there so store it
subq #1,d0 ; for dbra
@tokenCompare ; otherwise compare token with whats in the cache
move.w (a1)+,d1
cmp.w theTokens(a6),d1 ;
beq.s @quitSubroutine ; we've already got this one so lets get on with it
; addq #2,a1 ; increment the pointer into the cache
dbra d0,@tokenCompare ; ne so look at the next one
@storeToken
move.w theTokens(A6),(a1) ; when loop completes a1 points at first empty slot
add.w #1,countAltSeps(a2) ; increment our count of separators
subq #1,d7 ; decrement our number of available token slots in cache
ENDWITH
@quitSubroutine
tst.w d7 ; set condition codes
rts
ENDIF ; } <10>
ENDWITH ; Cache
ENDWITH
ENDFUNC
;============================================================================
String2Date FUNC EXPORT
;
;function String2Date( textPtr: Ptr;
; textLen: longint;
; theCache: DateCachePtr;
; var lengthUsed: longint;
; var DateTime: LongDateRec): Integer;
;
; String2Date will look for a date in the text given it according to the international
; resource format. Using the Tokenizer routine it will look for a dayOfWeek (which will
; be a string), a month (either a string or a number) and a day and year (both numbers).
; If the month is a number, order is decided by the ShortDate format in INTL 0; otherwise
; String2Date uses a table. Note if only two numbers are found they are assumed to be day
; and month. If one number is found it is assumed to be a date. Missing fields are
; filled in by the current date and time
;
; Register Usage
;
; A2 - Work register D3 - loop control register
; A3 - Work register D4 - MonthFound
; A4 - Cache Addr D5 - ResultNum
; D6 - AbbrLen
; D7 - NumDelimsFound
;
SaveRegs REG D3-D7/A2-a4 ; removed a5 <8/22/87med>
DateFrame RECORD {A6link},decr
Result DS.W 1 ; offset to function result (integer)
paramBegin EQU *
textPtr DS.L 1 ; offset to Date2Time's paramters
textLen DS.L 1
theCache DS.L 1 ; @DateCacheRecord
RestofText DS.L 1 ; @Longint
DateTime DS.L 1 ; @LongDateRec
selector ds.l 1 ; added for resource <8/21/87med>
paramEnd EQU *
return DS.L 1
A6link DS.L 1
theTokens DS.B MaxTokens*TokenRec.tokenRecSize ; storage for tokens found by tokenizer
theDate DS LongDateRec ; date time rec
results DS.W 3 ; three temporary results
myDateOrder DS.W 1
DayFound DS.W 1
lastItemSep DS.W 1
lastToken DS.W 1
lastTokenAddr DS.L 1
lastExToken DS.W 1
dummyLongDate ds LongDateTime
stringStorage DS.B NumStrBytes
localsize EQU *
ENDR
WITH DateFrame
With Cache,LongDateField
parametersize EQU paramBegin - paramEnd ; size of parameter space on stack
LINK A6,#localsize ; Establish local frame and variables
MOVEM.L SaveRegs,-(SP) ; saved used registers
bsr DateTimeEntry ; initialize & call _IntlTokenize
; Note that DateTimeEntry also does the following:
; 1. moves theCache(a6) into a4
; 2. moves TheTokens(a6) into a3
; 3. sets result(a6)
; 4. clears D7,D6; sets D5.L = -1
; 5. after IntlTokenize, sets D3= number of tokens - 1
tst.w result(a6) ; entry failed?
bne DTComExit ; bail if so
; specific stuff
MOVEQ #-1,D4 ; initialize MonthFound to -1
CLR.W DayFound(A6)
LEA CurrentDate(A4),A1 ; source
LEA theDate(A6),A0 ;
MOVE.L (A1)+,(A0)+ ; era, year
MOVE.L (A1)+,(A0)+ ; month, day
MOVE.L (A1)+,(A0)+ ; hour, minute
move.w (a1)+,(a0)+ ; second
CLR.W (A0)+ ; clear out dayOfWeek. Will either be set by user or<6F>
; <20>be set in the course of the validity check of the date
MOVE.B theAbbrLen(A4),D6
WITH TokenRec
@TokenLoop
MOVE.W theToken(A3),D1 ; get token code from TokenRec record at (A3)
CMP.W #NonAlphNumToken,D1 ; is it a separator
BGE.S @FoundSeparator
SUB.W #WhiteSpace,D1 ; was it a white space?
BEQ @TokenLoopEnd ; ignore
SUBQ.W #(AlphaToken - WhiteSpace),D1 ; is it an alpha token?
IF FixCacheAndStr2Date THEN ; { <10><11>
beq @FoundAlpha ; <1-8-91, jh> changed to .w
SUBQ.W #(NumericToken - AlphaToken),D1 ; is it a number token?
BEQ @NumberToken ; <1-8-91, jh> changed to .w
SUBQ.W #(AltNumericToken - NumericToken),D1 ; is it a number token? <9/2/87med>
BEQ @NumberToken ; <1-8-91, jh> changed to .w <9/2/87med>
ELSE ; }{ <10>
beq.s @FoundAlpha
SUBQ.W #(NumericToken - AlphaToken),D1 ; is it a number token?
BEQ.S @NumberToken
SUBQ.W #(AltNumericToken - NumericToken),D1 ; is it a number token? <9/2/87med>
BEQ.S @NumberToken ; <9/2/87med>
ENDIF ; } <10>
BRA @TokenLoopEnd ; ignore any other characters
@FoundSeparator
TST.B D7 ; possible separator. Has a separator already been found?
BEQ.S @OneDelimFound ; no, so no error yet
OR.W #TooManySeps,Result(A6) ; yes, so now we have too many separators
@OneDelimFound
IF FixCacheAndStr2Date THEN ; { <10><11>
;***********************
;begin <1-8-91 jh> changes <10>
;here we compare if any of the separators in the itl1 equal this so-called
;separator we just found
;*********************
cmp.w theDateSep(a4),d1 ; start by comparing the DateSep (which is not cached with the other stuff) with the new token
beq.s @SeparatorFound ; found it
move.w countAltSeps(a4),d0 ; d0 will be our loop counter
beq.s @SeparatorFound ; hmm, nothing cached, but didn't match DateSep we could fail completely
; but I guess will just go with the old method of having everything match
subq #1,d0 ; set up for dbra
lea AltSeps(a4),a0 ; address of alternate separators
@compareSeps
cmp.w (a0)+,d1 ; compare cached tokens with new token
beq.s @SeparatorFound ; found it branch out of loop
dbra d0,@compareSeps ; decrement and branch
;no separator match. If any of the date is there we set up for an error and kind of continue
TST.w D5 ; is this after the first number loaded? (.w)
bmi.s @firstNonAlphaInvalid ; if first non-alphanumeric isn't a valid separator we return dateTimeInvalid
or.w #SepNotIntlSep+sepNotConsistent+extraneousStrings,Result(a6)
bra.s @SeparatorFound
@firstNonAlphaInvalid
OR.W #dateTimeInvalid,Result(A6) ; date not valid, return error
BRA DTComExit
@SeparatorFound
;;********************************************
; end <1-8-91, jh> changes <10>
;;********************************************
ENDIF ; } <10>
ADDQ.B #1,D7 ; record separator found
TST.w D5 ; is this after the first number loaded? (.w) <1/5/88med>
BMI @TokenLoopEnd ; if we have not reached a number yet go on
BNE.S @CheckDateSep ; if we loaded in a number then check consistency
MOVE.W D1,lastItemSep(A6) ; otherwise update lastItemSep with just found separator
BRA @TokenLoopEnd
@CheckDateSep
CMP.W lastItemSep(A6),D1 ; are they consistent
BEQ @TokenLoopEnd ; if yes, then go on
OR.W #SepNotIntlSep+sepNotConsistent,Result(A6) ; record warning
BRA @TokenLoopEnd
@NumberToken
; check for numbers separated only by white space <9/2/87med>
tst.w d7 ; got a separator?
bne.s @1 ; yes
tst.w d5 ; first number?
blt.s @1 ; yes, skip
bne.s @0 ; have 1 number
move.w #WhiteSpace,lastItemSep(A6) ; set separator
bra.s @1 ; continue
@0
cmp.w #WhiteSpace,lastItemSep(a6) ; same?
beq.s @1 ; yes, continue
or.w #SepNotIntlSep+sepNotConsistent,Result(A6) ; record warning
@1
; end of white space check <9/2/87med>
CLR.L D7 ; clear out past separators
CMP.W #2,D5 ; make sure that results array is not full
BGE @ExtrnsToken ; if full, record warning and search for final string (remove .s <2.5>)
; ValidLong(position,textLength): longint
MOVE.L stringPosition(A3),A0
JSR ValidLong ; get number in text at TokenRec.position
IF FixCacheAndStr2Date THEN ; <10><11>
bpl.s @numberOK ; branch around error if the number is a valid long
ori.w #dateTimeInvalid,result(a6) ;bad number so or in the dateTimeInvalid error
bra DTComExit ; and branch to our exit place
@numberOK
ELSE ; <10>
BMI DTComExit
ENDIF
bsr FixValue
bra @TokenRecognized ; get next token (remove .s <2.5>)
@FoundAlpha
CLR.L D7 ; clear out past separators
;; CMP.L length(A3),D6 ; is alpha token string length less than abbrLen? <2/23/88med>
;; BGT @ExtrnsToken ; if so, record warning and continue searching <2/23/88med>
; UprString(newTextPtr,AbbrLen) ; and make it uppercase for case insensitive search
MOVE.L stringPosition(A3),A2
ADDQ.L #1,A2
MOVE.L A2,A0
;; MOVE.L D6,D0
MOVE.L length(A3),D0 ; use real length
_UpperText ; _LwrString with uppercase function <3>
TST.W D4 ; d4<0: month not found, otherwise month num
BPL.S @SearchForDay ; <2.5>
; MatchString(newTextPtr,AbbrLen,@months,15,12): integer
CLR.W -(SP) ; attempt to find a day/month string which matches alpha token
MOVE.L A2,-(SP)
MOVE.W length+2(a3),-(SP) ; push length as integer <2/22/88med>
MOVE.W D6,-(SP) ; push minlen as integer <2/23/88med>
PEA theDays(A4)
MOVE.W #DayMonthLen,-(SP)
;; MOVE.W #NumMonths,-(SP)
MOVE.W #NumMonths+NumDays,-(SP) ; check for both at once <2/23/88med>
JSR MatchString
MOVE.W (SP)+,D2 ; save in D2
;; BLE.S @CheckForDay
BLE.S @ExtrnsToken ; checking both <2/23/88med>
; decide between days and months <2/23/88med>
sub.w #NumDays,d2 ; months? <2/23/88med>
ble.s @CheckForDay ; no, do days <2/23/88med>
; got a month
CMP.W #2,D5 ; is result array already full?
BGE.S @ExtrnsToken ; if so, then its not a needed token
;; CMP.W #NumMonths,D2 ; dump <2/23/88med>
;; BGT.S @CheckForDay ; got a month but out of range?, check if day <2/23/88med>
ADDQ.W #1,D5 ; is in range, result is not full and string
MOVE.W D5,D1 ; did not match as a day
ADD.W D1,D1 ; double index for integer array
LEA results(A6),A1 ; ResultNum:= ResultNum + 1
MOVE.W D2,(A1,D1.W) ; results[ResultNum]:= match result
MOVE.W D5,D4 ; MonthFound:= resultNum
BRA.S @TokenRecognized
; if day not found yet, we need to see if current string matches a day <2.5>
@SearchForDay
TST.B DayFound(a6) ; have we found one yet?
BNE.S @ExtrnsToken ; day already found, record warning
CLR.W -(SP) ; attempt to find a day string which matches alpha token
MOVE.L A2,-(SP)
MOVE.W length+2(a3),-(SP) ; push length as integer
MOVE.W D6,-(SP) ; push minlen as integer
PEA theDays(A4)
MOVE.W #DayMonthLen,-(SP)
MOVE.W #NumDays,-(SP) ; just check days this time
JSR MatchString
MOVE.W (SP)+,D2 ; save in D2
BLE.S @ExtrnsToken ; checking both
BRA.S @HaveDay
@CheckForDay
TST.B DayFound(a6) ; off of a6! <8/24/87med>
BNE.S @ExtrnsToken ; day already found, record warning
IF 0 THEN ; <2/23/88med>
; MatchString(newTextPtr,AbbrLen,@days,15,12): integer
CLR.W -(SP) ; also attempt to find a day string<6E>
; <20>which matches alpha token
MOVE.L A2,-(SP)
;; MOVE.W D6,-(SP) ; push length as integer
MOVE.W length(a3),-(SP) ; push length as integer <2/22/88med>
PEA theDays(A4)
MOVE.W #DayMonthLen,-(SP)
MOVE.W #NumDays,-(SP)
JSR MatchString
MOVE.W (SP)+,D2 ; save DResult in D2
BLE.S @ExtrnsToken ; neither matched a day or month, record warning
CMP.W #NumDays,D2
BGT.S @ExtrnsToken ; day out of range, record warning
ENDIF ; <2/23/88med>
add.w #NumDays,d2 ; restore days
@HaveDay
ST DayFound(A6) ; record that day was found <2.5>
MOVE.W D2,theDate.dayOfWeek(A6) ; otherwise, load dayOfWeek into date time record
TST.W D5 ; is dayOfWeek between two numbers (.w) <1/5/88med>
BMI.S @NoWarning ; if no number has been found yet, go on
OR.W #fieldOrderNotIntl,Result(A6) ; record warning
@NoWarning
BRA.S @TokenRecognized
@ExtrnsToken
TST.W lastExToken(A6) ; is this the first extraneous token found?
BPL.S @TokenLoopEnd ; no, go on
MOVE.W D3,lastExToken(A6) ; a string which we don't recognize has been found
BRA.S @TokenLoopEnd ; record warning and go on
@TokenRecognized
MOVE.W D3,lastToken(A6)
MOVE.L A3,lastTokenAddr(A6) ; save loop and token addr for later use
@TokenLoopEnd
ADD.L #tokenRecSize,A3 ; add size of TokenRec record to A3 to get next token
CMP.W #2,D5 ; if the result array full (.w) <1/5/88med>
SGE D0
AND.B DayFound(A6),D0 ; and dayofWeek string been found
DBNE D3,@TokenLoop ; then stop loop, otherwise go until all tokens are looked at
TST.W D5 ; test if ResultNum is negative
BPL.S @CheckRestTokens ; if not, go on and check the rest of the tokens
OR.W #dateTimeNotFound,Result(A6)
BRA DTComExit ; if no numbers were found, exit function
@CheckRestTokens
bsr CheckRest
;CheckIfSepIntl
LEA CvtTables,A0 ; load A0 with addr of convert tables
LEA results(A6),A1 ; load A1 with addr of results
move.b longDateOrder(a4),d2 ; assume long date order
TST.W D4
BPL.S CheckDateOrder ; if month string found, don't check sep but date order
move.b theDateOrder(a4),d2 ; is actually short-date
TST.W D5 ; first off, check if we needed separator
BEQ.S MonthNotFound ; if only one number, dont check, go on
MOVE.W lastItemSep(A6),D0 ; separators were used
CMP.W theDateSep(A4),D0 ; was the separator the date separator?
BEQ.S MonthNotFound ; if yes, go on
OR.W #SepNotIntlSep,Result(A6) ; no, return warning
BRA.S MonthNotFound
CheckDateOrder
OR.W #LongDateFound,Result(A6) ; month string found, long date
; now clear out warnings irrelevant to long date
AND.W #-(fieldOrderNotIntl + sepNotConsistent + SepNotIntlSep + 1),Result(A6)
TST.W D5 ; if Month was found than we must fix order to include it
BNE.S NotMonthOnly
MOVEQ #1,D5 ; but if month was all that was found than include date
MOVE.W #1,2(A1) ; as first day of month (result[1]:= 1). Year will be
; current year
NotMonthOnly
MOVE.W D4,D0 ; theDateOrder= CvtTable.monthReplace[FoundMonth,theDateOrder]
MULU.W #6,D0 ; fix theDateOrder so that month is where it was found
ADD.B D2,D0
MOVE.B monthReplace(A0,D0.W),d2 ; fix order
; MOVE.B monthReplace(A0,D0.W),theDateOrder(A4)
; CMP.B theDateOrder(A4),D0 ; is date order still intl?
; BEQ.S MonthNotFound ; if so, go on
; OR.W #fieldOrderNotIntl,Result(A6) ; otherwise record warning
WITH LongDateRec
MonthNotFound
CLR.L D1
LEA theDate(A6),A2 ; load theDate addr in A2
MOVE.W D5,D0 ; copy ResultNum
MULU.W #24,D0 ; 24 byte array. multiply index by 24
; MOVE.B theDateOrder(A4),D2
ADD.B D2,D2
ADD.B D2,D2 ; four byte array. multiply index by 4
ADD.B D2,D0
MOVE.B (reorder + theYear)(A0,D0.W),D1 ; get CvtTables.reorder[resultNum,theDateOrder].year
BMI.S YearNotDefined ; if less than zero go to month
ADD.W D1,D1
MOVE.W (A1,D1.W),theDate.year(a6) ; theDate.year:= result[year]
YearNotDefined
MOVE.B (reorder + theMonth)(A0,D0.W),D1 ; get CvtTables.reorder[resultNum,theDateOrder].month
BMI.S MonthNotDefined ; if less than zero go to day
ADD.W D1,D1
MOVE.W (A1,D1.W),theDate.month(a6) ; theDate.month:= result[month]
MonthNotDefined
MOVE.B (reorder + theDay)(A0,D0.W),D1 ; get CvtTables.reorder[resultNum,theDateOrder].day
ADD.W D1,D1 ; day is always defined, so load it in
MOVE.W (A1,D1.W),theDate.day(a6) ; theDate.day:= result[day]
CMP.W #1,D5 ; were three numbers found?
BLE.S ValidateDate ; no, so don't bother adjusting year
MOVE.W BaseDate.year(A4),D0
move.w theDate.year(a6),d1 ; temp values
CMP.W d1,D0 ; is starting year of Mac calender more than current year
BLE.S ValidateDate ; if not than year is Ok and see if everthing else is valid
; CMP.W #10,d1 ; is year from input less than 10?
; BGE.S Adjust100 ; if not, adjust century
; MOVE.W #10,D0 ; yes fill in current decade, century and millenia
; BRA.S AdjustYear ; do adjustment
;Adjust100
CMP.W #100, d1 ; is year from input less than 100?
BGE.S Adjust1000 ; if not adjust millenia
lowerYear equ 10
upperYear equ 100-lowerYear
;<9/27/88ldc> Added code to determine how to interpret input years less than 100
; If currentdate.year >= upperYear and theDate.year <= lowerYear then
; theDate.year goes to next century
; else if currentDate.year <= lowerYear and theDate.year >= upperYear then
; theDate.year goes to previous century
; else theDate.year belongs in the current century
move.w CurrentDate.year(a4), d0 ; currentYear mod 100 <= lowerYear?
divu.w #100, d0 ; currentYear mod 100 >= upperYear
mulu.w #100, d0 ;
move.w d0, d1 ; copy
move.w CurrentDate.year(a4), d0 ;
sub.w d1, d0 ; d0 := currentdate.year mod 100
move.w theDate.year(a6), d1 ;
cmp.w #upperYear, d0 ; CurrentDate.year mod 100 >= upper year bound?
bls.s @checkLowerYear ; no, check less than lower
cmp.w #lowerYear, d1 ; theDate.year <= 10?
bgt.s Adjust100 ; no, so assume in same century
add.w #100, theDate.year(a6) ; yes, so put this year in the next century
bra.s Adjust100
@checkLowerYear
cmp.w #lowerYear, d0 ; current year mod 100 <= lowerYear ?
bgt.s Adjust100 ; no, no need to adjust
cmp.w #upperYear, d1 ; input year >= upperYear?
bls.s Adjust100 ; no, just adjust century
sub.w #100, theDate.year(a6) ; adjust input date and fall through
Adjust100
MOVE.W #100,D0 ; yes fill in current century and millenia
BRA.S AdjustYear
Adjust1000
CMP.W #1000,d1 ; is year from input less than 1000?
BGE.S ValidateDate ; if not, than there is nothing we can do about it
MOVE.W #1000,D0 ; put in current millenia
AdjustYear
MOVE.W CurrentDate.year(A4), D1 ; theDate.year:= (CurrentDate.year div D0)*D0 + theDate.year
DIVU.W D0,D1
MULU.W D0,D1
ADD.W D1,theDate.year(a6)
ValidateDate
move.l #yearMask++monthMask++dayMask,d0 ; fields to test <1/11/88med>
tst.w theDate.dayOfWeek(a6) ; if dayofweek was not gotten from user then <1/11/88med>
beq.s @0 ; <1/11/88med>
or.l #dayOfWeekMask,d0 ; add checking this field <1/11/88med>
@0
bsr CheckValid ; check the date <1/11/88med>
blt.s FoundDate ; yes, exit <1/11/88med>
ENDWITH ; LongDateRec
OR.W #dateTimeInvalid,Result(A6) ; date not valid, return error
BRA.S DTComExit
FoundDate
MOVE.L DateTime(A6),A1
LEA theDate(A6),A0
MOVE.W LongDateRec.dayOfWeek(A0),LongDateRec.dayOfWeek(A1)
MOVE.L (A0)+,(A1)+ ; era, year
MOVE.L (A0)+,(A1)+ ; month, day; load date fields into DateTime parameter
MOVE.L RestofText(A6),A0 ; return last byte of text used
;======================================================================
DTComFinish
MOVE.L lastTokenAddr(A6),A1
MOVE.L TokenRec.position(A1),(A0)
MOVE.L textPtr(A6),D0
SUB.L TokenRec.length(A1),D0
SUB.L D0,(A0) ; restofText:= lastToken.position + lastToken.length
; - textPtr
DTComExit
MOVEM.L (SP)+,SaveRegs ; restore registers to their original value
UNLK A6 ; get rid of local frame and variables
MOVE.L (SP)+,A0 ; pull return addr
ADD.L #parametersize,SP ; destroy parameters on stack
JMP (A0)
;======================================================================
CheckRest
MOVE.L lastTokenAddr(A6),A3
ADD.L #tokenRecSize,A3 ; get addr of token after last used token
MOVE.W lastToken(A6),D3 ; restore loop variable
TST.W lastExToken(A6) ; any extranous tokens found?
BMI.S @NoExTokens ; if none anywhere, go on
CMP.W lastExToken(A6),D3 ; was it after the last token to be recognized
BGT.S @NoExTokens ; if so, go on
OR.W #extraneousStrings,Result(A6) ; no, extraneous token was found
@NoExTokens
MOVEQ.L #0,D1 ; force zero flag on
BRA.S @LoopEnd
@CheckToken
MOVE.W theToken(A3),D1 ; get token code from TokenRec record at (A3)
SUBQ.W #WhiteSpace,D1 ; was it a white space?
ADD.L #tokenRecSize,A3
@LoopEnd
DBNE D3,@CheckToken ; ignore white spaces
ENDWITH ; TokenRec
TST.B D3
BMI.S @0 ; if all tokens were checked, branch
OR.W #LeftOverChars,Result(A6) ; otherwise report left overs
@0
rts
;======================================================================
FixValue
ADDQ.W #1,D5 ; resultNum:= resultNum + 1;
MOVE.W D5,D1
ADD.W D1,D1 ; integer array, so double index
LEA results(A6),A1
MOVE.W D0,(A1,D1.W) ; results[resultNum]:= ValidLong(position,length)
rts
;======================================================================
DateTimeEntry
;
; Side effects (comment added <1.9>)
; Note that if textLen(a6) <20> 0 then nothing is set up except result(a6)
;
; 1. moves theCache(a6) into a4
; 2. moves TheTokens(a6) into a3
; 3. sets result(a6)
; 4. clears D7,D6; sets D5.L = -1
; 5. after IntlTokenize, sets d3= number of tokens - 1
; first check degenerate case (len = 0) <8/24/87med>
move.w #dateTimeNotFound,result(a6) ; assume bad
tst.l textLen(A6) ; bad case?
ble.s DateEntryExit ; yes, take off
; continue with initialization <8/24/87med>
CLR.W Result(A6) ; clear function result
MOVE.L theCache(A6),A4
CLR.L D7 ; clear out any delims
CLR.L D6
MOVEQ #-1,D5 ; initialize ResultNum to -1
CLR.W lastItemSep(A6) ; clear out separator found in input
CLR.W lastToken(A6)
MOVE.W #-1,lastExToken(A6) ; put -1 in lastExToken
MOVE.L RestOfText(A6),A0
CLR.L (A0) ; default RestOfText:= 0;
LEA results(A6),A0
CLR.L (A0)+
CLR.W (A0)+ ; Clear out result array
WITH TBLock
LEA theTokens(A6),A0 ; spaces for tokens in local frame
MOVE.L A0,tokenList(A4)
ST DoString(A4)
LEA stringStorage(A6),A0
MOVE.L A0,stringList(A4)
MOVE.L #NumStrBytes,stringLength(A4)
MOVE.L textPtr(A6),source(A4) ; tokenize starting at text given routine
MOVE.L textLen(A6),sourceLength(A4) ; for length given texT
LEA TheTokens(A6),A3 ; put address of the tokens in A3
ENDWITH ; TBlock
; IntlTokenize(@Cache^.TBlock): signedByte;
CLR.B -(SP)
PEA TBlock(A4)
_IntlTokenize ; tokenize text
TST.B (A7)+ ; check if ok
BEQ.S @HandleTokens ; if so, handle the tokens
OR.W #fatalDateTime,Result(A6) ; if not, exit procedure and return fatal error
bra.s DateEntryExit
@HandleTokens
MOVE.L TBlock.tokenCount(A4),D3 ; get number of tokens
SUBQ #1,D3
clr.w result(a6) ; show ok
DateEntryExit
rts
;======================================================================
CheckValid
move.w #0,-(sp) ; allocate return
pea theDate(a6) ; pass the date
move.l d0,-(sp) ; fields to test
pea dummyLongDate(a6) ; toss result
_ValidDate ; check it
tst.w (sp)+ ; ok? (lt?)
rts
;======================================================================
WITH DateOrders
CvtTables
; first array is a 0..2 x 0..6 array, for recasting type when month is inserted
; mdy dmy ymd myd dym ydm
DC.B mdy, mdy, myd, myd, mdy, myd ; month is 0
DC.B dmy, dmy, ymd, ymd, dmy, ymd ; month is 1
DC.B dym, dym, ydm, ydm, dym, ydm ; month is 2
; second array is a triple array, first by number of elements
; each item is y,m,d; with -1 for no setting
; extra 0 is because pascal pads subarrays to even boundary
; mdy dmy ymd myd dym ydm
DC.B -1,-1,0,0, -1,-1,0,0, -1,-1,0,0, -1,-1,0,0, -1,-1,0,0, -1,-1,0,0 ; 1 element
DC.B -1, 0,1,0, -1, 1,0,0, -1, 0,1,0, -1, 0,1,0, -1, 1,0,0, -1, 1,0,0 ; 2 elements
DC.B 2, 0,1,0, 2, 1,0,0, 0, 1,2,0, 1, 0,2,0, 1, 2,0,0, 0, 2,1,0 ; 3 elements
;============================================================================
export String2Time
String2Time
;
;function String2Time( textPtr: Ptr;
; textLen: longint;
; theCache: CachePtr;
; var lengthUsed: longint;
; var DateTime: LongDateRec): integer;
;
; String2Time will look for a time in the text given it according to the international resource format. It will
; look for 1 to 3 numbers in the text using the IntlTokenize routine and assign them to the hour minute and second
; respectively. If it finds the evestr (in the INTL 0 resource) in the text 12 will be added to the hour.
;
; Register Usage
;
; A2 - Work register D3 - loop control register
; A3 - Work register D4 - PMFound
; A4 - CacheAddr D5 - ResultNum
; D6 - TimeSep
; D7 - NumDelimsFound
;
LINK A6,#localsize ; Establish local frame and variables
MOVEM.L SaveRegs,-(SP) ; saved used registers
bsr DateTimeEntry
tst.w result(a6) ; entry failed?
bne DTComExit ; bail if so
; specific stuff
CLR.W D4 ; assume PM not found
LEA theDate(A6),A0
LEA BaseDate(A4),A1
MOVE.w LongDateRec.dayOfWeek(A1),LongDateRec.dayOfWeek(A0)
MOVE.L (A1)+,(A0)+ ; era, year
MOVE.L (A1)+,(A0)+ ; hour, minute
WITH TokenRec
@TokenLoop
MOVE.W theToken(A3),D1 ; get token code from TokenRec record at (A3)
CMP.W #NonAlphNumToken,D1 ; is it a separator
BGE.S @FoundSeparator
sub.w #WhiteSpace,D1 ; was it a white space?
beq @TokenLoopEnd ; ignore
SUBQ.W #(AlphaToken - WhiteSpace),D1 ; is it an alpha token?
BEQ @FoundAlpha
SUBQ.W #(NumericToken - AlphaToken),D1 ; is it a number token?
BEQ.S @NumberToken
SUBQ.W #(AltNumericToken - NumericToken),D1 ; is it a number token? <9/2/87med>
BEQ.S @NumberToken ; <9/2/87med>
BRA @TokenLoopEnd ; ignore any other characters
@FoundSeparator
TST.B D7 ; possible separator. Has a separator already been found?
BEQ.S @OneDelimFound ; no, so no error yet
OR.W #TooManySeps,Result(A6) ; yes, so now we have too many separators
@OneDelimFound
ADDQ.B #1,D7 ; record separator found
TST.w D5 ; is this after the first number loaded?
BEQ.S @GetTimeSep ; one number has been loaded in, so get separator
BPL.S @CheckTimeSep ; if we loaded in a number then check consistentcy
OR.W #extraneousStrings,Result(A6) ; shouldn't be anything before time, record warning
BRA @TokenLoopEnd
@GetTimeSep
MOVE.W D1,lastItemSep(A6) ; otherwise update lastItemSep with just found separator
BRA @TokenLoopEnd
@CheckTimeSep
CMP.W lastItemSep(A6),D1 ; are they consistent
BEQ @TokenLoopEnd ; if yes, than go on
OR.W #SepNotIntlSep+sepNotConsistent,Result(A6) ; record warning
BRA @TokenLoopEnd
@NumberToken
; check for numbers separated only by white space <9/2/87med>
tst.w d7 ; got a separator?
bne.s @1 ; yes
tst.w d5 ; first number?
blt.s @1 ; yes, skip
bne.s @0 ; have 1 number
move.w #WhiteSpace,lastItemSep(A6) ; set separator
bra.s @1 ; continue
@0
cmp.w #WhiteSpace,lastItemSep(a6) ; same?
beq.s @1 ; yes, continue
or.w #SepNotIntlSep+sepNotConsistent,Result(A6) ; record warning
@1
; end of white space check <9/2/87med>
CLR.L D7 ; clear out past separators
CMP.w #2,D5 ; make sure that results array is not full
BGE.s @ExtrnsToken ; if full, record warning and search for final string
; ValidLong(position,textLength): longint
MOVE.L stringPosition(A3),A0
JSR ValidLong ; get number in text at TokenRec.position
BMI DTComExit
TST.B D6 ; have we found a number after finding AM, PM or 24 hr str?
BEQ.S @RightFieldOrder
OR.W #fieldOrderNotIntl,Result(A6) ; if so, record a warning but go on
@RightFieldOrder
bsr FixValue
BRA.s @TokenRecognized ; get next token
@FoundAlpha
TST.B D6
BNE.S @ExtrnsToken ; if time strings have been found record warning
; UprString(newTextPtr,AbbrLen) ; and make it uppercase for case insensitive search
MOVE.L stringPosition(A3),A2
ADDQ.L #1,A2
MOVE.L A2,A0
MOVE.L length(A3),D0
_UpperText ; _LwrString with uppercase function <3>
; change to use MatchString <2/22/88med>
; MatchString(newTextPtr,AbbrLen,@months,15,12): integer
CLR.W -(SP) ; attempt to find a time string which matches alpha token
MOVE.L A2,-(SP)
MOVE.W length+2(a3),-(SP) ; push length as integer
MOVE.W #2,-(SP) ; push minlen as integer <2/23/88med>
PEA theTimeStrings(a4) ; array
MOVE.W #TimeLen,-(SP)
MOVE.W #NumTimeStrings,-(SP)
JSR MatchString
MOVE.W (SP)+,D2 ; save in D2
BLE.S @DiscardAlpha ; not found, exit gracefully
cmp.w #2,d2 ; morning?
bgt.s @GotRightString ; 24hour, exit
st D4 ; save comparison of alpha token and evening string (-1 if =)
blt.s @GotRightString ; done if eve
neg.b d4 ; +1 for AM
@GotRightString
st D6 ; record whether or not time string has been found
TST.B D7 ; were any separators found. Should be none before time str
BEQ.S @DiscardAlpha ; if so, go on
OR.W #TooManySeps,Result(A6) ; otherwise record error
@DiscardAlpha
CLR.L D7 ; clear out any previous separators found
TST.B D6 ; was a string actually found that we recognize
BNE.S @TokenRecognized ; if so, record token
@ExtrnsToken
TST.W lastExToken(A6) ; is this the first extraneous token found?
BPL.S @TokenLoopEnd ; no, go on
MOVE.W D3,lastExToken(A6) ; a string which we don't recognize has been found
BRA.S @TokenLoopEnd ; record warning and go on
@TokenRecognized
MOVE.W D3,lastToken(A6)
MOVE.L A3,lastTokenAddr(A6) ; put in here for later use
@TokenLoopEnd
ADD.L #tokenRecSize,A3 ; add size of TokenRec record to A3 to get next token
; CMP.B #2,D5 ; if the result array full
; SGE D0
; OR.B D6,D0 ; and time string been found <8/24/87med>
tst.b d6 ; time string been found <8/25/87med>
DBNE D3,@TokenLoop ; then stop loop, otherwise go until all tokens are looked at
TST.w D5 ; test if ResultNum is negative
BPL.s @CheckRestTokens ; if not, go on and check the resot of the tokens
OR.W #dateTimeNotFound,Result(A6)
BRA DTComExit ; if no numbers were found, exit function
@CheckRestTokens
bsr CheckRest
;CheckIfSepIntl
TST.w D5 ; first off, check if we needed separator
BEQ.S CheckPMString ; if only one number, dont check, go on
MOVE.W lastItemSep(A6),D0 ; separators were used
CMP.W theTimeSep(A4),D0 ; was the separator the time separator?
BEQ.S CheckPMString ; if yes, go on
OR.W #SepNotIntlSep,Result(A6) ; no, return warning
CheckPMString
move.l #NoonHr,d0 ; for testing <8/25/87med>
TST.B D4 ; was PM/AM string found?
BEQ.S SaveTime ; no
blt.s @FixPM
@FixAM
sub.w results(a6),d0 ; hour >= 12? <8/22/87med>
bgt.s SaveTime ; yes, skip add <8/22/87med>
neg d0 ; 12 => 0, 13 => 1...
move.w d0,results(a6) ; set result
bra.s SaveTime ; continue
@FixPM
cmp.w results(a6),d0 ; d0 >=? <8/22/87med>
ble.s SaveTime ; yes, skip add <8/22/87med>
ADD.W d0,results(A6) ; 11- => x+12
SaveTime
cmp.w #24,results(A6) ; catch degenerate case
bne.s @1 ; no, skip
clr.w results(a6) ; set 24:xx:xx to 00:xx:xx
@1
LEA results(A6),A2
LEA theDate.hour(A6),A3
MOVE.L (A2)+,(A3)+ ; load hour and minute into theDate
MOVE.W (A2)+,(A3)+ ; load secs into theDate. Note any numbers not found are 0
move.l #hourMask++minuteMask++secondMask,d0
bsr CheckValid ; valid?
blt.s FoundTime ; yes, exit
OR.W #dateTimeInvalid,Result(A6) ; date not valid, return error
BRA DTComExit
FoundTime
MOVE.L DateTime(A6),A1
ADDQ.L #LongDateRec.hour,A1
LEA theDate.hour(A6),A0
MOVE.L (A0)+,(A1)+
MOVE.W (A0)+,(A1)+
MOVE.L RestofText(A6),A0
bra DTComFinish
ENDWITH ;DateOrders
ENDWITH
ENDFUNC
END
Reference in New Issue Copy Permalink