Package Error

Uses KbdCRT

Interface

\ Fonctions de branchement \
Type
    Func is Pointer

Sub CallProcWord(Func as Pointer,W as Word)
Sub CallProcString(Func as Pointer,S as String)

Type
    Record JumpBuf is
      DS,SS as Word
      BP,BPOld as Word
      CS,IP as Word
    End

Def SetJump(J as @JumpBuf) as Word
Sub LongJump(J as @JumpBuf,RetCode as Word)

Type
    ErrorHandler1 is Func

\ Fonctions de sortie \
Var
   NbCarriages as Word
   More as Boolean

Sub WaitingForAKey
Sub WriteCarriage

\ Fonction Error \
Var
   NbCR as Word
   WaitOnError as Boolean
   ErrorReturnInitialized as Boolean
   ErrorReturn as JumpBuf
   ErrorMessage as Array[0..&HFF] Of Byte

Sub Error(S as String)

\ Maniement des vecteurs d'it \
Sub GetIntVec(No as Byte,F as @Func)
Sub SetIntVec(No as Byte,F as Func)

\ Keyboard ctrl \
Var
   CBreakReturn as JumpBuf
   IgnoreCBreak as Boolean

Sub GetCBreakControl
Sub RestoreCBreakControl

Implementation

\\\ Fonctions de branchement :: ATTENTION : ces fonctions
    doivent tjrs ˆtre appel‚es de l'EXTERIEUR du module,
    … cause de la lecture de DSOld dans la pile.
    En cas d'appel depuis l'int‚rieur de ce module, comme
    ds le handler kbd, f.e., il faut encadrer les appels
    … SetJmp et LongJmp par PUSH DS et POP DS (Pas besoin
    du POP DS pour LongJmp).
\\\
\$F+\
Def SetJump(J as @JumpBuf) as Word
Var
   rDS,rSS,rBP,BPOld,rCS,rIP as Word
Enter
\ Lecture registres \
\ MOV rDS,[BP+&HA] \
  InLine(&H8B,&H7E,&HA)
  rDS=DI
\ SS, BP \
  rSS=SS:rBP=BP
\ MOV BPOld,[BP] \
  InLine(&H8B,&H46,&H0)
  InLine(&H89,&H86,BPOld)
\ MOV rCS,[BP+4] \
  InLine(&H8B,&H7E,&H4)
  rCS=DI
\ MOV rIP,[BP+2] \
  InLine(&H8B,&H46,&H2)
  InLine(&H89,&H86,rIP)
\ Set J \
  J.DS=rDS:J.SS=rSS
  J.BP=rBP:J.BPOld=BPOld
  J.CS=rCS:J.IP=rIP
\ Resu \
  Result=0
Leave

Sub LongJump(J as @JumpBuf,RetCode as Word)
Var
   rDS,rSS,rBP,BPOld,rCS,rIP as Word
Enter
\ Set rVAR \
  rDS=J.DS:rSS=J.SS
  rBP=J.BP:BPOld=J.BPOld
  rCS=J.CS:rIP=J.IP
\ RetCode \
  If RetCode=0 Then RetCode=1;
\ MOV AX,RetCode \
  InLine(&H8B,&H86,RetCode)
\ MOV DX,J.DS \
  InLine &HCC
  DX=rDS
\ MOV SI,J.IP \
  InLine(&H8B,&HB6,rIP)
\ MOV DI,J.CS \
  InLine(&H8B,&HBE,rCS)
\ MOV BX,J.SS \
  InLine(&H8B,&H9E,rSS)
\ MOV CX,J.BPOld \
  InLine(&H8B,&H8E,BPOld)
\ MOV BP,J.BP \
  InLine(&H8B,&HAE,rBP)
\ MOV SS,BX \
  InLine(&H8E,&HD3)
\ MOV [BP],CX \
  InLine(&H89,&H4E,&H0)
\ MOV [BP+&HA],DX \
  InLine(&H89,&H56,&H0A)
\ MOV [BP+4],DI \
  InLine(&H89,&H7E,&H4)
\ MOV [BP+2],SI \
  InLine(&H89,&H76,&H2)
\ MOV SP,BP \
  InLine(&H89,&HEC)
\ POP BP \
  InLine(&H5D)
\ RETF 4 \
  InLine(&HCA,&H4,&H0)
Leave
\$F-\

Sub CallProcWord(Func as Pointer,W as Word)
Enter
\ PUSH DS \
  InLine &H1E
\ PUSH W \
  BX=W:InLine &H53
\ CALL FAR [Func] \
  InLine &HFF,&H9E,Func
\ POP DS \
  InLine &H1F
Leave

Sub CallProcString(Func as Pointer,S as String)
  P as Pointer
Enter
\ PUSH DS \
  InLine &H1E
  P=@S
