Raymond Toy pushed to rtoy-unix-core at cmucl / cmucl Commits: 214a3766 by Raymond Toy at 2014-12-02T20:25:57Z Load up initial_function with the correct value for Darwin/ppc if the builtin_image_flag is set. - - - - - 4e3000cd by Raymond Toy at 2014-12-02T20:28:50Z Add bootstrap file to enable :executable feature for ppc. - - - - - ee975d1b by Raymond Toy at 2014-12-02T20:34:57Z Use the same code for sparc and ppc to handle the call_into_c entry. They were identical before anyway, so make it so. - - - - - 3dd74e81 by Raymond Toy at 2014-12-03T20:50:03Z Update from logs. - - - - - f8a84c42 by Raymond Toy at 2015-01-03T11:55:07Z Move the vpath stuff to GNUMakefile from the configs. These paths don't depend on the config so GNUMakefile is the right place. - - - - - b038df8d by Raymond Toy at 2015-01-17T10:12:21Z Simplify code to use FUNCTION_CODE_OFFSET instead of computing the value directly. - - - - - 01777725 by Raymond Toy at 2015-01-17T10:16:39Z Remove old sunos stuff from sparc-assem.S We only support Solaris now so remove the old SunOS stuff. (Besides we haven't built for SunOS in decades.) * globals.h: * Solaris uses ELF, so don't prefix names with _. * sparc-assem.S: * Remove SunOS support. * Don't prefix names with _. - - - - - 419cdec6 by Raymond Toy at 2015-03-07T21:35:05Z Add clx-inspector contrib module. Submitted by Fred Gilham, who updated and enhanced the version from Bill Chiles, Christopher Hoover, and Skef Wholey. - - - - - 2a6b55bb by Raymond Toy at 2015-04-16T19:04:59Z Merge branch 'master' into rtoy-unix-core - - - - - 22 changed files: - + src/bootfiles/20f/boot-2014-11-ppc.lisp - + src/contrib/clx-inspector/clx-inspector.asd - + src/contrib/clx-inspector/clx-inspector.catalog - + src/contrib/clx-inspector/clx-inspector.lisp - + src/contrib/clx-inspector/compile-clx-inspector.lisp - + src/contrib/clx-inspector/inspect11-d.cursor - + src/contrib/clx-inspector/inspect11-d.mask - + src/contrib/clx-inspector/inspect11-s.cursor - + src/contrib/clx-inspector/inspect11-s.mask - + src/contrib/clx-inspector/inspect11.cursor - + src/contrib/clx-inspector/inspect11.mask - + src/contrib/clx-inspector/inspector.help - src/general-info/release-21a.txt - src/lisp/Config.ppc_darwin - src/lisp/Config.sparc_common - src/lisp/Config.x86_common - src/lisp/GNUmakefile - src/lisp/globals.h - src/lisp/lisp.c - src/lisp/os-common.c - src/lisp/ppc-assem.S - src/lisp/sparc-assem.S Changes: ===================================== src/bootfiles/20f/boot-2014-11-ppc.lisp ===================================== --- /dev/null +++ b/src/bootfiles/20f/boot-2014-11-ppc.lisp @@ -0,0 +1,3 @@ +;; Enable executable feature on ppc. +#+ppc +(pushnew :executable *features*) ===================================== src/contrib/clx-inspector/clx-inspector.asd ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/clx-inspector.asd @@ -0,0 +1,18 @@ +;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- + +(in-package :asdf) + +(require :clx) + +(defsystem :clx-inspector + :name "INSPECT" + :author "Skef Wholey et. al." + :maintainer "Fred Gilham" + :license "Public Domain" + :description "Graphical Inspector" + :long-description "Inspector that uses pop-up windows to display the + objects. Updates the values of the objects in the background." + :components + ((:file "clx-inspector"))) + + ===================================== src/contrib/clx-inspector/clx-inspector.catalog ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/clx-inspector.catalog @@ -0,0 +1,39 @@ +Name: + CLX Inspector. + +Package Name: + INSPECT + +Description: + Adds another inspector style as an alternative to the console + inspector. Inspecting objects pops up windows with the + contents of the object. The values of the object are updated + in the background. Multiple windows can be displayed at the + same time. + + +Author: + Original by Skef Wholey. Ported to CLX by Christopher Hoover + with "minor tweaks" by Bill Chiles. Updated and enhanced by + Fred Gilham. + +Net Address: + fred@sunbot.homedns.org + +Copyright Status: + CMUCL public domain code. No Warranty. + +Files: + clx-inspector.lisp + + +How to Get: + Comes with CMUCL contrib library. + +Portability: + Depends on CMUCL-specific features. + +Instructions: + (require :clx-inspector) + (inspect <object>) Once the window pops up, you can type "h" + to pop up a window of instructions. ===================================== src/contrib/clx-inspector/clx-inspector.lisp ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/clx-inspector.lisp @@ -0,0 +1,2214 @@ +;;; -*- Mode: Lisp; Package: INSPECT; Log:code.log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +#+cmu +(ext:file-comment + "$Header: clx-inspector.lisp,v 1.1 2004/03/12 10:02:30 fmg $") +;;; +;;; ********************************************************************** +;;; +;;; An inspector for CMU Common Lisp. +;;; +;;; Written by Skef Wholey. +;;; Ported to CLX by Christopher Hoover with minor tweaks by Bill Chiles. +;;; +;;; Each Lisp object is displayed in its own X window, and components +;;; of each object are "mouse sensitive" items that may be selected +;;; for further investigation. +;;; +;;; Some cleanup by FMG plus adding dynamic updating of values when +;;; multiprocessing is present. (2000-2002) +;;; +;;; Converted former "home-made object system" to CLOS. FMG Oct 2002. +;;; +;;; Fix inability to deal with circular lists. Paper over problem with +;;; PCL and uninitialized slots. FMG March 2004. +;;; +;;; Cleanup and minor fixes. FMG 2015. Haha.. ten years.. still works.... +;;; Add scroll wheel support. FMG 2015. + +(declaim (optimize (speed 2) (safety 3) (debug 3) (space 1.5) (ext:inhibit-warnings 3))) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (provide :clx-inspector)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + (setf lisp::*enable-package-locked-errors* nil)) + +(in-package "COMMON-LISP-USER") + +(eval-when (:compile-toplevel :load-toplevel :execute) + (require :clx #+cmu "library:subsystems/clx-library")) + +(defpackage "INSPECT" + (:use "COMMON-LISP" "LISP" "EXTENSIONS" "KERNEL") + (:export inspect show-object remove-object-display remove-all-displays *interface-style*)) + +(in-package "INSPECT") + + +;;;; Parameters and stuff. + +(defvar *inspect-result*) + +(defparameter *update-interval* .5 + "Seconds between item window background updates.") + +;;; CLX specials + +(defvar *display* nil) +(defvar *screen* nil) +(defvar *root* nil) +(defvar *gcontext* nil) +(defvar *black-pixel* nil) +(defvar *white-pixel* nil) + +;; Inspect-Length is the number of components that will be displayed in a +;; window at any one time. If an object has more than Inspect-Length +;; components, we generally put it in a scrolling window. Inspect-Level +;; might someday correspond to Print-Level, controlling the amount of +;; detail and mouse-sensitivity we get inside components, but for now +;; it's ignored. +(defparameter inspect-length 30) +(defparameter inspect-level 1) + +;; Inspect-Print-Level and Inspect-Print-Length are used by +;; IPrin1-To-String to generate the textual representation of +;; components. +(defparameter inspect-print-length 10) +(defparameter inspect-print-level 3) + + +;; The handler-case is an easy way to handle unbound slots. From what +;; previous versions said, using slot-boundp didn't always work. +(defun iprin1-to-string (object) + (let ((*print-length* inspect-print-length) + (*print-level* inspect-print-level) + (*print-pretty* nil)) + + (handler-case (prin1-to-string object) + (unbound-slot () "Unbound")))) + + +;;;; Setting up fonts and cursors and stuff. + +;; We use Font structures to keep stuff like the character height and +;; width of a font around for quick and easy size calculations. For +;; variable width fonts, the Width slot will be Nil. + +(defstruct (font (:constructor make-font (name font height ascent width))) + name + font + height + ascent + width) + +;; The *Header-Font* is a big font usually used for displaying stuff +;; in the header portion of an object view. *Entry-Font* is used as +;; the main "body font" for an object, and *Italic-Font* is used for +;; special stuff. + +;; You can go crazy with fonts here. +;;(defparameter header-font-name "*-*-bold-r-*-sans-14-*-*") +(defparameter header-font-name "-adobe-helvetica-bold-r-*-*-14-*-*") +(defvar *header-font*) + +;; XXX You must use a fixed-width font here. Variable-width fonts +;; cause the tracking to fail miserably. +(defparameter entry-font-name "*-courier-medium-r-normal--12-*-*") +(defvar *entry-font*) + +;; XXX Better to use a fixed-width font here --- a variable-width font +;; tends to result in bits and pieces of letters getting chopped off. +(defparameter italic-font-name "*-courier-medium-o-normal--12-*-*") +(defvar *italic-font*) + +;; The *Cursor* is a normal arrow thing used most of the time. During +;; modification operations, we change the cursor to *Cursor-D* (while +;; the destination for the modification is being chosen) and +;; *Cursor-S* (while the source is being chosen). + +(defparameter cursor-name "library:contrib/clx-inspector/inspect11.cursor") +(defvar *cursor*) +(defparameter cursor-d-name "library:contrib/clx-inspector/inspect11-d.cursor") +(defvar *cursor-d*) +(defparameter cursor-s-name "library:contrib/clx-inspector/inspect11-s.cursor") +(defvar *cursor-s*) + +;; This file contains the help message for the inspector. The text in +;; the file must not extend past the 72nd column, and any initial +;; whitespace on a line must be built on the space character only. The +;; window that displays this text is too small in height for easy +;; reading of this text. +(defparameter help-file-pathname "library:contrib/clx-inspector/inspector.help") + + +;;;; CLX stuff + +;; Max-Window-Width is used to constrain the width of our views. + +(declaim (fixnum max-window-width)) +(defparameter max-window-width 1000) + +;; Border is the number of pixels between an object view and the box +;; we draw around it. VSP is the number of pixels we leave between +;; lines of text. (We should put VSP in the fonts structure sometime +;; so we can have font-specific vertical spacing.) + +(defparameter border 3) +(defparameter vsp 2) + +;; The arrow bitmaps are used inside scrollbars. + +(defvar *up-arrow*) +(defvar *down-arrow*) +(defvar *up-arrow-i*) +(defvar *down-arrow-i*) + +(defparameter arrow-bits + '(#*0000000000000000 + #*0111111111111110 + #*0100000000000010 + #*0100000110000010 + #*0100001111000010 + #*0100011111100010 + #*0100111111110010 + #*0101111111111010 + #*0100001111000010 + #*0100001111000010 + #*0100001111000010 + #*0100001111000010 + #*0100001111000010 + #*0100000000000010 + #*0111111111111110 + #*0000000000000000)) + + +;; Font and cursor support + +(defun open-font (name) + (let* ((font (xlib:open-font *display* name)) + (max-width (xlib:max-char-width font)) + (min-width (xlib:min-char-width font)) + (width (if (= max-width min-width) max-width nil)) + (ascent (xlib:max-char-ascent font)) + (height (+ (xlib:max-char-descent font) ascent))) + (make-font name font height ascent width))) + +(defun get-cursor-pixmap-from-file (name) + (let ((pathname (probe-file name))) + (if pathname + (let* ((image (xlib:read-bitmap-file pathname)) + (pixmap (xlib:create-pixmap :width 16 :height 16 + :depth 1 :drawable *root*)) + (gc (xlib:create-gcontext :drawable pixmap + :function boole-1 + :foreground *black-pixel* + :background *white-pixel*))) + (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16) + (xlib:free-gcontext gc) + (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image))) + (values nil nil nil)))) + +(defun open-cursor (name) + (multiple-value-bind + (cursor-pixmap cursor-x-hot cursor-y-hot) + (get-cursor-pixmap-from-file name) + (multiple-value-bind + (mask-pixmap mask-x-hot mask-y-hot) + (get-cursor-pixmap-from-file (make-pathname :type "mask" :defaults name)) + (declare (ignore mask-x-hot mask-y-hot)) + (let* ((white (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) + (black (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)) + (cursor (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap + :x cursor-x-hot :y cursor-y-hot + :foreground black :background white))) + (xlib:free-pixmap mask-pixmap) + (xlib:free-pixmap cursor-pixmap) + cursor)))) + +(defun bitvec-list-to-pixmap (bvl width height) + (let* ((image (apply #'xlib:bitmap-image bvl)) + (pixmap (xlib:create-pixmap :width width :height height + :drawable *root* + :depth (xlib:screen-root-depth *screen*))) + (gc (xlib:create-gcontext :drawable pixmap + :function boole-1 + :foreground *black-pixel* + :background *white-pixel*))) + (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16 :bitmap-p t) + (xlib:free-gcontext gc) + pixmap)) + +(defun invert-pixmap (pixmap) + (let* ((width (xlib:drawable-width pixmap)) + (height (xlib:drawable-height pixmap)) + (inv-pixmap (xlib:create-pixmap :width width :height height + :drawable *root* + :depth (xlib:screen-root-depth *screen*))) + (gc (xlib:create-gcontext :drawable inv-pixmap + :function boole-c1 + :foreground *black-pixel* + :background *white-pixel*))) + (xlib:copy-area pixmap gc 0 0 width height inv-pixmap 0 0) + (xlib:free-gcontext gc) + inv-pixmap)) + +;;; Draw-Bitmap, Draw-Box, and Draw-Block --- thin wrapper over X +;;; drawing primitives. + +(defun draw-bitmap (window x y pixmap) + (xlib:copy-area pixmap *gcontext* 0 0 16 16 window x y)) + +(defun draw-box (window x1 y1 x2 y2) + (declare (fixnum x1 y1 x2 y2)) + (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1))) + +(defun draw-block (window x1 y1 x2 y2) + (declare (fixnum x1 y1 x2 y2)) + (xlib:draw-rectangle window *gcontext* x1 y1 (- x2 x1) (- y2 y1) t)) + +;;; *X-Constraint* is used by Disp-String to truncate long strings so that +;;; they stay inside windows of reasonable width. + +(defvar *x-constraint* nil) + +;;; Disp-String draws a string in an X window, trying to constrain it +;;; to not run beyond the *X-Constraint*. For variable width fonts, +;;; we can only guess about the right length... + +(defun disp-string (window x y string disp-font) + (declare (simple-string string)) + (let ((font (font-font disp-font)) + (font-width (font-width disp-font)) + (font-height (font-height disp-font)) + (length (length string)) + (max-width (if *x-constraint* (- *x-constraint* x) max-window-width))) + (cond (font-width + ;; fixed width font + (let ((end (if (<= (* length font-width) max-width) + length + (max 0 (truncate max-width font-width))))) + (when window + (xlib:with-gcontext (*gcontext* :font font) + (xlib:draw-image-glyphs window *gcontext* + x (+ y (font-ascent disp-font)) + string :end end))) + (values (* end font-width) (+ font-height vsp)))) + (t + ;; this is hackish... + (multiple-value-bind (end width) + (do* ((index length (1- index)) + (width (xlib:text-width font string :end index) + (xlib:text-width font string :end index))) + ((or (= index 0) (<= width max-width)) + (values index width))) + (when window + (xlib:with-gcontext (*gcontext* :font font) + (xlib:draw-image-glyphs window *gcontext* + x (+ y (font-ascent disp-font)) + string :end end))) + (values width (+ font-height vsp))))))) + + + +;;;; Inspect-Init + +;;; Inspect-Init sets all this stuff up, using *Inspect-Initialized* to +;;; know when it's already been done. + +(defvar *inspect-initialized* nil) + +(defun inspect-init () + (unless *inspect-initialized* + + (multiple-value-setq (*display* *screen*) (ext:open-clx-display)) + (ext:carefully-add-font-paths + *display* + (mapcar #'(lambda (x) + (concatenate 'string (namestring x) "fonts/")) + (ext:search-list "library:"))) + (setq *root* (xlib:screen-root *screen*)) + (setq *black-pixel* (xlib:screen-black-pixel *screen*)) + (setq *white-pixel* (xlib:screen-white-pixel *screen*)) + (setq *gcontext* (xlib:create-gcontext :drawable *root* :function boole-1 + :foreground *black-pixel* + :background *white-pixel*)) + (setq *cursor* (open-cursor cursor-name)) + (setq *cursor-d* (open-cursor cursor-d-name)) + (setq *cursor-s* (open-cursor cursor-s-name)) + (setq *header-font* (open-font header-font-name)) + (setq *entry-font* (open-font entry-font-name)) + (setq *italic-font* (open-font italic-font-name)) + (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16)) + (setq *up-arrow-i* (invert-pixmap *up-arrow*)) + (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16)) + (setq *down-arrow-i* (invert-pixmap *down-arrow*)) + (ext:enable-clx-event-handling *display* 'inspector-event-handler) + (setq *inspect-initialized* t))) + +#| +;;; For debugging... +;;; +(defun inspect-reinit (&optional (host "unix:0.0")) + (let ((win nil)) + (setq *inspect-initialized* nil) + (when *display* + (ext:disable-clx-event-handling *display*) + (xlib:close-display *display*))) + (unwind-protect + (progn + (multiple-value-setq + (*display* *screen*) + (ext:open-clx-display host)) + (setf (xlib:display-after-function *display*) + #'xlib:display-finish-output) + (setq *root* (xlib:screen-root *screen*)) + (setq *black-pixel* (xlib:screen-black-pixel *screen*)) + (setq *white-pixel* (xlib:screen-white-pixel *screen*)) + (setq *gcontext* (xlib:create-gcontext :drawable *root* + :function boole-1 + :foreground *black-pixel* + :background *white-pixel*)) + (setq *cursor* (open-cursor cursor-name)) + (setq *cursor-d* (open-cursor cursor-d-name)) + (setq *cursor-s* (open-cursor cursor-s-name)) + (setq *header-font* (open-font header-font-name)) + (setq *entry-font* (open-font entry-font-name)) + (setq *italic-font* (open-font italic-font-name)) + (setq *up-arrow* (bitvec-list-to-pixmap arrow-bits 16 16)) + (setq *up-arrow-i* (invert-pixmap *up-arrow*)) + (setq *down-arrow* (bitvec-list-to-pixmap (reverse arrow-bits) 16 16)) + (setq *down-arrow-i* (invert-pixmap *down-arrow*)) + (setf (xlib:display-after-function *display*) nil) + (setf win t)) + (cond (win + (ext:enable-clx-event-handling *display* 'inspector-event-handler) + (setq *inspect-initialized* t)) + (*display* + (xlib:close-display *display*)))))) +|# + + +;;;; Mid-level interface between inspector and window system. + +(defclass view () + ((name :initarg :name :accessor name) + (object :initarg :object :accessor object) + (view-item :initarg :view-item :accessor view-item) + (window :initarg :window :accessor window) + #+:mp (update-process :initarg :update-process :accessor update-process :initform nil) + (stack :initarg :stack :accessor stack :initform nil)) + (:documentation "We use view classes to associate objects with their +graphical images (View-Items, see below), the X windows that they're +displayed in, and maybe even a user-supplied Name for the whole +thing.")) + +#+:mp +(defun make-view (name object view-item window) + (let* ((new-view (make-instance 'view + :name name + :object object + :view-item view-item + :window window))) + ;; Create a background process to update the view once per second. + (setf (update-process new-view) + (mp:make-process + #'(lambda () + (loop + (update-view-of-object new-view) + (sleep *update-interval*))) + :name (format nil "Background update process for ~A" name))) + new-view)) + +#-:mp +(defun make-view (name object view-item window) + (make-instance 'view + :name name + :object object + :view-item view-item + :window window)) + + +;;; *views* is a list of all the live views of objects. +;;; +(defvar *views* nil) + +;;; CLX window to view object mapping. +;;; +(defvar *windows-to-views* (make-hash-table :test #'eq)) + +(defun add-window-view-mapping (window view) + (setf (gethash window *windows-to-views*) view)) + +(defun delete-window-view-mapping (window) + (remhash window *windows-to-views*)) + +(defun map-window-to-view (window) + (multiple-value-bind (view found-p) + (gethash window *windows-to-views*) + (unless found-p (error "No such window as ~S in mapping!" window)) + view)) + +;; *Tracking-Mode* is a kind of hack used so things know what to do +;; during modify operations. If it's :Source, only objects that are +;; really there will be selectable. If it's :Destination, objects that +;; aren't necessarily really there (like the values of unbound +;; symbols) will be selectable. +(declaim (type (member '(:source :destination) *tracking-mode*))) +(defvar *tracking-mode* :source) + +;; *Mouse-X* and *Mouse-Y* are a good approximation of where the mouse +;; is in the window that the mouse is in. + +(declaim (fixnum *mouse-x* *mouse-y*)) +(defvar *mouse-x* 0) +(defvar *mouse-y* 0) + + +;;;; Event Handling for CLX. Translates events in X windows to +;;;; commands operating on views. + +;; We're interested in these events: + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defconstant important-xevents + '(:key-press :button-press :exposure :pointer-motion + :enter-window :leave-window #+notready :structure-notify)) + + (defconstant important-xevents-mask + (apply #'xlib:make-event-mask important-xevents))) + + +;; We need to add some mouse key translations to handle the scroll +;; wheel. XXX These should be in CMUCL, not here. + +(ext:define-mouse-keysym 4 25607 "Scrollupdown" "Super" :button-press) +(ext:define-mouse-keysym 4 25608 "Scrollupup" "Super" :button-release) + +(ext:define-mouse-keysym 5 25609 "Scrolldowndown" "Super" :button-press) +(ext:define-mouse-keysym 5 25610 "Scrolldownup" "Super" :button-release) + + +(defun inspector-event-handler (display) + (xlib:event-case (display :discard-p t :force-output-p t :timeout .1) + ((:exposure) (event-window count) + (when (zerop (the fixnum count)) + (redisplay-item + (view-item (map-window-to-view event-window)))) + t) + ((:key-press) (event-window state code) + (do-command (map-window-to-view event-window) + (ext:translate-key-event display code state)) + t) + ((:button-press :button-release) (event-key event-window state code) + (do-command (map-window-to-view event-window) + (ext:translate-mouse-key-event code state event-key)) + t) + ((:enter-notify :motion-notify) (event-window x y) + (cond ((xlib:event-listen display) + ;; if there are other things in the queue, blow this event off... + nil) + (t + ;; This is the alternative to the background update + ;; process. When the mouse enters the window, its values + ;; get updated. + #-:mp (update-view-of-object (map-window-to-view event-window)) + (setf *mouse-x* x) + (setf *mouse-y* y) + (tracker (view-item (map-window-to-view event-window)) x y) + t))) + ((:leave-notify) (event-window) + (tracker (view-item (map-window-to-view event-window)) -1 -1) + t) + + ((:no-exposure) () + ;; just ignore this one + t) + ((:client-message) (event-window display data) + ;; User used the window manager to close a window. + (when (eq (xlib:atom-name display (aref data 0)) :wm_delete_window) + ;; Make the program think the user hit the "D" key in the event + ;; window. + (do-command (map-window-to-view event-window) #k"D")) + t) + (t (event-key) + (format t "Inspector received unexpected event, ~S, recieved." event-key) + t))) + +#| + +;;; Some debugging code... + + (xlib:event-cond (display :timeout 0 :peek-p t) + (t (event-key) + (unless (eq event-key :motion-notify) + (format t "Event received: ~S~%" event-key)))) + +(defun discard-event-on-window (display window type) + (loop + (unless (xlib:process-event display :timeout 0 + :handler #'(lambda (&key event-window event-type &allow-other-keys) + (and (eq event-window window) + (eq event-type type)))) + (return)))) + +|# + + +;;;; More stuff that interfaces between X and the view stuff. + +;; NEXT-WINDOW-POSITION currently uses a very dumb heuristic to decide +;; where the next inspector window ought to go. If there aren't any +;; windows, it puts the view of an object in the upper left hand +;; corner. Otherwise, it'll put it underneath the last one created. +;; When putting the new window below the last one, if it should extend +;; below the bottom of the screen, we position it to just fit on the +;; bottom. Thus, all future windows created in this fashion will "pile +;; up" on the bottom of the screen. +;; +(defun next-window-position (width height) + (declare (ignore width)) + (if *views* + (let ((window (window (car *views*)))) + (xlib:with-state (window) + (let ((drawable-x (xlib:drawable-x window)) + (drawable-y (xlib:drawable-y window)) + (drawable-height (xlib:drawable-height window)) + (border-width (xlib:drawable-border-width window))) + (declare (fixnum drawable-y drawable-height border-width)) + (multiple-value-bind (children parent root) (xlib:query-tree window) + (declare (ignore children)) + (let ((root-height (xlib:drawable-height root))) + (declare (fixnum root-height)) + (multiple-value-bind + (new-x new-y) + (if (eq parent root) + (values drawable-x (+ drawable-y drawable-height + (* 2 border-width))) + ;; Deal with reparented windows... + (multiple-value-bind (root-x root-y) + (xlib:translate-coordinates + parent drawable-x drawable-y root) + (declare (fixnum root-y)) + (values root-x (+ root-y drawable-height + (* 2 border-width))))) + (declare (fixnum new-y)) + (values new-x + (if (> (+ new-y height border-width) root-height) + (- root-height height border-width) + new-y)))))))) + (values 200 20))) + + +;;;; View-Item. A view item is the object that contains the actual +;;;; underlying object being inspected as well as the window being +;;;; used to display it and some other information about the window. + +(defclass view-item () + ((window :initarg :window :accessor window) + (x :initarg :x :accessor x) + (y :initarg :y :accessor y) + (width :initarg :width :accessor width) + (height :initarg :height :accessor height)) + (:documentation "View-Items are objects with methods to display +themselves, track the mouse inside their boundries, handle mouse +clicks on themselves, and so on. Everything we put up on the screen is +backed in some way by a View-Item. These are the components of the +total view of an object as described in a view object.")) + +(defmethod print-object ((item view-item) stream) + (format stream "#<~S {~8,'0X}>" (type-of item) + (kernel:get-lisp-obj-address item))) + +(defgeneric view-item-p (item) + (:method ((item t)) + nil) + (:method ((item view-item)) + t)) + +;; The following generic functions constitute the interface to the +;; view-item objects. Subclasses of view-item implement behavior by +;; overriding these methods. + +(defgeneric display (item window x y)) + +(defgeneric tracker (item x y) + (:method ((item view-item) x y) + (update-current-item item x y))) + +(defgeneric untracker (item) + (:method ((item view-item)) + nil)) + +(defgeneric mouse-handler (item view key-event) + (:method ((item view-item) view key-event) + (declare (ignore view key-event)) + nil)) + +(defgeneric walker (item function) + (:method ((item view-item) function) + (declare (ignore function)) + nil)) + + +;;;; The following are functions that apply to all view-items. + +;; The *Current-Item* is the view item that is currently under the +;; mouse, to the best of our knowledge, or Nil if the mouse isn't over +;; an item that does anything with its Tracker method. + +(defvar *current-item* nil) + +;; Display-Item invokes the Display method of an item to put it up on +;; the specified window. The window, position, and size are all set, +;; and the size is returned. + +(defun display-item (item window x y) + (setf (window item) window + (x item) x + (y item) y) + (multiple-value-bind (width height) + (display item window x y) + (setf (width item) width) + (setf (height item) height) + (values width height))) + +;; Redisplay-Item redraws an item (if, say, it's changed, or if its +;; window has received an exposure event). If the item is the +;; *Current-Item*, we call its tracker method to make sure it gets +;; highlighted if it's supposed to be. + +(defun redisplay-item (item) + (when (window item) + (xlib:clear-area (window item) + :x (x item) :y (y item) + :width (width item) + :height (height item)) + (multiple-value-bind (width height) + (display item (window item) (x item) (y item)) + (setf (width item) width) + (setf (height item) height)) + (xlib:display-force-output *display*) + (when (and *current-item* + (eq (window *current-item*) + (window item))) + (tracker *current-item* *mouse-x* *mouse-y*)))) + +;; Size-Item uses the Display method to calculate the size of an item +;; once displayed. If the window supplied to View-Item is Nil, all the +;; size calculation will get done, but no graphical output will +;; happen. + +(defun size-item (item) + (if (slot-boundp item 'width) + (values (width item) (height item)) + (display-item item nil 0 0))) + + +;;;; Tracking and untracking. + +;; Update-Current-Item is used by trackers to figure out if an item is +;; really under the mouse. If it is, and it's not the same as the +;; *Current-Item*, the *Current-Item* gets untracked. If the mouse is +;; inside the current item, Update-Current-Item returns T. + +(defun update-current-item (item x0 y0) + (let ((old-current *current-item*)) + (with-slots (x y width height) item + (if (and (<= x x0 (+ x width)) + (<= y y0 (+ y height))) + (setq *current-item* item) + (setq *current-item* nil)) + (when (and old-current (not (eq *current-item* old-current))) + (untracker old-current))) + (eq item *current-item*))) + +;; The Boxifying-Tracker and Boxifying-Untracker highlight and +;; unhighlight an item by drawing or erasing a box around the object. + +(defun boxifying-tracker (item x y) + (when (update-current-item item x y) + (boxify-item item boole-1))) + +(defun boxifying-untracker (item) + (boxify-item item boole-c1)) + +(defun boxify-item (item function) + (when (view-item-p item) + (with-slots (x y width height window) item + (xlib:with-gcontext (*gcontext* :function function) + (xlib:draw-rectangle window *gcontext* (1- x) y (1+ width) (- height 2))) + (xlib:display-force-output *display*)))) + +;; Track-In-List tries to track inside of each item in the List. + +(defun track-in-list (list x0 y0) + (dolist (item list) + (when (view-item-p item) + (with-slots (x y width height) item + (when (and (<= x x0 (+ x width)) + (<= y y0 (+ y height))) + (tracker item x0 y0) + (return-from track-in-list nil))))) + (when *current-item* + (untracker *current-item*) + (setq *current-item* nil))) + + +;;;; Specialized View-Item definitions. + +(defclass inspection-item (view-item) + ((objects :initarg :objects :accessor objects) ; Objects being inspected (for decaching) + (headers :initarg :headers :accessor headers) ; List of items in header, may be Nil + (entries :initarg :entries :accessor entries)) ; List of items below header + (:documentation "Inspection-Items are used as the `top-level' items +in the display of an object. They've got a list of header items and a +list of entry items.")) + +(defun make-inspection-item (objects headers entries) + (make-instance 'inspection-item :objects objects :headers headers :entries entries)) + +;; Inspection item methods + +(defmethod display ((item inspection-item) window x0 y0) + (let ((y (+ y0 border)) + (x (+ x0 border)) + (max-width 0) + (max-x 0) + (first-entry-y nil) + (header-end-y nil) + (sb (when (scrolling-inspection-item-p item) + (scrollbar item)))) + (when sb + (funcall (reset-index sb) sb)) + ;; First, header items. + (when (headers item) + (dolist (element (headers item)) + (multiple-value-bind (width height) + (display-item element window x y) + (incf y height) + (setq max-width (max max-width width)))) + (setq header-end-y y) + (incf y vsp)) + (when sb + (incf x (+ 16 border)) + (funcall (reset-index sb) sb)) + ;; Then do entry items. + (let ((max-name-width 0)) + (setq first-entry-y y) + ;; Figure out width of widest entry slot name. + (dolist (element (entries item)) + (when (slot-item-p element) + (setq max-name-width + (max max-name-width (length (name element)))))) + (dolist (element (entries item)) + (when (slot-item-p element) + (unless (slot-boundp element 'max-name-width) + (setf (max-name-width element) max-name-width))) + (multiple-value-bind (width height) + (display-item element window x y) + (incf y height) + (setq max-width (max max-width (+ width (if sb (+ 16 border) 0))))))) + (setq max-x (+ x0 border max-width border)) + ;; Display scrollbar, if any. + (when sb + (setf (bottom sb) y) + (display-item sb window (+ x0 border) first-entry-y) + (unless (slot-boundp sb 'window-width) + (setf (window-width sb) (- max-width 16 border)))) + ;; Finally, draw a box around the whole thing. + (when window + (draw-box window x0 y0 max-x y) + (when header-end-y + (xlib:draw-line window *gcontext* x0 header-end-y max-x header-end-y))) + ;; And return size. + (values (- max-x x0) (- (+ y border) y0)))) + +(defmethod tracker ((inspection-item inspection-item) x0 y0) + (dolist (item (headers inspection-item)) + (with-slots (x y width height) item + (when (and (<= x x0 (+ x width)) + (<= y y0 (+ y height))) + (tracker item x0 y0) + (return-from tracker nil)))) + (track-in-list (entries inspection-item) x0 y0)) + +(defmethod walker ((item inspection-item) function) + (flet ((walk-item-list (list function) + (dolist (item list) + (walker item function)))) + (with-slots (x width) item + (let ((*x-constraint* (if (slot-boundp item 'width) + (+ x width (- border)) + max-window-width))) + (walk-item-list (headers item) function) + (walk-item-list (entries item) function))))) + + +(defclass scrolling-inspection-item (inspection-item) + ((scrollbar :initarg :scrollbar :accessor scrollbar) ; Scrollbar display item + (set-next :initarg :set-next :accessor set-next) ; To set next state + (next :initarg :next :accessor next)) ; To get & increment next state + (:documentation "Scrolling-Inspection-Items are used as the +'top-level' of display of objects that have lots of components and so +have to scroll. In addition to headers and entries, they've got a +scrollbar item and stuff so that the entries can lazily compute where +they are and what they should display.")) + +(defun make-scrolling-inspection-item (objects headers entries scrollbar) + (make-instance 'scrolling-inspection-item + :objects objects + :headers headers + :entries entries + :scrollbar scrollbar)) + +(defgeneric scrolling-inspection-item-p (item) + (:method ((item t)) + nil) + (:method ((item scrolling-inspection-item)) + t)) + +;; Scrolling-inspection-item methods. + +(defmethod tracker ((item scrolling-inspection-item) x0 y0) + (dolist (element (headers item)) + (with-slots (x y height width) element + (when (and (<= x x0 (+ x width)) + (<= y y0 (+ y height))) + (tracker element x0 y0) + (return-from tracker nil)))) + (let ((sb (scrollbar item))) + (with-slots (x y width height) sb + (if (and (<= x x0 (+ x width)) + (<= y y0 (+ y height))) + (tracker sb x0 y0) + (track-in-list (entries item) x0 y0))))) + + + +(defclass scrollbar (view-item) + ((scrollee :initarg :scrollee :accessor scrollee) ; Item for which this guy's a scrollbar + (bottom :initarg bottom :accessor bottom) ; Y coordinate of end (hack, hack) + (active-button :initarg :active-button :accessor active-button :initform nil) + (first-index :initarg :first-index :accessor first-index) ; Index of first thing to + ; be displayed + (next-element :initarg :next-element :accessor next-element) ; Function to extract next + ; element to be displayed + (reset-index :initarg :reset-index :accessor reset-index) ; Function to reset internal + ; index for next-element + (window-width :initarg :window-width :accessor window-width) ; Max X for scrollees + (bar-height :initarg :bar-height :accessor bar-height) ; Height of bar in pixels + (bar-top :initarg :bar-top :accessor bar-top) + (bar-bottom :initarg :bar-bottom :accessor bar-bottom) + (num-elements :initarg :num-elements :accessor num-elements) ; Number of elements in scrollee + (num-elements-displayed :initarg :num-elements-displayed + :accessor num-elements-displayed )) ; Number of elements displayed + ; at once + (:documentation "A Scrollbar has buttons and a thumb bar and the +stuff it needs to figure out whatever it needs to figure out.")) + +(defun make-scrollbar (first-index num-elements num-elements-displayed + next-element reset-index) + (make-instance 'scrollbar + :first-index first-index :num-elements num-elements + :num-elements-displayed num-elements-displayed + :next-element next-element :reset-index reset-index)) + +;;; Scrollbar methods. + +;; Yeah, we use a hard-wired constant 16 here, which is the width and +;; height of the buttons. Grody, yeah, but hey, "16" is only two +;; keystrokes... + +(defmethod display ((scrollbar scrollbar) window x y) + (with-slots (active-button bottom bar-bottom bar-top bar-height + first-index num-elements num-elements-displayed) + scrollbar + (when window + (draw-bitmap window x y + (if (eq active-button :top) + *up-arrow-i* *up-arrow*)) + (draw-bitmap window x (- bottom 16) + (if (eq active-button :bottom) + *down-arrow-i* *down-arrow*)) + (draw-box window x (+ y 16) (+ x 15) (- bottom 17)) + (setf bar-top (+ y 17) + bar-bottom (- bottom 17) + bar-height (- bar-bottom bar-top)) + (draw-block window x + (+ bar-top (truncate (* first-index bar-height) num-elements)) + (+ x 16) + (- bar-bottom + (truncate (* (- num-elements (+ first-index num-elements-displayed)) + bar-height) + num-elements))) + (xlib:display-force-output *display*)) + (values 16 (- bottom y)))) + +(defmethod tracker ((scrollbar scrollbar) x0 y0) + (with-slots (active-button window x y bottom) scrollbar + (update-current-item scrollbar x0 y0) + (cond ((<= y y0 (+ y 16)) + (setf active-button :top) + (draw-bitmap window x y *up-arrow-i*)) + ((<= (- bottom 16) y0 bottom) + (setf active-button :bottom) + (draw-bitmap window x (- bottom 16) *down-arrow-i*)) + (t + (untracker scrollbar))) + (xlib:display-force-output *display*))) + +(defmethod untracker ((scrollbar scrollbar)) + (with-slots (active-button window x y bottom) scrollbar + (cond ((eq active-button :top) + (draw-bitmap window x y *up-arrow*)) + ((eq active-button :bottom) + (draw-bitmap window x (- bottom 16) *down-arrow*))) + (xlib:display-force-output *display*) + (setf active-button nil))) + +(defmethod mouse-handler ((scrollbar scrollbar) view key-event) + (declare (ignore view)) + (with-slots (first-index active-button num-elements num-elements-displayed + bar-top bar-bottom bar-height scrollee) + scrollbar + (let* ((old-first first-index) + (new-first old-first)) + (cond ((or (eq key-event #k"Scrolldowndown") + (eq active-button :bottom)) + (incf new-first + (if (eq key-event #k"Rightdown") + num-elements-displayed + 1))) + ((or (eq key-event #k"Scrollupdown") + (eq active-button :top)) + (decf new-first + (if (eq key-event #k"Rightdown") + num-elements-displayed + 1))) + ((<= bar-top *mouse-y* bar-bottom) + (setq new-first + (truncate (* (- *mouse-y* bar-top) + num-elements) + bar-height)))) + (setq new-first (max new-first 0)) + (setq new-first (min new-first (- num-elements num-elements-displayed))) + (unless (= new-first old-first) + (setf first-index new-first) + (funcall (reset-index scrollbar) scrollbar) + (dolist (element (entries scrollee)) + (redisplay-item element)) + (redisplay-item scrollbar))))) + + +(defclass scrolling-item (view-item) + ((scrollbar :initarg :scrollbar :accessor scrollbar) + (item :initarg :item :accessor item)) + (:documentation "Scrolling-Items are used as the entries in +Scrolling-Inspection-Items. They know the scrollbar that moves them +around so they can lazily do their stuff.")) + +(defun make-scrolling-item (scrollbar item) + (make-instance 'scrolling-item :scrollbar scrollbar :item item)) + +;; Scrolling item methods. + +(defmethod display ((item scrolling-item) window x y) + (with-slots (scrollbar item) item + (funcall (next-element scrollbar) item) + (let ((*x-constraint* (if (slot-boundp scrollbar 'window-width) + (+ (window-width scrollbar) x) + max-window-width))) + (multiple-value-bind (width height) (display item window x y) + (values + (or (and (slot-boundp scrollbar 'window-width) + (window-width scrollbar)) + width) + height))))) + +(defmethod tracker :before ((scrolling-item scrolling-item) x y) + (update-current-item scrolling-item x y)) + +(defmethod tracker ((scrolling-item scrolling-item) x y) + (tracker (item scrolling-item) x y)) + +(defmethod walker ((scrolling-item scrolling-item) function) + (walker (item scrolling-item) function)) + + +(defclass string-item (view-item) + ((item-string :initarg :item-string :accessor item-string) ; String to be displayed + (font :initarg :font :accessor font)) ; Font in which to display it + (:documentation "String-Items just have a string of text and a font +that it gets displayed in.")) + +(defun make-string-item (string &optional (font *entry-font*)) + (make-instance 'string-item :item-string string :font font)) + +;;; String item method. + +(defmethod display ((item string-item) window x y) + (disp-string window x y (item-string item) (font item))) + + +(defclass slot-item (view-item) + ((name :initarg :name :accessor name) ; String name of slot + (object :initarg :object :accessor object) ; Display item for contents of slot + (max-name-width :initarg :max-name-width + :accessor max-name-width)) ; Length of longest slot name in structure + (:documentation "Slot-Items have a string name for the slot (e.g., +structure slot name or vector index) and an object item for the +contents of the slot. The Max-Name-Width is used so that all the slots +in an inspection item can line their objects up nicely in a +left-justified column.")) + +(defun make-slot-item (name object) + (make-instance 'slot-item :name name :object object)) + +(defgeneric slot-item-p (item) + (:method ((item t)) + nil) + (:method ((item slot-item)) + t)) + +;;; Slot item methods. + +(defmethod display ((item slot-item) window x y) + (with-slots (name object max-name-width) item + (let ((name-pixel-width (* (+ 2 max-name-width) + (font-width *entry-font*)))) + (disp-string window x y name *entry-font*) + (multiple-value-bind (width height) (display-item object window (+ x name-pixel-width) y) + (values (+ name-pixel-width width border) + (max (+ (font-height *entry-font*) vsp) height)))))) + +(defmethod tracker ((item slot-item) x y) + (tracker (object item) x y)) + +(defmethod walker ((item slot-item) function) + (with-slots (object max-name-width) item + (walker object function) + (setf (width item) + (+ (* (+ 2 max-name-width) (font-width *entry-font*)) + (width object) + border)))) + + +(defclass list-item (view-item) + ((item-list :initarg :item-list :accessor item-list)) ; List of things to be displayed + (:documentation "List-Items are used to display several things on +the same line, one after the other.")) + +(defun make-list-item (list) + (make-instance 'list-item :item-list list)) + +;;; List item methods. + +;; If a thing in the item list is a string, we just Disp-String it. +;; That way, we don't have to cons lots of full string items all the +;; time. +(defmethod display ((item list-item) window x0 y0) + (let ((x x0) + (max-height 0)) + (dolist (item (item-list item)) + (multiple-value-bind (width height) + (if (stringp item) + (disp-string window x y0 item *entry-font*) + (display-item item window x y0)) + (incf x width) + (setq max-height (max max-height height)))) + (values (- x x0) max-height))) + +(defmethod tracker ((item list-item) x y) + (track-in-list (item-list item) x y)) + +(defmethod walker ((item list-item) function) + (dolist (element (item-list item)) + (when (view-item-p element) + (walker element function)))) + + +(defclass object-item (view-item) + ((object :initarg :object :accessor object) ; The Lisp object itself + (item-string :initarg :item-string :accessor item-string) ; String representation cache + (place :initarg :place :accessor place) ; Place where it came from + (index :initarg :index :accessor index) ; Index into where it came from + (ref :initarg :ref :accessor ref) ; Function to get object, given place and index + (setter :initarg :setter :accessor setter)) ; Function to set object, given place, index + ; and new value + (:documentation "Object-Items are used to display component Lisp +objects. They know where the object came from and how to get it again +(for decaching) and how to change it (for modification).")) + +(defun make-object-item (object place index ref set) + (make-instance 'object-item :object object :place place :index index :ref ref :setter set)) + +(defgeneric object-item-p (item) + (:method ((item t)) + nil) + (:method ((item object-item)) + t)) + +;;; Object item methods. + +(defmethod display ((item object-item) window x y) + (unless (and (slot-boundp item 'item-string) (item-string item)) + (setf (item-string item) (iprin1-to-string (object item)))) + (disp-string window x y (item-string item) *entry-font*)) + +(defmethod tracker ((item object-item) x y) + (when (update-current-item item x y) + (boxify-item item boole-1))) + +(defmethod untracker ((item object-item)) + (boxify-item item boole-c1)) + +(defmethod mouse-handler ((item object-item) view key-event) + (cond ((eq key-event #k"Leftdown") + ;; Open in current window + (push (cons (object view) + (view-item view)) + (stack view)) + (update-view-of-object view (object item))) + + ((eq key-event #k"Rightdown") + ;; Open in new window + (create-view-of-object (object item) (prin1 (type-of item)))) + + ((eq key-event #k"Middledown") + ;; Return object from inspect + (setq *inspect-result* (object item)) + (try-to-quit)) + + ((eq key-event #k"Super-Middledown") + ;; Return object but leave windows around + (setq *inspect-result* (object item)) + (try-to-proceed)))) + +(defmethod walker ((item object-item) function) + (funcall function item)) + +;;; Object* items. + +(defclass object*-item (object-item) + ((live :initarg :live :accessor live) + (string* :initarg :string* :accessor string*)) + (:documentation "Object*-Items are like Object-Items except that +sometimes they can be like string items and be not-selectable.")) + +(defun make-object*-item (string* object live place index ref set) + (make-instance 'object*-item + :string* string* + :object object + :live live + :place place + :index index + :ref ref + :setter set)) + +(defgeneric object*-item-p (item) + (:method ((item t)) + nil) + (:method ((item object*-item)) + t)) + +;;; Object* item methods. + +(defmethod display ((item object*-item) window x y) + (if (live item) + (call-next-method) + (disp-string window x y (string* item) *italic-font*))) + +(defmethod tracker ((item object*-item) x y) + (if (or (live item) (eq *tracking-mode* :destination)) + (boxifying-tracker item x y) + (update-current-item item x y))) + +(defmethod untracker ((item object*-item)) + (when (or (live item) (eq *tracking-mode* :destination)) + (boxifying-untracker item))) + +(defmethod mouse-handler ((item object*-item) view key-event) + (when (live item) + (call-next-method))) + + +;;;; Display stuff. This uses the methods defined above to actually +;;;; render the objects onto a visible window. + +;; Computing display items for Lisp objects. + + +(defgeneric plan-view (object &key header stream) + (:documentation "Plan-View returns a top-level View-Item for the + given Object.")) + +(defgeneric replan-view (object plan) + (:documentation "Replan-view tries to fix up the existing Plan if +possible, but might punt and just return a new View-Item if things +have changed too much.")) + +(defun replan (plan) + "Replan is for the update function. It sets up the right calling + convention for calling the generic replan-view function." + (let ((object (objects plan))) + (replan-view object plan))) + + +(defun replan-object-item (item) + "Replan-Object-Item is used at the leaves of the replanning walk." + (if (object*-item-p item) + (multiple-value-bind (decached-object live) + (funcall (ref item) (place item) (index item)) + (unless (and (eq live (live item)) + (eq decached-object (object item)) + (or (symbolp decached-object) (numberp decached-object) + ;; ... + )) + (setf (live item) live) + (setf (object item) decached-object) + (setf (item-string item) nil) + (redisplay-item item))) + (let ((decached-object (funcall (ref item) + (place item) (index item)))) + (unless (and (eq decached-object (object item)) + (or (symbolp decached-object) (numberp decached-object) + ;; ... any others that'll be the same? + )) + (setf (object item) decached-object) + (setf (item-string item) nil) + (redisplay-item item))))) + + +;; Figure out how long random list structures are. Deals with dotted +;; lists and circular lists. + +;; This routine is too simple --- I'm not sure it always works. In +;; particular, I doubt it gives an accurate count for every kind of +;; circular list. +(defun count-conses (list) + (if (atom list) + (values 0 :atom) + (do ((count 1 (1+ count)) + (tortoise list) + (tortoise-advance nil (not tortoise-advance)) + (hare (cdr list) (cdr hare))) + ((or (null hare) (not (listp hare)) (eq hare tortoise)) + (cond ((null hare) + (values count :proper-list)) + ((not (listp hare)) + (values count :dotted-list)) + ((eq hare tortoise) + (values count :circular-list)))) + (when tortoise-advance + (setf tortoise (cdr tortoise)))))) + + +;; For lists, what we stash in the Inspection-Item-Objects slot is the +;; list of the top level conses, rather than the conses themselves. +;; This lets us detect when conses "in the middle" of the list change. +(defmethod plan-view ((object list) &key &allow-other-keys) + (cond + ;; Display the list object as a "list": ( .... ) + ((or (and (< (size-item (make-string-item (iprin1-to-string object))) + (- max-window-width (* 2 border))) + (<= (count-conses object) inspect-length)) + (= (count-conses object) 1)) + (do ((list object (cdr list)) + (i 0 (1+ i)) + (items (list "("))) + ((or (not (consp (cdr list))) + ;; The following covers circular lists. + (> i (count-conses object))) + (push (make-object-item (car list) list nil 'lref 'lset) items) + (when (not (null (cdr list))) + (push " . " items) + (push (make-object-item (cdr list) list nil 'lref* 'lset*) items)) + (push ")" items) + (make-inspection-item + (copy-n-conses object (count-conses object)) + nil + (list (make-list-item (nreverse items))))) + (push (make-object-item (car list) list nil 'lref 'lset) items) + (push " " items))) + + ((<= (count-conses object) inspect-length) + (let ((items nil)) + (push (make-list-item (list "(" + (make-object-item + (car object) object nil 'lref 'lset))) + items) + (do ((list (cdr object) (cdr list))) + ((not (consp (cdr list))) + (cond ((null (cdr list)) + (push (make-list-item + (list " " + (make-object-item + (car list) list nil 'lref 'lset) + ")")) + items)) + (t + (push (make-list-item + (list " " + (make-object-item + (car list) list nil 'lref 'lset))) + items) + (push " ." items) + (push (make-list-item + (list " " + (make-object-item + (cdr list) list nil 'lref* 'lset*) + ")")) + items)))) + (push (make-list-item + (list " " + (make-object-item + (car list) list nil 'lref 'lset))) + items)) + (make-inspection-item (copy-n-conses object (count-conses object)) + nil (nreverse items)))) + + ;; This list is too long --- use a scrolling view. + (t + (let ((scrollbar + (let ((index 0) + (cons object) + (last (last object))) + (make-scrollbar + 0 + (+ (count-conses object) (if (cdr last) 1 0)) + inspect-length + #'(lambda (item) + (setf (item-list item) + `(,(cond ((eq cons object) "(") + ((not (consp cons)) " . ") + (t " ")) + ,(if (consp cons) + (make-object-item (car cons) cons nil 'lref 'lset) + (make-object-item cons last nil 'lref* 'lset*)) + ,@(if (or (and (eq cons last) (null (cdr cons))) + (atom cons)) + `(")")))) + (incf index) + (unless (atom cons) + (setq cons (cdr cons)))) + #'(lambda (item) + (setq index (first-index item)) + (setq cons (nthcdr index object))))))) + (setf (scrollee scrollbar) + (make-scrolling-inspection-item + (copy-n-conses object (count-conses object)) + nil + (let ((items nil)) + (dotimes (i inspect-length) + (push (make-scrolling-item scrollbar (make-list-item nil)) + items)) + (nreverse items)) + scrollbar))) + ))) + +;; This is kind of like (maplist #'identity list), except that it +;; doesn't choke on non-nil-terminated lists. +(defun copy-conses (list) + (do ((list list (cdr list)) + (conses nil)) + ((atom list) + (nreverse conses)) + (push list conses))) + + +;; This will copy "n" conses; this deals with circular lists. +(defun copy-n-conses (list n) + (do ((i 1 (1+ i)) + (list list (cdr list)) + (conses nil)) + ((or (atom list) (= i n)) (nreverse conses)) + (push list conses))) + + +(defmethod replan-view ((object list) plan) + (cond ((do ((list (car object) (cdr list)) + (conses object (cdr conses))) + ((or (null list) (null conses)) + (and (null list) (null conses))) + (unless (and (eq list (car conses)) + (eq (cdr list) (cadr conses))) + (return nil))) + (walker plan #'replan-object-item) + plan) + (t + (plan-view (car object))))) + +(defun lref (object ignore) (declare (ignore ignore)) + (car object)) +(defun lref* (object ignore) (declare (ignore ignore)) + (cdr object)) +(defun lset (object ignore new) (declare (ignore ignore)) + (setf (car object) new)) +(defun lset* (object ignore new) (declare (ignore ignore)) + (setf (cdr object) new)) + + +(defmethod plan-view ((object vector) &key &allow-other-keys) + (let* ((type (type-of object)) + (length (array-dimension object 0)) + (header + `(,(make-string-item (format nil "~A" (if (listp type) (car type) type)) + *header-font*) + ,(make-string-item (format nil "Length = ~D" length) + *header-font*) + ,@(if (array-has-fill-pointer-p object) + `(,(make-list-item (list "Fill-Pointer: " + (make-object-item + (fill-pointer object) + object nil 'fpref 'fpset)))))))) + (cond ((<= length inspect-length) + (make-inspection-item + object + header + (let ((items nil)) + (dotimes (i length) + (push (make-slot-item (prin1-to-string i) + (make-object-item + (aref object i) object i 'vref 'vset)) + items)) + (nreverse items)))) + (t + (let ((scrollbar + (let ((index 0)) + (make-scrollbar + 0 + length + inspect-length + #'(lambda (item) + (setf (name item) (prin1-to-string index)) + (let ((obj (object item))) + (setf (object obj) (aref object index)) + (setf (index obj) index) + (setf (item-string obj) nil)) + (incf index)) + #'(lambda (item) + (setq index (first-index item))))))) + (setf (scrollee scrollbar) + (make-scrolling-inspection-item + object + header + (let ((items nil) + (name-width (length (iprin1-to-string (1- length))))) + (dotimes (i inspect-length) + (let ((slot + (make-slot-item + nil + (make-object-item nil object nil 'vref 'vset)))) + (setf (max-name-width slot) name-width) + (push (make-scrolling-item scrollbar slot) items))) + (nreverse items)) + scrollbar))))))) + +(defmethod replan-view ((object vector) plan) + (cond ((= (length object) (length (objects plan))) + (walker plan #'replan-object-item) + plan) + (t + (plan-view object)))) + +(defun vref (object index) + (aref object index)) +(defun vset (object index new) + (setf (aref object index) new)) + +(defun fpref (object index) + (declare (ignore index)) + (fill-pointer object)) +(defun fpset (object index new) + (declare (ignore index)) + (setf (fill-pointer object) new)) + + +(defmethod plan-view ((object array) &key &allow-other-keys) + (lisp::with-array-data ((data object) + (start) + (end)) + (let* ((length (- end start)) + (dimensions (array-dimensions object)) + (rev-dimensions (reverse dimensions)) + (header + (list (make-string-item + (format nil "Array of ~A" (array-element-type object)) + *header-font*) + (make-string-item + (format nil "Dimensions = ~S" dimensions) + *header-font*)))) + (cond ((<= length inspect-length) + (make-inspection-item + object + header + (let ((items nil)) + (dotimes (i length) + (push (make-slot-item (index-string i rev-dimensions) + (make-object-item + (aref data (+ start i)) + object (+ start i) 'vref 'vset)) + items)) + (nreverse items)))) + (t + (let ((scrollbar + (let ((index 0)) + (make-scrollbar + 0 + length + inspect-length + #'(lambda (item) + (setf (name item) + (index-string index rev-dimensions)) + (let ((obj (object item))) + (setf (object obj) + (aref data (+ start index))) + (setf (index obj) (+ start index)) + (setf (item-string obj) nil)) + (incf index)) + #'(lambda (item) + (setq index (first-index item))))))) + (setf (scrollee scrollbar) + (make-scrolling-inspection-item + object + header + (let ((items nil) + (name-width (length (index-string (1- length) + rev-dimensions)))) + (dotimes (i inspect-length) + (let ((slot + (make-slot-item + nil + (make-object-item nil data nil 'vref 'vset)))) + (setf (max-name-width slot) name-width) + (push (make-scrolling-item scrollbar slot) items))) + (nreverse items)) + scrollbar)))))))) + +(defun index-string (index rev-dimensions) + (if (null rev-dimensions) + "[]" + (let ((list nil)) + (dolist (dim rev-dimensions) + (multiple-value-bind (q r) + (floor index dim) + (setq index q) + (push r list))) + (format nil "[~D~{,~D~}]" (car list) (cdr list))))) + +(defmethod replan-view ((object array) plan) + (cond ((and (equal (array-dimensions object) + (array-dimensions (objects plan))) + (lisp::with-array-data ((data1 object) + (start1) (end1)) + (lisp::with-array-data ((data2 (objects plan)) + (start2) (end2)) + (and (eq data1 data2) + (= start1 start2) + (= end1 end2))))) + (walker plan #'replan-object-item) + plan) + (t + (plan-view object)))) + + +(defmethod plan-view ((object t) &key &allow-other-keys) + (make-inspection-item + object + nil + (list (make-object-item object (list object) nil 'lref 'lset)))) + +(defmethod replan-view ((object t) plan) + (declare (ignore object)) + (walker plan #'replan-object-item) + plan) + + + +(defmethod plan-view ((object structure-object) &key &allow-other-keys) + (let* ((dd (kernel:layout-info (kernel:%instance-layout object))) + (dsds (kernel:dd-slots dd))) + (make-inspection-item + object + (list (make-string-item + (format nil "~A ~A" + (symbol-name (kernel:dd-name dd)) + object) + *header-font*)) + (let ((items nil)) + (dolist (dsd dsds) + (push (make-slot-item + (kernel:dsd-%name dsd) + (make-object-item + (funcall (fdefinition (kernel:dsd-accessor dsd)) object) + object (kernel:dsd-index dsd) + #'(lambda (str ignore) + (declare (ignore ignore)) + (funcall (fdefinition (kernel:dsd-accessor dsd)) + str)) + #'(lambda (str ignore val) + (declare (ignore ignore)) + (funcall (fdefinition `(setf ,(kernel:dsd-accessor dsd))) + val str)))) + items)) + (nreverse items))))) + +(defmethod replan-view ((object structure-object) plan) + (declare (ignore object)) + (walker plan #'replan-object-item) + plan) + + + +(defmethod plan-view ((object standard-object) &key &allow-other-keys) + (let ((class (pcl:class-of object))) + (make-inspection-item + object + (list (make-string-item (format nil "~S ~A" + (pcl:class-name class) + object) + *header-font*)) + (let ((slotds (pcl::slots-to-inspect class object)) + instance-slots class-slots other-slots) + (dolist (slotd slotds) + (with-slots ((slot pcl::name) (allocation pcl::allocation)) slotd + (let* ((boundp (slot-boundp object slot)) + (item (make-slot-item (prin1-to-string slot) + (make-object*-item + "Unbound" + (and boundp (slot-value object slot)) + boundp + object + slot + 'ref-slot + 'set-slot)))) + (case allocation + (:instance (push item instance-slots)) + (:class (push item class-slots)) + (otherwise + (setf (name item) + (format nil "~S [~S]" slot allocation)) + (push item other-slots)))))) + (append (unless (null instance-slots) + (cons (make-string-item "These slots have :INSTANCE allocation" + *entry-font*) + (nreverse instance-slots))) + (unless (null class-slots) + (cons (make-string-item "These slots have :CLASS allocation" + *entry-font*) + (nreverse class-slots))) + (unless (null other-slots) + (cons (make-string-item "These slots have allocation as shown" + *entry-font*) + (nreverse other-slots)))))))) + + +(defun ref-slot (object slot) + (if (slot-boundp object slot) + (values (slot-value object slot) t) + (values nil nil))) + +(defun set-slot (object slot val) + (setf (slot-value object slot) val)) + +;;; Should check to see if we need to redo the entire plan or not. +(defmethod replan-view ((object standard-object) plan) + (declare (ignore plan)) + (plan-view object)) + + + +(defmethod plan-view ((object symbol) &key &allow-other-keys) + (make-inspection-item + object + (list (make-string-item (format nil "Symbol ~A" object) *header-font*)) + (list (make-slot-item "Value" + (make-object*-item + "Unbound" (if (boundp object) (symbol-value object)) + (boundp object) object nil 'valref 'valset)) + (make-slot-item "Function" + (make-object*-item + "Undefined" (if (fboundp object) (symbol-function object)) + (fboundp object) object nil 'defref 'defset)) + (make-slot-item "Properties" + (make-object-item + (symbol-plist object) object nil 'plistref 'plistset)) + (make-slot-item "Package" + (make-object-item + (symbol-package object) object nil 'packref 'packset))))) + +(defmethod replan-view ((object symbol) plan) + (declare (ignore object)) + (walker plan #'replan-object-item) + plan) + +(defun valref (object ignore) (declare (ignore ignore)) + (if (boundp object) + (values (symbol-value object) t) + (values nil nil))) +(defun defref (object ignore) (declare (ignore ignore)) + (if (fboundp object) + (values (symbol-function object) t) + (values nil nil))) +(defun plistref (object ignore) (declare (ignore ignore)) + (symbol-plist object)) +(defun packref (object ignore) (declare (ignore ignore)) + (symbol-package object)) + +(defun valset (object ignore new) (declare (ignore ignore)) + (setf (symbol-value object) new)) +(defun defset (object ignore new) (declare (ignore ignore)) + (setf (symbol-function object) new)) +(defun plistset (object ignore new) (declare (ignore ignore)) + (setf (symbol-plist object) new)) +(defun packset (object ignore new) (declare (ignore ignore)) + (lisp::%set-symbol-package object new)) + + +;; This is all very gross and silly now, just so we can get something +;; working quickly. Eventually do this with a special stream that +;; listifies things as it goes along... +(defmethod plan-view ((object function) &key &allow-other-keys) + (let ((stream (make-string-output-stream))) + (let ((*standard-output* stream) + (ext:*describe-print-level* 30)) + (describe object)) + (close stream) + (with-input-from-string (in (get-output-stream-string stream)) + (plan-view-text + object + (list + (make-string-item (format nil "Function ~S" object) *header-font*) + (make-string-item + (format nil "Argument list: ~A" (kernel:%function-arglist object)))) + in)))) + + +(defun plan-view-text (object header stream) + (let ((list nil)) + (do ((line (read-line stream nil nil) (read-line stream nil nil))) + ((null line)) + (push line list)) + (setq list (nreverse list)) + (if (<= (length list) inspect-length) + (make-inspection-item + object + header + (mapcar #'make-string-item list)) + (let ((index 0) + (vector (coerce list 'vector))) + (let ((scrollbar (make-scrollbar + 0 (length list) inspect-length + #'(lambda (item) + (setf (item-string item) + (aref vector index)) + (incf index)) + #'(lambda (item) + (setq index + (first-index item)))))) + (setf (scrollee scrollbar) + (make-scrolling-inspection-item + object + header + (let ((items nil)) + (dotimes (i inspect-length) + (push + (make-scrolling-item + scrollbar + ;; This is to ensure that the slots in + ;; the string item are bound. + (let ((string-item (make-string-item ""))) + (setf (x string-item) 0 + (y string-item) 0 + (width string-item) 0 + (height string-item) 0) + string-item)) + items)) + (nreverse items)) + scrollbar))))))) + + +;;;; Displaying old and new plans in old and new windows. + +(defun new-plan-in-new-view (object plan &optional name) + (multiple-value-bind (width height) (size-item plan) + ;; add border + (incf width 10) + (incf height 10) + (multiple-value-bind (x y) (next-window-position width height) + (let* ((window (xlib:create-window :parent *root* :x x :y y + :width width :height height + :background *white-pixel* + :border-width 2)) + (view (make-view name object plan window))) + (xlib:set-wm-properties window + :name "Inspector Window" + :icon-name "Inspector Display" + :resource-name "Inspector" + :x x :y y :width width :height height + :user-specified-position-p t + :user-specified-size-p t + :min-width width :min-height height + :width-inc nil :height-inc nil) + (setf (xlib:wm-protocols window) `(:wm_delete_window)) + (add-window-view-mapping window view) + (xlib:map-window window) + (xlib:clear-area window) + (xlib:with-state (window) + (setf (xlib:window-event-mask window) important-xevents-mask) + (setf (xlib:window-cursor window) *cursor*)) + (xlib:display-finish-output *display*) + (display-item plan window 5 5) + (push view *views*) + (multiple-value-bind + (x y same-screen-p child mask root-x root-y root) + (xlib:query-pointer window) + (declare (ignore same-screen-p child mask root-x root-y root)) + (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10))) + (tracker plan x y))) + (xlib:display-force-output *display*) + view)))) + +(defun create-view-of-object (object &optional name) + (new-plan-in-new-view object (plan-view object) name)) + +(defun new-plan-in-old-view (view old new) + (unless (eq new old) + (setf (view-item view) new) + (let ((window (window view))) + (when (and *current-item* + (eql (window *current-item*) window)) + (setq *current-item* nil)) + (multiple-value-bind (width height) + (size-item new) + (xlib:with-state (window) + (setf (xlib:drawable-width window) (+ width 10)) + (setf (xlib:drawable-height window) (+ height 10))) + (xlib:clear-area window) + (display-item new window 5 5) + (setf (window new) window + (x new) 5 + (y new) 5 + (width new) width + (height new) height) + (xlib:display-force-output *display*) + (multiple-value-bind + (x y same-screen-p child mask root-x root-y root) + (xlib:query-pointer window) + (declare (ignore same-screen-p child mask root-x root-y root)) + (when (and (< 0 x (+ width 10)) (< 0 y (+ height 10))) + (tracker new x y))))))) + +(defun update-view-of-object (view &optional (object (object view))) + (cond ((eq object (object view)) + (new-plan-in-old-view view + (view-item view) + (replan (view-item view)))) + (t + (setf (object view) object) + (new-plan-in-old-view view (view-item view) (plan-view object)))) + (xlib:display-force-output *display*)) + + +;; DELETING-WINDOW-DROP-EVENT checks for any events on win. If there +;; is one, it is removed from the queue, and t is returned. Otherwise, +;; returns nil. +(defun deleting-window-drop-event (display win) + (xlib:display-finish-output display) + (let ((result nil)) + (xlib:process-event + display :timeout 0 + :handler #'(lambda (&key event-window window &allow-other-keys) + (if (or (eq event-window win) (eq window win)) + (setf result t) + nil))) + result)) + +(defun remove-view-of-object (view) + (let (#+:mp (update-process (update-process view)) + (window (window view))) + #+:mp (mp:destroy-process update-process) + (setf (xlib:window-event-mask window) #.(xlib:make-event-mask)) + (xlib:display-finish-output *display*) + (loop (unless (deleting-window-drop-event *display* window) (return))) + (xlib:destroy-window window) + (xlib:display-finish-output *display*) + (delete-window-view-mapping window) + (setq *views* (delete view *views*)))) + + +;;;; The command interpreter. + +(defvar *can-quit* nil) +(defvar *can-proceed* nil) +(defvar *unwinding* t) + +(defun try-to-quit () + (setq *current-item* nil) + (when *can-quit* + (setq *unwinding* nil) + (ext:flush-display-events *display*) + (throw 'inspect-exit nil)) + (try-to-proceed)) + +(defun try-to-proceed () + (when *can-proceed* + (setq *unwinding* nil) + (ext:flush-display-events *display*) + (throw 'inspect-proceed nil))) + +(defvar *do-command* nil) + +(defun do-command (view key-event) + (cond (*do-command* + (funcall *do-command* view key-event)) + + ;; If we get scrollwheel down key events anywhere in the view, + ;; the scrollbar wants to know about them. Yes, a bit + ;; ad-hoc.... + ((and (or (eq key-event #k"Scrollupdown") + (eq key-event #k"Scrolldowndown")) + (typep (view-item view) 'scrolling-inspection-item)) + (dotimes (i 5) ; Simulate multiple clicks. + (mouse-handler (scrollbar (view-item view)) view key-event))) + + ((or (eq key-event #k"d") (eq key-event #k"D")) + ;; Delete current window. + (remove-view-of-object view) + (setq *current-item* nil) + (unless *views* + (try-to-quit) + (try-to-proceed))) + + ((or (eq key-event #k"h") (eq key-event #k"H") (eq key-event #k"?")) + (let ((inspect-length (max inspect-length 30))) + (with-open-file (stream help-file-pathname :direction :input) + (new-plan-in-new-view + nil + (plan-view-text nil + (list (make-string-item "Help" *header-font*)) + stream) + "Help Window")))) + + ((or (eq key-event #k"m") (eq key-event #k"M")) + ;; Modify something. + ;; Since the tracking stuff sets up event handlers that can + ;; throw past the CLX event dispatching form in + ;; INSPECTOR-EVENT-HANDLER, those handlers are responsible + ;; for discarding their events when throwing to this CATCH + ;; tag. + (catch 'quit-modify + (let* ((destination-item (track-for-destination)) + (source (cond + ((eq key-event #k"m") + (object (track-for-source))) + (t + (format *query-io* + "~&Form to evaluate for new contents: ") + (force-output *query-io*) + (eval (read *query-io*)))))) + (funcall (setter destination-item) + (place destination-item) + (index destination-item) + source) + (update-view-of-object view)))) + + ((or (eq key-event #k"q") (eq key-event #k"Q")) + ;; Quit. + (try-to-quit)) + + ((or (eq key-event #k"p") (eq key-event #k"P")) + ;; Proceed. + (try-to-proceed)) + + ((or (eq key-event #k"r") (eq key-event #k"R")) + ;; Recompute object (decache). + (update-view-of-object view)) + + ((or (eq key-event #k"u") (eq key-event #k"U")) + ;; Up (pop history stack). + (when (stack view) + (let ((parent (pop (stack view)))) + (setf (object view) (car parent)) + (new-plan-in-old-view view (view-item view) (cdr parent)) + (update-view-of-object view)))) + + ((or (eq key-event #k"Leftdown") + (eq key-event #k"Middledown") + (eq key-event #k"Rightdown") + (eq key-event #k"Super-Leftdown") + (eq key-event #k"Super-Middledown") + (eq key-event #k"Super-Rightdown") +;; (eq key-event #k"Scrollupdown") +;; (eq key-event #k"Scrolldowndown") +;; (eq key-event #k"Super-Scrollupdown") +;; (eq key-event #k"Super-Scrolldowndown") + ) + + (when *current-item* + (mouse-handler *current-item* view key-event))))) + + +;;;; Stuff to make modification work. + +(defun track-for-destination () + (track-for :destination *cursor-d*)) + +(defun track-for-source () + (track-for :source *cursor-s*)) + +;; TRACK-FOR loops over SYSTEM:SERVE-EVENT waiting for some event +;; handler to throw to this CATCH tag. Since any such handler throws +;; past SYSTEM:SERVE-EVENT, and therefore, past the CLX event +;; dispatching form in INSPECTOR-EVENT-HANDLER, it is that handler's +;; responsibility to discard its event. +(defun track-for (tracking-mode cursor) + (let ((*tracking-mode* tracking-mode) + (*do-command* #'track-for-do-command)) + (catch 'track-for + (unwind-protect + (progn + (dolist (view *views*) + (setf (xlib:window-cursor (window view)) + cursor)) + (xlib:display-force-output *display*) + (loop + (system:serve-event))) + (dolist (view *views*) + (setf (xlib:window-cursor (window view)) + *cursor*)) + (xlib:display-force-output *display*))))) + +;; TRACK-FOR-DO-COMMAND is the "DO-COMMAND" executed when tracking. +;; Since this throws past the CLX event handling form in +;; INSPECTOR-EVENT-HANDLER, the responsibility for discarding the +;; current event lies here. +(defun track-for-do-command (view key-event) + (declare (ignore view)) + (cond + ((or (eq key-event #k"q") (eq key-event #k"Q")) + (xlib:discard-current-event *display*) + (throw 'quit-modify t)) + ((or (eq key-event #k"Leftdown") + (eq key-event #k"Middledown") + (eq key-event #k"Rightdown")) + (when (object-item-p *current-item*) + (throw 'track-for + (prog1 *current-item* + (when (object*-item-p *current-item*) + (untracker *current-item*) + (setq *current-item* nil)) + (xlib:discard-current-event *display*))))))) + + + +;;;; Top-level program interface. + +(defun show-object (object &optional name) + (inspect-init) + (dolist (view *views*) + (when (if name + (eq name (name view)) + (eq object (object view))) + (update-view-of-object view object) + (return-from show-object nil))) + (create-view-of-object object name)) + +(defun remove-object-view (object &optional name) + (dolist (view *views*) + (when (if name + (eq name (name view)) + (eq object (object view))) + (remove-view-of-object view) + (return nil)))) + +(defun remove-all-views () + (dolist (view *views*) + (remove-view-of-object view))) + + + +;;;; Top-level user interface. + +(defvar *interface-style* :graphics + "This specifies the default value for the interface argument to INSPECT. The + default value of this is :graphics, indicating when running under X, INSPECT + should use a graphics interface instead of a command-line oriented one.") + +(defun inspect (&optional (object nil object-p) + (interface *interface-style*)) + "(inspect <object> <interface>) + +Interactively examine Lisp objects. + +Arguments: + +object: The object to examine. + +interface: one of [:window :windows :graphics :graphical :x + :command-line :tty] + +Any of [:window :windows :graphics :graphical :x] give a windowing +interface. Once you've got a window, type <h> or <H> to get a help +window explaining how to use it. + +Either of [:command-line :tty] gives a pure command-line inspector. + +If <interface> is not supplied, the default is to use a windowing +interface if running under X11, and a command-line interface if not. + +If neither argument is given, the windowing version of inspect will +resume inspection of items left active from previous uses if there are +any, otherwise give an error. The command-line interface will give an +error." + (cond ((or (member interface '(:command-line :tty)) + (not (assoc :display ext:*environment-list*))) + (when object-p (tty-inspect object))) + ((not (member interface '(:window :windows :graphics :graphical :x))) + (error "Interface must be one of :window, :windows, :graphics, ~ + :graphical, :x, :command-line, or :tty -- not ~S." + interface)) + (object-p + (inspect-init) + (let ((disembodied-views nil) + (*inspect-result* object) + (*x-constraint* max-window-width) + (*can-quit* t) + (*can-proceed* t)) + (let ((*views* nil)) + (create-view-of-object object "User Supplied Object") + (catch 'inspect-proceed + (unwind-protect + (progn + (catch 'inspect-exit + (loop + (system:serve-event))) + (setq *unwinding* t)) + (when *unwinding* + (do ((view (pop *views*) + (pop *views*))) + ((null view)) + (remove-view-of-object view))))) + (setq disembodied-views *views*)) + (dolist (view (reverse disembodied-views)) + (push view *views*)) + *inspect-result*)) + (*views* + (inspect-init) + (let ((*inspect-result* nil) + (*can-quit* t) + (*can-proceed* t)) + (catch 'inspect-proceed + (catch 'inspect-exit + (loop + (system:serve-event)))) + *inspect-result*)) + (t (error "No object supplied for inspection and no previous ~ + inspection object exists.")))) ===================================== src/contrib/clx-inspector/compile-clx-inspector.lisp ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/compile-clx-inspector.lisp @@ -0,0 +1,2 @@ +(compile-file "modules:clx-inspector/clx-inspector" + :load t) ===================================== src/contrib/clx-inspector/inspect11-d.cursor ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/inspect11-d.cursor @@ -0,0 +1,8 @@ +#define inspect-d_width 16 +#define inspect-d_height 16 +#define inspect-d_x_hot 1 +#define inspect-d_y_hot 1 +static char inspect-d_bits[] = { + 0x00,0x00,0x02,0x00,0x06,0x00,0x0e,0x00,0x1e,0x00,0x3e,0x00,0x7e,0x00,0xfe, + 0x00,0xfe,0x45,0x3e,0x6c,0x36,0x54,0x62,0x54,0x60,0x44,0xc0,0x44,0xc0,0x44, + 0x00,0x00}; ===================================== src/contrib/clx-inspector/inspect11-d.mask ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/inspect11-d.mask @@ -0,0 +1,6 @@ +#define inspect-d_width 16 +#define inspect-d_height 16 +static char inspect-d_bits[] = { + 0x07,0x00,0x0f,0x00,0x1f,0x00,0x3f,0x00,0x7f,0x00,0xff,0x00,0xff,0x01,0xff, + 0xef,0xff,0xff,0x7f,0xfe,0xff,0xfe,0xff,0xfe,0xf7,0xef,0xe0,0xef,0xe0,0xef, + 0xe0,0xef}; ===================================== src/contrib/clx-inspector/inspect11-s.cursor ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/inspect11-s.cursor @@ -0,0 +1,8 @@ +#define inspect-s_width 16 +#define inspect-s_height 16 +#define inspect-s_x_hot 1 +#define inspect-s_y_hot 1 +static char inspect-s_bits[] = { + 0x00,0x00,0x02,0x00,0x06,0x00,0x0e,0x00,0x1e,0x00,0x3e,0x00,0x7e,0x00,0xfe, + 0x00,0xfe,0x79,0x3e,0x44,0x36,0x04,0x62,0x38,0x60,0x40,0xc0,0x44,0xc0,0x3c, + 0x00,0x00}; ===================================== src/contrib/clx-inspector/inspect11-s.mask ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/inspect11-s.mask @@ -0,0 +1,6 @@ +#define inspect-s_width 16 +#define inspect-s_height 16 +static char inspect-s_bits[] = { + 0x07,0x00,0x0f,0x00,0x1f,0x00,0x3f,0x00,0x7f,0x00,0xff,0x00,0xff,0x01,0xff, + 0xfd,0xff,0xff,0x7f,0xfe,0xff,0x7e,0xff,0xfc,0xf7,0xff,0xe0,0xff,0xe0,0x7f, + 0xe0,0x7f}; ===================================== src/contrib/clx-inspector/inspect11.cursor ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/inspect11.cursor @@ -0,0 +1,8 @@ +#define inspect_width 16 +#define inspect_height 16 +#define inspect_x_hot 3 +#define inspect_y_hot 1 +static char inspect_bits[] = { + 0x00,0x00,0x08,0x00,0x18,0x00,0x38,0x00,0x78,0x00,0xf8,0x00,0xf8,0x01,0xf8, + 0x03,0xf8,0x07,0xf8,0x00,0xd8,0x00,0x88,0x01,0x80,0x01,0x00,0x03,0x00,0x03, + 0x00,0x00}; ===================================== src/contrib/clx-inspector/inspect11.mask ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/inspect11.mask @@ -0,0 +1,6 @@ +#define inspect_width 16 +#define inspect_height 16 +static char inspect_bits[] = { + 0x0c,0x00,0x1c,0x00,0x3c,0x00,0x7c,0x00,0xfc,0x00,0xfc,0x01,0xfc,0x03,0xfc, + 0x07,0xfc,0x0f,0xfc,0x0f,0xfc,0x01,0xdc,0x03,0xcc,0x03,0x80,0x07,0x80,0x07, + 0x00,0x03}; ===================================== src/contrib/clx-inspector/inspector.help ===================================== --- /dev/null +++ b/src/contrib/clx-inspector/inspector.help @@ -0,0 +1,73 @@ +The component objects of the window's object will become highlighted +(surrounded by a box) as the mouse passes over them. In an inspector +window, keystrokes and mouse clicks are interpreted as follows: + + Left When the mouse is over a component object, + clicking Left will inspect that object in + the current inspector window. The "up" command + (below) can be used to return to the current + object. + + Middle When the mouse is over a component object, + clicking Middle will exit the inspector, deleting + all new windows, and returning the component + as the result of the call to Inspect. + + Right When the mouse is over a component object, + clicking Right will inspect that object in + a new inspector window. + + Shift-Middle When the mouse is over a component object, + clicking Shift-Middle will exit the inspector, + leaving all windows displayed, and returning the + component as the result of the call to Inspect. + + d, D Typing "d" or "D" inside an inspector window + will delete that window, and exit the inspector + if there are no more inspector windows. + + h, H, ? Typing "h", "H", or "?" inside an inspector + window will create a window with helpful + instructions. + + m, M Typing "m" or "M" inside an inspector window + will allow one to modify a component of an + object. The mouse cursor will change from an + arrow to an arrow with an "M" beside it, + indicating that one should select the component + to be modified. Clicking any mouse button while + the mouse is over a component will select that + component as a destination for modification. + + If one has typed "m", the source object will + also be selected by the mouse, with the mouse + cursor changed to an arrow with an "S" beside + it. The object will replace the destination + component. + + If one has typed "M", the source object will be + prompted for on the *Query-IO* stream. + + When choosing the destination or source with the + mouse, one may type "q" or "Q" to abort the + modify operation. + + q, Q Typing "q" or "Q" will quit the inspector, + deleting all new inspector windows. + + p, P Typing "p" or "P" will proceed from the + inspector, leaving all inspector windows intact. + + r, R Typing "r" or "R" will recompute the display for + the object in the window. This is used to + maintain a consistent display for an object that + may have changed since the display was computed. + + u, U Typing "u" or "U" takes one back up the chain of + investigation, to the object for which this + object was displayed as a component. This only + works for displays generated by modifying a + previously current display; this does not work + for a display generated as a new inspector + window. +DONE ===================================== src/general-info/release-21a.txt ===================================== --- a/src/general-info/release-21a.txt +++ b/src/general-info/release-21a.txt @@ -20,12 +20,25 @@ New in this release: * Known issues: * Feature enhancements + * The darwin/ppc port can create executables now. Current + implementation is rather buggy, though. * Changes * Micro-optimize SCALE-FLOAT to do multiplication when possible. * Update to ASDF 3.1.4. * The external-format :UTF is no longer an alias for :UTF-8. * :ELF feature added for solaris. + * LISP:WITH-STRING-CODEPOINT-ITERATOR added to iterate over the + codepoints in a string. This works the same as + WITH-HASH-TABLE-ITERATOR. + * LISP:WITH-STRING-GLYPH-ITERATOR added to iterate over the glyphs + in a string. Works like WITH-HASH-TABLE-ITERATOR. + * LOOP supports new extended keywords + * (loop for cp being the codepoint of string ...) + * codepoints, code-point, and code-points are aliases for + codepoint. + * (loop for g-string being the glpyh of string ...) + * glyphs is an alias for glpyh. * ANSI compliance fixes: @@ -42,17 +55,40 @@ New in this release: * Support for 64-bit time_t on NetBSD added. This allows cmucl to run on more recent versions of NetBSD. * The empty package LOOP has been removed. + * Executables on x86 can be created once again. This ability was + inadvertently broken when x86 support was removed. + * (log number base) no longer generates an error when one of the + args is a double-double. + * Fix bug in kernel::dd-%log2 which returned the wrong value. + * More accurate values for (log x 2) and (log x 10): + * Add log10 implementation for double-doubles so that log10(10^n) + = n for integer n. + * An accurate log2 function added so that log2(2^n) = n. + * All unit tests pass successfully on darwin/x86, linux/x86, and + solaris/sparc. Darwin/ppc fails most of the tests dealing with + exceptions for the special functions. + + * Trac Tickets: * Ticket #54 fixed. + * Ticket #95 fixed. + * Ticket #110 fixed. + * Ticket #112 fixed. * Other changes: * Cross compile scripts from x86 to sparc and ppc updated to work again to cross-compile from the current snapshot. + * motifd is a 64-bit binary on linux again, instead of 32-bit. + * Improvements to the PCL implementation of CLOS: * Changes to building procedure: + * Dependencies for motifd are autogenerated. + * Cross compile frox darwin/x86 to solaris/x86 fixed to work + correctly. + This release is not binary compatible with code compiled using CMUCL ===================================== src/lisp/Config.ppc_darwin ===================================== --- a/src/lisp/Config.ppc_darwin +++ b/src/lisp/Config.ppc_darwin @@ -1,8 +1,4 @@ # -*- Mode: makefile -*- -PATH1 = ../../src/lisp -vpath %.h $(PATH1) -vpath %.c $(PATH1) -vpath %.S $(PATH1) CPPFLAGS = -I. -I$(PATH1) # For Mac OS X 10.2, gcc3 is appropriate. For 10.4, gcc (gcc 4.0) is ok. But ===================================== src/lisp/Config.sparc_common ===================================== --- a/src/lisp/Config.sparc_common +++ b/src/lisp/Config.sparc_common @@ -2,19 +2,6 @@ # Common configuration for sparc/solaris builds. -# These tell gmake where to look for .h, .c and .S files. Mostly for -# building the binary outside of the src tree. - -PATH1 = ../../src/lisp -vpath %.h .:$(PATH1) -vpath %.c .:$(PATH1) -vpath %.S .:$(PATH1) - -CMULOCALE = ../../src/i18n/locale -vpath %.pot $(CMULOCALE) -vpath %.po $(CMULOCALE) -vpath %.mo $(CMULOCALE) - CPP_DEFINE_OPTIONS := -DSOLARIS -DSVR4 # Enable support for :linkage-table feature. ===================================== src/lisp/Config.x86_common ===================================== --- a/src/lisp/Config.x86_common +++ b/src/lisp/Config.x86_common @@ -1,18 +1,5 @@ # -*- Mode: makefile -*- -# These tell gmake where to look for .h, .c and .S files. Mostly for -# building the binary outside of the src tree. - -PATH1 = ../../src/lisp -vpath %.h $(PATH1) -vpath %.c $(PATH1) -vpath %.S $(PATH1) - -CMULOCALE = ../../src/i18n/locale -vpath %.pot $(CMULOCALE) -vpath %.po $(CMULOCALE) -vpath %.mo $(CMULOCALE) - CPP_DEFINE_OPTIONS := -Di386 # Enable support for :linkage-table feature. ===================================== src/lisp/GNUmakefile ===================================== --- a/src/lisp/GNUmakefile +++ b/src/lisp/GNUmakefile @@ -1,7 +1,21 @@ # $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.39 2010/10/14 17:47:12 rtoy Exp $ +# These tell gmake where to look for .h, .c and .S files. Mostly for +# building the binary outside of the src tree. + +PATH1 = ../../src/lisp +vpath %.h $(PATH1) +vpath %.c $(PATH1) +vpath %.S $(PATH1) + +CMULOCALE = ../../src/i18n/locale +vpath %.pot $(CMULOCALE) +vpath %.po $(CMULOCALE) +vpath %.mo $(CMULOCALE) + all: lisp.nm + -include internals.inc include Config @@ -130,3 +144,4 @@ translations-update: msgfmt -v ../../src/$$po/$$f.po -o ../$$po/$$f.mo; \ done; done + ===================================== src/lisp/globals.h ===================================== --- a/src/lisp/globals.h +++ b/src/lisp/globals.h @@ -64,7 +64,7 @@ extern void globals_init(void); #define EXTERN(name,bytes) .extern name bytes #endif #ifdef sparc -#ifdef SVR4 +#if defined(SVR4) || defined(FEATURE_ELF) #define EXTERN(name,bytes) .global name #else #define EXTERN(name,bytes) .global _ ## name ===================================== src/lisp/lisp.c ===================================== --- a/src/lisp/lisp.c +++ b/src/lisp/lisp.c @@ -470,7 +470,7 @@ main(int argc, const char *argv[], const char *envp[]) lispobj initial_function = 0; if (builtin_image_flag != 0) { -#if defined(SOLARIS) || (defined(i386) && (defined(__linux__) || defined(DARWIN) || defined(__FreeBSD__) || defined(__NetBSD__))) +#if defined(SOLARIS) || defined(DARWIN) || (defined(i386) && (defined(__linux__) || defined(__FreeBSD__) || defined(__NetBSD__))) initial_function = (lispobj) initial_function_addr; #else initial_function = (lispobj) & initial_function_addr; ===================================== src/lisp/os-common.c ===================================== --- a/src/lisp/os-common.c +++ b/src/lisp/os-common.c @@ -221,7 +221,7 @@ os_foreign_linkage_init(void) } #endif if (i == 0) { -#if defined(sparc) +#if defined(sparc) || (defined(DARWIN) && defined(__ppc__)) if (type != LINKAGE_CODE_TYPE || strcmp(c_symbol_name, EXTERN_ALIEN_NAME("call_into_c"))) { fprintf(stderr, "linkage_data is %s but expected %s\n", c_symbol_name, @@ -229,14 +229,6 @@ os_foreign_linkage_init(void) lose("First element of linkage_data is bogus.\n"); } arch_make_linkage_entry(i, (void*) call_into_c, 1); -#elif (defined(DARWIN) && defined(__ppc__)) - if (type != 1 || strcmp(c_symbol_name, EXTERN_ALIEN_NAME("call_into_c"))) { - fprintf(stderr, "linkage_data is %s but expected %s\n", - c_symbol_name, - EXTERN_ALIEN_NAME("call_into_c")); - lose("First element of linkage_data is bogus.\n"); - } - arch_make_linkage_entry(i, &call_into_c, 1); #else if (type != LINKAGE_CODE_TYPE || strcmp(c_symbol_name, EXTERN_ALIEN_NAME("resolve_linkage_tramp"))) { ===================================== src/lisp/ppc-assem.S ===================================== --- a/src/lisp/ppc-assem.S +++ b/src/lisp/ppc-assem.S @@ -236,7 +236,7 @@ x: * The 6 is vm:function-code-offset, the 4 is * the number of bytes in a lispobj. */ - addi reg_LIP,reg_CODE,6*4-type_FunctionPointer + addi reg_LIP,reg_CODE,FUNCTION_CODE_OFFSET mtctr reg_LIP slwi reg_NARGS,reg_NL2,2 bctr ===================================== src/lisp/sparc-assem.S ===================================== --- a/src/lisp/sparc-assem.S +++ b/src/lisp/sparc-assem.S @@ -4,43 +4,12 @@ #include <sys/asm_linkage.h> #include <sys/psw.h> #include <sys/trap.h> -#define _current_binding_stack_pointer current_binding_stack_pointer -#define _current_control_stack_pointer current_control_stack_pointer -#define _current_dynamic_space_free_pointer current_dynamic_space_free_pointer -#define _foreign_function_call_active foreign_function_call_active -#define _current_control_frame_pointer current_control_frame_pointer -#define _call_into_lisp call_into_lisp -#define _function_end_breakpoint_end function_end_breakpoint_end -#define _closure_tramp closure_tramp -#define _undefined_tramp undefined_tramp -#define _function_end_breakpoint_trap function_end_breakpoint_trap -#define _function_end_breakpoint_guts function_end_breakpoint_guts -#define _call_into_c call_into_c -#define _flush_icache flush_icache -#define _do_pending_interrupt do_pending_interrupt -#define _do_dynamic_space_overflow_error do_dynamic_space_overflow_error -#define _do_dynamic_space_overflow_warning do_dynamic_space_overflow_warning -#ifdef GENCGC -/*#define _collect_garbage collect_garbage*/ -#define _fpu_save fpu_save -#define _fpu_restore fpu_restore -#endif -#ifdef LINKAGE_TABLE -#define _resolve_linkage_tramp resolve_linkage_tramp -#define _lazy_resolve_linkage lazy_resolve_linkage -#define _undefined_foreign_symbol_trap undefined_foreign_symbol_trap -#endif #ifdef __STDC__ #define FUNCDEF(x) .type x, \#function #else #define FUNCDEF(x) .type x, #function #endif #else -#include <machine/asm_linkage.h> -#include <machine/psl.h> -#include <machine/trap.h> -#define FUNCDEF(x) /* nothing */ -#define SET_SIZE(x) /* nothing */ #endif #define LANGUAGE_ASSEMBLY @@ -68,9 +37,9 @@ #define FRAMESIZE (SA(MINFRAME)) #endif .seg "text" - .global _call_into_lisp - FUNCDEF(_call_into_lisp) -_call_into_lisp: + .global call_into_lisp + FUNCDEF(call_into_lisp) +call_into_lisp: save %sp, -FRAMESIZE, %sp /* Flush all of C's register windows to the stack. */ ta ST_FLUSH_WINDOWS @@ -96,15 +65,15 @@ _call_into_lisp: set pseudo_atomic_Value, reg_ALLOC /* Turn off foreign function call. */ - sethi %hi(_foreign_function_call_active), reg_NL0 - st reg_ZERO, [reg_NL0+%lo(_foreign_function_call_active)] + sethi %hi(foreign_function_call_active), reg_NL0 + st reg_ZERO, [reg_NL0+%lo(foreign_function_call_active)] /* Load the rest of lisp state. */ - load(_current_dynamic_space_free_pointer, reg_NL0) + load(current_dynamic_space_free_pointer, reg_NL0) add reg_NL0, reg_ALLOC, reg_ALLOC - load(_current_binding_stack_pointer, reg_BSP) - load(_current_control_stack_pointer, reg_CSP) - load(_current_control_frame_pointer, reg_OCFP) + load(current_binding_stack_pointer, reg_BSP) + load(current_control_stack_pointer, reg_CSP) + load(current_control_frame_pointer, reg_OCFP) /* No longer atomic, and check for interrupt. */ andn reg_ALLOC, pseudo_atomic_Value, reg_ALLOC @@ -147,13 +116,13 @@ lra: /* Store LISP state */ andn reg_ALLOC, lowtag_Mask, reg_NL1 - store(reg_NL1,_current_dynamic_space_free_pointer) - store(reg_BSP,_current_binding_stack_pointer) - store(reg_CSP,_current_control_stack_pointer) - store(reg_CFP,_current_control_frame_pointer) + store(reg_NL1,current_dynamic_space_free_pointer) + store(reg_BSP,current_binding_stack_pointer) + store(reg_CSP,current_control_stack_pointer) + store(reg_CFP,current_control_frame_pointer) /* No longer in Lisp. */ - store(reg_NL1,_foreign_function_call_active) + store(reg_NL1,foreign_function_call_active) /* Were we interrupted? */ andn reg_ALLOC, pseudo_atomic_Value, reg_ALLOC @@ -164,13 +133,13 @@ lra: ld [%sp+FRAMESIZE-4], %i7 ret restore %sp, FRAMESIZE, %sp - SET_SIZE(_call_into_lisp) + SET_SIZE(call_into_lisp) - .global _call_into_c - FUNCDEF(_call_into_c) -_call_into_c: + .global call_into_c + FUNCDEF(call_into_c) +call_into_c: #ifdef v8plus stx %o2, [%fp - 8 - 1*8] stx %o3, [%fp - 8 - 2*8] @@ -195,17 +164,17 @@ _call_into_c: st reg_L0, [reg_CFP+4] /* Store LISP state */ - store(reg_BSP,_current_binding_stack_pointer) - store(reg_CSP,_current_control_stack_pointer) - store(reg_CFP,_current_control_frame_pointer) + store(reg_BSP,current_binding_stack_pointer) + store(reg_CSP,current_control_stack_pointer) + store(reg_CFP,current_control_frame_pointer) /* Use reg_CFP as a work register, and restore it */ andn reg_ALLOC, lowtag_Mask, reg_CFP - store(reg_CFP,_current_dynamic_space_free_pointer) - load(_current_control_frame_pointer, reg_CFP) + store(reg_CFP,current_dynamic_space_free_pointer) + load(current_control_frame_pointer, reg_CFP) /* No longer in Lisp. */ - store(reg_CSP,_foreign_function_call_active) + store(reg_CSP,foreign_function_call_active) /* Were we interrupted? */ andn reg_ALLOC, pseudo_atomic_Value, reg_ALLOC @@ -229,15 +198,15 @@ _call_into_c: set pseudo_atomic_Value, reg_ALLOC /* No longer in foreign function call. */ - sethi %hi(_foreign_function_call_active), reg_NL2 - st reg_ZERO, [reg_NL2+%lo(_foreign_function_call_active)] + sethi %hi(foreign_function_call_active), reg_NL2 + st reg_ZERO, [reg_NL2+%lo(foreign_function_call_active)] /* Load the rest of lisp state. */ - load(_current_dynamic_space_free_pointer, reg_NL2) + load(current_dynamic_space_free_pointer, reg_NL2) add reg_NL2, reg_ALLOC, reg_ALLOC - load(_current_binding_stack_pointer, reg_BSP) - load(_current_control_stack_pointer, reg_CSP) - load(_current_control_frame_pointer, reg_CFP) + load(current_binding_stack_pointer, reg_BSP) + load(current_control_stack_pointer, reg_CSP) + load(current_control_frame_pointer, reg_CFP) /* Get the return address back. */ ld [reg_CFP+4], reg_LIP @@ -267,7 +236,7 @@ _call_into_c: ret nop - SET_SIZE(_call_into_c) + SET_SIZE(call_into_c) #if 0 /* undefined_tramp and closure_tramp are now Lisp assembly routines. @@ -332,8 +301,8 @@ _closure_tramp: .text .align 8 - .global _function_end_breakpoint_guts -_function_end_breakpoint_guts: + .global function_end_breakpoint_guts +function_end_breakpoint_guts: .word type_ReturnPcHeader b 1f nop @@ -347,18 +316,18 @@ _function_end_breakpoint_guts: mov reg_NIL, reg_A5 1: - .global _function_end_breakpoint_trap -_function_end_breakpoint_trap: + .global function_end_breakpoint_trap +function_end_breakpoint_trap: unimp trap_FunctionEndBreakpoint b 1b nop - .global _function_end_breakpoint_end -_function_end_breakpoint_end: + .global function_end_breakpoint_end +function_end_breakpoint_end: - .global _flush_icache - FUNCDEF(_flush_icache) -_flush_icache: + .global flush_icache + FUNCDEF(flush_icache) +flush_icache: add %o0,%o1,%o2 1: iflush %o0 ! flush instruction cache add %o0,8,%o0 @@ -367,34 +336,34 @@ _flush_icache: nop retl ! return from leaf routine nop - SET_SIZE(_flush_icache) + SET_SIZE(flush_icache) - .global _do_pending_interrupt - FUNCDEF(_do_pending_interrupt) -_do_pending_interrupt: + .global do_pending_interrupt + FUNCDEF(do_pending_interrupt) +do_pending_interrupt: unimp trap_PendingInterrupt retl nop - SET_SIZE(_do_pending_interrupt) + SET_SIZE(do_pending_interrupt) #ifdef trap_DynamicSpaceOverflowError - .global _do_dynamic_space_overflow_error - FUNCDEF(_do_dynamic_space_overflow_error) -_do_dynamic_space_overflow_error: + .global do_dynamic_space_overflow_error + FUNCDEF(do_dynamic_space_overflow_error) +do_dynamic_space_overflow_error: unimp trap_DynamicSpaceOverflowError retl nop - SET_SIZE(_do_dynamic_space_overflow_error) + SET_SIZE(do_dynamic_space_overflow_error) #endif #ifdef trap_DynamicSpaceOverflowWarning - .global _do_dynamic_space_overflow_warning - FUNCDEF(_do_dynamic_space_overflow_warning) -_do_dynamic_space_overflow_warning: + .global do_dynamic_space_overflow_warning + FUNCDEF(do_dynamic_space_overflow_warning) +do_dynamic_space_overflow_warning: unimp trap_DynamicSpaceOverflowWarning retl nop - SET_SIZE(_do_dynamic_space_overflow_warning) + SET_SIZE(do_dynamic_space_overflow_warning) #endif #ifdef LINKAGE_TABLE @@ -411,10 +380,10 @@ _do_dynamic_space_overflow_warning: * registers have been saved, including FP registers. Hence, no need * to save them. */ - .global _lazy_resolve_linkage - .global _resolve_linkage_tramp - FUNCDEF(_resolve_linkage_tramp) -_resolve_linkage_tramp: + .global lazy_resolve_linkage + .global resolve_linkage_tramp + FUNCDEF(resolve_linkage_tramp) +resolve_linkage_tramp: /* * At this point, all of the global %g registers have been * saved by call_into_c, so we can use them as temps. %g2, @@ -433,7 +402,7 @@ _resolve_linkage_tramp: save %sp, -FRAMESIZE, %sp /* %g2 tells where we came from in the linkage table */ - call _lazy_resolve_linkage + call lazy_resolve_linkage mov reg_NIL, %o0 ! in the delay slot mov %o0, reg_NIL @@ -443,15 +412,15 @@ _resolve_linkage_tramp: jmp reg_NIL nop - SET_SIZE(_resolve_linkage_tramp) + SET_SIZE(resolve_linkage_tramp) - .global _undefined_foreign_symbol_trap - FUNCDEF(_undefined_foreign_symbol_trap) + .global undefined_foreign_symbol_trap + FUNCDEF(undefined_foreign_symbol_trap) /* * When we get called, %o0 contains the address of the data_vector object * which is a string naming the bad symbol. */ -_undefined_foreign_symbol_trap: +undefined_foreign_symbol_trap: /* Need to restore all the global registers with the Lisp values that were saved away in call_into_c. (This routine is only called from @@ -463,10 +432,10 @@ _undefined_foreign_symbol_trap: */ - load(_current_dynamic_space_free_pointer, reg_ALLOC) - load(_current_binding_stack_pointer, reg_BSP) - load(_current_control_stack_pointer, reg_CSP) - load(_current_control_frame_pointer, reg_CFP) + load(current_dynamic_space_free_pointer, reg_ALLOC) + load(current_binding_stack_pointer, reg_BSP) + load(current_control_stack_pointer, reg_CSP) + load(current_control_frame_pointer, reg_CFP) set NIL, reg_NIL @@ -493,9 +462,9 @@ _undefined_foreign_symbol_trap: * a sparc v9, the Lisp code can actually use all 32 double-float * registers. For later. */ - .global _fpu_save - FUNCDEF(_fpu_save) -_fpu_save: + .global fpu_save + FUNCDEF(fpu_save) +fpu_save: std %f0, [%o0 + 4*0] std %f2, [%o0 + 4*2] std %f4, [%o0 + 4*4] @@ -535,11 +504,11 @@ _fpu_save: #endif retl nop - SET_SIZE(_fpu_save) + SET_SIZE(fpu_save) - .global _fpu_restore - FUNCDEF(_fpu_restore) -_fpu_restore: + .global fpu_restore + FUNCDEF(fpu_restore) +fpu_restore: ldd [%o0 + 4*0], %f0 ldd [%o0 + 4*2], %f2 ldd [%o0 + 4*4], %f4 @@ -579,254 +548,8 @@ _fpu_restore: #endif retl nop - SET_SIZE(_fpu_restore) - -#ifndef SOLARIS - -/****************************************************************\ -* State saving and restoring. -\****************************************************************/ - - - .global _call_on_stack -_call_on_stack: - call %o0 - sub %o1, SA(MINFRAME), %sp - unimp 0 + SET_SIZE(fpu_restore) - .global _save_state -_save_state: - save %sp, -(SA(8*4)+SA(MINFRAME)), %sp - ta ST_FLUSH_WINDOWS - st %i7, [%sp+SA(MINFRAME)] - st %g1, [%sp+SA(MINFRAME)+4] - std %g2, [%sp+SA(MINFRAME)+8] - std %g4, [%sp+SA(MINFRAME)+16] - std %g6, [%sp+SA(MINFRAME)+24] - ! ### Should also save the FP state. - mov %i1, %o1 - call %i0 - mov %sp, %o0 - mov %o0, %i0 -restore_state: - ld [%sp+SA(MINFRAME)+4], %g1 - ldd [%sp+SA(MINFRAME)+8], %g2 - ldd [%sp+SA(MINFRAME)+16], %g4 - ldd [%sp+SA(MINFRAME)+24], %g6 - ret - restore - - .global _restore_state -_restore_state: - ta ST_FLUSH_WINDOWS - mov %o0, %fp - mov %o1, %i0 - restore - ld [%sp+SA(MINFRAME)], %i7 - b restore_state - mov %o0, %i0 - - - -/****************************************************************\ - -We need our own version of sigtramp. - -\****************************************************************/ - - .global __sigtramp, __sigfunc -__sigtramp: - ! - ! On entry sp points to: - ! 0 - 63: window save area - ! 64: signal number - ! 68: signal code - ! 72: pointer to sigcontext - ! 76: addr parameter - ! - ! A sigcontext looks like: -#define SC_ONSTACK 0 -#define SC_MASK 4 -#define SC_SP 8 -#define SC_PC 12 -#define SC_NPC 16 -#define SC_PSR 20 -#define SC_G1 24 -#define SC_O0 28 - ! - ! We change sc_g1 to point to a reg save area: -#define IREGS_SAVE 0 -#define FPREGS_SAVE (32*4) -#define Y_SAVE (64*4) -#define FSR_SAVE (65*4) -#define REGSAVESIZE (66*4) - ! - ! After we allocate space for the reg save area, the stack looks like: - ! < window save area, etc > -#define REGSAVEOFF SA(MINFRAME) -#define IREGSOFF REGSAVEOFF+IREGS_SAVE -#define FPREGSOFF REGSAVEOFF+FPREGS_SAVE -#define YOFF REGSAVEOFF+Y_SAVE -#define FSROFF REGSAVEOFF+FSR_SAVE -#define ORIGSIGNUMOFF REGSAVEOFF+REGSAVESIZE -#define ORIGCODEOFF ORIGSIGNUMOFF+4 -#define ORIGSCPOFF ORIGSIGNUMOFF+8 -#define ORIGADDROFF ORIGSIGNUMOFF+12 - - ! Allocate space for the reg save area. - sub %sp, REGSAVESIZE+SA(MINFRAME)-64, %sp - - ! Save integer registers. - ! Note: the globals and outs are good, but the locals and ins have - ! been trashed. But luckly, they have been saved on the stack. - ! So we need to extract the saved stack pointer from the sigcontext - ! to determine where they are. - std %g0, [%sp+IREGSOFF] - std %g2, [%sp+IREGSOFF+8] - std %g4, [%sp+IREGSOFF+16] - std %g6, [%sp+IREGSOFF+24] - std %o0, [%sp+IREGSOFF+32] - std %o2, [%sp+IREGSOFF+40] - ld [%sp+ORIGSCPOFF], %o2 - ld [%o2+SC_SP], %o0 - std %o4, [%sp+IREGSOFF+48] - st %o0, [%sp+IREGSOFF+56] - st %o7, [%sp+IREGSOFF+60] - - ldd [%o0], %l0 - ldd [%o0+8], %l2 - ldd [%o0+16], %l4 - ldd [%o0+24], %l6 - ldd [%o0+32], %i0 - ldd [%o0+40], %i2 - ldd [%o0+48], %i4 - ldd [%o0+56], %i6 - std %l0, [%sp+IREGSOFF+64] - std %l2, [%sp+IREGSOFF+72] - std %l4, [%sp+IREGSOFF+80] - std %l6, [%sp+IREGSOFF+88] - std %i0, [%sp+IREGSOFF+96] - std %i2, [%sp+IREGSOFF+104] - std %i4, [%sp+IREGSOFF+112] - std %i6, [%sp+IREGSOFF+120] - - ! Check to see if we need to save the fp regs. - ld [%o2+SC_PSR], %l5 ! get psr - set PSR_EF, %l0 - mov %y, %l2 ! save y - btst %l0, %l5 ! is FPU enabled? - bz 1f ! if not skip FPU save - st %l2, [%sp + YOFF] - - ! save all fpu registers. - std %f0, [%sp+FPREGSOFF+(0*4)] - std %f2, [%sp+FPREGSOFF+(2*4)] - std %f4, [%sp+FPREGSOFF+(4*4)] - std %f6, [%sp+FPREGSOFF+(6*4)] - std %f8, [%sp+FPREGSOFF+(8*4)] - std %f10, [%sp+FPREGSOFF+(10*4)] - std %f12, [%sp+FPREGSOFF+(12*4)] - std %f14, [%sp+FPREGSOFF+(14*4)] - std %f16, [%sp+FPREGSOFF+(16*4)] - std %f18, [%sp+FPREGSOFF+(18*4)] - std %f20, [%sp+FPREGSOFF+(20*4)] - std %f22, [%sp+FPREGSOFF+(22*4)] - std %f24, [%sp+FPREGSOFF+(24*4)] - std %f26, [%sp+FPREGSOFF+(26*4)] - std %f28, [%sp+FPREGSOFF+(28*4)] - std %f30, [%sp+FPREGSOFF+(30*4)] - st %fsr, [%sp+FSROFF] ! save old fsr -1: - - ld [%sp+ORIGSIGNUMOFF], %o0! get signal number - set __sigfunc, %g1 ! get array of function ptrs - sll %o0, 2, %g2 ! scale signal number for index - ld [%g1+%g2], %g1 ! get func - ld [%sp+ORIGCODEOFF], %o1 ! get code - ! %o2 is already loaded with scp - add %sp, REGSAVEOFF, %o3 ! compute pointer to reg save area - st %o3, [%o2 + SC_G1] ! save in sc_g1. - call %g1 ! (*_sigfunc[sig])(sig,code,scp,addr) - ld [%sp+ORIGADDROFF], %o3 ! get addr - - ! Recompute scp, and drop into _sigreturn - ld [%sp+ORIGSCPOFF], %o0 ! get scp - - .global _sigreturn -_sigreturn: - ! Load g1 with addr of reg save area (from sc_g1) - ld [%o0+SC_G1], %g1 - - ! Move values we cannot restore directory into real sigcontext. - ld [%g1+IREGS_SAVE+(4*1)], %l0 ! g1 - ld [%g1+IREGS_SAVE+(4*8)], %l1 ! o0 - ld [%g1+IREGS_SAVE+(4*14)], %l2 ! sp - st %l0, [%o0+SC_G1] - st %l1, [%o0+SC_O0] - st %l2, [%o0+SC_SP] - - ld [%o0+SC_PSR], %l2 ! get psr - set PSR_EF, %l0 - ld [%g1+Y_SAVE], %l1 ! restore y - btst %l0, %l2 ! is FPU enabled? - bz 2f ! if not skip FPU restore - mov %l1, %y - - ldd [%g1+FPREGS_SAVE+(0*4)], %f0 ! restore all fpu registers. - ldd [%g1+FPREGS_SAVE+(2*4)], %f2 - ldd [%g1+FPREGS_SAVE+(4*4)], %f4 - ldd [%g1+FPREGS_SAVE+(6*4)], %f6 - ldd [%g1+FPREGS_SAVE+(8*4)], %f8 - ldd [%g1+FPREGS_SAVE+(10*4)], %f10 - ldd [%g1+FPREGS_SAVE+(12*4)], %f12 - ldd [%g1+FPREGS_SAVE+(14*4)], %f14 - ldd [%g1+FPREGS_SAVE+(16*4)], %f16 - ldd [%g1+FPREGS_SAVE+(18*4)], %f18 - ldd [%g1+FPREGS_SAVE+(20*4)], %f20 - ldd [%g1+FPREGS_SAVE+(22*4)], %f22 - ldd [%g1+FPREGS_SAVE+(24*4)], %f24 - ldd [%g1+FPREGS_SAVE+(26*4)], %f26 - ldd [%g1+FPREGS_SAVE+(28*4)], %f28 - ldd [%g1+FPREGS_SAVE+(30*4)], %f30 - ld [%g1+FSR_SAVE], %fsr ! restore old fsr -2: - - ! The locals and in are restored from the stack, so we have to put - ! them there. - ld [%o0+SC_SP], %o1 - ldd [%g1+IREGS_SAVE+(16*4)], %l0 - ldd [%g1+IREGS_SAVE+(18*4)], %l2 - ldd [%g1+IREGS_SAVE+(20*4)], %l4 - ldd [%g1+IREGS_SAVE+(22*4)], %l6 - ldd [%g1+IREGS_SAVE+(24*4)], %i0 - ldd [%g1+IREGS_SAVE+(26*4)], %i2 - ldd [%g1+IREGS_SAVE+(28*4)], %i4 - ldd [%g1+IREGS_SAVE+(30*4)], %i6 - std %l0, [%o1+(0*4)] - std %l2, [%o1+(2*4)] - std %l4, [%o1+(4*4)] - std %l6, [%o1+(6*4)] - std %i0, [%o1+(8*4)] - std %i2, [%o1+(10*4)] - std %i4, [%o1+(12*4)] - std %i6, [%o1+(14*4)] - - ! Restore the globals and outs. Do not restore %g1, %o0, or %sp - ! because they get restored from the sigcontext. - ldd [%g1+IREGS_SAVE+(2*4)], %g2 - ldd [%g1+IREGS_SAVE+(4*4)], %g4 - ldd [%g1+IREGS_SAVE+(6*4)], %g6 - ld [%g1+IREGS_SAVE+(9*4)], %o1 - ldd [%g1+IREGS_SAVE+(10*4)], %o2 - ldd [%g1+IREGS_SAVE+(12*4)], %o4 - ld [%g1+IREGS_SAVE+(15*4)], %o7 - - set 139, %g1 ! sigcleanup system call - t 0 - unimp 0 ! just in case it returns - /*NOTREACHED*/ - -#else /* SOLARIS */ .global save_context FUNCDEF(save_context) save_context: @@ -834,8 +557,6 @@ save_context: retl ! return from leaf routine nop SET_SIZE(save_context) - -#endif /* * Local variables: * tab-width: 8 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/compare/822beed88eed7cbdd5e63e338...