Commit 9c44d11f authored by cer's avatar cer
Browse files

fixes

parent 2d4873d9
# $fiHeader: Makefile,v 1.44 92/08/21 16:34:13 cer Exp Locker: cer $
# $fiHeader: Makefile,v 1.45 92/09/08 10:35:20 cer Exp Locker: cer $
#
# Makefile for CLIM 2.0
#
CL = /usr/tech/cer/cl/src/dcl
#CL = /usr/tech/cer/cl/src/dcl
CL = /net/vapor/scm2/4.2.beta/src/dcl-stable
PWD = /usr/tech/cer/stuff/clim-2.0
DUMP-CL = $(CL)
CLOPTS = -qq
......@@ -73,6 +74,7 @@ OPENWINHOME=/usr/openwin-3.0
DEBUGLIB=
MOTIFLIB=/x11/R4/sun4-lib/libXm$(DEBUGLIB).a
MOTIFLIB_d=/x11/R4/sun4-lib/libXm_d.a
XLIB= /x11/R4/sun4-lib/libX11$(DEBUGLIB).a
XTLIB=/x11/R4/sun4-lib/libXt$(DEBUGLIB).a
XLIBS= $(XTLIB) $(XLIB)
......@@ -80,6 +82,7 @@ XLIBS= $(XTLIB) $(XLIB)
OLCOPYLIB=/usr/tech/cer/stuff/clim-2.0/tk/lib2
OLXLIBS=$(OLCOPYLIB)/libXt.a $(OLCOPYLIB)/libX11.a
LIBXOL=$(OLCOPYLIB)/libXol.a
LIBXOL_d=$(OLCOPYLIB)/libXol.a
# This has to be kept consistent with xlib.lisp
UNDEFS=misc/undefinedsymbols
......@@ -94,11 +97,14 @@ XM_UNDEFS=misc/undefinedsymbols.motif
OL_UNDEFS=misc/undefinedsymbols.olit
CLIMFASLS= climg.fasl climol.fasl climxm.fasl clim-debug.fasl climps.fasl
CLIMOBJS= clim-motif.o clim-olit.o stub-xt.o stub-x.o xlibsupport.o MyDrawingA.o \
CLIMOBJS= clim-motif_d.o clim-olit_d.o clim-motif.o clim-olit.o stub-xt.o stub-x.o \
xlibsupport.o MyDrawingA.o \
olsupport.o xtsupport.o
# These are linked into the distribution
FCLIMOBJS= `pwd`/clim-motif.o `pwd`/clim-olit.o `pwd`/stub-xt.o `pwd`/stub-x.o \
FCLIMOBJS= `pwd`/clim-motif_d.o `pwd`/clim-olit_d.o \
`pwd`/clim-motif.o `pwd`/clim-olit.o \
`pwd`/stub-xt.o `pwd`/stub-x.o \
`pwd`/xlibsupport.o `pwd`/MyDrawingA.o `pwd`/olsupport.o `pwd`/xtsupport.o
# These are built into xm-dcl and ol-dcl.
......@@ -223,6 +229,7 @@ CLIM-STANDALONE-OBJS = clim/gestures.fasl \
clim/basic-translators.fasl \
clim/frames.fasl \
clim/default-frame.fasl \
clim/activities.fasl \
clim/noting-progress.fasl \
clim/menus.fasl \
clim/accept-values.fasl \
......@@ -487,6 +494,9 @@ compile-xm: $(CLIMOBJS) FORCE
(setf excl:*record-xref-info* $(RECORD_XREF_INFO)) \
(setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \
(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \
(setq sys::*libxt-pathname* \"$(XTLIB)\") \
(setq sys::*libx11-pathname* \"$(XLIB)\") \
(setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
(load \"misc/compile-xm.lisp\")" | $(CL) $(CLOPTS) -batch
echo CLIM-XM compiled!!!!
......@@ -496,6 +506,9 @@ compile-ol: $(CLIMOBJS) FORCE
(setf excl:*record-source-file-info* $(RECORD_SOURCE_FILE_INFO)) \
(setf excl:*record-xref-info* $(RECORD_XREF_INFO)) \
(setf excl:*load-xref-info* $(LOAD_XREF_INFO)) \
(setq sys::*libxt-pathname* \"$(XTLIB)\") \
(setq sys::*libx11-pathname* \"$(XLIB)\") \
(setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
(setq *ignore-package-name-case* t) \
(set-case-mode :case-insensitive-lower) \
(proclaim '(optimize (speed $(SPEED)) (safety $(SAFETY)) (debug $(DEBUG)))) \
......@@ -549,9 +562,12 @@ tk/xm-defs.fasl : tk/xm-defs.lisp
# Building
clim-xm: FORCE
clim-xm: FORCE $(CLIMOBJS)
# -$(RM) $(CLIM)
$(ECHO) " \
(setq sys::*libxt-pathname* \"$(XTLIB)\") \
(setq sys::*libx11-pathname* \"$(XLIB)\") \
(setq sys::*clim-motif-pathname* \"clim-motif$(DEBUGLIB).o\") \
(load \"misc/dev-load-xm.lisp\") \
(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
......@@ -563,6 +579,9 @@ clim-xm: FORCE
clim-ol: FORCE
# -$(RM) $(CLIM)
$(ECHO) " \
(setq sys::*libxt-pathname* \"$(XTLIB)\") \
(setq sys::*libx11-pathname* \"$(XLIB)\") \
(setq sys::*clim-olit-pathname* \"clim-olit$(DEBUGLIB).o\") \
(load \"misc/dev-load-ol.lisp\") \
(load \"misc/dump.lisp\")" | $(DUMP-CL) $(CLOPTS) -batch
$(MV) $(TMP)/clim.temp_`whoami` $(CLIM)
......@@ -585,15 +604,26 @@ clim-small: FORCE
train : FORCE
$(TRAIN_TEXT)
BENCHMARK_FILE=nil
benchmark:
$(ECHO) "\
(load \"tk-silica/test-clim.lisp\") \
(clim-user::benchmark-clim $(BENCHMARK_FILE)) \
" | $(CLIM) $(CLOPTS) -batch
echo-train:
-$(ECHO) "$(TRAIN_LISP)"
# Misc
cleanobjs:
rm -f $(CLIMOBJS) stub-motif.o stub-olit.o
clean:
find $(DIRS) -name "*.fasl" -print | xargs rm -f ; rm -f $(CLIMFASLS) \
$(CLIMOBJS) slim slim-small
l $(CLIMOBJS) slim slim-small
cheapclean:
......@@ -663,6 +693,13 @@ clim-motif.o : stub-motif.o
clim-olit.o : stub-olit.o
ld -r -o clim-olit.o stub-olit.o $(LIBXOL)
clim-motif_d.o : stub-motif.o
ld -r -o clim-motif_d.o stub-motif.o $(MOTIFLIB_d)
clim-olit_d.o : stub-olit.o
ld -r -o clim-olit_d.o stub-olit.o $(LIBXOL_d)
stub-motif.c : $(XT_UNDEFS) $(XM_UNDEFS) misc/make-stub-file
misc/make-stub-file "void ___lisp_load_motif_stub ()" $(XT_UNDEFS) $(XM_UNDEFS) > stub-motif.c
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: accept-values.lisp,v 1.32 92/09/08 10:34:36 cer Exp Locker: cer $
;; $fiHeader: accept-values.lisp,v 1.33 92/09/08 15:17:23 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -1198,7 +1198,11 @@
:documentation documentation
:resynchronize resynchronize)))
(make-pane 'push-button
:label prompt
:label (if (stringp prompt)
stream
;;--- Perhaps we should create a pixmap
(with-output-to-string (stream)
(funcall prompt stream)))
:id record :client client
:activate-callback
#'(lambda (button)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: db-stream.lisp,v 1.28 92/09/08 10:34:41 cer Exp Locker: cer $
;; $fiHeader: db-stream.lisp,v 1.29 92/09/08 15:17:39 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -321,10 +321,10 @@
,pane)))
(when label
(setq pane `(vertically ()
,pane
(make-pane 'label-pane
(make-pane 'label-pane
:label ,label
:max-width +fill+))))
:max-width +fill+)
,pane)))
`(let (,stream)
(values
(outlining (:thickness 1)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: frames.lisp,v 1.39 92/09/08 10:34:45 cer Exp Locker: cer $
;; $fiHeader: frames.lisp,v 1.40 92/09/08 15:17:44 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -54,7 +54,9 @@
:reader frame-resizable)
(layout :initarg :layouts :reader frame-layouts)
(top-level-process :initform nil)
(command-queue :initform (make-locking-queue) :reader frame-command-queue))
(command-queue :initform (make-locking-queue) :reader
frame-command-queue)
(input-buffer :initform nil :initarg :input-buffer :reader frame-input-buffer))
(:default-initargs :pointer-documentation nil
:layouts nil
:resize-frame nil
......@@ -625,6 +627,8 @@
(destructuring-bind (&key left top width height &allow-other-keys)
(frame-geometry frame)
(ecase (frame-state frame)
(:shrunk
(note-frame-deiconified (frame-manager frame) frame))
(:enabled)
((:disabled :disowned)
(let ((old (frame-state frame)))
......@@ -647,6 +651,9 @@
(move-sheet (frame-top-level-sheet frame) left top))
(note-frame-enabled (frame-manager frame) frame)))))))
(defmethod iconify-frame ((frame standard-application-frame))
(note-frame-iconified (frame-manager frame) frame))
(defmethod destroy-frame ((frame standard-application-frame))
(when (eq (frame-state frame) :enabled)
(disable-frame frame))
......@@ -1035,14 +1042,17 @@
(synchronous-command-event-command condition)))))
) ;eval-when
(defvar *reading-frame-command* nil)
(defmethod read-frame-command :around ((frame standard-application-frame) &key)
(let* ((command (queue-pop (frame-command-queue frame))))
(or command
(handler-bind ((synchronous-command-event
#'(lambda (c)
(return-from read-frame-command
(synchronous-command-event-command c)))))
(call-next-method)))))
#'(lambda (c)
(return-from read-frame-command
(synchronous-command-event-command c)))))
(let ((*reading-frame-command* t))
(call-next-method))))))
;;--- Actually this should be named command-event
......@@ -1347,4 +1357,10 @@
right right-presentation right-context)))
(defmethod raise-frame ((frame standard-application-frame))
(raise-sheet (frame-top-level-sheet frame)))
(defmethod bury-frame ((frame standard-application-frame))
(bury-sheet (frame-top-level-sheet frame)))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: gadget-output.lisp,v 1.26 92/09/08 10:34:47 cer Exp Locker: cer $
;; $fiHeader: gadget-output.lisp,v 1.27 92/09/08 15:17:46 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -371,23 +371,20 @@
#'(lambda (element)
(let* ((value (funcall value-key element))
(button
(make-pane 'toggle-button
:label
(let ((name (funcall name-key element)))
(if (eq printer #'write-token)
name
(pixmap-from-menu-item stream name printer nil)))
:indicator-type (getf toggle-options :indicator-type :some-of)
:value (and default-supplied-p
(member value default
:test test
;;--- Should the value-key be used?
:key value-key)
t)
:id value
toggle-options)))
(apply #'make-pane 'toggle-button
:label (let ((name (funcall name-key element)))
(if (eq printer #'write-token)
name
(pixmap-from-menu-item stream name printer nil)))
:indicator-type (getf toggle-options :indicator-type :some-of)
:value (and default-supplied-p
(member value default
:test test
;;--- Should the value-key be used?
:key value-key)
t)
:id value
toggle-options)))
button))
sequence))
(check-box (apply #'make-pane 'check-box
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: gestures.lisp,v 1.11 92/08/18 17:24:57 cer Exp $
;; $fiHeader: gestures.lisp,v 1.12 92/09/08 15:17:48 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -265,15 +265,15 @@
(multiple-value-bind (keysym modifier-state)
(if modifier-state
(values gesture-spec modifier-state)
(parse-gesture-spec gesture-spec))
(parse-gesture-spec gesture-spec))
(with-stack-list (key keysym modifier-state)
(let ((table (port-canonical-gesture-specs port)))
(when table
(multiple-value-bind (value found-p) (gethash key table)
(if found-p
value
(setf (gethash (evacuate-list key) table)
(call-next-method port keysym modifier-state)))))))))
(setf (gethash (evacuate-list key) table)
(call-next-method port keysym modifier-state)))))))))
;; Needed for (sigh) string streams. Hardly ever used...
(defmethod port-canonicalize-gesture-spec
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: input-defs.lisp,v 1.12 92/07/27 11:02:30 cer Exp $
;; $fiHeader: input-defs.lisp,v 1.13 92/08/18 17:25:05 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -27,6 +27,9 @@
(button-state :accessor pointer-button-state
:type fixnum :initform 0)
(position-changed :accessor pointer-position-changed)
;; In case the pointer's cursor needs to be managed more directly...
(cursor :initform nil :reader pointer-cursor)
;;-- Dunno what all this are for.
(cursor-pattern :accessor pointer-cursor-pattern)
(cursor-width :accessor pointer-cursor-width)
(cursor-height :accessor pointer-cursor-height)
......@@ -40,6 +43,10 @@
(progn
(declaim (notinline pointer-sheet (setf pointer-sheet))))
(defmethod (setf pointer-cursor) (cursor (pointer standard-pointer))
(port-set-pointer-cursor (port pointer) pointer cursor)
(setf (slot-value pointer 'cursor) cursor))
(defmethod pointer-position ((pointer standard-pointer))
(with-slots (x-position y-position) pointer
(values x-position y-position)))
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: input-protocol.lisp,v 1.23 92/08/19 18:04:53 cer Exp $
;; $fiHeader: input-protocol.lisp,v 1.24 92/09/08 15:17:57 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -369,9 +369,13 @@
:numeric-argument (or *accelerator-numeric-argument* 1)))
((member gesture *abort-gestures*
:test #'keyboard-event-matches-gesture-name-p)
(let ((cursor (slot-value stream 'text-cursor)))
(when (and cursor
(cursor-active cursor))
(let* ((frame (pane-frame stream))
(stream (if (typep stream 'interactor-pane)
stream
(and frame
(find-frame-pane-of-type frame 'interactor-pane))))
(cursor (and stream (stream-text-cursor stream))))
(when (and cursor (cursor-active cursor))
(write-string "[Abort]" stream)
(force-output stream)))
(error 'abort-gesture :event gesture))))
......@@ -407,6 +411,9 @@
(return-from stream-read-char gesture))
;;--- Probably wrong. It prevents the input editor from ever seeing
;;--- mouse clicks, for example.
(when (and (typep gesture 'key-press-event)
(characterp (keyboard-event-character gesture)))
(return-from stream-read-char (slot-value gesture 'character)))
(beep stream))))
(defmethod stream-unread-char ((stream input-protocol-mixin) character)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: output-protocol.lisp,v 1.21 92/09/08 15:18:07 cer Exp Locker: cer $
;; $fiHeader: output-protocol.lisp,v 1.22 92/09/09 11:44:44 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -289,25 +289,19 @@
(defmethod stream-start-line-p ((output-stream output-protocol-mixin))
(zerop (slot-value output-stream 'cursor-x)))
#+Allegro
(defmethod stream-line-column ((output-stream output-protocol-mixin))
(multiple-value-bind (origin-x origin-y space-width)
(port-glyph-for-character (port output-stream) #\space
(port-glyph-for-character (port output-stream) #\Space
(medium-merged-text-style output-stream))
(declare (ignore origin-x origin-y))
;;--- This is pretty dubious stuff
#-Symbolics
(multiple-value-bind (column remainder)
(floor (slot-value output-stream 'cursor-x) space-width)
(and (= remainder 0)
column))))
;;--- This version returns non-integers and makes allegro unhappy.
#-Allegro
(defmethod stream-line-column ((output-stream output-protocol-mixin))
(multiple-value-bind (origin-x origin-y space-width)
(port-glyph-for-character (port output-stream) #\Space
(medium-merged-text-style output-stream))
(declare (ignore origin-x origin-y))
;; Better to return a rational number than NIL
column))
#+Symbolics
;; Better to return a rational number than NIL.
(/ (slot-value output-stream 'cursor-x) space-width)))
(defmethod stream-advance-to-column ((output-stream output-protocol-mixin) column)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: presentations.lisp,v 1.14 92/08/19 10:24:03 cer Exp $
;; $fiHeader: presentations.lisp,v 1.15 92/09/08 15:18:19 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -140,6 +140,7 @@
(setf (presentation-object null-presentation) null-presentation)
null-presentation))
(defun window-cohorts-p (window-one window-two)
;; The best test for whether or not two windows care about each
;; other's mouse motion (for now) is whether they share an IO buffer.
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: standard-types.lisp,v 1.12 92/08/21 16:33:59 cer Exp $
;; $fiHeader: standard-types.lisp,v 1.13 92/09/08 15:18:32 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -359,7 +359,7 @@
:inherit-from t ;enforce CL definition
:history t
:options ((default-type nil)
(default-version :newest)
(default-version #+allegro :unspecific #-allegro :newest)
(merge-default t)))
;;; PATHNAME is supposed to be a built-in-class, but since it's missing in Genera,
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: table-formatting.lisp,v 1.9 92/08/18 17:25:39 cer Exp Locker: cer $
;; $fiHeader: table-formatting.lisp,v 1.10 92/08/19 18:05:04 cer Exp Locker: cer $
(in-package :clim-internals)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: text-recording.lisp,v 1.10 92/08/18 17:25:43 cer Exp $
;; $fiHeader: text-recording.lisp,v 1.11 92/09/08 15:18:38 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -29,7 +29,7 @@
(defclass standard-text-output-record
(output-record-element-mixin text-displayed-output-record)
((string :initarg :string)
((string :initarg :string :reader text-displayed-output-record-string)
(wrapped-p :initform nil :initarg :wrapped-p)
(ink :initarg :ink)
(clipping-region :initarg :clipping-region)))
......@@ -55,6 +55,8 @@
:ink ink :string string :clipping-region clipping-region :wrapped-p wrapped-p
:initial-style style :current-style style :baseline baseline)
(defmethod print-object ((object standard-text-output-record) stream)
(print-unreadable-object (object stream :type t :identity t)
(format stream "~S /x ~A:~A y ~A:~A/"
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
;; $fiHeader: clx-mirror.lisp,v 1.11 92/08/18 17:54:05 cer Exp $
;; $fiHeader: clx-mirror.lisp,v 1.12 92/09/08 15:17:14 cer Exp Locker: cer $
(in-package :clx-clim)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
;; $fiHeader: clx-port.lisp,v 1.12 92/07/27 11:02:02 cer Exp $
;; $fiHeader: clx-port.lisp,v 1.13 92/08/18 17:24:27 cer Exp Locker: cer $
(in-package :clx-clim)
......@@ -505,33 +505,35 @@
(defvar *clx-cursor-type-alist*
'((:default 132)
(:vertical-scroll 116)
(:scroll-up 114)
(:scroll-down 106)
(:horizontal-scroll 108)
(:scroll-left 110)
(:scroll-right 112)
(:busy 150)
(:upper-left 134)
(:upper-right 136)
(:lower-left 12)
(:lower-right 14)
(:vertical-thumb 112)
(:horizontal-thumb 114)
(:button 132)
(:prompt 92)
(:move 52)
(:position 34)))
(defmethod install-port-cursor ((port clx-port) sheet cursor)
(unless (eq cursor (port-cursor port))
'((:default 132)
(:vertical-scroll 116)
(:scroll-up 114)
(:scroll-down 106)
(:horizontal-scroll 108)
(:scroll-left 110)
(:scroll-right 112)
(:busy 150)
(:upper-left 134)
(:upper-right 136)
(:lower-left 12)
(:lower-right 14)
(:vertical-thumb 112)
(:horizontal-thumb 114)
(:button 132)
(:prompt 92)
(:move 52)
(:position 34)))
;; In X Windows, cursors are associated with a particular window, so
;; we are depending on the fact that the CLX port is not deeply mirrored
;; to get the behavior that we can "globally" change the pointer cursor.
(defmethod port-set-pointer-cursor ((port clx-port) pointer cursor)
(unless (eq (pointer-cursor pointer) cursor)
(with-slots (display) port
(setf (port-cursor port) cursor)
(setf (xlib:window-cursor (sheet-mirror sheet))
(setf (xlib:window-cursor (sheet-mirror (pointer-sheet pointer)))
(realize-cursor port cursor))
(xlib:display-force-output display))
cursor))
(xlib:display-force-output display)))
cursor)
(defmethod realize-cursor :around ((port clx-port) cursor)
(with-slots (cursor-cache) port
......@@ -555,6 +557,7 @@
:foreground (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)
:background (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))))
;;--- We need something like PORT-SET-POINTER-POSITION
(defmethod set-cursor-location ((port clx-port) sheet x y)
(xlib:warp-pointer (sheet-mirror sheet)
......
......@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
;; $fiHeader: bitmap-editor.lisp,v 1.1 92/09/08 10:39:09 cer Exp Locker: cer $
(in-package :clim-demo)
......@@ -46,32 +46,37 @@
(flet ((display-color (object stream)
(with-room-for-graphics (stream)
(draw-rectangle* stream 0 0 30 10 :ink object))))
(setf current-color
(position
(accept `((completion ,colors)
:name-key ,#'identity
:printer ,#'display-color)
:view '(clim-internals::radio-box-view :orientation
:vertical :toggle-button-options (:indicator-type nil))
:stream stream
:default (nth current-color colors)
:prompt "Colors")
colors))
(terpri stream)
(accept-values-command-button (stream)
"Add Color"
(add-color-to-palette frame))
(terpri stream)
(accept-values-command-button (stream)
"Edit Color"
(replace-current-color frame))
(terpri stream)
(accept-values-command-button (stream)
"Delete Color"
(delete-current-color frame)))))
(formatting-item-list (stream :n-columns 2)
(formatting-cell (stream)
(setf current-color
(position
(accept `((completion ,colors)
:name-key ,#'identity
:printer ,#'display-color)
:view '(clim-internals::radio-box-view
:orientation :vertical
:toggle-button-options (:indicator-type nil))
:stream stream
:default (nth current-color colors)
:prompt "Colors")
colors)))
(formatting-cell (stream)
(formatting-item-list (stream :n-columns 1)
(formatting-cell (stream)
(accept-values-command-button (stream)
"Add Color"