/local-lisp/slime/swank-allegro.lisp
Lisp | 908 lines | 712 code | 141 blank | 55 comment | 19 complexity | d5c2f45bb91308ad771bf055d3fc47e2 MD5 | raw file
Possible License(s): GPL-3.0, CC-BY-SA-4.0, GPL-2.0, Unlicense
- ;;;; -*- indent-tabs-mode: nil; outline-regexp: ";;;;;* "; -*-
- ;;;
- ;;; swank-allegro.lisp --- Allegro CL specific code for SLIME.
- ;;;
- ;;; Created 2003
- ;;;
- ;;; This code has been placed in the Public Domain. All warranties
- ;;; are disclaimed.
- ;;;
- (in-package :swank-backend)
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (require :sock)
- (require :process)
- #+(version>= 8 2)
- (require 'lldb)
- )
- (import-from :excl *gray-stream-symbols* :swank-backend)
- ;;; swank-mop
- (import-swank-mop-symbols :clos '(:slot-definition-documentation))
- (defun swank-mop:slot-definition-documentation (slot)
- (documentation slot t))
- ;;;; TCP Server
- (defimplementation preferred-communication-style ()
- :spawn)
- (defimplementation create-socket (host port)
- (socket:make-socket :connect :passive :local-port port
- :local-host host :reuse-address t))
- (defimplementation local-port (socket)
- (socket:local-port socket))
- (defimplementation close-socket (socket)
- (close socket))
- (defimplementation accept-connection (socket &key external-format buffering
- timeout)
- (declare (ignore buffering timeout))
- (let ((s (socket:accept-connection socket :wait t)))
- (when external-format
- (setf (stream-external-format s) external-format))
- s))
- (defimplementation socket-fd (stream)
- (excl::stream-input-handle stream))
- (defvar *external-format-to-coding-system*
- '((:iso-8859-1
- "latin-1" "latin-1-unix" "iso-latin-1-unix"
- "iso-8859-1" "iso-8859-1-unix")
- (:utf-8 "utf-8" "utf-8-unix")
- (:euc-jp "euc-jp" "euc-jp-unix")
- (:us-ascii "us-ascii" "us-ascii-unix")
- (:emacs-mule "emacs-mule" "emacs-mule-unix")))
- (defimplementation find-external-format (coding-system)
- (let ((e (rassoc-if (lambda (x) (member coding-system x :test #'equal))
- *external-format-to-coding-system*)))
- (and e (excl:crlf-base-ef
- (excl:find-external-format (car e)
- :try-variant t)))))
- (defimplementation format-sldb-condition (c)
- (princ-to-string c))
- (defimplementation call-with-syntax-hooks (fn)
- (funcall fn))
- ;;;; Unix signals
- (defimplementation getpid ()
- (excl::getpid))
- (defimplementation lisp-implementation-type-name ()
- "allegro")
- (defimplementation set-default-directory (directory)
- (let* ((dir (namestring (truename (merge-pathnames directory)))))
- (setf *default-pathname-defaults* (pathname (excl:chdir dir)))
- dir))
- (defimplementation default-directory ()
- (namestring (excl:current-directory)))
- ;;;; Misc
- (defimplementation arglist (symbol)
- (handler-case (excl:arglist symbol)
- (simple-error () :not-available)))
- (defimplementation macroexpand-all (form)
- (excl::walk form))
- (defimplementation describe-symbol-for-emacs (symbol)
- (let ((result '()))
- (flet ((doc (kind &optional (sym symbol))
- (or (documentation sym kind) :not-documented))
- (maybe-push (property value)
- (when value
- (setf result (list* property value result)))))
- (maybe-push
- :variable (when (boundp symbol)
- (doc 'variable)))
- (maybe-push
- :function (if (fboundp symbol)
- (doc 'function)))
- (maybe-push
- :class (if (find-class symbol nil)
- (doc 'class)))
- result)))
- (defimplementation describe-definition (symbol namespace)
- (ecase namespace
- (:variable
- (describe symbol))
- ((:function :generic-function)
- (describe (symbol-function symbol)))
- (:class
- (describe (find-class symbol)))))
- ;;;; Debugger
- (defvar *sldb-topframe*)
- (defimplementation call-with-debugging-environment (debugger-loop-fn)
- (let ((*sldb-topframe* (find-topframe))
- (excl::*break-hook* nil))
- (funcall debugger-loop-fn)))
- (defimplementation sldb-break-at-start (fname)
- ;; :print-before is kind of mis-used but we just want to stuff our
- ;; break form somewhere. This does not work for setf, :before and
- ;; :after methods, which need special syntax in the trace call, see
- ;; ACL's doc/debugging.htm chapter 10.
- (eval `(trace (,fname
- :print-before
- ((break "Function start breakpoint of ~A" ',fname)))))
- `(:ok ,(format nil "Set breakpoint at start of ~S" fname)))
- (defun find-topframe ()
- (let ((magic-symbol (intern (symbol-name :swank-debugger-hook)
- (find-package :swank)))
- (top-frame (excl::int-newest-frame)))
- (loop for frame = top-frame then (next-frame frame)
- for name = (debugger:frame-name frame)
- for i from 0
- when (eq name magic-symbol)
- return (next-frame frame)
- until (= i 10) finally (return top-frame))))
- (defun next-frame (frame)
- (let ((next (excl::int-next-older-frame frame)))
- (cond ((not next) nil)
- ((debugger:frame-visible-p next) next)
- (t (next-frame next)))))
- (defun nth-frame (index)
- (do ((frame *sldb-topframe* (next-frame frame))
- (i index (1- i)))
- ((zerop i) frame)))
- (defimplementation compute-backtrace (start end)
- (let ((end (or end most-positive-fixnum)))
- (loop for f = (nth-frame start) then (next-frame f)
- for i from start below end
- while f collect f)))
- (defimplementation print-frame (frame stream)
- (debugger:output-frame stream frame :moderate))
- (defimplementation frame-locals (index)
- (let ((frame (nth-frame index)))
- (loop for i from 0 below (debugger:frame-number-vars frame)
- collect (list :name (debugger:frame-var-name frame i)
- :id 0
- :value (debugger:frame-var-value frame i)))))
- (defimplementation frame-var-value (frame var)
- (let ((frame (nth-frame frame)))
- (debugger:frame-var-value frame var)))
- (defimplementation disassemble-frame (index)
- (let ((frame (nth-frame index)))
- (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
- (format t "pc: ~d (~s ~s ~s)~%fun: ~a~%" pc x xx xxx fun)
- (disassemble (debugger:frame-function frame)))))
- (defimplementation frame-source-location (index)
- (let* ((frame (nth-frame index)))
- (multiple-value-bind (x fun xx xxx pc) (debugger::dyn-fd-analyze frame)
- (declare (ignore x xx xxx))
- (cond (pc
- #+(version>= 8 2)
- (pc-source-location fun pc)
- #-(version>= 8 2)
- (function-source-location fun))
- (t ; frames for unbound functions etc end up here
- (cadr (car (fspec-definition-locations
- (car (debugger:frame-expression frame))))))))))
- (defun function-source-location (fun)
- (cadr (car (fspec-definition-locations (xref::object-to-function-name fun)))))
- #+(version>= 8 2)
- (defun pc-source-location (fun pc)
- (let* ((debug-info (excl::function-source-debug-info fun)))
- (cond ((not debug-info)
- (function-source-location fun))
- (t
- (let* ((code-loc (find-if (lambda (c)
- (<= (- pc (sys::natural-width))
- (excl::ldb-code-pc c)
- pc))
- debug-info)))
- (cond ((not code-loc)
- (ldb-code-to-src-loc (aref debug-info 0)))
- (t
- (ldb-code-to-src-loc code-loc))))))))
- #+(version>= 8 2)
- (defun ldb-code-to-src-loc (code)
- (let* ((start (excl::ldb-code-start-char code))
- (func (excl::ldb-code-func code))
- (src-file (excl:source-file func)))
- (cond (start
- (buffer-or-file-location src-file start))
- (t
- (let* ((debug-info (excl::function-source-debug-info func))
- (whole (aref debug-info 0))
- (paths (source-paths-of (excl::ldb-code-source whole)
- (excl::ldb-code-source code)))
- (path (longest-common-prefix paths))
- (start (excl::ldb-code-start-char whole)))
- (buffer-or-file
- src-file
- (lambda (file)
- (make-location `(:file ,file)
- `(:source-path (0 . ,path) ,start)))
- (lambda (buffer bstart)
- (make-location `(:buffer ,buffer)
- `(:source-path (0 . ,path)
- ,(+ bstart start))))))))))
-
- (defun longest-common-prefix (sequences)
- (assert sequences)
- (flet ((common-prefix (s1 s2)
- (let ((diff-pos (mismatch s1 s2)))
- (if diff-pos (subseq s1 0 diff-pos) s1))))
- (reduce #'common-prefix sequences)))
- (defun source-paths-of (whole part)
- (let ((result '()))
- (labels ((walk (form path)
- (cond ((eq form part)
- (push (reverse path) result))
- ((consp form)
- (loop for i from 0 while (consp form) do
- (walk (pop form) (cons i path)))))))
- (walk whole '())
- (reverse result))))
- (defimplementation eval-in-frame (form frame-number)
- (let ((frame (nth-frame frame-number)))
- ;; let-bind lexical variables
- (let ((vars (loop for i below (debugger:frame-number-vars frame)
- for name = (debugger:frame-var-name frame i)
- if (symbolp name)
- collect `(,name ',(debugger:frame-var-value frame i)))))
- (debugger:eval-form-in-context
- `(let* ,vars ,form)
- (debugger:environment-of-frame frame)))))
- (defimplementation return-from-frame (frame-number form)
- (let ((frame (nth-frame frame-number)))
- (multiple-value-call #'debugger:frame-return
- frame (debugger:eval-form-in-context
- form
- (debugger:environment-of-frame frame)))))
- (defimplementation frame-restartable-p (frame)
- (handler-case (debugger:frame-retryable-p frame)
- (serious-condition (c)
- (funcall (read-from-string "swank::background-message")
- "~a ~a" frame (princ-to-string c))
- nil)))
- (defimplementation restart-frame (frame-number)
- (let ((frame (nth-frame frame-number)))
- (cond ((debugger:frame-retryable-p frame)
- (apply #'debugger:frame-retry frame (debugger:frame-function frame)
- (cdr (debugger:frame-expression frame))))
- (t "Frame is not retryable"))))
- ;;;; Compiler hooks
- (defvar *buffer-name* nil)
- (defvar *buffer-start-position*)
- (defvar *buffer-string*)
- (defvar *compile-filename* nil)
- (defun compiler-note-p (object)
- (member (type-of object) '(excl::compiler-note compiler::compiler-note)))
- (defun redefinition-p (condition)
- (and (typep condition 'style-warning)
- (every #'char-equal "redefin" (princ-to-string condition))))
- (defun compiler-undefined-functions-called-warning-p (object)
- (typep object 'excl:compiler-undefined-functions-called-warning))
- (deftype compiler-note ()
- `(satisfies compiler-note-p))
- (deftype redefinition ()
- `(satisfies redefinition-p))
- (defun signal-compiler-condition (&rest args)
- (signal (apply #'make-condition 'compiler-condition args)))
- (defun handle-compiler-warning (condition)
- (declare (optimize (debug 3) (speed 0) (space 0)))
- (cond ((and (not *buffer-name*)
- (compiler-undefined-functions-called-warning-p condition))
- (handle-undefined-functions-warning condition))
- (t
- (signal-compiler-condition
- :original-condition condition
- :severity (etypecase condition
- (redefinition :redefinition)
- (style-warning :style-warning)
- (warning :warning)
- (compiler-note :note)
- (reader-error :read-error)
- (error :error))
- :message (format nil "~A" condition)
- :location (if (typep condition 'reader-error)
- (location-for-reader-error condition)
- (location-for-warning condition))))))
- (defun location-for-warning (condition)
- (let ((loc (getf (slot-value condition 'excl::plist) :loc)))
- (cond (*buffer-name*
- (make-location
- (list :buffer *buffer-name*)
- (list :offset *buffer-start-position* 0)))
- (loc
- (destructuring-bind (file . pos) loc
- (let ((start (cond ((consp pos) ; 8.2 and newer
- (car pos))
- (t pos))))
- (make-location
- (list :file (namestring (truename file)))
- (list :position (1+ start))))))
- (t
- (make-error-location "No error location available.")))))
- (defun location-for-reader-error (condition)
- (let ((pos (car (last (slot-value condition 'excl::format-arguments))))
- (file (pathname (stream-error-stream condition))))
- (if (integerp pos)
- (if *buffer-name*
- (make-location `(:buffer ,*buffer-name*)
- `(:offset ,*buffer-start-position* ,pos))
- (make-location `(:file ,(namestring (truename file)))
- `(:position ,pos)))
- (make-error-location "No error location available."))))
- ;; TODO: report it as a bug to Franz that the condition's plist
- ;; slot contains (:loc nil).
- (defun handle-undefined-functions-warning (condition)
- (let ((fargs (slot-value condition 'excl::format-arguments)))
- (loop for (fname . locs) in (car fargs) do
- (dolist (loc locs)
- (multiple-value-bind (pos file) (ecase (length loc)
- (2 (values-list loc))
- (3 (destructuring-bind
- (start end file) loc
- (declare (ignore end))
- (values start file))))
- (signal-compiler-condition
- :original-condition condition
- :severity :warning
- :message (format nil "Undefined function referenced: ~S"
- fname)
- :location (make-location (list :file file)
- (list :position (1+ pos)))))))))
- (defimplementation call-with-compilation-hooks (function)
- (handler-bind ((warning #'handle-compiler-warning)
- (compiler-note #'handle-compiler-warning)
- (reader-error #'handle-compiler-warning))
- (funcall function)))
- (defimplementation swank-compile-file (input-file output-file
- load-p external-format
- &key policy)
- (declare (ignore policy))
- (handler-case
- (with-compilation-hooks ()
- (let ((*buffer-name* nil)
- (*compile-filename* input-file))
- (compile-file *compile-filename*
- :output-file output-file
- :load-after-compile load-p
- :external-format external-format)))
- (reader-error () (values nil nil t))))
- (defun call-with-temp-file (fn)
- (let ((tmpname (system:make-temp-file-name)))
- (unwind-protect
- (with-open-file (file tmpname :direction :output :if-exists :error)
- (funcall fn file tmpname))
- (delete-file tmpname))))
- (defvar *temp-file-map* (make-hash-table :test #'equal)
- "A mapping from tempfile names to Emacs buffer names.")
- (defun compile-from-temp-file (string buffer offset file)
- (call-with-temp-file
- (lambda (stream filename)
- (let ((excl:*load-source-file-info* t)
- (sys:*source-file-types* '(nil)) ; suppress .lisp extension
- #+(version>= 8 2)
- (compiler:save-source-level-debug-info-switch t)
- #+(version>= 8 2)
- (excl:*load-source-debug-info* t) ; NOTE: requires lldb
- )
- (write-string string stream)
- (finish-output stream)
- (multiple-value-bind (binary-filename warnings? failure?)
- (excl:without-redefinition-warnings
- ;; Suppress Allegro's redefinition warnings; they are
- ;; pointless when we are compiling via a temporary
- ;; file.
- (compile-file filename :load-after-compile t))
- (declare (ignore warnings?))
- (when binary-filename
- (setf (gethash (pathname stream) *temp-file-map*)
- (list buffer offset file))
- (delete-file binary-filename))
- (not failure?))))))
- (defimplementation swank-compile-string (string &key buffer position filename
- policy)
- (declare (ignore policy))
- (handler-case
- (with-compilation-hooks ()
- (let ((*buffer-name* buffer)
- (*buffer-start-position* position)
- (*buffer-string* string)
- (*default-pathname-defaults*
- (if filename
- (merge-pathnames (pathname filename))
- *default-pathname-defaults*)))
- (compile-from-temp-file string buffer position filename)))
- (reader-error () (values nil nil t))))
- ;;;; Definition Finding
- (defun buffer-or-file (file file-fun buffer-fun)
- (let* ((probe (gethash file *temp-file-map*)))
- (cond (probe
- (destructuring-bind (buffer start file) probe
- (declare (ignore file))
- (funcall buffer-fun buffer start)))
- (t (funcall file-fun (namestring (truename file)))))))
- (defun buffer-or-file-location (file offset)
- (buffer-or-file file
- (lambda (filename)
- (make-location `(:file ,filename)
- `(:position ,(1+ offset))))
- (lambda (buffer start)
- (make-location `(:buffer ,buffer)
- `(:offset ,start ,offset)))))
- (defun fspec-primary-name (fspec)
- (etypecase fspec
- (symbol fspec)
- (list (fspec-primary-name (second fspec)))))
- (defun find-definition-in-file (fspec type file top-level)
- (let* ((part
- (or (scm::find-definition-in-definition-group
- fspec type (scm:section-file :file file)
- :top-level top-level)
- (scm::find-definition-in-definition-group
- (fspec-primary-name fspec)
- type (scm:section-file :file file)
- :top-level top-level)))
- (start (and part
- (scm::source-part-start part)))
- (pos (if start
- (list :position (1+ start))
- (list :function-name (string (fspec-primary-name fspec))))))
- (make-location (list :file (namestring (truename file)))
- pos)))
- (defun find-fspec-location (fspec type file top-level)
- (handler-case
- (etypecase file
- (pathname
- (let ((probe (gethash file *temp-file-map*)))
- (cond (probe
- (destructuring-bind (buffer offset file) probe
- (declare (ignore file))
- (make-location `(:buffer ,buffer)
- `(:offset ,offset 0))))
- (t
- (find-definition-in-file fspec type file top-level)))))
- ((member :top-level)
- (make-error-location "Defined at toplevel: ~A" (fspec->string fspec))))
- (error (e)
- (make-error-location "Error: ~A" e))))
- (defun fspec->string (fspec)
- (typecase fspec
- (symbol (let ((*package* (find-package :keyword)))
- (prin1-to-string fspec)))
- (list (format nil "(~A ~A)"
- (prin1-to-string (first fspec))
- (let ((*package* (find-package :keyword)))
- (prin1-to-string (second fspec)))))
- (t (princ-to-string fspec))))
- (defun fspec-definition-locations (fspec)
- (cond
- ((and (listp fspec)
- (eql (car fspec) :top-level-form))
- (destructuring-bind (top-level-form file &optional (position 0)) fspec
- (declare (ignore top-level-form))
- `((,fspec
- ,(buffer-or-file-location file position)))))
- ((and (listp fspec) (eq (car fspec) :internal))
- (destructuring-bind (_internal next _n) fspec
- (declare (ignore _internal _n))
- (fspec-definition-locations next)))
- (t
- (let ((defs (excl::find-source-file fspec)))
- (when (and (null defs)
- (listp fspec)
- (string= (car fspec) '#:method))
- ;; If methods are defined in a defgeneric form, the source location is
- ;; recorded for the gf but not for the methods. Therefore fall back to
- ;; the gf as the likely place of definition.
- (setq defs (excl::find-source-file (second fspec))))
- (if (null defs)
- (list
- (list fspec
- (make-error-location "Unknown source location for ~A"
- (fspec->string fspec))))
- (loop for (fspec type file top-level) in defs collect
- (list (list type fspec)
- (find-fspec-location fspec type file top-level))))))))
- (defimplementation find-definitions (symbol)
- (fspec-definition-locations symbol))
- ;;;; XREF
- (defmacro defxref (name relation name1 name2)
- `(defimplementation ,name (x)
- (xref-result (xref:get-relation ,relation ,name1 ,name2))))
- (defxref who-calls :calls :wild x)
- (defxref calls-who :calls x :wild)
- (defxref who-references :uses :wild x)
- (defxref who-binds :binds :wild x)
- (defxref who-macroexpands :macro-calls :wild x)
- (defxref who-sets :sets :wild x)
- (defun xref-result (fspecs)
- (loop for fspec in fspecs
- append (fspec-definition-locations fspec)))
- ;; list-callers implemented by groveling through all fbound symbols.
- ;; Only symbols are considered. Functions in the constant pool are
- ;; searched recursively. Closure environments are ignored at the
- ;; moment (constants in methods are therefore not found).
- (defun map-function-constants (function fn depth)
- "Call FN with the elements of FUNCTION's constant pool."
- (do ((i 0 (1+ i))
- (max (excl::function-constant-count function)))
- ((= i max))
- (let ((c (excl::function-constant function i)))
- (cond ((and (functionp c)
- (not (eq c function))
- (plusp depth))
- (map-function-constants c fn (1- depth)))
- (t
- (funcall fn c))))))
- (defun in-constants-p (fun symbol)
- (map-function-constants fun
- (lambda (c)
- (when (eq c symbol)
- (return-from in-constants-p t)))
- 3))
-
- (defun function-callers (name)
- (let ((callers '()))
- (do-all-symbols (sym)
- (when (fboundp sym)
- (let ((fn (fdefinition sym)))
- (when (in-constants-p fn name)
- (push sym callers)))))
- callers))
- (defimplementation list-callers (name)
- (xref-result (function-callers name)))
- (defimplementation list-callees (name)
- (let ((result '()))
- (map-function-constants (fdefinition name)
- (lambda (c)
- (when (fboundp c)
- (push c result)))
- 2)
- (xref-result result)))
- ;;;; Profiling
- ;; Per-function profiling based on description in
- ;; http://www.franz.com/support/documentation/8.0/doc/runtime-analyzer.htm#data-collection-control-2
- (defvar *profiled-functions* ())
- (defvar *profile-depth* 0)
- (defmacro with-redirected-y-or-n-p (&body body)
- ;; If the profiler is restarted when the data from the previous
- ;; session is not reported yet, the user is warned via Y-OR-N-P.
- ;; As the CL:Y-OR-N-P question is (for some reason) not directly
- ;; sent to the Slime user, the function CL:Y-OR-N-P is temporarily
- ;; overruled.
- `(let* ((pkg (find-package "common-lisp"))
- (saved-pdl (excl::package-definition-lock pkg))
- (saved-ynp (symbol-function 'cl:y-or-n-p)))
-
- (setf (excl::package-definition-lock pkg) nil
- (symbol-function 'cl:y-or-n-p) (symbol-function
- (find-symbol "y-or-n-p-in-emacs"
- "swank")))
- (unwind-protect
- (progn ,@body)
-
- (setf (symbol-function 'cl:y-or-n-p) saved-ynp
- (excl::package-definition-lock pkg) saved-pdl))))
- (defun start-acl-profiler ()
- (with-redirected-y-or-n-p
- (prof:start-profiler :type :time :count t
- :start-sampling-p nil :verbose nil)))
- (defun acl-profiler-active-p ()
- (not (eq (prof:profiler-status :verbose nil) :inactive)))
- (defun stop-acl-profiler ()
- (prof:stop-profiler :verbose nil))
- (excl:def-fwrapper profile-fwrapper (&rest args)
- ;; Ensures sampling is done during the execution of the function,
- ;; taking into account recursion.
- (declare (ignore args))
- (cond ((zerop *profile-depth*)
- (let ((*profile-depth* (1+ *profile-depth*)))
- (prof:start-sampling)
- (unwind-protect (excl:call-next-fwrapper)
- (prof:stop-sampling))))
- (t
- (excl:call-next-fwrapper))))
- (defimplementation profile (fname)
- (unless (acl-profiler-active-p)
- (start-acl-profiler))
- (excl:fwrap fname 'profile-fwrapper 'profile-fwrapper)
- (push fname *profiled-functions*))
- (defimplementation profiled-functions ()
- *profiled-functions*)
- (defimplementation unprofile (fname)
- (excl:funwrap fname 'profile-fwrapper)
- (setq *profiled-functions* (remove fname *profiled-functions*)))
- (defimplementation profile-report ()
- (prof:show-flat-profile :verbose nil)
- (when *profiled-functions*
- (start-acl-profiler)))
- (defimplementation profile-reset ()
- (when (acl-profiler-active-p)
- (stop-acl-profiler)
- (start-acl-profiler))
- "Reset profiling counters.")
- ;;;; Inspecting
- (excl:without-redefinition-warnings
- (defmethod emacs-inspect ((o t))
- (allegro-inspect o)))
- (defmethod emacs-inspect ((o function))
- (allegro-inspect o))
- (defmethod emacs-inspect ((o standard-object))
- (allegro-inspect o))
- (defun allegro-inspect (o)
- (loop for (d dd) on (inspect::inspect-ctl o)
- append (frob-allegro-field-def o d)
- until (eq d dd)))
- (defun frob-allegro-field-def (object def)
- (with-struct (inspect::field-def- name type access) def
- (ecase type
- ((:unsigned-word :unsigned-byte :unsigned-natural
- :unsigned-long :unsigned-half-long
- :unsigned-3byte)
- (label-value-line name (inspect::component-ref-v object access type)))
- ((:lisp :value :func)
- (label-value-line name (inspect::component-ref object access)))
- (:indirect
- (destructuring-bind (prefix count ref set) access
- (declare (ignore set prefix))
- (loop for i below (funcall count object)
- append (label-value-line (format nil "~A-~D" name i)
- (funcall ref object i))))))))
- ;;;; Multithreading
- (defimplementation initialize-multiprocessing (continuation)
- (mp:start-scheduler)
- (funcall continuation))
- (defimplementation spawn (fn &key name)
- (mp:process-run-function name fn))
- (defvar *id-lock* (mp:make-process-lock :name "id lock"))
- (defvar *thread-id-counter* 0)
- (defimplementation thread-id (thread)
- (mp:with-process-lock (*id-lock*)
- (or (getf (mp:process-property-list thread) 'id)
- (setf (getf (mp:process-property-list thread) 'id)
- (incf *thread-id-counter*)))))
- (defimplementation find-thread (id)
- (find id mp:*all-processes*
- :key (lambda (p) (getf (mp:process-property-list p) 'id))))
- (defimplementation thread-name (thread)
- (mp:process-name thread))
- (defimplementation thread-status (thread)
- (princ-to-string (mp:process-whostate thread)))
- (defimplementation thread-attributes (thread)
- (list :priority (mp:process-priority thread)
- :times-resumed (mp:process-times-resumed thread)))
- (defimplementation make-lock (&key name)
- (mp:make-process-lock :name name))
- (defimplementation call-with-lock-held (lock function)
- (mp:with-process-lock (lock) (funcall function)))
- (defimplementation current-thread ()
- mp:*current-process*)
- (defimplementation all-threads ()
- (copy-list mp:*all-processes*))
- (defimplementation interrupt-thread (thread fn)
- (mp:process-interrupt thread fn))
- (defimplementation kill-thread (thread)
- (mp:process-kill thread))
- (defvar *mailbox-lock* (mp:make-process-lock :name "mailbox lock"))
- (defstruct (mailbox (:conc-name mailbox.))
- (lock (mp:make-process-lock :name "process mailbox"))
- (queue '() :type list)
- (gate (mp:make-gate nil)))
- (defun mailbox (thread)
- "Return THREAD's mailbox."
- (mp:with-process-lock (*mailbox-lock*)
- (or (getf (mp:process-property-list thread) 'mailbox)
- (setf (getf (mp:process-property-list thread) 'mailbox)
- (make-mailbox)))))
- (defimplementation send (thread message)
- (let* ((mbox (mailbox thread)))
- (mp:with-process-lock ((mailbox.lock mbox))
- (setf (mailbox.queue mbox)
- (nconc (mailbox.queue mbox) (list message)))
- (mp:open-gate (mailbox.gate mbox)))))
- (defimplementation receive-if (test &optional timeout)
- (let ((mbox (mailbox mp:*current-process*)))
- (assert (or (not timeout) (eq timeout t)))
- (loop
- (check-slime-interrupts)
- (mp:with-process-lock ((mailbox.lock mbox))
- (let* ((q (mailbox.queue mbox))
- (tail (member-if test q)))
- (when tail
- (setf (mailbox.queue mbox) (nconc (ldiff q tail) (cdr tail)))
- (return (car tail)))
- (mp:close-gate (mailbox.gate mbox))))
- (when (eq timeout t) (return (values nil t)))
- (mp:process-wait-with-timeout "receive-if" 0.5
- #'mp:gate-open-p (mailbox.gate mbox)))))
- (defimplementation set-default-initial-binding (var form)
- (setq excl:*cl-default-special-bindings*
- (acons var form excl:*cl-default-special-bindings*)))
- (defimplementation quit-lisp ()
- (excl:exit 0 :quiet t))
- ;;Trace implementations
- ;;In Allegro 7.0, we have:
- ;; (trace <name>)
- ;; (trace ((method <name> <qualifier>? (<specializer>+))))
- ;; (trace ((labels <name> <label-name>)))
- ;; (trace ((labels (method <name> (<specializer>+)) <label-name>)))
- ;; <name> can be a normal name or a (setf name)
- (defimplementation toggle-trace (spec)
- (ecase (car spec)
- ((setf)
- (toggle-trace-aux spec))
- (:defgeneric (toggle-trace-generic-function-methods (second spec)))
- ((setf :defmethod :labels :flet)
- (toggle-trace-aux (process-fspec-for-allegro spec)))
- (:call
- (destructuring-bind (caller callee) (cdr spec)
- (toggle-trace-aux callee
- :inside (list (process-fspec-for-allegro caller)))))))
- (defun tracedp (fspec)
- (member fspec (eval '(trace)) :test #'equal))
- (defun toggle-trace-aux (fspec &rest args)
- (cond ((tracedp fspec)
- (eval `(untrace ,fspec))
- (format nil "~S is now untraced." fspec))
- (t
- (eval `(trace (,fspec ,@args)))
- (format nil "~S is now traced." fspec))))
- (defun toggle-trace-generic-function-methods (name)
- (let ((methods (mop:generic-function-methods (fdefinition name))))
- (cond ((tracedp name)
- (eval `(untrace ,name))
- (dolist (method methods (format nil "~S is now untraced." name))
- (excl:funtrace (mop:method-function method))))
- (t
- (eval `(trace (,name)))
- (dolist (method methods (format nil "~S is now traced." name))
- (excl:ftrace (mop:method-function method)))))))
- (defun process-fspec-for-allegro (fspec)
- (cond ((consp fspec)
- (ecase (first fspec)
- ((setf) fspec)
- ((:defun :defgeneric) (second fspec))
- ((:defmethod) `(method ,@(rest fspec)))
- ((:labels) `(labels ,(process-fspec-for-allegro (second fspec))
- ,(third fspec)))
- ((:flet) `(flet ,(process-fspec-for-allegro (second fspec))
- ,(third fspec)))))
- (t
- fspec)))
- ;;;; Weak hashtables
- (defimplementation make-weak-key-hash-table (&rest args)
- (apply #'make-hash-table :weak-keys t args))
- (defimplementation make-weak-value-hash-table (&rest args)
- (apply #'make-hash-table :values :weak args))
- (defimplementation hash-table-weakness (hashtable)
- (cond ((excl:hash-table-weak-keys hashtable) :key)
- ((eq (excl:hash-table-values hashtable) :weak) :value)))
- ;;;; Character names
- (defimplementation character-completion-set (prefix matchp)
- (loop for name being the hash-keys of excl::*name-to-char-table*
- when (funcall matchp prefix name)
- collect (string-capitalize name)))