Skip to content
GitLab
Explore
Sign in
Register
Primary navigation
Search or go to…
Project
cmucl
Manage
Activity
Members
Labels
Plan
Issues
Issue boards
Milestones
Wiki
Code
Merge requests
Repository
Branches
Commits
Tags
Repository graph
Compare revisions
Snippets
Build
Pipelines
Jobs
Pipeline schedules
Artifacts
Deploy
Releases
Package Registry
Model registry
Operate
Environments
Terraform modules
Monitor
Incidents
Service Desk
Analyze
Value stream analytics
Contributor analytics
CI/CD analytics
Repository analytics
Model experiments
Help
Help
Support
GitLab documentation
Compare GitLab plans
Community forum
Contribute to GitLab
Provide feedback
Terms and privacy
Keyboard shortcuts
?
Snippets
Groups
Projects
Show more breadcrumbs
Carl Shapiro
cmucl
Commits
cf636c19
Commit
cf636c19
authored
31 years ago
by
ram
Browse files
Options
Downloads
Patches
Plain Diff
simple-condition-format-string -> simple-condition-format-control. Flushed
storage-exhausted and stack-overflow.
parent
bc8e7bb6
No related branches found
No related tags found
No related merge requests found
Changes
1
Hide whitespace changes
Inline
Side-by-side
Showing
1 changed file
code/error.lisp
+29
-38
29 additions, 38 deletions
code/error.lisp
with
29 additions
and
38 deletions
code/error.lisp
+
29
−
38
View file @
cf636c19
...
@@ -7,7 +7,7 @@
...
@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
;;;
(
ext:file-comment
(
ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.2
0
1993/0
2
/2
6 08
:25:
11
ram Exp $"
)
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/error.lisp,v 1.2
1
1993/0
6
/2
4 12
:25:
42
ram Exp $"
)
;;;
;;;
;;; **********************************************************************
;;; **********************************************************************
;;;
;;;
...
@@ -36,9 +36,9 @@
...
@@ -36,9 +36,9 @@
compute-restarts
invoke-restart
invoke-restart-interactively
abort
compute-restarts
invoke-restart
invoke-restart-interactively
abort
continue
muffle-warning
store-value
use-value
invoke-debugger
restart
continue
muffle-warning
store-value
use-value
invoke-debugger
restart
condition
warning
serious-condition
simple-condition
simple-warning
condition
warning
serious-condition
simple-condition
simple-warning
simple-error
simple-condition-format-
string
simple-error
simple-condition-format-
control
simple-condition-format-arguments
storage-condition
stack-overflow
simple-condition-format-arguments
storage-condition
storage-exhausted
type-error
type-error-datum
type-error
type-error-datum
type-error-expected-type
simple-type-error
program-error
type-error-expected-type
simple-type-error
program-error
control-error
stream-error
stream-error-stream
end-of-file
file-error
control-error
stream-error
stream-error-stream
end-of-file
file-error
file-error-pathname
cell-error
unbound-variable
undefined-function
file-error-pathname
cell-error
unbound-variable
undefined-function
...
@@ -152,7 +152,7 @@
...
@@ -152,7 +152,7 @@
(
let
((
real-restart
(
find-restart
restart
)))
(
let
((
real-restart
(
find-restart
restart
)))
(
unless
real-restart
(
unless
real-restart
(
error
'control-error
(
error
'control-error
:format-
string
"Restart ~S is not active."
:format-
control
"Restart ~S is not active."
:format-arguments
(
list
restart
)))
:format-arguments
(
list
restart
)))
(
apply
(
restart-function
real-restart
)
values
)))
(
apply
(
restart-function
real-restart
)
values
)))
...
@@ -163,7 +163,7 @@
...
@@ -163,7 +163,7 @@
(
let
((
real-restart
(
find-restart
restart
)))
(
let
((
real-restart
(
find-restart
restart
)))
(
unless
real-restart
(
unless
real-restart
(
error
'control-error
(
error
'control-error
:format-
string
"Restart ~S is not active."
:format-
control
"Restart ~S is not active."
:format-arguments
(
list
restart
)))
:format-arguments
(
list
restart
)))
(
apply
(
restart-function
real-restart
)
(
apply
(
restart-function
real-restart
)
(
let
((
interactive-function
(
let
((
interactive-function
...
@@ -355,7 +355,7 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -355,7 +355,7 @@ The previous version is uglier, but it sets up unique run-time tags.
(
cond
((
not
fn
)
(
error
'simple-type-error
(
cond
((
not
fn
)
(
error
'simple-type-error
:datum
type
:datum
type
:expected-type
'
(
satisfies
make-function
)
:expected-type
'
(
satisfies
make-function
)
:format-
string
"Not a condition type: ~S"
:format-
control
"Not a condition type: ~S"
:format-arguments
(
list
type
)))
:format-arguments
(
list
type
)))
(
t
(
apply
fn
slot-initializations
)))))
(
t
(
apply
fn
slot-initializations
)))))
...
@@ -520,7 +520,7 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -520,7 +520,7 @@ The previous version is uglier, but it sets up unique run-time tags.
'simple-type-error
'simple-type-error
:datum
arguments
:datum
arguments
:expected-type
'null
:expected-type
'null
:format-
string
"You may not supply additional arguments ~
:format-
control
"You may not supply additional arguments ~
when giving ~S to ~S."
when giving ~S to ~S."
:format-arguments
(
list
datum
function-name
)))
:format-arguments
(
list
datum
function-name
)))
datum
)
datum
)
...
@@ -528,13 +528,13 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -528,13 +528,13 @@ The previous version is uglier, but it sets up unique run-time tags.
(
apply
#'
make-condition
datum
arguments
))
(
apply
#'
make-condition
datum
arguments
))
((
or
(
stringp
datum
)
(
functionp
datum
))
((
or
(
stringp
datum
)
(
functionp
datum
))
(
make-condition
default-type
(
make-condition
default-type
:format-
string
datum
:format-
control
datum
:format-arguments
arguments
))
:format-arguments
arguments
))
(
t
(
t
(
error
'simple-type-error
(
error
'simple-type-error
:datum
datum
:datum
datum
:expected-type
'
(
or
symbol
string
)
:expected-type
'
(
or
symbol
string
)
:format-
string
"Bad argument to ~S: ~S"
:format-
control
"Bad argument to ~S: ~S"
:format-arguments
(
list
function-name
datum
)))))
:format-arguments
(
list
function-name
datum
)))))
...
@@ -604,21 +604,15 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -604,21 +604,15 @@ The previous version is uglier, but it sets up unique run-time tags.
(
define-condition
warning
(
condition
)
())
(
define-condition
warning
(
condition
)
())
(
defvar
*break-on-warnings*
()
"If non-NIL, then WARN will enter a break loop before returning."
)
(
defun
warn
(
datum
&rest
arguments
)
(
defun
warn
(
datum
&rest
arguments
)
"Warns about a situation by signalling a condition formed by datum and
"Warns about a situation by signalling a condition formed by datum and
arguments. Before signalling, if *break-on-warnings* is set, then BREAK
arguments. While the condition is being signaled, a muffle-warning restart
is called. While the condition is being signaled, a muffle-warning restart
exists that causes WARN to immediately return nil."
exists that causes WARN to immediately return nil."
(
kernel:infinite-error-protect
(
kernel:infinite-error-protect
(
let
((
condition
(
coerce-to-condition
datum
arguments
(
let
((
condition
(
coerce-to-condition
datum
arguments
'simple-warning
'warn
)))
'simple-warning
'warn
)))
(
check-type
condition
warning
"a warning condition"
)
(
check-type
condition
warning
"a warning condition"
)
(
if
*break-on-warnings*
(
break
"~A~%Break entered because of *break-on-warnings*."
condition
))
(
restart-case
(
signal
condition
)
(
restart-case
(
signal
condition
)
(
muffle-warning
()
(
muffle-warning
()
:report
"Skip warning."
:report
"Skip warning."
...
@@ -635,29 +629,29 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -635,29 +629,29 @@ The previous version is uglier, but it sets up unique run-time tags.
(
defun
simple-condition-printer
(
condition
stream
)
(
defun
simple-condition-printer
(
condition
stream
)
(
apply
#'
format
stream
(
simple-condition-format-
string
condition
)
(
apply
#'
format
stream
(
simple-condition-format-
control
condition
)
(
simple-condition-format-arguments
condition
)))
(
simple-condition-format-arguments
condition
)))
;;; The simple-condition type has a conc-name, so SIMPLE-CONDITION-FORMAT-
STRING
;;; The simple-condition type has a conc-name, so SIMPLE-CONDITION-FORMAT-
CONTROL
;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
;;; This seems to create some kind of bogus multiple inheritance that the user
;;; This seems to create some kind of bogus multiple inheritance that the user
;;; sees.
;;; sees.
;;;
;;;
(
define-condition
simple-condition
(
condition
)
(
define-condition
simple-condition
(
condition
)
(
format-
string
(
format-
control
(
format-arguments
'
()))
(
format-arguments
'
()))
(
:conc-name
internal-simple-condition-
)
(
:conc-name
internal-simple-condition-
)
(
:report
simple-condition-printer
))
(
:report
simple-condition-printer
))
;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-
STRING
;;; The simple-warning type has a conc-name, so SIMPLE-CONDITION-FORMAT-
CONTROL
;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
;;; This seems to create some kind of bogus multiple inheritance that the user
;;; This seems to create some kind of bogus multiple inheritance that the user
;;; sees.
;;; sees.
;;;
;;;
(
define-condition
simple-warning
(
warning
)
(
define-condition
simple-warning
(
warning
)
(
format-
string
(
format-
control
(
format-arguments
'
()))
(
format-arguments
'
()))
(
:conc-name
internal-simple-warning-
)
(
:conc-name
internal-simple-warning-
)
(
:report
simple-condition-printer
))
(
:report
simple-condition-printer
))
...
@@ -666,17 +660,17 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -666,17 +660,17 @@ The previous version is uglier, but it sets up unique run-time tags.
(
defun
print-simple-error
(
condition
stream
)
(
defun
print-simple-error
(
condition
stream
)
(
format
stream
"~&~@<Error in function ~S: ~3i~:_~?~:>"
(
format
stream
"~&~@<Error in function ~S: ~3i~:_~?~:>"
(
internal-simple-error-function-name
condition
)
(
internal-simple-error-function-name
condition
)
(
internal-simple-error-format-
string
condition
)
(
internal-simple-error-format-
control
condition
)
(
internal-simple-error-format-arguments
condition
)))
(
internal-simple-error-format-arguments
condition
)))
;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-
STRING
;;; The simple-error type has a conc-name, so SIMPLE-CONDITION-FORMAT-
CONTROL
;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
;;; and SIMPLE-CONDITION-FORMAT-ARGUMENTS could be written to handle the
;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
;;; simple-condition, simple-warning, simple-type-error, and simple-error types.
;;; This seems to create some kind of bogus multiple inheritance that the user
;;; This seems to create some kind of bogus multiple inheritance that the user
;;; sees.
;;; sees.
;;;
;;;
(
define-condition
simple-error
(
error
)
(
define-condition
simple-error
(
error
)
(
format-
string
(
format-
control
(
format-arguments
'
()))
(
format-arguments
'
()))
(
:conc-name
internal-simple-error-
)
(
:conc-name
internal-simple-error-
)
(
:report
print-simple-error
))
(
:report
print-simple-error
))
...
@@ -684,9 +678,6 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -684,9 +678,6 @@ The previous version is uglier, but it sets up unique run-time tags.
(
define-condition
storage-condition
(
serious-condition
)
())
(
define-condition
storage-condition
(
serious-condition
)
())
(
define-condition
stack-overflow
(
storage-condition
)
())
(
define-condition
storage-exhausted
(
storage-condition
)
())
(
define-condition
type-error
(
error
)
(
define-condition
type-error
(
error
)
(
datum
(
datum
expected-type
)
expected-type
)
...
@@ -698,13 +689,13 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -698,13 +689,13 @@ The previous version is uglier, but it sets up unique run-time tags.
(
type-error-expected-type
condition
)))))
(
type-error-expected-type
condition
)))))
;;; The simple-type-error type has a conc-name, so
;;; The simple-type-error type has a conc-name, so
;;; SIMPLE-CONDITION-FORMAT-
STRING
and SIMPLE-CONDITION-FORMAT-ARGUMENTS could
;;; SIMPLE-CONDITION-FORMAT-
CONTROL
and SIMPLE-CONDITION-FORMAT-ARGUMENTS could
;;; be written to handle the simple-condition, simple-warning,
;;; be written to handle the simple-condition, simple-warning,
;;; simple-type-error, and simple-error types. This seems to create some kind
;;; simple-type-error, and simple-error types. This seems to create some kind
;;; of bogus multiple inheritance that the user sees.
;;; of bogus multiple inheritance that the user sees.
;;;
;;;
(
define-condition
simple-type-error
(
type-error
)
(
define-condition
simple-type-error
(
type-error
)
(
format-
string
(
format-
control
(
format-arguments
'
()))
(
format-arguments
'
()))
(
:conc-name
internal-simple-type-error-
)
(
:conc-name
internal-simple-type-error-
)
(
:report
simple-condition-printer
))
(
:report
simple-condition-printer
))
...
@@ -730,17 +721,17 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -730,17 +721,17 @@ The previous version is uglier, but it sets up unique run-time tags.
(
case-failure-possibilities
condition
)))))
(
case-failure-possibilities
condition
)))))
;;; SIMPLE-CONDITION-FORMAT-
STRING
and SIMPLE-CONDITION-FORMAT-ARGUMENTS.
;;; SIMPLE-CONDITION-FORMAT-
CONTROL
and SIMPLE-CONDITION-FORMAT-ARGUMENTS.
;;; These exist for the obvious types to seemingly give the impression of
;;; These exist for the obvious types to seemingly give the impression of
;;; multiple inheritance. That is, the last three types inherit from warning,
;;; multiple inheritance. That is, the last three types inherit from warning,
;;; type-error, and error while inheriting from simple-condition also.
;;; type-error, and error while inheriting from simple-condition also.
;;;
;;;
(
defun
simple-condition-format-
string
(
condition
)
(
defun
simple-condition-format-
control
(
condition
)
(
etypecase
condition
(
etypecase
condition
(
simple-condition
(
internal-simple-condition-format-
string
condition
))
(
simple-condition
(
internal-simple-condition-format-
control
condition
))
(
simple-warning
(
internal-simple-warning-format-
string
condition
))
(
simple-warning
(
internal-simple-warning-format-
control
condition
))
(
simple-type-error
(
internal-simple-type-error-format-
string
condition
))
(
simple-type-error
(
internal-simple-type-error-format-
control
condition
))
(
simple-error
(
internal-simple-error-format-
string
condition
))))
(
simple-error
(
internal-simple-error-format-
control
condition
))))
;;;
;;;
(
defun
simple-condition-format-arguments
(
condition
)
(
defun
simple-condition-format-arguments
(
condition
)
(
etypecase
condition
(
etypecase
condition
...
@@ -756,11 +747,11 @@ The previous version is uglier, but it sets up unique run-time tags.
...
@@ -756,11 +747,11 @@ The previous version is uglier, but it sets up unique run-time tags.
(
defun
print-control-error
(
condition
stream
)
(
defun
print-control-error
(
condition
stream
)
(
format
stream
"~&~@<Error in function ~S: ~3i~:_~?~:>"
(
format
stream
"~&~@<Error in function ~S: ~3i~:_~?~:>"
(
control-error-function-name
condition
)
(
control-error-function-name
condition
)
(
control-error-format-
string
condition
)
(
control-error-format-
control
condition
)
(
control-error-format-arguments
condition
)))
(
control-error-format-arguments
condition
)))
(
define-condition
control-error
(
error
)
(
define-condition
control-error
(
error
)
(
format-
string
(
format-
control
(
format-arguments
nil
))
(
format-arguments
nil
))
(
:report
print-control-error
))
(
:report
print-control-error
))
...
...
This diff is collapsed.
Click to expand it.
Preview
0%
Loading
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Save comment
Cancel
Please
register
or
sign in
to comment