-not a Macintosh disk-DPi`KJDBH@%zp((NP"N,L 8!"@$|Gn"`I N.@A,H<( F<B<H111.Bx<kNNF`, 8! "NH@"|J(g g`LNu"_ |a||a0@||9݁g|w|a||NH瀀 |(_@"g2<@gBA?N`Fa`||aPLNu  fBR$N"NBH@&|݁ |B$<0HN~NL@dBgg>N&|)`RNuBBBA*2h/ BBB N _"_$_"H&|݁ |B$<0NNd 0<`L$|J HA H  2I<FFI<<FFfHHFFfHHH?B@L"_2N _0H 2<@I6@o Az:<2`6@oJA~:<26" @n2BDBB(`EB@nAJEkz`z2<HAIL0.NL0.N  / p? O@ 0  0  XO _,_2_!.NBBB/ BBBN08 @ gNu@ f"_E!NH\O/ ?`@&x|N _!@"|xEz En"`CE"|xN"Ҹ< A  33"|@E E4n"`C&E"|@.N _LHNFLN*8&E@<<'CJJKK f`  f `><$CS*<FF4>BRIBC Gff&<CBSC`D GnKG45BQf` f `Ns |0< BXHQ!4 _$_"_!XOHH/8/ $ f0<? QN ! N.x $_$ g ! N.x !C !!LLyp!N\OFN  l0P߀ Aǀ`  6lo6@ 0_an*>]> j 56, l602  ۰Poo A` &ll6p@ 0?۷a?^ ꭕ 5o6, l602 8!ED91kE"0369? CoNGNOS BOOT FAILED TRY A NEWER MACHINE AND BOOT PROM _"_NN/A lNNu _.NHL$ orD?|?@?e\SFk!!QSWk:CL<HL|hH>L|4H>L|H>SWjTO>SGk\!Q`TSFk QSWk8L|H|L|H|4L|H|hL|H|LSGkQLx _O NNVH8=| f=|G* G, &N(N n"n$n 0.  S@ZeJ S@BBDBG S@gg.BC CJDg720faL`fa:` 320f8<S@`JDg  fa$` fa`  U@o$SBjt`(N&N><`JGg (Ev#$#$QNukJDg`g 3$f(N`BnLN^ _NUNPACK H>8$O&j.(j4,*8:*,BB6*2SCCn`8CL0@D@04"F K0HEY@2< Vb,g`aJaBVgbHE6SCCo`p`HE4RBCo8B@ j(0 j$L| _pN am znNu _"_$_$0H2< @`Q`BQBNNV;n *N^.NuEVINIT NVH,. ^J]g n0`4B?N. f n0`/.//. /.N6(n)FLN^ _NEAD_BLONV/ (n Jno./.?././ /.Nj nJPg`RSn`(_N^ _NEAD_SEQHNT"|E.|r |BBByBygRBf~NuLHPPNqNqpS_n.0<QLHPPNqNqpS_n|~By&JM*Np|azJGfb|a|,Mpa`JGfH|a<<AaJGf0Avtp BQvr BQH@02N\LhL"4NtB@6Kd a"JDf`02IP g a JDf`Nub SBg pxNuBDNu><Nu4< vB@bp2IPSCfSBfNuppB@(4<dBC(4< CBC(C"H4<BACSBf(CAg><NuJoNV?-,N.H|)?NN^ _TONRAP NV.HgVS@g`J.f& -`мS//<N/<NB+_`-m` . ѭ` -`o<Np`B . \J.f/-\/<N4/<N+_\-m\ -\l<N,N^ _PONGETSPACNV .мS//<N/<N-_ .=@ N^.NuINDSPARNVH.. Bg/N0Hހ m0.@I/./<N 8//<Np @n ?.Bg?<BgNLN^ _ NETMMU NVH+| d+|l+|(+||+|+|t+|(|;TV(|;T|(|.;Tz&| n!SLN^.NuETVARS NVH/Nt;| .䐼/+@ .м/м+@+|`*<(< E"D +@\&|?-|0-VS?NHnHmJNJngp+@JBBg/-BgNz+_ -Э+@XBB<0<H/BgNPN+_P+mPBG` m @I G~V GTVgd Gl|p@ @8`$ Gf|p@BT`| p@BT H< @"@=A?.??<BgNRG Gox mI|p@BT mIP|p@/-P/<N* 8LN^NuOOTINITNVH(nB BgNBgNHH,BgN0HѬ f,/, N"BgNBgNHH,BgN0HѬ f,/, NBgNrBgNjHH,BgN0HѬ f:Jf< N/, NBgN2BgN*HH,BgNb0HѬ g<NLBN,BN+_ n/BN|  _r Ё0p//-`N/-/-`N&m`:=E E0o<N0<H+@l+| -lЭd n2HҀ -Ё"-Ҁ(Bg Э/N0Hѭ -Є+@B</-BgN+_+mh -dЭh+@p -lЭp, n0HІ+@ -Э+@ -Э+@?<f/-/-?<Nb-m/ /./-N n LN^ _ NUILD_SYNVH(nBGBF. gB `P-n n0. PoB."` n0. A-H&n/+/<N  n0>+<+/, NBgN<BgN4HH-@BgNj0H(٬ JVJ_gB."`4JGW WJGV WgJFf n `H n n/B."n/BgN2  _ BNB-_JGf n Q/ n P/Nr` Q@H/ n P/NZ|B. n=h-nA-H n-P/./.p/N JGgR-mBg n/( n r Ё/ n P/ nP/ | ? Q@?N9_Jlg< N, nQ f|"LN^ _NOADSEG NVHBBg/-tBgN+_x -x"-Ҁ+At(|`p}//<Nn -Пx((|p}//<NN -Пx(?<}/-x/-t?<N&|BSLN^.NuLLOC_SCNVHAC 0BgHnNz_m+m-gBBg/-BgNP+_`+m-gBBg/<BgN, м,BgBgBHnBgHnHnBg/.N g<NACD 0BgHnN  g B-n`.BgBgBHnBgHnHnBg/.Nx g<Nf .@+@ -Э+@` B -@+@ -м@+@?</-/-?<N@ <逐.JfB` .ЇP-@JfB` .ЇP-@-g -Ї/ -Ї//./.N`/-/-BBN(|p((|t(LN^.NuOAD_DEB SYSTEM.DEBUG2 SYSTEM.DEBUGNVH nCJp"S@n2&n (nBBgHnN dgZB /, N NBgN BgN HH(BgN0H* f&.B</BgN&B /, N //NlLN^ _ NOAD_UNPNVBgBgBHn</. /.Bg/.N g<NN^ _ NOAD_LLDNVH(n 0-N|>Jg,, .* Ю(H//<N( Д-@`,.(.H//<N-_?//?<N. .P/NdLN^ _NNSTALL_NVH(n=n ~`/, N BgN p_BgN fHH(BgN 0H-@Jg .Ѭ `<N~ .fBN (BN ( GfAB0pB5pB`ACZ 0z`BgN _ .ARE EoHn?<?<HnNAC 0HnHzNg(AB0pp @AB @AB`2HnHzNPgAB0pB5pB`App| 5pgnBg?/.Hn @AHp @AHp</.NX g<NF?. @A/0 @A"0Ҽ/?<NHRGinoLLN^ _ NOADCODEkrni NVBBg/-BgN+_?<e/-/-?<NN^.NuAKESUPSNVH(m . R A T&@-kLN^ _ NINDMAINNVBg/-NF0HѭB</-BgNx+_?<g/-/-?<N\Bg/-|N 0Hѭ|B</-|BgN>+_?<{/-/-|?<N"N^.NuLLOC_OPNV A0C ArC 0AC 0/NLHnHm/NFBgHn0N g< NHnHn/NBgHnrN g<N^/NZBg/.Hn$/N;_N/./.Hm/N-UgNj/.$?-N/N@/N2 n /B/.$0-NH//NR  _ /NBNj+_N^ _PONOADSYS $ SYSTEM.UNPACK SYSTEM.OS SYSTEM.LLDN :NV,_NUvN ,+|v mv PVD@UNHmHmNHm?- -|Э//-NzNZN N]N NuN^NuOADER NVHAv(HA^&HHn?-.0-0H".Ҁ// / NrJng<NLN^.NuEAD_PAGNV0.HBH"-DҀ-A0.HBH@J@=@/.NvAv0.HЈ-@ N^ _TONIND_SENNVBH nCJp"S@n2 n BBgA/A/Nz-m2Av(H&L U.=m6B|`A^-HHAv(BE`:HnN?-.0-0H".ҀH҅///.HNhؼJnNg<NRE Eom6l^Bn So4 X/ U/0S@?A/?<$Hn/. N n gRn G0.D@@20HҌ-A n-P`/ /?A/?<$Hn/. NRFinBo$ n g< G0.D@@20HҌ-A/.HnP?<NN n/B?.vN4  _ LN^ _ ND_SEARCNVH n-h .S/0-:H/N ;@Z-n p+@V;m:\BF` AvIBBlRF Fo=mHnNBgHn?->N>H/p6/NNZBp6/A/NACp S@n0HnN^J.gHHnHnN .Wgz n/B?.N  _ `SFRGm>fBGBNJFfELN^ _PONOOKUP_ENVH.<A"G";n .;m.,?.?-.N;n0BN&Av(HJg<NH;l~:+lD;lB;l>;l@;l<;T8;l26+l.2 2f<N m8lB?,N&_+SH+kL+kPLN^.NuNITMEDINV m8lBg/.HnN2_`/.HnHnNn .gB/.N-_N^.NuPENINPUNVH(.BGBF Go<NR Av:0JEf<N8 EHl@ AvH"Ұ n n Jf<NHH " n ``RGE`LN^ _ NIND_POSNV-mV/.0-:H/N+_VJV]2-ZHV]g<N0-:H/-V/N2 .;@\ -Vg/-VHnHnN/.N"N^.NuILLBUF NV0-\m:f -VR2-:H//NNT0-\AvpRm\N^NuETBYTE NVHBgNHH<BgNH>JGl H м> G=@LN^NuETWORD NVHBgN0H//<ND,BgN0H.Jl޼ Ї-@LN^NuETLONG NVH,. 0-:m\>HǼl>JGo0-\AvA//.H/NH߮Hǜm\0-:HnJV]2-ZHV]g<N -VR/HnHnNn-nA^(H/0-:H/N*l-EJoZHn?-.0-0H".Ҁ/?././ NjJng<N~0-:H/./N(ٮ .Ѯ .ѭV`:Jo -VR2-:H//NNhJfLN^ _PONOVEMULTNVH(n0,k @nH0;N *6BN\BgHlN_`n/,N`dBgN_`XBgN9_`LBN)_`@/,/,N:`2&l.,/ ?-.0-0H", Ҁ/?,/ /NP`<NhLN^.NuRIVER_C//0/2/ AH@B@2/Ё/@" /WXNuNV// /"/N:/A" N^/WXNuNV// /"/N/@" N^/WXNuH>*jD,jD$HBJBf6B@H@g4HB04"B@H@`$&BBxԂрҁmRQJjDjDL|NuNuNuJoNu$_0 _"_J @o4$ Tg,2ABAgSBgS@2@ISA QS@kQN$_0 _"_J`!QN$_02 _`QNHBB oJ0/2/gk gRBSAn` R gSBRAk?B/oL\NuHBB oJ0/2/gk fRBSAn` R fSBRAk?B/oL\NuHr`HBA oJ"oJB@f`fQ AA/oL\NuH"o J oJv`:H"o J oJBC`&H o J"oJv`H o J"oJBCB@BA@m4`4`fQ@n C`cC"/oL\NuH0/ oC"4JBAR`$aJBBB`QQ oC"0/H#//IL._NuH oJB@BA"o JBBBlBA`$HR` fQ`RS@`?A"/oL\NuH o0/2/SA"o JBBA@m`Q/o L NuB`$_02 _ @o0 Ao*BBAm"6@SCBoSA`@"H`RCoN$_0"_ _J/ S@m*BABB@m6B$I”@`!Q`QNuKb@ TK Sources 3̆V{t̆^K :a$ kT hk\:)$ "#." #"##%& ! . M  {,$F.1 .1m$libtk/Udraw2.TEXT|ĝK$LIBTK/UOBJECT.TEXTy\P$libtk/UOBJECT2.TEXTtL$libtk/UOBJECT3.TEXTWL$libtk/UOBJECT4.TEXT L,,$libtk/utext.text Lח$libtk/utext.text Lחount.OBJi.8$TOOLS/concat.OBJmCS.8$TOOLS/copy.OBJhڷ.8$TOOLS/find.OBJnܚܮ((.8$tools/help.texts 8` $TOOLS/linecount.OBJk۞ۮ.8$TOOLS/lwccount.OBJl.8$TOOLS/translit.OBJo"".8$TOOLS/wordcount.OBJjP`.8$Transfer.Obja"DDj$Transfer/config.texty, $TTY/TERM.MENUS.TEXTzWY7v g $ubaudrate.Text} $ucsdeditor.OBJsϾ$UXref.OBJXМDD.8$WORKSHOP.STEP.HELP.TEXT?Z3Z:N$WORKSHOPERRS.ERRƜ$xref.help.textay|$xref.OBJ`zؚzz.8${T11}buttons#${T11}obj*{(${T11}PHRASEsX)*(jj@@@@@@NNlibtk/Udraw2.TEXTTEXTXTUhKbP|ĝ\-KUNV n j MjLIBTK/UOBJECT.TEXTTEXTTUhKbQy\K\PYNV n T Tlibtk/UOBJECT2.TEXTTEXTUhKbRt\=LNV n l llibtk/UOBJECT3.TEXTTEXTUhKbSW\GLUNV n  {libtk/UOBJECT4.TEXTTEXTUhKbT\RLUNV n  libtk/UTEXT.TEXTTEXTEXTUhKbULsLחNV n B Blibtk/utext.text-#2#1Z̨̝LEr\YLחNV n B <3. "6F^9PaD!$ǐ^J##TLהTextImage, TTextView} {$I LibTK/UTEXT4.text} {Text Selections and Commands} END. UNIT UText; {$SETC IsIntrinsic := TRUE } {$IFC IsIntrinsic} INTRINSIC; {$ENDC} {Multiple Paragraph Building Block for the Tool Kit} {changed 04/25/84 1437 Added TTextImage.TxtImgForClipBoard method} {changed 04/18/84 1652 Added firstLinePixel, useFirstPixel fields to TTextImage} {changed 04/16/84 1135 Added styleSheet field to TParaFormat} {changed 04/13/84 0209 Added TTextImage.NewEditPara} {changed 04/12/84 2344 Changed parameter list of TParagraph.UpdateRuns} {changed 04/10/84 1400 Changed TEditPara.images field back to a TList} INTERFACE {$DECL fUseUnivText} {$SETC fUseUnivText := TRUE} USES ${$U libtk/UObject} UObject, {$IFC LibraryVersion <= 20} ${$U UFont} UFont, {$ENDC} ${$U QuickDraw} QuickDraw, ${$U libtk/UDraw} UDraw, {$IFC fUseUnivText} ${$U libtk/UUnivText} UTKUniversalText, {$ENDC} ${$U UABC} UABC; {$DECL fTextTrace} {$SETC fTextTrace := fDbgOK} {$DECL fParaTrace} {$SETC fParaTrace := fDbgOK} {$DECL fRngText} {$SETC fRngText := fDbgOK} CONST $cVertMargin = 4; $cHorizMargin = 6; $somethingKind = 1; TYPE $TStyleChange = RECORD (lp: INTEGER; (newStyle: TTypeStyle; (END; $TTxtTabDescriptor = RECORD (xCoord: INTEGER; (quad: TAlignment; ({MORE LATER} (END; $TDrawAction = (actionDraw, actionInval, actionNone); { PARAGRAPH SUBCLASSES } $TParaFormat = SUBCLASS OF TObject (dfltTStyle: TTypeStyle; {default type style} (wordWrap: BOOLEAN; (quad: TAlignment; (firstIndent: INTEGER; (leftIndent: INTEGER; (rightIndent: INTEGER; (spaceAbovePara: INTEGER; (spaceBelowPara: INTEGER; (lineSpacing: INTEGER; (tabs: TArray; (refCount: INTEGER; {number of paragraphs referencing this paraFormat} (permanent: BOOLEAN; {TRUE -> don't free when refcount goes to zero} (styleSheet: TStyleSheet; {NIL if format not in a styleSheet} (FUNCTION TParaFormat.CREATE(object: TObject; heap: THeap; itsStyleSheet: TStyleSheet): TParaFormat; ({$IFC fParaTrace} (PROCEDURE TParaFormat.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} (PROCEDURE TParaFormat.SetTypeStyle(tStyle: TTypeStyle); (PROCEDURE TParaFormat.ChangeRefCountBy(delta: INTEGER); (END; $TParagraph = SUBCLASS OF TString (typeStyles: TArray; { of TStyleChange } &{Creation/Destruction} (FUNCTION TParagraph.CREATE(object: TObject; heap: THeap; HinitialSize: INTEGER; initialTypeStyle: TTypeStyle): TParagraph; (PROCEDURE TParagraph.Free; OVERRIDE; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TParagraph.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Overridden TString methods} (PROCEDURE TParagraph.Draw(i: LONGINT; howMany: INTEGER); OVERRIDE; (FUNCTION TParagraph.Width(i: LONGINT; howMany: INTEGER): INTEGER; OVERRIDE; &{This method is used by TParagraph.Draw and TParagraph.Width to interpret the typeStyles array} (PROCEDURE TParagraph.DrawLine(startLP, endLP: INTEGER; fDraw: BOOLEAN; fWidth: BOOLEAN; MVAR width: INTEGER; VAR styleIndex: INTEGER); &{Type Style Maintainence} (PROCEDURE TParagraph.ChangeStyle(startLP, endLP: INTEGER; PROCEDURE Change(VAR typeStyle: TTypeStyle); XVAR styleOfStartLP: TTypeStyle); ({These four routines all call ChangeStyle} (PROCEDURE TParagraph.ChgFace(startLP, endLP: INTEGER; HnewOnFaces: {$IFC LibraryVersion <= 20}TSeteface{$ELSEC}Style{$ENDC}; XVAR styleOfStartLP: TTypeStyle); (PROCEDURE TParagraph.ChgFontSize(startLP, endLP: INTEGER; newFontSize: Byte; XVAR styleOfStartLP: TTypeStyle); (PROCEDURE TParagraph.ChgFontFamily(startLP, endLP: INTEGER; newFontFamily: Byte; XVAR styleOfStartLP: TTypeStyle); (PROCEDURE TParagraph.NewStyle(startLP, endLP: INTEGER; newTypeStyle: TTypeStyle); (PROCEDURE TParagraph.CleanRuns; (PROCEDURE TParagraph.UpdateRuns(atLP: INTEGER; replacedChars: INTEGER; insertedChars: INTEGER); &{Character Maintainence} (PROCEDURE TParagraph.ReplPara(fPos, numChars: INTEGER; LotherPara: TParagraph; otherFPos, otherNumChars: INTEGER); (PROCEDURE TParagraph.ReplTString(fPos, numChars: INTEGER; LotherString: TString; otherFPos, otherNumChars: INTEGER); (PROCEDURE TParagraph.ReplPString(fPos, numChars: INTEGER; pStr: TPString); &{Utilities} &{BuildExtentLRect takes an LPoint that indicates the baseline of the paragraph. It returns 'in extentLRect the bounding rectangle whose height is based on the tallest font in the 'paragraph and width is the width of the characters in the paragraph. Specifically: 8top := baseLPt.v - tallestFontInfo.ascent; 8bottom := baseLPt.v + tallestFontInfo.descent + tallestFontInfo.leading; 8left := baseLPt.h; 8right := baseLpt.h + paragraph.Width;} (PROCEDURE TParagraph.BuildExtentLRect(baseLPt: LPoint; VAR extentLRect: LRect); (FUNCTION TParagraph.FixLP(LP: INTEGER): INTEGER; (PROCEDURE TParagraph.SetTypeStyle(tStyle: TTypeStyle); (PROCEDURE TParagraph.StyleAt(lp: INTEGER; VAR typeStyle: TTypeStyle); &{Word Selection} (PROCEDURE TParagraph.FindWordBounds(orig: INTEGER; VAR first, last: INTEGER); (FUNCTION TParagraph.Qualifies(pos: INTEGER): BOOLEAN; (END; #{Editable Paragraph} $TEditPara = SUBCLASS OF TParagraph &{ character stuff } (bsCount: INTEGER; &{ formatting stuff } (nestLevel: INTEGER; (format: TParaFormat; &{ paraImage stuff } (beingFiltered: BOOLEAN; { TRUE when a type style command has just been Fperformed on this paragraph} ((* (maxImage: INTEGER; (numImages: INTEGER; (images: ARRAY [1..1] OF TParaImage; {THIS MUST BE LAST FIELD !} (*) (images: TList; { Users may subclass TEditPara } &{Creation/Destruction} (FUNCTION TEditPara.CREATE(object: TObject; heap: THeap; initialSize: INTEGER; HitsFormat: TParaFormat): TEditPara; (PROCEDURE TEditPara.Free; OVERRIDE; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TEditPara.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Special Editing} (PROCEDURE TEditPara.BeginInsertion(atLP: INTEGER; size:INTEGER); (PROCEDURE TEditPara.EndInsertion; (FUNCTION TEditPara.GrowSize: INTEGER; (PROCEDURE TEditPara.InsertOneChar(ch: CHAR; atLP: INTEGER); &{Utility} (PROCEDURE TEditPara.SetTypeStyle(tStyle: TTypeStyle); OVERRIDE; &{ParaImage Maintenance} (PROCEDURE TEditPara.EachImage(PROCEDURE ImageProc(paraImage: TParaImage)); (PROCEDURE TEditPara.DelImage(delImage: TParaImage; fFree: BOOLEAN); (PROCEDURE TEditPara.InsImage(paraImage: TParaImage); (PROCEDURE TEditPara.DelImgIF(FUNCTION ShouldDelete(paraImage: TParaImage): BOOLEAN); (END; $TLineInfo = SUBCLASS OF TObject (valid: BOOLEAN; (startLP: INTEGER; (lastDrawnLP: INTEGER; {last character in line to draw: may omit trailing spaces} (endLP: INTEGER; {last character in line: equals next lineInfo.startLP - 1} (lineLRect: LRect; (lineAscent: INTEGER; (FUNCTION TLineInfo.CREATE(object: TObject; heap: THeap): TLineInfo; ({$IFC fParaTrace} (PROCEDURE TLineInfo.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Used by subclassers who don't like the way the hilite/update 'rectangle is chosen so they can overrride it} (FUNCTION TLineInfo.LeftCoord(proposedLeftPixel: LONGINT): LONGINT; (FUNCTION TLineInfo.RightCoord(proposedRightPixel: LONGINT): LONGINT; (END; $TParaImage = SUBCLASS OF TImage (paragraph: TEditPara; (height: INTEGER; { pixel height of the paragraph} (lineList: TList; { of TLineInfo} (changed: BOOLEAN; (tickCount: INTEGER; { incremented (mod MAXINT) every time image is drawn } (startLP: INTEGER; (endLP: INTEGER; { while drawing, this is the LP of the beginning of the next line Fwhich, when drawing is finished, may be in another image if the Fparagraph is split } (textImage: TTextImage; { the textImage that this image belongs to } (wasOffset: BOOLEAN; { used by Building block to determine when to invalidate} &{Creation} (FUNCTION TParaImage.CREATE(object: TObject; heap: THeap; itsView: TView; HitsParagraph: TEditPara; itsLRect: LRect; HlineTop: LONGINT; lineLeft: LONGINT): TParaImage; (PROCEDURE TParaImage.Free; OVERRIDE; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TParaImage.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Routines} (PROCEDURE TParaImage.ComputeLineInfo(curLine: TLineInfo; maxLineLen: INTEGER; PVAR nextLP: INTEGER; VAR lRectNeeded: LRect); (FUNCTION TParaImage.DfltLineInfo(lineTop: LONGINT; lineLeft: LONGINT): TLineInfo; (PROCEDURE TParaImage.DrawLine(startLP: INTEGER; fDraw: BOOLEAN; LstopWidth, wrapWidth: INTEGER; LVAR lineWidth, lastToDraw, endLP: INTEGER); (PROCEDURE TParaImage.DrawParaImage(limitLRect: LRect; startLP: INTEGER; drawAction: TDrawAction; PinvalBits: BOOLEAN; VAR drawnLRect: LRect); (PROCEDURE TParaImage.Draw; OVERRIDE; (PROCEDURE TParaImage.FastDrawLine(startLP, endLP: INTEGER; fDraw: BOOLEAN; fWidth: BOOLEAN; MVAR width: INTEGER; VAR styleIndex: INTEGER); (FUNCTION TParaImage.GetFormat: TParaFormat; (PROCEDURE TParaImage.LineWithLPt(pt: LPoint; VAR lineIndex: INTEGER; VAR lineInfo: TLineInfo); (PROCEDURE TParaImage.LocateLP(LP: INTEGER; VAR lineIndex: INTEGER; VAR pixel: LONGINT); (FUNCTION TParaImage.LpWithLPt(pt: LPoint): INTEGER; (PROCEDURE TParaImage.OffSetBy(deltaLPt: LPoint); OVERRIDE; (FUNCTION TParaImage.ParaTextWidth(startLP, endLP: INTEGER): INTEGER; (PROCEDURE TParaImage.RedrawLines(startLine: INTEGER; endLine: INTEGER); (FUNCTION TParaImage.SeesSameAs(image: TImage): BOOLEAN; OVERRIDE; '{validation/invalidation procs} (PROCEDURE TParaImage.InvalLinesWith(startLP, endLP: INTEGER); (PROCEDURE TParaImage.AdjustLineLPs(atLP, deltaLP: INTEGER); (END; { MULTI-PARAGRAPH SUBCLASSES } $TStyleSheet = SUBCLASS OF TObject (formats: TList; {of TParaFormat} &{Creation} (FUNCTION TStyleSheet.CREATE(object: TObject; heap: THeap): TStyleSheet; (PROCEDURE TStyleSheet.Free; OVERRIDE; &{Installs Default paraFormat into formats list} (PROCEDURE TStyleSheet.InitDefault; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TStyleSheet.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} (END; $TTextRange = SUBCLASS OF TObject (firstPara: TEditPara; (firstIndex: LONGINT; (firstLP: INTEGER; (lastPara: TEditPara; (lastIndex: LONGINT; (lastLP: INTEGER; &{Creation} (FUNCTION TTextRange.CREATE(object: TObject; heap: THeap; HbeginPara: TEditPara; beginIndex: LONGINT; beginLP: INTEGER; HendPara: TEditPara; endIndex: LONGINT; endLP: INTEGER): TTextRange; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextRange.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{AdjustBy adjust the fields of TTextRange by the value of delta (where delta is in LPs)} (PROCEDURE TTextRange.AdjustBy(delta: INTEGER); (END; $TText = SUBCLASS OF TObject (paragraphs: TList; {of TEditPara } (styleSheet: TStyleSheet; (txtImgList: TList; {of TTextImages that point to this text; =IMPORTANT: If the multiple linked textImage feature is used as described in HTTextImage below, the application should only store the Hhead text image in this list. This list is intended for HtextImages that are viewing the same text object independently H(ie in different panels)} &{Creation/Freeing} (FUNCTION TText.CREATE(object: TObject; heap: THeap; itsStyleSheet: TStyleSheet): TText; ({DfltTextImage can be called after CREATE to create and return a single textImage. It also )creates one empty paragraph using the first paraFormat in SELF.styleSheet. It installs the )textImage in txtImgList and the paragraph in paragraphs. This routine calls )textImage.RecomputeImages to set up the first paraImage.} (FUNCTION TText.DfltTextImage(view: TView; imageLRect: LRect; imgIsGrowable: BOOLEAN): TTextImage; '{TText.Free frees all paragraphs that belong to this text object and all textImages that (reference this text object} (PROCEDURE TText.Free; OVERRIDE; (PROCEDURE TText.FreeSelf(freeParas: BOOLEAN); &{Debugging} ({$IFC fParaTrace} (PROCEDURE TText.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} '{Calls to textImage procs get routed through these} (PROCEDURE TText.ChangeSelInOtherPanels(textSelection: TTextSelection); (PROCEDURE TText.DelPara(delPara: TEditPara; fFree: BOOLEAN); (PROCEDURE TText.Draw; (PROCEDURE TText.HiliteRange(highTransit: THighTransit; textRange: TTextRange; wholePara: BOOLEAN); (PROCEDURE TText.HiliteParagraphs(highTransit: THighTransit; PstartIndex: LONGINT; startLP: INTEGER; PendIndex: LONGINT; endLP: INTEGER; wholePara: BOOLEAN); (PROCEDURE TText.InsParaAfter(existingPara: TEditPara; newPara: TEditPara); (PROCEDURE TText.Invalidate; (PROCEDURE TText.MarkChanged(textRange: TTextRange); (PROCEDURE TText.RecomputeImages; (FUNCTION TText.SelectAll(textImage: TTextImage): TTextSelection; (END; $TTextImage = SUBCLASS OF TImage (text: TText; {complete list of paragraphs} (imageList: TList; {paraImages for some range of paragraphs in text} (tickCount: INTEGER; (growsDynamically: BOOLEAN; {TRUE --> extentLRect bottom grows as more text entered; IFALSE -> text is truncated at last line that fits} (minHeight: INTEGER; {the minimum height to shrink (if growsDynamically=TRUE); Idefaults to height of original extentLRect} (formerBottom: LONGINT; {Used by Invalidate when the displayed paragraphs get shorter Iand text at end needs to be erased} (updateLRect: LRect; { " " " "} (firstLinePixel: LONGINT; {Used by Text BB to limit what gets erased on first update line} (useFirstPixel: BOOLEAN; ({ The following fields support multiple linked text images displaying a single text object, *where the text "flows" from one box to the next. APPLICATIONS ARE RESPONSIBLE FOR *MAINTAINING THESE FIELDS. This Building Block uses these fields for drawing, etc. *All text images in a chain should have growsDynamically set to FALSE (except possibly *for the last text image in a chain). *For applications that DO NOT use this feature, the fields will always be as follows: 0startLP = 0; 0endLP = LP of last character in last paragraph; (if growsDynamically = TRUE) :LP of last character that fit in extentLRect; (if growsDynamically = FALSE) 0prevTxtImg, nextTxtImg = NIL; 0headTxtImg = SELF; 0tailTxtImg = SELF; )} (firstIndex: LONGINT; {index of paragraph at SELF.imageList.First} (startLP: INTEGER; {startLP of paragraph at SELF.imageList.First} (endLP: INTEGER; {endLP of paragraph at SELF.imageList.Last} (prevTxtImg: TTextImage; { for linking textImages that display different parts of } (nextTxtImg: TTextImage; { the same text object. eg: columns} (headTxtImg: TTextImage; {points to first text image in this list} (tailTxtImg: TTextImage; {points to last text image in this list} &{Creation} (FUNCTION TTextImage.CREATE(object: TObject; heap: THeap; itsView: TView; HitsLRect: LRect; itsText: TText; isGrowable: BOOLEAN): TTextImage; ({TTextImage.Free frees all text images and their paraImages in the text image chain. )It does NOT free any paragraphs, text objects, or paraFormats. Call this only once )for each text image chain (NOT for each text image in the chain). Note that TText.Free )frees its textImages so calling this routine is not necessary in most cases} (PROCEDURE TTextImage.Free; OVERRIDE; ({TTextImage.FreeOneTextImage frees just one text image from the chain. It pays no attention )to links or whether this is the head text image. Maintenance of these fields must be )handled by the caller before calling this routine. Those who do not use linked text images )should always call TTextImage.Free above, NOT this routine} (PROCEDURE TTextImage.FreeOneTextImage; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextImage.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Drawing} (PROCEDURE TTextImage.Draw; OVERRIDE; (PROCEDURE TTextImage.DrawImages(fDraw: BOOLEAN); (PROCEDURE TTextImage.DrawOrInval(invalBits: BOOLEAN); (PROCEDURE TTextImage.HiliteText(highTransit: THighTransit; LstartIndex: LONGINT; startLP: INTEGER; LendIndex: LONGINT; endLP: INTEGER; wholePara: BOOLEAN); &{Locating} (PROCEDURE TTextImage.FindParaAndLp(LPt: LPoint; VAR paraImage: TParaImage; ZVAR paraIndex: LONGINT; VAR aLP: INTEGER); (FUNCTION TTextImage.FindTextImage(VAR mouseLPt: LPoint; VAR firstTxtImg: TTextImage): TTextImage; (FUNCTION TTextImage.ImageBottom: LONGINT; (PROCEDURE TTextImage.GetImageRange(firstIndex: LONGINT; VAR firstLP: INTEGER; MlastIndex: LONGINT; VAR lastLP: INTEGER; MVAR firstImage, lastImage: TParaImage); (FUNCTION TTextImage.ImageWith(paragraph: TEditPara; lp: INTEGER): TParaImage; (PROCEDURE TTextImage.MousePress(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TTextImage.OffsetBy(deltaLPt: LPoint); OVERRIDE; &{Image maintenence} (PROCEDURE TTextImage.AddImage(paraImage: TParaImage); (PROCEDURE TTextImage.DelImagesWith(delPara: TEditPara); (PROCEDURE TTextImage.InsertNewPara(existingPara, newPara: TEditPara); (PROCEDURE TTextImage.InvalAll; (PROCEDURE TTextImage.Invalidate; OVERRIDE; {Invalidate changed lineLRects in changed paraimages} (PROCEDURE TTextImage.MarkChanged(startIndex: LONGINT; startLP: INTEGER; LendIndex: LONGINT; endLP: INTEGER); (FUNCTION TTextImage.NewTextSelection(firstPara: TEditPara; firstIndex: LONGINT; firstLP: INTEGER; LlastPara: TEditPara; lastIndex: LONGINT; lastLP: INTEGER L): TTextSelection; (PROCEDURE TTextImage.RecomputeImages(drawAction: TDrawAction; invalBits: BOOLEAN); (PROCEDURE TTextImage.Resize(newExtent: LRect); OVERRIDE; (FUNCTION TTextImage.SeesSameAs(image: TImage): BOOLEAN; OVERRIDE; &{By default SetFirstIndex just sets firstIndex to 0, but subclassers may override this 'if they want the display to start from other than the first paragraph} (PROCEDURE TTextImage.SetFirstIndex; ({These routines are provided so that users can subclass the appropriate class and )then override these methods so that the building block will create the user's subclass )when generating new instances of that class. } (FUNCTION TTextImage.NewEditPara(initialSize: INTEGER; itsFormat: TParaFormat): TEditPara; (FUNCTION TTextImage.NewParaImage(itsParagraph: TEditPara; itsLRect: LRect; HlineTop: LONGINT; lineLeft: LONGINT): TParaImage; (FUNCTION TTextImage.NewTextImage(heap: THeap; itsView: TView; itsLRect: LRect; PitsText:TText; isGrowable: BOOLEAN): TTextImage; (FUNCTION TTextImage.TxtImgForClipBoard(heap: THeap; itsView: TView; itsLRect: LRect; PitsText:TText; isGrowable: BOOLEAN): TTextImage; (END; ${Clipboard Text View} $TTextView = SUBCLASS OF TView (textImage: TTextImage; (valid: BOOLEAN; {If FALSE, calls Recompute before Drawing} &{Creation} (FUNCTION TTextView.CREATE(object: TObject; heap: THeap; itsPanel: TPanel; itsExtent: LRect) B: TTextView; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextView.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} ({$IFC fUseUnivText} (PROCEDURE TTextView.CreateUniversalText; OVERRIDE; ({$ENDC} (PROCEDURE TTextView.Draw; OVERRIDE; (PROCEDURE TTextView.MousePress(mouseLPt: LPoint); OVERRIDE; (END; ${$IFC fUseUnivText} $TTextWriteUnivText = SUBCLASS OF TTKWriteUnivText (textSelection: TTextSelection; (currIndex: LONGINT; (currPara: TEditPara; (currLP: INTEGER; (currStyleIndex: INTEGER; (currTStyles: TArray; &{Creation} (FUNCTION TTextWriteUnivText.CREATE(object: TObject; heap: THeap; PitsString: TString; itsDataSize: INTEGER; PitsTextSel: TTextSelection): TTextWriteUnivText; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextWriteUnivText.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} (PROCEDURE TTextWriteUnivText.FillParagraph; OVERRIDE; (END; ${$ENDC} $TTextSelection = SUBCLASS OF TSelection (textImage: TTextImage; (textRange: TTextRange; (isWordSelection: BOOLEAN; (isParaSelection: BOOLEAN; (viewTick: INTEGER; (amTyping: BOOLEAN; (currTypeStyle: TTypeStyle; (FUNCTION TTextSelection.CREATE(object: TObject; heap: THeap; itsView: TView; LitsTextImage: TTextImage; itsAnchorLPt: LPoint; LbeginPara: TEditPara; beginIndex: LONGINT; beginLP: INTEGER; LendPara: TEditPara; endIndex: LONGINT; endLP: INTEGER L): TTextSelection; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextSelection.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TTextSelection.KeyText; (FUNCTION TTextSelection.NewCommand(cmdNumber: TCmdNumber): TCommand; OVERRIDE; (FUNCTION TTextSelection.NewStyleCmd(heap: THeap; cmdNumber: TCmdNumber; DtextImage: TTextImage): TCommand; (FUNCTION TTextSelection.NewCutCopyCmd(heap: THeap; cmdNumber: TCmdNumber; DtextImage: TTextImage): TCommand; DEFAULT; (PROCEDURE TTextSelection.StyleFromContext; DEFAULT; (PROCEDURE TTextSelection.DoChangeStyle(cmdNumber: TCmdNumber; paragraph: TParagraph; HfirstLP: INTEGER; lastLP: INTEGER; VAR newStyle: TTypeStyle); (PROCEDURE TTextSelection.ChangeStyle(cmdNumber: TCmdNumber); DEFAULT; &{Editing} (PROCEDURE TTextSelection.ChangeText(PROCEDURE TextEdit; PROCEDURE Adjust); DEFAULT; (FUNCTION TTextSelection.CopySelf(heap: THeap; view: TView): TMultiParaSelection; DEFAULT; (PROCEDURE TTextSelection.CutCopy(clipSelection: TSelection; deleteOriginal: BOOLEAN); DEFAULT; (PROCEDURE TTextSelection.DeleteAndFree; DEFAULT; (FUNCTION TTextSelection.DeleteButSave: TText; DEFAULT; &{Highlighting} (PROCEDURE TTextSelection.Highlight(highTransit: THighTransit); OVERRIDE; &{Selecting} (FUNCTION TTextSelection.BecomeInsertionPoint: TInsertionPoint; (PROCEDURE TTextSelection.GetHysteresis(VAR hysterPt: Point); OVERRIDE; (PROCEDURE TTextSelection.MousePress(mouseLPt: LPoint); OVERRIDE; (FUNCTION TTextSelection.SelSize: INTEGER; ABSTRACT; &{Invalidation} (PROCEDURE TTextSelection.Invalidate; DEFAULT; &{Generate Text Selection in another panel (ie. another Text Image)} (FUNCTION TTextSelection.ReplicateForOtherPanel(itsTextImage: TTextImage): TTextSelection; (END; $TInsertionPoint = SUBCLASS OF TTextSelection (typingCmd: TTypingCmd; {the current typing command (if user is typing)} (styleCmdNumber: INTEGER; {Set to cmdNumber when a type style item is chosen, Pset to zero otherwise} (newestLP: INTEGER; {the lp position as updated between KeyPause's} (justReturned: BOOLEAN; {flag that prevents redundant update in KeyPause} (nextHighTransit: THighTransit; (nextTransitTime: LONGINT; &{Creation/Freeing} (FUNCTION TInsertionPoint.CREATE(object: TObject; heap: THeap; itsView: TView; FitsTextImage: TTextImage; itsAnchorLPt: LPoint; itsParagraph: TEditPara; FitsIndex: LONGINT; itsLP: INTEGER): TInsertionPoint; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TInsertionPoint.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TInsertionPoint.IdleBegin(centiSeconds: LONGINT); OVERRIDE; (PROCEDURE TInsertionPoint.IdleContinue(centiSeconds: LONGINT); OVERRIDE; (PROCEDURE TInsertionPoint.IdleEnd(centiSeconds: LONGINT); OVERRIDE; (FUNCTION TInsertionPoint.NewCutCopyCmd(heap: THeap; cmdNumber: TCmdNumber; DtextImage: TTextImage): TCommand; OVERRIDE; (PROCEDURE TInsertionPoint.StyleFromContext; OVERRIDE; &{Editing} (PROCEDURE TInsertionPoint.CutCopy(clipSelection: TSelection; deleteOriginal: BOOLEAN); OVERRIDE; (PROCEDURE TInsertionPoint.FinishPaste(clipSelection: TSelection; pic: PicHandle); (PROCEDURE TInsertionPoint.InsertText(text: TText; isParaSelection: BOOLEAN; isWordSelection: BOOLEAN; tuniversalText: BOOLEAN); (PROCEDURE TInsertionPoint.KeyBack(fWord: BOOLEAN); OVERRIDE; (PROCEDURE TInsertionPoint.KeyChar(ch: CHAR); OVERRIDE; (PROCEDURE TInsertionPoint.KeyClear; OVERRIDE; (PROCEDURE TInsertionPoint.KeyForward(fWord: BOOLEAN); OVERRIDE; &{Selecting} (PROCEDURE TInsertionPoint.MouseMove(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TInsertionPoint.MousePress(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TInsertionPoint.MouseRelease; OVERRIDE; (END; $TOneParaSelection = SUBCLASS OF TTextSelection (anchorBegin: INTEGER; (anchorEnd: INTEGER; {anchorBegin <> anchorEnd iff double or triple click} &{Creation/Freeing} (FUNCTION TOneParaSelection.CREATE(object: TObject; heap: THeap; itsView: TView; EitsTextImage: TTextImage; itsAnchorLPt: LPoint; itsParagraph: TEditPara; EitsIndex: LONGINT; oldLP: INTEGER; currLP: INTEGER): TOneParaSelection; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TOneParaSelection.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TOneParaSelection.StyleFromContext; OVERRIDE; &{Editing} (FUNCTION TOneParaSelection.CopySelf(heap: THeap; view: TView): TMultiParaSelection; OVERRIDE; (PROCEDURE TOneParaSelection.DeleteAndFree; OVERRIDE; (FUNCTION TOneParaSelection.DeleteButSave: TText; OVERRIDE; &{Selecting} (PROCEDURE TOneParaSelection.MouseMove(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TOneParaSelection.MouseRelease; OVERRIDE; (END; $TMultiParaSelection = SUBCLASS OF TTextSelection (anchorPara: TEditPara; (anchorIndex: LONGINT; (anchorBegin: INTEGER; (anchorEnd: INTEGER; {anchorBegin <> anchorEnd iff double or triple click} &{Creation/Freeing} (FUNCTION TMultiParaSelection.CREATE(object: TObject; heap: THeap; itsView: TView; LitsTextImage: TTextImage; itsAnchorLPt: LPoint; LbeginPara: TEditPara; beginIndex: LONGINT; beginLP: INTEGER; LendPara: TEditPara; endIndex: LONGINT; endLP: INTEGER; LbeginIsAnchor: BOOLEAN): TMultiParaSelection; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TMultiParaSelection.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TMultiParaSelection.StyleFromContext; OVERRIDE; &{Editing} (FUNCTION TMultiParaSelection.CopySelf(heap: THeap; view: TView): TMultiParaSelection; OVERRIDE; (FUNCTION TMultiParaSelection.Delete(saveIt: BOOLEAN): TText; (PROCEDURE TMultiParaSelection.DeleteAndFree; OVERRIDE; (FUNCTION TMultiParaSelection.DeleteButSave: TText; OVERRIDE; &{Selecting} (PROCEDURE TMultiParaSelection.MouseMove(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TMultiParaSelection.MouseRelease; OVERRIDE; (END; 8{------------- COMMANDS -----------------} $TClearTextCmd = SUBCLASS OF TCommand &{Variables} (savedText: TText; {save the cleared text for undo} (text: TText; {the text object we are clearing} &{Creation} (FUNCTION {TClearTextCmd.}CREATE(object: TObject; heap: THeap; itsCmdNumber: TCmdNumber; IitsImage: TImage; itsText: TText): TClearTextCmd; (PROCEDURE TClearTextCmd.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TClearTextCmd.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TClearTextCmd.Commit; OVERRIDE; (PROCEDURE TClearTextCmd.Perform(cmdPhase: TCmdPhase); OVERRIDE; (END; $TStyleCmd = SUBCLASS OF TCommand &{Variables} (text: TText; (textSelection: TTextSelection; (firstFiltParaIndex: LONGINT; (lastFiltParaIndex: LONGINT; (filtFirstLP: INTEGER; (filtLastLP: INTEGER; (currFilteredPara: TEditPara; {handle to most recently filtered paragraph} (filteredStyles: TArray; {changed type styles of most recently filtered paragraph} &{Creation} (FUNCTION TStyleCmd.CREATE(object: TObject; heap: THeap; itsCmdNumber: TCmdNumber; @itsImage: TImage; @itsFirstIndex: LONGINT; itsLastIndex: LONGINT; @itsLPFirst: INTEGER; itsLPLast: INTEGER; @itsSelection: TTextSelection): TStyleCmd; (PROCEDURE TStyleCmd.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TStyleCmd.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TStyleCmd.Commit; OVERRIDE; (PROCEDURE TStyleCmd.FilterAndDo(actualObject: TObject; HPROCEDURE DoToObject(filteredObject: TObject)); OVERRIDE; (PROCEDURE TStyleCmd.Perform(cmdPhase: TCmdPhase); OVERRIDE; (END; $TTextCutCopy = SUBCLASS OF TCutCopyCommand &{Variables} (text: TText; &{Creation} (FUNCTION TTextCutCopy.CREATE(object: TObject; heap: THeap; itsCmdNumber: TCmdNumber; 3. "6F^9 eD!$ǐ^!60%0%[K,RectPlusRect(youngerRect, deltaRect, youngerRect); ,END; (youngerChild.ResizeOutside(youngerRect); (elderChild.ResizeOutside(elderRect); (SELF.outerRect := newOuterRect; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$S SgABCcld} $FUNCTION TBranchArea.TopLeftChild: TArea; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF SELF.elderFirst THEN ,TopLeftChild := SELF.elderChild (ELSE ,TopLeftChild := SELF.youngerChild; ( {INCLUDE FILE UDRAW2 -- IMPLEMENTATION OF UDRAW} {Copyright 1983, 1984, Apple Computer, Inc.} {changed 05/01 1503 Changes to allow people to use Clascal on the Workshop} {Segments: SgABCini(tialize and Terminate), SgDRWres(ident), SgABCc(o)ld, SgABCdbg} {$IFC fRngDraw} {$R+} {$ELSEC} {$R-} {$ENDC} {$IFC fSymDraw} {$D+} {$ELSEC} {$D-} {$ENDC} $CONST (magicNumber = 32768; $VAR fontID: TFontIDArray; {$S SgDRWres} {$S SgABCini} PROCEDURE TrmntExceptionHandler; $VAR ch: CHAR; (error: INTEGER; BEGIN $IF onDesktop THEN (ImDying; {This must be done first} $IF NOT amDying THEN (BEGIN ({$IFC fDbgDraw} (WriteLn('TrmntExceptionHandler'); ({$ENDC} (amDying := TRUE; (IF crashPad <> NIL THEN ,crashPad.Crash; (END; ${$IFC fDbgDraw} {Flush the input queue in case there was user typeahead to the alternate screen} $WHILE KeyPress DO (Read(ch); ${$ENDC} $IF NOT onDesktop THEN (MoveConsole(error, mainscreen); END; {$S SgDRWres} {$S SgABCini} PROCEDURE QkDrError(error: INTEGER); BEGIN ${$IFC fDbgDraw} $ABCbreak('QkDrError', error); ${$ENDC} $HALT; END; {$S SgDRWres} {$S SgABCini} PROCEDURE InitQDWM; $VAR error: INTEGER; (workDir: Pathname; (bootVol: e_name; (bootDir: Pathname; {$IFC LibraryVersion < 30} (bootPort: tports; {$ENDC} BEGIN ${$IFC libraryVersion <= 20} $InitGraf(@thePort, @QkDrError); ${$ELSEC} $InitGraf(@thePort); ${$ENDC} $crashPad := NIL; $IF onDesktop THEN (BEGIN (OpenWM; (SetPort(deskPort); (wmIsInitialized := TRUE; (END $ELSE (BEGIN ({move WriteLns to alternate screen} (MoveConsole(error, alscreen); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('MoveConsole error', error); {$ENDC} ({ set work directory to boot volume for FMOpen} (Get_Working_Dir(error, workDir); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('Get_Working_Dir error', error); {$ENDC} {$IFC LibraryVersion < 30} (bootPort := OSBootVol(error); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('OSBootVol error', error); {$ENDC} (Get_Config_Name(error, bootPort, bootVol); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('Get_Config_Name error', error); {$ENDC} {$ELSEC} (OSBootVol(error, bootVol); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('OSBootVol error', error); {$ENDC} {$ENDC} (bootDir := CONCAT('-', bootVol); (Set_Working_Dir(error, bootDir); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('Set_Working_Dir to boot vol error', error); {$ENDC} (FMOpen(error); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('FMOpen error = ', error); {$ENDC} ({ Set work directory back after OpenWM } (Set_Working_Dir(error, workDir); {$IFC fDbgDraw} (IF error > 0 THEN ,ABCBreak('Set_Working_Dir back to prefix error = ', error); {$ENDC} (END; END; {$S SgDRWres} {$S SgABCdbg} FUNCTION BindHeap(activeVsClip, doBind: BOOLEAN): THeap; BEGIN $IF crashPad = NIL THEN (BindHeap := NIL {no UABC to do it for me} $ELSE (BindHeap := crashPad.BindHeap(activeVsClip, doBind); END; {$S SgDRWres} {$S SgABCcld} FUNCTION FilerReason(error: INTEGER): FReason; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $FilerReason := allOk; $IF error > 0 THEN (CASE error OF -309: FilerReason := noDiskSpace; -315: FilerReason := noMemory; ,4001: FilerReason := badData; ,OTHERWISE FilerReason := internalError; ,END; END; {$S SgDRWres} {$S SgABCini} PROCEDURE InitErrorAbort(error: INTEGER); BEGIN $IF error > 0 THEN (BEGIN ({$IFC fDbgDraw} (ABCbreak('InitErrorAbort', error); ({$ENDC} (IF onDesktop THEN ,TellFiler(error, initFailed, FilerReason(error), NIL); (HALT; (END $ELSE $IF wmIsInitialized THEN (IF Abort THEN ,BEGIN ,IF onDesktop THEN 0TellFiler(error, initFailed, aUserAbort, NIL); ,HALT; ,END; END; {$S SgDRWres} {$S SgDRWres} PROCEDURE Reduce(VAR numerator, denominator: INTEGER); {reduce fraction to lowest terms} $VAR factor: INTEGER; (maxFactor: INTEGER; {also makes cosmetics} (smallerNumerator: INTEGER; (smallerDenominator: INTEGER; BEGIN {very crude at the moment} ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $maxFactor := MIN(numerator, denominator); $FOR factor := maxFactor DOWNTO 2 DO (BEGIN (smallerNumerator := numerator DIV factor; (smallerDenominator := denominator DIV factor; (IF (factor * smallerNumerator = numerator) AND (factor * smallerDenominator = denominator) THEN ,BEGIN ,numerator := smallerNumerator; ,denominator := smallerDenominator; ,END; (END; END; {$S SgDRWres} FUNCTION FPtPlusPt(operand1, operand2: Point): LONGINT; $VAR result: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h + operand2.h; $result.v := operand1.v + operand2.v; $FPtPlusPt := LONGINT(result); END; {$S SgDRWres} FUNCTION FPtMinusPt(operand1, operand2: Point): LONGINT; $VAR result: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h - operand2.h; $result.v := operand1.v - operand2.v; $FPtMinusPt := LONGINT(result); END; {$S SgABCdat} FUNCTION FPtMulInt(operand1: Point; operand2: INTEGER): LONGINT; $VAR result: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h * operand2; $result.v := operand1.v * operand2; $FPtMulInt := LONGINT(result); END; {$S SgABCdat} FUNCTION FPtDivInt(operand1: Point; operand2: INTEGER): LONGINT; $VAR result: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h DIV operand2; $result.v := operand1.v DIV operand2; $FPtDivInt := LONGINT(result); END; {$S SgDRWres} FUNCTION FPtMaxPt(operand1, operand2: Point): LONGINT; $VAR result: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := Max(operand1.h, operand2.h); $result.v := Max(operand1.v, operand2.v); $FPtMaxPt := LONGINT(result); END; {$S SgDRWres} FUNCTION FPtMinPt(operand1, operand2: Point): LONGINT; $VAR result: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := Min(operand1.h, operand2.h); $result.v := Min(operand1.v, operand2.v); $FPtMinPt := LONGINT(result); END; {$S SgDRWres} FUNCTION FDiagRect(operand1: Rect): LONGINT; $VAR result: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.right - operand1.left; $result.v := operand1.bottom - operand1.top; $FDiagRect := LONGINT(result); END; {$S SgABCdat} PROCEDURE BoolToStr(bool: BOOLEAN; str: TPstring); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IF bool THEN (str^ := 'TRUE' $ELSE (str^ := 'FALSE'; END; FUNCTION LIntDivLInt(i, j: LONGINT): LONGINT; $EXTERNAL; FUNCTION LIntDivInt(i: LONGINT; j: INTEGER): LONGINT; $EXTERNAL; FUNCTION LIntMulInt(i: LONGINT; j: INTEGER): LONGINT; $EXTERNAL; {$S SgDRWres} FUNCTION LIntOvrInt(i: LONGINT; j: INTEGER): LONGINT; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IF i>0 THEN (LIntOvrInt := LIntDivInt(i+(j DIV 2), j) $ELSE (LIntOvrInt := LIntDivInt(i-(j DIV 2), j); END; {$S SgABCdat} PROCEDURE PtPlusPt(operand1, operand2: Point; VAR result: Point); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h + operand2.h; $result.v := operand1.v + operand2.v; END; {$S SgABCdat} PROCEDURE PtMinusPt(operand1, operand2: Point; VAR result: Point); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h - operand2.h; $result.v := operand1.v - operand2.v; END; {$S SgABCdat} PROCEDURE PtMulInt(operand1: Point; operand2: INTEGER; VAR result: Point); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h * operand2; $result.v := operand1.v * operand2; END; {$S SgABCdat} PROCEDURE PtDivInt(operand1: Point; operand2: INTEGER; VAR result: Point); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h DIV operand2; $result.v := operand1.v DIV operand2; END; {$IFC LibraryVersion <= 20} FUNCTION EqualPt(operand1, operand2: Point): BOOLEAN; BEGIN $EqualPt := (operand1.h = operand2.h) AND (operand1.v = operand2.v); END; {$ENDC} {$S SgDRWres} PROCEDURE RectPlusRect(operand1, operand2: Rect; VAR result: Rect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.left := operand1.left + operand2.left; $result.top := operand1.top + operand2.top; $result.right := operand1.right + operand2.right; $result.bottom := operand1.bottom + operand2.bottom; END; {$S SgDRWres} PROCEDURE RectMinusRect(operand1, operand2: Rect; VAR result: Rect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.left := operand1.left - operand2.left; $result.top := operand1.top - operand2.top; $result.right := operand1.right - operand2.right; $result.bottom := operand1.bottom - operand2.bottom; END; {$IFC LibraryVersion <= 20} {$S SgDRWres} FUNCTION EqualRect(rectA, rectB: Rect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $EqualRect := (rectA.left=rectB.left) AND (rectA.top=rectB.top) AND 1(rectA.right=rectB.right) AND (rectA.bottom=rectB.bottom); END; {$S SgDRWres} FUNCTION EmptyRect(r: Rect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH r DO (EmptyRect := (left >= right) OR (top >= bottom); END; {$ENDC} {$S SgDRWres} PROCEDURE AlignRect(VAR dstRect: Rect; srcRect: Rect; vhs: VHSelect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $dstRect.topLeft.vh[vhs] := srcRect.topLeft.vh[vhs]; $dstRect.botRight.vh[vhs] := srcRect.botRight.vh[vhs]; END; {$S SgDRWres} FUNCTION LengthRect(r: Rect; vhs: VHSelect): INTEGER; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $LengthRect := r.botRight.vh[vhs] - r.topLeft.vh[vhs]; END; {$S SgDRWres} FUNCTION RectsNest(outer, inner: Rect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $RectsNest := RectHasPt(outer, inner.topLeft) AND RectHasPt(outer, inner.botRight); END; {$S SgDRWres} FUNCTION RectHasPt(dstRect: Rect; pt: Point): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $RectHasPt := (dstRect.left <= pt.h) AND (pt.h <= dstRect.right) AND 1(dstRect.top <= pt.v) AND (pt.v <= dstRect.bottom); END; {$S SgDRWres} PROCEDURE RectHavePt(dstRect: Rect; VAR pt: Point); BEGIN {if dstRect is negative size, left/top is forced} ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $pt.h := Max(dstRect.left, Min(dstRect.right, pt.h)); $pt.v := Max(dstRect.top, Min(dstRect.bottom, pt.v)); END; {$S SgDRWres} PROCEDURE RectifyRect(VAR dstRect: Rect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $Pt2Rect(dstRect.topLeft, dstRect.botRight, dstRect); END; {$S SgDRWres} FUNCTION RectIsVisible(rectInPort: Rect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $RectIsVisible := RectInRgn(rectInPort, focusRgn); END; {$S SgABCdbg} PROCEDURE PointToStr(pt: Point; str: TPstring); $VAR s: S255; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IntToStr(pt.h, str); $IntToStr(pt.v, @s); $str^ := CONCAT('(', str^, ',', s, ')'); END; {$S SgABCdbg} PROCEDURE RectToStr(r: Rect; str: TPstring); $VAR s: S255; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $PointToStr(r.topLeft, str); $PointToStr(r.botRight, @s); $str^ := CONCAT('[', str^, ',', s, ']'); END; {$S SgDRWres} {$S SgDRWres} PROCEDURE LPtPlusLPt(operand1, operand2: LPoint; VAR result: LPoint); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h + operand2.h; $result.v := operand1.v + operand2.v; END; {$S SgDRWres} PROCEDURE LPtMinusLPt(operand1, operand2: LPoint; VAR result: LPoint); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h - operand2.h; $result.v := operand1.v - operand2.v; END; {$S SgABCdat} PROCEDURE LPtMulInt(operand1: LPoint; operand2: INTEGER; VAR result: LPoint); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := operand1.h * operand2; $result.v := operand1.v * operand2; END; {$S SgABCdat} PROCEDURE LPtDivInt(operand1: LPoint; operand2: INTEGER; VAR result: LPoint); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.h := LIntDivInt(operand1.h, operand2); $result.v := LIntDivInt(operand1.v, operand2); END; {$S SgDRWres} FUNCTION EqualLPt(operand1, operand2: LPoint): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $EqualLPt := (operand1.h = operand2.h) AND (operand1.v = operand2.v); END; {$S SgDRWres} PROCEDURE LRectPlusLRect(operand1, operand2: LRect; VAR result: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.left := operand1.left + operand2.left; $result.top := operand1.top + operand2.top; $result.right := operand1.right + operand2.right; $result.bottom := operand1.bottom + operand2.bottom; END; {$S SgDRWres} PROCEDURE LRectMinusLRect(operand1, operand2: LRect; VAR result: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $result.left := operand1.left - operand2.left; $result.top := operand1.top - operand2.top; $result.right := operand1.right - operand2.right; $result.bottom := operand1.bottom - operand2.bottom; END; {$S SgDRWres} FUNCTION EqualLRect(rectA, rectB: LRect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $EqualLRect := (rectA.left=rectB.left) AND (rectA.top=rectB.top) AND 2(rectA.right=rectB.right) AND (rectA.bottom=rectB.bottom); END; {$S SgDRWres} FUNCTION EmptyLRect(r: LRect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH r DO (EmptyLRect := (left >= right) OR (top >= bottom); END; {$S SgDRWres} PROCEDURE AlignLRect(VAR destLRect: LRect; srcLRect: LRect; vhs: VHSelect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $destLRect.topLeft.vh[vhs] := srcLRect.topLeft.vh[vhs]; $destLRect.botRight.vh[vhs] := srcLRect.botRight.vh[vhs]; END; {$S SgDRWres} FUNCTION LengthLRect(r: LRect; vhs: VHSelect): LONGINT; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $LengthLRect := r.botRight.vh[vhs] - r.topLeft.vh[vhs]; END; {$S SgDRWres} FUNCTION LRectsNest(outer, inner: LRect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $LRectsNest := LRectHasLPt(outer, inner.topLeft) AND LRectHasLPt(outer, inner.botRight); END; {$S SgDRWres} FUNCTION LRectHasLPt(destLRect: LRect; pt: LPoint): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $LRectHasLPt := (destLRect.left <= pt.h) AND (pt.h <= destLRect.right) AND 3(destLRect.top <= pt.v) AND (pt.v <= destLRect.bottom); END; {$S SgDRWres} PROCEDURE LRectHaveLPt(destLRect: LRect; VAR pt: LPoint); BEGIN {if destLRect is negative size, left/top is forced} ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $pt.h := Max(destLRect.left, Min(destLRect.right, pt.h)); $pt.v := Max(destLRect.top, Min(destLRect.bottom, pt.v)); END; {$S SgDRWres} PROCEDURE RectifyLRect(VAR destLRect: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $SetLRect(destLRect, Min(destLRect.left, destLRect.right), Min(destLRect.top, destLRect.bottom), 8Max(destLRect.left, destLRect.right), Max(destLRect.top, destLRect.bottom)); END; {$S SgDRWres} FUNCTION LRectIsVisible(srcLRect: LRect): BOOLEAN; $VAR rectInPort: Rect; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $thePad.LRectToRect(srcLRect, rectInPort); $IF EmptyRect(rectInPort) THEN (LRectIsVisible := FALSE $ELSE (LRectIsVisible := RectInRgn(rectInPort, focusRgn); END; {$S SgABCdbg} PROCEDURE LPointToStr(pt: LPoint; str: TPstring); $VAR s: S255; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $LIntToStr(pt.h, str); $LIntToStr(pt.v, @s); $str^ := CONCAT('(', str^, ',', s, ')'); END; {$S SgABCdbg} PROCEDURE LRectToStr(r: LRect; str: TPstring); $VAR s: S255; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $LPointToStr(r.topLeft, str); $LPointToStr(r.botRight, @s); $str^ := CONCAT('[', str^, ',', s, ']'); END; {$S SgDRWres} {$S SgDRWres} PROCEDURE SetLPt(VAR destPt: LPoint; itsH, itsV: LONGINT); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH destPt DO (BEGIN (h := itsH; (v := itsV; (END; END; {$S SgDRWres} PROCEDURE SetLRect(VAR dstRect: LRect; itsLeft, itsTop, itsRight, itsBottom: LONGINT); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH dstRect DO (BEGIN (left := itsLeft; (top := itsTop; (right := itsRight; (bottom := itsBottom; (END; END; {$S SgDRWres} PROCEDURE OffsetLRect(VAR dstRect: LRect; dh, dv: LONGINT); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH dstRect DO (BEGIN (left := left + dh; (top := top + dv; (right := right + dh; (bottom := bottom + dv; (END; END; {$S SgDRWres} PROCEDURE InsetLRect(VAR dstRect: LRect; dh, dv: LONGINT); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH dstRect DO (BEGIN (left := left + dh; (top := top + dv; (right := right - dh; (bottom := bottom - dv; (IF (left >= right) OR (top >= bottom) THEN ,BEGIN ,left := 0; ,top := 0; ,right := 0; ,bottom := 0; ,END; (END; END; {$S SgABCres} FUNCTION SectLRect(srcRectA, srcRectB: LRect; VAR dstRect: LRect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH dstRect DO (BEGIN (left := Max(srcRectA.left, srcRectB.left); (top := Max(srcRectA.top, srcRectB.top); (right := Min(srcRectA.right, srcRectB.right); (bottom := Min(srcRectA.bottom, srcRectB.bottom); (IF (left >= right) OR (top >= bottom) THEN ,BEGIN ,SectLRect := FALSE; ,left := 0; ,top := 0; ,right := 0; ,bottom := 0; ,END (ELSE ,SectLRect := TRUE; (END; END; {$S SgDRWres} PROCEDURE UnionLRect(srcRectA, srcRectB: LRect; VAR dstRect: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $WITH dstRect DO (BEGIN (left := Min(srcRectA.left, srcRectB.left); (top := Min(srcRectA.top, srcRectB.top); (right := Max(srcRectA.right, srcRectB.right); (bottom := Max(srcRectA.bottom, srcRectB.bottom); (END; END; {$S SgDRWres} FUNCTION LPtInLRect(pt: LPoint; r: LRect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $LPtInLRect := (r.left <= pt.h) AND (pt.h < r.right) AND 2(r.top <= pt.v) AND (pt.v < r.bottom); END; {$S SgABCdat} FUNCTION IsSmallPt(srcPt: LPoint): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IsSmallPt := (ABS(srcPt.h) < MAXINT) AND (ABS(srcPt.v) < MAXINT); END; {$S SgABCdat} FUNCTION IsSmallRect(srcRect: LRect): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IsSmallRect := IsSmallPt(srcRect.topLeft) AND IsSmallPt(srcRect.botRight); END; {Drawing Text} {$S SgABCdat} PROCEDURE DrawLText(textBuf: Ptr; startByte, numBytes: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} #{$IFC libraryVersion > 20} $IF thePad.scaled THEN (thePad.DrawLText(textBuf, startByte, numBytes) $ELSE (DrawText(QDPtr(textBuf), startByte, numBytes); #{$ELSEC} $DrawText(WordPtr(textBuf), startByte, numBytes); #{$ENDC} END; {Drawing lines, rectangles, and ovals} {$S SgDRWres} PROCEDURE MoveToL(h, v: LONGINT); VAR lPtInView: LPoint; $ptInPort: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %SetLPt(lPtInView, h, v); %thePad.LPtToPt(lPtInView, ptInPort); %MoveTo(ptInPort.h, ptInPort.v); END; {$S SgDRWres} PROCEDURE MoveL(dh, dv: LONGINT); VAR lPtInView: LPoint; $ptInPort: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %SetLPt(lPtInView, dh, dv); %thePad.LDistToDist(lPtInView, ptInPort); %Move(ptInPort.h, ptInPort.v); END; {$S SgDRWres} PROCEDURE LineToL(h, v: LONGINT); VAR lPtInView: LPoint; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %SetLPt(lPtInView, h, v); %thePad.DrawLLine(lPtInView); END; {$S SgDRWres} PROCEDURE LineL(dh, dv: LONGINT); VAR lPtInView: LPoint; $ptInPort: Point; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %SetLPt(lPtInView, dh, dv); %thePad.LDistToDist(lPtInView, ptInPort); %Line(ptInPort.h, ptInPort.v); END; {$S SgDRWres} PROCEDURE FrameLRect(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRect(frame, r); END; {$S SgDRWres} PROCEDURE PaintLRect(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRect(paint, r); END; {$S SgDRWres} PROCEDURE EraseLRect(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRect(erase, r); END; {$S SgDRWres} PROCEDURE InvrtLRect(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRect(invert, r); END; {$S SgDRWres} PROCEDURE FillLRect(r: LRect; lPat: LPattern); $VAR pat: Pattern; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IF amPrinting THEN (thePad.LPatToPat(lPat, pat); {$IFC LibraryVersion <= 20} %thePat := Pattern(lPat); {$ELSEC} %thePort^.fillPat := Pattern(lPat); {$ENDC} %thePad.DrawLRect(fill, r); END; {$S SgDRWres} PROCEDURE FrameLOval(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLOval(frame, r); END; {$S SgDRWres} PROCEDURE PaintLOval(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLOval(paint, r); END; {$S SgDRWres} PROCEDURE EraseLOval(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLOval(erase, r); END; {$S SgDRWres} PROCEDURE InvrtLOval(r: LRect); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLOval(invert, r); END; {$S SgDRWres} PROCEDURE FillLOval(r: LRect; lPat: LPattern); $VAR pat: Pattern; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IF amPrinting THEN (thePad.LPatToPat(lPat, pat); {$IFC LibraryVersion <= 20} %thePat := Pattern(lPat); {$ELSEC} %thePort^.fillPat := Pattern(lPat); {$ENDC} %thePad.DrawLOval(fill, r); END; PROCEDURE FrameLRRect(r: LRect; ovalWidth, ovalHeight: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRRect(frame, r, ovalWidth, ovalHeight); END; PROCEDURE PaintLRRect(r: LRect; ovalWidth, ovalHeight: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRRect(paint, r, ovalWidth, ovalHeight); END; PROCEDURE EraseLRRect(r: LRect; ovalWidth, ovalHeight: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRRect(erase, r, ovalWidth, ovalHeight); END; PROCEDURE InvrtLRRect(r: LRect; ovalWidth, ovalHeight: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLRRect(invert, r, ovalWidth, ovalHeight); END; PROCEDURE FillLRRect(r: LRect; ovalWidth, ovalHeight: INTEGER; lPat: LPattern); $VAR pat: Pattern; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IF amPrinting THEN (thePad.LPatToPat(lPat, pat); {$IFC LibraryVersion <= 20} %thePat := Pattern(lPat); {$ELSEC} %thePort^.fillPat := Pattern(lPat); {$ENDC} %thePad.DrawLRRect(fill, r, ovalWidth, ovalHeight) END; PROCEDURE FrameLArc(r: LRect; startAngle, arcAngle: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLArc(frame, r, startAngle, arcAngle); END; PROCEDURE PaintLArc(r: LRect; startAngle, arcAngle: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLArc(paint, r, startAngle, arcAngle); END; PROCEDURE EraseLArc(r: LRect; startAngle, arcAngle: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLArc(erase, r, startAngle, arcAngle); END; PROCEDURE InvrtLArc(r: LRect; startAngle, arcAngle: INTEGER); BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} %thePad.DrawLArc(invert, r, startAngle, arcAngle); END; PROCEDURE FillLArc(r: LRect; startAngle, arcAngle: INTEGER; lPat: LPattern); $VAR pat: Pattern; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IF amPrinting THEN (thePad.LPatToPat(lPat, pat); {$IFC LibraryVersion <= 20} %thePat := Pattern(lPat); {$ELSEC} %thePort^.fillPat := Pattern(lPat); {$ENDC} %thePad.DrawLArc(fill, r, startAngle, arcAngle); END; PROCEDURE RotatePattern(pInPat, pOutPat: Ptr; dh, dv: LONGINT); $EXTERNAL; {$S SgABCdat} FUNCTION ClonePicture(pic: PicHandle; toHeap: THeap): PicHandle; $VAR h: TH; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $h := HAllocate(THz(toHeap), pic^^.picSize); $XferLeft(Ptr(pic^), Ptr(h^), pic^^.picSize); $ClonePicture := PicHandle(h); END; {$S SgDRWres} PROCEDURE ResizeFeedback(mousePt: Point; minPt, maxPt: Point; outerRect: Rect; :tabHeight, sbWidth, sbHeight: INTEGER; VAR newPt: Point); $VAR rFrame: Rect; (limitRect: Rect; (oldMousePt: Point; (innerTop: INTEGER; (fTab: BOOLEAN; (fHscroll: BOOLEAN; (fVScroll: BOOLEAN; (event: EventRecord; (savePort: GrafPtr; $PROCEDURE InitXorFrame; $BEGIN (fTab := TRUE; (fHScroll := TRUE; (fVScroll := TRUE; *{ set up scroll bar and tab widths } *{ the +1 's are to account for enlarging rFrame by one pixel } (IF sbWidth > 0 THEN ,sbWidth := sbWidth+1 (ELSE ,fVScroll := FALSE; (IF sbHeight > 0 THEN ,sbHeight := sbHeight+1 (ELSE ,fHScroll := FALSE; (IF tabHeight > 0 THEN ,tabHeight := tabHeight+1 (ELSE ,fTab := FALSE; *{ setup rFrame - the outer rect for XORing } (rFrame := outerRect; (InsetRect(rFrame, -1, -1); (limitRect.topLeft := minPt; (limitRect.botRight := maxPt; (IF fTab THEN innerTop := rFrame.top+tabHeight (ELSE innerTop := rFrame.top; *{ Setup the pen } (PenNormal; (PenPat(gray); (PenMode(notPatXor); $END; $PROCEDURE XorFrame; $BEGIN (rFrame.botRight := newPt; (FrameRect(rFrame); (IF fTab THEN ,BEGIN ,MoveTo(rFrame.left, innerTop); ,LineTo(rFrame.right-1, innerTop); ,END; (IF fHScroll THEN ,BEGIN ,MoveTo(rFrame.left, newPt.v-sbHeight); ,LineTo(rFrame.right-1, newPt.v-sbHeight); ,END; (IF fVScroll THEN ,BEGIN ,MoveTo(newPt.h - sbWidth, innerTop); ,LineTo(newPt.h - sbWidth, rFrame.bottom-1); ,END; $END; $PROCEDURE DoDragFrame; (VAR nxtPt: Point; $BEGIN (nxtPt := Point(FPtPlusPt(newPt, Point(FPtMinusPt(mousePt, oldMousePt)))); (RectHavePt(limitRect, nxtPt); (mousePt := Point(FPtPlusPt(Point(FPtMinusPt(nxtPt, newPt)), oldMousePt)); (IF NOT EqualPt(nxtPt, newPt) THEN ,BEGIN ,XorFrame; { hide old } ,newPt := nxtPt; ,XorFrame; { draw new } ,END; %END; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $InitXorFrame; { sets rFrame } $newPt := rFrame.botRight; $XorFrame; $oldMousePt := mousePt; $WHILE StillDown DO (BEGIN (GetMouse(mousePt); (DoDragFrame; (oldMousePt := mousePt; (END; $IF PeekEvent(event) AND (event.what = buttonUp) THEN (BEGIN (GetPort(savePort); (SetPort(event.who); (mousePt := event.where; (LocalToGlobal(mousePt); (SetPort(savePort); (GlobalToLocal(mousePt); (END $ELSE (GetMouse(mousePt); $DoDragFrame; $XorFrame; { hide last } $newPt.h := newPt.h - 1; $newPt.v := newPt.v - 1; END; { ResizeFeedback } {$S SgABCres} PROCEDURE PopFocus; BEGIN ${$IFC fTrace}BP(6);{$ENDC} $SetEmptyRgn(padRgn); {To save memory space} $focusArea := focusStack[focusStkPtr]; $thePad := NIL; $IF focusArea <> NIL THEN (focusArea.Focus; $focusStkPtr := focusStkPtr - 1; ${$IFC fTrace}EP;{$ENDC} END; {$S SgABCres} PROCEDURE PushFocus; BEGIN ${$IFC fTrace}BP(6);{$ENDC} $focusStkPtr := focusStkPtr + 1; $focusStack[focusStkPtr] := focusArea; ${$IFC fTrace}EP;{$ENDC} END; {$S SgDRWres} PROCEDURE MakeTypeStyle{(itsFamily: INTEGER; itsSize: INTEGER; itsFaces: TSetEFace/Style; ,VAR typeStyle: TTypeStyle)}; BEGIN ${$IFC fTrace}BP(11);{$ENDC} $WITH typeStyle DO (BEGIN (onFaces := itsFaces; (font.fontFamily := itsFamily; (font.fontSize := itsSize; (END; ${$IFC fTrace}EP;{$ENDC} END; FUNCTION QDFontNumber{(typeStyle: TTypeStyle): INTEGER}; BEGIN ${$IFC fTrace}BP(11);{$ENDC} $WITH typeStyle.font DO (IF fontFamily = famSystem THEN ,QDFontNumber := fIDSystem (ELSE ,QDFontNumber := fontID[fontFamily, fontSize]; ${$IFC fTrace}EP;{$ENDC} END; PROCEDURE SetQDTypeStyle{(typeStyle: TTypeStyle)}; BEGIN ${$IFC fTrace}BP(11);{$ENDC} $TextFont(QDFontNumber(typeStyle)); $TextFace(typeStyle.onFaces); ${$IFC fTrace}EP;{$ENDC} END; METHODS OF TArea; ${$IFC fDebugMethods} ${$S SgABCdbg} $PROCEDURE TArea.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN (Field('innerRect: Rect'); (Field('outerRect: Rect'); (Field('parentBranch: TBranchArea'); $END; ${$S SgDRWres} ${$ENDC} $FUNCTION TArea.ChildWithPt(pt: Point; childList: TList; VAR nearestPt: Point): TArea; (VAR foundArea: TArea; ,s: TListScanner; $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (RectHavePt(SELF.innerRect, pt); (s := childList.scanner; (WHILE s.Scan(foundArea) DO ,IF RectHasPt(foundArea.outerRect, pt) THEN 0s.Done; (IF foundArea = NIL THEN ,BEGIN ,{$IFC fDbgDraw} ,ABCbreak('ChildWithPt found no area', 0); ,{$ENDC} ,foundArea := TArea(childList.First); ,END; (RectHavePt(foundArea.innerRect, pt); (nearestPt := pt; (ChildWithPt := foundArea; ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TArea.Erase; $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (FillRect(SELF.innerRect, white); ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TArea.Frame; (VAR innerRect: Rect; ,borderRect: Rect; $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (innerRect := SELF.innerRect; (IF NOT RectsNest(innerRect, focusRgn^^.rgnBBox) THEN ,BEGIN ,PenNormal; ,PenSize(1, 1); ,borderRect := innerRect; ,InsetRect(borderRect, -1, -1); ,FrameRect(borderRect); ,END; ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TArea.GetBorder(VAR border: Rect); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SetRect(border, -1, -1, 1, 1); ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TArea.SetInnerRect(newInnerRect: Rect); (VAR border: Rect; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (SELF.innerRect := newInnerRect; (SELF.GetBorder(border); "{$H-} RectPlusRect(SELF.innerRect, border, SELF.outerRect); {$H+} ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TArea.SetOuterRect(newOuterRect: Rect); (VAR border: Rect; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (SELF.outerRect := newOuterRect; (SELF.GetBorder(border); "{$H-} RectMinusRect(SELF.outerRect, border, SELF.innerRect); {$H+} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCini} BEGIN (fontID[famModern, size20Pitch] := fID20Pitch; (fontID[famModern, size15Pitch] := fID15Pitch; (fontID[famModern, size10Pitch] := fIDm10Pitch; (fontID[famModern, size12Pitch] := fIDm12Pitch; (fontID[famModern, size12Point] := fIDm12Point; (fontID[famModern, size14Point] := fIDm14Point; (fontID[famModern, size18Point] := fIDm18Point; (fontID[famModern, size24Point] := fIDm24Point; (fontID[famClassic, size20Pitch] := fID20Pitch; (fontID[famClassic, size15Pitch] := fID15Pitch; (fontID[famClassic, size10Pitch] := fIDc10Pitch; (fontID[famClassic, size12Pitch] := fIDc12Pitch; (fontID[famClassic, size12Point] := fIDc12Point; (fontID[famClassic, size14Point] := fIDc14Point; (fontID[famClassic, size18Point] := fIDc18Point; (fontID[famClassic, size24Point] := fIDc24Point; (MakeTypeStyle(famSystem, 0 {dummy}, [], sysTypeStyle); END; {$S SgDRWres} METHODS OF TPad; ${$S sCldInit} $FUNCTION TPad.CREATE(object: TObject; heap: THeap; itsInnerRect: Rect; itsViewedLRect: LRect; 8itsPadRes, itsViewRes: Point; 8itsPort: GrafPtr): TPad; (VAR zoomFactor: TScaler; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF object = NIL THEN ,object := NewObject(heap, THISCLASS); (SELF := TPad(object); (SELF.parentBranch := NIL; (SetPt(zoomFactor.numerator, 1, 1); (SetPt(zoomFactor.denominator, 1, 1); (SELF.Redefine(itsInnerRect, itsViewedLRect, itsPadRes, itsViewRes, 6zoomFactor, itsPort); ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$S sCldInit} $PROCEDURE TPad.Redefine(itsInnerRect: Rect; itsViewedLRect: LRect; 5itsPadRes, itsViewRes: Point; 5itsZoomFactor: TScaler; itsPort: GrafPtr); (VAR vhs: VHSelect; ,newOffset: LPoint; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (SELF.SetInnerRect(itsInnerRect); (WITH SELF, scaleFactor DO %{$H-} BEGIN ,port := itsPort; ,viewedLRect := itsViewedLRect; ,availLRect := itsViewedLRect; ,InsetLRect(availLRect, -8192, -8192); ,clippedRect := itsInnerRect; ,zoomFactor := itsZoomFactor; +{install new Resolutions} ,padRes := itsPadRes; ,viewedRes := itsViewRes; +{compute scale factor from resolutions and zoom factor} ,FOR vhs := v TO h DO 0BEGIN 0numerator.vh[vhs] := itsPadRes.vh[vhs] * zoomFactor.numerator.vh[vhs]; 0denominator.vh[vhs] := itsViewRes.vh[vhs] * zoomFactor.denominator.vh[vhs]; 0Reduce(numerator.vh[vhs], denominator.vh[vhs]); 0END; ,scaled := (numerator.h <> denominator.h) OR (numerator.v <> denominator.v); +{compute scroll offset} ,FOR vhs := v TO h DO 0newOffset.vh[vhs] := 1LIntOvrInt(LIntMulInt(itsViewedLRect.topLeft.vh[vhs], Gnumerator.vh[vhs]),  NIL THEN ,IF dataSize <> 4 THEN 0BEGIN 0pData := TpLongint(ORD(dataHandle^)); 0CASE kind OF 4picForeColor: 8ForeColor(pData^); 4picBackColor: 8BackColor(pData^); 4END; 0END; $END; {This is still not the right implementation when we are printing} $PROCEDURE TPad.DrawLPicture(pic: PicHandle; r:LRect); (VAR rectInPort: Rect; ,oldProcsPtr: QDProcsPtr; ,TKProcs: QDProcs; ,oldTextProc: QDPtr; ,oldCommentProc: QDPtr; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (WITH thePort^ DO ,BEGIN ,oldProcsPtr := grafprocs; ,IF oldProcsPtr = NIL THEN 0BEGIN 0SetStdProcs(TKProcs); 0grafprocs := @TKProcs; 0END; ,WITH grafprocs^ DO 0BEGIN 0oldTextProc := textProc; 0oldCommentProc := commentProc; 0IF amPrinting THEN 4BEGIN 4textProc := @TKStdText; 4commentProc := @TKStdComment; 4END; 0END; ,END; (SELF.LRectToRect(r, rectInPort); (DrawPicture(pic, rectInPort); (WITH thePort^ DO ,BEGIN ,IF oldProcsPtr <> NIL THEN 0WITH grafprocs^ DO 4BEGIN 4textProcs := oldTextProc; 4commentProc := oldCommentProc; 4END; ,grafProcs := oldProcsPtr; ,END; $END; {$ENDC} $PROCEDURE TPad.DrawLRect(verb: GrafVerb; r: LRect); $VAR rectInPort: Rect; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (SELF.LRectToRect(r, rectInPort); (StdRect(verb, rectInPort); $END; $PROCEDURE TPad.DrawLRRect(verb: GrafVerb; r: LRect; ovalWidth, ovalHeight: INTEGER); $VAR rectInPort: Rect; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (SELF.LRectToRect(r, rectInPort); (StdRRect(verb, rectInPort, ovalWidth, ovalHeight); $END; $PROCEDURE TPad.DrawLOval(verb: GrafVerb; r: LRect); $VAR rectInPort: Rect; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (SELF.LRectToRect(r, rectInPort); (StdOval(verb, rectInPort); $END; $PROCEDURE TPad.DrawLArc(verb: GrafVerb; r: LRect; startAngle, arcAngle: INTEGER); $VAR rectInPort: Rect; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (SELF.LRectToRect(r, rectInPort); (StdArc(verb, rectInPort, startAngle, arcAngle); $END; $PROCEDURE TPad.DrawLBits(VAR srcBits: BitMap; VAR srcRect: Rect; @VAR dstLRect: LRect; mode: INTEGER; maskRgn: RgnHandle); $VAR dstGrafRect: Rect; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (SELF.LRectToRect(dstLRect, dstGrafRect); (StdBits(srcBits, srcRect,dstGrafRect, mode, maskRgn); $END; {$S SgABCres} $PROCEDURE TPad.Focus; (VAR visRgn: RgnHandle; ,origin: Point; $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (IF SELF.Port <> printerPseudoPort THEN ,SetPort(SELF.port); {for the moment anyway don't tamper if being controlled by LisaPrint} (SetOrigin(0, 0); {so thePort^.visRgn will be relative to a (0,0)-origined space, to match @SELF.clippedRect and altVisRgn} (RectRgn(padRgn, SELF.clippedRect); (IF useAltVisRgn THEN ,visRgn := altVisRgn {Instigated by TWindow.StashPicture or TClipboard.Publicize} (ELSE ,visRgn := thePort^.visRgn; (SectRgn(padRgn, visRgn, padRgn); (origin := SELF.origin; (WITH origin DO {+LSR+} ,BEGIN ,SetOrigin(h, v); ,OffsetRgn(padRgn, h, v); ,END; (SetClip(padRgn); (focusRgn := padRgn; {focusRgn is an alias for either padRgn or visRgn} (focusArea := SELF; (thePad := SELF; (WITH SELF DO &{$H-} BEGIN ,SELF.RectToLRect(focusRgn^^.rgnBBox, visLRect); ,IF SectLRect(viewedLRect, visLRect, visLRect) THEN 0BEGIN END; &{$H+} END; ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.InvalLRect(r: LRect); (VAR rectInPort: Rect; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (SELF.LRectToRect(r, rectInPort); (SELF.InvalRect(rectInPort); ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.InvalRect(r: Rect); $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF SectRect(r, focusRgn^^.rgnBBox, r) THEN ,InvalRect(r); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgDRWres} $PROCEDURE TPad.LDistToDist(lDistInView: LPoint; VAR distInPort: Point); $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (IF SELF.scaled THEN ,WITH SELF.scaleFactor DO *{$H-} BEGIN 0distInPort.h := LIntOvrInt(LIntMulInt(lDistInView.h, numerator.h), denominator.h); 0distInPort.v := LIntOvrInt(LIntMulInt(lDistInView.v, numerator.v), denominator.v); *{$H+} END (ELSE ,BEGIN ,distInPort.h := lDistInView.h; ,distInPort.v := lDistInView.v; ,END; ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.LPatToPat(lPatInView: LPattern; VAR patInPort: Pattern); $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (IF amPrinting THEN ,RotatePattern(@lPatInView, @patInPort, SELF.cdOffset.h, SELF.cdOffset.v) (ELSE ,patInPort := Pattern(lPatInView); {+LSR+} ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.LPtToPt(lPtInView: LPoint; VAR ptInPort: Point); $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (LRectHaveLPt(SELF.availLRect, lPtInView); (WITH SELF, cdOffset, scaleFactor DO {+LSR+} ,IF scaled THEN *{$H-} BEGIN 0ptInPort.h := LIntOvrInt(LIntMulInt(lPtInView.h, numerator.h), denominator.h) - h; 0ptInPort.v := LIntOvrInt(LIntMulInt(lPtInView.v, numerator.v), denominator.v) - v; *{$H+} END ,ELSE 0BEGIN 0ptInPort.h := lPtInView.h - h; 0ptInPort.v := lPtInView.v - v; 0END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCres} $PROCEDURE TPad.LRectToRect(lRectInView: LRect; VAR rectInPort: Rect); $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (LRectHaveLPt(SELF.availLRect, lRectInView.topLeft); (LRectHaveLPt(SELF.availLRect, lRectInView.botRight); (WITH SELF, cdOffset, scaleFactor DO {+LSR+} ,IF scaled THEN *{$H-} BEGIN 0rectInPort.left := LIntOvrInt(LIntMulInt(lRectInView.left, numerator.h), denominator.h) - h; 0rectInPort.top := LIntOvrInt(LIntMulInt(lRectInView.top, numerator.v), denominator.v) - v; 0rectInPort.right := LIntOvrInt(LIntMulInt(lRectInView.right, numerator.h), denominator.h) - h; 0rectInPort.bottom := LIntOvrInt(LIntMulInt(lRectInView.bottom, numerator.v), denominator.v) E- v; *{$H+} END ,ELSE 0BEGIN 0rectInPort.left := lRectInView.left - h; 0rectInPort.top := lRectInView.top - v; 0rectInPort.right := lRectInView.right - h; 0rectInPort.bottom := lRectInView.bottom - v; 0END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgDRWres} $PROCEDURE TPad.OffsetBy(deltaLPt: LPoint); (VAR vhs: VHSelect; ,newOffset: LPoint; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (WITH SELF, deltaLPt DO &{$H-} BEGIN ,OffsetLRect(viewedLRect, h, v); ,OffsetLRect(availLRect, h, v); &{$H+} END; (FOR vhs := v TO h DO {$H-} {+LSR+} ,WITH SELF, scaleFactor DO 0newOffset.vh[vhs] := LIntOvrInt(LIntMulInt(viewedLRect.topLeft.vh[vhs], ^numerator.vh[vhs]), Sdenominator.vh[vhs]) - innerRect.topLeft.vh[vhs]; ({$H+} (SELF.SetScrollOffset(newOffset); ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.PatToLPat(patInPort: Pattern; VAR lPatInView: LPattern); $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (IF amPrinting THEN ,RotatePattern(@patInPort, @lPatInView, -SELF.cdOffset.h, -SELF.cdOffset.v) (ELSE ,LPatInView := LPattern(patInPort); {+LSR+} ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.PtToLPt(ptInPort: Point; VAR lPtInView: LPoint); ${$IFC fDbgDraw} $VAR pt: Point; (s: S255; ${$ENDC} $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (WITH SELF, cdOffset, scaleFactor DO {+LSR+} ,IF scaled THEN *{$H-} BEGIN 0lPtInView.h := LIntOvrInt(LIntMulInt(ptInPort.h + h, denominator.h), numerator.h); 0lPtInView.v := LIntOvrInt(LIntMulInt(ptInPort.v + v, denominator.v), numerator.v); *{$H+} END (ELSE ,BEGIN ,lPtInView.h := ptInPort.h + h; ,lPtInView.v := ptInPort.v + v; ,END; ({$IFC fDbgDraw} (SELF.LPtToPt(lPtInView, pt); (IF NOT EqualPt(pt, ptInPort) THEN ,BEGIN ,PointToStr(ptInPort, @s); ,writeln('ptInPort:', s); ,LPointToStr(lPtInView, @s); ,writeln('lPtInView:',s); ,PointToStr(pt, @s); ,writeln('pt:', s); ,WrObj(SELF, 1, ''); ,writeln; ,ABCbreak('Error in TPad.PtToLPt', 0); ,END; ({$ENDC} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCres} $PROCEDURE TPad.RectToLRect(rectInPort: Rect; VAR lRectInView: LRect); $BEGIN ({$IFC fTrace}BP(6);{$ENDC} (WITH SELF, cdOffset, scaleFactor DO {+LSR+} ,IF scaled THEN *{$H-} BEGIN 0lRectInView.left := 4LIntOvrInt(LIntMulInt(rectInPort.left + h, denominator.h), numerator.h); 0lRectInView.top := 4LIntOvrInt(LIntMulInt(rectInPort.top + v, denominator.v), numerator.v); 0lRectInView.right := 4LIntOvrInt(LIntMulInt(rectInPort.right + h, denominator.h), numerator.h); 0lRectInView.bottom := 4LIntOvrInt(LIntMulInt(rectInPort.bottom + v, denominator.v), numerator.v); *{$H+} END (ELSE ,BEGIN ,lRectInView.left := rectInPort.left + h; ,lRectInView.top := rectInPort.top + v; ,lRectInView.right := rectInPort.right + h; ,lRectInView.bottom := rectInPort.bottom + v; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgDRWres} $PROCEDURE TPad.SetPen(pen: PenState); (VAR lPat: LPattern; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF amPrinting THEN ,BEGIN ,noPad.PatToLPat(pen.pnPat, lPat); ,SELF.LPatToPat(lPat, pen.pnPat); ,END; (SetPenState(pen); ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.SetPenToHighlight(highTransit: THighTransit); $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (SELF.SetPen(highPen[highTransit]); ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TPad.SetScrollOffset(VAR newOffset: LPoint); 8{recalculates the origin and cdOffset fields; does not change arg} (VAR vhs: VHSelect; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (WITH SELF DO ,BEGIN ,scrollOffset := newOffset; ,FOR vhs := v TO h DO 0BEGIN 0origin.vh[vhs] := newOffset.vh[vhs] MOD magicNumber; 0cdOffset.vh[vhs] := newOffset.vh[vhs] - origin.vh[vhs]; 0END; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S Override} $PROCEDURE TPad.SetZoomFactor; {.... ONLY SEEMS TO BE RELEVANT FOR PANE--NONSENSE HERE FOR NOW} $BEGIN ({$IFC fTrace}BP(7);{$ENDC} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TPad.DrawLText(textBuf: Ptr; startByte, numBytes: INTEGER); $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (WITH SELF.zoomFactor DO {$H-} #{$IFC libraryVersion > 20} ,StdText(numBytes, QDPtr(ORD(textBuf) + startByte), numerator, denominator); #{$ELSEC} ,DrawText(WordPtr(textBuf), startByte, numBytes); #{$ENDC} {$H+} $END; {$S SgDRWres} {$S SgABCini} BEGIN $UnitAuthor('Apple'); $printerPseudoPort := POINTER(0); $crashPad := NIL; $SetPt(screenRes, 90, 60); $lPatWhite := LPattern(white); $lPatBlack := LPattern(black); $lPatGray := LPattern(gray); $lPatLtGray := LPattern(ltGray); $lPatDkGray := LPattern(dkGray); $amPrinting := FALSE; END; {$S SgDRWres} METHODS OF TBranchArea; ${$S SgABCcld} $FUNCTION TBranchArea.CREATE(object: TObject; heap: THeap; vhs: VHSelect; hasElderFirst: BOOLEAN; EwhoCanResizeIt: TResizability; EitsElderChild, itsYoungerChild: TArea): TBranchArea; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF object = NIL THEN ,object := NewObject(heap, THISCLASS); (SELF := TBranchArea(object); (WITH SELF DO ,BEGIN ,outerRect := itsElderChild.outerRect; ,parentBranch := itsElderChild.parentBranch; ,arrangement := vhs; ,elderFirst := hasElderFirst; ,resizability := whoCanResizeIt; ,elderChild := itsElderChild; ,youngerChild := itsYoungerChild; ,END; (itsElderChild.parentBranch := SELF; (itsYoungerChild.parentBranch := SELF; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$IFC fDebugMethods} ${$S SgABCdbg} $PROCEDURE TBranchArea.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN (TArea.Fields(Field); (Field('arrangement: Byte'); (Field('elderFirst: BOOLEAN'); (Field('resizability: Byte'); (Field('elderChild: TArea'); (Field('youngerChild: TArea'); $END; ${$S SgDRWres} ${$ENDC} ${$S SgABCcld} $PROCEDURE TBranchArea.GetMinExtent(VAR minExtent: Point; windowIsResizingIt: BOOLEAN); (VAR elderMinSize: Point; ,youngerMinSize: Point; ,vhs: VHSelect; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (vhs := SELF.arrangement; (SELF.elderChild.GetMinExtent(elderMinSize, TRUE); (SELF.youngerChild.GetMinExtent(youngerMinSize, TRUE); (IF windowIsResizingIt AND NOT (windowCanResizeIt IN SELF.resizability) THEN ,youngerMinSize.vh[vhs] := LengthRect(SELF.youngerChild.outerRect, vhs); (minExtent.vh[vhs] := elderMinSize.vh[vhs] + youngerMinSize.vh[vhs]; (vhs := orthogonal[vhs]; (minExtent.vh[vhs] := Max(elderMinSize.vh[vhs], youngerMinSize.vh[vhs]); ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$S SgABCcld} $FUNCTION TBranchArea.OtherChild(child: TArea): TArea; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF SELF.elderChild = child THEN ,OtherChild := SELF.youngerChild (ELSE ({$IFC fDbgDraw} (IF SELF.youngerChild = child THEN ,OtherChild := SELF.elderChild (ELSE ,ABCBreak('This panel branch does not have a child that is', ORD(child)); ({$ELSEC} ,OtherChild := SELF.elderChild; ({$ENDC} ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$S SgABCcld} $PROCEDURE TBranchArea.Redivide(newCd: INTEGER); (VAR elderRect: Rect; ,youngerRect: Rect; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (elderRect := SELF.elderChild.outerRect; (youngerRect := SELF.youngerChild.outerRect; (TRectCoords(elderRect)[SELF.elderFirst].vh[SELF.arrangement] := newCd; (TRectCoords(youngerRect)[NOT SELF.elderFirst].vh[SELF.arrangement] := newCd; (SELF.elderChild.ResizeOutside(elderRect); (SELF.youngerChild.ResizeOutside(youngerRect); ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$S SgABCcld} $PROCEDURE TBranchArea.ReplaceChild(child, newChild: TArea); $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF SELF.elderChild = child THEN ,SELF.elderChild := newChild (ELSE ({$IFC fDbgDraw} (IF SELF.youngerChild = child THEN ,SELF.youngerChild := newChild (ELSE ,ABCBreak('This panel branch does not have a child that is', ORD(child)); ({$ELSEC} ,SELF.youngerChild := newChild; ({$ENDC} (newChild.parentBranch := SELF; (IF child.parentBranch = SELF THEN ,child.parentBranch := NIL; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$S SgABCcld} $PROCEDURE TBranchArea.ResizeOutside(newOuterRect: Rect); (VAR formerRect: Rect; ,elderChild: TArea; ,youngerChild: TArea; ,elderRect: Rect; ,youngerRect: Rect; ,vhs: VHSelect; ,eldFirst: BOOLEAN; ,minExtents: ARRAY [FALSE..TRUE] OF Point; ,newCd: INTEGER; ,deltaRect: Rect; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (formerRect := SELF.outerRect; (elderChild := SELF.elderChild; (youngerChild := SELF.youngerChild; (elderRect := elderChild.outerRect; (youngerRect := youngerChild.outerRect; (vhs := SELF.arrangement; (eldFirst := SELF.elderFirst; (IF windowCanResizeIt IN SELF.resizability THEN ,BEGIN {both children resize proportionally} ,MapRect(elderRect, formerRect, newOuterRect); ,MapRect(youngerRect, formerRect, newOuterRect); ,elderChild.GetMinExtent(minExtents[NOT eldFirst], TRUE); ,youngerChild.GetMinExtent(minExtents[eldFirst], TRUE); ,IF (minExtents[FALSE].vh[vhs] + minExtents[TRUE].vh[vhs]) < LengthRect(newOuterRect, vhs) THEN 0BEGIN {It is possible to satisfy both min constraints, so do so} 0newCd := Max(newOuterRect.topLeft.vh[vhs] + minExtents[FALSE].vh[vhs], =Min(newOuterRect.botRight.vh[vhs] - minExtents[TRUE].vh[vhs], ATRectCoords(elderRect)[eldFirst].vh[vhs])); 0TRectCoords(elderRect)[eldFirst].vh[vhs] := newCd; 0TRectCoords(youngerRect)[NOT eldFirst].vh[vhs] := newCd; 0END; ,END (ELSE ,BEGIN {only elder child resizes in my direction} ,RectMinusRect(newOuterRect, formerRect, deltaRect); ,RectPlusRect(elderRect, deltaRect, elderRect); ,TRectCoords(deltaRect)[NOT eldFirst].vh[vhs] := TRectCoords(deltaRect)[eldFirst].vh[vhs]; ,RectPlusRect(youngerRect, deltaRect, youngerRect); ,END; (youngerChild.ResizeOutside(youngerRect); (elderChild.ResizeOutside(elderRect); (SELF.outerRect := newOuterRect; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} ${$S SgABCcld} $FUNCTION TBranchArea.TopLeftChild: TArea; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (IF SELF.elderFirst THEN ,TopLeftChild := SELF.elderChild (ELSE ,TopLeftChild := SELF.youngerChild; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgDRWres} {$S SgABCini} END; {$S SgDRWres} {$S SgABCini} 3. "6F^9. D!$ǐ^QXbbs\K ] OF Byte} e of the above forms} lly! m; 8̇nZ ̆̇v̇n̆r '8̇n¦ ̆˜ands. *** File LIBTK/UOBJECT4.text *** 2505 Write('Na0SUPERSELF.Fields(Field); .{The following type names are recognized by the parser} 0Field('flag: BOOLEAN'); 0Field('coCode: Byte'); 0Field('inputChar: CHAR'); 0Field('version: INTEGER'); 0Field('width: LONGINT'); 0Field('viewLPtUNIT UObject; {Copyright 1983, 1984, Apple Computer, Inc.} {Implementation is in UOBJECT2-3-4} {$SETC IsIntrinsic := TRUE} {$IFC IsIntrinsic} INTRINSIC; {$ENDC} {$SETC ErrsToFile := TRUE } {$IFC ErrsToFile} {$E+} {****************************************} {$E ERRS.TEXT} {****************************************} {$ENDC} {NOTE: The implementation of class TObject is quite obscure because this is actually system-type code} {Segments: SgABCini(tialize), SgABCdat(a structures), SgABCdbg} { =========================================== SPECIFICALLY IN UObject ========================================= ----------CLASSES------ ------------------VARIABLES-------------------- ------------- COMMENTS ---------- "TObject $TCollection size dynOffset holeStart holeSize holeStd -- indexed access (At, InsAt, oEach) (TList -- contains object handles (TArray recordBytes -- contains records (even qlengths) (TString -- contains characters (TFile path scanners -- disk file (Exists, Rename) $TScanner collection position increment scanDone atEnd -- sequential access (Scan, oInsert) (TListScanner -- an object at a time (TArrayScanner -- a record at a time (TStringScanner error actual -- a character at a time (Xfer) ,TFileScanner accesses refnum -- through a whole TFile ========================================= IN ALL DATA STRUCTURE UNITS ======================================= /=== KEY ===> $ = in UObject @ = in UHuge * in UDb # in UMac ----------CLASSES---------- ---------------VARIABLES------------------- ------------- COMMENTS ---------- $ TObject $ TCollection size dynOffset holeStart holeSize holeStd -- indexed access (At, InsAt, oEach) $ TList -- contains object handles "@ TLinkList head tail -- stored in TLinks "@ THugeList hugeArray -- stored in linked blocks $ TArray recordBytes -- contains records (even qlengths) "@ THugeArray minBlockLength maxBlockLength blocks -- impl. with linked blocks $ TString -- contains characters $ TFile path scanners -- disk file (Exists, Rename) "* TDb -- contains keyed records "* TDbFile file rScanDesc -- key is a PAOC/String "* TRsFile endIncrement firstKey lastKey scanners -- key is a LONGINT (SwapIn) "* TDbRsFile dbFile -- implemented with a uTDbFile (# TMcRsFile ??? -- implemented in the Mac uROM $ TScanner collection position increment scanDone atEnd -- sequential access (Scan, oInsert) $ TListScanner -- an object at a time "@ TLnkLstScanner scanLink "@ THgeLstScanner blkArrScanner $ TArrayScanner -- a record at a time "@ THgeArrScanner cacheBlock cacheIndex -- through a THugeArray $ TStringScanner error actual -- a character at a time (Xfer) $ TFileScanner accesses refnum -- through a whole TFile "* TRsScanner whichWay key buffer -- through a single resource "* TDbScanner error -- a key at a time "* TDbFiScanner rScanDesc -- through a TDbFile "* TRsFiScanner -- a resource at a time "* TDbRsFiScanner dbRecSeq dbRecSize -- through a TDbRsFile (# TMcRsFiScanner ??? -- implemented in the Mac uROM "@ TLink element next -- has one element of a TLinkList } INTERFACE {$SETC LibraryVersion := 30 } { 10 = 1.0 libraries; 13 = 1.3 libraries; 20 = Pepsi, @29 = V12.0 Libraries, 30 = V13.0+ libraries } {$SETC compatibleLists := FALSE } USES $UnitStd, $UnitHz, ${$U -#BOOT-SysCall } SysCall, {$IFC LibraryVersion > 20} ${$U LIBTK/Passwd } Passwd, {$ENDC} {$IFC LibraryVersion <= 20} ${$U UClascal} UClascal, {$ELSEC} {$IFC LibraryVersion < 30} ${$U LIBTK/UClascal} UClascal, {Needed for interface} {$ELSEC} ${$U LIBPL/UClascal} UClascal, {Needed for interface} {$ENDC} {$ENDC} &{ The next units needed to find out where the printer is located, from parameter memory, (so we can tell Paslib where it is. (Needed for debugger Output Redirect.) } %PmDecl, %Pmm, {$IFC LibraryVersion > 10} %{$U LIBPL/PaslibCall} PaslibCall, %{$U LIBPL/PPasLibc } PPasLibC, {$ENDC} %{$U HWInt} HWInt; {$SETC fDbgOK := TRUE}{FALSE} {override UnitStd to test Tool Kit} {$SETC fSymOK := TRUE}{FALSE} {override UnitStd to test Tool Kit} {$SETC fDbgObject := fDbgOK} {$SETC fRngObject := fDbgOK} {$SETC fSymObject := fSymOK} {$SETC fDebugMethods := fDbgObject} {include debugging methods in the compilation} {$SETC fCheckHeap := fDbgObject} {if VAR also true, check heap} {$SETC fTrace := fDbgObject} {if VAR also true, trace entries/exits} {$SETC fMaxTrace := fTrace AND FALSE} {if TRUE trace entries/exits on minor procedures too} {$SETC fCheckIndices := fDbgObject} {if VAR also true, check subscripts} CONST $prcsLdsn = 1; {ldsn for the process data segment} $prcsDsBytes = 15000; {default heap size for a process data segment} $MaxBreaks = 10; $outputRMargin = 85; $erInternal = 4200; {Stolen from list of errors in UABC for newHeap} $MAXLINT = $7FFFFFFF; TYPE "{Aliases needed to compile QuickDraw} $Ptr = ^LONGINT; $ProcPtr = Ptr; $Handle = ^Ptr; "{Aliases for commonly used types} $S8 = STRING[8]; $S255 = STRING[255]; $TFilePath = S255; {Increased from 66 because of the new hierarchical file system;  write only class; 2numLevels=1 => write class, non-Object fields, and class of Object fields 2etc.} ({$ENDC} &{Version Conversion} (PROCEDURE TObject.Convert(fromVersion: Byte); {Override it to finish conversion from an old version} (FUNCTION TObject.JoinClass(newClass: TClass): TObject; {Called for you by version conversion} (END; $TCollecHeader = RECORD (classPtr: TClass; (size: LONGINT; {number of real elements, not counting the hole} (dynStart: INTEGER; {bytes from the class ptr to the dynamic data; MAXINT if none allowed} (holeStart: INTEGER; {0 = at the beginning, size = at the end; MAXINT = none allowed} (holeSize: INTEGER; {measured in MemberBytes units} (holeStd: INTEGER; {if the holeSize goes to 0, how much to grow the collection by} (END; $TFastString = RECORD {only access ch[i] when hole is at end & TString is not subclassed} (header: TCollecHeader; (ch: PACKED ARRAY[1..32740] OF CHAR; (END; $TPFastString = ^TFastString; $THFastString = ^TPFastString; $TArrayHeader = RECORD (classPtr: TClass; (size: LONGINT; {number of real elements, not counting the hole} (dynStart: INTEGER; {bytes from the class ptr to the dynamic data} (holeStart: INTEGER; {0 means hole at the beginning, size means hole at the end} (holeSize: INTEGER; {measured in MemberBytes units} (holeStd: INTEGER; {if the holeSize goes to 0, how much to grow the collection by} (recordBytes: INTEGER; (END; $TCollection = SUBCLASS OF TObject &{Variables} (size: LONGINT; {number of real elements, not counting the hole} (dynStart: INTEGER; {bytes from the class ptr to the dynamic data} (holeStart: INTEGER; {0 means hole at the beginning, size means hole at the end} (holeSize: INTEGER; {measured in MemberBytes units} (holeStd: INTEGER; {if the holeSize goes to 0, how much to grow the collection by} ({The field "size" is a LONGINT for the benefit of huge collections like remote data bases. )It is always in the INTEGER range for non-subclassed TLists, TArrays, and TStrings. )The field "dynStart" is an offset from Handle(collection)^ and tells where the dynamic part )of the data is stored, if any. This convention allows subclasses to add fields. )When editing a collection, there may be an unused "hole" somewhere in the storage block. The )fields "holeStart" and "holeSize" specify (in member-sized units) the starting index of the )hole and the length of the hole. When holeSize is zero, there is no hole. If members are )added when there is no hole, the storage block is expanded to allow for at least another )"holeStd" members. )CREATE has an argument that lets the initial collection have a hole at the end, so that )Ins- methods can be called to initialize the collection without any storage allocation. )StartEdit sets holeStd to its argument, which forces subsequent edit methods to leave intact )any hole they might form. StopEdit squeezes out the hole and sets holeStd to zero, which )forces subsequent edit methods that get called with no hole to squeeze out any hole they may form. )Thus, every StartEdit that has a nonzero argument should be terminated by a call on StopEdit to )save space.} &{Creation and Destruction} (FUNCTION TCollection.CREATE(object: TObject; heap: THeap; initialSlack: INTEGER): TCollection; (FUNCTION TCollection.Clone(heap: THeap): TObject; OVERRIDE; &{Attributes} (FUNCTION TCollection.MemberBytes: INTEGER; ABSTRACT; (FUNCTION TCollection.Equals(otherCollection: TCollection): BOOLEAN; &{Slack control} (PROCEDURE TCollection.StartEdit(withSlack: INTEGER); (PROCEDURE TCollection.StopEdit; &{Generic Inserts} (PROCEDURE TCollection.InsManyAt(i: LONGINT; otherCollection: TCollection; index, howMany: LONGINT); (PROCEDURE TCollection.InsNullsAt(i, howMany: LONGINT); #(* BEGIN CONCEPTUAL METHODS (parameter types differ in subclasses; sometimes extra parameters required) &{Enumerate members} (PROCEDURE TCollection.Each(PROCEDURE DoToMember(member: "TMember")); CONCEPTUAL; (FUNCTION TCollection.Pos(after: LONGINT; member: "TMember"): LONGINT; CONCEPTUAL; (FUNCTION TCollection.Scanner: TScanner; CONCEPTUAL; {c.ScannerFrom(-MaxLInt, scanForward)} (FUNCTION TCollection.ScannerFrom(firstToScan: LONGINT; scanDirection: TScanDirection) I: TScanner; CONCEPTUAL; &{Inspect members} (FUNCTION TCollection.At(i: LONGINT): "TMember"; CONCEPTUAL; (FUNCTION TCollection.First: "TMember"; CONCEPTUAL; (FUNCTION TCollection.Last: "TMember"; CONCEPTUAL; (FUNCTION TCollection.ManyAt(i, howMany: LONGINT): "TCollection"; CONCEPTUAL; &{Insert members} (PROCEDURE TCollection.InsAt(i: LONGINT; member: "TMember"); CONCEPTUAL; (PROCEDURE TCollection.InsFirst(member: "TMember"); CONCEPTUAL; (PROCEDURE TCollection.InsLast(member: "TMember"); CONCEPTUAL; &{Delete members} (PROCEDURE TCollection.DelAll; CONCEPTUAL; (PROCEDURE TCollection.DelAt(i: LONGINT); CONCEPTUAL; (PROCEDURE TCollection.DelFirst; CONCEPTUAL; (PROCEDURE TCollection.DelLast; CONCEPTUAL; (PROCEDURE TCollection.DelManyAt(i, howMany: LONGINT); CONCEPTUAL; &{Change member} (PROCEDURE TCollection.PutAt(i: LONGINT; member: "TMember"); CONCEPTUAL; #END CONCEPTUAL METHODS *) &{Private methods -- to be called by subclasses only!!!} ({$IFC fRngObject} (PROCEDURE TCollection.CheckIndex(index: LONGINT); ({$ENDC} (FUNCTION TCollection.AddrMember(i: LONGINT): LONGINT; {The address is only valid momentarily} (PROCEDURE TCollection.CopyMembers(dstAddr, startIndex, howMany: LONGINT); (PROCEDURE TCollection.EditAt(atIndex: LONGINT; deltaMembers: INTEGER); {Transfers no data} (PROCEDURE TCollection.ResizeColl(membersPlusHole: INTEGER); {Resizes at end, no fields changed} (PROCEDURE TCollection.ShiftColl(afterSrcIndex, afterDstIndex, howMany: INTEGER); {No fields changed} (END; $TList = SUBCLASS OF TCollection &{Variables} &{Creation and Destruction} (FUNCTION TList.CREATE(object: TObject; heap: THeap; initialSlack: INTEGER): TList; (FUNCTION TList.Clone(heap: THeap): TObject; OVERRIDE; (PROCEDURE TList.Free; OVERRIDE; &{Debugging} '{$IFC fDebugMethods} (PROCEDURE TList.Debug(numLevels: INTEGER; memberTypeStr: S255); OVERRIDE; ,{ numLevels=0 print just class of list; 81 also print size of list; 82 also print compacted list of member classes 6>=3 print class, size, and call Debug(numLevels-1) on members ,} (PROCEDURE TList.DebugMembers; '{$ENDC} &{Attributes} (FUNCTION TList.MemberBytes: INTEGER; OVERRIDE; &{Enumerate members} (PROCEDURE TList.Each(PROCEDURE DoToObject(object: TObject)); DEFAULT; (FUNCTION TList.Pos(after: LONGINT; object: TObject): LONGINT; (FUNCTION TList.Scanner: TListScanner; (FUNCTION TList.ScannerFrom(firstToScan: LONGINT; scanDirection: TScanDirection) C: TListScanner; DEFAULT; &{Inspect members} (FUNCTION TList.At(i: LONGINT): TObject; DEFAULT; (FUNCTION TList.First: TObject; DEFAULT; (FUNCTION TList.Last: TObject; DEFAULT; (FUNCTION TList.ManyAt(i, howMany: LONGINT): TList; DEFAULT; &{Insert members} (PROCEDURE TList.InsAt(i: LONGINT; object: TObject); DEFAULT; (PROCEDURE TList.InsFirst(object: TObject); (PROCEDURE TList.InsLast(object: TObject); &{Delete members} (PROCEDURE TList.DelAll(freeOld: BOOLEAN); DEFAULT; (PROCEDURE TList.DelAt(i: LONGINT; freeOld: BOOLEAN); DEFAULT; (PROCEDURE TList.DelFirst(freeOld: BOOLEAN); (PROCEDURE TList.DelLast(freeOld: BOOLEAN); (PROCEDURE TList.DelManyAt(i, howMany: LONGINT; freeOld: BOOLEAN); DEFAULT; (PROCEDURE TList.DelObject(object: TObject; freeOld: BOOLEAN); (FUNCTION TList.PopLast: TObject; &{Change member} (PROCEDURE TList.PutAt(i: LONGINT; object: TObject; freeOld: BOOLEAN); DEFAULT; (END; $TArray = SUBCLASS OF TCollection {*** WARNING: The Ptrs below become invalid if the heap compacts!!!} &{Variables} (recordBytes: INTEGER; &{Creation and Destruction} (FUNCTION TArray.CREATE(object: TObject; heap: THeap; initialSlack, bytesPerRecord: INTEGER): TArray; &{Attributes} (FUNCTION TArray.MemberBytes: INTEGER; OVERRIDE; &{Enumerate members} (PROCEDURE TArray.Each(PROCEDURE DoToRecord(pRecord: Ptr)); DEFAULT; (FUNCTION TArray.Pos(after: LONGINT; pRecord: Ptr): LONGINT; (FUNCTION TArray.Scanner: TArrayScanner; (FUNCTION TArray.ScannerFrom(firstToScan: LONGINT; scanDirection: TScanDirection) D: TArrayScanner; DEFAULT; &{Inspect members} (FUNCTION TArray.At(i: LONGINT): Ptr; DEFAULT; (FUNCTION TArray.First: Ptr; (PROCEDURE TArray.GetAt(i: LONGINT; pRecord: Ptr); DEFAULT; {Sort of: pRecord^ := SELF.At(i)^} (FUNCTION TArray.Last: Ptr; (FUNCTION TArray.ManyAt(i, howMany: LONGINT): TArray; DEFAULT; &{Insert members} (PROCEDURE TArray.InsAt(i: LONGINT; pRecord: Ptr); DEFAULT; (PROCEDURE TArray.InsFirst(pRecord: Ptr); (PROCEDURE TArray.InsLast(pRecord: Ptr); &{Delete members} (PROCEDURE TArray.DelAll; DEFAULT; (PROCEDURE TArray.DelAt(i: LONGINT); DEFAULT; (PROCEDURE TArray.DelFirst; (PROCEDURE TArray.DelLast; (PROCEDURE TArray.DelManyAt(i, howMany: LONGINT); DEFAULT; &{Change member} (PROCEDURE TArray.PutAt(i: LONGINT; pRecord: Ptr); DEFAULT; (END; $TString = SUBCLASS OF TCollection &{Variables} &{Creation and Destruction} (FUNCTION TString.CREATE(object: TObject; heap: THeap; initialSlack: INTEGER): TString; &{Attributes} (FUNCTION TString.MemberBytes: INTEGER; OVERRIDE; &{Enumerate members} (PROCEDURE TString.Each(PROCEDURE DoToCharacter(character: CHAR)); (FUNCTION TString.Pos(after: LONGINT; character: CHAR): LONGINT; (FUNCTION TString.Scanner: TStringScanner; (FUNCTION TString.ScannerFrom(firstToScan: LONGINT; scanDirection: TScanDirection): TStringScanner; &{Inspect members} (FUNCTION TString.At(i: LONGINT): CHAR; (FUNCTION TString.First: CHAR; (FUNCTION TString.Last: CHAR; (FUNCTION TString.ManyAt(i, howMany: LONGINT): TString; (PROCEDURE TString.ToPStr(pStr: TPString); (PROCEDURE TString.ToPStrAt(i, howMany: LONGINT; pStr: TPString); &{Insert members} (PROCEDURE TString.InsAt(i: LONGINT; character: CHAR); (PROCEDURE TString.InsFirst(character: CHAR); (PROCEDURE TString.InsLast(character: CHAR); (PROCEDURE TString.InsPStrAt(i: LONGINT; pStr: TPString); &{Delete members} (PROCEDURE TString.DelAll; (PROCEDURE TString.DelAt(i: LONGINT); (PROCEDURE TString.DelFirst; (PROCEDURE TString.DelLast; (PROCEDURE TString.DelManyAt(i, howMany: LONGINT); &{Change member} (PROCEDURE TString.PutAt(i: LONGINT; character: CHAR); &{QuickDraw} (PROCEDURE TString.Draw(i: LONGINT; howMany: INTEGER); (FUNCTION TString.Width(i: LONGINT; howMany: INTEGER): INTEGER; (END; $TFile = SUBCLASS OF TCollection &{Variables} (path: TFilePath; (password: TPassword; {The current password protecting this file, and used for all Paccesses to it; client is responsible for setting this Pfield after the TFile is created; ignored if PLibraryVersion <= 20} (scanners: TList {OF TScanner}; &{Creation and Destruction} (FUNCTION TFile.CREATE(object: TObject; heap: THeap; itsPath: TFilePath; @itsPassword: TPassword): TFile; 4{itsPassword is ignored from LibraryVersion <= 20} (PROCEDURE TFile.Free; OVERRIDE; {Frees the scanners as well} (FUNCTION TFile.Clone(heap: THeap): TObject; OVERRIDE; {Illegal} &{Attributes} (FUNCTION TFile.MemberBytes: INTEGER; OVERRIDE; &{Enumerate members} (FUNCTION TFile.Scanner: TFileScanner; {f.ScannerFrom(0, [fRead, fWrite])} (FUNCTION TFile.ScannerFrom(firstToScan: LONGINT; manip: TAccesses): TFileScanner; &{Catalog} (PROCEDURE TFile.ChangePassword(VAR error: INTEGER; newPassword: TPassword); 4{also changes the password field, if successful} (PROCEDURE TFile.Delete(VAR error: INTEGER); (FUNCTION TFile.Exists(VAR error: INTEGER): BOOLEAN; (FUNCTION TFile.WhenModified(VAR error: INTEGER): LONGINT; (PROCEDURE TFile.Rename(VAR error: INTEGER; newFileName: TFilePath); (FUNCTION TFile.VerifyPassword(VAR error: INTEGER; password: TPassword): BOOLEAN; (END; $TScanner = SUBCLASS OF TObject &{Variables} (collection: TCollection; {The collection being scanned} (position: LONGINT; {The current position (between members: 0=before first, size+1=after Flast)} (increment: INTEGER; {1 if scanning forward, -1 if scanning backward} (scanDone: BOOLEAN; {TRUE if next .Scan call should return FALSE, leaving its VAR Fparameter alone} (atEnd: BOOLEAN; {TRUE if next .Scan call will return FALSE because at end of collection} (FUNCTION TScanner.CREATE(object: TObject; itsCollection: TCollection; itsInitialPosition: LONGINT; BscanDirection: TScanDirection): TScanner; &{Close and Reopen} (PROCEDURE TScanner.Close; DEFAULT; {If disk-based, flush buffers and tell OS to close file, Melse no-op} (PROCEDURE TScanner.Open; DEFAULT; {If disk-based, tell OS to reopen file and fill first buffer} &{Slack Control} (PROCEDURE TScanner.Allocate(slack: LONGINT); DEFAULT; {Like collection.StartEdit(slack)} (PROCEDURE TScanner.Compact; DEFAULT; {Like collection.StopEdit} &{Positioning} (FUNCTION TScanner.Advance(PROCEDURE DoToCurrent(anotherMember: BOOLEAN)): BOOLEAN; (PROCEDURE TScanner.Done; DEFAULT; {Set scanDone so that Scan will return FALSE} (PROCEDURE TScanner.Reverse; DEFAULT; {Reverse the scan direction} (PROCEDURE TScanner.Seek(newPosition: LONGINT); DEFAULT; {Forces to legal places} (PROCEDURE TScanner.Skip(deltaPos: LONGINT); DEFAULT; {Forces to legal places} #(* BEGIN CONCEPTUAL METHODS (parameter types differ in subclasses; sometimes extra parameters required) &{Data Transfer} (FUNCTION TScanner.Obtain: "TMember"; CONCEPTUAL; {Return previous member (redundant right after [Scan)} (FUNCTION TScanner.Scan(VAR member: "TMember"): BOOLEAN; CONCEPTUAL; {Return next & advance past it} &{Editing} (PROCEDURE TScanner.Append(member: "TMember"); CONCEPTUAL; {Add a new member after position, scan epast it} (PROCEDURE TScanner.Delete; CONCEPTUAL; {Delete previous member and adjust eposition} (PROCEDURE TScanner.DeleteRest; CONCEPTUAL; {Delete everything after SELF.position} (PROCEDURE TScanner.Replace(member: "TMember"); CONCEPTUAL; {Replace previous member and maintain eposition} #END CONCEPTUAL METHODS *) (END; $TListScanner = SUBCLASS OF TScanner &{Variables} &{Creation and Destruction} (FUNCTION TListScanner.CREATE(object: TObject; itsList: TList; itsInitialPosition: LONGINT; FitsScanDirection: TScanDirection): TListScanner; (PROCEDURE TListScanner.Free; OVERRIDE; &{Traversal} (FUNCTION TListScanner.Obtain: TObject; DEFAULT; {Return previous member (redundant right after Scan)} (FUNCTION TListScanner.Scan(VAR nextObject: TObject): BOOLEAN; DEFAULT;{Return next, advance past it} &{Editing} (PROCEDURE TListScanner.Append(object: TObject); DEFAULT; {Add object after position, scan past it} (PROCEDURE TListScanner.Delete(freeOld: BOOLEAN); DEFAULT; {Delete previous object, adjust position} (PROCEDURE TListScanner.DeleteRest(freeOld: BOOLEAN); DEFAULT; {Delete all objects after position} (PROCEDURE TListScanner.Replace(object: TObject; freeOld: BOOLEAN); DEFAULT; {Replace previous} (END; $TArrayScanner = SUBCLASS OF TScanner &{Variables} &{Creation and Destruction} (FUNCTION TArrayScanner.CREATE(object: TObject; itsArray: TArray; itsInitialPosition: LONGINT; GitsScanDirection: TScanDirection): TArrayScanner; (PROCEDURE TArrayScanner.Free; OVERRIDE; &{Traversal} (FUNCTION TArrayScanner.Obtain: Ptr; DEFAULT; {Return previous member (redundant right after Scan)} (FUNCTION TArrayScanner.Scan(VAR pNextRecord: Ptr): BOOLEAN; DEFAULT; {Return next & advance past it} &{Editing} (PROCEDURE TArrayScanner.Append(pRecord: Ptr); DEFAULT; {Add a new record after position, scan past it} (PROCEDURE TArrayScanner.Delete; DEFAULT; {Delete previous record and adjust position} (PROCEDURE TArrayScanner.DeleteRest; DEFAULT; {Delete all records after position} (PROCEDURE TArrayScanner.Replace(pRecord: Ptr); DEFAULT;{Replace previous record and maintain position} (END; $TStringScanner = SUBCLASS OF TScanner &{Variables} (actual: LONGINT; {no. bytes last xfered} &{Creation and Destruction} (FUNCTION TStringScanner.CREATE(object: TObject; itsString: TString; itsInitialPosition: LONGINT; HitsScanDirection: TScanDirection): TStringScanner; (PROCEDURE TStringScanner.Free; OVERRIDE; &{Traversal} (FUNCTION TStringScanner.Obtain: CHAR; DEFAULT; {Return previous member (redundant right after Scan)} (FUNCTION TStringScanner.Scan(VAR nextChar: CHAR): BOOLEAN; DEFAULT; {Return next & advance past it} &{Editing} (PROCEDURE TStringScanner.Append(character: CHAR); DEFAULT; {Add char after position, scan past it} (PROCEDURE TStringScanner.Delete; DEFAULT; {Delete previous char, adjust position} (PROCEDURE TStringScanner.DeleteRest; DEFAULT; {Delete all chars after position} (PROCEDURE TStringScanner.Replace(character: CHAR); DEFAULT;{Replace previous char, maintain position} &{Typed Sequential Data Transfer: characters are read/written from left to right regardless of increment} (FUNCTION TStringScanner.ReadArray(heap: THeap; bytesPerRecord: INTEGER): TArray; {reads size first} (FUNCTION TStringScanner.ReadNumber(numBytes: SizeOfNumber): LONGINT; {iff numBytes is even pthen signed} (FUNCTION TStringScanner.ReadObject(heap: THeap): TObject; {tells object to Read(SELF)} (PROCEDURE TStringScanner.WriteArray(a: TArray); {inverse of ReadArray: writes size but not ZrecordBytes} (PROCEDURE TStringScanner.WriteNumber(value: LONGINT; numBytes: SizeOfNumber);{does not write size} (PROCEDURE TStringScanner.WriteObject(object: TObject); {tells object to Write(SELF)} (PROCEDURE TStringScanner.XferContiguous(whichWay: xReadWrite; collection: TCollection); 9{xfers the size and members, non-recursively; xRead appends what it reads} (PROCEDURE TStringScanner.XferFields(whichWay: xReadWrite; object: TObject); {xfers all but the class} (PROCEDURE TStringScanner.XferPString(whichWay: xReadWrite; pStr: TPString); {it better be long enough} &{Untyped Data Transfer: characters are read/written from left to right regardless of increment} (PROCEDURE TStringScanner.XferSequential(whichWay: xReadWrite; pFirst: Ptr; numBytes: PLONGINT); DEFAULT; (PROCEDURE TStringScanner.XferRandom(whichWay: xReadWrite; pFirst: Ptr; numBytes: LONGINT; Lmode: TIOMode; offset: LONGINT); DEFAULT; (END; $TFileScanner = SUBCLASS OF TStringScanner &{Variables} (accesses: TAccesses; {[fRead, fWrite, fAppend, fPrivate]} (refnum: INTEGER; {OS file refnum, or -1 if not open now} (error: INTEGER; {EOF is not an error} {first error (or warning if no error) encountered} &{Creation and Destruction} (FUNCTION TFileScanner.CREATE(object: TObject; itsFile: TFile; manip: TAccesses): TFileScanner; (PROCEDURE TFileScanner.FreeObject; OVERRIDE; {also closes the OS file} (PROCEDURE TFileScanner.Free; OVERRIDE; {if the last scanner, frees the TFile, too} &{Close and Reopen} (PROCEDURE TFileScanner.Close; OVERRIDE; (PROCEDURE TFileScanner.Open; OVERRIDE; &{Slack Control} (PROCEDURE TFileScanner.Allocate(slack: LONGINT); OVERRIDE; {Get slack DIV pageSize unused disk pages} (PROCEDURE TFileScanner.Compact; OVERRIDE; {Return unused disk pages to free space} &{Positioning} (PROCEDURE TFileScanner.Seek(newPosition: LONGINT); OVERRIDE; (PROCEDURE TFileScanner.Skip(deltaPos: LONGINT); OVERRIDE; &{Traversal} (FUNCTION TFileScanner.Obtain: CHAR; OVERRIDE; {Return previous member (redundant right after Scan)} (FUNCTION TFileScanner.Scan(VAR nextChar: CHAR): BOOLEAN; OVERRIDE; {Return next & advance past it} &{Editing} (PROCEDURE TFileScanner.Append(character: CHAR); OVERRIDE; {Acts like: Replace; Skip(1)} (PROCEDURE TFileScanner.Delete; OVERRIDE; {Acts like: Skip(-1)} (PROCEDURE TFileScanner.DeleteRest; OVERRIDE; {Shorten file size to SELF.position} (PROCEDURE TFileScanner.Replace(character: CHAR); OVERRIDE;{Replace previous member and maintain cposition} &{Untyped Data Transfer: characters are read/written from left to right regardless of increment} (PROCEDURE TFileScanner.XferSequential(whichWay: xReadWrite; pFirst: Ptr; numBytes: LONGINT); OVERRIDE; (PROCEDURE TFileScanner.XferRandom(whichWay: xReadWrite; pFirst: Ptr; numBytes: LONGINT; Jmode: TIOMode; offset: LONGINT); OVERRIDE; 'END; {$IFC compatibleLists} ${Backward compatibility classes} $TDynamicArray = SUBCLASS OF TArray (ch: {UNPACKED} ARRAY [0..16370] OF CHAR; (FUNCTION TDynamicArray.CREATE(object: TObject; heap: THeap; bytesPerRecord: INTEGER; GinitialSize: INTEGER): TDynamicArray; (FUNCTION TDynamicArray.NumRecords: INTEGER; (PROCEDURE TDynamicArray.BeSize(newSize: INTEGER); (END; $TIndexList = SUBCLASS OF TList (elements: ARRAY[1..1] OF TObject; (FUNCTION TIndexList.CREATE(object: TObject; heap: THeap; initialSize: INTEGER): TIndexList; (FUNCTION TIndexList.numElements: INTEGER; (END; $TLinkList = SUBCLASS OF TList (FUNCTION TLinkList.CREATE(object: TObject; heap: THeap): TLinkList; (FUNCTION TLinkList.numElements: INTEGER; (END; $TBlockList = SUBCLASS OF TList (FUNCTION TBlockList.CREATE(object: TObject; heap: THeap; itsMinBlockSize: INTEGER): TBlockList; (FUNCTION TBlockList.numElements: INTEGER; (END; $TFileStream = SUBCLASS OF TFileScanner (FUNCTION TFileStream.CREATE(object: TObject; heap: THeap; path: S255; manip: TAccesses): TFileStream; (FUNCTION TFileStream.Size: LONGINT; (END; {$ENDC} VAR $mainDsRefnum: INTEGER; {refnum of the process data segment} $mainHeap: THeap; {heap of the process} $mainLdsn: INTEGER; {ldsn of the process data segment} $fCheckIndices: BOOLEAN; $onDesktop: BOOLEAN; {Is there a DM (Desktop Manager) to talk to?} $wmIsInitialized: BOOLEAN; {Has OpenWM been done?} $isInitialized: BOOLEAN; {Iff TRUE, shouldn't tell DM initFailed any more} $amDying: BOOLEAN; {Iff TRUE, I have called ImDying} $myWorld: TClassWorld; {For Version Conversion} ${ Variables for Debugging } (indentTrace: INTEGER; *{ stuff for the intelligent output } (currXPos: INTEGER; (outputIndent: INTEGER; ({$IFC fTrace} ,{ TRUE if we want to inhibit tracing; client must save and restore its value; 4normally this is needed only if you override the Debug method } (fDebugRecursion: BOOLEAN; ,{ how often to call KeyPress from debugger to check for user interrupt } (keyPresLimit: INTEGER; ({$ENDC} {$IFC fCheckHeap} FUNCTION CountHeap(heap: THeap): INTEGER; {$ENDC} FUNCTION Min(i, j: LONGINT): LONGINT; FUNCTION Max(i, j: LONGINT): LONGINT; PROCEDURE XferLeft(source, dest: Ptr; nBytes: INTEGER); PROCEDURE XferRight(source, dest: Ptr; nBytes: INTEGER); FUNCTION EqualBytes(source, dest: Ptr; nBytes: INTEGER): BOOLEAN; FUNCTION LIntAndLInt(i, j: LONGINT): LONGINT; FUNCTION LIntOrLInt(i, j: LONGINT): LONGINT; FUNCTION LIntXorLInt(i, j: LONGINT): LONGINT; FUNCTION NewObject(heap: THeap; itsClass: TClass): TObject; FUNCTION NewDynObject(heap: THeap; itsClass: TClass; dynBytes: INTEGER): TObject; PROCEDURE ResizeDynObject(object: TObject; newTotalBytes: INTEGER); FUNCTION NewOrRecycledObject(heap: THeap; itsClass: TClass; VAR chainHead: TObject): TObject; PROCEDURE RecycleObject(object: TObject; VAR chainHead: TObject); PROCEDURE Free(object: TObject); {$IFC compatibleLists} ${Backward compatibility procedures} FUNCTION SubObject(super: TObject; itsClass: TClass): TObject; PROCEDURE FileDelete(path: S255); PROCEDURE FileLookup(VAR error: INTEGER; path: S255); PROCEDURE FileRename(oldPath, newPath: S255); FUNCTION FileModified(path: S255): LONGINT; {$ENDC} FUNCTION Superclass(class: TClass): TClass; FUNCTION ClassDescendsFrom(descendant, ancestor: TClass): BOOLEAN; PROCEDURE NameOfClass(class: TClass; VAR className: TClassName); FUNCTION SizeOfClass(class: TClass): INTEGER; {The next 3 can only be called from a class-init block or a subroutine of a class-init block} PROCEDURE UnitAuthor(companyAndAuthor: TAuthorName); {required once per unit} PROCEDURE ClassAuthor(companyAndAuthor: TAuthorName; classAlias: TClassName); {optional} PROCEDURE ClassVersion(itsVersion, oldestItCanRead: Byte); {optional} FUNCTION ValidObject(hndl: Handle): BOOLEAN; PROCEDURE ABCBreak(s: S255; errCode: LONGINT); PROCEDURE ClascalError(error: INTEGER); {Some useful procedures; we should decide once and for all whether or not to keep any or all of these} PROCEDURE LIntToHex(decNumber: LONGINT; hexNumber: TPString); ,{NOTE: hexNumber must be >= 8 characters, regardless of size of decNumber} PROCEDURE LIntToStr(decNumber: LONGINT; str: TPString); ,{NOTE: str must be >= 11 characters (sign + 10 digits), regardless of size of decNumber} PROCEDURE IntToStr(decNumber: INTEGER; str: TPString); ,{NOTE: str must be >= 6 characters (sign + 5 digits), regardless of size of decNumber} PROCEDURE HexStrToLInt(hexString: TPString; VAR decNumber: LONGINT; VAR result: TConvResult); PROCEDURE StrToLInt(str: TPString; VAR decNumber: LONGINT; VAR result: TConvResult); PROCEDURE StrToInt(str: TPString; VAR decNumber: INTEGER; VAR result: TConvResult); PROCEDURE TrimBlanks(str: TPString); FUNCTION CharUpperCased(ch: CHAR): CHAR; PROCEDURE StrUpperCased(str: TPString); PROCEDURE SplitFilePath(VAR fullPath, itsCatalog, itsFilePart: TFilePath); ${fullPath = CONCAT(itsCatalog, itsFilePart} PROCEDURE LatestError(newError: INTEGER; VAR previousError: INTEGER); ({This is used to handle error codes returned by multiple operations, so that you end up with ,the first error number or warning number (error code < 0) if there was no error. )You should pass in the latest error as 'newError' and the variable that is to be the final ,error code as 'previousError'. Here is the actual code of LatestError: 9IF ((newError > 0) AND (previousError <= 0) OR =(newError < 0) AND (previousError = 0)) THEN  no tracing, traceCount of 1 means you have traced through defTraceCount methods (so time to enter the debugger. } $traceCount, defTraceCount: INTEGER; &{ Set with the Level command } $curTraceLevel: INTEGER; &{ Break when you come to one of these methods } $breakMethods: ARRAY [1..maxBreaks] OF RECORD XbrClass, brMethod: S8; TEND; &{ The number of valid break methods currently active } $breakMCount: INTEGER; &{ TRUE IF showing the debugger prompt } $showPrompt: BOOLEAN; &{ TRUE if BP is tallying procedure calls } $tallyingCalls: BOOLEAN; &{ A hash table if tallyingCalls } $tallies: THTallies; (* tallyOverhead: LONGINT; {usual time spent calling and returning from BP, EP, or Tally} *) (* debugTime: LONGINT; {cumulative time spend in BP and EP since tallying started} *) $startTime: LONGINT; {when tallying started} $stopTime: LONGINT; {when tallying last paused} $segNames: TArray{[1..127] OF S8}; &{ Used to avoid break point checking on methods we have already checked } $lastBpPc: LONGINT; $lastEpPc: LONGINT; ${$ENDC} { ==================================== EXTERNAL AND FORWARD PROCEDURES ==================================== } {$IFC LibraryVersion < 20} "{So we don't need to use PasLibCall or PPasLibC; this may have to change if those .OBJ files change !!!!} $PROCEDURE OutputRedirect (VAR errnum : INTEGER; VAR outfile : pathname; stopoutput : BOOLEAN); EXTERNAL; $PROCEDURE DSPaslibCall (VAR ProcParam : dsProcParam); EXTERNAL; {$ENDC} "{We can't USE Unit UDRAW because it USES us} $PROCEDURE InitErrorAbort(error: INTEGER); EXTERNAL; $PROCEDURE TrmntExceptionHandler; EXTERNAL; ${$IFC fDbgObject} $FUNCTION BindHeap(activeVsClip, doBind: BOOLEAN): THeap; EXTERNAL; ${$ENDC} "{We can't USE Unit UDRAW because it USES us} $PROCEDURE PointToStr(pt: FakePoint; str: TPstring); EXTERNAL; $PROCEDURE RectToStr(r: FakeRect; str: TPstring); EXTERNAL; $PROCEDURE LPointToStr(pt: FakeLPoint; str: TPstring); EXTERNAL; $PROCEDURE LRectToStr(r: FakeLRect; str: TPstring); EXTERNAL; "{We can't USE Unit Storage because of type name conflicts (Ptr, Handle, ProcPtr)} $PROCEDURE SetHeap(heap: THeap); EXTERNAL; $PROCEDURE GetHeap(VAR heap: THeap); EXTERNAL; "{We can't USE Unit QuickDraw because we can't use Storage; nor WM without using QuickDraw; nor UDraw, so...} $PROCEDURE InitQDWM; EXTERNAL; {in UDraw} $PROCEDURE DrawText(textBuf: TpINTEGER; firstByte, byteCount: INTEGER); EXTERNAL; $FUNCTION TextWidth(textBuf: TpINTEGER; firstByte, byteCount: INTEGER): INTEGER; EXTERNAL; $PROCEDURE DrawLText(textBuf: TpINTEGER; firstByte, byteCount: INTEGER); EXTERNAL; "{The rest are assembler routines in XFER and ARE declared in the INTERFACE of this unit} $FUNCTION LIntAndLInt(i, j: LONGINT): LONGINT; EXTERNAL; $FUNCTION LIntOrLInt(i, j: LONGINT): LONGINT; EXTERNAL; $FUNCTION LIntXorLInt(i, j: LONGINT): LONGINT; EXTERNAL; $PROCEDURE XferLeft(source, dest: Ptr; nBytes: INTEGER); EXTERNAL; $PROCEDURE XferRight(source, dest: Ptr; nBytes: INTEGER); EXTERNAL; $FUNCTION EqualBytes(source, dest: Ptr; nBytes: INTEGER): BOOLEAN; EXTERNAL; "{The rest are assembler routines in CLASLIB and are NOT declared in the INTERFACE of this unit} $FUNCTION %_GetA5: LONGINT; EXTERNAL; $PROCEDURE %_GoLisabug; EXTERNAL; "{Forward} ${$IFC fDebugMethods} $PROCEDURE WriteDRecord(numLevels: INTEGER; hDRecord: Handle; posInDRecord: INTEGER; ;PROCEDURE SupplyFields(PROCEDURE Field(nameAndType: S255))); FORWARD; ${$ENDC} { ====================================== COLD UTILITIES ====================================== } {$S SgCLAcld} FUNCTION MakeIdxArray(numElements: INTEGER; sparse: BOOLEAN): THIdxArray; $VAR anArray: TArray; (i: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} $IF sparse THEN (numElements := (((numElements + 6) * 4) DIV 3); $anArray := TArray.CREATE(NIL, mainHeap, numElements, SIZEOF(INTEGER)); $anArray.InsNullsAt(1, numElements); $MakeIdxArray := THIdxArray(anArray); (***** $hArray := THIdxArray(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(INTEGER), numElements)); $FOR i := 1 TO numElements DO (hArray^^.records[i] := 0; $MakeIdxArray := hArray; *****) END; {$S SgCLAcld} PROCEDURE EachObject(heap: THeap; PROCEDURE DoToObject(object: TObject)); $VAR hz: THz; { The heap as a UnitHz type } )mpFirst: LONGINT; { The address of the first master pointer } )mpLast: LONGINT; { The address of the last master pointer } )mpIndex: LONGINT; { An index variable used for stepping through the master pointers } )mp: LONGINT; { the value of the master pointer at mpIndex } BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} $hz := THz(heap); $mpFirst := ORD(@hz^.argpPool); $mpLast := mpFirst + 4 * ((hz^.ipPoolMac) - 1); "{Step through each master pointer in heap} $mpIndex := mpFirst; $WHILE mpIndex <= mpLast DO (BEGIN (mp := ORD(Handle(mpIndex)^); (IF NOT (((mp >= mpFirst) AND (mp <= mpLast)) OR (mp = 1)) THEN {not on the free list} +DoToObject(POINTER(ORD(mpIndex))); { Pass it to DoToObject as a TObject, but don't coerce Tdirectly to a TObject because of run-time checking. } (mpIndex := mpIndex + 4; { advance to the next master pointer } (END; END; { ====================================== HOT UTILITIES ====================================== } {$S sHotUtil} FUNCTION Min(i, j: LONGINT): LONGINT; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $IF i < j THEN (Min := i $ELSE (Min := j; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sHotUtil} FUNCTION Max(i, j: LONGINT): LONGINT; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $IF i > j THEN (Max := i $ELSE (Max := j; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sHotUtil} PROCEDURE LatestError(newError: INTEGER; VAR previousError: INTEGER); BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $IF ((newError > 0) AND (previousError <= 0) OR ((newError < 0) AND (previousError = 0)) THEN 'previousError := newError; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sHotUtil} FUNCTION ClassPtr(hndl: Handle): TClass; $VAR stp: RECORD 0CASE INTEGER OF 41: (asLong: LONGINT); 42: (asBytes: PACKED ARRAY [0..3] OF TByte); 43: (asClass: TClass); 4END; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} $stp.asLong := hndl^^; $stp.asBytes[0] := 0; $ClassPtr := stp.asClass; END; {$S sUtil} PROCEDURE LIntToHex(decNumber: LONGINT; hexNumber: TPString); ,{NOTE: hexNumber must be >= 8 characters, regardless of size of decNumber} (* This PROCEDURE accepts a binary LONGINT, decNumber, and returns the equivalent hexadecimal *) (* number by means of the output parameter hexNumber. Note that if the equivalent hexadecimal number is *) (* of a sufficiently small magnitude that it does not require all of the digits in the hex field to be *) (* expressed (e.g. if 8 digits are allocated in the hex field and the hex number if 58A7, which is only *) (* 4 digits), then the hexadecimal number will be right-justified with leading zeros to pad the field. So, *) (* for example, 58A7 will be returned as 000058A7 if 8 digits are allocated for hexadecimal numbers via the *) (* constant hexFieldSize. To change the number of digits in the hex field, change the constant *) (* hexFieldSize. *) {NOTE: many users of LIntToHex pass in a pointer to a variable declared as S8; therefore, it is important ,that LIntToHex not return more than 8 digits } CONST $hexFieldSize = 8; (* the number of digits which are to appear in a hexadecimal field; leading zeros *) 7(* may be used to pad small hexadecimal numbers (e.g. if hexFieldSize is 8, then the 7(* hex number FA9 would appear as 00000FA9) *) VAR hexDigits: S16; (* a list which is to contain all hexadecimal digits *) $i: 1..hexFieldSize; (* a variable for indexing individual digits of the hex number's field *) $fudge: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $hexDigits := '0123456789ABCDEF'; (* Initialize the list of hexadecimal digits *) {$R-}hexNumber^[0] := CHR(hexFieldSize); {$IFC fRngObject}{$R+}{$ENDC} $IF decNumber < 0 THEN (BEGIN (fudge := 16; {reverse hexDigit indexes} (decNumber := decNumber + 1; {correct for two's complement} (END $ELSE (fudge := 1; $FOR i := hexFieldSize DOWNTO 1 DO (BEGIN (hexNumber^[i] := hexDigits[(decNumber MOD 16) + fudge]; (decNumber := decNumber DIV 16; (END; ${$IFC fMaxTrace}EP;{$ENDC} END; (* LIntToHex *) {$S sUtil} PROCEDURE LIntToStr(decNumber: LONGINT; str: TPString); ({NOTE: str must be >= 11 characters, regardless of size of number} $VAR neg : BOOLEAN; (pos : INTEGER; $BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} "{$R-} str^[0] := CHR(11); {$IFC fRngObject} {$R+} {$ENDC} (pos := 11; (neg := (decNumber < 0); (decNumber := ABS (decNumber); (REPEAT ,str^[pos] := CHR(ORD('0') + (decNumber MOD 10)); ,pos := pos - 1; ,decNumber := decNumber DIV 10; (UNTIL decNumber = 0; (IF neg THEN ,BEGIN ,str^[pos] := '-'; ,pos := pos - 1; ,END; (DELETE (str^, 1, pos); ${$IFC fMaxTrace}EP;{$ENDC} $END; {$S sUtil} PROCEDURE IntToStr(decNumber: INTEGER; str: TPString); ,{NOTE: str must be >= 6 characters (sign + 5 digits), regardless of size of decNumber} $VAR s11: STRING[11]; $BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} (LIntToStr(decNumber, @s11); (XferLeft(Ptr(@s11), Ptr(str), Length(s11) + 1); { str length + 1 size byte } ${$IFC fMaxTrace}EP;{$ENDC} $END; {$S sUtil} PROCEDURE HexStrToLInt(hexString: TPString; VAR decNumber: LONGINT; VAR result: TConvResult); (* This PROCEDURE accepts a STRING of hexadecimal digits, hexString, and returns a long-INTEGER decimal *) (* equivalent by means of the variable parameter decNumber. Information concerning the acceptability of *) (* the hexadecimal STRING is returned via the variable parameter result. *) (* Note that this PROCEDURE ignores any leading or trailing blanks which may be present in the given *) (* hexString, and the presence of lower-case hexadecimal digits in the hex STRING does not adversely *) (* affect conversion. Also, if the first non-blank character of the STRING is a dollar sign, then that *) (* dollar sign is ignored and not considered during conversion (it is, effectively, deleted from the *) (* STRING). *) VAR numDigits: 0..255; (* The number of digits in the hex STRING *) $digit: CHAR; $i: INTEGER; (* index variable *) $digitValue: INTEGER; (* index variable *) $hexDigits: S16; (* an array which is to contain a list of hexadecimal digits *) BEGIN (* HexStrToLInt *) ${$IFC fMaxTrace}BP(1);{$ENDC} &(* Delete any trailing blanks *) $TrimBlanks(POINTER(ORD(hexstring))); ${ Remove any leading zeros, except keep at least 1 digit; also, remove any leading $ } $IF Length(hexString^) > 0 THEN (WHILE ((Length(hexString^) > 1) AND (hexString^[1] = '0')) OR (hexString^[1] = '$') DO ,Delete(hexString^, 1, 1); $numDigits := Length(hexString^); $decNumber := 0; $IF numDigits = 0 THEN (* if the given hex STRING is empty... *) (result := cvNoNumber $ELSE $IF Length (hexString^) > 8 THEN (* if can't fit in LONGINT *) (result := cvOverflow $ELSE (result := cvValid; (* innocent until proven guilty *) $FOR i := 1 TO numDigits DO (BEGIN (digit := hexString^[i]; (IF digit IN ['0'..'9'] THEN ,digitValue := ORD(digit) - ORD('0') (ELSE (IF digit IN ['A'..'F'] THEN ,digitValue := ORD(digit) - ORD('A') + 10 (ELSE (IF digit IN ['a'..'f'] THEN ,digitValue := ORD(digit) - ORD('a') + 10 (ELSE ,BEGIN ,digitValue := 0; ,result := cvBadNumber; ,END; (decNumber := decNumber * 16 + digitValue; (END; ${$IFC fMaxTrace}EP;{$ENDC} END; (* HexStrToLInt *) {$S sUtil} PROCEDURE StrToLInt(str: TPString; VAR decNumber: LONGINT; VAR result: TConvResult); $LABEL 1; $VAR s: S255; (pos: INTEGER; (neg: BOOLEAN; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $result := cvValid; $XferLeft(Ptr(str), Ptr(@s), Length(str^) + 1); $TrimBlanks(@s); $decNumber := 0; $neg := FALSE; $IF s='' THEN (result := cvNoNumber $ELSE IF (s[1]='-') OR (s[1]='+') THEN (BEGIN (neg := s[1] = '-'; (Delete(s, 1, 1); (IF s='' THEN ,result := cvBadNumber; (END; $pos := 1; $WHILE pos <= Length(s) DO (BEGIN (IF ('0' > s[pos]) OR (s[pos] > '9') THEN {invalid numeric character} ,BEGIN ,result := cvBadNumber; ,GOTO 1; ,END; ({check for overflow} (IF pos > 10 THEN {more than 10 digits guarantees an overflow} ,BEGIN ,result := cvOverflow; ,GOTO 1; ,END; (IF pos = 10 THEN ,IF ORD(s[pos]) > ORD('7') THEN 0IF decNumber > 214748363 THEN 4BEGIN 4result := cvOverflow; 4GOTO 1; 4END 0ELSE 4{ okay } ,ELSE { 10th digit is 7 or less } 0IF decNumber > 214748364 THEN 4BEGIN 4result := cvOverflow; 4GOTO 1; 4END; (decNumber := (10 * decNumber) + (ORD(s[pos]) - ORD('0')); (pos := pos + 1; (END; $IF neg THEN (decNumber := -decNumber; 1: ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sUtil} PROCEDURE StrToInt(str: TPString; VAR decNumber: INTEGER; VAR result: TConvResult); $VAR l: LONGINT; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} {$IFC fDbgObject} {$0V+} {make sure we don't screw up} {$ENDC} $StrToLint(str, l, result); $IF result = cvValid THEN (IF (l < -MAXINT-1) OR (l > MAXINT) THEN ,result := cvOverflow (ELSE ,decNumber := INTEGER(l); ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sUtil} PROCEDURE TrimBlanks(str: TPString); $LABEL (1, 10; $CONST (tabCh = CHR(9); $VAR i: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $i := 1; $WHILE i <= Length(str^) DO (BEGIN (IF str^[i] <> ' ' THEN ,IF str^[i] <> tabCh THEN 0BEGIN {delete all the leading stuff we have found} 0Delete(str^, 1, i-1); 0GOTO 1; 0END; (i := i + 1; (END; ${ we fell thru -- either '' or all blanks or tabs } $str^ := ''; $GOTO 10; 1: {now trim the trailing blanks} $i := Length(str^); $WHILE i > 0 DO (BEGIN (IF (str^[i] = ' ') OR (str^[i] = tabCh) THEN ,Delete(str^, i, 1) (ELSE ,GOTO 10; (i := i - 1; (END; 10: ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sUtil} FUNCTION CharUpperCased(ch: CHAR): CHAR; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $CharUpperCased := ch; $IF 'a' <= ch THEN (IF ch <= 'z' THEN ,CharUpperCased := CHR(ORD(ch) - 32); ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sUtil} PROCEDURE StrUpperCase(str: TPString); $VAR i: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $i := Length(str^); $WHILE i > 0 DO (BEGIN (str^[i] := CharUpperCased(str^[i]); (i := i - 1; (END; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sUtil} PROCEDURE SplitFilePath(VAR fullPath, itsCatalog, itsFilePart: TFilePath); $LABEL 1; $VAR i: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $itsCatalog := ''; $itsFilePart := fullPath; $FOR i := Length(itsFilePart) DOWNTO 1 DO (IF itsFilePart[i] = '-' THEN ,BEGIN ,itsCatalog := COPY(itsFilePart, 1, i); ,DELETE(itsFilePart, 1, i); ,GOTO 1; ,END; 1: ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sStartup} PROCEDURE SetCp(object: TObject; itsClass: TClass); $VAR index: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $Handle(object)^^ := ORD(itsClass); {Install slice table pointer} $index := CiOfCp(TPSliceTable(itsClass)); {Determine its class index} $IF index < 256 THEN {If it will fit in a byte, store it...} {$R-} TPByte(Handle(object)^)^ := index; {...to speed version conversion (cf ConvertHeap: FindClasses)} {$IFC fRngObject}{$R+}{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sStartup} FUNCTION NewDynObject(heap: THeap; itsClass: TClass; dynBytes: INTEGER): TObject; $VAR nBytes: INTEGER; (object: TObject; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $nBytes := SizeOfCp(TPSliceTable(itsClass)) + dynBytes; $object := POINTER(ORD(HAllocate(THz(heap), nBytes))); {TObject() won't work until after SetCp} $IF ORD(object) = ORD(hNIL) THEN (BEGIN ({$IFC fDbgObject} (WriteLn(CbOfHz(THz(heap)):1, ' bytes in the heap'); ({$ENDC} (ABCBreak('NewObject: Heap full, can''t make an object of size', nBytes); (END; $SetCp(object, itsClass); $NewDynObject := object; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sStartup} FUNCTION NewObject(heap: THeap; itsClass: TClass): TObject; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $NewObject := NewDynObject(heap, itsClass, 0); ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sStartup} PROCEDURE ResizeDynObject(object: TObject; newTotalBytes: INTEGER); $VAR i: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $IF (newTotalBytes < 0) OR (newTotalBytes > (MAXINT-20)) THEN (ABCBreak('New size must lie between 0 and 32K-20, not', newTotalBytes); $ChangeSizeH(THz(object.Heap), TH(object), newTotalBytes); $IF CbDataOfH(THz(object.Heap), TH(object)) < newTotalBytes THEN 'ABCBreak('ResizeDynObject: Heap full, size can''t change to', newTotalBytes); ${$IFC fMaxTrace}EP;{$ENDC} END; {$IFC compatibileLists} FUNCTION SubObject(super: TObject; itsClass: TClass): TObject; BEGIN $ResizeDynObject(super, SizeOfCp(TPSliceTable(itsClass))); $SetCP(super, itsClass); $SubObject := super; END; {$ENDC} {$S sStartup} FUNCTION NewOrRecycledObject(heap: THeap; itsClass: TClass; VAR chainHead: TObject): TObject; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $IF chainHead = NIL THEN (NewOrRecycledObject := NewObject(heap, itsClass) $ELSE (BEGIN ({$IFC fDbgObject} (IF (chainHead.Class <> itsClass) OR (chainHead.Heap <> heap) THEN ,ABCBreak('NewOrRecycledObject: chainHead contains an alien object', ORD(chainHead)); ({$ENDC} (NewOrRecycledObject := chainHead; (chainHead := THRecycleChain(chainHead)^^.chainLink; (END; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sStartup} PROCEDURE RecycleObject(object: TObject; VAR chainHead: TObject); ${$IFC fDbgObject} $VAR chainMember: TObject; ${$ENDC} BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fDbgObject} $IF object.HeapBytes < 8 THEN (ABCBreak('RecycleObject: object is too small for a chainHead link', ORD(object)); $chainMember := chainHead; $WHILE chainMember <> NIL DO (BEGIN (IF chainMember = object THEN ,ABCBreak('RecycleObject: object freed twice', ORD(object)); (chainMember := THRecycleChain(chainMember)^^.chainLink; (END; ${$ENDC} $THRecycleChain(object)^^.chainLink := chainHead; $chainHead := object; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sRes} PROCEDURE Recreate(object: TObject; oldSize, newSize: INTEGER; newSTP: TPSliceTable); $VAR extraPtr: TPByte; (hz: THz; (cb: INTEGER; (bk: LONGINT; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $SetCP(object, TClass(newSTP)); {Install the new slice-table pointer} $IF newSize <> oldSize THEN {Default extra fields to 0/NIL} (BEGIN (hz := HzFromH(TH(object)); (cb := CbDataOfH(hz, TH(object)); (bk := ORD(Handle(object)^); (IF (cb > oldSize) AND (newSize < oldSize) THEN {There is a variable-length part & we're shrinking} ,XferLeft(Ptr(bk + oldSize), Ptr(bk + newSize), cb - oldSize); (ChangeSizeH(hz, TH(object), cb + newSize - oldSize); (IF (cb > oldSize) AND (newSize > oldSize) THEN {There is a variable-length part & we're expanding} ,XferRight(Ptr(bk + oldSize), Ptr(bk + newSize), cb - oldSize); (IF newSize > oldSize THEN {Default extra fields to 0/NIL} ,BEGIN ,extraPtr := TPByte(bk + oldSize + 1); ,extraPtr^ := 0; {Store one zero and let XferLeft copy it repeatedly} ,XferLeft(Ptr(extraPtr), Ptr(ORD(extraPtr) + 1), newSize - oldSize - 1); ,END; (END; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sRes} FUNCTION Superclass(class: TClass): TClass; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} {$R-} Superclass := TClass(TPSliceTable(class)^[-1]); {$IFC fRngObject}{$R+}{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sRes} FUNCTION ClassDescendsFrom(descendant, ancestor: TClass): BOOLEAN; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $WHILE (descendant <> ancestor) AND (descendant <> NIL) DO ({$R-} descendant := TClass(TPSliceTable(descendant)^[-1]); {$IFC fRngObject}{$R+}{$ENDC} $ClassDescendsFrom := descendant <> NIL; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sRes} PROCEDURE NameOfClass(class: TClass; VAR className: TClassName); BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $CpToCn(TPSliceTable(class), TS8(className)); ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sRes} FUNCTION SizeOfClass(class: TClass): INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $SizeOfClass := SizeOfCp(TPSliceTable(class)); ${$IFC fMaxTrace}EP;{$ENDC} END; {$S SgCLAres} ${toInsert, return: -1 if class already there or if table full, index if a hole found} ${not toInsert, return: index (> 0) if class found, -1 if not there} FUNCTION LookupName(classAlpha: TA8; toInsert: BOOLEAN): INTEGER; $FUNCTION CompareName(hashIndex: INTEGER): THashCompare; (VAR myIndex: INTEGER; ,trialName: TS8; $BEGIN (myIndex := hMyHashName^^.records[hashIndex]; (IF myIndex = 0 THEN ,CompareName := cHole (ELSE (IF classAlpha = hMyClasses^^.records[myIndex].classAlpha THEN ,CompareName := cMatch (ELSE ,CompareName := cMismatch; $END; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} $LookupName := LookupInHashArray(hMyHashName^^.header.size, DORD(classAlpha[2])*ORD(classAlpha[4])+ORD(classAlpha[6]), DtoInsert, CompareName); END; {$S SgCLAres} FUNCTION ValidDataAddress(addr: LONGINT): BOOLEAN; *{Returns TRUE iff: addr is in a data segment (stack seg doesn't qualify) 4AND is it an even address 4AND is it within the bounds of the data segment} $CONST dsMaxSize = $00020000; {128K} $VAR error: INTEGER; (refnum: INTEGER; (dsInfo: dsInfoRec; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $ValidDataAddress := FALSE; $IF NOT ODD(addr) THEN (BEGIN (Info_Address(error, addr, refnum); (IF error <= 0 THEN ,BEGIN ,Info_Dataseg(error, refnum, dsInfo); ,IF error <= 0 THEN 0IF (addr MOD dsMaxSize) < dsInfo.mem_size THEN 4ValidDataAddress := TRUE; ,END; (END; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sStartup} PROCEDURE Free(object: TObject); BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $IF object <> NIL THEN (object.Free; ${$IFC fMaxTrace}EP;{$ENDC} END; {*** THE FOLLOWING TWO ROUTINES ASSUME THAT THE hHashName AND hMyClasses TABLES ARE ALWAYS AROUND ***} ({*** IF THEY START SWAPPING OUT, WRITE LINEAR SEARCH ROUTINES TO REPLACE THESE ***} {$S SgCLAres} FUNCTION CiOfAlpha(classAlpha: TA8): INTEGER; {convert class title TA8 to class index} $VAR hashIndex: INTEGER; (i: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $hashIndex := LookupName(classAlpha, FALSE); $IF hashIndex <= 0 THEN (CiOfAlpha := 0 $ELSE (CiOfAlpha := hMyHashName^^.records[hashIndex]; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S SgCLAres} FUNCTION CiOfCn(className: S8): INTEGER; {convert upper-case class title S8 to class index} $VAR a8: TA8; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $FillChar(a8, 8, ' '); $XferLeft(Ptr(ORD(@className)+1), @a8, Length(className)); $CiOfCn := CiOfAlpha(a8); ${$IFC fMaxTrace}EP;{$ENDC} END; { ====================================== INITIALIZATION ====================================== } {$S sError} PROCEDURE CheckInitError(error: INTEGER); BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $IF error > 0 THEN {Can only call with error > 0 before TProcess class-init has run} (InitErrorAbort(error); ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sInit1} FUNCTION NewHeap(VAR error: INTEGER; heapStart, numBytes: LONGINT; numObjects: INTEGER): THeap; $VAR heap: THeap; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $heap := THeap(HzInit(POINTER(heapStart), POINTER(heapStart+numBytes), INIL, numObjects, 0, POINTER(procNil), IPOINTER(procNil), POINTER(procNil), POINTER(procNil))); $IF heap = POINTER(1) THEN (BEGIN (error := erInternal; (ABCBreak('NewHeap could not make a heap of size', numBytes); (heap := NIL; (END $ELSE (error := 0; $NewHeap := heap; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sInit1} FUNCTION MakeDataSegment(VAR error, dsRefnum: INTEGER; firstTryVolume, thenTryVolume: TFilePath; ?ldsn, memBytes, diskBytes: INTEGER): LONGINT; $VAR startAddress: LONGINT; $PROCEDURE TryMakeDataSegment(volumePart: TFilePath); (VAR dsPathname: PathName; $BEGIN (dsPathname := Concat(volumePart, 'ds_private'); (Make_Dataseg(error, dsPathname, memBytes, diskBytes, dsRefnum, startAddress, ldsn, ds_private); $END; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $TryMakeDataSegment(firstTryVolume); $IF error = 309 THEN (IF firstTryVolume <> thenTryVolume THEN ,TryMakeDataSegment(thenTryVolume); $IF error >0 THEN (BEGIN (ABCBreak('MakeDataSegment', error); (startAddress := 0; (END; $MakeDataSegment := startAddress; ${$IFC fMaxTrace}EP;{$ENDC} END; {$S sInit1} PROCEDURE InitObject; $VAR dsp: DsProcParam; (excepName: T_Ex_Name; (error: INTEGER; (prcsInfo: ProcInfoRec; (heapBase: LONGINT; (progVolume: PathName; BEGIN "{Until we call InitQDWM, NOTHING CAN FAIL!!!!} $isInitialized := FALSE; {An interface variable set true at a higher level: e.g., by TProcess.Run} $amDying := FALSE; {An interface variable set true at a higher level when ImDying is called} $wmIsInitialized := FALSE; {An interface variable set true at a higher level: e.g., by InitQDWM} ${$IFC fTrace} $fTraceEnabled := FALSE; $fDebugRecursion := FALSE; $tabLevel := -1; $curTraceLevel := 1; $traceCount := 0; $defTraceCount := 0; $breakMCount := 0; $kpcntr := 0; $keyPresLimit := stdKeyPresLimit; $returnToMain := TRUE; $showPrompt := TRUE; $outputIndent := 0; $currXPos := 0; $tallyingCalls := FALSE; $tallies := NIL; $segNames := NIL; ${$ENDC} "{Determine environment and program volume name} $Info_Process(error, My_id, prcsInfo); ${get my volume name as '-volname-'; assumes that the OS gives us back a program name of the form: L'-volname-progname'} $Delete(prcsInfo.progPathName, 1, 1); {the first '-'} $progVolume := Concat('-', Copy(prcsInfo.progPathName, 1, Pos('-', prcsInfo.progPathName))); {$IFC LibraryVersion <= 20} "{Yu Ying has a better way to know if we are on the desktop or in the workshop, but meanwhile...} $IF prcsInfo.father_Id > 1 THEN (BEGIN (Info_Process(error, prcsInfo.father_Id, prcsInfo); ({this assumes that the OS returns a program name of the form '-volname-progname'} (Delete(prcsInfo.progPathName, 1, 1); {the first '-'} (Delete(prcsInfo.progPathName, 1, Pos('-', prcsInfo.progPathName)); {the 'volname-'} (StrUpperCased(@prcsInfo.progPathName); (onDesktop := prcsInfo.progPathName = 'SHELL.OFFICE SYSTEM'; (END $ELSE (BEGIN (onDesktop := FALSE; (END; {$ELSEC} $dsp.procCode := dsGetDiskEnbF; $DSPaslibCall(dsp); $onDesktop := NOT dsp.diskEnbF; {$ENDC} $InitQDWM; {must be the first thing before any operations that could fail; 4when running on the Workshop, it also sets up the FontMgr & writeln to alternate screen.} ${$IFC fDbgObject} $Write('Running on the '); $IF onDesktop THEN (WriteLn('desktop') $ELSE (WriteLn('workshop'); ${$ENDC} "{Declare an OS Exception Handler} $excepName := 'SYS_TERMINATE'; $Declare_Excep_Hdl(error, excepName, @TrmntExceptionHandler); $CheckInitError(error); ${$IFC fDbgObject} $GoToXY(0,31); ${$ENDC} "{Create data segment and heap} $mainLdsn := prcsLdsn; $heapBase := MakeDataSegment(error, mainDsRefnum, '', progVolume, mainLdsn, prcsDsBytes, prcsDsBytes); $CheckInitError(error); $mainHeap := NewHeap(error, heapBase, prcsDsBytes, prcsDsBytes DIV 20); $CheckInitError(error); $SetHeap(mainHeap); END; {$S sInit1} PROCEDURE UnitAuthor(companyAndAuthor: TAuthorName); {required once per unit} $VAR a32: TA32; BEGIN $StrUpperCased(@companyAndAuthor); $FillChar(a32, 32, ' '); $XferLeft(Ptr(ORD(@companyAndAuthor)+1), @a32, LENGTH(companyAndAuthor)); $QUnitAuthor(a32); END; {$S sInit1} PROCEDURE ClassAuthor(companyAndAuthor: TAuthorName; classAlias: TClassName); {optional} $VAR a32: TA32; (a8: TA8; BEGIN $IF LENGTH(companyAndAuthor) > 0 THEN (BEGIN (StrUpperCased(@companyAndAuthor); (FillChar(a32, 32, ' '); (XferLeft(Ptr(ORD(@companyAndAuthor)+1), @a32, LENGTH(companyAndAuthor)); (QClassAuthor(a32); (END; $IF LENGTH(classAlias) > 0 THEN (BEGIN (StrUpperCased(@classAlias); (FillChar(a8, 8, ' '); (XferLeft(Ptr(ORD(@classAlias)+1), @a8, LENGTH(classAlias)); (QClassAlias(a8); (END; END; {$S sInit1} PROCEDURE ClassVersion(itsVersion, oldestItCanRead: Byte); {optional} BEGIN $IF (itsVersion < 0) OR (itsVersion > 127) OR (oldestItCanRead < 0) OR (oldestItCanRead > 127) OR ((oldestItCanRead > itsVersion) THEN ,ABCBreak('Version numbers must be in the range 0..127 and oldestItCanRead <= itsVersion', 5itsVersion); $QClassVersion(itsVersion, oldestItCanRead); END; { ====================================== VERSION CONVERSION ====================================== } {$S SgCLAcld} PROCEDURE ConvClass(object: TObject; exWorld: TWorld; exIndex, myIndex: INTEGER); BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} $Recreate(object, exWorld.hExClasses^^.records[exIndex].objectSize, (*^*) (hMyClasses^^.records[myIndex].objectSize, hMySTables^^.records[myIndex]); (*^*) ${$IFC fMaxTrace}EP;{$ENDC} END; {$S SgCLAcld} FUNCTION IndexOfExClass(exWorld: TWorld; exIndex: INTEGER): INTEGER; $LABEL 1,2; $VAR exAuthor: TA32; (exAlias: TA8; (exAlpha: TA8; (coCode: INTEGER; (alCode: INTEGER; (index: INTEGER; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} $IndexOfExClass := 0; $WITH exWorld, hExClasses^^.records[exIndex] DO (*^*)(* WHOLE BLOCK CHANGED *) (BEGIN (exAlpha := classAlpha; (IF classAlias = 0 THEN ,exAlias := classAlpha (ELSE ,exAlias := hExAliases^^.records[classAlias]; (IF companyAndAuthor <> 0 THEN ,BEGIN ,exAuthor := hExAuthors^^.records[companyAndAuthor]; ,WITH hMyAuthors^^ DO 0FOR coCode := 1 TO numAuthors DO 4IF records[coCode] = exAuthor THEN (*^*) 8GOTO 1; ,END; (coCode := 0; "1: (END; ${If that class name is in my alias list, do it the hard way} $WITH hMyAliases^^ DO (FOR alCode := 1 TO numAliases DO ,IF records[alCode] = exAlias THEN 0GOTO 2; ${If that class name is one of mine, too, do it the easy way} $index := CiOfAlpha(exAlpha); $IF index <> 0 THEN (*^*) (IF hMyClasses^^.records[index].companyAndAuthor = coCode THEN ,BEGIN (*^*) ,IndexOfExClass := index; ,EXIT(IndexOfExClass); (*^*) ,END; (*^*) ${Different company name or never heard of that class name at all, return 0} $EXIT(IndexOfExClass); (*^*) "2: ${The hard way: exhaustive search, because we may be using different names for the same class} $WITH hMyClasses^^ DO (FOR index := 1 TO numClasses DO ,WITH records[index] DO 0IF coCode = companyAndAuthor THEN 4IF alCode = classAlias THEN 8BEGIN 8IndexOfExClass := index; 8EXIT(IndexOfExClass); 8END; END; {$S SgCLAcld} FUNCTION NeedConversion(exClassWorld: TClassWorld; VAR olderVersion, newerVersion: BOOLEAN): BOOLEAN; $VAR someDifference: BOOLEAN; (exWorld: TWorld; (numExClasses: INTEGER; (exIndex: INTEGER; (exInfo: TClassInfo; (exSize: INTEGER; (exSTP: TPSliceTable; (myIndex: INTEGER; (myInfo: TClassInfo; (mySize: INTEGER; (mySTP: TPSliceTable; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} $someDifference := FALSE; $olderVersion := FALSE; $newerVersion := FALSE; $exWorld := TWorld(exClassWorld); {Separate statement because of a compiler bug} $WITH exWorld DO (BEGIN (numExClasses := hExClasses^^.header.size; (IF numClasses <> numExClasses THEN ,someDifference := TRUE; (FOR exIndex := 1 TO numExClasses DO ,BEGIN ,myIndex := IndexOfExClass(exWorld, exIndex); ,IF myIndex = 0 THEN 0newerVersion := TRUE ,ELSE 0BEGIN 0exInfo := hExClasses^^.records[exIndex]; 0exSize := exInfo.objectSize; 0exSTP := hExSTables^^.records[exIndex]; 0myInfo := hMyClasses^^.records[myIndex]; 0mySize := myInfo.objectSize; 0mySTP := hMySTables^^.records[myIndex]; 0IF (myInfo.version < exInfo.version) OR (mySize < exSize) THEN 4newerVersion := TRUE; 0IF (myInfo.version > exInfo.version) OR (mySize > exSize) THEN 4olderVersion := TRUE; 0IF (mySTP <> exSTP) OR (myInfo.oldestReadableVersion <> exInfo.oldestReadableVersion) THEN 4someDifference := TRUE; 0IF exInfo.superIndex = 0 THEN 4BEGIN 4IF myInfo.superIndex <> 0 THEN 8newerVersion := TRUE; 4END 0ELSE 0IF myInfo.superIndex <> IndexOfExClass(exWorld, exInfo.superIndex) THEN 4newerVersion := TRUE; 0END; ,END; (END; $NeedConversion := someDifference OR olderVersion OR newerVersion; END; {$S SgCLAcld} PROCEDURE ConvertHeap(heap: THeap; exClassWorld: TClassWorld); ${*** VERSION CONVERSION *** %Convert all the contents of heap from its classes to ours. %The job is done in two passes through heap: ((1) ConvertClass changes the method-table pointer of each object, and may change its size. ,If the object grows, extra fields are defaulted to 0/NIL. ((2) ConvertFields tells each object to "Convert(oldVersion)", thus giving the application a 0chance to calculate extra fields or otherwise modify the converted object.} $VAR exWorld: TWorld; (needPassTwo: BOOLEAN; (numExClasses: INTEGER; (hExHashSTP: THIdxArray; (hExEquivalent: THIdxArray; (exIndex: INTEGER; ({toInsert, return: -1 if sliceTable already there or if table full, index if a hole found} ({not toInsert, return: index (> 0) if sliceTable found, -1 if not there} $FUNCTION LookupSTP(stp: TPSliceTable; toInsert: BOOLEAN): INTEGER; (FUNCTION CompareSTP(hashIndex: INTEGER): THashCompare; ,VAR myIndex: INTEGER; (BEGIN ,myIndex := hExHashSTP^^.records[hashIndex]; ,IF myIndex = 0 THEN 0CompareSTP := cHole ,ELSE ,IF exWorld.hExSTables^^.records[myIndex] = stp THEN 0CompareSTP := cMatch ,ELSE 0CompareSTP := cMismatch; (END; $BEGIN (LookupSTP := LookupInHashArray(hExHashSTP^^.header.size, ORD(stp), toInsert, CompareSTP); $END; $FUNCTION EquivIndex(exIndex: INTEGER): INTEGER; (VAR tblIndex: INTEGER; ,myIndex: INTEGER; $BEGIN (tblIndex := exIndex; (WITH exWorld DO ,WHILE tblIndex <> 0 DO 0WITH hExClasses^^.records[tblIndex] DO 4BEGIN 4myIndex := IndexOfExClass(exWorld, tblIndex); 4IF myIndex <> 0 THEN 8IF version >= hMyClasses^^.records[myIndex].oldestReadableVersion THEN  255 or not a Clascal object)} (exIndex := TPByte(pStp)^; (TPByte(pStp)^ := 0; {So the stp comparisons below will be uncluttered} (IF exIndex < 0 THEN ,exIndex := 256 + exIndex; {Undo sign extension caused by TPByte^} (IF exIndex <> 0 THEN {It might be a class pointer} ,IF exIndex > numExClasses THEN 0exIndex := 0 {Not a real class pointer} ,ELSE {Could not use "WITH exWorld" here because code generator balked} ,IF exWorld.hExSTables^^.records[exIndex] <> stp THEN 0exIndex := 0; {Not a real class pointer} (*^*){Also added next 3 comments below} (IF exIndex = 0 THEN {It is not a class pointer, or exIndex>255} ,IF numExClasses > 255 THEN {It might be a class pointer after all} 0BEGIN {Look in the hash table} 0exHashIndex := LookupSTP(stp, FALSE); 0IF exHashIndex <= 0 THEN {Not a Clascal object} 4Exit(FindClasses); 0exIndex := hExHashSTP^^.records[exHashIndex]; 0END ,ELSE 0Exit(FindClasses); {not a Clascal object} &{Determine the equivalent class in my process} (myIndex := hExEquivalent^^.records[exIndex]; (FindClasses := TRUE; (WITH exWorld.hExClasses^^.records[exIndex] DO ,BEGIN ,exVersion := version; ,exSize := objectSize; ,END; (WITH hMyClasses^^.records[myIndex] DO ,moreConversion := (exVersion < version) OR (exSize < objectSize); (**** Replaced the following line by the preceding because it is too complicated for the ,Spring Release code generator: (WITH exWorld.hExClasses^^ DO ,moreConversion := (records[exIndex].version < hMyClasses^^.records[myIndex].version) OR >(records[exIndex].objectSize < hMyClasses^^.records[myIndex].objectSize); ****) %END; $PROCEDURE ConvertClass(object: TObject); ({Pass 1: Map the method-table ptr from the original to mine and change the object size} (VAR exIndex: INTEGER; ,myIndex: INTEGER; ,moreConverson: BOOLEAN; $BEGIN &{Determine both the original and my class} (IF FindClasses(object, exIndex, myIndex, moreConversion) THEN ,BEGIN *{Convert the method table pointer, change the size, default extra fields to 0/NIL} ,ConvClass(object, exWorld, exIndex, myIndex); ,IF moreConversion THEN {a second pass will be needed to let the app do special defaulting} 0needPassTwo := TRUE; ,END; $END; $PROCEDURE ConvertFields(object: TObject); ({Pass 2: Default extra fields; a separate pass so the application can follow pointers if need be} (VAR exIndex: INTEGER; ,myIndex: INTEGER; ,moreConverson: BOOLEAN; $BEGIN &{Determine both the original and my class} (IF FindClasses(object, exIndex, myIndex, moreConversion) THEN ,IF moreConversion THEN {Let the app supply extra fields etc.} 0object.Convert(exWorld.hExClasses^^.records[exIndex].version); $END; BEGIN ${$IFC fMaxTrace}BP(1);{$ENDC} ${$IFC fMaxTrace}EP;{$ENDC} $exWorld := TWorld(exClassWorld); $WITH exWorld DO (BEGIN (numExClasses := hExClasses^^.header.size; &{Make temporary arrays that will speed up reconciliation of the two worlds} (hExEquivalent := MakeIdxArray(numExClasses, FALSE); (FOR exIndex := 1 TO numExClasses DO ,hExEquivalent^^.records[exIndex] := EquivIndex(exIndex); (IF numExClasses > 255 THEN ,BEGIN ,hExHashSTP := MakeIdxArray(numExClasses - 255, TRUE); ,FOR exIndex := 256 TO numExClasses DO 0hExHashSTP^^.records[LookupSTP(hExSTables^^.records[exIndex], TRUE)] := exIndex; ,END; (END; $needPassTwo := FALSE; "{Pass One -- convert method table pointers (STPs)} $EachObject(heap, ConvertClass); "{Pass Two -- let application default extra fields} $IF needPassTwo THEN (EachObject(heap, ConvertFields); "{Free the temporary arrays} $FreeH(THz(mainHeap), TH(hExEquivalent)); $IF numExClasses > 255 THEN (*^*) (FreeH(THz(mainHeap), TH(hExHashSTP)); END; {$S sError} PROCEDURE ClascalReason(error: INTEGER; VAR s: S255); BEGIN $CASE error OF (OTHERWISE s := 'Some kind of problem'; {** Need more cases **} (END; END; {$S sInit1} PROCEDURE ClascalError(error: INTEGER); {called with error = 0 after successful Clascal initialization} $VAR s: S255; (i: INTEGER; BEGIN $IF error > 0 THEN (BEGIN ({$IFC fDbgObject} (ClascalReason(error, s); ({$ENDC} (IF isInitialized THEN ,BEGIN ,{$IFC fDbgObject} ,ABCBreak(s, error); ,{$ENDC} ,TrmntExceptionHandler; ,END (ELSE ,BEGIN ,{$IFC fDbgObject} ,WriteLn('Clascal error: ', s); ,{$ENDC} ,IF wmIsInitialized THEN 0InitErrorAbort(error) ,ELSE ,{$IFC fDbgObject} 0%_GoLisaBug; ,{ELSEC} 0HALT; ,{$ENDC} ,END; (END $ELSE $IF NOT classesInitialized THEN (BEGIN &{*** STILL TO DO: The first time the program runs, write to the tool resource file ***} ({Save conversion information not obtainable from UClascal in permanent arrays} (***** (hMyClasses := THClasses(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TClassInfo), numClasses)); (XferLeft(Ptr(pClasses), @hMyClasses^^.records, numClasses * SIZEOF(TClassInfo)); (hMySTables := THSTables(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TPSliceTable), numClasses)); (XferLeft(Ptr(pSTables), @hMySTables^^.records, numClasses * SIZEOF(TPSliceTable)); (hMyAuthors := THAuthors(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TA32), numAuthors)); (XferLeft(Ptr(pAuthors), @hMyAuthors^^.records, numAuthors * SIZEOF(TA32)); (hMyAliases := THAliases(TDynamicArray.CREATE(NIL, mainHeap, SIZEOF(TA8), numAliases)); (XferLeft(Ptr(pAliases), @hMyAliases^^.records, numAliases * SIZEOF(TA8)); *****) (hMyClasses := THClasses(TArray.CREATE(NIL, mainHeap, numClasses, SIZEOF(TClassInfo))); (TArray(hMyClasses).EditAt(1, numClasses); (XferLeft(Ptr(pClasses), @hMyClasses^^.records, numClasses * SIZEOF(TClassInfo)); (hMySTables := THSTables(TArray.CREATE(NIL, mainHeap, numClasses, SIZEOF(TPSliceTable))); (TArray(hMySTables).EditAt(1, numClasses); (XferLeft(Ptr(pSTables), @hMySTables^^.records, numClasses * SIZEOF(TPSliceTable)); (hMyAuthors := THAuthors(TArray.CREATE(NIL, mainHeap, numAuthors, SIZEOF(TA32))); (TArray(hMyAuthors).EditAt(1, numAuthors); (XferLeft(Ptr(pAuthors), @hMyAuthors^^.records, numAuthors * SIZEOF(TA32)); (hMyAliases := THAliases(TArray.CREATE(NIL, mainHeap, numAliases, SIZEOF(TA8))); (TArray(hMyAliases).EditAt(1, numAliases); (XferLeft(Ptr(pAliases), @hMyAliases^^.records, numAliases * SIZEOF(TA8)); (WITH myWorld DO ,BEGIN ,infRecs := TArray(hMyClasses); {&&& field names are a bit confusing} ,classes := TArray(hMySTables); ,authors := TArray(hMyAuthors); ,aliases := TArray(hMyAliases); ,END; (hMyHashName := MakeIdxArray(numClasses, TRUE); (FOR i := 1 TO numClasses DO ,hMyHashName^^.records[LookupName(hMyClasses^^.records[i].classAlpha, TRUE)] := i; (END; END; { ====================================== METHODS OF CLASSES ====================================== } METHODS OF TObject; {$S sStartup} $PROCEDURE TObject.Become(object: TObject); (LABEL 1; (VAR hSelf: TH; ,hObj: TH; ,bkSelf: TBk; ,bkObj: TBk; ,p: TP; {$IFC LibraryVersion <= 20} ,oh: TC; {$ELSEC} ,tempBP: TBp; {$ENDC} $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (IF SELF.Heap <> object.Heap THEN ,BEGIN ,{$IFC fDbgObject} ,WriteLn(ORD(SELF)); ,ABCBreak('Attempt to Become an object on another heap', ORD(object)); ,{$ENDC} ,GOTO 1; ,END; (hSelf := TH(SELF); (hObj := TH(object); (bkSelf := TBk(ORD(hSelf^) - 4); (bkObj := TBk(ORD(hObj^) - 4); (p := hSelf^; (hSelf^ := hObj^; (hObj^ := p; {$IFC LibraryVersion <= 20} (oh := bkSelf^.oh; (bkSelf^.oh := bkObj^.oh; (bkObj^.oh := oh; {$ELSEC} (tempBP := bkSelf^.bp; (bkSelf^.bp := bkObj^.bp; (bkObj^.bp := tempBP; {$ENDC} (object.Free; 1: ({$IFC fTrace}EP;{$ENDC} $END; {$S sStartup} $FUNCTION TObject.Class: TClass; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} (Class := ClassPtr(Handle(SELF)); ({$IFC fMaxTrace}EP;{$ENDC} $END; {$S sRes} $FUNCTION TObject.Clone(heap: THeap): TObject; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} (Clone := SELF.CloneObject(heap); ({$IFC fMaxTrace}EP;{$ENDC} $END; {$S sRes} $FUNCTION TObject.CloneObject(heap: THeap): TObject; (VAR hz: THz; ,size: INTEGER; ,source: TH; ,dest: TH; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (hz := THz(heap); (source := TH(SELF); (size := cbDataOfH(hz, source); (dest := HAllocate(hz, size); (XferLeft(@source^^, @dest^^, size); (CloneObject := TObject(dest); ({$IFC fTrace}EP;{$ENDC} $END; {$S sStartup} $PROCEDURE TObject.Free; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.FreeObject; ({$IFC fTrace}EP;{$ENDC} $END; {$S sStartup} $PROCEDURE TObject.FreeObject; (VAR heap: THeap; ,numObjects: INTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (heap := SELF.Heap; (FreeH(THz(heap), TH(SELF)); ({$IFC fTrace}EP;{$ENDC} $END; {$S sStartup} $FUNCTION TObject.Heap: THeap; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (Heap := THeap(HzFromH(TH(SELF))); $END; {$S sRes} $FUNCTION TObject.HeapBytes: INTEGER; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (HeapBytes := CbDataOfH(HzFromH(TH(SELF)), TH(SELF)); ({$IFC fTrace}EP;{$ENDC} $END; {$S sLOX} $PROCEDURE TObject.Read(s: TStringScanner); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (s.XferFields(xRead, SELF); ({$IFC fTrace}EP;{$ENDC} $END; {$S sLOX} $PROCEDURE TObject.Write(s: TStringScanner); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (s.XferFields(xWrite, SELF); ({$IFC fTrace}EP;{$ENDC} $END; ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TObject.Debug(numLevels: INTEGER; memberTypeStr: S255); (VAR class: TClass; ,name: TClassName; ,str: S255; ,{$IFC fTrace} ,oldFlag: BOOLEAN; ,{$ENDC} (PROCEDURE SupplyObjFields(PROCEDURE Field(nameAndType: S255)); (BEGIN ,SELF.Fields(Field); (END; $BEGIN ({$IFC fTrace} (oldFlag := fDebugRecursion; (fDebugRecursion := TRUE; ({$ENDC} (class := SELF.Class; (CpToCn(TPSliceTable(class), TS8(name)); (TrimBlanks(@name); (WrStr(Concat(name, ' ')); ({$IFC fDebugMethods} (IF numLevels > 0 THEN ,WriteDRecord(numLevels, Handle(SELF), 4, SupplyObjFields); {4 skips method table ptr} ({$ELSEC} (LIntToHex(ORD(SELF), @str); (str := Concat('-- $', str); (IF NOT ValidObject(Handle(SELF)) THEN ,str := Concat('Invalid Object', str); (WrStr(str); ({$ENDC} ({$IFC fTrace} (fDebugRecursion := oldFlag; ({$ENDC} $END; ${$S SgCLAres} ${$ENDC} ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TObject.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN $END; ${$S SgCLAres} ${$ENDC} ${$S SgCLAcld} $PROCEDURE TObject.Convert(fromVersion: Byte); $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $END; ${$S SgCLAres} ${$S SgCLAcld} $FUNCTION TObject.JoinClass(newClass: TClass): TObject; (VAR oldClass: TClass; $BEGIN ({$IFC fTrace}BP(7);{$ENDC} (oldClass := SELF.Class; (IF NOT ClassDescendsFrom(oldClass, newClass) THEN ,IF ClassDescendsFrom(newClass, oldClass) THEN 0Recreate(SELF, SizeOfCp(TPSliceTable(oldClass)), ?SizeOfCP(TPSliceTable(newClass)), TPSliceTable(newClass)) (*^*) ,ELSE 0{$IFC fDbgObject} 0ABCBreak('An Object cannot move to an unrelated class', ORD(newClass)) 0{$ENDC}; (JoinClass := SELF; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgCLAres} {$S sInit1} BEGIN {Class Initialization} $InitClascal(ClascalError); {Provide an error routine in case of errors in Clascal run-time support} $InitObject; {Do remaining initialization} $UnitAuthor('Apple'); $cObject := THISCLASS; END; 3. "6F^9NDD!$ǐ^)c8787YLRING !!!! } path, ''), manip)); tream; canner; N a.`a.̥$ȐD&nt'); 0Field('b¬L0Z`aa.a.`LRa.̥$̥L̋h(osPath: Pathname; (error: INTEGER; BEGIN $osPath := path; { THIS IS THE SECOND TIME WE COPY THE STRING !!!! } $Lookup(error, osPath, refInfo); $IF error <= 0 THEN (FileModified := refInfo.DTM $ELSE (FileModifie{INCLUDE FILE UOBJECT3 -- COLLECTIONS} {Copyright 1983, 1984, Apple Computer, Inc.} {Segments: SgCLAini(tialize and Terminate), SgCLAres(ident), SgCLAc(o)ld, SgCLAdbg} {$S sResDat} PROCEDURE XferContiguous(whichWay: xReadWrite; collection: TCollection; alsoSkip: INTEGER; s: TStringScanner); ({Transfer the size (as an INTEGER), class-specific fields (after alsoSkip bytes), and all members. )Do not recur on the members. )Do not transfer the class, the dynStart (=SizeOfClass), or the hole info (=zero). )When reading, append the elements that are read. )This only works for contiguous objects up to 32K members in size.} $VAR size: INTEGER; (numToXfer: INTEGER; BEGIN ${$IFC fTrace}BP(3);{$ENDC} $size := collection.size; $collection.StopEdit; $CASE whichWay OF (xRead: ,BEGIN ,numToXfer := s.ReadNumber(2); ,collection.EditAt(size + 1, numToXfer); ,size := collection.size; ,END; (xWrite: ,BEGIN ,numToXfer := size; ,s.WriteNumber(numToXfer, 2); ,END; (END; $s.XferSequential(whichWay, 5Ptr(ORD(Handle(collection)^) + SIZEOF(TCollection) + alsoSkip), 5size * collection.MemberBytes); ${$IFC fTrace}EP;{$ENDC} END; {INVARIANT ON TCollections: $given a collection c, the elements of the collection are stored at physical indices: ([1..c.holeStart] and [c.holeStart+c.holeSize+1..c.Size+c.holeSize] the hole occupies physical indices: ([c.holeStart+1..c.holeStart+c.holeSize] } METHODS OF TCollection; {$S sResDat} $FUNCTION TCollection.CREATE(object: TObject; heap: THeap; initialSlack: INTEGER): TCollection; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF object = NIL THEN ,ABCBreak('TCollection.CREATE must be passed an already-allocated object by a subclass CREATE', 0); (SELF := TCollection(object); (WITH SELF DO ,BEGIN ,size := 0; &{$H-} dynStart := SizeOfClass(SELF.Class); {$H+} ,holeStart := 0; ,holeSize := initialSlack; ,holeStd := 0; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TCollection.Clone(heap: THeap): TObject; (VAR numMembers: INTEGER; ,collection: TCollection; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (numMembers := SELF.size; (collection := TCollection(NewDynObject(heap, SELF.Class, numMembers * SELF.MemberBytes)); (XferLeft(Ptr(Handle(SELF)^), Ptr(Handle(collection)^), SELF.dynStart); (collection := TCollection.CREATE(collection, heap, numMembers); (collection.InsManyAt(1, SELF, 1, numMembers); (Clone := collection; ({$IFC fTrace}EP;{$ENDC} $END; ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TCollection.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN (SUPERSELF.Fields(Field); (Field('size: LONGINT'); (Field('dynStart: INTEGER'); (Field('holeStart: INTEGER'); (Field('holeSize: INTEGER'); (Field('holeStd: INTEGER'); $END; ${$S SgCLAres} ${$ENDC} ${$IFC fCheckIndices} ${$S SgCLAdbg} $PROCEDURE TCollection.CheckIndex(index: LONGINT); $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (IF (index < 1) OR (index > SELF.size) THEN ,ABCBreak('CheckIndex', index); $END; ${$S SgCLAres} ${$ENDC} {$S sResDat} $FUNCTION TCollection.AddrMember(i: LONGINT): LONGINT; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', i); ({$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,IF (i < 1) OR (i > SELF.size+1) THEN 0ABCBreak('CheckIndex', i); ({$ENDC} (IF i > SELF.holeStart THEN ,i := i + SELF.holeSize; ({i is now a physical index} (AddrMember := TpLONGINT(SELF)^ + SELF.dynStart + (SELF.MemberBytes * (i - 1)); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TCollection.CopyMembers(dstAddr, startIndex, howMany: LONGINT); (VAR memberBytes: INTEGER; ,beforeHole: INTEGER; ,srcAddr: LONGINT; ,j: INTEGER; ,offset: INTEGER; ,numBytes: INTEGER; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (IF startIndex < 1 THEN ,startIndex := 1; (howMany := Min(howMany, SELF.size + 1 - startIndex); (IF (howMany > 0) AND (startIndex <= SELF.size) THEN ,BEGIN ,memberBytes := SELF.MemberBytes; ,beforeHole := Min(howMany, SELF.holeStart + 1 - startIndex); ,srcAddr := SELF.AddrMember(startIndex); ,IF beforeHole > 0 THEN 0BEGIN 0numBytes := beforeHole * memberBytes; 0XferLeft(Ptr(srcAddr), Ptr(dstAddr), numBytes); 0dstAddr := dstAddr + numBytes; 0END ,ELSE 0beforeHole := 0; ,IF beforeHole < howMany THEN 0BEGIN 0srcAddr := SELF.AddrMember(startIndex + beforeHole); 0XferLeft(Ptr(srcAddr), Ptr(dstAddr), (howMany - beforeHole) * memberBytes); 0END; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} {AFTER EXECUTING THIS METHOD: $IF deltaMembers >= 0, (physical positions [atIndex..atIndex+deltaMembers-1] are available for adding new members. $IF deltaMembers < 0, (actual members [atIndex..atIndex-deltaMembers+1] have been removed. NOTE: This routine does not preserve the TCollection invariant. } $PROCEDURE TCollection.EditAt(atIndex: LONGINT; deltaMembers: INTEGER); (VAR oldHoSize: INTEGER; ,newHoSize: INTEGER; ,oldHoStart: INTEGER; ,newHoStart: INTEGER; ,maxHoStart: INTEGER; ,minHoStart: INTEGER; ,size: INTEGER; ,b: 0..1; $BEGIN {Removes any hole it creates unless holdStd <> 0} ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', atIndex); ({$ENDC} ({Force atIndex and deltaMembers into the valid range} (atIndex := Max(1, Min(atIndex, SELF.size + 1)); (IF deltaMembers < 0 THEN ,deltaMembers := Min(0, Max(deltaMembers, atIndex - SELF.size - 1)); (***** Range checks not necessary with the above code ({$IFC fCheckIndices} (IF fCheckIndices THEN ,BEGIN ,IF atIndex <> (SELF.size + 1) THEN 0SELF.CheckIndex(atIndex); ,IF deltaMembers < 0 THEN 0SELF.CheckIndex(atIndex - 1 - deltaMembers); ,END; ({$ENDC} *****) (oldHoSize := SELF.holeSize; (oldHoStart := SELF.holeStart; (IF (deltaMembers < 0) AND ((oldHoStart + 1) = atIndex) THEN {the hole is right before the deletion} ,SELF.holeStart := oldHoStart - deltaMembers {deltaMembers is going to be added in again later} (ELSE ,BEGIN ,newHoStart := atIndex - 1 - Min(deltaMembers, 0); ,IF (deltaMembers > oldHoSize) OR (newHoStart <> oldHoStart) THEN 0BEGIN 0maxHoStart := Max(oldHoStart, newHoStart); 0newHoSize := Max(oldHoSize, deltaMembers); 0IF newHoSize > oldHoSize THEN 4BEGIN 4{increase the space allocated to the collection, and shift the collection so that the 5the last real element is at the end of the space allocated to the collection; 5but only move REAL elements that will end up after the hole} 4size := SELF.size; 4newHoSize := Max(newHoSize, SELF.holeStd); 4SELF.ResizeColl(size + newHoSize); 4SELF.ShiftColl(maxHoStart + oldHoSize, maxHoStart + newHoSize, size - maxHoStart); 4{Explanation of the above line: 8maxHoStart = max # real elements before the hole (in initial and final collections) 8size = # real elements in the initial collection 8therefore, size - maxHoStart is min # real elements after the hole, which  oldHoStart THEN 4BEGIN 4b := ORD(newHoStart > oldHoStart); {1 if hole is moving right and data is moving left, [0 otherwise} 4minHoStart := Min(oldHoStart, newHoStart); 4SELF.ShiftColl(minHoStart + oldHoSize*b, minHoStart + newHoSize*(1-b), DmaxHoStart - minHoStart); 4END; 0SELF.holeStart := newHoStart; 0SELF.holeSize := newHoSize; 0END; ,END; (WITH SELF DO ,BEGIN ,size := size + deltaMembers; ,holeSize := holeSize - deltaMembers; ,holeStart := holeStart + deltaMembers; ,IF oldHoSize = 0 THEN 0IF holeStd = 0 THEN 4IF holeSize > 0 THEN 0{$H-} SELF.StopEdit; {$H+} ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TCollection.Equals(otherCollection: TCollection): BOOLEAN; (LABEL 1; (VAR memberBytes: INTEGER; ,size: INTEGER; ,i: INTEGER; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (Equals := FALSE; (memberBytes := SELF.MemberBytes; (size := SELF.size; (IF SELF = otherCollection THEN ,Equals := TRUE (ELSE (IF size = otherCollection.size THEN ,IF memberBytes = otherCollection.MemberBytes THEN 0BEGIN 0FOR i := 1 TO size DO 4IF NOT EqualBytes(Ptr(SELF.AddrMember(i)), Ptr(otherCollection.AddrMember(i)), WmemberBytes) THEN 8GOTO 1; 0Equals := TRUE; 0END; (1: ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TCollection.InsManyAt(i: LONGINT; otherCollection: TCollection; index, howMany: LONGINT); $BEGIN {Stops edit if it wasn't explicitly started} ({$IFC fTrace}BP(3);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', i); ({$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices AND (howMany > 0) THEN ,BEGIN {i is checked by EditAt} ,IF SELF.memberBytes <> otherCollection.MemberBytes THEN 0BEGIN 0WriteLn; 0WriteLn('*** ERROR: Tried to insert ', otherCollection.MemberBytes:1, 8'-byte Members into a TCollection with ', SELF.memberBytes, '-byte Members'); 0ABCbreak('InsManyAt', howMany); 0END; (***** Dont need range checks anymore ,otherCollection.CheckIndex(index); ,otherCollection.CheckIndex(index + howMany - 1); *****) ,END; ({$ENDC} (IF howMany > 0 THEN ,BEGIN ,SELF.EditAt(i, howMany); ,otherCollection.CopyMembers(SELF.AddrMember(i), index, howMany); ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TCollection.InsNullsAt(i, howMany: LONGINT); (VAR dstAddr: LONGINT; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', i); ({$ENDC} (SELF.EditAt(i, howMany); (IF howMany > 0 THEN ,BEGIN ,dstAddr := SELF.AddrMember(i); ,TPByte(dstAddr)^ := 0; ,XferLeft(Ptr(dstAddr), Ptr(dstAddr + 1), howMany * SELF.MemberBytes-1); 0{WARNING: The success of the preceding line depends on the fact the XferLeft 8copies data 1 byte at a time; use of a routine that tries to optimize the 8transfer will negatively impact the correctness of this method.} ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} {NOTE: This routine does not preserve the TCollection invariant.} $PROCEDURE TCollection.ResizeColl(membersPlusHole: INTEGER); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', membersPlusHole); ({$ENDC} (IF membersPlusHole <> (SELF.size + SELF.holeSize) THEN ,ResizeDynObject(SELF, SELF.dynStart + (membersPlusHole * SELF.MemberBytes)); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} {NOTE: This routine does not preserve the TCollection invariant.} $PROCEDURE TCollection.ShiftColl(afterSrcIndex, afterDstIndex, howMany: INTEGER); (VAR memberBytes: INTEGER; ,numBytes: INTEGER; ,startAddr: LONGINT; ,srcAddr: LONGINT; ,dstAddr: LONGINT; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', howMany); ({$ENDC} (IF (howMany > 0) AND (afterSrcIndex <> afterDstIndex) THEN ,BEGIN ,memberBytes := SELF.MemberBytes; ,numBytes := howMany * memberBytes; ,startAddr := TpLONGINT(SELF)^ + SELF.dynStart; ,srcAddr := startAddr + afterSrcIndex * memberBytes; ,dstAddr := startAddr + afterDstIndex * memberBytes; ,IF afterSrcIndex < afterDstIndex THEN 0XferRight(Ptr(srcAddr), Ptr(dstAddr), numBytes) ,ELSE 0XferLeft(Ptr(srcAddr), Ptr(dstAddr), numBytes); ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TCollection.StartEdit(withSlack: INTEGER); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', withSlack); ({$ENDC} (SELF.holeStd := withSlack; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TCollection.StopEdit; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fDbgObject} (IF SELF.dynStart = MAXINT THEN ,ABCBreak('No dynamic part', 0); ({$ENDC} (IF SELF.holeStart < SELF.size THEN ,SELF.EditAt(SELF.size + 1, 0); (SELF.ResizeColl(SELF.size); (SELF.holeStd := 0; (SELF.holeSize := 0; ({$IFC fTrace}EP;{$ENDC} $END; {$S sInit1} BEGIN ${$IFC fCheckIndices} $fCheckIndices := FALSE; ${$ENDC} END; {$S SgCLAres} METHODS OF TList; {$S sResDat} $FUNCTION TList.CREATE(object: TObject; heap: THeap; initialSlack: INTEGER): TList; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF object = NIL THEN ,object := NewDynObject(heap, THISCLASS, initialSlack * SIZEOF(Handle)); (SELF := TList(TCollection.CREATE(object, heap, initialSlack)); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TList.Free; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.Each(Free); (SUPERSELF.Free; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TList.Clone(heap: THeap): TObject; (VAR l: TList; ,j: INTEGER; ,x: TObject; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (l := TList(SUPERSELF.Clone(heap)); (FOR j := 1 TO l.size DO ,BEGIN ,x := SELF.At(j); ,IF x <> NIL THEN 0l.PutAt(j, x.Clone(heap), FALSE); ,END; (Clone := l; ({$IFC fTrace}EP;{$ENDC} $END; ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TList.Debug(numLevels: INTEGER; memberTypeStr: S255); $VAR s: TListScanner; (obj: TObject; (str: S8; (first: BOOLEAN; ({$IFC fTrace} (oldFlag: BOOLEAN; ({$ENDC} $BEGIN ({$IFC fTrace} (oldFlag := fDebugRecursion; (fDebugRecursion := TRUE; ({$ENDC} (SUPERSELF.Debug(numLevels, ''); { this prints other fields of the list } (IF numLevels > 0 THEN ,BEGIN ,WrStr('('); ,IF numLevels = 1 THEN { compressed list of classes } 0SELF.DebugMembers ,ELSE { list of classes and their handles } 0BEGIN 0s := SELF.Scanner; 0IF s.position = SELF.holeStart THEN 4Write('<=HOLE=>'); 0first := TRUE; 0WHILE s.Scan(obj) DO 4BEGIN 4IF NOT first THEN 8WrStr(', '); 4first := FALSE; 4IF obj = NIL THEN 8WrStr('NIL') 4ELSE IF ValidObject(Handle(obj)) THEN 8obj.Debug(numLevels-2, '') 4ELSE 8WrStr(''); 4IF numLevels = 2 THEN 8BEGIN 8LIntToHex(ORD4(obj), @str); 8WrStr(CONCAT(': $', str)); 8END; 4IF s.position = SELF.holeStart THEN 8Write('<=HOLE=>'); 4END; 0END; ,WrStr(')'); ,END; ({$IFC fTrace} (fDebugRecursion := oldFlag; ({$ENDC} $END; ${$S SgCLAres} ${$S SgCLAdbg} $PROCEDURE TList.DebugMembers; (VAR y: TObject; ,s: TListScanner; ,str: S8; ,initial: BOOLEAN; ,class: TClass; ,thisClass: TClassName; ,prevClass: TClassName; ,sameClass: INTEGER; ,charCount: INTEGER; (PROCEDURE WriteMembers; ,VAR charsNeeded: INTEGER; (BEGIN ,IF sameClass = 0 THEN EXIT(WriteMembers); ,IF sameClass = 1 THEN 0charsNeeded := 10 ,ELSE 0charsNeeded := 13; ,IF initial THEN 0initial := FALSE ,ELSE IF (charCount + charsNeeded) > 70 THEN 0BEGIN 0WrStr(','); 0WrLn; 0WrStr(' '); 0charCount := 10; 0END ,ELSE 0WrStr(', '); ,str := prevClass; ,WrStr(str); ,IF sameClass > 1 THEN 0BEGIN 0IntToStr(sameClass, @str); 0WrStr(CONCAT('*', str)); 0END; ,charCount := charCount + charsNeeded; (END; $BEGIN (IF SELF.size > 0 THEN {prevent initialization anomaly in BP(i)/EP} ,BEGIN ,charCount := cMin(indentTrace, 20) + 30; ,initial := TRUE; ,sameClass := 0; ,prevClass := ''; ,s := SELF.Scanner; ,WHILE s.Scan(y) DO 0BEGIN 0IF y = NIL THEN 4thisClass := 'NIL' 0ELSE IF ValidObject(Handle(y)) THEN 4BEGIN 4class := y.Class; 4CpToCn(TPSliceTable(class), TS8(thisClass)); 4END 0ELSE 4thisClass := '????????'; 0IF thisClass <> prevClass THEN 4BEGIN 4WriteMembers; 4sameClass := 1; 4END 0ELSE 4sameClass := sameClass + 1; 0prevClass := thisClass; 0END; ,WriteMembers; ,END; $END; ${$S SgCLAres} ${$ENDC} {$S sResDat} $FUNCTION TList.At(i: LONGINT): TObject; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} '{At := TPObject(SELF.AddrMember(i))^; but for speed...} (IF i > SELF.holeStart THEN ,i := i + SELF.holeSize; (At := TPObject(TpLONGINT(SELF)^ + SELF.dynStart + (4 * (i - 1)))^; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.DelAll(freeOld: BOOLEAN); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (IF freeOld THEN ,SELF.Each(Free); (SELF.EditAt(1, -SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.DelAt(i: LONGINT; freeOld: BOOLEAN); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} (IF freeOld THEN ,Free(SELF.At(i)); (SELF.EditAt(i, -1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.DelFirst(freeOld: BOOLEAN); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.DelAt(1, freeOld); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.DelLast(freeOld: BOOLEAN); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.DelAt(SELF.size, freeOld); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.DelManyAt(i, howMany: LONGINT; freeOld: BOOLEAN); (VAR j: INTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (IF howMany > 0 THEN ,BEGIN ,{$IFC fCheckIndices} ,IF fCheckIndices THEN 0BEGIN 0SELF.CheckIndex(i); 0SELF.CheckIndex(i+howMany-1); 0END; ,{$ENDC} ,IF freeOld THEN 0FOR j := 0 TO howMany - 1 DO 4Free(SELF.At(i + j)); ,SELF.EditAt(i, -howMany); ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.DelObject(object: TObject; freeOld: BOOLEAN); (VAR y: TObject; ,s: TListScanner; $BEGIN {If there is more than one occurrence, and editing is off, this calls StopEdit more than once} ({$IFC fTrace}BP(4);{$ENDC} (s := SELF.Scanner; (WHILE s.Scan(y) DO ,IF y = object THEN 0s.Delete(FALSE); (IF freeOld THEN ,Free(object); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TList.Each(PROCEDURE DoToObject(object: TObject)); (VAR holeStart: INTEGER; ,offset: INTEGER; ,j: INTEGER; ,pObject: TPObject; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (holeStart := SELF.holeStart; (offset := SELF.dynStart; (FOR j := 0 TO SELF.size - 1 DO ,BEGIN ,IF j = holeStart THEN 0offset := offset + 4 * SELF.holeSize; ,pObject := TPObject(TpLONGINT(SELF)^ + offset); ,DoToObject(pObject^); ,offset := offset + 4; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TList.First: TObject; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (First := SELF.At(1); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TList.InsAt(i: LONGINT; object: TObject); (VAR pObject: TPObject; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.EditAt(i, 1); (pObject := TPObject(SELF.AddrMember(i)); (pObject^ := object; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.InsFirst(object: TObject); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.InsAt(1, object); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TList.InsLast(object: TObject); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.InsAt(SELF.size + 1, object); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TList.Last: TObject; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (Last := SELF.At(SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TList.ManyAt(i, howMany: LONGINT): TList; (VAR list: TList; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (list := TList.CREATE(NIL, SELF.Heap, howMany); (list.InsManyAt(1, SELF, i, howMany); (ManyAt := list; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TList.MemberBytes: INTEGER; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (MemberBytes := 4; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TList.PopLast: TObject; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (PopLast := SELF.Last; (SELF.DelLast(FALSE); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TList.Pos(after: LONGINT; object: TObject): LONGINT; (VAR y: TObject; ,s: TListScanner; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (Pos := after; (s := SELF.ScannerFrom(after, scanForward); (WHILE s.Scan(y) DO ,IF object = y THEN 0BEGIN 0Pos := s.position; 0s.Done; 0END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TList.PutAt(i: LONGINT; object: TObject; freeOld: BOOLEAN); (VAR pObject: TPObject; ,oldObject: TObject; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} '{pObject := TPObject(SELF.AddrMember(i)); but for speed...} (IF i > SELF.holeStart THEN ,i := i + SELF.holeSize; (pObject := TPObject(TpLONGINT(SELF)^ + SELF.dynStart + (4 * (i - 1))); (oldObject := pObject^; (pObject^ := object; (IF freeOld THEN ,IF object <> oldObject THEN 0Free(oldObject); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TList.Scanner: TListScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (Scanner := TListScanner.CREATE(NIL, SELF, 0, scanForward); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TList.ScannerFrom(firstToScan: LONGINT; scanDirection: TScanDirection): TListScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (ScannerFrom := TListScanner.CREATE(NIL, SELF, firstToScan, scanDirection); ({$IFC fTrace}EP;{$ENDC} $END; {$S sInit1} {$IFC compatibleLists} {For TIndexList.Class} BEGIN $cList := THISCLASS; {$ENDC} END; {$S SgCLAres} METHODS OF TArray; {$S sResDat} $FUNCTION TArray.CREATE(object: TObject; heap: THeap; initialSlack, bytesPerRecord: INTEGER): TArray; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF ODD(bytesPerRecord) THEN ,bytesPerRecord := bytesPerRecord + 1; (IF object = NIL THEN ,object := NewDynObject(heap, THISCLASS, initialSlack * bytesPerRecord); (SELF := TArray(TCollection.CREATE(object, heap, initialSlack)); (SELF.recordBytes := bytesPerRecord; ({$IFC fTrace}EP;{$ENDC} $END; ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TArray.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN (SUPERSELF.Fields(Field); (Field('recordBytes: INTEGER'); $END; ${$S SgCLAres} ${$ENDC} ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TArray.Debug(numLevels: INTEGER; memberTypeStr: S255); (VAR s: TArrayScanner; ,pRecord: Ptr; ,i: INTEGER; ,j: INTEGER; ,str: S255; ,hexOrd: S8; (PROCEDURE SupplyMember(PROCEDURE Field(nameAndType: S255)); (BEGIN ,Field(Concat(str, ': ', memberTypeStr)); (END; $BEGIN (SUPERSELF.Debug(numLevels, ''); { this prints other fields of the array } (IF (numLevels > 1) OR ((numLevels = 1) AND (memberTypeStr <> '')) THEN ,BEGIN ,WrStr('{ '); ,i := 0; ,s := SELF.Scanner; ,IF s.position = SELF.holeStart THEN 0WrStr(' <=HOLE=> '); ,WHILE s.Scan(pRecord) DO 0BEGIN 0IF i > 0 THEN 4WrStr(', '); 0i := i + 1; 0IntToStr(i, @str); 0IF memberTypeStr = '' THEN 4BEGIN 4str := CONCAT(str, ': '); 4FOR j := 0 TO SELF.recordBytes-1 DO 8BEGIN 8LIntToHex(TPByte(ORD(pRecord)+j)^, @hexOrd); 8str := CONCAT(str, Copy(hexOrd, 7, 2)); 8END; 4WrStr(str); 4END 0ELSE 4WriteDRecord(numLevels - 1, @pRecord, 0, SupplyMember); 0IF s.position = SELF.holeStart THEN 4WrStr(', <=HOLE=> '); 0END; ,WrStr(' }'); ,END; $END; ${$S SgCLAres} ${$ENDC} {$S sResDat} $FUNCTION TArray.At(i: LONGINT): Ptr; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} '{ At := Ptr(SELF.AddrMember(i)); but for speed...} (IF i > SELF.holeStart THEN ,i := i + SELF.holeSize; (At := Ptr(TpLONGINT(SELF)^ + SELF.dynStart + (SELF.recordBytes * (i - 1))); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArray.DelAll; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.EditAt(1, -SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArray.DelAt(i: LONGINT); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.EditAt(i, -1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArray.DelFirst; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.DelAt(1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArray.DelLast; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.DelAt(SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArray.DelManyAt(i, howMany: LONGINT); (VAR j: INTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (IF howMany > 0 THEN ,SELF.EditAt(i, -howMany); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArray.Each(PROCEDURE DoToRecord(pRecord: Ptr)); (VAR holeStart: INTEGER; ,offset: INTEGER; ,recordBytes: INTEGER; ,j: INTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (holeStart := SELF.holeStart; (offset := SELF.dynStart; (recordBytes := SELF.recordBytes; (FOR j := 0 TO SELF.size - 1 DO ,BEGIN ,IF j = holeStart THEN 0offset := offset + recordBytes * SELF.holeSize; ,DoToRecord(Ptr(TpLONGINT(SELF)^ + offset)); ,offset := offset + recordBytes; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArray.First: Ptr; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (First := SELF.At(1); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TArray.GetAt(i: LONGINT; pRecord: Ptr); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} (XferLeft(Ptr(SELF.AddrMember(i)), pRecord, SELF.recordBytes); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TArray.InsAt(i: LONGINT; pRecord: Ptr); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.EditAt(i, 1); (SELF.PutAt(i, pRecord); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TArray.InsFirst(pRecord: Ptr); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.InsAt(1, pRecord); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TArray.InsLast(pRecord: Ptr); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.InsAt(SELF.size + 1, pRecord); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArray.Last: Ptr; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (Last := SELF.At(SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArray.ManyAt(i, howMany: LONGINT): TArray; (VAR arr: TArray; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (arr := TArray.CREATE(NIL, SELF.Heap, howMany, SELF.recordBytes); (arr.InsManyAt(1, SELF, i, howMany); (ManyAt := arr; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TArray.MemberBytes: INTEGER; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (MemberBytes := SELF.recordBytes; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArray.Pos(after: LONGINT; pRecord: Ptr): LONGINT; (VAR y: Ptr; ,s: TArrayScanner; (FUNCTION EqualRecords(p, q: Ptr; n: INTEGER): BOOLEAN; {n is even} ,VAR i: INTEGER; (BEGIN ,EqualRecords := FALSE; ,i := 0; ,WHILE i < n DO 0BEGIN 0IF TpINTEGER(ORD(p) + i)^ <> TpINTEGER(ORD(q) + i)^ THEN 4EXIT(EqualRecords); 0i := i + 2; 0END; ,EqualRecords := TRUE; (END; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (Pos := after; (s := SELF.ScannerFrom(after, scanForward); (WHILE s.Scan(y) DO ,IF EqualRecords(pRecord, y, SELF.recordBytes) THEN 0BEGIN 0Pos := s.position; 0s.Done; 0END; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TArray.PutAt(i: LONGINT; pRecord: Ptr); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} (XferLeft(pRecord, Ptr(SELF.AddrMember(i)), SELF.recordBytes); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArray.Scanner: TArrayScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (Scanner := TArrayScanner.CREATE(NIL, SELF, 0, scanForward); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArray.ScannerFrom(firstToScan: LONGINT; scanDirection: TScanDirection): TArrayScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (ScannerFrom := TArrayScanner.CREATE(NIL, SELF, firstToScan, scanDirection); ({$IFC fTrace}EP;{$ENDC} $END; {$S sInit1} {$IFC compatibleLists} {For TDynamicArray.Class} BEGIN $cArray := THISCLASS; {$ENDC} END; METHODS OF TString; {$S sResDat} $FUNCTION TString.CREATE(object: TObject; heap: THeap; initialSlack: INTEGER): TString; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF ODD(initialSlack) THEN ,initialSlack := initialSlack + 1; (IF object = NIL THEN ,object := NewDynObject(heap, THISCLASS, initialSlack); (SELF := TString(TCollection.CREATE(object, heap, initialSlack)); ({$IFC fTrace}EP;{$ENDC} $END; ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TString.Debug(numLevels: INTEGER; memberTypeStr: S255); $VAR s: TStringScanner; (ch: CHAR; (str: S8; $BEGIN (SUPERSELF.Debug(numLevels, ''); { this prints other fields of the list } (IF numLevels > 0 THEN ,BEGIN ,WrStr(''''); ,s := SELF.Scanner; ,IF s.position = SELF.holeStart THEN 0WrStr('<=HOLE=>'); ,str := 'x'; ,WHILE s.Scan(ch) DO 0BEGIN 0str[1] := ch; 0WrStr(str); 0IF s.position = SELF.holeStart THEN 4WrStr('<=HOLE=>'); 0END; ,WrStr(''''); ,END; $END; ${$S SgCLAres} ${$ENDC} {$S SgCLAres} $FUNCTION TString.At(i: LONGINT): CHAR; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} (IF i > SELF.holeStart THEN ,i := i + SELF.holeSize; (At := TpPAOC(TpLONGINT(SELF)^ + SELF.dynStart)^[i]; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.DelAll; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.EditAt(1, -SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.DelAt(i: LONGINT); $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.EditAt(i, -1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.DelFirst; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.DelAt(1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.DelLast; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.DelAt(SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.DelManyAt(i, howMany: LONGINT); (VAR j: INTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (IF howMany > 0 THEN ,SELF.EditAt(i, -howMany); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.Draw(i: LONGINT; howMany: INTEGER); (VAR beforeHole: INTEGER; ,pWord1: TpINTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (beforeHole := Min(SELF.holeStart - (i - 1), howMany); (pWord1 := TpINTEGER(TpLONGINT(SELF)^ + SELF.dynStart); (IF beforeHole > 0 THEN ,DrawLText(pWord1, i - 1, beforeHole); (IF beforeHole < howMany THEN ,DrawLText(pWord1, SELF.holeStart + SELF.holeSize - Min(beforeHole, 0), >howMany - Max(beforeHole, 0)); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TString.Width(i: LONGINT; howMany: INTEGER): INTEGER; (VAR beforeHole: INTEGER; ,pWord1: TpINTEGER; ,totalWidth: INTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (beforeHole := Min(SELF.holeStart - (i - 1), howMany); (pWord1 := TpINTEGER(TpLONGINT(SELF)^ + SELF.dynStart); (totalWidth := 0; (IF beforeHole > 0 THEN ,totalWidth := TextWidth(pWord1, i - 1, beforeHole); (IF beforeHole < howMany THEN ,totalWidth := totalWidth + TextWidth(pWord1, SELF.holeStart + SELF.holeSize - Min(beforeHole, 0), RhowMany - Max(beforeHole, 0)); (Width := totalWidth; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.Each(PROCEDURE DoToCharacter(character: CHAR)); (VAR holeStart: INTEGER; ,offset: INTEGER; ,j: INTEGER; ,pChars: TpPAOC; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (holeStart := SELF.holeStart; (pChars := TpPAOC(TpLONGINT(SELF)^ + SELF.dynStart); (offset := 1; (FOR j := 0 TO SELF.size - 1 DO ,BEGIN ,IF j = holeStart THEN 0offset := offset + SELF.holeSize; ,DoToCharacter(pChars^[offset]); ,offset := offset + 1; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $FUNCTION TString.First: CHAR; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (First := SELF.At(1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.InsAt(i: LONGINT; character: CHAR); (VAR pPAOC: TpPAOC; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (SELF.EditAt(i, 1); (pPAOC := TpPAOC(TpLONGINT(SELF)^ + SELF.dynStart); (pPAOC^[i] := character; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.InsFirst(character: CHAR); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.InsAt(1, character); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.InsLast(character: CHAR); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.InsAt(SELF.size + 1, character); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TString.InsPStrAt(i: LONGINT; pStr: TPString); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.EditAt(i, Length(pStr^)); (XferLeft(Ptr(ORD(pStr)+1), Ptr(SELF.AddrMember(i)), Length(pStr^)); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $FUNCTION TString.Last: CHAR; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (Last := SELF.At(SELF.size); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $FUNCTION TString.ManyAt(i, howMany: LONGINT): TString; (VAR str: TString; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (str := TString.CREATE(NIL, SELF.Heap, howMany); (str.InsManyAt(1, SELF, i, howMany); (ManyAt := str; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TString.MemberBytes: INTEGER; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (MemberBytes := 1; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $FUNCTION TString.Pos(after: LONGINT; character: CHAR): LONGINT; (VAR y: CHAR; ,s: TStringScanner; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (Pos := after; (s := SELF.ScannerFrom(after, scanForward); (WHILE s.Scan(y) DO ,IF y = character THEN 0BEGIN 0Pos := s.position; 0s.Done; 0END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.PutAt(i: LONGINT; character: CHAR); (VAR pPAOC: TpPAOC; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} ({$IFC fCheckIndices} (IF fCheckIndices THEN ,SELF.CheckIndex(i); ({$ENDC} (IF i > SELF.holeStart THEN ,i := i + SELF.holeSize; (pPAOC := TpPAOC(TpLONGINT(SELF)^ + SELF.dynStart); (pPAOC^[i] := character; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $FUNCTION TString.Scanner: TStringScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (Scanner := TStringScanner.CREATE(NIL, SELF, 0, scanForward); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $FUNCTION TString.ScannerFrom(firstToScan: LONGINT; scanDirection: TScanDirection): TStringScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (ScannerFrom := TStringScanner.CREATE(NIL, SELF, firstToScan, scanDirection); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.ToPStr(pStr: TPString); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.ToPStrAt(1, SELF.size, pStr); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgCLAres} $PROCEDURE TString.ToPStrAt(i, howMany: LONGINT; pStr: TPString); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} ({$IFC fCheckIndices} (IF howMany > 255 THEN ,ABCBreak('ToPStrAt: Too many characters', howMany); ({$ENDC} (SELF.EditAt(i + howMany, 0); (XferLeft(Ptr(SELF.AddrMember(i)), Ptr(ORD(pStr)+1), howMany); "{$R-} pStr^[0] := CHAR(howMany); {$IFC fRngObject}{$R+}{$ENDC} ({$IFC fTrace}EP;{$ENDC} $END; {$S sInit1} END; {$S SgCLAres} METHODS OF TFile; {$S sResDat} $FUNCTION TFile.CREATE(object: TObject; heap: THeap; itsPath: TFilePath;  0 THEN 0size := 0 ,ELSE 0size := fsInfo.size; ,path := itsPath; ,password := itsPassword; ,scanners := itsScanners; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TFile.Free; {Free frees the scanners as well} $BEGIN ({$IFC fTrace}BP(5);{$ENDC} (SELF.scanners.Free; (SUPERSELF.Free; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgCLAres} ${$IFC fDbgObject} ${$S SgCLAdbg} $FUNCTION TFile.Clone(heap: THeap): TObject; $BEGIN (ABCBreak('A TFile cannot Clone', 0); $END; ${$S SgCLAres} ${$ENDC} ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TFile.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN (SUPERSELF.Fields(Field); (Field('path: STRING[255]'); (Field('password: STRING[32]'); (Field('scanners: TList'); $END; ${$S SgCLAres} ${$ENDC} ${$S SgCLAcld} $PROCEDURE TFile.ChangePassword(VAR error: INTEGER; newPassword: TPassword); (VAR pPath: TPPathname; ,pPass: TPEName; ,pNPass: TPEName; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} ({$IFC LibraryVersion <= 20} (error := -1293; {warning: file is not password protected} ({$ELSEC} (pPath := @SELF.path; (pPass := @SELF.password; (pNPass := @newPassword; (Change_Password(error, pPath^, pPass^, pNPass^); ({$ENDC} (IF error <= 0 THEN ,SELF.password := newPassword; $END; ${$S SgCLAres} ${$S SgCLAcld} $PROCEDURE TFile.Delete(VAR error: INTEGER); (VAR pPath: TPPathname; ,{$IFC LibraryVersion > 20} ,pPass: TPEName; ,{$ENDC} $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (pPath := @SELF.path; ({$IFC LibraryVersion <= 20} (Kill_Object(error, pPath^); ({$ELSEC} (pPass := @SELF.password; (Kill_Secure(error, pPath^, pPass^); ({$ENDC} $END; ${$S SgCLAres} ${$S sResDat} $FUNCTION TFile.Exists(VAR error: INTEGER): BOOLEAN; &{$IFC LibraryVersion <= 20} (VAR refInfo: FS_Info; &{$ELSEC} (VAR refInfo: Q_Info; &{$ENDC} ,pPath: TPPathname; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (pPath := @SELF.path; &{$IFC LibraryVersion <= 20} (Lookup(error, pPath^, refInfo); &{$ELSEC} (Quick_Lookup(error, pPath^, refInfo); &{$ENDC} (Exists := error <= 0; $END; ${$S SgCLAres} {$S SgABCdat} $FUNCTION TFile.MemberBytes: INTEGER; $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (MemberBytes := 1; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgCLAcld} $PROCEDURE TFile.Rename(VAR error: INTEGER; newFileName: TFilePath); ,{the volume of newFileName is ignored} (VAR pPath: TPPathname; ,vol: TFilePath; ,name: TFilePath; ,pEName: TPEname; ,{$IFC LibraryVersion > 20} ,pPass: TPEName; ,{$ENDC} $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (pPath := @SELF.path; (SplitFilePath(newFileName, vol, name); (pEName := @name; ({$IFC LibraryVersion <= 20} (Rename_Entry(error, pPath^, pEName^); ({$ELSEC} (pPass := @SELF.password; (Rename_Secure(error, pPath^, pEName^, pPass^); ({$ENDC} $END; ${$S SgCLAres} ${$S SgCLAcld} $FUNCTION TFile.Scanner: TFileScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (Scanner := SELF.ScannerFrom(0, [fRead, fWrite]); ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgCLAres} {$S sResDat} $FUNCTION TFile.ScannerFrom(firstToScan: LONGINT; manip: TAccesses): TFileScanner; (VAR s: TFileScanner; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (s := TFileScanner.CREATE(NIL, SELF, manip); (s.Seek(firstToScan); (ScannerFrom := s; ({$IFC fTrace}EP;{$ENDC} $END; ${$S SgCLAres} ${$S SgCLAcld} $FUNCTION TFile.VerifyPassword(VAR error: INTEGER; password: TPassword): BOOLEAN; (VAR pPath: TPPathname; ,pPass: TPEName; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} ({$IFC LibraryVersion <= 20} (error := -1293; {warning file is not password protected} (VerifyPassword := TRUE; ({$ELSEC} (pPath := @SELF.path; (pPass := @password; (Verify_Password(error, pPath^, pPass^); (VerifyPassword := error <= 0; ({$ENDC} $END; ${$S SgCLAres} ${$S SgCLAcld} $FUNCTION TFile.WhenModified(VAR error: INTEGER): LONGINT; &{$IFC LibraryVersion <= 20} (VAR refInfo: FS_Info; &{$ELSEC} (VAR refInfo: Q_Info; &{$ENDC} ,pPath: TPPathname; $BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} (pPath := @SELF.path; &{$IFC LibraryVersion <= 20} (Lookup(error, pPath^, refInfo); &{$ELSEC} (Quick_Lookup(error, pPath^, refInfo); &{$ENDC} (IF error <= 0 THEN ,WhenModified := refInfo.DTM (ELSE ,WhenModified := -1; $END; ${$S SgCLAres} {$S sInit1} END; {$S SgCLAres} METHODS OF TScanner; {$S sResDat} $FUNCTION TScanner.CREATE(object: TObject; itsCollection: TCollection; >itsInitialPosition: LONGINT; scanDirection: TScanDirection): TScanner; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF object = NIL THEN ,ABCBreak('TScanner.CREATE must be passed an already-allocated object by a subclass CREATE', 0); (SELF := TScanner(object); (WITH SELF DO ,BEGIN ,collection := itsCollection; &{$H-} position := Max(0, Min(collection.size+1, itsInitialPosition)); {$H+} ,scanDone := FALSE; ,IF scanDirection = scanForward THEN 0BEGIN 0increment := 1; 0atEnd := position >= collection.size; 0END ,ELSE 0BEGIN 0increment := -1; 0atEnd := position <= 1; 0END; ,END; (SELF.Seek(itsInitialPosition); ({$IFC fTrace}EP;{$ENDC} $END; ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TScanner.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN (SUPERSELF.Fields(Field); (Field('collection: TCollection'); (Field('position: LONGINT'); (Field('increment: INTEGER'); (Field('scanDone: BOOLEAN'); (Field('atEnd: BOOLEAN'); $END; ${$S SgCLAres} ${$ENDC} {$S SgABCdat} $FUNCTION TScanner.Advance(PROCEDURE DoToCurrent(anotherMember: BOOLEAN)): BOOLEAN; (VAR moreToScan: BOOLEAN; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (WITH SELF DO ,IF scanDone THEN 0moreToScan := FALSE {don't reassign nextObject} ,ELSE 0BEGIN 0IF atEnd THEN 4moreToScan := FALSE 0ELSE 4BEGIN 4moreToScan := TRUE; 4position := position + increment; 4IF increment > 0 THEN 8atEnd := position >= collection.size 4ELSE 8atEnd := position <= 1; 4END; *{$H-} DoToCurrent(moreToScan); {$H+} 0END; (IF NOT moreToScan THEN ,SELF.Free; (Advance := moreToScan; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TScanner.Allocate(slack: LONGINT); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.collection.StartEdit(slack); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TScanner.Close; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TScanner.Compact; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.collection.StopEdit; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TScanner.Done; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.scanDone := TRUE; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TScanner.Open; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TScanner.Reverse; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.increment := - SELF.increment; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TScanner.Seek(newPosition: LONGINT); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (WITH SELF DO ,BEGIN &{$H-} position := Max(0, Min(collection.size+1, newPosition)); {$H+} ,atEnd := ((position >= collection.size) AND (increment > 0)) OR 5((position <= 1) AND (increment < 0)); ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TScanner.Skip(deltaPos: LONGINT); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.Seek(SELF.position + deltaPos); ({$IFC fTrace}EP;{$ENDC} $END; {$S sInit1} END; {$S SgCLAres} METHODS OF TListScanner; {$S sResDat} $FUNCTION TListScanner.CREATE(object: TObject; itsList: TList; BitsInitialPosition: LONGINT; itsScanDirection: TScanDirection) B: TListScanner; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF object = NIL THEN ,object := NewOrRecycledObject(mainHeap, THISCLASS, availListScanner); (SELF := TListScanner(TScanner.CREATE(object, itsList, itsInitialPosition, itsScanDirection)); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TListScanner.Free; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (RecycleObject(SELF, availListScanner); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TListScanner.Append(object: TObject); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TList(SELF.collection).InsAt(SELF.position + 1, object); (SELF.position := SELF.position + 1; ((***** removed the following line: .InsAt should have set the collection size "{$H-} SELF.collection.size := Max(SELF.collection.size, SELF.position); {$H+} (*****) ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TListScanner.Delete(freeOld: BOOLEAN); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TList(SELF.collection).DelAt(SELF.position, freeOld); (WITH SELF DO ,IF increment > 0 THEN 0position := position - 1; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TListScanner.DeleteRest(freeOld: BOOLEAN); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (WITH SELF DO ,IF increment > 0 THEN '{$H-} TList(collection).DelManyAt(position + 1, collection.size - position, freeOld) ,ELSE 0TList(collection).DelManyAt(1, position - 1, freeOld); {$H+} (WITH SELF DO ,BEGIN ,collection.size := position; ,atEnd := TRUE; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TListScanner.Obtain: TObject; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (Obtain := TList(SELF.collection).At(SELF.position); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TListScanner.Replace(object: TObject; freeOld: BOOLEAN); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TList(SELF.collection).PutAt(SELF.position, object, freeOld); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TListScanner.Scan(VAR nextObject: TObject): BOOLEAN; (VAR actIndex: LONGINT; {an actual index into the list, INCLUDING the hole as part of the list} (* (PROCEDURE AssignListScanVariable(anotherObject: BOOLEAN); (BEGIN ,IF anotherObject THEN 0nextObject := TList(SELF.collection).At(SELF.position) ,ELSE 0nextObject := NIL; (END; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (Scan := SELF.Advance(AssignListScanVariable); ({$IFC fTrace}EP;{$ENDC} $END; *) (VAR moreToScan: BOOLEAN; $BEGIN {speedier version} ({$IFC fTrace}BP(1);{$ENDC} (WITH SELF DO ,IF scanDone THEN 0moreToScan := FALSE {don't reassign nextObject} ,ELSE 0BEGIN 0IF atEnd THEN 4moreToScan := FALSE 0ELSE 4BEGIN 4moreToScan := TRUE; 4position := position + increment; 4IF increment > 0 THEN 8atEnd := position >= collection.size 4ELSE 8atEnd := position <= 1; 4END; 0IF moreToScan THEN 4BEGIN 4IF position > collection.holeStart THEN 8actIndex := position + collection.holeSize 4ELSE 8actIndex := position; 4nextObject := TPObject(TpLONGINT(collection)^ + collection.dynStart K+ (4 * (actIndex - 1)))^; 4END 0ELSE 4nextObject := NIL; 0END; (IF NOT moreToScan THEN ,SELF.Free; (Scan := moreToScan; ({$IFC fTrace}EP;{$ENDC} $END; {$S sInit1} BEGIN $availListScanner := NIL; END; {$S SgCLAres} METHODS OF TArrayScanner; {$S SgABCdat} $FUNCTION TArrayScanner.CREATE(object: TObject; itsArray: TArray; CitsInitialPosition: LONGINT; itsScanDirection: TScanDirection) C: TArrayScanner; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF object = NIL THEN ,object := NewOrRecycledObject(mainHeap, THISCLASS, availArrayScanner); (SELF := TArrayScanner(TScanner.CREATE(object, itsArray, itsInitialPosition, itsScanDirection)); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArrayScanner.Free; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (RecycleObject(SELF, availArrayScanner); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArrayScanner.Append(pRecord: Ptr); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TArray(SELF.collection).InsAt(SELF.position + 1, pRecord); (SELF.position := SELF.position + 1; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArrayScanner.Delete; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TArray(SELF.collection).DelAt(SELF.position); (WITH SELF DO ,IF increment > 0 THEN 0position := position - 1; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArrayScanner.DeleteRest; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (WITH SELF DO ,IF increment > 0 THEN '{$H-} TArray(collection).DelManyAt(position + 1, collection.size - position) ,ELSE 0TArray(collection).DelManyAt(1, position - 1); {$H+} (WITH SELF DO ,BEGIN ,collection.size := position; ,atEnd := TRUE; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArrayScanner.Obtain: Ptr; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (Obtain := TArray(SELF.collection).At(SELF.position); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TArrayScanner.Replace(pRecord: Ptr); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TArray(SELF.collection).PutAt(SELF.position, pRecord); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TArrayScanner.Scan(VAR pNextRecord: Ptr): BOOLEAN; (PROCEDURE AssignArrayScanVariable(anotherRecord: BOOLEAN); (BEGIN ,IF anotherRecord THEN 0pNextRecord := TArray(SELF.collection).At(SELF.position) ,ELSE 0pNextRecord := NIL; (END; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (Scan := SELF.Advance(AssignArrayScanVariable); ({$IFC fTrace}EP;{$ENDC} $END; {$S sInit1} BEGIN $availArrayScanner := NIL; END; {$S SgCLAres} METHODS OF TStringScanner; {$S SgABCdat} $FUNCTION TStringScanner.CREATE(object: TObject; itsString: TString; CitsInitialPosition: LONGINT; itsScanDirection: TScanDirection) C: TStringScanner; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (IF object = NIL THEN ,object := NewOrRecycledObject(mainHeap, THISCLASS, availStringScanner); (SELF := TStringScanner(TScanner.CREATE(object, itsString, itsInitialPosition, itsScanDirection)); (SELF.actual := 0; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.Free; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (RecycleObject(SELF, availStringScanner); ({$IFC fTrace}EP;{$ENDC} $END; ${$IFC fDebugMethods} ${$S SgCLAdbg} $PROCEDURE TStringScanner.Fields(PROCEDURE Field(nameAndType: S255)); $BEGIN (SUPERSELF.Fields(Field); (Field('actual: LONGINT'); $END; ${$S SgCLAres} ${$ENDC} {$S SgABCdat} $PROCEDURE TStringScanner.Append(character: CHAR); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TString(SELF.collection).InsAt(SELF.position + 1, character); (SELF.position := SELF.position + 1; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.Delete; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TString(SELF.collection).DelAt(SELF.position); (WITH SELF DO ,IF increment > 0 THEN 0position := position - 1; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.DeleteRest; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (WITH SELF DO ,IF increment > 0 THEN '{$H-} TString(collection).DelManyAt(position + 1, collection.size - position) ,ELSE 0TString(collection).DelManyAt(1, position - 1); {$H+} (WITH SELF DO ,BEGIN ,collection.size := position; ,atEnd := TRUE; ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TStringScanner.Obtain: CHAR; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (Obtain := TString(SELF.collection).At(SELF.position); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.Replace(character: CHAR); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (TString(SELF.collection).PutAt(SELF.position, character); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TStringScanner.Scan(VAR nextChar: CHAR): BOOLEAN; (PROCEDURE AssignStringScanVariable(anotherChar: BOOLEAN); (BEGIN ,IF anotherChar THEN 0nextChar := TString(SELF.collection).At(SELF.position) ,ELSE 0nextChar := CHAR(0); (END; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (Scan := SELF.Advance(AssignStringScanVariable); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TStringScanner.ReadArray(heap: THeap; bytesPerRecord: INTEGER): TArray; (VAR a: TArray; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (a := TArray.CREATE(NIL, heap, 0, bytesPerRecord); (XferContiguous(xRead, a, 2, SELF); (ReadArray := a; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $FUNCTION TStringScanner.ReadNumber(numBytes: SizeOfNumber): LONGINT; (VAR v: ,RECORD ,CASE INTEGER OF 01: (signExtension, short: INTEGER); 02: (long: LONGINT); 0END; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (v.long := 0; (SELF.XferSequential(xRead, Ptr(ORD(@v)+4-numBytes), numBytes); (IF numBytes=2 THEN ,IF v.short < 0 THEN 0v.signExtension := -1; (ReadNumber := v.long; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TStringScanner.ReadObject(heap: THeap): TObject; (VAR class: TClass; ,object: TObject; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (class := TClass(SELF.ReadNumber(4)); (object := NewObject(heap, class); (object.Read(SELF); (ReadObject := object; ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.WriteArray(a: TArray); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (XferContiguous(xWrite, a, 2, SELF); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.WriteNumber(value: LONGINT; numBytes: SizeOfNumber); $BEGIN ({$IFC fTrace}BP(3);{$ENDC} (SELF.XferSequential(xWrite, Ptr(ORD(@value)+4-numBytes), numBytes); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.WriteObject(object: TObject); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.WriteNumber(ORD(object.Class), 4); (object.Write(SELF); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.XferContiguous(whichWay: xReadWrite; collection: TCollection); (VAR numToXfer: INTEGER; $BEGIN {Transfer the size (as an INTEGER), class-specific fields, and members. -Do not recur on the members. -Do not transfer the class, the dynStart (=SizeOfClass), or the hole info (=zero). -When reading, append the elements that are read. -This only works for contiguous objects up to 32K members in size.} ({$IFC fTrace}BP(3);{$ENDC} (XferContiguous(whichWay, collection, 0, SELF); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TStringScanner.XferFields(whichWay: xReadWrite; object: TObject); $BEGIN {Transfers the bits of a TObject, excluding the class pointer and any dynamic part} ({$IFC fTrace}BP(3);{$ENDC} (SELF.XferSequential(whichWay,  0 THEN ,Allocate(newErr, SELF.refnum, TRUE, pages, actual); (IF (newErr <= 0) AND (actual < pages) THEN ,Allocate(newErr, SELF.refnum, FALSE, pages - actual, actual); "{$H-} LatestError(newErr, SELF.error); {$H+} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TFileScanner.Close; (VAR newErr: INTEGER; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (Close_Object(newErr, SELF.refnum); "{$H-} LatestError(newErr, SELF.error); {$H+} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TFileScanner.Compact; (VAR newErr: INTEGER; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (Compact(newErr, SELF.refnum); "{$H-} LatestError(newErr, SELF.error); {$H+} ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TFileScanner.Delete; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.Skip(-1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TFileScanner.DeleteRest; (VAR newErr: INTEGER; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (Truncate(newErr, SELF.refnum); "{$H-} LatestError(newErr, SELF.error); {$H+} (WITH SELF DO ,BEGIN ,collection.size := position; ,atEnd := TRUE; ,END; ({$IFC fTrace}EP;{$ENDC} $END; $PROCEDURE TFileScanner.Append(character: CHAR); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.XferSequential(xWrite, Ptr(ORD(@character)+1), 1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TFileScanner.Obtain: CHAR; (VAR character: CHAR; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (SELF.XferRandom(xRead, Ptr(ORD(@character) + 1), 1, fRelative, -1); (Obtain := character; ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} {$IFC LibraryVersion <= 20} $PROCEDURE TFileScanner.Open; (VAR pPath: TPPathName; ,itsFile: TFile; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (itsFile := TFile(SELF.collection); (pPath := @itsFile.path; "{$H-} Open(SELF.error, pPath^, SELF.refnum, MSet(SELF.accesses)); {$H+} (IF (SELF.error = 948) and (fWrite in SELF.accesses) then ,BEGIN "{$H-} Make_File(SELF.error, pPath^, 0); ,IF SELF.error <= 0 then 0Open(SELF.error, pPath^, SELF.refnum, MSet(SELF.accesses)); {$H+} ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$ELSEC} $PROCEDURE TFileScanner.Open; (VAR pPath: TPPathName; ,itsFile: TFile; ,pPass: TPEName; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (itsFile := TFile(SELF.collection); (pPath := @itsFile.path; (pPass := @itsFile.password; "{$H-} Open_Secure(SELF.error, pPath^, SELF.refnum, MSet(SELF.accesses), pPass^); {$H+} (IF (SELF.error = 948) and (fWrite in SELF.accesses) then ,BEGIN "{$H-} Make_Secure(SELF.error, pPath^, pPass^); ,IF SELF.error <= 0 then 0Open_Secure(SELF.error, pPath^, SELF.refnum, MSet(SELF.accesses), pPass^); {$H+} ,END; ({$IFC fTrace}EP;{$ENDC} $END; {$ENDC} {$S SgABCdat} $PROCEDURE TFileScanner.Replace(character: CHAR); $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.XferRandom(xWrite, Ptr(ORD(@character) + 1), 1, fRelative, -1); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $FUNCTION TFileScanner.Scan(VAR nextChar: CHAR): BOOLEAN; (PROCEDURE AssignFileScanVariable(anotherChar: BOOLEAN); (BEGIN ,IF anotherChar THEN 0SELF.XferSequential(xRead, Ptr(ORD(@nextChar) + 1), 1) ,ELSE 0nextChar := CHAR(0); (END; $BEGIN ({$IFC fTrace}BP(1);{$ENDC} (Scan := SELF.Advance(AssignFileScanVariable); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TFileScanner.Seek(newPosition: LONGINT); (VAR dummy: INTEGER; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.XferRandom(xRead, @dummy, 0, fAbsolute, newPosition); ({$IFC fTrace}EP;{$ENDC} $END; {$S SgABCdat} $PROCEDURE TFileScanner.Skip(deltaPos: LONGINT); (VAR dummy: INTEGER; $BEGIN ({$IFC fTrace}BP(2);{$ENDC} (SELF.XferRandom(xRead, @dummy, 0, fRelative, deltaPos); ({$IFC fTrace}EP;{$ENDC} $END; {$S sResDat} $PROCEDURE TFileScanner.XferRandom(whichWay: xReadWrite; pFirst: Ptr; numBytes: LONGINT; Hmode: TIOMode; offset: LONGINT); (VAR newErr: INTEGER; ,osMode: IOMode; ,fsInfo: FS_Info; ,sched_err: INTEGER; $BEGIN ({$IFC fTrace}BP(4);{$ENDC} (osMode := IOMode(mode); (WITH SELF DO {$H-} ,IF error <= 0 THEN 0BEGIN 0CASE whichWay OF 4xRead: BEGIN  addr) AND (addr > ORD(@addr)); END; FUNCTION ValidSTP(stAddr: LONGINT): BOOLEAN; $VAR count: INTEGER; (hiWord: INTEGER; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $IF ValidGlobalAddress(stAddr) AND ValidGlobalAddress(stAddr+3) AND NOT ODD(stAddr) THEN (BEGIN (count := 100; {Prevent infinite loops} (hiWord := 0; (WHILE ValidGlobalAddress(stAddr-4) AND ValidGlobalAddress(stAddr-1) AND NOT ODD(stAddr) AND .(count > 0) DO ,BEGIN &{$R-} hiWord := TpINTEGER(stAddr-4)^; ,stAddr := TpLONGINT(stAddr-4)^; {$IFC fRngObject}{$R+}{$ENDC} ,count := count - 1; ,END; (ValidSTP := hiWord = -1; (END $ELSE (ValidSTP := FALSE; END; FUNCTION ValidObject(hndl: Handle): BOOLEAN; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $ValidObject := FALSE; $IF (hndl <> NIL) AND (cObject <> NIL) THEN {Not NIL; and we have made a heap} (IF ValidDataAddress(ORD(hndl)) THEN {Handle reasonable} ,IF ValidDataAddress(ORD(hndl^)) THEN {Master ptr reasonable} 0IF ValidSTP(ORD(ClassPtr(hndl))) THEN {Reasonable stp} 4ValidObject := TRUE; {Go for it} END; { ====================================== GARBAGE COLLECTOR ====================================== } {$S SgCLAcld} PROCEDURE MarkHeap{(heap: THeap; mpAddress: LONGINT)}; { MarkHeap accepts two parameters: (1) a pointer (heap) to the document heap and (2) the address, } { (mpAddress) of a "root" master pointer from which all other accessible objects on heap can be reached. } { MarkHeap marks all objects that are "in-use" by marking the root object, all objects that the root object } { has a handle on, all objects that those objects have handles on, etc. Marking is accomplished by setting } { the high order bit (bit 31) of the master pointer that points to the object which is to be marked. } { Although MarkHeap operates depth-first, it is NOT recursive. Thus, it can mark long chains of objects } { without causing stack expansion. If w.e => x, x.f => y and y.g => z, then while y is being scanned, } { x.f => w.e. Thus, when y returns to x for further marking starting after f, x can know where it will } { have to return to when its scan is complete. The comments below assume that the scan has reached y.g } $TYPE TOffsets = RECORD ,objectOffset: INTEGER; { x - mpFirst: where the object's master ptr is in the heap } ,fieldOffset: INTEGER; { @x.f - @x^^: where the field is in the object } (END; $VAR hz: THz; { heap as a UnitHz type } (mpFirst: LONGINT; { The address of the first master pointer in the heap } (mpLast: LONGINT; { The address of the last master pointer in the heap } (blockPtr: TBk; { A pointer to the first (size) word of the storage block of y} (sizeInWords: INTEGER; { The size found there } (firstFieldAddress: LONGINT; { @y^^, the address of y's first data field (usually a method-table ptr)} (lastFieldAddress: LONGINT; { The upper limit of the fieldAddress loop--the last 4-byte field of y } (mpPtr: TpLONGINT; { A handle as a pointer to a LONGINT (the master pointer) } (mp: LONGINT; { The master pointer value, z^, i.e., the object data address } (fieldOffset: INTEGER; { @y.g - @y^^ } (fieldAddress: LONGINT; { The address of the field y.g, which may or may not be a handle. HIt increases by twos because a handle can start on any even address} (previous: TOffsets; { Two offsets representing @x.f: x - mpFirst & @x.f - @x^^. FA pointer to x.f will be stashed there while z is scanned, Fin the form of two offsets (see "previous") } (hndlAddress: LONGINT; { The handle z found in or to be replaced in y.g } (goodHandleFound: BOOLEAN; { TRUE if a handle to an unmarked object was found in the fields of Fthe present object; otherwise, FALSE. } BEGIN { MarkHeap } ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $hz := THz(heap); { A pointer to the heap } $mpFirst := ORD(@hz^.argpPool); { The address of the first master pointer } $mpLast := mpFirst + (4 * (hz^.ipPoolMac - 1)); { The address of the last master pointer } $fieldOffset := 0; { The offset from firstFieldAddress of the first field to Mconsider } $goodHandleFound := TRUE; $previous.objectOffset := 1; { An illegal value to flag the end of the entire marking operation } {$IFC LibraryVersion > 20} ${Mark the hrgpnob field of the Hz} $mpPtr := TpLONGINT(hz^.hrgpnob); $mpPtr^ := mpPtr^ + $80000000; ${Mark the hScramble field of the Hz} $mpPtr := TpLONGINT(hz^.hScramble); $mpPtr^ := mpPtr^ + $80000000; {$ENDC} $mpPtr := TpLONGINT(mpAddress); { The handle of y } $mpPtr^ := mpPtr^ + $80000000; { Mark the master pointer which points to the present object } $REPEAT { Loop through all accessible objects} (firstFieldAddress := mpPtr^; { The address of the first field of y } (blockPtr := TBk(firstFieldAddress - 4); { The size word of the header of the object } (sizeInWords := blockPtr^.hdr.cw; { The size of the object, in words } (lastFieldAddress := firstFieldAddress + sizeInWords + sizeInWords - 6; { The last 4-byte field } (fieldAddress := firstFieldAddress + fieldOffset; { Where to start or resume the scan of y } (IF (NOT goodHandleFound) THEN ,BEGIN { We have just returned to y after scanning z } ,previous := TOffsets(TpLONGINT(fieldAddress)^);{ Restore previous offsets from field y.g } ,TpLONGINT(fieldAddress)^ := hndlAddress; { Restore the original contents of y.g, which ]was z } ,fieldAddress := fieldAddress + 2; { Advance to the next potential handle } ,fieldOffset := fieldOffset + 2; ,END; (goodHandleFound := FALSE; { No handle to an unmarked object has been found yet } +{ Scan the fields of the present object in search of a handle to an unmarked object } (WHILE ((fieldAddress <= lastFieldAddress) AND (NOT goodHandleFound)) DO ,BEGIN ,hndlAddress := TpLONGINT(fieldAddress)^; { Get what may be the address of a master pointer } ,IF (hndlAddress >= mpFirst) THEN 0IF (hndlAddress <= mpLast) THEN 4IF (LIntAndLInt(hndlAddress - mpFirst, 3) = 0) THEN 8BEGIN E{ if the address of the alleged master pointer lies between the } E{ addresses of the first and last master pointers, inclusive, and if } E{ the address of the alleged master pointer lies a multiple of 4 bytes } E{ (the length of a master pointer) from the address of the first } E{ master pointer, then the given address is the address of a master } E{ pointer (i.e. it is a valid handle).} 8mpPtr := TpLONGINT(hndlAddress); { Get a handle on the validated master pointer } 8mp := ORD(mpPtr^); 8IF (mp >= 0) THEN { unmarked } = mpFirst) AND (mp <= mpLast)) OR (mp = 1)) THEN @BEGIN { not on the free list; it must be in the heap proper } @goodHandleFound := TRUE; { A handle to an unmarked object has been found } @TOffsets(TpLONGINT(fieldAddress)^) := previous; { Save offsets in the rfield y.g } @previous.fieldOffset := fieldOffset; { y's current offsets are z's hprevious ones } @previous.objectOffset := mpAddress - mpFirst; @mpAddress := hndlAddress; { The handle of z } @END; 8END; ,fieldAddress := fieldAddress + 2; { Advance to the next potential handle } ,fieldOffset := fieldOffset + 2; { Set offset to next potential handle } ,END; (IF goodHandleFound THEN { y.g contained the handle of z } ,BEGIN ,mpPtr^ := mpPtr^ + $80000000; { Mark the master pointer of z } ,fieldOffset := 0; { Prepare to scan z } ,END (ELSE ,BEGIN { Finished examining the fields of y. Prepare to return to x.f } ,hndlAddress := mpAddress; { The handle y will be put back into x.f where it belongs } ,fieldOffset := previous.fieldOffset; { Restore fieldOffset to @x.f - @x^^ } ,mpAddress := mpFirst + previous.objectOffset; { Restore mpAddress to x } ,mpPtr := TpLONGINT(mpAddress); { The handle of y } ,END; &UNTIL previous.objectOffset = 1; { until all the fields of the original object have been examined } END; { MarkHeap } PROCEDURE SweepHeap{(heap: THeap; report: BOOLEAN)}; { This procedure sweeps through all existing objects on the document heap specified by the handle heap. } { If the parameter report has the value TRUE, then the classes of all unmarked objects are displayed on the } { alternate screen; otherwise, if report is FALSE, the unmarked objects are quietly freed-up. } $VAR tempPtr: TpLONGINT; { a temporary pointer used either to carry out simple indirection or to mark a } 9{ master pointer } $PROCEDURE CollectGarbage (obj: TObject); ${ This procedure accepts a handle, obj, to an object and frees or reports that object (depending on the } ${ value of SweepHeap's parameter, report) if its master pointer is not marked. If, the } ${ object's master pointer is marked, then this procedure unmarks the object's master pointer but } ${ otherwise leaves the object alone. } (VAR mpAddress: LONGINT; { the address of the master pointer specified by the handle obj } ,clsName: TClassName; { the name of that class } ,hexOrd: S8; { the handle of the object, as a hex string } $BEGIN { CollectGarbage } (mpAddress := ORD(obj); (tempPtr := TpLONGINT(obj); { get a handle of the right type on the given object OBJ } (IF (tempPtr^ < 0) THEN ,BEGIN { if the given object OBJ is marked } ,tempPtr := TpLONGINT(mpAddress); { Unmark the master pointer that points to the present object } ,tempPtr^ := tempPtr^ - $80000000; { Note: 2^31 = $80000000 } ,END (ELSE IF report THEN ,BEGIN ,WriteLn; ,IF ValidObject(Handle(obj)) THEN 0CpToCn(TPSliceTable(ClassPtr(Handle(obj))), TS8(clsName)) ,ELSE 0clsName := '????????'; ,LIntToHex(ORD(obj), @hexOrd); ,Write (CHR(7), 'Found garbage object $', hexOrd, ' of class ', clsName); { Report the garbage } ,END (ELSE ,FreeH(THz(heap), TH(obj)); { It is unmarked, i.e., garbage. Free it. } $END; { CollectGarbage } BEGIN { SweepHeap } ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $EachObject(heap, CollectGarbage); END; { SweepHeap } { ====================================== ABCBREAK ====================================== } {$IFC fDbgObject} PROCEDURE TallyZero; FORWARD; {$ENDC} {$S sError} PROCEDURE ABCBreak{(s: S255; errCode: LONGINT)}; $VAR asHex: S8; BEGIN ${$IFC fDbgObject} $WriteLn; $Write(CHR(7), s); {Beep} $IF errCode <> 0 THEN (BEGIN (LIntToHex(errCode, @asHex); (Write(': ', errCode:1, ' = $', asHex); (END; $WriteLn; ${Turn off all tracing, tallying, etc.} $tallyingCalls := FALSE; $TallyZero; $fTraceEnabled := FALSE; $defTraceCount := 0; $traceCount := defTraceCount; $returnToMain := TRUE; $EntDebugger(' ', 'Error caused ABCBreak call'); ${$ELSEC} $HALT; ${$ENDC} END; {$S SgCLAcld} { ====================================== $D DECODING ====================================== } {$IFC fTrace OR fDebugMethods} {$S SgCLAdbg} FUNCTION GetDollarD(pFrame: TppINTEGER; 4VAR nameOfClass: TClassName; VAR nameOfMethod: S8; VAR nextPC: LONGINT): BOOLEAN; $LABEL 1; $VAR pname: TPByte; (pPC: TppINTEGER; (pc: TpINTEGER; (startOfSegment: TpLONGINT; (endOfSegment: TpINTEGER; (pcl: TpLONGINT; (fBothClassAndProc: BOOLEAN; $PROCEDURE SwapIn(valueString: S8); (BEGIN (END; $PROCEDURE CopyName(VAR anyName: S8); (VAR j: INTEGER; $BEGIN (anyName := '12345678'; (FOR j := 1 TO 8 DO ,BEGIN ,anyName[j] := CHR(Wand(pname^, 127)); ,pname := TPByte(ORD(pname)+1); ,END; $END; $PROCEDURE AdvancePC; $BEGIN (IF ORD(pc) >= ORD(endOfSegment) THEN ,GOTO 1; (pc := TpInteger(ORD(pc)+2); $END; BEGIN ({$IFC fMaxTrace}BP(1);{$ENDC} ({$IFC fMaxTrace}EP;{$ENDC} $pPC := TppINTEGER(ORD(pFrame) + 4); $pc := pPC^; $nameOfClass := ''; $nameOfMethod := ''; $nextPC := 0; $GetDollarD := FALSE; $IF ORD(pc) <> 0 THEN (BEGIN ${$R-} SwapIn(TPS8(pc)^); {$IFC fRngObject} {$R+} {$ENDC} {Be sure the code is swapped in} 'startOfSegment := TpLONGINT(LIntAndLint(LONGINT(PC), $FFFE0000)); 'endOfSegment := TpINTEGER(LONGINT(startOfSegment) + LIntAndLint(startOfSegment^, $00FFFFFF) {length} ); ,{We add the -1 to the following tests so that the things we are searching for don't 0appear in the body of the procedure.} (WHILE (pc^-1) <> ($4E5E-1) DO {search for UNLK A6} ,IF ORD(pc) >= ORD(endOfSegment) THEN 0GOTO 1 ,ELSE 0pc := TpINTEGER(ORD(pc)+2); (WHILE ((pc^-1) <> ($4E75-1)) AND .((pc^-1) <> ($4ED0-1)) DO {search for RTS or JMP (A0)} ,IF ORD(pc) >= ORD(endOfSegment) THEN 0GOTO 1 ,ELSE 0pc := TpINTEGER(ORD(pc)+2); (nextPC := ORD(pc); (GetDollarD := TRUE; (pname := TPByte(ORD(pc)+3); (fBothClassAndProc := pname^ < 0; (pname := TPByte(ORD(pname)-1); (CopyName(nameOfMethod); (IF fBothClassAndProc THEN ,CopyName(S8(nameOfClass)) (ELSE ,nameOfClass := ''; (END; 1: END; {$ENDC} { ==================================== CALL TALLY ==================================== } {$IFC fTrace} {$S SgCLAini} { *** NB *** Is this Sg necessary? } PROCEDURE TallyStart; $VAR timeNow: LONGINT; (i: INTEGER; (arrSize: INTEGER; (elapsed: LONGINT; (*^*) BEGIN $IF tallies = NIL THEN (BEGIN ({array size must be <= maxTallies; imposed by declaration of tallies global variable.} (arrSize := Min(numMethods, maxTallies); (tallies := THTallies(TArray.CREATE(NIL, mainHeap, arrSize, SIZEOF(TTally))); (TArray(tallies).InsNullsAt(1, arrSize); (elapsed := 0;(*^*) (END $ELSE {continuing} (elapsed := stopTime - startTime;(*^*) $timeNow := MicroTimer; $startTime := timeNow - elapsed; (*^*) $FOR i := 0 TO tabLevel DO {BP's already passed} (traceTimes[i] := timeNow; (*^*) $stopTime := timeNow; $tallyingCalls := TRUE; END; PROCEDURE TallyZero; BEGIN $IF tallies <> NIL THEN (BEGIN (Free(TArray(tallies)); (tallies := NIL; (END; END; FUNCTION TallySlot(pc: LONGINT): INTEGER; $FUNCTION ComparePC(hashIndex: INTEGER): THashCompare; (VAR myPC: LONGINT; $BEGIN (myPC := tallies^^.recs[hashIndex].epPC; (IF myPC = 0 THEN ,ComparePC := cHole (ELSE (IF myPC = pc THEN ,ComparePC := cMatch (ELSE ,ComparePC := cMismatch; $END; BEGIN $TallySlot := LookupInHashArray(tallies^^.header.size, pc, FALSE, ComparePC); END; PROCEDURE Tally(pc, micSecs: LONGINT); $VAR slot: INTEGER; (segNum: INTEGER; (pPC: TpByte; BEGIN $pPC := TPByte(@pc); $pPC^ := 0; {occasionally, a return addr hibyte is nonzero! no one knows why...} $slot := TallySlot(pc); $WITH tallies^^.recs[ABS(slot)] DO (IF slot > 0 THEN ,BEGIN ,count := count + 1; ,microseconds := microseconds + micsecs; ,END (ELSE (IF slot < 0 THEN ,BEGIN ,segNum := TpINTEGER(pPC)^ DIV 2; ,IF segNum = 0 THEN 0ABCBreak('Impossible Tally PC', pc) ,ELSE 0BEGIN 0epPC := pc; 0count:= 1; 0microseconds := micSecs; 0END; ,END (ELSE ,BEGIN ,ABCBreak('Tally table full--more non-method procedures had EP''s than expected', 4tallies^^.header.size); ,tallyingCalls := FALSE; ,END; END; PROCEDURE TallyReport; $VAR totalCalls: LONGINT; (totalTime: LONGINT; (callees: INTEGER; (slot: INTEGER; (calls: INTEGER; (micSecs: LONGINT; (roundoff: LONGINT; (i: INTEGER; (j: INTEGER; (sortKeys: THIdxArray; (segCount: ARRAY [0..127] OF LONGINT; (segTime: ARRAY [0..127] OF LONGINT; (pc: LONGINT; (sortBy: INTEGER; (swapem: BOOLEAN; (sloti: INTEGER; (slotj: INTEGER; (pctg: INTEGER; (elapsed: LONGINT; (segName: S8; (segNum: INTEGER; (cState: TConvResult; (wantCalled: BOOLEAN; (clsName: TClassName; (mthName: S8; (nextPC: LONGINT; (inStr: S255; (hexPC: S8; (PROCEDURE ReadSegNames; ,CONST 0bSegTable = $9A; 0bEOFMark = $00; 0bModuleName = $80; 0bCodeBlock = $85; 0modNameSkip = 8; {# bytes to skip in module name block, to get segment name} 0allBlanks = ' '; {8 blanks} 0blankSeg = 'BLANKSEG'; ,TYPE 0SegTblEntry = RECORD 4SegName: PACKED ARRAY[1..8] OF CHAR; 4SegNumber: INTEGER; 4Version1: LONGINT; 4Version2: LONGINT; 4END; ,VAR prcsInfo: ProcInfoRec; 0error: INTEGER; 0aFile: TFile; 0scanner: TFileScanner; 0blkType: LONGINT; 0blkSize: LONGINT; 0nSegments: LONGINT; 0segblk: SegTblEntry; 0addr: LONGINT; 0i: INTEGER; (BEGIN ,Info_Process(error, My_id, prcsInfo); ,IF error <= 0 THEN 0BEGIN 0segName := allBlanks; 0segNames := TArray.CREATE(NIL, mainHeap, 127, SIZEOF(S8)); 0segNames.InsNullsAt(1, 127); 0aFile := TFile.CREATE(NIL, mainHeap, prcsInfo.progPathName, ''); 0scanner := TFileScanner.CREATE(NIL, aFile, [fRead]); 0WriteLn('Reading segment numbers and names from ', prcsInfo.progPathName); 0WriteLn; 0REPEAT 4blkType := scanner.ReadNumber(1); 4blkSize := scanner.ReadNumber(3) - 4; 4CASE blkType OF 8bSegTable:  0 DO 4IF (prcsInfo.progPathName[i] = '}') OR (prcsInfo.progPathName[i] = '.') THEN 8GOTO 1 4ELSE 8i := i - 1; 1: 0IF i > 0 THEN 4filename := Concat(Copy(prcsInfo.progPathName, 1, i), 'SegNames.Text'); 0Reset(segNameFile, fileName); 0i := IoResult; 0IF i > 0 THEN 4WriteLn('Unable to open ', fileName, ' because of error number ', i:1) 0ELSE 4BEGIN 4WriteLn('Reading segment numbers and names from ', fileName); 4WriteLn; 4segNames := TArray.CREATE(NIL, mainHeap, 127, SIZEOF(S8)); 4segNames.InsNullsAt(1, 127); 4WHILE (i = 0) AND NOT Eof(segNameFile) DO 8BEGIN 8segNum := 0; 8ReadLn(segNameFile, segNum, inStr); 8i := IoResult; 8IF (i <= 0) AND (1 <= segNum) AND (segNum <= 127) THEN  0 THEN  0 THEN 8IF pc1 < epPC THEN  0 THEN 0BEGIN 0totalCalls := totalCalls + count; 0callees := callees + 1; 0segNum := TpINTEGER(@epPC)^ DIV 2; 0segCount[segNum] := segCount[segNum] + count; 0segTime[segNum] := segTime[segNum] + microseconds; 0END; $IF totalCalls = 0 THEN (WriteLn('All tallies are zero.') $ELSE (BEGIN {totalCalls > 0} (roundOff := totalTime DIV 2; (WriteLn(callees:1, ' methods were called a total of ', totalCalls:1, ' times.'); (WriteLn; (IF segNames = NIL THEN ,ReadSegNames; (WriteLn(' SEGMENT USAGE'); (WriteLn; (WriteLn('No. of calls % of time Segment SegSize Seg#'); (WriteLn('------------ --------- ------- ------- ----'); (WriteLn; (FOR segNum := 1 TO 127 DO ,IF segCount[segNum] > 0 THEN 0BEGIN 0IF segNames = NIL THEN 4segName := '????????' 0ELSE 4segName := TPString(segNames.At(segNum))^; 4{Be sure the code is swapped in, before getting the size of the segment} *{$R-} SwapIn(TpS8($20000 * segNum)^); {$IFC fRngObject} {$R+} {$ENDC} 0WriteLn(segCount[segNum]:8, ' ....... ', 8(LONGINT(segTime[segNum]) * 100 + roundOff) DIV totalTime:3, '% ... ', 8segName, 8LIntAndLint(TpLONGINT($20000 * segNum)^, $00FFFFFF):8, 8segNum:7); 0END; (REPEAT ,WriteLn; ,WriteLn; ,Write('Report procedure executions sorted by (C = # Calls; T = % of Time; S = Segment)? '); ,ReadLn(inStr); ,StrUpperCased(@inStr); ,TrimBlanks(@inStr); ,IF inStr = '' THEN 0sortBy := -1 ,ELSE ,IF inStr[1] = 'C' THEN 0sortBy := 1 ,ELSE ,IF inStr[1] = 'T' THEN 0sortBy := 2 ,ELSE ,IF inStr[1] = 'S' THEN 0sortBy := 3 ,ELSE 0sortBy := 0; ,IF sortBy > 0 THEN 0BEGIN {sortBy > 0} 0sortKeys := MakeIdxArray(callees, FALSE); 0{$R-} 0WITH sortKeys^^, tallies^^ DO 4BEGIN {with} 4i := 0; 4FOR slot := 1 TO header.size DO 8IF recs[slot].count > 0 THEN  recs[slotj].count; @2: swapem := recs[sloti].microseconds > recs[slotj].microseconds; @3: swapem := TpINTEGER(@recs[sloti].epPC)^ DIV 2 > MTpINTEGER(@recs[slotj].epPC)^ DIV 2; @END;  segNum THEN {if different from segment of previous line} @WriteLn; {then leave a blank line} 4segNum := j; 4Write(calls:8, ' ....... '); 4pctg := (LONGINT(micSecs) * 100 + roundOff) DIV totalTime; 4IF pctg = 0 THEN 8Write(' ') 4ELSE 8Write(pctg:3, '%'); 4Write(' ... '); 4IF GetDollarD(TppINTEGER(ORD(@pc)-4), clsName, mthName, nextPC) THEN; 4WriteName; 4LIntToHex(pc, @hexPC); 4Write(' ', hexPC); 4IF segNames = NIL THEN 8Write(segNum:10) 4ELSE 8BEGIN 8segName := TPString(segNames.At(segNum))^; 8IF segName = '????????' THEN  0} ,UNTIL sortBy < 0; (IF segNames <> NIL THEN {segNames will be non-NIL except in case of an IO error} ,REPEAT 0Write('List procedures that were and weren''t called in segment [name or number]? '); 0ReadLn(inStr); 0TrimBlanks(@inStr); 0StrUpperCased(@inStr); 0IF inStr = '?' THEN 4BEGIN 4WriteLn('List of all segments used by application:'); 4i := 0; {# output so far} 4FOR segnum := 1 TO 127 DO 8BEGIN 8segname := TPString(segNames.At(segnum))^; 8IF segname <> '' THEN  '' THEN 4BEGIN 4StrToInt(@inStr, segNum, cState); 4IF cState <> cvValid THEN 8BEGIN 8segNum := 0; 8FOR i := 1 TO 127 DO =1) AND (segNum<=127) THEN{make sure the segment number is OK} 8BEGIN 8segName := TPString(segNames.At(segNum))^; 8IF segName = '' THEN  NIL THEN @Write(': ', TPString(segNames.At(segNum))^);  0) = wantCalled THEN DBEGIN DWriteName; DWrite(' '); Dj := j + 1; DIF j = 4 THEN HBEGIN Hj := 0; HWriteLn; HEND; DEND; @pc := nextPC; @IF CheckKeyPress('Segment Listing') THEN Dpc := 0; @END;  ''} 0UNTIL inStr = ''; (END; {totalCalls > 0} $WriteLn; END; {$ENDC} { ============================================================================================= } {$S SgCLAdbg} {for rest of file} { ====================================== "FIELDS" METHODS ====================================== } {$IFC fDebugMethods} PROCEDURE ParseDecl(inStr: S255; 0PROCEDURE FoundName(token: S8); 0PROCEDURE FoundType(token: S8; typeCode: TTypeCode; numBytes: INTEGER; 1{for arrays only:} lowerBound, upperBound: INTEGER; memberTypeStr: S255); 0PROCEDURE FoundUnexpected(token, wanted: S8)); $VAR p: INTEGER; (token: S8; (eoi: INTEGER; (alpha: BOOLEAN; (start: INTEGER; {where the last token started} (inhibited: BOOLEAN; $PROCEDURE NextToken; $BEGIN &{Skip leading blanks} (WHILE (p <= eoi) AND (inStr[p] <= ' ') DO ,p := p + 1; (start := p; (IF p > eoi THEN ,token := '' (ELSE ,BEGIN ,WHILE (p <= eoi) AND (inStr[p] IN ['-', '0'..'9', 'A'..'Z', 'a'..'z']) DO {Form a word or number} 0p := p + 1; ,alpha := p > start; ,IF NOT alpha THEN {A single non-alphanumeric nonblank character} 0p := p + 1; ,token := Copy(inStr, start, CMin(8, p - start)); ,END; $END; $PROCEDURE Expect(str: S8); $BEGIN (StrUpperCased(@token); (IF token <> str THEN ,FoundUnexpected(token, str); (NextToken; $END; $FUNCTION ParseNumber: LONGINT; (VAR k: LONGINT; ,cState: TConvResult; $BEGIN (StrToLint(@token, k, cState); (IF cState = cvValid THEN ,ParseNumber := k (ELSE ,FoundUnexpected(token, 'a number'); (NextToken; $END; $PROCEDURE ParseField; FORWARD; $PROCEDURE ParseType(inhibit: BOOLEAN); (VAR typeName: S8; ,upName: S8; ,alphaName: BOOLEAN; ,word: S8; ,lowerBound: INTEGER; ,upperBound: INTEGER; ,pp: INTEGER; ,i: INTEGER; ,len: INTEGER; ,wasInhibited: BOOLEAN; $BEGIN (wasInhibited := inhibited; (IF inhibit THEN ,inhibited := TRUE; (typeName := token; (upName := token; (StrUpperCased(@upName); (alphaName := alpha; (NextToken; (IF NOT alphaName THEN ,FoundUnexpected(typeName, 'typename') (ELSE (IF upName = 'RECORD' THEN ,BEGIN ,REPEAT 0ParseField; 0word := token; 0StrUpperCased(@word); .UNTIL (word = 'END') OR (word = ''); ,Expect('END'); ,END (ELSE (IF upName = 'ARRAY' THEN ,BEGIN ,Expect('['); ,lowerBound := ParseNumber; ,Expect('.'); ,Expect('.'); ,upperBound := ParseNumber; ,Expect(']'); ,pp := p; ,Expect('OF'); ,ParseType(TRUE); ,IF NOT inhibited THEN 0FoundType('ARRAY', yArray, 0, lowerBound, upperBound, Copy(inStr, pp, start - pp)); ,END (ELSE (IF upName = 'STRING' THEN ,BEGIN ,Expect('['); ,len := ParseNumber; ,Expect(']'); ,IF NOT inhibited THEN 0FoundType('STRING', yString, len + 1, 0, 0, ''); ,END (ELSE (IF upName = 'BOOLEAN' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yBoolean, 1, 0, 0, ''); ,END (ELSE (IF upName = 'CHAR' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yChar, 2, 0, 0, '') ,END (ELSE (IF upName = 'BYTE' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yByte, 1, 0, 0, '') ,END (ELSE (IF upName = 'HEXBYTE' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yHexByte, 1, 0, 0, '') ,END (ELSE (IF upName = 'INTEGER' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yInteger, 2, 0, 0, '') ,END (ELSE (IF upName = 'HEXINTEG' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yHexInteger, 1, 0, 0, '') ,END (ELSE (IF upName = 'LONGINT' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yLongInt, 4, 0, 0, '') ,END (ELSE (IF upName = 'REAL' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yReal, 4, 0, 0, '') ,END (ELSE (IF upName = 'POINT' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yPoint, 4, 0, 0, '') ,END (ELSE (IF upName = 'PTR' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yPtr, 4, 0, 0, '') ,END (ELSE (IF upName = 'LONGREAL' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yLongReal, 8, 0, 0, '') ,END (ELSE (IF upName = 'LPOINT' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yLPoint, 8, 0, 0, '') ,END (ELSE (IF upName = 'RECT' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yRect, 8, 0, 0, '') ,END (ELSE (IF upName = 'LRECT' THEN ,BEGIN ,IF NOT inhibited THEN 0FoundType(typeName, yLRect, 16, 0, 0, '') ,END (ELSE ,BEGIN ,IF CiOfCn(upName) > 0 THEN 0BEGIN 0word := token; 0StrUpperCased(@word); 0IF word = 'OF' THEN 4BEGIN 4pp := p; 4NextToken; 4ParseType(TRUE); 4IF NOT inhibited THEN 8FoundType(typeName, yObject, SIZEOF(Handle), 0, 0, Copy(inStr, pp, start - pp)); 4END 0ELSE 0IF NOT inhibited THEN 4FoundType(typeName, yObject, SIZEOF(Handle), 0, 0, ''); 0END ,ELSE 0FoundUnexpected(typeName, 'typename'); ,END; (inhibited := wasInhibited; $END; $PROCEDURE ParseField; $BEGIN (IF NOT alpha THEN ,BEGIN ,FoundUnexpected(token, 'var name'); ,NextToken; ,END (ELSE ,BEGIN ,IF NOT inhibited THEN 0FoundName(token); ,NextToken; ,Expect(':'); ,ParseType(FALSE); ,IF token = ';' THEN 0NextToken ,ELSE ,IF (token <> '') AND (token <> 'END') THEN 0FoundUnexpected(token, '; or END'); ,END; $END; BEGIN $inhibited := FALSE; $p := 1; $eoi := Length(inStr); $Insert(' ', inStr, Length(inStr) + 1); {So that inStr[eoi+1] won't blow up} $NextToken; $WHILE token <> '' DO (ParseField; END; PROCEDURE WriteDRecord{(numLevels: INTEGER; hDRecord: Handle; posInDRecord: INTEGER; 7PROCEDURE SupplyFields(PROCEDURE Field(nameAndType: S255)))}; $VAR fieldInDRecord: INTEGER; $PROCEDURE WrCkAbort; $BEGIN (IF KeyPress THEN ,BEGIN ,WrStr('...abort...'); ,EXIT(WriteDRecord); ,END; $END; $PROCEDURE DeclName(token: S8); $BEGIN (WrCkAbort; (WrStr(Concat(token, ': ')); $END; $PROCEDURE SkipName(token: S8); $BEGIN (WrCkAbort; $END; $PROCEDURE DeclBad(token, wanted: S8); $BEGIN (WrCkAbort; (WrLn; (WrStr('<>')); $END; $PROCEDURE DeclType(token: S8; typeCode: TTypeCode; numBytes: INTEGER; 7lowerBound, upperBound: INTEGER; memberTypeStr: S255); FORWARD; $PROCEDURE DeclArray(token: S8; lowerBound, upperBound: INTEGER; memberTypeStr: S255); (VAR str1: S8; ,str2: S8; ,i: INTEGER; ,origPos: INTEGER; $BEGIN (IF Odd(posInDRecord) THEN ,posInDRecord := posInDRecord + 1; (IntToStr(lowerBound, @str1); (IntToStr(upperBound, @str2); (WrStr(Concat(token, ' [', str1, '..', str2, '] = {')); (FOR i := lowerBound TO upperBound DO ,BEGIN ,IF i > lowerBound THEN 0WrStr(', '); ,origPos := posInDRecord; ,IntToStr(i, @str1); ,ParseDecl(CONCAT(str1, ': ', memberTypeStr), DeclName, DeclType, DeclBad); (***** ,IF Odd(posInDRecord) THEN 0posInDRecord := posInDRecord + 1; *****) ,END; (WrStr('}'); $END; $PROCEDURE DeclType(token: S8; typeCode: TTypeCode; numBytes: INTEGER; 7lowerBound, upperBound: INTEGER; memberTypeStr: S255); (TYPE ,TAlias = 0RECORD 4CASE TTypeCode OF 8yByte: (asByte: Byte); 8yChar: (asChar: CHAR); 8yInteger: (asInteger: INTEGER); 8yLongInt: (asLongInt: LONGINT); 8yLPoint: (asLPoint: FakeLPoint); 8yLRect: (asLRect: FakeLRect); 8yObject: (asObject: TObject); 8yPoint: (asPoint: FakePoint); 8yReal: (asReal: REAL); 8yRect: (asRect: FakeRect); 8yString: (asString: S255); 8END; (VAR alias: ^TAlias; {a bona fide use for aliasing instead of typecasting} ,obj: TObject; ,str: S255; ,i: INTEGER; $BEGIN (IF typeCode = yArray THEN ,BEGIN ,DeclArray(token, lowerBound, upperBound, memberTypeStr); ,EXIT(DeclType); ,END; (IF token <> '' THEN ,WrStr(Concat(token, ' = ')); (IF numBytes > 1 THEN ,IF Odd(posInDRecord) THEN 0posInDRecord := posInDRecord + 1; (alias := POINTER(ORD(hDRecord^) + posInDRecord); {Careful, this is a relocatable location!} (str := ''; (CASE typeCode OF ,yPtr: BEGIN 8LIntToHex(alias^.asLongInt, @str); 8str := Concat('$', str); 8END; ,yBoolean: IF alias^.asByte = ORD(FALSE) THEN  '' THEN ,WrStr(Concat(str, ' ')); (posInDRecord := posInDRecord + numBytes; $END; $PROCEDURE DebugField(nameAndType: S255); $BEGIN (IF nameAndType <> '' THEN ,BEGIN ,fieldInDRecord := fieldInDRecord + 1; ,IF fieldInDRecord > 1 THEN 0WrStr('; '); ,ParseDecl(nameAndType, DeclName, DeclType, DeclBad); ,WrCkAbort; ,END (ELSE {Empty string signifies padding to a word boundary, if necessary} (IF Odd(posInDRecord) THEN ,posInDRecord := posInDRecord + 1; $END; BEGIN $IF KeyPress THEN (Exit(WriteDRecord); $fieldInDRecord := 0; $WrStr('[ '); $SupplyFields(DebugField); $WrStr('] '); END; PROCEDURE DumpVar{(pVariable: Ptr; nameAndType: S255)}; $PROCEDURE SupplyVar(PROCEDURE Field(nameAndType: S255)); $BEGIN (Field(nameAndType); $END; BEGIN $currXPos := 0; $outputIndent := 20; $WriteDRecord(1, @pVariable, 0, SupplyVar); $outputIndent := 0; $WrLn; END; {$ENDC} { ====================================== KITBUG ====================================== } {$IFC fDbgObject} PROCEDURE WrStr{(str: S255)}; { Write a STRING with word-wrap } $VAR start: INTEGER; (maxLen: INTEGER; (len: INTEGER; (total: INTEGER; BEGIN $total := Length(str); $start := 1; $WHILE start <= total DO (BEGIN (len := total - start + 1; (maxLen := outputRMargin - currXPos; (IF len > maxLen THEN ,BEGIN ,len := maxLen; ,WHILE (len > 0) AND (str[len] <> ' ') DO 0len := len - 1; ,IF (len = 0) AND (currXPos = outputIndent) THEN 0len := maxLen; ,END; (IF len > 0 THEN ,BEGIN ,Write(Copy(str, start, len)); ,currXPos := currXPos + len; ,start := start + len; ,END; (IF (currXPos >= outputRMargin) OR (start <= total) THEN ,WrLn; (END; END; PROCEDURE WrLn; { goto next line and output indentation } BEGIN $WriteLn; $IF outputIndent > 0 THEN (BEGIN (Write(' ':outputIndent); (currXPos := outputIndent; (END $ELSE (currXPos := 0; END; FUNCTION CheckKeyPress{(routine: S255): BOOLEAN}; $VAR ch: CHAR; BEGIN $IF KeyPress THEN (BEGIN (IF routine <> '' THEN ,BEGIN ,WriteLn; ,WriteLn(' -- ', routine, ' stopped because you typed a key --'); ,WriteLn; ,END; (* commented out and should be removed if paslib bug has been fixed ({ flush characters; because of PASLIB bug, also stop when user types a ~ } (ch := ' '; (WHILE KeyPress AND (ch<>'~') DO ,IF EOLn THEN 0ReadLn ,ELSE 0Read(ch); *) (CheckKeyPress := TRUE; (END $ELSE (CheckKeyPress := FALSE; END; ${$IFC fDebugMethods} PROCEDURE WrObj(object: TObject; numLevels: INTEGER; memberTypeStr: S255); BEGIN $WriteLn; $currXPos := 0; $outputIndent := 0; $IF ValidObject(Handle(object)) THEN (BEGIN (object.Debug(numLevels, memberTypeStr); (IF CheckKeyPress('Display of the object') THEN; (END $ELSE (Write('Not an object: ', ORD(object):1); END; ${$ENDC} {$S SgCLAini} PROCEDURE DumpHeap(heap: THeap; wantedSTP: LONGINT; wantedReference: LONGINT; fPrintSelf: BOOLEAN); $VAR hz: THz; (cb: TC; (hndl: Handle; (obj: TObject; (heapSize: LONGINT; (numObjects: LONGINT; {Clascal objects only} (objOvhdSize: LONGINT; {includes master, header, and class pointer} (objDataSize: LONGINT; (numOther: LONGINT; {Non-Clascal objects} (otherSize: LONGINT; (numFree: LONGINT; (freeSize: LONGINT; (bigFreeSize: LONGINT; (bk: TBk; (dumpIt: BOOLEAN; (valid: BOOLEAN; (offset: INTEGER; (base: LONGINT; (hStr: S8; (class: TClass; (className: TClassName; BEGIN $WriteLn; $IF heap = NIL THEN (BEGIN (WriteLn('The heap pointer is NIL'); (WriteLn; (EXIT(DumpHeap); (END; $hz := THz(heap); $heapSize := cbOfHz(hz); $numObjects := 0; $objOvhdSize := 0; $objDataSize := 0; $numOther := 0; $otherSize := 0; $numFree := 0; $freeSize := 0; $bigFreeSize := 0; $WriteLn('Heap size in bytes: ', heapSize:6); $WriteLn('Bytes free: ', hz^.cbFree:6); $WriteLn; $WriteLn('Heap contents (handle, size in bytes):'); $WriteLn; ({ setup indentation for writing objects } $outputIndent := 17; { '$', ORD(hndl):8, cb:6, ': ' } $bk := hz^.bkFst; $WHILE (ORD(bk) >= ORD(hz^.bkFst)) AND (ORD(bk) <= ORD(hz^.bkLst)) DO (BEGIN (IF bk^.hdr.tybk <> tybkFree THEN ,cb := bk^.hdr.cw * 2 (ELSE ,cb := bk^.cwFree * 2; (IF cb <= 0 THEN ,BEGIN ,WriteLn('FREE BLOCK ', ORD(bk):1, ' HAS LENGTH', cb); ,EXIT(DumpHeap); ,END; (CASE bk^.hdr.tybk OF ,tybkStd: 0BEGIN {$IFC LibraryVersion <= 20} 0hndl := Handle(ORD(hz) + bk^.oh); {$ELSEC} 0hndl := Handle(ORD(@hz^.argpPool) + (LONGINT(bk^.bp.ip)*4)); {$ENDC} 0valid := ValidObject(hndl); 0IF wantedSTP > 0 THEN 4IF valid THEN {looks like a class pointer; pray that it is!} 8dumpIt := %_InObCp(ORD(hndl), wantedSTP) 4ELSE 8dumpIt := FALSE 0ELSE 0IF wantedReference <> 0 THEN 4BEGIN 4offset := 0; 4base := ORD(hndl^); 4WHILE (offset < cb) AND (TpLONGINT(base + offset)^ <> wantedReference) DO 8offset := offset + 2; 4dumpIt := offset < cb; 4END 0ELSE 4dumpIt := TRUE; 0IF dumpIt THEN 4BEGIN 4LIntToHex(ORD(hndl), @hStr); 4Write('$', hStr, cb:6, ': '); 4IF bk <> TBk(ORD(hndl^) - 4) THEN 8BEGIN 8WriteLn('INCORRECT BACK POINTER FOR bk = ', ORD(bk):1); 8EXIT(DumpHeap); 8END; 4IF valid THEN 8BEGIN 8obj := TObject(hndl); 8currXPos := outputIndent; 8{$IFC fDebugMethods} 8IF fPrintSelf THEN  bigFreeSize THEN 4bigFreeSize := cb; 0END; ,OTHERWISE 0BEGIN 0numOther := numOther + 1; 0otherSize := otherSize + cb; 0END; ,END; (bk := TBk(ORD(bk) + cb); (IF CheckKeyPress('HeapDump') THEN ,EXIT(DumpHeap); (END; $WriteLn; $IF numObjects > 0 THEN (BEGIN (WriteLn('Number of Clascal objects: ', numObjects:6); (IF wantedReference = 0 THEN ,BEGIN ,WriteLn('Bytes in their headers & masters: ', objOvhdSize:12); ,WriteLn('Bytes in their records: ', objDataSize:12); ,IF objDataSize+objOvhdSize > 0 THEN 0WriteLn('Header and master overhead: ', 8(100 * objOvhdSize) DIV (objDataSize+objOvhdSize):5, '%'); ,END; (WriteLn; (END; $IF (wantedSTP <= 0) AND (wantedReference = 0) THEN 'BEGIN 'WriteLn('Number of free blocks: ', numFree:6); 'WriteLn('Largest free block: ', bigFreeSize:6); 'WriteLn('Bytes in free blocks: ', freeSize:12); 'WriteLn; 'WriteLn('Number of other blocks: ', numOther:6); 'WriteLn('Bytes in those blocks: ', otherSize:12); 'WriteLn; 'WriteLn('Other overhead: ', heapSize-objOvhdSize-objDataSize-freeSize-otherSize:12); 'WriteLn('Total heap size in bytes: ', heapSize:12); 'WriteLn; 'END; END; {$S SgCLAini} PROCEDURE GoKitBug; {intended to be called from LisaBug} BEGIN $EntDebugger(' ', 'Called from GoKitBug'); END; {$S SgCLAini} PROCEDURE EntDebugger{(inputStr, enterReason: S255)}; $LABEL 99; $CONST null = CHR(0); $VAR token: S255; (cState: TConvResult; (timeToGo: BOOLEAN; (brClass: S8; (brMethod: S8; $PROCEDURE GetToken; (VAR endOfToken: INTEGER; $BEGIN (token := ''; (WHILE Pos(' ', inputStr) = 1 DO ,Delete(inputStr,1,1); (endOfToken := Pos(' ', inputStr)-1; (IF endOfToken <= 0 THEN ,endOfToken := Length(inputStr); (token := Copy(inputStr, 1, endOfToken); (Delete(inputStr, 1, endOfToken); $END; $PROCEDURE DebugStatus; (VAR i: INTEGER; $BEGIN (IntToStr(curTraceLevel, @token); (Write('Watch Level = ',token); (IntToStr(defTraceCount, @token); (WriteLn(', Watch Count = ',token); (FOR i := 1 TO breakMCount DO ,WITH breakMethods[i] DO 0IF (brClass <> '') OR (brMethod <> '') THEN 4WriteLn(i:3, ': ', brClass:8,'.',brMethod:8) $END; $PROCEDURE ClearBreaks; (VAR brNumber: INTEGER; ,cState: TConvResult; $BEGIN (GetToken; (IF token = '' THEN ,BEGIN ,Write('Clear which breakpoint [A for all breakpoints]? '); ,ReadLn(token); ,END; (TrimBlanks(@token); (StrUpperCased(@token); (IF token <> '' THEN ,IF token[1] = 'A' THEN 0breakMCount := 0 ,ELSE 0BEGIN 0StrToInt(@token, brNumber, cState); 0IF cState = cvValid THEN 4IF (brNumber >= 1) AND (brNumber <= breakMCount) THEN 8WITH breakMethods[brNumber] DO  0 THEN ,BEGIN ,inputStr := Concat(Copy(token, i + 1, Length(token) - i), inputStr); ,token := Copy(token, 1, i - 1); ,END; (TrimBlanks(@token); (IF token <> '' THEN ,BEGIN ,StrUpperCased(@token); ,token := Copy(Concat(token, ' '), 1, 8); ,END; $END; $PROCEDURE BrSetup(prompt: S255); (VAR brNumber: INTEGER; (FUNCTION MoreThanAClass: Boolean; (BEGIN ,MoreThanAClass := TRUE; ,IF length(inputstr) > 0 THEN 0IF inputstr[length(inputstr)] = '.' THEN 0BEGIN 4GetOne(Concat(prompt,' what Class?')); 4WITH breakMethods[brNumber] DO 8BEGIN 8brClass := token; 8brMethod := ''; 8END; 4MoreThanAClass := FALSE; 0END; (END; $BEGIN (FOR brNumber := 1 TO maxBreaks DO ,WITH breakMethods[brNumber] DO 0IF (brNumber > breakMCount) OR ((brClass='') AND (brMethod='')) THEN 4BEGIN 4IF MoreThanAClass THEN 8BEGIN 8GetOne(Concat(prompt,' what Class?')); 8brClass := token; 8GetOne(Concat(prompt,' what Method?')); 8brMethod := token; 8END; 4IF (brClass <> '') OR (brMethod <> '') THEN 8breakMCount := Max(breakMCount, brNumber); 4lastBpPc := 0; 4lastEpPc := 0; 4EXIT(BrSetup); 4END; (WriteLn('Too Many Breaks Defined, you must first clear a breakpoint') $END; $PROCEDURE TraceOrNot; (VAR i: INTEGER; $BEGIN (GetToken; (StrToInt(@token, i, cState); (IF cState = cvValid THEN ,BEGIN ,defTraceCount := i; ,GetToken; ,END (ELSE ,defTraceCount := 0; (returnToMain := TRUE; (fTraceSelf := FALSE; (fTraceClass := FALSE; (WHILE token <> '' DO ,BEGIN ,StrUpperCased(@token); ,IF token[1] = 'A' THEN {Stay on Alternate Screen During Trace} 0returnToMain := FALSE ,ELSE ,IF token[1] = 'C' THEN {Print Class with Trace} 0fTraceClass := TRUE ,ELSE ,IF token[1] = 'F' THEN {Print Fields with Trace} 0fTraceSelf := TRUE; ,GetToken; ,END; (fTraceEnabled := TRUE; (traceCount := defTraceCount; $END; $PROCEDURE Level; (VAR i: INTEGER; $BEGIN (GetToken; (IF token = '' THEN ,BEGIN ,Write('Lowest BP level to watch (1..9999)? '); ,ReadLn(token); ,END; (StrToInt(@token, i, cState); (IF cState = cvValid THEN ,IF (i >= 1) AND (i <= 32000) THEN 0curTraceLevel := i; $END; $FUNCTION YesNo(prompt: S255): BOOLEAN; $BEGIN (REPEAT ,GetOne(Concat(prompt, '? [Y/N]: ')); ,IF token = '' THEN 0GOTO 99; *UNTIL token[1] IN ['Y', 'N']; (YesNo := token[1] = 'Y'; $END; $PROCEDURE PromptOnOff; $BEGIN (showPrompt := YesNo('Show Debugger Prompt'); $END; ${$IFC fDebugMethods} $PROCEDURE Inspect; $VAR lh: LONGINT; (d: INTEGER; $BEGIN (GetToken; (IF token = '' THEN ,BEGIN ,Write('Handle to inspect [depth] [member decl]? '); ,Readln(inputStr); ,GetToken; ,END; (HexStrToLInt(@token, lh, cState); (IF cState <> cvValid THEN ,BEGIN ,WriteLn('Not a hex number'); ,Exit(Inspect); ,END (ELSE ,GetToken; (StrToInt(@token, d, cState); (IF cState <> cvValid THEN ,d := 1; (IF ValidObject(Handle(lh)) THEN ,BEGIN ,WrObj(TObject(lh), d, inputStr); ,Writeln; ,END (ELSE ,Writeln('Invalid Object'); (Writeln; $END; ${$ENDC} $PROCEDURE TallyAndTime; $BEGIN (tallyingCalls := FALSE; (IF tallies <> NIL THEN ,BEGIN ,IF YesNo('Do you want to see performance measurements now') THEN 0TallyReport; ,IF YesNo('Do you want to zero the tallies and times') THEN 0TallyZero; ,END; (IF YesNo('Do you want to continue execution and measure its performance') THEN ,TallyStart; (WriteLn; $END; $PROCEDURE RefsToObject; $VAR lh: LONGINT; $BEGIN (GetToken; (IF token = '' THEN ,BEGIN ,Write('Handle of the object whose every Reference from the same heap should be dumped? '); ,Readln(inputStr); ,GetToken; ,END; (HexStrToLInt(@token, lh, cState); (IF cState <> cvValid THEN ,BEGIN ,WriteLn('Not a hex number'); ,Exit(RefsToObject); ,END; (IF ValidObject(Handle(lh)) THEN ,DumpHeap(TObject(lh).Heap, -1, lh, TRUE) (ELSE ,Writeln('Invalid Object'); (Writeln; $END; $FUNCTION StackFrame(whichFrame: INTEGER): LONGINT; ({ Returns address of stack frame 'whichFrame' (>=-1); ,whichFrame < 0 returns -1. ,whichFrame = 1 is the top frame not belonging to the debugger itself. 0When called from ABCBREAK, the caller of ABCBREAK is frame 1; 0When called from BEPSN, the caller of BP or EP is frame 1. ,whichFrame = 2 is the caller of frame 1, and so on. ,If whichFrame is greater than # frames, returns -1. ,If neither ABCBREAK nor BEPSN is on the stack, returns -1.} (VAR dummy: INTEGER; { must be first local and two bytes long } ,RA6: LONGINT; ,RA5: LONGINT; ,i: INTEGER; ,className: TClassName; ,procName: S8; ,startCount: BOOLEAN; ,frameReference: INTEGER; ,nextPC: LONGINT; $BEGIN (StackFrame := -1; { default return } (frameReference := 0; (startCount := FALSE; (RA5 := %_GetA5; (RA6 := ORD(@dummy)+2; { stack frame called by current one; start with my stack frame } (WHILE (whichFrame >= frameReference) AND (RA6 <> RA5) DO ,BEGIN ,IF NOT startCount THEN 0BEGIN 0IF GetDollarD(TppINTEGER(RA6), className, procName, nextPC) THEN { is this frame 0? } 4IF (className = '') AND ((procName = 'BEPSN ') OR (procName = 'ABCBREAK'))THEN 8BEGIN 8startCount := TRUE; { yes } 8IF procName = 'BEPSN ' THEN  ORD('~')) THEN 0Byte2Char := '' ,ELSE 0Byte2Char := CHR(n); (END; ({$R-} (PROCEDURE AddCh(s: TPString; ch: CHAR; maxStrLeng: INTEGER; VAR overflow: BOOLEAN); ,BEGIN ,overflow := TRUE; ,IF Length(s^) < maxStrLeng THEN 0BEGIN 0overflow := FALSE; 0s^[0] := CHR(ORD(s^[0]) + 1); 0s^[ORD(s^[0])] := ch; .END; *END; *{$IFC fRngObject} {$R+} {$ENDC} $BEGIN ({ start at an even address and fullBytes a multiple of 16 >= numBytes } (addr := (start DIV 2) * 2; (IF checkAddresses THEN ,IF NOT ValidDataAddress(addr) THEN 0IF NOT ValidGlobalAddress(addr) THEN 4BEGIN 4WriteLn; 4Write('*** That address is neither in a data segment nor in the stack/global segment. '); 4WriteLn('***'); 4EXIT(WrMemory); 4END; (fullBytes := ((numBytes + 15) DIV 16) * 16; (WHILE fullBytes > 0 DO ,BEGIN ,IF fullBytes MOD 16 = 0 THEN 0BEGIN 0LIntToHex(addr, @str); 0Write(' ', str, ' '); 0asChars := ''; 0END; ,IF checkAddresses THEN 0IF NOT ValidDataAddress(addr) THEN 4IF NOT ValidGlobalAddress(addr) THEN 8WHILE numBytes > 0 DO  0 DO 4BEGIN 4Write(' '); 4AddCh(@asChars, ' ', 16, overflow); 4AddCh(@asChars, ' ', 16, overflow); 4fullBytes := fullBytes - 2; 4END; ,IF fullBytes > 0 THEN 0BEGIN 0extdWord := LIntAndLInt(TpINTEGER(addr)^, $0000FFFF); 0LIntToHex(extdWord, @str); 0Delete(str, 1, 4); {4 leading zeros} 0Write(str, ' '); 0AddCh(@asChars, Byte2Char(extdWord DIV 256), 16, overflow); 0AddCh(@asChars, Byte2Char(extdWord MOD 256), 16, overflow); 0addr := addr + 2; 0fullBytes := fullBytes - 2; 0numBytes := numBytes - 2; 0END; ,IF fullBytes MOD 16 = 0 THEN 0WriteLn(' |', asChars, '|'); ,END; (WriteLn; $END; $FUNCTION WrFrame(whichFrame: INTEGER; full: BOOLEAN): BOOLEAN; ({ Write a frame given its number; return TRUE if that frame exists } (VAR RA5: LONGINT; ,calledA6: LONGINT; ,addr: LONGINT; ,laterA6: LONGINT; ,earlierA6: LONGINT; ,hexStr: S8; ,gotMainProg: BOOLEAN; ,className: TClassName; ,methName: S8; ,procName: S255; ,procStart: LONGINT; ,frameSELF: TObject; ,class: TClass; ,nextPC: LONGINT; ,localBytes: INTEGER; ,paramBytes: INTEGER; ,selfBytes: INTEGER; $PROCEDURE SwapIn(valueString: S8); (BEGIN (END; $BEGIN (RA5 := %_GetA5; (calledA6 := StackFrame(whichFrame-1); { A6 of frame called by desired frame } (IF (whichFrame < 1) OR (calledA6 = -1) OR (calledA6 = RA5) THEN ,BEGIN ,WrFrame := FALSE; ,EXIT(WrFrame); ,END; (WrFrame := TRUE; (addr := calledA6; (LIntToHex(TpLONGINT(addr)^, @hexStr); (Write('Frame # ', whichFrame:3, ' @ $', hexStr, ' '); (gotMainProg := TpLONGINT(addr)^ = RA5; { stack frame for main prog starts at A5 } ({ find called-from address } (IF GetDollarD(TppINTEGER(calledA6), className, methName, nextPC) THEN ,IF className = '' THEN 0procName := methName ,ELSE 0procName := Concat(className, '.', methName) (ELSE ,procName := ''; (IF procName <> '' THEN ,BEGIN ,Write(procName:17); ,{ search back in code for TST.W (A7) and LINK A6, instructions } ,addr := calledA6+4; ,addr := TpLONGINT(addr)^; &{$R-} SwapIn(TPS8(addr)^); {$IFC fRngObject} {$R+} {$ENDC} {Be sure the code is swapped in} ,procStart := 0; ,WHILE procStart = 0 DO 0BEGIN 0addr := addr - 2; 0IF TpINTEGER(addr)^ = $4E56 { LINK A6, } THEN 4{ found LINK, so numLocal is now set correctly, and 6start of PROCEDURE is 4 bytes back (auto stack expansion) } 4procStart := addr - 4; 0END; ,IF gotMainProg THEN 0procStart := procStart + 4; { main prog has no stack expansion } ,addr := calledA6+4; ,LintToHex(TpLONGINT(addr)^-4 - procStart, @hexStr); ,Delete(hexStr, 1, Length(hexStr)-4); { only want the lower 4 digits of hex number } ,Write('+ $', hexStr); ,{ advance to next stack frame now, so we can get at its variables } ,laterA6 := calledA6; ,calledA6 := TpLONGINT(laterA6)^; ,IF calledA6 = RA5 THEN 0earlierA6 := RA5 ,ELSE 0earlierA6 := TpLONGINT(calledA6)^; ,frameSELF := NIL; ,IF (className <> '') AND (procName <> 'CREATE ') THEN { regular method } 0BEGIN 0addr := calledA6+8; 0IF ValidObject(Handle(TpLONGINT(addr)^)) THEN 4frameSELF := TObject(TpLONGINT(addr)^); 0END; ,IF frameSELF <> NIL THEN 0BEGIN 0LIntToHex(ORD(frameSELF), @hexStr); 0class := frameSELF.Class; 0CpToCn(TPSliceTable(class), TS8(className)); 0Write(' (', className, ': $', hexStr, ')'); 0END; ,IF full THEN 0BEGIN 0{$IFC fDebugMethods} 0WriteLn; 0IF frameSELF <> NIL THEN 4BEGIN 4Write('SELF = '); 4currXPos := 7; 4outputIndent := 7; 4frameSELF.Debug(1, ''); 4WriteLn; 4END; 0{$ENDC} 0localBytes := Max(0, Min(ORD(calledA6 - (laterA6 + 8)), $50)); 0paramBytes := Max(0, Min(ORD(earlierA6 - (calledA6 + 8)), $50)); 0selfBytes := 4 * ORD(frameSELF <> NIL); 0WriteLn; 0WriteLn('LOCALS (First declared local is listed last):'); 0WrMemory(calledA6 - localBytes, localBytes, FALSE); 0WriteLn('PARAMETERS (Last declared parameter is listed first):'); 0WrMemory(calledA6 + 8 + selfBytes, paramBytes - selfBytes, FALSE); 0END; ,END; (WriteLn; $END; $PROCEDURE StackCrawl; (VAR frNum: INTEGER; $BEGIN (frNum := 1; (WHILE WrFrame(frNum, FALSE) DO ,frNum := frNum + 1; (WriteLn; $END; $PROCEDURE FrameDump; (VAR i: INTEGER; ,frame: LONGINT; $BEGIN (GetToken; (IF token = '' THEN ,BEGIN ,Write('Frame number to dump? '); ,ReadLn(token); ,END; (StrToInt(@token,i,cState); (IF cState = cvValid THEN ,BEGIN ,IF (i >= 1) THEN 0IF NOT WrFrame(i, TRUE) THEN 4WriteLn('Frame number was too large'); ,END; (WriteLn; $END; $PROCEDURE ToPrinter; (VAR errnum: INTEGER; ,outfname: PathName; {$IFC LibraryVersion <= 20} ,{ Paslib initialization done in the WorkShop that is not done in the DeskTop manager } (PROCEDURE TellPaslibPrinterLocation; ,CONST 0AlreadyMounted = 1052; ,VAR 0errnum: INTEGER; { error return } 0tp: TPORTS; 0devname: E_Name; 0vname: E_Name; 0password: E_Name; 0tdt: TDeviceType; 0tdi: TDeviceInfo; 0dsp: DsProcParam; 0DevControl: DcType; 0path: PathName; (BEGIN ,FOR tp := uppertwig TO t_extra3 DO 0BEGIN 0Get_config_name(errnum,tp,devname); 0IF errnum <= 0 THEN 4BEGIN 4PMReadConfig(tp,tdt,tdi); 4IF tdt IN [DMPrinter,Typer] THEN 8BEGIN 8Mount(errnum, vname, password, devname); 8IF (errnum <= 0) or (errnum = AlreadyMounted) THEN = 1 THEN 8BEGIN 8pExtWords := @config.extWords[1]; 8IF pExtWords^.isPrinter THEN = 1 THEN} ,UNTIL errnum > 0; (END { TellPaslibPrinterLocation }; {$ENDC} $BEGIN (GetToken; (outfname := token; (IF token = '' THEN ,BEGIN ,Write('Name of file to send output to? [-console] '); ,ReadLn(outfname); ,END; (IF outfname = '' THEN *OutputRedirect(errnum,outfname,TRUE) (ELSE *BEGIN ,StrUpperCased(@outfname); ,IF outfname = '-PRINTER' THEN .TellPaslibPrinterLocation; ,OutputRedirect(errnum,outfname,FALSE); *END; (IF errnum > 0 THEN ,BEGIN ,IF outfname = '' THEN 0outfname := '-CONSOLE'; ,WriteLn('Error number ',errnum,' redirecting output to ',outfname); ,END; $END; $PROCEDURE MemoryDump; (VAR start: LONGINT; ,numBytes: LONGINT; $BEGIN (GetToken; (IF token = '' THEN ,BEGIN ,Write('Starting address [# bytes]? '); ,Readln(inputStr); ,GetToken; ,END; (HexStrToLInt(@token, start, cState); (IF cState <> cvValid THEN ,Exit(MemoryDump) (ELSE ,GetToken; (HexStrToLInt(@token, numBytes, cState); (IF cState <> cvValid THEN ,numBytes := $10; (WrMemory(start, numBytes, TRUE); $END; $PROCEDURE HeapDump; (VAR allInfo: BOOLEAN; ,wantedSTP: LONGINT; {-1 for all classes} ,allHeaps: BOOLEAN; ,index: INTEGER; ,heap: THeap; ,dumpDocHeap: BOOLEAN; $BEGIN (allInfo := TRUE; (wantedSTP := -1; (allHeaps := TRUE; (GetToken; (IF token <> '' THEN ,BEGIN ,allHeaps := FALSE; ,TrimBlanks(@token); ,StrUpperCased(@token); ,index := CiOfCn(Copy(Concat(token, ' '), 1, 8)); ,IF index > 0 THEN 0wantedSTP := ORD(hMySTables^^.records[index]) ,ELSE 0BEGIN 0WriteLn('No such class!'); 0EXIT(HeapDump); 0END; ,END; (IF allHeaps THEN ,IF NOT YesNo('All classes') THEN 0WHILE wantedSTP <= 0 DO 4BEGIN 4GetOne('Which class?'); 4IF token = '' THEN 8GOTO 99 4ELSE 8BEGIN 8index := CiOfCn(token); 8IF index > 0 THEN  [# bytes], O)utputTo, P)rompt [Y/N], R)efsToObject,'); 3WriteLn(' S)tackCrawl, T)ally & Time, W)atch [count] [A)ltScreen] [C)lass] [F)ields]'); 3END; 0Write('-->'); 0ReadLn(inputStr); 0END; ,GetToken; ,IF token <> '' THEN 0CASE CharUpperCased(token[1]) OF 4null: GoKitBug; {don't expect people to type this command, but this Lwill guarantee that the Linker does not flush Lthe GoKitBug procedure} 4'B': BrSetup('Break on'); 4'C': ClearBreaks; 4'D': DebugStatus; 4'E': %_GoLisabug; 4'F': FrameDump; 4'G': BEGIN = keyPresLimit THEN (BEGIN (tb := KeyPress; ,{ force call to keyPress until press is dealt with } (IF NOT tb THEN ,kpcntr := 0; (AKeyPress := tb; (END $ELSE (kpcntr := kpcntr + 1 END; { ====================================== BP -- EP ====================================== } {$IFC fTrace} PROCEDURE BEPSN(odummy: LONGINT; fBegin, displayIt: BOOLEAN); $VAR receiver: TObject; (caller: TpLONGINT; (i: INTEGER; (className: TClassName; (procName: S8; (toDebugger: BOOLEAN; (nextPC: LONGINT; &{ See if this is the method to start tracing at } $PROCEDURE BreakHere; (VAR ts: S16; ,i: INTEGER; ,found: BOOLEAN; $BEGIN (found := FALSE; (FOR i := 1 TO breakMCount DO ,BEGIN ,WITH breakMethods[i] DO 0{ NOTE: if both brClass and brMethod are '', then the iTH breakpoint is unassigned } 0IF brClass = '' THEN 4found := (brMethod = procName) AND (brMethod <> '') 0ELSE 0IF brMethod = '' THEN 4found := brClass = className 0ELSE 4found := (brClass = className) AND (brMethod = procName); ,IF found THEN 0BEGIN 0displayIt := TRUE; 0toDebugger := TRUE; 0returnToMain := TRUE; 0fTraceSelf := FALSE; 0fTraceClass := TRUE; 0lastBpPc := 0; 0lastEpPc := 0; 0EXIT(BreakHere) 0END ,END $END; $PROCEDURE WriteOutDebugInfo; (CONST maxIndent = 70; (VAR i: INTEGER; ,hexStr: S8; $BEGIN (WriteLn; (indentTrace := CMin(tabLevel, maxIndent + 5); (IF tabLevel <= trLevMemory THEN ,Write(traceLevels[tablevel]:4, ' ') (ELSE ,Write(' '); (Write(' ': CMin(tabLevel, maxIndent)); (IF tabLevel > maxIndent + 5 THEN ,Write(tabLevel:4, ' ') (ELSE (IF indentTrace > maxIndent THEN ,Write(' ': indentTrace - maxIndent); (IF fBegin THEN ,Write('BEGIN ') (ELSE ,Write('END '); ({$IFC fDebugMethods} (currXPos := indentTrace + 11 {5 for level #; 6 for BEGIN/END}; ({$ENDC} (IF className<>'' THEN ,BEGIN ,Write(className, '.'); ,{$IFC fDebugMethods} ,currXpos := currXPos + 9; ,{$ENDC} ,END; (Write(procName); ({$IFC fDebugMethods} (currXPos := currXPos + 8; ({$ENDC} (IF (fTraceSelf OR fTraceClass) AND (receiver <> NIL) THEN ,IF (procName<>'DEBUGOBJ') AND (procName<>'DEBUG ') AND (procName<>'FIELDS ') AND /(fBegin OR ((procName<>'FREEOBJE') AND (procName<>'FREE '))) THEN 0BEGIN 0{$IFC fDebugMethods} 0Write('('); 0currXPos := currXPos + 1; 0IF (procName <> 'FREEOBJE') AND fTraceSelf THEN 4BEGIN 4outputIndent := currXPos; 4receiver.Debug(1, ''); 4END 0ELSE 4BEGIN 4receiver.Debug(0, ''); 4LIntToHex(LONGINT(receiver), @hexStr); 4Write(': $', hexStr); 4END; 0Write(')'); 0{$ENDC} 0END; $END; $PROCEDURE TraceStuff; (VAR nextPC: LONGINT; $BEGIN (IF traceCount = 1 THEN ,EntDebugger(' ','Count methods displayed') (ELSE ,traceCount := traceCount - 1 $END; BEGIN $toDebugger := FALSE; $IF fDebugRecursion THEN (EXIT(BEPSN); $fDebugRecursion := TRUE; $caller := TpLONGINT(odummy + 4); $receiver := NIL; $IF GetDollarD(TppINTEGER(caller), className, procName, nextPC) THEN (IF (className <> '') AND (procName <> 'CREATE ') THEN ,IF ValidObject(Handle(TpLONGINT(caller^+8)^)) THEN 0receiver := TObject(TpLONGINT(caller^+8)^); $IF breakMCount > 0 THEN (BreakHere; $IF displayIt THEN (WriteOutDebugInfo; $IF toDebugger THEN (EntDebugger(' ','Breakpoint found') $ELSE (BEGIN (IF displayIt THEN ,toDebugger := KeyPress (ELSE ,toDebugger := AKeyPress; (IF toDebugger THEN ,EntDebugger(' ','Key pressed on alternate screen') (ELSE (IF (traceCount > 0) and (displayIt) THEN ,TraceStuff; (END; $fDebugRecursion := FALSE; END; PROCEDURE BP{(myTraceLevel: INTEGER)}; $VAR dummy: LONGINT; {Must be first VAR} (bpFrame: TpLONGINT; (callerPC: LONGINT; (departed: LONGINT; BEGIN $IF tallyingCalls THEN (stopTime := MicroTimer(* - debugTime*); $tabLevel := tabLevel + 1; {Increment first because BEPSN can be reentrant} $callerPC := TpLONGINT(ORD(@dummy) + 8)^; $IF tabLevel <= trLevMemory THEN (BEGIN (traceLevels[tabLevel] := myTraceLevel; (bpFrame := TpLONGINT(ORD(@dummy) + 4); (traceFrames[tabLevel] := LIntAndLInt(bpFrame^, $00FFFFFF); (END; $IF fTraceEnabled AND (myTraceLevel >= curTraceLevel) THEN (BEPSN(ORD(@dummy), TRUE, TRUE) $ELSE $IF (breakMCount > 0) OR AKeyPress THEN (IF callerPC <> lastBpPc THEN ,BEPSN(ORD(@dummy), TRUE, FALSE); $lastBpPc := callerPC; $IF tallyingCalls THEN (BEGIN (departed := MicroTimer; (* debugTime := debugTime + departed - stopTime + tallyOverhead; *) (IF tabLevel <= trLevMemory THEN ,traceTimes[tabLevel] := departed (*- debugTime*); (END; END; PROCEDURE EP; $VAR dummy: LONGINT; {Must be first VAR and 4 bytes long} (epFrame: LONGINT; (doTrace: BOOLEAN; (i: INTEGER; (callerPC: LONGINT; (elapsed: LONGINT; BEGIN $callerPC := TpLONGINT(ORD(@dummy) + 8)^; $IF tallyingCalls THEN (BEGIN (stopTime := MicroTimer (*- debugTime*); (IF tabLevel <= trLevMemory THEN ,BEGIN ,elapsed := stopTime - traceTimes[tabLevel]; ,FOR i := tabLevel - 1 DOWNTO 1 DO 0traceTimes[i] := traceTimes[i] + elapsed; ,Tally(callerPC, elapsed); ,END (ELSE ,BEGIN ,WriteLn('Stack bigger than performance measurement can handle! ', tablevel:1); ,tallyingCalls := FALSE; ,END; (END; $IF tabLevel < 0 THEN (BEGIN (tabLevel := 0; (Writeln('--------------------------'); (BEPSN(ORD(@dummy), FALSE, TRUE); (ABCBreak('The above EP had no BP at all', 0); (doTrace := FALSE; (END $ELSE IF tabLevel <= trLevMemory THEN (BEGIN (epFrame := LIntAndLInt(TpLONGINT(ORD(@dummy) + 4)^, $00FFFFFF); (IF traceFrames[tabLevel] <> epFrame THEN ,BEGIN ,i := tabLevel - 1; {Try to resynchronize} ,WHILE (tabLevel <> i) AND (i >= 0) DO 0IF traceFrames[i] = epFrame THEN 4BEGIN 4Writeln('--------------------------'); 4ABCBreak('There was a BP with no EP', 0); 4tabLevel := i; 4END 0ELSE 4i := i - 1; ,IF tabLevel <> i THEN 0BEGIN 0Writeln('--------------------------'); 0BEPSN(ORD(@dummy), FALSE, TRUE); 0ABCBreak('The above EP had no BP', 0); 0END; ,END; (doTrace := fTraceEnabled AND (traceLevels[tablevel] >= curTraceLevel); (END $ELSE (doTrace := FALSE; $IF doTrace THEN (BEPSN(ORD(@dummy), FALSE, TRUE) $ELSE $IF (breakMCount > 0) OR AKeyPress THEN (IF callerPC <> lastEpPc THEN ,BEPSN(ORD(@dummy), FALSE, FALSE); $IF tabLevel >= 0 THEN (tabLevel := tabLevel - 1; $lastEpPc := callerPC; (* IF tallyingCalls THEN (debugTime := MicroTimer - stopTime + tallyOverhead; $*) END; {$ENDC} {$ENDC} { ====================================== COUNTHEAP ====================================== } {$IFC fCheckHeap} FUNCTION CountHeap{(heap: THeap): INTEGER}; $VAR hz: THz; (numObjects: INTEGER; BEGIN $hz := THz(heap); $IF FCheckHzOK(hz, numObjects) THEN ; $CountHeap := numObjects; END; {$ENDC} {$S sInit1} 3. "6F^9PaD!$ǐ^J##TLהTextImage, TTextView} {$I LibTK/UTEXT4.text} {Text Selections and Commands} END. UNIT UText; {$SETC IsIntrinsic := TRUE } {$IFC IsIntrinsic} INTRINSIC; {$ENDC} {Multiple Paragraph Building Block for the Tool Kit} {changed 04/25/84 1437 Added TTextImage.TxtImgForClipBoard method} {changed 04/18/84 1652 Added firstLinePixel, useFirstPixel fields to TTextImage} {changed 04/16/84 1135 Added styleSheet field to TParaFormat} {changed 04/13/84 0209 Added TTextImage.NewEditPara} {changed 04/12/84 2344 Changed parameter list of TParagraph.UpdateRuns} {changed 04/10/84 1400 Changed TEditPara.images field back to a TList} INTERFACE {$DECL fUseUnivText} {$SETC fUseUnivText := TRUE} USES ${$U libtk/UObject} UObject, {$IFC LibraryVersion <= 20} ${$U UFont} UFont, {$ENDC} ${$U QuickDraw} QuickDraw, ${$U libtk/UDraw} UDraw, {$IFC fUseUnivText} ${$U libtk/UUnivText} UTKUniversalText, {$ENDC} ${$U UABC} UABC; {$DECL fTextTrace} {$SETC fTextTrace := fDbgOK} {$DECL fParaTrace} {$SETC fParaTrace := fDbgOK} {$DECL fRngText} {$SETC fRngText := fDbgOK} CONST $cVertMargin = 4; $cHorizMargin = 6; $somethingKind = 1; TYPE $TStyleChange = RECORD (lp: INTEGER; (newStyle: TTypeStyle; (END; $TTxtTabDescriptor = RECORD (xCoord: INTEGER; (quad: TAlignment; ({MORE LATER} (END; $TDrawAction = (actionDraw, actionInval, actionNone); { PARAGRAPH SUBCLASSES } $TParaFormat = SUBCLASS OF TObject (dfltTStyle: TTypeStyle; {default type style} (wordWrap: BOOLEAN; (quad: TAlignment; (firstIndent: INTEGER; (leftIndent: INTEGER; (rightIndent: INTEGER; (spaceAbovePara: INTEGER; (spaceBelowPara: INTEGER; (lineSpacing: INTEGER; (tabs: TArray; (refCount: INTEGER; {number of paragraphs referencing this paraFormat} (permanent: BOOLEAN; {TRUE -> don't free when refcount goes to zero} (styleSheet: TStyleSheet; {NIL if format not in a styleSheet} (FUNCTION TParaFormat.CREATE(object: TObject; heap: THeap; itsStyleSheet: TStyleSheet): TParaFormat; ({$IFC fParaTrace} (PROCEDURE TParaFormat.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} (PROCEDURE TParaFormat.SetTypeStyle(tStyle: TTypeStyle); (PROCEDURE TParaFormat.ChangeRefCountBy(delta: INTEGER); (END; $TParagraph = SUBCLASS OF TString (typeStyles: TArray; { of TStyleChange } &{Creation/Destruction} (FUNCTION TParagraph.CREATE(object: TObject; heap: THeap; HinitialSize: INTEGER; initialTypeStyle: TTypeStyle): TParagraph; (PROCEDURE TParagraph.Free; OVERRIDE; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TParagraph.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Overridden TString methods} (PROCEDURE TParagraph.Draw(i: LONGINT; howMany: INTEGER); OVERRIDE; (FUNCTION TParagraph.Width(i: LONGINT; howMany: INTEGER): INTEGER; OVERRIDE; &{This method is used by TParagraph.Draw and TParagraph.Width to interpret the typeStyles array} (PROCEDURE TParagraph.DrawLine(startLP, endLP: INTEGER; fDraw: BOOLEAN; fWidth: BOOLEAN; MVAR width: INTEGER; VAR styleIndex: INTEGER); &{Type Style Maintainence} (PROCEDURE TParagraph.ChangeStyle(startLP, endLP: INTEGER; PROCEDURE Change(VAR typeStyle: TTypeStyle); XVAR styleOfStartLP: TTypeStyle); ({These four routines all call ChangeStyle} (PROCEDURE TParagraph.ChgFace(startLP, endLP: INTEGER; HnewOnFaces: {$IFC LibraryVersion <= 20}TSeteface{$ELSEC}Style{$ENDC}; XVAR styleOfStartLP: TTypeStyle); (PROCEDURE TParagraph.ChgFontSize(startLP, endLP: INTEGER; newFontSize: Byte; XVAR styleOfStartLP: TTypeStyle); (PROCEDURE TParagraph.ChgFontFamily(startLP, endLP: INTEGER; newFontFamily: Byte; XVAR styleOfStartLP: TTypeStyle); (PROCEDURE TParagraph.NewStyle(startLP, endLP: INTEGER; newTypeStyle: TTypeStyle); (PROCEDURE TParagraph.CleanRuns; (PROCEDURE TParagraph.UpdateRuns(atLP: INTEGER; replacedChars: INTEGER; insertedChars: INTEGER); &{Character Maintainence} (PROCEDURE TParagraph.ReplPara(fPos, numChars: INTEGER; LotherPara: TParagraph; otherFPos, otherNumChars: INTEGER); (PROCEDURE TParagraph.ReplTString(fPos, numChars: INTEGER; LotherString: TString; otherFPos, otherNumChars: INTEGER); (PROCEDURE TParagraph.ReplPString(fPos, numChars: INTEGER; pStr: TPString); &{Utilities} &{BuildExtentLRect takes an LPoint that indicates the baseline of the paragraph. It returns 'in extentLRect the bounding rectangle whose height is based on the tallest font in the 'paragraph and width is the width of the characters in the paragraph. Specifically: 8top := baseLPt.v - tallestFontInfo.ascent; 8bottom := baseLPt.v + tallestFontInfo.descent + tallestFontInfo.leading; 8left := baseLPt.h; 8right := baseLpt.h + paragraph.Width;} (PROCEDURE TParagraph.BuildExtentLRect(baseLPt: LPoint; VAR extentLRect: LRect); (FUNCTION TParagraph.FixLP(LP: INTEGER): INTEGER; (PROCEDURE TParagraph.SetTypeStyle(tStyle: TTypeStyle); (PROCEDURE TParagraph.StyleAt(lp: INTEGER; VAR typeStyle: TTypeStyle); &{Word Selection} (PROCEDURE TParagraph.FindWordBounds(orig: INTEGER; VAR first, last: INTEGER); (FUNCTION TParagraph.Qualifies(pos: INTEGER): BOOLEAN; (END; #{Editable Paragraph} $TEditPara = SUBCLASS OF TParagraph &{ character stuff } (bsCount: INTEGER; &{ formatting stuff } (nestLevel: INTEGER; (format: TParaFormat; &{ paraImage stuff } (beingFiltered: BOOLEAN; { TRUE when a type style command has just been Fperformed on this paragraph} ((* (maxImage: INTEGER; (numImages: INTEGER; (images: ARRAY [1..1] OF TParaImage; {THIS MUST BE LAST FIELD !} (*) (images: TList; { Users may subclass TEditPara } &{Creation/Destruction} (FUNCTION TEditPara.CREATE(object: TObject; heap: THeap; initialSize: INTEGER; HitsFormat: TParaFormat): TEditPara; (PROCEDURE TEditPara.Free; OVERRIDE; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TEditPara.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Special Editing} (PROCEDURE TEditPara.BeginInsertion(atLP: INTEGER; size:INTEGER); (PROCEDURE TEditPara.EndInsertion; (FUNCTION TEditPara.GrowSize: INTEGER; (PROCEDURE TEditPara.InsertOneChar(ch: CHAR; atLP: INTEGER); &{Utility} (PROCEDURE TEditPara.SetTypeStyle(tStyle: TTypeStyle); OVERRIDE; &{ParaImage Maintenance} (PROCEDURE TEditPara.EachImage(PROCEDURE ImageProc(paraImage: TParaImage)); (PROCEDURE TEditPara.DelImage(delImage: TParaImage; fFree: BOOLEAN); (PROCEDURE TEditPara.InsImage(paraImage: TParaImage); (PROCEDURE TEditPara.DelImgIF(FUNCTION ShouldDelete(paraImage: TParaImage): BOOLEAN); (END; $TLineInfo = SUBCLASS OF TObject (valid: BOOLEAN; (startLP: INTEGER; (lastDrawnLP: INTEGER; {last character in line to draw: may omit trailing spaces} (endLP: INTEGER; {last character in line: equals next lineInfo.startLP - 1} (lineLRect: LRect; (lineAscent: INTEGER; (FUNCTION TLineInfo.CREATE(object: TObject; heap: THeap): TLineInfo; ({$IFC fParaTrace} (PROCEDURE TLineInfo.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Used by subclassers who don't like the way the hilite/update 'rectangle is chosen so they can overrride it} (FUNCTION TLineInfo.LeftCoord(proposedLeftPixel: LONGINT): LONGINT; (FUNCTION TLineInfo.RightCoord(proposedRightPixel: LONGINT): LONGINT; (END; $TParaImage = SUBCLASS OF TImage (paragraph: TEditPara; (height: INTEGER; { pixel height of the paragraph} (lineList: TList; { of TLineInfo} (changed: BOOLEAN; (tickCount: INTEGER; { incremented (mod MAXINT) every time image is drawn } (startLP: INTEGER; (endLP: INTEGER; { while drawing, this is the LP of the beginning of the next line Fwhich, when drawing is finished, may be in another image if the Fparagraph is split } (textImage: TTextImage; { the textImage that this image belongs to } (wasOffset: BOOLEAN; { used by Building block to determine when to invalidate} &{Creation} (FUNCTION TParaImage.CREATE(object: TObject; heap: THeap; itsView: TView; HitsParagraph: TEditPara; itsLRect: LRect; HlineTop: LONGINT; lineLeft: LONGINT): TParaImage; (PROCEDURE TParaImage.Free; OVERRIDE; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TParaImage.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Routines} (PROCEDURE TParaImage.ComputeLineInfo(curLine: TLineInfo; maxLineLen: INTEGER; PVAR nextLP: INTEGER; VAR lRectNeeded: LRect); (FUNCTION TParaImage.DfltLineInfo(lineTop: LONGINT; lineLeft: LONGINT): TLineInfo; (PROCEDURE TParaImage.DrawLine(startLP: INTEGER; fDraw: BOOLEAN; LstopWidth, wrapWidth: INTEGER; LVAR lineWidth, lastToDraw, endLP: INTEGER); (PROCEDURE TParaImage.DrawParaImage(limitLRect: LRect; startLP: INTEGER; drawAction: TDrawAction; PinvalBits: BOOLEAN; VAR drawnLRect: LRect); (PROCEDURE TParaImage.Draw; OVERRIDE; (PROCEDURE TParaImage.FastDrawLine(startLP, endLP: INTEGER; fDraw: BOOLEAN; fWidth: BOOLEAN; MVAR width: INTEGER; VAR styleIndex: INTEGER); (FUNCTION TParaImage.GetFormat: TParaFormat; (PROCEDURE TParaImage.LineWithLPt(pt: LPoint; VAR lineIndex: INTEGER; VAR lineInfo: TLineInfo); (PROCEDURE TParaImage.LocateLP(LP: INTEGER; VAR lineIndex: INTEGER; VAR pixel: LONGINT); (FUNCTION TParaImage.LpWithLPt(pt: LPoint): INTEGER; (PROCEDURE TParaImage.OffSetBy(deltaLPt: LPoint); OVERRIDE; (FUNCTION TParaImage.ParaTextWidth(startLP, endLP: INTEGER): INTEGER; (PROCEDURE TParaImage.RedrawLines(startLine: INTEGER; endLine: INTEGER); (FUNCTION TParaImage.SeesSameAs(image: TImage): BOOLEAN; OVERRIDE; '{validation/invalidation procs} (PROCEDURE TParaImage.InvalLinesWith(startLP, endLP: INTEGER); (PROCEDURE TParaImage.AdjustLineLPs(atLP, deltaLP: INTEGER); (END; { MULTI-PARAGRAPH SUBCLASSES } $TStyleSheet = SUBCLASS OF TObject (formats: TList; {of TParaFormat} &{Creation} (FUNCTION TStyleSheet.CREATE(object: TObject; heap: THeap): TStyleSheet; (PROCEDURE TStyleSheet.Free; OVERRIDE; &{Installs Default paraFormat into formats list} (PROCEDURE TStyleSheet.InitDefault; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TStyleSheet.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} (END; $TTextRange = SUBCLASS OF TObject (firstPara: TEditPara; (firstIndex: LONGINT; (firstLP: INTEGER; (lastPara: TEditPara; (lastIndex: LONGINT; (lastLP: INTEGER; &{Creation} (FUNCTION TTextRange.CREATE(object: TObject; heap: THeap; HbeginPara: TEditPara; beginIndex: LONGINT; beginLP: INTEGER; HendPara: TEditPara; endIndex: LONGINT; endLP: INTEGER): TTextRange; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextRange.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{AdjustBy adjust the fields of TTextRange by the value of delta (where delta is in LPs)} (PROCEDURE TTextRange.AdjustBy(delta: INTEGER); (END; $TText = SUBCLASS OF TObject (paragraphs: TList; {of TEditPara } (styleSheet: TStyleSheet; (txtImgList: TList; {of TTextImages that point to this text; =IMPORTANT: If the multiple linked textImage feature is used as described in HTTextImage below, the application should only store the Hhead text image in this list. This list is intended for HtextImages that are viewing the same text object independently H(ie in different panels)} &{Creation/Freeing} (FUNCTION TText.CREATE(object: TObject; heap: THeap; itsStyleSheet: TStyleSheet): TText; ({DfltTextImage can be called after CREATE to create and return a single textImage. It also )creates one empty paragraph using the first paraFormat in SELF.styleSheet. It installs the )textImage in txtImgList and the paragraph in paragraphs. This routine calls )textImage.RecomputeImages to set up the first paraImage.} (FUNCTION TText.DfltTextImage(view: TView; imageLRect: LRect; imgIsGrowable: BOOLEAN): TTextImage; '{TText.Free frees all paragraphs that belong to this text object and all textImages that (reference this text object} (PROCEDURE TText.Free; OVERRIDE; (PROCEDURE TText.FreeSelf(freeParas: BOOLEAN); &{Debugging} ({$IFC fParaTrace} (PROCEDURE TText.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} '{Calls to textImage procs get routed through these} (PROCEDURE TText.ChangeSelInOtherPanels(textSelection: TTextSelection); (PROCEDURE TText.DelPara(delPara: TEditPara; fFree: BOOLEAN); (PROCEDURE TText.Draw; (PROCEDURE TText.HiliteRange(highTransit: THighTransit; textRange: TTextRange; wholePara: BOOLEAN); (PROCEDURE TText.HiliteParagraphs(highTransit: THighTransit; PstartIndex: LONGINT; startLP: INTEGER; PendIndex: LONGINT; endLP: INTEGER; wholePara: BOOLEAN); (PROCEDURE TText.InsParaAfter(existingPara: TEditPara; newPara: TEditPara); (PROCEDURE TText.Invalidate; (PROCEDURE TText.MarkChanged(textRange: TTextRange); (PROCEDURE TText.RecomputeImages; (FUNCTION TText.SelectAll(textImage: TTextImage): TTextSelection; (END; $TTextImage = SUBCLASS OF TImage (text: TText; {complete list of paragraphs} (imageList: TList; {paraImages for some range of paragraphs in text} (tickCount: INTEGER; (growsDynamically: BOOLEAN; {TRUE --> extentLRect bottom grows as more text entered; IFALSE -> text is truncated at last line that fits} (minHeight: INTEGER; {the minimum height to shrink (if growsDynamically=TRUE); Idefaults to height of original extentLRect} (formerBottom: LONGINT; {Used by Invalidate when the displayed paragraphs get shorter Iand text at end needs to be erased} (updateLRect: LRect; { " " " "} (firstLinePixel: LONGINT; {Used by Text BB to limit what gets erased on first update line} (useFirstPixel: BOOLEAN; ({ The following fields support multiple linked text images displaying a single text object, *where the text "flows" from one box to the next. APPLICATIONS ARE RESPONSIBLE FOR *MAINTAINING THESE FIELDS. This Building Block uses these fields for drawing, etc. *All text images in a chain should have growsDynamically set to FALSE (except possibly *for the last text image in a chain). *For applications that DO NOT use this feature, the fields will always be as follows: 0startLP = 0; 0endLP = LP of last character in last paragraph; (if growsDynamically = TRUE) :LP of last character that fit in extentLRect; (if growsDynamically = FALSE) 0prevTxtImg, nextTxtImg = NIL; 0headTxtImg = SELF; 0tailTxtImg = SELF; )} (firstIndex: LONGINT; {index of paragraph at SELF.imageList.First} (startLP: INTEGER; {startLP of paragraph at SELF.imageList.First} (endLP: INTEGER; {endLP of paragraph at SELF.imageList.Last} (prevTxtImg: TTextImage; { for linking textImages that display different parts of } (nextTxtImg: TTextImage; { the same text object. eg: columns} (headTxtImg: TTextImage; {points to first text image in this list} (tailTxtImg: TTextImage; {points to last text image in this list} &{Creation} (FUNCTION TTextImage.CREATE(object: TObject; heap: THeap; itsView: TView; HitsLRect: LRect; itsText: TText; isGrowable: BOOLEAN): TTextImage; ({TTextImage.Free frees all text images and their paraImages in the text image chain. )It does NOT free any paragraphs, text objects, or paraFormats. Call this only once )for each text image chain (NOT for each text image in the chain). Note that TText.Free )frees its textImages so calling this routine is not necessary in most cases} (PROCEDURE TTextImage.Free; OVERRIDE; ({TTextImage.FreeOneTextImage frees just one text image from the chain. It pays no attention )to links or whether this is the head text image. Maintenance of these fields must be )handled by the caller before calling this routine. Those who do not use linked text images )should always call TTextImage.Free above, NOT this routine} (PROCEDURE TTextImage.FreeOneTextImage; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextImage.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Drawing} (PROCEDURE TTextImage.Draw; OVERRIDE; (PROCEDURE TTextImage.DrawImages(fDraw: BOOLEAN); (PROCEDURE TTextImage.DrawOrInval(invalBits: BOOLEAN); (PROCEDURE TTextImage.HiliteText(highTransit: THighTransit; LstartIndex: LONGINT; startLP: INTEGER; LendIndex: LONGINT; endLP: INTEGER; wholePara: BOOLEAN); &{Locating} (PROCEDURE TTextImage.FindParaAndLp(LPt: LPoint; VAR paraImage: TParaImage; ZVAR paraIndex: LONGINT; VAR aLP: INTEGER); (FUNCTION TTextImage.FindTextImage(VAR mouseLPt: LPoint; VAR firstTxtImg: TTextImage): TTextImage; (FUNCTION TTextImage.ImageBottom: LONGINT; (PROCEDURE TTextImage.GetImageRange(firstIndex: LONGINT; VAR firstLP: INTEGER; MlastIndex: LONGINT; VAR lastLP: INTEGER; MVAR firstImage, lastImage: TParaImage); (FUNCTION TTextImage.ImageWith(paragraph: TEditPara; lp: INTEGER): TParaImage; (PROCEDURE TTextImage.MousePress(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TTextImage.OffsetBy(deltaLPt: LPoint); OVERRIDE; &{Image maintenence} (PROCEDURE TTextImage.AddImage(paraImage: TParaImage); (PROCEDURE TTextImage.DelImagesWith(delPara: TEditPara); (PROCEDURE TTextImage.InsertNewPara(existingPara, newPara: TEditPara); (PROCEDURE TTextImage.InvalAll; (PROCEDURE TTextImage.Invalidate; OVERRIDE; {Invalidate changed lineLRects in changed paraimages} (PROCEDURE TTextImage.MarkChanged(startIndex: LONGINT; startLP: INTEGER; LendIndex: LONGINT; endLP: INTEGER); (FUNCTION TTextImage.NewTextSelection(firstPara: TEditPara; firstIndex: LONGINT; firstLP: INTEGER; LlastPara: TEditPara; lastIndex: LONGINT; lastLP: INTEGER L): TTextSelection; (PROCEDURE TTextImage.RecomputeImages(drawAction: TDrawAction; invalBits: BOOLEAN); (PROCEDURE TTextImage.Resize(newExtent: LRect); OVERRIDE; (FUNCTION TTextImage.SeesSameAs(image: TImage): BOOLEAN; OVERRIDE; &{By default SetFirstIndex just sets firstIndex to 0, but subclassers may override this 'if they want the display to start from other than the first paragraph} (PROCEDURE TTextImage.SetFirstIndex; ({These routines are provided so that users can subclass the appropriate class and )then override these methods so that the building block will create the user's subclass )when generating new instances of that class. } (FUNCTION TTextImage.NewEditPara(initialSize: INTEGER; itsFormat: TParaFormat): TEditPara; (FUNCTION TTextImage.NewParaImage(itsParagraph: TEditPara; itsLRect: LRect; HlineTop: LONGINT; lineLeft: LONGINT): TParaImage; (FUNCTION TTextImage.NewTextImage(heap: THeap; itsView: TView; itsLRect: LRect; PitsText:TText; isGrowable: BOOLEAN): TTextImage; (FUNCTION TTextImage.TxtImgForClipBoard(heap: THeap; itsView: TView; itsLRect: LRect; PitsText:TText; isGrowable: BOOLEAN): TTextImage; (END; ${Clipboard Text View} $TTextView = SUBCLASS OF TView (textImage: TTextImage; (valid: BOOLEAN; {If FALSE, calls Recompute before Drawing} &{Creation} (FUNCTION TTextView.CREATE(object: TObject; heap: THeap; itsPanel: TPanel; itsExtent: LRect) B: TTextView; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextView.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} ({$IFC fUseUnivText} (PROCEDURE TTextView.CreateUniversalText; OVERRIDE; ({$ENDC} (PROCEDURE TTextView.Draw; OVERRIDE; (PROCEDURE TTextView.MousePress(mouseLPt: LPoint); OVERRIDE; (END; ${$IFC fUseUnivText} $TTextWriteUnivText = SUBCLASS OF TTKWriteUnivText (textSelection: TTextSelection; (currIndex: LONGINT; (currPara: TEditPara; (currLP: INTEGER; (currStyleIndex: INTEGER; (currTStyles: TArray; &{Creation} (FUNCTION TTextWriteUnivText.CREATE(object: TObject; heap: THeap; PitsString: TString; itsDataSize: INTEGER; PitsTextSel: TTextSelection): TTextWriteUnivText; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextWriteUnivText.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} (PROCEDURE TTextWriteUnivText.FillParagraph; OVERRIDE; (END; ${$ENDC} $TTextSelection = SUBCLASS OF TSelection (textImage: TTextImage; (textRange: TTextRange; (isWordSelection: BOOLEAN; (isParaSelection: BOOLEAN; (viewTick: INTEGER; (amTyping: BOOLEAN; (currTypeStyle: TTypeStyle; (FUNCTION TTextSelection.CREATE(object: TObject; heap: THeap; itsView: TView; LitsTextImage: TTextImage; itsAnchorLPt: LPoint; LbeginPara: TEditPara; beginIndex: LONGINT; beginLP: INTEGER; LendPara: TEditPara; endIndex: LONGINT; endLP: INTEGER L): TTextSelection; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TTextSelection.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TTextSelection.KeyText; (FUNCTION TTextSelection.NewCommand(cmdNumber: TCmdNumber): TCommand; OVERRIDE; (FUNCTION TTextSelection.NewStyleCmd(heap: THeap; cmdNumber: TCmdNumber; DtextImage: TTextImage): TCommand; (FUNCTION TTextSelection.NewCutCopyCmd(heap: THeap; cmdNumber: TCmdNumber; DtextImage: TTextImage): TCommand; DEFAULT; (PROCEDURE TTextSelection.StyleFromContext; DEFAULT; (PROCEDURE TTextSelection.DoChangeStyle(cmdNumber: TCmdNumber; paragraph: TParagraph; HfirstLP: INTEGER; lastLP: INTEGER; VAR newStyle: TTypeStyle); (PROCEDURE TTextSelection.ChangeStyle(cmdNumber: TCmdNumber); DEFAULT; &{Editing} (PROCEDURE TTextSelection.ChangeText(PROCEDURE TextEdit; PROCEDURE Adjust); DEFAULT; (FUNCTION TTextSelection.CopySelf(heap: THeap; view: TView): TMultiParaSelection; DEFAULT; (PROCEDURE TTextSelection.CutCopy(clipSelection: TSelection; deleteOriginal: BOOLEAN); DEFAULT; (PROCEDURE TTextSelection.DeleteAndFree; DEFAULT; (FUNCTION TTextSelection.DeleteButSave: TText; DEFAULT; &{Highlighting} (PROCEDURE TTextSelection.Highlight(highTransit: THighTransit); OVERRIDE; &{Selecting} (FUNCTION TTextSelection.BecomeInsertionPoint: TInsertionPoint; (PROCEDURE TTextSelection.GetHysteresis(VAR hysterPt: Point); OVERRIDE; (PROCEDURE TTextSelection.MousePress(mouseLPt: LPoint); OVERRIDE; (FUNCTION TTextSelection.SelSize: INTEGER; ABSTRACT; &{Invalidation} (PROCEDURE TTextSelection.Invalidate; DEFAULT; &{Generate Text Selection in another panel (ie. another Text Image)} (FUNCTION TTextSelection.ReplicateForOtherPanel(itsTextImage: TTextImage): TTextSelection; (END; $TInsertionPoint = SUBCLASS OF TTextSelection (typingCmd: TTypingCmd; {the current typing command (if user is typing)} (styleCmdNumber: INTEGER; {Set to cmdNumber when a type style item is chosen, Pset to zero otherwise} (newestLP: INTEGER; {the lp position as updated between KeyPause's} (justReturned: BOOLEAN; {flag that prevents redundant update in KeyPause} (nextHighTransit: THighTransit; (nextTransitTime: LONGINT; &{Creation/Freeing} (FUNCTION TInsertionPoint.CREATE(object: TObject; heap: THeap; itsView: TView; FitsTextImage: TTextImage; itsAnchorLPt: LPoint; itsParagraph: TEditPara; FitsIndex: LONGINT; itsLP: INTEGER): TInsertionPoint; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TInsertionPoint.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TInsertionPoint.IdleBegin(centiSeconds: LONGINT); OVERRIDE; (PROCEDURE TInsertionPoint.IdleContinue(centiSeconds: LONGINT); OVERRIDE; (PROCEDURE TInsertionPoint.IdleEnd(centiSeconds: LONGINT); OVERRIDE; (FUNCTION TInsertionPoint.NewCutCopyCmd(heap: THeap; cmdNumber: TCmdNumber; DtextImage: TTextImage): TCommand; OVERRIDE; (PROCEDURE TInsertionPoint.StyleFromContext; OVERRIDE; &{Editing} (PROCEDURE TInsertionPoint.CutCopy(clipSelection: TSelection; deleteOriginal: BOOLEAN); OVERRIDE; (PROCEDURE TInsertionPoint.FinishPaste(clipSelection: TSelection; pic: PicHandle); (PROCEDURE TInsertionPoint.InsertText(text: TText; isParaSelection: BOOLEAN; isWordSelection: BOOLEAN; tuniversalText: BOOLEAN); (PROCEDURE TInsertionPoint.KeyBack(fWord: BOOLEAN); OVERRIDE; (PROCEDURE TInsertionPoint.KeyChar(ch: CHAR); OVERRIDE; (PROCEDURE TInsertionPoint.KeyClear; OVERRIDE; (PROCEDURE TInsertionPoint.KeyForward(fWord: BOOLEAN); OVERRIDE; &{Selecting} (PROCEDURE TInsertionPoint.MouseMove(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TInsertionPoint.MousePress(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TInsertionPoint.MouseRelease; OVERRIDE; (END; $TOneParaSelection = SUBCLASS OF TTextSelection (anchorBegin: INTEGER; (anchorEnd: INTEGER; {anchorBegin <> anchorEnd iff double or triple click} &{Creation/Freeing} (FUNCTION TOneParaSelection.CREATE(object: TObject; heap: THeap; itsView: TView; EitsTextImage: TTextImage; itsAnchorLPt: LPoint; itsParagraph: TEditPara; EitsIndex: LONGINT; oldLP: INTEGER; currLP: INTEGER): TOneParaSelection; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TOneParaSelection.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TOneParaSelection.StyleFromContext; OVERRIDE; &{Editing} (FUNCTION TOneParaSelection.CopySelf(heap: THeap; view: TView): TMultiParaSelection; OVERRIDE; (PROCEDURE TOneParaSelection.DeleteAndFree; OVERRIDE; (FUNCTION TOneParaSelection.DeleteButSave: TText; OVERRIDE; &{Selecting} (PROCEDURE TOneParaSelection.MouseMove(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TOneParaSelection.MouseRelease; OVERRIDE; (END; $TMultiParaSelection = SUBCLASS OF TTextSelection (anchorPara: TEditPara; (anchorIndex: LONGINT; (anchorBegin: INTEGER; (anchorEnd: INTEGER; {anchorBegin <> anchorEnd iff double or triple click} &{Creation/Freeing} (FUNCTION TMultiParaSelection.CREATE(object: TObject; heap: THeap; itsView: TView; LitsTextImage: TTextImage; itsAnchorLPt: LPoint; LbeginPara: TEditPara; beginIndex: LONGINT; beginLP: INTEGER; LendPara: TEditPara; endIndex: LONGINT; endLP: INTEGER; LbeginIsAnchor: BOOLEAN): TMultiParaSelection; &{Debugging} ({$IFC fParaTrace} (PROCEDURE TMultiParaSelection.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Commands} (PROCEDURE TMultiParaSelection.StyleFromContext; OVERRIDE; &{Editing} (FUNCTION TMultiParaSelection.CopySelf(heap: THeap; view: TView): TMultiParaSelection; OVERRIDE; (FUNCTION TMultiParaSelection.Delete(saveIt: BOOLEAN): TText; (PROCEDURE TMultiParaSelection.DeleteAndFree; OVERRIDE; (FUNCTION TMultiParaSelection.DeleteButSave: TText; OVERRIDE; &{Selecting} (PROCEDURE TMultiParaSelection.MouseMove(mouseLPt: LPoint); OVERRIDE; (PROCEDURE TMultiParaSelection.MouseRelease; OVERRIDE; (END; 8{------------- COMMANDS -----------------} $TClearTextCmd = SUBCLASS OF TCommand &{Variables} (savedText: TText; {save the cleared text for undo} (text: TText; {the text object we are clearing} &{Creation} (FUNCTION {TClearTextCmd.}CREATE(object: TObject; heap: THeap; itsCmdNumber: TCmdNumber; IitsImage: TImage; itsText: TText): TClearTextCmd; (PROCEDURE TClearTextCmd.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TClearTextCmd.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TClearTextCmd.Commit; OVERRIDE; (PROCEDURE TClearTextCmd.Perform(cmdPhase: TCmdPhase); OVERRIDE; (END; $TStyleCmd = SUBCLASS OF TCommand &{Variables} (text: TText; (textSelection: TTextSelection; (firstFiltParaIndex: LONGINT; (lastFiltParaIndex: LONGINT; (filtFirstLP: INTEGER; (filtLastLP: INTEGER; (currFilteredPara: TEditPara; {handle to most recently filtered paragraph} (filteredStyles: TArray; {changed type styles of most recently filtered paragraph} &{Creation} (FUNCTION TStyleCmd.CREATE(object: TObject; heap: THeap; itsCmdNumber: TCmdNumber; @itsImage: TImage; @itsFirstIndex: LONGINT; itsLastIndex: LONGINT; @itsLPFirst: INTEGER; itsLPLast: INTEGER; @itsSelection: TTextSelection): TStyleCmd; (PROCEDURE TStyleCmd.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TStyleCmd.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TStyleCmd.Commit; OVERRIDE; (PROCEDURE TStyleCmd.FilterAndDo(actualObject: TObject; HPROCEDURE DoToObject(filteredObject: TObject)); OVERRIDE; (PROCEDURE TStyleCmd.Perform(cmdPhase: TCmdPhase); OVERRIDE; (END; $TTextCutCopy = SUBCLASS OF TCutCopyCommand &{Variables} (text: TText; &{Creation} (FUNCTION TTextCutCopy.CREATE(object: TObject; heap: THeap; itsCmdNumber: TCmdNumber; EitsImage: TImage; DisCutCmd: BOOLEAN; itsText: TText): TTextCutCopy; (PROCEDURE TTextCutCopy.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TTextCutCopy.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TTextCutCopy.DoCutCopy(clipSelection: TSelection; deleteOriginal: BOOLEAN; LcmdPhase: TCmdPhase); OVERRIDE; (END; $TTextPaste = SUBCLASS OF TPasteCommand &{Variables} (savedText: TText; (pasteRange: TTextRange; {The text range spanned by the pasted text} (text: TText; (origIsPara: BOOLEAN; (origIsWord: BOOLEAN; (clipIsPara: BOOLEAN; &{Creation} (FUNCTION TTextPaste.CREATE(object: TObject; heap: THeap; itsImage: TImage; FitsText: TText): TTextPaste; (PROCEDURE TTextPaste.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TTextPaste.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TTextPaste.Commit; OVERRIDE; (PROCEDURE TTextPaste.DoPaste(clipSelection: TSelection; pic: PicHandle; cmdPhase: TCmdPhase); |OVERRIDE; (END; $TTypingCmd = SUBCLASS OF TCommand &{Variables} (savedText: TText; (text: TText; (newCharCount: INTEGER; (newParaCount: INTEGER; (typingRange: TTextRange; {The text range spanned by the typed characters} (otherInsPts: TList; &{Creation} (FUNCTION TTypingCmd.CREATE(object: TObject; heap: THeap; itsImage: TImage; FitsText: TText): TTypingCmd; (PROCEDURE TTypingCmd.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TTypingCmd.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TTypingCmd.Commit; OVERRIDE; (PROCEDURE TTypingCmd.Perform(cmdPhase: TCmdPhase); OVERRIDE; (END; VAR fParaTrace: BOOLEAN; $fTextTrace: BOOLEAN; IMPLEMENTATION (* {$I UTEXT2.text} {Paragraph classes} {$I UTEXT3.text} {TStyleSheet, TText, TTextImage, TTextView} {$I UTEXT4.text} {Text Selections and Commands} *) {$I LibTK/UTEXT2.text} {Paragraph classes} {$I LibTK/UTEXT3.text} {TStyleSheet, TText, TTextImage, TTextView} {$I LibTK/UTEXT4.text} {Text Selections and Commands} END. EitsImage: TImage; DisCutCmd: BOOLEAN; itsText: TText): TTextCutCopy; (PROCEDURE TTextCutCopy.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TTextCutCopy.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TTextCutCopy.DoCutCopy(clipSelection: TSelection; deleteOriginal: BOOLEAN; LcmdPhase: TCmdPhase); OVERRIDE; (END; $TTextPaste = SUBCLASS OF TPasteCommand &{Variables} (savedText: TText; (pasteRange: TTextRange; {The text range spanned by the pasted text} (text: TText; (origIsPara: BOOLEAN; (origIsWord: BOOLEAN; (clipIsPara: BOOLEAN; &{Creation} (FUNCTION TTextPaste.CREATE(object: TObject; heap: THeap; itsImage: TImage; FitsText: TText): TTextPaste; (PROCEDURE TTextPaste.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TTextPaste.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TTextPaste.Commit; OVERRIDE; (PROCEDURE TTextPaste.DoPaste(clipSelection: TSelection; pic: PicHandle; cmdPhase: TCmdPhase); |OVERRIDE; (END; $TTypingCmd = SUBCLASS OF TCommand &{Variables} (savedText: TText; (text: TText; (newCharCount: INTEGER; (newParaCount: INTEGER; (typingRange: TTextRange; {The text range spanned by the typed characters} (otherInsPts: TList; &{Creation} (FUNCTION TTypingCmd.CREATE(object: TObject; heap: THeap; itsImage: TImage; FitsText: TText): TTypingCmd; (PROCEDURE TTypingCmd.Free; OVERRIDE; ({$IFC fParaTrace} (PROCEDURE TTypingCmd.Fields(PROCEDURE Field(nameAndType: S255)); OVERRIDE; ({$ENDC} &{Command Execution} (PROCEDURE TTypingCmd.Commit; OVERRIDE; (PROCEDURE TTypingCmd.Perform(cmdPhase: TCmdPhase); OVERRIDE; (END; VAR fParaTrace: BOOLEAN; $fTextTrace: BOOLEAN; IMPLEMENTATION (* {$I UTEXT2.text} {Paragraph classes} {$I UTEXT3.text} {TStyleSheet, TText, TTextImage, TTextView} {$I UTEXT4.text} {Text Selections and Commands} *) {$I LibTK/UTEXT2.text} {Paragraph classes} {$I LibTK/UTEXT3.text} {TStyleSheet, TText, TTextImage, TTextView} {$I LibTK/UTEXT4.text} {Text Selections and Commands} END. $$$$$$$$$$ $ $ $ $ $$$$$$$$$$$$$ O 9999                  ! "  #! $" %# &$ '% (& )' *( +) ,* -+ ., /- 0. 1/ 20 !31 "42 #53 $64 %75 &86 '97 (:8 );9 *<: +=; ,>< -?= .@> /A? 0B@ 1CA 2DB 3EC 4FD 5GE 6HF 7IG 8JH 9KI :LJ ;KNOMPNQORPSQTRUSVT WU XV YW ZX [Y\Z][^\_]`^a_b`cadbecfdgehfigjhkiljmk nl!om"pn#qo$rp%sq&tr'us(vt)wu*xv+yw,zx-{y.|z/}{0~|1}2~3456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghi      !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQ R S O       !" #!$"%#&$'%(&)'*(+),*-+.,/- 0.!1/"20#31$42%53&64'75(86)97*:8+;9,<:-=;.></?=0@>1A?2B@3CA4DB5EC6FD7GE8HF9IG:JH;KINL?OM@PNAQOBRPCSQDTREUSFVTGWUHXVIYWJZXK[YL\ZM][N^\O_]P`^Qa_Rb`ScaTdbUecVfdWgeXhfYigZjh[ki\lj]mk^nl_om`pnaqobrpcsqdtreusfvtgwuhxviywjzxky|}{~|}~      !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~                                  ! " #! $" %# &$ !'% "(& #)' $*( %+) &,* '-+ (., )/- *0. +1/ ,20 -31 .42 /53 064 175 286 397 4:8 5;9 6<: 7=; 8>< 9?= :@> ;A? DB ?EC @FD AGE BHF CIG DJH EKI FLJ GMK HNL IOM JPN KQO LRP MSQ NTR OUS PVT QWU RXV SYW TZX U[Y V\Z W][ X^\ Y_] Z`^ [a_ \b` ]ca ^db _ec `fd age bhf cig djh eki flj gmk hnl iom jpn kqo lrp msq ntr ous pvt qwu rxv syw tzx u{y v|z w}{ x~| y} z~ { | } ~                                                         ! " # $ % & ' ( ) * + , - . / 0 1 2 3 4 5 6 7 8 9 : ; < = > ? @ A <L = > ? @ A