system/base/1.7.5/src/error handling

Raw file
Back to index

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
PACKET error handling DEFINES
 
    enable stop ,
    disable stop ,
    is error ,
    clear error ,
    errormessage ,
    error code ,
    error line ,
    put error ,
    errorstop ,
    stop :
 
 
LET cr lf            = ""13""10"" ,
    line nr field    = 1 ,
    error line field = 2 ,
    error code field = 3 ,
    syntax error code= 100 ,

    error pre        = ""7""13""10""5"FEHLER : " ;


TEXT VAR errortext := "" ;
 
 
PROC enable stop :
  EXTERNAL 75
ENDPROC enable stop ;

PROC disable stop :
  EXTERNAL 76
ENDPROC disable stop ;

PROC set error stop (INT CONST code) :
  EXTERNAL 77
ENDPROC set error stop ;
 
BOOL PROC is error : 
  EXTERNAL 78
ENDPROC is error ; 
 
PROC clear error :
  EXTERNAL 79
ENDPROC clear error ;

PROC select error message :

  SELECT error code OF
    CASE 1 : error text := "'halt' vom Terminal"
    CASE 2 : error text := "Stack-Ueberlauf"
    CASE 3 : error text := "Heap-Ueberlauf"
    CASE 4 : error text := "INT-Ueberlauf"
    CASE 5 : error text := "DIV durch 0"
    CASE 6 : error text := "REAL-Ueberlauf"
    CASE 7 : error text := "TEXT-Ueberlauf"
    CASE 8 : error text := "zu viele DATASPACEs"
    CASE 9 : error text := "Ueberlauf bei Subskription"
    CASE 10: error text := "Unterlauf bei Subskription"
    CASE 11: error text := "falscher DATASPACE-Zugriff"
    CASE 12: error text := "INT nicht initialisiert"
    CASE 13: error text := "REAL nicht initialisiert"
    CASE 14: error text := "TEXT nicht initialisiert"
    CASE 15: error text := "nicht implementiert"
    CASE 16: error text := "Block unlesbar"
    CASE 17: error text := "Codefehler"
  END SELECT 

ENDPROC select error message ;

TEXT PROC error message : 
 
  select error message ;
  error text
 
ENDPROC error message ;
 
INT PROC error code :

  pcb (error code field) 

ENDPROC error code ;

INT PROC error line :
 
  IF is error
    THEN pcb (error line field)
    ELSE 0
  FI
 
ENDPROC error line ;
 
PROC syntax error (TEXT CONST message) :

  INTERNAL 259 ;
  errorstop (syntax error code, message) .

ENDPROC syntax error ;

PROC errorstop (TEXT CONST message) :

  errorstop (0, message) ;

ENDPROC errorstop ;

PROC errorstop (INT CONST code, TEXT CONST message) :

  IF NOT is error
    THEN error text := message ;
         set error stop (code)
  FI

ENDPROC errorstop ;
 
PROC put error :
 
  IF is error
    THEN select error message ;
         IF error text <> ""
           THEN put error message
         FI
  FI .
 
put error message :
  out (error pre) ;
  out (error text) ;
  IF error line > 0
    THEN out (" bei Zeile "); out (text (error line)) ;
  FI ; 
  out (cr lf) .

ENDPROC put error ;
 
PROC stop :

  errorstop ("stop")

ENDPROC stop ;

ENDPACKET error handling ;