- cmucl-cvs - mailman3.common-lisp.net

[cmucl/cmucl][master] 2 commits: Remove old sunos stuff from sparc-assem.S
by Raymond Toy 10 Apr '15

10 Apr '15

Raymond Toy pushed to master at cmucl / cmucl Commits: 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. - - - - - 13 changed files: - + 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/lisp/globals.h - src/lisp/sparc-assem.S Changes: ===================================== 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(a)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(a)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/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/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/b038df8de36e85365670a50b…

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-11-1-g373bc97
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 373bc974935a33ff1515d0d1cce2af8f7d910c04 (commit) from e99b2b29bf65f7a2a678e9d7199085bf4aabd81a (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 373bc974935a33ff1515d0d1cce2af8f7d910c04 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Nov 6 19:20:01 2013 -0800 Recognize -h and -? options to print out a usage message. diff --git a/bin/create-target.sh b/bin/create-target.sh index 21b38a6..84c00c8 100755 --- a/bin/create-target.sh +++ b/bin/create-target.sh @@ -18,6 +18,19 @@ usage() { ##-- prgm_name=`basename $0` bld_dir=$1 lisp_variant=$2 motif_variant=$3 + +while getopts "h?" arg +do + case $arg in + h) usage ;; + \?) usage ;; + esac +done + +bld_dir=$1 +lisp_variant=$2 +motif_variant=$3 + exec 2>&1 [ -n "$bld_dir" ] || usage ----------------------------------------------------------------------- Summary of changes: bin/create-target.sh | 13 +++++++++++++ 1 file changed, 13 insertions(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. begin-x87-removal-21-gecd7d26
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via ecd7d26d363b65a174ab04a1c2a802fe8ca96ddc (commit) from 5abd66f6073fabd08af8e0155f74cd338a28d280 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit ecd7d26d363b65a174ab04a1c2a802fe8ca96ddc Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Apr 29 22:44:04 2014 -0700 Oops. Only compile float-sse2 on x86 machines! diff --git a/src/tools/comcom.lisp b/src/tools/comcom.lisp index b75a588..9ad7973 100644 --- a/src/tools/comcom.lisp +++ b/src/tools/comcom.lisp @@ -173,8 +173,9 @@ (when *load-stuff* (load (vmdir "target:assembly/support"))) (comf (vmdir "target:compiler/move")) -(comf (vmdir "target:compiler/float-sse2") - :byte-compile *byte-compile*) +(when (c:target-featurep :x86) + (comf (vmdir "target:compiler/float-sse2") + :byte-compile *byte-compile*)) (comf (vmdir "target:compiler/sap") :byte-compile *byte-compile*) (when (c:target-featurep :x86) (comf (vmdir "target:compiler/sse2-sap") ----------------------------------------------------------------------- Summary of changes: src/tools/comcom.lisp | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-42-g386d97b
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 386d97b2222de3cb7d175013d6509722c10b3846 (commit) via 058a45ff915dbe4ed7f08a24226b074e00c63d14 (commit) from e0b1f9f8b2142397cbf4ea76dd3ba862862baa49 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 386d97b2222de3cb7d175013d6509722c10b3846 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Aug 1 19:44:29 2014 -0700 Import pow (ieee754_pow) from fdlibm, as is. diff --git a/src/lisp/e_pow.c b/src/lisp/e_pow.c new file mode 100644 index 0000000..5683bf5 --- /dev/null +++ b/src/lisp/e_pow.c @@ -0,0 +1,309 @@ + +#ifndef lint +static char sccsid[] = "@(#)e_pow.c 1.5 04/04/22 SMI"; +#endif + +/* + * ==================================================== + * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved. + * + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* __ieee754_pow(x,y) return x**y + * + * n + * Method: Let x = 2 * (1+f) + * 1. Compute and return log2(x) in two pieces: + * log2(x) = w1 + w2, + * where w1 has 53-24 = 29 bit trailing zeros. + * 2. Perform y*log2(x) = n+y' by simulating muti-precision + * arithmetic, where |y'|<=0.5. + * 3. Return x**y = 2**n*exp(y'*log2) + * + * Special cases: + * 1. (anything) ** 0 is 1 + * 2. (anything) ** 1 is itself + * 3. (anything) ** NAN is NAN + * 4. NAN ** (anything except 0) is NAN + * 5. +-(|x| > 1) ** +INF is +INF + * 6. +-(|x| > 1) ** -INF is +0 + * 7. +-(|x| < 1) ** +INF is +0 + * 8. +-(|x| < 1) ** -INF is +INF + * 9. +-1 ** +-INF is NAN + * 10. +0 ** (+anything except 0, NAN) is +0 + * 11. -0 ** (+anything except 0, NAN, odd integer) is +0 + * 12. +0 ** (-anything except 0, NAN) is +INF + * 13. -0 ** (-anything except 0, NAN, odd integer) is +INF + * 14. -0 ** (odd integer) = -( +0 ** (odd integer) ) + * 15. +INF ** (+anything except 0,NAN) is +INF + * 16. +INF ** (-anything except 0,NAN) is +0 + * 17. -INF ** (anything) = -0 ** (-anything) + * 18. (-anything) ** (integer) is (-1)**(integer)*(+anything**integer) + * 19. (-anything except 0 and inf) ** (non-integer) is NAN + * + * Accuracy: + * pow(x,y) returns x**y nearly rounded. In particular + * pow(integer,integer) + * always returns the correct integer provided it is + * representable. + * + * Constants : + * The hexadecimal values are the intended ones for the following + * constants. The decimal values may be used, provided that the + * compiler will convert from decimal to binary accurately enough + * to produce the hexadecimal values shown. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +bp[] = {1.0, 1.5,}, +dp_h[] = { 0.0, 5.84962487220764160156e-01,}, /* 0x3FE2B803, 0x40000000 */ +dp_l[] = { 0.0, 1.35003920212974897128e-08,}, /* 0x3E4CFDEB, 0x43CFD006 */ +zero = 0.0, +one = 1.0, +two = 2.0, +two53 = 9007199254740992.0, /* 0x43400000, 0x00000000 */ +huge = 1.0e300, +tiny = 1.0e-300, + /* poly coefs for (3/2)*(log(x)-2s-2/3*s**3 */ +L1 = 5.99999999999994648725e-01, /* 0x3FE33333, 0x33333303 */ +L2 = 4.28571428578550184252e-01, /* 0x3FDB6DB6, 0xDB6FABFF */ +L3 = 3.33333329818377432918e-01, /* 0x3FD55555, 0x518F264D */ +L4 = 2.72728123808534006489e-01, /* 0x3FD17460, 0xA91D4101 */ +L5 = 2.30660745775561754067e-01, /* 0x3FCD864A, 0x93C9DB65 */ +L6 = 2.06975017800338417784e-01, /* 0x3FCA7E28, 0x4A454EEF */ +P1 = 1.66666666666666019037e-01, /* 0x3FC55555, 0x5555553E */ +P2 = -2.77777777770155933842e-03, /* 0xBF66C16C, 0x16BEBD93 */ +P3 = 6.61375632143793436117e-05, /* 0x3F11566A, 0xAF25DE2C */ +P4 = -1.65339022054652515390e-06, /* 0xBEBBBD41, 0xC5D26BF1 */ +P5 = 4.13813679705723846039e-08, /* 0x3E663769, 0x72BEA4D0 */ +lg2 = 6.93147180559945286227e-01, /* 0x3FE62E42, 0xFEFA39EF */ +lg2_h = 6.93147182464599609375e-01, /* 0x3FE62E43, 0x00000000 */ +lg2_l = -1.90465429995776804525e-09, /* 0xBE205C61, 0x0CA86C39 */ +ovt = 8.0085662595372944372e-0017, /* -(1024-log2(ovfl+.5ulp)) */ +cp = 9.61796693925975554329e-01, /* 0x3FEEC709, 0xDC3A03FD =2/(3ln2) */ +cp_h = 9.61796700954437255859e-01, /* 0x3FEEC709, 0xE0000000 =(float)cp */ +cp_l = -7.02846165095275826516e-09, /* 0xBE3E2FE0, 0x145B01F5 =tail of cp_h*/ +ivln2 = 1.44269504088896338700e+00, /* 0x3FF71547, 0x652B82FE =1/ln2 */ +ivln2_h = 1.44269502162933349609e+00, /* 0x3FF71547, 0x60000000 =24b 1/ln2*/ +ivln2_l = 1.92596299112661746887e-08; /* 0x3E54AE0B, 0xF85DDF44 =1/ln2 tail*/ + +#ifdef __STDC__ + double __ieee754_pow(double x, double y) +#else + double __ieee754_pow(x,y) + double x, y; +#endif +{ + double z,ax,z_h,z_l,p_h,p_l; + double y1,t1,t2,r,s,t,u,v,w; + int i0,i1,i,j,k,yisint,n; + int hx,hy,ix,iy; + unsigned lx,ly; + + i0 = ((*(int*)&one)>>29)^1; i1=1-i0; + hx = __HI(x); lx = __LO(x); + hy = __HI(y); ly = __LO(y); + ix = hx&0x7fffffff; iy = hy&0x7fffffff; + + /* y==zero: x**0 = 1 */ + if((iy|ly)==0) return one; + + /* +-NaN return x+y */ + if(ix > 0x7ff00000 || ((ix==0x7ff00000)&&(lx!=0)) || + iy > 0x7ff00000 || ((iy==0x7ff00000)&&(ly!=0))) + return x+y; + + /* determine if y is an odd int when x < 0 + * yisint = 0 ... y is not an integer + * yisint = 1 ... y is an odd int + * yisint = 2 ... y is an even int + */ + yisint = 0; + if(hx<0) { + if(iy>=0x43400000) yisint = 2; /* even integer y */ + else if(iy>=0x3ff00000) { + k = (iy>>20)-0x3ff; /* exponent */ + if(k>20) { + j = ly>>(52-k); + if((j<<(52-k))==ly) yisint = 2-(j&1); + } else if(ly==0) { + j = iy>>(20-k); + if((j<<(20-k))==iy) yisint = 2-(j&1); + } + } + } + + /* special value of y */ + if(ly==0) { + if (iy==0x7ff00000) { /* y is +-inf */ + if(((ix-0x3ff00000)|lx)==0) + return y - y; /* inf**+-1 is NaN */ + else if (ix >= 0x3ff00000)/* (|x|>1)**+-inf = inf,0 */ + return (hy>=0)? y: zero; + else /* (|x|<1)**-,+inf = inf,0 */ + return (hy<0)?-y: zero; + } + if(iy==0x3ff00000) { /* y is +-1 */ + if(hy<0) return one/x; else return x; + } + if(hy==0x40000000) return x*x; /* y is 2 */ + if(hy==0x3fe00000) { /* y is 0.5 */ + if(hx>=0) /* x >= +0 */ + return sqrt(x); + } + } + + ax = fabs(x); + /* special value of x */ + if(lx==0) { + if(ix==0x7ff00000||ix==0||ix==0x3ff00000){ + z = ax; /*x is +-0,+-inf,+-1*/ + if(hy<0) z = one/z; /* z = (1/|x|) */ + if(hx<0) { + if(((ix-0x3ff00000)|yisint)==0) { + z = (z-z)/(z-z); /* (-1)**non-int is NaN */ + } else if(yisint==1) + z = -z; /* (x<0)**odd = -(|x|**odd) */ + } + return z; + } + } + + n = (hx>>31)+1; + + /* (x<0)**(non-int) is NaN */ + if((n|yisint)==0) return (x-x)/(x-x); + + s = one; /* s (sign of result -ve**odd) = -1 else = 1 */ + if((n|(yisint-1))==0) s = -one;/* (-ve)**(odd int) */ + + /* |y| is huge */ + if(iy>0x41e00000) { /* if |y| > 2**31 */ + if(iy>0x43f00000){ /* if |y| > 2**64, must o/uflow */ + if(ix<=0x3fefffff) return (hy<0)? huge*huge:tiny*tiny; + if(ix>=0x3ff00000) return (hy>0)? huge*huge:tiny*tiny; + } + /* over/underflow if x is not close to one */ + if(ix<0x3fefffff) return (hy<0)? s*huge*huge:s*tiny*tiny; + if(ix>0x3ff00000) return (hy>0)? s*huge*huge:s*tiny*tiny; + /* now |1-x| is tiny <= 2**-20, suffice to compute + log(x) by x-x^2/2+x^3/3-x^4/4 */ + t = ax-one; /* t has 20 trailing zeros */ + w = (t*t)*(0.5-t*(0.3333333333333333333333-t*0.25)); + u = ivln2_h*t; /* ivln2_h has 21 sig. bits */ + v = t*ivln2_l-w*ivln2; + t1 = u+v; + __LO(t1) = 0; + t2 = v-(t1-u); + } else { + double ss,s2,s_h,s_l,t_h,t_l; + n = 0; + /* take care subnormal number */ + if(ix<0x00100000) + {ax *= two53; n -= 53; ix = __HI(ax); } + n += ((ix)>>20)-0x3ff; + j = ix&0x000fffff; + /* determine interval */ + ix = j|0x3ff00000; /* normalize ix */ + if(j<=0x3988E) k=0; /* |x|<sqrt(3/2) */ + else if(j<0xBB67A) k=1; /* |x|<sqrt(3) */ + else {k=0;n+=1;ix -= 0x00100000;} + __HI(ax) = ix; + + /* compute ss = s_h+s_l = (x-1)/(x+1) or (x-1.5)/(x+1.5) */ + u = ax-bp[k]; /* bp[0]=1.0, bp[1]=1.5 */ + v = one/(ax+bp[k]); + ss = u*v; + s_h = ss; + __LO(s_h) = 0; + /* t_h=ax+bp[k] High */ + t_h = zero; + __HI(t_h)=((ix>>1)|0x20000000)+0x00080000+(k<<18); + t_l = ax - (t_h-bp[k]); + s_l = v*((u-s_h*t_h)-s_h*t_l); + /* compute log(ax) */ + s2 = ss*ss; + r = s2*s2*(L1+s2*(L2+s2*(L3+s2*(L4+s2*(L5+s2*L6))))); + r += s_l*(s_h+ss); + s2 = s_h*s_h; + t_h = 3.0+s2+r; + __LO(t_h) = 0; + t_l = r-((t_h-3.0)-s2); + /* u+v = ss*(1+...) */ + u = s_h*t_h; + v = s_l*t_h+t_l*ss; + /* 2/(3log2)*(ss+...) */ + p_h = u+v; + __LO(p_h) = 0; + p_l = v-(p_h-u); + z_h = cp_h*p_h; /* cp_h+cp_l = 2/(3*log2) */ + z_l = cp_l*p_h+p_l*cp+dp_l[k]; + /* log2(ax) = (ss+..)*2/(3*log2) = n + dp_h + z_h + z_l */ + t = (double)n; + t1 = (((z_h+z_l)+dp_h[k])+t); + __LO(t1) = 0; + t2 = z_l-(((t1-t)-dp_h[k])-z_h); + } + + /* split up y into y1+y2 and compute (y1+y2)*(t1+t2) */ + y1 = y; + __LO(y1) = 0; + p_l = (y-y1)*t1+y*t2; + p_h = y1*t1; + z = p_l+p_h; + j = __HI(z); + i = __LO(z); + if (j>=0x40900000) { /* z >= 1024 */ + if(((j-0x40900000)|i)!=0) /* if z > 1024 */ + return s*huge*huge; /* overflow */ + else { + if(p_l+ovt>z-p_h) return s*huge*huge; /* overflow */ + } + } else if((j&0x7fffffff)>=0x4090cc00 ) { /* z <= -1075 */ + if(((j-0xc090cc00)|i)!=0) /* z < -1075 */ + return s*tiny*tiny; /* underflow */ + else { + if(p_l<=z-p_h) return s*tiny*tiny; /* underflow */ + } + } + /* + * compute 2**(p_h+p_l) + */ + i = j&0x7fffffff; + k = (i>>20)-0x3ff; + n = 0; + if(i>0x3fe00000) { /* if |z| > 0.5, set n = [z+0.5] */ + n = j+(0x00100000>>(k+1)); + k = ((n&0x7fffffff)>>20)-0x3ff; /* new k for n */ + t = zero; + __HI(t) = (n&~(0x000fffff>>k)); + n = ((n&0x000fffff)|0x00100000)>>(20-k); + if(j<0) n = -n; + p_h -= t; + } + t = p_l+p_h; + __LO(t) = 0; + u = t*lg2_h; + v = (p_l-(t-p_h))*lg2+t*lg2_l; + z = u+v; + w = v-(z-u); + t = z*z; + t1 = z - t*(P1+t*(P2+t*(P3+t*(P4+t*P5)))); + r = (z*t1)/(t1-two)-(w+z*w); + z = one-(r-z); + j = __HI(z); + j += (n<<20); + if((j>>20)<=0) z = scalbn(z,n); /* subnormal output */ + else __HI(z) += (n<<20); + return s*z; +} commit 058a45ff915dbe4ed7f08a24226b074e00c63d14 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Aug 1 19:41:02 2014 -0700 Use fdlibm versions of log1p and expm1. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 2a88c9f..1a942fe 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -88,8 +88,8 @@ (def-math-rtn "sqrt" 1) (def-math-rtn "hypot" 2) -(def-math-rtn "log1p" 1) -(def-math-rtn "expm1" 1) +(def-math-rtn ("fdlibm_log1p" %log1p) 1) +(def-math-rtn ("fdlibm_expm1" %expm1) 1) ;; These are needed for use by byte-compiled files. But don't use ;; these with sse2 since we don't support using the x87 instructions ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 4 +- src/lisp/e_pow.c | 309 +++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 311 insertions(+), 2 deletions(-) create mode 100644 src/lisp/e_pow.c hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch rtoy-simp-dd-trig created. snapshot-2013-12-a-25-g712df0b
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, rtoy-simp-dd-trig has been created at 712df0bc4e655226bc5c9ed91aa9c875b4a5eb0d (commit) - Log ----------------------------------------------------------------- commit 712df0bc4e655226bc5c9ed91aa9c875b4a5eb0d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Dec 20 16:47:21 2013 -0800 Add tests for dd-%sincos. diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp index 911b623..b46c904 100644 --- a/src/tests/trig.lisp +++ b/src/tests/trig.lisp @@ -388,3 +388,46 @@ -4.080663888418042385451434945255951177650840227682488471558860153w-1 1.888w-33))) +(define-test dd-sincos.signed-zeroes + "Test sincos at 0d0, -0d0" + (:tag :sincos :signed-zeroes :double-double) + (assert-equal '(0w0 1w0) + (multiple-value-list (kernel::dd-%sincos 0w0))) + (assert-equal '(-0w0 1w0) + (multiple-value-list (kernel::dd-%sincos -0w0)))) + +;; Test sincos at a bunch of random points and compare the result from +;; sin and cos. If they differ, save the result in a list to be +;; returned. +(defun dd-sincos-test (limit n) + (let (results) + (dotimes (k n) + (let* ((x (random limit)) + (s-exp (sin x)) + (c-exp (cos x))) + (multiple-value-bind (s c) + (kernel::dd-%sincos x) + (unless (and (eql s s-exp) + (eql c c-exp)) + (push (list x + (list s s-exp) + (list c c-exp)) + results))))) + results)) + +(define-test dd-sincos.consistent + "Test sincos is consistent with sin and cos" + (:tag :sincos :double-double) + ;; Small values + (assert-eql nil + (dd-sincos-test (/ kernel:dd-pi 4) 1000)) + ;; Medium + (assert-eql nil + (dd-sincos-test 16w0 1000)) + ;; Large + (assert-eql nil + (dd-sincos-test (scale-float 1w0 120) 1000)) + ;; Very large + (assert-eql nil + (dd-sincos-test (scale-float 1w0 1023) 1000))) + commit bf84dbc8c5bd5478fd36b55f99e119cfff11ca6d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Dec 20 16:47:07 2013 -0800 Add dd-%sincos and use it as needed instead of calling sin and cos separately. diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp index 6661f2b..381d678 100644 --- a/src/code/irrat-dd.lisp +++ b/src/code/irrat-dd.lisp @@ -1191,6 +1191,29 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 (dd-%%tan reduced) (- (/ (dd-%%tan reduced)))))))) +(defun dd-%sincos (x) + (declare (double-double-float x)) + (cond ((< (abs x) (/ pi 4)) + (values (dd-%%sin x) + (dd-%%cos x))) + (t + ;; Argument reduction needed + (multiple-value-bind (n reduced) + (reduce-arg x) + (case (logand n 3) + (0 + (values (dd-%%sin reduced) + (dd-%%cos reduced))) + (1 + (values (dd-%%cos reduced) + (- (dd-%%sin reduced)))) + (2 + (values (- (dd-%%sin reduced)) + (- (dd-%%cos reduced)))) + (3 + (values (- (dd-%%cos reduced)) + (dd-%%sin reduced)))))))) + ;;; dd-%log2 ;;; Base 2 logarithm. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 4ccf80a..078e56f 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -1298,7 +1298,9 @@ (coerce s '(dispatch-type theta))))) #+double-double ((double-double-float) - (complex (cos theta) (sin theta)))))) + (multiple-value-bind (s c) + (dd-%sincos theta) + (complex c s)))))) (defun asin (number) "Return the arc sine of NUMBER." diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index d123d18..34acdeb 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -748,8 +748,9 @@ #+double-double (deftransform cis ((z) (double-double-float) *) - ;; Cis. - '(complex (cos z) (sin z))) + `(multiple-value-bind (s c) + (kernel::dd-%sincos x) + (complex c s))) ;;; The argument range is limited on the x86 FP trig. functions. A commit 2e3e48d466c67a09ea7aeb23106fdc50143be3b5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Dec 20 16:07:12 2013 -0800 Add tests for double-double trig functions. diff --git a/src/tests/trig.lisp b/src/tests/trig.lisp index 58d10b6..911b623 100644 --- a/src/tests/trig.lisp +++ b/src/tests/trig.lisp @@ -215,3 +215,176 @@ (assert-eql nil (sincos-test (scale-float 1d0 1023) 1000))) +;; Compute the relative error between actual and expected if expected +;; is not zero. Otherwise, return absolute error between actual and +;; expected. If the error is less than the threshold, return T. +;; Otherwise return the actual (relative or absolute) error. +(defun rel-or-abs-error (actual expected &optional (threshold double-float-epsilon)) + (let ((err (if (zerop expected) + (abs (- actual expected)) + (/ (abs (- actual expected)) + (abs expected))))) + (if (<= err threshold) + t + err))) + +(define-test dd-sin.signed-zeroes + "Test sin for 0w0 and -0w0" + (:tag :sin :double-double :signed-zeroes) + (assert-eql 0w0 (sin 0w0)) + (assert-equal -0w0 (sin -0w0))) + +(define-test dd-sin.no-reduction + "Test sin for small args without reduction" + (:tag :sin :double-double) + (assert-eq t (rel-or-abs-error + (sin .5w0) + 4.794255386042030002732879352155713880818033679406006751886166131w-1 + 1w-32)) + (assert-eq t (rel-or-abs-error + (sin -0.5w0) + -4.794255386042030002732879352155713880818033679406006751886166131w-1 + 1w-32))) + +(define-test dd-sin.pi/2 + "Test for arg near pi/2" + (:tag :sin :double-double) + (assert-eq t (rel-or-abs-error + (sin (/ kernel:dd-pi 2)) + 1w0 + 1w-50))) + +;; The reference value were computed using maxima. Here's how to +;; compute the reference value. Set fpprec:64 to tell maxima to use +;; 64 digits of precision. For 7/4*pi, do (integer-decode-float (* 7/4 +;; kernel:dd-pi)) to get the exact rational representation of the +;; desired double-double-float. Then bfloat(sin(<rational>)). +(define-test dd-sin.arg-reduction + "Test for sin with arg reduction" + (:tag :sin :double-double) + ;; Test for argument reduction with n mod 4 = 0 + (assert-eq t (rel-or-abs-error + (sin (* 7/4 kernel:dd-pi)) + -7.07106781186547524400844362104849691328261037289050238659653433w-1 + 0w0)) + ;; Test for argument reduction with n mod 4 = 1 + (assert-eq t (rel-or-abs-error + (sin (* 9/4 kernel:dd-pi)) + 7.07106781186547524400844362104858161816423215627023442400880643w-1 + 0w0)) + ;; Test for argument reduction with n mod 4 = 2 + (assert-eq t (rel-or-abs-error + (sin (* 11/4 kernel:dd-pi)) + 7.071067811865475244008443621048998682901731241858306822215522497w-1 + 8.716w-33)) + ;; Test for argument reduction with n mod 4 = 3 + (assert-eq t (rel-or-abs-error + (sin (* 13/4 kernel:dd-pi)) + -7.071067811865475244008443621048777109664479707052746581685893187w-1 + 8.716w-33)) + ;; Test for argument reduction, big value + (assert-eq t (rel-or-abs-error + (sin (scale-float 1w0 120)) + 3.778201093607520226555484700569229919605866976512306642257987199w-1 + 8.156w-33))) + +(define-test dd-cos.signed-zeroes + "Test cos for 0w0 and -0w0" + (:tag :cos :double-double :signed-zeroes) + (assert-eql 1w0 (cos 0w0)) + (assert-equal 1w0 (cos -0w0))) + +(define-test dd-cos.no-reduction + "Test cos for small args without reduction" + (:tag :cos :double-double) + (assert-eq t (rel-or-abs-error + (cos .5w0) + 8.775825618903727161162815826038296519916451971097440529976108683w-1 + 0w0)) + (assert-eq t (rel-or-abs-error + (cos -0.5w0) + 8.775825618903727161162815826038296519916451971097440529976108683w-1 + 0w0))) + +(define-test dd-cos.pi/2 + "Test for arg near pi/2" + (:tag :cos :double-double) + (assert-eq t (rel-or-abs-error + (cos (/ kernel:dd-pi 2)) + -1.497384904859169777320797133937725094986669701841027904483071358w-33 + 0w0))) + +(define-test dd-cos.arg-reduction + "Test for cos with arg reduction" + (:tag :cos :double-double) + ;; Test for argument reduction with n mod 4 = 0 + (assert-eq t (rel-or-abs-error + (cos (* 7/4 kernel:dd-pi)) + 7.07106781186547524400844362104849691328261037289050238659653433w-1 + 0w0)) + ;; Test for argument reduction with n mod 4 = 1 + (assert-eq t (rel-or-abs-error + (cos (* 9/4 kernel:dd-pi)) + 7.07106781186547524400844362104858161816423215627023442400880643w-1 + 3.487w-32)) + ;; Test for argument reduction with n mod 4 = 2 + (assert-eq t (rel-or-abs-error + (cos (* 11/4 kernel:dd-pi)) + -7.071067811865475244008443621048998682901731241858306822215522497w-1 + 1.482w-31)) + ;; Test for argument reduction with n mod 4 = 3 + (assert-eq t (rel-or-abs-error + (cos (* 13/4 kernel:dd-pi)) + -7.071067811865475244008443621048777109664479707052746581685893187w-1 + 7.845w-32)) + ;; Test for argument reduction, big value + (assert-eq t (rel-or-abs-error + (cos (scale-float 1w0 120)) + -9.258790228548378673038617641074149467308332099286564602360493726w-1 + 0w0))) + +(define-test dd-tan.signed-zeroes + "Test tan for 0w0 and -0w0" + (:tag :tan :double-double :signed-zeroes) + (assert-eql 0w0 (tan 0w0)) + (assert-equal -0w0 (tan -0w0))) + +(define-test dd-tan.no-reduction + "Test tan for small args without reduction" + (:tag :tan :double-double) + (assert-eq t (rel-or-abs-error + (tan .5w0) + 5.463024898437905132551794657802853832975517201797912461640913859w-1 + 0w0)) + (assert-eq t (rel-or-abs-error + (tan -0.5w0) + -5.463024898437905132551794657802853832975517201797912461640913859w-1 + 0w0))) + +(define-test dd-tan.pi/2 + "Test for arg near pi/2" + (:tag :tan :double-double) + (assert-eq t (rel-or-abs-error + (tan (/ kernel:dd-pi 2)) + -6.67830961000672557834948096545679895621313886078988606234681001w32 + 0w0))) + +(define-test dd-tan.arg-reduction + "Test for tan with arg reduction" + (:tag :tan :double-double) + ;; Test for argument reduction with n even + (assert-eq t (rel-or-abs-error + (tan (* 7/4 kernel:dd-pi)) + -1.000000000000000000000000000000001844257310064121018312678894979w0 + 6.467w-33)) + ;; Test for argument reduction with n odd + (assert-eq t (rel-or-abs-error + (tan (* 9/4 kernel:dd-pi)) + 1.000000000000000000000000000000025802415787810837455445433037983w0 + 5.773w-33)) + ;; Test for argument reduction, big value + (assert-eq t (rel-or-abs-error + (tan (scale-float 1w0 120)) + -4.080663888418042385451434945255951177650840227682488471558860153w-1 + 1.888w-33))) + commit 949acab5719c22e51a45a936271b46b04edaa8ac Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Dec 20 16:06:40 2013 -0800 For dd-%%sin, return x if x is small enough. (Makes sin(-0w0) be -0w0). diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp index 170bc06..6661f2b 100644 --- a/src/code/irrat-dd.lisp +++ b/src/code/irrat-dd.lisp @@ -1000,8 +1000,11 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 (declare (type (double-double-float -1w0 1w0) x) (optimize (speed 2) (space 0) (inhibit-warnings 3))) - (let ((x2 (* x x))) - (+ x (* x (* x2 (poly-eval x2 sincof)))))) + (if (< (abs (double-double-hi x)) + (scale-float 1d0 -52)) + x + (let ((x2 (* x x))) + (+ x (* x (* x2 (poly-eval x2 sincof))))))) ;; cos(x) = 1 - .5 x^2 + x^2 (x^2 P(x^2)) ;; Theoretical peak relative error = 2.1e-37, commit 6f25e2e894bdf13c00a29651031ad0bbedb50f0e Merge: 408aa78 82d0a77 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Dec 20 12:39:48 2013 -0800 Merge branch 'master' into rtoy-simp-dd-trig commit 408aa78aa3947f2c8f8a5b2a03429d5c05e93fbe Merge: 00bd409 01a3f47 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Dec 20 07:44:09 2013 -0800 Merge branch 'master' into rtoy-simp-dd-trig commit 00bd409b8d9de4f5f6223bf4d017e6f1c0826e48 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 12 18:48:41 2013 -0800 Simplify dd-%%sin, dd-%%cos, and dd-%%tan. These routines did argument reduction, but since we use __kernel_rem_pio2 to do accurate argument reduction, the argument reduction in these routines is a waste of time. This greatly simplifies the routines to just the polynomial (or rational) approximations. diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp index 4c57165..170bc06 100644 --- a/src/code/irrat-dd.lisp +++ b/src/code/irrat-dd.lisp @@ -995,6 +995,14 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 -1.666666666666666666666666666666666647199w-1 ))) +;; Compute sin(x) for |x| < pi/4 (approx). +(defun dd-%%sin (x) + (declare (type (double-double-float -1w0 1w0) x) + (optimize (speed 2) (space 0) + (inhibit-warnings 3))) + (let ((x2 (* x x))) + (+ x (* x (* x2 (poly-eval x2 sincof)))))) + ;; cos(x) = 1 - .5 x^2 + x^2 (x^2 P(x^2)) ;; Theoretical peak relative error = 2.1e-37, ;; relative peak error spread = 1.4e-8 @@ -1016,101 +1024,17 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 4.166666666666666666666666666666459301466w-2 ))) -(defconstant dp1 - (scale-float (float #b1100100100001111110110101010001000100001011010001100001000110100110001001100011001100010100010111000000011 1w0) -106)) - -(defconstant dp2 - (scale-float (float #b0111000001110011010001001010010000001001001110000010001000101001100111110011000111010000000010000010111011 1w0) (* 2 -106))) - -(defconstant dp3 - (scale-float (float #b1110101001100011101100010011100110110010001001010001010010100000100001111001100011100011010000000100110111 1w0) (* 3 -106))) - -(defconstant dp4 - (scale-float (float #b0111101111100101010001100110110011110011010011101001000011000110110011000000101011000010100110110111110010 1w0) (* 4 -106))) - -(defun dd-%%sin (x) - (declare (type double-double-float x) - (optimize (speed 2) (space 0) - (inhibit-warnings 3))) - (when (minusp x) - (return-from dd-%%sin (- (the double-double-float (dd-%%sin (- x)))))) - ;; y = integer part of x/(pi/4). - (let* ((y (float (floor (/ x dd-pi/4)) 1w0)) - (z (scale-float y -4))) - (declare (type double-double-float y z)) - (setf z (float (floor z) 1w0)) ; integer part of y/8 - (setf z (- y (scale-float z 4))) ; y - 16*(y/16) - - (let ((j (truncate z)) - (sign 1)) - (declare (type (integer -1 1) sign)) - (unless (zerop (logand j 1)) - (incf j) - (incf y)) - (setf j (logand j 7)) - - (when (> j 3) - (setf sign (- sign)) - (decf j 4)) - - ;; Extended precision modular arithmetic - (setf z (- (- (- x (* y dp1)) - (* y dp2)) - (* y dp3))) - (let ((zz (* z z))) - (if (or (= j 1) - (= j 2)) - (setf y (+ (- 1 (scale-float zz -1)) - (* zz zz (poly-eval zz coscof)))) - (setf y (+ z (* z (* zz (poly-eval zz sincof)))))) - (if (< sign 0) - (- y) - y))))) - +;; Compue cos(x) for |x| < pi/4 (approx) (defun dd-%%cos (x) - (declare (type double-double-float x) + (declare (type (double-double-float -1w0 1w0) x) (optimize (speed 2) (space 0) (inhibit-warnings 3))) - (when (minusp x) - (return-from dd-%%cos (dd-%%cos (- x)))) - ;; y = integer part of x/(pi/4). - (let* ((y (float (floor (/ x dd-pi/4)) 1w0)) - (z (scale-float y -4))) - (declare (type double-double-float y z)) - (setf z (float (floor z) 1w0)) ; integer part of y/8 - (setf z (- y (scale-float z 4))) ; y - 16*(y/16) - - (let ((i (truncate z)) - (j 0) - (sign 1)) - (declare (type (integer 0 7) j) - (type (integer -1 1) sign)) - (unless (zerop (logand i 1)) - (incf i) - (incf y)) - (setf j (logand i 7)) - - (when (> j 3) - (setf sign (- sign)) - (decf j 4)) - (when (> j 1) - (setf sign (- sign))) - - ;; Extended precision modular arithmetic. This is basically - ;; computing x - y*(pi/4) accurately so that |z| < pi/4. - (setf z (- (- (- x (* y dp1)) - (* y dp2)) - (* y dp3))) - (let ((zz (* z z))) - (if (or (= j 1) - (= j 2)) - (setf y (+ z (* z (* zz (poly-eval zz sincof))))) - (setf y (+ (- 1 (scale-float zz -1)) - (* zz (poly-eval zz coscof) zz)))) - (if (< sign 0) - (- y) - y))))) + (let ((x2 (* x x))) + (+ (- 1 (scale-float x2 -1)) + (* x2 (poly-eval x2 coscof) x2)))) +;; Compute tan(x) or cot(x) for |x| < pi/4 (approx). If cotflag is +;; non-nil, cot(x) is returned. Otherwise, return tan(x). (let ((P (make-array 6 :element-type 'double-double-float :initial-contents '( @@ -1132,50 +1056,18 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 -4.152206921457208101480801635640958361612w10 8.650244186622719093893836740197250197602w10 )))) - (defun dd-tancot (xx cotflag) - (declare (type double-double-float xx) - (optimize (speed 2) (space 0))) - (let ((x 0w0) - (sign 1)) - (declare (type double-double-float x) - (type (integer -1 1) sign)) - (cond ((minusp xx) - (setf x (- xx)) - (setf sign -1)) - (t - (setf x xx))) - (let* ((y (float (floor (/ x dd-pi/4)) 1w0)) - (z (scale-float y -4)) - (j 0)) - (declare (type double-double-float y z) - (type fixnum j)) - (setf z (float (floor z) 1w0)) - (setf z (- y (scale-float z 4))) - - (setf j (truncate z)) - - (unless (zerop (logand j 1)) - (incf j) - (incf y)) - - (setf z (- (- (- x (* y dp1)) - (* y dp2)) - (* y dp3))) - (let ((zz (* z z))) - (if (> zz 1w-40) - (setf y (+ z - (* z (* zz (/ (poly-eval zz p) - (poly-eval-1 zz q)))))) - (setf y z)) - (if (not (zerop (logand j 2))) - (if cotflag - (setf y (- y)) - (setf y (/ -1 y))) - (if cotflag - (setf y (/ y)))) - (if (< sign 0) - (- y) - y)))))) + (defun dd-tancot (x cotflag) + (declare (type (double-double-float -1w0 1w0) x) + (optimize (speed 2) (space 0) (inhibit-warnings 3))) + (let* ((xx (* x x)) + (y (if (> xx 1w-40) + (+ x + (* x (* xx (/ (poly-eval xx p) + (poly-eval-1 xx q))))) + x))) + (if cotflag + (/ y) + y)))) (defun dd-%%tan (x) (declare (type double-double-float x)) @@ -1254,9 +1146,7 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 dd-%sin)) (defun dd-%sin (x) (declare (double-double-float x)) - (cond ((minusp (float-sign x)) - (- (dd-%sin (- x)))) - ((< (abs x) (/ pi 4)) + (cond ((< (abs x) (/ pi 4)) (dd-%%sin x)) (t ;; Argument reduction needed @@ -1272,9 +1162,7 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 dd-%cos)) (defun dd-%cos (x) (declare (double-double-float x)) - (cond ((minusp x) - (dd-%cos (- x))) - ((< (abs x) (/ pi 4)) + (cond ((< (abs x) (/ pi 4)) (dd-%%cos x)) (t ;; Argument reduction needed @@ -1290,9 +1178,7 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 dd-%tan)) (defun dd-%tan (x) (declare (double-double-float x)) - (cond ((minusp (float-sign x)) - (- (dd-%tan (- x)))) - ((< (abs x) (/ pi 4)) + (cond ((< (abs x) (/ pi 4)) (dd-%%tan x)) (t ;; Argument reduction needed ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-11-11-gd669c12
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via d669c129619ad3952fcabb263e307e3d48b12969 (commit) from 06300c812a5dfeecc9afd43d45608356f7c80dd6 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit d669c129619ad3952fcabb263e307e3d48b12969 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Dec 8 09:26:24 2013 -0800 Update for ppc/darwin 10.5 and gcc 4.8. o Remove -no-cpp-precomp, which isn't recognized by gcc 4.8. o Add -static-libgcc so lisp doesn't need to have a compatible version of libgcc on the target system. o e_rem_pio2.c doesn't have aliasing issues, so remove the compiler flags. diff --git a/src/lisp/Config.ppc_darwin b/src/lisp/Config.ppc_darwin index e999827..0902b89 100644 --- a/src/lisp/Config.ppc_darwin +++ b/src/lisp/Config.ppc_darwin @@ -11,12 +11,12 @@ CPPFLAGS = -I. -I$(PATH1) # think gcc 4 is wrong. However, to work around this, we use /**/ to # concatenate tokens which reguires the -traditional flag. -# Build for OSX 10.2.8 or later. (Is this what we want?) +# Build for OSX 10.4 or later. (Is this what we want?) OSX_VERSION=-mmacosx-version-min=10.4 CC = gcc LD = ld NM = $(PATH1)/darwin-nm -CPP = cpp -no-cpp-precomp +CPP = cpp DEPEND_FLAGS = -MM ifdef FEATURE_LINKAGE_TABLE @@ -34,8 +34,8 @@ ifdef FEATURE_UNICODE UNICODE = -DUNICODE endif -CFLAGS = $(OSX_VERSION) -g -O3 -no-cpp-precomp -DDARWIN -Dppc $(LINKAGE) $(GENCGC) $(UNICODE) -ASFLAGS = $(OSX_VERSION) -traditional -g -O3 -no-cpp-precomp -DDARWIN -Dppc $(LINKAGE) $(GENCGC) +CFLAGS = $(OSX_VERSION) -g -O3 -DDARWIN -Dppc $(LINKAGE) $(GENCGC) $(UNICODE) +ASFLAGS = $(OSX_VERSION) -traditional -g -O3 -DDARWIN -Dppc $(LINKAGE) $(GENCGC) UNDEFSYMPATTERN = -Xlinker -u -Xlinker & ASSEM_SRC = ppc-assem.S linux-stubs.S @@ -52,10 +52,15 @@ endif # that the segaddr for CMUCLRO should be the READ_ONLY_SPACE_START. # The seg1addr should be somewhere above our spaces. This is where # the C runtime code goes, I think. - +# # OS_LINK_FLAGS = -g -dynamic -Wl,-sectcreate,CMUCLRO,core,/dev/null -Wl,-segaddr,CMUCLRO,0x01000000 -Wl,-seg1addr,0x1a000000 -OS_LINK_FLAGS = $(OSX_VERSION) + +# gcc 4.8, (used on zombie) needs -static-libgcc so that the gcc +# library is staticly linked into lisp so that the user doesn't need a +# matching version of libgcc. +OS_LINK_FLAGS = $(OSX_VERSION) -static-libgcc OS_LIBS = -lSystem -lc -lm + #all: adjustlisp #adjustlisp: lisp darwin-lispadjuster # ./darwin-lispadjuster lisp @@ -64,6 +69,7 @@ OS_LIBS = -lSystem -lc -lm #darwin-lispadjuster: darwin-lispadjuster.c -# This has aliasing problems, so turn off aliasing. +# According to Config.x86_common, this no longer has aliasing +# problems, so we don't need any additional compilation options. e_rem_pio2.o : e_rem_pio2.c - $(CC) -c -fno-strict-aliasing -ffloat-store $(CFLAGS) $< + $(CC) -c $(CFLAGS) $< ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.ppc_darwin | 22 ++++++++++++++-------- 1 file changed, 14 insertions(+), 8 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch rtoy-lisp-trig updated. snapshot-2013-12-a-6-g7069ef9
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, rtoy-lisp-trig has been updated via 7069ef9dfa3770d7b3e00aac297ae7dcb22b8c20 (commit) from 7190b61cf97c8320d6a218c430471c0fb0bf518e (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 7069ef9dfa3770d7b3e00aac297ae7dcb22b8c20 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Dec 14 21:38:18 2013 -0800 Small cleanups. * Remove unneeded package specifier for %ieee754-rem-pi/2 * Add some comments for %tan. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index c23321d..6a025a1 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -543,7 +543,7 @@ (t ;; Argument reduction needed (multiple-value-bind (n y0 y1) - (kernel::%ieee754-rem-pi/2 x) + (%ieee754-rem-pi/2 x) (case (logand n 3) (0 (kernel-sin y0 y1 1)) @@ -568,7 +568,7 @@ (t ;; Argument reduction needed (multiple-value-bind (n y0 y1) - (kernel::%ieee754-rem-pi/2 x) + (%ieee754-rem-pi/2 x) (ecase (logand n 3) (0 (kernel-cos y0 y1)) @@ -584,16 +584,19 @@ (optimize (speed 3))) (let ((ix (logand #x7fffffff (kernel:double-float-high-bits x)))) (cond ((<= ix #x3fe921fb) + ;; |x| < pi/4 (kernel-tan x 0d0 1)) ((>= ix #x7ff00000) + ;; tan(Inf or Nan) is NaN (- x x)) (t (multiple-value-bind (n y0 y1) - (kernel::%ieee754-rem-pi/2 x) + (%ieee754-rem-pi/2 x) (let ((flag (- 1 (ash (logand n 1) 1)))) ;; flag = 1 if n even, -1 if n odd (kernel-tan y0 y1 flag))))))) +;; Compute sin and cos of x, simultaneously. (defun %sincos (x) (declare (double-float x) (optimize (speed 3))) @@ -617,7 +620,6 @@ (3 (values (- (kernel-cos y0 y1)) (kernel-sin y0 y1 1)))))))) - (declaim (ext:end-block)) ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-30-g5f031f1
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 5f031f16b552b5798732191e4e5d0a04607373bf (commit) from 06179e0c45b51011eae88bfc711d7bec00769c89 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5f031f16b552b5798732191e4e5d0a04607373bf Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 31 15:57:55 2014 -0700 Update to 3.1.3. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index cce093d..750a886 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- -;;; This is ASDF 3.1.2: Another System Definition Facility. +;;; This is ASDF 3.1.3: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -402,7 +402,7 @@ or when loading the package is optional." (imported) (t (push name intern))))))) (labels ((sort-names (names) - (sort names #'string<)) + (sort (copy-list names) #'string<)) (table-keys (table) (loop :for k :being :the :hash-keys :of table :collect k)) (when-relevant (key value) @@ -845,8 +845,8 @@ UNINTERN -- Remove symbols here from PACKAGE." (uiop/package:define-package :uiop/common-lisp (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) - (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package) - (:reexport :common-lisp) + (:use :uiop/package) + (:use-reexport #-genera :common-lisp #+genera :future-common-lisp) (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) @@ -855,7 +855,7 @@ UNINTERN -- Remove symbols here from PACKAGE." #:logical-pathname #:translate-logical-pathname #:make-broadcast-stream #:file-namestring) #+genera (:shadowing-import-from :scl #:boolean) - #+genera (:export #:boolean #:ensure-directories-exist) + #+genera (:export #:boolean #:ensure-directories-exist #:read-sequence #:write-sequence) #+mcl (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) @@ -935,9 +935,20 @@ UNINTERN -- Remove symbols here from PACKAGE." #+genera (eval-when (:load-toplevel :compile-toplevel :execute) + (unless (fboundp 'lambda) + (defmacro lambda (&whole form &rest bvl-decls-and-body) + (declare (ignore bvl-decls-and-body)(zwei::indentation 1 1)) + `#',(cons 'lisp::lambda (cdr form)))) (unless (fboundp 'ensure-directories-exist) (defun ensure-directories-exist (path) - (fs:create-directories-recursively (pathname path))))) + (fs:create-directories-recursively (pathname path)))) + (unless (fboundp 'read-sequence) + (defun read-sequence (sequence stream &key (start 0) end) + (scl:send stream :string-in nil sequence start end))) + (unless (fboundp 'write-sequence) + (defun write-sequence (sequence stream &key (start 0) end) + (scl:send stream :string-out sequence start end) + sequence))) #.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl, so we use this trick (read-from-string @@ -1213,7 +1224,7 @@ Returns two values: $A B C$ and $1 2 3$." ;;; Characters (with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. - (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + (defconstant +non-base-chars-exist-p+ #.(not (subtypep 'character 'base-char))) #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow??? (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) @@ -1390,7 +1401,7 @@ and EVAL that in a (FUNCTION ...) context." (etypecase fun (function fun) ((or boolean keyword character number pathname) (constantly fun)) - (hash-table (lambda (x) (gethash x fun))) + (hash-table #'(lambda (x) (gethash x fun))) (symbol (fdefinition fun)) (cons (if (eq 'lambda (car fun)) (eval fun) @@ -1750,10 +1761,13 @@ then returning the non-empty string value of the variable" (defun operating-system () "The operating system of the current host" (first-feature - '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! + '(:cygwin + (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd - (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix + (:solaris :solaris :sunos) + (:bsd :bsd :freebsd :netbsd :openbsd :dragonfly) + :unix :genera))) (defun architecture () @@ -2552,7 +2566,7 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." (let ((sub (when maybe-subpath (pathname maybe-subpath))) - (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) + (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) (or (and base (subpathp sub base)) sub))) (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) @@ -3297,13 +3311,14 @@ in an atomic way if the implementation allows." directory-pathname (unix:get-unix-error-msg errno)))) #+cormanlisp (win32:delete-directory directory-pathname) #+ecl (si:rmdir directory-pathname) + #+genera (fs:delete-directory directory-pathname) #+lispworks (lw:delete-directory directory-pathname) #+mkcl (mkcl:rmdir directory-pathname) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) @@ -3337,7 +3352,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (error "~S was asked to delete ~S but the directory does not exist" 'delete-filesystem-tree directory-pathname)) (:ignore nil))) - #-(or allegro cmu clozure sbcl scl) + #-(or allegro cmu clozure genera sbcl scl) ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, ;; except on implementations where we can prevent DIRECTORY from following symlinks; ;; instead spawn a standard external program to do the dirty work. @@ -3347,7 +3362,7 @@ If you're suicidal or extremely confident, just use :VALIDATE T." #+allegro (symbol-call :excl.osi :delete-directory-and-files directory-pathname :if-does-not-exist if-does-not-exist) #+clozure (ccl:delete-directory directory-pathname) - #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type)) + #+genera (fs:delete-directory directory-pathname :confirm nil) #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) @@ -3995,7 +4010,9 @@ Upon success, the KEEP form is evaluated and the file is is deleted unless it ev (beforef (gensym "BEFORE")) (afterf (gensym "AFTER"))) `(flet (,@(when before - `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before))) + `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) + ,@(when after `((declare (ignorable ,pathname)))) + ,@before))) ,@(when after (assert pathnamep) `((,afterf (,pathname) ,@after)))) @@ -4120,7 +4137,7 @@ This is designed to abstract away the implementation specific quit forms." #+(or cmu scl) (unix:unix-exit code) #+ecl (si:quit code) #+gcl (system:quit code) - #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) + #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) @@ -4144,8 +4161,8 @@ This is designed to abstract away the implementation specific quit forms." (declare (ignorable stream count condition)) #+abcl (loop :for i :from 0 - :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do - (safe-format! stream "~&~D: ~A~%" i frame)) + :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do + (safe-format! stream "~&~D: ~A~%" i frame)) #+allegro (let ((*terminal-io* stream) (*standard-output* stream) @@ -4169,20 +4186,20 @@ This is designed to abstract away the implementation specific quit forms." (debug:backtrace (or count most-positive-fixnum) stream)) #+(or ecl mkcl) (let* ((top (si:ihs-top)) - (repeats (if count (min top count) top)) - (backtrace (loop :for ihs :from 0 :below top + (repeats (if count (min top count) top)) + (backtrace (loop :for ihs :from 0 :below top :collect (list (si::ihs-fun ihs) (si::ihs-env ihs))))) (loop :for i :from 0 :below repeats - :for frame :in (nreverse backtrace) :do - (safe-format! stream "~&~D: ~S~%" i frame))) + :for frame :in (nreverse backtrace) :do + (safe-format! stream "~&~D: ~S~%" i frame))) #+gcl (let ((*debug-io* stream)) (ignore-errors (with-safe-io-syntax () - (if condition - (conditions::condition-backtrace condition) - (system::simple-backtrace))))) + (if condition + (conditions::condition-backtrace condition) + (system::simple-backtrace))))) #+lispworks (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) @@ -4196,8 +4213,8 @@ This is designed to abstract away the implementation specific quit forms." stream) #+xcl (loop :for i :from 0 :below (or count most-positive-fixnum) - :for frame :in (extensions:backtrace-as-list) :do - (safe-format! stream "~&~D: ~S~%" i frame))) + :for frame :in (extensions:backtrace-as-list) :do + (safe-format! stream "~&~D: ~S~%" i frame))) (defun print-backtrace (&rest keys &key stream count condition) "Print a backtrace" @@ -4297,14 +4314,14 @@ if we are not called from a directly executable image." ;; SBCL and Allegro already separate user arguments from implementation arguments. #-(or sbcl allegro) (unless (eq *image-dumped-p* :executable) - ;; LispWorks command-line processing isn't transparent to the user - ;; unless you create a standalone executable; in that case, - ;; we rely on cl-launch or some other script to set the arguments for us. - #+lispworks (return *command-line-arguments*) - ;; On other implementations, on non-standalone executables, - ;; we trust cl-launch or whichever script starts the program - ;; to use -- as a delimiter between implementation arguments and user arguments. - #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) + ;; LispWorks command-line processing isn't transparent to the user + ;; unless you create a standalone executable; in that case, + ;; we rely on cl-launch or some other script to set the arguments for us. + #+lispworks (return *command-line-arguments*) + ;; On other implementations, on non-standalone executables, + ;; we trust cl-launch or whichever script starts the program + ;; to use -- as a delimiter between implementation arguments and user arguments. + #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) (rest arguments))) (defun argv0 () @@ -4339,7 +4356,7 @@ immediately to the surrounding restore process if allowed to continue. Then, comes the restore process itself: First, call each function in the RESTORE-HOOK, -in the order they were registered with REGISTER-RESTORE-HOOK. +in the order they were registered with REGISTER-IMAGE-RESTORE-HOOK. Second, evaluate the prelude, which is often Lisp text that is read, as per EVAL-INPUT. Third, call the ENTRY-POINT function, if any is specified, with no argument. @@ -4384,7 +4401,7 @@ of the function will be returned rather than interpreted as a boolean designatin (dump-hook *image-dump-hook*) #+clozure prepend-symbols #+clozure (purify t) #+sbcl compression - #+(and sbcl windows) application-type) + #+(and sbcl os-windows) application-type) "Dump an image of the current Lisp environment at pathname FILENAME, with various options. First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of @@ -4458,7 +4475,7 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." (when compression (list :compression compression)) ;;--- only save runtime-options for standalone executables (when executable (list :toplevel #'restore-image :save-runtime-options t)) - #+(and sbcl windows) ;; passing :application-type :gui will disable the console window. + #+(and sbcl os-windows) ;; passing :application-type :gui will disable the console window. ;; the default is :console - only works with SBCL 1.1.15 or later. (when application-type (list :application-type application-type))))) #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) @@ -5295,7 +5312,7 @@ It returns a process-info plist with possible keys: #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) (%wait-process-result (apply '%run-program (%normalize-system-command command) :wait t keys)) - #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl) + #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) #+(and lispworks os-windows) (system:call-system %command :current-directory directory :wait t) @@ -5312,6 +5329,8 @@ It returns a process-info plist with possible keys: (*error-output* *stderr*)) (ext:system %command)) #+gcl (system:system %command) + #+genera (error "~S not supported on Genera, cannot run ~S" + '%system %command) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) #+mkcl (mkcl:system %command) #+xcl (system:%run-shell-command %command)))) @@ -6342,7 +6361,7 @@ this function tries to locate the Windows FOLDER for one of "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will be applied to the results to yield a configuration form. Current values of TAG include :source-registry and :output-translations." - (let ((files (sort (ignore-errors + (let ((files (sort (ignore-errors ;; SORT w/o COPY-LIST is OK: DIRECTORY returns a fresh list (remove-if 'hidden-pathname-p (directory* (make-pathname :name *wild* :type "conf" :defaults directory)))) @@ -6568,7 +6587,8 @@ directive.") :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) -#+mkcl (provide :uiop) +;; Provide both lowercase and uppercase, to satisfy more people. +(provide "uiop") (provide "UIOP") ;;;; ------------------------------------------------------------------------- ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 @@ -6638,7 +6658,7 @@ previously-loaded version of ASDF." ;; "3.4.5.67" would be a development version in the official branch, on top of 3.4.5. ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 - (asdf-version "3.1.2") + (asdf-version "3.1.3") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -6650,26 +6670,26 @@ previously-loaded version of ASDF." (when-upgrading () (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. - ;; NB: it's too late to do anything about functions in UIOP! - ;; If you introduce some critically incompatibility there, you must change name. + ;; NB: it's too late to do anything about functions in UIOP! + ;; If you introduce some critically incompatibility there, you must change name. '(#:component-relative-pathname #:component-parent-pathname ;; component #:source-file-type #:find-system #:system-source-file #:system-relative-pathname ;; system - #:find-component ;; find-component - #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action - #:component-depends-on #:operation-done-p #:component-depends-on - #:traverse ;; backward-interface + #:find-component ;; find-component + #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action + #:component-depends-on #:operation-done-p #:component-depends-on + #:traverse ;; backward-interface #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan - #:operate ;; operate - #:parse-component-form ;; defsystem - #:apply-output-translations ;; output-translations - #:process-output-translations-directive - #:inherit-source-registry #:process-source-registry ;; source-registry - #:process-source-registry-directive - #:trivial-system-p)) ;; bundle - (redefined-classes + #:operate ;; operate + #:parse-component-form ;; defsystem + #:apply-output-translations ;; output-translations + #:process-output-translations-directive + #:inherit-source-registry #:process-source-registry ;; source-registry + #:process-source-registry-directive + #:trivial-system-p)) ;; bundle + (redefined-classes ;; redefining the classes causes interim circularities - ;; with the old ASDF during upgrade, and many implementations bork + ;; with the old ASDF during upgrade, and many implementations bork '((#:compile-concatenated-source-op (#:operation) ())))) (loop :for name :in redefined-functions :for sym = (find-symbol* name :asdf nil) :do @@ -6677,12 +6697,12 @@ previously-loaded version of ASDF." ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh. #-clisp (fmakunbound sym))) (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf)) - (find-symbol* s p nil))) - (asyms (l) (mapcar #'asym l))) + (find-symbol* s p nil))) + (asyms (l) (mapcar #'asym l))) (loop* :for (name superclasses slots) :in redefined-classes - :for sym = (find-symbol* name :asdf nil) - :when (and sym (find-class sym)) - :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) + :for sym = (find-symbol* name :asdf nil) + :when (and sym (find-class sym)) + :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) ;;; Self-upgrade functions @@ -7143,8 +7163,9 @@ in which the system specification (.asd file) is located." (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache - #:do-asdf-cache #:normalize-namestring - #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) + #:do-asdf-cache #:normalize-namestring + #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache* + #:clear-configuration-and-retry #:retry)) (in-package :asdf/cache) ;;; This stamp cache is useful for: @@ -7180,8 +7201,17 @@ in which the system specification (.asd file) is located." (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) (if (and *asdf-cache* (not override)) (funcall fun) - (let ((*asdf-cache* (make-hash-table :test 'equal))) - (funcall fun))))) + (loop + (restart-case + (let ((*asdf-cache* (make-hash-table :test 'equal))) + (return (funcall fun))) + (retry () + :report (lambda (s) + (format s (compatfmt "~@<Retry ASDF operation.~@:>")))) + (clear-configuration-and-retry () + :report (lambda (s) + (format s (compatfmt "~@<Retry ASDF operation after resetting the configuration.~@:>"))) + (clear-configuration))))))) (defmacro with-asdf-cache ((&key key override) &body body) `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) @@ -7308,8 +7338,8 @@ of which is a system object.") (defun clear-defined-systems () ;; Invalidate all systems but ASDF itself, if registered. (loop :for name :being :the :hash-keys :of *defined-systems* - :unless (equal name "asdf") - :do (clear-defined-system name))) + :unless (equal name "asdf") + :do (clear-defined-system name))) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) @@ -7562,82 +7592,73 @@ but not loaded in memory" Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME FOUNDP is true when a system was found, either a new unregistered one or a previously registered one. -FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is -PATHNAME when not null is a path from where to load the system, +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed. +PATHNAME when not null is a path from which to load the system, either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." - (with-asdf-cache (:key `(locate-system ,name)) - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (cond - (previous (setf found nil pathname nil)) - (t - (setf found (sysdef-preloaded-system-search "asdf")) - (assert (typep found 'system)) - (setf found-system found pathname nil)))) - (values foundp found-system pathname previous previous-time)))) + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (setf found (sysdef-preloaded-system-search "asdf")) + (assert (typep found 'system)) + (setf found-system found pathname nil)))) + (values foundp found-system pathname previous previous-time))) (defmethod find-system ((name string) &optional (error-p t)) (with-asdf-cache (:key `(find-system ,name)) (let ((primary-name (primary-system-name name))) (unless (equal name primary-name) (find-system primary-name nil))) - (loop - (restart-case - (multiple-value-bind (foundp found-system pathname previous previous-time) - (locate-system name) - (when (and found-system (eq found-system previous) - (or (first (gethash `(find-system ,name) *asdf-cache*)) - (and *immutable-systems* (gethash name *immutable-systems*)))) - (return found-system)) - (assert (eq foundp (and (or found-system pathname previous) t))) - (let ((previous-pathname (and previous (system-source-file previous))) - (system (or previous found-system))) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and system pathname) - (setf (system-source-file system) pathname)) - (when (and pathname - (let ((stamp (get-file-stamp pathname))) - (and stamp - (not (and previous - (or (pathname-equal pathname previous-pathname) - (and pathname previous-pathname - (pathname-equal - (physicalize-pathname pathname) - (physicalize-pathname previous-pathname)))) - (stamp<= stamp previous-time)))))) - ;; only load when it's a pathname that is different or has newer content, and not an old asdf - (load-asd pathname :name name))) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed - (return - (cond - (in-memory - (when pathname - (setf (car in-memory) (get-file-stamp pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name)))))) - (reinitialize-source-registry-and-retry () - :report (lambda (s) - (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) - (unset-asdf-cache-entry `(locate-system ,name)) - (initialize-source-registry))))))) - + (or (and *immutable-systems* (gethash name *immutable-systems*) + (cdr (system-registered-p name))) + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (assert (eq foundp (and (or found-system pathname previous) t))) + (let ((previous-pathname (and previous (system-source-file previous))) + (system (or previous found-system))) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and system pathname) + (setf (system-source-file system) pathname)) + (when (and pathname + (let ((stamp (get-file-stamp pathname))) + (and stamp + (not (and previous + (or (pathname-equal pathname previous-pathname) + (and pathname previous-pathname + (pathname-equal + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) + (stamp<= stamp previous-time)))))) + ;; only load when it's a pathname that is different or has newer content, and not an old asdf + (load-asd pathname :name name))) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (cond + (in-memory + (when pathname + (setf (car in-memory) (get-file-stamp pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)) + (t ;; not found: don't keep negative cache, see lp#1335323 + (unset-asdf-cache-entry `(locate-system ,name)) + (return-from find-system nil))))))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -7747,10 +7768,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (and (typep c 'missing-dependency) (eq (missing-required-by c) component) (equal (missing-requires c) name)))) - (unless (component-parent component) - (let ((name (coerce-name name))) - (unset-asdf-cache-entry `(find-system ,name)) - (unset-asdf-cache-entry `(locate-system ,name)))))))) + (unless (component-parent component) + (let ((name (coerce-name name))) + (unset-asdf-cache-entry `(find-system ,name)) + (unset-asdf-cache-entry `(locate-system ,name)))))))) (defun resolve-dependency-spec (component dep-spec) @@ -9048,7 +9069,8 @@ The default operation may change in the future if we implement a component-directed strategy for how to load or compile systems.") (defmethod component-depends-on ((o prepare-op) (s system)) - `((,*load-system-operation* ,@(component-sideway-dependencies s)))) + (loop :for (o . cs) :in (call-next-method) + :collect (cons (if (eq o 'load-op) *load-system-operation* o) cs))) (defclass build-op (non-propagating-operation) () (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, @@ -9059,7 +9081,8 @@ as a symbol or as a string later read as a symbol (after loading the defsystem-d if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION* that will load the system in the current image, and its typically LOAD-OP.")) (defmethod component-depends-on ((o build-op) (c component)) - `((,(or (component-build-operation c) *load-system-operation*) ,c))) + `((,(or (component-build-operation c) *load-system-operation*) ,c) + ,@(call-next-method))) (defun make (system &rest keys) "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). @@ -9163,8 +9186,8 @@ the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (defun restart-upgraded-asdf () ;; If we're in the middle of something, restart it. (when *asdf-cache* - (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache* - :when (eq x 'find-system) :collect y))) + (let ((l (loop :for k :being :the hash-keys :of *asdf-cache* + :when (eq (first k) 'find-system) :collect (second k)))) (clrhash *asdf-cache*) (dolist (s l) (find-system s nil))))) (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) @@ -10683,7 +10706,7 @@ To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~ Please report to ASDF-DEVEL if this works for you."))) -;;; Backward compatibility with pre-3.1.1 names +;;; Backward compatibility with pre-3.1.2 names (defclass fasl-op (selfward-operation) ((selfward-operation :initform 'compile-bundle-op :allocation :class))) (defclass load-fasl-op (selfward-operation) @@ -10976,7 +10999,7 @@ Please use UIOP:RUN-PROGRAM instead." (in-package :asdf/package-inferred-system) (with-upgradability () - (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package)) + (defparameter *defpackage-forms* '(defpackage define-package)) (defun initial-package-inferred-systems-table () (let ((h (make-hash-table :test 'equal))) @@ -11222,11 +11245,13 @@ otherwise return a default system name computed from PACKAGE-NAME." #:package-inferred-system-missing-package-error #:operation-definition-warning #:operation-definition-error - #:try-recompiling + #:try-recompiling ; restarts #:retry - #:accept ; restarts + #:accept #:coerce-entry-to-directory #:remove-entry-from-registry + #:clear-configuration-and-retry + #:*encoding-detection-hook* #:*encoding-external-format-hook* @@ -11262,14 +11287,15 @@ otherwise return a default system name computed from PACKAGE-NAME." #:user-source-registry #:system-source-registry #:user-source-registry-directory - #:system-source-registry-directory)) + #:system-source-registry-directory + )) ;;;; --------------------------------------------------------------------------- ;;;; ASDF-USER, where the action happens. (uiop/package:define-package :asdf/user (:nicknames :asdf-user) - ;; NB: releases before 3.1.1 this :use'd only uiop/package instead of uiop below. + ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below. ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop. ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo. ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 324 ++++++++++++++++++++++++-------------------- 1 file changed, 175 insertions(+), 149 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2014-02 created. snapshot-2014-02
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2014-02 has been created at 4f494840e0d6c784941f252f77f041ed864da0ce (tag) tagging c96b5d32cec8300cccfcbcfc25211621a145f527 (commit) replaces snapshot-2014-01 tagged by Raymond Toy on Mon Feb 3 17:40:45 2014 -0800 - Log ----------------------------------------------------------------- Snapshot 2014-02 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlLwRScACgkQJ5IjUmgZO7ILmwCdGStocYPOWFLgNsvATjOvexD4 lSAAn3KVtsgyKWevH4l+OfHXAHjuOQx5 =jqBT -----END PGP SIGNATURE----- Raymond Toy (12): Use truename of *load-pathname*. Use the correct syntax to match Power Mac for uname -m. In trac.65, make comparison test an assertion test to show failures In the summary, print out all test failures and errors. Fix complex multiply vop. Update. Copy src/pcl/simple-streams/rt/simple-streams-tests.lisp to Convert to using lisp-unit. Disable the two inet tests since the echo Remove the zero checking of the heap. Allow stack-tn's to be accessed in the float arith vops. Simplify the macros that generate the basic float operations. Update from commit logs. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-42-g894af6c
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 894af6c4aaa3b83f3c13d2e59735c33f79abdc20 (commit) via 15d3bbe341280c08855d07dc6664c0fd17b27636 (commit) via e5bfd82b999468624a09dad92189843f08eac5b2 (commit) from f849f4dba02f2b41d78ffe21d43be5b184aa7cdf (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 894af6c4aaa3b83f3c13d2e59735c33f79abdc20 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Dec 23 10:40:03 2013 -0800 Add tests for the branch cut for atanh. Not clear that this is correct because atanh(-2) appears to be wrong. diff --git a/tests/trig.lisp b/tests/trig.lisp index 9565ef5..05437e5 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -725,3 +725,66 @@ (get-signs (acosh-def #c(0.25d0 -1d-20))) (assert-true (check-signs #'acosh #c(0.25d0 -0d0) tr ti)) (assert-true (check-signs #'acosh #c(0.25w0 -0w0) tr ti)))) + +;; atanh(z) = 1/2*(log(1+z) - log(1-z)) +;; +;; The branch cut is on the real axis for |x| > 1. For x < -1, it is +;; continuous with Quadrant III. For x > 1, it is continuous with +;; quadrant I. +;; +;; NOTE: The rules above are what is given by the CLHS. However, +;; consider the value of atanh(-2) and atanh(-2-0.0*i) +;; +;; atanh(-2) = 1/2*(log(1-2) - log(1+2)) +;; = 1/2*(log(-1) - log(3)) +;; = 1/2*(i*pi - log(3)) +;; = -1/2*log(3) + i*pi/2 +;; +;; atanh(-2-0*i) = 1/2*(log(1+(-2-0*i)) - log(1-(-2-0*i))) +;; = 1/2*(log(-1-0*i) - log(3-0*i)) +;; = 1/2*(-i*pi - log(3)) +;; = -1/2*log(3) - i*pi/2 +;; +;; atanh(-2+0*i) = 1/2*(log(1+(-2+0*i)) - log(1-(-2+0*i))) +;; = 1/2*(log(-1+0*i) - log(3-0*i)) +;; = 1/2*(i*pi - log(3)) +;; = -1/2*log(3) + i*pi/2 +;; +;; Thus, atanh(-2) is continuous with Quadrant II, NOT continuous with +;; Quadrant III! +;; +;; What do we do? +(defun atanh-def (z) + (r*z 1/2 + (- (log (1+z z)) + (log (1-z z))))) + +(define-test branch-cut.atanh + (:tag :atanh :branch-cuts) + ;; Test for x < -1, which is continuous with Quadrant III. Use the + ;; the value at #c(-2d0 -1d-20) as the reference. + (multiple-value-bind (tr ti) + (get-signs (atanh-def #c(-2d0 -1d-20))) + (assert-true (check-signs #'atanh -2d0 tr ti)) + (assert-true (check-signs #'atanh -2w0 tr ti)) + (assert-true (check-signs #'atanh #c(-2d0 -0d0) tr ti)) + (assert-true (check-signs #'atanh #c(-2w0 -0w0) tr ti))) + ;; Test the other side of the branch cut for x < -1. + (multiple-value-bind (tr ti) + (get-signs (atanh-def #c(-2d0 +1d-20))) + (assert-true (check-signs #'atanh #c(-2d0 0d0) tr ti)) + (assert-true (check-signs #'atanh #c(-2w0 0w0) tr ti))) + + ;; Test for x > 1, which is continuous with Quadrant I, using the + ;; value at #c(+2d0 1d-10) as the reference + (multiple-value-bind (tr ti) + (get-signs (atanh-def #c(2d0 1d-20))) + (assert-true (check-signs #'atanh 2d0 tr ti)) + (assert-true (check-signs #'atanh 2w0 tr ti)) + (assert-true (check-signs #'atanh #c(2d0 0) tr ti)) + (assert-true (check-signs #'atanh #c(2w0 0) tr ti))) + ;; Test the other side of the branch cut for x > 1. + (multiple-value-bind (tr ti) + (get-signs (atanh-def #c(2d0 -1d-20))) + (assert-true (check-signs #'atanh #c(2d0 -0d0) tr ti)) + (assert-true (check-signs #'atanh #c(2w0 -0w0) tr ti)))) commit 15d3bbe341280c08855d07dc6664c0fd17b27636 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Dec 23 08:36:22 2013 -0800 Add tests for the branch cuts for asinh and acosh, and some fixes. o Add function R-Z to compute r - z carefully. (For definition of acos) o Add function R*Z to compute r*z carefully, For acos and acosh. o Add tests for asinh and acosh. diff --git a/tests/trig.lisp b/tests/trig.lisp index 011aeaf..9565ef5 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -468,6 +468,13 @@ (complex (- 1 (realpart z)) (- (imagpart z))) (- 1 z))) +(defun z-1 (z) + (if (complexp z) + (complex (- (realpart z) 1) + (imagpart z)) + (- z 1))) + + ;; Carefully compute 1+z. For z = x + i*y, we want 1+x + i*y, which ;; only really matters when y is a signed zero. (defun 1+z (z) @@ -475,12 +482,24 @@ (complex (+ 1 (realpart z)) (imagpart z)) (+ 1 z))) +(defun r-z (r z) + (if (complexp z) + (complex (- r (realpart z)) + (- (imagpart z))) + (- r z))) + ;; Carefully compute i*z = i*(x+i*y) = -y + i*x. (defun i*z (z) (if (complexp z) (complex (- (imagpart z)) (realpart z)) (complex 0 z))) +;; Carefully compute r*z, where r is a real value and z is complex. +(defun r*z (r z) + (if (complexp z) + (complex (* r (realpart z)) (* r (imagpart z))) + (* r z))) + ;; asin(x) = -i*log(i*x + sqrt(1-x^2)) ;; ;; The branch cut is the real axis |x| > 1. For x < -1, it is @@ -529,10 +548,10 @@ ;; continous with Quadrant II; for x > 1, Quadrant IV. (defun acos-def (z) (if (typep z 'kernel:double-double-float) - (- (/ kernel:dd-pi 2) - (asin-def z)) - (- (/ pi 2) - (asin-def z)))) + (r-z (/ kernel:dd-pi 2) + (asin-def z)) + (r-z (/ pi 2) + (asin-def z)))) (define-test branch-cut.acos (:tag :acos :branch-cuts) @@ -601,7 +620,7 @@ (let* ((iz (i*z z)) (w (- (log (1+z iz)) (log (1-z iz))))) - (* -1/2 (i*z w)))) + (r*z -1/2 (i*z w)))) (define-test branch-cut.atan (:tag :atan :branch-cuts) @@ -628,3 +647,81 @@ (get-signs (atan-def #c(1d-20 2d0))) (assert-true (check-signs #'atan #c(0d0 2d0) tr ti)) (assert-true (check-signs #'atan #c(0d0 2w0) tr ti)))) + +;; asinh(z) = log(z + sqrt(1+z^2)) +;; +;; The branch cut is the imaginary axis with |y| > 1. For y > 1, asinh +;; is continuous with Quadrant I. For y < -1, it is continuous with +;; Quadrant III. + +(defun asinh-def (z) + (log (+ z (sqrt (1+z (* z z)))))) + +(define-test branch-cut.asinh + (:tag :asinh :branch-cuts) + ;; Test for y < -1, which is continuous with Quadrant I. Use the + ;; value at #c(1d-20 -2d0) as the reference. + (multiple-value-bind (tr ti) + (get-signs (asinh-def #c(1d-20 -2d0))) + (assert-true (check-signs #'asinh #c(0d0 -2d0) tr ti)) + (assert-true (check-signs #'asinh #c(0w0 -2w0) tr ti))) + ;; Test the other side of the branch cut for y < -1. + (multiple-value-bind (tr ti) + (get-signs (asinh-def #c(-1d-20 -2d0))) + (assert-true (check-signs #'asinh #c(-0d0 -2d0) tr ti)) + (assert-true (check-signs #'asinh #c(-0w0 -2w0) tr ti))) + + ;; Test for y > 1, which is continuous with Quadrant III, using the + ;; value at #c(-1d-20 +2d0) as the reference + (multiple-value-bind (tr ti) + (get-signs (asinh-def #c(-1d-20 2d0))) + (assert-true (check-signs #'asinh #c(-0d0 2d0) tr ti)) + (assert-true (check-signs #'asinh #c(-0w0 2w0) tr ti))) + ;; Test the other side of the branch cut for x > 1. + (multiple-value-bind (tr ti) + (get-signs (asinh-def #c(1d-20 2d0))) + (assert-true (check-signs #'asinh #c(0d0 2d0) tr ti)) + (assert-true (check-signs #'asinh #c(0d0 2w0) tr ti)))) + +;; acosh(z) = 2*log(sqrt((z+1)/2) + sqrt((z-1)/2)) +;; +;; The branch cut is along the real axis with x < 1. For x < 0, it is +;; continuous with Quadrant II. For 0< x < 1, it is continuous with +;; Quadrant I. + +(defun acosh-def (z) + (r*z 2 + (log (+ (sqrt (r*z 1/2 (1+z z))) + (sqrt (r*z 1/2 (z-1 z))))))) + + +(define-test branch-cut.acosh + (:tag :acosh :branch-cuts) + ;; Test for x < 0, which is continuous with Quadrant II. Use the + ;; value at #c(-2d0 1d-20) as a reference. + (multiple-value-bind (tr ti) + (get-signs (acosh-def #c(-2d0 1d-20))) + (assert-true (check-signs #'acosh -2d0 tr ti)) + ;;(assert-true (check-signs #'acosh -2w0 tr ti)) + (assert-true (check-signs #'acosh #c(-2d0 0) tr ti)) + ;;(assert-true (check-signs #'acosh #c(-2w0 0) tr ti)) + ) + ;; Test the other side of the branch cut for x < -1. + (multiple-value-bind (tr ti) + (get-signs (acosh-def #c(-2d0 -1d-20))) + (assert-true (check-signs #'acosh #c(-2d0 -0d0) tr ti)) + ;;(assert-true (check-signs #'acosh #c(-2w0 -0w0) tr ti)) + ) + + ;; Test for 0 < x < 1, which is continuous with Quadrant I, using the + ;; value at #c(0.25d0 1d-10) as the reference. + (multiple-value-bind (tr ti) + (get-signs (acosh-def #c(0.25d0 1d-20))) + (assert-true (check-signs #'acosh #c(0.25d0 0) tr ti)) + (assert-true (check-signs #'acosh #c(0.25w0 0) tr ti)) + ) + ;; Test the other side of the branch cut for 0 < x < 1. + (multiple-value-bind (tr ti) + (get-signs (acosh-def #c(0.25d0 -1d-20))) + (assert-true (check-signs #'acosh #c(0.25d0 -0d0) tr ti)) + (assert-true (check-signs #'acosh #c(0.25w0 -0w0) tr ti)))) commit e5bfd82b999468624a09dad92189843f08eac5b2 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Dec 23 00:16:43 2013 -0800 Float printer tests from reading the logs for print.lisp. diff --git a/tests/printer.lisp b/tests/printer.lisp new file mode 100644 index 0000000..b511f0b --- /dev/null +++ b/tests/printer.lisp @@ -0,0 +1,113 @@ +(defpackage :printer-tests + (:use :cl :lisp-unit)) + +(in-package "PRINTER-TESTS") + +(define-test format.float.1 + (assert-equal ".0000" + (format nil "~5F" 1d-10)) + (assert-equal "0.000" + (format nil "~,3F" 0.000001))) + +(define-test format.float.2 + (assert-equal " 0.990E+00" (format nil "~11,3,2,0,'*,,'EE" .99)) + (assert-equal " 0.999E+00" (format nil "~11,3,2,0,'*,,'EE" .999)) + (assert-equal " 0.100E+01" (format nil "~11,3,2,0,'*,,'EE" .9999)) + (assert-equal " 0.999E-04" (format nil "~11,3,2,0,'*,,'EE" .0000999)) + (assert-equal " 0.100E-03" (format nil "~11,3,2,0,'*,,'EE" .00009999)) + (assert-equal " 9.999E-05" (format nil "~11,3,2,,'*,,'EE" .00009999)) + (assert-equal " 1.000E-04" (format nil "~11,3,2,,'*,,'EE" .000099999))) + +(define-test format.float.3 + (assert-equal ".00123d+6" (format nil "~9,,,-2E" 1.2345689d3)) + (assert-equal "-.0012d+6" (format nil "~9,,,-2E" -1.2345689d3)) + (assert-equal ".00123d+0" (format nil "~9,,,-2E" 1.2345689d-3)) + (assert-equal "-.0012d+0" (format nil "~9,,,-2E" -1.2345689d-3))) + +(define-test format.float.4 + (assert-equal "0.314e-01" (format nil "~9,3,2,0,'%G" 0.0314159)) + (assert-equal "+.003e+03" (format nil "~9,3,2,-2,'%@e" 3.14159)) + (assert-equal " 31.42" (format nil "~6,2,1,'*F" 3.14159)) + (assert-equal " 3141590." (format nil "~9,0,6f" 3.14159)) + + (assert-equal ".00000003d+8" (format nil "~9,4,,-7E" pi)) + (assert-equal ".000003d+6" (format nil "~9,4,,-5E" pi)) + (assert-equal "3141600.d-6" (format nil "~5,4,,7E" pi)) + (assert-equal " 314.16d-2" (format nil "~11,4,,3E" pi)) + (assert-equal " 31416.d-4" (format nil "~11,4,,5E" pi)) + (assert-equal " 0.3142d+1" (format nil "~11,4,,0E" pi)) + (assert-equal ".03142d+2" (format nil "~9,,,-1E" pi)) + (assert-equal "0.003141592653589793d+3" (format nil "~,,,-2E" pi)) + (assert-equal "31.41592653589793d-1" (format nil "~,,,2E" pi)) + (assert-equal "3.141592653589793d+0" (format nil "~E" pi)) + (assert-equal ".03142d+2" (format nil "~9,5,,-1E" pi)) + (assert-equal " 0.03142d+2" (format nil "~11,5,,-1E" pi)) + (assert-equal "3.141592653589793 " (format nil "~G" pi)) + (assert-equal "3.1416 " (format nil "~9,5G" pi)) + (assert-equal "| 3141593.d-06|" (format nil "|~13,6,2,7E|" pi)) + (assert-equal "0.314d+01" (format nil "~9,3,2,0,'%E" pi)) + (assert-equal " 3141593." (format nil "~9,0,6f" pi)) + (assert-equal " 31.42" (format nil "~6,2,1,'*F" pi)) + (assert-equal "******" (format nil "~6,2,1,'*F" (* 100 pi))) + (assert-equal "+.003d+03" (format nil "~9,3,2,-2,'%@E" pi)) + (assert-equal "+0.003d+03" (format nil "~10,3,2,-2,'%@E" pi)) + (assert-equal "=====+0.003d+03" (format nil "~15,3,2,-2,'%,'=@E" pi)) + (assert-equal "0.003d+03" (format nil "~9,3,2,-2,'%E" pi)) + (assert-equal "%%%%%%%%" (format nil "~8,3,2,-2,'%@E" pi)) + + (assert-equal "1. " (format nil "~g" 1e0)) + + (assert-equal "0.0e+0" (format nil "~e" 0)) + (assert-equal "0.0d+0" (format nil "~e" 0d0)) + (assert-equal "0.0d+0000" (format nil "~9,,4e" 0d0)) + (assert-equal "1.2345678901234567d+4" (format nil "~E" 1.234567890123456789d4)) + + (assert-equal "1.32922799578492d+36" (format nil "~20E" (expt 2d0 120))) + (assert-equal " 1.32922800d+36" (format nil "~21,8E" (expt 2d0 120))) + + (assert-equal ".0012345679" (format nil "~11f" 1.23456789123456789d-3))) + +(define-test format.float.5 + ;; From CLHS 22.3.11 + (flet ((test-f (x) + (format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" + x x x x x x))) + (assert-equal " 3.14| 31.42| 3.14|3.1416|3.14|3.14159" (test-f 3.14159)) + (assert-equal " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" (test-f -3.14159)) + (assert-equal "100.00|******|100.00| 100.0|100.00|100.0" (test-f 100.0)) + (assert-equal "1234.00|******|??????|1234.0|1234.00|1234.0" (test-f 1234.0)) + (assert-equal " 0.01| 0.06| 0.01| 0.006|0.01|0.006" (test-f 0.006)))) + +(define-test format.float.6 + (flet ((test-e (x) + (format nil + "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~ + ~9,3,2,-2,'%@E|~9,2E" + x x x x))) + + (assert-equal " 3.14e+0| 31.42$-01|+.003e+03| 3.14e+0" (test-e 3.14159)) + (assert-equal " -3.14e+0|-31.42$-01|-.003e+03| -3.14e+0" (test-e -3.14159)) + (assert-equal " 1.10e+3| 11.00$+02|+.001e+06| 1.10e+3" (test-e 1100.0)) + (assert-equal " 1.10d+3| 11.00$+02|+.001d+06| 1.10d+3" (test-e 1100.0d0)) + (assert-equal "*********| 11.00$+12|+.001e+16| 1.10e+13" (test-e 1.1e13)) + (assert-equal "*********|??????????|%%%%%%%%%|1.10d+120" (test-e 1.1d120)))) + +(define-test format.float.7 + (flet ((test-scale (k) + (format nil "~&Scale factor ~2D: |~13,6,2,VE|" + (- k 5) (- k 5) 3.14159))) + + (assert-equal "Scale factor -5: | 0.000003e+06|" (test-scale 0)) + (assert-equal "Scale factor -4: | 0.000031e+05|" (test-scale 1)) + (assert-equal "Scale factor -3: | 0.000314e+04|" (test-scale 2)) + (assert-equal "Scale factor -2: | 0.003142e+03|" (test-scale 3)) + (assert-equal "Scale factor -1: | 0.031416e+02|" (test-scale 4)) + (assert-equal "Scale factor 0: | 0.314159e+01|" (test-scale 5)) + (assert-equal "Scale factor 1: | 3.141590e+00|" (test-scale 6)) + (assert-equal "Scale factor 2: | 31.41590e-01|" (test-scale 7)) + (assert-equal "Scale factor 3: | 314.1590e-02|" (test-scale 8)) + (assert-equal "Scale factor 4: | 3141.590e-03|" (test-scale 9)) + (assert-equal "Scale factor 5: | 31415.90e-04|" (test-scale 10)) + (assert-equal "Scale factor 6: | 314159.0e-05|" (test-scale 11)) + (assert-equal "Scale factor 7: | 3141590.e-06|" (test-scale 12)))) + ----------------------------------------------------------------------- Summary of changes: tests/printer.lisp | 113 ++++++++++++++++++++++++++++++++++ tests/trig.lisp | 170 ++++++++++++++++++++++++++++++++++++++++++++++++++-- 2 files changed, 278 insertions(+), 5 deletions(-) create mode 100644 tests/printer.lisp hooks/post-receive -- CMU Common Lisp

1 0