Commit f844003b authored by cer's avatar cer
Browse files

fixes

parent 32f281f6
# $fiHeader: Makefile,v 1.10 92/02/16 20:55:48 cer Exp $
# $fiHeader: Makefile,v 1.11 92/02/24 13:09:36 cer Exp Locker: cer $
#
# Makefile for CLIM 2.0
#
......@@ -216,6 +216,7 @@ clim-debug.fasl: $(MOTIF-OBJS)
cat: clim.fasl clim-debug.fasl
clim: FORCE
-$(RM) $(CLIM)
$(ECHO) " \
(setq *ignore-package-name-case* t) \
(set-case-mode :case-insensitive-lower) \
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: cursor.lisp,v 1.4 92/01/31 14:57:45 cer Exp $
;; $fiHeader: cursor.lisp,v 1.5 92/02/24 13:07:12 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -36,7 +36,8 @@
(y :initarg :y)
(stream :initarg :stream)
(flags :initform 0)
(width :initarg :width))
(width :initarg :width)
(plist :initform nil))
(:default-initargs :x 0 :y 0
:width 8
:stream nil))
......@@ -220,5 +221,12 @@
(force-output stream)))))
;;;---- BOGUS
(defun cursor-visibility (x) nil)
(defun (setf cursor-visibility) (nv x) nil)
(defun cursor-visibility (cursor)
(cursor-active cursor))
(defun (setf cursor-visibility) (nv cursor)
(setf (cursor-active cursor)
(case nv
(:off nil)
((nil) nil)
(t t))))
......@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: excl-streams.cl,v 1.2 92/02/05 21:52:04 cer Exp $
;; $fiHeader: excl-presentations.lisp,v 1.3 92/02/24 13:09:45 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -92,3 +92,21 @@
#+ignore(print (list parent abs-x abs-y) excl:*initial-terminal-io*)
(when parent
(add-output-record record parent)))))
(defvar *font-stack-hack* nil)
#+ignore
;;; Somehow this does not integrate with the CLIM mechanism
(defmethod excl::stream-set-font ((stm output-protocol) font-spec)
(setf (medium-text-style stm)
(etypecase font-spec
((nil)
(pop *font-stack-hack*)))
(character
(push (medium-text-style stm) *font-stack-hack*)
(ecase (char-downcase font-spec)
(#\r (window-stream-regular-font stm))
(#\b (window-stream-bold-font stm))
(#\i (window-stream-italic-font stm))
(#\j (window-stream-bold-italic-font stm))))))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;; $fiHeader: menus.lisp,v 1.10 92/02/16 20:55:35 cer Exp $
;; $fiHeader: menus.lisp,v 1.11 92/02/24 13:08:05 cer Exp Locker: cer $
(in-package :clim-internals)
......@@ -20,7 +20,8 @@
(:menu-bar nil))
(defmethod frame-calling-frame ((frame menu-frame))
*application-frame*)
(and (boundp '*application-frame*)
*application-frame*))
(defun get-menu (&key server-path)
(let ((frame (make-application-frame 'menu-frame
......
This diff is collapsed.
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
;; $fiHeader: aaai-demo-driver.lisp,v 1.1 92/01/31 14:31:55 cer Exp $
;; $fiHeader: aaai-demo-driver.lisp,v 1.2 92/02/24 13:09:15 cer Exp Locker: cer $
(in-package :clim-demo)
......@@ -36,8 +36,13 @@
desired-top (max top (- desired-bottom desired-height))))
(values desired-left desired-top desired-right desired-bottom))))
#+silica
(defun size-demo-frame (root desired-left desired-top desired-width
desired-height)
(values desired-left desired-top (+ desired-left desired-width)
(+ desired-top desired-height)))
(defun start-demo (&optional (root #-Silica *demo-root*))
#-Silica
(unless root
(lisp:format t "~&No current value for *DEMO-ROOT*. Use what value? ")
(setq root (eval (lisp:read)))
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*-
;; $fiHeader: listener.lisp,v 1.1 92/01/31 14:32:03 cer Exp $
;; $fiHeader: listener.lisp,v 1.2 92/02/24 13:09:25 cer Exp Locker: cer $
(in-package :clim-demo)
......@@ -493,12 +493,10 @@
(let* ((entry (assoc root *listeners*))
(ll (cdr entry)))
(when (or (null ll) reinit)
(multiple-value-bind (left top right bottom)
(size-demo-frame root 50 50 500 500)
(setq ll (make-application-frame 'lisp-listener
:parent root
:left left :top top
:right right :bottom bottom)))
(setq ll (make-application-frame 'lisp-listener
:parent root
:width 500
:height 500))
(if entry
(setf (cdr entry) ll)
(push (cons root ll) *listeners*)))
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*-
;; $fiHeader: sysdcl.lisp,v 1.2 92/02/24 13:09:33 cer Exp Locker: cer $
;; $fiHeader: sysdcl.lisp,v 1.3 92/02/24 13:31:03 cer Exp Locker: cer $
(in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user)
......@@ -28,17 +28,17 @@
("aaai-demo-driver" :load-before-compile ("packages"))
("graphics-demos" :load-before-compile ("aaai-demo-driver" "packages")
:features (not Minima))
("cad-demo" :load-before-compile ("aaai-demo-driver" "packages")
:features (not Minima))
("navdata" :load-before-compile ("packages")
:features (not Minima))
("navfun" :load-before-compile ("aaai-demo-driver" "navdata" "packages")
:features (not Minima))
("listener" :load-before-compile ("aaai-demo-driver" "packages"))
("puzzle" :load-before-compile ("aaai-demo-driver" "packages"))
("address-book" :load-before-compile ("aaai-demo-driver" "packages"))
("thinkadot" :load-before-compile ("aaai-demo-driver" "packages"))
("demo-prefill" :features (or Genera Cloe-Runtime))
; ("cad-demo" :load-before-compile ("aaai-demo-driver" "packages")
; :features (not Minima))
; ("navdata" :load-before-compile ("packages")
; :features (not Minima))
; ("navfun" :load-before-compile ("aaai-demo-driver" "navdata" "packages")
; :features (not Minima))
; ("puzzle" :load-before-compile ("aaai-demo-driver" "packages"))
; ("address-book" :load-before-compile ("aaai-demo-driver" "packages"))
; ("thinkadot" :load-before-compile ("aaai-demo-driver" "packages"))
; ("demo-prefill" :features (or Genera Cloe-Runtime))
)
#+Genera
......
......@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: compile-xm.lisp,v 1.1 92/02/16 20:31:27 cer Exp $
;; $fiHeader: compile-xm.lisp,v 1.2 92/02/24 13:09:41 cer Exp Locker: cer $
(in-package :user)
......@@ -28,9 +28,10 @@
(set-case-mode :case-insensitive-lower)
;;(load "/misc/jdi/4.1/src/code/defctype.fasl")
(setf *load-source-file-info* nil)
(setf *load-xref-info* nil)
(setf *record-xref-info* nil)
(setf *load-source-file-info* t)
(setf *record-source-file-info* t)
(setf *load-xref-info* t)
(setf *record-xref-info* t)
(setf (sys:gsgc-switch :print) nil)
(setf (sys:gsgc-switch :stats) nil)
(setq *compile-print* nil)
......@@ -44,7 +45,6 @@
(tenuring
(defsys::load-system 'motif-clim))
(compile-file-if-needed "test/test-suite")
#|
(load "demo/sysdcl")
(defsys::compile-system 'clim-demo :propagate t)
|#
......@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: dev-load-xm.lisp,v 1.1 92/02/16 20:31:28 cer Exp $
;; $fiHeader: dev-load-xm.lisp,v 1.2 92/02/24 13:09:42 cer Exp Locker: cer $
(excl::free (excl::malloc 131072))
......@@ -46,3 +46,8 @@
(tenuring
(load "test/test-suite")
(load "misc/clos-preload.fasl" :if-does-not-exist nil))
(load "demo/sysdcl")
(tenuring
(defsys::load-system 'clim-demo))
......@@ -19,7 +19,7 @@
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: classes.lisp,v 1.3 92/01/31 14:55:26 cer Exp $
;; $fiHeader: classes.lisp,v 1.4 92/02/24 13:04:22 cer Exp Locker: cer $
(in-package :silica)
......
......@@ -19,7 +19,7 @@
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: event.lisp,v 1.4 92/01/31 14:55:37 cer Exp $
;; $fiHeader: event.lisp,v 1.5 92/02/24 13:04:33 cer Exp Locker: cer $
(in-package :silica)
......@@ -339,6 +339,7 @@
:modifiers modifiers)))))
(let ((v (port-trace-thing port)))
;; Pop up the stack of sheets
;;(print "going up")
(unless (zerop (fill-pointer v))
(let ((m (if (eq (aref v 0) sheet)
(let ((new-x x)
......@@ -358,12 +359,24 @@
(unless (zerop i)
(generate-enter-event (aref v (1- i)))))
(setf (fill-pointer v) m)))
;; If its empty initialize it
;;(print "maybe going deeper")
(when (region-contains-point*-p
(sheet-region sheet) x y)
(sheet-region sheet) x y)
;;(print (cons "going deeper" v))
(when (zerop (fill-pointer v))
(vector-push-extend sheet v)
(generate-enter-event sheet))
;; We have to get the sheets into the correct coordinate
;; space
(loop for i from (1+ (position sheet v)) below (fill-pointer v)
do (multiple-value-setq
(x y)
(map-sheet-point*-to-child (aref v i) x y)))
;; Add children
(let ((new-x x)
(new-y y)
......@@ -390,6 +403,7 @@
(let ((sheet (let ((v (port-trace-thing port)))
(and (not (zerop (fill-pointer v)))
(aref v (1- (fill-pointer v)))))))
;;(print sheet)
(when (and sheet (sheet-port sheet))
(multiple-value-bind (tx ty)
(untransform-point*
......@@ -414,6 +428,8 @@
(:method (port (event keyboard-event))
(let ((focus (or (port-keyboard-input-focus port)
(event-sheet event))))
;;--- Is this correct???
(setf (slot-value event 'sheet) focus)
(dispatch-event focus event)))
(:method (port (event window-event))
(dispatch-event
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*-
;; $fiHeader: medium.lisp,v 1.5 92/01/31 14:55:44 cer Exp $
;; $fiHeader: medium.lisp,v 1.6 92/02/24 13:04:48 cer Exp Locker: cer $
(in-package :silica)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*-
;; $fiHeader: sysdcl.lisp,v 1.6 91/03/26 13:00:01 cer Exp $
;; $fiHeader: sysdcl.lisp,v 1.4 92/02/24 13:09:02 cer Exp Locker: cer $
(in-package #-ANSI-90 "USER" #+ANSI-90 :cl-user)
......@@ -277,6 +277,9 @@
:load-before-compile ("presentations"))
("ptypes2"
:load-before-compile ("translators"))
("excl-presentations"
:load-before-compile ("presentations")
:features Allegro)
(#-Cloe-Runtime "standard-types" #+Cloe-Runtime "std-typs"
:load-before-compile ("ptypes2"))
......@@ -486,6 +489,7 @@
("xt-gadgets")
("xm-gadgets")
("xm-menus")
("xm-cursor")
("xt-pixmaps"))
#+(and Silica Allegro)
......
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*-
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: silica; Base: 10; Lowercase: Yes -*-
;;
;; -[]-
;;
......@@ -20,26 +20,70 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: simple-test.lisp,v 1.3 92/02/16 20:55:44 cer Exp $
;; $fiHeader: simple-test.lisp,v 1.4 92/02/24 13:09:07 cer Exp Locker: cer $
(in-package :silica)
(setq port (find-port))
(setq graft (find-graft))
(defclass even-simpler (simple-sheet) ())
(setq sheet (make-instance 'standard-sheet
:parent graft
:region (make-bounding-rectangle 0 0 300 300)))
(defun simple-test ()
(let* ((port (find-port))
(graft (find-graft))
(sheet (make-instance 'standard-sheet
:parent graft
:region (make-bounding-rectangle 0 0 300 300))))
(dotimes (i 5)
(dotimes (j 5)
(let ((s (make-instance 'simple-sheet
:parent sheet
:region (make-bounding-rectangle 0 0 60 60)
:transformation
(make-translation-transformation (* i 60) (* j 60)))))
(setf (sheet-enabled-p s) t)
(let ((s2 (make-instance 'even-simpler
:parent s
:region (make-bounding-rectangle 0 0 40 40)
:transformation
(make-translation-transformation 10 10))))
(setf (sheet-enabled-p s2) t)))))
(setf (sheet-enabled-p sheet) t)
sheet))
(setf (sheet-enabled-p sheet) t)
(setq sheet1 (make-instance 'simple-sheet
:parent sheet
:region (make-bounding-rectangle 0 0 100 100)
:transformation
(make-translation-transformation 75 75)))
(defmethod handle-event ((sheet simple-sheet) (event pointer-enter-event))
(outline-sheet sheet)
(setf (port-keyboard-input-focus (sheet-port sheet)) sheet))
(defun outline-sheet (sheet)
(with-bounding-rectangle* (a b c d) sheet
(draw-rectangle*
sheet
a b (1- c) (1- d)
:filled nil
:ink +flipping-ink+)))
(setf (sheet-enabled-p sheet1) t)
(defmethod handle-event ((sheet simple-sheet) (event pointer-exit-event))
(outline-sheet sheet))
(defmethod handle-event ((sheet simple-sheet) (event pointer-button-event))
(multiple-value-call
#'draw-rectangle*
sheet
(bounding-rectangle* sheet)
:ink +flipping-ink+))
(defmethod handle-event ((sheet simple-sheet) (event keyboard-event))
(draw-line* sheet -200 -200 200 200 :ink +flipping-ink+
:line-thickness 10))
(defmethod repaint-sheet ((sheet even-simpler) region)
(declare (ignore region))
(multiple-value-call #'draw-rectangle*
sheet
(bounding-rectangle* sheet)
:filled t
:ink +red+))
;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-USER; Base: 10; Lowercase: Yes -*-
;; $fiHeader: test-suite.lisp,v 1.7 92/01/31 14:59:04 cer Exp Locker: cer $
;; $fiHeader: test-suite.lisp,v 1.10 92/02/24 13:09:09 cer Exp Locker: cer $
(in-package :clim-user)
......@@ -2514,6 +2514,9 @@ Luke Luck licks the lakes Luke's duck likes."))
(define-benchmark (simple-menu-choose :iterations 10) (stream)
"Pop up a simple menu of colors"
(without-clim-input
(if #+Allegro (typep (sheet-port stream) 'xm-silica::xt-port)
#-Allegro nil
(sleep 1) ;; Avoid division by zero!
(menu-choose '(("Red" :value +red+)
("Green" :value +green+)
("Blue" :value +blue+)
......@@ -2524,7 +2527,7 @@ Luke Luck licks the lakes Luke's duck likes."))
:label "Please choose a color"
:printer #'print-menu-item ;no Macintosh menus, please
:cache nil
:associated-window stream)))
:associated-window stream))))
(define-benchmark (cached-menu-choose :iterations 10) (stream)
"Pop up a cached menu of colors"
......
......@@ -18,7 +18,7 @@
;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xm-gadgets.lisp,v 1.10 92/02/14 18:57:42 cer Exp $
;; $fiHeader: xm-gadgets.lisp,v 1.11 92/02/24 13:06:18 cer Exp Locker: cer $
(in-package :xm-silica)
......@@ -476,4 +476,4 @@
(sheet motif-frame-pane))
(values 'tk::xm-frame nil))
......@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader$
;; $fiHeader: xm-cursor.lisp,v 1.1 92/02/25 16:52:41 cer Exp Locker: cer $
(in-package :xm-silica)
......@@ -38,9 +38,11 @@
(convert-to-device-coordinates transformation x y)
(cond ((and active state focus)
(tk::set-values blinker :x x :y y)
;;--- This should indicate that we do not have focus
(tk::manage-child blinker))
((and active state)
(tk::set-values blinker :x x :y y)
;;--- This should indicate that we do have focus
(tk::manage-child blinker))
(t
(tk::unmanage-child blinker)))))))))
......
......@@ -20,7 +20,7 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xt-graphics.lisp,v 1.7 92/02/16 20:55:18 cer Exp $
;; $fiHeader: xt-graphics.lisp,v 1.8 92/02/24 13:06:27 cer Exp Locker: cer $
(in-package :xm-silica)
......@@ -42,6 +42,10 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
sheet
(sheet-mirror sheet))))))
(defmethod silica::deallocate-medium :after (port (medium xt-medium))
(with-slots (drawable) medium
(setf drawable nil)))
(defmethod fetch-medium-drawable (sheet (mirror tk::xt-root-class))
(declare (ignore sheet))
(tk::widget-window mirror nil))
......@@ -294,39 +298,60 @@ U;; -*- mode: common-lisp; package: xm-silica -*-
(defmethod adjust-ink ((medium xt-medium) gc ink line-style x-origin y-origin)
;; This is used to adjust for the line-style
(declare (ignore ink))
(let ((thickness (line-style-thickness line-style)))
(when (< thickness 2)
(setq thickness 0))
(setf (tk::gcontext-line-width gc) (round thickness)))
#+++ignore ;---do this...
(let ((dashes (line-style-dashes line-style)))
(when dashes
(setf (tk::gcontext-dashes gc)
(cond ((eq dashes t) '(4 4))
((vectorp dashes) (coerce dashes 'list))
(t dashes)))))
(setf (tk::gcontext-cap-style gc)
(ecase (line-style-cap-shape line-style)
(:butt :butt)
(:square :projecting)
(:round :round)
(:no-end-point :not-last)))
;;-- This should just call the equivalent of xsetlineattributes to bash
;; everything in one go
(let* ((dashes (line-style-dashes line-style))
(gc-line-style
(etypecase dashes
((member nil t) :solid) (sequence :dash))))
(tk::set-line-attributes
gc
(let ((thickness (line-style-thickness line-style)))
(when (< thickness 2)
(setq thickness 0))
(round thickness))
gc-line-style
(ecase (line-style-cap-shape line-style)
(:butt :butt)
(:square :projecting)
(:round :round)
(:no-end-point :not-last))
(ecase (line-style-joint-shape line-style)
((:miter :none) :miter)
(:bevel :bevel)
(:round :round)))
(setf (tk::gcontext-join-style gc)
(ecase (line-style-joint-shape line-style)
((:miter :none) :miter)
(:bevel :bevel)
(:round :round)))
(when (eq gc-line-style :dash)
(setf (tk::gcontext-dashes gc) dashes))
(when (eq (tk::gcontext-fill-style gc) :tiled)
(setf (tk::gcontext-ts-x-origin gc) x-origin
(tk::gcontext-ts-y-origin gc) y-origin))
(let* ((sheet (medium-sheet medium))
(dr (sheet-device-region sheet))
(mcr (medium-clipping-region medium)))
(unless (eq mcr +everywhere+)
(setq mcr (transform-region (sheet-device-transformation sheet) mcr))
(setq dr (region-intersection dr (bounding-rectangle mcr))))
(cond ((eq dr +everywhere+)
(setf (tk::gcontext-clip-mask gc)
:none))
((eq dr +nowhere+)
(setf (tk::gcontext-clip-mask gc)
:nowhere))
(t
(with-bounding-rectangle*
(a b c d) dr
(with-stack-list (x
(integerize-coordinate a)
(integerize-coordinate b)
(integerize-coordinate (- c a))
(integerize-coordinate (- d b)))
(setf (tk::gcontext-clip-mask gc) x))))))
gc)
(when (eq (tk::gcontext-fill-style gc) :tiled)
(setf (tk::gcontext-ts-x-origin gc) x-origin
(tk::gcontext-ts-y-origin gc) y-origin))
gc))
(defmethod decode-ink :around ((ink t) (medium xt-medium))
(let ((gc (call-next-method)))
......
......@@ -20,7 +20,7 @@
;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as
;; applicable.
;;
;; $fiHeader: xt-silica.lisp,v 1.3 92/01/31 14:56:42 cer Exp $
;; $fiHeader: xt-silica.lisp,v 1.7 92/02/24 13:06:30 cer Exp Locker: cer $
(in-package :xm-silica)
......@@ -144,9 +144,12 @@
:parent parent
:managed (sheet-enabled-p sheet)
initargs)))
(add-sheet-callbacks port sheet widget)
(initialize-mirror port sheet widget)
widget))))
(defmethod initialize-mirror (port sheet widget)
(add-sheet-callbacks port sheet widget))
(defmethod add-sheet-callbacks ((port xt-port) sheet (widget t))
(declare (ignore sheet)))
......