Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • mcclim/gramps-clim2
  • abridgewater/gramps-clim2
  • wannis/gramps-clim2
3 results
Show changes
Commits on Source (121)
Showing with 285 additions and 217 deletions
The Common Lisp Interface Manager
=================================
Common Lisp Interface Manager: The Original Series
==================================================
Description
-----------
The contents of this repo are known to compile and work in
Allegro CL 8.2 and later. No work has been done to make it work on
other Common Lisps, even though there is considerable
conditionalization for many other CLs.
Common Lisp Interface Manager 2.0 based on the open source release by
Franz, Inc. TOS stands for The Original Series as a reference to Star
Trek: The Original Series.
See the file LICENSE for information on the license for this source
code.
Running the software
--------------------
To manage dependencies `clim-tos` uses ASDF system definitions and
Quicklisp. To use the software clone its source code to
`~/quicklisp/local-projects` and call:
(ql:quickload 'clim-tos/all)
(clim-demo:start-demo)
Development status
------------------
Currently software has many problems which may result in application
crashes. It is not overly stable, but runs on SBCL and CCL with X11
server backend.
Project goals are to make it work reliably on conforming Common Lisp
implementations which feature Gray Streams and MOP extensions.
......@@ -288,7 +288,7 @@
(setf (aref stringvar newlen) #\null)
(setf (fill-pointer stringvar) newlen))
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant *nstringify-buffer-default-size* 2048)
(defvar nstringify-buffer
(make-array *nstringify-buffer-default-size* :fill-pointer t
......@@ -1127,7 +1127,7 @@ to be run from another."
(car dotted-pair) (cdr dotted-pair) (code-char 0)
(cdr dotted-pair) (code-char 0))))
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; All pathnames returned by SELECT-FILE must fit in the scratch string,
;; so make it pretty big.
(defconstant *scratch-string-length* 2048)
......@@ -1139,7 +1139,7 @@ to be run from another."
(defparameter *scratch-c-string*
(ff:allocate-fobject-c `(:array :char ,*scratch-string-length*)))
(eval-when (compile eval load)
(eval-when (:compile-toplevel :execute :load-toplevel)
;; this type useful since we don't open code anonymous types well yet:
(ff:def-foreign-type foreign-string (:array :char 1))
)
......
......@@ -155,15 +155,12 @@
(color-rgb (wincolor->color (win:GetSysColor win:COLOR_BTNFACE))))
(defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +foreground-ink+)))
(declare (values image created-bitmap created-mask-bitmap))
(dc-image-for-ink medium (medium-foreground medium)))
(defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +background-ink+)))
(declare (values image created-bitmap created-mask-bitmap))
(dc-image-for-ink medium (medium-background medium)))
(defmethod dc-image-for-ink ((medium acl-medium) (ink t))
(declare (values image created-bitmap created-mask-bitmap))
;; Don't blow out if somebody tries to use a fancy ink like compose-in.
(dc-image-for-ink medium (medium-foreground medium)))
......@@ -209,7 +206,6 @@
(convert blue))))))
(defmethod dc-image-for-ink ((medium acl-medium) (ink color))
(declare (values image created-bitmap created-mask-bitmap))
(let ((cache (port-dc-cache (port medium))))
(or (gethash ink cache)
(setf (gethash ink cache)
......@@ -235,17 +231,14 @@
*blank-image*)
(defmethod dc-image-for-ink ((medium acl-medium) (ink (eql +everywhere+)))
(declare (values image created-bitmap created-mask-bitmap))
(dc-image-for-ink medium +foreground-ink+))
(defmethod dc-image-for-ink ((medium acl-medium) (ink standard-opacity))
(declare (values image created-bitmap created-mask-bitmap))
(if (>= (opacity-value ink) 0.5)
(dc-image-for-ink medium +foreground-ink+)
*blank-image*))
(defmethod dc-image-for-ink ((medium acl-medium) (ink region))
(declare (values image created-bitmap created-mask-bitmap))
(dc-image-for-ink medium +foreground-ink+))
;;; ink for patterns, tiles, etc
......@@ -439,7 +432,6 @@
(color->wincolor (elt designs tcolor))))))
(defmethod dc-image-for-ink ((medium acl-medium) (ink pattern))
(declare (values image created-bitmap created-mask-bitmap))
;; The "pattern" part of the ink is put into the brush.
;; This will return a list of two DCs if one of the inks is transparent.
(let ((cache (port-dc-cache (port medium))))
......@@ -506,7 +498,6 @@ draw icons and mouse cursors on the screen.
|#
(defmethod dc-image-for-ink ((medium acl-medium) (ink rectangular-tile))
(declare (values image created-bitmap created-mask-bitmap))
;; The only case we handle right now is stipples
(let ((cache (port-dc-cache (port medium))))
(or (gethash ink cache)
......@@ -541,7 +532,6 @@ draw icons and mouse cursors on the screen.
(error "This NT CLIM operation is NYI (Not Yet Implemented)."))
(defmethod dc-image-for-ink ((medium acl-medium) (ink flipping-ink))
(declare (values image created-bitmap created-mask-bitmap))
(let ((cache (port-dc-cache (port medium))))
(or (gethash ink cache)
(setf (gethash ink cache)
......@@ -565,7 +555,6 @@ draw icons and mouse cursors on the screen.
:background-color nil))))))))
(defmethod dc-image-for-ink ((medium acl-medium) (ink contrasting-ink))
(declare (values image created-bitmap created-mask-bitmap))
(dc-image-for-ink medium (make-color-for-contrasting-ink ink)))
(defmethod dc-image-for-ink ((medium acl-medium) (ink composite-out))
......@@ -1819,7 +1808,7 @@ device-independent bitmap, an icon, nor a cursor."))
(setf (gethash "magenta" table) +magenta+)
table))
(eval-when (load eval)
(eval-when (:load-toplevel :execute)
(initialize-named-colors))
(defun clim-internals::kana-process-gesture (istream gesture type)
......
......@@ -16,7 +16,7 @@
(in-package :silica)
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-event-class scrollbar-event (event)
((sheet :reader event-sheet :initarg :sheet)
(orientation :initarg :orientation :reader scrollbar-event-orientation)
......@@ -474,7 +474,7 @@
(resize-sheet child nwidth nheight) ;;; get the viewport sized correctly!
(allocate-space child nwidth nheight)))
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
;; Turn this on as long as it gets turned off in pkgdcl.lisp
(setq excl:*enable-package-locked-errors* common-lisp-user::*lock-preference*)
(provide :climnt))
......@@ -486,7 +486,6 @@
;;; Retreive the start and end position of the
;;; selection in a mswin-text-edit gadget.
(defmethod get-selection ((pane mswin-text-edit))
(declare (values startpos endpos))
(let ((mirror (sheet-direct-mirror pane)))
(cond (mirror
(let ((startptr
......
......@@ -15,7 +15,7 @@
#-(and mswindows 64bit) t)
;; Invite everybody to the party.
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(require :climg)
;; [rfe4951]: not needed anymore:
;; (require :ffcompat)
......@@ -48,7 +48,7 @@
#:make-windows-font-named ;make a windows font from a name
))
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(pushnew :aclmerge *features*)
(pushnew :os-threads *features*))
(in-package #:asdf-user)
(defsystem #:gramps-clim2
(defsystem #:clim-tos
:description "CLIM 2 implementation released by Franz Inc."
:license "BSD-4-Clause"
:depends-on (#:gramps-clim2/core))
:depends-on (#:clim-tos/core))
(defsystem #:clim-tos/all
:description "All default packages for demo."
:depends-on (#:clim-tos
#:clim-tos/clx-backend
#:clim-tos/examples
#:clim-tos/homegrown))
;;; based on `clim-standalone' in sys/sysdcl.lisp
(defsystem #:gramps-clim2/core
(defsystem #:clim-tos/core
:description "Core functionality (doesn't contain backends)."
:depends-on (#:gramps-clim2/silica)
:depends-on (#:clim-tos/silica)
:components ((:module "clim"
:components
(;#+(or) "Basic tools"
(;; Basic tools
(:file "gestures")
(:file "defprotocol")
(:file "stream-defprotocols")
......@@ -20,7 +27,7 @@
(:file "temp-strings")
(:file "clim-defs")
#+(or) "Definitions and protocols"
;; Definitions and protocols
(:file "stream-class-defs")
(:file "interactive-defs")
(:file "cursor")
......@@ -29,29 +36,29 @@
(:file "input-protocol")
(:file "output-protocol")
#+(or) "Output recording"
;; Output recording
(:file "recording-defs")
(:file "formatting-output-defs")
(:file "formatted-output-defs")
(:file "recording-protocol")
(:file "text-recording")
(:file "graphics-recording")
(:file "design-recording")
#+(or) "Input editing"
;; Input editing
(:file "interactive-protocol")
(:file "input-editor-commands")
#+(and allegro (not acl86win32)) (:file "japanese-input-editor")
#+(or) "Incremental redisplay"
;; Incremental redisplay
(:file "incremental-redisplay")
#+(or) "Windows"
;; Windows (sheets)
(:file "coordinate-sorted-set")
(:file "r-tree")
(:file "window-stream")
(:file "pixmap-streams")
#+(or) "Presentation types"
;; Presentation types
(:file "ptypes1")
(:file "completer")
(:file "presentations")
......@@ -61,21 +68,21 @@
(:file "standard-types")
#+allegro (:file "excl-presentations")
#+(or) "Formatted output"
;; Formatted output
(:file "table-formatting")
(:file "graph-formatting")
(:file "surround-output")
(:file "text-formatting")
#+(or) "Pointer tracking"
;; Pointer tracking
(:file "tracking-pointer")
(:file "dragging-output")
#+(or) "Gadgets"
;; Gadgets
(:file "db-stream")
(:file "gadget-output")
#+(or) "Application building substrate"
;; Application building substrate
(:file "accept")
(:file "present")
(:file "command")
......@@ -94,11 +101,14 @@
(:file "drag-and-drop")
(:file "item-list-manager")
#+(or) "Bootstrap everything"
;; Bootstrap everything
(:file "stream-trampolines")))))
;;; based on `clim-utils'
(defsystem #:gramps-clim2/utils
(defsystem #:clim-tos/utils
:depends-on (#:closer-mop
#:trivial-gray-streams
#:bordeaux-threads)
:components
((:module "utils"
:components ((:file "packages")
......@@ -116,7 +126,8 @@
(:file "protocols")
;; Establish a uniform stream model
#+ (or) (:file "trivial-gray-streams")
(:file "clim-streams")
(:file "cl-streams")
;; Basic utilities for Silica and CLIM
(:file "clim-macros")
......@@ -128,13 +139,14 @@
(:file "designs")))))
;;; based on `clim-silica'
(defsystem #:gramps-clim2/silica
:depends-on (#:gramps-clim2/utils
#:closer-mop)
(defsystem #:clim-tos/silica
:depends-on (#:clim-tos/utils
#:closer-mop
#:alexandria)
:components
((:module "silica"
:components
(;#+(or) "Silica"
(;; Silica
(:file "macros")
(:file "classes")
(:file "text-style")
......@@ -149,22 +161,95 @@
(:file "std-sheet")
;; "Windshield", aka "DashBoard"
#+(or) "Layout gadgets"
;; Layout gadgets
(:file "layout")
(:file "db-layout")
(:file "db-box")
(:file "db-table")
#+(or) "'Physical' gadgets"
;; 'Physical' gadgets
(:file "gadgets")
(:file "db-border")
(:file "db-scroll")))))
(defsystem #:gramps-clim2/postscript
(:file "db-scroll")
(:file "db-button")
(:file "db-label")
(:file "db-slider")
(:file "scroll-pane")))))
(defsystem #:clim-tos/homegrown
:depends-on (#:clim-tos/silica)
:components
((:module "homegrown"
:components
(;(:file "scroll-pane")
(:file "db-button")
(:file "db-label")
(:file "db-slider")
(:file "db-menu")
(:file "db-list" :depends-on ("db-menu"))
(:file "db-text")
(:file "last")))))
(defsystem #:clim-tos/postscript
:description "Draw-only backend as defined in the specification.")
(defsystem #:gramps-clim2/clx-backend
:description "Reference backend for X-Window system.")
;;; based on `clx-clim' in clx/sysdcl.lisp
(defsystem #:clim-tos/clx-backend
:description "Reference backend for X-Window system."
:depends-on (#:clx #:clim-tos/core)
:components
((:module "clx"
:components
((:file "pkgdcl")
(:file "clx-port")
(:file "clx-mirror")
(:file "clx-medium")
(:file "clx-pixmaps")
(:file "clx-frames")))))
;;; based on `clim-test' in test/sysdcl.lisp
(defsystem #:clim-tos/tests
:description "CLIM tests (framework and definitions)."
:depends-on (#:clim-tos/core
#:clim-tos/examples)
:serial t
:components
((:module "test"
:components
((:file "test-suite")
(:file "test")
(:file "test-buttons")
(:file "test-sliders")
(:file "simple-test")
(:file "postscript-tests")))))
;;; based on `clim-demo' in demo/sysdcl.lisp
(defsystem #:clim-tos/examples
:description "Applications bundled in clim-tos repository."
:depends-on (#:clim-tos/core
#:bordeaux-threads)
(defsystem #:gramps-clim2/examples
:description "Applications bundled in gramps-clim2 repository.")
:components
((:module "demo"
:components
((:file "packages")
(:file "demo-driver" :depends-on ("packages"))
(:file "listener" :depends-on ("demo-driver"))
(:file "graphics-demos" :depends-on ("demo-driver"))
(:file "palette" :depends-on ("demo-driver"))
;(:file "cad-demo" :depends-on ("demo-driver"))
;(:file "navdata" :depends-on ("packages"))
;(:file "navfun" :depends-on ("navdata"))
(:file "puzzle" :depends-on ("demo-driver"))
(:file "address-book" :depends-on ("demo-driver"))
(:file "thinkadot" :depends-on ("demo-driver"))
;(:file "plot" :depends-on ("demo-driver"))
;(:file "color-editor" :depends-on ("demo-driver"))
;(:file "graphics-editor" :depends-on ("demo-driver"))
))))
(defmethod perform :after ((op load-op) (c (eql (find-system :clim-tos))))
(pushnew :clim *features*)
(pushnew :clim-2 *features*)
(pushnew :clim-2.1 *features*)
(pushnew :silica *features*))
......@@ -28,7 +28,6 @@
(:default-initargs :query-table (make-hash-table :test #'equal)))
(defmethod find-query ((record accept-values-output-record) query-identifier)
(declare (values query found-p))
(gethash query-identifier (slot-value record 'query-table)))
;; We are in control of the AVV code, and we know that there is only 1 AVV
......@@ -1144,12 +1143,6 @@
&body body &environment env)
#+Genera (declare (zwei:indentation 1 3 2 1))
#-(or Genera Minima) (declare (ignore env))
#-acl3.0 ; temporary restriction?
(declare (arglist ((&optional stream
&key documentation query-identifier
(cache-value t) (cache-test #'eql)
view resynchronize)
prompt &body body)))
(default-input-stream stream accept-values-command-button)
(with-keywords-removed (options options '(:view))
(let ((constant-prompt-p
......
......@@ -24,7 +24,6 @@
(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
activation-gestures additional-activation-gestures
delimiter-gestures additional-delimiter-gestures
......@@ -336,7 +335,6 @@
(delimiter-gestures nil delimiter-gestures-p)
(additional-delimiter-gestures nil)
(start 0) (end nil))
(declare (values object type index))
;; Allow the arguments to be presentation type abbreviations
(multiple-value-bind (expansion expanded)
......@@ -446,14 +444,14 @@
;; protocol on input-from-string streams
(defmethod stream-read-gesture ((stream t)
&key timeout peek-p
input-wait-test input-wait-handler
pointer-button-press-handler)
input-wait-test input-wait-handler
pointer-button-press-handler)
(declare (ignore input-wait-test input-wait-handler pointer-button-press-handler))
;; avoid using STREAM-x functions to reduce Gray stream dependence,
;; tfb 13-jun-2000
(let ((char (if (eq timeout 0)
(let ((char (if (eql timeout 0)
(read-char-no-hang stream nil *end-of-file-marker*)
(read-char stream nil *end-of-file-marker*))))
(read-char stream nil *end-of-file-marker*))))
(when (and char peek-p
;; spr26071 -pnc
;; As noted above, this used to call stream-unread-char,
......
......@@ -43,7 +43,7 @@
(presentation-subtypep-1 type-name context-name)
(presentation-typep object context-type))))))))
(eval-when (compile eval load)
(eval-when (:compile-toplevel :execute :load-toplevel)
;; Only the PRESENTATION-MENU translator lives in this
(unless (find-command-table 'presentation-menu-command-table :errorp nil)
(make-command-table 'presentation-menu-command-table :inherit-from nil))
......
......@@ -88,7 +88,7 @@
,(if record-supplied record `(stream-recording-p ,new-stream))
,(if draw-supplied draw `(stream-drawing-p ,new-stream)))))))
(eval-when (compile eval load)
(eval-when (:compile-toplevel :execute :load-toplevel)
(defvar *output-record-constructor-cache* (make-hash-table))
(defmacro construct-output-record (type &rest initargs &environment env)
......@@ -292,8 +292,7 @@
&key partial-completers allow-any-input
possibility-printer (help-displays-possibilities t))
&body body)
(declare (values object success string nmatches)
(ignore allow-any-input possibility-printer help-displays-possibilities))
(declare (ignore allow-any-input possibility-printer help-displays-possibilities))
#+Genera (declare (zwei:indentation 0 3 1 1))
(let ((string '#:string)
(action '#:action))
......@@ -345,14 +344,6 @@
;;; From ACCEPTING-VALUES.LISP
(defmacro accepting-values ((&optional stream &rest args) &body body)
(declare (arglist (&optional stream
&key frame-class command-table own-window
background foreground text-style
exit-boxes resize-frame align-prompts
initially-select-query-identifier modify-initial-query
resynchronize-every-pass (check-overlapping t)
label x-position y-position width height (scroll-bars nil))
&body body))
#+Genera (declare (zwei:indentation 0 3 1 1))
(default-input-stream stream accepting-values)
`(flet ((accepting-values-body (,stream) ,@body))
......
......@@ -688,33 +688,37 @@
(start-position (and (input-editing-stream-p stream)
(stream-scan-pointer stream)))
(replace-input-p nil))
;;NOTE workaround for the define-presentation-method implementation doing code-walking
;;in search for variables in presentation types' parameters and options. -- jacek.zlydach 2017-10-28
auto-activate
(multiple-value-bind (object type)
(with-input-context (command-type) (command command-presentation-type nil options)
(with-input-context (form-type) (form form-presentation-type nil options)
(let ((gesture (read-gesture :stream stream :peek-p t)))
(cond ((and (characterp gesture)
(find gesture *command-dispatchers* :test #'char-equal))
(read-gesture :stream stream) ;get out the colon
(apply #'accept command-type
:stream stream :prompt nil :view view
:history type args))
(t (apply #'accept form-type
:stream stream :prompt nil :view view
:history type args))))
(t (when (getf options :echo t)
(setq replace-input-p t))
(values form form-presentation-type)))
(t (when (getf options :echo t)
(setq replace-input-p t))
(when (partial-command-p command)
(setq command (funcall *partial-command-parser*
command command-table stream start-position)))
(when replace-input-p
(unless (stream-rescanning-p stream)
(replace-input stream (string (first *command-dispatchers*))
:buffer-start start-position)
(incf start-position)))
(values command command-presentation-type)))
(with-input-context (form-type) (form form-presentation-type nil options)
(let ((gesture (read-gesture :stream stream :peek-p t)))
(cond ((and (characterp gesture)
(find gesture *command-dispatchers* :test #'char-equal))
(read-gesture :stream stream) ;get out the colon
(apply #'accept command-type
:stream stream :prompt nil :view view
:history type args))
(t
(apply #'accept form-type ;might this be missing?
:stream stream :prompt nil :view view
:history type args))))
(t (when (getf options :echo t)
(setq replace-input-p t))
(values form form-presentation-type)))
(t (when (getf options :echo t)
(setq replace-input-p t))
(when (partial-command-p command)
(setq command (funcall *partial-command-parser*
command command-table stream start-position)))
(when replace-input-p
(unless (stream-rescanning-p stream)
(replace-input stream (string (first *command-dispatchers*))
:buffer-start start-position)
(incf start-position)))
(values command command-presentation-type)))
(when replace-input-p
(presentation-replace-input stream object type view
:buffer-start start-position))
......
......@@ -313,7 +313,6 @@
(gethash command-name (slot-value command-table 'commands)))
(defun command-accessible-in-command-table-p (command-name command-table)
(declare (values command-table))
(do-command-table-inheritance (comtab command-table)
(when (command-present-in-command-table-p command-name comtab)
(return-from command-accessible-in-command-table-p comtab)))
......@@ -385,7 +384,6 @@
(slot-value (find-command-table command-table) 'command-line-names))))
(defun find-command-from-command-line-name (name command-table &key (errorp t))
(declare (values command command-table))
(do-command-table-inheritance (comtab command-table)
;;--- Use binary search on COMMAND-LINE-NAMES (completion aarrays)
(let ((item (find name (slot-value comtab 'command-line-names)
......@@ -549,7 +547,6 @@
(slot-value (find-command-table command-table) 'menu)))
(defun find-menu-item (menu-name command-table &key (errorp t))
(declare (values menu-item command-table))
(let* ((command-table (find-command-table command-table))
(item (find menu-name (slot-value command-table 'menu)
:test #'menu-name-equal :key #'first)))
......@@ -786,7 +783,6 @@
(defun find-keystroke-item (keystroke command-table
&key (test #'keyboard-event-matches-gesture-name-p) (errorp t))
(declare (values menu-item command-table))
(let* ((command-table (find-command-table command-table))
(entry (block find-entry
;; Do it the hard way so that GESTURE-SPEC-EQL doesn't see NILs
......@@ -805,7 +801,6 @@
(defun lookup-keystroke-item (keystroke command-table
&key (test #'keyboard-event-matches-gesture-name-p))
(declare (values menu-item command-table))
(labels ((map-menu (command-table)
(map nil #'(lambda (entry)
(let ((item (third entry)))
......@@ -919,7 +914,6 @@
(funcall function translator))))))
(defun find-presentation-translator (translator-name command-table &key (errorp t))
(declare (values command command-table))
(when (presentation-translator-p translator-name)
(setq translator-name (presentation-translator-name translator-name)))
(do-command-table-inheritance (comtab command-table)
......@@ -1178,7 +1172,6 @@
(defvar *define-command-options* '(:command-table :name :menu :keystroke))
(defun decode-name-and-options (name-and-options &optional command-table-name)
(declare (values command-name command-options))
(if (symbolp name-and-options)
(values name-and-options nil)
(let ((name (first name-and-options))
......
......@@ -44,7 +44,6 @@
&key partial-completers allow-any-input possibility-printer
(help-displays-possibilities t))
(declare (dynamic-extent function))
(declare (values answer-object success string))
(with-temporary-string (stuff-so-far :length 100 :adjustable t)
(with-delimiter-gestures (partial-completers)
(with-activation-gestures (*magic-completion-gestures*)
......@@ -278,7 +277,6 @@
(defun complete-from-possibilities (string completions delimiters
&key (action :complete) predicate
(name-key #'first) (value-key #'second))
(declare (values string success object nmatches possibilities))
(when (and (not (eq action :possibilities))
(not (eq action :apropos-possibilities))
(zerop (length string)))
......@@ -318,7 +316,6 @@
;; gotten by funcalling a generator rather than from a completion alist.
(defun complete-from-generator (string generator delimiters
&key (action :complete) predicate)
(declare (values string success object nmatches possibilities))
(declare (dynamic-extent generator))
(when (and (not (eq action :possibilities))
(not (eq action :apropos-possibilities))
......@@ -356,7 +353,6 @@
(defun chunkwise-complete-string (string completion object action delimiters
best-completion best-length best-object
nmatches possibilities)
(declare (values best-completion best-length best-object nmatches possibilities))
(let* ((length (length string))
(matches (if (eq action :apropos-possibilities)
(if (search string completion :test #'char-equal) length 0)
......@@ -408,7 +404,6 @@
;; where the strings mismatches and the index of the last character that was
;; unambiguous. When MERGE-P, STRING1 gets side-effected.
(defun chunkwise-string-compare (string1 string2 delimiters &optional merge-p end1)
(declare (values matched ambiguous))
(let ((len1 (or end1 (length string1)))
(len2 (length string2))
(matched 0)
......
......@@ -51,15 +51,14 @@
;; cares?? --CIM
(values x y (+ x width) (+ y width))))
(defconstant cursor_active (byte 1 0))
(defconstant cursor_state (byte 1 1))
(defconstant cursor_focus (byte 1 2))
(defparameter +cursor-active+ (byte 1 0))
(defparameter +cursor-state+ (byte 1 1))
(defparameter +cursor-focus+ (byte 1 2))
(defun decode-cursor-flags (flags)
#+Genera (declare (values active state focus))
(values (ldb-test cursor_active flags)
(ldb-test cursor_state flags)
(ldb-test cursor_focus flags)))
(values (ldb-test +cursor-active+ flags)
(ldb-test +cursor-state+ flags)
(ldb-test +cursor-focus+ flags)))
;;; Required method
(defmethod (setf cursor-stream) (new-value (cursor standard-text-cursor))
......@@ -96,33 +95,33 @@
(multiple-value-bind (active state focus)
(decode-cursor-flags flags)
(declare (ignore active focus))
(setf (ldb cursor_state flags) (if new-state 1 0))
(setf (ldb +cursor-state+ flags) (if new-state 1 0))
(note-cursor-change cursor 'cursor-state state new-state))))
(defmethod cursor-state ((cursor standard-text-cursor))
(ldb-test cursor_state (slot-value cursor 'flags)))
(ldb-test +cursor-state+ (slot-value cursor 'flags)))
(defmethod (setf cursor-active) (new-active (cursor standard-text-cursor))
(with-slots (flags) cursor
(multiple-value-bind (active state focus)
(decode-cursor-flags flags)
(declare (ignore state focus))
(setf (ldb cursor_active flags) (if new-active 1 0))
(setf (ldb +cursor-active+ flags) (if new-active 1 0))
(note-cursor-change cursor 'cursor-active active new-active))))
(defmethod cursor-active ((cursor standard-text-cursor))
(ldb-test cursor_active (slot-value cursor 'flags)))
(ldb-test +cursor-active+ (slot-value cursor 'flags)))
(defmethod (setf cursor-focus) (new-focus (cursor standard-text-cursor))
(with-slots (flags) cursor
(multiple-value-bind (active state focus)
(decode-cursor-flags flags)
(declare (ignore active state))
(setf (ldb cursor_focus flags) (if new-focus 1 0))
(setf (ldb +cursor-focus+ flags) (if new-focus 1 0))
(note-cursor-change cursor 'cursor-focus focus new-focus))))
(defmethod cursor-focus ((cursor standard-text-cursor))
(ldb-test cursor_focus (slot-value cursor 'flags)))
(ldb-test +cursor-focus+ (slot-value cursor 'flags)))
(defmethod (setf cursor-color) (color (cursor standard-text-cursor))
(with-slots (flipping-ink flags) cursor
......
......@@ -27,7 +27,7 @@
((next-menu :initform nil :initarg :next-menu)))
;;;#+(or aclpc acl86win32)
;;;(eval-when (compile load eval)
;;;(eval-when (:compile-toplevel :load-toplevel :execute)
;;; ;;mm: 11Jan95 - this is defined later in ???
;;; (unless (ignore-errors (find-class 'pull-down-menu))
;;; (defclass pull-down-menu () ())))
......@@ -285,8 +285,13 @@
(make-pane 'menu-bar-button-logic
:label name
:next-menu value)
(error "not yet implemented")
)))
;; NOTE WORKAROUND this push button is a temporary replacement for the
;; error condition below. -- jacek.zlydach 2017-05-04
(make-pane 'push-button
:label name)
;(error "not yet implemented")
)))
(make-command-table-menu command-table))))
(make-pane 'hbox-pane :contents buttons
:min-height 2 :height 2))))
......
......@@ -137,7 +137,6 @@
(setf display-time value)))
(defmethod pane-needs-redisplay ((pane clim-stream-pane))
(declare (values needs-redisplay clear))
(with-slots (display-time) pane
(ecase display-time
((t)
......@@ -379,7 +378,7 @@
()
(:default-initargs :default-view +gadget-dialog-view+))
(eval-when (compile)
(eval-when (:compile-toplevel)
;; defined later in the compilation...
(declaim (special *default-menu-text-style*))
)
......@@ -454,8 +453,10 @@
:name name
:thickness 1
:contents pane
:background background)
:background background)))
;; :background background
)
;; :background background -- NOTE this actually should work!
)))
(values pane stream))))
(defmacro make-clim-interactor-pane (&rest options)
......
......@@ -28,9 +28,7 @@
(map-over-output-records #'make-design record))
(make-instance 'composite-over :designs (apply #'vector designs))))
(defgeneric draw-design (design stream &rest args)
#-(or aclpc acl86win32) (declare (arglist design stream &key . #.(all-drawing-options-lambda-list nil))))
(defgeneric draw-design (design stream &rest args))
;;; Simple composite designs
(defmethod draw-design ((composite composite-over) stream &rest args)
......
......@@ -26,7 +26,6 @@
&key (repaint t) multiple-window
(erase #'erase-output-record erase-sp) feedback
(finish-on-release *dragging-output-finish-on-release*))
(declare (values final-x final-y delta-x delta-y))
(let (last-x last-y
(delta-x 0)
(delta-y 0)
......
......@@ -138,7 +138,7 @@
(frame standard-application-frame))
(adjust-layout-requirements frame (frame-current-layout frame)))
(eval-when (compile load eval)
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun define-application-frame-1 (name state-variables pane-descriptions
&key top-level layouts
command-table)
......@@ -233,7 +233,7 @@
`',layout)))
layouts))))
`(progn
(eval-when (compile)
(eval-when (:compile-toplevel)
(when ',command-table
(setf (compile-time-property ',(first command-table) 'command-table-name) t))
(define-application-frame-1 ',name ',slots ,pane-constructors
......@@ -511,7 +511,7 @@
(flet ((reset-sr (sheet)
(when (panep sheet)
(change-space-requirements-to-default sheet))))
(declare (dynamic-extent #'adjust-layout))
(declare (dynamic-extent #'adjust-layout-requirements))
(map-over-sheets #'reset-sr (frame-panes frame))
(dolist (pane-and-sr layout-space-requirements)
(let ((name (car pane-and-sr)))
......@@ -537,7 +537,7 @@
(setq frame-class frame-name))
(when (or left top right bottom width height)
(when (getf options :geometry)
(error "Cannot specify ~S and ~S, S, ~S, ~S, ~S, or ~S at the same time"
(error "Cannot specify ~S and ~S, ~S, ~S, ~S, ~S, or ~S at the same time"
:geometry :left :top :right :bottom :width :height))
(macrolet ((check-conflict (edge1 edge2 size)
`(cond
......@@ -907,69 +907,69 @@
(defmethod default-frame-top-level ((frame standard-application-frame)
&key command-parser command-unparser
partial-command-parser
(prompt "Command: "))
partial-command-parser
(prompt "Command: "))
(unless (eq (frame-state frame) :enabled)
(enable-frame frame))
(loop
(let* ((*standard-output*
(or (frame-standard-output frame) *standard-output*))
(*standard-input*
(or (frame-standard-input frame) *standard-input*))
(*query-io*
(or (frame-query-io frame) *query-io*))
(*error-output*
(or (frame-error-output frame) *error-output*))
(*pointer-documentation-output*
(frame-pointer-documentation-output frame))
(interactor
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(*command-parser*
(or command-parser
(if interactor
#'command-line-command-parser
#'menu-command-parser)))
(*command-unparser*
(or command-unparser
#'command-line-command-unparser))
(*partial-command-parser*
(or partial-command-parser
(if interactor
#'command-line-read-remaining-arguments-for-partial-command
#'menu-read-remaining-arguments-for-partial-command)))
(command-stream
;;--- We have to ask the frame since we do not want to
;;--- just pick up a stream from the dynamic environment
(let ((si (or (frame-standard-input frame)
(frame-standard-output frame))))
(typecase si
(output-protocol-mixin si)
(t (frame-top-level-sheet frame)))))
(*avv-refreshed* nil))
;; The read-eval-print loop for applications...
(letf-globally (((frame-actual-pointer-documentation-pane frame)
*pointer-documentation-output*))
(loop
;; Redisplay all the panes
(catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
(redisplay-frame-panes frame)
(when (not *avv-refreshed*)
;;; This needs to happen after the
;;; call to redisplay-frame-panes
;;; but only do it the first time.
(force-refresh-avv-streams frame)
(setq *avv-refreshed* t))
(when interactor
(fresh-line *standard-input*)
(if (stringp prompt)
(write-string prompt *standard-input*)
(funcall prompt *standard-input* frame)))
(let ((command (read-frame-command frame :stream command-stream)))
(when interactor
(terpri *standard-input*))
;; Need this check in case the user aborted out of a command menu
(when command
(execute-frame-command frame command)))))))))
(let* ((*standard-output*
(or (frame-standard-output frame) *standard-output*))
(*standard-input*
(or (frame-standard-input frame) *standard-input*))
(*query-io*
(or (frame-query-io frame) *query-io*))
(*error-output*
(or (frame-error-output frame) *error-output*))
(*pointer-documentation-output*
(frame-pointer-documentation-output frame))
(interactor
(not (null (find-frame-pane-of-type frame 'interactor-pane))))
(*command-parser*
(or command-parser
(if interactor
#'command-line-command-parser
#'menu-command-parser)))
(*command-unparser*
(or command-unparser
#'command-line-command-unparser))
(*partial-command-parser*
(or partial-command-parser
(if interactor
#'command-line-read-remaining-arguments-for-partial-command
#'menu-read-remaining-arguments-for-partial-command)))
(command-stream
;;--- We have to ask the frame since we do not want to
;;--- just pick up a stream from the dynamic environment
(let ((si (or (frame-standard-input frame)
(frame-standard-output frame))))
(typecase si
(output-protocol-mixin si)
(t (frame-top-level-sheet frame)))))
(*avv-refreshed* nil))
;; The read-eval-print loop for applications...
(letf-globally (((frame-actual-pointer-documentation-pane frame)
*pointer-documentation-output*))
(loop
;; Redisplay all the panes
(catch-abort-gestures ("Return to ~A command level" (frame-pretty-name frame))
(redisplay-frame-panes frame)
(when (not *avv-refreshed*)
;;; This needs to happen after the
;;; call to redisplay-frame-panes
;;; but only do it the first time.
(force-refresh-avv-streams frame)
(setq *avv-refreshed* t))
(when interactor
(fresh-line *standard-input*)
(if (stringp prompt)
(write-string prompt *standard-input*)
(funcall prompt *standard-input* frame)))
(let ((command (read-frame-command frame :stream command-stream)))
(when interactor
(terpri *standard-input*))
;; Need this check in case the user aborted out of a command menu
(unless (member command '(nil :timeout))
(execute-frame-command frame command)))))))))
(defmethod force-refresh-avv-streams (frame)
;;; NOTE: Not using get-frame-pane-to-avv-stream-table.
......@@ -1370,7 +1370,7 @@
(process-command-event sheet event))
;;;#+(or aclpc acl86win32)
;;;(eval-when (compile load eval)
;;;(eval-when (:compile-toplevel :load-toplevel :execute)
;;; ;;mm: 11Jan95 - this is defined later in ???
;;; (unless (ignore-errors (find-class 'activity-frame))
;;; (defclass activity-frame () ())))
......@@ -1489,23 +1489,23 @@
(defun find-frame-pane-of-type (frame type)
(map-over-sheets #'(lambda (sheet)
(when (typep sheet type)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(when (typep sheet type)
(return-from find-frame-pane-of-type sheet)))
(frame-top-level-sheet frame)))
(defmethod frame-standard-output ((frame standard-application-frame))
(if (not (member '*standard-output* (slot-value frame
'non-frame-stream-names)))
(or
(if (not (member '*standard-output* (slot-value frame
'non-frame-stream-names)))
(or
(find-frame-pane-of-type frame 'application-pane)
(find-frame-pane-of-type frame 'interactor-pane))
nil))
(defmethod frame-standard-input ((frame standard-application-frame))
(if (not (member '*standard-input* (slot-value frame
'non-frame-stream-names)))
'non-frame-stream-names)))
(or (find-frame-pane-of-type frame 'interactor-pane)
(frame-standard-output frame))))
(frame-standard-output frame))))
(defmethod frame-query-io ((frame standard-application-frame))
(if (not (member '*query-io* (slot-value frame
......