diff --git a/clim/accept-values.lisp b/clim/accept-values.lisp index 9d03ca4e58ed8fcbd92fc88239ecb044245306cd..287ebe4a59b3b0828996b981f907b2b693711e1b 100644 --- a/clim/accept-values.lisp +++ b/clim/accept-values.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: accept-values.lisp,v 1.51 93/01/18 13:54:16 cer Exp $ +;; $fiHeader: accept-values.lisp,v 1.52 93/01/21 14:57:35 cer Exp $ (in-package :clim-internals) @@ -313,7 +313,8 @@ (initially-select-query-identifier nil) (modify-initial-query nil) align-prompts (resynchronize-every-pass nil) (check-overlapping t) - label x-position y-position width height) + label x-position y-position + width height (right-margin 10) (bottom-margin 10)) (incf *accept-values-tick*) (setq align-prompts (ecase align-prompts ((t :right) :right) @@ -321,9 +322,7 @@ ((nil) nil))) (let ((frame-manager (frame-manager stream)) (*current-accept-values-tick* *accept-values-tick*) - (the-own-window nil) - (right-margin 10) - (bottom-margin 10)) + (the-own-window nil)) ;; Create the AVV, run it, and return its values (if own-window (let ((frame (make-application-frame diff --git a/clim/command.lisp b/clim/command.lisp index 0410b0eac62f2dcc0707a71057a627ca20be0fa0..5609b389a974dceb6db9219b9e7f8f9f11100a24 100644 --- a/clim/command.lisp +++ b/clim/command.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: command.lisp,v 1.18 92/11/06 18:59:12 cer Exp $ +;; $fiHeader: command.lisp,v 1.19 92/12/14 15:02:00 cer Exp $ (in-package :clim-internals) @@ -517,8 +517,7 @@ (defun map-over-command-table-menu-items (function command-table) (declare (dynamic-extent function)) (map nil #'(lambda (entry) - (when (first entry) - (apply function entry))) + (apply function entry)) (slot-value (find-command-table command-table) 'menu))) (defun find-menu-item (menu-name command-table &key (errorp t)) diff --git a/clim/db-stream.lisp b/clim/db-stream.lisp index cd4aa3ede69e942611f560b97cf169126db2a142..de4ca4d5dc7b6dab7422249146d6ac74fcc1577b 100644 --- a/clim/db-stream.lisp +++ b/clim/db-stream.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-stream.lisp,v 1.43 93/01/18 13:54:20 cer Exp $ +;; $fiHeader: db-stream.lisp,v 1.44 93/01/21 14:57:47 cer Exp $ (in-package :clim-internals) @@ -321,8 +321,10 @@ label (label-alignment #+Genera :bottom #-Genera :top) (scroll-bars ':vertical) (borders t) (display-after-commands nil dac-p) + (background nil background-p) &allow-other-keys) - (setq options (remove-keywords options '(:type :scroll-bars :borders :label + (setq options (remove-keywords options '(:type :scroll-bars :borders + :label :background :label-alignment :display-after-commands))) (let* ((stream '#:clim-stream) @@ -331,31 +333,38 @@ `(:display-time ,(cond ((eq display-after-commands t) :command-loop) ((eq display-after-commands :no-clear) :no-clear) (t nil))))) + (background-var (and background (gensym))) (pane `(setq ,stream (make-pane ,type - ,@display-time - ,@options)))) + ,@display-time + ,@(and background-p `(:background ,background-var)) + ,@options)))) (when scroll-bars - (setq pane `(scrolling (:scroll-bars ,scroll-bars) + (setq pane `(scrolling (:scroll-bars ,scroll-bars ,@(and background-p `(:background ,background-var))) ,pane))) (when label (let ((label (if (stringp label) `(make-pane 'label-pane :label ,label - :max-width +fill+) + :max-width +fill+ + ,@(and background-p `(:background ,background-var))) `(make-pane 'label-pane :label ,(first label) - :max-width +fill+ ,@(rest label))))) + :max-width +fill+ ,@(rest label) + ,@(and background-p `(:background ,background-var)))))) (ecase label-alignment (:bottom - (setq pane `(vertically () ,pane ,label))) + (setq pane `(vertically (,@(and background-p `(:background ,background-var))) ,pane ,label))) (:top - (setq pane `(vertically () ,label ,pane)))))) + (setq pane `(vertically (,@(and background-p `(:background ,background-var))) ,label ,pane)))))) (when borders - (setq pane `(outlining (:thickness 1) + (setq pane `(outlining (:thickness 1 ,@(and background-p + `(:background + ,background-var))) #+Allegro ,pane #-Allegro (spacing (:thickness 1) ,pane)))) - `(let (,stream) + `(let ((,stream) + ,@(and background-p `((,background-var ,background)))) (values ,pane ,stream)))) (defmacro make-clim-interactor-pane (&rest options) diff --git a/clim/frames.lisp b/clim/frames.lisp index af1d4983d2d7e9d3cc929f6e72098ef4fe4e6a99..aa0e782911d77bae6bab78991f3dba24a2050b3d 100644 --- a/clim/frames.lisp +++ b/clim/frames.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: frames.lisp,v 1.57 93/01/18 13:54:26 cer Exp $ +;; $fiHeader: frames.lisp,v 1.58 93/01/21 14:57:55 cer Exp $ (in-package :clim-internals) @@ -168,10 +168,8 @@ (check-type disabled-commands list) (when (and pane panes) (error "The ~S and ~S options cannot be used together" :pane :panes)) - (when (and layouts - (null pane) - (null panes)) - (error "You must use either ~S or ~S with ~S" :pane :panes :layouts)) + (when (and layouts (null panes)) + (error "You must use ~S with ~S" :panes :layouts)) (when (null superclasses) (setq superclasses '(standard-application-frame))) (when (eq command-definer 't) @@ -1258,6 +1256,18 @@ (presentation-event-value event)) (beep sheet)))))) +(defun command-callback (function &rest arguments) + (cons #'(lambda (widget &rest args) (apply #'command-callback-1 function widget args)) arguments)) + +(defun command-callback-1 (function sheet &rest arguments) + (let ((frame (pane-frame sheet))) + (process-command-event + sheet + (make-instance 'presentation-event + :frame frame + :value (list* function sheet arguments) + :presentation-type `(command :command-table ,(frame-command-table frame)))))) + (defun queue-frame-command (frame command) (queue-push (frame-command-queue frame) command)) diff --git a/clim/gadget-output.lisp b/clim/gadget-output.lisp index f563be3653758a6808bbe4c2d0a9d36c5c69ea03..3e0dcb3209475e2554ebb25e397481d6cc9a1a3c 100644 --- a/clim/gadget-output.lisp +++ b/clim/gadget-output.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadget-output.lisp,v 1.42 92/12/03 10:26:40 cer Exp $ +;; $fiHeader: gadget-output.lisp,v 1.43 93/01/18 13:54:32 cer Exp $ (in-package :clim-internals) @@ -283,7 +283,7 @@ ;;--- number of items, etc. (if read-only (call-next-method) - +radio-box-view+)) + +radio-box-view+)) (define-presentation-method gadget-includes-prompt-p ((type completion) (stream t) (view radio-box-view)) diff --git a/clim/menus.lisp b/clim/menus.lisp index 96f910470ea25bb8ecc2bd2507e4b607dce5db38..5fd283a4f85e5dcf991a711541cf3307562f79c0 100644 --- a/clim/menus.lisp +++ b/clim/menus.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: menus.lisp,v 1.37 92/12/03 10:27:16 cer Exp $ +;; $fiHeader: menus.lisp,v 1.38 92/12/16 16:46:43 cer Exp $ (in-package :clim-internals) @@ -244,7 +244,7 @@ max-width max-height n-rows n-columns x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top) - pointer-documentation menu-type) + pointer-documentation menu-type gesture) (declare (values value chosen-item gesture)) (declare (ignore associated-window text-style default-item @@ -252,7 +252,7 @@ cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y - pointer-documentation menu-type)) + pointer-documentation menu-type gesture)) (declare (dynamic-extent keys)) (unless (zerop (length items)) (apply #'frame-manager-menu-choose (frame-manager *application-frame*) items keys))) @@ -270,9 +270,9 @@ max-width max-height n-rows n-columns x-spacing y-spacing (row-wise nil) (cell-align-x ':left) (cell-align-y ':top) - pointer-documentation menu-type) + pointer-documentation menu-type gesture) (declare (values value chosen-item gesture)) - (declare (ignore keys)) + (declare (ignore keys gesture)) (flet ((present-item (item stream) (present item presentation-type :stream stream))) (declare (dynamic-extent #'present-item)) diff --git a/clim/noting-progress.lisp b/clim/noting-progress.lisp index 960a0b0edc860141afe2101e1e2f801b882081af..5ac3b883b3e600189b7d2f35d692f4ce9fabf14d 100644 --- a/clim/noting-progress.lisp +++ b/clim/noting-progress.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: noting-progress.lisp,v 1.3 92/07/01 15:46:43 cer Exp $ +;; $fiHeader: noting-progress.lisp,v 1.4 92/07/08 16:30:44 cer Exp $ (in-package :clim-internals) @@ -51,12 +51,19 @@ (defmacro noting-progress ((stream name &optional (note-var '*current-progress-note*)) &body body) (check-type note-var symbol) - `(let (,note-var) - (unwind-protect - (progn - (setq ,note-var (add-progress-note ,name ,stream)) - ,@body) - (remove-progress-note ,note-var)))) + `(invoke-with-noting-progress + ,stream ,name #'(lambda (,note-var) ,@body))) + +(defun invoke-with-noting-progress (stream name continuation) + (let ((note (add-progress-note name stream))) + (unwind-protect + (frame-manager-invoke-with-noting-progress + (frame-manager *application-frame*) note continuation) + (remove-progress-note note)))) + +(defmethod frame-manager-invoke-with-noting-progress ((framem standard-frame-manager) + note continuation) + (funcall continuation note)) (defun note-progress (numerator &optional (denominator 1) (note *current-progress-note*)) (when note diff --git a/clim/output-protocol.lisp b/clim/output-protocol.lisp index a49780b11f3dfa1a8e4d3312411626d4d2e68a68..9c165af97e0df3973a67cfada35c0d1b6ce524cf 100644 --- a/clim/output-protocol.lisp +++ b/clim/output-protocol.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- -;; $fiHeader: output-protocol.lisp,v 1.32 93/01/11 15:44:49 colin Exp $ +;; $fiHeader: output-protocol.lisp,v 1.33 93/01/21 14:58:13 cer Exp $ (in-package :clim-internals) @@ -1088,7 +1088,7 @@ ;;; Input Editor support. This does STREAM-SCAN-STRING-FOR-WRITING and ;;; other stuff, and calls the continuation so the Input Editor can know ;;; where its strings are on the screen. -(Defmethod do-text-screen-real-estate ((stream output-protocol-mixin) continuation +(defmethod do-text-screen-real-estate ((stream output-protocol-mixin) continuation string start end cursor-x cursor-y height baseline style max-x) ;; Continuation is a function which takes L T R B Baseline diff --git a/demo/navfun.lisp b/demo/navfun.lisp index e9fc1d1631760bd03f5548ee6a4574c8bb3c8376..e96ece35856d1b5d555a00bd6403e708bdd83e37 100644 --- a/demo/navfun.lisp +++ b/demo/navfun.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- -;; $fiHeader: navfun.lisp,v 1.20 92/11/09 10:55:00 cer Exp $ +;; $fiHeader: navfun.lisp,v 1.22 92/11/20 08:45:30 cer Exp $ (in-package :clim-demo) @@ -1414,6 +1414,17 @@ (object) (list object)) +(define-flight-planner-command (com-foo-it :name t :menu t) + ((start 'route-start-object)&key (blah 'number)) + (print (cons start blah))) + +(define-presentation-to-command-translator foo-it + (route-start-object com-foo-it flight-planner + :gesture nil) + (object) + (list object :blah *unsupplied-argument-marker*)) + + (define-flight-planner-command (com-show-distance :name t :menu t) ((start 'route-start-object) (end 'route-start-object)) diff --git a/postscript/postscript-medium.lisp b/postscript/postscript-medium.lisp index 337aa4514f354e6530eee83b09908db39c0cc7b4..b4d70cf1eedf720aec73678b18a66ecc92d8b6df 100644 --- a/postscript/postscript-medium.lisp +++ b/postscript/postscript-medium.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-medium.lisp,v 1.11 92/12/16 16:48:16 cer Exp $ +;; $fiHeader: postscript-medium.lisp,v 1.12 93/01/21 14:58:47 cer Exp $ (in-package :postscript-clim) @@ -514,8 +514,9 @@ (al (length font-map)) (fcs (do ((i 0 (1+ i))) - ((>= i al) - (error "Font map overflow for ~S" medium)) + (nil) + (when (= i al) + (setq font-map (adjust-array font-map (setq al (+ al al)) :initial-element nil))) (let ((fcs (aref font-map i))) (when (null fcs) (setq fcs (make-new-fcs styledesc i)) diff --git a/postscript/postscript-port.lisp b/postscript/postscript-port.lisp index b8783eedab2448287177ecf42ae4db873a9da3f9..422953faefcd03c824e1f5869e4a3adfa24db066 100644 --- a/postscript/postscript-port.lisp +++ b/postscript/postscript-port.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: POSTSCRIPT-CLIM; Base: 10; Lowercase: Yes -*- -;; $fiHeader: postscript-port.lisp,v 1.13 92/12/16 16:48:19 cer Exp $ +;; $fiHeader: postscript-port.lisp,v 1.14 92/12/17 15:33:11 cer Exp $ (in-package :postscript-clim) @@ -472,7 +472,7 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (defvar *postscript-prologue* "statusdict /waittimeout 30 put -/fontarray 30 array def +/fontarray ~D array def /f {fontarray exch get setfont} def /estfont {findfont exch scalefont fontarray 3 1 roll put} def /m {moveto} def @@ -504,7 +504,7 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def hour minute second)) (format printer-stream "%%DocumentFonts: (atend)~%") (format printer-stream "%%EndComments~%") - (write-string *postscript-prologue* printer-stream) + (format printer-stream *postscript-prologue* (length (slot-value (port medium) 'font-map))) (ecase orientation (:portrait (format printer-stream @@ -806,10 +806,10 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def header-comments (orientation :portrait)) (assert (not (and multi-page scale-to-fit)) (multi-page scale-to-fit) - "You may not use both ~S and ~S" ':multi-page ':scale-to-fit) + "You may not use both ~S and ~S" ':multi-page ':scale-to-fit) (let* ((port (make-instance device-type)) (stream (make-instance 'postscript-stream - :multi-page multi-page)) + :multi-page multi-page)) (abort-p t)) (setf (port stream) port) (let ((medium (sheet-medium stream))) @@ -817,35 +817,39 @@ x y translate xra yra scale 0 0 1 sa ea arcp setmatrix end} def (with-output-recording-options (stream :record t :draw nil) (unwind-protect (multiple-value-prog1 - (funcall continuation stream) + (funcall continuation stream) (multiple-value-bind (width height) (bounding-rectangle-size (stream-output-history stream)) (let* ((page-width - (floor (* (slot-value port 'page-width) - (slot-value port 'device-units-per-inch)) - *1-pixel=points*)) + (floor (* (slot-value port 'page-width) + (slot-value port 'device-units-per-inch)) + *1-pixel=points*)) (page-height - (floor (* (slot-value port 'page-height) - (slot-value port 'device-units-per-inch)) - *1-pixel=points*)) + (floor (* (slot-value port 'page-height) + (slot-value port 'device-units-per-inch)) + *1-pixel=points*)) (scale-factor - (progn - (when (eq orientation :landscape) - (rotatef page-width page-height)) - (if (or (not scale-to-fit) - (and (< width page-width) - (< height page-height))) - 1 - (min (/ page-width width) - (/ page-height height)))))) - (postscript-prologue medium - :scale-factor scale-factor - :orientation orientation - :header-comments header-comments))) - ;; Now do the output to the printer, breaking up the output into - ;; multiple pages if that was requested - (with-output-recording-options (stream :record nil :draw t) - (stream-replay stream nil)) + (progn + (when (eq orientation :landscape) + (rotatef page-width page-height)) + (if (or (not scale-to-fit) + (and (< width page-width) + (< height page-height))) + 1 + (min (/ page-width width) + (/ page-height height)))))) + ;; Now do the output to the printer, breaking up the output into + ;; multiple pages if that was requested + (let ((string + (with-output-to-string (string-stream) + (letf-globally (((slot-value medium 'printer-stream) string-stream)) + (with-output-recording-options (stream :record nil :draw t) + (stream-replay stream nil)))))) + (postscript-prologue medium + :scale-factor scale-factor + :orientation orientation + :header-comments header-comments) + (write-string string (slot-value medium 'printer-stream))))) (setq abort-p nil)) (close stream :abort abort-p) (destroy-port port)))))) diff --git a/silica/db-border.lisp b/silica/db-border.lisp index 1afc9eadbbf09e2d5f12286cd3cc57755ca326f5..8b85b4b1c789ed00af8a48c44c4bae6bd2442902 100644 --- a/silica/db-border.lisp +++ b/silica/db-border.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-border.lisp,v 1.15 92/12/03 10:29:15 cer Exp $ +;; $fiHeader: db-border.lisp,v 1.16 92/12/16 16:48:32 cer Exp $ "Copyright (c) 1989, 1990 by Xerox Corporation. All rights reserved. Portions copyright (c) 1991, 1992 by Symbolics, Inc. All rights reserved." @@ -32,15 +32,23 @@ (move-and-resize-sheet (sheet-child pane) thickness thickness - (- width (* 2 thickness)) (- height (* 2 thickness))))) + (- width (* 2 thickness)) (- height (* 2 thickness))) + (repaint-border-pane pane))) (defmethod handle-repaint ((pane border-pane) region) - (declare (ignore region)) ;not worth checking + (declare (ignore region)) ;not worth checking + (repaint-border-pane pane)) + +(defun repaint-border-pane (pane) (with-sheet-medium (medium pane) - (with-bounding-rectangle* (left top right bottom) (sheet-region pane) - (let ((thickness (slot-value pane 'thickness))) - (decf right (ceiling thickness 2)) - (decf bottom (ceiling thickness 2)) + (with-bounding-rectangle* (left top right bottom) + (sheet-region pane) + (let* ((thickness (slot-value pane 'thickness)) + (ht (ceiling thickness 2))) + (incf left ht) + (incf top ht) + (decf right ht) + (decf bottom ht) (draw-rectangle* medium left top right bottom :line-thickness thickness :filled nil :ink (pane-background pane)))))) diff --git a/silica/db-box.lisp b/silica/db-box.lisp index d40e0affb7391f17ffe2441db9b466f903b166c2..22b5fb371a4529b19b9837cde1a5f8976991264c 100644 --- a/silica/db-box.lisp +++ b/silica/db-box.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: db-box.lisp,v 1.21 92/09/08 10:34:17 cer Exp $ +;; $fiHeader: db-box.lisp,v 1.22 92/09/24 09:37:28 cer Exp $ (in-package :silica) @@ -179,3 +179,49 @@ #---ignore (declare (ignore available where-we-are-now)) #---ignore wanted-size #+++ignore (min wanted-size (1- (- available where-we-are-now)))) + +;;; Bulletin board +;;; Is there any value in this??? +;;; What do we want it to do? +;;; Panes are just as big as they want to be and where they want to be. +;;; Could specify position and size in turns of relative coordinates. +;;; + +(defclass bulletin-board-pane (layout-pane) + ((contents :initarg :contents))) + +(defmacro bulletin-board (options &rest contents) + `(make-pane 'bulletin-board-pane + :contents (list ,@contents) + ,@options)) + +(defmethod initialize-instance :after ((pane bulletin-board-pane) &key contents) + (dolist (content contents) + (destructuring-bind (x y child) content + (declare (ignore x y)) + (sheet-adopt-child pane child)))) + +(defmethod compose-space ((pane bulletin-board-pane) &key width height) + (declare (ignore width height)) + (with-slots (contents) pane + (let ((max-x 0) + (max-y 0)) + (dolist (content contents) + (destructuring-bind (x y pane) content + (let ((sr (compose-space pane))) + (maxf max-x (+ x (space-requirement-width sr))) + (maxf max-y (+ y (space-requirement-height sr)))))) + (make-space-requirement :width max-x :height max-y)))) + + +(defmethod allocate-space ((pane bulletin-board-pane) width height) + (declare (ignore width height)) + (with-slots (contents) pane + (dolist (content contents) + (destructuring-bind (x y pane) content + (let ((sr (compose-space pane))) + (move-and-resize-sheet + pane x y + (space-requirement-width sr) + (space-requirement-height sr))))))) + diff --git a/silica/framem.lisp b/silica/framem.lisp index b6f29c819054ed93095963b3b6cbd39ff2349cd2..96d5ed5cebd744528d4ae773b5e53bba4d893ba5 100644 --- a/silica/framem.lisp +++ b/silica/framem.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: framem.lisp,v 1.25 92/11/19 14:24:57 cer Exp $ +;; $fiHeader: framem.lisp,v 1.26 92/12/03 10:29:21 cer Exp $ (in-package :silica) @@ -27,7 +27,7 @@ ;;--- This is most likely wrong, since it forces a 1-to-1 mapping ;;--- between ports and grafts (defmethod graft ((framem standard-frame-manager)) - (car (port-grafts (port framem)))) + (find-graft :port (port framem))) (defvar *default-frame-manager* nil) diff --git a/silica/gadgets.lisp b/silica/gadgets.lisp index 335a7a37f26b91dc434a94cc6d8bfcd47ab50f9b..ce776394a80c889767006526f7f0ca899fc5d462 100644 --- a/silica/gadgets.lisp +++ b/silica/gadgets.lisp @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: gadgets.lisp,v 1.43 92/12/16 16:49:26 cer Exp $ +;; $fiHeader: gadgets.lisp,v 1.44 93/01/21 14:59:03 cer Exp $ "Copyright (c) 1991, 1992 by Franz, Inc. All rights reserved. Portions copyright (c) 1992 by Symbolics, Inc. All rights reserved." @@ -343,10 +343,13 @@ ;;; Caption ;;; Option menu +(defclass row-column-gadget-mixin (oriented-gadget-mixin) + ((rows :initarg :rows :initform nil :accessor gadget-rows) + (columns :initarg :columns :initform nil :accessor gadget-columns))) ;;; Radio box [exclusive-choice] .. [inclusive-choice] (defclass radio-box - (value-gadget oriented-gadget-mixin) + (value-gadget row-column-gadget-mixin) ((selections :initform nil :reader radio-box-selections) ;;--- think about this... @@ -392,7 +395,7 @@ ;;; Check-box (defclass check-box - (value-gadget oriented-gadget-mixin) + (value-gadget row-column-gadget-mixin) ((selections :initform nil :reader check-box-selections) ;;--- think about this... @@ -445,8 +448,10 @@ ((ncolumns :initarg :ncolumns :accessor gadget-columns) (nlines :initarg :nlines - :accessor gadget-lines)) - (:default-initargs :ncolumns 1 :nlines 1 :editable-p t)) + :accessor gadget-lines) + (word-wrap :initarg :word-wrap + :accessor gadget-word-wrap)) + (:default-initargs :ncolumns 1 :nlines 1 :editable-p t :word-wrap nil)) ;;; Viewport diff --git a/silica/mirror.lisp b/silica/mirror.lisp index 46163e976201323c0b9852cd1a41f11ad5120dc6..334c6294c9073fb96e59eebe285a3a3a9cba1ee4 100644 --- a/silica/mirror.lisp +++ b/silica/mirror.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: mirror.lisp,v 1.27 92/09/24 09:37:47 cer Exp $ +;; $fiHeader: mirror.lisp,v 1.28 92/10/02 15:18:29 cer Exp $ (in-package :silica) @@ -159,8 +159,6 @@ (defgeneric mirror-region* (port sheet) (declare (values left top right bottom))) -(defgeneric set-mirror-region* (port sheet minx miny maxx maxy)) - ;; Returns the coordinates of sheet's mirror in the coordinates of the ;; mirror itself. That is, it will return 0,0,WIDTH,HEIGHT for most ;; known window systems @@ -175,12 +173,6 @@ (multiple-value-call #'make-bounding-rectangle (mirror-region* port sheet))) -;; Returns the mirror's region in its parents coordinate space -(defgeneric mirror-edges* (port sheet)) - -;; Sets the mirror's region in its parents coordinate space -(defgeneric set-mirror-edges* (port sheet minx miny maxx maxy)) - (defmethod mirror-origin ((port basic-port) (sheet basic-sheet)) :nw) diff --git a/silica/pixmaps.lisp b/silica/pixmaps.lisp index 310ffcac2a20a19224ec937b4629674c47979429..d47a86ec0d7035e6d32d6778ad6623666e3ec1d9 100644 --- a/silica/pixmaps.lisp +++ b/silica/pixmaps.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: pixmaps.lisp,v 1.13 92/10/28 11:30:51 cer Exp $ +;; $fiHeader: pixmaps.lisp,v 1.14 92/12/03 10:29:30 cer Exp $ (in-package :silica) @@ -119,9 +119,10 @@ :medium pixmap-medium :width width :height height))) ;;--- Is this a waste of time if this does not have a medium? - (with-sheet-medium (medium sheet) - (setf (medium-foreground pixmap-medium) (medium-foreground medium) - (medium-background pixmap-medium) (medium-background medium))) + (when (typep sheet 'sheet-with-medium-mixin) + (with-sheet-medium (medium sheet) + (setf (medium-foreground pixmap-medium) (medium-foreground medium) + (medium-background pixmap-medium) (medium-background medium)))) (funcall continuation pixmap-sheet) (slot-value pixmap-medium 'pixmap))) diff --git a/silica/sheet.lisp b/silica/sheet.lisp index a3b39f6293522b206dbcea17983660929e2de92c..e0df5cec17b6067384d3f7321ecc9b9fee080c5c 100644 --- a/silica/sheet.lisp +++ b/silica/sheet.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- -;; $fiHeader: sheet.lisp,v 1.33 92/12/03 10:29:34 cer Exp $ +;; $fiHeader: sheet.lisp,v 1.34 92/12/16 16:49:48 cer Exp $ (in-package :silica) @@ -245,24 +245,6 @@ (sheet-transformation child) left top right bottom))) (funcall function child)))))) -(defgeneric children-overlapping-rectangle* (sheet min-x min-y max-x max-y)) - -(defgeneric delta-transformation (sheet ancestor)) -(defmethod delta-transformation ((sheet basic-sheet) ancestor) - (let ((parent (sheet-parent sheet))) - (cond - ((eq parent ancestor) - (sheet-transformation sheet)) - ((null parent) - (error "in delta transformation: ~S,~S" - sheet parent)) - (t - (compose-transformations - (sheet-transformation sheet) - (delta-transformation parent ancestor)))))) - -(defgeneric allocated-region (sheet child)) - ;;;; (defclass sheet-identity-transformation-mixin () ()) @@ -374,7 +356,6 @@ (invalidate-cached-transformations sheet) (invalidate-cached-regions sheet)) -(defgeneric update-native-transformation (port sheet)) (defmethod (setf sheet-enabled-p) :after (enabled (sheet basic-sheet)) (if enabled @@ -384,6 +365,29 @@ (defmethod sheet-enabled-children ((sheet sheet-parent-mixin)) (remove-if-not #'sheet-enabled-p (sheet-children sheet))) +(defmethod sheet-siblings ((sheet basic-sheet)) + (let ((parent (sheet-parent sheet))) + (assert parent () "Sheet must have parent") + (remove sheet (sheet-children parent)))) + +(defmethod sheet-ancestor-p ((sheet basic-sheet) (ancestor basic-sheet)) + (do ((sheet sheet (sheet-parent sheet))) + ((or (null sheet) + (eq sheet ancestor)) + (and sheet t)))) + +(defmethod sheet-viewable-p ((sheet basic-sheet)) + (do ((sheet sheet (sheet-parent sheet))) + ((graftp sheet) t) + (unless (sheet-enabled-p sheet) (return nil)))) + +(defmethod sheet-occluding-sheets ((sheet basic-sheet) (child basic-sheet)) + (let ((sheets nil) + (r (transform-region (sheet-transformation child) (sheet-region child)))) + (dolist (child1 (sheet-children sheet) (error "Sheet ~S is not the parent of ~S" sheet child)) + (cond ((eq child1 child) (return (nreverse sheets))) + ((region-intersects-region-p r (transform-region (sheet-transformation child1) (sheet-region child1))) + (push child1 r)))))) ;;; Making sheets diff --git a/test/test.lisp b/test/test.lisp index 57e6eb8225cf95a6ad44b97b68a490cf6b37775e..50d637323ff719ae3da314ccfa80162a573fab3a 100644 --- a/test/test.lisp +++ b/test/test.lisp @@ -19,7 +19,7 @@ ;; 52.227-19 or DOD FAR Suppplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: test.lisp,v 1.42 92/11/19 14:25:18 cer Exp $ +;; $fiHeader: test.lisp,v 1.43 92/12/03 10:29:53 cer Exp $ (in-package :clim-user) @@ -27,15 +27,20 @@ (define-application-frame test-frame () () (:pane - (vertically () - (make-clim-interactor-pane - :foreground +green+ - :background +red+) - (make-pane 'push-button - :label "press me" - :background +black+ - :foreground +cyan+ - :text-style (make-text-style :serif :roman 20))))) + (vertically () + (make-clim-interactor-pane + :foreground +green+ + :background +red+) + (make-pane 'push-button + :label (with-output-to-pixmap (stream (graft *application-frame*) :width 100 :height 100) + (draw-rectangle* stream 0 0 100 100 :ink +background-ink+) + (draw-rectangle* stream 10 10 90 90 :ink +red+))) + (make-pane 'push-button + :label "press me" + :activate-callback (command-callback #'(lambda (gadget) (print :hello))) + :background +black+ + :foreground +cyan+ + :text-style (make-text-style :serif :roman 20))))) ;;; Some commands @@ -369,17 +374,19 @@ (clim:define-application-frame tf100 () () (:command-table test-frame) (:pane - (vertically () - (outlining () - (scrolling () - (make-pane 'text-editor - :value "c sucks" - :ncolumns 30 :nlines 10))) - (outlining () - (scrolling () - (make-pane 'text-editor - :value "unix sucks more" - :ncolumns 30 :nlines 10)))))) + (vertically () + (outlining () + (scrolling () + (make-pane 'text-editor + :word-wrap nil + :value "c sucks" + :ncolumns 30 :nlines 10))) + (outlining () + (scrolling () + (make-pane 'text-editor + :word-wrap t + :value "unix sucks more" + :ncolumns 30 :nlines 10)))))) (define-application-frame tf99 () () (:command-table test-frame) @@ -981,3 +988,25 @@ :view +slider-view+ :stream stream :prompt "XXXX"))))) + + +(define-application-frame tf107 () () + (:command-table test-frame) + (:pane + (bulletin-board () + (list 10 10 (make-clim-interactor-pane + :height '(10 :line) + :width '(50 :character) + :foreground +green+ + :background +red+)) + (list 50 200 (make-pane 'push-button + :label (with-menu (menu (graft *application-frame*)) + (with-output-to-pixmap (stream menu :width 100 :height 100) + (draw-rectangle* stream 0 0 100 100 :ink +background-ink+) + (draw-rectangle* stream 10 10 90 90 :ink +red+))))) + (list 90 300 (make-pane 'push-button + :label "press me" + :background +black+ + :foreground +cyan+ + :text-style (make-text-style :serif + :roman 20)))))) diff --git a/tk-silica/ol-gadgets.lisp b/tk-silica/ol-gadgets.lisp index 78ca1ab8fd1f3dce77ed1680113a48e43c686fd7..1082b5fc3fe3469beda37ca941517e8917dc3cb8 100644 --- a/tk-silica/ol-gadgets.lisp +++ b/tk-silica/ol-gadgets.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: ol-gadgets.lisp,v 1.36 92/12/16 16:50:43 cer Exp $ +;; $fiHeader: ol-gadgets.lisp,v 1.37 93/01/18 13:58:07 cer Exp $ (in-package :xm-silica) @@ -364,7 +364,6 @@ (unless top (apply #'make-instance 'xt::static-text :parent parent - :managed nil :string " " options))) (:function @@ -899,13 +898,19 @@ (with-accessors ((value gadget-value) (ncolumns gadget-columns) (nlines gadget-lines) - (editable gadget-editable-p)) sheet + (editable gadget-editable-p) + (word-wrap gadget-word-wrap)) sheet (values 'tk::text-edit (append (and (not editable) `(:edit-type :text-read)) (and ncolumns (list :chars-visible ncolumns)) (and nlines (list :lines-visible nlines)) - (and value `(:source ,value)))))) + (and value `(:source ,value)) + (list :wrap-mode (if word-wrap :wrap-white-space :wrap-off)))))) + +(defmethod (setf gadget-word-wrap) :after (nv (gadget openlook-text-editor)) + (tk::set-values (sheet-direct-mirror gadget) + :wrap-mode (if word-wrap :wrap-white-space :wrap-off))) (defmethod add-sheet-callbacks :after ((port openlook-port) (sheet openlook-text-editor) diff --git a/tk-silica/xm-frames.lisp b/tk-silica/xm-frames.lisp index afe149259ae1403b19fde17e08f271ddafb91093..b67c8731527c690a14b7ec0d053e00b9a78eaa68 100644 --- a/tk-silica/xm-frames.lisp +++ b/tk-silica/xm-frames.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-frames.lisp,v 1.45 93/01/11 15:46:14 colin Exp $ +;; $fiHeader: xm-frames.lisp,v 1.46 93/01/21 14:59:19 cer Exp $ (in-package :xm-silica) @@ -210,9 +210,7 @@ (let ((type (command-menu-item-type item))) (case type (:divider - (make-instance 'tk::xm-separator - :managed nil - :parent menu)) + (make-instance 'tk::xm-separator :parent parent)) (:function ;;--- Do this sometime ) @@ -342,7 +340,8 @@ presentation-type associated-window text-style - label) + label + gesture) (let* (value-returned return-value (simplep (and (null printer) @@ -353,8 +352,12 @@ (sheet-mirror associated-window)) (port-application-shell port)) - ;;---------- Hard decision - ;; :menu-post "<Btn1Down>" + :menu-post (case (and gesture + (gesture-name-button-and-modifiers gesture)) + (#.+pointer-left-button+ "<Btn1Down>") + (#.+pointer-middle-button+ "<Btn2Down>") + (#.+pointer-right-button+ "<Btn3Down>") + (t "<Btn1Down>")) :managed nil)) (font (and text-style (text-style-mapping (port framem) text-style))) (font-list (and (or label simplep) font (list :font-list (list font))))) @@ -414,7 +417,6 @@ (ecase (clim-internals::menu-item-type item) (:divider (make-instance 'xt::xm-separator - :managed nil :parent menu)) (:label (make-instance 'xt::xm-label @@ -482,3 +484,15 @@ ;;;; + +#| + +(defmethod frame-manager-clear-progress-note + ((framem motif-frame-manager) (note progress-note)) + ) + +(defmethod frame-manager-display-progress-note + ((framem motif-frame-manager) (note progress-note)) + ) + +|# diff --git a/tk-silica/xm-gadgets.lisp b/tk-silica/xm-gadgets.lisp index f255c746cf602bc51eab3dfd83c7b4b792498565..5fe197ee00dbfde1678204b6765d42959fd8d6a0 100644 --- a/tk-silica/xm-gadgets.lisp +++ b/tk-silica/xm-gadgets.lisp @@ -18,7 +18,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xm-gadgets.lisp,v 1.61 93/01/11 15:46:18 colin Exp $ +;; $fiHeader: xm-gadgets.lisp,v 1.62 93/01/21 14:59:24 cer Exp $ (in-package :xm-silica) @@ -250,6 +250,9 @@ (defclass motif-oriented-sliding-gadget (xt-oriented-gadget) ()) + +;;; + (defmethod set-widget-orientation ((gadget motif-oriented-sliding-gadget) nv) (tk::set-values (sheet-direct-mirror gadget) :processing-direction @@ -539,7 +542,8 @@ (with-accessors ((value gadget-value) (editable gadget-editable-p) (ncolumns gadget-columns) - (nlines gadget-lines)) sheet + (nlines gadget-lines) + (word-wrap gadget-word-wrap)) sheet (let ((scroll-mode (let ((p (sheet-parent sheet))) (and (typep p 'motif-scroller-pane) @@ -553,7 +557,11 @@ (list :editable editable) (and ncolumns (list :columns ncolumns)) (and nlines (list :rows nlines)) - (and value `(:value ,value))))))) + (and value `(:value ,value)) + (and word-wrap `(:word-wrap t))))))) + +(defmethod (setf gadget-word-wrap) :after (nv (gadget motif-text-editor)) + (tk::set-values (sheet-direct-mirror gadget) :word-wrap (and nv t))) (defmethod (setf gadget-editable-p) :after (nv (te motif-text-editor)) (let ((m (sheet-direct-mirror te))) @@ -681,6 +689,23 @@ viewport) ()) +;;; + +(defclass motif-row-column-gadget-mixin (xt-oriented-gadget) + ()) + +(defmethod find-widget-class-and-initargs-for-sheet :around ((port motif-port) + (parent t) + (sheet motif-row-column-gadget-mixin)) + (multiple-value-bind (class initargs) + (let ((x (ecase (gadget-orientation sheet) + (:vertical (gadget-columns sheet)) + (:horizontal (gadget-rows sheet))))) + (when x (setf (getf initargs :num-columns) x))) + (values class initargs))) + +;;; + (defmethod find-widget-class-and-initargs-for-sheet ((port motif-port) (parent t) (sheet xm-viewport)) @@ -755,7 +780,8 @@ ; (move-and-resize-sheet (sheet-child fr) 0 0 width height)) -(defclass motif-frame-pane (motif-geometry-manager +(defclass motif-frame-pane (foreground-background-and-text-style-mixin + motif-geometry-manager mirrored-sheet-mixin sheet-single-child-mixin sheet-permanently-enabled-mixin @@ -1442,11 +1468,15 @@ (sheet-adopt-child sp contents) (with-look-and-feel-realization (frame-manager frame) (when (member scroll-bars '(:both :dynamic :vertical)) - (let ((sb (make-pane 'scroll-bar :orientation :vertical :id :vertical :client sp))) + (let ((sb (make-pane 'scroll-bar + :background (pane-background sp) + :orientation :vertical :id :vertical :client sp))) (setf (scroller-pane-vertical-scroll-bar sp) sb) (sheet-adopt-child sp sb))) (when (member scroll-bars '(:both :dynamic :horizontal)) - (let ((sb (make-pane 'scroll-bar :orientation :horizontal :id :horizontal :client sp))) + (let ((sb (make-pane 'scroll-bar + :background (pane-background sp) + :orientation :horizontal :id :horizontal :client sp))) (setf (scroller-pane-horizontal-scroll-bar sp) sb) (sheet-adopt-child sp sb))) (sheet-adopt-child sp (setf (slot-value sp 'viewport) (make-pane 'viewport :scroller-pane sp))) diff --git a/tk-silica/xt-frames.lisp b/tk-silica/xt-frames.lisp index 1e75a96fe0a9fb8036a9038b35cd86617cfbc2b9..e6670136ff26042b342cfbd4fe66518ced3404bb 100644 --- a/tk-silica/xt-frames.lisp +++ b/tk-silica/xt-frames.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-frames.lisp,v 1.26 93/01/18 13:58:10 cer Exp $ +;; $fiHeader: xt-frames.lisp,v 1.27 93/01/21 14:59:28 cer Exp $ (in-package :xm-silica) @@ -103,7 +103,8 @@ (unique-id items) (id-test 'equal) (cache-value items) - (cache-test #'equal)) + (cache-test #'equal) + gesture) (declare (ignore keys)) (declare (values value chosen-item gesture)) (let ((port (port framem)) @@ -133,7 +134,8 @@ presentation-type associated-window text-style - label)) + label + gesture)) (when cache (push (list unique-id menu closure) (frame-manager-menu-cache framem)))) diff --git a/tk-silica/xt-gadgets.lisp b/tk-silica/xt-gadgets.lisp index 13adcedbee8c2ee18a22c5e987742b9d88b5e3c0..f2a774f55bcf423e844957ef24ef764b1e86c281 100644 --- a/tk-silica/xt-gadgets.lisp +++ b/tk-silica/xt-gadgets.lisp @@ -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.27 93/01/11 15:46:24 colin Exp $ +;; $fiHeader: xt-gadgets.lisp,v 1.28 93/01/18 13:58:13 cer Exp $ (in-package :xm-silica) @@ -70,17 +70,17 @@ ;; decode-gadget-background ;; decode-gadget-foreground - (when silica::background + (when (or silica::background silica::foreground) (with-sheet-medium (medium sheet) - (setf initargs - (append (decode-gadget-background medium sheet silica::background) - initargs)))) + (when silica::background + (setf initargs + (append (decode-gadget-background medium sheet silica::background) + initargs))) - (when silica::foreground - (with-sheet-medium (medium sheet) - (setf initargs - (append (decode-gadget-foreground medium sheet silica::foreground) - initargs)))) + (when silica::foreground + (setf initargs + (append (decode-gadget-foreground medium sheet silica::foreground) + initargs))))) (if text-style (setf (getf initargs :font-list) diff --git a/tk-silica/xt-pixmaps.lisp b/tk-silica/xt-pixmaps.lisp index 4febd99d2d06c9206f41cc8e9f8b57808f6bf46d..300128d9b5afea6bf67d73b3f5adfc336ec328df 100644 --- a/tk-silica/xt-pixmaps.lisp +++ b/tk-silica/xt-pixmaps.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xt-pixmaps.lisp,v 1.12 92/11/13 14:47:24 cer Exp $ +;; $fiHeader: xt-pixmaps.lisp,v 1.13 92/12/03 10:30:26 cer Exp $ (in-package :xm-silica) @@ -36,7 +36,7 @@ :depth (tk::drawable-depth root)))) (defmethod port-deallocate-pixmap ((port xt-port) (pixmap tk::pixmap)) - (break "implement me")) + (x11:xfreepixmap pixmap)) (defmethod pixmap-width ((pixmap tk::pixmap)) (tk::pixmap-width pixmap)) @@ -51,8 +51,7 @@ (defclass xt-pixmap-medium (xt-medium basic-pixmap-medium) ()) (defmethod make-pixmap-medium ((port xt-port) sheet &key width height) - (let* ((pixmap (with-sheet-medium (medium sheet) - (port-allocate-pixmap port medium width height))) + (let* ((pixmap (port-allocate-pixmap port sheet width height)) (medium (make-instance 'xt-pixmap-medium :port port :sheet sheet diff --git a/tk-silica/xt-silica.lisp b/tk-silica/xt-silica.lisp index b2401ce9c2cc12499ac691fdcb5494ffa5d0ed92..0d2f1323f7ecd5282f4dc6b2d1dbcc9d78e7eed6 100644 --- a/tk-silica/xt-silica.lisp +++ b/tk-silica/xt-silica.lisp @@ -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.67 93/01/11 15:46:36 colin Exp $ +;; $fiHeader: xt-silica.lisp,v 1.68 93/01/21 14:59:36 cer Exp $ (in-package :xm-silica) @@ -1595,7 +1595,7 @@ the geometry of the children. Instead the parent has control. ")) ;;;---- Cursor stuff -(defvar *clx-cursor-type-alist* +(defvar *xt-cursor-type-alist* '((:default 132) (:vertical-scroll 116) (:scroll-up 114) @@ -1657,7 +1657,7 @@ the geometry of the children. Instead the parent has control. ")) (call-next-method))))) (defmethod realize-cursor ((port xt-port) (cursor symbol)) - (let ((cursor (or (second (assoc cursor *clx-cursor-type-alist*)) + (let ((cursor (or (second (assoc cursor *xt-cursor-type-alist*)) 132))) (realize-cursor port cursor))) @@ -1722,3 +1722,9 @@ the geometry of the children. Instead the parent has control. ")) (check-type x (signed-byte 16)) (check-type y (signed-byte 16)) (tk::set-values (frame-shell frame) :x x :y y)) + +(defmethod destroy-port ((port xt-port)) + (when (port-process port) + (clim-sys:destroy-process (port-process port))) + (port-terminated port (make-condition 'error))) + diff --git a/tk/make-classes.lisp b/tk/make-classes.lisp index eabd955bb9939909368b495002cca5a58ef29a27..4fb732d102ebb57084f6dfacfeccf6e775d8c844 100644 --- a/tk/make-classes.lisp +++ b/tk/make-classes.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: make-classes.lisp,v 1.27 92/12/14 15:03:53 cer Exp $ +;; $fiHeader: make-classes.lisp,v 1.28 93/01/11 15:45:42 colin Exp $ (in-package :tk) @@ -35,6 +35,10 @@ (let ((x (make-array 1 :element-type '(unsigned-byte 32))) (y (make-array 1 :element-type '(unsigned-byte 32))) result) + ;;--- Perhaps we can just do this when we want to grab the resources. + ;;--- In this way we would only have to do one the display is + ;;--- opened and the toolkit initialized etc etc. + (xt_initialize_widget_class (class-handle class)) (funcall fn (class-handle class) x y) (let ((resources (aref x 0)) (n (aref y 0))) @@ -188,11 +192,7 @@ #+ignore (format excl:*initial-terminal-io* ";; Initializing class ~s~%" class-ep) (let ((h (get-foreign-variable-value class-ep))) - (push (list h class-ep) clist) - ;;--- Perhaps we can just do this when we want to grab the resources. - ;;--- In this way we would only have to do one the display is - ;;--- opened and the toolkit initialized etc etc. - (xt_initialize_widget_class h))) + (push (list h class-ep) clist))) (setq clist (nreverse clist)) (do ((cs clist (cdr cs)) diff --git a/tk/xlib.lisp b/tk/xlib.lisp index f62eea99aed885cef9b91590d275d41b870acfe9..fe6a22da2bb7a0b4cf32e0c8a6f5d84077510678 100644 --- a/tk/xlib.lisp +++ b/tk/xlib.lisp @@ -20,7 +20,7 @@ ;; 52.227-19 or DOD FAR Supplement 252.227-7013 (c) (1) (ii), as ;; applicable. ;; -;; $fiHeader: xlib.lisp,v 1.37 92/12/16 16:50:29 cer Exp $ +;; $fiHeader: xlib.lisp,v 1.38 93/01/11 15:45:55 colin Exp $ (in-package :tk) @@ -260,13 +260,17 @@ (:report report-x-connection-lost)) (defun report-x-connection-lost (condition stream) - (let ((display (x-error-display condition))) - (format stream "Xlib: Connection to X11 server '~a' lost" - (ff:char*-to-string (x11:display-display-name display))))) + (let ((display (x-error-display condition))) + (format stream "Xlib: Connection to X11 server '~a' lost" + (ff:char*-to-string (x11:display-display-name display))))) + +(defvar *inside-event-wait-function* nil) (defun-c-callable x-io-error-handler ((display :unsigned-long)) - (let ((*error-output* excl:*initial-terminal-io*)) - (error 'x-connection-lost :display display))) + (if *inside-event-wait-function* + (throw *inside-event-wait-function* :error) + (let ((*error-output* excl:*initial-terminal-io*)) + (error 'x-connection-lost :display display)))) diff --git a/utils/packages.lisp b/utils/packages.lisp index 9e52426b259dd047bc979d64bc0492b354d91c86..da4efcc9dc0fecffb003d331ff1b001a963750d7 100644 --- a/utils/packages.lisp +++ b/utils/packages.lisp @@ -1,6 +1,6 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CL-USER; Base: 10; Lowercase: Yes -*- -;; $fiHeader: packages.lisp,v 1.45 92/12/16 16:51:14 cer Exp $ +;; $fiHeader: packages.lisp,v 1.46 93/01/21 14:59:44 cer Exp $ (in-package #-ANSI-90 :user #+ANSI-90 :common-lisp-user) @@ -38,7 +38,7 @@ class-of class-precedence-list class-prototype - class-slots + class-slots #+PCL classp compute-applicable-methods defclass @@ -2772,7 +2772,8 @@ ;; Panes +fill+ allocate-space - bboard-pane + bulletin-board-pane + bulletin-board border-pane bordering change-space-requirements @@ -2842,6 +2843,7 @@ check-box-current-selection check-box-pane check-box-selections + command-callback deactivate-gadget disarmed-callback drag-callback @@ -3413,6 +3415,7 @@ gadget-lines gadget-supplied-scrolling gadget-visible-items + gadget-word-wrap generic-label-pane generic-list-pane generic-option-pane