Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
Wm Annis
clim-tos
Commits
9c44d11f
Commit
9c44d11f
authored
Sep 22, 1992
by
cer
Browse files
fixes
parent
2d4873d9
Changes
52
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
9c44d11f
# $fiHeader: Makefile,v 1.4
4
92/0
8/21
1
6
:3
4:13
cer Exp Locker: cer $
# $fiHeader: Makefile,v 1.4
5
92/0
9/08
1
0
:3
5: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
...
...
clim/accept-values.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: accept-values.lisp,v 1.3
2
92/09/08 1
0:34:36
cer Exp Locker: cer $
;; $fiHeader: accept-values.lisp,v 1.3
3
92/09/08 1
5: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
)
...
...
clim/db-stream.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: db-stream.lisp,v 1.2
8
92/09/08 1
0:34:41
cer Exp Locker: cer $
;; $fiHeader: db-stream.lisp,v 1.2
9
92/09/08 1
5: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
)
...
...
clim/frames.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: frames.lisp,v 1.
39
92/09/08 1
0:34
:4
5
cer Exp Locker: cer $
;; $fiHeader: frames.lisp,v 1.
40
92/09/08 1
5:17
:4
4
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
)))
clim/gadget-output.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: gadget-output.lisp,v 1.2
6
92/09/08 1
0:34
:4
7
cer Exp Locker: cer $
;; $fiHeader: gadget-output.lisp,v 1.2
7
92/09/08 1
5:17
:4
6
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
...
...
clim/gestures.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: gestures.lisp,v 1.1
1
92/0
8/18 17:24:57 cer Exp
$
;; $fiHeader: gestures.lisp,v 1.1
2
92/0
9/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
...
...
clim/input-defs.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: input-defs.lisp,v 1.1
2
92/0
7/27 11:02:30 cer Exp
$
;; $fiHeader: input-defs.lisp,v 1.1
3
92/0
8/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
)))
...
...
clim/input-protocol.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: input-protocol.lisp,v 1.2
3
92/0
8/19 18:04
:5
3
cer Exp $
;; $fiHeader: input-protocol.lisp,v 1.2
4
92/0
9/08 15:17
:5
7
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
)
...
...
clim/output-protocol.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: output-protocol.lisp,v 1.2
1
92/09/0
8
1
5:18:07
cer Exp Locker: cer $
;; $fiHeader: output-protocol.lisp,v 1.2
2
92/09/0
9
1
1: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
)
#\
s
pace
(
port-glyph-for-character
(
port
output-stream
)
#\
S
pace
(
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
)
...
...
clim/presentations.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: presentations.lisp,v 1.1
4
92/0
8/19 10:24:03 cer Exp
$
;; $fiHeader: presentations.lisp,v 1.1
5
92/0
9/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.
...
...
clim/standard-types.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: standard-types.lisp,v 1.1
2
92/0
8/21 16:33:59 cer Exp
$
;; $fiHeader: standard-types.lisp,v 1.1
3
92/0
9/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,
...
...
clim/table-formatting.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: table-formatting.lisp,v 1.
9
92/08/1
8
1
7:25:39
cer Exp Locker: cer $
;; $fiHeader: table-formatting.lisp,v 1.
10
92/08/1
9
1
8:05:04
cer Exp Locker: cer $
(
in-package
:clim-internals
)
...
...
clim/text-recording.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: text-recording.lisp,v 1.1
0
92/0
8/18 17:25:43 cer Exp
$
;; $fiHeader: text-recording.lisp,v 1.1
1
92/0
9/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/"
...
...
clx/clx-mirror.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
;; $fiHeader: clx-mirror.lisp,v 1.1
1
92/0
8/18 17:54:05 cer Exp
$
;; $fiHeader: clx-mirror.lisp,v 1.1
2
92/0
9/08 15:17:14 cer Exp Locker: cer
$
(
in-package
:clx-clim
)
...
...
clx/clx-port.lisp
View file @
9c44d11f
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLX-CLIM; Base: 10; Lowercase: Yes -*-
;; $fiHeader: clx-port.lisp,v 1.1
2
92/0
7/27 11:02:02 cer Exp
$
;; $fiHeader: clx-port.lisp,v 1.1
3
92/0
8/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
)
...
...
demo/bitmap-editor.lisp
View file @
9c44d11f
...
...
@@ -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"