/[cmucl]/src/code/interr.lisp
ViewVC logotype

Diff of /src/code/interr.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.39 by pmai, Wed Aug 28 13:29:26 2002 UTC revision 1.39.4.2 by gerd, Mon Mar 24 10:54:40 2003 UTC
# Line 17  Line 17 
17    
18  (in-package "KERNEL")  (in-package "KERNEL")
19    
20  (export '(infinite-error-protect find-caller-name *maximum-error-depth*))  (export '(infinite-error-protect find-caller-name *maximum-error-depth*
21              red-zone-hit yellow-zone-hit))
22    
23    
24    
# Line 488  Line 489 
489               (error-error "Help! " *current-error-depth* " nested errors.  "               (error-error "Help! " *current-error-depth* " nested errors.  "
490                            "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")                            "KERNEL:*MAXIMUM-ERROR-DEPTH* exceeded.")
491               (progn ,@forms)))               (progn ,@forms)))
492         (%primitive halt)))         (progn
493             (%primitive print "infinite-error-protect")
494             (%primitive halt))))
495    
496  ;;; Track the depth of recursive errors.  ;;; Track the depth of recursive errors.
497  ;;;  ;;;
# Line 514  Line 517 
517  (defun error-error (&rest messages)  (defun error-error (&rest messages)
518    (let ((*error-error-depth* (1+ *error-error-depth*)))    (let ((*error-error-depth* (1+ *error-error-depth*)))
519      (when (> *error-throw-up-count* 50)      (when (> *error-throw-up-count* 50)
520          (%primitive print "error-error 1")
521        (%primitive halt)        (%primitive halt)
522        (throw 'lisp::top-level-catcher nil))        (throw 'lisp::top-level-catcher nil))
523      (case *error-error-depth*      (case *error-error-depth*
# Line 524  Line 528 
528         (incf *error-throw-up-count*)         (incf *error-throw-up-count*)
529         (throw 'lisp::top-level-catcher nil))         (throw 'lisp::top-level-catcher nil))
530        (t        (t
531           (%primitive print "error-error 2")
532         (%primitive halt)         (%primitive halt)
533         (throw 'lisp::top-level-catcher nil)))         (throw 'lisp::top-level-catcher nil)))
534    
# Line 621  Line 626 
626                   (t                   (t
627                    (funcall handler name fp scp arguments)))))))))                    (funcall handler name fp scp arguments)))))))))
628    
629    ;;;
630    ;;; Called from C when the yellow control stack guard zone is hit.
631    ;;; The yellow zone is unprotected in the C code prior to calling this
632    ;;; function, to give some room for debugging.  The red zone is still
633    ;;; protected.
634    ;;;
635    #+stack-checking
636    (defun yellow-zone-hit ()
637      (let ((debug:*stack-top-hint* nil))
638        (format *error-output*
639                "~2&~@<A control stack overflow has occurred: ~
640                the program has entered the yellow control stack guard zone.  ~
641                Please note that you will be returned to the Top-Level if you ~
642                enter the red control stack guard zone while debugging.~@:>~2%")
643        (infinite-error-protect (error 'stack-overflow))))
644    
645    ;;;
646    ;;; Called from C when the red control stack guard zone is hit.  We
647    ;;; could ABORT here, which would usually take us back to the debugger
648    ;;; or top-level, and add code to the restarts re-protecting the red
649    ;;; zone (which can't be done here because we're still in the red
650    ;;; zone).  Using ABORT is too dangerous because users may be using
651    ;;; abort restarts which don't do the necessary re-protecting of the
652    ;;; red zone, and would thus render CMUCL unprotected.
653    ;;;
654    #+stack-checking
655    (defun red-zone-hit ()
656      (format *error-output*
657              "~2&~@<Fatal control stack overflow.  You have entered ~
658               the red control stack guard zone while debugging.  ~
659               Returning to Top-Level.~@:>~2%")
660      (throw 'lisp::top-level-catcher nil))
661    
662    

Legend:
Removed from v.1.39  
changed lines
  Added in v.1.39.4.2

  ViewVC Help
Powered by ViewVC 1.1.5