Newer
Older
;;; -*- Log: code.log; Package: MACH -*-
;;;
;;; **********************************************************************
;;; 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.4 1990/07/23 18:54:14 wlott Exp $
;;;
;;; Code for handling UNIX signals.
;;;
;;; Written by William Lott.
;;;
(export '(unix-signal-name unix-signal-description unix-signal-number
sigcontext sigmask unix-sigblock unix-sigpause
unix-sigsetmask unix-kill unix-getpid))
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
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
(export 'kernel::signal-init (find-package "KERNEL"))
;;; These should probably be somewhere, but I don't know where.
;;;
(defconstant sig_dfl 0)
(defconstant sig_ign 1)
;;;; Utilities for dealing with signal names and numbers.
(defstruct (unix-signal
(:constructor make-unix-signal (%name %number %description)))
%name ; Signal keyword
(%number :type integer) ; UNIX signal number
(%description :type string)) ; Documentation
(defvar *unix-signals* nil
"A list of unix signal structures.")
(eval-when (compile eval)
(defmacro def-unix-signal (name number description)
(let ((mach-symbol (intern (symbol-name name))))
`(progn
(push (make-unix-signal ,name ,number ,description) *unix-signals*)
;;
;; This is to make the new signal lookup stuff compatible with
;; old code which expects the symbol with the same print name as
;; our keywords to be a constant with a value equal to the signal
;; number.
(defconstant ,mach-symbol ,number ,description)
(export ',mach-symbol))))
) ;eval-when
(defun unix-signal-or-lose (arg)
(let ((signal (find arg *unix-signals*
:key (etypecase arg
(symbol #'unix-signal-%name)
(number #'unix-signal-%number)))))
(unless signal
(error "~S is not a valid signal name or number." arg))
signal))
(defun unix-signal-name (signal)
"Return the name of the signal as a string. Signal should be a valid
signal number or a keyword of the standard UNIX signal name."
(symbol-name (unix-signal-%name (unix-signal-or-lose signal))))
(defun unix-signal-description (signal)
"Return a string describing signal. Signal should be a valid signal
number or a keyword of the standard UNIX signal name."
(unix-signal-%description (unix-signal-or-lose signal)))
(defun unix-signal-number (signal)
"Return the number of the given signal. Signal should be a valid
signal number or a keyword of the standard UNIX signal name."
(unix-signal-%number (unix-signal-or-lose signal)))
;;; Known signals
;;;
(def-unix-signal :CHECK 0 "Check")
(def-unix-signal :SIGHUP 1 "Hangup")
(def-unix-signal :SIGINT 2 "Interrupt")
(def-unix-signal :SIGQUIT 3 "Quit")
(def-unix-signal :SIGILL 4 "Illegal instruction")
(def-unix-signal :SIGTRAP 5 "Trace trap")
(def-unix-signal :SIGIOT 6 "Iot instruction")
(def-unix-signal :SIGEMT 7 "Emt instruction")
(def-unix-signal :SIGFPE 8 "Floating point exception")
(def-unix-signal :SIGKILL 9 "Kill")
(def-unix-signal :SIGBUS 10 "Bus error")
(def-unix-signal :SIGSEGV 11 "Segmentation violation")
(def-unix-signal :SIGSYS 12 "Bad argument to system call")
(def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it")
(def-unix-signal :SIGALRM 14 "Alarm clock")
(def-unix-signal :SIGTERM 15 "Software termination signal")
(def-unix-signal :SIGURG 16 "Urgent condition present on socket")
(def-unix-signal :SIGSTOP 17 "Stop")
(def-unix-signal :SIGTSTP 18 "Stop signal generated from keyboard")
(def-unix-signal :SIGCONT 19 "Continue after stop")
(def-unix-signal :SIGCHLD 20 "Child status has changed")
(def-unix-signal :SIGTTIN 21 "Background read attempted from control terminal")
(def-unix-signal :SIGTTOU 22 "Background write attempted to control terminal")
(def-unix-signal :SIGIO 23 "I/O is possible on a descriptor")
(def-unix-signal :SIGXCPU 24 "Cpu time limit exceeded")
(def-unix-signal :SIGXFSZ 25 "File size limit exceeded")
(def-unix-signal :SIGVTALRM 26 "Virtual time alarm")
(def-unix-signal :SIGPROF 27 "Profiling timer alarm")
(def-unix-signal :SIGWINCH 28 "Window size change")
(def-unix-signal :SIGUSR1 30 "User defined signal 1")
(def-unix-signal :SIGUSR2 31 "User defined signal 2")
;;;
;;; These are Mach Specific
(def-unix-signal :SIGEMSG 30 "Mach Emergency message")
(def-unix-signal :SIGMSG 31 "Mach message")
;;; SIGMASK -- Public
;;;
(defmacro sigmask (&rest signals)
"Returns a mask given a set of signals."
(apply #'logior
(mapcar #'(lambda (signal)
(ash 1 (1- (unix-signal-number signal))))
signals)))
;;;; System calls that deal with signals.
(proclaim '(inline real-unix-kill))
(def-c-routine ("kill" real-unix-kill) (int)
(pid int)
(signal int))
(defun unix-kill (pid signal)
"Unix-kill sends the signal signal to the process with process
id pid. Signal should be a valid signal number or a keyword of the
standard UNIX signal name."
(real-unix-kill pid (unix-signal-number signal)))
(proclaim '(inline real-unix-killpg))
(def-c-routine ("killpg" real-unix-killpg) (int)
(pgrp int)
(signal int))
(defun unix-killpg (pgrp signal)
"Unix-killpg sends the signal signal to the all the process in process
group PGRP. Signal should be a valid signal number or a keyword of
the standard UNIX signal name."
(real-unix-killpg pgrp (unix-signal-number signal)))
(def-c-routine ("sigblock" unix-sigblock) (unsigned-long)
"Unix-sigblock cause the signals specified in mask to be
added to the set of signals currently being blocked from
delivery. The macro sigmask is provided to create masks."
(mask unsigned-long))
(def-c-routine ("sigpause" unix-sigpause) (void)
"Unix-sigpause sets the set of masked signals to its argument
and then waits for a signal to arrive, restoring the previous
mask upon its return."
(mask unsigned-long))
(def-c-routine ("sigsetmask" unix-sigsetmask) (unsigned-long)
"Unix-sigsetmask sets the current set of masked signals (those
begin blocked from delivery) to the argument. The macro sigmask
can be used to create the mask. The previous value of the signal
mask is returned."
(mask unsigned-long))
;;;; C routines that actually do all the work of establishing signal handlers.
(def-c-routine ("install_handler" install-handler)
(int)
(signal int)
(handler unsigned-long))
;;;; Interface to enabling and disabling signal handlers.
(defun enable-interrupt (signal handler)
(without-gcing
(install-handler (unix-signal-number signal)
(di::get-lisp-obj-address handler))))
(defun default-interrupt (signal)
(declare (ignore signal))
(warn "Can't default interrupts yet."))
(defun ignore-interrupt (signal)
(declare (ignore signal))
(warn "Can't ignore interrupts yet."))
;;;; Default LISP signal handlers.
;;; Most of these just call ERROR to report the presence of the signal.
(defmacro define-signal-handler (name what &optional (function 'error))
`(defun ,name (signal code scp)
(declare (ignore signal code))
(alien-bind ((sc
(make-alien 'mach:sigcontext
#.(c-sizeof 'mach:sigcontext)
scp)
mach:sigcontext
t))
(,function ,(concatenate 'simple-string what " at #x~x.")
(sap-int
(alien-access (mach:sigcontext-pc (alien-value sc))))))))
(define-signal-handler sigint-handler "Interrupted" break)
(define-signal-handler sigill-handler "Illegal Instruction")
(define-signal-handler sigiot-handler "SIGIOT")
(define-signal-handler sigemt-handler "SIGEMT")
(define-signal-handler sigfpe-handler "SIGFPE")
(define-signal-handler sigbus-handler "Bus Error")
(define-signal-handler sigsegv-handler "Segmentation Violation")
(define-signal-handler sigsys-handler "Bad Argument to a System Call")
(define-signal-handler sigpipe-handler "SIGPIPE")
(define-signal-handler sigalrm-handler "SIGALRM")
(defun sigquit-handler (signal code scp)
(declare (ignore signal code scp))
(throw 'lisp::top-level-catcher nil))
"Enable all the default signals that Lisp knows how to deal with."
#+nil (enable-interrupt :sigint #'sigint-handler)
(enable-interrupt :sigquit #'sigquit-handler)
(enable-interrupt :sigill #'sigill-handler)
(enable-interrupt :sigtrap #'kernel::internal-error)
(enable-interrupt :sigiot #'sigiot-handler)
(enable-interrupt :sigemt #'sigemt-handler)
#+nil (enable-interrupt :sigfpe #'sigfpe-handler)
(enable-interrupt :sigbus #'sigbus-handler)
(enable-interrupt :sigsegv #'sigsegv-handler)
(enable-interrupt :sigsys #'sigsys-handler)
(enable-interrupt :sigpipe #'sigpipe-handler)
(enable-interrupt :sigalrm #'sigalrm-handler)