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
c1e1153c
Commit
c1e1153c
authored
34 years ago
by
wlott
Browse files
Options
Downloads
Patches
Plain Diff
Initial revision
parent
c66f8ea0
No related branches found
No related tags found
No related merge requests found
Changes
2
Hide whitespace changes
Inline
Side-by-side
Showing
2 changed files
code/interr.lisp
+405
-0
405 additions, 0 deletions
code/interr.lisp
code/signal.lisp
+30
-0
30 additions, 0 deletions
code/signal.lisp
with
435 additions
and
0 deletions
code/interr.lisp
0 → 100644
+
405
−
0
View file @
c1e1153c
;;; -*- Log: code.log; Package: KERNEL -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/interr.lisp,v 1.1 1990/06/04 05:32:47 wlott Exp $
;;;
;;; Functions and macros to define and deal with internal errors (i.e.
;;; problems that can be signaled from assembler code).
;;;
;;; Written by William Lott.
;;;
(
in-package
"KERNEL"
)
(
export
'
(
error-number-or-lose
))
(
export
'
(
unknown-error
object-not-function-error
object-not-list-error
object-not-bignum-error
object-not-ratio-error
object-not-single-float-error
object-not-double-float-error
object-not-simple-string-error
object-not-simple-bit-vector-error
object-not-simple-vector-error
object-not-fixnum-error
object-not-function-or-symbol-error
object-not-vector-error
object-not-string-error
object-not-bit-vector-error
object-not-array-error
object-not-number-error
object-not-rational-error
object-not-float-error
object-not-real-error
object-not-integer-error
object-not-cons-error
object-not-symbol-error
undefined-symbol-error
object-not-coercable-to-function-error
invalid-argument-count-error
bogus-argument-to-values-list-error
unbound-symbol-error
object-not-base-character-error
object-not-sap-error
invalid-unwind-error
unseen-throw-tag-error
division-by-zero-error
object-not-type-error
odd-keyword-arguments-error
unknown-keyword-argument-error
not-<=-error
not-=-error
invalid-array-index-error
wrong-number-of-indices-error
object-not-simple-array-error
object-not-signed-byte-32-error
object-not-unsigned-byte-32-error
object-not-simple-array-unsigned-byte-2-error
object-not-simple-array-unsigned-byte-4-error
object-not-simple-array-unsigned-byte-8-error
object-not-simple-array-unsigned-byte-16-error
object-not-simple-array-unsigned-byte-32-error
object-not-simple-array-single-float-error
object-not-simple-array-double-float-error
object-not-complex-error
))
;;;; Internal Errors
(
defvar
*internal-errors*
(
make-array
10
:initial-element
nil
))
(
defstruct
(
error-info
(
:print-function
%print-error-info
))
name
description
function
)
(
defun
%print-error-info
(
info
stream
depth
)
(
declare
(
ignore
depth
))
(
format
stream
"#<error-info for ~S>"
(
error-info-name
info
)))
(
defun
error-number-or-lose
(
name
)
(
or
(
position-if
#'
(
lambda
(
info
)
(
and
info
(
eq
name
(
error-info-name
info
))))
*internal-errors*
)
(
error
"Unknown internal error: ~S"
name
)))
(
eval-when
(
compile
eval
)
(
defvar
*meta-error*
)
(
setf
*meta-errors*
(
make-array
10
:initial-element
nil
))
(
defun
meta-error-number
(
name
)
(
or
(
when
(
boundp
'*internal-errors*
)
(
position-if
#'
(
lambda
(
info
)
(
and
info
(
eq
name
(
error-info-name
info
))))
*internal-errors*
))
(
position
name
*meta-errors*
)
(
do
((
number
0
(
1+
number
)))
((
and
(
or
(
not
(
boundp
'*internal-errors*
))
(
>=
number
(
length
*internal-errors*
))
(
null
(
svref
*internal-errors*
number
)))
(
or
(
>=
number
(
length
*meta-errors*
))
(
null
(
svref
*meta-errors*
number
))))
(
when
(
>=
number
(
length
*meta-errors*
))
(
setf
*meta-errors*
(
replace
(
make-array
(
+
number
10
)
:initial-element
nil
)
*meta-errors*
)))
(
setf
(
svref
*meta-errors*
number
)
name
)
number
))))
(
defmacro
deferr
(
name
description
args
&rest
body
)
`
(
%deferr
',name
,
(
meta-error-number
name
)
,
description
#'
(
lambda
,
args
,@
body
)))
)
(
defun
%deferr
(
name
number
description
function
)
(
when
(
>=
number
(
length
*internal-errors*
))
(
setf
*internal-errors*
(
replace
(
make-array
(
+
number
10
)
:initial-element
nil
)
*internal-errors*
)))
(
setf
(
svref
*internal-errors*
number
)
(
make-error-info
:name
name
:description
description
:function
function
))
name
)
)
; Eval-When (Compile Load Eval)
(
deferr
unknown-error
"Unknown. System lossage."
(
&rest
args
)
(
error
"Unknown error:~{ ~S~})"
args
))
(
deferr
object-not-function-error
"Object is not of type FUNCTION."
(
&rest
args
)
(
error
"object-not-function:~{ ~S~}"
args
))
(
deferr
object-not-list-error
"Object is not of type LIST."
(
&rest
args
)
(
error
"object-not-list:~{ ~S~}"
args
))
(
deferr
object-not-bignum-error
"Object is not of type BIGNUM."
(
&rest
args
)
(
error
"object-not-bignum:~{ ~S~}"
args
))
(
deferr
object-not-ratio-error
"Object is not of type RATIO."
(
&rest
args
)
(
error
"object-not-ratio:~{ ~S~}"
args
))
(
deferr
object-not-single-float-error
"Object is not of type SINGLE-FLOAT."
(
&rest
args
)
(
error
"object-not-single-float:~{ ~S~}"
args
))
(
deferr
object-not-double-float-error
"Object is not of type DOUBLE-FLOAT."
(
&rest
args
)
(
error
"object-not-double-float:~{ ~S~}"
args
))
(
deferr
object-not-simple-string-error
"Object is not of type SIMPLE-STRING."
(
&rest
args
)
(
error
"object-not-simple-string:~{ ~S~}"
args
))
(
deferr
object-not-simple-bit-vector-error
"Object is not of type SIMPLE-BIT-VECTOR."
(
&rest
args
)
(
error
"object-not-simple-bit-vector:~{ ~S~}"
args
))
(
deferr
object-not-simple-vector-error
"Object is not of type SIMPLE-VECTOR."
(
&rest
args
)
(
error
"object-not-simple-vector:~{ ~S~}"
args
))
(
deferr
object-not-fixnum-error
"Object is not of type FIXNUM."
(
&rest
args
)
(
error
"object-not-fixnum:~{ ~S~}"
args
))
(
deferr
object-not-function-or-symbol-error
"Object is not of type FUNCTION or of type SYMBOL."
(
&rest
args
)
(
error
"object-not-function-or-symbol:~{ ~S~}"
args
))
(
deferr
object-not-vector-error
"Object is not of type VECTOR."
(
&rest
args
)
(
error
"object-not-vector:~{ ~S~}"
args
))
(
deferr
object-not-string-error
"Object is not of type STRING."
(
&rest
args
)
(
error
"object-not-string:~{ ~S~}"
args
))
(
deferr
object-not-bit-vector-error
"Object is not of type BIT-VECTOR."
(
&rest
args
)
(
error
"object-not-bit-vector:~{ ~S~}"
args
))
(
deferr
object-not-array-error
"Object is not of type ARRAY."
(
&rest
args
)
(
error
"object-not-array:~{ ~S~}"
args
))
(
deferr
object-not-number-error
"Object is not of type NUMBER."
(
&rest
args
)
(
error
"object-not-number:~{ ~S~}"
args
))
(
deferr
object-not-rational-error
"Object is not of type RATIONAL."
(
&rest
args
)
(
error
"object-not-rational:~{ ~S~}"
args
))
(
deferr
object-not-float-error
"Object is not of type FLOAT."
(
&rest
args
)
(
error
"object-not-float:~{ ~S~}"
args
))
(
deferr
object-not-real-error
"Object is not of type REAL."
(
&rest
args
)
(
error
"object-not-real:~{ ~S~}"
args
))
(
deferr
object-not-integer-error
"Object is not of type INTEGER."
(
&rest
args
)
(
error
"object-not-integer:~{ ~S~}"
args
))
(
deferr
object-not-cons-error
"Object is not of type CONS."
(
&rest
args
)
(
error
"object-not-cons:~{ ~S~}"
args
))
(
deferr
object-not-symbol-error
"Object is not of type SYMBOL."
(
&rest
args
)
(
error
"object-not-symbol:~{ ~S~}"
args
))
(
deferr
undefined-symbol-error
"Undefined symbol."
(
&rest
args
)
(
error
"undefined-symbol:~{ ~S~}"
args
))
(
deferr
object-not-coercable-to-function-error
"Object is not coercable to type FUNCTION."
(
&rest
args
)
(
error
"object-not-coercable-to-function:~{ ~S~}"
args
))
(
deferr
invalid-argument-count-error
"Invalid argument count."
(
&rest
args
)
(
error
"invalid-argument-count:~{ ~S~}"
args
))
(
deferr
bogus-argument-to-values-list-error
"Bogus argument to VALUES-LIST."
(
&rest
args
)
(
error
"bogus-argument-to-values-list:~{ ~S~}"
args
))
(
deferr
unbound-symbol-error
"Unbound symbol."
(
&rest
args
)
(
error
"unbound-symbol:~{ ~S~}"
args
))
(
deferr
object-not-base-character-error
"Object is not of type BASE-CHARACTER."
(
&rest
args
)
(
error
"object-not-base-character:~{ ~S~}"
args
))
(
deferr
object-not-sap-error
"Object is not a System Area Pointer (SAP)."
(
&rest
args
)
(
error
"object-not-sap:~{ ~S~}"
args
))
(
deferr
invalid-unwind-error
"Attempt to RETURN-FROM a block that no longer exists."
(
&rest
args
)
(
error
"invalid-unwind:~{ ~S~}"
args
))
(
deferr
unseen-throw-tag-error
"Attempt to THROW to a non-existent tag."
(
&rest
args
)
(
error
"unseen-throw-tag:~{ ~S~}"
args
))
(
deferr
division-by-zero-error
"Attempt to divide by zero."
(
&rest
args
)
(
error
"division-by-zero:~{ ~S~}"
args
))
(
deferr
object-not-type-error
"Object is of the wrong type."
(
&rest
args
)
(
error
"object-not-type:~{ ~S~}"
args
))
(
deferr
odd-keyword-arguments-error
"Odd number of keyword arguments."
(
&rest
args
)
(
error
"odd-keyword-arguments:~{ ~S~}"
args
))
(
deferr
unknown-keyword-argument-error
"Unknown keyword."
(
&rest
args
)
(
error
"unknown-keyword-argument:~{ ~S~}"
args
))
(
deferr
not-<=-error
"Not less than or equal."
(
&rest
args
)
(
error
"not-<=:~{ ~S~}"
args
))
(
deferr
not-=-error
"Not equal."
(
&rest
args
)
(
error
"not-=:~{ ~S~}"
args
))
(
deferr
invalid-array-index-error
"Invalid array index."
(
&rest
args
)
(
error
"invalid-array-index:~{ ~S~}"
args
))
(
deferr
wrong-number-of-indices-error
"Wrong number of indices."
(
&rest
args
)
(
error
"wrong-number-of-indices:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-error
"Object is not of type SIMPLE-ARRAY."
(
&rest
args
)
(
error
"object-not-simple-array:~{ ~S~}"
args
))
(
deferr
object-not-signed-byte-32-error
"Object is not of type (SIGNED-BYTE 32)."
(
&rest
args
)
(
error
"object-not-signed-byte-32:~{ ~S~}"
args
))
(
deferr
object-not-unsigned-byte-32-error
"Object is not of type (UNSIGNED-BYTE 32)."
(
&rest
args
)
(
error
"object-not-unsigned-byte-32:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-unsigned-byte-2-error
"Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 2) (*))."
(
&rest
args
)
(
error
"object-not-simple-array-unsigned-byte-2:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-unsigned-byte-4-error
"Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 4) (*))."
(
&rest
args
)
(
error
"object-not-simple-array-unsigned-byte-4:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-unsigned-byte-8-error
"Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 8) (*))."
(
&rest
args
)
(
error
"object-not-simple-array-unsigned-byte-8:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-unsigned-byte-16-error
"Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 16) (*))."
(
&rest
args
)
(
error
"object-not-simple-array-unsigned-byte-16:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-unsigned-byte-32-error
"Object is not of type (SIMPLE-ARRAY (UNSIGNED-BYTE 32) (*))."
(
&rest
args
)
(
error
"object-not-simple-array-unsigned-byte-32:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-single-float-error
"Object is not of type (SIMPLE-ARRAY SINGLE-FLOAT (*))."
(
&rest
args
)
(
error
"object-not-simple-array-single-float:~{ ~S~}"
args
))
(
deferr
object-not-simple-array-double-float-error
"Object is not of type (SIMPLE-ARRAY DOUBLE-FLOAT (*))."
(
&rest
args
)
(
error
"object-not-simple-array-double-float:~{ ~S~}"
args
))
(
deferr
object-not-complex-error
"Object is not of type COMPLEX."
(
&rest
args
)
(
error
"object-not-complex:~{ ~S~}"
args
))
#+
new-compiler
(
defun
internal-error
(
signal
code
scp
)
(
declare
(
ignore
signal
code
))
(
alien-bind
((
sc
(
mach:indirect-*sigcontext
(
make-alien
'mach:sigcontext
#.
(
c-sizeof
'mach:sigcontext
)
scp
))
mach:sigcontext
t
)
(
regs
(
mach:sigcontext-regs
sc
)
mach:int-array
t
))
(
let*
((
pc
(
int-sap
(
mach:sigcontext-pc
sc
)))
(
bad-inst
(
sap-ref-32
pc
0
))
(
number
(
sap-ref-8
pc
4
))
(
info
(
svref
*internal-errors*
number
))
(
args
nil
))
(
do
((
ptr
(
sap+
pc
5
)
(
sap+
ptr
1
)))
((
zerop
(
sap-ref-8
ptr
0
)))
(
without-gcing
(
push
(
di::make-lisp-obj
(
alien-access
(
mach:int-array-ref
(
alien-value
regs
)
(
sap-ref-8
ptr
0
))))
args
)))
(
error
"~A [~D]:~{ ~S~}"
(
if
info
(
error-info-description
info
)
"Unknown error"
)
number
(
nreverse
args
)))))
This diff is collapsed.
Click to expand it.
code/signal.lisp
0 → 100644
+
30
−
0
View file @
c1e1153c
;;; -*- Log: code.log; Package: KERNEL -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/signal.lisp,v 1.1 1990/06/04 05:34:33 wlott Exp $
;;;
;;; Code for handling UNIX signals.
;;;
;;; Written by William Lott.
;;;
(
in-package
"KERNEL"
)
(
export
'
(
signal-init
))
(
def-c-routine
(
"install_handler"
install-handler
)
(
int
)
(
signal
int
)
(
handler
unsigned-long
))
(
defun
signal-init
()
(
install-handler
#.
(
mach:unix-signal-number
:sigtrap
)
(
di::get-lisp-obj-address
#'
internal-error
))
nil
)
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