From 4b96fab1838fb631292ef626667099684d8224e0 Mon Sep 17 00:00:00 2001 From: cer <cer> Date: Wed, 19 Aug 1992 10:29:27 +0000 Subject: [PATCH] Initial revision --- clim/db-menu.lisp | 332 ++++ cloe/sysdcl.lisp | 29 + clx/sysdcl.lisp | 48 + compatibility/clim1-compatibility.lisp | 1938 ++++++++++++++++++++++++ compatibility/packages.lisp | 115 ++ compatibility/sysdcl.lisp | 23 + demo/color-editor.lisp | 164 ++ genera/sysdcl.lisp | 31 + misc/xtsupport.c | 90 ++ postscript/sysdcl.lisp | 27 + sys/load-clim2.lisp | 92 ++ 11 files changed, 2889 insertions(+) create mode 100644 clim/db-menu.lisp create mode 100644 cloe/sysdcl.lisp create mode 100644 clx/sysdcl.lisp create mode 100644 compatibility/clim1-compatibility.lisp create mode 100644 compatibility/packages.lisp create mode 100644 compatibility/sysdcl.lisp create mode 100644 demo/color-editor.lisp create mode 100644 genera/sysdcl.lisp create mode 100644 misc/xtsupport.c create mode 100644 postscript/sysdcl.lisp create mode 100644 sys/load-clim2.lisp diff --git a/clim/db-menu.lisp b/clim/db-menu.lisp new file mode 100644 index 00000000..e0d8317c --- /dev/null +++ b/clim/db-menu.lisp @@ -0,0 +1,332 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: SILICA; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +"Copyright (c) 1992 by Symbolics, Inc. All rights reserved." + +(in-package :silica) ;yes, this file is in the Silica package + +;;; Menu bars and buttons + +;;--- The main visual problem is that there is just too much whitespace... + + +;;; Menu bar buttons + +;; Like push buttons, except that they activate when the pointer button is +;; down rather than when it is released +(defclass menu-bar-button (push-button-pane) + ((next-menu :initform nil :initarg :next-menu))) + +(defmethod handle-event ((pane menu-bar-button) (event pointer-enter-event)) + (with-slots (armed next-menu) pane + (unless armed + (cond ((let ((pointer (pointer-event-pointer event))) + (and (pointer-button-state pointer) + (not (zerop (pointer-button-state pointer))))) + (with-sheet-medium (medium pane) + (setf armed :active) + (highlight-button pane medium) + (if (typep next-menu 'pull-down-menu) + (choose-from-pull-down-menu next-menu pane) + (activate-callback pane (gadget-client pane) (gadget-id pane))) + (setf armed t) + (highlight-button pane medium))) + (t (setf armed t))) + (armed-callback pane (gadget-client pane) (gadget-id pane))))) + +(defmethod handle-event ((pane menu-bar-button) (event pointer-button-press-event)) + (with-slots (armed next-menu) pane + (with-sheet-medium (medium pane) + (when armed + (setf armed :active) + (highlight-button pane medium)) + (if (typep next-menu 'pull-down-menu) + (choose-from-pull-down-menu next-menu pane) + (activate-callback pane (gadget-client pane) (gadget-id pane))) + (setf armed t) + (highlight-button pane medium)))) + +(defmethod handle-event ((pane menu-bar-button) (event pointer-button-release-event)) + (with-slots (armed) pane + (when (and (eq armed :active)) + (with-sheet-medium (medium pane) + (setf armed t) + (highlight-button pane medium))))) + + +;;; Pull-down menu buttons + +(defparameter *cascade-button-pattern* + (make-pattern #2a((1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 0 0 0 0 0 0 0 1) + (1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1) + (1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1)) + (list +background-ink+ +foreground-ink+))) + +;; Like push buttons except that the pointer button is assumed to be already down +(defclass pull-down-menu-button (push-button-pane) + ((next-menu :initform nil :initarg :next-menu))) + +(defmethod initialize-instance :after ((pane pull-down-menu-button) &key) + (with-slots (next-menu pattern) pane + (when next-menu + (setq pattern *cascade-button-pattern*)))) + +(defmethod handle-event ((pane pull-down-menu-button) (event pointer-enter-event)) + (when (port pane) ;the menu is sometimes disabled... + (let* ((pointer (port-pointer (find-port))) + (pointer-button-state (pointer-button-state pointer))) + (unless (= pointer-button-state 0) + (with-slots (armed) pane + (unless (eq armed :active) + (with-sheet-medium (medium pane) + (setq armed :active) + (highlight-button pane medium)) + (armed-callback pane (gadget-client pane) (gadget-id pane)))))))) + +(defmethod handle-event ((pane pull-down-menu-button) (event pointer-exit-event)) + (when (port pane) ;the menu is often disabled... + (with-slots (armed) pane + (when armed + (with-sheet-medium (medium pane) + (setq armed nil) + (highlight-button pane medium)) + (disarmed-callback pane (gadget-client pane) (gadget-id pane)))))) + +(defmethod handle-event ((pane pull-down-menu-button) (event pointer-motion-event)) + (with-slots (next-menu x-margin normal-pattern) pane + (when next-menu + (with-bounding-rectangle* (left top right bottom) (sheet-region pane) + (declare (ignore top right bottom)) + (let* ((pattern-width (pattern-width normal-pattern)) + (sensitive-region 16) + (x (pointer-event-x event))) + (when (and next-menu (> x (- (+ left x-margin pattern-width) sensitive-region))) + (if (typep next-menu 'pull-down-menu) + (choose-from-pull-down-menu next-menu pane :cascade-p t) + (funcall next-menu pane)))))))) + +;; We really shouldn't ever get one of these - the button must have been down +;; for us to get here. +(defmethod handle-event ((pane pull-down-menu-button) (event pointer-button-press-event)) + ) + +(defmethod handle-event ((pane pull-down-menu-button) (event pointer-button-release-event)) + (with-slots (armed) pane + (when (eq armed :active) + (setf armed t) + (with-sheet-medium (medium pane) + (highlight-button pane medium)) + (activate-callback pane (gadget-client pane) (gadget-id pane)) + ;;--- This modularity is a bit dubious. Oh well. + (throw 'exit-pull-down-menu (values))))) + + +;;; Pull-down menu sheets + +(defclass popup-menu-sheet + (sheet-permanently-enabled-mixin + sheet-single-child-mixin + wrapping-space-mixin + space-requirement-mixin + pane) + () + (:default-initargs :medium t)) + +(defclass pull-down-menu (popup-menu-sheet) + ((current-button :initform nil) + (buttons :initarg :buttons :accessor pull-down-menu-buttons) + (entered :initarg nil :accessor pull-down-menu-entered)) + (:default-initargs :buttons nil)) + +(defmethod repaint-sheet :after ((pane pull-down-menu) region) + (dolist (button (slot-value pane 'buttons)) + (repaint-sheet button region))) + +(defmethod handle-event ((pane pull-down-menu) (event pointer-motion-event)) + (when (and (plusp (pointer-event-x event)) + (plusp (pointer-event-y event))) + (setf (pull-down-menu-entered pane) t))) + +(defmethod handle-event ((pane pull-down-menu) (event pointer-button-press-event)) + ) + +(defmethod handle-event ((pane pull-down-menu) (event pointer-button-release-event)) + ) + +(defmethod handle-event ((pane pull-down-menu) (event pointer-enter-event)) + (when (and (plusp (pointer-event-x event)) + (plusp (pointer-event-y event))) + (setf (pull-down-menu-entered pane) t))) + +(defmethod handle-event ((pane pull-down-menu) (event pointer-exit-event)) + ;; Don't punt if we've never entered the menu + (when (pull-down-menu-entered pane) + (throw 'exit-pull-down-menu (values)))) + +(defmethod handle-event :after ((pane pull-down-menu) (event pointer-event)) + (deallocate-event event)) + + +;;; Interface to pull-down menus + +(define-application-frame pull-down-menu-frame () + (menu) + (:pane + (with-slots (menu) *application-frame* + (outlining () + (setq menu (make-pane 'pull-down-menu + :width 100 :height 100))))) + (:menu-bar nil)) + +(defun make-pull-down-menu (&key port) + (let ((frame (make-application-frame 'pull-down-menu-frame + :parent port + :save-under t))) + (values (slot-value frame 'menu) frame))) + +;; Pull-down menus share their event queue with the owning application +(defresource pull-down-menu (port) + :constructor (make-pull-down-menu :port port) + :matcher (eq (port pull-down-menu) port) + :deinitializer + (progn + (setf (pull-down-menu-buttons pull-down-menu) nil) + (setf (pull-down-menu-entered pull-down-menu) nil) + (dolist (child (sheet-children pull-down-menu)) + (sheet-disown-child pull-down-menu child)))) + +(defmacro initialize-pull-down-menu (menu &body buttons) + (assert (= (length buttons) 1)) + `(with-look-and-feel-realization () + (setf (pull-down-menu-buttons ,menu) ,@buttons) + (sheet-adopt-child ,menu (make-pane 'vbox-pane + :contents (pull-down-menu-buttons ,menu) + :spacing 0)) + (layout-frame (pane-frame ,menu)) + ,menu)) + +(defvar *subsidiary-pull-down-menu* nil) +(defun choose-from-pull-down-menu (menu &optional button &key cascade-p) + (let ((menu-frame (pane-frame menu)) + (event-queue (sheet-event-queue menu))) + (when button + (with-bounding-rectangle* (bleft btop bright bbottom) + (sheet-device-region button) + (declare (ignore bright)) + (multiple-value-bind (fleft ftop fright fbottom) + (let ((tls (get-top-level-sheet button))) + (mirror-region* (port tls) tls)) + (declare (ignore fright fbottom)) + (if cascade-p + (let ((pattern-width (pattern-width (slot-value button 'normal-pattern))) + (button-x-margin (slot-value button 'x-margin))) + (move-sheet (frame-top-level-sheet menu-frame) + (+ bleft fleft pattern-width button-x-margin -16) + (+ btop ftop))) + (move-sheet (frame-top-level-sheet menu-frame) + (+ bleft fleft 10) + (+ bbottom ftop -10)))))) + (enable-frame menu-frame) + ;; Share the event queue with the application frame + (setf (sheet-event-queue (frame-top-level-sheet (pane-frame menu))) + (sheet-event-queue (frame-top-level-sheet *application-frame*))) + ;; Ensure no surprise exit events + (setf (pull-down-menu-entered menu) nil) + ;; Wait for an event and then handle it + (unwind-protect + (flet ((waiter () + (not (queue-empty-p event-queue)))) + (declare (dynamic-extent #'waiter)) + (catch (if *subsidiary-pull-down-menu* + '|Not exit-pull-down-menu| + 'exit-pull-down-menu) + (let ((*subsidiary-pull-down-menu* t)) + (loop + (port-event-wait (port menu) #'waiter) + (let ((event (queue-get event-queue))) + (handle-event (event-sheet event) event)))))) + (disable-frame menu-frame)))) + +;;--- Kludge alert +(defun get-top-level-sheet (pane) + (if (typep pane 'top-level-sheet) + pane + (get-top-level-sheet (sheet-parent pane)))) + + +;;; Menu bars + +(defclass menu-bar-pane + (menu-bar) + ()) + +;;--- What about when the command menu tick changes? +;;--- What about graying of disabled commands? +(defun compute-menu-bar-pane (frame command-table) + (with-look-and-feel-realization ((frame-manager frame) frame) + (labels + ((make-command-table-buttons (command-table top-level) + (let ((buttons nil)) + (map-over-command-table-menu-items + #'(lambda (menu keystroke item) + (let ((type (command-menu-item-type item)) + (value (command-menu-item-value item))) + (case type + (:command + (push (make-pane (if top-level 'push-button 'pull-down-menu-button) + :label menu + :activate-callback + #'(lambda (button) + (menu-bar-command-callback button command-table value))) + buttons)) + (:function + ;;--- Do something about this + ) + (:menu + (push (make-pane (if top-level 'menu-bar-button 'pull-down-menu-button) + :label menu + :next-menu (make-command-table-menu value nil) + :activate-callback nil) + buttons)) + (:divider + (unless top-level + ;;--- Do something about this + ))))) + command-table) + (nreverse buttons))) + (make-command-table-menu (command-table top-level) + (let ((buttons (make-command-table-buttons command-table top-level))) + (if top-level + (outlining () + (make-pane 'hbox-pane :contents buttons)) + (let ((menu (make-pull-down-menu :port (port frame)))) + (initialize-pull-down-menu menu buttons) + menu))))) + (declare (dynamic-extent #'make-command-table-buttons #'make-command-table-menu)) + (make-command-table-menu command-table t)))) + +(defun menu-bar-command-callback (button command-table command) + (let ((frame (pane-frame button))) + (distribute-event + (port button) + (allocate-event 'presentation-event + :frame frame + :sheet (frame-top-level-sheet frame) + :presentation-type `(command :command-table ,command-table) + :value command)))) diff --git a/cloe/sysdcl.lisp b/cloe/sysdcl.lisp new file mode 100644 index 00000000..0dbcf506 --- /dev/null +++ b/cloe/sysdcl.lisp @@ -0,0 +1,29 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(in-package #-ANSI-90 :user #+ANSI-90 :cl-user) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(clim-defsys:defsystem cloe-clim + (:default-pathname #+Genera "SYS:CLIM;REL-2;CLOE;" + #-Genera (frob-pathname "cloe") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLOE;" + #-Genera (frob-pathname "cloe") + :needed-systems (clim-standalone) + :load-before-compile (clim-standalone)) + ("pkgdcl") + ("wheader") + ("windows") + ("cloe-port") + ("cloe-mirror") + ("cloe-medium") + ("cloe-frames") + ("cloe-gadgets") + ("cloe-menus")) + +#+Genera +(clim-defsys:import-into-sct 'cloe-clim + :pretty-name "Cloe CLIM" + :default-pathname "SYS:CLIM;REL-2;CLOE;") diff --git a/clx/sysdcl.lisp b/clx/sysdcl.lisp new file mode 100644 index 00000000..6db74fbe --- /dev/null +++ b/clx/sysdcl.lisp @@ -0,0 +1,48 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(in-package #-ANSI-90 :user #+ANSI-90 :cl-user) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(clim-defsys:defsystem clx-clim + (:default-pathname #+Genera "SYS:CLIM;REL-2;CLX;" + #-Genera (frob-pathname "clx") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;CLX;" + #-Genera (frob-pathname "clx") + :needed-systems (clim-standalone) + :load-before-compile (clim-standalone)) + ("pkgdcl") + ("clx-port") + ("clx-mirror") + ("clx-medium") + ("clx-pixmaps") + ("clx-frames") + ("clx-prefill" :features (or Genera Cloe-Runtime))) + +#+Genera +(clim-defsys:import-into-sct 'clx-clim + :pretty-name "CLX CLIM" + :default-pathname "SYS:CLIM;REL-2;CLX;" + :required-systems '(clim) + :bug-reports "Bug-CLIM" + :patches-reviewed "Bug-CLIM-Doc") + +#+Minima-Developer +(clim-defsys:import-into-sct 'clx-clim :subsystem t + :sct-name :minima-clx-clim-standalone + :pretty-name "Minima CLX CLIM Standalone" + :default-pathname "SYS:CLIM;REL-2;CLX;" + :default-destination-pathname "SYS:CLIM;REL-2;CLX;") + +#+Minima-Developer +(zl:::sct:defsystem minima-clx-clim + (:pretty-name "Minima CLX CLIM" + :default-pathname "SYS:CLIM;REL-2;CLX;" + :journal-directory "SYS:CLIM;REL-2;CLX;PATCH;" + :maintain-journals nil + :default-module-type :system + :patches-reviewed "Bug-CLIM-Doc" + :source-category :optional) + (:serial "minima-clim" "minima-clx-clim-standalone")) diff --git a/compatibility/clim1-compatibility.lisp b/compatibility/clim1-compatibility.lisp new file mode 100644 index 00000000..c14f33d3 --- /dev/null +++ b/compatibility/clim1-compatibility.lisp @@ -0,0 +1,1938 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes; Patch-File: Yes -*- + +;;; $fiHeader$ + +(in-package :clim-internals) + +"Copyright (c) 1992 Symbolics, Inc. All rights reserved." + + +;;; Compatibility stubs for CLIM 1.1 + +(eval-when (compile load eval) + ;; We use this below to flag the compatibility code... + (pushnew :CLIM-1-compatibility *features*)) + +(defmacro define-compatibility-function ((old-name new-name) arglist &body body) + `(progn + (define-compiler-macro ,old-name (&whole form) + (warn "The function ~S is now obsolete, use ~S instead.~%~ + Compatibility code is being generated for the time being." + ',old-name ',new-name) + form) + (defun-inline ,old-name ,arglist + ,@body))) + + +(define-compatibility-function (point-position* point-position) + (point) + (point-position point)) + +(define-compatibility-function (region-contains-point*-p region-contains-position-p) + (region x y) + (region-contains-position-p region x y)) + + +(defmacro with-bounding-rectangle* ((left top &optional right bottom) region &body body) + #+Genera (declare (zwei:indentation 1 3 2 1)) + (when (or (null right) (null bottom)) + (warn "The ~A and ~A arguments to ~S are now required.~%~ + Compatibility code is being generated for the time being." + 'right 'bottom 'with-bounding-rectangle*)) + `(multiple-value-bind (,left ,top ,@(when right (list right bottom))) + (bounding-rectangle* ,region) + (declare (type coordinate ,left ,top ,@(when right (list right bottom)))) + ,@body)) + +(define-compatibility-function (bounding-rectangle-position* + bounding-rectangle-position) + (region) + (bounding-rectangle-position region)) + +(define-compatibility-function (bounding-rectangle-set-position* + bounding-rectangle-set-position) + (region x y) + (bounding-rectangle-set-position region)) + + +(define-compiler-macro make-3-point-transformation (&whole form) + (warn "The function ~S has a different arglist than it did in CLIM 1.1.~%~ + Please check your code." + 'make-3-point-transformation) + form) + +(define-compiler-macro make-3-point-transformation* (&whole form) + (warn "The function ~S has a different arglist than it did in CLIM 1.1.~%~ + Please check your code." + 'make-3-point-transformation*) + form) + +(define-compatibility-function (compose-rotation-transformation + compose-rotation-with-transformation) + (transform angle &optional origin) + (compose-rotation-with-transformation transform angle origin)) + +(define-compatibility-function (compose-scaling-transformation + compose-scaling-with-transformation) + (transform mx my &optional origin) + (compose-scaling-with-transformation transform mx my origin)) + +(define-compatibility-function (compose-translation-transformation + compose-translation-with-transformation) + (transform dx dy) + (compose-translation-with-transformation transform dx dy)) + +(define-compatibility-function (transform-point* transform-position) + (transform x y) + (transform-position transform x y)) + +(define-compatibility-function (untransform-point* untransform-position) + (transform x y) + (transform-position transform x y)) + + +(eval-when (compile load eval) +(defun probably-stream-or-medium-p (symbol) + (and (symbolp symbol) + ;;--- This is really not completely safe + (or (search "MEDIUM" (symbol-name symbol) :test #'string-equal) + (search "STREAM" (symbol-name symbol) :test #'string-equal)))) +) ;eval-when + +(defmacro with-text-style ((medium &optional style) &body body) + (when (or (member style '(t nil *standard-input* *standard-output* *query-io*)) + (and (constantp medium) + (listp (eval medium)) + (= (length (eval medium)) 3)) + (probably-stream-or-medium-p style)) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-text-style) + (rotatef medium style)) + (default-output-stream medium with-text-style) + `(flet ((with-text-style-body (,medium) ,@body)) + (declare (dynamic-extent #'with-text-style-body)) + (invoke-with-text-style + ,medium #'with-text-style-body ,style ,medium))) + +(defmacro with-text-family ((medium &optional family) &body body) + (when (or (member family '(t nil *standard-input* *standard-output* *query-io*)) + (and (constantp medium) + (keywordp (eval medium))) + (probably-stream-or-medium-p family)) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-text-family) + (rotatef medium family)) + `(with-text-style (,medium (make-text-style ,family nil nil)) ,@body)) + +(defmacro with-text-face ((medium &optional face) &body body) + (when (or (member face '(t nil *standard-input* *standard-output* *query-io*)) + (and (constantp medium) + (keywordp (eval medium))) + (probably-stream-or-medium-p face)) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-text-face) + (rotatef medium face)) + `(with-text-style (,medium (make-text-style nil ,face nil)) ,@body)) + +(defmacro with-text-size ((medium &optional size) &body body) + (when (or (member size '(t nil *standard-input* *standard-output* *query-io*)) + (and (constantp medium) + (or (keywordp (eval medium)) + (realp (eval medium)))) + (probably-stream-or-medium-p size)) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-text-size) + (rotatef medium size)) + `(with-text-style (,medium (make-text-style nil nil ,size)) ,@body)) + + +(define-compatibility-function (add-text-style-mapping (setf text-style-mapping)) + (device character-set style mapping) + (setf (text-style-mapping device style character-set) mapping)) + + +(define-compatibility-function (draw-character draw-text) + (stream character point &rest args) + (declare (dynamic-extent args)) + (apply #'draw-text stream character point args)) + +(define-compatibility-function (draw-character* draw-text) + (stream character x y &rest args) + (declare (dynamic-extent args)) + (apply #'draw-text stream character x y args)) + +(define-compatibility-function (draw-string draw-text) + (stream string point &rest args) + (declare (dynamic-extent args)) + (apply #'draw-text stream string point args)) + +(define-compatibility-function (draw-string* draw-text) + (stream string x y &rest args) + (declare (dynamic-extent args)) + (apply #'draw-text stream string x y args)) + +;; DRAW-ICON* was misnamed DRAW-ICON for a while... +(define-compatibility-function (draw-icon draw-pattern*) + (stream icon x y &rest args) + (declare (dynamic-extent args)) + (apply #'draw-pattern* stream icon x y args)) + +(define-compatibility-function (draw-icon* draw-pattern*) + (stream icon x y &rest args) + (declare (dynamic-extent args)) + (apply #'draw-pattern* stream icon x y args)) + + +(defvar +foreground+ +foreground-ink+) +(defvar +background+ +background-ink+) + + +(define-compatibility-function (make-color-rgb make-rgb-color) + (red green blue) + (make-rgb-color red green blue)) + +(define-compatibility-function (make-color-ihs make-ihs-color) + (intensity hue saturation) + (make-ihs-color intensity hue saturation)) + + +(define-compatibility-function (stream-cursor-position* + stream-cursor-position) + (stream) + (stream-cursor-position stream)) + +(define-compatibility-function (stream-set-cursor-position* + stream-set-cursor-position) + (stream x y) + (stream-set-cursor-position stream x y)) + +(define-compatibility-function (stream-increment-cursor-position* + stream-increment-cursor-position) + (stream dx dy) + (stream-increment-cursor-position stream dx dy)) + + +(define-compatibility-function (cursor-position* cursor-position) + (cursor) + (cursor-position cursor)) + +(define-compatibility-function (cursor-set-position* cursor-set-position) + (cursor x y) + (cursor-set-position cursor x y)) + + +(define-compatibility-function (stream-vsp stream-vertical-spacing) + (stream) + (stream-vertical-spacing stream)) + +(defmacro with-end-of-page-action (#-CLIM-1-compatibility (stream action) + #+CLIM-1-compatibility (stream &optional action) + &body body &environment env) + #+CLIM-1-compatibility + (when (or (keywordp stream) + (null action)) + (rotatef stream action) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-end-of-page-action)) + (default-output-stream stream) + (let ((actions '(:wrap :scroll :allow)) + (assert-required t) + (wrapped-body `(letf-globally (((stream-end-of-page-action ,stream) ,action)) + ,@body))) + (when (constantp action #+(or Genera Minima) env) + (setf action (eval action #+(or Genera Minima-Developer) env)) + (if (member action actions) + (setf assert-required nil) + (warn "~S action must be one of ~S, not ~S" 'with-end-of-page actions action)) + (setf action `',action)) + (when assert-required + (setf wrapped-body + `(progn (assert (member ,action ',actions)) + ,wrapped-body))) + wrapped-body)) + +(defmacro with-end-of-line-action (#-CLIM-1-compatibility (stream action) + #+CLIM-1-compatibility (stream &optional action) + &body body &environment env) + #+CLIM-1-compatibility + (when (or (keywordp stream) + (null action)) + (rotatef stream action) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-end-of-line-action)) + (default-output-stream stream) + (let ((actions '(:wrap :scroll :allow)) + (assert-required t) + (wrapped-body `(letf-globally (((stream-end-of-line-action ,stream) ,action)) + ,@body))) + (when (constantp action #+(or Genera Minima) env) + (setf action (eval action #+(or Genera Minima-Developer) env)) + (if (member action actions) + (setf assert-required nil) + (warn "~S action must be one of ~S, not ~S" 'with-end-of-line actions action)) + (setf action `',action)) + (when assert-required + (setf wrapped-body + `(progn (assert (member ,action ',actions)) + ,wrapped-body))) + wrapped-body)) + + +(define-compatibility-function (output-record-position* output-record-position) + (record) + (output-record-position record)) + +(define-compatibility-function (output-record-set-position* output-record-set-position) + (record x y) + (output-record-set-position record x y)) + +(define-compatibility-function (output-record-start-position* + output-record-start-cursor-position) + (record) + (output-record-start-cursor-position record)) + +(define-compatibility-function (output-record-set-start-position* + output-record-set-start-cursor-position) + (record nx ny) + (output-record-set-start-cursor-position record nx ny)) + +(define-compatibility-function (output-record-start-position + output-record-start-cursor-position) + (record) + (multiple-value-bind (x y) + (output-record-start-cursor-position record) + (make-point x y))) + +(define-compatibility-function (output-record-end-position* + output-record-end-cursor-position) + (record) + (output-record-end-cursor-position record)) + +(define-compatibility-function (output-record-set-end-position* + output-record-set-end-cursor-position) + (record nx ny) + (output-record-set-end-cursor-position record nx ny)) + +(define-compatibility-function (output-record-element-count output-record-count) + (record) + (output-record-count record)) + +(define-compatibility-function (output-record-elements output-record-children) + (record) + (output-record-children record)) + +(define-compatibility-function (replay-1 replay-output-record) + (record) + (replay-output-record record)) + + +(define-compatibility-function (output-record-refined-sensitivity-test + output-record-refined-position-test) + (record x y) + (output-record-refined-position-test record x y)) + + +(define-compatibility-function (output-recording-stream-output-record + stream-output-history) + (stream) + (stream-output-history stream)) + +(define-compatibility-function (output-recording-stream-current-output-record-stack + stream-current-output-record) + (stream) + (stream-current-output-record stream)) + +(define-compatibility-function (output-recording-stream-replay stream-replay) + (stream &optional region) + (stream-replay stream region)) + +(define-compiler-macro add-output-record (&whole form) + (warn "The function ~S has a different contract than it did in CLIM 1.1.~%~ + Please check your code." + 'add-output-record) + form) + +(defmacro with-output-recording-options + ((stream &key (draw nil draw-supplied) + (record nil record-supplied) + #+CLIM-1-compatibility (draw-p nil draw-p-supplied) + #+CLIM-1-compatibility (record-p nil record-p-supplied)) + &body body) + #+CLIM-1-compatibility + (when (or draw-p-supplied record-p-supplied) + (setq draw draw-p + draw-supplied draw-p-supplied + record record-p + record-supplied record-p-supplied) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-output-recording-options)) + (let ((new-stream (gensymbol 'stream))) + `(let ((,new-stream ,stream)) + (flet ((with-output-recording-options-body () ,@body)) + (declare (dynamic-extent #'with-output-recording-options-body)) + (invoke-with-output-recording-options + ,new-stream #'with-output-recording-options-body + ,(if record-supplied record `(stream-recording-p ,new-stream)) + ,(if draw-supplied draw `(stream-drawing-p ,new-stream))))))) + +(define-compatibility-function (stream-draw-p stream-drawing-p) + (stream) + (stream-drawing-p stream)) + +(define-compatibility-function (stream-record-p stream-recording-p) + (stream) + (stream-recording-p stream)) + + +(define-compatibility-function (add-output-record-element add-output-record) + (record child) + (add-output-record child record)) + +(define-compatibility-function (delete-output-record-element delete-output-record) + (record child &optional (errorp t)) + (delete-output-record child record errorp)) + +(define-compatibility-function (map-over-output-record-elements + map-over-output-records) + (record function + &optional x-offset y-offset &rest continuation-args) + (declare (dynamic-extent function continuation-args)) + (apply #'map-over-output-records + function record x-offset y-offset continuation-args)) + +(define-compatibility-function (map-over-output-record-elements-overlapping-region + map-over-output-records-overlapping-region) + (record region function + &optional x-offset y-offset &rest continuation-args) + (declare (dynamic-extent function continuation-args)) + (apply #'map-over-output-records-overlapping-region + function record region x-offset y-offset continuation-args)) + +(define-compatibility-function (map-over-output-record-elements-containing-point* + map-over-output-records-containing-position) + (record x y function + &optional x-offset y-offset &rest continuation-args) + (declare (dynamic-extent function continuation-args)) + (apply #'map-over-output-records-containing-position + function record x y x-offset y-offset continuation-args)) + + +(defmacro formatting-table ((&optional stream + &rest options + &key x-spacing y-spacing + multiple-columns multiple-columns-x-spacing + equalize-column-widths + record-type (move-cursor t) + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing + #+CLIM-1-compatibility multiple-columns-inter-column-spacing) + &body body) + (declare (ignore x-spacing y-spacing + multiple-columns multiple-columns-x-spacing + equalize-column-widths record-type move-cursor)) + #+Genera (declare (zwei:indentation 0 3 1 1)) + #+CLIM-1-compatibility + (when (or inter-row-spacing inter-column-spacing multiple-columns-inter-column-spacing) + (setf (getf options :x-spacing) inter-column-spacing) + (setf (getf options :y-spacing) inter-row-spacing) + (setf (getf options :multiple-columns-x-spacing) multiple-columns-inter-column-spacing) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'formatting-table)) + (default-output-stream stream formatting-table) + `(flet ((formatting-table-body (,stream) ,@body)) + (declare (dynamic-extent #'formatting-table-body)) + (invoke-formatting-table ,stream #'formatting-table-body ,@options))) + +(defmacro formatting-cell ((&optional stream + &rest options + &key (align-x ':left) (align-y ':top) + min-width min-height record-type + #+CLIM-1-compatibility minimum-width + #+CLIM-1-compatibility minimum-height) + &body body) + (declare (ignore align-x align-y min-width min-height record-type)) + #+Genera (declare (zwei:indentation 0 3 1 1)) + #+CLIM-1-compatibility + (when (or minimum-width minimum-height) + (setf (getf options :min-width) minimum-width) + (setf (getf options :min-height) minimum-height) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'formatting-cell)) + (default-output-stream stream formatting-cell) + `(flet ((formatting-cell-body (,stream) ,@body)) + (declare (dynamic-extent #'formatting-cell-body)) + (invoke-formatting-cell ,stream #'formatting-cell-body ,@options))) + +(defmacro formatting-item-list ((&optional stream + &rest options + &key record-type + x-spacing y-spacing initial-spacing + n-columns n-rows + max-width max-height + stream-width stream-height + (move-cursor T) + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing) + &body body) + (declare (ignore x-spacing y-spacing initial-spacing + record-type n-columns n-rows max-width max-height + stream-width stream-height move-cursor)) + #+Genera (declare (zwei:indentation 0 3 1 1)) + #+CLIM-1-compatibility + (when (or inter-row-spacing inter-column-spacing) + (setf (getf options :x-spacing) inter-column-spacing) + (setf (getf options :y-spacing) inter-row-spacing) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'formatting-item-list)) + (default-output-stream stream formatting-item-list) + `(flet ((formatting-item-list-body (,stream) ,@body)) + (declare (dynamic-extent #'formatting-item-list-body)) + (invoke-formatting-item-list ,stream #'formatting-item-list-body ,@options))) + +(defun format-items (items &key (stream *standard-output*) printer presentation-type + x-spacing y-spacing initial-spacing + n-rows n-columns max-width max-height + (record-type 'standard-item-list-output-record) + (cell-align-x ':left) (cell-align-y ':top) + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing) + #+CLIM-1-compatibility + (when (or inter-row-spacing inter-column-spacing) + (setq x-spacing inter-column-spacing + y-spacing inter-row-spacing)) + (when (and printer presentation-type) + (error "Only one of ~S or ~S can be specified." ':printer ':presentation-type)) + (when (and (null printer) (null presentation-type)) + (error "One of ~S or ~S must be specified." ':printer ':presentation-type)) + (formatting-item-list (stream :record-type record-type + :n-rows n-rows :n-columns n-columns + :max-width max-width :max-height max-height + :x-spacing x-spacing :y-spacing y-spacing + :initial-spacing initial-spacing) + (flet ((format-item (item) + (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) + (cond (printer + (funcall printer item stream)) + (presentation-type + (present item presentation-type :stream stream)))))) + (declare (dynamic-extent #'format-item)) + (map nil #'format-item items)))) + +(define-compiler-macro format-items + (&whole form + items + &rest keys + &key inter-row-spacing inter-column-spacing + &allow-other-keys) + (cond ((or inter-row-spacing inter-column-spacing) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'format-items) + (with-keywords-removed (keys keys '(:x-spacing :y-spacing + :inter-row-spacing :inter-column-spacing)) + `(format-items + ,items + ,@(and inter-row-spacing `(:y-spacing ,inter-row-spacing)) + ,@(and inter-column-spacing `(:x-spacing ,inter-column-spacing)) + ,@keys))) + (t form))) + + +(define-compatibility-function (redisplay-1 redisplay-output-record) + (record) + (redisplay-output-record record)) + + +(define-compatibility-function (event-window event-sheet) + (event) + (event-sheet event)) + +(define-compatibility-function (pointer-event-shift-mask event-modifier-state) + (pointer-event) + (event-modifier-state pointer-event)) + +(define-compatibility-function (stream-pointer-position* + stream-pointer-position) + (stream) + (stream-pointer-position stream)) + +(define-compatibility-function (stream-set-pointer-position* + stream-set-pointer-position) + (stream x y) + (stream-set-pointer-position stream x y)) + +(define-compatibility-function (pointer-position* pointer-position) + (pointer) + (pointer-position pointer)) + +(define-compatibility-function (pointer-set-position* pointer-set-position) + (pointer x y) + (pointer-set-position pointer x y)) + + +(define-compatibility-function (dragging-output-record drag-output-record) + (stream output-record + &key (repaint t) (erase #'erase-output-record) feedback + (finish-on-release nil)) + (drag-output-record stream output-record + :repaint repaint + :erase erase + :feedback feedback + :finish-on-release finish-on-release)) + + +(defmacro with-output-as-presentation ((&rest options) &body body) + #+Genera (declare (zwei:indentation 0 3 1 1)) + (let (stream object type + modifier single-box allow-sensitive-inferiors + parent record-type + (asi-p '#:asi)) + (cond ((oddp (length options)) + (setq stream (pop options) + object (pop options) + type (pop options)) + (setq modifier (getf options :modifier)) + (setq single-box (getf options :single-box)) + (setq allow-sensitive-inferiors (getf options :allow-sensitive-inferiors asi-p)) + (setq parent (getf options :parent nil)) + (setq record-type (getf options :record-type `'standard-presentation))) + (t + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'with-output-as-presentation) + (setq stream (getf options :stream)) + (setq object (getf options :object)) + (setq type (getf options :type)) + (setq modifier (getf options :modifier)) + (setq single-box (getf options :single-box)) + (setq allow-sensitive-inferiors (getf options :allow-sensitive-inferiors asi-p)) + (setq parent (getf options :parent nil)) + (setq record-type (getf options :record-type `'standard-presentation)))) + (default-output-stream stream) + ;; Maybe with-new-output-record should turn record-p on? + (when (eq allow-sensitive-inferiors asi-p) + (setq allow-sensitive-inferiors '*allow-sensitive-inferiors*)) + (let ((nobject '#:object) ;(once-only (object type) ...) + (ntype '#:type)) + `(with-output-recording-options (,stream :record t) + (let ((,nobject ,object) + (,ntype ,type)) + (with-new-output-record (,stream (if *allow-sensitive-inferiors* + ,record-type + 'standard-nonsensitive-presentation) nil + :object ,nobject + :type (if ,ntype + (expand-presentation-type-abbreviation ,ntype) + (presentation-type-of ,nobject)) + :single-box ,single-box + ,@(when modifier `(:modifier ,modifier)) + ,@(when parent `(:parent ,parent))) + (let ((*allow-sensitive-inferiors* ,allow-sensitive-inferiors)) + ,@body))))))) + + +(defun accept (type &rest accept-args + &key (stream *query-io*) + (view (stream-default-view stream)) + (default nil default-supplied-p) + (default-type type) + (history type) + (provide-default nil) + (prompt t) + (prompt-mode ':normal) + (display-default prompt) + (query-identifier nil) + (activation-gestures nil) + (additional-activation-gestures nil) + (delimiter-gestures nil) + (additional-delimiter-gestures nil) + #+CLIM-1-compatibility (activation-characters nil) + #+CLIM-1-compatibility (additional-activation-characters nil) + #+CLIM-1-compatibility (blip-characters nil) + #+CLIM-1-compatibility (additional-blip-characters nil) + (insert-default nil) (replace-input t) + (present-p nil) (active-p t)) + (declare (dynamic-extent accept-args)) + (declare (values object type)) + (declare (ignore prompt-mode display-default query-identifier + activation-gestures additional-activation-gestures + delimiter-gestures additional-delimiter-gestures + #+CLIM-1-compatibility activation-characters + #+CLIM-1-compatibility additional-activation-characters + #+CLIM-1-compatibility blip-characters + #+CLIM-1-compatibility additional-blip-characters + insert-default replace-input present-p active-p)) + + ;; Allow the arguments to be presentation type abbreviations + (multiple-value-bind (expansion expanded) + (expand-presentation-type-abbreviation type) + (when expanded + (when (eq default-type type) + (setq default-type expansion)) + (when (eq history type) + (setq history expansion)) + (setq type expansion))) + (unless (eq default-type type) + (multiple-value-bind (expansion expanded) + (expand-presentation-type-abbreviation default-type) + (when expanded + (setq default-type expansion) + (setq accept-args `(:default-type ,default-type ,@accept-args))))) + (unless (eq history type) + (multiple-value-bind (expansion expanded) + (expand-presentation-type-abbreviation history) + (when expanded + (setq history expansion) + (setq accept-args `(:history ,history ,@accept-args))))) + + (let ((insert-default nil)) + (when (and provide-default (null default-supplied-p)) + ;; If the user wants a default, but provided none, go get it from the history + (let ((history (if (typep history 'basic-history) + history + (presentation-type-history history)))) + (when history + (let ((element (yank-from-history history))) + (when element + (setq default (presentation-history-element-object element) + default-supplied-p t + insert-default t)))))) + (when default-supplied-p + ;; Massage the default + (multiple-value-bind (new-default new-type) + (presentation-default-preprocessor default type :default-type default-type) + (when (or (not (eq default new-default)) + (not (eq default-type new-type))) + (setq default new-default + default-type (or new-type default-type) + insert-default t)))) + (when insert-default + (setq accept-args `(:default ,default :default-type ,default-type ,@accept-args)))) + + (typecase view + (null) + (symbol (setq view (make-instance view))) + (cons (setq view (apply #'make-instance view)))) + (setq view (decode-indirect-view type view (frame-manager stream))) + + ;; Call methods to do the work + (with-keywords-removed (accept-args accept-args '(:stream :view)) + (let ((query-identifier + (apply #'prompt-for-accept + (or *original-stream* stream) type view accept-args))) + (apply #'stream-accept (or *original-stream* stream) type + :view view :query-identifier query-identifier + accept-args)))) + +(define-compiler-macro accept + (&whole form + type + &rest keys + &key activation-characters additional-activation-characters + blip-characters additional-blip-characters + &allow-other-keys) + (cond ((or activation-characters additional-activation-characters + blip-characters additional-blip-characters) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'accept) + (with-keywords-removed (keys keys + '(:activation-characters :additional-activation-characters + :blip-characters :additional-blip-characters + :activation-gestures :additional-activation-gestures + :delimiter-gestures :additional-delimiter-gestures)) + `(accept + ,type + ,@(and activation-characters + `(:activation-gestures ,activation-characters)) + ,@(and additional-activation-characters + `(:additional-activation-gestures ,additional-activation-characters)) + ,@(and blip-characters + `(:delimiter-gestures ,blip-characters)) + ,@(and additional-blip-characters + `(:additional-delimiter-gestures ,additional-blip-characters)) + ,@keys))) + (t form))) + +(defun accept-1 (stream type + &key (view (stream-default-view stream)) + (default nil default-supplied-p) + (default-type type) + ((:history history-type) type) + (insert-default nil) (replace-input t replace-supplied-p) + (prompt t) + (present-p nil) + (query-identifier nil) + (activation-gestures nil) + (additional-activation-gestures nil) + (delimiter-gestures nil) + (additional-delimiter-gestures nil) + #+CLIM-1-compatibility (activation-characters nil) + #+CLIM-1-compatibility (additional-activation-characters nil) + #+CLIM-1-compatibility (blip-characters nil) + #+CLIM-1-compatibility (additional-blip-characters nil) + &allow-other-keys) + + #+CLIM-1-compatibility + (when (or activation-characters additional-activation-characters + blip-characters additional-blip-characters) + (setq activation-gestures activation-characters + additional-activation-gestures additional-activation-characters + delimiter-gestures blip-characters + additional-delimiter-gestures additional-blip-characters)) + + ;; Set up the input editing environment + (let ((the-object nil) + (the-type nil) + (activated t) + (history nil)) + + (cond ((typep history-type 'basic-history) + (setq history history-type + history-type type)) + (history-type + (setq history (presentation-type-history history-type)))) + + ;; Inside ACCEPTING-VALUES, ACCEPT can turn into PRESENT + (when present-p + (return-from accept-1 + (accept-present-default type stream view default default-supplied-p + present-p query-identifier :prompt prompt))) + + (block input-editing + (flet ((input-sensitizer (continuation stream) + (declare (dynamic-extent continuation)) + (if (stream-recording-p stream) + (with-output-as-presentation (stream the-object (or the-type type)) + (funcall continuation stream)) + (funcall continuation stream)))) + (declare (dynamic-extent #'input-sensitizer)) + (with-input-editing (stream :input-sensitizer #'input-sensitizer + :initial-contents (and insert-default + default-supplied-p + (list default default-type))) + (let ((start-position (stream-scan-pointer stream))) + (with-input-context (type) + (object presentation-type nil options) + (with-activation-gestures ((or activation-gestures + additional-activation-gestures + *standard-activation-gestures*) + :override (not (null activation-gestures))) + (with-delimiter-gestures ((or delimiter-gestures + additional-delimiter-gestures) + :override (not (null delimiter-gestures))) + (handler-bind ((parse-error + #'(lambda (error) + (declare (ignore error)) + (when (and default-supplied-p + (check-for-default stream start-position + default default-type + view)) + (setq the-object default + the-type default-type) + (return-from input-editing)) + ;; Decline to handle the parse error + nil))) + (flet ((accept-help (stream action string-so-far) + (declare (ignore action string-so-far)) + (write-string "You are being asked to enter " stream) + (describe-presentation-type type stream) + (write-char #\. stream))) + (declare (dynamic-extent #'accept-help)) + (with-accept-help + (((:top-level-help :establish-unless-overridden) + ;; :ESTABLISH-... here because we want (SEQUENCE PATHNAME)'s + ;; help, not both (SEQUENCE PATHNAME) and PATHNAME. + #'accept-help)) + ;; Call the presentation type's ACCEPT method + (multiple-value-setq (the-object the-type) + (let ((*presentation-type-for-yanking* (and history history-type))) + (if default-supplied-p + (if history + (let ((default-element + (make-presentation-history-element + :object default :type default-type))) + (with-default-bound-in-history history default-element + (funcall-presentation-generic-function accept + type stream view + :default default :default-type default-type))) + (funcall-presentation-generic-function accept + type stream view + :default default :default-type default-type)) + (funcall-presentation-generic-function accept + type stream view))))))))) + + ;; A presentation translator was invoked + (t + (setq the-object object + the-type presentation-type + activated nil) + (when (if replace-supplied-p + replace-input + (getf options :echo t)) + (presentation-replace-input stream object presentation-type view + :buffer-start start-position + :query-identifier query-identifier)))))))) + + ;; The input has been parsed, moused, or defaulted. + ;; If we are still inside a WITH-INPUT-EDITING at an outer level, leave the + ;; delimiter in the stream. But if this was the top level of input, eat + ;; the activation gesture instead of leaving it in the stream. Don't eat + ;; the activation gesture on streams that can't ever support input editing, + ;; such as string streams. + ;;--- This is really lousy. We need a coherent theory here. + (when activated + (when (and (not (input-editing-stream-p stream)) + (stream-supports-input-editing stream)) + (let ((gesture (read-gesture :stream stream :timeout 0))) + ;;--- For now, just ignore button release events + (when (typep gesture 'pointer-button-release-event) + (read-gesture :stream stream :timeout 0))))) + (when (and history (frame-maintain-presentation-histories *application-frame*)) + ;;--- Should this only record stuff that was input via the keyboard? + (push-history-element history (make-presentation-history-element + :object the-object :type (or the-type type)))) + #+compulsive-type-checking + (when (and the-type (not (eq the-type type))) + (unless (presentation-subtypep the-type type) + ;; Catch a common bug by verifying that the returned type is a subtype + ;; of the requested type + (cerror "Return a second value of ~*~*~*~S" + "The ~S method for the type ~S returned a second value of ~S, ~ + which is not a subtype of ~S" + 'accept type the-type type) + (setq the-type type))) + ;; Ensure that there are no stale highlighting boxes lying around if + ;; we are exiting via keyboard input + (when (output-recording-stream-p stream) + (unhighlight-highlighted-presentation stream t)) + (values the-object (or the-type type)))) + + +(defclass dialog-view (textual-dialog-view) ()) +(defclass menu-view (textual-menu-view) ()) +(defclass iconic-view (gadget-view) ()) + +(defvar +dialog-view+ (make-instance 'dialog-view)) +(defvar +menu-view+ (make-instance 'menu-view)) +(defvar +iconic-view+ (make-instance 'iconic-view)) + + +(defmacro call-presentation-generic-function (&rest name-and-args) + (let* ((apply-p (and (eql (first name-and-args) 'apply) + (pop name-and-args))) + (name (pop name-and-args)) + (args name-and-args)) + (warn "The function ~S is now obsolete, use ~S instead.~%~ + Compatibility code is being generated for the time being." + 'call-presentation-generic-function + (if apply-p + 'apply-presentation-generic-function + 'funcall-presentation-generic-function)) + (if apply-p + `(apply-presentation-generic-function ,name ,@args) + `(funcall-presentation-generic-function ,name ,@args)))) + + +(defun test-presentation-translator (translator presentation context-type + frame window x y + &key event (modifier-state 0) for-menu + #+CLIM-1-compatibility (shift-mask 0 shift-mask-p)) + #+CLIM-1-compatibility + (when shift-mask-p + (setq modifier-state shift-mask)) + (and (presentation-translator-matches-event translator event modifier-state for-menu) + (test-presentation-translator-1 translator presentation context-type + frame event window x y))) + +(define-compiler-macro test-presentation-translator + (&whole form + translator presentation context-type frame window x y + &key event (modifier-state 0) for-menu (shift-mask 0 shift-mask-p)) + (declare (ignore modifier-state)) + (cond (shift-mask-p + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'test-presentation-translator) + `(test-presentation-translator + ,translator ,presentation ,context-type ,frame ,window ,x ,y + ,@(and event `(:event ,event)) + :modifier-state ,shift-mask + ,@(and for-menu `(:for-menu ,for-menu)))) + (t form))) + + +(defun presentation-matches-context-type (presentation context-type + frame window x y + &key event (modifier-state 0) + #+CLIM-1-compatibility + (shift-mask 0 shift-mask-p)) + (declare (values translator any-match-p)) + #+CLIM-1-compatibility + (when shift-mask-p + (setq modifier-state shift-mask)) + (let ((one-matched nil) + (translators + (find-presentation-translators + (presentation-type presentation) context-type (frame-command-table frame)))) + (when translators + (dolist (translator translators) + (let ((by-gesture + (presentation-translator-matches-event translator event modifier-state)) + (by-tester + (test-presentation-translator-1 translator presentation context-type + frame event window x y))) + (when (and by-gesture by-tester) + ;; Matched by both gesture and by the tester, we're done + (return-from presentation-matches-context-type + (values translator t))) + (when by-tester + ;; We matched by the tester, it's OK to try the menu translator + ;; unless the translator is not supposed to be in a menu. + (setq one-matched (or one-matched + (presentation-translator-menu translator)))))) + ;; If EVENT is non-NIL, then we are running on behalf of the user having + ;; pressed a pointer button, which means that some translator must have + ;; matched during the test phase, which means that the PRESENTATION-MENU + ;; translator might be applicable, even though no others were found. + (let ((menu-applicable + (and one-matched + *presentation-menu-translator* + (test-presentation-translator *presentation-menu-translator* + presentation context-type + frame window x y + :modifier-state modifier-state + :event event)))) + (if (and event menu-applicable) + (values *presentation-menu-translator* t) + (values nil (and one-matched + (presentation-translator-matches-event + *presentation-menu-translator* event modifier-state)))))))) + +(define-compiler-macro presentation-matches-context-type + (&whole form + presentation context-type frame window x y + &key event (modifier-state 0) (shift-mask 0 shift-mask-p)) + (declare (ignore modifier-state)) + (cond (shift-mask-p + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'presentation-matches-context-type) + `(presentation-matches-context-type + ,presentation ,context-type ,frame ,window ,x ,y + ,@(and event `(:event ,event)) + :modifier-state ,shift-mask)) + (t form))) + + +(defun find-applicable-translators (presentation input-context frame window x y + &key event modifier-state (for-menu nil for-menu-p) fastp + #+CLIM-1-compatibility (shift-mask nil shift-mask-p)) + #+CLIM-1-compatibility + (when shift-mask-p + (setq modifier-state shift-mask)) + (let ((applicable-translators nil)) + (do ((presentation presentation + (parent-presentation-with-shared-box presentation window))) + ((null presentation)) + (let ((from-type (presentation-type presentation))) + ;; Loop over the contexts, from the most specific to the least specific + (dolist (context input-context) + (let ((context-type (pop context)) ;input-context-type = first + (tag (pop context))) ;input-context-tag = second + (let ((translators (find-presentation-translators + from-type context-type (frame-command-table frame)))) + (when translators + (dolist (translator translators) + (when (and (or (not for-menu-p) + (eq (presentation-translator-menu translator) for-menu)) + (test-presentation-translator translator + presentation context-type + frame window x y + :event event + :modifier-state modifier-state + :for-menu for-menu)) + (when fastp + (return-from find-applicable-translators translator)) + ;; Evacuate the context-type, but don't bother evacuating the + ;; tag since it will get used before its extent expires. + (push (list translator presentation + (evacuate-list context-type) tag) + applicable-translators)))) + ;; If we've accumulated any translators, maybe add on PRESENTATION-MENU. + ;; If FASTP is T, we will have returned before we get here. + (when (and applicable-translators + *presentation-menu-translator* + (or (not for-menu-p) + (eq (presentation-translator-menu *presentation-menu-translator*) + for-menu)) + (test-presentation-translator *presentation-menu-translator* + presentation context-type + frame window x y + :event event + :modifier-state modifier-state + :for-menu for-menu)) + (push (list *presentation-menu-translator* presentation + (evacuate-list context-type) tag) + applicable-translators))))))) + ;; Since we pushed translators onto the list, the least specific one + ;; will be at the beginning of the list. DELETE-DUPLICATES is defined to + ;; remove duplicated items which appear earlier in the list, so it will + ;; remove duplicated less specific translators. Finally, NREVERSE will + ;; get the translators in most-specific to least-specific order. + (nreverse (delete-duplicates applicable-translators + :test #'(lambda (x y) + (and (eq (first x) (first y)) + (eq (second x) (second y)))))))) + +(define-compiler-macro find-applicable-translators + (&whole form + presentation input-context frame window x y + &key event (modifier-state 0) (for-menu nil for-menu-p) fastp + (shift-mask 0 shift-mask-p)) + (declare (ignore modifier-state)) + (cond (shift-mask-p + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'find-applicable-translators) + `(find-applicable-translators + ,presentation ,input-context ,frame ,window ,x ,y + ,@(and event `(:event ,event)) + :modifier-state ,shift-mask + ,@(and for-menu-p `(:for-menu ,for-menu)) + ,@(and fastp `(:fastp ,fastp)))) + (t form))) + + +(defun find-presentation-translators (from-type to-type command-table) + #+CLIM-1-compatibility + (when (application-frame-p command-table) + (setq command-table (frame-command-table command-table))) + (setq command-table (find-command-table command-table)) + (with-slots (translators-cache) command-table + (let ((cache translators-cache)) ;for speed... + (with-presentation-type-translator-key (from-key from-type) + (with-presentation-type-translator-key (to-key to-type) + (with-stack-list (key from-key to-key) + (multiple-value-bind (translators found-p) + (and cache (gethash key cache)) + (cond ((or (null found-p) + (/= (pop translators) *translators-cache-tick*)) + (let ((translators (find-presentation-translators-1 + from-key to-key command-table))) + (when (null cache) + (setq translators-cache + (make-hash-table :size *translators-cache-size* + :test #'equal)) + (setq cache translators-cache)) + ;; Need to copy the whole tree, since the from- and to-keys + ;; could themselves be stack-consed. + (setf (gethash (copy-tree key) cache) + (cons *translators-cache-tick* translators)) + translators)) + (t + ;; Already popped above + translators))))))))) + + +(defun find-innermost-applicable-presentation + (input-context stream x y + &key (frame *application-frame*) + (modifier-state (window-modifier-state stream)) event + #+CLIM-1-compatibility (shift-mask 0 shift-mask-p)) + #+CLIM-1-compatibility + (when shift-mask-p + (setq modifier-state shift-mask)) + (let ((x (coordinate x)) + (y (coordinate y))) + (declare (type coordinate x y)) + ;; Depth first search for a presentation that is both under the pointer and + ;; matches the input context. + ;; This relies on MAP-OVER-OUTPUT-RECORDS-CONTAINING-POSITION traversing + ;; the most recently drawn of overlapping output records first. + (labels + ((mapper (record presentations x-offset y-offset) + (declare (type coordinate x-offset y-offset)) + ;; RECORD is an output record whose bounding rectangle contains (X,Y). + ;; PRESENTATIONS is a list of non-:SINGLE-BOX presentations that are + ;; ancestors of RECORD. + ;; X-OFFSET and Y-OFFSET are the position on the drawing plane of the + ;; origin of RECORD's coordinate system, i.e. RECORD's parent's start-position. + (multiple-value-bind (sensitive superior-sensitive inferior-presentation) + ;; SENSITIVE is true if RECORD is a presentation to test against the context. + ;; SUPERIOR-SENSITIVE is true if PRESENTATIONS should be tested also. + ;; INFERIOR-PRESENTATION is a presentation to pass down to our children. + (if (presentationp record) + ;;--- This should call PRESENTATION-REFINED-POSITION-TEST + (if (output-record-refined-position-test + record (- x x-offset) (- y y-offset)) + ;; Passed user-defined sensitivity test for presentations. + ;; It might be both a presentation and a displayed output record. + ;; It might be sensitive now [:single-box t] or the decision might + ;; depend on finding a displayed output record [:single-box nil]. + (let ((displayed (displayed-output-record-p record)) + (single-box (presentation-single-box record))) + (if (or (eq single-box t) (eq single-box :position)) + ;; This presentation is sensitive + (values t displayed nil) + ;; This presentation is not presented as a single box, + ;; so it contains the point (X,Y) if and only if a + ;; visibly displayed inferior contains that point. + (values nil displayed record))) + (values nil nil nil)) + ;; RECORD is not a presentation, but a superior presentation's + ;; sensitivity might depend on whether record contains (X,Y) + (values nil + (and presentations + (dolist (presentation presentations nil) + (unless (null presentation) (return t))) + (displayed-output-record-p record) + ;; Call the refined position test for displayed + ;; output records (e.g., ellipses, text, etc.) + (output-record-refined-position-test + record (- x x-offset) (- y y-offset))) + nil)) + + ;; Add INFERIOR-PRESENTATION to PRESENTATIONS + (with-stack-list* (more-presentations inferior-presentation presentations) + (when inferior-presentation + (setq presentations more-presentations)) + + ;; Depth-first recursion + (multiple-value-bind (dx dy) (output-record-position record) + (map-over-output-records-containing-position + #'mapper record x y + (- x-offset) (- y-offset) + presentations (+ x-offset dx) (+ y-offset dy))) + + ;; If we get here, didn't find anything in the inferiors of record so test + ;; any presentations that are now known to be sensitive, depth-first + (when sensitive + (test record)) + (when superior-sensitive + (do* ((presentations presentations (cdr presentations)) + (presentation (car presentations) (car presentations))) + ((null presentations)) + (when presentation + (test presentation) + ;; A given presentation only has to be tested once + (setf (car presentations) nil))))))) + (test (presentation) + ;; This presentation contains the point (X,Y). See if there is + ;; a translator from it to the input context. + (dolist (context input-context) + (let ((context-type (input-context-type context))) + (multiple-value-bind (translator any-match-p) + (presentation-matches-context-type presentation context-type + frame stream x y + :event event + :modifier-state modifier-state) + (declare (ignore translator)) + (when any-match-p + (return-from find-innermost-applicable-presentation + presentation))))))) + (declare (dynamic-extent #'mapper #'test)) + (mapper (stream-output-history stream) nil (coordinate 0) (coordinate 0))))) + +(define-compiler-macro find-innermost-applicable-presentation + (&whole form + input-context window x y + &key frame event (modifier-state 0) (shift-mask 0 shift-mask-p)) + (declare (ignore modifier-state)) + (cond (shift-mask-p + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'find-innermost-applicable-presentation) + `(find-innermost-applicable-presentation + ,input-context ,window ,x ,y + ,@(and frame `(:frame ,frame)) + ,@(and event `(:event ,event)) + :modifier-state ,shift-mask)) + (t form))) + + +(defmacro define-gesture-name (name &rest options) + (let (type gesture-spec unique) + (cond ((member (first options) '(:keyboard :pointer-button)) + (setq type (pop options) + gesture-spec (pop options) + unique (getf options :unique t))) + (t + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'define-gesture-name) + (setq type :pointer-button + gesture-spec (cons (getf options :button :left) + (getf options :shifts)) + unique t))) + (setf (compile-time-property name 'gesture-name) t) + `(add-gesture-name ',name ',type ',gesture-spec :unique ',unique))) + +(define-compatibility-function (add-pointer-gesture-name add-gesture-name) + (name button modifiers &key (action :click) (unique t)) + (add-gesture-name name :pointer-button `(,button ,modifiers) :unique unique)) + +(define-compatibility-function (remove-pointer-gesture-name delete-gesture-name) + (name) + (delete-gesture-name name)) + + +(defmacro with-activation-characters ((additional-characters &key override) &body body) + (warn "The function ~S is now obsolete, use ~S instead.~%~ + Compatibility code is being generated for the time being." + 'with-activation-characters 'with-activation-gestures) + `(with-activation-gestures (,additional-characters :override ,override) ,@body)) + +(define-compatibility-function (activation-character-p activation-gesture-p) + (character) + (activation-gesture-p character)) + +(defmacro with-blip-characters ((additional-characters &key override) &body body) + (warn "The function ~S is now obsolete, use ~S instead.~%~ + Compatibility code is being generated for the time being." + 'with-blip-characters 'with-delimiter-gestures) + `(with-delimiter-gestures (,additional-characters :override ,override) ,@body)) + +(define-compatibility-function (blip-character-p delimiter-gesture-p) + (character) + (delimiter-gesture-p character)) + + +(define-compatibility-function (input-position stream-scan-pointer) + (stream) + (stream-scan-pointer stream)) + +(define-compatibility-function (insertion-pointer stream-insertion-pointer) + (stream) + (stream-insertion-pointer stream)) + +(define-compatibility-function (rescanning-p stream-rescanning-p) + (stream) + (stream-rescanning-p stream)) + + +(defgeneric menu-choose (items &rest keys + &key associated-window default-item default-style + label printer presentation-type + cache unique-id id-test cache-value cache-test + max-width max-height n-rows n-columns + x-spacing y-spacing + cell-align-x cell-align-y + pointer-documentation + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing)) + +;; Are these reasonable defaults for UNIQUE-ID, CACHE-VALUE, ID-TEST, and CACHE-TEST? +(defmethod menu-choose ((items t) &rest keys + &key (associated-window (frame-top-level-sheet *application-frame*)) + default-item default-style + label printer presentation-type + (cache nil) (unique-id items) (id-test #'equal) + (cache-value items) (cache-test #'equal) + max-width max-height n-rows n-columns + x-spacing y-spacing + (cell-align-x ':left) (cell-align-y ':top) + pointer-documentation + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing) + (declare (values value chosen-item gesture)) + (declare (ignore associated-window + default-item default-style + label printer presentation-type + cache unique-id id-test cache-value cache-test + max-width max-height n-rows n-columns + x-spacing y-spacing cell-align-x cell-align-y + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing + pointer-documentation)) + (declare (dynamic-extent keys)) + (unless (zerop (length items)) + (apply #'frame-manager-menu-choose (frame-manager *application-frame*) items keys))) + +(define-compiler-macro menu-choose + (&whole form + items + &rest keys + &key inter-row-spacing inter-column-spacing + &allow-other-keys) + (cond ((or inter-row-spacing inter-column-spacing) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'menu-choose) + (with-keywords-removed (keys keys '(:x-spacing :y-spacing + :inter-row-spacing :inter-column-spacing)) + `(menu-choose + ,items + ,@(and inter-row-spacing `(:y-spacing ,inter-row-spacing)) + ,@(and inter-column-spacing `(:x-spacing ,inter-column-spacing)) + ,@keys))) + (t form))) + +(defmethod frame-manager-menu-choose + ((framem standard-frame-manager) items &rest keys + &key (associated-window + (frame-top-level-sheet *application-frame*)) + default-item default-style + label printer presentation-type + (cache nil) (unique-id items) (id-test #'equal) + (cache-value items) (cache-test #'equal) + max-width max-height n-rows n-columns + x-spacing y-spacing + (cell-align-x ':left) (cell-align-y ':top) + pointer-documentation + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing) + (declare (values value chosen-item gesture)) + (declare (ignore keys)) + #+CLIM-1-compatibility + (when (or inter-row-spacing inter-column-spacing) + (setq x-spacing inter-column-spacing + y-spacing inter-row-spacing)) + (flet ((present-item (item stream) + (present item presentation-type :stream stream))) + (declare (dynamic-extent #'present-item)) + (let ((item-printer (cond (presentation-type #'present-item) + (printer printer) + (t #'print-menu-item))) + ;; Lucid production compiler tries to use an undefined internal + ;; variable if this LET isn't done. + #+Lucid (items items)) + (with-menu (menu associated-window) + (setf (window-label menu) label) + (reset-frame (pane-frame menu) :title label) + (with-text-style (menu default-style) + (with-end-of-line-action (menu :allow) + (loop + (multiple-value-bind (item gesture) + (flet ((menu-choose-body (stream presentation-type) + (draw-standard-menu stream presentation-type items default-item + :item-printer item-printer + :max-width max-width :max-height max-height + :n-rows n-rows :n-columns n-columns + :x-spacing x-spacing :y-spacing y-spacing + :cell-align-x cell-align-x + :cell-align-y cell-align-y))) + (declare (dynamic-extent #'menu-choose-body)) + (menu-choose-from-drawer + menu 'menu-item #'menu-choose-body + :cache cache + :unique-id unique-id :id-test id-test + :cache-value cache-value :cache-test cache-test + :pointer-documentation pointer-documentation)) + (cond ((menu-item-items item) + ;; Set the new item list, then go back through the loop. + ;; Don't cache, because that will cause us to see the same + ;; menu items again and again. + (setq items (menu-item-items item) + default-item nil + cache nil) + (clear-output-history menu)) + (t (return-from frame-manager-menu-choose + (values (menu-item-value item) item gesture)))))))))))) + +(defun hierarchical-menu-choose (items + &key (associated-window + (frame-top-level-sheet *application-frame*)) + default-item default-style + label printer presentation-type + x-position y-position + (cache nil) + (unique-id items) (id-test #'equal) + (cache-value items) (cache-test #'equal) + max-width max-height n-rows n-columns + x-spacing y-spacing + (cell-align-x ':left) (cell-align-y ':top) + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing) + (declare (values value chosen-item gesture)) + #+CLIM-1-compatibility + (when (or inter-row-spacing inter-column-spacing) + (setq x-spacing inter-column-spacing + y-spacing inter-row-spacing)) + (flet ((present-item (item stream) + (present item presentation-type :stream stream))) + (declare (dynamic-extent #'present-item)) + (let ((item-printer (cond (presentation-type #'present-item) + (printer printer) + (t #'print-menu-item)))) + (with-menu (menu associated-window) + (setf (window-label menu) label) + (with-text-style (menu default-style) + (multiple-value-bind (item gesture) + (flet ((menu-choose-body (stream presentation-type) + (draw-standard-menu stream presentation-type items default-item + :item-printer item-printer + :max-width max-width :max-height max-height + :n-rows n-rows :n-columns n-columns + :x-spacing x-spacing :y-spacing y-spacing + :cell-align-x cell-align-x + :cell-align-y cell-align-y))) + (declare (dynamic-extent #'menu-choose-body)) + (menu-choose-from-drawer + menu 'menu-item #'menu-choose-body + :x-position x-position :y-position y-position + :leave-menu-visible t + :cache cache + :unique-id unique-id :id-test id-test + :cache-value cache-value :cache-test cache-test)) + (cond ((menu-item-items item) + (with-bounding-rectangle* (ml mt mr mb) menu + (declare (ignore ml mb)) + ;;--- How to pass on LABEL, PRINTER, and PRESENTATION-TYPE? + (hierarchical-menu-choose + (menu-item-items item) + :associated-window associated-window + :default-style default-style + :x-position mr :y-position mt + :cache cache + :unique-id unique-id :id-test id-test + :cache-value cache-value :cache-test cache-test))) + (t (return-from hierarchical-menu-choose + (values (menu-item-value item) item gesture)))))))))) + +(define-compiler-macro hierarchical-menu-choose + (&whole form + items + &rest keys + &key inter-row-spacing inter-column-spacing + &allow-other-keys) + (cond ((or inter-row-spacing inter-column-spacing) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'hierarchical-menu-choose) + (with-keywords-removed (keys keys '(:x-spacing :y-spacing + :inter-row-spacing :inter-column-spacing)) + `(hierarchical-menu-choose + ,items + ,@(and inter-row-spacing `(:y-spacing ,inter-row-spacing)) + ,@(and inter-column-spacing `(:x-spacing ,inter-column-spacing)) + ,@keys))) + (t form))) + +(defun draw-standard-menu (menu presentation-type items default-item + &key (item-printer #'print-menu-item) + max-width max-height n-rows n-columns + x-spacing y-spacing + (cell-align-x ':left) (cell-align-y ':top) + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing + &aux default-presentation) + #+CLIM-1-compatibility + (when (or inter-row-spacing inter-column-spacing) + (setq x-spacing inter-column-spacing + y-spacing inter-row-spacing)) + (formatting-item-list (menu :max-width max-width :max-height max-height + :n-rows n-rows :n-columns n-columns + :x-spacing x-spacing :y-spacing y-spacing + :move-cursor nil) + (flet ((format-item (item) + (let ((type (menu-item-type item))) + (flet ((print-item () + (formatting-cell (menu :align-x cell-align-x + :align-y cell-align-y) + (funcall item-printer item menu)))) + (declare (dynamic-extent #'print-item)) + (ecase type + (:item + (if (menu-item-active item) + (let ((presentation + (with-output-as-presentation (menu item presentation-type + :single-box t) + (print-item)))) + (when (and default-item + (eq item default-item)) + (setf default-presentation presentation))) + (with-drawing-options (menu :ink *command-table-menu-gray* + :text-face :bold) + (print-item)))) + (:label + (print-item)) + (:divider + (let* ((width (menu-item-getf item :width 50)) + (thickness (menu-item-getf item :thickness 2)) + (ink (menu-item-getf item :ink *command-table-menu-gray*))) + (formatting-cell (menu :align-x cell-align-x + :align-y :center) + (with-local-coordinates (menu) + (draw-line* menu 0 0 width 0 + :line-thickness thickness :ink ink)))))))))) + (declare (dynamic-extent #'format-item)) + (map nil #'format-item items))) + default-presentation) + +(define-compiler-macro draw-standard-menu + (&whole form + menu presentation-type items default-item + &rest keys + &key inter-row-spacing inter-column-spacing + &allow-other-keys) + (cond ((or inter-row-spacing inter-column-spacing) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'draw-standard-menu) + (with-keywords-removed (keys keys '(:x-spacing :y-spacing + :inter-row-spacing :inter-column-spacing)) + `(draw-standard-menu + ,menu ,presentation-type ,items ,default-item + ,@(and inter-row-spacing `(:y-spacing ,inter-row-spacing)) + ,@(and inter-column-spacing `(:x-spacing ,inter-column-spacing)) + ,@keys))) + (t form))) + +(defmacro define-static-menu (name root-window items + &rest keys + &key default-item default-style + printer presentation-type + max-width max-height n-rows n-columns + x-spacing y-spacing + (cell-align-x ':left) (cell-align-y ':top) + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing) + (declare (ignore max-width max-height n-rows n-columns + x-spacing y-spacing cell-align-x cell-align-y + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing)) + (with-keywords-removed (drawer-keys keys + '(:default-item :default-style :printer :presentation-type)) + `(defvar ,name (define-static-menu-1 ',name ,root-window ',items + :default-item ',default-item + :default-style ',default-style + :presentation-type ',presentation-type + :printer ',printer + :drawer-args ,(copy-list drawer-keys))))) + + +(defvar *unsupplied-argument* *unsupplied-argument-marker*) + +(defun display-command-table-menu (command-table stream + &key max-width max-height + n-rows n-columns + x-spacing y-spacing + (cell-align-x ':left) (cell-align-y ':top) + (initial-spacing t) move-cursor + #+CLIM-1-compatibility inter-row-spacing + #+CLIM-1-compatibility inter-column-spacing) + #+CLIM-1-compatibility + (when (or inter-row-spacing inter-column-spacing) + (setq x-spacing inter-column-spacing + y-spacing inter-row-spacing)) + (unless (or max-width max-height) + (multiple-value-bind (width height) + (bounding-rectangle-size (sheet-region stream)) + (unless max-width (setf max-width width)) + (unless max-height (setf max-height height)))) + (let ((menu (slot-value (find-command-table command-table) 'menu))) + (if (zerop (count-if #'(lambda (x) (not (null (first x)))) menu)) + (with-text-face (stream :italic) + (write-string "[No menu items]" stream)) + (formatting-item-list (stream :max-width max-width :max-height max-height + :n-rows n-rows :n-columns n-columns + :x-spacing x-spacing :y-spacing y-spacing + :initial-spacing initial-spacing + :move-cursor move-cursor) + (dovector (element menu) + (cond ((eq (command-menu-item-type (third element)) :divider) + (typecase (first element) + (string + (let ((text-style + (getf (command-menu-item-options (third element)) :text-style))) + (with-text-style (stream text-style) + (formatting-cell (stream :align-x cell-align-x + :align-y cell-align-y) + (write-string (first element) stream))))) + (null + (let* ((options (command-menu-item-options (third element))) + (width (getf options :width 50)) + (thickness (getf options :thickness 2)) + (ink (getf options :ink *command-table-menu-gray*))) + (formatting-cell (stream :align-x cell-align-x + :align-y :center) + (with-local-coordinates (stream) + (draw-line* stream 0 0 width 0 + :line-thickness thickness :ink ink))))))) + ((first element) + (formatting-cell (stream :align-x cell-align-x :align-y cell-align-y) + (present element 'command-menu-element + :stream stream :single-box t))))))))) + +(define-compiler-macro display-command-table-menu + (&whole form + command-table stream + &rest keys + &key inter-row-spacing inter-column-spacing + &allow-other-keys) + (cond ((or inter-row-spacing inter-column-spacing) + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'display-command-table-menu) + (with-keywords-removed (keys keys '(:x-spacing :y-spacing + :inter-row-spacing :inter-column-spacing)) + `(display-command-table-menu + ,command-table ,stream + ,@(and inter-row-spacing `(:y-spacing ,inter-row-spacing)) + ,@(and inter-column-spacing `(:x-spacing ,inter-column-spacing)) + ,@keys))) + (t form))) + + +(defun add-command-to-command-table (command-name command-table + &key name menu keystroke (errorp t) + #+CLIM-1-compatibility test) + #+CLIM-1-compatibility (declare (ignore test)) + (check-type command-name symbol) + (setq command-table (find-command-table command-table)) + (when (eq name t) + (setq name (command-name-from-symbol command-name))) + (check-type name (or string null)) + (when keystroke + (assert (keyboard-gesture-spec-p keystroke) (keystroke) + "~S is not a keyboard gesture spec" keystroke)) + (when (command-present-in-command-table-p command-name command-table) + (when errorp + (cerror "Remove the command and proceed" + 'command-already-present + :format-string "Command ~S already present in ~S" + :format-args (list command-name command-table))) + (remove-command-from-command-table command-name command-table)) + (let ((menu-name nil) + (menu-options nil)) + (when menu + (setq menu-name (if (consp menu) (first menu) menu)) + (when (eq menu-name t) + (setq menu-name (or name (command-name-from-symbol command-name)))) + (check-type menu-name string) + (setq menu-options (if (consp menu) (rest menu) nil))) + (with-slots (commands) command-table + (if name + (add-command-line-name-to-command-table command-table name command-name) + (setf (gethash command-name commands) t)) + (cond (menu + (apply #'add-menu-item-to-command-table + command-table menu-name ':command command-name + :keystroke keystroke :errorp errorp + menu-options)) + (keystroke + (add-keystroke-to-command-table command-table keystroke ':command command-name + :errorp errorp))))) + command-name) + +(define-compiler-macro add-command-to-command-table + (command-name command-table + &rest keys &key test &allow-other-keys) + (cond (test + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'add-command-to-command-table) + (with-keywords-removed (keys keys '(:test)) + `(add-command-to-command-table + ,command-name ,command-table ,@keys))) + (t form))) + + +(defun add-keystroke-to-command-table (command-table keystroke type value + &key documentation (errorp t) + #+CLIM-1-compatibility test) + #+CLIM-1-compatibility (declare (ignore test)) + (assert (keyboard-gesture-spec-p keystroke) (keystroke) + "~S is not a keyboard gesture spec" keystroke) + (check-type type (member :command :function :menu)) + (check-type documentation (or string null)) + (setq command-table (find-command-table command-table)) + (let ((old-item (find-keystroke-item keystroke command-table + :test #'gesture-spec-eql :errorp nil))) + (when old-item + (when errorp + (cerror "Remove the keystroke item and proceed" + 'command-already-present + :format-string "Keystroke item ~S already present in ~S" + :format-args (list keystroke command-table))) + (remove-keystroke-from-command-table command-table keystroke))) + (add-menu-item-to-command-table command-table nil type value + :documentation documentation + :keystroke keystroke :errorp nil)) + +(define-compiler-macro add-keystroke-to-command-table + (command-table keystroke type value + &rest keys &key test &allow-other-keys) + (cond (test + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'add-keystroke-to-command-table) + (with-keywords-removed (keys keys '(:test)) + `(add-keystroke-to-command-table + ,command-table ,keystroke ,type ,value ,@keys))) + (t form))) + + +(defun remove-keystroke-from-command-table (command-table keystroke + &key (errorp t) + #+CLIM-1-compatibility test) + #+CLIM-1-compatibility (declare (ignore test)) + (setq command-table (find-command-table command-table)) + (with-slots (menu keystrokes) command-table + (let ((index (position keystroke menu :key #'second :test #'gesture-spec-eql))) + (cond (index + (let ((element (aref menu index))) + ;; Don't remove the whole item if there's a menu-name, + ;; just remove the accelerator + (when (stringp (first element)) + (setf (second element) nil) + (return-from remove-keystroke-from-command-table nil))) + (unless (= (1+ index) (fill-pointer menu)) + (replace menu menu :start1 index :start2 (1+ index)) + (decf (fill-pointer menu)) + (setq keystrokes nil))) + (t + (when errorp + (error 'command-not-present + :format-string "Keystroke item ~S not present in ~S" + :format-args (list keystroke command-table)))))))) + +(define-compiler-macro remove-keystroke-from-command-table + (command-table keystroke + &rest keys &key test &allow-other-keys) + (cond (test + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'remove-keystroke-from-command-table) + (with-keywords-removed (keys keys '(:test)) + `(remove-keystroke-from-command-table + ,command-table ,keystroke ,@keys))) + (t form))) + + +(defun read-command (command-table + &key (stream *query-io*) + (command-parser *command-parser*) + (command-unparser *command-unparser*) + (partial-command-parser *partial-command-parser*) + (use-keystrokes nil) + #+CLIM-1-compatibility keystroke-test) + #+CLIM-1-compatibility (declare (ignore keystroke-test)) + (if use-keystrokes + (with-command-table-keystrokes (keystrokes command-table) + (read-command-using-keystrokes command-table keystrokes + :stream stream + :command-parser command-parser + :command-unparser command-unparser + :partial-command-parser partial-command-parser)) + (let ((*command-parser* command-parser) + (*command-unparser* command-unparser) + (*partial-command-parser* partial-command-parser)) + (values (accept `(command :command-table ,command-table) + :stream stream :prompt nil))))) + +(define-compiler-macro read-command + (command-table + &rest keys &key keystroke-test &allow-other-keys) + (cond (test + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'read-command) + (with-keywords-removed (keys keys '(:keystroke-test)) + `(read-command ,command-table ,@keys))) + (t form))) + + +(defun read-command-using-keystrokes (command-table keystrokes + &key (stream *query-io*) + (command-parser *command-parser*) + (command-unparser *command-unparser*) + (partial-command-parser *partial-command-parser*) + #+CLIM-1-compatibility keystroke-test) + #+CLIM-1-compatibility (declare (ignore keystroke-test)) + (let ((*command-parser* command-parser) + (*command-unparser* command-unparser) + (*partial-command-parser* partial-command-parser)) + ;; NUMERIC-ARG only applies when we read a keystroke accelerator + (multiple-value-bind (command numeric-arg) + (block keystroke + (handler-bind ((accelerator-gesture + #'(lambda (c) + (return-from keystroke + (values + (accelerator-gesture-event c) + (accelerator-gesture-numeric-argument c)))))) + (let ((*accelerator-gestures* keystrokes)) + (accept `(command :command-table ,command-table) + :stream stream :prompt nil)))) + (if (keyboard-event-p command) + (let ((command (lookup-keystroke-command-item command command-table + :numeric-argument numeric-arg))) + (if (partial-command-p command) + (funcall *partial-command-parser* + command command-table stream nil :for-accelerator t) + command)) + command)))) + +(define-compiler-macro read-command-using-keystrokes + (command-table keystrokes + &rest keys &key keystroke-test &allow-other-keys) + (cond (test + (warn "Converting old style call to ~S to the new style.~%~ + Please update your code." 'read-command-using-keystrokes) + (with-keywords-removed (keys keys '(:keystroke-test)) + `(read-command-using-keystrokes ,command-table ,@keys))) + (t form))) + + +(define-compatibility-function (set-frame-layout (setf frame-current-layout)) + (frame layout) + (setf (frame-current-layout frame) layout)) + +(define-compatibility-function (frame-top-level-window frame-top-level-sheet) + (frame) + (frame-top-level-sheet frame)) + +(define-compatibility-function (command-enabled-p command-enabled) + (command-name frame) + (command-enabled command-name frame)) + +(define-compatibility-function (enable-command (setf command-enabled)) + (command-name frame) + (setf (command-enabled command-name frame) t)) + +(define-compatibility-function (disable-command (setf command-enabled)) + (setf (command-enabled command-name frame) nil)) + + +(defmacro with-frame-state-variables + ((frame-name &optional (frame '*application-frame*)) &body body) + (warn "The macro ~S is obsolete, use ~S instead." + 'with-frame-state-variables 'with-slots) + (let* ((slots (clos:class-slots (clos:find-class frame-name))) + (slot-names (mapcar #'clos:slot-definition-name slots))) + `(with-slots ,slot-names ,frame ,@body))) + + +(define-compatibility-function (position-window-near-carefully position-sheet-carefully) + (window x y) + (position-sheet-carefully window x y)) + +(define-compatibility-function (position-window-near-pointer position-sheet-near-pointer) + (window &optional x y) + (position-sheet-near-pointer window x y)) + +(define-compatibility-function (size-menu-appropriately size-frame-from-contents) + (menu &key width height right-margin bottom-margin size-setter) + (size-frame-from-contents menu + :width width :height height + :right-margin right-margin :bottom-margin bottom-margin + :size-setter size-setter)) + + +(define-compatibility-function (open-window-stream make-clim-stream-pane) + (&key parent + left top right bottom width height + (text-style *default-text-style*) + (vertical-spacing 2) + (end-of-line-action :allow) + (end-of-page-action :allow) + (background +white+) + (foreground +black+) + output-history + text-cursor text-margin + label save-under + (scroll-bars :vertical) + (class 'clim-stream-pane)) + (with-look-and-feel-realization () + (make-clim-stream-pane :type class + :left left :top top :right right :bottom bottom + :width width :height height + :text-style text-style :vertical-spacing vertical-spacing + :end-of-line-action end-of-line-action + :end-of-page-action end-of-page-action + :background background :foreground foreground + :output-history output-history + :text-cursor text-cursor :text-margin text-margin + :label label :save-under save-under + :scroll-bars scroll-bars))) + +(define-compatibility-function (open-root-window find-port) + (type &rest args) + (declare (ignore args)) + (find-port :server-path (if (listp type) type (list type)))) diff --git a/compatibility/packages.lisp b/compatibility/packages.lisp new file mode 100644 index 00000000..82fa3c71 --- /dev/null +++ b/compatibility/packages.lisp @@ -0,0 +1,115 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-INTERNALS; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(in-package :clim-internals) + +"Copyright (c) 1992 Symbolics, Inc. All rights reserved." + + +(defvar *clim-1-symbols* + '(*abort-characters* + *activation-characters* + *blip-characters* + *completion-characters* + *help-characters* + *possibilities-characters* + *standard-activation-characters* + *unsupplied-argument* + +background+ + +dialog-view+ + +foreground+ + +menu-view+ + activation-character-p + add-output-record-element + add-pointer-gesture-name + add-text-style-mapping + blip-character-p + bounding-rectangle-position* + call-presentation-generic-function + command-enabled-p + compose-rotation-transformation + compose-scaling-tansformation + compose-translation-transformation + cursor-position* + cursor-set-position* + delete-output-record-element + dialog-view + disable-command + dragging-output-record + draw-character + draw-character* + draw-icon + draw-icon* + draw-string + draw-string* + enable-command + frame-top-level-window + input-position + insertion-pointer + make-color-ihs + make-color-rgb + map-over-output-record-elements + map-over-output-record-elements-containing-point* + map-over-output-record-elements-overlapping-region + menu-view + open-root-window + open-window-stream + output-record-element-count + output-record-elements + output-record-end-position* + output-record-position* + output-record-refined-sensitivity-test + output-record-set-position* + output-record-set-end-position* + output-record-set-start-position* + output-record-start-position + output-record-start-position* + output-recording-stream-current-output-record-stack + output-recording-stream-output-record + output-recording-stream-replay + point-position* + pointer-set-position* + pointer-event-shift-mask + pointer-position* + position-window-near-carefully + position-window-near-pointer + region-contains-point*-p + redisplay-1 + replay-1 + remove-pointer-gesture-name + rescanning-p + set-frame-layout + size-menu-appropriately + stream-cursor-position* + stream-set-cursor-position* + stream-draw-p + stream-increment-cursor-position* + stream-pointer-position* + stream-set-pointer-position* + stream-record-p + stream-vsp + transform-point* + untransform-point* + window-viewport-position* + window-set-viewport-position* + with-activation-characters + with-blip-characters + with-frame-state-variables)) + +#+Genera +(defmacro with-package-unlocked ((package) &body body) + `(si:with-package-lock package nil + ,@body)) + +#-Genera +(defmacro with-package-unlocked ((package) &body body) + (declare (ignore package)) + `(progn ,@body)) + +;; Import the above symbols into the CLIM package, then export them +(eval-when (compile load eval) + (let ((clim (find-package :clim))) + (dolist (symbol *clim-1-symbols*) + (import symbol clim) + (export symbol clim)))) diff --git a/compatibility/sysdcl.lisp b/compatibility/sysdcl.lisp new file mode 100644 index 00000000..6ea5033d --- /dev/null +++ b/compatibility/sysdcl.lisp @@ -0,0 +1,23 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(in-package #-ANSI-90 :user #+ANSI-90 :cl-user) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(clim-defsys:defsystem clim-compatibility + (:default-pathname #+Genera "SYS:CLIM;REL-2;COMPATIBILITY;" + #-Genera (frob-pathname "compatibility") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;COMPATIBILITY;" + #-Genera (frob-pathname "compatibility") + :needed-systems (clim-standalone) + :load-before-compile (clim-standalone)) + ("packages") + ("clim1-compatibility")) + +#+Genera +(clim-defsys:import-into-sct 'clim-compatibility + :pretty-name "CLIM Compatibility" + :default-pathname "SYS:CLIM;REL-2;COMPATIBILITY;" + :required-systems '(clim)) diff --git a/demo/color-editor.lisp b/demo/color-editor.lisp new file mode 100644 index 00000000..bf2b0aea --- /dev/null +++ b/demo/color-editor.lisp @@ -0,0 +1,164 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: CLIM-DEMO; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(in-package :clim-demo) + +"Copyright (c) 1992 Symbolics, Inc. All rights reserved." + + +(define-application-frame color-chooser () + ((color :accessor color :initform +black+) + red blue green + intensity hue saturation) + (:menu-bar nil) + (:panes + (display :application + :scroll-bars nil + :display-function 'display-color + ;; Make sure we don't have a useless cursor blinking away... + :initial-cursor-visibility nil) + (exit push-button + :label "Exit" + :activate-callback #'(lambda (button) + (frame-exit (pane-frame button)))) + (rgb (with-slots (red green blue) *application-frame* + (outlining () + (horizontally () + (setq red (make-pane 'slider + :label "Red" :foreground +red+ + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :show-value-p t :decimal-places 3 + :client 'color :id 'red)) + (setq green (make-pane 'slider + :label "Green" :foreground +green+ + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :show-value-p t :decimal-places 3 + :client 'color :id 'green)) + (setq blue (make-pane 'slider + :label "Blue" :foreground +blue+ + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :show-value-p t :decimal-places 3 + :client 'color :id 'blue)))))) + (ihs (with-slots (intensity hue saturation) *application-frame* + (outlining () + (horizontally () + (setq intensity (make-pane 'slider + :label "Intensity" + :orientation :vertical + :min-value 0.0 :max-value (sqrt 3) + :show-value-p t :decimal-places 3 + :client 'color :id 'intensity)) + (setq hue (make-pane 'slider + :label "Hue" + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :show-value-p t :decimal-places 3 + :client 'color :id 'hue)) + (setq saturation (make-pane 'slider + :label "Saturation" + :orientation :vertical + :min-value 0.0 :max-value 1.0 + :show-value-p t :decimal-places 3 + :client 'color :id 'saturation))))))) + (:layouts + (default + (horizontally () + (outlining () + (vertically () display exit)) + rgb ihs)))) + +(defmethod display-color ((frame color-chooser) stream) + (with-bounding-rectangle* (left top right bottom) (window-viewport stream) + (with-output-recording-options (stream :record nil) + (draw-rectangle* stream left top right bottom + :filled t :ink (color frame))))) + +(defmacro define-rgb-callbacks (color) + (check-type color (member red green blue)) + (let* ((rgb '(red green blue)) + (new-rgb (substitute 'value color rgb))) + `(progn + (defmethod value-changed-callback + ((slider slider) (client (eql 'color)) (id (eql ',color)) value) + (let ((frame (pane-frame slider))) + (multiple-value-bind (,@rgb) (color-rgb (color frame)) + (declare (ignore ,color)) + (setf (color frame) (make-rgb-color ,@new-rgb))) + (update-ihs frame))) + (defmethod drag-callback + ((slider slider) (client (eql 'color)) (id (eql ',color)) value) + (let ((frame (pane-frame slider))) + (multiple-value-bind (,@rgb) (color-rgb (color frame)) + (declare (ignore ,color)) + (setf (color frame) (make-rgb-color ,@new-rgb))) + (update-ihs frame)))))) + +(define-rgb-callbacks red) +(define-rgb-callbacks green) +(define-rgb-callbacks blue) + +(defmethod update-ihs ((frame color-chooser)) + (with-slots (intensity hue saturation) frame + (multiple-value-bind (ii hh ss) (color-ihs (color frame)) + (setf (gadget-value intensity :invoke-callback nil) ii) + (setf (gadget-value hue :invoke-callback nil) hh) + (setf (gadget-value saturation :invoke-callback nil) ss)))) + +(defmacro define-ihs-callbacks (color) + (check-type color (member intensity hue saturation)) + (let* ((ihs '(intensity hue saturation)) + (new-ihs (substitute 'value color ihs))) + `(progn + (defmethod value-changed-callback + ((slider slider) (client (eql 'color)) (id (eql ',color)) value) + (let ((frame (pane-frame slider))) + (multiple-value-bind (,@ihs) (color-ihs (color frame)) + (declare (ignore ,color)) + (setf (color frame) (make-ihs-color ,@new-ihs))) + (update-rgb frame))) + (defmethod drag-callback + ((slider slider) (client (eql 'color)) (id (eql ',color)) value) + (let ((frame (pane-frame slider))) + (multiple-value-bind (,@ihs) (color-ihs (color frame)) + (declare (ignore ,color)) + (setf (color frame) (make-ihs-color ,@new-ihs))) + (update-rgb frame)))))) + +(define-ihs-callbacks intensity) +(define-ihs-callbacks hue) +(define-ihs-callbacks saturation) + +(defmethod update-rgb ((frame color-chooser)) + (with-slots (red green blue) frame + (multiple-value-bind (rr gg bb) (color-rgb (color frame)) + (setf (gadget-value red :invoke-callback nil) rr) + (setf (gadget-value green :invoke-callback nil) gg) + (setf (gadget-value blue :invoke-callback nil) bb)))) + +(defmethod value-changed-callback :after ((slider slider) (client (eql 'color)) id value) + (declare (ignore id value)) + (redisplay-frame-pane (pane-frame slider) 'display)) + + +(defvar *color-choosers* nil) + +(defun do-color-chooser (&key (port (find-port)) (force nil)) + (let* ((framem (find-frame-manager :port port)) + (frame + (let* ((entry (assoc port *color-choosers*)) + (frame (cdr entry))) + (when (or force (null frame)) + (setq frame (make-application-frame 'color-chooser + :frame-manager framem))) + (if entry + (setf (cdr entry) frame) + (push (cons port frame) *color-choosers*)) + frame))) + (run-frame-top-level frame) + (color frame))) + +(define-demo "Color Chooser" do-color-chooser) diff --git a/genera/sysdcl.lisp b/genera/sysdcl.lisp new file mode 100644 index 00000000..f9c8a19a --- /dev/null +++ b/genera/sysdcl.lisp @@ -0,0 +1,31 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(in-package #-ANSI-90 :user #+ANSI-90 :cl-user) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(clim-defsys:defsystem genera-clim + (:default-pathname #+Genera "SYS:CLIM;REL-2;GENERA;" + #-Genera (frob-pathname "genera") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;GENERA;" + #-Genera (frob-pathname "genera") + :needed-systems (clim-standalone) + :load-before-compile (clim-standalone)) + ("pkgdcl") + ("genera-port") + ("genera-mirror") + ("genera-medium") + ("genera-pixmaps") + ("genera-frames") + ("genera-activities") + ("genera-prefill")) + +#+Genera +(clim-defsys:import-into-sct 'genera-clim + :pretty-name "Genera CLIM" + :default-pathname "SYS:CLIM;REL-2;GENERA;" + :required-systems '(clim) + :bug-reports "Bug-CLIM" + :patches-reviewed "Bug-CLIM-Doc") diff --git a/misc/xtsupport.c b/misc/xtsupport.c new file mode 100644 index 00000000..d97c49df --- /dev/null +++ b/misc/xtsupport.c @@ -0,0 +1,90 @@ +#include "/vapor/x11/R4/src/mit/lib/Xt/IntrinsicI.h" + +/* $fiHeader$ */ + +/* Some systems running NTP daemons are known to return strange usec + * values from gettimeofday. At present (3/90) this has only been + * reported on SunOS... + */ + +#ifndef NEEDS_NTPD_FIXUP +# if defined(sun) || defined(MOTOROLA) +# define NEEDS_NTPD_FIXUP 1 +# else +# define NEEDS_NTPD_FIXUP 0 +# endif +#endif + +#if NEEDS_NTPD_FIXUP +#define FIXUP_TIMEVAL(t) { \ + while ((t).tv_usec >= 1000000) { \ + (t).tv_usec -= 1000000; \ + (t).tv_sec++; \ + } \ + while ((t).tv_usec < 0) { \ + if ((t).tv_sec > 0) { \ + (t).tv_usec += 1000000; \ + (t).tv_sec--; \ + } else { \ + (t).tv_usec = 0; \ + break; \ + } \ + }} +#else +#define FIXUP_TIMEVAL(t) +#endif /*NEEDS_NTPD_FIXUP*/ + + + +/* + * Private routines + */ +#define ADD_TIME(dest, src1, src2) { \ + if(((dest).tv_usec = (src1).tv_usec + (src2).tv_usec) >= 1000000) {\ + (dest).tv_usec -= 1000000;\ + (dest).tv_sec = (src1).tv_sec + (src2).tv_sec + 1 ; \ + } else { (dest).tv_sec = (src1).tv_sec + (src2).tv_sec ; \ + if(((dest).tv_sec >= 1) && (((dest).tv_usec <0))) { \ + (dest).tv_sec --;(dest).tv_usec += 1000000; } } } + + +#define TIMEDELTA(dest, src1, src2) { \ + if(((dest).tv_usec = (src1).tv_usec - (src2).tv_usec) < 0) {\ + (dest).tv_usec += 1000000;\ + (dest).tv_sec = (src1).tv_sec - (src2).tv_sec - 1;\ + } else (dest).tv_sec = (src1).tv_sec - (src2).tv_sec; } + +#define IS_AFTER(t1, t2) (((t2).tv_sec > (t1).tv_sec) \ + || (((t2).tv_sec == (t1).tv_sec)&& ((t2).tv_usec > (t1).tv_usec))) + +#define IS_AT_OR_AFTER(t1, t2) (((t2).tv_sec > (t1).tv_sec) \ + || (((t2).tv_sec == (t1).tv_sec)&& ((t2).tv_usec >= (t1).tv_usec))) + + +/* + * This is what it's all for + */ + + +unsigned long XtAppIntervalNextTimer(app) + XtAppContext app; +{ + struct timeval cur_time; + struct timeval wait_time; + + (void) gettimeofday (&cur_time, NULL); + FIXUP_TIMEVAL(cur_time); + + if(app->timerQueue != NULL && IS_AFTER(cur_time, app->timerQueue->te_timer_value)) + { + TIMEDELTA (wait_time, app->timerQueue->te_timer_value, cur_time); + /* + * We add an extra 1 to ensure that events due to happen in less than + * 1000us are not lost by the rounding error of the integer divide + */ + return (1+wait_time.tv_sec*1000+wait_time.tv_usec/1000); + } + else + return 0; + } + diff --git a/postscript/sysdcl.lisp b/postscript/sysdcl.lisp new file mode 100644 index 00000000..9eeecd04 --- /dev/null +++ b/postscript/sysdcl.lisp @@ -0,0 +1,27 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(in-package #-ANSI-90 :user #+ANSI-90 :cl-user) + +"Copyright (c) 1990, 1991, 1992 Symbolics, Inc. All rights reserved." + +(clim-defsys:defsystem postscript-clim + (:default-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;" + #-Genera (frob-pathname "postscript") + :default-binary-pathname #+Genera "SYS:CLIM;REL-2;POSTSCRIPT;" + #-Genera (frob-pathname "postscript") + :needed-systems (clim-standalone) + :load-before-compile (clim-standalone)) + ("pkgdcl") + ("postscript-port") + ("postscript-medium") + ("laserwriter-metrics")) + +#+Genera +(clim-defsys:import-into-sct 'postscript-clim + :pretty-name "PostScript CLIM" + :default-pathname "SYS:CLIM;REL-2;POSTSCRIPT;" + :required-systems '(clim) + :bug-reports "Bug-CLIM" + :patches-reviewed "Bug-CLIM-Doc") diff --git a/sys/load-clim2.lisp b/sys/load-clim2.lisp new file mode 100644 index 00000000..4a541759 --- /dev/null +++ b/sys/load-clim2.lisp @@ -0,0 +1,92 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Package: USER; Base: 10; Lowercase: Yes -*- + +;;; $fiHeader$ + +(defun flush-clim () + (when (find-package 'clim-defsys) + (set (intern "*SYSTEMS*" 'clim-defsys) nil)) + (dolist (pkg '(clim-lisp clim-utils clim clim-user clim-defsys defsys + clim-demo clim-graphics-editor clim-browser + ;; CLIM 2.0 + clim-sys clim-silica clim-internals clx-clim genera-clim + ;; CLIM 0.9 + clim-conditions clim-shared clim-stream + silica windshield on-x on-genera)) + (when (find-package pkg) + (pkg-kill pkg))) + (dolist (sys '(clim-utils clim-standalone clim clim-demo + ;; CLIM 2.0 + clim-internals clim-silica genera-clim clx-clim postscript-clim + ;; CLIM 0.9 + silica silica-low silica-core ws ws-core ws-panes + silica-x silica-genera silica-coral-2 silica-postscript + clim-stream ws-demo clim-test ptk)) + (sct:undefsystem sys))) + +(defun rename-clim1 () + (loop for (old new) in '((clim-lisp clim1-lisp) + (clim-utils clim1-utils) + (clim clim1) + (clim-user clim1-user) + (clim-demo clim1-demo) + (defsystem clim1-defsystem)) + do (rename-package old new))) + +(defun compile-clim2 () + (compile-file #p"sys:clim;rel-2;sys;defsystem.lisp") + (load #p"sys:clim;rel-2;sys;defsystem") + (load #p"sys:clim;rel-2;sys;sysdcl") + (load #p"sys:clim;rel-2;genera;sysdcl") + (load #p"sys:clim;rel-2;clx;sysdcl") + (load #p"sys:clim;rel-2;postscript;sysdcl") + (sct:compile-system 'clim + :query nil :recompile t :reload t + :batch #p"sys:clim;rel-2;sys;clim.cwarns") + (sct:compile-system 'genera-clim :include-components nil + :query nil :recompile t :reload t + :batch #p"sys:clim;rel-2;sys;genera-clim.cwarns") + (sct:compile-system 'clx-clim :include-components nil + :query nil :recompile t :reload t + :batch #p"sys:clim;rel-2;sys;clx-clim.cwarns") + (sct:compile-system 'postscript-clim :include-components nil + :query nil :recompile t :reload t + :batch #p"sys:clim;rel-2;sys;postscript-clim.cwarns")) + +(defun load-clim2 () + (unless (find-package 'clim-defsys) + (load #p"sys:clim;rel-2;sys;defsystem")) + (load #p"sys:clim;rel-2;sys;sysdcl") + (load #p"sys:clim;rel-2;genera;sysdcl") + (load #p"sys:clim;rel-2;clx;sysdcl") + (load #p"sys:clim;rel-2;postscript;sysdcl") + (sct:load-system 'clim + :query nil :reload t) + (sct:load-system 'genera-clim :include-components nil + :query nil :reload t) + (sct:load-system 'clx-clim :include-components nil + :query nil :reload t) + (sct:load-system 'postscript-clim :include-components nil + :query nil :reload t)) + +(defun compile-clim2-demo () + (load #p"sys:clim;rel-2;demo;sysdcl") + (sct:compile-system 'clim-demo + :query nil :recompile t :reload t + :batch #p"sys:clim;rel-2;sys;clim-demo.cwarns")) + +(defun load-clim2-demo () + (load #p"sys:clim;rel-2;demo;sysdcl") + (sct:load-system 'clim-demo + :query nil :reload t)) + +(defun compile-clim2-tests () + (compile-file #p"sys:clim;rel-2;test;test-suite.lisp") + (compile-file #p"sys:clim;rel-2;test;test.lisp") + (compile-file #p"sys:clim;rel-2;test;test-sliders.lisp") + (compile-file #p"sys:clim;rel-2;test;test-buttons.lisp")) + +(defun load-clim2-tests () + (load #p"sys:clim;rel-2;test;test-suite") + (load #p"sys:clim;rel-2;test;test") + (load #p"sys:clim;rel-2;test;test-sliders") + (load #p"sys:clim;rel-2;test;test-buttons")) -- GitLab