Commit 38e9384b authored by Iban Hatchondo's avatar Iban Hatchondo
Browse files

some type declaration added.

parent 84fe6cc5
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: global.lisp,v 1.20 2004/02/12 23:30:22 ihatchondo Exp $
;;; $Id: global.lisp,v 1.21 2004/03/04 14:51:48 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2001, 2002 Iban HATCHONDO
......@@ -165,7 +165,7 @@
#+gcl (lisp:bye code)
#+lispworks (lw:quit :status code)
#+lucid (lcl:quit code)
#+sbcl (sb-ext:quit :unix-code (typecase code (number code) (null 0) (t 1)))
#+sbcl (sb-ext:quit :unix-status (typecase code (number code) (null 0) (t 1)))
#-(or allegro clisp cmu cormanlisp gcl lispworks lucid sbcl)
(error 'not-implemented :proc (list 'quit code))
)
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: input.lisp,v 1.35 2004/02/25 10:59:36 ihatchondo Exp $
;;; $Id: input.lisp,v 1.36 2004/03/08 23:40:33 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -22,6 +22,9 @@
;;; Event processing.
(deftype client-message-data ()
`(simple-array (or xlib:card8 xlib:card16 xlib:card32) (*)))
;; Most generals methods.
(defmethod event-process (event widget)
......@@ -123,15 +126,16 @@
(setf (netwm:net-active-window (widget-window root)) :none))))
(defmethod event-process ((event client-message) (root root))
(with-slots (type data event-window) event
(case type
(let ((data (event-data event)))
(declare (type client-message-data data))
(case (event-type event)
((or :_WIN_WORKSPACE :_NET_CURRENT_DESKTOP)
(change-vscreen root :n (aref data 0)))
(:_NET_NUMBER_OF_DESKTOPS
(setf (number-of-virtual-screens) (aref data 0)))
(:WM_PROTOCOLS
(when (eq :wm_delete_window (id->atom-name (aref data 0)))
(close-widget (lookup-widget event-window)))))))
(close-widget (lookup-widget (event-event-window event))))))))
(defmethod event-process ((event keyboard-event) (root root))
(with-slots (code state) event
......@@ -288,9 +292,10 @@
(:wm_transient_for (computes-transient-for app)))))
(defmethod event-process ((event client-message) (application application))
(with-slots (data type) event
(let ((data (event-data event)))
(declare (type client-message-data data))
(with-slots (master window iconic-p icon) application
(case type
(case (event-type event)
(:WM_CHANGE_STATE (when (= 3 (aref data 0)) (iconify application)))
(:_WIN_STATE
(let* ((to-change (aref data 0))
......@@ -357,7 +362,9 @@
:width (when (logbitp 2 value-mask) (aref data 3))
:height (when (logbitp 3 value-mask) (aref data 4))
:gravity (unless (zerop gravity)
(svref xlib::*win-gravity-vector* gravity)))))
(svref '#(:unmap :north-west :north :north-east :west
:center :east :south-west :south :south-east
:static) gravity)))))
(:_NET_WM_DESKTOP (migrate-application application (aref data 0)))
(:_NET_CLOSE_WINDOW (close-widget application))))))
......
;;; -*- Mode: Lisp; Package: Clx-Extensions -*-
;;; Copyright 1987, 1998 The Open Group
;;; $Id: cursordef.lisp,v 1.2 2003/12/03 14:32:38 ihatchondo Exp $
;;; $Id: cursordef.lisp,v 1.3 2004/03/08 23:37:15 ihatchondo Exp $
;;;
;;; Permission to use, copy, modify, distribute, and sell this software and its
;;; documentation for any purpose is hereby granted without fee, provided that
......@@ -26,7 +26,7 @@
(common-lisp:in-package :clx-extensions)
(declaim (type (simple-array keyword 78) +cursors+))
(declaim (type (simple-array keyword (78)) +cursors+))
(defconstant +cursors+
'#(:XC_X_CURSOR :XC_ARROW
......
;;; -*- Mode: Lisp; Package: PPM -*-
;;; $Id: image-reader.lisp,v 1.7 2004/03/03 04:03:40 ihatchondo Exp $
;;; $Id: image-reader.lisp,v 1.9 2004/03/04 15:37:50 ihatchondo Exp $
;;;
;;; This a ppm image reader for CLX
;;; This file is part of Eclipse
......@@ -62,6 +62,9 @@
;;;; x color utilities.
(deftype clx-array ()
'(simple-array (or bit card-4 card-8 card-16 card-24 card-32) (* *)))
(defvar *gray-table* (make-array 256 :element-type 'fixnum))
(defvar *red-table* (make-array 256 :element-type 'fixnum))
(defvar *green-table* (make-array 256 :element-type 'fixnum))
......@@ -121,16 +124,17 @@
(defmethod image-height ((image image))
(car (array-dimensions (image-pixels image))))
(defmethod image-pixel ((image image) x y)
(aref (the pixarray (image-pixels image)) y x))
(defmethod (setf image-pixel) (x y pixel image)
(setf (aref (the pixarray (image-pixels image)) y x) pixel))
;; Gray scale image
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass gray-scale-image (image)
((pixels :type pixarray-8)))
((pixels :type pixarray-8))))
(defmethod image-pixel ((image gray-scale-image) x y)
(aref (the pixarray-8 (image-pixels image)) y x))
(defmethod (setf image-pixel) (x y pixel (image gray-scale-image))
(setf (aref (the pixarray-8 (image-pixels image)) y x) pixel))
(defun gray->x-gray (pixel)
(declare (type card-8 pixel))
......@@ -138,8 +142,15 @@
;; Colored image
(eval-when (:compile-toplevel :load-toplevel :execute)
(defclass colored-24-image (image)
((pixels :type pixarray-24)))
((pixels :type pixarray-24))))
(defmethod image-pixel ((image colored-24-image) x y)
(aref (the pixarray-24 (image-pixels image)) y x))
(defmethod (setf image-pixel) (x y pixel (image colored-24-image))
(setf (aref (the pixarray-24 (image-pixels image)) y x) pixel))
(defmacro red-component (pixel)
`(the (unsigned-byte 8) (logand (ash ,pixel -16) 255)))
......@@ -164,10 +175,10 @@
(defmethod make-image-from-stream ((type (eql :P5)) stream width height mlevel)
(declare (type card-16 width height))
(declare (type card-8 mlevel))
(loop with size of-type fixnum = (* width height)
with pixels = (make-array `(,height ,width) :element-type 'card-8)
(loop with size of-type card-32 = (* width height)
with pixels = (make-array (list height width) :element-type 'card-8)
with vec = (make-array size :element-type 'card-8 :displaced-to pixels)
with offset of-type fixnum = 0
with offset of-type card-32 = 0
while (< offset size)
do (setf offset (read-sequence vec stream :start offset))
finally (return (make-p5-image pixels mlevel))))
......@@ -180,18 +191,18 @@
(defmethod make-image-from-stream ((type (eql :P6)) stream width height mlevel)
(declare (type card-16 width height))
(declare (type card-8 mlevel))
(loop with size of-type fixnum = (* width height)
with cache-size of-type fixnum = (the fixnum (min size 21000))
(loop with size of-type card-32 = (* width height)
with cache-size of-type card-32 = (the card-32 (min size 21000))
with aux = (make-array (* 3 cache-size) :element-type 'card-8)
for start of-type fixnum from 0 by cache-size below size
for start of-type card-32 from 0 by cache-size below size
for end of-type fixnum = (min (+ start cache-size) size)
with data = (make-array `(,height ,width) :element-type 'card-24)
with data = (make-array (list height width) :element-type 'card-24)
with vec = (make-array size :element-type 'card-24 :displaced-to data)
do (loop with offset = 0
while (< offset (* 3 (the fixnum (- end start))))
do (loop with offset of-type card-32 = 0
while (< offset (* 3 (the card-32 (- end start))))
do (setf offset (read-sequence aux stream :start offset)))
(loop for i of-type fixnum from start below end
for j of-type fixnum from 0 by 3
(loop for i of-type card-32 from start below end
for j of-type card-32 from 0 by 3
do (setf (aref vec i)
(the card-24
(+ (ash (the card-8 (aref aux j)) 16)
......@@ -239,17 +250,19 @@
"Returns a clx image representation of an image."
(loop with getter = (typecase image
(gray-scale-image #'gray->x-gray)
(colored-24-image #'color->x-color))
(colored-24-image #'color->x-color)
(t (error "unknow image type ~a" (type-of image))))
with depth of-type card-8 = (xlib:drawable-depth drawable)
with bits-per-pixel = (find-bits-per-pixel depth)
with w = (image-width image)
with h = (image-height image)
with type = `(unsigned-byte ,bits-per-pixel)
with res of-type pixarray = (make-array `(,h ,w) :element-type type)
with res of-type clx-array = (make-array (list h w) :element-type type)
for y of-type card-16 from 0 below h
do (loop for x of-type card-16 from 0 below w
for pixel = (image-pixel image x y)
do (setf (aref res y x) (funcall getter pixel)))
do (setf (aref res y x)
(funcall (the function getter) pixel)))
finally (return (xlib:create-image
:width w :height h :depth depth :data res
:bits-per-pixel bits-per-pixel))))
......
;;; -*- Mode: Lisp; Package: EXTENDED-WINDOW-MANAGER-HINTS -*-
;;; $Id: netwm-manager.lisp,v 1.14 2004/02/17 11:03:21 ihatchondo Exp $
;;; $Id: netwm-manager.lisp,v 1.15 2004/03/01 14:54:02 ihatchondo Exp $
;;;
;;; This is the CLX support for the managing with gnome.
;;;
......@@ -389,7 +389,7 @@
(defun net-wm-strut (window)
"return the strut property as a multiple value (left right top bottom)."
(let ((v (get-property window :_NET_WM_STRUT :result-type 'vector)))
(declare (type (or null (simple-array integer (4))) v))
(declare (type (or null (simple-array xlib:card32 (4))) v))
(when v (values (aref v 0) (aref v 1) (aref v 2) (aref v 3)))))
(defsetf net-wm-strut (window) (strut)
......@@ -406,7 +406,7 @@
left_start_y, left_end_y, right_start_y, right_end_y,
top_start_x, top_end_x, bottom_start_x, bottom_end_x"
(let ((v (get-property window :_NET_WM_STRUT_PARTIAL :result-type 'vector)))
(declare (type (or null (simple-array integer (12))) v))
(declare (type (or null (simple-array xlib:card32 (12))) v))
(when v
(values (aref v 0) (aref v 1) (aref v 2) (aref v 3)
(aref v 4) (aref v 5) (aref v 6) (aref v 7)
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: menu.lisp,v 1.5 2004/02/10 14:03:14 ihatchondo Exp $
;;; $Id: menu.lisp,v 1.6 2004/03/08 23:40:34 ihatchondo Exp $
;;;
;;; This file is part of Eclipse
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO, Robert STRANDH
......@@ -177,7 +177,7 @@
(when armed
(highlight item))))
(defmethod event-process ((event button-press) (item menu-item)))
(defmethod event-process ((event button-press) (item menu-leaf-item)))
(defmethod event-process ((event button-release) (item menu-leaf-item))
(with-slots (armed callback) item
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: misc.lisp,v 1.26 2004/03/04 15:37:49 ihatchondo Exp $
;;; $Id: misc.lisp,v 1.27 2004/03/04 20:15:16 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -216,6 +216,13 @@
:cursor (or cursor (root-default-cursor *root*))
:owner-p owner-p))
(defsetf window-priority (window &optional sibling) (priority)
"Set the window priority such as if done by (setf xlib:window-priority) and
guaranty that stacking order constraints described in the extended window
manager protocol will be respected. Then invokes update-client-list-stacking
to reflect the new order in all the root properties that are involved in."
`(set-window-priority ,priority ,window ,sibling))
(defun send-wm-protocols-client-message (window atom &rest data)
"Send a client-message of type :wm-protocol to the specified window
with data being the given atom plus the rest of the function args."
......@@ -297,13 +304,6 @@
else collect w into no-stack-state
finally (return (values belows no-stack-state aboves))))
(defsetf window-priority (window &optional sibling) (priority)
"Set the window priority such as if done by (setf xlib:window-priority) and
guaranty that stacking order constraints described in the extended window
manager protocol will be respected. Then invokes update-client-list-stacking
to reflect the new order in all the root properties that are involved in."
`(set-window-priority ,priority ,window ,sibling))
(defun update-workarea-property (root)
"computes and sets the _net_workarea property for the root-window."
(with-slots (window) root
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: move-resize.lisp,v 1.13 2004/01/29 00:50:59 ihatchondo Exp $
;;; $Id: move-resize.lisp,v 1.14 2004/02/12 23:30:22 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -174,6 +174,7 @@
(multiple-value-bind (x y width height) (window-geometry window)
(let ((corners '#(#.'#(:nw :north :nw :west) #.'#(:north :ne :east :ne)
#.'#(:se :east :se :south) #.'#(:west :sw :south :sw))))
(declare (type (simple-array (simple-array keyword (4)) (4)) corners))
(labels ((find (x y rx ry w h)
(if (<= x rx (+ x (floor w 2)))
(if (<= y ry (+ y (floor h 2))) 0 3)
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: themer.lisp,v 1.7 2004/01/21 17:48:35 ihatchondo Exp $
;;; $Id: themer.lisp,v 1.8 2004/03/01 14:53:57 ihatchondo Exp $
;;;
;;; This file is part of Eclipse.
;;; Copyright (C) 2002 Iban HATCHONDO
......@@ -22,6 +22,8 @@
(defparameter *themes* (make-hash-table :test #'equal))
(deftype pixmaps () `(simple-array (or null xlib:pixmap) (*)))
(declaim (inline lookup-theme))
(defun lookup-theme (name)
"return named theme or nil"
......@@ -174,22 +176,22 @@
(defmethod frame-item-exist-p ((style frame-style) frame-item-key)
(gethash frame-item-key (style-frame-item-pixmaps style)))
(defmethod frame-item-sizes ((style frame-style) frame-item-key)
(defmethod frame-item-sizes ((style frame-style) item-key)
"returns the sizes, as a multiple value, of the frame item according to
the sizes of the first pixmap in its associated pixmaps array."
(let ((pixmap (aref (frame-item-pixmaps style frame-item-key) 0)))
(let ((pixmap (aref (the pixmaps (frame-item-pixmaps style item-key)) 0)))
(if (xlib:pixmap-p pixmap) (drawable-sizes pixmap) (values 0 0))))
(defmethod frame-item-width ((style frame-style) frame-item-key)
(defmethod frame-item-width ((style frame-style) item-key)
"returns the width of the frame item according to the width of the
first pixmap in its associated pixmaps array."
(let ((pixmap (aref (frame-item-pixmaps style frame-item-key) 0)))
(let ((pixmap (aref (the pixmaps (frame-item-pixmaps style item-key)) 0)))
(if (xlib:pixmap-p pixmap) (xlib:drawable-width pixmap) 0)))
(defmethod frame-item-height ((style frame-style) frame-item-key)
(defmethod frame-item-height ((style frame-style) item-key)
"returns the height of the frame item according to the width of the
first pixmap in its associated pixmaps array."
(let ((pixmap (aref (frame-item-pixmaps style frame-item-key) 0)))
(let ((pixmap (aref (the pixmaps (frame-item-pixmaps style item-key)) 0)))
(if (xlib:pixmap-p pixmap) (xlib:drawable-height pixmap) 0)))
(defmethod frame-button-sizes ((style frame-style))
......@@ -197,6 +199,7 @@
(let ((bpixmaps (or (gethash :close frame-item-pixmaps)
(gethash :maximize frame-item-pixmaps)
(gethash :icon-b frame-item-pixmaps))))
(declare (type (or null pixmaps) bpixmaps))
(and bpixmaps (drawable-sizes (aref bpixmaps 0))))))
(defmethod free-frame-style ((style frame-style))
......@@ -268,6 +271,7 @@
default-style)))
(defun ensure-theme-directory-exists (theme-dir)
(declare (type simple-string theme-dir))
(unless (char= (char theme-dir (1- (length theme-dir))) #\/)
(setf theme-dir (format nil "~A/" theme-dir)))
(unless (directory theme-dir)
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: widgets.lisp,v 1.38 2004/03/08 23:40:34 ihatchondo Exp $
;;; $Id: widgets.lisp,v 1.39 2004/03/08 23:50:19 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -587,14 +587,16 @@
(draw-pixmap window gcontext pixmap)))))
(defun push-button-pixmap (pbutton pixmap-index)
(with-slots (frame-style) (button-master pbutton)
(aref (frame-item-pixmaps frame-style (widget->frame-item-key pbutton))
(case pixmap-index
(:focused-click 3)
(:unfocused-click 2)
(:focused-unclick 1)
((and (numberp pixmap-index) (<= 0 pixmap-index 3)) pixmap-index)
(t 0)))))
(with-slots ((astyle frame-style)) (button-master pbutton)
(let ((pixs (frame-item-pixmaps astyle (widget->frame-item-key pbutton))))
(declare (type pixmaps pixs))
(aref pixs
(case pixmap-index
(:focused-click 3)
(:unfocused-click 2)
(:focused-unclick 1)
((and (numberp pixmap-index) (<= 0 pixmap-index 3)) pixmap-index)
(t 0))))))
;;;; Standard decoration buttons
......
;;; -*- Mode: Lisp; Package: ECLIPSE-INTERNALS -*-
;;; $Id: wm.lisp,v 1.40 2004/03/01 14:53:57 ihatchondo Exp $
;;; $Id: wm.lisp,v 1.41 2004/03/02 19:16:48 ihatchondo Exp $
;;;
;;; ECLIPSE. The Common Lisp Window Manager.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
......@@ -58,11 +58,12 @@
(defmethod decoration-wm-hints ((master decoration))
"return as a multiple value: minw minh maxw maxh incw inch basew baseh."
(with-slots (frame-style (wmsh wm-size-hints)) master
(declare (type (vector integer 8) wmsh))
(with-slots ((hm hmargin) (vm vmargin)) frame-style
(values (+ hm (aref wmsh 0)) (+ vm (aref wmsh 1))
(+ hm (aref wmsh 2)) (+ vm (aref wmsh 3))
(aref wmsh 4) (aref wmsh 5)
(+ hm (aref wmsh 6)) (+ vm (aref wmsh 7))))))
(values (+ hm (svref wmsh 0)) (+ vm (svref wmsh 1))
(+ hm (svref wmsh 2)) (+ vm (svref wmsh 3))
(svref wmsh 4) (svref wmsh 5)
(+ hm (svref wmsh 6)) (+ vm (svref wmsh 7))))))
(defmethod focus-widget ((master decoration) timestamp)
(with-slots (window input-model) (get-child master :application)
......@@ -204,6 +205,7 @@
(when (frame-item-exist-p frame-style :menu-button)
(let ((pixmaps (frame-item-pixmaps frame-style :menu-button))
(horizontal-p (title-bar-horizontal-p master)))
(declare (type pixmaps pixmaps))
(multiple-value-bind (width height) (drawable-sizes (aref pixmaps 0))
(multiple-value-bind (tw th) (drawable-sizes parent-window)
(setf (getf children :menu-button)
......@@ -217,22 +219,22 @@
:x (if horizontal-p 0 (ash (- tw width) -1))))))))))
(defun make-buttons-bar (master parent-window)
(with-slots (children frame-style) master
(with-slots (children (astyle frame-style)) master
(flet ((make-container (horizontal-p)
(xlib:create-window
:parent parent-window
:x 0 :y 0 :width 1 :height 1
:background :parent-relative
:gravity (if horizontal-p :north-east :north-west))))
(loop initially (when (zerop (style-nb-buttons frame-style)) (return))
(loop initially (when (zerop (style-nb-buttons astyle)) (return))
with horizontal-p = (title-bar-horizontal-p master)
with container = (make-container horizontal-p)
and (x y width height) = '(0 0 0 0)
for type in '(iconify-button maximize-button close-button)
for child in '(:icon-b :maximize :close)
for pixmaps = (frame-item-pixmaps frame-style child)
for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
for bkgrd = (aref pixmaps 0)
when (frame-item-exist-p frame-style child)
when (frame-item-exist-p astyle child)
do (multiple-value-setq (width height) (drawable-sizes bkgrd))
(setf (getf children child)
(create-button type
......@@ -263,6 +265,7 @@
(menu-button (make-menu-button master parent-window))
(pixmaps (frame-item-pixmaps frame-style title-pos))
(bcw 0) (bch 0) (mbw 0) (mbh 0) (title))
(declare (type pixmaps pixmaps))
(when button-container
(multiple-value-setq (bcw bch) (drawable-sizes button-container)))
(when menu-button
......@@ -302,16 +305,16 @@
'(:right :left :top :bottom :top-left :top-right :bottom-left :bottom-right))
(defun make-frame-parts (master)
(with-slots (children window frame-style) master
(with-slots (children window (astyle frame-style)) master
(multiple-value-bind (width height) (drawable-sizes window)
(loop for child in *frame-parts*
for pixmaps = (frame-item-pixmaps frame-style child)
for pixmaps of-type pixmaps = (frame-item-pixmaps astyle child)
for hilighted = (aref pixmaps 1)
for event-mask = (if hilighted +std-button-mask+ +edge-event-mask+)
when (frame-item-exist-p frame-style child) do
when (frame-item-exist-p astyle child) do
(multiple-value-bind (x y)
(edge-position frame-style child width height)
(multiple-value-bind (w h) (frame-item-sizes frame-style child)
(edge-position astyle child width height)
(multiple-value-bind (w h) (frame-item-sizes astyle child)
(setf (getf children child)
(create-button (intern (symbol-name child) :eclipse)
:parent window :master master
......@@ -616,6 +619,7 @@
integer that will be the index of the desktop entry. It may return a lambda
or sub menu entries. If :realize is nil (the default value) it returns the
menu entries otherwise a pop-up-menu object is return."
(declare (type function callback-maker))
(loop with root-window = (widget-window root)
with names = (workspace-names root-window)
for i from 0 below (number-of-virtual-screens root-window)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment