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
4a6067af
Commit
4a6067af
authored
Feb 16, 1992
by
cer
Browse files
fixes
parent
abcc0207
Changes
22
Hide whitespace changes
Inline
Side-by-side
Makefile
View file @
4a6067af
# $fiHeader: Makefile,v 1.
8
92/01/31 17:5
1:05
cer Exp
Locker: cer
$
SOMEDIRS
=
sys utils silica clim demo
DIRS
=
$(SOMEDIRS)
xlib tk xm-silica misc
DEVICE
=
/dev/nul
l
CL
=
/net/vapor/usr/composer2/composer2
# $fiHeader: Makefile,v 1.
9
92/01/31 17:5
2:53
cer Exp $
#
# Makefile for CLIM 2.0
#
CL
=
/misc/jdi/c
l
DUMP-CL
=
/misc/jdi/cl
CLOPTS
=
-qq
# Lisp optimization for compiling
SPEED
=
3
SAFETY
=
1
# Name of dumped lisp
CLIM
=
./slim
CLIM-SMALL
=
./slim-small
PUBDIRS
=
sys utils silica clim demo
test
DIRS
=
$(PUBDIRS)
xlib tk xm-silica misc
DEVICE
=
/dev/null
RM
=
/bin/rm
CAT
=
/bin/cat
ECHO
=
/bin/echo
MV
=
/usr/fi/mv-nfs
TAGS
=
/usr/fi/lib/emacs/etc/etags
TMP
=
/usr/tmp
#
# "Compile time objects" -- these go into clim-debug.fasl
#
DEBUG-OBJS
=
xlib/xlib.fasl
#
# "Load time objects" -- these go into clim.fasl
#
CLIM-UTILS-OBJS
=
utils/excl-verification.fasl
\
utils/lisp-package-fixups.fasl
\
utils/defpackage.fasl
\
utils/packages.fasl
\
utils/defun-utilities.fasl
\
utils/reader.fasl
\
utils/clos-patches.fasl
\
utils/clos.fasl
\
utils/utilities.fasl
\
utils/lisp-utilities.fasl
\
utils/processes.fasl
\
utils/queue.fasl
\
utils/protocols.fasl
\
utils/autoconstructor.fasl
\
utils/clim-streams.fasl
\
utils/excl-streams.fasl
\
utils/clim-macros.fasl
\
utils/transformations.fasl
\
utils/regions.fasl
\
utils/region-arithmetic.fasl
\
utils/designs.fasl
CLIM-SILICA-OBJS
=
silica/classes.fasl
\
silica/text-style.fasl
\
silica/macros.fasl
\
silica/sheet.fasl
\
silica/mirror.fasl
\
silica/event.fasl
\
silica/port.fasl
\
silica/medium.fasl
\
silica/graphics.fasl
\
silica/std-sheet.fasl
\
silica/layout.fasl
\
silica/db-layout.fasl
\
silica/db-box.fasl
\
silica/db-table.fasl
\
silica/gadgets.fasl
\
silica/db-scroll.fasl
CLIM-STANDALONE-OBJS
=
clim/shift-mask.fasl
\
clim/defprotocol.fasl
\
clim/stream-defprotocols.fasl
\
clim/defresource.fasl
\
clim/temp-strings.fasl
\
clim/clim-defs.fasl
\
clim/stipples.fasl
\
clim/stream-class-defs.fasl
\
clim/interactive-defs.fasl
\
clim/cursor.fasl
\
clim/view-defs.fasl
\
clim/input-defs.fasl
\
clim/input-protocol.fasl
\
clim/output-protocol.fasl
\
clim/window-protocol.fasl
\
clim/output-recording-protocol.fasl
\
clim/output-recording-defs.fasl
\
clim/interactive-protocol.fasl
\
clim/input-editor-commands.fasl
\
clim/formatted-output-defs.fasl
\
clim/incremental-redisplay.fasl
\
clim/coordinate-sorted-set.fasl
\
clim/window-stream.fasl
\
clim/completer.fasl
\
clim/ptypes1.fasl
\
clim/presentations.fasl
\
clim/translators.fasl
\
clim/histories.fasl
\
clim/ptypes2.fasl
\
clim/standard-types.fasl
\
clim/table-formatting.fasl
\
clim/graph-formatting.fasl
\
clim/surround-output.fasl
\
clim/text-formatting.fasl
\
clim/tracking-pointer.fasl
\
clim/dragging-output.fasl
\
clim/db-stream.fasl
\
clim/gadget-output.fasl
\
clim/accept.fasl
\
clim/present.fasl
\
clim/command.fasl
\
clim/command-processor.fasl
\
clim/basic-translators.fasl
\
clim/frames.fasl
\
clim/menus.fasl
\
clim/accept-values.fasl
\
clim/item-list-manager.fasl
\
clim/pixmap-streams.fasl
\
clim/stream-trampolines.fasl
XLIB-CLIM-OBJS
=
xlib/pkg.fasl
\
xlib/ffi.fasl
\
xlib/x11-keysyms.fasl
\
xlib/last.fasl
XT-CLIM-OBJS
=
tk/pkg.fasl
\
tk/foreign-obj.fasl
\
tk/macros.fasl
\
tk/xlib.fasl
\
tk/font.fasl
\
tk/gcontext.fasl
\
tk/graphics.fasl
\
tk/xtk.fasl
\
tk/meta-tk.fasl
\
tk/make-classes.fasl
\
tk/foreign.fasl
\
tk/widget.fasl
\
tk/resources.fasl
\
tk/event.fasl
\
tk/callbacks.fasl
\
tk/xt-classes.fasl
\
tk/xt-init.fasl
XM-CLIM-OBJS
=
tk/xm-classes.fasl
\
tk/xm-init.fasl
\
tk/xm-widgets.fasl
\
tk/xm-font-list.fasl
\
tk/xm-protocols.fasl
\
tk/convenience.fasl
\
tk/make-widget.fasl
MOTIF-CLIM-OBJS
=
xm-silica/pkg.fasl
\
xm-silica/xt-silica.fasl
\
xm-silica/xm-silica.fasl
\
xm-silica/xt-graphics.fasl
\
xm-silica/xm-graphics.fasl
\
xm-silica/image.fasl
\
xm-silica/xt-frames.fasl
\
xm-silica/xm-frames.fasl
\
xm-silica/xt-gadgets.fasl
\
xm-silica/xm-gadgets.fasl
\
xm-silica/xm-menus.fasl
\
xm-silica/xt-pixmaps.fasl
default
:
compile
OL-CLIM-OBJS
=
tk/ol-classes.fasl
\
tk/ol-init.fasl
\
tk/ol-callbacks.fasl
\
tk/make-widget.fasl
compile
:
FRC
OPENLOOK-CLIM-OBJS
=
xm-silica/pkg.fasl
\
xm-silica/xt-silica.fasl
\
xm-silica/ol-silica.fasl
\
xm-silica/xt-graphics.fasl
\
xm-silica/ol-graphics.fasl
\
xm-silica/image.fasl
\
xm-silica/xt-frames.fasl
\
xm-silica/ol-frames.fasl
\
xm-silica/xt-gadgets.fasl
\
xm-silica/ol-gadgets.fasl
\
xm-silica/xt-pixmaps.fasl
MOTIF-OBJS
=
$
(
CLIM-UTILS-OBJS
)
$
(
CLIM-SILICA-OBJS
)
$
(
CLIM-STANDALONE-OBJS
)
\
$
(
XLIB-CLIM-OBJS
)
$
(
XT-CLIM-OBJS
)
$
(
XM-CLIM-OBJS
)
\
$
(
MOTIF-CLIM-OBJS
)
OPENLOOK-OBJS
=
$
(
CLIM-UTILS-OBJS
)
$
(
CLIM-SILICA-OBJS
)
\
$
(
CLIM-STANDALONE-OBJS
)
$
(
XLIB-CLIM-OBJS
)
$
(
XT-CLIM-OBJS
)
\
$
(
OL-CLIM-OBJS
)
$
(
OPENLOOK-CLIM-OBJS
)
all
:
compile cat clim
compile
:
FORCE
$(ECHO)
"
\
(load
\"
misc/go-xm.cl
\"
)"
|
$(CL)
$(CLOPTS)
-batch
(setq *ignore-package-name-case* t)
\
(set-case-mode :case-insensitive-lower)
\
(proclaim '(optimize (speed
$(SPEED)
) (safety
$(SAFETY)
)))
\
(load
\"
misc/compile-xm.lisp
\"
)"
|
$(CL)
$(CLOPTS)
-batch
clean
:
FRC
find
$(DIRS)
-name
"*.fasl"
-exec
$(RM)
"{}"
\;
clim.fasl
:
$(MOTIF-OBJS)
$(CAT)
$
(
MOTIF-OBJS
)
>
$(TMP)
/clim.fasl_
`
whoami
`
mv-nfs
$(TMP)
/clim.fasl_
`
whoami
`
clim.fasl
FRC
:
clim-debug.fasl
:
$(MOTIF-OBJS)
$(CAT)
$
(
DEBUG-OBJS
)
>
$(TMP)
/clim-debug.fasl_
`
whoami
`
mv-nfs
$(TMP)
/clim-debug.fasl_
`
whoami
`
clim-debug.fasl
cat
:
clim.fasl clim-debug.fasl
swm-tape
:
tar
cf
$(DEVICE)
`
find
$(SOMEDIRS)
'('
-name
"*.cl"
-o
-name
"*.lisp"
')'
-print
`
clim
:
FORCE
$(ECHO)
"
\
(setq *ignore-package-name-case* t)
\
(set-case-mode :case-insensitive-lower)
\
(load
\"
misc/dev-load-xm.lisp
\"
)
\
(load
\"
misc/dump.lisp
\"
)"
|
$
(
DUMP-CL
)
$(CLOPTS)
-batch
$(MV)
$(TMP)
/clim.temp_
`
whoami
`
$(CLIM)
clim-small
:
FORCE
$(ECHO)
"
\
(setq *ignore-package-name-case* t)
\
(set-case-mode :case-insensitive-lower)
\
(load
\"
misc/load-xm.lisp
\"
)
\
(load
\"
misc/dump.lisp
\"
)"
|
$
(
DUMP-CL
)
$(CLOPTS)
-batch
$(MV)
$(TMP)
/clim.temp_
`
whoami
`
$
(
CLIM-SMALL
)
xm-composer
:
cd
tk
;
$(MAKE)
xm-composer
xm-dcl
:
cd
tk
;
$(MAKE)
xm-dcl
dist
:
clean
:
find
$(DIRS)
-name
"*.fasl"
-ls
| xargs
rm
-f
;
rm
-f
clim.fasl
tags
:
$(TAGS)
`
find
$(DIRS)
'('
-name
"*.cl"
-o
-name
"*.lisp"
')'
-print
`
swm-tape
:
tar
cf
$(DEVICE)
`
find
$(PUBDIRS)
'('
-name
"*.cl"
-o
-name
"*.lisp"
')'
-print
`
dist
:
gtar
-z
-cf
-
\
*
/
*
.lisp
*
.lisp Makefile
\
>
Dist/src.tar.Z
rcscheck
:
rcscheck
$(DIRS)
|
grep
-v
.fasl
rcscheck
$(DIRS)
|
grep
-v
.fasl
# For the day the make dist happens.
echo_src_files
:
@
find
.
'('
-name
'*.cl'
-o
-name
'*.lisp'
')'
-print
FORCE
:
clim/menus.lisp
View file @
4a6067af
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: menus.lisp,v 1.
8
92/02/
05 21:45:43
cer Exp Locker: cer $
;; $fiHeader: menus.lisp,v 1.
9
92/02/
14 18:58:01
cer Exp Locker: cer $
(
in-package
:clim-internals
)
...
...
@@ -64,7 +64,7 @@
;; into a menu is required to use with-end-of-line-action and with-end-of-page-action
;; or set the size first itself.
:initializer
(
initialize-menu
(
sheet-port
menu
)
menu
associated-window
)
:matcher
(
or
(
null
root
)
:matcher
(
or
#+
ignore
(
null
root
)
#-
ignore
nil
;; horrible kludge in the case where no associated window is passed in.
(
eql
(
sheet-port
menu
)
(
sheet-port
root
))))
...
...
sys/defsystem.lisp
View file @
4a6067af
...
...
@@ -18,10 +18,10 @@
;;;
;;; $Author: cer $
;;; $Source: /repo/cvs.copy/clim2/sys/defsystem.lisp,v $
;;; $Revision: 1.
2
$
;;; $Date: 1992/02/
08 14:59:27
$
;;; $Revision: 1.
3
$
;;; $Date: 1992/02/
16 20:55:38
$
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Hacked by smL to convert it to lisp from C.
;;; No, seriously folks. Lots of changes here. Added support for multiple
;;; source file-types. Cleaned up a *lot* of code.
...
...
@@ -30,19 +30,19 @@
;;; Added support for different modules applicable only in certain features.
;;; -smL 17-April-89
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Added support for sysdcl files.
;;; -smL
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Cleaned up a lot of syntax. Made some fields of the defsystem macro be eval'ed.
;;; -smL
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Added "temporary" hack *load-all-before-compile*.
;;; -smL
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Incorporated changes from Bill York @ ILA to deal with Genera.
;;; Added the :default-binary-pathname option to defsystem and :binary-pathname
;;; to each module.
...
...
@@ -55,12 +55,12 @@
;;; Fixed the spelling of "propagate".
;;; -smL
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Fixed a bug that caused many too many calls to file-write-date during a
;;; load-system.
;;; -smL
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Incorporated changes from Bill York <york@ila-west.dialnet.symbolics.com>
;;; to make string --> pathname coersion cleaner under Genera.
;;; Also made some trivial changes to the messages printed out when *tracep*
...
...
@@ -75,7 +75,7 @@
;;; load-system and compile-system now return the system name.
;;; -smL
;;;
;;; $Revision: 1.
2
$
;;; $Revision: 1.
3
$
;;; Fixed bug with pretty-pathname-component. Added message when compiling a
;;; file in Genera, since it doesn't print one by default. Fixed a small bug
;;; with handling of *features*. Fixed a bug with *tracep*.
...
...
@@ -91,7 +91,7 @@
;;;
;;;-----------------------------------------------------------
;; $fiHeader: defsystem.lisp,v 1.
6
9
1
/0
3/26
1
2
:59:
59
cer Exp $
;; $fiHeader: defsystem.lisp,v 1.
2
9
2
/0
2/08
1
4
:59:
27
cer Exp $
;; Add a feature for ANSI-adhering Lisps. So far, only Apple's
;; version 2.0 tries to do adhere to the ANSI spec instead of CLtL rev 1.
...
...
@@ -1541,9 +1541,9 @@ verify that each already loaded subsystem is up-to-date, reloading it if need be
,@
(
and
old-safety
,
safety
`
((
safety
,
old-safety
))))))))
#|
;;; Write (Franz only?) Makefile description for constructiong big FASL
;;; from system definition. 20-21 August 1990 by Richard Lamson
(defun write-Makefile-for-system (system)
(unless (system-p system)
(setf system (find-system system)))
...
...
@@ -1615,4 +1615,4 @@ verify that each already loaded subsystem is up-to-date, reloading it if need be
(and pfp
(format nil "~VT~A.~A" indentation pfp bin-type))))
(list file-list-name)))))
|#
sys/sysdcl.lisp
View file @
4a6067af
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;; $fiHeader: sysdcl.lisp,v 1.
6
9
1
/0
3/26 13:00:01
cer Exp $
;; $fiHeader: sysdcl.lisp,v 1.
2
9
2
/0
2/08 14:59:29
cer Exp $
(
in-package
#-
ANSI-90
"USER"
#+
ANSI-90
:cl-user
)
...
...
@@ -323,13 +323,16 @@
:needed-systems
(
clim-standalone
)
:load-before-compile
(
clim-standalone
))
(
"pkg"
)
#+
ignore
(
"ffi"
:eval-after
(
mapc
#'
load
'
(
"xlib/xlib.lisp"
"xlib/x11-keysyms.lisp"
"xlib/last.lisp"
)))
(
"ffi"
)
(
"xlib"
)
(
"x11-keysyms"
)
(
"last"
))
#+
Allegro
(
defsys::defsystem
t
k
-clim
(
defsys::defsystem
x
t-clim
(
:default-pathname
(
frob-pathname
"tk"
)
:default-binary-pathname
(
frob-pathname
"tk"
)
:needed-systems
(
xlib-clim
)
...
...
@@ -354,9 +357,16 @@
(
"resources"
)
(
"event"
)
(
"callbacks"
)
(
"xt-classes"
)
(
"xt-init"
))
(
defsys::defsystem
xm-clim
(
:default-pathname
(
frob-pathname
"tk"
)
:default-binary-pathname
(
frob-pathname
"tk"
)
:needed-systems
(
xt-clim
)
:load-before-compile
(
xt-clim
))
;; Motif specific stuff
(
"
load-xm
"
)
(
"
xm-classes
"
)
(
"xm-init"
)
(
"xm-widgets"
)
(
"xm-font-list"
)
...
...
@@ -371,32 +381,9 @@
(
defsys::defsystem
ol-clim
(
:default-pathname
(
frob-pathname
"tk"
)
:default-binary-pathname
(
frob-pathname
"tk"
)
:needed-systems
(
xlib-clim
)
:load-before-compile
(
xlib-clim
))
(
|pkg|
)
(
|foreign-obj|
)
(
|macros|
)
;; Xlib stuff
(
|xlib|
)
(
|font|
)
(
|gcontext|
)
(
|graphics|
)
;; Toolkit stuff
(
|xtk|
)
(
|meta-tk|
)
(
|make-classes|
)
(
|foreign|
)
(
|widget|
)
(
|resources|
)
(
|event|
)
(
|callbacks|
)
(
|load-ol|
)
:needed-systems
(
xt-clim
)
:load-before-compile
(
xt-clim
))
(
|ol-classes|
)
(
|ol-init|
)
(
|ol-callbacks|
)
#+
ignore
(
|ol-examples|
)
...
...
@@ -407,8 +394,8 @@
(
defsys::defsystem
motif-clim
(
:default-pathname
(
frob-pathname
"xm-silica"
)
:default-binary-pathname
(
frob-pathname
"xm-silica"
)
:needed-systems
(
tk
-clim
)
:load-before-compile
(
tk
-clim
))
:needed-systems
(
xm
-clim
)
:load-before-compile
(
xm
-clim
))
(
"pkg"
)
(
"xt-silica"
)
(
"xm-silica"
)
...
...
test/chess.lisp
View file @
4a6067af
;; -*- mode: common-lisp; package: clim -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(
in-package
:clim
)
(
define-application-frame
chess-board
()
...
...
test/simple-test.lisp
View file @
4a6067af
;; -*- mode: common-lisp; package: silica -*-
;;
;; -[]-
;;
;; copyright (c) 1985, 1986 Franz Inc, Alameda, CA All rights reserved.
;; copyright (c) 1986-1991 Franz Inc, Berkeley, CA All rights reserved.
;;
;; The software, data and information contained herein are proprietary
;; to, and comprise valuable trade secrets of, Franz, Inc. They are
;; given in confidence by Franz, Inc. pursuant to a written license
;; agreement, and may be stored and used only in accordance with the terms
;; of such license.
;;
;; Restricted Rights Legend
;; ------------------------
;; Use, duplication, and disclosure of the software, data and information
;; contained herein by any agency, department or entity of the U.S.
;; Government are subject to restrictions of Restricted Rights for
;; Commercial Software developed at private expense as specified in FAR
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(
in-package
:silica
)
(
setq
port
(
find-port
))
...
...
test/test.lisp
View file @
4a6067af
...
...
@@ -19,6 +19,8 @@
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
(
in-package
:clim-internals
)
(
define-application-frame
test-frame
()
...
...
tk-silica/xt-gadgets.lisp
View file @
4a6067af
...
...
@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xt-gadgets.lisp,v 1.
3
92/02/
05 21:45:29
cer Exp Locker: cer $
;; $fiHeader: xt-gadgets.lisp,v 1.
4
92/02/
14 18:57:46
cer Exp Locker: cer $
(
in-package
:xm-silica
)
...
...
@@ -70,19 +70,19 @@
;; Background can either be a pixel of a bitmap
;; Foreground has to be a pixel
;;
clx-
decode-gadget-background
;;
clx-
decode-gadget-foreground
;; decode-gadget-background
;; decode-gadget-foreground
(
when
silica::background
(
with-sheet-medium
(
medium
sheet
)
(
setf
initargs
(
append
(
clx-
decode-gadget-background
medium
sheet
silica::background
)
(
append
(
decode-gadget-background
medium
sheet
silica::background
)
initargs
))))
(
when
silica::foreground
(
with-sheet-medium
(
medium
sheet
)
(
setf
initargs
(
append
(
clx-
decode-gadget-foreground
medium
sheet
silica::foreground
)
(
append
(
decode-gadget-foreground
medium
sheet
silica::foreground
)
initargs
))))
(
when
silica::text-style
...
...
@@ -91,20 +91,18 @@
(
values
class
initargs
))))
(
defmethod
clx-
decode-gadget-background
(
medium
sheet
ink
)
(
defmethod
decode-gadget-background
(
medium
sheet
ink
)
(
declare
(
ignore
sheet
))
(
let
((
gc
(
clx-
decode-ink
ink
medium
)))
(
let
((
gc
(
decode-ink
ink
medium
)))
(
if
(
tk::gcontext-tile
gc
)
(
list
:background-pixmap
(
tk::gcontext-tile
gc
))
(
list
:background
(
tk::gcontext-foreground
gc
)))))
(
defmethod
clx-
decode-gadget-foreground
(
medium
sheet
ink
)
(
defmethod
decode-gadget-foreground
(
medium
sheet
ink
)
(
declare
(
ignore
sheet
))
(
let
((
gc
(
clx-decode-ink
ink
medium
)))
(
if
(
tk::gcontext-tile
gc
)
(
error
"Gadget foreground cannot be pixmap"
)
(
list
:foreground
(
tk::gcontext-foreground
gc
)))))
(
let
((
pixel
(
decode-color
medium
ink
)))
(
list
:foreground
pixel
)))
;; This needs to be somewhere.
...
...
tk-silica/xt-graphics.lisp
View file @
4a6067af
...
...
@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xt-graphics.lisp,v 1.
5
92/02/
05 21:45:30
cer Exp Locker: cer $
;; $fiHeader: xt-graphics.lisp,v 1.
6
92/02/
14 18:57:47
cer Exp Locker: cer $
(
in-package
:xm-silica
)
...
...
@@ -28,9 +28,13 @@
((
foreground-gcontext
:reader
medium-foreground-gcontext
:initform
nil
)
(
background-gcontext
:reader
medium-background-gcontext
:initform
nil
)
(
flipping-gcontext
:reader
medium-flipping-gcontext
:initform
nil
)
(
sheet
:accessor
medium-sheet
)
(
drawable
:initform
nil
:writer
(
setf
medium-drawable
))
(
ink-table
:initform
(
make-hash-table
))))
(
sheet
:accessor
medium-sheet
)
(
drawable
:initform
nil
)
(
color-p
)
(
ink-table
:initform
(
make-hash-table
))
(
stipple-gcontext
:initform
nil
)
; These don't belong here.
(
white-pixel
:initform
0
)
(
black-pixel
:initform
1
)))
(
defmethod
medium-drawable
((
medium
xt-medium
))
(
with-slots
(
drawable
sheet
)
medium
...
...
@@ -44,27 +48,40 @@
(
tk::widget-window
mirror
nil
))
(
defmethod
engraft-medium
:after
((
medium
xt-medium
)
(
port
xt-port
)
sheet
)
(
with-slots
(
foreground-gcontext
background-gcontext
flipping-gcontext
)
(
with-slots
(
foreground-gcontext
background-gcontext
flipping-gcontext
color-p
drawable
stipple-gcontext
white-pixel
black-pixel
)
medium
(
setf
(
medium-sheet
medium
)
sheet
)
(
let
((
drawable
(
tk::display-root-window
(
port-display
port
))))
(
unless
foreground-gcontext
(
setf
foreground-gcontext
(
tk::make-instance
'tk::gcontext
:drawable
drawable
)))
(
unless
background-gcontext
(
setf
background-gcontext
(
tk::make-instance
'tk::gcontext
:drawable
drawable
)))
(
unless
flipping-gcontext
(
setf
flipping-gcontext
(
tk::make-instance
'tk::gcontext
:function
boole-xor
:drawable
drawable
)))