\ LES BX,[P] \
  InLine &HC4,&H9E,P
\ PUSH ES:PUSH BX \
  InLine &H06,&H53
\ CALL FAR [Func] \
  InLine &HFF,&H9E,Func
\ POP DS \
  InLine &H1F
Leave

\ Fonctions de sortie \
Sub WaitingForAKey
Type
    BytePtr is ^Byte
Enter
  PrintS("-- Press any key --")
  BytePtr(0,1050)^=BytePtr(0,1052)^
  GetCar
Leave

Sub WriteCarriage
Enter
  PrintCR
  NbCarriages+=1
  If NbCarriages=24 Then
    NbCarriages=0
    If More=True Then
      WaitingForAKey
      PrintCR
    End
  End
Leave

\ Fonction Error \
\$F+\
Sub Error(S as String)
Enter
  If ErrorReturnInitialized=1 Then
    StrCpy(ErrorMessage,S)
    InLine(&H1E) \DS\
    LongJump(ErrorReturn,1)
  Else
    PrintS(S):PrintS(", line "):PrintD(NbCR+1)
    If WaitOnError=1 Then WaitingForAKey;
  \ Halt \
    InLine &HFEEB
  End
Leave
\$F-\

\ Maniement des vecteurs d'it \
Var
   IHVec as @Array[0..&HFF] Of Func

Sub GetIntVec(No as Byte,F as @Func)
Enter
  F=IHVec[No]
Leave

Sub SetIntVec(No as Byte,F as Func)
Enter
  IHVec[No]=F
Leave

\ Keyboard ctrl \
Var
   OKeyBoardItStub as Func
   ScanCode,PrevScanCode,Ignore as Byte

\$F+\
\$R-\
\$S-\
Sub KeyBoardItStub
Enter
\ (AX,BX,CX,DX,SI,DI,DS,ES,BP) \
  InLine(&H50,&H53,&H51,&H52,&H56,&H57,&H1E,&H06,&H55)
\ BPSP \
  InLine(&H89,&HE5)
\ AXDSEG(Error):DSAX \
  InLine(&HB8,&H1234,&H8E,&HD8)
  Goto Suite
Arrachos:
\ JMP FAR OldInt9 \
  InLine(&HEA,&H0,&H0,&H0,&H0)
Suite:
\ Handler \
\ IN AL,60 \
  InLine(&HE4,&H60)
  ScanCode=AX
  If Ignore<>0 Then
    Ignore-=1
    If IgnoreCBreak=1 Then Goto DontCare
    Else
    \ MOV AL,20:OUT 20,AL \
      InLine(&HB0,&H20,&HE6,&H20)
    \ STI \
      InLine(&HFB)
      InLine(&H1E) \DS\
      LongJump(CBreakReturn,1)
    End
  Else
  If PrevScanCode=&HE0 Then
  Begin
    If ScanCode=&H46 Then
      Ignore=1
      Goto DontCare
    End
    PrevScanCode=0
  Else
  If ScanCode=&HE0 Then PrevScanCode=&HE0;
\ SPBP \
  InLine(&H89,&HEC)
\ (BP,ES,DS,DI,SI,DX,CX,BX,AX) \
  InLine(&H5D,&H07,&H1F,&H5F,&H5E,&H5A,&H59,&H5B,&H58)
  Goto Arrachos
DontCare:
\ Acknowledge \
\ MOV AL,20:OUT 20,AL \
  InLine(&HB0,&H20,&HE6,&H20)
\ SPBP \
  InLine(&H89,&HEC)
\ (BP,ES,DS,DI,SI,DX,CX,BX,AX) \
  InLine(&H5D,&H07,&H1F,&H5F,&H5E,&H5A,&H59,&H5B,&H58)
\ IRET \
  InLine(&HCF)
Leave
\$S+\
\$R+\
\$F-\

Sub GetCBreakControl
Type
    PointerPtr is ^Pointer
    WordPtr is ^Word
Var
   P as PointerPtr
   W as WordPtr
Enter
  ScanCode=0
  PrevScanCode=0
  Ignore=0
  IgnoreCBreak=True
  GetIntVec(&H9,OKeyBoardItStub)
  W=WordPtr(@KeyBoardItStub)
  Low(W)+=15
  W^=DS
  P=PointerPtr(@KeyBoardItStub)
  Low(P)+=&H17
  P^=OKeyBoardItStub
  P=PointerPtr(@KeyBoardItStub)
  Low(P)+=3
  SetIntVec(&H9,Pointer(P))
Leave

Sub RestoreCBreakControl
Enter
  SetIntVec(&H9,OKeyBoardItStub)
Leave

Enter
  WaitOnError=True
  ErrorMessage[0]=0
  ErrorReturnInitialized=False
  @IHVec=Pointer(0,0)
  PrintS "Error start done":PrintCR
Leave