level1/50_error.f

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;; UrForth level 1: self-hosting 32-bit Forth compiler
   3 ;; Copyright (C) 2020 Ketmar Dark // Invisible Vector
   4 ;; GPLv3 ONLY
   5 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   6
   7 ;; default abort calls ABORT-CLEANUP, and then MAIN-LOOP
   8 ;; threading code replaces it
   9 $uservar "(ABORT-CLEANUP-PTR)" ua_ofs_abort_cleanup_ptr 0
  10
  11 ;; ye good olde ABORT, vectorized
  12 ;; this word should never return
  13 ;; note that by default it cleans exception frames, and goes straight to QUIT
  14 $uservar "(ABORT-PTR)" ua_ofs_abort_ptr 0
  15
  16 ;; called when the system needs to abort with error message
  17 ;; this word should never return
  18 ;; it uses THROW to throw an error
  19 ;; ( errcode )
  20 $uservar "(ERROR-PTR)" ua_ofs_error_ptr 0
  21
  22 ;; this one completely ignores any exceptions, cleans exception frames, and aborts
  23 ;; ( errcode )
  24 $uservar "(FATAL-ERROR-PTR)" ua_ofs_fatal_error_ptr 0
  25
  26 ;; this is called to reset FPU
  27 $defer "FPU-RESET" cfa "noop"
  28
  29 $value "ERROR-TYPE-LINE?" 1
  30
  31 $constant "(#user-abort-msg)" 63
  32 $uservar "(user-abort-msg)" ua_ofs_user_abort_msg 0
  33 (hidden)
  34 $userallot 60
  35
  36
  37 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  38 : (abort-msg-reset)  ( -- ) (user-abort-msg) 0c! ;
  39 : (abort-msg-emit)  ( ch -- ) (user-abort-msg) c@ (#user-abort-msg) < if (user-abort-msg) c1s:cat-char else drop endif ;
  40 : (abort-msg-type)  ( addr count -- )  dup +if (#user-abort-msg) min bounds do i c@ (abort-msg-emit) loop else 2drop endif ;
  41
  42 : (abort-with-built-msg-errcode)  ( errcode -- )  (tib-fname>error-fname) throw ;
  43
  44 : (abort-with-built-msg)  ( -- )  err-user-abort ['] (abort-with-built-msg-errcode) execute-tail ;
  45
  46 : (abort-with-msg)  ( addr count -- )
  47   0 (#user-abort-msg) clamp (user-abort-msg) c1s:copy-counted
  48   ['] (abort-with-built-msg) execute-tail
  49 ;
  50
  51 : <abort  ( -- )  (abort-msg-reset) ;
  52 : abort-emit  ( char -- ) (abort-msg-emit) ;
  53 : abort-safe-emit  ( char -- ) dup 32 < over 127 = or if drop [char] ? endif (abort-msg-emit) ;
  54 : abort-type  ( addr count -- ) (abort-msg-type) ;
  55 alias (abort-with-built-msg) abort>
  56
  57
  58 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  59 $constant "ERR-UNKNOWN-WORD"                   -1
  60 $constant "ERR-STACK-UNDERFLOW"                -2
  61 $constant "ERR-STACK-OVERFLOW"                 -3
  62 $constant "ERR-R-STACK-UNDERFLOW"              -4
  63 $constant "ERR-R-STACK-OVERFLOW"               -5
  64 $constant "ERR-OUT-OF-MEMORY"                  -6
  65 $constant "ERR-WORD-REDEFINED"                 -7
  66 $constant "ERR-FILE-NOT-FOUND"                 -8
  67 $constant "ERR-FILE-READ-ERROR"                -9
  68 $constant "ERR-FILE-WRITE-ERROR"              -10
  69 $constant "ERR-FILE-TOO-BIG"                  -11
  70 $constant "ERR-COMPILATION-ONLY"              -12
  71 $constant "ERR-EXECUTION-ONLY"                -13
  72 $constant "ERR-UNPAIRED-CONDITIONALS"         -14
  73 $constant "ERR-UNFINISHED-DEFINITION"         -15
  74 $constant "ERR-IN-PROTECTED-DICT"             -16  ;; for "forget" (which will prolly never materialize)
  75 $constant "ERR-NOT-DEFER"                     -17
  76 $constant "ERR-INVALID-WORD-NAME"             -18
  77 $constant "ERR-WORD-EXPECTED"                 -19
  78 $constant "ERR-USER-ABORT"                    -20
  79 $constant "ERR-BAD-RELADDR"                   -21
  80 $constant "ERR-INVALID-MALLOC"                -22
  81 $constant "ERR-VOCABULARY-STACK-OVERFLOW"     -23
  82 $constant "ERR-CHAR-EXPECTED"                 -24
  83 $constant "ERR-STRING-EXPECTED"               -25
  84 $constant "ERR-NUMBER-EXPECTED"               -26
  85 $constant "ERR-VOCABULARY-EXPECTED"           -27
  86 $constant "ERR-INVALID-BREAK-CONT"            -28
  87 $constant "ERR-NONNAKED-SYSTEM"               -29
  88 $constant "ERR-NOT-IMPLEMENTED"               -30
  89 $constant "ERR-NEGATIVE-ALLOT"                -31
  90 $constant "ERR-NO-TEMP-HERE"                  -32
  91 $constant "ERR-TEMP-HERE-ALREADY"             -33
  92 $constant "ERR-CANNOT-OVERRIDE"               -34
  93 $constant "ERR-CANNOT-REPLACE"                -35
  94 $constant "ERR-INPUT-TOO-LONG"                -36
  95 $constant "ERR-THROW-WITHOUT-CATCH"           -37
  96 $constant "ERR-THROW-CHAIN-CORRUPTED"         -38
  97 $constant "ERR-UNBALANCED-IFDEF"              -39
  98 $constant "ERR-STRING-TOO-LONG"               -40
  99 $constant "ERR-SEGFAULT"                      -41
 100 $constant "ERR-MATH-OVERFLOW"                 -42
 101 $constant "ERR-MATH-ZERO-DIVIDE"              -43
 102 $constant "ERR-SAVE-CHAIN-STACK"              -44
 103 $constant "ERR-FSTACK-UNDERFLOW"              -45
 104 $constant "ERR-UNKNOWN-LIBRARY"               -46
 105 $constant "ERR-ELLIPSIS-FORTH"                -47
 106 $constant "ERR-ELLIPSIS-FIRST"                -48
 107 $constant "ERR-INVALID-INPUT-SIZE"            -49
 108 $constant "ERR-OUT-OF-USER-AREA"              -50
 109 $constant "ERR-INVALID-THREAD"                -51
 110 $constant "ERR-DISPATCH-ERROR"                -52
 111 $constant "ERR-NONMACRO-ONLY"                 -53
 112 $constant "ERR-UNDEFINED-INSTRUCTION"         -54
 113 $constant "ERR-ALIGNED-NAME-TOO-LONG"         -55
 114 $constant "ERR-ALIGN-VIOLATION"               -56
 115
 116 $constant "ERR-USER-ERROR" -669
 117
 118
 119 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 120 create (ERROR-MSG-TABLE) (hidden)
 121   ERR-UNKNOWN-WORD                  error-table-msg," pardon?"
 122   ERR-STACK-UNDERFLOW               error-table-msg," stack underflow"
 123   ERR-STACK-OVERFLOW                error-table-msg," stack overflow"
 124   ERR-R-STACK-UNDERFLOW             error-table-msg," return stack underflow"
 125   ERR-R-STACK-OVERFLOW              error-table-msg," return stack overflow"
 126   ERR-OUT-OF-MEMORY                 error-table-msg," out of memory"
 127   ERR-WORD-REDEFINED                error-table-msg," is not unique"
 128   ERR-FILE-NOT-FOUND                error-table-msg," file not found"
 129   ERR-FILE-READ-ERROR               error-table-msg," file read error"
 130   ERR-FILE-WRITE-ERROR              error-table-msg," file write error"
 131   ERR-FILE-TOO-BIG                  error-table-msg," file too big"
 132   ERR-COMPILATION-ONLY              error-table-msg," compilation only"
 133   ERR-EXECUTION-ONLY                error-table-msg," execution only"
 134   ERR-UNPAIRED-CONDITIONALS         error-table-msg," conditionals not paired"
 135   ERR-UNFINISHED-DEFINITION         error-table-msg," definition not finished"
 136   ERR-IN-PROTECTED-DICT             error-table-msg," in protected dictionary"
 137   ERR-NOT-DEFER                     error-table-msg," not a DEFER word"
 138   ERR-INVALID-WORD-NAME             error-table-msg," invalid word name"
 139   ERR-WORD-EXPECTED                 error-table-msg," known word expected"
 140   ERR-USER-ABORT                    error-table-msg," user abort"  ;; actually, this will show (user-abort-msg) instead
 141   ERR-BAD-RELADDR                   error-table-msg," reladdr out of bounds"
 142   ERR-INVALID-MALLOC                error-table-msg," invalid malloc/realloc/free"
 143   ERR-VOCABULARY-STACK-OVERFLOW     error-table-msg," vocabulary stack overflow"
 144   ERR-CHAR-EXPECTED                 error-table-msg," character expected"
 145   ERR-STRING-EXPECTED               error-table-msg," string expected"
 146   ERR-INVALID-BREAK-CONT            error-table-msg," invalid break/continue"
 147   ERR-NONNAKED-SYSTEM               error-table-msg," non-naked system"
 148   ERR-NOT-IMPLEMENTED               error-table-msg," not implemented"
 149   ERR-NEGATIVE-ALLOT                error-table-msg," negative ALLOT is not allowed"
 150   ERR-NO-TEMP-HERE                  error-table-msg," not allowed in transient HERE"
 151   ERR-TEMP-HERE-ALREADY             error-table-msg," transient HERE already in use"
 152   ERR-CANNOT-OVERRIDE               error-table-msg," cannot override non-Forth word"
 153   ERR-CANNOT-REPLACE                error-table-msg," no code space to replace word"
 154   ERR-INPUT-TOO-LONG                error-table-msg," input too long"
 155   ERR-THROW-WITHOUT-CATCH           error-table-msg," THROW without CATCH"
 156   ERR-THROW-CHAIN-CORRUPTED         error-table-msg," THROW chain corrupted"
 157   ERR-UNBALANCED-IFDEF              error-table-msg," unbalanced ifdefs"
 158   ERR-USER-ERROR                    error-table-msg," user-defined error"
 159   ERR-STRING-TOO-LONG               error-table-msg," string too long"
 160   ERR-SEGFAULT                      error-table-msg," segmentation fault"
 161   ERR-MATH-OVERFLOW                 error-table-msg," arithmetic overflow"
 162   ERR-MATH-ZERO-DIVIDE              error-table-msg," division by zero"
 163   ERR-SAVE-CHAIN-STACK              error-table-msg," unbalanced stack in save chain"
 164   ERR-FSTACK-UNDERFLOW              error-table-msg," fpu stack underflow"
 165   ERR-UNKNOWN-LIBRARY               error-table-msg," unknown library"
 166   ERR-ELLIPSIS-FORTH                error-table-msg," `...` must be in a Forth word"
 167   ERR-ELLIPSIS-FIRST                error-table-msg," `...` must be the first in a Forth word"
 168   ERR-INVALID-INPUT-SIZE            error-table-msg," invalid size in RESTORE-INPUT"
 169   ERR-OUT-OF-USER-AREA              error-table-msg," out of user area"
 170   ERR-INVALID-THREAD                error-table-msg," use resource in invalid thread"
 171   ERR-DISPATCH-ERROR                error-table-msg," cannot dynamicaly dispatch class method"
 172   ERR-NONMACRO-ONLY                 error-table-msg," definition must be non-macro"
 173   ERR-UNDEFINED-INSTRUCTION         error-table-msg," undefined CPU instruction"
 174   ERR-ALIGNED-NAME-TOO-LONG         error-table-msg," aligned word name too long"
 175   ERR-ALIGN-VIOLATION               error-table-msg," align violation (internal compiler error)"
 176 error-table-end
 177
 178
 179 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 180 : (FIND-MESSAGE)  ( id tbladdr -- addr count true // id false )
 181   swap >r
 182   begin
 183     dup @
 184   while
 185     dup @ r@ =
 186     if
 187       ;; i found her!
 188       rdrop cell+ zcount true exit
 189     endif
 190     ;; skip
 191     cell+ zcount + 1+
 192   repeat
 193   drop r> false
 194 ; (hidden)
 195
 196
 197 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 198 ;; error 0 is "unknown word"; usually called with the word in HERE
 199 ;; the word should be already dumped, and we won't show the usual "ERROR:" prompt
 200 : ERROR-MESSAGE  ( errcode -- )
 201   dup err-unknown-word = if
 202     ;; unknown word
 203     (error-msg-table) (find-message) ifnot drop ." pardon?" endif
 204     63 emit space type
 205   else
 206     ;; look for error message in the table
 207     ?endcr if space endif
 208     ." ERROR"
 209     dup err-user-abort = if ." : " (user-abort-msg) bcount ?dup ifnot drop " unknown user error" endif type (abort-msg-reset)
 210     else dup err-dispatch-error = (user-abort-msg) bcount-only logand if (user-abort-msg) bcount type (abort-msg-reset)
 211     else (error-msg-table) (find-message) if ." : " type
 212     else ." #" base @ swap decimal 0 .r base !
 213     endif endif endif
 214   endif
 215 ;
 216
 217
 218 : ERROR-LINE.  ( -- )
 219   (tib-error-line#) ?dup if
 220     ."  around line #"
 221     base @ >r decimal . r> base !
 222     (tib-error-fname) count ?dup
 223     if
 224       ." of file \`" type 34 emit space
 225     else
 226       drop
 227     endif
 228   endif
 229   error-type-line? if endcr (tib-type-error-line) cr endif
 230   (tib-clear-error)
 231 ;
 232
 233 ;; this does "ABORT"
 234 : (FATAL-ERROR)  ( errcode -- )
 235   decimal  ;; because why not
 236   error-message
 237   error-line.
 238   ;; print stacks depth
 239   base @ >r decimal
 240   ."  D:"
 241   sp0 @ sp@ - 2 arshift .
 242   ." R:"
 243   rp0 @ rp@ - 2 arshift .
 244   ;;pardottype ")"
 245   cr
 246   r> base !
 247   abort
 248   ;; just in case it returns
 249   1 n-bye
 250 ; (noreturn) (hidden)
 251
 252
 253 ;; and this one tries to throw
 254 : (ERROR) ( errcode -- )
 255   (tib-fname>error-fname)
 256   (exc-frame-ptr) @ if throw endif
 257   ;; no exception frame set, do fatal
 258   fatal-error
 259 ;
 260
 261
 262 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 263 ;; issue an error message with the given code if the boolean flag is true
 264 : ?ERROR  ( flag code -- )
 265   swap if error endif
 266   drop
 267 ;
 268
 269 : NOT-?ERROR  ( flag code -- )
 270   swap ifnot error endif
 271   drop
 272 ;
 273
 274
 275 ;; this is also used in "(COLD-FIRSTTIME)"
 276 : (ABORT-CLEANUP-MIN)  ( -- )
 277   sp0!
 278   r@ rp0! >r  ;; this is so we will be able to return to the caller
 279   state 0!
 280   dp-temp-reset
 281   (exc0!)  ;; clear all exception frames
 282   ;; 0 (self!) 0 (locptr!) -- this is done in the corresponding modules now
 283   ;; temp-pool-reset
 284   fpu-reset
 285   tib-reset
 286   only forth definitions
 287 ;
 288
 289
 290 $uservar "(ABORT-CLEANUP-RET)" ua_ofs_abort_cleanup_ret 0
 291 (hidden)
 292
 293 ..: (ABORT-CLEANUP)  ( -- )
 294   sp0! r@ (abort-cleanup-ret) ! ;; this is so we will be able to return to the caller
 295   (abort-cleanup-min)
 296  $if URFORTH_DEBUG
 297   (dbginfo-reset)
 298  $endif
 299   tload-verbose-default to tload-verbose
 300   (abort-cleanup-ret) @ >r
 301 ;..
 302
 303
 304 : (ABORT)  ( -- )
 305   (abort-cleanup)
 306   main-loop
 307   ;; just in case it returns
 308   bye
 309 ; (noreturn) (hidden)
 310
 311
 312 code: abort-cleanup  ( )
 313   jp    ts:[ua_ofs_abort_cleanup_ptr]
 314 endcode
 315
 316 code: abort  ( )
 317   jp    ts:[ua_ofs_abort_ptr]
 318 endcode
 319
 320 code: error  ( code )
 321   jp    ts:[ua_ofs_error_ptr]
 322 endcode
 323
 324 code: fatal-error  ( code )
 325   jp    ts:[ua_ofs_fatal_error_ptr]
 326 endcode
 327
 328 ..: (startup-init)  ( -- )
 329   ['] (abort-cleanup) (abort-cleanup-ptr) !
 330   ['] (abort) (abort-ptr) !
 331   ['] (error) (error-ptr) !
 332   ['] (fatal-error) (fatal-error-ptr) !
 333 ;..
 334
 335
 336 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 337 ;; dump data stack (unlimited depth)
 338 : .STACK  ( -- )
 339   depth dup -if ." stack underflowed" cr drop exit endif
 340   ?dup ifnot ." stack empty" cr exit endif
 341   dup ." stack depth: " . cr
 342   0 do
 343     depth 1- i - pick
 344     dup . ." | " u. cr
 345   loop
 346 ;
 347
 348
 349 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 350 : error-table-msg,"  ( code -- )  \ msg"
 351   ;; UrForth level 0 uses byte for error code, UrForth level 1 uses dword
 352   ,  ;; store code
 353   34 parse dup n-allot swap move
 354   0 c, ;; terminating zero for the string
 355 ;
 356
 357
 358 ;; compile end of list
 359 : error-table-end  ( -- )
 360   ;; UrForth level 0 uses two zero bytes, UrForth level 1 uses 4
 361   0 ,
 362 ;
 363
 364
 365 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 366 : abort"  ( -- )  ;; "
 367   34 (parse-and-unescape) [compile] sliteral ['] (abort-with-msg) state @ if compile, else execute-tail endif
 368 ; immediate
 369
 370 : (?abort-compiler)  ( iftrue? -- )  ( flag iftrue? -- )
 371   state @ if
 372     if [compile] if else [compile] ifnot endif
 373     [compile] abort"  ;; "
 374     [compile] endif
 375   else
 376     ifnot not endif 34 (parse-and-unescape) rot if (abort-with-msg) else 2drop endif
 377   endif
 378 ;
 379
 380 : ?abort"  ( flag -- )  ;; "
 381   true (?abort-compiler)
 382 ; immediate
 383
 384 : not-?abort"  ( flag -- )  ;; "
 385   false (?abort-compiler)
 386 ; immediate