Macintosh-SW/supermario
1
0
Fork 0
mirror of https://github.com/elliotnunn/supermario.git synced 2024-12-01 18:50:30 +00:00
Code Issues Projects Releases Wiki Activity
7627be1e6d
supermario/base/SuperMarioProj.1994-02-09/Toolbox/ScriptMgr/InternationalPACK.a

3553 lines
137 KiB
Plaintext
Raw Normal View History

Bring in sources, and document
2019-06-29 15:17:50 +00:00
;
; File: InternationalPACK.a
;
; Contains: Date, time, and sorting routines for language-independent programs. These routines
; help maintain international parameter blocks as resources of type 'itl_' where the
; last character is a digit (0 through 4). The date and time routines translate the
; long integer "seconds" count into strings whose formats are specified in the
; parameter blocks. The magnitude string comparison routine for Roman languages was
; designed and implemented by Dr. J. Coonen. Later modifications allow the parameter
; blocks to change the sorting algorithm for non-Roman languages. For 7.0, the type
; select utilities (for keyboard navigation) are added here.
;
; Written by: AJH Andy Hertzfeld
; JTC Jerome Coonen
; MED Mark Davis
; JDT Joe Ternasky
; DRS daan strebe
; LDC Lee Collins
; PKE Peter Edberg
; ngk Nick Kledzik
; …and a cast of thousands
;
; Copyright: © 1983-1992 by Apple Computer, Inc., all rights reserved.
;
; Change History (most recent first):
;
; <46> 10/16/92 PKE Move itl1 extension offsets into Packages.a. Include Packages.a
; instead of PackMacs.a.
; <45> 6/2/92 PKE #1028868 <smb>: Really fix problem of crashing when resource is
; not loaded: the problem was not ResLoad being false, but GetIntl
; not handling low-memory failure to load resource when GetIntl
; was called internally (with ResLoad always TRUE). Now GetIntl
; always returns NIL handle if a resource fails to load. Also
; revert to making direct calls to GetIntl pay attention to
; ResLoad (as in <43>), but handle ResLoad as a byte.
; <44> 6/1/92 DTY #1028868 <FM>: The previous change only turns on ResLoad (if
; it’s false) for calls to GetIntl made internally. This isn’t
; enough. There are some cases where an external call to GetIntl
; will fail and crash because ResLoad is false, and it’s not
; turned on before getting an ‘itl ’ resource. Get rid of the
; check to see if the call to GetIntl is made from an internal
; call, and always turn on ResLoad before getting an ‘itl ’
; resource.
; <43> 5/14/92 PKE #1028868,<bbm>: Fix crash in internal call to GetIntl (e.g. from
; MagString) if ResLoad false and itl resource purged. Fix
; GetItlTable to handle ResLoad false by returning nil handle.
; <42> 4/22/92 JSM Get rid of useNewItlCache (which was never used) and
; FixNonRomanTypeSelect (which was only used once) conditionals.
; <41> 4/22/92 PKE #1026767: (no reviewer before check-in: it is late at night,
; nobody is around, I am going out of town early tomorrow morning,
; and I have to have this in for the a7 build) Stop caching
; handles to itl2/itl4 resources, since itl2/itl4 resources can be
; changed under us; use cached IDs instead. Also, in GetIntl move
; DoneIntl and FailIntl above UnlockIt call to make sure we always
; unlock (since we may have gotten locked before making an
; internal call to GetIntl); this is a continuation of fix <40>.
; <40> 4/17/92 PKE #1027387,<DTY>: Fix <35> below - removing the check for
; emItlDirectGetIntl at the end of GetIntl caused the PACK to
; become unlocked prematurely (this is a bug in 7up too). However,
; the emItlDirectGetIntl scheme was brain-dead anyway. Instead, do
; locking/unlocking a better way: bracket all internal calls to
; other externally-callable PACK 6 routines with an
; increment/decrement of emItlDontUnlockYet (renamed from
; emItlDirectGetIntl), and have UnlockIt not unlock if
; emItlDontUnlockYet is non-zero. Also, add missing calls to
; LockIt before LoadResource in MagString, DatePString, and
; TimePString, and add missing call to UnlockIt in QuickExit from
; MagString (this last missing UnlockIt was responsible for PACK 6
; remaining locked in many cases, which was what 7up was trying to
; fix).
; <39> 4/15/92 PKE #1023781,<dty>: Fix <36> below - need to use it0 or itl1 handle,
; as appropriate; itl2 has nothing to do with dates or times!!
; Also test if intlParam handle is unloaded; if so, load it.
; <38> 4/3/92 PKE #1015311,<smb>: Fix <37> below - If you change IntlMaxID, you
; also need to add a 0 entry in CacheOffset.
; <37> 4/2/92 DTY #1015311,<SLS>: Change IntlMaxID to 5 now that we have 'itl5'
; resources.
; <36> 4/1/92 DTY #1025710,<pvh>: IUDatePString and IUTimePString will crash if
; intlParam is nil. Add checks for nil to these two routines. If
; intlParam is nil, get the default 'itl2' resource.
; <35> 1/7/92 DTY Checking emItlDirectGetIntl before calling UnlockIt causes the
; PACK to not get unlocked sometimes. Take out this check. (This
; was done as a patch by 7 Up.)
; <34> 10/16/91 PKE For Cube-E (and Bruges): Increment PACK 6 version number.
; <33> 10/8/91 PKE For Cube-E (and Bruges): Fix IUScriptOrder and IUTextOrder (by
; fixing internal routine intScriptCodeToSort) to ignore FontForce
; flag, and to sort non-enabled scripts last. Clean up some more
; conditionals.
; <32> 9/20/91 PKE Remove CubeE conditionals, since the new plan (according to
; Darin) is that everything for Cube-E goes in without
; conditionals. While I'm at it, remove some ">=$700" conditionals
; and pre-7.0-only code.
; <31> 9/15/91 PKE smb,#85675: IUSetIntl was causing crashes. It assumed that
; _HomeResFile returned the actual refNum (not 0) for the system
; file, so it failed to remove an ‘INTL’ resource before adding
; another one with the same ID. Also, it was setting the
; resChanged attribute with _SetResAttrs instead of calling
; ChangedResource.
; <30> 3/1/91 ngk pke,#77804: use secondary difference when differentiating
; between better possibilities for type selecting.
; <29> 2/21/91 PKE gbm,#82260: TypeSelect does not work if system script is
; non-Roman but Roman name is typed.
; <28> 2/21/91 ngk dho: fix bug introduced by change <27>
; <27> 2/11/91 ngk dho, #80563: Fix TypeSelect wrap around bug.
; <26> 1/10/91 PKE (fjs) Fix bugs in GetIntl that can result in a call to
; UseResFile with an invalid refNum, and a call to HLock with an
; invalid handle. Make MagPString and MagIdPString load handle
; passed to them if necessary.
; <25> 12/19/90 PKE (VL) Have app caches ignore SetScript changes to itl2 or itl4
; ID, since IUClearCache eliminates the need for this. This
; isolates each application’s cache from the effects of other
; apps. Add private ClearCacheSys routine. Protect against bad
; selectors.
; <24> 12/14/90 PKE (DC) Use itl1 extension, if present, to make IUDateString,
; IUDatePString, and IULDateString produce correct abbreviated
; date and handle calendars with >7 days or >12 months (So that
; localizers can fix bug #49924 correctly). Force IUGetIntl to
; load sys cache from System file, and make sys cache relatively
; immune to a SetScript change to itl2 or itl4 ID.
; <23> 10/21/90 gbm (with dba) Fix an assembly warning
; <22> 9/14/90 BG Removed <13>. 040s are behaving more reliably now.
; <21> 9/10/90 PKE Merge common code from TextOrder and TypeSelectCompare into
; GetScriptItl for code sharing; change it to take its ScriptCode
; and sysFlag parameters on the stack; make it accessible through
; dispatcher for internal use.
; <20> 9/6/90 PKE Change TypeSelectCompare to use only primary sorting order, and
; to use correct way of getting itl2 handles.
; <19> 8/29/90 PKE Let IUGetItlTable provide whiteSpaceList too.
; <18> 8/26/90 PKE NEEDED FOR SIXPACK: Fixed a register trashing bug introduced in
; <16> in the internal routine GetLArray. If IULDateString or
; IULTimeString were passed an intlParam value of 0, this bug
; would cause GetIntl to look for an invalid resource type;
; GetIntl wouldn’t find it, and these procedures would bail,
; returning null strings.
; <17> 8/24/90 PKE Let IUGetItlTable provide unTokenTable too.
; <16> 8/1/90 PKE NEEDED FOR SIXPACK: Change IUGetIntl to do better error
; reporting. Change all Pack6 routines that make internal GetIntl
; calls to actually check if there was an error (what a concept).
; This fixes crashes that occurred in low-memory situations,
; including BRC #70045 (string compare routines were crashing in
; two-byte systems).
; <15> 7/30/90 gbm axe branch to next instruction
; <14> 7/25/90 PKE Modify so that application itl cache is part of new
; application-specific script globals. Remove code in ClearCache
; and GetIntl that creates the cache; app-specific script globals
; are now allocated by InitScriptApp.
; <13> 7/17/90 BG Added EclipseNOPs for flakey 040s.
; <12> 7/16/90 PKE Use new names for fields in ExpandMemRec: emItlCache2Ptr is now
; emItlSysCachePtr, emItlAppCachePtr is now emItlAppCacheHndl.
; Renamed Cache2Rec to NewItlCacheRec.
; <11> 7/5/90 PKE Fixed bugs in new cache scheme (see <10>): register use bug was
; wiping out the script code used for finding the right cache
; entry, so we didn’t find a match and defaulted to system script;
; save app cache handle (!); better handling of BlockMove errs,
; etc. Changed IUClearCache to fit more nicely into this scheme.
; Reworked itl2 handle fetching for IUTextOrder and IUTextOrderSys
; to use new caching via GetScriptItl entry point; ensures that
; IUTextOrderSys uses system sorting and not app sorting.
; <10> 7/2/90 PKE Redo GetIntl’s itl2/itl4 caching to use emItlAppCachePtr so
; Process Mgr can swap cache for each application. Put in
; framework for private IUTextOrderSys routine - a new entry point
; for IUTextOrder that uses the system’s cached itl2/itl4 handles
; instead of the current application’s cached handles.
; <9> 5/8/90 PKE Changed script and language sorting routines to use new
; emScriptMap and emLangMap tables, which are set up from ‘itlm’
; resource. Use new emItlCache2 for improved caching of ‘itl2’ and
; ‘itl4’ resource handles. Changed ClearCache to work with new
; cache.
; <8> 5/3/90 ngk Fixed bug in TypeSelectNewKey of script not being set in tsr.
; <7> 5/2/90 ngk Added private TypeSelect (a.k.a. keyboard navigation) routines.
; <6> 4/10/90 PKE Conditionalized <2.3> and <3> so object compares work against
; official 6.0.x sources. Used smgrSys7Extensions instead of
; SysVers where appropriate.
; <5> 3/21/90 PKE Added private IUMagWPString interface.
; <4> 3/2/90 PKE Use new name IUNSortFrame for the extended IUSortFrame in System
; 7.0; use new name nItl4Rec for the extended Itl4Rec (used in
; GetItlTable). Updated version number. Extended langScriptTable
; to accomodate all current language codes (need to put this in a
; resource soon!!). Fixed up header and tabs.
; <3> 1/4/90 dba get rid of assembly warnings by using ALIGN statement and using
; low-memory for an empty string
; <2> 12/19/89 EMT (with dba) Cleared itl2Handle in MagWString, which is an
; undocumented call used by Microsoft.
; <1> 12/18/89 CCH Adding for the first time into BBS.
; (BBS versions above, EASE versions below)
; <2.3> 11/17/89 dba got rid of checks for 64K ROMs
; <2.2> 10/31/89 PKE Lock package before GetResource calls in new routines
; (IUTextOrder, IUGetItlTable)!! Also, in LockIt and UnlockIt,
; get handle directly from AppPacks instead of using
; RecoverHandle (takes care of problems when Pack6 is called from
; MultiFinder).
; <2.1> 10/5/89 PKE Clear ignChar flag in FetchChar; fixes bug (BRC #54591) with
; sorting of ignorable characters.
; <2.0> 9/22/89 PKE Added GetItlTable routine. Implemented the remaining special
; negative ScriptCodes and LangCode values for ScriptOrder,
; LangOrder, and TextOrder.
; <1.9> 9/18/89 PKE Rearrange parameters for IUTextOrder; use different lang code
; to signal mapping to default lang for script.
; <1.8> 9/15/89 PKE Add 7.0 functions ClearCache, MagPString, MagIdPString,
; ScriptOrder, LangOrder, and TextOrder.
; <1.7> 8/26/89 PKE Delete load 'nEqu.d'.
; <1.6> 3/10/89 PKE Add sorting support for 'ß and extended Mac character set (incl.
; fi,fl). Should revise to get project & vernier info from the same
; table at the same time.
; <1.5> 2/22/89 PKE Change GetIntl to determine the script itself if the
; smgrIntlForce flag is true, instead of calling IntlScript to do
; this. This makes GetIntl independent of the a5 world when
; smgrIntlForce is true, which is most of the time. Need to
; include ScriptEqu.priv for this.
; <1.4> 2/21/89 PKE Fix up includes: always include 'inc.sum.a'.
; <1.3> 2/14/89 PKE Updated to use MPW 3.0 final ScriptEqu.a equate names
; <1.2> 1/17/89 CCH Changed LongMonth to LongMonth1 and LongDay to LongDay1.
; <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)
; 7/11/88 ldc fixed IUSetIntl stack frame values
; 6/27/88 ldc fixed IUEqualString (MagIDString) to only return 1 in place of
; -1
; 6/16/88 ldc moved NeedUnlock and DirectGetIntl to expandMem
; 6/13/88 ldc allow caller of GetLArray to select itlx
; 6/1/88 med DatePString common entry must go to LongerDate, NOT DoLongForm
;
; 3/21/88 med Do not use cache if expandMem version is not correct
; 2/5/88 med Use Cache Offsets table to avoid some calculation.
; 2/5/88 med Moved cache storage into expandmem
; 1/25/88 med Gave SetIntl a frame, to prevent spurious errors
; 1/19/88 med Skip cache if id = 0,1; since MacWrite breaks it
; 1/19/88 med We know the script manager is always there, so don't check
; 1/13/88 med Added MakeDatLString, MakeTimLString; restructured entries
; slightly
; 1/13/88 drs Fixed equates and stack frame. Produces identical code.
; 1/7/88 med Changed label 'NoCache' to 'GotNoCache': must be new name
; conflict
; 1/4/88 drs Fixed lock/unlock of Pack6
; 1/4/88 med Fixed TestMetric Offset for new dispatch
; 12/22/87 med Fixed two nasty bugs with ligatures: oeœ = œoe, and oer < and >
; œdipus
; 11/16/87 med GetIntl now takes verbs 0,1,2,4
; 5/15/87 drs Created a cache for the handle loaded from GetIntl so that
; subsequent calls could used LoadResource. Optimizations
; throughout the sorting routine. Fixed bug in FetchChar which
; updated the character pointer wrongly. Global reorganization of
; entire sort routine. Don't start initialization until strings
; are proven to be unequal and quick exit if they are equal.
;
; Changes for performance enhancements above
;
; <S132> 3/24/87 med Fixed the BMI in TestMetric, and the CLR.L in GetTheIntl to
; unlock properly.
; 3/2/87 med Used _HPurge instead of direct call. Cleared d1 in GetTheIntl.
; This routine calls GetIntl, which unlocks the package if d1 is
; set, so for safety, it should be cleared.
; 1/19/87 jdt Replaced resource type constants with literals.
; 1/5/87 jdt Minor changes to GetIntl routine for clarity. Replaced script
; manager core macro with check for _ScriptUtil trap implemented.
; Changed dispatch to use _HGetState when new ROMs are present.
; Changed d2 to d7 in MakeTimeString and removed saving of d2 in
; AppendNumCom. Added call to ExitHook in MagComString exit code.
; Removed CCR save and restore in TwoMoreChars.
; 11/25/86 jdt Changed the equate files just one more time.
; 11/18/86 MED Fixed register save/restore with MakeTimPString; Modified movem
; calls generally by using REG
; 11/13/86 MED Redid equates
; 9/18/86 JDT Modified GetIntl routine to handle switch-launch. We cannot
; assume that the script manager has been installed.
; 9/11/86 MED Save and restore d2 over appendNum call for safety.
; 9/3/86 JDT Modified GetIntl to use the ScriptUtil trap.
; 8/30/86 JDT GetIntl now uses the Script Manager to find the ITLx resources.
; 8/28/86 JDT Removed support for LocalRtn in string comparison. A4 is now a
; handle to the international parameter block that contains the
; new sorting hooks.
; 8/26/86 JDT Moved localization hooks from ITL1 to new ITL2 resource.
; 8/25/86 JDT Modified the GetIntl routine to look for ITLx resources.
; 7/29/86 MED Changed AppendNum (and AppendLongNum) to use NumToString in the
; 'approved' manner.
;
; Changes for Script Manager support above
;
; 6/10/86 MED Added: hooks in string comparison, ignore flags.
; 5/20/86 JDT Put MagWString back in, depending on the Microsoft flag.
; 5/9/86 JDT Removed Kanji routines from Pack6. They now reside in their own
; package, Pack8.
; 5/7/86 JDT Bracked all Kanji routines by calls to saveLock and checkLock,
; to preserve the (un)locked status of the package.
; 3/26/86 MED Changed inKanji to be zero if CharMode > 1
; 3/22/86 MED Added separate entry for Microsoft (WeakMag)
; 3/21/86 KWK Changed version number to use equate
; 3/10/86 MED Cleaned up extended routines
; 3/3/86 MED added:
; short form formats: added 3,4,5 for myd,dym,ydm.
; timeCycle: 128 for 0:00 AM/PM instead of 12:00 AM/PM.
; longDateFormat: first+second*4+third*16+fourth*64, where 0 =
; day, 1 = weekday, 2 = month, 3 = year.
; suppressDay: now a bitmap to suppress 0,1,2,3.
; old forms all should work as before.
; 2/19/86 MED now interleaves katakana, hiragana, kana
; 2/17/86 MED Added routines to access KIS vectors (text manipulation)
; 12/16/85 MED Added basic support for double-byte characters
;
; Changes for Kanji Interface System support above
;
; 12/30/85 JTC Fix reg save bug in SetIntl. <30Dec85 JTC>
; 12/18/85 JTC Last nanosecond changes for Mac+: Fix old JTC bug with string
; comparisons trashing D3. Have the package preserve its
; lockedness across the call. <18Dec85 JTC>
; 2/4/84 JTC fixed oe ligature problem
; 1/11/84 AJH believe it or not, there was a 12 AM bug, too...
; 1/6/84 AJH fixed short year bug
; 1/5/84 AJH made it use medium mode for day, too
; 1/4/84 AJH fixed 12 PM bug (was giving 00 PM)
; 1/3/84 AJH alternate entry points added for Random Wigginton
; 12/22/83 AJH GetIntl was staying locked...
; 11/17/83 JTC Added MagIdString compare.
; 11/12/83 AJH Fixed bug in "medium long" option
; 11/10/83 AJH Added "medium long" date option
; 11/8/83 AJH Made "GetIntl" preserve lock state
; 11/7/83 AJH Integrated Jerome's magnitude compare
; 11/3/83 AJH Added "wantSeconds" parameter to time formatting
;___________________________________________________________________________________________________
; To Do:
; • Always call LockIt at entry instead of waiting for first time that might move memory
;___________________________________________________________________________________________________
load 'StandardEqu.d'
include 'Packages.a' ; <46>
include 'ScriptPriv.a'
include 'IntlUtilsPriv.a' ; <7>
string asis
EmptyString equ Lo3Bytes ; handy empty string <3>
proc
;---------------------------------------------------------------------------------------------------------
; Local Variable Equates.
;---------------------------------------------------------------------------------------------------------
;---------------------------------------------------------------------------------------------------------
; International Parameter Block Definitions
;---------------------------------------------------------------------------------------------------------
IntlMaxID equ 5 ; <37> maximum resource ID number.
; Parameter Block 0 Offsets
IntlDecPoint EQU 0 ;decimal point character
IntlThouSep EQU 1 ;thousands separator character
IntlListSep EQU 2 ;list separator character
IntlCurSym EQU 3 ;3 byte currency symbol
IntlCurFmt EQU 6 ;currency format flags
IntlDateOrder EQU 7 ;order for short form dates
IntlSDLZFlags EQU 8 ;leading zero flags for dates
IntlDSep EQU 9 ;seperator character for dates
IntlTimeMode EQU 10 ;12 or 24 hour time mode flag
IntlTLZFlags EQU 11 ;time leading zero flags
IntlAMSuffix EQU 12 ;suffix string for AM times
IntlPMSuffix EQU 16 ;suffix string for PM times
IntlTSep EQU 20 ;time separator character
Intl24Suffix EQU 21 ;suffix for 24 hr mode
IntlMetric EQU 29 ;boolean for English/Metric
; Parameter Block 1 Offsets.
; Get rid of unused ones. <24>
IntlSunday EQU 0 ;string for Sunday
IntlJanuary EQU 112 ;string for January
IntlDaySupress EQU 304 ;boolean for supressing day-of-week
IntlLongOrder EQU 305 ;boolean for selecting order
IntlLDayLZFlag EQU 306 ;boolean for day# leading zeros
IntlMonLen EQU 307 ;month length for medium date
IntlStr1 EQU 308 ;long date prefix string
IntlStr2 EQU 312 ;long date day seperator string
IntlStr3 EQU 316 ;long date month seperator string
IntlStr4 EQU 320 ;long date date seperator string
IntlStr5 EQU 324 ;long date year suffix string
; New offsets for itl1 extension. Moved to Packages.a. <24><46>
; Note: Each list above begins with a count of items,
; followed by that many variable-length pstrings.
; Since these routines are accessed as a "package", the first code is
; a dispatcher which strips the selection parameter and cases out on it.
;---------------------------------------------------------------------------------------------------------
; Package dispatch
;---------------------------------------------------------------------------------------------------------
maxSelector equ 52 ; <25>
IntlUnit
bra.s RealStart ; skip over header
; Standard resource header.
dc.w 0 ; flags word.
dc.b 'PACK' ; resource type is PACK.
dc.w 6 ; resource ID number is 6.
dc.w $701 ; version number. <4><34>
; The real code starts here. We dispatch
; to the appropriate routine based on the selector parameter.
; Note!: the dispatch changed around August 87, but is not marked <1/4/88med>
RealStart
with ExpandMemRec
move.l expandMem, a0 ; get expand mem <6/16/88ldc>
clr.w emItlNeedUnlock(a0) ; clear both emItlNeedUnlock & emItlDontUnlockYet <40>
endwith ;ExpandMemRec
move.l (sp)+,a0 ; save return address.
move.w (sp)+,d0 ; pop the selector.
move.l a0,-(sp) ; restore return address.
cmp.w #maxSelector,d0 ; <25>
bhi.s @bail ; bail if selector high or negative <25>
lea IntlTable,a0 ; get jump table address.
add.w 0(a0,d0.w),a0 ; compute dispatch address.
jmp (a0) ; jump into routine.
@bail ; <25>
rts ; <25>
; import/export needed for separate type select procedures ; <7>
import TypeSelectClear, TypeSelectNewKey, TypeSelectFindItem, TypeSelectCompare ; <7>
export ScriptOrder, MagWPString, LockIt, UnLockIt, intScriptCodeToReal, GetScriptItl ; <7><20>
; Package dispatch table.
IntlTable
dc.w MakeDateString - IntlTable ; 00
dc.w MakeTimeString - IntlTable ; 02
dc.w TestMetric - IntlTable ; 04
dc.w GetIntl - IntlTable ; 06
dc.w SetIntl - IntlTable ; 08
dc.w MagString - IntlTable ; 10 and CompString
dc.w MagIdString - IntlTable ; 12 and EqualString
dc.w MakeDatPString - IntlTable ; 14
dc.w MakeTimPString - IntlTable ; 16
dc.w MagWString - IntlTable ; 18 (private interface)
dc.w MakeLDatString - IntlTable ; 20 (Script Mgr 2.0)
dc.w MakeLTimString - IntlTable ; 22 (Script Mgr 2.0)
; System 7 extensions:
dc.w ClearCache - IntlTable ; 24 <1.8>
dc.w MagPString - IntlTable ; 26 (and CompPString) <1.8>
dc.w MagIdPString - IntlTable ; 28 (and EqualPString) <1.8>
dc.w ScriptOrder - IntlTable ; 30 <1.8>
dc.w LangOrder - IntlTable ; 32 <1.8>
dc.w TextOrder - IntlTable ; 34 (and StringOrder) <1.8>
dc.w GetItlTable - IntlTable ; 36 <2.0>
dc.w MagWPString - IntlTable ; 38 (private interface) <5>
dc.w TypeSelectClear - IntlTable ; 40 (private interface) <7>
dc.w TypeSelectNewKey - IntlTable ; 42 (private interface) <7>
dc.w TypeSelectFindItem - IntlTable ; 44 (private interface) <7>
dc.w TypeSelectCompare - IntlTable ; 46 (private interface) <7>
dc.w TextOrderSys - IntlTable ; 48 (private interface) <10>
dc.w GetScriptItl - IntlTable ; 50 (private interface) <21>
dc.w ClearCacheSys - IntlTable ; 52 (private interface) <25>
;---------------------------------------------------------------------------------------------------------
; Utility Routines
;---------------------------------------------------------------------------------------------------------
; UnlockIt is a short utility that unlocks the package.
; Simplified <1/4/88med>
UnlockIt
with ExpandMemRec
move.l ExpandMem,a0 ; ExpandMem ptr
tst.b emItlDontUnlockYet(a0) ; are we really leaving PACK 6? <40>
bne.s @0 ; if not, don't even try to unlock <40>
tst.b emItlNeedUnlock(a0) ; did we lock it? <40>
beq.s @0 ; if not, don't unlock it
endWith ;ExpandMemRec
move.l AppPacks+(6*4),a0 ; get handle directly <2.2>
_HUnlock ; unlock the package.
@0
rts ; return to the caller.
;---------------------------------------------------------------------------------------------------------
; LockIt is a short utility that locks the package if we locked it
; Simplified <1/4/88med>
LockIt
move.l AppPacks+(6*4),a0 ; get handle directly <2.2>
_HGetState ; get lock state new way.
tst.b d0 ; was it already locked (negative)? (d0) <1/4/88med>
blt.s @LockReturn ; yes, done
_HLock ; lock the package down.
with ExpandMemRec
move.l ExpandMem, a0 ; ExpandMem ptr <6/16/88ldc>
st emItlNeedUnlock(a0) ; remember that we locked it <6/16/88ldc><40>
endwith ;ExpandMemRec
@LockReturn
rts
;---------------------------------------------------------------------------------------------------------
;---------------------------------------------------------------------------------------------------------
; The following are frames, equates and utilities for date and time conversions.
; They share a fair amount of common code, so the entries are a bit odd.
DateTimeFrame record {oldA61},decrement
argFrameT1 EQU *
return1 ds.l 1
argFrame1 EQU argFrameT1-*
theTime ds.l 1 ; LongInt ; 14
longFlag ds.w 1 ; BOOLEAN ; 12
result ds.l 1 ; str255 ; 8
intlParam ds.l 1 ; Handle ; 4
oldA61 ds.l 1 ; ; 0
garbage ds.b 2 ;-2
longdate ds LongDateRec
MPByte ds.w 1 ;-18
TempStr ds.b 10 ;-28
LocSiz EQU *
ENDR
WITH DateTimeFrame
DateTimeRegs reg D3-D7/A2-A4 ; common entry/exit regs <18Nov86MED>
DayInteger equ longDate.dayOfWeek
SecondInteger equ longDate.second
MinuteInteger equ longDate.minute
HourInteger equ longDate.hour
DateInteger equ longDate.day
MonthInteger equ longDate.month
YearInteger equ longDate.year
;---------------------------------------------------------------------------------------------------------
; The following is a set of common utility routines for decimal conversion,
; string manipulation, etc.
;---------------------------------------------------------------------------------------------------------
; AppendLongNum appends a four digit number to the current string
; Note: we use this unusual method of adding zeros so that StringToNum adds the proper form.
AppendLongNum
st d1 ; leading zeros
add.w #10000,d0 ; for zeros
bra.s AppendNumCom ; go to it
;---------------------------------------------------------------------------------------------------------
; AppendNum -- given an integer in D0, and a leading zero flag in D1, append
; its 2 low order digits to the string pointed to by A0. D0 and D1 are
; clobbered.
AppendNum
tst.b d1 ; leading zeros?
beq.s AppendNumCom ; no
add.w #100,d0 ; for zeros
;---------------------------------------------------------------------------------------------------------
AppendNumCom
ext.l d0 ; longize (always positive)
movem.l a0/d1,-(sp) ; save the registers.
lea TempStr(a6),a0 ; space for string
_NumToString ; put string in apStr(a6)
movem.l (sp)+,a0/d1 ; restore the registers.
lea TempStr(a6),a1 ; get string in local frame
tst.b d1 ; want leading zeros on two digit num?
beq.s @1 ; no, just add string
move.b (a1)+,d0 ; get length
subq.w #1,d0 ; subtract
move.b d0,(a1) ; set length one byte up
@1
bsr.s AppendString ; append a1 to a0
rts
;---------------------------------------------------------------------------------------------------------
; AppendChar appends the character in D0 to the string pointed to by A0.
; It filters out NULLs (ASCII 0).
AppendChar
TST.B D0 ;is it null?
BEQ.S @1 ;if so, ignore it
MOVEQ #0,D1
MOVE.B (A0),D1 ;get current length of string
ADDQ.B #1,(A0) ;bump it by one
MOVE.B D0,1(A0,D1) ;store away the new character
@1
RTS ;return to our caller
;---------------------------------------------------------------------------------------------------------
; AppendString appends the string pointed to by A1 to the string pointed
; to by A0.
; If a string can't be found, the NoAppend entry point is used. <24>
AppendString
MOVEQ #0,D2 ;zero high part
MOVE.B (A1)+,D2 ;get the length
AppStrLoop
MOVE.B (A1)+,D0 ;get next character
BSR.S AppendChar ;append it
SUBQ #1,D2 ;more to do?
BNE.S AppStrLoop ;loop till done
NoAppend
RTS ;all done
;---------------------------------------------------------------------------------------------------------
; Append4 appends the four character string pointed at by A1 to the string
; pointed to by A3.
Append4
MOVE.L A3,A0 ;get result string ptr
MOVEQ #4,D2 ;4 characters to process
BRA.S AppStrLoop ;use common code
;---------------------------------------------------------------------------------------------------------
; The following is a set of common utility routines for setting up the date time.
;---------------------------------------------------------------------------------------------------------
; GetTheDate is a utility subroutine shared by the date and time routines
; The time longInt is passed in the stack frame.
;
; It makes a3 point to the result string, sets it to null, gets itl0 handle in a4,
; and now sets Z if itl0 couldn't be loaded. <16>
;---------------------------------------------------------------------------------------------------------
GetTheDate
BSR.S GetTArray
MOVEQ #0,D0 ;we need INTL 0
BRA GetTheINTL ;get resource handle in A4
; and set Z if we fail <16>
;---------------------------------------------------------------------------------------------------------
GetTArray
MOVE.L theTime(A6),D0 ;get the time (common) <1/13/88med>
LEA YearInteger(A6),A0 ;point to word array
_Secs2Date ;convert to tractable integers
; copied from below (6.0.6 fix) <16>
MOVE.L result(A6),A3 ;get the result string
CLR.B (A3) ;start it out with length 0
RTS
; added new routine for long times <1/13/88med>
;---------------------------------------------------------------------------------------------------------
GetLArray
; a4 = intlParam. if nil, we load a new one.
; d0.w = itlx type from caller (0 or 1).
; Now sets Z if we can't load the itl resource. <16>
; rearrange so Z is set if we can't load handle (6.0.6 fix) <16>
move.w d0,-(sp) ;save d0 <18>
move.l theTime(A6),-(sp) ; @LongDateTime
pea longDate(A6) ;point to word array
_LongSecs2Date ;convert to tractable integers
MOVE.L result(A6),A3 ;get the result string
CLR.B (A3) ;start it out with length 0
move.w (sp)+,d0 ; restore d0 <18>
move.l a4,d1 ; nil handle?
beq GetTheIntl ; if so, get resource handle in A4 (else set Z)
rts ; else we have a good handle
;---------------------------------------------------------------------------------------------------------
; PROCEDURE IULDateString(theTime: Comp; longFlag:BOOLEAN; VAR result: str255; intlParam: Handle);
; MakeDatPString is an alternate for of MakeDateString added for Randy. It has
; an additional parameter, which is the INTL parameter block handle, which it
; uses instead of getting it from resources.
;<1/13/88med> Added
;---------------------------------------------------------------------------------------------------------
MakeLDatString
MOVE.L (SP)+,D0 ;get return address
MOVE.L (SP)+,A0 ;get parameter handle
MOVE.L D0,-(SP) ;replace return address
LINK A6,#LocSiz ;get local space <18Dec85 JTC>
MOVEM.L DateTimeRegs,-(SP) ;save work regs <18Nov86MED>
MOVE.L A0,A4 ;keep pBlock in A4
;<6/11/88ldc> need itl1 or 0 depending on long or short form
; seems like longFlag isn't really a flag, but an enumerated type
; check on this.
moveq #1, d0 ; assume itl1
tst.b longFlag(A6) ; long date form?
bne.s @elseGLA ; else just call GetLArray
moveq #0, d0 ; itl0
@elseGLA
BSR.s GetLArray ; included theTime <1/13/88med>
beq DoneMDS ; bail if we couldn't load itl0/1 <16>
bra.s DateCommon ; jump to common date routine <1/13/88med>
;---------------------------------------------------------------------------------------------------------
; PROCEDURE MakeDatePString(theTime: LongInt; longFlag:BOOLEAN; VAR result: str255; intlParam: Handle);
; MakeDatPString is an alternate for of MakeDateString added for Randy. It has
; an additional parameter, which is the INTL parameter block handle, which it
; uses instead of getting it from resources.
;---------------------------------------------------------------------------------------------------------
MakeDatPString
MOVE.L (SP)+,D0 ;get return address
MOVE.L (SP)+,A0 ;get parameter handle
MOVE.L D0,-(SP) ;replace return address
LINK A6,#LocSiz ;get local space <18Dec85 JTC>
MOVEM.L DateTimeRegs,-(SP) ;save work regs <18Nov86MED>
MOVE.L A0,d0 ; Make sure there is a valid intlParam <36>
bz.s @getDefaultItl ; Handle was nil. Go get the default 'itl' resource. <36><39>
move.l d0,a4 ; <36>
tst.l (a4) ; is it loaded <39>
bne.s @gotValidHandle ; if so, done <39>
bsr LockIt ; lock ourselves down <40>
move.l a4,-(sp) ; <39>
_LoadResource ; else load it <39>
bra.s @gotValidHandle ; <36>
@getDefaultItl ; <36><39>
moveq #0,d0 ; assume 'itl0' resource <36><39>
TST.B longFlag(A6) ; long or short date? <39>
beq.s @gotWhichItl ; if short, have correct 'which' param <39>
moveq #1,d0 ; set 'itl1' resource <39>
@gotWhichItl ; <39>
bsr GetTheIntl ; <36>
beq DoneMDS ; bail if we couldn't load default itl <39>
@gotValidHandle ; <36>
BSR.s GetTArray ; included theTime <1/13/88med>
; common entry must go to LongerDate, NOT DoLongForm <6/1/88med>
DateCommon
TST.B longFlag(A6) ; long form? (1,2) <6/1/88med>
BEQ.S ShorterDate ; no (0) <6/1/88med>
BRA LongerDate ; long form, have parameter
;---------------------------------------------------------------------------------------------------------
; table for short date order
OrderTable
dc.w 2,6,4,5,0,$8007 ;month, day, year
dc.w 4,5,2,6,0,$8007 ;day, month, year
dc.w 0,$8007,2,6,4,5 ;year, month, day
dc.w 2,6,0,$8007,4,5 ;month, year, day
dc.w 4,5,0,$8007,2,6 ;day, year, month
dc.w 0,$8007,4,5,2,6 ;year, day, month
;---------------------------------------------------------------------------------------------------------
; PROCEDURE MakeDateString(theTime: LongInt; longFlag:BOOLEAN; VAR result: str255);
;
; MakeDateString produces a result string from the input parameter based
; on the current settings in the international resource block. It provides
; both a long and short form of the date.
;---------------------------------------------------------------------------------------------------------
MakeDateString
LINK A6,#LocSiz ;get space for our locals <18Dec85 JTC>
MOVEM.L DateTimeRegs,-(SP) ;save work registers
BSR GetTheDate ;get the date/time integers
beq DoneMDS ; bail if we couldn't load itl0 <16>
;;DateCommon ; moved higher <6/1/88med>
TST.B longFlag(A6) ;long or short?
BNE.S DoLongForm ;if long, go do it
; the caller is requesting a short-form date so inspect the parameters in the
; resource block and build a string for her
ShorterDate
MOVEQ #0,D0 ;clear out high part of D0
MOVE.L (A4),A0 ;get pBlock ptr
MOVE.B IntlDateOrder(A0),D0 ;get order indicator
MULU #12,D0 ;multiply by 12 for index
MOVEQ #2,D3 ;three fields to handle
LEA OrderTable(D0),A2 ;point to the order table entry
; here is the loop where we process one field at a time. The order is
; determined by the 4 byte/entry table pointed at by A2
DateLoop
MOVEQ #0,D0 ;clear out high part
MOVE.W (A2)+,D0 ;get date array index
MOVE.W (A2)+,D1 ;get flag bit index
MOVE.L (A4),A0 ;get pBlock ptr
BTST D1,IntlSDLZFlags(A0) ;test the appropriate flag bit
SNE D1 ;record the boolean
MOVE.W YearInteger(A6,D0),D0 ;get the value to append
MOVE.L A3,A0 ;get the string ptr
TST.W D1 ;is it the year command?
BPL.S @1 ;if not, skip
TST.B D1 ;long form enabled?
BNE.S LongYear1
DIVU #100,D0 ;compute year mod 100
SWAP D0 ;remainder in D0
@1
BSR AppendNum ;append it
TestLast
TST D3 ;is it the last one?
BEQ.S SkipSep ;the last one doesn't have a separator
; append the separator character
MOVE.L (A4),A0 ;get pBlock pointer
MOVE.B IntlDSep(A0),D0 ;get the separator character
MOVE.L A3,A0 ;point A0 at the result string
BSR AppendChar ;append the character in D0
; loop till we've processed all three fields
SkipSep
DBRA D3,DateLoop ;loop until finished
; all done so clean up the stack and go home
DoneMDS
BSR UnlockIt ;unlock the package
MOVEM.L (SP)+,DateTimeRegs ;restore registers <18Nov86MED>
UNLK A6 ;deallocate stck frame
MOVE.L (SP)+,A0 ;get the return address
ADD #10,SP ;strip parameters
JMP (A0) ;return to caller
; handle the case of the long year (all four digits)
LongYear1
BSR AppendLongNum
BRA.S TestLast
; handle the long form of the date. We must get the INTL 1 resource to
; get all those strings
DoLongForm
MOVEQ #1,D0 ;get INTL 1
BSR GetTheINTL ;get the resource
beq DoneMDS ; bail if we couldn't load itl0 <16>
LongerDate
MOVE.L (A4),A2 ; point to record with A2
; generalize the old formats
move.b IntlLongOrder(A2),d5 ; get the order byte
bne.s @1 ; zero, get old format?
move.b #1+0*4+2*16+3*64,d5 ; weekday,day,month,year
bra.s @2 ; continue
@1
cmp.b #$FF,d5 ; 255, get old format?
bne.s @2 ; continue
move.b #1+2*4+0*16+3*64,d5 ; weekday,month,day,year
@2
moveq #0,d6 ; longize
move.b IntlDaySupress(A2),d6 ; get suppression byte
cmp.b #$FF,d6 ; old style?
bne.s @3 ; no, skip
moveq #2,d6 ; suppress day
@3
move.w #IntlStr1,d7 ; get offset
lea 0(a2,d7),a1 ; point at first prefix
move.l a3,a0 ; point at string
bsr Append4 ; and stick it on
LongDateLoop
addq.w #4,d7 ; point to next separator
move.b d5,d0 ; get part number
and.w #3,d0 ; out of the composite
lsr.b #2,d5 ; and remove it
btst.l d0,d6 ; suppress element?
bne.s @1 ; yes, skip
add.w d0,d0 ; make word offset
lea LongDispatch,a1 ; get dispatch
add.w 0(a1,d0.w),a1 ; add offset
jsr (a1) ; call it
lea 0(a2,d7),a1 ; pass separator
bsr Append4 ; and stick it on
@1
cmp.w #IntlStr5,d7 ; at end yet?
blo.s LongDateLoop ; and loop til done
BRA.S DoneMDS ; all done!
LongDispatch
dc.w LongDay1-LongDispatch ; day
dc.w LongWeekDay-LongDispatch ; weekday
dc.w LongMonth1-LongDispatch ; month
dc.w LongYear2-LongDispatch ; year
LongDay1
MOVE.W DateInteger(A6),D0 ;get day of month
MOVE.B IntlLDayLZFlag(A2),D1 ;get leading zero supress flag
bra AppendNum ;append it and return from there
LongWeekDay
MOVE.W DayInteger(A6),D0 ; get the day of week
; support for 7.0 itl1 extension <24>
cmp.w #itl1ExtFlag,localRtn(a2) ; extended itl1?
beq.s @doExt ; if so, handle differently
cmp.w #7,d0 ; out of range or negative?
bhi.s NoAppend ; if so, bail
@doOld
SUBQ #1,D0 ; make it zero based [0..6]
ASL #4,D0 ; multiply by 16
LEA IntlSunday(A2,D0),A1 ; get string ptr
CMP.B #abbrevDate,longFlag(A6) ; is it abbreviated?
BEQ AbbrevString ; if so, go truncate it <24>
bra AppendString ; otherwise, append name and return
; support for 7.0 itl1 extension <24>
@doExt
cmp.b #abbrevDate,longFlag(A6) ; is it abbreviated?
beq.s @doExtAbbrev ; if so, deal with it.
cmp.w #7,d0 ; in range?
bls.s @doOld ; if so, use old code
; here we need extra day name
subq.w #7,d0 ; extra day number
move.l #itl1XDayOffset,d2 ; offset to extra days list
bsr GetListString ; get pointer to name in a1;
bge.s NoAppend ; if no extra day name, bail
; here we are pointing to the correct pstring
bra AppendString ; append name and return
@doExtAbbrev
; here we need abbrev day name
move.l #itl1AbDayOffset,d2 ; offset to abbrev days list
bsr.s GetListString ; get pointer to abbrev in a1;
bge.s @doOld ; if no abbrev, go truncate
; here we are pointing to the correct pstring
bra AppendString ; append name and return
LongMonth1
MOVE.W MonthInteger(A6),D0 ; get the month
; support for 7.0 itl1 extension <24>
cmp.w #itl1ExtFlag,localRtn(a2) ; extended itl1?
beq.s @doExt ; if so, handle differently
cmp.w #12,d0 ; out of range or negative?
bhi.s NoAppend ; if so, bail
@doOld
SUBQ #1,D0 ; make it zero based [0..11]
ASL #4,D0 ; multiply by 16
LEA IntlJanuary(A2,D0),A1 ; get string ptr
CMP.B #abbrevDate,longFlag(A6) ; is it abbreviated?
BEQ.S AbbrevString ; if so, go truncate it
bra AppendString ; otherwise, append name and return
; support for 7.0 itl1 extension <24>
@doExt
cmp.b #abbrevDate,longFlag(A6) ; is it abbreviated?
beq.s @doExtAbbrev ; if so, deal with it.
cmp.w #12,d0 ; in range?
bls.s @doOld ; if so, use old code
; here we need extra month name
sub.w #12,d0 ; extra month number
move.l #itl1XMonOffset,d2 ; offset to extra months list
bsr.s GetListString ; get pointer to name in a1;
bge.s NoAppend ; if no extra month name, bail
; here we are pointing to the correct pstring
bra AppendString ; append name and return
@doExtAbbrev
; here we need abbrev month name
move.l #itl1AbMonOffset,d2 ; offset to abbrev months list
bsr.s GetListString ; get pointer to abbrev in a1;
bge.s @doOld ; if no abbrev, go truncate
; here we are pointing to the correct pstring
bra AppendString ; append name and return
LongYear2
MOVE.W YearInteger(A6),D0 ;get the year
bra AppendLongNum ;append it and return from there
AbbrevString
ADDQ #1,A1 ;bump past length
MOVEQ #0,D2 ;clear high part
MOVE.B IntlMonLen(A2),D2 ;get month length
BRA AppStrLoop ;append it, return to caller
;------------------------------------------------------------------------------- <24>
; GetListString
;
; Local routine for code saving. Gets a string specified by index in d0 from
; itl1 table whose offset is in d2.l.
;
; input:
; string index [1..n] in d0
; table offset in d2
; itl1 pointer in a2
; output:
; Caller should use bge to branch if failure.
; If no failure, string pointer is in a1
; effects:
; Does not change a0 (current date string pointer)
;-------------------------------------------------------------------------------
GetListString
move.l 0(a2,d2.w),d2 ; get offset to list
beq.s @fail ; if none, bail (with nZvc)
lea 0(a2,d2.l),a1 ; make pointer to list
cmp.w (a1)+,d0 ; is our string# in the list?
bgt.s @fail ; if not, bail
subq.w #1,d0 ; set up for dbra
moveq #0,d2 ; for longizing
bra.s @endLoop
@loop
move.b (a1)+,d2 ; this pstring length
add.w d2,a1 ; skip, point to next pstring
@endLoop
dbra d0,@loop
moveq #-1,d0 ; set cond codes to Nzvc
@fail
rts
;---------------------------------------------------------------------------------------------------------
; PROCEDURE IULTimeString(theTime: Comp; wantSeconds: BOOLEAN; VAR result: str255; intlParam: Handle);
;
; MakeTimPString is an alternate entry point for Randy. It takes the pBlock
; handle as an additional parameter instead of getting it from resources
;<1/13/88med> Added
;---------------------------------------------------------------------------------------------------------
MakeLTimString
MOVE.L (SP)+,D0 ;get return address
MOVE.L (SP)+,A0 ;get pBlock handle
MOVE.L D0,-(SP) ;replace return address
LINK A6,#LocSiz ;get space for our locals <18Dec85 JTC>
MOVEM.L DateTimeRegs,-(SP) ;save work registers <18Nov86MED>
MOVE.L A0,A4 ;keep pBLock handle in A4
;<6/11/88ldc> change GetLArray so caller specifies which itlx
MOVEQ #0,D0 ;want itl0
BSR GetLArray ; included theTime <1/13/88med>
beq DoneMDS ; bail if we couldn't load itl0 <16>
BRA.s MTimeCommon ;use common code for the rest
;---------------------------------------------------------------------------------------------------------
; PROCEDURE MakeTimeString(theTime: LongInt; wantSeconds: BOOLEAN; VAR result: str255; intlParam: Handle);
;
; MakeTimPString is an alternate entry point for Randy. It takes the pBlock
; handle as an additional parameter instead of getting it from resources
;---------------------------------------------------------------------------------------------------------
MakeTimPString
MOVE.L (SP)+,D0 ;get return address
MOVE.L (SP)+,A0 ;get pBlock handle
MOVE.L D0,-(SP) ;replace return address
LINK A6,#LocSiz ;get space for our locals <18Dec85 JTC>
MOVEM.L DateTimeRegs,-(SP) ;save work registers <18Nov86MED>
MOVE.L A0,d0 ; Make sure there is a valid intlParam <36>
bz.s @getDefaultItl0 ; Handle was nil. Go get the default 'itl0' resource. <36><39>
move.l d0,a4 ; <36>
tst.l (a4) ; is it loaded <39>
bne.s @gotValidHandle ; if so, done <39>
bsr LockIt ; lock ourselves down <40>
move.l a4,-(sp) ; <39>
_LoadResource ; else load it <39>
bra.s @gotValidHandle ; <36>
@getDefaultItl0 ; <36><39>
moveq #0,d0 ; Get default 'itl0' resource if handle was nil. <36><39>
bsr GetTheIntl ; <36>
beq DoneMDS ; bail if we couldn't load default itl0 <39>
@gotValidHandle ; <36>
BSR GetTArray ;included theTime <1/13/88med>
BRA.s MTimeCommon ;use common code for the rest
;---------------------------------------------------------------------------------------------------------
; PROCEDURE MakeTimeString(theTime: LongInt; wantSeconds: BOOLEAN; VAR result: str255);
;
; MakeTimeString produces a result string from the input parameter based
; on the current settings in the international resource block.
;---------------------------------------------------------------------------------------------------------
MakeTimeString
LINK A6,#LocSiz ;get space for our locals <18Dec85 JTC>
MOVEM.L DateTimeRegs,-(SP) ;save work registers <18Nov86MED>
BSR GetTheDate ;get the date/time integers
beq DoneMDS ; bail if we couldn't load itl0 <16>
; pre-process the hour integer to reflect a 12 or 24 hour time system as
; indicated in the parameter block
MTimeCommon
LEA HourInteger(A6),A2 ;point at the hour number
MOVE.W (A2),D7 ;remember it
SUB #12,D7 ;subtract 12
MOVE.L (A4),A0 ;get pointer to pBlock
MOVE.B IntlTLZFlags(A0),D4 ;get time leading zero flags
TST.B IntlTimeMode(A0) ;12 or 24 hr cycle (or special12)?
BEQ.S @1 ;skip if 24
bmi.s @11 ; normal 12 hour
tst.b d7 ; special 12 hour: is it AM?
bmi.s @1 ; yes, skip
bra.s @0 ; no, adjust for PM
@11
TST (A2) ;12 AM?
BNE.S @2 ;if not, skip
MOVE.W #12,(A2) ;12 AM, not 00 AM
BRA.S @1 ;skip the rest...
@2
TST.B D7 ;is it AM?
BMI.S @1 ;if negative, skip
BNE.S @0 ;if non-zero, go update it
MOVEQ #12,d7 ;12 PM is not 00 PM
@0
MOVE.W d7,(A2) ;update hour
; OK, set up the loop count and dive in
@1
MOVEQ #2,D3 ;3 times through the loop
TST.B longFlag(A6) ;want seconds?
BNE.S TimeLoop ;if so, we're cool
SUBQ #1,D3 ;skip the seconds
TimeLoop
MOVE.W (A2)+,D0 ;get the integer
MOVE.L A3,A0 ;point to the string
TST.B D4 ;test the current LZ flag
SMI D1 ;set D1 accordingly
BSR AppendNum ;append the number
ADD.B D4,D4 ;shift flags for next time
; now print the separator if necessary
TST D3 ;the last one?
BEQ.S @1 ;if so, skip the separator
MOVE.L (A4),A1 ;get pointer to pBlock
MOVE.B IntlTSep(A1),D0 ;get the date separator
BSR AppendChar ;append it
; loop until finished
@1
DBRA D3,TimeLoop ;loop 3 times total
; now append a trailing string based on the current hour (AM or PM, etc.)
MOVE.L (A4),A1 ;point to pBlock
TST.B IntlTimeMode(A1) ;12 or 24 hr mode?
BEQ.S Mode24 ;branch if 24 hr
LEA IntlAMSuffix(A1),A1 ;point to suffix string
ModeCommon
TST.B D7 ;AM or PM?
BMI.S AppendTrailer ;if AM, skip
ADDQ #4,A1 ;bump to PM
AppendTrailer
BSR Append4 ;append the suffix
; OK, the time string is built so restore the registers and return to the caller
BRA DoneMDS ;use common exit code
; use 24-hr trailer
Mode24
LEA Intl24Suffix(A1),A1 ;point to suffix string
BRA.S ModeCommon ;use common code
ENDWITH ;DateTimeFrame
;---------------------------------------------------------------------------------------------------------
; FUNCTION TestMetric: BOOLEAN;
;
; TestMetric returns TRUE if the current international resource block is
; configured for metric.
;---------------------------------------------------------------------------------------------------------
TestMetric
CLR.W 4(SP) ;assume false <fixed offset> <1/4/88med>
move.l a4,-(sp) ; save a4 <1/4/88med>
moveq.l #0,d0
BSR GetTheIntl ;get it
move.l a4,a0 ; intl handle for outside use <1/4/88med>
move.l (sp)+,a4 ; restore a4 <1/4/88med>
beq UnlockIt ; bail if GetIntl error <16>
MOVE.L (A0),A0 ;handle to pointer
TST.B IntlMetric(A0) ;is the metric flag set?
BEQ.S @1 ;if so, we're done
ADDQ.B #1,4(SP) ;return true <18Dec85 JTC> <fixed offset> <1/4/88med>
@1
BRA UnlockIt ;unlock it, return to caller <18Dec85 JTC><S132>
;---------------------------------------------------------------------------------------------------------
; PROCEDURE ClearCache;
;
; Clears out cache memory for resources, so apps can supply their own itl2/itl4. New. <1.8>
; New implementation for new cache structure. <9>
;
; Removed the code for handling the internal entry point ClearCacheInt - <11>
; we no longer need it, and it was wrong anyway. Rewrote to use app cache,
; creating one if necessary.
;
; No longer create app cache, since it is done in InitScriptApp <14>
;---------------------------------------------------------------------------------------------------------
with ExpandMemRec,SMgrAppRecord
; Add new entry point to clear the system cache <25>
ClearCacheSys ; <25>
move.l ExpandMem,a0 ; get ExpandMemRec ptr <25>
move.l emItlSysCachePtr(a0),d0 ; get cache pointer <25>
beq.s ccExit ; if 0, don't do anything <25>
move.l d0,a0 ; <25>
bra.s ClearCacheCommon ; <25>
ClearCache
move.l ExpandMem,a0 ; get ExpandMemRec ptr
move.l emScriptAppGlobals(a0),a0 ; get globals handle
move.l a0,d0 ; is it 0 (no app-specific ScriptMgr globals)?
beq.s ccExit ; if so, don't do anything
addq.l #1,d0 ; is it -1 (no Process Mgr yet, use sys cache)?
beq.s ccExit ; if so, don’t do anything
move.l (a0),a0 ; dereference - get ptr to globals
lea smgrAppCacheCount(a0),a0 ; point to record count
ClearCacheCommon ; <25>
move.w (a0)+,d0 ; get count, point to cache start
moveq #-1,d1 ; for flagging invalid IDs <41>
bra.s @enterLoop
@loop
addq #2,a0 ; skip script code
move.w d1,(a0)+ ; invalid itl2 ID <41>
clr.l (a0)+ ; nil itl2 handle <41>
move.w d1,(a0)+ ; invalid itl4 ID <41>
clr.l (a0)+ ; nil itl4 handle <41>
@enterLoop
dbra d0,@loop
ccExit
bra.s UnlockIt ; unlock it, return to caller
endwith ;ExpandMemRec,SMgrAppRecord
;---------------------------------------------------------------------------------------------------------
; PROCEDURE GetItlTable(script:ScriptCode; tableCode: Integer;
; VAR itlHandle: Handle; VAR offset: LongInt; VAR length: LongInt);
;
; Permits access to tables in itl2, itl4
; <2.0> new
;---------------------------------------------------------------------------------------------------------
gtRecord record {a6link},decr ;
gtArgs equ *-8 ; size of arguments
script ds.w 1 ; script code
table ds.w 1 ; table selector
itlHandlePtr ds.l 1 ; address of itlHandle longword
offsetPtr ds.l 1 ; address of offset longword
lengthPtr ds.l 1 ; address of length longword
return ds.l 1 ; return address.
a6link ds.l 1 ; old link pointer.
gtLocals equ * ; size of local variables.
endr ;
GetItlTable
with gtRecord,SMgrRecord,ScriptRecord
link a6,#gtLocals
move.l a2,-(sp) ; save a2
; process script code, check validity
move.w script(a6),d0 ; get ScriptCode
blt.s @mapScript ; if special, go map to real script
cmp.w #smgrCount-1,d0 ; invalid?
ble.s @gotScript ; if not, we have a good script code
bra @gtError ; otherwise, bail
@mapScript
add.w #1,d0 ; is it iuSystemScript (-1)?
blt.s @getCurrent ; no, check for other codes
GetSMgrCore a0 ; get SMgrRecord pointer
move.w smgrSysScript(a0),d0 ; get system script
bra.s @gotScript
@getCurrent
add.w #1,d0 ; is it iuCurrentScript (-2)?
blt @gtError ; no, bail
subq.w #2,sp ; leave space for returned script
_FontScript ; NOT IntlScript
move.w (sp)+,d0
; OK, we have a good script code in d0, use it to get ScriptRecord
@gotScript
lsl.w #2,d0 ; make script code a long offset
GetSMgrCore a0 ; SMgrRecord pointer
move.l smgrEntry(a0,d0.w),d0 ; script's ScriptRecord pointer
beq @gtError ; bail if not installed
move.l d0,a0 ; copy
tst.b scriptEnabled(a0) ; script enabled?
beq @gtError ; bail if not
; If table selector ok, use it to locate resource info.
move.w table(a6),d1 ; get table selector
lea TableLocator,a2 ; point to locator table (1st wd is max) <17>
cmp.w (a2)+,d1 ; too big (unsigned)? <17>
bhi @gtError ; if so, bail
add.w d1,d1 ; mult by 2
move.w d1,d0 ; copy
add.w d1,d0
add.w d1,d0 ; now it is multiplied by 6
add.w d0,a2 ; now point to info for correct table
tst.w (a2)+ ; which resource?
bne.s @getitl4
; Get itl2 info
subq #4,sp ; space for returned handle
move.l #'itl2',-(sp) ; push resource type
move.w scriptBundle.itlbSort(a0),-(sp) ; push resource ID
bsr LockIt ; lock the package!! <2.2>
_GetResource
move.l (sp)+,d0 ; get itl2 handle
beq.s @gtError ; bail if nil
; OK, we're cool. Get offset and length from resource.
move.l d0,a1 ; copy resource handle
move.l (a1),d0 ; resource pointer <43>
beq.s @gtError ; bail if resource not loaded <43>
move.l d0,a0 ; copy pointer <43>
move.w (a2)+,d0 ; get offset for offset!
moveq #0,d1 ; for longizing
move.w 0(a0,d0.w),d1 ; get offset
move.w (a2)+,d0 ; get offset for length
moveq #0,d2 ; for longizing
move.w 0(a0,d0.w),d2 ; get length
bra.s @gtSetResult
; Get itl4 info
@getItl4
subq #4,sp ; space for returned handle
move.l #'itl4',-(sp) ; push resource type
move.w scriptBundle.itlbToken(a0),-(sp) ; push resource ID
bsr LockIt ; lock the package!! <2.2>
_GetResource
move.l (sp)+,d0 ; get itl2 handle
beq.s @gtError ; bail if nil
; OK, we're cool. Get offset and length from resource.
move.l d0,a1 ; copy resource handle
move.l (a1),d0 ; resource pointer <43>
beq.s @gtError ; bail if resource not loaded <43>
move.l d0,a0 ; copy pointer <43>
move.w (a2)+,d0 ; get offset for offset!
move.l 0(a0,d0.w),d1 ; get offset
move.w (a2)+,d0 ; get offset for length
moveq #0,d2 ; for longizing
move.w 0(a0,d0.w),d2 ; get length
; now we have handle in a1, offset in d1, length in d2; set result.
@gtSetResult
move.l itlHandlePtr(a6),a0
move.l a1,(a0)
move.l offsetPtr(a6),a0
move.l d1,(a0)
move.l lengthPtr(a6),a0
move.l d2,(a0)
move.l (sp)+,a2 ; restore a2
unlk a6 ; unlink stack
move.l (sp)+,a0 ; pop return addr
add.w #gtArgs,sp ; kill args
move.l a0,-(sp) ; push return addr
bra.s UnlockIt ; unlock it, return to caller
@gtError
moveq #0,a1 ; make handle nil
moveq #0,d1
moveq #0,d2
bra.s @gtSetResult
endwith ;gtRecord,SMgrRecord,ScriptRecord
TableLocator
with nItl4Rec ; <4>
dc.w iuWhiteSpaceList ; max selector <17><19>
; 0/1 for itl2/4,offset for offset,offset for length
dc.w 0,wordTableOffset,wordTableLen ; WordSelectTable
dc.w 0,wrapTableOffset,wrapTableLen ; WordWrapTable
dc.w 1,defPartsOffset,defPartsLength ; NumberPartsTable
dc.w 1,unTokenOffset,unTokenLength ; unTokenTable <17>
dc.w 1,whtSpListOffset,whtSpListLength ; whiteSpaceList <19>
endwith
;---------------------------------------------------------------------------------------------------------
; GetTheINTL is an internal entry point for GetIntl. It expects the 'which'
; parameter in d0 and returns the resource handle in a4.
; It now also returns Z set if GetIntl failed. <16>
;---------------------------------------------------------------------------------------------------------
GetTheINTL
with ExpandMemRec ; <40>
sub.l #4,sp ; make room for the handle.
move.w d0,-(sp) ; push 'which' argument.
move.l ExpandMem,a4 ; ExpandMem ptr <40>
addq.b #1,emItlDontUnlockYet(a4) ; say this is internal call <40>
bsr.s GetIntl ; get the ITLx resource. <40>
subq.b #1,emItlDontUnlockYet(a4) ; end of internal call <40>
move.l (sp)+,a4 ; copy result to a4.
move.l a4,d0 ; is handle ok? set cond codes <16>
rts ; return to the caller.
endwith ;ExpandMemRec ; <40>
;---------------------------------------------------------------------------------------------------------
; Cache memory for resources. Three records comprise the cache, one for each of
; three international resources. These records will be checked before
; performing a GetResource.
;---------------------------------------------------------------------------------------------------------
cache record 0
theID ds.w 1
theHandle ds.l 1
endr
; offsets in expandMem. 0 means don't cache, -1 means doesn't exist <2/5/88med>
with ExpandMemRec
CacheOffset
with NewItlCacheRec
dc.b 0, 0, itl2Id, -1, itl4Id, 0 ; offsets in NewItlCacheRec <9><38>
endwith
align 2
;---------------------------------------------------------------------------------------------------------
; FUNCTION GetIntl(which: INTEGER): Handle;
;
; GetIntl returns a handle to the international parameter block specified
; by the "which" parameter and the resource id numbers kept in the Script
; Manager globals.
; 5/15/87 <daan> Extensive revisions to cache the Intl block handle and call
; LoadResource when possible.
;---------------------------------------------------------------------------------------------------------
giRecord record {a6link},decr ;
result ds.l 1 ; handle to intl block.
which ds.w 1 ; which argument.
return ds.l 1 ; return address.
a6link ds.l 1 ; old link pointer.
state ds.w 1 ; old lock state.
sAppGlobHnd ds.l 1 ; handle to app script globals & itl cache <10><14>
sysFlag ds.w 1 ; non-zero => use sys itl cache <11>
saveRefNum ds.w 1 ; saved ref num of current resource file <24>
saveResLoad ds.b 1 ; saved value of ResLoad at entry <43><45>
ds.b 1 ; filler <45>
giLocals equ * ; size of local variables.
endr ;
GetIntl1Regs reg a3/a4/d3-d5 ; define regs <11>
with giRecord ;
GetIntl
; Link the stack and clear the result. If the 'which'
; argument is illegal, return immediately.
link a6,#giLocals ; link the stack.
movem.l GetIntl1Regs,-(sp)
clr.l result(a6) ; clear result handle.
; clr.l sAppGlobHnd(a6) ; <10><26>
clr.w sysFlag(a6) ; use app cache <11>
move.w #resNotFound,ResErr ; assume illegal 'which' arg <16>
move.w which(a6),d0 ; load 'which' argument.
cmp.w #IntlMaxID,d0 ; which > IntlMaxID?
bhi FailIntl ; yes -> bail out.
; Do not use cache if expandMem version is not correct. <3/21/88med>
; Don't bother testing anymore, it is always there in 7.0. <9>
clr.l d3 ; longize
move.b CacheOffset(d0.w),d3 ; get offset <3/21/88med>
blt FailIntl ; no resource, bail <2/5/88med>
; Get the new ITLx resource if it exists. The resource type is calculated
; by adding the 'which' parameter to the base type, ITL0. The resource id
; number is found in the script bundle of the current IntlScript.
;
; If the smgrIntlForce flag is on (which is most of the time), we know that IntlScript
; will force the script to the system script. So, if we do it here, we can avoid
; the a5 dependence of IntlScript (by doing this, however, the smgrForced and smgrDefault
; flags will not be set as they would have with IntlScript). The reason for doing this
; is to make GetIntl independent of the a5 world for most cases (i.e., when IntlForce is
; on <02/22/89 pke>.
NewIntl
subq.l #2,sp ; make room for IntlScript result <9>
with SMgrRecord,ScriptRecord ; <9>
GetSMgrCore a0 ; load script manager globals. <02/22/89 pke>
move.b smgrIntlForce(a0),d0 ; load IntlForce flag. <02/22/89 pke>
beq.s @DoIntlScr ; if 0, call IntlScript <02/22/89 pke>
move.w smgrSysScript(a0),d0 ; otherwise, use system script <02/22/89 pke>
move.w d0,(sp) ; arg for _GetScript <02/22/89 pke>
bra.s @HaveScript ; <02/22/89 pke>
@DoIntlScr ; <02/22/89 pke>
_IntlScript ; get the IntlScript code.
@HaveScript ; now script code is on stack <02/22/89 pke>
; <9>
move.w (sp)+,d0 ; get script code
move.w d0,d2 ; save in d2
GetSMgrCore a0 ; get SMgrRecord pointer
lsl.w #2,d0 ; make long offset
move.l smgrEntry(a0,d0.w),a1 ; get ScriptRecord pointer
move.w which(a6),d0 ; load 'which' argument.
add.w d0,d0 ; make word offset
move.w scriptBundle(a1,d0.w),d4 ; get resource id
endwith ;SMgrRecord,ScriptRecord ; <9>
GetIntlCommon ; code shared with GetScriptItl <11>
clr.w ResErr ; now assume no errs <16>
clr.l sAppGlobHnd(a6) ; nothing to lock/unlock <26>
move.b ResLoad,saveResLoad(a6) ; save orig value of ResLoad <43><45>
bne.s @doneSetResLoad ; if already TRUE, no need to set <43><45>
move.l ExpandMem,a0 ; ExpandMem ptr <43><45>
tst.b emItlDontUnlockYet(a0) ; if this is external call... <43><45>
beq.s @doneSetResLoad ; ...don't change ResLoad <43><45>
st ResLoad ; else set it TRUE <43><44>
@doneSetResLoad ; <43>
; skip cache if id = 0,1; since MacWrite breaks it <1/19/88med>
tst.w d3 ; no cache?
beq GotNoCache ; bail <1/19/88med>
; Set up a4 to point to the right place. Assumes script code in d2 (not true for <9>
; all settings of conditionals! Need to fix them up some more).
; Rewrote this (down through @gotCachePtr) to use new ItlAppCache. I also <10>
; eliminated the code that cleared the new cache if someone had tried to
; clear the old one, since no developers know how to clear the old cache.
with SMgrAppRecord ; <14>
move.l Expandmem,a4
tst.w sysFlag(a6) ; use sys cache? <11>
bne.s @useSysCache ; if flag says yes, go do it <11>
move.l emScriptAppGlobals(a4),a1 ; get handle to globals <14>
move.l a1,d0 ; is it 0 (no app-specific ScriptMgr globals)?
beq.s @useSysCache ; if so, use sys cache <14>
addq.l #1,d0 ; is it -1 (no Process Mgr yet, use sys cache)?
beq.s @useSysCache ; if so, use sys cache
move.l a1,sAppGlobHnd(a6) ; save handle for lock/unlock
move.l (a1),a1 ; dereference - get ptr to globals & app cache
lea smgrAppCacheCount(a1),a1 ; point to record count <14>
bra.s @gotCachePtr
endwith ;SMgrAppRecord ; <14>
@useSysCache
move.l emItlSysCachePtr(a4),a1 ; get pointer to sys itl cache
; clr.l sAppGlobHnd(a6) ; nothing to lock/unlock <26>
move.w #-1,sysFlag(a6) ; we are now using the sys cache <26>
@gotCachePtr
with NewItlCacheRec
move.w (a1)+,d0 ; get record count, point to cache start
move.l a1,a4 ; work with copy
bra.s @endLoop ; decrement for dbra, test for 0
@loop
cmp.w (a4),d2 ; is this rec for this script
beq.s @a4SetupDone
adda.w #newItlCacheRecSize,a4 ; skip to next record
@endLoop
dbra d0,@loop
move.l a1,a4 ; oops, we failed, set to first entry
@a4SetupDone
add.w d3,a4 ; select itl2 or itl4 handle
endwith ;NewItlCacheRec
; continue on for good citizens <1/19/88med>
MOVE.W cache.theID(a4),d0 ; check cached ID <41>
cmp.w #-1,d0 ; is it -1 (invalid)? <41>
beq.s @gotID ; if so, use value in d4 from ScriptRecord <41>
move.w d0,d4 ; else use cached ID <41>
@gotID ; <41>
MOVE.L cache.theHandle(a4),d0 ; do we have a handle?
BEQ.S GotNoCache ; too bad
; skip old branch to make all caches immune to ID changes unless cleared <24><25>
IsCache
MOVEA.L d0,a0 ; get in addr reg
MOVE.L a0,result(a6) ; assume cache is ok <2/5/88med>
TST.L (a0) ; if ptr's ok, skip this nonsense
BNE DoneIntl ; don't bother unlocking <2/5/88med>
MOVE.L a0, -(sp) ; push the handle for load
BSR LockIt ; take the plunge
; <10>
move.l sAppGlobHnd(a6),d0 ; do we need to lock script app globals?
beq.s @noLock ; if not, skip
move.l d0,a0
_HLock
@noLock
_LoadResource ; load 'em up
tst.w ResErr ; any errs? <16>
beq.s UnlockIntl ; go finish up if not <16>
clr.l result(a6) ; if so, clear returned handle <16>
BRA.S UnlockIntl ; unlock
GotNoCache
SUBQ.L #4, sp ; room for getresource handle
CLR.L d0 ; clean up high word
move.w which(a6),d0 ; load 'which' argument.
add.l #'itl0',d0 ; load base type.
move.l d0,-(sp) ; push resource type.
MOVE.W d4,-(sp) ; push resource id <2/5/88med>
; Whatever resource we decided to load, go get it and return the resulting handle.
BSR LockIt
; <10>
tst.w sysFlag(a6) ; get system resources? <26>
beq.s @setupApp ; if not, do app setup <26>
move.w CurMap,saveRefNum(a6) ; save current resource file <24>
clr.w -(sp) ; use system <24>
_UseResFile ; <24>
bra.s @doneSetup ; <24>
@setupApp ; <26>
move.l sAppGlobHnd(a6),d0 ; need to lock script app globals?
beq.s @doneSetup ; if not, all done <24><26>
move.l d0,a0
_HLock
@doneSetup
_GetResource ; get the param block.
; <24>
move.l (sp)+,d0 ; did we get a handle? <24>
tst.w ResErr ; error reported? <45>
beq.s @noResErr ; if not, go check handle <45>
clr.l d0 ; if so, force handle to NIL <45>
bra.s @doneErrChk ; <45>
@noResErr ; here, no error was reported <45>
tst.l d0 ; but check if handle is NIL <45>
bne.s @doneErrChk ; if not, ResErr is OK <45>
move.w #resNotFound,ResErr ; otherwise, make it useful <16>
@doneErrChk ; <16>
tst.w d3 ; no cache?
beq.s FinishIntl ; done.
MOVE.W d4,cache.theID(a4) ; update theID (from stack) <2/5/88med>
;;; MOVE.L d0,cache.theHandle(a4) ; cache the handle (no more!!) <24><41>comment out
; Restore the state and unlock the package if necessary.
; Unlink the stack and return to the caller.
FinishIntl
; <24>
MOVE.L d0, result(a6) ; also return the handle <24>
tst.w sysFlag(a6) ; get system resources? <26>
beq.s @doneRestore ; if not, skip restore <26>
move.w saveRefNum(a6),-(sp) ; restore saved resource file <24><26>
_UseResFile ; <24><26>
@doneRestore ; <26>
UnlockIntl
; <10>
move.l sAppGlobHnd(a6),d0 ; need to unlock script app globals?
beq.s @doneAppCleanup ; if not, done app cleanup <24><26>
move.l d0,a0
_HUnlock
; Moved CurMap restore to FinishIntl <26>
@doneAppCleanup ; <26>
DoneIntl ; move above Unlock call <41>
move.b saveResLoad(a6),ResLoad ; restire orig ResLoad <43><45>
FailIntl ; move above Unlock call <41>
BSR UnlockIt
movem.l (sp)+,GetIntl1Regs
unlk a6 ; unlink the stack.
move.l (sp)+,a0 ; pop return address.
add.l #2,sp ; pop the arguments.
jmp (a0) ; return to the caller.
;---------------------------------------------------------------------------------------------------------
; GetScriptItl <11><21>
;
; FUNCTION IUGetScriptItl(theID: INTEGER; script: ScriptCode; sysFlag: INTEGER): Handle;
;
; The following routine is a special interface to GetIntl. In addition
; to the usual 'which' parameter, it expects:
; script: ScriptCode, which may be a special negative code
; sysFlag: 0 for app cache, -1 for sys cache
;
; The following code performs the relevant operations from the initial part of
; GetIntl, modified as necessary, then rejoins GetIntl for the stuff we need.
GetScriptItl
move.l (sp)+,a0 ; pop return address <21>
move.w (sp)+,d1 ; pop sysFlag <21>
move.w (sp)+,d0 ; pop script <21>
move.l a0,-(sp) ; push return address <21>
; Now stack is set up like entry to GetIntl, so we can do the link.
; We also have script in d0, sysFlag in d1
link a6,#giLocals ; link the stack.
movem.l GetIntl1Regs,-(sp)
clr.l result(a6) ; clear result handle.
; clr.l sAppGlobHnd(a6) ; comment out <26>
move.w d1,sysFlag(a6) ; <21>
move.w #resNotFound,ResErr ; assume illegal 'which' arg <21>
move.w which(a6),d2 ; load 'which' argument. <21>
cmp.w #IntlMaxID,d2 ; which > IntlMaxID? <21>
bhi.s FailIntl ; yes -> bail out. <21>
clr.l d3 ; longize
lea CacheOffset,a0 ; point to table of offsets <21>
move.b 0(a0,d2.w),d3 ; get cache offset from table <21>
blt FailIntl ; no resource, bail <21>
; we still have ScriptCode in d0. Map it to real code, check that script <21>
; is installed and enabled, end up with script code in d2, resource ID
; in d4. Leave a4 alone.
with SMgrRecord,ScriptRecord ;
bsr intScriptCodeToReal ; map it to real script code
cmp.w #smgrCount-1,d0 ; valid?
bhi.s FailIntl ; if not, bail
move.w d0,d2 ; save in d2
lsl.w #2,d0 ; make script code a long offset
GetSMgrCore a0 ; SMgrRecord pointer
move.l smgrEntry(a0,d0.w),d0 ; ScriptRecord ptr. Script installed?
beq.s FailIntl ; if not, can't get resource ID
move.l d0,a1 ;
tst.b scriptEnabled(a1) ; script enabled?
beq.s FailIntl ; if not, bail
move.w scriptBundle.itlbSort(a1),d4 ; itl2 resource id
endwith ;SMgrRecord,ScriptRecord ;
; now we have script code in d2, cache offset in d3, resource ID in d4,
; and stack frame set up as needed. Rejoin main GetIntl code.
bra.s GetIntlCommon ; go get itl2 handle
endWith ;giRecord
endWith ;ExpandMemRec
;---------------------------------------------------------------------------------------------------------
; PROCEDURE SetIntl(resFile: INTEGER; theID: INTEGER; theBlock: Handle);
;
; SetIntl appends (or replaces) an INTL parameter block in the resource
; file specified by the "resFile" parameter.
;---------------------------------------------------------------------------------------------------------
;
siRecord record {a6link},decr ; Added frame <1/25/88med>
resFile ds.w 1 ; resource file
theId ds.w 1 ; 0,1
theBlock ds.l 1 ; handle <7/11/88ldc> change from w to l
return ds.l 1 ; return address.
a6link ds.l 1 ; old link pointer.
siLocals equ * ; size of local variables.
endr ;
SetIntlRegs reg D3-D5/A3 ; <18Nov86MED>
SetIntl
with siRecord
link a6,#siLocals ; allocate <1/25/88med>
BSR LockIt
MOVEM.L SetIntlRegs,-(SP) ;save work registers <30Dec85 JTC>
; MOVE.L theBlock(SP),A0 ;get the block handle (was 24 when D1...) <18Dec85 JTC>
; MOVEM.W 24(SP),D3-D4 ;get the ID and resFile (was 28 when D1...) <18Dec85 JTC>
move.w resFile(a6),d4 ; get resource file <1/25/88med>
bne.s @doneFixRequest ;if nonzero, it is a real refNum <31>
move.w SysMap,d4 ;else map it to real refNum for System <31>
@doneFixRequest ;now we have real refNum <31>
move.w theId(a6),d3 ; get id <1/25/88med>
move.l theBlock(a6),a0 ; get the block handle <1/25/88med>
; copy the INTL parameter block into a new handle
_HandToHand ;clone the handle
MOVE.L A0,A3 ;keep the clone in A3
; remember the current resFile and make this one the current one
SUBQ #2,SP ;make room for result
_CurResFile ;remember it on the stack
MOVE.W D4,-(SP) ;push the resFile
_UseResFile ;use this one
; determine if this resource is already in the file; if it is, remove it
SUBQ #4,SP ;make room on stack
MOVE.L #'INTL',-(SP) ;push the INTL type
MOVE.W D3,-(SP) ;push the ID
_GetResource ;get the resource
MOVE.L (SP)+,D5 ;did we get it?
BEQ.S @GoAddIt ;if not, we're cool
; unfortunately, there's already one there, but it might not be in our
; particular file. Check this out using HomeResFile
SUBQ #2,SP ;make room for result
MOVE.L D5,-(SP) ;push the handle
_HomeResFile ;see where it came from
move.w (sp)+,d0 ;get the old INTL's file refNum <31>
bne.s @doneFixHome ;if nonzero, it is a real refNum <31>
move.w SysMap,d0 ;else map it to real refNum for System <31>
@doneFixHome ;now we have real refNum for old INTL <31>
cmp.w d0,d4 ;same as caller's refNum? <31>
BNE.S @GoAddIt ;if not, we're cool
; better remove the resource
MOVE.L D5,-(SP) ;push the handle
_RmveResource ;remove it
; O.K., now we can add the resource to our file
@GoAddIt
MOVE.L A3,-(SP) ;push the handle to be added
MOVE.L #'INTL',-(SP) ;push the type
MOVE.W D3,-(SP) ;push the ID
PEA EmptyString ;push NIL string for name
_AddResource
; make sure we make it purgable
MOVE.L A3,-(SP) ;push the handle
MOVE.W #resPurgeable,-(SP) ;purgeable <31>
_SetResAttrs ;set attributes <31>
MOVE.L A3,-(SP) ;push the handle again <31>
_ChangedResource ;mark it changed (the right way) <31>
; better update the resFile to make sure it gets written out
MOVE.W D4,-(SP) ;push resFile refNum
_UpdateResFile ;update it
MOVE.L A3,A0 ; pass the handle <3/2/87med>
_HPurge ; make it really purgable <3/2/87med>
; BSET #6,(A3) ;make it really purgable <3/2/87med>
; all done with SetINTL; clean up the stack and go home
_UseResFile ;restore old resFile
MOVEM.L (SP)+,SetIntlRegs ;restore work registers <30Dec85 JTC>
unlk a6 ; deallocate frame <1/25/88med>
BSR UnlockIt
MOVE.L (SP)+,A0 ;get the return address
ADDQ #8,SP ;strip parameters
JMP (A0) ;return to caller
endwith ;siRecord ; <11>
;------------------------------------------------------------------------
; Interscript sorting <1.8>
;
; FUNCTION ScriptOrder(script1, script2: ScriptCode): Integer;
;
; For now, this sorts system script first and sorts the rest in
; numerical order of script code. A script code of iuSystemScript
; is mapped to the system script.
;
; FUNCTION LangOrder(language1, language2: LangCode): Integer;
;
; This sorts languages in different scripts by the script. Languages
; in the same script are, for now, just sorted in numerical order.
;
; FUNCTION TextOrder(aPtr, bPtr: Ptr; aLen, bLen: Integer; aScript,
; bScript: ScriptCode; aLang, bLang: LangCode): Integer;
;
; This calls ScriptOrder on the scripts and returns that result if
; nonzero; otherwise it calls LangOrder on the languages and returns
; that result if nonzero; otherwise it gets the itl2 for the script,
; and calls MagPString with that itl2 handle, returning the MagPString
; result.
;------------------------------------------------------------------------
bignum equ 32767 ; largest positive int
noScriptFlag equ bignum
tableHeaderSize equ 4 ; header size in script & font map tables <9>
ScriptOrder
move.l (sp)+,a1 ; save return addr
move.w (sp)+,d2 ; get script 2
move.w (sp)+,d1 ; get script 1
move.l a1,-(sp)
bsr.s intScriptOrder
bra.s OrderExit
LangOrder
move.l (sp)+,a1 ; save return addr
move.w #noScriptFlag,d2 ; no associated script
swap d2 ; put in high word
move.w (sp)+,d2 ; get lang 2
move.w #noScriptFlag,d1 ; no associated script
swap d1 ; put in high word
move.w (sp)+,d1 ; get lang 1
move.l a1,-(sp)
bsr.s intLangOrder
OrderExit
move.w d0,4(sp) ; set result
bra.s UnlockIt ; return from UnlockIt
;---------------------------------------------------------------
; intScriptOrder
; On entry, d1 & d2 contain ScriptCode in low word
; On exit, d0.w contains order result, with cond codes N and Z set appropriately.
; Uses a0-a1,d0-d2, plus saved a2/d3-d4
;
intScriptOrder
with ExpandMemRec ; <9>
movem.l a2/d3-d4,-(sp) ; save regs <9>
cmp.w d1,d2 ; are scripts equal? <9>
beq.s commonOrderEqual ; if so, save a lot of work <9>
intScriptOrderForLangs ; entry point with regs saved <9>
move.l ExpandMem,a2 ; get ExpandMem ptr <9>
move.l emScriptMapPtr(a2),a2 ; get script map data ptr <9>
move.w d2,d4 ; save script2
move.w d1,d0 ; set up to map script1
bsr intScriptCodeToSort ; map it to sort position <9>
move.w d0,d3 ; save mapped value
move.w d4,d0 ; set up to map script2
bsr intScriptCodeToSort ; map it to sort position <9>
move.w d0,d4 ; save mapped value
; intScriptCodeToSort has mapped system script to 0 so it sorts first <9>
endwith ;ExpandMemRec
bra.s commonOrder
;---------------------------------------------------------------
; intLangOrder
; On entry, d1 & d2 contain LangCode in low word, assoc ScriptCode in high word.
; On exit, d0 contains order result, with cond codes N and Z set appropriately.
; Uses a0-a1,d0-d2, plus saved a2/d3-d4
;
intLangOrder
with ExpandMemRec ; <9>
movem.l a2/d3-d4,-(sp) ; save regs <9>
cmp.l d1,d2 ; are langs equal? <9>
beq.s commonOrderEqual ; if so, save a lot of work <9>
move.l ExpandMem,a2 ; get ExpandMem ptr <9>
move.l emLangMapPtr(a2),a2 ; get lang map data ptr <9>
move.l d2,d4 ; save lang2/script2
move.l d1,d0 ; set up to map lang1
bsr intLangCodeToScript ; map to real script code <9>
move.l d0,d3 ; save mapped value
move.l d4,d0 ; set up to map lang2
bsr intLangCodeToScript ; map to real script code <9>
; If real script codes are different, then return sorting order for
; the scripts.
cmp.w d3,d0 ; how do we look? <9>
beq.s @mapLangs ; if same, go map langs. <9>
move.w d3,d1 ; set up for intScriptOrderForLangs <9>
move.w d0,d2 ; " <9>
bra.s intScriptOrderForLangs ; <9>
; Scripts are identical. If lang codes in d0 hi are too, return 0.
@mapLangs
cmp.l d3,d0 ; look at everything.
beq.s commonOrderEqual ; if identical, save some work
bsr intLangScriptToSort ; map lang & script info to sort position <9>
move.w d0,d4 ; save it
move.l d3,d0
bsr intLangScriptToSort ; map lang & script info to sort position <9>
move.w d0,d3 ; save it
; fall through to commonOrder
endwith ;ExpandMemRec ; <9>
;---------------------------------------------------------------
; now return ordering of scripts/langs
commonOrder
moveq #-1,d0 ; assume item1 < item2
cmp.w d4,d3 ; what's the real scoop?
blt.s @2 ; if as assumed, we're done
bgt.s @1 ; if item1 > item2, deal with it
clr.w d0 ; that leaves item1 = item2
bra.s @2 ; and we're done
@1 moveq #1,d0 ; handling item1 > item2
@2 ;tst.w d0 ; not necessary
commonOrderExit
movem.l (sp)+,a2/d3-d4 ; restore temp regs
rts
commonOrderEqual ; <9>
clr.w d0 ; item1 = item2
bra.s commonOrderExit
;---------------------------------------------------------------
; Map ScriptCode value to sort position.
; At entry, d0 contains ScriptCode. a2 points to script map data table.
; At exit, d0 contains sorting position.
; Uses a0-a1,d0-d2.
; Invalid ScriptCodes are mapped to a large number.
;
intScriptCodeToSort
tst.w d0
bge.s @gotScript ; if non-negative, get sort position
addq.w #1,d0 ; is it iuSystemScript (-1)?
beq.s @doneMap ; if it is, already have result
addq.w #1,d0 ; is it iuCurrentScript (-2)?
bne.s @doErr ; no, return error result
subq #2,sp ; leave space for returned script
_RealScript ; NOT IntlScript. Change FontScript to RealScript <33>
move.w (sp)+,d0
; Now have real script code in d0.w, map it to sort position.
@gotScript
cmp.w (a2),d0 ; is our code past end of table?
bgt.s @doErr ; if so, bail
lsl.w #2,d0 ; make a long offset
move.w tableHeaderSize(a2,d0.w),d0 ; get sort position from table
@doneMap
rts
@doErr
move.w #bignum,d0 ; sort at end.
rts
;---------------------------------------------------------------
; Map ScriptCode value to real script code.
; At entry, d0 contains ScriptCode.
; At exit, d0 contains real script code.
; Uses a0-a1,d0-d2.
; Invalid ScriptCodes are mapped to a number larger than 64.
;
intScriptCodeToReal
with SMgrRecord
tst.w d0
bge.s @doneMap ; if non-negative, we-re done
addq.w #1,d0 ; is it iuSystemScript (-1)?
blt.s @getCurrent ; no, check for other codes
GetSMgrCore a0 ; get SMgrRecord pointer
move.w smgrSysScript(a0),d0 ; get system script
rts
@getCurrent
addq.w #1,d0 ; is it iuCurrentScript (-2)?
blt.s @doErr ; no, handle error
subq.w #2,sp ; leave space for returned script
_FontScript ; NOT IntlScript
move.w (sp)+,d0
rts
@doErr
move.w #bignum,d0 ; sort at end.
@doneMap
rts
endwith ;SMgrRecord
;---------------------------------------------------------------
; Map LangCode value to real script code, save info needed to get lang code.
; At entry, d0 lo contains LangCode and d0 hi contains an associated ScriptCode
; (=noScriptFlag if it is meaningless). a2 points to language data map table.
; At exit, d0 lo contains real script code. d0 hi contains a real lang code, or -1 to use
; current language for script in d0 lo, or -2 to use default lang for script in d0 lo.
; Uses a0-a1,d0-d2.
; Invalid LangCodes (or invalid associated ScriptCodes) will produce a large number for
; the real script code and 0 for the real lang code.
;
intLangCodeToScript
with SMgrRecord
tst.w d0
bge.s @realLang ; if non-negative, map lang to script <9>
add.w #1,d0 ; shift to get rid of hole at -1
beq.s @doScriptErr
asr.w #1,d0 ; C = current/default lang bit
scs -(sp) ; save bit state
cmp.w #-3,d0 ; -1,-2,-3 are valid here <9>
bgt.s @mapScript ; handle -1, -2 with intScriptCodeToReal <9>
blt.s @doScriptErrPop ; handle < -3 as err <9>
swap d0 ; set up to map specified script <9>
@mapScript ; <9>
bsr.s intScriptCodeToReal ; map to real script code <9>
cmp.w #smgrCount-1,d0 ; is script ok?
bhi.s @doScriptErrPop ; bail if not
swap d0 ; save how to get lang code
move.w #-1,d0 ; assume current lang
tst.b (sp)+ ; get current or default?
bne.s @doneLangFlag ; if current, flag is ok
move.w #-2,d0 ; set flag to be default
@doneLangFlag
swap d0 ; everything in its proper place
rts
; Map lang code to script code using table. <9>
@realLang
move.w d0,d1 ; copy lang code
swap d0 ; save real lang code in d0 hi
cmp.w (a2),d1 ; is our code past end of table?
bgt.s @doRangeErr ; if so, bail
lsl.w #2,d1 ; make lang code into long offset
move.w tableHeaderSize+2(a2,d1.w),d0 ; get real script code for lang
rts
@doRangeErr
move.w #bignum,d0 ; sort at end (move.w preserves lang code) <9>
rts
@doScriptErrPop
addq.w #2,sp ; remove flag from stack
@doScriptErr
move.l #bignum,d0 ; sort at end, arbitrary lang code <9>
rts
endwith ;SMgrRecord
;--------------------------------------------------------------- <9>
; Map lang and script info to sort position.
; At entry, d0 lo contains real script code. d0 hi contains a real lang code, or -1 to use
; current language for script in d0 lo, or -2 to use default lang for script in d0 lo.
; a2 points to language map data table.
; At exit, d0.w contains sort position.
; Uses a0-a1,d0-d2.
;
intLangScriptToSort
with SMgrRecord,ScriptRecord, ExpandMemRec
move.w d0,d1 ; save script code
swap d0 ; get lang code
tst.w d0 ; (we need cc for just low word)
bpl.s @mapLangToSort ; if positive, it is real, map it
addq.w #1,d0 ; -1 or -2?
bne.s @getDefault
GetSMgrCore a0 ; SMgrRecord pointer
move.w d1,d0 ; copy script code
lsl.w #2,d0 ; make it a long offset
move.l smgrEntry(a0,d0.w),d0 ; ScriptRecord pointer
beq.s @getDefault ; if no ScriptRecord, bail
move.l d0,a0 ; copy
tst.b scriptEnabled(a0) ; script enabled?
beq.s @getDefault ; if not, ScriptRecord not valid
move.w scriptBundle.ItlbLang(a0),d0 ; resource id
bra.s @gotLang
@getDefault
move.l ExpandMem,a0
move.l emScriptMapPtr(a0),a0 ; get script map data ptr <9>
cmp.w (a0),d1 ; is script code past end of table?
bgt.s @doErr ; if so, bail
lsl.w #2,d1 ; make script code a long offset
move.w tableHeaderSize+2(a0,d1.w),d0 ; get default lang from table
@gotLang
; Map lang code in d0.w to sort position using table.
@mapLangToSort
cmp.w (a2),d0 ; is our code past end of table?
bhi.s @doErr ; if so, bail
lsl.w #2,d0 ; make a long offset
move.w tableHeaderSize(a2,d0.w),d0 ; get sort position from table
rts
@doErr
move.w #bignum,d0 ; sort at end. <9>
rts
endwith ;SMgrRecord,ScriptRecord, ExpandMemRec
;------------------------------------------------------------------------
;
; Public routine
;
; IUTextOrder(aPtr, bPtr: Ptr; aLen, bLen: Integer;
; aScript, bScript: ScriptCode; aLang, bLang: LangCode);
;
; Private routine. <10>
; • IUTextOrderSys uses the system itl cache (instead of the app itl cache)
; to get handle for the itl2 resource.
;
; IUTextOrderSys(aPtr, bPtr: Ptr; aLen, bLen: Integer;
; aScript, bScript: ScriptCode; aLang, bLang: LangCode);
;
; Unimplemented but possible private routine. <10>
; • IUTextOrderHndl uses a specifed 'itl2' handle. We only use the handle
; to compare strings if script and language are identical, so we only need
; one handle.
;
; IUTextOrderHndl(aPtr, bPtr: Ptr; aLen, bLen: Integer;
; aScript, bScript: ScriptCode; aLang, bLang: LangCode;
; sortHandle: Handle);
;
;------------------------------------------------------------------------
toRecord record {a6link},decr ; <2.0>
result ds.w 1 ; result.
toArgs equ *-8 ; size of arguments <2.0>
aStr ds.l 1 ; aStr pointer.
bStr ds.l 1 ; bStr pointer.
aLen ds.w 1 ; aStr length
bLen ds.w 1 ; bStr length
toXtraArgs equ *-8 ; size of extra args over MagString <2.0>
aScript ds.w 1 ; aStr script
bScript ds.w 1 ; bStr script
aLang ds.w 1 ; aStr language
bLang ds.w 1 ; bStr language
return ds.l 1 ; return address.
a6link ds.l 1 ; saved a6 reg <2.0>
sysFlag ds.w 1 ; non-zero => use sys itl cache <10>
toLocals equ * ; <2.0>
endr
export TextOrder ; <30>
with toRecord
TextOrder
link a6,#toLocals ; <2.0>
clr.w sysFlag(a6) ; <10>
bra.s TextOrderCommon ; <10>
TextOrderSys ; <10>
link a6,#toLocals ; <10>
move.w #-1,sysFlag(a6) ; <10>
TextOrderCommon ; <10>
; check scripts
move.w aScript(a6),d1 ; get script1 <2.0>
move.w bScript(a6),d2 ; get script2 <2.0>
bsr.s intScriptOrder
bne.s @exit ; if so, we're done
; check languages
move.w aScript(a6),d1 ; get associated script for lang1 <2.0>
swap d1 ; put it in high byte <2.0>
move.w aLang(a6),d1 ; get lang1 <2.0>
move.w bScript(a6),d2 ; get associated script for lang2 <2.0>
swap d2 ; put it in high byte <2.0>
move.w bLang(a6),d2 ; get lang2 <2.0>
bsr.s intLangOrder
beq.s @tryText ; if not, go compare text
@exit
move.w d0,result(a6) ; otherwise, set result <2.0>
unlk a6 ; unlink stack <2.0>
move.l (sp)+,a0 ; pop return addr
add.w #toArgs,sp ; kill args
move.l a0,-(sp) ; push return addr
bra.s UnlockIt ; return from UnlockIt
; Both strings have same script and language; have to actually compare them!
; Create a stack frame for MagPString and go there. Use GetItlScript to get <21>
; itl2 handle from cache, using specified script.
@tryText
with ExpandMemRec ; <40>
sub.l #4,sp ; make room for the itl handle. <11>
move.w #2,-(sp) ; push 'which' argument for itl2. <11>
move.w aScript(a6),-(sp) ; push ScriptCode <21>
move.w sysFlag(a6),-(sp) ; push sysFlag <21>
move.l ExpandMem,a0 ; ExpandMem ptr <40>
addq.b #1,emItlDontUnlockYet(a0) ; say this is internal call <40>
bsr GetScriptItl ; get itl handle (does it all now) <11><21>
move.l ExpandMem,a0 ; ExpandMem ptr <40>
subq.b #1,emItlDontUnlockYet(a0) ; end of internal call <40>
move.l (sp)+,a1 ; pop handle into a1 (null if err) <11>
endwith ;ExpandMemRec ; <40>
@cleanUp
unlk a6 ; unlink stack <2.0>
move.l (sp)+,a0 ; temporarily pop return
addq #toXtraArgs,sp ; destroy extra args
move.l a1,-(sp) ; push itl2 Handle for MagPString
move.l a0,-(sp) ; and push return.
bra MagPString ; someone else's job now…
endwith ;toRecord
;------------------------------------------------------------------------
; FUNCTION MagString (A,B:str255; Alen,Blen:integer): integer;
; FUNCTION MagIdString(A,B:str255; Alen,Blen:integer): integer;
;
; Designed for international flavors of magnitude string comparison
; by J. Coonen 27 Oct 83.
;
;------------------------------------------------------------------------
;------------------------------------------------------------------------
; Macro: CallHook
; Input: a4.l international hooks parameter block (itl2).
; Warning: This routine trashes d0.
; This routine does not return directly.
;
; Calls one of the new hook routines from itl2 to perform special
; processing for sorting algorithm.
;------------------------------------------------------------------------
MACRO
CallHook &offset
move.w &offset(a4),d0
jsr 0(a4,d0.w) ; go and return from there.
ENDM
;------------------------------------------------------------------------
;
; In adding the Script Manager support, we call routines that trash the
; standard scratch regs, so we remap the register usage. MED
;
; d0 scratch
; d1 scratch
; d2 scratch/temporary storage for return value
; d3 end-of-strings: 2-both empty, 1-one empty, 0-neither empty
; d4 character return (now two byte)
; d5 eos (fetch)/low byte(vernier)
; d6 temporary storage
;
; a0 scratch
; a1 scratch
; a2 string data structure/deciding char (vernier)
; a3 string pointer/table ptr (vernier,proj,lig)
; a4 hook international parameter block (ITL2).
;
;------------------------------------------------------------------------
; Start code: allocate string data structures and save a4 for hook block
; resource handle (using Andy's routine).
;------------------------------------------------------------------------
; 5/15/87 <daan> Massive reorganization, renaming, and optimizing to
; squeeze as much out o' this puppy as we can. It worked.
; <1.8> Added MagPString and MagIdPString
;------------------------------------------------------------------------
with IUNSortFrame,IUStrData ; Use IUNSortFrame <4>
SortRegs reg D3-D6/A2-A4 ; <18Nov86MED>
MagWString ; <22Mar86 MED>
LINK A6,#LkSize ; <22Mar86 MED>
CLR.B WantMag(A6) ; mark weak identity compare only <22Mar86 MED>
st WeakMag(a6) ; mark as weak identity compare <22Mar86 MED>
move.w #-1, d2 ; return for less than <6/27/88ldc>
clr.l itl2Handle(a6) ; no itl2 handle supplied <2>
BRA.S ComWString ; <22Mar86 MED>
; 3 new entry points for System 7 <1.8>
MagWPString ; <5>
MOVE.L (SP)+,D0 ; get return address <5>
MOVE.L (SP)+,A0 ; get parameter handle <5>
MOVE.L D0,-(SP) ; replace return address <5>
LINK A6,#LkSize ;
CLR.B WantMag(A6) ; mark weak identity compare only
st WeakMag(a6) ; mark as weak identity compare
move.w #-1, d2 ; return for less than
move.l a0,itl2Handle(a6) ; save supplied itl2 handle <5>
BRA.S ComWString ;
MagIdPString ; <1.8>
MOVE.L (SP)+,D0 ; get return address <1.8>
MOVE.L (SP)+,A0 ; get parameter handle <1.8>
MOVE.L D0,-(SP) ; replace return address <1.8>
LINK A6,#LkSize
CLR.B WantMag(A6) ; mark weak identity compare only
move.w #1, d2 ; '<' value for EqualString
; which only returns 0 or 1
move.l a0,itl2Handle(a6) ; save supplied itl2 handle <1.8>
BRA.S ComString
MagPString ; <1.8>
MOVE.L (SP)+,D0 ; get return address <1.8>
MOVE.L (SP)+,A0 ; get parameter handle <1.8>
MOVE.L D0,-(SP) ; replace return address <1.8>
LINK A6,#LkSize
MOVE.B #1,WantMag(A6) ; true mag compare
move.w #-1, d2 ; allows -1 for '<'
move.l a0,itl2Handle(a6) ; save supplied itl2 handle <1.8>
BRA.S ComString
MagIdString
LINK A6,#LkSize
CLR.B WantMag(A6) ; mark weak identity compare only
move.w #1, d2 ; '<' value for EqualString
; which only returns 0 or 1 <6/27/88ldc>
clr.l itl2Handle(a6) ; no itl2 handle supplied <1.8>
BRA.S ComString
MagString
LINK A6,#LkSize
MOVE.B #1,WantMag(A6) ; true mag compare
move.w #-1, d2 ; allows -1 for '<' <6/27/88ldc>
clr.l itl2Handle(a6) ; no itl2 handle supplied <1.8>
ComString
sf WeakMag(a6) ; mark as strong identity compare <22Mar86 MED>
;-------------------------------------------------------------------------------
; 5/15/87 <daan> Advance pointers so far as the two strings are equal. If they
; happen to be exactly equal to the end, then so much the better; forget the
; expensive resource loading and initializations, set the status and exit.
;-------------------------------------------------------------------------------
ComWString
MOVEA.L AStrText(a6),a0 ; a string pointer
MOVEA.L BStrText(a6),a1 ; b string pointer
MOVE.W AStrLen(a6),d0 ; a length
BNE.S @1 ; remove null cases
MOVE.W BStrLen(a6),d1 ; b length
BEQ.S QuickExit ; = 0 also
MOVEQ.L #-1,d0 ; <> 0 so a < b
BRA.S QuickExit
@1 MOVE.W BStrLen(a6),d1 ; b length
BNE.S @2 ; <> 0 either
MOVEQ.L #1,d0 ; = 0 so a > b
BRA.S QuickExit
@2 CMP.W d0,d1 ; can mag(a) = mag(b)?
BNE.S NotShortEQ ; mags not trivially equal
SUBQ.W #1,d0 ; loop optimize
@3 CMPM.B (a0)+,(a1)+ ; check equality
DBNE d0,@3 ; branch if strings not exhausted
BNE.S FixLength ; didn't run out of characters
MOVEQ.L #0,d0 ; did run out; mag(a) = mag(b)
QuickExit
MOVE.W d0,result(a6) ; comparison result
bpl.s @doQuick ; check for -1 because
; IUEqualString replaces -1 with 1
; <6/27/88ldc> fix so that IUEqualString only returns 0 and 1
move.w d2, result(a6) ; d2 contains 1 if this is IUEqualString
@doQuick
bsr UnlockIt ; might have been locked by this point <40>
UNLK A6 ; clean up stack and quit
MOVEA.L (sp)+,a0
ADDA.W #ParamBytes,sp
JMP (a0)
QuickPopExit ; <16>
MOVEM.L (sp)+,SortRegs ; restore work regs <16>
moveq.l #0,d0 ; say strings are equal <16>
bra.s QuickExit ; and return <16>
FixLength
ADDQ.W #1,d0 ; repair lengths
MOVE.W d0,d1
BRA.S MainComp
NotShortEQ
SUBQ.W #1,d0 ; loop optimization
@1 CMPM.B (a0)+,(a1)+ ; check equality
BNE.S @2 ; no match
SUBQ.W #1,d1
DBEQ d0,@1 ; branch iff neither exhausted
BNE.S QuickExit ; string A ran out; d0 = -1
MOVEQ.L #1,d0 ; string B ran out; quickexit
BRA.S QuickExit
@2 ADDQ.W #1,d0 ; repair length
MainComp
SUBA.L #1,a0 ; repair addresses
SUBA.L #1,a1
MOVEM.L SortRegs,-(SP) ; use D3&A4 as temp cells <18Dec85 JTC>
MOVE.W d0,AInfo.StrCnt(A6)
MOVE.W d1,BInfo.StrCnt(A6)
MOVE.L a0,AInfo.StrPtr(A6)
MOVE.L a1,BInfo.StrPtr(A6)
CLR.L AInfo.BufChar(A6) ; nil buffer on input, false JustA, IgnChar
CLR.L BInfo.BufChar(A6) ; nil buffer on input, false JustA, IgnChar
move.l itl2Handle(a6),d0 ; <1.8><26>
beq.s @useDefault ; <26>
move.l d0,a0 ; <26>
move.l (a0),a4 ; get pointer <26>
move.l a4,d0 ; resource purged? <26>
bne.s @gotPointer ; if not, pointer ok, continue <26>
move.l a0,a4 ; copy handle <26>
bsr LockIt ; gonna move memory, lock ourselves down <40>
move.l a4,-(sp) ; <26>
_LoadResource ; load resource <26>
tst.w ResErr ; any errs? <26>
beq.s @gotHandle ; if not, handle ok, continue <26>
@useDefault ; <26>
moveq #2,d0 ; get ITL2 for hooks. <28Aug86 JDT>
bsr GetTheINTL ; puts ITL2 handle in a4.
beq QuickPopExit ; bail if can't load itl2 resource <16>
@gotHandle ; <1.8><26>
movea.l (a4),a4 ; dereference handle
@gotPointer ; <26>
; Initialize the Sorting Hooks stuff.
CLR.B WeakEq(A6) ; initialize flag
CallHook InitHook ; call InitHook routine. <28Aug86 JDT>
BRA.S MagLoop
;------------------------------------------------------------------------
; MOVED HERE FOR PROXIMITY (Formerly TwoMoreChars)
; When both strings have more characters, do a first compare for the
; easy case of equality. Otherwise, project the characters onto their
; so-called rows and compare. If their projections differ, duck soup.
; Else mark the strings as equivalent, if they haven't been so marked
; already.
;------------------------------------------------------------------------
CompareChars
CMP.W D4,D6 ; D4-B D6-A
BEQ.S MagLoop ; look no further
LEA BInfo(A6),A2 ; B data structure
BSR ProcessChar ; Mapped char in d4
LEA AInfo(A6),A2 ; A data structure
BSR ProcessChar ; Mapped char in d4
;------------------------------------------------------------------------
; After processing, if mapped characters differ, then the comparison is
; unambiguous.
;------------------------------------------------------------------------
CMP.W BInfo.MapChar(A6),D4 ; compare second char.
beq.s MappedEqual
; check for tweeking. If either char is ignorable, the string is weakly equal.
move.b AInfo.IgnChar(a6),d0 ; A ignore flag
or.b BInfo.IgnChar(a6),d0 ; B ignore flag
bne.s @1 ; at least one ignorable
CMP.W BInfo.MapChar(A6),D4 ; set status codes
bra.s MagFiniNE ; and exit
; also, fix the noFetch flags for next fetch.
; if A has an ignorable, don't fetch B's next char, and vv (unless both are ignore)
@1
move.b AInfo.IgnChar(a6),d0 ; ignorable?
move.b BInfo.IgnChar(a6),d1 ; ignorable?
not.b d0 ; reverse
move.b d0,AInfo.NoFetch(a6) ; store
not.b d1 ; reverse
move.b d1,BInfo.NoFetch(a6) ; store
;------------------------------------------------------------------------
; If the mapped characters are equal, save any necessary state.
;------------------------------------------------------------------------
MappedEqual
TST.B WeakEq(A6)
BNE.S MagLoop ; already weakly equal
ADDQ.B #1,WeakEq(A6) ; set up proper state
MOVE.W AInfo.CurChar(A6),AInfo.DecChar(A6)
MOVE.W BInfo.CurChar(A6),BInfo.DecChar(A6)
;------------------------------------------------------------------------
; Fetch a character from each string, checking for end of string, and
; make the quick check for bit equality.
;------------------------------------------------------------------------
MagLoop
LEA AInfo(A6),A2 ; string A data structure
BSR FetchChar
MOVE.W D4,D6 ; copy character
MOVE.B D5,D3 ; end of string indicator
LEA BInfo(A6),A2 ; string B data structure
BSR FetchChar
ADD.B D5,D3 ; 2-both empty 1-one empty
; 0-neither empty
BEQ.S CompareChars
SUBQ.B #2,D3
BEQ.S NoMorechars
;------------------------------------------------------------------------
; Fall through to here when just one string is exhausted.
;
; Deal specially with ignore characters.
; If we are weakly equal,
; the non-exhausted string has the ignore flag on,
; and the non-exhausted string has all ignorable characters afterward,
; then we are still weakly equal
;------------------------------------------------------------------------
move.b d5,d3 ; save status
TST.B WeakEq(A6) ; set status code
BEQ.S OneStrDone
LEA AInfo(A6),A2 ; assume string A data structure
tst.b d5 ; B exhausted?
bne.s @1 ; yes
LEA BInfo(A6),A2 ; string B data structure
@1
bra.s @3 ; map the last char
@2
BSR FetchChar ; get character
tst.b d5 ; exhausted?
bne.s CheckNoMore ; yes, check weak flags
@3
BSR ProcessChar ; map it, find if ignorable
tst.b IgnChar(a2) ; is it?
bne.s @2 ; yes, keep looping
OneStrDone
;------------------------------------------------------------------------
; Trick: since D3 is 0 if B is nonempty and 1 if B is empty,
; corresponding to A<B and A>B, respectively, just double D5 and
; compare with #1 immediate to get proper result.
; No special care required for MagIdCompare -- they're always unequal.
;------------------------------------------------------------------------
ADD.B D3,D3 ; 0-B full 2-B empty
CMPI.B #1,D3
;------------------------------------------------------------------------
; Finally, store -1,0,1 in result field according to A<B, A=B, A>B.
; If just comparing for identity, force absolute(result) into D0.
;------------------------------------------------------------------------
MagFini
BEQ.S MagFiniEQ
MagFiniNE
BCS.S @2 ; unsigned less than
@1
MOVEQ #1,D0 ; greater-than code
BRA.S MagExit
@2
tst.b WeakMag(a6) ; weak compare? <22Mar86 MED>
bne.s @25 ; yes, skip force <22Mar86 MED>
TST.B WantMag(A6)
BEQ.S @1 ; just force 1 for unequal
@25
MOVEQ #-1,D0 ; less-than code
BRA.S MagExit
MagFiniEQ
MOVEQ #0,D0 ; equal code
;------------------------------------------------------------------------
; Exit code.
;------------------------------------------------------------------------
MagExit
MOVE.W D0,result(a6) ; return result
CallHook ExitHook ; <28Aug86 JDT>
BSR UnlockIt ; unlock the package
MOVEM.L (sp)+,SortRegs ; restore work regs <18Dec85 JTC>
UNLK a6
MOVEA.L (sp)+,a0
ADDA.W #ParamBytes,sp
JMP (a0)
;------------------------------------------------------------------------
; When both strings are exhuasted simultaneously, either:
; WeakEq = 1, in which case row-relation must be arbitrated, subject
; to the JustAfter flag; or
; WeakEq = 0, in which case the strings are in fact equal.
; In the former case, if WantMag is set, then presume equality.
;------------------------------------------------------------------------
NoMoreChars
TST.B WeakEq(A6)
BEQ.S MagFiniEQ
CheckNoMore
TST.B WantMag(A6)
BEQ.S MagFiniEQ
LEA AInfo.DecChar(A6),A2 ; get deciding char
BSR.S VernierChar
MOVE.W D4,D6 ; save off
LEA BInfo.DecChar(A6),A2
BSR.S VernierChar
CMP.W D4,D6 ; compare as A-B
BNE.S MagFiniNE
;------------------------------------------------------------------------
; If both row characters are equal, decide with JustAfter flag:
; A=0 B=0 A=B
; A=0 B=1 A<B
; A=1 B=0 A>B
; A=1 B=1 A=B
; So the condition bits can be set properly just by comparing the flags!
;------------------------------------------------------------------------
MOVE.B AInfo.JustAfter(A6),D0
CMP.B BInfo.JustAfter(A6),D0
BRA.S MagFini
;------------------------------------------------------------------------
; FUNCTION VernierChar
; Input: A2 = pointer to relevant DecChar
;
; Vernier tuning of characters within rows.
; The default ordering for diacriticals is:
; acute -- '
; grave -- `
; circumflex -- ^
; umlaut -- <double dot>
; tilde -- ~
; circle -- <like the A in Angstrom>
; slash -- / <Swedish>
; cedilla -- ,
;
; The general ordering for letters is thus:
; A A' `A A^ A-umlaut A~ A-circle A/ A, a a' `a a^ ...
;
; Since most of the accented characters are correctly ordered in the
; character mapping, some simple adjustments are required. Adding $22
; to a lower-case letter forces it between its accented CAPS and accented
; lowers. The four letters requiring special treatment are:
; O-slash $AF --> $88
; A-grave $CB --> $7F
; A-tilde $CC --> $80 followed by low-order $80 to force between
; $80 and $81
; O-tilde $CD --> $86
; If the CurChar has nonzero low-order information, Vernier just maps
; to CurChar.
;------------------------------------------------------------------------
VernierChar
MOVE.B (A2)+,D4 ; hi byte of DecChar
MOVE.B (A2),D5 ; low byte
CallHook VernierHook
bne.s @9 ; skip other vernier
tst.b d5 ; special char?
bne.s @9 ; skip other vernier
LEA VernTable,A3 ; tuning table
CMP.B (A3)+,D4 ; less than lower a
BCS.S @9
CMP.B (A3)+,D4 ; greater than lower z
BHI.S @3
ADDI.B #$22,D4 ; magic translation
BRA.S @9
@3
CMP.B (A3)+,D4 ; is it in list now?
BEQ.S @8
ADDQ.L #2,A3 ; skip over hi and low
TST.B (A3)
BNE.S @3
BRA.S @9 ; no sub at all
@8
MOVE.B (A3)+,D4
MOVE.B (A3),D5
@9
LSL.W #8,D4 ; put hi and low together
OR.B D5,D4
RTS
;------------------------------------------------------------------------
; The vernier table consists of byte pairs for final tweaking.
;------------------------------------------------------------------------
VernTable
dc.b $61 ; 'a' for lower-case test
dc.b $7B ; '{' = 'z'+1 for lower-case test
dc.b $AF, $87, $00 ; O-slash ---> after O-tilde
dc.b $CB, $7E, $00 ; A` - redo to fit with stuff below <03/10/89 pke>
dc.b $CC, $80, $01 ; A-tilde ---> between A-umlaut and A-circle
dc.b $CD, $86, $00 ; O-tilde ---> after O-umlaut
dc.b $83, $70, $00 ; redo É to fit with stuff below <03/10/89 pke>
; added support for char set extensions <03/10/89 pke>
dc.b $E5, $7F, $00 ; Â
dc.b $E6, $72, $00 ; Ê
dc.b $E7, $7D, $00 ; Á
dc.b $E8, $73, $00 ; Ë
dc.b $E9, $71, $00 ; È
dc.b $EA, $80, $00 ; Í
dc.b $EB, $82, $00 ; Î
dc.b $EC, $83, $00 ; Ï
dc.b $ED, $81, $00 ; Ì
dc.b $EE, $80, $00 ; Ó
dc.b $EF, $82, $00 ; Ô
dc.b $F1, $81, $00 ; Ò
dc.b $F2, $80, $00 ; Ú
dc.b $F3, $82, $00 ; Û
dc.b $F4, $81, $00 ; Ù
dc.b $F5, $8B, $00 ; ı (change to 'i' + $22)
dc.b $00, $00 ; stop codes
align ; <3>
;------------------------------------------------------------------------
; FUNCTION FetchChar
; Input: A2 = string data structure
; Output: D4.B = next character
; D5 = nonzero iff string exhausted
; CurChar, StrPtr, IgnChar reset
;
; Note that expansion presumes that second character is not ASCII NULL.
; Note that expansion character is a byte only.
;------------------------------------------------------------------------
; 5/15/87 <daan> Reorganized, optimized, and bug-fixed.
;------------------------------------------------------------------------
FetchChar
clr.b ignChar(a2) ; reset ignChar <2.1>
MOVEQ #0,D5 ; presume string non0
tst.b NoFetch(a2) ; ignorable?
bne.s @20 ; yes, skip
MOVE.B BufChar(A2),D4 ; presume char from buf
bne.s @15 ; get a char unless one is waiting
MOVEA.L StrPtr(A2),A3
MOVE.B (A3)+,d4 ; get a character regardless
lsl.w #8,D4 ; put char in upper byte
SUBQ.W #1,StrCnt(A2) ; decrement string length (Z cleared iff ≠)
addx.w d5,d5 ; set x=1 if string len = 0
CallHook FetchHook ; call fetch hook: return d4,a3,d5
MOVE.L A3,StrPtr(A2)
move.w d4,CurChar(a2) ; save input char
rts
@15
lsl.w #8,D4 ; put char in upper byte
clr.b BufChar(A2) ; kill buffered char
move.w d4,CurChar(a2) ; save input char
rts
@20
clr.b NoFetch(a2) ; not any more, it ain't
move.w CurChar(a2),d4 ; get same char
rts
;------------------------------------------------------------------------
; After a byte is input, it is mapped to a family character (e.g. all
; A's and a's are mapped to 'A'), and expanded if one of the ligatures
; AE, ae, OE, oe. Then the Info structure is passed to the international
; routine for one last chance to tweak.
;------------------------------------------------------------------------
ProcessChar
; just fall into...
;------------------------------------------------------------------------
; FUNCTION projectChar
; Input: A2 = string data structure
; Output: D4 = Mapped character
;
; Uses table for all values.
; If the CurChar has any nonzero tail, then set MapChar := CurChar.
; Special processing for double-byte characters
;------------------------------------------------------------------------
projectChar
CLR.W MapChar(A2) ; clear hi/low halves
move.w CurChar(a2),d4 ; get current
CallHook ProjectHook ; call it
bne.s SkipProject ; skip if NE
lsr #8,d4 ; get char in lower byte
MOVE.B ProjTable(D4),D4 ; look up mapping
; then fall through to...
CMP.B LigTable(PC),D4 ; ligature iff $AE
bne.s ProjectD4 ; fix D4 and return <12/22/87med>
;------------------------------------------------------------------------
; PROCEDURE xLigature
; Input: D4 = MapChar hi byte; A2 = string data structure
;
; <03/10/89 pke> added ß, fi, fl. Need to turn this into a loop, get
; count from table, used defined constant to mark
; ligature above and in ProjTable.
;------------------------------------------------------------------------
xLigature
LEA LigTable,A3
MOVE.B CurChar(A2),D4 ; restore character
CMP.B (A3)+,D4 ; AE
BEQ.S @18
ADDQ.L #3,A3
CMP.B (A3)+,D4 ; ae
BEQ.S @18
ADDQ.L #3,A3
CMP.B (A3)+,D4 ; OE
BEQ.S @18
ADDQ.L #3,A3
CMP.B (A3)+,D4 ; oe
BEQ.S @18
ADDQ.L #3,A3
CMP.B (A3)+,D4 ; ß
BEQ.S @18
ADDQ.L #3,A3
CMP.B (A3)+,D4 ; fi
BEQ.S @18
ADDQ.L #4,A3 ; fl, by default
@18
MOVE.B (A3)+,CurChar(A2)
MOVE.B (A3)+,D4
MOVE.B (A3),BufChar(A2)
TST.B WeakEq(A6) ; only set JustAfter if not yet we <12/22/87med>
BNE.S ProjectD4 ; already weakly equal <12/22/87med>
ADDQ.B #1,JustAfter(A2)
ProjectD4
asl.w #8,d4 ; restore to high byte <12/22/87med>
SkipProject
MOVE.W D4,MapChar(A2) ; hi-order MapChar
rts
;------------------------------------------------------------------------
; Table of default ligature expansions.
;------------------------------------------------------------------------
LigTable
dc.b $AE, 'A', 'A', 'E' ; note: $AE must be first
dc.b $BE, 'a', 'A', 'e'
dc.b $CE, 'O', 'O', 'E'
dc.b $CF, 'o', 'O', 'e'
dc.b $A7, 's', 'S', 's' ; ß <03/10/89 pke>
dc.b $DE, 'f', 'F', 'i' ; fi <03/10/89 pke>
dc.b $DF, 'f', 'F', 'l' ; fl <03/10/89 pke>
;------------------------------------------------------------------------
; Table projecting all byte values into 'rows':
; -- All letters are mapped to the CAPITAL form, sans diacriticals.
; -- Non-breaking space is mapped to space.
; -- All double quotes are mapped to ASCII double quote $22.
; -- All single quotes are mapped to ASCII single quote $27
; (this doesn't include acute $AB and ASCII grave $60).
; -- All AE/OE/fi/fl/ß ligatures are mapped to ligature-AE $AE.
; -- Superscripted, underscored a and o ($BB and $BC) are symbols,
; and thus mapped to themselves rather than 'A' and 'O'.
; -- Em-dash and minus sign ($D0 and $D1) are mapped to selves rather
; than ASCII hyphen $2D.
; -- All other characters in $00 to $FF are mapped to themselves.
;------------------------------------------------------------------------
ProjTable
dc.b $00, $01, $02, $03, $04, $05, $06, $07
dc.b $08, $09, $0A, $0B, $0C, $0D, $0E, $0F
dc.b $10, $11, $12, $13, $14, $15, $16, $17
dc.b $18, $19, $1A, $1B, $1C, $1D, $1E, $1F
dc.b ' ', '!', '"', '#', '$', '%', '&', $27 ; $20
dc.b '(', ')', '*', '+', ',', '-', '.', '/'
dc.b '0', '1', '2', '3', '4', '5', '6', '7'
dc.b '8', '9', ':', ';', '<', '=', '>', '?'
dc.b '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G' ; $40
dc.b 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O'
dc.b 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W'
dc.b 'X', 'Y', 'Z', '[', '\', ']', '^', '_'
dc.b '`', 'A', 'B', 'C', 'D', 'E', 'F', 'G' ; $60
dc.b 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O'
dc.b 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W'
dc.b 'X', 'Y', 'Z', '{', '|', '}', '~', $7F
dc.b 'A', 'A', 'C', 'E', 'N', 'O', 'U', 'A' ; $80
dc.b 'A', 'A', 'A', 'A', 'A', 'C', 'E', 'E'
dc.b 'E', 'E', 'I', 'I', 'I', 'I', 'N', 'O'
dc.b 'O', 'O', 'O', 'O', 'U', 'U', 'U', 'U'
dc.b $A0, $A1, $A2, $A3, $A4, $A5, $A6, $AE ; ß is ligature <03/10/89 pke>
dc.b $A8, $A9, $AA, $AB, $AC, $AD, $AE, 'O'
dc.b $B0, $B1, $B2, $B3, $B4, $B5, $B6, $B7
dc.b $B8, $B9, $BA, $BB, $BC, $BD, $AE, 'O'
dc.b $C0, $C1, $C2, $C3, $C4, $C5, $C6, $22 ; note: $22 = "
dc.b $22, $C9, ' ', 'A', 'A', 'O', $AE, $AE
dc.b $D0, $D1, $22, $22, $27, $27, $D6, $D7
dc.b 'Y', 'Y', $DA, $DB, $DC, $DD, $AE, $AE ; add Ÿ & fi,fl ligatures <03/10/89 pke>
dc.b $E0, $E1, $E2, $E3, $E4, 'A', 'E', 'A' ; add Â,Ê,Á
dc.b 'E', 'E', 'I', 'I', 'I', 'I', 'O', 'O' ; add Ë,È,Í,Î,Ï,Ì,Ó,Ô <3/10/89 pke>
dc.b $F0, 'O', 'U', 'U', 'U', 'I', $F6, $F7 ; add Ò,Ú,Û,Ù,ı <03/10/89 pke>
dc.b $F8, $F9, $FA, $FB, $FC, $FD, $FE, $FF
endWith ; iuSortFrame/iuNSortFrame, IUStrData
endProc
;---------------------------------------------------------- <7>
;
; PROCEDURE TypeSelectClear(VAR tsr: TypeSelectRecord);
;
; clears/initials the tsr record.
;
;----------------------------------------------------------
TypeSelectClear PROC EXPORT
move.l (sp)+,a0 ; get return address
move.l (sp)+,a1 ; get tsr pointer
moveq #0,d0
move.l d0,TypeSelectRecord.tsrLastKeyTime(a1) ; clear timer
move.b d0,TypeSelectRecord.tsrKeyStrokes(a1) ; clear text
jmp (a0)
ENDPROC
;----------------------------------------------------------------------
;
; FUNCTION TypeSelectNewKey(theEvent: EventRecord;
; VAR tsr: TypeSelectRecord): BOOLEAN;
;
; Call this each time you get a key down event for a type select list.
; If it returns true then you should change selection to the closest
; match in tsr. It handles timeouts, and delete/clear keys.
;
;----------------------------------------------------------------------
TypeSelectNewKey PROC EXPORT
kMaxTypeDelay EQU 60 ; if auto repeat is turn off, then value to use
chClear EQU $1B ; clear key on keypad happens to have same char code as ESC
chDelete EQU $08 ; aka backspace
StackFrame RECORD {A6Link},DECR
result DS.W 1
paramSize EQU *-8 ; bytes of prameters to remove on return
theEvent DS.L 1
tsr DS.L 1
ReturnAddr DS.L 1
A6Link DS.L 1
; locals go here
ALIGN
size EQU * ; size to link
ENDR
EventRecord RECORD 0
what DS.W 1
message DS.L 1
when DS.L 1
where DS.W 2
modifiers DS.W 1
ENDR
link a6,#StackFrame.size
movem.l a3/a4,-(sp) ; save registers
move.l StackFrame.theEvent(a6),a4 ; get theEvent
move.l StackFrame.tsr(a6),a3 ; get tsr pointer
clr.b StackFrame.result(a6) ; set return to false by default
; only do somthing if event is a keydown
cmp.w #keyDwnEvt,EventRecord.what(a4)
bne @done ; if not really key down, then done
; and not a command-key
btst #cmdKey,EventRecord.modifiers(a4)
bne.s @clearTyping ; if command key down, then clear buffer?
; delete or clear key means clear buffer
move.b EventRecord.message+3(a4),d0 ; get character
cmp.b #chDelete,d0 ; is this Delete/Backspace?
bne.s @notDelete
@clearTyping move.l a3,-(sp)
bsr.s TypeSelectClear
bra.s @done
@notDelete cmp.b #chClear,d0 ; is this Clear? ### should I check keycode?
beq.s @clearTyping
; get max delay since last key stroke
move.w keyThresh,d0 ; get threshhold 'til auto-repeat
cmp.w #kMaxTypeDelay,d0
bls.s @autoRepeatOn ; if large, then it is turned off
move.w #kMaxTypeDelay,d0 ; so use resonably long delay instead
@autoRepeatOn add.l d0,d0 ; use 2x keythreshold
; check time since last keystroke
move.l EventRecord.when(a4),d1 ; get time of this key stroke
sub.l TypeSelectRecord.tsrLastKeyTime(a3),d1 ; get time since last key stroke
cmp.l d0,d1 ; see if key strokes close enough together
bls.s @checkScript ; if not reset buffer and start with this key
move.l a3,-(sp)
bsr.s TypeSelectClear
; check if keyboard script has changed
@checkScript subq #4,sp ; space for long
move.w #smKeyScript,-(sp) ; ask for current keyboard script
_GetEnvirons ; from script manager
move.l (sp)+,d0 ; get long result, script in low word
; always treat Roman keyboard like system script <29>
bne.s @doneRomanAdjust ; <29>
subq #4,sp ; space for long <29>
move.w #smSysScript,-(sp) ; ask for system script <29>
_GetEnvirons ; from script manager <29>
move.l (sp)+,d0 ; get long result, script in low word <29>
@doneRomanAdjust ; <29>
tst.b TypeSelectRecord.tsrKeyStrokes(a3) ; will this be first byte in buffer? <8>
bne.s @compareScript ; <8>
move.w d0,TypeSelectRecord.tsrScript(a3) ; if so initialize script for this string <8>
bra.s @addNewKey ; <8>
@compareScript cmp.w TypeSelectRecord.tsrScript(a3),d0 ; has keyboard script changed?
beq.s @addNewKey
move.l a3,-(sp)
bsr TypeSelectClear
; add key stroke to buffer
@addNewKey lea TypeSelectRecord.tsrKeyStrokes(a3),a0
cmp.b #63,(a0) ; check for overflow
bge.s @done
addq.b #1,(a0) ; increment string buffer
moveq #0,d0
move.b (a0),d0 ; get end index
add.l d0,a0 ; make into pointer
move.b EventRecord.message+3(a4),(a0) ; put char code into end of buffer
; record time of keystroke
move.l EventRecord.when(a4),TypeSelectRecord.tsrLastKeyTime(a3)
; return true
addq.b #1,StackFrame.result(a6) ; return boolean true
@done movem.l (sp)+,a3/a4
unlk a6
move.l (sp)+,a0
add #StackFrame.paramSize,sp
jmp (a0)
ENDPROC
;----------------------------------------------------------------------
;
; FUNCTION TypeSelectCompare(tsr: TypeSelectRecord;
; testStringScript: ScriptCode;
; testStringPtr: StringPtr): INTEGER;
;
; Used to find closest matching list item. Does correct international
; comparison of the keys strokes stored in tsr against any string.
; That is, first check for byte to byte equality, if not the same then
; call MagWPString to compare strings. <20>
; Returns -1, 0, 1 if keys strokes are before, same, or after the test string
;
;----------------------------------------------------------------------
TypeSelectCompare PROC EXPORT
IMPORT ScriptOrder, MagWPString, UnLockIt, intScriptCodeToReal, GetScriptItl ; <20>
StackFrame RECORD {A6Link},DECR
result DS.W 1
paramSize EQU *-8 ; bytes of prameters to remove on return
tsr DS.L 1
testStringScript DS.W 1 ; cached in d3.w
testStringPtr DS.L 1 ; lea testStringPtr^[1] in a3, length in d4.w
ReturnAddr DS.L 1
A6Link DS.L 1
; locals go here
; tsr.script cached in d5.w
; lea tsr.keyStrokes^[1] in a4, length in d6.w
ALIGN
size EQU * ; size to link
ENDR
link a6,#StackFrame.size
movem.l d3-d6/a2-a4,-(sp) ; save registers <20>
move.w StackFrame.testStringScript(a6),d3 ; get testStringScript
move.l StackFrame.testStringPtr(a6),a3 ; get testStringPtr
moveq #0,d4
move.b (a3)+,d4 ; a3 = test.StringPtr, d4.w = test.length
move.l StackFrame.tsr(a6),a4
move.w TypeSelectRecord.tsrScript(a4),d5 ; d5.w = tsr.script
moveq #0,d6
move.b TypeSelectRecord.tsrKeyStrokes(a4),d6 ; d6.w = tsr.length
lea TypeSelectRecord.tsrKeyStrokes+1(a4),a4 ; a4 = tsr.stringPtr
; first check the scripts, if same check strings
cmp.w d3,d5 ; compare script numbers first
beq.s @testStringsLength ; same script so compare the text
; scripts are different so use script order to find overall order
subq #2,sp ; room for result
move.w d5,-(sp)
move.w d3,-(sp)
bsr ScriptOrder ; get order for scripts
move.w (sp)+,d0 ; set CC's and we are done
bra.s @done
; check string lengths as short circuit of equality
@testStringsLength
cmp.b d4,d6 ; are strings the same length?
bne.s @doIntlCompare ; if not check sort order
; check for exactly the same bytes
move.l a3,a0
move.l a4,a1
move.w d4,d0
@nextByte cmp.b (a0)+,(a1)+ ; compare each byte
bne.s @doIntlCompare ; if one byte wrong then try I.U.
subq.w #1,d0
beq.s @done ; if all bytes same, return 0
bra.s @nextByte
; use localizable string comparison, for primary sort order only. <20>
@doIntlCompare
;; bsr LockIt ; GetScriptItl will lock if necessary <20>
; Use GetItlScript to get itl2 handle from cache, using specified script. <21>
with ExpandMemRec ; <40>
sub.l #4,sp ; make room for the itl handle.
move.w #2,-(sp) ; push 'which' argument for itl2.
move.w d3,-(sp) ; push ScriptCode <21>
move.w #-1,-(sp) ; we want system cache <21>
move.l ExpandMem,a0 ; ExpandMem ptr <40>
addq.b #1,emItlDontUnlockYet(a0) ; say this is internal call <40>
bsr GetScriptItl ; get itl handle
move.l ExpandMem,a0 ; ExpandMem ptr <40>
subq.b #1,emItlDontUnlockYet(a0) ; end of internal call <40>
move.l (sp)+,d0 ; pop handle into d0.
beq.s @done ; if err, bail (d0=0) <21>
subq #2,sp ; room for result
move.l a4,-(sp) ; aPtr
move.l a3,-(sp) ; bPtr
move.w d6,-(sp) ; aLen
move.w d4,-(sp) ; bLen
move.l d0,-(sp) ; itl2 handle
move.l ExpandMem,a0 ; ExpandMem ptr <40>
addq.b #1,emItlDontUnlockYet(a0) ; say this is internal call <40>
bsr MagWPString ; order comparison
move.l ExpandMem,a0 ; ExpandMem ptr <40>
subq.b #1,emItlDontUnlockYet(a0) ; end of internal call <40>
move.w (sp)+,d0 ; <40>
endwith ;ExpandMemRec ; <40>
; return value in d0
@done move.w d0,StackFrame.result(a6) ; return boolean
bsr UnLockIt ; moved here <40>
movem.l (sp)+,d3-d6/a2-a4 ; restore regs <20>
unlk a6
move.l (sp)+,a0
add #StackFrame.paramSize,sp
jmp (a0)
;
; set up parameters for compare string call
; (modified and moved inline, since we only need it once now) <20>
ENDPROC
;----------------------------------------------------------------------
;
; FUNCTION TypeSelectFindItem( tsr: TypeSelectRecord;
; listSize: INTEGER;
; selectMode: TSCode {INTEGER};
; getStringProc: IndexToStringProcPtr;
; yourDataPtr: Ptr): INTEGER;
;
; If your list is sorted, you can start at the beginning of the list and
; call TypeSelectCompare on each item to you find one that is ≥ and
; it is the item to select.
;
; If list is not sorted, you can call TypeSelectFindItem. It will walk the
; entire list and return the correct one to select. It calls a procedure you
; supply to get an item's script and string from its index in the list
;
; If the number of item in the list is unknown, you pass in MAXINT ($7FFF) for
; listSize and have your getStringProc return false when it is called past the
; end of the list.
;
; selectMode is a parameter to allow the user to alphabetically walk through an
; unsorted list. Normally, you would use tsNormalSelectMode for type selecting.
; If after an item is selected, the user wants to select the next alphabetical
; item, fill the tsr buffer with the string for the current selected item
; and call TypeSelectFindSelect with selectMode = tsNextSelectMode. To get the
; previous item use selectMode = tsPreviousSelectMode.
;
; tsPreviousSelectMode largest item < type select buffer
; tsNormalSelectMode smallest item ≥ type select buffer
; tsNextSelectMode smallest item > type select buffer
;
;
;TYPE
; IndexToStringProcPtr = ^FUNCTION(item: INTEGER;
; VAR itemsScript: ScriptCode;
; VAR itemsStringPtr: StringPtr;
; yourDataPtr: Ptr): BOOLEAN;
;
; If an item is not selectable (ex. grayed out items in putfile)
; your IndexToStringProcPtr should return NIL for itemsStringPtr.
;
; Selects the item which based on the selectMode. tsNormalSelectMode is
; the smallest item ≥ type select buffer.
; That is, the exact match, or if the list was sorted, the first
; file after where the type select buffer would be inserted.
;
; Works by scanning the entire list. Trying to find the closet match.
; It keeps a "best guess", The best guess is changed if another item is
; found which better matches the criteria.
;
; Uses a routine BndBranch to do bounds checking based on selectMode.
;
;----------------------------------------------------------------------
TypeSelectFindItem PROC EXPORT
IMPORT LockIt, UnLockIt
StackFrame RECORD {A6Link},DECR
result DS.W 1
paramSize EQU *-8 ; bytes of prameters to remove on return
tsr DS.L 1 ; cached in A4
listSize DS.W 1
selectMode DS.W 1
getStringProc DS.L 1
yourDataPtr DS.L 1
ReturnAddr DS.L 1
A6Link DS.L 1
; locals go here
bestGuess DS TypeSelectRecord
firstValidItem DS.W 1 ; for use as guess if wrap-around needed
lastValidItem DS.W 1 ; for use as guess if wrap-around needed
anItemScript DS.W 1 ; cached in D5
anItemStringPtr DS.L 1 ; cached in D4
; bestGuess StringPtr in D7
ALIGN
size EQU * ; size to link
ENDR
MACRO
tstBra &branchLabel
lea &branchLabel,a1
bsr BndBranch ; <27>
ENDM
link a6,#StackFrame.size
movem.l a4/d3-d7,-(sp)
move.l StackFrame.tsr(a6),a4
move.w StackFrame.selectMode(a6),d6
bsr LockIt ; lock the package!! we will be calling user code
moveq #0,d7 ; remember, we have no bestGuess
move.w d7,StackFrame.result(a6) ; zero guess index
move.w d7,StackFrame.firstValidItem(a6) ; zero out
move.w d7,StackFrame.lastValidItem(a6) ; zero out
moveq #1,d3 ; start looking at first cell
@nextCell ; get D3'th item into anItem
bsr GetStringFromIndex
beq @endOfList ; if IndexToString returns false, then done <40>
tst.l d4 ; d4 = StackFrame.anItemStringPtr(a6)
beq.s @notFound ; if stringPtr is NIL then skip this item
; save off first and last know valid items
tst.w StackFrame.firstValidItem(a6)
bne.s @firstWasFound
move.w d3,StackFrame.firstValidItem(a6) ; this is once set once
@firstWasFound move.w d3,StackFrame.lastValidItem(a6) ; this keeps getting set
; compare anItem with type select buffer
with ExpandMemRec ; <40>
subq #2,sp ; room for result
move.l a4,-(sp) ; a4 = StackFrame.tsr(a6)
move.w d5,-(sp) ; d5 = StackFrame.anItemScript(a6)
move.l d4,-(sp) ; d4 = StackFrame.anItemStringPtr(a6)
; note: there is a bug here in next- and prev-mode. It should
; be doing a comparsion that includes secondary differences.
; Currently TAB in the Finder will skip over names that do not
; differ in a linguistically relevant manner (i.e. "abc" "åbc" in English)
move.l ExpandMem,a0 ; ExpandMem ptr <40>
addq.b #1,emItlDontUnlockYet(a0) ; say this is internal call <40>
bsr TypeSelectCompare
move.l ExpandMem,a0 ; ExpandMem ptr <40>
subq.b #1,emItlDontUnlockYet(a0) ; end of internal call <40>
tstBra @notFound ; if bounds fails, try next item
; have a contender for a better guess
; see if this is first contender, then it is bestGuess
tst.l d7 ; if last bestGuess does not exist
beq.s @newBest ; then this guess is better!
; see if current cell is closer to typeSelect than bestGuess
; need to consider secondary differences when differentiating between guesses <30>
lea StackFrame.bestGuess.tsrKeyStrokes(a6),a0 ; a0 is bestguess <30>
moveq #0,d0 ; <30>
move.b (a0)+,d0 ; d0 is bestguess length<30>
move.l d4,a1 ; a1 is this item <30>
moveq #0,d1 ; <30>
move.b (a1)+,d1 ; d1 is this item length<30>
subq #2,sp ; room for result <30>
pea (a0) ; aPtr <30>
pea (a1) ; bPtr <30>
move.w d0,-(sp) ; aLen <30>
move.w d1,-(sp) ; bLen <30>
move.w StackFrame.bestGuess.tsrScript(a6),-(sp) ; aScript <30>
move.w d5,-(sp) ; bScript <30>
moveq #iuScriptDefLang,d0 ; <30>
move.w d0,-(sp) ; aLang <30>
move.w d0,-(sp) ; bLang <30>
move.l ExpandMem,a0 ; ExpandMem ptr <40>
addq.b #1,emItlDontUnlockYet(a0) ; say this is internal call <40>
bsr TextOrder ; compare them <30>
move.l ExpandMem,a0 ; ExpandMem ptr <40>
subq.b #1,emItlDontUnlockYet(a0) ; end of internal call <40>
; note: if the list contains duplicate names and one of those names is
; the best type select match, then TypeSelectFindItem returns
; the last list-order of the duplicates. This maybe somewhat random,
; but the API for TypeSelect does not support anyway to differentiate
; between the duplicates. If you want to do something about it, check
; for $0000 on the stack at this point.
neg.w (sp)
tstBra @notFound ; if bounds fails, then bestGuess is
; still better than anItem, so try next item
endwith ;ExpandMemRec ; <40>
@newBest bsr NewBestGuess
@notFound addq.w #1,d3 ; next cell index
cmp.w StackFrame.listSize(a6),d3
ble.s @nextCell ; keep going 'til end of list
@endOfList
; see if tsr passed in was empty. if so, choose first or last <27>
tst.b TypeSelectRecord.tsrKeyStrokes(a4) ; a4 = StackFrame.tsr(a6) <27>
beq.s @firstOrLast ; <27>
; looked at 'em all, result has best one
tst.w StackFrame.result(a6)
bne.s @foundIt
@firstOrLast ; <27>
; if result is still zero then none matched
; so tsNormalSelectMode => select last item
; tsNextSelectMode => wrap around to first
; tsPreviousSelectMode => wrap around to last
move.w StackFrame.firstValidItem(a6),d3; assume will want to find first <27>
beq.s @foundIt ; handle zero length list <27>
tst.w d6 ; d6 = StackFrame.selectMode(a6) <27>
bgt.s @startSearch ; <27><28>
moveq #tsPreviousSelectMode,d6 ; force normal to previous in order to get last item<28>
@findLast move.w StackFrame.lastValidItem(a6),d3 ; assumption wrong, start with last <27>
@startSearch bsr GetStringFromIndex ; get D3'th item into anItem <27>
beq.s @foundIt ; if IndexToString returns false, then end of list <27>
bsr.s NewBestGuess ; use first/last as initial best guess <27>
; walk entire list finding the lowest (or highest) alphabetically <27>
move.w StackFrame.firstValidItem(a6),d3; start walking list <27>
subq.w #1,d3 ; <27>
@nextWrap addq.w #1,d3 ; next cell index <27>
cmp.w StackFrame.listSize(a6),d3 ; <27>
bgt.s @foundIt ; stop at end of list <27>
bsr GetStringFromIndex ; get D3'th item into anItem <27>
beq.s @foundIt ; if IndexToString returns false, then at end of list<27>
tst.l d4 ; d4 = StackFrame.anItemStringPtr(a6) <27>
beq.s @nextWrap ; if stringPtr is NIL then skip this item <27>
; see if this cell is better than bestGuess <27>
; that is, when trying to find first, it is better if cell is less than bestGuess <27>
subq #2,sp ; room for result <27>
pea StackFrame.bestGuess(a6) ; <27>
move.w d5,-(sp) ; d5 = StackFrame.anItemScript(a6) <27>
move.l d4,-(sp) ; d4 = StackFrame.anItemStringPtr(a6) <27>
bsr TypeSelectCompare ; <27>
neg.w (sp) ; want to branch on opposite conditions <27>
tstBra @nextWrap ; if bounds fails, try next item <27>
bsr.s NewBestGuess ; this is better than guess, so use it <27>
bra.s @nextWrap ; <27>
@foundIt bsr UnLockIt ; unlock the package
movem.l (sp)+,a4/d3-d7
unlk a6
move.l (sp)+,a0
add #StackFrame.paramSize,sp
jmp (a0)
;--------------------------------------
;
; Branch according to selectMode.
;
; tsPreviousSelectMode => bra if item ≥ type select buffer
; tsNormalSelectMode => bra if item < type select buffer
; tsNextSelectMode => bra if item ≤ type select buffer
;
;
; in: 4(sp).w = compare's result
; a1 = place to branch on success
;
; if test passes
; then pops return address and jumps to a1
; else returns
;
BndBranch move.l (sp)+,a0 ; return address
move.w (sp)+,d0 ; test result on which to base branch
neg.w d0
cmp.w d0,d6 ; d6 = StackFrame.selectMode(a6)
beq.s @dontBranch
tst.w d6
bne.s @branch
tst.w d0
bgt.s @dontBranch
@branch move.l a1,a0 ; force branch
@dontBranch jmp (a0) ; return
;--------------------------------------
;
; in d3.w = cell index
;
NewBestGuess move.w d3,StackFrame.result(a6)
move.w StackFrame.anItemScript(a6),StackFrame.bestGuess.tsrScript(a6)
move.l d4,d7 ; save off last ptr
move.l d4,a0 ; source
lea StackFrame.bestGuess.tsrKeyStrokes(a6),a1 ; destination
moveq #0,d0
move.b (a0),d0 ; source string length
addq #1,d0
moveq #63,d1
cmp.b d1,d0 ; no more then 63 chars long
blt.s @1
move.b d1,d0
@1 _BlockMove
rts
;--------------------------------------
;
; in: d3.w = cell index
;
GetStringFromIndex subq #2,sp ; Boolean result
move.w d3,-(sp) ; item: INTEGER
pea StackFrame.anItemScript(a6) ; VAR itemsScript
pea StackFrame.anItemStringPtr(a6) ; VAR itemsStringPtr
move.l StackFrame.yourDataPtr(a6),-(sp) ; yourDataPtr: Ptr;
move.l StackFrame.getStringProc(a6),a0
jsr (a0)
move.l StackFrame.anItemStringPtr(a6),d4 ; d4 = StackFrame.anItemStringPtr(a6)
move.w StackFrame.anItemScript(a6),d5 ; d5 = StackFrame.anItemScript(a6)
move.b (sp)+,d0
rts
ENDPROC
end ; of file
Reference in New Issue Copy Permalink