From thenriksen at common-lisp.net Wed Jan 3 13:08:04 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 3 Jan 2007 08:08:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070103130804.7E9284818A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27948 Modified Files: lisp-syntax.lisp Log Message: Literal objects are now always considered complete forms, fixes issue reported by Christophe Rhodes. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/13 20:41:56 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/03 13:08:04 1.15 @@ -387,7 +387,7 @@ (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) (defclass number-lexeme (form-lexeme complete-form-mixin) ()) (defclass token-mixin () ()) -(defclass literal-object-lexeme (form-lexeme) ()) +(defclass literal-object-form (form-lexeme complete-form-mixin) ()) (defclass complete-token-lexeme (token-mixin form-lexeme complete-form-mixin) ()) (defclass multiple-escape-start-lexeme (lisp-lexeme) ()) (defclass multiple-escape-end-lexeme (lisp-lexeme) ()) @@ -539,7 +539,7 @@ (t (cond ((or (constituentp object) (eql object #\\)) (lex-token syntax scan)) - (t (fo) (make-instance 'literal-object-lexeme)))))))) + (t (fo) (make-instance 'literal-object-form)))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -1880,7 +1880,7 @@ (t (call-next-method)))))) (call-next-method))) -(defmethod display-parse-tree ((parser-symbol literal-object-lexeme) stream (drei drei) +(defmethod display-parse-tree ((parser-symbol literal-object-form) stream (drei drei) (syntax lisp-syntax)) (updating-output (stream :unique-id (list drei parser-symbol) @@ -2890,7 +2890,7 @@ (when read (read-from-string (form-string syntax form)))) -(defmethod form-to-object ((syntax lisp-syntax) (form literal-object-lexeme) &key &allow-other-keys) +(defmethod form-to-object ((syntax lisp-syntax) (form literal-object-form) &key &allow-other-keys) (object-after (start-mark form))) (defmethod form-to-object ((syntax lisp-syntax) (form pathname-form) &key &allow-other-keys) From crhodes at common-lisp.net Thu Jan 4 09:13:25 2007 From: crhodes at common-lisp.net (crhodes) Date: Thu, 4 Jan 2007 04:13:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070104091325.25AC5671C5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9209 Modified Files: frames.lisp Log Message: Just a whitespace fixup --- /project/mcclim/cvsroot/mcclim/frames.lisp 2006/12/20 16:23:49 1.122 +++ /project/mcclim/cvsroot/mcclim/frames.lisp 2007/01/04 09:13:25 1.123 @@ -709,7 +709,7 @@ pane) (defun coerce-pane-name (pane name) - (when pane + (when pane (setf (slot-value pane 'name) name) (push pane (frame-named-panes (pane-frame pane)))) pane) From crhodes at common-lisp.net Thu Jan 4 09:15:25 2007 From: crhodes at common-lisp.net (crhodes) Date: Thu, 4 Jan 2007 04:15:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070104091525.4A68C68001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9240 Modified Files: commands.lisp Log Message: Rename the class MENU-ITEM to %MENU-ITEM, so that it doesn't clobber the MENU-ITEM presentation type. This is important because we want menus to supersede any inner accepts in READ-FRAME-COMMAND, so the MENU-ITEM presentation type must not have applicable translators to any inner type, including EXPRESSION or FORM. (Fixes menus in the Listener) --- /project/mcclim/cvsroot/mcclim/commands.lisp 2006/12/14 19:43:51 1.67 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/04 09:15:24 1.68 @@ -45,7 +45,7 @@ ;;; According to the specification, command menu items are stored as ;;; lists. This way seems better, and I hope nothing will break. -(defclass menu-item (command-item) +(defclass %menu-item (command-item) ((menu-name :reader command-menu-item-name :initarg :menu-name) (type :initarg :type :reader command-menu-item-type) (value :initarg :value :reader command-menu-item-value) @@ -53,7 +53,7 @@ (text-style :initarg :text-style :initform nil) (keystroke :initarg :keystroke))) -(defmethod print-object ((item menu-item) stream) +(defmethod print-object ((item %menu-item) stream) (print-unreadable-object (item stream :identity t :type t) (when (slot-boundp item 'menu-name) (format stream "~S" (command-menu-item-name item))) @@ -196,7 +196,7 @@ (when errorp (error 'command-not-present)) (progn - (when (typep item 'menu-item) + (when (typep item '%menu-item) (remove-menu-item-from-command-table table (command-menu-item-name item) :errorp nil)) @@ -352,7 +352,7 @@ (when (and (consp text-style) (eq (first text-style) 'make-text-style)) (setq text-style (apply #'make-text-style (rest text-style)))) - (apply #'make-instance 'menu-item + (apply #'make-instance '%menu-item :menu-name name :type type :value value `(,@(and documentationp `(:documentation ,documentation)) ,@(and keystrokep `(:keystroke ,keystroke)) @@ -431,7 +431,7 @@ (let ((command-table (find-command-table command-table))) (%add-keystroke-item command-table gesture - (make-instance 'menu-item + (make-instance '%menu-item :type type :value value :keystroke gesture :documentation documentation) From crhodes at common-lisp.net Thu Jan 4 09:20:58 2007 From: crhodes at common-lisp.net (crhodes) Date: Thu, 4 Jan 2007 04:20:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070104092058.C0DF04044@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv10142 Modified Files: listener.lisp Log Message: Restore +listener-view+ and +listener-pointer-documentation-view+ to the relevant listener panes. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/12/03 22:56:46 1.31 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/01/04 09:20:58 1.32 @@ -181,8 +181,9 @@ (:panes (interactor-container (make-clim-stream-pane :type 'listener-interactor-pane - :name 'interactor :scroll-bars t)) - (doc :pointer-documentation) + :name 'interactor :scroll-bars t + :default-view +listener-view+)) + (doc :pointer-documentation :default-view +listener-pointer-documentation-view+) (wholine (make-pane 'wholine-pane :display-function 'display-wholine :scroll-bars nil :display-time :command-loop :end-of-line-action :allow))) @@ -229,8 +230,8 @@ (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) "Specialized for the listener, read a lisp form to eval, or a command." (multiple-value-bind (object type) - (accept 'command-or-form :stream stream :prompt nil) - (format *trace-output* "~&object=~W~%" object) + (let ((*command-dispatchers* '(#\,))) + (accept 'command-or-form :stream stream :prompt nil)) (if (presentation-subtypep type 'command) object `(com-eval ,object)))) From thenriksen at common-lisp.net Thu Jan 4 23:15:48 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 4 Jan 2007 18:15:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070104231548.5F4753F00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6865 Modified Files: input-editor.lisp Log Message: Fix annoying bug where the first gesture of the subaccepts in an `accepting-values' body were ignored. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/11 22:55:28 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/01/04 23:15:48 1.15 @@ -567,6 +567,7 @@ *pointer-documentation-output* minibuffer) :prompt "M-x ") + (update-drei-buffer stream) ;; Commands are permitted to signal immediate rescans, but ;; we may need to do some stuff first. (unwind-protect From crhodes at common-lisp.net Fri Jan 5 12:45:22 2007 From: crhodes at common-lisp.net (crhodes) Date: Fri, 5 Jan 2007 07:45:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070105124522.F201775024@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13994 Modified Files: dev-commands.lisp Log Message: PRESENTATION is a magical argument name for DEFINE-PRESENTATION-TO-COMMAND-TRANSLATOR. This means that the body of the translator was unidiomatic, so change the name from PRESENTATION to OBJECT. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/12/13 21:05:11 1.40 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2007/01/05 12:45:22 1.41 @@ -425,19 +425,18 @@ :menu t :documentation "Show Class Subclasses" :pointer-documentation "Show Class Subclasses") - (presentation) - (list (presentation-object presentation))) + (object) + (list object)) (define-presentation-to-command-translator com-show-class-superclasses-translator (class-name com-show-class-superclasses lisp-commands :menu t - :tester ((presentation) - (not (eq t (presentation-object presentation)))) + :tester ((object) (not (eq t object))) :documentation "Show Class Superclasses" :pointer-documentation "Show Class Superclasses") - (presentation) - (list (presentation-object presentation))) + (object) + (list object)) (define-presentation-to-command-translator com-show-class-generic-functions-translator @@ -445,8 +444,8 @@ :menu t :documentation "Show Class Generic Functions" :pointer-documentation "Show Class Generic Functions") - (presentation) - (list (presentation-object presentation))) + (object) + (list object)) (define-presentation-to-command-translator com-show-class-slots-translator @@ -454,8 +453,8 @@ :menu t :documentation "Show Class Slots" :pointer-documentation "Show Class Slots") - (presentation) - (list (presentation-object presentation))) + (object) + (list object)) ;;; CLOS introspection commands From rstrandh at common-lisp.net Sat Jan 6 05:00:17 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 6 Jan 2007 00:00:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070106050017.E1F9C19001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv12843 Modified Files: drei.texi make-tempfiles.sh mcclim.texi Log Message: Make the documentation compile again. I am not sure what the problem was, but replacing the use of the macro @glossentry{...} by its expansion solved the problem. I removed the @bye from drei.texi because it just had the effect of making the compilation stop before the glossentry macros were seen. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/12/24 13:01:08 1.4 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/01/06 05:00:17 1.5 @@ -1249,4 +1249,3 @@ Macroexpansion command to Lisp syntax), their modus operandi is general enough to be used for all conditional activity of command tables. - at bye --- /project/mcclim/cvsroot/mcclim/Doc/make-tempfiles.sh 2006/12/21 12:22:02 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/make-tempfiles.sh 2007/01/06 05:00:17 1.2 @@ -23,7 +23,7 @@ SBCLRUNTIME="$1" fi -SBCL="$SBCLRUNTIME --noinform --no-sysinit --no-userinit --noprint --disable-debugger" +SBCL="$SBCLRUNTIME --noinform --no-sysinit --noprint --disable-debugger" # Output directory. This has to end with a slash (it's interpreted by # Lisp's `pathname' function) or you lose. This is normally set from --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/12/24 14:27:48 1.4 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/06 05:00:17 1.5 @@ -43,6 +43,10 @@ @cindex \ENTRY\ @end macro + at macro func{FUN} + at b{\FUN\} + at end macro + @macro fmacro{MACRO} @func{\MACRO\} @end macro @@ -2080,7 +2084,9 @@ @node Glossary @chapter Glossary - at glossentry{Direct mirror} + at c @glossentry{Direct mirror} + at b{Direct mirror} + at cindex Direct mirror A @gloss{mirror} of a sheet which is not shared with any of the ancestors of the sheet. All grafted McCLIM sheets have mirrors, but not @@ -2098,7 +2104,9 @@ or not is not determined statically by the class of a sheet, but dynamically by the frame manager. - at glossentry{Mirror} + at c @glossentry{Mirror} + at b{Mirror} + at cindex Mirror A device window such as an X11 window that parallels a @gloss{sheet} in the CLIM @gloss{sheet hierarchy}. A @gloss{sheet} having such a @@ -2111,7 +2119,9 @@ (direct or indirect) of a @gloss{mirrored sheet}, which will then be the @gloss{sheet} that receives the drawing commands. - at glossentry{Mirrored sheet} + at c @glossentry{Mirrored sheet} + at b{Mirrored sheet} + at cindex Mirrored sheet A @gloss{sheet} in the CLIM @gloss{sheet hiearchy} that has a direct parallel (called the @gloss{direct mirror}) in the host windowing @@ -2147,14 +2157,18 @@ sheet or not. A call to @genfun{sheet-direct-mirror}, on the other hand, returns nil if the sheet is not a mirrored sheet. - at glossentry{Mirror transformation} + at c @glossentry{Mirror transformation} + at b{Mirror transformation} + at cindex Mirror transformation The transformation that transforms coordinates in the coordinate system of a mirror (i.e. the native coordinates of the mirror) to native coordinates of its parent in the underlying windowing system. On most systems, including X, this transformation will be a simple translation. - at glossentry{Native coordinates} + at c @glossentry{Native coordinates} + at b{Native coordinates} + at cindex Native coordinates Each mirror has a coordinate system called the native coordinate system. Usually, the native coordinate system of a mirror has its origin in the @@ -2168,23 +2182,31 @@ coordinates of the parent of a mirror, use the @gloss{mirror transformation}. - at glossentry{Native region} + at c @glossentry{Native region} + at b{Native region} + at cindex Native region The native region of a sheet is the intersection of its region and the sheet region of all of its parents, expressed in the @gloss{native coordinates} of the sheet. - at glossentry{Potentially visible area} + at c @glossentry{Potentially visible area} + at b{Potentially visible area} + at cindex Potentially visible area A bounded area of an otherwise infinte drawing plane that is visible unless it is covered by other visible areas. - at glossentry{Sheet coordinates} + at c @glossentry{Sheet coordinates} + at b{Sheet coordinates} + at cindex Sheet coordinates The coordinate system of coordinates obtained by application of the @gloss{user transformation}. - at glossentry{Sheet region} + at c @glossentry{Sheet region} + at b{Sheet region} + at cindex Sheet region The @gloss{region} of a sheet determines the visible part of the drawing plane. The dimensions of the sheet region are given in @gloss{sheet @@ -2208,7 +2230,9 @@ obtain effects such as scrolling, zooming, coordinate system transformations, etc. - at glossentry{Sheet transformation} + at c @glossentry{Sheet transformation} + at b{Sheet transformation} + at cindex Sheet transformation The transformation used to transform @gloss{sheet coordinates} of a sheet to @gloss{sheet coordinates} of its @gloss{parent sheet}. The @@ -2220,7 +2244,9 @@ obtain effects such as scrolling, zooming, coordinate system transformations, etc. - at glossentry{User Clipping region } + at c @glossentry{User Clipping region } + at b{User Clipping region } + at cindex User Clipping region A @gloss{clipping region} used to limit the effect of @gloss{drawing functions}. The user @gloss{clipping region} is stored in the @@ -2228,12 +2254,16 @@ @gloss{medium}, or by passing a value for the :clipping-region @gloss{drawing option} to a @gloss{drawing function}. - at glossentry{User Coordinates} + at c @glossentry{User Coordinates} + at b{User Coordinates} + at cindex User Coordinates The coordinate system of coordinates passed to the @gloss{drawing functions}. - at glossentry{User Transformation} + at c @glossentry{User Transformation} + at b{User Transformation} + at cindex User Transformation A transformation used to transform @gloss{user coordinates} into @gloss{sheet coordinates}. The user transformation is stored in the @@ -2241,7 +2271,9 @@ @gloss{medium}, or by passing a value for the :transformation @gloss{drawing option} to a @gloss{drawing function}. - at glossentry{Visible area} + at c @glossentry{Visible area} + at b{Visible area} + at cindex Visible area @node Development History @chapter Development History From rstrandh at common-lisp.net Sat Jan 6 05:01:05 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 6 Jan 2007 00:01:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070106050105.7761E1E00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv16226 Modified Files: Makefile Log Message: Added image conversion to PDF needed by the PDF version of the manual. --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/12/24 12:54:19 1.8 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2007/01/06 05:01:02 1.9 @@ -9,7 +9,7 @@ HTMLDIRS=$(basename $(MCCLIMTEXI)) IMAGES=ex2.eps inspect-as-cells.eps inspect-object-1.eps \ inspect-object-2.eps inspect-object-3.eps native.fig -IMAGETARGETTYPES=gif png eps +IMAGETARGETTYPES=gif png eps pdf TARGETIMAGES=$(shell sh ./makeimages.sh -e "$(IMAGES)" "$(IMAGETARGETTYPES)") # Place where generated documentation ends up. The value of # DOCSTRINGDIR has to end with a slash or you lose (it's passed to From rstrandh at common-lisp.net Sat Jan 6 05:27:53 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 6 Jan 2007 00:27:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070106052753.E041538005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv22828 Modified Files: mcclim.texi Log Message: Added a section on how CLIM applications produce output. --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/06 05:00:17 1.5 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/06 05:27:53 1.6 @@ -418,6 +418,7 @@ @cindex writing an application @menu +* How CLIM applications produce output:: * Panes and Gadgets:: * Defining Application Frames:: * A First Attempt:: @@ -427,6 +428,84 @@ * Incremental redisplay:: @end menu + at node How CLIM applications produce output + at section How CLIM applications produce output + +CLIM stream panes use output recording. This means that such a pane +maintains a display list, consisting of a sequence of output records, +ordered chronologically, from the first output record to be drawn to +the last. + +This display list is used to fill in damaged areas of the pane, for +instance as a result of the pane being partially or totally covered by +other panes, and then having some or all of its area again becoming +visible. The output records of the display list that have some parts +in common with the exposed area are partially or totally replayed (in +chronological order) to redraw the contents of the area. + +An application can have a pane establish this display list in several +fundamentally different ways. + +Very simple applications have no internal data structure to keep track +of application objects, and simply produce output to the pane from +time to time as a result of running commands, occasionally perhaps +erasing the pane and starting over. Such applications typically use +text or graphics output as a result of running commands. CLIM +maintains the display list for the pane, and adds to the end of it, +each time also producing the pixels that result from drawing the new +output record. If the pane uses scrolling (which it typically does), +then CLIM must determine the extent of the pane so as to update the +scroll bar after each new output. + +More complicated applications use a display function. Before the +display function is run, the existing display list is typically +deleted, so that the purpose of the display function becomes to +establish an entirely new display list. The display function might +for instance produce some kind of form to be filled in, and +application commands can use text or graphics operations to fill in +the form. A game of tic-tac-toe could work this way, where the +display function draws the board and commands draw shapes into the +squares. + +Even more complicated applications might have some internal data +structure that has a direct mapping to output, and commands simply +modify this internal data structure. In this case, the display +function is run after each time around the command loop, because a +command can have modified the internal data structure in some +arbitrary ways. Some such applications might simply want to delete +the existing display list and produce a new one each time (to minimize +flicker, double buffering could be used). This is a very simple way +of structuring an application, and entirely acceptable in many cases. +Consider, for instance, a board game where pieces can be moved (as +opposed to just added). A very simple way of structuring such an +application is to have an internal representation of the board, and to +make the display function traverse this data structure and produce the +complete output each time in the command loop. + +Some applications have very large internal data structures to be +displayed, and it would cause a serious performance problem if the +display list had to be computer from scratch each time around the +command loop. To solve this problem, CLIM contains a feature called +incremental redisplay. It allows many of the output records to be +kept from one iteration of the command loop to the next. This can be +done in two different ways. The simplest way is for the application +to keep the simple structure which consists of traversing the entire +data structure each time, but at various points indicate to CLIM that +the output has not changed since last time, so as to avoid actually +invoking the application code for computing it. This is accomplished +by the use of @t{updating-output}. The advantage of + at t{updating-output} is that the application logic remains +straightforward, and it is up to CLIM to do the hard work of recycling +output records. The disadvantage is that for some very demanding +applications, this method might not be fast enough. + +The other way is more complicated and requires the programmer to +structure the application differently. Essentially, the application +has to keep track of the output records in the display list, and +inform CLIM about modifications to it. The main disadvantage of this +method is that the programmer must now write the application to keep +track of the output records itself, as opposed to leaving it to CLIM. + @node Panes and Gadgets @section Panes and Gadgets From thenriksen at common-lisp.net Sat Jan 6 12:50:38 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 6 Jan 2007 07:50:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070106125038.8A3CE4047@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7414 Modified Files: presentation-defs.lisp Log Message: Improve presentation history - is now explicitly a stack, and works pretty much as you would expect. Goatee's support is temporarily broken until I can make `define-input-editor-command' also define commands for Goatee. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/12/13 21:33:43 1.65 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/06 12:50:38 1.66 @@ -451,8 +451,20 @@ (defun presentation-type-history (type) (funcall-presentation-generic-function presentation-type-history type)) -(defclass presentation-history-ring (goatee::ring) - ()) +(defclass presentation-history () + ((stack :accessor presentation-history-array + :initform (make-array 1 :fill-pointer 0 + :adjustable t) + :documentation "The history, with the newest objects at +the end of the array. Should contain conses with the car being +the object and the cdr being the type.") + (pointer :accessor presentation-history-pointer + :initform nil + :documentation "The index of the \"current\" object, +used when navigating the history. If NIL, means that no +navigation has yet been performed.")) + (:documentation "Class for objects that contain the history for +a specific type.")) (define-default-presentation-method presentation-type-history (type) (if (and *application-frame* @@ -468,7 +480,7 @@ (history-object (gethash name history-table))) (unless history-object (setf history-object - (make-instance 'presentation-history-ring) + (make-instance 'presentation-history) (gethash name history-table) history-object)) history-object)) @@ -505,53 +517,94 @@ (funcall-presentation-generic-function presentation-type-history type)) (defun presentation-history-insert (history object ptype) - (goatee::ring-obj-insert (cons object ptype) history)) - -(defun presentation-history-head (history ptype) + "Unconditionally insert `object' as an input of presentation +type `type' at the top of the presentation history `history', as +the most recently added object." + (vector-push-extend (cons object ptype) + (presentation-history-array history))) + +(defun presentation-history-top (history ptype) + "Find the topmost (most recently added object) of `history' +that is of the presentation type `ptype' or a subtype. Two values +will be returned, the object and the presentation type of the +object. If no applicable object can be found, these values will +both be NIL." (loop - for cell = (goatee::dbl-head history) then (goatee::next cell) - for (object . object-ptype) = (and cell (goatee::contents cell)) - while cell - if (presentation-subtypep object-ptype ptype) - return (values object object-ptype) - finally (return (values nil nil)))) + with array = (presentation-history-array history) + for index from (1- (fill-pointer array)) downto 0 + for (object . object-ptype) = (aref array index) + do + (when (presentation-subtypep object-ptype ptype) + (return (aref array index))) + finally (return (values nil nil)))) + +(defun presentation-history-reset-pointer (history) + "Set the pointer to point at the object most recently added +object." + (setf (presentation-history-pointer history) nil)) (defun presentation-history-next (history ptype) - (let ((first-object (goatee::backward history))) - (loop - for first-time = t then nil - for cell = first-object then (goatee::backward history) - for (object . object-ptype) = (goatee::contents cell) - while (or first-time (not (eq first-object cell))) - if (presentation-subtypep object-ptype ptype) - return (values object object-ptype) - end - finally (return (values nil nil))))) + "Go to the next input (forward in time) in `history' that is a +presentation-subtype of `ptype', respective to the pointer in +`history'. Returns two values: the found object and its +presentation type, both of which will be NIL if no applicable +object can be found." + (with-accessors ((pointer presentation-history-pointer) + (array presentation-history-array)) history + ;; If no navigation has been performed, we have no object to go + ;; forwards to. + (if (or (null pointer) (>= (1+ pointer) (length array))) + (values nil nil) + (progn + (incf pointer) + (destructuring-bind (object . object-ptype) + (aref array pointer) + (if object-ptype + (if (presentation-subtypep object-ptype ptype) + (values object object-ptype) + (presentation-history-next history ptype)) + (values nil nil))))))) (defun presentation-history-previous (history ptype) - (let ((first-object (goatee::forward history))) - (loop - for first-time = t then nil - for cell = first-object then (goatee::forward history) - for (object . object-ptype) = (goatee::contents cell) - while (or first-time (not (eq first-object cell))) - if (presentation-subtypep object-ptype ptype) - return (values object object-ptype) - end - finally (return (values nil nil))))) + "Go to the previous input (backward in time) in `history' that +is a presentation-subtype of `ptype', respective to the pointer +in `history'. Returns two values: the found object and its +presentation type, both of which will be NIL if no applicable +object can be found." + (with-accessors ((pointer presentation-history-pointer) + (array presentation-history-array)) history + (if (and (numberp pointer) (zerop pointer)) + (values nil nil) + (progn + (if pointer + (decf pointer) + (setf pointer (1- (fill-pointer array)))) + (destructuring-bind (object . object-ptype) + (when (array-in-bounds-p array pointer) + (aref array pointer)) + (if object-ptype + (if (presentation-subtypep object-ptype ptype) + (values object object-ptype) + (progn (presentation-history-previous history ptype))) + (values nil nil))))))) (defmacro with-object-on-history ((history object ptype) &body body) - `(goatee::with-object-on-ring ((cons ,object ,ptype) ,history) - , at body)) + "Evaluate `body' with `object' as `ptype' as the head (most +recently added object) on `history', and remove it again after +`body' has run. If `body' as `ptype' is already the head, the +history will be unchanged." + (with-gensyms (added) + `(let ((,added (presentation-history-add ,history ,object ,ptype))) + (unwind-protect (progn , at body) + (when ,added + (decf (fill-pointer (presentation-history-array ,history)))))))) (defun presentation-history-add (history object ptype) "Add OBJECT and PTYPE to the HISTORY unless they are already at the head of HISTORY" - (let* ((cell (goatee::dbl-head history)) - (contents (and cell (goatee::contents cell)))) - (unless (and cell - (eql object (car contents)) - (equal ptype (cdr contents))) + (multiple-value-bind (top-object top-ptype) + (presentation-history-top history ptype) + (unless (and top-ptype (eql object top-object) (equal ptype top-ptype)) (presentation-history-insert history object ptype)))) ;;; Context-dependent input @@ -730,34 +783,37 @@ ;; presentation history. In addition, we'll implement the Genera ;; behavior of temporarily putting the default on the history ;; stack so the user can conveniently suck it in. - (flet ((do-accept (args) - (apply #'stream-accept stream real-type args)) - (get-history () - (when real-history-type - (funcall-presentation-generic-function - presentation-type-history-for-stream - real-history-type stream)))) + (labels ((get-history () + (when real-history-type + (funcall-presentation-generic-function + presentation-type-history-for-stream + real-history-type stream))) + (do-accept (args) + (apply #'stream-accept stream real-type args))) (let* ((default-from-history (and (not defaultp) provide-default)) (history (get-history)) (results (multiple-value-list (if history - (let ((*active-history-type* real-history-type)) - (cond (defaultp - (with-object-on-history - (history default real-default-type) - (do-accept rest-args))) - (default-from-history - (multiple-value-bind - (history-default history-type) - (presentation-history-head history - real-default-type) - (do-accept (if history-type - (list* :default history-default - :default-type history-type - rest-args) - rest-args)))) - (t (do-accept rest-args)))) + (unwind-protect + (let ((*active-history-type* real-history-type)) + (cond (defaultp + (with-object-on-history + (history default real-default-type) + (do-accept rest-args))) + (default-from-history + (multiple-value-bind + (history-default history-type) + (presentation-history-top history + real-default-type) + (do-accept (if history-type + (list* :default history-default + :default-type history-type + rest-args) + rest-args)))) + (t (do-accept rest-args)))) + (unless *recursive-accept-p* + (presentation-history-reset-pointer (get-history)))) (do-accept rest-args)))) (results-history (get-history))) (when results-history From thenriksen at common-lisp.net Sat Jan 6 12:51:20 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 6 Jan 2007 07:51:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070106125120.D409F4047@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7516 Modified Files: commands.lisp Log Message: When doing sub-accepts for `command-or-form', inherit the history of the `command-or-form' type. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/04 09:15:24 1.68 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/06 12:51:16 1.69 @@ -1401,8 +1401,8 @@ (if (member initial-char *command-dispatchers*) (progn (read-gesture :stream stream) - (accept command-ptype :stream stream :view view :prompt nil)) - (accept 'form :stream stream :view view :prompt nil))) + (accept command-ptype :stream stream :view view :prompt nil :history 'command-or-form)) + (accept 'form :stream stream :view view :prompt nil :history 'command-or-form))) (t (funcall (cdar *input-context*) object type event options))))) From thenriksen at common-lisp.net Sat Jan 6 13:11:43 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 6 Jan 2007 08:11:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070106131143.1054C68001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15615 Modified Files: mcclim.asd Log Message: Make McCLIM loadable in CLISP. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/12/26 16:44:45 1.45 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:11:42 1.46 @@ -40,7 +40,11 @@ (asdf:missing-component ()))) (defun find-swank () (or (find-swank-package) - (find-swank-system)))) + (find-swank-system))) + (defun ifswank () + (if (find-swank) + '(and) + '(or)))) ;;; Legacy CMUCL support stuff #+cmu @@ -253,7 +257,7 @@ (defsystem :drei-mcclim - :depends-on (:flexichain :esa-mcclim :clim-core #.(if (find-swank-system) :swank (values))) + :depends-on (:flexichain :esa-mcclim :clim-core #+#.(mcclim.system::ifswank) :swank) :components ((:module "cl-automaton" :pathname #.(make-pathname :directory '(:relative "Drei" "cl-automaton")) @@ -304,9 +308,7 @@ (:file "lisp-syntax" :depends-on ("core" "motion" "fundamental-syntax")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) - #.(if (find-swank) - '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) - (values)))))) + #+#.(mcclim.system::ifswank) (:file "lisp-syntax-swank" :depends-on ("lisp-syntax")))))) (defsystem :drei-tests :depends-on (:drei-mcclim :fiveam) From thenriksen at common-lisp.net Sat Jan 6 13:27:25 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 6 Jan 2007 08:27:25 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070106132725.AB91BC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19077 Modified Files: mcclim.asd Log Message: Really Make CLISP Work. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:11:42 1.46 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:27:25 1.47 @@ -41,6 +41,11 @@ (defun find-swank () (or (find-swank-package) (find-swank-system))) + (defun dep-on-swank () + (if (and (find-swank-system) + (not (find-package :swank))) + '(and) + '(or))) (defun ifswank () (if (find-swank) '(and) @@ -257,7 +262,7 @@ (defsystem :drei-mcclim - :depends-on (:flexichain :esa-mcclim :clim-core #+#.(mcclim.system::ifswank) :swank) + :depends-on (:flexichain :esa-mcclim :clim-core #+#.(mcclim.system::dep-on-swank) :swank) :components ((:module "cl-automaton" :pathname #.(make-pathname :directory '(:relative "Drei" "cl-automaton")) From dlichteblau at common-lisp.net Sun Jan 7 19:32:28 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:32:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070107193228.EBBCE72088@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18071 Modified Files: mcclim.asd Log Message: Add a new class RGB-IMAGE (renamed from closure's IMAGELIB:AIMAGE) and RGB-IMAGE-DESIGN (used to implement CLOSURE/CLIM-DEVICE::RO/IMG). Drawing code implemented only in CLIM-CLX, and only for true color visuals. * Examples/rgb-image.lisp: New file, from closure/src/imagelib/basic.lisp. * Backends/CLX/medium.lisp (MEDIUM-DRAW-IMAGE-DESIGN*, MEDIUM-FREE-IMAGE-DESIGN, COMPUTE-RGB-IMAGE-PIXMAP, COMPUTE-RGB-IMAGE-MASK, IMAGE-TO-XIMAGE-FOR-DRAWABLE, IMAGE-TO-XIMAGE, MASK->BYTE, PIXEL-TRANSLATOR): Methods and functions, renamed from original closure code. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/06 13:27:25 1.47 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/07 19:32:28 1.48 @@ -348,7 +348,8 @@ :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp")) (:file "input-editing-goatee") (:file "input-editing-drei") - (:file "text-editor-gadget"))) + (:file "text-editor-gadget") + (:file "Extensions/rgb-image"))) (defsystem :clim-clx :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) From dlichteblau at common-lisp.net Sun Jan 7 19:32:29 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:32:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20070107193229.3A3BB9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv18071/Backends/CLX Modified Files: medium.lisp Log Message: Add a new class RGB-IMAGE (renamed from closure's IMAGELIB:AIMAGE) and RGB-IMAGE-DESIGN (used to implement CLOSURE/CLIM-DEVICE::RO/IMG). Drawing code implemented only in CLIM-CLX, and only for true color visuals. * Examples/rgb-image.lisp: New file, from closure/src/imagelib/basic.lisp. * Backends/CLX/medium.lisp (MEDIUM-DRAW-IMAGE-DESIGN*, MEDIUM-FREE-IMAGE-DESIGN, COMPUTE-RGB-IMAGE-PIXMAP, COMPUTE-RGB-IMAGE-MASK, IMAGE-TO-XIMAGE-FOR-DRAWABLE, IMAGE-TO-XIMAGE, MASK->BYTE, PIXEL-TRANSLATOR): Methods and functions, renamed from original closure code. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2006/12/28 19:30:40 1.78 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2007/01/07 19:32:28 1.79 @@ -6,6 +6,7 @@ ;;; Julien Boninfante (boninfan at emi.u-bordeaux.fr) ;;; Robert Strandh (strandh at labri.u-bordeaux.fr) ;;; (c) copyright 2001 by Arnaud Rouanet (rouanet at emi.u-bordeaux.fr) +;;; (c) copyright 1998,1999 by Gilbert Baumann ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -1151,3 +1152,152 @@ (setf (medium-buffer medium) nil))) (funcall continuation))) + +;;; RGB-IMAGE support, from Closure + +(defmethod climi::medium-draw-image-design* + ((medium clx-medium) (design climi::rgb-image-design) x y) + (let* ((da (sheet-direct-mirror (medium-sheet medium))) + (image (slot-value design 'climi::image)) + (width (climi::image-height image)) + (height (climi::image-height image))) + (destructuring-bind (&optional pixmap mask) + (slot-value design 'climi::medium-data) + (unless pixmap + (setf pixmap (compute-rgb-image-pixmap da image)) + (when (climi::image-alpha-p image) + (setf mask (compute-rgb-image-mask da image))) + (setf (slot-value design 'climi::medium-data) (list pixmap mask))) + (multiple-value-bind (x y) + (transform-position + (sheet-device-transformation (medium-sheet medium)) + x y) + (setf x (round x)) + (setf y (round y)) + (let ((gcontext (xlib:create-gcontext :drawable da))) + (cond + (mask + (xlib:with-gcontext (gcontext + :clip-mask mask + :clip-x x + :clip-y (- y height)) + (xlib:copy-area pixmap gcontext 0 0 width height + da x (- y height)))) + (t + (xlib:copy-area pixmap gcontext 0 0 width height + da x (- y height))))))))) + +(defmethod climi::medium-free-image-design + ((medium clx-medium) (design climi::rgb-image-design)) + (destructuring-bind (&optional pixmap mask) + (slot-value design 'climi::medium-data) + (when pixmap + (xlib:free-pixmap pixmap) + (when mask + (xlib:free-pixmap mask)) + (setf (slot-value design 'climi::medium-data) nil)))) + +(defun compute-rgb-image-pixmap (drawable image) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (depth (xlib:drawable-depth drawable)) + (im (image-to-ximage-for-drawable drawable image))) + (setf width (max width 1)) + (setf height (max height 1)) + (let* ((pixmap (xlib:create-pixmap :drawable drawable + :width width + :height height + :depth depth)) + (gc (xlib:create-gcontext :drawable pixmap))) + (unless (or (>= width 2048) (>= height 2048)) ;### CLX bug + (xlib:put-image pixmap gc im + :src-x 0 :src-y 0 + :x 0 :y 0 + :width width :height height)) + (xlib:free-gcontext gc) + pixmap))) + +(defun compute-rgb-image-mask (drawable image) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (bitmap (xlib:create-pixmap :drawable drawable + :width width + :height height + :depth 1)) + (gc (xlib:create-gcontext :drawable bitmap + :foreground 1 + :background 0)) + (idata (climi::image-data image)) + (xdata (make-array (list height width) + :element-type '(unsigned-byte 1))) + (im (xlib:create-image :width width + :height height + :depth 1 + :data xdata)) ) + (dotimes (y width) + (dotimes (x height) + (if (> (aref idata x y) #x80000000) + (setf (aref xdata x y) 0) + (setf (aref xdata x y) 1)))) + (unless (or (>= width 2048) (>= height 2048)) ;### CLX breaks here + (xlib:put-image bitmap gc im :src-x 0 :src-y 0 + :x 0 :y 0 :width width :height height + :bitmap-p nil)) + (xlib:free-gcontext gc) + bitmap)) + +(defun image-to-ximage-for-drawable (drawable image) + (image-to-ximage image + (xlib:drawable-depth drawable) + (pixel-translator (xlib:window-colormap drawable)))) + +(defun image-to-ximage (image depth translator) + (let* ((width (climi::image-width image)) + (height (climi::image-height image)) + (idata (climi::image-data image)) + ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on + ;; top of a hack. At some point in the past, XFree86 and/or + ;; X.org decided that they would no longer support pixmaps + ;; with 24 bpp, which seems to be what most AIMAGEs want to + ;; be. For now, force everything to a 32-bit pixmap. + (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) + (ximage (xlib:create-image :width width + :height height + :depth depth + :bits-per-pixel 32 + :data xdata))) + (declare (type (simple-array (unsigned-byte 32) (* *)) idata)) + (loop for x fixnum from 0 below width do + (loop for y fixnum from 0 below height do + (setf (aref xdata y x) + (funcall translator + x y + (ldb (byte 24 0) (aref idata y x)))))) + ximage)) + +(defun mask->byte (mask) + (let ((h (integer-length mask))) + (let ((l (integer-length (logxor mask (1- (ash 1 h)))))) + (byte (- h l) l)))) + +;; fixme! This is not just incomplete, but also incorrect: The original +;; true color code knew how to deal with non-linear RGB value +;; allocation. +(defun pixel-translator (colormap) + (unless (eq (xlib:visual-info-class (xlib:colormap-visual-info colormap)) + :true-color) + (error "sorry, cannot draw rgb image for non-true-color drawable yet")) + colormap + (let* ((info (xlib:colormap-visual-info colormap)) + (rbyte (mask->byte (xlib:visual-info-red-mask info))) + (gbyte (mask->byte (xlib:visual-info-green-mask info))) + (bbyte (mask->byte (xlib:visual-info-blue-mask info)))) + (lambda (x y sample) + (declare (ignore x y)) + (dpb (the (unsigned-byte 8) (ldb (byte 8 0) sample)) + rbyte + (dpb (the (unsigned-byte 8) (ldb (byte 8 8) sample)) + gbyte + (dpb (the (unsigned-byte 8) (ldb (byte 8 16) sample)) + bbyte + 0)))))) From dlichteblau at common-lisp.net Sun Jan 7 19:32:29 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 7 Jan 2007 14:32:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Extensions Message-ID: <20070107193229.6D055C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv18071/Extensions Added Files: rgb-image.lisp Log Message: Add a new class RGB-IMAGE (renamed from closure's IMAGELIB:AIMAGE) and RGB-IMAGE-DESIGN (used to implement CLOSURE/CLIM-DEVICE::RO/IMG). Drawing code implemented only in CLIM-CLX, and only for true color visuals. * Examples/rgb-image.lisp: New file, from closure/src/imagelib/basic.lisp. * Backends/CLX/medium.lisp (MEDIUM-DRAW-IMAGE-DESIGN*, MEDIUM-FREE-IMAGE-DESIGN, COMPUTE-RGB-IMAGE-PIXMAP, COMPUTE-RGB-IMAGE-MASK, IMAGE-TO-XIMAGE-FOR-DRAWABLE, IMAGE-TO-XIMAGE, MASK->BYTE, PIXEL-TRANSLATOR): Methods and functions, renamed from original closure code. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/01/07 19:32:29 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2007/01/07 19:32:29 1.1 ;;; (c) copyright 1998 by Gilbert Baumann ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the ;;; "Software"), to deal in the Software without restriction, including ;;; without limitation the rights to use, copy, modify, merge, publish, ;;; distribute, sublicense, and/or sell copies of the Software, and to ;;; permit persons to whom the Software is furnished to do so, subject to ;;; the following conditions: ;;; ;;; The above copyright notice and this permission notice shall be ;;; included in all copies or substantial portions of the Software. ;;; ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;;; ;;; (Hacked for inclusion into McCLIM by David Lichteblau.) (in-package :climi) ;;; ARGB image data represented as an (unsigned-byte 32) array (defclass rgb-image () ((width :initarg :width :accessor image-width) (height :initarg :height :accessor image-height) (data :initarg :data :accessor image-data :type (or null (simple-array (unsigned-byte 32) (* *)))) (alphap :initarg :alphap :initform nil :accessor image-alpha-p))) ;;; Applications (closure in particular) might want to cache any ;;; backend-specific data required to draw an RGB-IMAGE. ;;; ;;; To implement this caching, designs must be created separately for each ;;; medium, so that mediums can put their own data into them. (defclass rgb-image-design (design) ((medium :initarg :medium) (image :initarg :image) (medium-data :initform nil))) (defun make-rgb-image-design (medium image) (make-instance 'rgb-image-design :medium medium :image image)) ;;; Protocol to free cached data (defgeneric medium-free-image-design (medium design)) (defun free-image-design (design) (medium-free-image-design (slot-value design 'medium) design)) ;;; Drawing protocol (defgeneric medium-draw-image-design* (medium design x y)) (defmethod medium-draw-image-design* :before (medium design x y) (assert (eq medium (slot-value design 'medium)))) From thenriksen at common-lisp.net Sun Jan 7 19:36:06 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 7 Jan 2007 14:36:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20070107193606.DBE175605D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv18682/Goatee Modified Files: presentation-history.lisp Log Message: Now Goatee has Drei-like presentation history commands. --- /project/mcclim/cvsroot/mcclim/Goatee/presentation-history.lisp 2004/01/20 16:07:26 1.1 +++ /project/mcclim/cvsroot/mcclim/Goatee/presentation-history.lisp 2007/01/07 19:36:06 1.2 @@ -30,67 +30,40 @@ (defun insert-ptype-history (object type) (multiple-value-bind (line pos) (point* *buffer*) - (setf *insert-extent* (make-instance 'extent - :start-line line - :start-pos pos)) (multiple-value-bind (printed-rep accept-object) (present-acceptably-to-string object type +textual-view+ ; XXX type) - (format *trace-output* "insert-ptype-history: ~S, ~S~%" - (pos (bp-start *insert-extent*)) - (pos (bp-end *insert-extent*))) ;; XXX accept-object - (insert *buffer* printed-rep :line line :pos pos) - (format *trace-output* "insert-ptype-history:: ~S, ~S~%" - (pos (bp-start *insert-extent*)) - (pos (bp-end *insert-extent*)))))) + (insert *buffer* printed-rep :line line :pos pos)))) -(defun cmd-presentation-history-yank (&key &allow-other-keys) +(defun cmd-history-yank-next (&key &allow-other-keys) (let* ((accepting-type climi::*active-history-type*) - (history (and accepting-type - (climi::presentation-type-history accepting-type)))) - (setq *last-history-type* accepting-type - *last-history* history) + (history (and accepting-type + (presentation-type-history accepting-type)))) (when history (multiple-value-bind (object type) - (climi::presentation-history-head history accepting-type) - (if type - (insert-ptype-history object type)))))) + (climi::presentation-history-next history accepting-type) + (when type + (clear-buffer *buffer*) + (insert-ptype-history object type)))))) -(defun cmd-presentation-history-yank-next (&key &allow-other-keys) - (when (and *last-history-type* *last-history*) +(defun cmd-history-yank-previous (&key &allow-other-keys) + (let* ((accepting-type climi::*active-history-type*) + (history (and accepting-type + (presentation-type-history accepting-type)))) + (when history (multiple-value-bind (object type) - (climi::presentation-history-next *last-history* *last-history-type*) - (when type - (delete-region *buffer* - (bp-start *insert-extent*) - (bp-end *insert-extent*)) - (insert-ptype-history object type))))) - - -(defun goatee-next (&key &allow-other-keys) - (cond ((or (eq *last-command* 'cmd-presentation-history-yank) - (and (eq *last-command* 'goatee-next) - (or (eq *last-yank-command* 'cmd-presentation-history-yank-next) - (eq *last-yank-command* - 'cmd-presentation-history-yank-prev)))) - (funcall #'cmd-presentation-history-yank-next) - (setq *last-yank-command* 'cmd-presentation-history-yank-next)) - ((or (eq *last-command* 'cmd-yank) - (eq *last-command* 'cmd-yank-prev) - (and (eq *last-command* 'goatee-next) - (or (eq *last-yank-command* 'cmd-yank-next) - (eq *last-yank-command* 'cmd-yank-prev)))) - (funcall #'cmd-yank-next) - (setq *last-yank-command* 'cmd-yank-next)) - (t (beep)))) - -(add-gesture-command-to-table '(#\y :control :meta) - 'cmd-presentation-history-yank - *simple-area-gesture-table*) - -(add-gesture-command-to-table '(#\y :meta) - 'goatee-next - *simple-area-gesture-table*) + (climi::presentation-history-previous history accepting-type) + (when type + (clear-buffer *buffer*) + (insert-ptype-history object type)))))) + +(add-gesture-command-to-table '(#\p :meta) + 'cmd-history-yank-previous + *simple-area-gesture-table*) + +(add-gesture-command-to-table '(#\n :meta) + 'cmd-history-yank-next + *simple-area-gesture-table*) From thenriksen at common-lisp.net Sun Jan 7 19:48:16 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 7 Jan 2007 14:48:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070107194816.CFAC359088@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21022/Drei Modified Files: lisp-syntax-swank.lisp Log Message: Handle :not-available return value from `swank::arglist' (makes it work on CLISP). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/01/07 19:48:16 1.2 @@ -95,7 +95,9 @@ (defmethod arglist ((image swank-local-image) symbol) (declare (ignore image)) - (swank::arglist symbol)) + (let ((arglist (swank::arglist symbol))) + (unless (eq arglist :not-available) + arglist))) (defmethod simple-completions ((image swank-local-image) string default-package) (declare (ignore image)) From thenriksen at common-lisp.net Sun Jan 7 19:53:05 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 7 Jan 2007 14:53:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070107195305.8BF7D6800C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21388 Modified Files: panes.lisp Log Message: >From the spec: "Returns the viewport region of the CLIM stream pane window. If the window is not scrollable, and hence has no viewport, this will region [sic] `sheet-region' of window." --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/12/23 11:42:43 1.176 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/01/07 19:53:05 1.177 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.176 2006/12/23 11:42:43 ahefner Exp $ +;;; $Id: panes.lisp,v 1.177 2007/01/07 19:53:05 thenriksen Exp $ (in-package :clim-internals) @@ -2543,7 +2543,8 @@ (stream-replay pane)) (defmethod window-viewport ((pane clim-stream-pane)) - (pane-viewport-region pane)) + (or (pane-viewport-region pane) + (sheet-region pane))) (defmethod window-erase-viewport ((pane clim-stream-pane)) (with-bounding-rectangle* (x1 y1 x2 y2) (or (pane-viewport-region pane) From thenriksen at common-lisp.net Sun Jan 7 19:54:52 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 7 Jan 2007 14:54:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Scigraph/dwim Message-ID: <20070107195452.77C5C6800C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim In directory clnet:/tmp/cvs-serv21482/Apps/Scigraph/dwim Modified Files: load-dwim.lisp Log Message: Make sure the output directory exists before compiling. --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/load-dwim.lisp 2006/10/28 17:11:31 1.4 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/dwim/load-dwim.lisp 2007/01/07 19:54:52 1.5 @@ -119,6 +119,7 @@ (binary (make-pathname :defaults bin-dir :name name :type (file-type-for-binaries)))) + (ensure-directories-exist bin-dir) (when (or (not (probe-file binary)) (< (file-write-date binary) (file-write-date source))) (compile-file source :output-file binary)) From thenriksen at common-lisp.net Sun Jan 7 19:58:13 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 7 Jan 2007 14:58:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Scigraph/scigraph Message-ID: <20070107195813.455266B561@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph In directory clnet:/tmp/cvs-serv21709/Apps/Scigraph/scigraph Modified Files: demo-frame.lisp Log Message: >From graph-data.lisp: ; in clim, NIL == FILLED --- /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/demo-frame.lisp 2003/10/31 11:35:37 1.1 +++ /project/mcclim/cvsroot/mcclim/Apps/Scigraph/scigraph/demo-frame.lisp 2007/01/07 19:58:13 1.2 @@ -117,7 +117,7 @@ :color :salmon :symbologies (list :line-symbol) :data-symbol :circle - :pattern :filled + :pattern nil :equation '(* (sin (* a x)) (sin (* b x))) :variable 'x :min 0 :max 10 :increment .1 :parameters '((a 2) (b 3)))) From rgoldman at common-lisp.net Mon Jan 8 01:30:28 2007 From: rgoldman at common-lisp.net (rgoldman) Date: Sun, 7 Jan 2007 20:30:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Spec/src Message-ID: <20070108013028.80B025D009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Spec/src In directory clnet:/tmp/cvs-serv31520/src Modified Files: bboxes.tex bordered-output.tex clim.tex designs.tex drawing-options.tex graph-formatting.tex graphics.tex regions.tex table-formatting.tex Added Files: border-example.pdf bounding-box.pdf corner-circle.pdf correct-circle.pdf design-classes.pdf different-ellipses.pdf graph-example.pdf horizontal-lines.pdf inscribed-circle.pdf line-cap-shapes.pdf line-joint-shapes.pdf region-composition.pdf region-normalization.pdf region-structure.pdf table-example.pdf thick-lines.pdf thin-lines.pdf two-triangles.pdf Log Message: Absent any objections, I have modified the Spec LaTeX source so that it works with pdflatex as well as normal latex. In the process, I have added a number of pdf equivalents of epsi files, and changed clim.tex to use graphicx instead of epsfig. As a side-benefit, I tweaked the pdflatex so that hyperlinks are added. --- /project/mcclim/cvsroot/mcclim/Spec/src/bboxes.tex 2000/12/11 06:59:59 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/bboxes.tex 2007/01/08 01:30:25 1.2 @@ -34,7 +34,7 @@ \end{verbatim} \begin{figure} -\centerline{\epsfig{file=bounding-box.epsi}} +\centerline{\includegraphics{bounding-box}} \caption{\label{output-record-bbox} The bounding rectangle of an output record.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/bordered-output.tex 2000/12/11 06:59:59 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/bordered-output.tex 2007/01/08 01:30:25 1.2 @@ -25,7 +25,7 @@ \end{verbatim} \begin{figure} -\centerline{\epsfig{file=border-example.epsi}} +\centerline{\includegraphics{border-example}} \caption{\label{border-example} Examples of bordered output.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/clim.tex 2000/12/11 06:59:59 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/clim.tex 2007/01/08 01:30:25 1.2 @@ -4,7 +4,9 @@ % --SWM \pagestyle{headings} \usepackage{makeidx} -\usepackage{epsfig} +% replaced with using graphics package [2007/01/05:rpg] +%\usepackage{epsfig} +\usepackage{graphicx} \makeatletter \renewenvironment{theindex}% @@ -17,6 +19,22 @@ {\end{small}\clearpage} \makeatother +%% added to try to make nice bookmarks in PDF... [2005/04/12:rpg] +\ifx\pdfoutput\undefined \csname newcount\endcsname\pdfoutput \fi +\ifcase\pdfoutput \else +\usepackage[pdftex]{hyperref} +\fi + +%% added to try to make nice bookmarks in PDF... [2005/04/12:rpg] +\ifx\pdfoutput\undefined \csname newcount\endcsname\pdfoutput \fi +\ifcase\pdfoutput \DeclareGraphicsExtensions{.epsi}\DeclareGraphicsRule{epsi}{eps}{*}{} +\fi + +% \DeclareGraphicsExtensions{.pdf,.epsi} +% % \DeclareGraphicsRule{epsi}{eps}{*}{} + +% \DeclareGraphicsRule{epsi}{eps}{*}{} + %\usepackage{times} %% For PDF --- /project/mcclim/cvsroot/mcclim/Spec/src/designs.tex 2000/12/11 07:00:00 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/designs.tex 2007/01/08 01:30:25 1.2 @@ -216,7 +216,7 @@ each other. \begin{figure} -\centerline{\epsfig{file=design-classes.epsi}} +\centerline{\includegraphics{design-classes}} \caption{\label{design-classes} The class structure for all designs and regions. Entries in bold correspond to real CLIM classes.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/drawing-options.tex 2000/12/11 07:00:00 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/drawing-options.tex 2007/01/08 01:30:25 1.2 @@ -486,7 +486,7 @@ window system, so not all platforms will necessarily fully support it. \begin{figure} -\centerline{\epsfig{file=line-joint-shapes.epsi}} +\centerline{\includegraphics{line-joint-shapes}} \caption{Line joint shapes.} \end{figure} @@ -499,7 +499,7 @@ system, so not all platforms will necessarily fully support it. \begin{figure} -\centerline{\epsfig{file=line-cap-shapes.epsi}} +\centerline{\includegraphics{line-cap-shapes}} \caption{Line cap shapes.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/graph-formatting.tex 2000/12/11 07:00:00 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/graph-formatting.tex 2007/01/08 01:30:27 1.2 @@ -31,7 +31,7 @@ \end{verbatim} \begin{figure} -\centerline{\epsfig{file=graph-example.epsi}} +\centerline{\includegraphics{graph-example}} \caption{\label{graph-example} Example of graph formatting.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/graphics.tex 2000/12/11 07:00:00 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/graphics.tex 2007/01/08 01:30:27 1.2 @@ -231,7 +231,7 @@ implementations should attempt to draw in this case. \begin{figure} -\centerline{\epsfig{file=two-triangles.epsi}} +\centerline{\includegraphics{two-triangles}} \caption{\label{two-triangles} Pixel assignment with boundary on decision points.} \end{figure} @@ -247,7 +247,7 @@ pick only two of the four points, leading to an undesirable lopsided figure. \begin{figure} -\centerline{\epsfig{file=corner-circle.epsi}} +\centerline{\includegraphics{corner-circle}} \caption{\label{corner-circle} Choosing any two of the shaded pixels causes asymmetry.} \end{figure} @@ -265,7 +265,7 @@ \end{verbatim} \begin{figure} -\centerline{\epsfig{file=inscribed-circle.epsi}} +\centerline{\includegraphics{inscribed-circle}} \caption{\label{inscribed-circle} Two forms of a circle inscribed in a rectangle.} \end{figure} @@ -275,7 +275,7 @@ attempt to draw. \begin{figure} -\centerline{\epsfig{file=correct-circle.epsi}} +\centerline{\includegraphics{correct-circle}} \caption{\label{correct-circle} An aesthetically pleasing circle.} \end{figure} @@ -301,7 +301,7 @@ tilted rectangle, the left as the ``thinnest visible'' line. \begin{figure} -\centerline{\epsfig{file=thin-lines.epsi}} +\centerline{\includegraphics{thin-lines}} \caption{\label{thin-lines} Two examples of lines of thickness 1.} \end{figure} @@ -312,7 +312,7 @@ Figure~\ref{thick-lines} are both reasonable. \begin{figure} -\centerline{\epsfig{file=thick-lines.epsi}} +\centerline{\includegraphics{thick-lines}} \caption{\label{thick-lines} Two examples of lines of thickness 2.} \end{figure} @@ -326,7 +326,7 @@ simpler to draw rectilinear borders around rectilinear areas. \begin{figure} -\centerline{\epsfig{file=horizontal-lines.epsi}} +\centerline{\includegraphics{horizontal-lines}} \caption{\label{horizontal-lines} Two possible definitions of horizontal lines. Left figure is X11 definition.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/regions.tex 2000/12/11 07:00:00 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/regions.tex 2007/01/08 01:30:27 1.2 @@ -267,7 +267,7 @@ \begin{figure} -\centerline{\epsfig{file=region-normalization.epsi}} +\centerline{\includegraphics{region-normalization}} \caption{Normalization of rectangular region sets.} \end{figure} @@ -319,7 +319,7 @@ \begin{figure} -\centerline{\epsfig{file=region-composition.epsi}} +\centerline{\includegraphics{region-composition}} \caption{Examples of region union, intersection, and difference.} \end{figure} @@ -352,7 +352,7 @@ classes to a separately loadable module (via \cl{provide} and \cl{require}).} \begin{figure} -\centerline{\epsfig{file=region-structure.epsi}} +\centerline{\includegraphics{region-structure}} \caption{The class structure for all regions.} \end{figure} @@ -721,7 +721,7 @@ and correspond to the semi-axes of the ellipse. \begin{figure} -\centerline{\epsfig{file=different-ellipses.epsi}} +\centerline{\includegraphics{different-ellipses}} \caption{Different vectors may specify the same ellipse.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/table-formatting.tex 2000/12/11 07:00:00 1.1 +++ /project/mcclim/cvsroot/mcclim/Spec/src/table-formatting.tex 2007/01/08 01:30:27 1.2 @@ -29,7 +29,7 @@ \end{verbatim} \begin{figure} -\centerline{\epsfig{file=table-example.epsi}} +\centerline{\includegraphics{table-example}} \caption{\label{table-example} Example of tabular output.} \end{figure} --- /project/mcclim/cvsroot/mcclim/Spec/src/border-example.pdf 2007/01/08 01:30:28 NONE +++ /project/mcclim/cvsroot/mcclim/Spec/src/border-example.pdf 2007/01/08 01:30:28 1.1 %PDF-1.2 %???? 5 0 obj <> stream x??P?n?0??W??9???c??JQ?I?.?@?qb???.?R???????zvf|C?????p0?xz]A8? ???R8|1?tJ1G? S`?1U)?b> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 8 0 obj <> endobj 7 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000000553 00000 n 0000000692 00000 n 0000000494 00000 n 0000000353 00000 n 0000000015 00000 n 0000000334 00000 n 0000000630 00000 n 0000000601 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [(xQU?nS!CCn7u??|)(xQU?nS!CCn7u??|)] >> startxref 894 %%EOF --- /project/mcclim/cvsroot/mcclim/Spec/src/bounding-box.pdf 2007/01/08 01:30:28 NONE +++ /project/mcclim/cvsroot/mcclim/Spec/src/bounding-box.pdf 2007/01/08 01:30:28 1.1 %PDF-1.2 %???? 5 0 obj <> stream x??S?n?0 ??+xL?DJ??c v??[?C?8^??Y? ??~??d???: 6??'?|????#??g^???}??? |s;???c H?@?9y8????(R+3 ??J? Q?????? LL? ?K%?8??^&?bQ?r??IUP??[H?????P1P?cc1&??>[?2?5??)f??G?O?f??V??*??????????#??f??XUEK???????&???I?%"ny'L?p?tZ_???{Vh???nd?????/?[g????????o]???I??v???|???{?}???>?]?????1???#??[HA5$????????????:?>??a?/????s??,2?Q?? ?&?]?_OB????W????KQG??h?;??????@?n??????>GX???M????s????:??s???{???^????"$?????_`u?t`??????v???r??endstream endobj 6 0 obj 466 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 9 0 obj <> endobj 7 0 obj <> endobj 8 0 obj <> endobj 2 0 obj <>endobj xref 0 10 0000000000 65535 f 0000000770 00000 n 0000000988 00000 n 0000000711 00000 n 0000000570 00000 n 0000000015 00000 n 0000000551 00000 n 0000000856 00000 n 0000000918 00000 n 0000000818 00000 n trailer << /Size 10 /Root 1 0 R /Info 2 0 R /ID [(~k ?\)@?C??c`+,p)(~k ?\)@?C??c`+,p)] >> startxref 1186 %%EOF --- /project/mcclim/cvsroot/mcclim/Spec/src/corner-circle.pdf 2007/01/08 01:30:28 NONE +++ /project/mcclim/cvsroot/mcclim/Spec/src/corner-circle.pdf 2007/01/08 01:30:28 1.1 %PDF-1.2 %???? 5 0 obj <> stream x??????6F{=???????R;?7X?A?la7~}S?4?Q?? ??%???W???mv????o?&???????????????????L???p?4?yH? n??}\F?>??aL???1-C?n/?7]?wm???1Mc??? ??=??z??6rc??4?i??????? V?:?, Y?2b?}??U? ?}]G???!?CV~??4?4??0di???u???????????????|u?_?_?tz?:S\R??O??(3?)??V?O???7I?~???MH?dK?o$?r?]??V??????S?????????=?;???$X??j???8kB???$????0$?;I???D ??I??I??U?G?|'I>'?;???7?oo7Y?I?^?S???N?r????6???>????w???.?????R??e???.I??? C???5K??d??Y?f?}?Y??Y(?g????????/?G??o???;??IV ????}????g ????&?f????|%K?n&I???? ???8 ????e/+???JO?'??xB>???{?????xZ`YY???u?%?R?[R-u<??'? ?h|D???w?;???hQX?ee????TKoI???d|B??'???yo?G?????g?Ea??=?????V?L k??$pR?8?9??9?9?N6%?!&?l???v?V???^k?I???!p?s"8?s<8?s8?lJFCL??xM?????=??6??I?C?P?Dpb?xp|?8p:????? ??????????=??6??I?C?P?Dpb?xp|?8p:????? ????>??km3{z?m&??:????????????q?8t?) 1A?g?5??-????????N??:'?;???;??????d4?A????+???6????f8?s??N??[??_?????lJFCL???#???'?R?fendstream endobj 6 0 obj 1102 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 8 0 obj <> endobj 7 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000001407 00000 n 0000001546 00000 n 0000001348 00000 n 0000001207 00000 n 0000000015 00000 n 0000001187 00000 n 0000001484 00000 n 0000001455 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [(3ON\),????t?????)(3ON\),????t?????)] >> startxref 1746 %%EOF --- /project/mcclim/cvsroot/mcclim/Spec/src/correct-circle.pdf 2007/01/08 01:30:28 NONE +++ /project/mcclim/cvsroot/mcclim/Spec/src/correct-circle.pdf 2007/01/08 01:30:28 1.1 %PDF-1.2 %???? 5 0 obj <> stream x??????6 F?~ /?E???? t}{? M??w?l???e??dk5F?u???????-~v??????????????Vv???????????{7l?1MC:???e??{ ?????1?C:?hxv??:d???????1?cZ?t9?p?RN??]??q??v?4?yL??.'??W??]????????1?cZ??~???B_???,?v???!?CVF?~^yt)/?r^?n?4dy?????"\?a???u?_?????q???K?q??_??zS??sj??v?s???7??z4S????c!?b?sz??q{f?s'?=H"w??s?j??L??$??$v????!???!?9???|?Q^^??{rk.???D)??:????l?M??n?j???%i??Oa??w??f ??,t7K?,?? Kx1 ??Y??c??l??#? ????jC\??'Y-?z3???????????|3?d???%I7???!?}??+m????]x{???rQ>?h/???O????|4>"????;??Y? ?(,???\?}?&?R?GR-???O????|4>"????;??Y? ?(,???-i?=?R?GR-???O????|4>"????;??Y? ?(,???-i9T?j??a???N??:'?;???;??????d4?A?????6?j[?????N??:'?;???;??????d4?A?????^k[?????N??:'?;???;??????d4?A????{?????Z?J'u?C??????????q?dS2b? ??k?{?????Z?J'u?C??????????q?dS2b? ??kz????Vjz?m%??:????????????q?8t?) 1A?g?5? {?????Z?J'u?C??????????q?dS2b? ????o?o?u??endstream endobj 6 0 obj 1089 endobj 4 0 obj <> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 8 0 obj <> endobj 7 0 obj <> endobj 2 0 obj <>endobj xref 0 9 0000000000 65535 f 0000001394 00000 n 0000001533 00000 n 0000001335 00000 n 0000001194 00000 n 0000000015 00000 n 0000001174 00000 n 0000001471 00000 n 0000001442 00000 n trailer << /Size 9 /Root 1 0 R /Info 2 0 R /ID [(?2iB&??,?/X??')(?2iB&??,?/X??')] >> startxref 1735 %%EOF --- /project/mcclim/cvsroot/mcclim/Spec/src/design-classes.pdf 2007/01/08 01:30:28 NONE +++ /project/mcclim/cvsroot/mcclim/Spec/src/design-classes.pdf 2007/01/08 01:30:28 1.1 %PDF-1.2 %???? 5 0 obj <> stream x???K??0??? /???6~l+U?????? J<* ??? ?????*??|?{??? ????-?A????D0d??)5?J at h,%C SX ?Qv??????G?R?c ??%t?nm??LK?ae?nk?0?????c?\?????)q??????>|?????(????x??P?Z?h???l[Ta???7?????i?^?Mk (??fq??`[ ??2?N?E0Eo?????S&\?0?KS?Uem?Bc?r?SaZ?3UU^????$o ??Sjk?D}i???$?)?????????!!?:??%????????T ]?S?D?U7?b???3!j?r=???TSv5???4A?,?f4?H??????u??90h&?-J????]??X??L`o?Y?C???ZB?&4?> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 9 0 obj <> endobj 8 0 obj <> endobj 7 0 obj <> endobj 2 0 obj <>endobj xref 0 10 0000000000 65535 f 0000000964 00000 n 0000001179 00000 n 0000000905 00000 n 0000000764 00000 n 0000000015 00000 n 0000000745 00000 n 0000001112 00000 n 0000001050 00000 n 0000001012 00000 n trailer << /Size 10 /Root 1 0 R /Info 2 0 R /ID [(\r??>?!??g?/T5XfX)(\r??>?!??g?/T5XfX)] >> startxref 1381 %%EOF --- /project/mcclim/cvsroot/mcclim/Spec/src/different-ellipses.pdf 2007/01/08 01:30:28 NONE +++ /project/mcclim/cvsroot/mcclim/Spec/src/different-ellipses.pdf 2007/01/08 01:30:28 1.1 %PDF-1.2 %???? 5 0 obj <> stream x?m?Kn?0 D?>?N ?#R? ?r?&???U?R?=???"hvU????dL????{#H????? ?i???#d??m??b??r???8??g??1!?p4???P!SR?57J??? ?? a?a at d7p?x?a?:?X??y????%??2??L??l???c?/??kk???%???I!}n(??.m*??P*??O?V???V?????Dd????T)#???*??}?*????$?????b?6|??????]??G??? ??? ??/?0x??3-?i?L7?t????L7?t?L???n?iM'?k?4?0??8]?R` ?????????K??????)0?H/??z????????U^?U?)??!??,?vp_nK???D??>a?? ??? d?y?2/?y@? 9??1?? c????1_???2? ???? ????yY???7?0? ?>??|?? >7?1? ;??> /Contents 5 0 R >> endobj 3 0 obj << /Type /Pages /Kids [ 4 0 R ] /Count 1 >> endobj 1 0 obj <> endobj 2 0 obj <>endobj xref 0 7 0000000000 65535 f 0000000781 00000 n 0000000829 00000 n 0000000722 00000 n 0000000608 00000 n 0000000015 00000 n 0000000589 00000 n trailer << /Size 7 /Root 1 0 R /Info 2 0 R /ID [(h?9]?G\)[?4??\r)(h?9]?G\)[?4??\r)] >> startxref 1039 %%EOF --- /project/mcclim/cvsroot/mcclim/Spec/src/graph-example.pdf 2007/01/08 01:30:28 NONE +++ /project/mcclim/cvsroot/mcclim/Spec/src/graph-example.pdf 2007/01/08 01:30:28 1.1 %PDF-1.2 %???? 5 0 obj <> stream x?u???0 Dw?7??!qS')B,,-??"? e??q?e?}?.??2????!A>??.??#?y_???????W??F(??U3????"?1??l? T? a?@a2??? Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv16242 Modified Files: file-browser.lisp Log Message: This is a version of the file-browser example application that works, unlike the one that was previously available. Unfortunately, it doesn't work *well*, because McCLIM's support for AND and SATISFIES presentation-types is incomplete. I am unable to work on this more for the near future, so am committing the working-but-unsatisfactory version. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/file-browser.lisp 2006/01/30 16:14:01 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/file-browser.lisp 2007/01/09 00:11:39 1.2 @@ -2,6 +2,9 @@ (asdf:oos 'asdf:load-op :clim) (asdf:oos 'asdf:load-op :clim-clx)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (asdf:oos 'asdf:load-op :cl-fad)) + (in-package :clim-user) ; LTAG-start:file-browser-all @@ -18,6 +21,9 @@ file-browser interactor)))) +(define-presentation-type dir-pathname () + :inherit-from 'pathname) + (defmethod dirlist-display-files ((frame file-browser) pane) ;; Clear old displayed entries (clear-output-record (stream-output-history pane)) @@ -26,27 +32,39 @@ ;; Instead of write-string, we use present so that the link to ;; object file and the semantic information that file is ;; pathname is retained. - (present file 'pathname :stream pane) + (present file + (if (cl-fad:directory-pathname-p file) 'dir-pathname 'pathname) + :stream pane) (terpri pane))) (define-file-browser-command (com-edit-directory :name "Edit Directory") - ((dir 'pathname)) - (let ((dir (make-pathname :directory (pathname-directory dir) - :name :wild :type :wild :version :wild - :defaults dir))) + ((dir 'dir-pathname)) + ;; the following was a previous attempt to deal with the oddities of + ;; CL pathnames. Unfortunately, it does not work properly with all + ;; lisp implementations. Because of these oddities, we really need + ;; a layer like cl-fad to keep things straight. [2007/01/05:rpg] +;;; (let ((dir (make-pathname :directory (pathname-directory dir) +;;; :name :wild :type :wild :version :wild +;;; :defaults dir))) (setf (active-files *application-frame*) - (directory dir)))) + (cl-fad:list-directory dir))) (define-presentation-to-command-translator pathname-to-edit-command - (pathname ; source presentation-type + (dir-pathname ; source presentation-type com-edit-directory ; target-command file-browser ; command-table :gesture :select ; use this translator for pointer clicks :documentation "Edit this path") ; used in context menu (object) ; argument List - (list object)) ; arguments for target-command + (list object)) ; arguments for target-command + +(define-file-browser-command (com-quit :name t) () + (frame-exit *application-frame*) + ) (defmethod adopt-frame :after (frame-manager (frame file-browser)) + (declare (ignore frame-manager)) (execute-frame-command frame - `(com-edit-directory ,(make-pathname :directory '(:absolute))))) + `(com-edit-directory ,(make-pathname :directory '(:absolute))))) + ; LTAG-end \ No newline at end of file From rgoldman at common-lisp.net Tue Jan 9 03:28:19 2007 From: rgoldman at common-lisp.net (rgoldman) Date: Mon, 8 Jan 2007 22:28:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20070109032819.5B3C319001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv11339 Added Files: file-browser.lisp-type-abbrev Log Message: Alternative version of file-browser, more elegant, but relies on features not working yet in McCLIM. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/file-browser.lisp-type-abbrev 2007/01/09 03:28:19 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/file-browser.lisp-type-abbrev 2007/01/09 03:28:19 1.1 (eval-when (:compile-toplevel) (asdf:oos 'asdf:load-op :clim) (asdf:oos 'asdf:load-op :clim-clx)) (eval-when (:compile-toplevel :load-toplevel :execute) (asdf:oos 'asdf:load-op :cl-fad)) (in-package :clim-user) ; LTAG-start:file-browser-all (define-application-frame file-browser () ((active-files :initform nil :accessor active-files)) (:panes (file-browser :application :display-function '(dirlist-display-files) ;; Call the display-function whenever the command ;; loop makes a ``full-cycle'' :display-time :command-loop) (interactor :interactor)) (:layouts (default (vertically () file-browser interactor)))) (define-presentation-type-abbreviation dir-pathname () '((and pathname (satisfies cl-fad:directory-pathname-p)) :description "Directory")) (defmethod dirlist-display-files ((frame file-browser) pane) ;; Clear old displayed entries (clear-output-record (stream-output-history pane)) (dolist (file (active-files frame)) ;; Instead of write-string, we use present so that the link to ;; object file and the semantic information that file is ;; pathname is retained. (present file 'pathname ;; (if (cl-fad:directory-pathname-p file) 'dir-pathname 'pathname) :stream pane) (terpri pane))) ;;; shouldn't this bletch if it is given an argument that is a ;;; well-formed directory name, but for a directory that doesn't ;;; exist? cl-fad:directory-exists-p is relevant ;;; here... [2007/01/07:rpg] (define-file-browser-command (com-edit-directory :name "Edit Directory") ((dir 'dir-pathname)) ;; the following was a previous attempt to deal with the oddities of ;; CL pathnames. Unfortunately, it does not work properly with all ;; lisp implementations. Because of these oddities, we really need ;; a layer like cl-fad to keep things straight. [2007/01/05:rpg] ;;; (let ((dir (make-pathname :directory (pathname-directory dir) ;;; :name :wild :type :wild :version :wild ;;; :defaults dir))) (setf (active-files *application-frame*) (cl-fad:list-directory dir))) (define-presentation-to-command-translator pathname-to-edit-command ((and pathname (satisfies cl-fad:directory-pathname-p)) ; source presentation-type com-edit-directory ; target-command file-browser ; command-table :gesture :select ; use this translator for pointer clicks :documentation "Edit this path") ; used in context menu (object) ; argument List (list object)) ; arguments for target-command (define-file-browser-command (com-quit :name t) () (frame-exit *application-frame*) ) (defmethod adopt-frame :after (frame-manager (frame file-browser)) (declare (ignore frame-manager)) (execute-frame-command frame `(com-edit-directory ,(make-pathname :directory '(:absolute))))) ; LTAG-end From rgoldman at common-lisp.net Tue Jan 9 03:39:09 2007 From: rgoldman at common-lisp.net (rgoldman) Date: Mon, 8 Jan 2007 22:39:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070109033909.5F1532806A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12180 Modified Files: presentation-defs.lisp Log Message: A partial fix to add support for AND and SATISFIES in presentation-subtypep, where they were previously not supported. Christophe has a better one to replace this with soon. Also added an accept method for AND types. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/06 12:50:38 1.66 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/09 03:39:09 1.67 @@ -172,6 +172,21 @@ when (presentation-subtypep type or-type) do (return-from presentation-subtypep (values t t)) finally (return-from presentation-subtypep (values nil t)))) + (when (eq super-name 'satisfies) + (return-from presentation-subtypep (values nil nil))) + (with-presentation-type-decoded (sub-name sub-parameters) + type + (when (eq sub-name 'and) + (loop for and-type in sub-parameters + with subtypep and knownp + with answer-knownp = t + do (multiple-value-setq (subtypep knownp) + (presentation-subtypep and-type maybe-supertype)) + if subtypep + do (return-from presentation-subtypep (values t t)) + else ; track whether we know the answer + do (setf answer-knownp (and answer-knownp knownp)) + finally (return-from presentation-subtypep (values nil answer-knownp))))) (map-over-presentation-type-supertypes #'(lambda (name massaged) (when (eq name super-name) @@ -1526,10 +1541,17 @@ ;; XXX: We can only visually represent the pathname if it has a name ;; - making it wild is a compromise. If the pathname is completely ;; blank, we leave it as-is, though. + + ;; The above comment was meant to indicate that if the pathname had + ;; neither a name NOR a directory, then it couldn't be visually + ;; represented. Some discussion has ensued on the possbility of + ;; emitting something like "A pathname of type " + ;; [2007/01/08:rpg] (let ((pathname (if (equal object #.(make-pathname)) object (merge-pathnames object (make-pathname :name :wild))))) - (princ pathname stream))) + (princ object stream)) + ) (define-presentation-method present ((object string) (type pathname) stream (view textual-view) @@ -2150,6 +2172,19 @@ :acceptably acceptably :for-context-type for-context-type)) +(define-presentation-method accept ((type and) + (stream input-editing-stream) + (view textual-view) + &key) + (let* ((subtype (first types)) + (value (accept subtype + :stream stream + :view view + :prompt nil))) + (unless (presentation-typep value type) + (simple-parse-error "Input type is not of type ~S" type)) + value)) + (define-presentation-type-abbreviation token-or-type (tokens type) `(or (member-alist ,tokens) ,type)) From crhodes at common-lisp.net Wed Jan 10 11:19:01 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 Jan 2007 06:19:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070110111901.AA00383070@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25795 Modified Files: builtin-commands.lisp presentations.lisp presentation-defs.lisp Log Message: Mostly fix AND and OR presentation types in STUPID-SUBTYPEP (used for translator applicability) and PRESENTATION-SUBTYPEP. Add some tests for predefined presentation types. --- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2006/11/08 01:18:22 1.25 +++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2007/01/10 11:19:01 1.26 @@ -93,9 +93,15 @@ (t nil global-command-table :gesture :select :tester ((presentation context-type) - (presentation-subtypep (presentation-type presentation) - context-type)) - :tester-definitive t + ;; see the comments around DEFUN PRESENTATION-SUBTYPEP + ;; for some of the logic behind this. Only when + ;; PRESENTATION-SUBTYPEP is unsure do we test the object + ;; itself for PRESENTATION-TYPEP. + (multiple-value-bind (yp sp) + (presentation-subtypep (presentation-type presentation) + context-type) + (or yp (not sp)))) + :tester-definitive nil :menu nil :documentation ((object presentation context-type frame event window x y stream) (let* ((type (presentation-type presentation)) @@ -116,6 +122,10 @@ :stream stream :sensitive nil))))) (object presentation) + ;; returning (PRESENTATION-TYPE PRESENTATION) as the ptype is + ;; formally undefined, as this means that the translator returns a + ;; presentation type which is not PRESENTATION-SUBTYPEP the + ;; translator's TO-TYPE. (values object (presentation-type presentation))) (define-presentation-action presentation-menu --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2006/12/13 19:35:01 1.78 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/01/10 11:19:01 1.79 @@ -1419,30 +1419,50 @@ (eq super-meta *standard-object-class*)))) do (funcall function super-meta)))) +;;; This is to implement the requirement on presentation translators +;;; for doing subtype calculations without reference to type +;;; parameters. We are generous in that we return T when we are +;;; unsure, to give translator testers a chance to accept or reject +;;; the translator. This is essentially +;;; (multiple-value-bind (yesp surep) +;;; (presentation-subtypep maybe-subtype type) +;;; (or yesp (not surep))) +;;; except faster. (defun stupid-subtypep (maybe-subtype type) "Return t if maybe-subtype is a presentation subtype of type, regardless of parameters." - (when (or (eq maybe-subtype nil) - (eq type t) - (equal maybe-subtype type)) + (when (or (eq maybe-subtype nil) (eq type t)) + (return-from stupid-subtypep t)) + (when (eql maybe-subtype type) (return-from stupid-subtypep t)) (let ((maybe-subtype-name (presentation-type-name maybe-subtype)) (type-name (presentation-type-name type))) - (when (eq type-name 'or) - (loop for or-type in (decode-parameters type) - when (stupid-subtypep maybe-subtype or-type) - do (return-from stupid-subtypep t) - finally (return-from stupid-subtypep nil))) - (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name)) - (type-meta (get-ptype-metaclass type-name))) - (unless (and subtype-meta type-meta) - (return-from stupid-subtypep nil)) - (map-over-ptype-superclasses #'(lambda (super) - (when (eq type-meta super) - (return-from stupid-subtypep t))) - maybe-subtype-name) - nil))) - + (cond + ;; see DEFUN PRESENTATION-SUBTYPEP for some caveats + ((eq maybe-subtype-name 'or) + (let ((or-types (decode-parameters maybe-subtype))) + (every (lambda (x) (stupid-subtypep x type)) or-types))) + ((eq type-name 'and) + (stupid-subtypep maybe-subtype (car (decode-parameters type)))) + ((eq type-name 'or) + (let ((or-types (decode-parameters type))) + (some (lambda (x) (stupid-subtypep maybe-subtype x)) or-types))) + ((eq maybe-subtype-name 'and) + ;; this clause is actually not conservative, but probably in a + ;; way that no-one will complain about too much. Basically, we + ;; will only return T if the first type in the AND (which is + ;; treated specially by CLIM) is subtypep the maybe-supertype + (stupid-subtypep (car (decode-parameters maybe-subtype)) type)) + (t + (let ((subtype-meta (get-ptype-metaclass maybe-subtype-name)) + (type-meta (get-ptype-metaclass type-name))) + (unless (and subtype-meta type-meta) + (return-from stupid-subtypep nil)) + (map-over-ptype-superclasses #'(lambda (super) + (when (eq type-meta super) + (return-from stupid-subtypep t))) + maybe-subtype-name) + nil))))) (defun find-presentation-translators (from-type to-type command-table) (let* ((command-table (find-command-table command-table)) --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/09 03:39:09 1.67 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/10 11:19:01 1.68 @@ -162,31 +162,126 @@ (block presentation-subtypep , at body)))))))) +;;; PRESENTATION-SUBTYPEP suffers from some of the same problems as +;;; CL:SUBTYPEP, most (but sadly not all) of which were solved in +;;; H. Baker "A Decision Procedure for SUBTYPEP"; additionally, it +;;; suffers from the behaviour being underspecified, as CLIM +;;; documentation did not have the years of polish that CLtS did. +;;; +;;; So you might wonder why, instead of copying or using directly some +;;; decent Public Domain subtype code (such as that found in SBCL, +;;; implementing CL:SUBTYPEP), there's this slightly wonky +;;; implementation here. Well, some of the answer lies in the fact +;;; that the subtype relationships answered by this predicate are not +;;; in fact analogous to CL's type system. The major use of +;;; PRESENTATION-SUBTYPEP seems to be for determining whether a +;;; presentation is applicable as input to a translator (including the +;;; default translator, transforming an object to itself); actually, +;;; the first step is taken by STUPID-SUBTYPEP, but that I believe is +;;; simply intended to be a short-circuiting conservative version of +;;; PRESENTATION-SUBTYPEP. +;;; +;;; Most presentation types in CLIM are hierarchically arranged by +;;; single-inheritance, and SUBTYPEP relations on the hierarchy are +;;; easy to determine: simply walk up the hierarchy until you find the +;;; putative supertype (in which case the answer is T, T unless the +;;; type's parameters are wrong) or you find the universal supertype +;;; (in which case the answer is NIL, T. There are numerous wrinkles, +;;; however... +;;; +;;; (1) the NIL presentation type is the universal subtype, breaking +;;; the single-inheritance of the hierarchy. This isn't too bad, +;;; because it can be special-cased. +;;; +;;; (2) union types can be constructed, destroying the +;;; single-inheritance hierarchy (when used as a subtype). +;;; +;;; (3) union types can give rise to ambiguity. For example, is the +;;; NUMBER presentation type subtypep (OR REAL COMPLEX)? What +;;; about (INTEGER 3 6) subtypep (OR (INTEGER 3 4) (INTEGER 5 6))? +;;; Is (OR A B) subtypep (OR B A)? The answer to this last +;;; question is not obvious, as the two types have different +;;; ACCEPT behaviour if A and B have any Lisp objects in common, +;;; even if the presentation types are hierarchically unrelated... +;;; +;;; (4) intersection types can be constructed, destroying the +;;; single-inheritance hierarchy (when used as a supertype). This +;;; is partially mitigated by the explicit documentation that the +;;; first type in the AND type's parameters is privileged and +;;; treated specially by ACCEPT. +;;; +;;; Given these difficulties, I'm aiming for roughly expected +;;; behaviour from STUPID- and PRESENTATION-SUBTYPEP, rather than +;;; something which has a comprehensive understanding of presentation +;;; types and the Lisp object universe (as this would be unachievable +;;; anyway: the user can write arbitrary PRESENTATION-TYPEP +;;; functions); PRESENTATION-SUBTYPEP should not be thought of as a +;;; predicate over sets of Lisp objects, but simply a formal predicate +;;; over a graph of names. This gives rise to the implementation +;;; below for OR and AND types, and the hierarchical walk for all +;;; other types. CSR, 2007-01-10 (defun presentation-subtypep (type maybe-supertype) - (when (equal type maybe-supertype) + ;; special shortcuts: the universal subtype is privileged (and + ;; doesn't in fact fit into a hierarchical lattice); the universal + ;; supertype is easy to identify. + (when (or (eql type nil) (eql maybe-supertype t)) + (return-from presentation-subtypep (values t t))) + (when (eql type maybe-supertype) (return-from presentation-subtypep (values t t))) (with-presentation-type-decoded (super-name super-parameters) - maybe-supertype - (when (eq super-name 'or) - (loop for or-type in super-parameters - when (presentation-subtypep type or-type) - do (return-from presentation-subtypep (values t t)) - finally (return-from presentation-subtypep (values nil t)))) - (when (eq super-name 'satisfies) - (return-from presentation-subtypep (values nil nil))) - (with-presentation-type-decoded (sub-name sub-parameters) - type - (when (eq sub-name 'and) - (loop for and-type in sub-parameters - with subtypep and knownp - with answer-knownp = t - do (multiple-value-setq (subtypep knownp) - (presentation-subtypep and-type maybe-supertype)) - if subtypep - do (return-from presentation-subtypep (values t t)) - else ; track whether we know the answer - do (setf answer-knownp (and answer-knownp knownp)) - finally (return-from presentation-subtypep (values nil answer-knownp))))) + maybe-supertype + (with-presentation-type-decoded (type-name type-parameters) + type + (cond + ;; DO NOT BE TEMPTED TO REARRANGE THESE CLAUSES + ((eq type-name 'or) + (dolist (or-type type-parameters + (return-from presentation-subtypep (values t t))) + (multiple-value-bind (yesp surep) + (presentation-subtypep or-type maybe-supertype) + (unless yesp + (return-from presentation-subtypep (values yesp surep)))))) + ((eq super-name 'and) + (let ((result t)) + (dolist (and-type super-parameters + (return-from presentation-subtypep (values result result))) + (cond + ((and (consp and-type) (eq (car and-type) 'satisfies)) + (setq result nil)) + ((and (consp and-type) (eq (car and-type) 'not)) + (multiple-value-bind (yp sp) + (presentation-subtypep type (cadr and-type)) + (if yp + (return-from presentation-subtypep (values nil t)) + (setq result nil)))) + (t (multiple-value-bind (yp sp) + (presentation-subtypep type and-type) + (unless yp + (if sp + (return-from presentation-subtypep (values nil t)) + (setq result nil))))))))) + ((eq super-name 'or) + (assert (not (eq type-name 'or))) + ;; FIXME: this would be the right method were it not for the + ;; fact that there can be unions 'in disguise' in the + ;; subtype; examples: + ;; (PRESENTATION-SUBTYPEP 'NUMBER '(OR REAL COMPLEX)) + ;; (PRESENTATION-SUBTYPEP '(INTEGER 3 6) + ;; '(OR (INTEGER 2 5) (INTEGER 4 7))) + ;; Sorry about that. + (let ((surep t)) + (dolist (or-type super-parameters + (return-from presentation-subtypep (values nil surep))) + (multiple-value-bind (yp sp) + (presentation-subtypep type or-type) + (cond + (yp (return-from presentation-subtypep (values t t))) + ((not sp) (setq surep nil))))))) + ((eq type-name 'and) + (assert (not (eq super-name 'and))) + (multiple-value-bind (yp sp) + (presentation-subtypep (car type-parameters) maybe-supertype) + (return-from presentation-subtypep (values yp yp)))))) (map-over-presentation-type-supertypes #'(lambda (name massaged) (when (eq name super-name) @@ -2172,18 +2267,14 @@ :acceptably acceptably :for-context-type for-context-type)) -(define-presentation-method accept ((type and) - (stream input-editing-stream) - (view textual-view) - &key) - (let* ((subtype (first types)) - (value (accept subtype - :stream stream - :view view - :prompt nil))) - (unless (presentation-typep value type) - (simple-parse-error "Input type is not of type ~S" type)) - value)) +(define-presentation-method accept + ((type and) (stream input-editing-stream) (view textual-view) &rest args &key) + (let ((subtype (first types))) + (multiple-value-bind (obj ptype) + (apply-presentation-generic-function accept subtype stream view args) + (unless (presentation-typep obj type) + (simple-parse-error "Input object ~S is not of type ~S" obj type)) + obj))) (define-presentation-type-abbreviation token-or-type (tokens type) `(or (member-alist ,tokens) ,type)) From crhodes at common-lisp.net Wed Jan 10 11:19:01 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 10 Jan 2007 06:19:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Tests Message-ID: <20070110111901.E033B83071@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Tests In directory clnet:/tmp/cvs-serv25795/Tests Added Files: presentation-types.lisp Log Message: Mostly fix AND and OR presentation types in STUPID-SUBTYPEP (used for translator applicability) and PRESENTATION-SUBTYPEP. Add some tests for predefined presentation types. --- /project/mcclim/cvsroot/mcclim/Tests/presentation-types.lisp 2007/01/10 11:19:01 NONE +++ /project/mcclim/cvsroot/mcclim/Tests/presentation-types.lisp 2007/01/10 11:19:01 1.1 (in-package :clim-tests) (defparameter *presentation-type-supertypes* '(;; 23.8.1 (t) ;; NIL is a special case (null t) (boolean t) (symbol t) (keyword symbol t) (blank-area t) ;; 23.8.2 (number t) (complex number t) (real number t) (rational real number t) (integer rational real number t) (ratio rational real number t) (float real number t) ;; 23.8.3 (character t) (string t) ;; 23.8.4 (pathname t) ;; 23.8.5 ((completion nil) t) ;; not allowed abbreviations ;; (member t) ((member-sequence nil) t) ((member-alist nil) t) ((subset-completion nil) t) ;; (subset t) ((subset-sequence nil) t) ((subset-alist nil) t) ;; 23.8.6 ((sequence t) t) (sequence-enumerated t) ;; 23.8.7 ;; OR, AND ;; 23.8.8 ;; ((token-or-type nil t) t) ((null-or-type t) t) ((type-or-string t) t) ;; 23.8.9 (expression t) (form expression t))) (defun expect-t-t (type supertype) (multiple-value-bind (yesp surep) (presentation-subtypep type supertype) (assert yesp) (assert surep)) #+mcclim ;; we can do this because *presentation-type-supertypes* doesn't do ;; clever things with type parameters (assert (climi::stupid-subtypep type supertype))) (defun expect-nil-t (type supertype) (multiple-value-bind (yesp surep) (presentation-subtypep type supertype) (assert (not yesp)) (assert surep)) #+mcclim (assert (not (climi::stupid-subtypep type supertype)))) (defun expect-nil-nil (type supertype) (multiple-value-bind (yesp surep) (presentation-subtypep type supertype) (assert (not yesp)) (assert (not surep))) ;; stupid-subtypep must be conservative in what it reports as ;; possibly acceptable. #+mcclim (assert (climi::stupid-subtypep type supertype))) (loop for (type . supertypes) in *presentation-type-supertypes* do (expect-t-t type type) do (expect-t-t nil type) ;; if presentation types were "real" (FIXME: work out what ;; "real" means) types, then this wouldn't actually be true. ;; However, PRESENTATION-SUBTYPEP works by walking up the type ;; lattice until it finds a match, and only then checks the type ;; parameters. So even though presentation types (or ;; abbreviations) like (MEMBER) actually denote the empty set, ;; they are not PRESENTATION-SUBTYPEP NIL. do (expect-nil-t type nil) do (mapcar (lambda (x) (expect-t-t type x)) supertypes)) (loop for (type) in *presentation-type-supertypes* do (expect-t-t type `(and ,type)) do (expect-t-t `(and ,type) type) do (expect-t-t `(and ,type) `(and ,type)) do (expect-t-t type `(or ,type)) do (expect-t-t `(or ,type) type) do (expect-t-t `(or ,type) `(or ,type)) do (expect-t-t `(or ,type) `(and ,type)) do (expect-t-t `(and ,type) `(or ,type))) (defun constantly-t (object) (declare (ignore object)) t) (loop for (type) in *presentation-type-supertypes* do (expect-t-t `(and ,type (satisfies constantly-t)) type) do (expect-nil-nil type `(and ,type (satisfies constantly-t))) do (expect-t-t `(and ,type (not nil)) type) do (expect-nil-nil type `(and ,type (not nil)))) (expect-t-t '(or integer symbol) '(or integer symbol)) (expect-t-t '(or integer symbol) '(or symbol integer)) (expect-t-t '(or real complex) 'number) #+nil (expect-t-t 'number '(or real complex)) From thenriksen at common-lisp.net Wed Jan 10 20:54:13 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 10 Jan 2007 15:54:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070110205413.9B9503F00E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21474 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: Removed `unknown-symbol' presentation type. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/03 13:08:04 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/10 20:54:13 1.16 @@ -1848,36 +1848,25 @@ (with-face (:error) (call-next-method))) -(define-presentation-type unknown-symbol () :inherit-from 'symbol - :description "unknown symbol") - -(define-presentation-method presentation-typep (object (type unknown-symbol)) - (or (symbolp object) (stringp object))) - (defmethod display-parse-tree ((parse-symbol token-mixin) stream (drei drei) (syntax lisp-syntax)) (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol))) - (let ((string (form-string syntax parse-symbol))) - (multiple-value-bind (symbol status) - (form-to-object syntax parse-symbol :no-error t) - (with-output-as-presentation - (stream (if status symbol string) - (if status 'symbol 'unknown-symbol) - :single-box :highlighting) - (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) - (with-face (:keyword) - (call-next-method))) - ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) - (with-face (:lambda-list-keyword) - (call-next-method))) - ((and (macro-function symbol) - (form-operator-p parse-symbol syntax)) - (with-face (:macro) - (call-next-method))) - ((and (special-operator-p symbol) - (form-operator-p parse-symbol syntax)) - (with-face (:special-form) - (call-next-method))) - (t (call-next-method)))))) + (let ((symbol (form-to-object syntax parse-symbol :no-error t))) + (with-output-as-presentation (stream symbol 'symbol :single-box :highlighting) + (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) + (with-face (:keyword) + (call-next-method))) + ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) + (with-face (:lambda-list-keyword) + (call-next-method))) + ((and (macro-function symbol) + (form-operator-p parse-symbol syntax)) + (with-face (:macro) + (call-next-method))) + ((and (special-operator-p symbol) + (form-operator-p parse-symbol syntax)) + (with-face (:special-form) + (call-next-method))) + (t (call-next-method))))) (call-next-method))) (defmethod display-parse-tree ((parser-symbol literal-object-form) stream (drei drei) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/12/10 19:28:49 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/01/10 20:54:13 1.5 @@ -165,9 +165,6 @@ (define-presentation-to-command-translator lookup-symbol-arglist (symbol com-lookup-arglist lisp-table :gesture :describe - :tester ((object presentation) - (declare (ignore object)) - (not (eq (presentation-type presentation) 'unknown-symbol))) :documentation "Lookup arglist") (object) (list object)) From crhodes at common-lisp.net Thu Jan 11 10:56:40 2007 From: crhodes at common-lisp.net (crhodes) Date: Thu, 11 Jan 2007 05:56:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070111105640.482C63C007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27524 Modified Files: NEWS Log Message: Tell the world about my SUBTYPEP sk1llz --- /project/mcclim/cvsroot/mcclim/NEWS 2006/12/26 16:44:45 1.17 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/01/11 10:56:39 1.18 @@ -28,6 +28,8 @@ Text Styles" in the manual. ** Improvement: Added support for bezier splines (Robert Strandh). To be documented. +** better PRESENTATION-SUBTYPEP (more likely to give the right answer + on some-of and all-of presentation types) * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From thenriksen at common-lisp.net Sat Jan 13 21:09:52 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 13 Jan 2007 16:09:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070113210952.5575E1E00B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8180 Modified Files: input-editor.lisp Log Message: Redraw the input buffer after setting syntax, fixes some display issues when using `presentation-replace-input' (for example, when using the history). --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/01/04 23:15:48 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/01/13 21:09:51 1.16 @@ -791,6 +791,7 @@ (with-drei-options ((drei-instance stream) :syntax "Lisp" :keep-syntax t) + (redraw-input-buffer stream) (call-next-method))) (define-presentation-method accept ((type expression) From thenriksen at common-lisp.net Sun Jan 14 07:59:03 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 02:59:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070114075903.73A19690DD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10650 Modified Files: NEWS Log Message: Mention the presentation history navigation gestures. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/01/11 10:56:39 1.18 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/01/14 07:59:03 1.19 @@ -30,6 +30,7 @@ To be documented. ** better PRESENTATION-SUBTYPEP (more likely to give the right answer on some-of and all-of presentation types) +** Improvement: M-n/M-p gestures for navigating presentation histories. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From thenriksen at common-lisp.net Sun Jan 14 08:22:28 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 03:22:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070114082228.23A1330D3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15574/Drei Modified Files: drei.lisp Log Message: Update the syntax if it is changed by `with-drei-options'. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/12/09 23:55:39 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/01/14 08:22:27 1.13 @@ -855,16 +855,18 @@ (when syntax-provided-p (push (list (unless keep-syntax `(old-syntax (syntax (buffer ,drei)))) - `(setf (syntax (buffer ,drei)) - (etypecase ,syntax - (string (make-instance (or (syntax-from-name ,syntax) - (error "No such syntax: ~A" ,syntax)) - :buffer (buffer ,drei))) - (symbol (make-instance ,syntax - :buffer (buffer ,drei))) - (syntax ,syntax))) + `(progn (setf (syntax (buffer ,drei)) + (etypecase ,syntax + (string (make-instance (or (syntax-from-name ,syntax) + (error "No such syntax: ~A" ,syntax)) + :buffer (buffer ,drei))) + (symbol (make-instance ,syntax + :buffer (buffer ,drei))) + (syntax ,syntax))) + (update-syntax (buffer ,drei) (syntax (buffer ,drei)))) (unless keep-syntax - `(setf (syntax (buffer ,drei)) old-syntax))) + `(progn (setf (syntax (buffer ,drei)) old-syntax) + (update-syntax (buffer ,drei) (syntax (buffer ,drei)))))) triple-list)) `(progn (check-type ,drei drei) From thenriksen at common-lisp.net Sun Jan 14 08:38:34 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 03:38:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070114083834.35BCF39085@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv17049/Doc Modified Files: drei.texi Log Message: Fixed some typos. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/01/06 05:00:17 1.5 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/01/14 08:38:33 1.6 @@ -9,7 +9,7 @@ Drei - an acronym for @i{Drei Replaces EINE's Inheritor} - is one of the editor substrates provided by McCLIM. Drei is activated by default, but -if it gives you problem, you can disable it by evaluating @code{(setf +if it gives you problems, you can disable it by evaluating @code{(setf clim-internals::*use-goatee* t)}. @menu @@ -29,7 +29,7 @@ expose. Drei has to work as, at least, an input-editor, a text editor gadget and a simple pane. These three different uses have widely different semantics for reading input and performing redisplay - from -passively being fed gestures in the input editor, to having to event +passively being fed gestures in the input editor, to having to do event handling and redisplay timing manually in the gadget version. Furthermore, Drei is extensible software, so we wished to make the differences between these three modus operandorum transparent to the From thenriksen at common-lisp.net Sun Jan 14 08:41:58 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 03:41:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070114084158.441EE3908C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv18914/Doc Modified Files: DOCBUILDING Log Message: We do not use --no-userinit anymore. --- /project/mcclim/cvsroot/mcclim/Doc/DOCBUILDING 2006/12/21 12:22:03 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/DOCBUILDING 2007/01/14 08:41:58 1.2 @@ -20,8 +20,8 @@ You can also use the SBCL_SYSTEM environment variable to change which SBCL is used. Please note that SBCL will be run without evaluating the -user- or system-initialization-file (--no-sysinit --no-userinit). If -this does not work for you, edit make-tempfiles.sh +system-initialization-file (--no-sysinit). If this does not work for +you, edit make-tempfiles.sh The Makefile will have to reload McCLIM from scratch every time it regerenes the docstrings. If you are working on McCLIM, this is rather From thenriksen at common-lisp.net Sun Jan 14 14:10:00 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 09:10:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070114141000.7C16B48000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14299 Modified Files: mcclim.asd Log Message: Make mcclim.asd work better with OpenMCL and CLISP. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/07 19:32:28 1.48 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/14 14:10:00 1.49 @@ -44,12 +44,12 @@ (defun dep-on-swank () (if (and (find-swank-system) (not (find-package :swank))) - '(and) - '(or))) + '(:and) + '(:or))) (defun ifswank () (if (find-swank) - '(and) - '(or)))) + '(:and) + '(:or)))) ;;; Legacy CMUCL support stuff #+cmu @@ -310,7 +310,7 @@ (:file "misc-commands" :depends-on ("basic-commands")) (:file "unicode-commands" :depends-on ("core" "drei-clim")) (:file "search-commands" :depends-on ("core" "drei-clim")) - (:file "lisp-syntax" :depends-on ("core" "motion" "fundamental-syntax")) + (:file "lisp-syntax" :depends-on ("motion" "fundamental-syntax")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) #+#.(mcclim.system::ifswank) (:file "lisp-syntax-swank" :depends-on ("lisp-syntax")))))) @@ -349,7 +349,8 @@ (:file "input-editing-goatee") (:file "input-editing-drei") (:file "text-editor-gadget") - (:file "Extensions/rgb-image"))) + (:file "Extensions/rgb-image" :pathname #.(make-pathname :directory '(:relative "Extensions") + :name "rgb-image")))) (defsystem :clim-clx :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) From thenriksen at common-lisp.net Sun Jan 14 14:53:57 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 09:53:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20070114145357.CC8E03F00D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv22114/Apps/Listener Modified Files: listener.lisp Log Message: Added hack to make Listener run in CLISP. We need something like CL-FAD to make it be really good. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/01/04 09:20:58 1.32 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2007/01/14 14:53:54 1.33 @@ -96,7 +96,11 @@ (with-output-as-presentation (t *package* 'listener-current-package) (print-package-name t))) (cell (:center) - (when (probe-file *default-pathname-defaults*) + ;; CLISP gives us an error when calling + ;; `cl:probe-file' with a directory argument. + (when #+clisp (or (ignore-errors (ext:probe-directory *default-pathname-defaults*)) + (ignore-errors (probe-file *default-pathname-defaults*))) + #-clisp (probe-file *default-pathname-defaults*) (with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) (format t "~A" (frob-pathname *default-pathname-defaults*)))) (when *directory-stack* From afuchs at common-lisp.net Sun Jan 14 15:32:53 2007 From: afuchs at common-lisp.net (afuchs) Date: Sun, 14 Jan 2007 10:32:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070114153253.5C73A3C00B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv29791 Modified Files: mcclim.asd Log Message: Re-add the dependency on core.lisp in mcclim.asd --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/14 14:10:00 1.49 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/14 15:32:53 1.50 @@ -289,7 +289,7 @@ "delegating-buffer" "undo" "motion" "editing")) (:file "drei-clim" :depends-on ("drei")) (:file "drei-redisplay" :depends-on ("drei-clim")) - (:file "input-editor" :depends-on ("drei-redisplay" "lisp-syntax")) + (:file "input-editor" :depends-on ("drei-redisplay" "lisp-syntax" "core")) (:file "fundamental-syntax" :depends-on ("packages" "drei-redisplay")) (:file "abbrev" :depends-on ("packages")) (:file "kill-ring" :depends-on ("packages")) @@ -310,7 +310,7 @@ (:file "misc-commands" :depends-on ("basic-commands")) (:file "unicode-commands" :depends-on ("core" "drei-clim")) (:file "search-commands" :depends-on ("core" "drei-clim")) - (:file "lisp-syntax" :depends-on ("motion" "fundamental-syntax")) + (:file "lisp-syntax" :depends-on ("motion" "fundamental-syntax" "core")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) #+#.(mcclim.system::ifswank) (:file "lisp-syntax-swank" :depends-on ("lisp-syntax")))))) From thenriksen at common-lisp.net Sun Jan 14 17:33:51 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 12:33:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/cl-automaton Message-ID: <20070114173351.A07EE1900A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv24917/Drei/cl-automaton Modified Files: automaton.lisp eqv-hash.lisp state-and-transition.lisp Log Message: Make cl-automaton (the regexp part of Drei) work in CLISP. This was done by fixing non-conformant loops that SBCL happens to handle. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2007/01/14 17:33:51 1.2 @@ -83,20 +83,21 @@ (worklist nil)) (setf (gethash (initial a) visited) t) (push (initial a) worklist) - (loop while worklist - for s = (pop worklist) do - (with-ht (tr nil) (transitions s) - (let ((s2 (to tr))) - (unless (gethash s2 visited) - (setf (gethash s2 visited) t) - (push s2 worklist))))) + (loop for s = (first worklist) + while worklist do + (pop worklist) + (with-ht (tr nil) (transitions s) + (let ((s2 (to tr))) + (unless (gethash s2 visited) + (setf (gethash s2 visited) t) + (push s2 worklist))))) visited)) (defun accepting-states (a) "Returns a hash table containing the set of accepting states reachable from the initial state of A." (let ((accepting (make-hash-table))) - (loop for s being the hash-key of (states a) + (loop for s being the hash-keys of (states a) when (accept s) do (setf (gethash s accepting) t)) accepting)) @@ -106,7 +107,7 @@ states being the keys of STATES hash table, and finally returns STATES." (let ((i -1)) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (setf (num s) (incf i)))) states) @@ -117,7 +118,7 @@ (tr (make-instance 'transition :minc +min-char-code+ :maxc +max-char-code+ :to s))) (htadd (transitions s) tr) - (loop for p being the hash-key of (states a) + (loop for p being the hash-keys of (states a) and maxi = +min-char-code+ do (loop for tr in (sorted-transition-list p nil) do (with-slots (minc maxc) tr @@ -140,7 +141,7 @@ a (let ((states (states a))) (set-state-nums states) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (let ((st (sorted-transition-list s t))) (reset-transitions s) (let ((p nil) @@ -179,7 +180,7 @@ "Returns a sorted vector of all interval start points (character codes)." (let ((pset (make-hash-table))) - (loop for s being the hash-key of (states a) do + (loop for s being the hash-keys of (states a) do (setf (gethash +min-char-code+ pset) t) (with-ht (tr nil) (transitions s) (with-slots (minc maxc) tr @@ -188,7 +189,7 @@ (setf (gethash (1+ maxc) pset) t))))) (let ((pa (make-array (hash-table-count pset) :element-type 'char-code-type))) - (loop for p being the hash-key of pset and n from 0 do + (loop for p being the hash-keys of pset and n from 0 do (setf (aref pa n) p) finally (return (sort pa #'<)))))) @@ -196,19 +197,20 @@ "Returns the set of live states of A that are in STATES hash table. A state is live if an accepting state is reachable from it." (let ((map (make-hash-table))) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (setf (gethash s map) (make-hash-table))) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (with-ht (tr nil) (transitions s) (setf (gethash s (gethash (to tr) map)) t))) (let* ((live (accepting-states a)) - (worklist (loop for s being the hash-key of live collect s))) - (loop while worklist - for s = (pop worklist) do - (loop for p being the hash-key of (gethash s map) - unless (gethash p live) do - (setf (gethash p live) t) - (push p worklist))) + (worklist (loop for s being the hash-keys of live collect s))) + (loop for s = (first worklist) + while worklist do + (pop worklist) + (loop for p being the hash-keys of (gethash s map) + unless (gethash p live) do + (setf (gethash p live) t) + (push p worklist))) live))) (defun remove-dead-transitions (a) @@ -218,7 +220,7 @@ nil (let* ((states (states a)) (live (live-states2 a states))) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (let ((st (transitions s))) (reset-transitions s) (with-ht (tr nil) st @@ -232,7 +234,7 @@ slot." (set-state-nums states) (let ((transitions (make-array (hash-table-count states)))) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (setf (aref transitions (num s)) (sorted-transition-vector s nil))) transitions)) @@ -466,7 +468,7 @@ (progn (setf a1 (clone-expanded a1) a2 (clone-expanded a2)) - (loop for s being the hash-key of (accepting-states a1) do + (loop for s being the hash-keys of (accepting-states a1) do (setf (accept s) nil) (add-epsilon s (initial a2))) (setf (deterministic a1) nil) @@ -482,7 +484,7 @@ (loop for a2 in (cdr l) do (let* ((a2 (clone-expanded a2)) (ac2 (accepting-states a2))) - (loop for s being the hash-key of ac1 do + (loop for s being the hash-keys of ac1 do (setf (accept s) nil) (add-epsilon s (initial a2)) (when (accept s) @@ -511,7 +513,7 @@ (s (make-instance 'state))) (setf (accept s) t) (add-epsilon s (initial a)) - (loop for p being the hash-key of (accepting-states a) do + (loop for p being the hash-keys of (accepting-states a) do (add-epsilon p s)) (setf (initial a) s (deterministic a) nil) @@ -546,10 +548,10 @@ (let ((a3 (clone a))) (loop while (> (decf max) 0) do (let ((a4 (clone a))) - (loop for p being the hash-key of (accepting-states a4) do + (loop for p being the hash-keys of (accepting-states a4) do (add-epsilon p (initial a3))) (setq a3 a4))) - (loop for p being the hash-key of (accepting-states a2) do + (loop for p being the hash-keys of (accepting-states a2) do (add-epsilon p (initial a3))) (setf (deterministic a2) nil) (check-minimize-always a2)))) @@ -559,7 +561,7 @@ (let ((a (clone-expanded a))) (determinize a) (totalize a) - (loop for p being the hash-key of (states a) do + (loop for p being the hash-keys of (states a) do (setf (accept p) (not (accept p)))) (remove-dead-transitions a) (check-minimize-always a))) @@ -673,7 +675,7 @@ (loop while worklist do (let* ((s (pop worklist)) (r (htref newstate s))) - (loop for q being the hash-key of (ht s) + (loop for q being the hash-keys of (ht s) when (accept q) do (setf (accept r) t) (return)) @@ -681,7 +683,7 @@ for c across points and n from 0 do (let ((p (make-instance 'state-set))) - (loop for q being the hash-key of (ht s) do + (loop for q being the hash-keys of (ht s) do (with-ht (tr nil) (transitions q) (when (<= (minc tr) c (maxc tr)) (setf (gethash (to tr) (ht p)) t)))) @@ -763,7 +765,7 @@ (defun mark-pair (mark triggers n1 n2) (setf (aref mark n1 n2) t) (when (aref triggers n1 n2) - (loop for p being the hash-key of (aref triggers n1 n2) do + (loop for p being the hash-keys of (aref triggers n1 n2) do (let ((m1 (n1 p)) (m2 (n2 p))) (when (> m1 m2) @@ -773,7 +775,7 @@ (defun ht-set-to-vector (ht) (loop with vec = (make-array (hash-table-count ht)) - for k being the hash-key of ht + for k being the hash-keys of ht and i from 0 do (setf (aref vec i) k) finally (return vec))) @@ -900,9 +902,10 @@ (let ((j (if (<= i0 i1) 0 1))) (push (make-instance 'int-pair :n1 j :n2 i) pending) (setf (aref pending2 i j) t))) - (loop while pending - for ip = (pop pending) - for p = (n1 ip) and i = (n2 ip) do + (loop for ip = (first pending) + for p = (when pending (n1 ip)) and i = (when pending (n2 ip)) + while pending do + (pop pending) (setf (aref pending2 i p) nil) (loop for m = (fst (aref active p i)) then (succ m) while m do @@ -970,20 +973,20 @@ (let ((m (make-hash-table)) (states (states a)) (astates (accepting-states a))) - (loop for r being the hash-key of states do + (loop for r being the hash-keys of states do (setf (gethash r m) (make-generalized-hash-table +equalp-key-situation+) (accept r) nil)) - (loop for r being the hash-key of states do + (loop for r being the hash-keys of states do (with-ht (tr nil) (transitions r) (htadd (gethash (to tr) m) (make-instance 'transition :minc (minc tr) :maxc (maxc tr) :to r)))) - (loop for r being the hash-key of states do + (loop for r being the hash-keys of states do (setf (transitions r) (gethash r m))) (setf (accept (initial a)) t (initial a) (make-instance 'state)) - (loop for r being the hash-key of astates do + (loop for r being the hash-keys of astates do (add-epsilon (initial a) r)) (setf (deterministic a) nil) astates)) @@ -1011,13 +1014,14 @@ (let ((worklist pairs) (workset (make-generalized-hash-table +equalp-key-situation+))) (loop for p in pairs do (htadd workset p)) - (loop while worklist - for p = (pop worklist) do + (loop for p = (first worklist) + while worklist do + (pop worklist) (htremove workset p) (let ((tos (gethash (s2 p) forward)) (froms (gethash (s1 p) back))) (when tos - (loop for s being the hash-key of tos + (loop for s being the hash-keys of tos for pp = (make-instance 'state-pair :s1 (s1 p) :s2 s) unless (member pp pairs :test #'(lambda (o1 o2) @@ -1029,7 +1033,7 @@ (push pp worklist) (htadd workset pp) (when froms - (loop for q being the hash-key of froms + (loop for q being the hash-keys of froms for qq = (make-instance 'state-pair :s1 q :s2 (s1 p)) unless (htpresent workset qq) do (push qq worklist) @@ -1113,7 +1117,7 @@ "Returns the number of transitions of A." (if (singleton a) (length (singleton a)) - (loop for s being the hash-key of (states a) + (loop for s being the hash-keys of (states a) sum (cnt (transitions s))))) (defun empty-p (a) @@ -1152,7 +1156,7 @@ (set-state-nums states)) (format s "~@~:>" (num (initial a)) - (loop for st being the hash-key of states collect st))) + (loop for st being the hash-keys of states collect st))) a) (defun clone-expanded (a) @@ -1173,9 +1177,9 @@ (setf (singleton a2) (singleton a)) (let ((map (make-hash-table)) (states (states a))) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (setf (gethash s map) (make-instance 'state))) - (loop for s being the hash-key of states do + (loop for s being the hash-keys of states do (let ((p (gethash s map))) (setf (accept p) (accept s)) (when (eq s (initial a)) --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2007/01/14 17:33:51 1.2 @@ -100,13 +100,13 @@ (defmacro with-ht ((key value) table &body body) (let ((bucket (gensym "BUCKET"))) - `(loop for ,bucket being the hash-value of (ht ,table) do + `(loop for ,bucket being the hash-values of (ht ,table) do (loop for (,key . ,value) in ,bucket do , at body)))) (defmacro with-ht-collect ((key value) table &body body) (let ((bucket (gensym "BUCKET"))) - `(loop for ,bucket being the hash-value of (ht ,table) nconc + `(loop for ,bucket being the hash-values of (ht ,table) nconc (loop for (,key . ,value) in ,bucket collect , at body)))) --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2007/01/14 17:33:51 1.2 @@ -110,13 +110,13 @@ "Returns true if state-set objects SS1 and SS2 contain the same (eql) state objects." (and (= (hash-table-count (ht ss1)) (hash-table-count (ht ss2))) - (loop for st being the hash-key of (ht ss1) + (loop for st being the hash-keys of (ht ss1) always (gethash st (ht ss2))))) (defmethod hash ((ss state-set) (s (eql +equalp-key-situation+))) "Returns the hash code for state-set SS." (the fixnum - (mod (loop for st being the hash-key of (ht ss) + (mod (loop for st being the hash-keys of (ht ss) sum (sxhash st)) most-positive-fixnum))) From thenriksen at common-lisp.net Sun Jan 14 17:57:01 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 12:57:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070114175701.8BCAA6A02E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29818/Drei Modified Files: core.lisp base.lisp Log Message: Loop fixups for CLISP. --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2006/12/03 22:50:13 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/01/14 17:57:01 1.3 @@ -102,9 +102,9 @@ (loop with m = (clone-mark (low-mark (buffer mark)) :right) initially (beginning-of-buffer m) - do (end-of-line m) + repeat (1- line-number) until (end-of-buffer-p m) - repeat (1- line-number) + do (end-of-line m) do (incf (offset m)) (end-of-line m) finally (beginning-of-line m) @@ -202,16 +202,16 @@ with line-beginning-offset = (offset begin-mark) with walking-mark = (clone-mark begin-mark) while (mark< walking-mark mark) - as object = (object-after walking-mark) - do (case object - (#\Space - (setf (offset begin-mark) (offset walking-mark)) - (incf column)) - (#\Tab - (setf (offset begin-mark) (offset walking-mark)) - (incf column (- tab-width (mod column tab-width)))) - (t - (incf column))) + do (let ((object (object-after walking-mark))) + (case object + (#\Space + (setf (offset begin-mark) (offset walking-mark)) + (incf column)) + (#\Tab + (setf (offset begin-mark) (offset walking-mark)) + (incf column (- tab-width (mod column tab-width)))) + (t + (incf column)))) (when (and (>= column fill-column) (/= (offset begin-mark) line-beginning-offset)) (when compress-whitespaces @@ -266,8 +266,8 @@ (let ((mark2 (clone-mark mark))) (beginning-of-line mark2) (loop until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) + while (or (eql (object-after mark2) #\Space) + (eql (object-after mark2) #\Tab)) do (delete-range mark2 1)) (loop until (zerop indentation) do (cond ((and tab-width (>= indentation tab-width)) --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/14 10:17:13 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2007/01/14 17:57:01 1.4 @@ -268,14 +268,16 @@ constituent character of the line." (let ((mark2 (clone-mark mark))) (beginning-of-line mark2) - (loop with indentation = 0 - until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) - do (incf indentation - (if (eql (object-after mark2) #\Tab) tab-width 1)) - (incf (offset mark2)) - finally (return indentation)))) + (if (end-of-line-p mark2) + 0 + (loop with indentation = 0 + as object = (object-after mark2) + until (end-of-buffer-p mark2) + while (or (eql object #\Space) (eql object #\Tab)) + do (incf indentation + (if (eql (object-after mark2) #\Tab) tab-width 1)) + (incf (offset mark2)) + finally (return indentation))))) (defmethod buffer-number-of-lines-in-region (buffer offset1 offset2) "Helper method for number-of-lines-in-region. Count newline From thenriksen at common-lisp.net Sun Jan 14 19:17:11 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 14:17:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070114191711.430DC59001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13620/Drei Modified Files: drei.lisp Log Message: Updated :type option to be correct. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/01/14 08:22:27 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/01/14 19:17:10 1.14 @@ -628,7 +628,7 @@ (%minibuffer :initform nil :accessor minibuffer :initarg :minibuffer - :type (or minibuffer-pane null) + :type (or minibuffer-pane pointer-documentation-pane null) :documentation "The minibuffer pane (or null) associated with the Drei instance. This may be NIL.") (%command-table :initform (make-instance 'drei-command-table From thenriksen at common-lisp.net Sun Jan 14 19:59:07 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 14:59:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070114195907.CAEB71B004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21571 Modified Files: presentation-defs.lisp Log Message: Fixed `presentation-history-previous' to work properly with an empty history. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/10 11:19:01 1.68 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/01/14 19:59:07 1.69 @@ -686,17 +686,19 @@ (if (and (numberp pointer) (zerop pointer)) (values nil nil) (progn - (if pointer - (decf pointer) - (setf pointer (1- (fill-pointer array)))) - (destructuring-bind (object . object-ptype) - (when (array-in-bounds-p array pointer) - (aref array pointer)) - (if object-ptype - (if (presentation-subtypep object-ptype ptype) - (values object object-ptype) - (progn (presentation-history-previous history ptype))) - (values nil nil))))))) + (cond ((and (numberp pointer) (plusp pointer)) + (decf pointer)) + ((plusp (length array)) + (setf pointer (1- (fill-pointer array))))) + (if (and (numberp pointer) (array-in-bounds-p array pointer)) + (destructuring-bind (object . object-ptype) + (aref array pointer) + (if object-ptype + (if (presentation-subtypep object-ptype ptype) + (values object object-ptype) + (progn (presentation-history-previous history ptype))) + (values nil nil))) + (values nil nil)))))) (defmacro with-object-on-history ((history object ptype) &body body) "Evaluate `body' with `object' as `ptype' as the head (most From thenriksen at common-lisp.net Sun Jan 14 20:03:00 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 14 Jan 2007 15:03:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070114200300.9482425002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23631/Drei Modified Files: drei.lisp Log Message: Fix another :type option. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/01/14 19:17:10 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/01/14 20:03:00 1.15 @@ -603,7 +603,7 @@ executed.") (%point-cursor :accessor point-cursor :initarg :point-cursor - :type cursor + :type drei-cursor :documentation "The cursor object associated with point. This is guaranteed to be displayed on top of all other cursors.") From afuchs at common-lisp.net Sun Jan 14 21:49:18 2007 From: afuchs at common-lisp.net (afuchs) Date: Sun, 14 Jan 2007 16:49:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070114214918.7CDA43D008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv8651 Modified Files: mcclim.asd Log Message: Checkin the new version's release notes. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/14 15:32:53 1.50 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/14 21:49:18 1.51 @@ -446,7 +446,7 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :version "0.9.3-dev" + :version "0.9.4" :depends-on (:clim-looks)) ;;; CLIM-Examples depends on having at least one backend loaded. From afuchs at common-lisp.net Sun Jan 14 21:49:18 2007 From: afuchs at common-lisp.net (afuchs) Date: Sun, 14 Jan 2007 16:49:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20070114214918.D73F53E053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv8651/ReleaseNotes Added Files: 0-9-4-orthodox-new-year Log Message: Checkin the new version's release notes. --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-4-orthodox-new-year 2007/01/14 21:49:18 NONE +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-4-orthodox-new-year 2007/01/14 21:49:18 1.1 RELEASE NOTES FOR McCLIM 0.9.4, "Orthodox New Year": Compatibility ============= This release was tested and found to work on the following implementations: * SBCL * OpenMCL * CLISP * Allegro Common Lisp 8.0 in ANSI Mode In our tests, this release of McCLIM did not work on the following implementations: * CMUCL (at the time of this release, the released CMUCL has a bug that prevents successful loading of McCLIM; CMUCL 19d + patch 1 and the 2006-12 snapshot or later contain a fix for this problem) Also, McCLIM currently does not support lisps with case-sensitive readers (ACL "modern mode" and lower-case SCL). Changes in mcclim-0.9.4 "Orthodox New Year" relative to 0.9.3: =========================================================== >From the NEWS file: * cleanup: removed the obsolete system.lisp file. * backend improvements: Gtkairo ** Double buffering is now supported (fixes disappearing widgets on Windows). ** X errors no longer terminate the lisp process. ** Some bugfixes, including CMUCL support and better key event handling. ** Native implementation of context menus, list panes, label panes, and option panes. ** Draw text using Pango. (Bug fix: Fixed-width font supported on Windows now. Multiple lines of output in TEXT-SIZE supported now. TEXT-STYLE-FIXED-WIDTH-P works correctly now.) * Improvement: Added new editor substrate ("Drei"). * Improvement: Improved the pathname presentation methods considerably. * specification compliance: DELETE-GESTURE-NAME function now implemented. * specification compliance: PRESENTATION-TYPE-SPECIFIER-P presentaion function now implemented. * specification compliance: DISPLAY-COMMAND-TABLE-MENU function now implemented. * specification compliance: DISPLAY-COMMAND-MENU function now implemented. * specification compliance: POINTER-PLACE-RUBBER-BAND-LINE* function now implemented. * specification compliance: POINTER-INPUT-RECTANGLE* function now implemented. * specification compliance: POINTER-INPUT-RECTANGLE function now implemented. * Improvement: Added font listing support, see section "Fonts and Extended Text Styles" in the manual. * Improvement: Added support for bezier splines (Robert Strandh). To be documented. * better PRESENTATION-SUBTYPEP (more likely to give the right answer on some-of and all-of presentation types) * Improvement: M-n/M-p gestures for navigating presentation histories. From afuchs at common-lisp.net Sun Jan 14 21:53:04 2007 From: afuchs at common-lisp.net (afuchs) Date: Sun, 14 Jan 2007 16:53:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070114215304.243C84F00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv9014/Doc Modified Files: mcclim.texi Log Message: Tarball locations, mcclim.texi version number. --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/06 05:27:53 1.6 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2007/01/14 21:53:03 1.7 @@ -6,7 +6,7 @@ @setfilename mcclim @settitle McCLIM User's Manual - at set MCCLIMVERSION 0.9.3 + at set MCCLIMVERSION 0.9.4 @copying Copyright @copyright{} 2004,2005,2006 the McCLIM hackers. From afuchs at common-lisp.net Sun Jan 14 21:53:05 2007 From: afuchs at common-lisp.net (afuchs) Date: Sun, 14 Jan 2007 16:53:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage Message-ID: <20070114215305.A00824F011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage In directory clnet:/tmp/cvs-serv9014/Webpage Modified Files: index.html Log Message: Tarball locations, mcclim.texi version number. --- /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/11/02 18:37:04 1.17 +++ /project/mcclim/cvsroot/mcclim/Webpage/index.html 2007/01/14 21:53:05 1.18 @@ -54,9 +54,9 @@

Releases

- The most recent release of McCLIM is 0.9.3, in November 2006, + The most recent release of McCLIM is 0.9.4, in January 2007, available here: mcclim-0.9.3.tar.gz. It + href="downloads/mcclim-0.9.4.tar.gz">mcclim-0.9.4.tar.gz. It is also available via ASDF-INSTALL.

@@ -64,6 +64,10 @@

Recent News

+ 2007-01-14: McCLIM 0.9.4 "Orthodox New Year" released. +

+ +

2006-11-02: McCLIM 0.9.3 "All Souls' Day" released.

@@ -124,7 +128,7 @@

-$Date: 2006/11/02 18:37:04 $ +$Date: 2007/01/14 21:53:05 $ From afuchs at common-lisp.net Sun Jan 14 21:53:06 2007 From: afuchs at common-lisp.net (afuchs) Date: Sun, 14 Jan 2007 16:53:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage/downloads Message-ID: <20070114215306.27D424F011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv9014/Webpage/downloads Modified Files: index.html Log Message: Tarball locations, mcclim.texi version number. --- /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2006/11/02 18:08:29 1.15 +++ /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2007/01/14 21:53:05 1.16 @@ -43,7 +43,7 @@

Tarballs

Releases

-

The most recent release of McCLIM is 0.9.3, in Nobember 2006, available here: mcclim-0.9.3.tar.gz. It is also available via ASDF-INSTALL.

+

The most recent release of McCLIM is 0.9.4, in January 2007, available here: mcclim-0.9.4.tar.gz. It is also available via ASDF-INSTALL.

A compressed tar file of the repository is made nightly.

@@ -52,7 +52,7 @@

-$Date: 2006/11/02 18:08:29 $ +$Date: 2007/01/14 21:53:05 $ From afuchs at common-lisp.net Sun Jan 14 22:26:02 2007 From: afuchs at common-lisp.net (afuchs) Date: Sun, 14 Jan 2007 17:26:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20070114222602.00EEE36009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv15587/ReleaseNotes Modified Files: 0-9-4-orthodox-new-year Log Message: Known bugs in relnotes. --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-4-orthodox-new-year 2007/01/14 21:49:18 1.1 +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-4-orthodox-new-year 2007/01/14 22:26:02 1.2 @@ -21,6 +21,25 @@ Also, McCLIM currently does not support lisps with case-sensitive readers (ACL "modern mode" and lower-case SCL). +Known Bugs +========== + +Due to the radical changes introduced by the new editor substrate, +some bugs may surface in day-to-day use. We would very much like to +hear about them on mcclim-devel at common-lisp.net. As a work-around, you +can enable the old input substrate by using + (setf climi::*use-goatee* t) +on the REPL when clim is loaded. + +The following bugs are known to exist: + +* McCLIM freetype can interact poorly with Drei under some + circumstances +* Drei does not handle most reader macros well +* Sometimes, the ENTER key is not very responsive when editing forms + with Drei +* Calling stream-input-buffer is still buggy. + Changes in mcclim-0.9.4 "Orthodox New Year" relative to 0.9.3: =========================================================== From thenriksen at common-lisp.net Mon Jan 15 11:35:54 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 15 Jan 2007 06:35:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070115113554.6B35D4B006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv19991/Drei/Tests Modified Files: testing.lisp Added Files: buffer-streams-tests.lisp Log Message: Added implementation of the gray streams protocol using Drei buffers as the backend. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2006/12/10 19:28:48 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/01/15 11:35:53 1.3 @@ -107,6 +107,8 @@ (run! 'editing-tests) (format t "Testing miscellaneus editor functions~%") (run! 'core-tests) + (format t "Testing buffer-based gray streams~%") + (run! 'buffer-streams-tests) (format t "Testing rectangle editing~%") (run! 'rectangle-tests) (format t "Testing undo~%") --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-streams-tests.lisp 2007/01/15 11:35:54 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-streams-tests.lisp 2007/01/15 11:35:54 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (cl:in-package :drei-tests) (def-suite buffer-streams-tests :description "The test suite for buffer-streams related tests.") (in-suite buffer-streams-tests) (defun whole-buffer-stream (buffer) (let ((mark1 (clone-mark (low-mark buffer))) (mark2 (clone-mark (low-mark buffer)))) (beginning-of-buffer mark1) (end-of-buffer mark2) (make-buffer-stream :buffer buffer :start-mark mark1 :end-mark mark2))) (defun delimited-buffer-stream (buffer start-offset end-offset) (let ((mark1 (clone-mark (low-mark buffer))) (mark2 (clone-mark (low-mark buffer)))) (setf (offset mark1) start-offset) (setf (offset mark2) end-offset) (make-buffer-stream :buffer buffer :start-mark mark1 :end-mark mark2))) (test stream-creation (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (make-buffer-stream :buffer *current-buffer* :start-mark (clone-mark (low-mark *current-buffer*) :right) :end-mark (clone-mark (low-mark *current-buffer*) :left)))) (is (typep (start-mark stream) 'left-sticky-mark)) (is (typep (end-mark stream) 'right-sticky-mark))))) (test stream-read-char (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream *current-buffer*))) (is (char= (read-char stream) #\f)) (is (char= (read-char stream) #\o)) (is (char= (read-char stream) #\o)) (is (char= (read-char stream) #\Space)) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\r)) (is (char= (read-char stream) #\Space)) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\z)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof))) (let ((stream (delimited-buffer-stream *current-buffer* 4 7))) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\r)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof))))) (test stream-unread-char (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream *current-buffer*))) (is (char= (read-char stream) #\f)) (unread-char #\f stream) (is (char= (read-char stream) #\f))) (let ((stream (delimited-buffer-stream *current-buffer* 4 7))) (is (char= (read-char stream) #\b)) (unread-char #\b stream) (is (char= (read-char stream) #\b)) (is (char= (read-char stream) #\a)) (is (char= (read-char stream) #\r)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof)) (unread-char #\r stream) (is (char= (read-char stream) #\r)) (signals end-of-file (read-char stream)) (is (eq (read-char stream nil :eof) :eof))))) ;; Effectively the same as `read-char' for us. (test stream-read-char-no-hang (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream *current-buffer*))) (is (char= (read-char-no-hang stream) #\f)) (is (char= (read-char-no-hang stream) #\o)) (is (char= (read-char-no-hang stream) #\o)) (is (char= (read-char-no-hang stream) #\Space)) (is (char= (read-char-no-hang stream) #\b)) (is (char= (read-char-no-hang stream) #\a)) (is (char= (read-char-no-hang stream) #\r)) (is (char= (read-char-no-hang stream) #\Space)) (is (char= (read-char-no-hang stream) #\b)) (is (char= (read-char-no-hang stream) #\a)) (is (char= (read-char-no-hang stream) #\z)) (signals end-of-file (read-char-no-hang stream)) (is (eq (read-char-no-hang stream nil :eof) :eof))) (let ((stream (delimited-buffer-stream *current-buffer* 4 7))) (is (char= (read-char-no-hang stream) #\b)) (is (char= (read-char-no-hang stream) #\a)) (is (char= (read-char-no-hang stream) #\r)) (signals end-of-file (read-char-no-hang stream)) (is (eq (read-char-no-hang stream nil :eof) :eof))))) (test stream-peek-char (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream *current-buffer*))) (is (char= (peek-char nil stream) #\f)) (read-char stream) (is (char= (peek-char nil stream) #\o)) (read-char stream) (is (char= (peek-char nil stream) #\o)) (read-char stream)) (let ((stream (delimited-buffer-stream *current-buffer* 3 6))) (is (char= (peek-char nil stream) #\Space))) (let ((stream (delimited-buffer-stream *current-buffer* 3 6))) (is (char= (peek-char t stream) #\b))) (let ((stream (delimited-buffer-stream *current-buffer* 3 7))) (is (char= (peek-char #\r stream) #\r))) (let ((stream (delimited-buffer-stream *current-buffer* 0 0))) (signals end-of-file (peek-char t stream)) (is (eq (peek-char t stream nil :eof) :eof))))) (test stream-listen (with-drei-environment (:initial-contents "foo bar baz") (let ((stream (whole-buffer-stream *current-buffer*))) (is-true (stream-listen stream)) (dotimes (i 11) (finishes (read-char stream))) (is-false (stream-listen stream)) (unread-char #\z stream) (is-true (stream-listen stream))) (let ((stream (delimited-buffer-stream *current-buffer* 3 6))) (is-true (stream-listen stream)) (dotimes (i 3) (finishes (read-char stream))) (is-false (stream-listen stream)) (unread-char #\r stream) (is-true (stream-listen stream))) (let ((stream (delimited-buffer-stream *current-buffer* 0 0))) (is-false (stream-listen stream))))) (test stream-read-line (with-drei-environment (:initial-contents "line 1 line 2 line 3") (let ((stream (whole-buffer-stream *current-buffer*))) (is (string= (read-line stream) "line 1")) (is (string= (read-line stream) "line 2")) (is (char= (read-char stream) #\l)) (is (string= (read-line stream) "ine 3")) (signals end-of-file (read-line stream)) (is (eq (read-line stream nil :eof) :eof))))) (test stream-write-char (with-drei-environment (:initial-contents "piece of text") (let ((stream (whole-buffer-stream *current-buffer*))) (is (char= (write-char #\a stream) #\a)) (buffer-is "apiece of text") (is (char= (read-char stream) #\p)) (is (string= (read-line stream) "iece of text")) (signals end-of-file (read-char stream)) (is (char= (write-char #\a stream) #\a)) (buffer-is "apiece of texta") (signals end-of-file (read-char stream))))) (test stream-line-column (with-drei-environment (:initial-contents "abcde") (let ((stream (whole-buffer-stream *current-buffer*))) (is (= (stream-line-column stream) 0)) (is (char= (read-char stream) #\a)) (is (= (stream-line-column stream) 1)) (is (char= (read-char stream) #\b)) (is (= (stream-line-column stream) 2)) (is (char= (read-char stream) #\c)) (is (= (stream-line-column stream) 3)) (is (char= (read-char stream) #\d)) (is (= (stream-line-column stream) 4)) (is (char= (write-char #\a stream) #\a)) (is (= (stream-line-column stream) 5)) (is (char= (read-char stream) #\e)) (signals end-of-file (read-char stream)) (is (= (stream-line-column stream) 6))))) (test stream-start-line-p (with-drei-environment (:initial-contents "foobar") (let ((stream (whole-buffer-stream *current-buffer*))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\f)) (is-false (stream-start-line-p stream)) (unread-char #\f stream) (is-true (stream-start-line-p stream))) (let ((stream (delimited-buffer-stream *current-buffer* 3 6))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\b)) (is-false (stream-start-line-p stream)) (unread-char #\b stream) (is-true (stream-start-line-p stream))))) (test stream-write-string (with-drei-environment (:initial-contents "contents") (let ((stream (whole-buffer-stream *current-buffer*))) (write-string "foobar" stream) (buffer-is "foobarcontents") (is-false (stream-start-line-p stream)) (write-string #.(format nil "~%") stream) (buffer-is #.(format nil "foobar~%contents")) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\c))))) (test stream-terpri (with-drei-environment (:initial-contents "contents") (let ((stream (whole-buffer-stream *current-buffer*))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\c)) (is-false (stream-start-line-p stream)) (terpri stream) (is-true (stream-start-line-p stream)) (terpri stream) (is-true (stream-start-line-p stream)) (buffer-is #.(format nil "c~%~%ontents"))))) (test stream-fresh-line (with-drei-environment (:initial-contents "contents") (let ((stream (whole-buffer-stream *current-buffer*))) (is-true (stream-start-line-p stream)) (is (char= (read-char stream) #\c)) (is-false (stream-start-line-p stream)) (fresh-line stream) (is-true (stream-start-line-p stream)) (fresh-line stream) (is-true (stream-start-line-p stream)) (buffer-is #.(format nil "c~%ontents"))))) (test stream-advance-to-column (with-drei-environment (:initial-contents "") (let ((stream (whole-buffer-stream *current-buffer*))) (write-string "foobar" stream) (stream-advance-to-column stream 3) (buffer-is "foobar") (fresh-line stream) (stream-advance-to-column stream 3) (buffer-is #.(format nil "foobar~% "))))) From thenriksen at common-lisp.net Mon Jan 15 11:35:55 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 15 Jan 2007 06:35:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070115113555.A1E7F4E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19991/Drei Modified Files: packages.lisp Added Files: buffer-streams.lisp Log Message: Added implementation of the gray streams protocol using Drei buffers as the backend. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/12/22 15:34:46 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/01/15 11:35:54 1.12 @@ -421,7 +421,11 @@ #:replace-rectangle-line #:insert-in-rectangle-line #:delete-rectangle-line-whitespace - #:with-narrowed-buffer) + #:with-narrowed-buffer + + #:start-mark + #:end-mark + #:make-buffer-stream) (:documentation "Implementation of much syntax-aware, yet no syntax-specific, core functionality of Drei.")) --- /project/mcclim/cvsroot/mcclim/Drei/buffer-streams.lisp 2007/01/15 11:35:55 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/buffer-streams.lisp 2007/01/15 11:35:55 1.1 ;;; -*- Mode: Lisp; Package: DREI-CORE -*- ;;; (c) copyright 2006-2007 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :drei-core) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; (Gray) streams interface to buffers. (defclass buffer-stream (fundamental-character-input-stream fundamental-character-output-stream) ((%buffer :initarg :buffer :initform (error "A buffer must be provided") :reader buffer :documentation "The buffer from which this stream will read data.") (%start-mark :initarg :start-mark :reader start-mark :documentation "A mark into the buffer of the stream that indicates from which point on the stream will read data from the buffer. By default, the beginning of the buffer. This mark should not be changed.") (%end-mark :initarg :end-mark :reader end-mark :documentation "A mark into the buffer of the stream that indicates the buffer position that the stream will consider end-of-file. By default, the end of the buffer. This mark should not be changed.") (%point :accessor point :documentation "A mark indicating the current position in the buffer of the stream.")) (:documentation "A bidirectional stream that performs I/O on an underlying Drei buffer. Marks can be provided to let the stream operate on only a specific section of the buffer.")) (defmethod initialize-instance :after ((stream buffer-stream) &key) (unless (slot-boundp stream '%start-mark) (setf (slot-value stream '%start-mark) (clone-mark (point (buffer stream)) :left)) (beginning-of-buffer (start-mark stream))) (unless (slot-boundp stream '%end-mark) (setf (slot-value stream '%end-mark) (clone-mark (start-mark stream) :right)) (end-of-buffer (end-mark stream))) (setf (point stream) (narrow-mark (clone-mark (start-mark stream) :right) (start-mark stream) (end-mark stream)))) ;;; Input methods. (defmethod stream-read-char ((stream buffer-stream)) (if (end-of-buffer-p (point stream)) :eof (prog1 (object-after (point stream)) (forward-object (point stream))))) (defmethod stream-unread-char ((stream buffer-stream) (char character)) (unless (beginning-of-buffer-p (point stream)) (backward-object (point stream)) nil)) (defmethod stream-read-char-no-hang ((stream buffer-stream)) (stream-read-char stream)) (defmethod stream-peek-char ((stream buffer-stream)) (if (end-of-buffer-p (point stream)) :eof (object-after (point stream)))) (defmethod stream-listen ((stream buffer-stream)) (not (end-of-buffer-p (point stream)))) (defmethod stream-read-line ((stream buffer-stream)) (let ((orig-offset (offset (point stream))) (end-of-line-offset (offset (end-of-line (point stream))))) (unless (end-of-buffer-p (point stream)) (forward-object (point stream))) (values (buffer-substring (buffer stream) orig-offset end-of-line-offset) (end-of-buffer-p (point stream))))) (defmethod stream-clear-input ((stream buffer-stream)) nil) ;;; Output methods. (defmethod stream-write-char ((stream buffer-stream) char) (insert-object (point stream) char)) (defmethod stream-line-column ((stream buffer-stream)) (column-number (point stream))) (defmethod stream-start-line-p ((stream buffer-stream)) (or (mark= (point stream) (start-mark stream)) (beginning-of-line-p (point stream)))) (defmethod stream-write-string ((stream buffer-stream) string &optional (start 0) end) (insert-sequence (point stream) (subseq string start end))) (defmethod stream-terpri ((stream buffer-stream)) (insert-object (point stream) #\Newline)) (defmethod stream-fresh-line ((stream buffer-stream)) (unless (stream-start-line-p stream) (stream-terpri stream))) (defmethod stream-finish-output ((stream buffer-stream)) (declare (ignore stream)) nil) (defmethod stream-force-output ((stream buffer-stream)) (declare (ignore stream)) nil) (defmethod stream-clear-output ((stream buffer-stream)) (declare (ignore stream)) nil) (defmethod stream-advance-to-column ((stream buffer-stream) (column integer)) (call-next-method)) (defmethod interactive-stream-p ((stream buffer-stream)) nil) ;;; Interface functions. (defun make-buffer-stream (&key (buffer *current-buffer*) (start-mark nil start-mark-p) (end-mark nil end-mark-p)) "Create a buffer stream object reading data from `buffer'. By default, the stream will read from the beginning of the buffer and until the end of the buffer, but this can be changed via the optional arguments `start-mark' and `end-mark'." (apply #'make-instance 'buffer-stream :buffer buffer (append (when start-mark-p (list :start-mark (clone-mark start-mark :left))) (when end-mark-p (list :end-mark (clone-mark end-mark :right)))))) From thenriksen at common-lisp.net Mon Jan 15 11:35:56 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 15 Jan 2007 06:35:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070115113556.16F1A4E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19991 Modified Files: mcclim.asd Log Message: Added implementation of the gray streams protocol using Drei buffers as the backend. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/14 21:49:18 1.51 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/15 11:35:55 1.52 @@ -297,6 +297,7 @@ (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "basic-commands" :depends-on ("drei-clim" "motion" "editing")) (:file "core" :depends-on ("drei")) + (:file "buffer-streams" :depends-on ("core")) (:file "rectangle" :depends-on ("core")) (:file "core-commands" :depends-on ("core" "rectangle" "drei-clim")) (:file "persistent-buffer" @@ -337,6 +338,7 @@ (:file "motion-tests" :depends-on ("testing")) (:file "editing-tests" :depends-on ("testing")) (:file "core-tests" :depends-on ("testing")) + (:file "buffer-streams-tests" :depends-on ("testing")) (:file "rectangle-tests" :depends-on ("testing")) (:file "undo-tests" :depends-on ("testing")) (:file "lisp-syntax-tests" :depends-on ("testing")))))) From thenriksen at common-lisp.net Mon Jan 15 22:13:16 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 15 Jan 2007 17:13:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070115221316.2970A1900A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv6550/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Made Lisp syntax `form-to-object' handle label reader macros. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2006/12/10 19:28:48 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/01/15 22:13:15 1.2 @@ -364,13 +364,30 @@ (test form-to-object-16 (testing-lisp-syntax ("#+mcclim t") - (is (eq (get-object) t))) + (is (eq (get-object) (or #+mcclim t)))) (testing-lisp-syntax ("#-mcclim t") - (is (eq (get-object) nil))) + (is (eq (get-object) (or #-mcclim t)))) (testing-lisp-syntax ("(#+mcclim t)") - (is (equal (get-object) '(t)))) + (is (equal (get-object) '(#+mcclim t)))) (testing-lisp-syntax ("(#-mcclim t)") - (is (equal (get-object) '())))) + (is (equal (get-object) '(#-mcclim t))))) + +(test form-to-object-17 + (testing-lisp-syntax ("(#1=list #1#)") + (is (equal (get-object) '(list list)))) + (testing-lisp-syntax ("#1=(list . #1#)") + (finishes + (loop for x in (get-object) + for y in '#1=(list . #1#) + for i from 0 upto 100 + unless (eq y x) + do (fail "~A is not eq to ~A" x y)))) + (testing-lisp-syntax ("(#1=list (#1# 1 2 3))") + (let ((form (drei-lisp-syntax::form-before (syntax buffer) 14))) + (is (eq (form-to-object (syntax buffer) form) 'list)))) + (testing-lisp-syntax ("(#1=list #1=cons)") + (signals form-conversion-error + (get-object)))) (defgeneric find-pathnames (module) (:documentation "Get a list of the pathnames of the files From thenriksen at common-lisp.net Mon Jan 15 22:13:16 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 15 Jan 2007 17:13:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070115221316.66CAF1A007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6550 Modified Files: lisp-syntax.lisp Log Message: Made Lisp syntax `form-to-object' handle label reader macros. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/10 20:54:13 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/15 22:13:16 1.17 @@ -2664,10 +2664,30 @@ (list* (car result) item (cdr result))) (t (list op item result)))) -(defun token-to-symbol (syntax token &optional (case (readtable-case *readtable*))) - "Return the symbol `token' represents. If the symbol cannot be -found in a package, an uninterned symbol will be returned." - (form-to-object syntax token :case case :no-error t)) +(define-condition reader-invoked (condition) + ((%end-mark :reader end-mark :initarg :end-mark + :initform (error "You must provide an ending-mark for +the condition") + :documentation "The position at which the reader +stopped reading, form-to-object conversion should be resumed +from this point.") + (%object :reader object :initarg :object + :initform (error "You must provide the object that +was returned by the reader") + :documentation "The object that was returned by the reader.")) + (:documentation "Signal that the reader has been directly +invoked on the buffer contents, that the object of this condition +should be assumed as the result of the form-conversion.")) + +(defun invoke-reader (syntax form) + "Use the system reader to handle `form' and signal a +`reader-invoked' condition with the resulting data." + (let* ((start-mark (clone-mark (high-mark (buffer syntax))))) + (setf (offset start-mark) (start-offset form)) + (let* ((stream (make-buffer-stream :buffer (buffer syntax) + :start-mark start-mark)) + (object (read-preserving-whitespace stream))) + (signal 'reader-invoked :end-mark (point stream) :object object)))) (define-condition form-conversion-error (simple-error user-condition-mixin) ((syntax :reader syntax :initarg :syntax @@ -2698,6 +2718,153 @@ (setf (offset (point drei)) (start-offset (form condition)))) +;;; Handling labels (#n= and #n#) takes a fair bit of machinery, most +;;; of which is located here. We follow an approach similar to that +;;; found in the SBCL reader, where we replace instances of #n# with a +;;; special unique marker symbol that we replace before returning the +;;; final object. We maintain two tables, one that maps labels to +;;; placerholder symbols and one that maps placeholder symbols to the +;;; concrete objects. + +(defvar *labels->placeholders* nil + "This variable holds an alist mapping labels (as integers) to a +placeholder symbol. It is used for implementing the label reader +macros (#n=foo #n#).") + +(defvar *label-placeholders->object* nil + "This variable holds an alist mapping placeholder symbols to +the object. It is used for implementing the label reader +macros (#n=foo #n#).") + +(defgeneric extract-label (syntax form) + (:documentation "Get the label of `form' as an integer.")) + +(defmethod extract-label ((syntax lisp-syntax) (form sharpsign-equals-form)) + (let ((string (form-string syntax (first (children form))))) + (parse-integer string :start 1 :end (1- (length string)) :radix 10))) + +(defmethod extract-label ((syntax lisp-syntax) (form sharpsign-sharpsign-lexeme)) + (let ((string (form-string syntax form))) + (parse-integer string :start 1 :end (1- (length string)) :radix 10))) + +(defun register-form-label (syntax form &rest args) + "Register the label of `form' and the corresponding placeholder +symbol. `Form' must be a sharpsign-equals form (#n=), and if the +label has already been registered, an error of type +`form-conversion-error' will be signalled. Args will be passed to +`form-to-object' for the creation of the object referred to by +the label. Returns `form' converted to an object." + (let* ((label (extract-label syntax form)) + (placeholder-symbol (gensym))) + (when (assoc label *labels->placeholders*) + (form-conversion-error syntax form "multiply defined label: ~A" label)) + (push (list label placeholder-symbol) *labels->placeholders*) + (let ((object (apply #'form-to-object syntax + (second (children form)) args))) + (push (list placeholder-symbol object) *label-placeholders->object*) + object))) + +(defgeneric find-and-register-label (syntax form label limit &rest args) + (:documentation "Find the object referred to by the integer +value `label' in children of `form' or `form' itself. `Args' will +be passed to `form-to-object' for the creation of the +object. `Limit' is a buffer offset delimiting where not to search +past.")) + +(defmethod find-and-register-label ((syntax lisp-syntax) (form form) + (label integer) (limit integer) &rest args) + (find-if #'(lambda (child) + (when (and (formp child) + (< (start-offset form) limit)) + (apply #'find-and-register-label syntax child label limit args))) + (children form))) + +(defmethod find-and-register-label ((syntax lisp-syntax) (form sharpsign-equals-form) + (label integer) (limit integer) &rest args) + (when (and (= (extract-label syntax form) label) + (< (start-offset form) limit)) + (apply #'register-form-label syntax form args))) + +(defun ensure-label (syntax form label &rest args) + "Ensure as best as possible that `label' exist. `Form' is the +form that needs the value of the label, limiting where to end the +search. `Args' will be passed to `form-to-object' if it is +necessary to create a new object for the label." + (unless (assoc label *labels->placeholders*) + (apply #'find-and-register-label syntax (form-toplevel form syntax) label (start-offset form) args))) + +(defun label-placeholder (syntax form label &optional search-whole-form &rest args) + "Get the placeholder for `label' (which must be an integer). If +the placeholder symbol cannot be found, the label is undefined, +and an error of type `form-conversion-error' will be +signalled. If `search-whole-form' is true, the entire +top-level-form will be searched for the label reference if it has +not already been seen, upwards from `form', but not past +`form'. `Args' will be passed as arguments to `form-to-object' to +create the labelled object." + (when search-whole-form + (apply #'ensure-label syntax form label args)) + (let ((pair (assoc label *labels->placeholders*))) + (second pair))) + +;;; The `circle-subst' function is cribbed from SBCL. + +(defvar *sharp-equal-circle-table* nil + "Objects already seen by `circle-subst'.") + +(defun circle-subst (old-new-alist tree) + "This function is kind of like NSUBLIS, but checks for +circularities and substitutes in arrays and structures as well as +lists. The first arg is an alist of the things to be replaced +assoc'd with the things to replace them." + (cond ((not (typep tree + '(or cons (array t) structure-object standard-object))) + (let ((entry (find tree old-new-alist :key #'first))) + (if entry (second entry) tree))) + ((null (gethash tree *sharp-equal-circle-table*)) + (setf (gethash tree *sharp-equal-circle-table*) t) + (cond ((typep tree '(or structure-object standard-object)) + ;; I am time and again saved by the MOP as I code + ;; myself into a corner. + (let ((class (class-of tree))) + (dolist (slotd (clim-mop:class-slots class)) + (when (clim-mop:slot-boundp-using-class class tree slotd) + (let* ((old (clim-mop:slot-value-using-class class tree slotd)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (clim-mop:slot-value-using-class + class tree slotd) + new))))))) + ((arrayp tree) + (loop for i from 0 below (length tree) do + (let* ((old (aref tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (aref tree i) new))))) + (t + (let ((a (circle-subst old-new-alist (car tree))) + (d (circle-subst old-new-alist (cdr tree)))) + (unless (eq a (car tree)) + (rplaca tree a)) + (unless (eq d (cdr tree)) + (rplacd tree d))))) + tree) + (t tree))) + +(defun replace-placeholders (&rest values) + "Replace the placeholder symbols in `values' with the real +objects as determined by `*label-placeholders->objects*' and +return the modified `values' as multiple return values." + (values-list + (mapcar #'(lambda (value) + (let ((*sharp-equal-circle-table* (make-hash-table :test #'eq :size 20))) + (circle-subst *label-placeholders->object* value))) + values))) + +(defvar *form-to-object-depth* 0 + "This variable is used to keep track of how deeply nested calls +to `form-to-object' are.") + (defgeneric form-to-object (syntax form &key no-error package read backquote-level case) (:documentation "Return the Lisp object `form' would become if read. An attempt will be made to construct objects from @@ -2710,17 +2877,25 @@ will be signalled for incomplete forms.") (:method :around ((syntax lisp-syntax) (form form) &key package no-error &allow-other-keys) ;; Ensure that every symbol that is READ will be looked up - ;; in the correct package. Also handle quoting. + ;; in the correct package. (flet ((act () - (let ((*package* (or package - (package-at-mark - syntax (start-offset form))))) - - (call-next-method)))) - (if no-error - (handler-case (act) - (form-conversion-error ())) - (act)))) + (handler-case + (multiple-value-call #'replace-placeholders (call-next-method)) + (reader-invoked (c) + (if (> (offset (end-mark c)) (end-offset form)) + (signal c) + (object c))) + (form-conversion-error (e) + (unless no-error + (error e)))))) + (let ((*form-to-object-depth* (1+ *form-to-object-depth*)) + (*package* (or package (package-at-mark + syntax (start-offset form))))) + (if (= *form-to-object-depth* 1) + (let ((*labels->placeholders* nil) + (*label-placeholders->object* nil)) + (act)) + (act))))) (:method ((syntax lisp-syntax) (form t) &rest args &key no-error &allow-other-keys) (unless no-error @@ -2738,9 +2913,20 @@ (defmethod form-to-object ((syntax lisp-syntax) (form list-form) &rest args &key &allow-other-keys) - (mapcan #'(lambda (child) - (multiple-value-list (apply #'form-to-object syntax child args))) - (remove-if-not #'formp (children form)))) + (labels ((recurse (elements) + (unless (null elements) + (handler-case + (nconc (multiple-value-list + (apply #'form-to-object syntax (first elements) args)) + (recurse (rest elements))) + (reader-invoked (c) + (let ((remaining-elements (remove (offset (end-mark c)) elements + :key #'start-offset :test #'>))) + (if (and (not (null (rest elements))) + (null remaining-elements)) + (signal c) + (cons (object c) (recurse remaining-elements))))))))) + (recurse (remove-if-not #'formp (children form))))) (defmethod form-to-object ((syntax lisp-syntax) (form complete-quote-form) &rest args &key (backquote-level 0) &allow-other-keys) @@ -2825,7 +3011,7 @@ (defmethod form-to-object ((syntax lisp-syntax) (form number-lexeme) &key &allow-other-keys) (let ((*read-base* (base syntax))) - (values (read-from-string (form-string syntax form))))) + (invoke-reader syntax form))) (defmethod form-to-object ((syntax lisp-syntax) (form simple-vector-form) &key &allow-other-keys) @@ -2837,7 +3023,7 @@ (defmethod form-to-object ((syntax lisp-syntax) (form complete-string-form) &key &allow-other-keys) - (values (read-from-string (form-string syntax form)))) + (invoke-reader syntax form)) (defmethod form-to-object ((syntax lisp-syntax) (form function-form) &rest args) (list 'cl:function (apply #'form-to-object syntax (second (children form)) args))) @@ -2875,9 +3061,10 @@ (defmethod form-to-object ((syntax lisp-syntax) (form undefined-reader-macro-form) &key read &allow-other-keys) - ;; ??? + ;; This is likely to malfunction for some really evil reader macros, + ;; in that case, you need to extend the parser to understand them. (when read - (read-from-string (form-string syntax form)))) + (invoke-reader syntax form))) (defmethod form-to-object ((syntax lisp-syntax) (form literal-object-form) &key &allow-other-keys) (object-after (start-mark form))) @@ -2910,6 +3097,14 @@ (when read (values (eval (apply #'form-to-object syntax (first-form (children form)) args))))) +(defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-equals-form) + &rest args) + (apply #'register-form-label syntax form args)) + +(defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-sharpsign-lexeme) + &rest args) + (apply #'label-placeholder syntax form (extract-label syntax form) t args)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Arglist fetching. From thenriksen at common-lisp.net Tue Jan 16 22:16:32 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 16 Jan 2007 17:16:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070116221632.9B2BA3E058@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9566 Modified Files: drei-clim.lisp Log Message: `clear-modify' should be called even when no value-changed-callback is registered. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/12/21 00:38:14 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/01/16 22:16:32 1.15 @@ -294,13 +294,13 @@ (abort-gesture () (display-message "Aborted"))) (display-drei drei) - (when (and (modified-p (buffer drei)) - (gadget-value-changed-callback drei)) + (when (modified-p (buffer drei)) (clear-modify (buffer drei)) - (value-changed-callback drei - (gadget-client drei) - (gadget-id drei) - (gadget-value drei))))))) + (when (gadget-value-changed-callback drei) + (value-changed-callback drei + (gadget-client drei) + (gadget-id drei) + (gadget-value drei)))))))) (defmethod execute-drei-command :after ((drei drei-gadget-pane) command) (with-accessors ((buffer buffer)) drei From thenriksen at common-lisp.net Wed Jan 17 10:02:10 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 17 Jan 2007 05:02:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070117100210.521AB2B139@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26529 Modified Files: syntax.lisp Log Message: Let standard command tables use editor-commands when used for syntaxes. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/12/04 07:57:36 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/01/17 10:02:08 1.5 @@ -89,7 +89,7 @@ from `editor-table' - the command tables containing the editor commands will be added automatically, as long as this function returns T.") - (:method ((command-table syntax-command-table)) + (:method ((command-table standard-command-table)) t)) (defgeneric additional-command-tables (editor command-table) From thenriksen at common-lisp.net Wed Jan 17 11:43:51 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 17 Jan 2007 06:43:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070117114351.D91BB47369@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13236 Modified Files: drei-clim.lisp Log Message: Removed hopefully unnecessary call to `activate-gadget'. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/01/16 22:16:32 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/01/17 11:43:51 1.16 @@ -326,7 +326,6 @@ ;; eat keyboard events. (unwind-protect (progn (disarmed-callback drei t t) (funcall continuation)) - (activate-gadget drei) (armed-callback drei t t))) (defmethod additional-command-tables append ((drei drei-gadget-pane) From thenriksen at common-lisp.net Wed Jan 17 11:44:30 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 17 Jan 2007 06:44:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070117114430.BCDB550016@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13353 Modified Files: basic-commands.lisp Log Message: Fixed Backward Delete Unit commands. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/14 19:43:36 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/01/17 11:44:30 1.4 @@ -245,7 +245,7 @@ ;;; ;;; This file also holds command definitions for other functions ;;; defined in the DREI-EDITING package. - +n (defmacro define-deletion-commands (unit command-table &key noun plural) @@ -311,14 +311,14 @@ ((count 'integer :prompt ,(concat "Number of " plural))) ,(concat "Delete from point until the next " noun " end. With a positive numeric argument, delete that many " plural " forward.") - (,backward-delete *current-point* count)) + (,backward-delete *current-point* (syntax *current-buffer*) count)) ;; Backward Delete Unit (define-command (,com-backward-delete :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural))) ,(concat "Delete from point until the previous " noun " beginning. With a positive numeric argument, delete that many " plural " backward.") - (,backward-delete *current-point* count))))))) + (,backward-delete *current-point* (syntax *current-buffer*) count))))))) (defmacro define-editing-commands (unit command-table &key noun From thenriksen at common-lisp.net Wed Jan 17 12:02:05 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 17 Jan 2007 07:02:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070117120205.1A7DB53036@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16830 Modified Files: basic-commands.lisp Log Message: Removed junk character. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/01/17 11:44:30 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/01/17 12:02:04 1.5 @@ -245,7 +245,7 @@ ;;; ;;; This file also holds command definitions for other functions ;;; defined in the DREI-EDITING package. -n + (defmacro define-deletion-commands (unit command-table &key noun plural) From thenriksen at common-lisp.net Wed Jan 17 12:09:46 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 17 Jan 2007 07:09:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070117120946.AFF1D5C000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17546 Modified Files: commands.lisp Log Message: When reading commands for `command-or-form', use the command history. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/06 12:51:16 1.69 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2007/01/17 12:09:46 1.70 @@ -1401,7 +1401,7 @@ (if (member initial-char *command-dispatchers*) (progn (read-gesture :stream stream) - (accept command-ptype :stream stream :view view :prompt nil :history 'command-or-form)) + (accept command-ptype :stream stream :view view :prompt nil :history 'command)) (accept 'form :stream stream :view view :prompt nil :history 'command-or-form))) (t (funcall (cdar *input-context*) object type event options))))) From thenriksen at common-lisp.net Wed Jan 17 13:31:50 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 17 Jan 2007 08:31:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070117133150.E70D92B13B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3254/Drei Modified Files: lisp-syntax.lisp Log Message: Make `sharpsign-sharpsign-lexeme' a complete form (and change its name). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/15 22:13:16 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/17 13:31:50 1.18 @@ -375,7 +375,7 @@ (defclass delimiter-lexeme (lisp-lexeme) ()) (defclass text-lexeme (lisp-lexeme) ()) (defclass sharpsign-equals-lexeme (lisp-lexeme) ()) -(defclass sharpsign-sharpsign-lexeme (form-lexeme) ()) +(defclass sharpsign-sharpsign-form (form-lexeme complete-form-mixin) ()) (defclass reader-conditional-positive-lexeme (lisp-lexeme) ()) (defclass reader-conditional-negative-lexeme (lisp-lexeme) ()) (defclass uninterned-symbol-lexeme (lisp-lexeme) ()) @@ -525,7 +525,7 @@ (#\= (fo) (make-instance 'sharpsign-equals-lexeme)) (#\# (fo) - (make-instance 'sharpsign-sharpsign-lexeme)) + (make-instance 'sharpsign-sharpsign-form)) (#\+ (fo) (make-instance 'reader-conditional-positive-lexeme)) (#\- (fo) @@ -2743,7 +2743,7 @@ (let ((string (form-string syntax (first (children form))))) (parse-integer string :start 1 :end (1- (length string)) :radix 10))) -(defmethod extract-label ((syntax lisp-syntax) (form sharpsign-sharpsign-lexeme)) +(defmethod extract-label ((syntax lisp-syntax) (form sharpsign-sharpsign-form)) (let ((string (form-string syntax form))) (parse-integer string :start 1 :end (1- (length string)) :radix 10))) @@ -3101,7 +3101,7 @@ &rest args) (apply #'register-form-label syntax form args)) -(defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-sharpsign-lexeme) +(defmethod form-to-object ((syntax lisp-syntax) (form sharpsign-sharpsign-form) &rest args) (apply #'label-placeholder syntax form (extract-label syntax form) t args)) From afuchs at common-lisp.net Thu Jan 18 15:01:11 2007 From: afuchs at common-lisp.net (afuchs) Date: Thu, 18 Jan 2007 10:01:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070118150111.89E6652008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17193 Modified Files: NEWS mcclim.asd Added Files: clim-examples.asd clim-listener.asd clouseau.asd scigraph.asd symlink-asd-files.sh Log Message: Split the interesting systems from mcclim.asd into their own .asd files, to ease asdf-installation. Beware: If you had symlinks from e.g. /path/to/asdf-central-registry/clim-listener.asd to mcclim.asd, this will break your setup. Run ./symlink-asd-files.sh /path/to/asdf-central-registry/ to fix this. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/01/14 07:59:03 1.19 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/01/18 15:01:11 1.20 @@ -1,3 +1,8 @@ +* Changes in mcclim-0.9.5 relative to 0.9.4: +** Installation: the systems clim-listener, scigraph, clim-examples, + and clouseau can now be loaded without loading the system mcclim + first. + * Changes in mcclim-0.9.4 relative to 0.9.3: ** cleanup: removed the obsolete system.lisp file. ** backend improvements: Gtkairo --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/15 11:35:55 1.52 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/01/18 15:01:11 1.53 @@ -441,123 +441,12 @@ (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) -;;; name of :clim-clx-user chosen by mikemac for no good reason -(defsystem :clim-clx-user - :depends-on (:clim :clim-clx)) - ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :version "0.9.4" + :version "0.9.5-dev" :depends-on (:clim-looks)) -;;; CLIM-Examples depends on having at least one backend loaded. -(defsystem :clim-examples - :depends-on (:mcclim) - :components - ((:module "Examples" - :components - ((:file "calculator") - (:file "colorslider") - (:file "menutest") ; extra - (:file "address-book") - (:file "traffic-lights") - (:file "clim-fig") - (:file "postscript-test") - (:file "puzzle") - (:file "transformations-test") - (:file "demodemo") - (:file "stream-test") - (:file "presentation-test") - (:file "dragndrop") - (:file "gadget-test") - (:file "accepting-values") - (:file "method-browser") - (:file "stopwatch") - (:file "dragndrop-translator") - (:file "draggable-graph") - (:file "text-size-test") - (:file "drawing-benchmark") - (:file "logic-cube") - (:file "views") - (:file "font-selector"))) - (:module "Goatee" - :components - ((:file "goatee-test"))))) - -;;; This won't load in SBCL, either. I have really crappy code to -;;; extract dependency information from :serial t ASDF systems, but -;;; this comment is too narrow to contain it. -(clim-defsystem (:scigraph :depends-on (:mcclim)) - ;; The DWIM part of SCIGRAPH - "Apps/Scigraph/dwim/package" - "Apps/Scigraph/dwim/feature-case" - "Apps/Scigraph/dwim/macros" - "Apps/Scigraph/dwim/tv" - "Apps/Scigraph/dwim/draw" - "Apps/Scigraph/dwim/present" - "Apps/Scigraph/dwim/extensions" - "Apps/Scigraph/dwim/wholine" - "Apps/Scigraph/dwim/export" - ;; The Scigraph part - "Apps/Scigraph/scigraph/package" - "Apps/Scigraph/scigraph/copy" - "Apps/Scigraph/scigraph/dump" - "Apps/Scigraph/scigraph/duplicate" - "Apps/Scigraph/scigraph/random" - "Apps/Scigraph/scigraph/menu-tools" - "Apps/Scigraph/scigraph/basic-classes" - "Apps/Scigraph/scigraph/draw" - "Apps/Scigraph/scigraph/mouse" - "Apps/Scigraph/scigraph/color" - "Apps/Scigraph/scigraph/basic-graph" - "Apps/Scigraph/scigraph/graph-mixins" - "Apps/Scigraph/scigraph/axis" - "Apps/Scigraph/scigraph/moving-object" - "Apps/Scigraph/scigraph/symbol" - "Apps/Scigraph/scigraph/graph-data" - "Apps/Scigraph/scigraph/legend" - "Apps/Scigraph/scigraph/graph-classes" - "Apps/Scigraph/scigraph/present" - "Apps/Scigraph/scigraph/annotations" - "Apps/Scigraph/scigraph/annotated-graph" - "Apps/Scigraph/scigraph/contour" - "Apps/Scigraph/scigraph/equation" - "Apps/Scigraph/scigraph/popup-accept" - "Apps/Scigraph/scigraph/popup-accept-methods" - "Apps/Scigraph/scigraph/duplicate-methods" - "Apps/Scigraph/scigraph/frame" - "Apps/Scigraph/scigraph/export" - "Apps/Scigraph/scigraph/demo-frame") - -(defsystem :clim-listener - :depends-on (:mcclim #+sbcl :sb-posix) - :components - ((:file "Experimental/xpm" - :pathname #.(make-pathname :directory '(:relative "Experimental") :name "xpm" :type "lisp")) - (:module "Apps/Listener" - :pathname #.(make-pathname :directory '(:relative "Apps" "Listener")) - :depends-on ("Experimental/xpm") - :components - ((:file "package") - (:file "util" :depends-on ("package")) - (:file "icons" :depends-on ("package" "util")) - (:file "file-types" :depends-on ("package" "icons" "util")) - (:file "dev-commands" :depends-on ("package" "icons" "file-types" "util")) - (:file "listener" :depends-on ("package" "file-types" "icons" "dev-commands" "util")) - #+CMU (:file "cmu-hacks" :depends-on ("package")))))) - -(defsystem :clouseau - :depends-on (:mcclim) - :serial t - :components - ((:module "Apps/Inspector" - :pathname #.(make-pathname :directory '(:relative "Apps" "Inspector")) - :components - ((:file "package") - (:file "disassembly" :depends-on ("package")) - (:file "inspector" :depends-on ("disassembly")))))) - (defmethod perform :after ((op load-op) (c (eql (find-system :clim)))) (pushnew :clim *features*) (pushnew :mcclim *features*)) --- /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/01/18 15:01:11 NONE +++ /project/mcclim/cvsroot/mcclim/clim-examples.asd 2007/01/18 15:01:11 1.1 ;;; -*- lisp -*- (defpackage :clim-examples.system (:use :cl :asdf)) (in-package :clim-examples.system) ;;; CLIM-Examples depends on having at least one backend loaded. (defsystem :clim-examples :depends-on (:mcclim) :components ((:module "Examples" :components ((:file "calculator") (:file "colorslider") (:file "menutest") ; extra (:file "address-book") (:file "traffic-lights") (:file "clim-fig") (:file "postscript-test") (:file "puzzle") (:file "transformations-test") (:file "demodemo") (:file "stream-test") (:file "presentation-test") (:file "dragndrop") (:file "gadget-test") (:file "accepting-values") (:file "method-browser") (:file "stopwatch") (:file "dragndrop-translator") (:file "draggable-graph") (:file "text-size-test") (:file "drawing-benchmark") (:file "logic-cube") (:file "views") (:file "font-selector"))) (:module "Goatee" :components ((:file "goatee-test"))))) --- /project/mcclim/cvsroot/mcclim/clim-listener.asd 2007/01/18 15:01:11 NONE +++ /project/mcclim/cvsroot/mcclim/clim-listener.asd 2007/01/18 15:01:11 1.1 ;;; -*- lisp -*- (defpackage :clim-listener.system (:use :cl :asdf)) (in-package :clim-listener.system) (defsystem :clim-listener :depends-on (:mcclim #+sbcl :sb-posix) :components ((:file "Experimental/xpm" :pathname #.(make-pathname :directory '(:relative "Experimental") :name "xpm" :type "lisp")) (:module "Apps/Listener" :pathname #.(make-pathname :directory '(:relative "Apps" "Listener")) :depends-on ("Experimental/xpm") :components ((:file "package") (:file "util" :depends-on ("package")) (:file "icons" :depends-on ("package" "util")) (:file "file-types" :depends-on ("package" "icons" "util")) (:file "dev-commands" :depends-on ("package" "icons" "file-types" "util")) (:file "listener" :depends-on ("package" "file-types" "icons" "dev-commands" "util")) #+CMU (:file "cmu-hacks" :depends-on ("package"))))))--- /project/mcclim/cvsroot/mcclim/clouseau.asd 2007/01/18 15:01:11 NONE +++ /project/mcclim/cvsroot/mcclim/clouseau.asd 2007/01/18 15:01:11 1.1 ;;; -*- lisp -*- (defpackage :clouseau.system (:use :cl :asdf)) (in-package :clouseau.system) (defsystem :clouseau :depends-on (:mcclim) :serial t :components ((:module "Apps/Inspector" :pathname #.(make-pathname :directory '(:relative "Apps" "Inspector")) :components ((:file "package") (:file "disassembly" :depends-on ("package")) (:file "inspector" :depends-on ("disassembly"))))))--- /project/mcclim/cvsroot/mcclim/scigraph.asd 2007/01/18 15:01:11 NONE +++ /project/mcclim/cvsroot/mcclim/scigraph.asd 2007/01/18 15:01:11 1.1 ;;; -*- lisp -*- (defpackage :scigraph.system (:use :cl :asdf)) (in-package :scigraph.system) ;;; This won't load in SBCL, either. I have really crappy code to ;;; extract dependency information from :serial t ASDF systems, but ;;; this comment is too narrow to contain it. (defsystem :scigraph :depends-on (:mcclim) ;; The DWIM part of SCIGRAPH :serial t :components ( (:file "Apps/Scigraph/dwim/package") (:file "Apps/Scigraph/dwim/feature-case") (:file "Apps/Scigraph/dwim/macros") (:file "Apps/Scigraph/dwim/tv") (:file "Apps/Scigraph/dwim/draw") (:file "Apps/Scigraph/dwim/present") (:file "Apps/Scigraph/dwim/extensions") (:file "Apps/Scigraph/dwim/wholine") (:file "Apps/Scigraph/dwim/export") ;; The Scigraph part (:file "Apps/Scigraph/scigraph/package") (:file "Apps/Scigraph/scigraph/copy") (:file "Apps/Scigraph/scigraph/dump") (:file "Apps/Scigraph/scigraph/duplicate") (:file "Apps/Scigraph/scigraph/random") (:file "Apps/Scigraph/scigraph/menu-tools") (:file "Apps/Scigraph/scigraph/basic-classes") (:file "Apps/Scigraph/scigraph/draw") (:file "Apps/Scigraph/scigraph/mouse") (:file "Apps/Scigraph/scigraph/color") (:file "Apps/Scigraph/scigraph/basic-graph") (:file "Apps/Scigraph/scigraph/graph-mixins") (:file "Apps/Scigraph/scigraph/axis") (:file "Apps/Scigraph/scigraph/moving-object") (:file "Apps/Scigraph/scigraph/symbol") (:file "Apps/Scigraph/scigraph/graph-data") (:file "Apps/Scigraph/scigraph/legend") (:file "Apps/Scigraph/scigraph/graph-classes") (:file "Apps/Scigraph/scigraph/present") (:file "Apps/Scigraph/scigraph/annotations") (:file "Apps/Scigraph/scigraph/annotated-graph") (:file "Apps/Scigraph/scigraph/contour") (:file "Apps/Scigraph/scigraph/equation") (:file "Apps/Scigraph/scigraph/popup-accept") (:file "Apps/Scigraph/scigraph/popup-accept-methods") (:file "Apps/Scigraph/scigraph/duplicate-methods") (:file "Apps/Scigraph/scigraph/frame") (:file "Apps/Scigraph/scigraph/export") (:file "Apps/Scigraph/scigraph/demo-frame")))--- /project/mcclim/cvsroot/mcclim/symlink-asd-files.sh 2007/01/18 15:01:11 NONE +++ /project/mcclim/cvsroot/mcclim/symlink-asd-files.sh 2007/01/18 15:01:11 1.1 #!/bin/sh -e # (Re-)Installs the top-level .asd files into an # asdf:*central-registry* directory. Prompts before overwriting # anything. CENTRAL_REG="$1" if [ -z "$CENTRAL_REG" ] ; then echo "USAGE: $0 central-registry-dir" 2>&1 echo " central-registry-dir is a directory where asdf looks for .asd files." 2>&1 echo " e.g. on SBCL, this could be ~/.sbcl/systems/" 2>&1 exit 1 fi cd "`dirname $0`" for i in *.asd ; do if [ -e "$CENTRAL_REG"/"$i" ]; then echo -en "Warning: overwriting $CENTRAL_REG/$i with link to \n`pwd`/$i (press RET to continue)" 2>&1 read fi ln -sf "`pwd`/$i" "$CENTRAL_REG"/"$i" done From thenriksen at common-lisp.net Sun Jan 21 23:07:45 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 21 Jan 2007 18:07:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070121230745.E238C4D04D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3729/Drei Modified Files: lisp-syntax.lisp Log Message: Delete, not kill, the symbol to be replaced when doing symbol-completion. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/17 13:31:50 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/21 23:07:45 1.19 @@ -1736,7 +1736,7 @@ after `string'." (let ((token (symbol-at-mark mark syntax))) (setf (offset mark) (start-offset token)) - (forward-kill-expression mark syntax) + (forward-delete-expression mark syntax) (insert-sequence mark string))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From thenriksen at common-lisp.net Mon Jan 22 11:37:12 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 22 Jan 2007 06:37:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070122113712.5C02D710D2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv2622/Doc Modified Files: drei.texi Log Message: Fixed grammar mistake. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/01/14 08:38:33 1.6 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/01/22 11:37:12 1.7 @@ -32,7 +32,7 @@ passively being fed gestures in the input editor, to having to do event handling and redisplay timing manually in the gadget version. Furthermore, Drei is extensible software, so we wished to make -the differences between these three modus operandorum transparent to the +the differences between these three modi operandi transparent to the extender (as much as possible at least, unfortunately the Law of Leaky Abstractions prevents us from reaching perfection). These two demands require the core Drei protocols, especially those pertaining to From ahefner at common-lisp.net Tue Jan 23 07:51:11 2007 From: ahefner at common-lisp.net (ahefner) Date: Tue, 23 Jan 2007 02:51:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070123075111.15AB738013@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21411 Modified Files: panes.lisp Log Message: Fix typo in note-space-requirements-changed which caused unnecessary scrolling. For reference, restored the original scroll-extent call as a comment. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/01/07 19:53:05 1.177 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/01/23 07:51:10 1.178 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.177 2007/01/07 19:53:05 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.178 2007/01/23 07:51:10 ahefner Exp $ (in-package :clim-internals) @@ -1869,16 +1869,28 @@ ;; XXX: We cannot use `scroll-extent', because McCLIM ignores it ;; unless the scrollee happens to be drawing. Very weird, should ;; be fixed. + + ;; It's not a bug, it's a feature. This requires further thought. -Hefner (move-sheet child (round (- (if (> (+ horizontal-scroll viewport-width) child-width) (- child-width viewport-width) horizontal-scroll))) (round (- (if (> (+ vertical-scroll viewport-height) - child-width) + child-height) (- child-height viewport-height) vertical-scroll)))) - (scroller-pane/update-scroll-bars (sheet-parent pane))))) + (scroller-pane/update-scroll-bars (sheet-parent pane)) + #+NIL + (scroll-extent child + (if (> (+ horizontal-scroll viewport-width) + child-width) + (max 0 (- child-width viewport-width)) + horizontal-scroll) + (if (> (+ vertical-scroll viewport-height) + child-height) + (max 0 (- child-height viewport-height)) + vertical-scroll))))) ;;;; ;;;; SCROLLER PANE @@ -2090,6 +2102,8 @@ (setq viewport (first (sheet-children pane))) ;; make the background of the viewport match the background of the ;; things scrolled. + ;; This doesn't appear to work, hence the "gray space" bugs. Actually + ;; handy for observing when the space requirements get messed up.. -Hefner (when (first (sheet-children viewport)) (setf (slot-value pane 'background) ;### hmm ... (pane-background (first (sheet-children viewport))))) @@ -2487,7 +2501,7 @@ (flet ((compute (val default) (if (eq val :compute) default val))) (if (or (eq (pane-user-width pane) :compute) - (eq (pane-user-height pane) :compute)) + (eq (pane-user-height pane) :compute)) (progn (with-output-recording-options (pane :record t :draw nil) ;; multiple-value-letf anyone? @@ -2500,7 +2514,7 @@ (stream-output-history pane) ;; Should we now get rid of the output history? ;; Why should we? --GB 2003-03-16 - (reset-output-history pane) + (reset-output-history pane) (let ((width (- x2 x1)) (height (- y2 y1))) ;; I don't want this letf here --GB 2003-01-23 From thenriksen at common-lisp.net Wed Jan 24 10:57:24 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 24 Jan 2007 05:57:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070124105724.C297E59001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10259 Modified Files: drei-redisplay.lisp Log Message: Try to minimize the amount of calls to `change-space-requirements'. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/19 11:39:44 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/01/24 10:57:24 1.6 @@ -416,20 +416,30 @@ (defgeneric fix-pane-viewport (pane)) (defmethod fix-pane-viewport ((pane drei-pane)) - (let ((output-width (bounding-rectangle-width (stream-current-output-record pane)))) - (change-space-requirements pane :width output-width)) - (when (and (pane-viewport pane) (active pane)) - (multiple-value-bind (cursor-x cursor-y) (offset-to-screen-position pane pane (offset (point pane))) - (declare (ignore cursor-y)) - (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) - (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) - (cond ((> cursor-x (+ x-position viewport-width)) - (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) - ((> x-position cursor-x) - (move-sheet pane (if (> viewport-width cursor-x) - 0 - (round (- cursor-x))) - 0))))))) + (let* ((output-width (bounding-rectangle-width (stream-current-output-record pane))) + (viewport (pane-viewport pane)) + (viewport-width (and viewport (bounding-rectangle-width viewport))) + (pane-width (bounding-rectangle-width pane))) + ;; If the width of the output is greater than the width of the + ;; sheet, make the sheet wider. If the sheet is wider than the + ;; viewport, but doesn't really need to be, make it thinner. + (when (or (> output-width pane-width) + (and viewport + (> pane-width viewport-width) + (>= viewport-width output-width))) + (change-space-requirements pane :width output-width)) + (when (and viewport (active pane)) + (multiple-value-bind (cursor-x cursor-y) (offset-to-screen-position pane pane (offset (point pane))) + (declare (ignore cursor-y)) + (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0))) + (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane)))) + (cond ((> cursor-x (+ x-position viewport-width)) + (move-sheet pane (round (- (- cursor-x viewport-width))) 0)) + ((> x-position cursor-x) + (move-sheet pane (if (> viewport-width cursor-x) + 0 + (round (- cursor-x))) + 0)))))))) (defmethod handle-repaint :before ((pane drei-pane) region) (declare (ignore region)) From thenriksen at common-lisp.net Wed Jan 31 14:31:59 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 31 Jan 2007 09:31:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070131143159.AD0934B000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv10820/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Handle vector and array forms better. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/01/15 22:13:15 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/01/31 14:31:59 1.3 @@ -254,7 +254,15 @@ collecting x) (is (string= (symbol-name a) "NIL")) (is (string= (symbol-name b) "nil")) - (is (string= (symbol-name c) "Nil"))))) + (is (string= (symbol-name c) "Nil")))) + (testing-lisp-syntax ("#(a b c c c c)") + (is (equalp (get-object) #6(a b c c c c)))) + (testing-lisp-syntax ("#6(a b c c c c)") + (is (equalp (get-object) #6(a b c c c c)))) + (testing-lisp-syntax ("#6(a b c)") + (is (equalp (get-object) #6(a b c c c c)))) + (testing-lisp-syntax ("#6(a b c c)") + (is (equalp (get-object) #6(a b c c c c))))) (test form-to-object-12 (testing-lisp-syntax ("(t . t)") @@ -389,6 +397,18 @@ (signals form-conversion-error (get-object)))) +(test form-to-object-18 + (testing-lisp-syntax ("#2A((0 1 5) (foo 2 (hot dog)))") + (is (equalp (get-object) #2A((0 1 5) (foo 2 (hot dog)))))) + (testing-lisp-syntax ("#2A((0 1) (foo 2 (hot dog)))") + (signals form-conversion-error (get-object))) + (testing-lisp-syntax ("#1A((0 1 5) (foo 2 (hot dog)))") + (is (equalp (get-object) #1A((0 1 5) (foo 2 (hot dog)))))) + (testing-lisp-syntax ("#0Anil") + (is (equalp (get-object) #0Anil))) + (testing-lisp-syntax ("#0A#2A((0 1 5) (foo 2 (hot dog)))") + (is (equalp (get-object) #0A#2A((0 1 5) (foo 2 (hot dog))))))) + (defgeneric find-pathnames (module) (:documentation "Get a list of the pathnames of the files making up an ASDF module/system/component.") From thenriksen at common-lisp.net Wed Jan 31 14:31:59 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 31 Jan 2007 09:31:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070131143159.032404C00A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10820 Modified Files: lisp-syntax.lisp Log Message: Handle vector and array forms better. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/21 23:07:45 1.19 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/01/31 14:31:59 1.20 @@ -2835,12 +2835,19 @@ (setf (clim-mop:slot-value-using-class class tree slotd) new))))))) - ((arrayp tree) + ((vectorp tree) (loop for i from 0 below (length tree) do (let* ((old (aref tree i)) (new (circle-subst old-new-alist old))) (unless (eq old new) (setf (aref tree i) new))))) + ((arrayp tree) + (loop with array-size = (array-total-size tree) + for i from 0 below array-size do + (let* ((old (row-major-aref tree i)) + (new (circle-subst old-new-alist old))) + (unless (eq old new) + (setf (row-major-aref tree i) new))))) (t (let ((a (circle-subst old-new-alist (car tree))) (d (circle-subst old-new-alist (cdr tree)))) @@ -3015,7 +3022,18 @@ (defmethod form-to-object ((syntax lisp-syntax) (form simple-vector-form) &key &allow-other-keys) - (apply #'vector (call-next-method))) + (let* ((contents (call-next-method)) + (lexeme-string (form-string syntax (first (children form)))) + (size (parse-integer lexeme-string :start 1 + :end (1- (length lexeme-string)) + :junk-allowed t)) + (vector (make-array (or size (length contents))))) + (loop for cons = contents then (or rest cons) + for element = (first cons) + for rest = (rest cons) + for i below (length vector) do + (setf (aref vector i) element) + finally (return vector)))) (defmethod form-to-object ((syntax lisp-syntax) (form incomplete-string-form) &key &allow-other-keys) @@ -3105,6 +3123,26 @@ &rest args) (apply #'label-placeholder syntax form (extract-label syntax form) t args)) +(defmethod form-to-object ((syntax lisp-syntax) (form array-form) + &rest args) + (let* ((rank-string (form-string syntax (first (children form)))) + (rank (parse-integer rank-string :start 1 + :end (1- (length rank-string)))) + (array-contents (apply #'form-to-object syntax (second (children form)) args))) + (labels ((dimensions (rank contents) + (cond ((= rank 0) + nil) + ((= rank 1) + (list (length contents))) + (t + (let ((goal (dimensions (1- rank) (first contents)))) + (dolist (element (rest contents)) + (unless (equal goal (dimensions (1- rank) element)) + (form-conversion-error syntax form "jagged multidimensional array"))) + (cons (length contents) goal)))))) + (make-array (dimensions rank array-contents) + :initial-contents array-contents)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Arglist fetching.