/[slime]/slime/swank-allegro.lisp
ViewVC logotype

Contents of /slime/swank-allegro.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.67 - (hide annotations)
Thu Jan 20 16:09:23 2005 UTC (9 years, 2 months ago) by heller
Branch: MAIN
Changes since 1.66: +14 -12 lines
(handle-undefined-functions-warning): Prevent breakage if the
undefined function is called at multiple locations.  By Edi Weitz.

(restart-frame): Handle frames with arguments better.  From Ian Eslick.
1 heller 1.8 ;;;; -*- Mode: lisp; indent-tabs-mode: nil; outline-regexp: ";;;;;*"; -*-
2 heller 1.1 ;;;
3     ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
4     ;;;
5 heller 1.60 ;;; Created 2003
6 heller 1.1 ;;;
7     ;;; This code has been placed in the Public Domain. All warranties
8 heller 1.14 ;;; are disclaimed. This code was written for "Allegro CL Trial
9     ;;; Edition "5.0 [Linux/X86] (8/29/98 10:57)".
10 heller 1.1 ;;;
11    
12 heller 1.21 (in-package :swank-backend)
13    
14 heller 1.1 (eval-when (:compile-toplevel :load-toplevel :execute)
15     (require :sock)
16 lgorrie 1.33 (require :process)
17 heller 1.1
18 lgorrie 1.33 (import
19     '(excl:fundamental-character-output-stream
20     excl:stream-write-char
21     excl:stream-force-output
22     excl:fundamental-character-input-stream
23     excl:stream-read-char
24     excl:stream-listen
25     excl:stream-unread-char
26     excl:stream-clear-input
27     excl:stream-line-column
28     excl:stream-read-char-no-hang)))
29 heller 1.1
30 mbaringer 1.53 ;;; swank-mop
31    
32 heller 1.60 ;; maybe better change MOP to ACLMOP ?
33     ;; CLOS also works in ACL5. --he
34     (import-swank-mop-symbols :clos '(:slot-definition-documentation))
35 mbaringer 1.53
36 mbaringer 1.54 (defun swank-mop:slot-definition-documentation (slot)
37 heller 1.62 (documentation slot t))
38 mbaringer 1.53
39 heller 1.8 ;;;; TCP Server
40 heller 1.1
41 heller 1.21 (defimplementation preferred-communication-style ()
42     :spawn)
43 heller 1.12
44 heller 1.14 (defimplementation create-socket (host port)
45     (socket:make-socket :connect :passive :local-port port
46     :local-host host :reuse-address t))
47 heller 1.5
48 heller 1.10 (defimplementation local-port (socket)
49 heller 1.6 (socket:local-port socket))
50    
51 heller 1.10 (defimplementation close-socket (socket)
52 heller 1.6 (close socket))
53    
54 heller 1.66 (defimplementation accept-connection (socket &key external-format)
55     (let ((ef (or external-format :iso-latin-1-unix))
56     (s (socket:accept-connection socket :wait t)))
57     (set-external-format s ef)
58 heller 1.63 s))
59 heller 1.6
60 heller 1.64 (defun set-external-format (stream external-format)
61     #-allegro-v5.0
62     (let* ((name (ecase external-format
63     (:iso-latin-1-unix :latin1)
64     (:utf-8-unix :utf-8-unix)
65     (:emacs-mule-unix :emacs-mule)))
66     (ef (excl:crlf-base-ef
67     (excl:find-external-format name :try-variant t))))
68     (setf (stream-external-format stream) ef)))
69    
70 heller 1.34 (defimplementation format-sldb-condition (c)
71     (princ-to-string c))
72    
73     (defimplementation condition-references (c)
74 heller 1.39 (declare (ignore c))
75 heller 1.34 '())
76 heller 1.7
77 heller 1.39 (defimplementation call-with-syntax-hooks (fn)
78     (funcall fn))
79    
80 heller 1.9 ;;;; Unix signals
81    
82 heller 1.10 (defimplementation call-without-interrupts (fn)
83 heller 1.9 (excl:without-interrupts (funcall fn)))
84    
85 heller 1.10 (defimplementation getpid ()
86 heller 1.8 (excl::getpid))
87 heller 1.6
88 heller 1.15 (defimplementation lisp-implementation-type-name ()
89     "allegro")
90    
91 pseibel 1.28 (defimplementation set-default-directory (directory)
92 heller 1.66 (let ((dir (namestring (setf *default-pathname-defaults*
93     (truename (merge-pathnames directory))))))
94     (excl:chdir dir)
95     dir))
96 pseibel 1.28
97 heller 1.35 (defimplementation default-directory ()
98 heller 1.66 (namestring (excl:current-directory)))
99 heller 1.35
100 heller 1.8 ;;;; Misc
101 heller 1.1
102 heller 1.21 (defimplementation arglist (symbol)
103 lgorrie 1.30 (handler-case (excl:arglist symbol)
104     (simple-error () :not-available)))
105 heller 1.21
106     (defimplementation macroexpand-all (form)
107     (excl::walk form))
108 heller 1.1
109 heller 1.10 (defimplementation describe-symbol-for-emacs (symbol)
110 heller 1.1 (let ((result '()))
111     (flet ((doc (kind &optional (sym symbol))
112     (or (documentation sym kind) :not-documented))
113     (maybe-push (property value)
114     (when value
115     (setf result (list* property value result)))))
116     (maybe-push
117     :variable (when (boundp symbol)
118     (doc 'variable)))
119     (maybe-push
120     :function (if (fboundp symbol)
121     (doc 'function)))
122     (maybe-push
123     :class (if (find-class symbol nil)
124     (doc 'class)))
125     result)))
126    
127 heller 1.20 (defimplementation describe-definition (symbol namespace)
128     (ecase namespace
129     (:variable
130     (describe symbol))
131     ((:function :generic-function)
132     (describe (symbol-function symbol)))
133     (:class
134     (describe (find-class symbol)))))
135 heller 1.10
136 lgorrie 1.43 (defimplementation make-stream-interactive (stream)
137     (setf (interactive-stream-p stream) t))
138    
139 heller 1.8 ;;;; Debugger
140    
141 heller 1.1 (defvar *sldb-topframe*)
142 heller 1.4
143 heller 1.10 (defimplementation call-with-debugging-environment (debugger-loop-fn)
144 heller 1.4 (let ((*sldb-topframe* (excl::int-newest-frame))
145 heller 1.20 (excl::*break-hook* nil))
146 heller 1.4 (funcall debugger-loop-fn)))
147 heller 1.1
148 heller 1.42 (defun next-frame (frame)
149     (let ((next (excl::int-next-older-frame frame)))
150     (cond ((not next) nil)
151     ((debugger:frame-visible-p next) next)
152     (t (next-frame next)))))
153    
154 heller 1.1 (defun nth-frame (index)
155 heller 1.42 (do ((frame *sldb-topframe* (next-frame frame))
156 heller 1.1 (i index (1- i)))
157     ((zerop i) frame)))
158    
159 heller 1.20 (defimplementation compute-backtrace (start end)
160 heller 1.1 (let ((end (or end most-positive-fixnum)))
161 heller 1.42 (loop for f = (nth-frame start) then (next-frame f)
162 heller 1.1 for i from start below end
163     while f
164 heller 1.42 collect f)))
165 heller 1.1
166 heller 1.20 (defimplementation print-frame (frame stream)
167     (debugger:output-frame stream frame :moderate))
168 heller 1.4
169 heller 1.10 (defimplementation frame-locals (index)
170 heller 1.1 (let ((frame (nth-frame index)))
171     (loop for i from 0 below (debugger:frame-number-vars frame)
172 mbaringer 1.19 collect (list :name (debugger:frame-var-name frame i)
173 heller 1.1 :id 0
174 mbaringer 1.19 :value (debugger:frame-var-value frame i)))))
175 heller 1.1
176 heller 1.39 (defimplementation frame-var-value (frame var)
177     (let ((frame (nth-frame frame)))
178     (debugger:frame-var-value frame var)))
179    
180 heller 1.10 (defimplementation frame-catch-tags (index)
181 heller 1.1 (declare (ignore index))
182     nil)
183    
184 heller 1.21 (defimplementation disassemble-frame (index)
185     (disassemble (debugger:frame-function (nth-frame index))))
186    
187 heller 1.10 (defimplementation frame-source-location-for-emacs (index)
188 lgorrie 1.37 (let* ((frame (nth-frame index))
189     (expr (debugger:frame-expression frame))
190     (fspec (first expr)))
191     (second (first (fspec-definition-locations fspec)))))
192 heller 1.4
193 heller 1.10 (defimplementation eval-in-frame (form frame-number)
194     (debugger:eval-form-in-context
195     form
196     (debugger:environment-of-frame (nth-frame frame-number))))
197    
198 heller 1.11 (defimplementation return-from-frame (frame-number form)
199     (let ((frame (nth-frame frame-number)))
200     (multiple-value-call #'debugger:frame-return
201     frame (debugger:eval-form-in-context
202 heller 1.20 form
203     (debugger:environment-of-frame frame)))))
204 heller 1.67
205 heller 1.11 (defimplementation restart-frame (frame-number)
206     (let ((frame (nth-frame frame-number)))
207 heller 1.67 (apply #'debugger:frame-retry
208     (append (list frame (debugger:frame-function frame))
209     (cdr (debugger:frame-expression frame))))))
210    
211 heller 1.8 ;;;; Compiler hooks
212    
213 heller 1.1 (defvar *buffer-name* nil)
214     (defvar *buffer-start-position*)
215     (defvar *buffer-string*)
216 lgorrie 1.33 (defvar *compile-filename* nil)
217 heller 1.1
218 heller 1.66 (defun compiler-note-p (object)
219     (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
220    
221     (defun compiler-undefined-functions-called-warning-p (object)
222     #-allegro-v5.0
223     (typep object 'excl:compiler-undefined-functions-called-warning))
224 heller 1.64
225     (deftype compiler-note ()
226     `(satisfies compiler-note-p))
227    
228 heller 1.66 (defun signal-compiler-condition (&rest args)
229     (signal (apply #'make-condition 'compiler-condition args)))
230    
231 heller 1.1 (defun handle-compiler-warning (condition)
232 heller 1.66 (declare (optimize (debug 3) (speed 0) (space 0)))
233     (cond ((and (not *buffer-name*)
234     (compiler-undefined-functions-called-warning-p condition))
235     (handle-undefined-functions-warning condition))
236     (t
237     (signal-compiler-condition
238     :original-condition condition
239     :severity (etypecase condition
240     (warning :warning)
241     (compiler-note :note))
242     :message (format nil "~A" condition)
243     :location (location-for-warning condition)))))
244    
245     (defun location-for-warning (condition)
246 heller 1.1 (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
247 heller 1.66 (cond (*buffer-name*
248     (make-location
249     (list :buffer *buffer-name*)
250     (list :position *buffer-start-position*)))
251     (loc
252     (destructuring-bind (file . pos) loc
253     (make-location
254     (list :file (namestring (truename file)))
255     (list :position (1+ pos)))))
256     (t
257     (list :error "No error location available.")))))
258    
259     (defun handle-undefined-functions-warning (condition)
260     (let ((fargs (slot-value condition 'excl::format-arguments)))
261 heller 1.67 (loop for (fname . pos-file) in (car fargs) do
262     (loop for (pos file) in pos-file do
263     (signal-compiler-condition
264     :original-condition condition
265     :severity :warning
266     :message (format nil "Undefined function referenced: ~S"
267     fname)
268     :location (make-location (list :file file)
269     (list :position (1+ pos))))))))
270 lgorrie 1.33
271     (defimplementation call-with-compilation-hooks (function)
272 heller 1.64 (handler-bind ((warning #'handle-compiler-warning)
273     (compiler-note #'handle-compiler-warning))
274 lgorrie 1.33 (funcall function)))
275 heller 1.1
276 heller 1.20 (defimplementation swank-compile-file (*compile-filename* load-p)
277 lgorrie 1.33 (with-compilation-hooks ()
278 heller 1.1 (let ((*buffer-name* nil))
279 heller 1.4 (compile-file *compile-filename* :load-after-compile load-p))))
280 heller 1.1
281 heller 1.46 (defun call-with-temp-file (fn)
282     (let ((tmpname (system:make-temp-file-name)))
283     (unwind-protect
284     (with-open-file (file tmpname :direction :output :if-exists :error)
285     (funcall fn file tmpname))
286     (delete-file tmpname))))
287    
288     (defun compile-from-temp-file (string)
289     (call-with-temp-file
290     (lambda (stream filename)
291     (write-string string stream)
292     (finish-output stream)
293     (let ((binary-filename (compile-file filename :load-after-compile t)))
294     (when binary-filename
295     (delete-file binary-filename))))))
296    
297 pseibel 1.51 (defimplementation swank-compile-string (string &key buffer position directory)
298 heller 1.46 ;; We store the source buffer in excl::*source-pathname* as a string
299 heller 1.50 ;; of the form <buffername>;<start-offset>. Quite ugly encoding, but
300 heller 1.46 ;; the fasl file is corrupted if we use some other datatype.
301 lgorrie 1.33 (with-compilation-hooks ()
302 heller 1.20 (let ((*buffer-name* buffer)
303 heller 1.1 (*buffer-start-position* position)
304 pseibel 1.51 (*buffer-string* string)
305     (*default-pathname-defaults*
306     (if directory (merge-pathnames (pathname directory))
307     *default-pathname-defaults*)))
308 heller 1.46 (compile-from-temp-file
309     (format nil "~S ~S~%~A"
310     `(in-package ,(package-name *package*))
311     `(eval-when (:compile-toplevel :load-toplevel)
312     (setq excl::*source-pathname*
313 heller 1.52 ',(format nil "~A;~D" buffer position)))
314 heller 1.46 string)))))
315 heller 1.1
316 heller 1.8 ;;;; Definition Finding
317    
318 heller 1.32 (defun fspec-primary-name (fspec)
319     (etypecase fspec
320 heller 1.62 (symbol fspec)
321     (list (fspec-primary-name (second fspec)))))
322 heller 1.32
323 heller 1.62 ;; If Emacs uses DOS-style eol conventions, \n\r are considered as a
324     ;; single character, but file-position counts them as two. Here we do
325     ;; our own conversion.
326     (defun count-cr (file pos)
327     (let* ((bufsize 256)
328 heller 1.63 (type '(unsigned-byte 8))
329     (buf (make-array bufsize :element-type type))
330 heller 1.62 (cr-count 0))
331 heller 1.63 (with-open-file (stream file :direction :input :element-type type)
332     (loop for bytes-read = (read-sequence buf stream) do
333     (incf cr-count (count (char-code #\return) buf
334     :end (min pos bytes-read)))
335     (decf pos bytes-read)
336     (when (<= pos 0)
337     (return cr-count))))))
338 heller 1.62
339 heller 1.60 (defun find-definition-in-file (fspec type file)
340 heller 1.62 (let* ((start (or (scm:find-definition-in-file fspec type file)
341     (scm:find-definition-in-file (fspec-primary-name fspec)
342     type file)))
343 heller 1.60 (pos (if start
344 heller 1.62 (list :position (1+ (- start (count-cr file start))))
345     (list :function-name (string (fspec-primary-name fspec))))))
346     (make-location (list :file (namestring (truename file)))
347     pos)))
348 heller 1.60
349     (defun find-definition-in-buffer (filename)
350     (let ((pos (position #\; filename :from-end t)))
351     (make-location
352     (list :buffer (subseq filename 0 pos))
353     (list :position (parse-integer (subseq filename (1+ pos)))))))
354    
355 heller 1.21 (defun find-fspec-location (fspec type)
356 heller 1.52 (multiple-value-bind (file err) (ignore-errors (excl:source-file fspec type))
357 heller 1.21 (etypecase file
358     (pathname
359 heller 1.60 (find-definition-in-file fspec type file))
360 heller 1.21 ((member :top-level)
361 heller 1.52 (list :error (format nil "Defined at toplevel: ~A"
362     (fspec->string fspec))))
363 heller 1.46 (string
364 heller 1.60 (find-definition-in-buffer file))
365 heller 1.21 (null
366 heller 1.52 (list :error (if err
367     (princ-to-string err)
368     (format nil "Unknown source location for ~A"
369 heller 1.60 (fspec->string fspec)))))
370     (cons
371     (destructuring-bind ((type . filename)) file
372     (assert (member type '(:operator)))
373     (etypecase filename
374     (pathname
375     (find-definition-in-file fspec type filename))
376     (string
377     (find-definition-in-buffer filename))))))))
378 lgorrie 1.49
379 heller 1.50 (defun fspec->string (fspec)
380 lgorrie 1.49 (etypecase fspec
381 heller 1.50 (symbol (let ((*package* (find-package :keyword)))
382     (prin1-to-string fspec)))
383     (list (format nil "(~A ~A)"
384     (prin1-to-string (first fspec))
385     (let ((*package* (find-package :keyword)))
386     (prin1-to-string (second fspec)))))))
387 heller 1.21
388     (defun fspec-definition-locations (fspec)
389 heller 1.1 (let ((defs (excl::find-multiple-definitions fspec)))
390 heller 1.21 (loop for (fspec type) in defs
391 lgorrie 1.49 collect (list (list type fspec)
392     (find-fspec-location fspec type)))))
393 heller 1.21
394     (defimplementation find-definitions (symbol)
395     (fspec-definition-locations symbol))
396 heller 1.1
397 heller 1.8 ;;;; XREF
398    
399 heller 1.21 (defmacro defxref (name relation name1 name2)
400     `(defimplementation ,name (x)
401     (xref-result (xref:get-relation ,relation ,name1 ,name2))))
402    
403     (defxref who-calls :calls :wild x)
404     (defxref who-references :uses :wild x)
405     (defxref who-binds :binds :wild x)
406     (defxref who-macroexpands :macro-calls :wild x)
407     (defxref who-sets :sets :wild x)
408     (defxref list-callees :calls x :wild)
409    
410     (defun xref-result (fspecs)
411     (loop for fspec in fspecs
412     append (fspec-definition-locations fspec)))
413 heller 1.46
414     ;; list-callers implemented by groveling through all fbound symbols.
415     ;; Only symbols are considered. Functions in the constant pool are
416     ;; searched recursevly. Closure environments are ignored at the
417     ;; moment (constants in methods are therefore not found).
418    
419     (defun map-function-constants (function fn depth)
420     "Call FN with the elements of FUNCTION's constant pool."
421     (do ((i 0 (1+ i))
422     (max (excl::function-constant-count function)))
423     ((= i max))
424     (let ((c (excl::function-constant function i)))
425     (cond ((and (functionp c)
426     (not (eq c function))
427     (plusp depth))
428     (map-function-constants c fn (1- depth)))
429     (t
430     (funcall fn c))))))
431    
432 heller 1.64 (defun in-constants-p (fun symbol)
433     (map-function-constants fun
434     (lambda (c)
435     (when (eq c symbol)
436     (return-from in-constants-p t)))
437     3))
438 heller 1.46
439     (defun function-callers (name)
440     (let ((callers '()))
441     (do-all-symbols (sym)
442     (when (fboundp sym)
443     (let ((fn (fdefinition sym)))
444     (when (in-constants-p fn name)
445     (push sym callers)))))
446     callers))
447    
448     (defimplementation list-callers (name)
449     (xref-result (function-callers name)))
450 heller 1.4
451 heller 1.18 ;;;; Inspecting
452    
453 mbaringer 1.56 (defclass acl-inspector (inspector)
454     ())
455    
456     (defimplementation make-default-inspector ()
457     (make-instance 'acl-inspector))
458    
459 mbaringer 1.55 ;; duplicated from swank.lisp in order to avoid package dependencies
460     (defun common-seperated-spec (list &optional (callback (lambda (v) `(:value ,v))))
461     (butlast
462     (loop
463     for i in list
464     collect (funcall callback i)
465     collect ", ")))
466    
467 heller 1.62 #-allegro-v5.0
468     (defmethod inspect-for-emacs ((f function) inspector)
469     inspector
470 mbaringer 1.56 (values "A function."
471 heller 1.62 (append
472     (label-value-line "Name" (function-name f))
473     `("Formals" ,(princ-to-string (arglist f)) (:newline))
474     (let ((doc (documentation (excl::external-fn_symdef f) 'function)))
475     (when doc
476     `("Documentation:" (:newline) ,doc))))))
477    
478 mbaringer 1.55
479 mbaringer 1.56 (defmethod inspect-for-emacs ((class structure-class) (inspector acl-inspector))
480 mbaringer 1.55 (values "A structure class."
481     `("Name: " (:value ,(class-name class))
482     (:newline)
483     "Super classes: " ,@(common-seperated-spec (swank-mop:class-direct-superclasses class))
484     (:newline)
485     "Direct Slots: " ,@(common-seperated-spec (swank-mop:class-direct-slots class)
486     (lambda (slot)
487     `(:value ,slot ,(princ-to-string
488     (swank-mop:slot-definition-name slot)))))
489     (:newline)
490     "Effective Slots: " ,@(if (swank-mop:class-finalized-p class)
491     (common-seperated-spec (swank-mop:class-slots class)
492     (lambda (slot)
493     `(:value ,slot ,(princ-to-string
494     (swank-mop:slot-definition-name slot)))))
495     '("N/A (class not finalized)"))
496     (:newline)
497     "Documentation:" (:newline)
498     ,@(when (documentation class t)
499     `(,(documentation class t) (:newline)))
500     "Sub classes: " ,@(common-seperated-spec (swank-mop:class-direct-subclasses class)
501     (lambda (sub)
502     `(:value ,sub ,(princ-to-string (class-name sub)))))
503     (:newline)
504     "Precedence List: " ,@(if (swank-mop:class-finalized-p class)
505     (common-seperated-spec (swank-mop:class-precedence-list class)
506     (lambda (class)
507     `(:value ,class ,(princ-to-string (class-name class)))))
508     '("N/A (class not finalized)"))
509     (:newline)
510     "Prototype: " ,(if (swank-mop:class-finalized-p class)
511     `(:value ,(swank-mop:class-prototype class))
512     '"N/A (class not finalized)"))))
513    
514 heller 1.62 #-allegro-v5.0
515 heller 1.60 (defmethod inspect-for-emacs ((slot excl::structure-slot-definition)
516     (inspector acl-inspector))
517 mbaringer 1.55 (values "A structure slot."
518 heller 1.60 `("Name: " (:value ,(swank-mop:slot-definition-name slot))
519 mbaringer 1.55 (:newline)
520     "Documentation:" (:newline)
521 heller 1.62 ,@(when (documentation slot t)
522     `((:value ,(documentation slot t)) (:newline)))
523 mbaringer 1.55 "Initform: " ,(if (swank-mop:slot-definition-initform slot)
524     `(:value ,(swank-mop:slot-definition-initform slot))
525     "#<unspecified>") (:newline)
526     "Type: " ,(if (swank-mop:slot-definition-type slot)
527     `(:value ,(swank-mop:slot-definition-type slot))
528     "#<unspecified>") (:newline)
529     "Allocation: " (:value ,(excl::slotd-allocation slot)) (:newline)
530     "Read-only: " (:value ,(excl::slotd-read-only slot)) (:newline))))
531    
532 mbaringer 1.56 (defmethod inspect-for-emacs ((o structure-object) (inspector acl-inspector))
533 mbaringer 1.55 (values "An structure object."
534     `("Structure class: " (:value ,(class-of o))
535     (:newline)
536     "Slots:" (:newline)
537     ,@(loop
538     with direct-slots = (swank-mop:class-direct-slots (class-of o))
539     for slot in (swank-mop:class-slots (class-of o))
540     for slot-def = (or (find-if (lambda (a)
541     ;; find the direct slot with the same as
542     ;; SLOT (an effective slot).
543     (eql (swank-mop:slot-definition-name a)
544     (swank-mop:slot-definition-name slot)))
545     direct-slots)
546     slot)
547     collect `(:value ,slot-def ,(princ-to-string (swank-mop:slot-definition-name slot-def)))
548     collect " = "
549     if (slot-boundp o (swank-mop:slot-definition-name slot-def))
550     collect `(:value ,(slot-value o (swank-mop:slot-definition-name slot-def)))
551     else
552     collect "#<unbound>"
553     collect '(:newline)))))
554 heller 1.62
555     (defmethod inspect-for-emacs ((o t) (inspector acl-inspector))
556     inspector
557     (values "A value." (allegro-inspect o)))
558    
559     (defmethod inspect-for-emacs ((o function) (inspector acl-inspector))
560     inspector
561     (values "A function." (allegro-inspect o)))
562    
563     (defun allegro-inspect (o)
564     (loop for (d dd) on (inspect::inspect-ctl o)
565     until (eq d dd)
566     for i from 0
567     append (frob-allegro-field-def o d i)))
568    
569     (defun frob-allegro-field-def (object def idx)
570     (with-struct (inspect::field-def- name type access) def
571     (label-value-line name
572     (ecase type
573     ((:unsigned-word :unsigned-byte :unsigned-natural
574     :unsigned-half-long)
575     (inspect::component-ref-v object access type))
576     (:lisp
577     (inspect::component-ref object access))
578     (:indirect
579     (apply #'inspect::indirect-ref object idx access))))))
580    
581     #|
582     (defun test (foo)
583     (inspect::show-object-structure foo (inspect::inspect-ctl foo) 1))
584     |#
585 mbaringer 1.55
586 heller 1.18 ;;;; Multithreading
587 heller 1.8
588 heller 1.10 (defimplementation startup-multiprocessing ()
589 heller 1.8 (mp:start-scheduler))
590    
591 heller 1.10 (defimplementation spawn (fn &key name)
592 lgorrie 1.47 (mp:process-run-function name fn))
593 heller 1.8
594 heller 1.40 (defvar *id-lock* (mp:make-process-lock :name "id lock"))
595     (defvar *thread-id-counter* 0)
596    
597     (defimplementation thread-id (thread)
598     (mp:with-process-lock (*id-lock*)
599     (or (getf (mp:process-property-list thread) 'id)
600     (setf (getf (mp:process-property-list thread) 'id)
601     (incf *thread-id-counter*)))))
602    
603     (defimplementation find-thread (id)
604     (find id mp:*all-processes*
605     :key (lambda (p) (getf (mp:process-property-list p) 'id))))
606    
607 heller 1.13 (defimplementation thread-name (thread)
608     (mp:process-name thread))
609 heller 1.8
610 heller 1.13 (defimplementation thread-status (thread)
611     (format nil "~A ~D" (mp:process-whostate thread)
612     (mp:process-priority thread)))
613 heller 1.8
614 heller 1.10 (defimplementation make-lock (&key name)
615 heller 1.8 (mp:make-process-lock :name name))
616    
617 heller 1.10 (defimplementation call-with-lock-held (lock function)
618 heller 1.8 (mp:with-process-lock (lock) (funcall function)))
619 heller 1.12
620     (defimplementation current-thread ()
621     mp:*current-process*)
622    
623     (defimplementation all-threads ()
624 heller 1.13 (copy-list mp:*all-processes*))
625 heller 1.12
626     (defimplementation interrupt-thread (thread fn)
627     (mp:process-interrupt thread fn))
628    
629 heller 1.16 (defimplementation kill-thread (thread)
630     (mp:process-kill thread))
631    
632 heller 1.12 (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
633    
634     (defstruct (mailbox (:conc-name mailbox.))
635     (mutex (mp:make-process-lock :name "process mailbox"))
636     (queue '() :type list))
637    
638     (defun mailbox (thread)
639     "Return THREAD's mailbox."
640     (mp:with-process-lock (*mailbox-lock*)
641     (or (getf (mp:process-property-list thread) 'mailbox)
642     (setf (getf (mp:process-property-list thread) 'mailbox)
643     (make-mailbox)))))
644    
645     (defimplementation send (thread message)
646     (let* ((mbox (mailbox thread))
647     (mutex (mailbox.mutex mbox)))
648 heller 1.25 (mp:process-wait-with-timeout
649     "yielding before sending" 0.1
650     (lambda ()
651     (mp:with-process-lock (mutex)
652 heller 1.26 (< (length (mailbox.queue mbox)) 10))))
653 heller 1.12 (mp:with-process-lock (mutex)
654     (setf (mailbox.queue mbox)
655     (nconc (mailbox.queue mbox) (list message))))))
656    
657     (defimplementation receive ()
658     (let* ((mbox (mailbox mp:*current-process*))
659     (mutex (mailbox.mutex mbox)))
660     (mp:process-wait "receive" #'mailbox.queue mbox)
661     (mp:with-process-lock (mutex)
662     (pop (mailbox.queue mbox)))))
663 mbaringer 1.27
664     (defimplementation quit-lisp ()
665     (excl:exit 0 :quiet t))

  ViewVC Help
Powered by ViewVC 1.1.5