Listing: 1 (*======================================================== 2 == TopSpeed Modula-2 V3.10 == 3 == demo program: == 4 == == 5 == TSR Shell == 6 == == 7 == Installs a "safe" Pop Up program == 8 == == 9 ========================================================*) 10 (*# check(stack=>off,index=>off,range=>off,overflow=>off,nil_ptr=>off) *) 11 (*# debug(vid=>off)*) 12 13 IMPLEMENTATION MODULE TSR ; 14 (* === *) 15 16 17 IMPORT IO,Window,Lib,Storage,Str,SYSTEM,TSRLow; 18 19 CONST 20 KBFuseful = KBFlagSet { RShift, LShift, Ctrl, Alt } ; ***** ^ undeclared identifier 21 TYPE 22 TSRmodeType = (Sleeping,Wake,Active,Kill,Dead ) ; 23 VAR 24 (*# save, data(volatile=>on) *) 25 ProgDTA : ADDRESS ; 26 ProgPSP : CARDINAL ; 27 ActivateScan : SHORTCARD ; 28 ActivateFlags : KBFlagSet ; 29 KBFlags[40H:17H] : KBFlagSet ; 30 TSRproc : PROC ; 31 DosNest : POINTER TO SHORTCARD ; 32 TSRmode : TSRmodeType ; 33 MainProcess : SYSTEM.PROCESS; 34 35 (*# restore *) 36 37 38 PROCEDURE SwapToTSR ; 39 VAR 40 op,np : SYSTEM.PROCESS ; 41 BEGIN 42 TSRmode := Active ; 43 np := MainProcess ; 44 SYSTEM.TRANSFER(op,np) ; (* can't use IOTRANSFER due to chaining problems 45 with other TSRs (SideKick 1, for example) *) 46 TSRmode := Sleeping ; 47 END SwapToTSR ; 48 49 50 (* Interrupt Handlers *) 51 (* ================== *) 52 53 (* pragmas for interrupt handler *) 54 (*# save, 55 call(interrupt => on, 56 reg_param => (), 57 same_ds => off 58 ) 59 *) 60 61 TYPE 62 IPROC = PROCEDURE(); 63 VAR 64 Irpt[0:0], (* Interrupt table *) 65 SaveIrpt : ARRAY [0..255] OF IPROC ; 66 67 68 PROCEDURE NullInt () ; (* Do nothing interrupt *) 69 BEGIN 70 END NullInt; 71 72 PROCEDURE Int9 () ; (* Keyboard H/W interrupt *) 73 VAR 74 sc : SHORTCARD ; 75 BEGIN 76 sc := SYSTEM.In(60H) ; 77 IF ((sc=ActivateScan)OR(ActivateScan=0))AND 78 ((KBFlags*KBFuseful)=ActivateFlags) THEN 79 sc := SYSTEM.In(61H) ; 80 SYSTEM.Out(61H,SHORTCARD(BITSET(sc)+{7})); 81 SYSTEM.Out(61H,sc); 82 SYSTEM.Out(20H,20H); 83 IF TSRmode=Sleeping THEN 84 TSRmode := Wake ; 85 END ; 86 ELSE 87 SaveIrpt[09H]() ; (* Chain Int 28 *) 88 END ; 89 END Int9 ; 90 91 VAR 92 Save28stack : ARRAY[0..3FFH] OF BYTE ; 93 94 PROCEDURE Int28 () ; (* DOS "I'm not doing much" interrupt *) 95 VAR 96 base : CARDINAL ; 97 BEGIN 98 Lib.Move(ADR(base),ADR(Save28stack),SIZE(Save28stack)); 99 SaveIrpt[28H]() ; (* Chain Int 28 *) 100 IF (Ofs(base)>100H) AND (TSRmode=Wake) THEN 101 SwapToTSR ; 102 END ; 103 Lib.Move(ADR(Save28stack),ADR(base),SIZE(Save28stack)); 104 END Int28 ; 105 106 107 PROCEDURE Int1C () ; (* Timer Interrupt *) 108 VAR 109 base : CARDINAL ; 110 BEGIN 111 SaveIrpt[1CH]() ; (* Chain Int 1C *) 112 IF (Ofs(base)>100H)AND(DosNest^ = 0)AND(TSRmode=Wake) THEN 113 SYSTEM.Out(20H,20H) ; (* Send EOI to timer *) 114 SwapToTSR ; 115 END ; 116 END Int1C ; 117 118 PROCEDURE Int24 () : CARDINAL ; (* Critical Error Interrupt *) 119 BEGIN 120 RETURN 0 ; 121 END Int24; 122 123 (*# restore *) 124 125 PROCEDURE SetIrpt ( N : CARDINAL ; P : IPROC ) ; 126 VAR 127 fl : CARDINAL ; 128 BEGIN 129 fl := SYSTEM.GetFlags() ; SYSTEM.DI ; 130 SaveIrpt[N] := Irpt[N] ; 131 Irpt[N] := P ; 132 SYSTEM.SetFlags(fl) ; 133 END SetIrpt ; 134 135 PROCEDURE ResetIrpt ( N : CARDINAL ) ; 136 VAR 137 fl : CARDINAL ; 138 BEGIN 139 fl := SYSTEM.GetFlags() ; SYSTEM.DI ; 140 Irpt[N] := SaveIrpt[N] ; 141 SYSTEM.SetFlags(fl) ; 142 END ResetIrpt ; 143 144 145 146 PROCEDURE Resident; 147 (* ======== *) 148 149 VAR I,F : CARDINAL; 150 R : SYSTEM.Registers; 151 SaveDTA : ADDRESS ; 152 SavePSP : CARDINAL ; 153 SaveBrk : SHORTCARD ; 154 BEGIN 155 (* Set Critical Error Handler and break handlers *) 156 SetIrpt(24H,IPROC(Int24)) ; 157 SetIrpt(1BH,NullInt); 158 SetIrpt(23H,NullInt); 159 (* Change DTA *) 160 R.AH := 2FH ; 161 Lib.Dos(R) ; 162 SaveDTA := [R.ES:R.BX] ; 163 R.AH := 1AH ; 164 R.DS := Seg(ProgDTA^) ; 165 R.DX := Ofs(ProgDTA^) ; 166 Lib.Dos(R) ; 167 (* Change PSP *) 168 R.AX := 5100H ; 169 Lib.Dos(R) ; 170 SavePSP := R.BX ; 171 R.BX := ProgPSP ; 172 R.AX := 5000H ; 173 Lib.Dos(R) ; 174 (* Turn off break flag *) 175 R.AX := 3300H ; 176 Lib.Dos(R) ; 177 SaveBrk := R.DL ; 178 R.DL := 0 ; 179 R.AX := 3301H ; 180 Lib.Dos(R) ; 181 R.AH := 3; 182 R.BH := 0; 183 Lib.Intr(R,010H); 184 Window.Use(Window.FullScreen); 185 Window.CursorOff; 186 Window.SnapShot; 187 TSRproc() ; 188 R.AH := 0DH ; 189 Lib.Dos(R) ; 190 Window.Use(Window.FullScreen); 191 Window.CursorOn; 192 R.AH := 2; 193 R.BH := 0; 194 Lib.Intr(R,010H); 195 196 (* Restore break flag *) 197 R.DL := SaveBrk ; 198 R.AX := 3301H ; 199 Lib.Dos(R) ; 200 (* Restore PSP *) 201 R.BX := SavePSP ; 202 R.AX := 5000H ; 203 Lib.Dos(R) ; 204 (* Restore DTA *) 205 R.AH := 1AH ; 206 R.DS := Seg(SaveDTA^) ; 207 R.DX := Ofs(SaveDTA^) ; 208 Lib.Dos(R) ; 209 (* Restore Critical irpt and break handlers *) 210 ResetIrpt(24H); 211 ResetIrpt(1BH); 212 ResetIrpt(23H); 213 END Resident; 214 215 VAR 216 HeapSize : CARDINAL ; 217 PROCEDURE TermProc ; 218 VAR 219 R : SYSTEM.Registers ; 220 psize : CARDINAL; 221 BEGIN 222 psize := TSRLow.ShrinkHeap(HeapSize); 223 R.AX := 03100H; (*Terminate and stay resident*) 224 R.DX := psize ; 225 Lib.Intr(R,21H); (* Use Intr, so as not to trigger the 226 Dos re-entry run-time check *) 227 (* No Return *) 228 END TermProc ; 229 230 231 PROCEDURE SKinstalled () : BOOLEAN ; 232 TYPE 233 AP = POINTER TO ADDRESS ; 234 VAR 235 id1 : POINTER TO LONGCARD ; 236 id2 : POINTER TO CARDINAL ; 237 BEGIN 238 id1 := Lib.SubAddr([0:8*4 AP]^,4) ; 239 id2 := Lib.SubAddr([0:25H*4 AP]^,2) ; 240 RETURN (id1^=049424B53H)OR(id2^=04B53H) ; 241 END SKinstalled ; 242 243 PROCEDURE InEnv() : BOOLEAN ; 244 TYPE Str5 = ARRAY[0..4] OF CHAR; 245 IDP = POINTER TO Str5; 246 AP = POINTER TO ADDRESS ; 247 CONST EnvId = 'TSENV'; 248 VAR id1 : IDP; 249 BEGIN 250 id1 := Lib.SubAddr([0:4*4 AP]^,8) ; 251 RETURN id1^=Str5(EnvId); 252 END InEnv; 253 254 255 256 PROCEDURE Install ( P : PROC ; (* Procedure to be invoked *) 257 KBF : KBFlagSet; (* Shift state to invoke *) 258 Scan : SHORTCARD ; (* Invoking scancode (0=All) *) 259 heapsize : CARDINAL (* Minimum heap required *) 260 ) ; 261 VAR 262 hp,nhp : Storage.HeapRecPtr ; 263 R : SYSTEM.Registers ; 264 stack : ARRAY[0..1023] OF BYTE ; 265 termp : SYSTEM.PROCESS ; 266 267 BEGIN 268 IF InEnv() THEN 269 Lib.FatalError('Failed to install TSR: should be installed outside the TopSpeed Environment'); 270 END ; 271 IF SKinstalled() THEN 272 Lib.FatalError('Failed to install TSR: should be installed BEFORE SideKick '); 273 END ; 274 ActivateScan := Scan ; 275 ActivateFlags := KBF ; 276 TSRproc := P ; 277 278 R.AH := 52 ; 279 Lib.Dos(R) ; 280 DosNest := [R.ES:R.BX] ; (* Dos nesting count *) 281 R.AH := 2FH ; 282 Lib.Dos(R) ; 283 ProgDTA := [R.ES:R.BX] ; (* Current DTA *) 284 R.AX := 5100H ; 285 Lib.Dos(R) ; 286 ProgPSP := R.BX ; (* Current PSP *) 287 288 (* Install Interrupt handlers *) 289 SetIrpt(09H,Int9); 290 SetIrpt(1CH,Int1C); 291 SetIrpt(28H,Int28); 292 SYSTEM.NEWPROCESS( TermProc, ADR(stack), SIZE(stack) , termp ); 293 HeapSize := heapsize ; 294 TSRmode := Sleeping ; 295 REPEAT 296 SYSTEM.TRANSFER(MainProcess,termp) ; 297 Resident ; 298 UNTIL TSRmode = Dead ; 299 END Install ; 300 301 PROCEDURE DeInstall ; 302 TYPE 303 BP = POINTER TO SHORTCARD ; 304 CP = POINTER TO CARDINAL ; 305 VAR 306 s : CARDINAL ; 307 R : SYSTEM.Registers ; 308 BEGIN 309 IF TSRmode<>Dead THEN 310 TSRmode := Dead ; 311 ResetIrpt(09H); 312 ResetIrpt(1CH); 313 ResetIrpt(28H); 314 R.AH := 52H ; 315 Lib.Dos(R); 316 s := [R.ES:R.BX-2 CP]^; 317 WHILE [s:0 BP]^ = 4DH DO 318 IF [s:1 CP]^ = ProgPSP THEN 319 R.AH := 49H ; 320 R.ES := s+1 ; 321 Lib.Dos(R) ; 322 END ; 323 INC(s,[s:3 CP]^+1); 324 END ; 325 END ; 326 END DeInstall ; 327 328 VAR 329 Continue : PROC ; 330 331 PROCEDURE Closedown ; 332 BEGIN 333 DeInstall ; 334 Continue() ; 335 END Closedown ; 336 337 338 BEGIN 339 TSRmode := Dead ; 340 Lib.Terminate(Closedown,Continue) ; 341 END TSR. 342 343 (*======================================================*) 344 1 error