[climacs-cvs] CVS climacs
tmoore
tmoore at common-lisp.net
Fri Mar 3 19:38:58 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv24197
Modified Files:
cl-syntax.lisp climacs.asd developer-commands.lisp esa.lisp
file-commands.lisp gui.lisp io.lisp kill-ring.lisp
misc-commands.lisp packages.lisp pane.lisp prolog-syntax.lisp
slidemacs-gui.lisp slidemacs.lisp ttcn3-syntax.lisp
window-commands.lisp
Added Files:
colors.lisp
Log Message:
Changes for running climacs in Allegro Common Lisp with Classic CLIM (tm). This includes a bunch of modern mode-related changes to symbol names and creating symbols and reordering of syntax rules definitions due to different compile-time behavior of defclass. The CLIM changes are suprisingly small
--- /project/climacs/cvsroot/climacs/cl-syntax.lisp 2005/11/12 09:34:34 1.16
+++ /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/03/03 19:38:57 1.17
@@ -401,6 +401,17 @@
item) 2))))
:start start :item item))
+(defclass simple-number (cl-item) ())
+
+(add-cl-rule (simple-number -> ((item default-item (radix-is
+ (coerce
+ (item-sequence item) 'string) 10)))
+ :item item))
+
+(defmethod display-parse-tree ((entity simple-number) (syntax cl-syntax) pane)
+ (with-slots (item) entity
+ (display-parse-tree item syntax pane)))
+
(defclass radix-n-expr (cl-entry)
((start :initarg :start)
(radix :initarg :radix)
@@ -426,18 +437,6 @@
(display-parse-tree radix syntax pane)
(display-parse-tree item syntax pane)))
-(defclass simple-number (cl-item) ())
-
-(add-cl-rule (simple-number -> ((item default-item (radix-is
- (coerce
- (item-sequence item) 'string) 10)))
- :item item))
-
-(defmethod display-parse-tree ((entity simple-number) (syntax cl-syntax) pane)
- (with-slots (item) entity
- (display-parse-tree item syntax pane)))
-
-
(defclass real-number (cl-entry)
((primary :initarg :primary)
(separator :initarg :separator)
@@ -587,6 +586,10 @@
(display-parse-tree item syntax pane))))
+
+(define-list cl-terminals empty-cl-terminals
+ nonempty-cl-terminals cl-terminal)
+
;;;;;;;;;;;;; list-expression
(defclass list-expr (cl-entry)
@@ -716,6 +719,11 @@
(expr cl-terminal (/= (end-offset test) (start-offset expr))))
:start start :test test :expr expr))
+;;; Avoid forward definition
+
+(defclass quoted-expr (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
;;;;;;;;;;;;; function-expression
@@ -775,10 +783,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Quoted expr
-(defclass quoted-expr (cl-entry)
- ((start :initarg :start)
- (item :initarg :item)))
-
(add-cl-rule (quoted-expr -> ((start quote-symbol)
(item cl-terminal))
:start start :item item))
@@ -884,6 +888,11 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Backquoted expr
+;;; Avoid forward definition
+(defclass unquoted-expr (cl-entry)
+ ((start :initarg :start)
+ (item :initarg :item)))
+
(defclass backquoted-expr (cl-entry)
((start :initarg :start)
(item :initarg :item)))
@@ -917,10 +926,6 @@
(display-parse-tree start syntax pane)
(display-parse-tree end syntax pane)))
-(defclass unquoted-expr (cl-entry)
- ((start :initarg :start)
- (item :initarg :item)))
-
(add-cl-rule (unquoted-expr -> ((start comma)
(item identifier))
:start start :item item))
@@ -965,9 +970,6 @@
(add-cl-rule (cl-terminal -> (read-time-evaluation) :item read-time-evaluation))
(add-cl-rule (cl-terminal -> (line-comment) :item line-comment))
-(define-list cl-terminals empty-cl-terminals
- nonempty-cl-terminals cl-terminal)
-
(defmethod display-parse-tree ((entity cl-terminal) (syntax cl-syntax) pane)
(with-slots (item) entity
(display-parse-tree item syntax pane)))
@@ -1048,11 +1050,25 @@
(when (and (end-offset entity) (mark> (end-offset entity) top))
(call-next-method))))
+(defun color-equal (c1 c2)
+ (when (eq c1 c2)
+ (return-from color-equal t))
+ (when (or (eq c1 +foreground-ink+)
+ (eq c2 +foreground-ink+)
+ (eq c1 +background-ink+)
+ (eq c2 +background-ink+))
+ (return-from color-equal nil))
+ (multiple-value-bind (r1 g1 b1)
+ (color-rgb c1)
+ (multiple-value-bind (r2 g2 b2)
+ (color-rgb c2)
+ (and (= r1 r2) (= g1 g2) (= b1 b2)))))
+
(defmethod display-parse-tree ((entity cl-entry) (syntax cl-syntax) pane)
(flet ((cache-test (t1 t2)
(and (eq t1 t2)
- (eq (slot-value t1 'ink)
- (medium-ink (sheet-medium pane)))
+ (color-equal (slot-value t1 'ink)
+ (medium-ink (sheet-medium pane)))
(eq (slot-value t1 'face)
(text-style-face (medium-text-style (sheet-medium pane)))))))
(updating-output (pane :unique-id entity
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/02/07 15:21:30 1.41
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/03/03 19:38:57 1.42
@@ -68,12 +68,16 @@
(:file "html-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
(:file "prolog-syntax" :depends-on ("packages" "base" "syntax" "pane" "buffer"))
(:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
- (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
- (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" "gui"))
+ (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base"
+ "pane"))
+ (:file "colors" :depends-on ("packages"))
+ (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane"
+ "gui" "colors"))
(:file "lisp-syntax-commands" :depends-on ("lisp-syntax"))
- (:file "esa" :depends-on ("packages"))
+ (:file "esa" :depends-on ("packages" "colors"))
(:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane"
- "esa" "kill-ring" "io" "text-syntax" "abbrev"))
+ "esa" "kill-ring" "io" "text-syntax"
+ "abbrev" "colors"))
;; (:file "buffer-commands" :depends-on ("gui"))
(:file "developer-commands" :depends-on ("gui" "lisp-syntax"))
(:file "file-commands" :depends-on ("gui"))
@@ -81,7 +85,7 @@
(:file "search-commands" :depends-on ("gui"))
(:file "window-commands" :depends-on ("gui"))
(:file "unicode-commands" :depends-on ("gui"))
- (:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane"))
+ (:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane" "colors"))
(:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax" "gui"))))
(defsystem :climacs.tests
--- /project/climacs/cvsroot/climacs/developer-commands.lisp 2005/11/12 09:38:32 1.1
+++ /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/03/03 19:38:57 1.2
@@ -40,7 +40,7 @@
(asdf:operate 'asdf:load-op :climacs))
-(define-gesture-name :select-other :pointer-button-press (:left :meta) :unique nil)
+(define-gesture-name :select-other #+mcclim :pointer-button-press #-mcclim :pointer-button (:left :meta) :unique nil)
(define-presentation-translator lisp-string-to-string
(climacs-lisp-syntax::lisp-string string development-table
--- /project/climacs/cvsroot/climacs/esa.lisp 2006/02/25 10:19:24 1.26
+++ /project/climacs/cvsroot/climacs/esa.lisp 2006/03/03 19:38:57 1.27
@@ -103,6 +103,19 @@
(command-table-inherit-from
(find-command-table start-table)))))
+;;; In Classic CLIM event-matches-gesture-name-p doesn't accept characters.
+#+mcclim
+(defun gesture-matches-gesture-name-p (gesture gesture-name)
+ (event-matches-gesture-name-p gesture gesture-name))
+
+#-mcclim
+(defun gesture-matches-gesture-name-p (gesture gesture-name)
+ (etypecase gesture
+ (event
+ (event-matches-gesture-name-p gesture gesture-name))
+ (character
+ (clim-internals::keyboard-event-matches-gesture-name-p gesture
+ gesture-name))))
(defparameter *current-gesture* nil)
(defparameter *meta-digit-table*
@@ -111,7 +124,7 @@
(defun meta-digit (gesture)
(position gesture *meta-digit-table*
- :test #'event-matches-gesture-name-p))
+ :test #'gesture-matches-gesture-name-p))
(defun esa-read-gesture ()
(unless (null (remaining-keys *application-frame*))
@@ -159,11 +172,11 @@
M-1 M-2 = 12. M-- M-1 M-2 = -12. As a special case, C-u - and M-- = -1.
In the absence of a prefix arg returns 1 (and nil)."
(let ((gesture (esa-read-gesture)))
- (cond ((event-matches-gesture-name-p
+ (cond ((gesture-matches-gesture-name-p
gesture 'universal-argument)
(let ((numarg 4))
(loop for gesture = (esa-read-gesture)
- while (event-matches-gesture-name-p
+ while (gesture-matches-gesture-name-p
gesture 'universal-argument)
do (setf numarg (* 4 numarg))
finally (esa-unread-gesture gesture stream))
@@ -187,7 +200,7 @@
(esa-unread-gesture gesture stream)
(values (if (minusp sign) -1 numarg) t))))))
((or (meta-digit gesture)
- (event-matches-gesture-name-p
+ (gesture-matches-gesture-name-p
gesture 'meta-minus))
(let ((numarg 0)
(sign +1))
@@ -281,6 +294,8 @@
(*standard-input* (frame-standard-input frame))
(*print-pretty* nil)
(*abort-gestures* `((:keyboard #\g ,(make-modifier-state :control)))))
+ (unless (eq (frame-state frame) :enabled)
+ (enable-frame frame))
(redisplay-frame-panes frame :force-p t)
(loop
do (restart-case
@@ -327,6 +342,35 @@
;;;
;;; command table manipulation
+;;; Helper to avoid calling find-keystroke-item at load time. In Classic CLIM
+;;; that function doesn't work if not connected to a port.
+
+(defun compare-gestures (g1 g2)
+ (and (eql (car g1) (car g2))
+ (eql (apply #'make-modifier-state (cdr g1))
+ (apply #'make-modifier-state (cdr g2)))))
+
+(defun find-gesture-item (table gesture)
+ (map-over-command-table-keystrokes
+ (lambda (name gest item)
+ (declare (ignore name))
+ (when (compare-gestures gesture gest)
+ (return-from find-gesture-item item)))
+ table)
+ nil)
+
+#-mcclim
+(defun ensure-subtable (table gesture)
+ (let ((item (find-gesture-item table gesture)))
+ (when (or (null item) (not (eq (command-menu-item-type item) :menu)))
+ (let ((name (gensym)))
+ (make-command-table name :errorp nil)
+ (add-menu-item-to-command-table table (symbol-name name)
+ :menu name
+ :keystroke gesture)))
+ (command-menu-item-value (find-gesture-item table gesture))))
+
+#+mcclim
(defun ensure-subtable (table gesture)
(let* ((event (make-instance
'key-press-event
@@ -342,14 +386,16 @@
:keystroke gesture)))
(command-menu-item-value
(find-keystroke-item event table :errorp nil))))
-
+
(defun set-key (command table gestures)
+ ;; WTF?
+ #-(and)
(unless (consp command)
(setf command (list command)))
(let ((gesture (car gestures)))
(cond ((null (cdr gestures))
- (add-command-to-command-table
- command table :keystroke gesture :errorp nil)
+ (add-keystroke-to-command-table
+ table gesture :command command :errorp nil)
(when (and (listp gesture)
(find :meta gesture))
;; KLUDGE: this is a workaround for poor McCLIM
@@ -587,7 +633,9 @@
(let* ((window (car (windows *application-frame*)))
(stream (open-window-stream
:label (format nil "Help: Describe Bindings")
- :input-buffer (climi::frame-event-queue *application-frame*)
+ :input-buffer (#+mcclim climi::frame-event-queue
+ #-mcclim silica:frame-input-buffer
+ *application-frame*)
:width 400))
(command-table (command-table window)))
(describe-bindings stream command-table
@@ -700,3 +748,4 @@
(define-command-table global-example-table
:inherit-from (global-esa-table keyboard-macro-table))
+
--- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/01/21 20:38:50 1.2
+++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/03/03 19:38:57 1.3
@@ -107,7 +107,7 @@
#'filename-completer
:allow-any-input t)
(cond (success
- (values pathname type))
+ (values (or pathname (parse-namestring string)) type))
((and (zerop (length string))
defaultp)
(values default default-type))
@@ -328,7 +328,7 @@
'buffer-table
'((#\x :control) (#\s :control)))
-(defmethod frame-exit :around ((frame climacs))
+(defmethod frame-exit :around ((frame climacs) #-mcclim &key)
(loop for buffer in (buffers frame)
when (and (needs-saving buffer)
(filepath buffer)
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/02/25 10:19:09 1.203
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/03/03 19:38:57 1.204
@@ -45,7 +45,7 @@
nil)
(defmethod buffer-pane-p ((pane extended-pane))
- T)
+ t)
(defclass climacs-info-pane (info-pane)
()
@@ -163,7 +163,10 @@
extended-pane)
extended-pane)
info-pane)))
- (minibuffer (make-pane 'climacs-minibuffer-pane :background *mini-bg-color* :foreground *mini-fg-color* :width 900)))
+ (minibuffer (make-pane 'climacs-minibuffer-pane
+ :background *mini-bg-color*
+ :foreground *mini-fg-color*
+ :width 900)))
(:layouts
(default
(vertically (:scroll-bars nil)
@@ -171,6 +174,9 @@
minibuffer)))
(:top-level (esa-top-level)))
+(defmethod frame-standard-input ((frame climacs))
+ (get-frame-pane frame 'minibuffer))
+
(defun current-window ()
(car (windows *application-frame*)))
--- /project/climacs/cvsroot/climacs/io.lisp 2004/12/28 06:58:36 1.3
+++ /project/climacs/cvsroot/climacs/io.lisp 2006/03/03 19:38:57 1.4
@@ -24,7 +24,8 @@
(defun input-from-stream (stream buffer offset)
(loop with vec = (make-array 10000 :element-type 'character)
- for count = (read-sequence vec stream)
+ for count = (#+mcclim read-sequence #-mcclim cl:read-sequence
+ vec stream)
while (plusp count)
do (if (= count (length vec))
(insert-buffer-sequence buffer offset vec)
--- /project/climacs/cvsroot/climacs/kill-ring.lisp 2005/08/14 18:09:42 1.8
+++ /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/03/03 19:38:57 1.9
@@ -148,6 +148,6 @@
vector
(pop-start chain))))))
-(defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL))
+(defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil))
(if reset (reset-yank-position kr))
(element> (kill-ring-cursor kr)))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/02/07 15:21:30 1.3
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/03/03 19:38:57 1.4
@@ -205,7 +205,7 @@
(set-key `(com-backward-object ,*numeric-argument-marker*)
'movement-table
- '((:left)))
+ '((#+mcclim :left #-mcclim :left-arrow)))
(define-command (com-forward-object :name t :command-table movement-table)
((count 'integer :prompt "Number of Objects"))
@@ -217,7 +217,7 @@
(set-key `(com-forward-object ,*numeric-argument-marker*)
'movement-table
- '((:right)))
+ '((#+mcclim :right #-mcclim :right-arrow)))
(defun transpose-words (mark)
(let (bw1 bw2 ew1 ew2)
@@ -295,7 +295,7 @@
(set-key `(com-previous-line ,*numeric-argument-marker*)
'movement-table
- '((:up)))
+ '((#+mcclim :up #-mcclim :up-arrow)))
(define-command (com-next-line :name t :command-table movement-table)
((numarg 'integer :prompt "How many lines?"))
@@ -314,7 +314,7 @@
(set-key `(com-next-line ,*numeric-argument-marker*)
'movement-table
- '((:down)))
+ '((#+mcclim :down #-mcclim :down-arrow)))
(define-command (com-open-line :name t :command-table editing-table)
((numarg 'integer :prompt "How many lines?"))
@@ -376,7 +376,7 @@
(set-key `(com-forward-word ,*numeric-argument-marker*)
'movement-table
- '((:right :control)))
+ '((#+mcclim :right #-mcclim :right-arrow :control)))
(define-command (com-backward-word :name t :command-table movement-table)
((count 'integer :prompt "Number of words"))
@@ -388,7 +388,7 @@
(set-key `(com-backward-word ,*numeric-argument-marker*)
'movement-table
- '((:left :control)))
+ '((#+mcclim :left #-mcclim :left-arrow :control)))
(define-command (com-delete-word :name t :command-table deletion-table)
((count 'integer :prompt "Number of words"))
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/02/07 15:21:30 1.84
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/03/03 19:38:57 1.85
@@ -161,8 +161,21 @@
#:url
#:climacs-textual-view #:+climacs-textual-view+))
-(defpackage :esa
+#-mcclim
+(defpackage :clim-extensions
(:use :clim-lisp :clim)
+ (:export
+ #:+blue-violet+
+ #:+dark-blue+
+ #:+dark-green+
+ #:+dark-violet+
+ #:+gray50+
+ #:+gray85+
+ #:+maroon+
+ #:+purple+))
+
+(defpackage :esa
+ (:use :clim-lisp :clim :clim-extensions)
(:export #:minibuffer-pane #:display-message
#:esa-pane-mixin #:previous-command
#:info-pane #:master-pane
@@ -175,7 +188,8 @@
#:find-applicable-command-table))
(defpackage :climacs-gui
- (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ :climacs-abbrev :climacs-syntax
:climacs-kill-ring :climacs-pane :clim-extensions :undo :esa)
;;(:import-from :lisp-string)
(:export :climacs ; Main entry point.
@@ -198,7 +212,7 @@
(defpackage :climacs-prolog-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane)
- (:shadow "ATOM" "CLOSE" "EXP" "INTEGER" "OPEN" "VARIABLE"))
+ (:shadow #:atom #:close #:exp #:integer #:open #:variable))
(defpackage :climacs-cl-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base
@@ -206,7 +220,7 @@
(:export))
(defpackage :climacs-lisp-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane :climacs-gui)
(:export :lisp-string))
--- /project/climacs/cvsroot/climacs/pane.lisp 2005/12/05 09:55:18 1.34
+++ /project/climacs/cvsroot/climacs/pane.lisp 2006/03/03 19:38:57 1.35
@@ -300,12 +300,23 @@
(with-slots (buffer top bot scan) pane
(setf top (clone-mark (low-mark buffer) :left)
bot (clone-mark (high-mark buffer) :right)))
+ #-(and)
(with-slots (space-width tab-width) (stream-default-view pane)
(let* ((medium (sheet-medium pane))
(style (medium-text-style medium)))
(setf space-width (text-style-width style medium)
tab-width (* 8 space-width)))))
+(defmethod note-sheet-grafted :around ((pane climacs-pane))
+ (call-next-method)
+ (with-slots (space-width tab-width) (stream-default-view pane)
+ (let ((medium (sheet-medium pane)))
+ (setf (medium-text-style medium) (medium-default-text-style medium))
+ (let ((style (medium-text-style medium)))
+ (setf space-width (text-style-width style medium)
+ tab-width (* 8 space-width))))))
+
+
(defmethod (setf buffer) :after (buffer (pane climacs-pane))
(with-slots (point mark top bot) pane
(setf point (clone-mark (point buffer))
--- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2005/11/01 12:31:52 1.25
+++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/03/03 19:38:57 1.26
@@ -21,7 +21,7 @@
;;; Syntax for analysing ISO Prolog
-(in-package "CLIMACS-PROLOG-SYNTAX")
+(in-package #:climacs-prolog-syntax)
(defclass prolog-parse-tree (parse-tree)
())
@@ -94,7 +94,7 @@
(defmethod syntactic-lexeme ((lexeme prolog-lexeme))
lexeme)
(macrolet ((def ((name &optional tokenp) &rest subs)
- (flet ((f (x) (intern (format nil "~A-LEXEME" x))))
+ (flet ((f (x) (intern (format nil "~A-~A" x '#:lexeme))))
`(progn
(defclass ,(f name) (prolog-lexeme) ())
--- /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2005/10/31 13:42:31 1.21
+++ /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2006/03/03 19:38:57 1.22
@@ -403,7 +403,7 @@
(defparameter *picture-cache*
(make-hash-table :test #'equal))
-#+(or)
+#+mcclim
(defun load-and-cache-xpm (pathname)
nil
(let ((hash-key (cons pathname (file-write-date pathname))))
@@ -412,7 +412,7 @@
(setf (gethash hash-key *picture-cache*)
(climi::xpm-parse-file pathname))))))
-#+(or)
+#+mcclim
(defmethod display-parse-tree ((entity picture-node) (syntax slidemacs-gui-syntax) pane)
(with-slots (picture-pathname) entity
(let ((real-pathname (slidemacs-entity-string picture-pathname)))
--- /project/climacs/cvsroot/climacs/slidemacs.lisp 2005/08/15 23:31:22 1.7
+++ /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/03/03 19:38:57 1.8
@@ -21,7 +21,7 @@
;;; Boston, MA 02111-1307 USA.
(defpackage :climacs-slidemacs-editor
- (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane)
(:export))
@@ -168,6 +168,23 @@
(string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
string))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun sort-definitions (forms)
+ (loop for form in forms
+ for name = (and (consp form) (car form))
+ if (eq name 'defclass)
+ collect form into defclasses
+ else if (eq name 'define-simple-list)
+ collect form into simple-lists
+ else if (eq name 'define-simple-nonempty-list)
+ collect form into nonempty-lists
+ else collect form into others
+ end
+ finally (return `(, at defclasses
+ , at simple-lists
+ , at nonempty-lists
+ , at others)))))
+
(defmacro define-parsing-rules ((grammar entry terminal syntax) &body rules)
(let (already-processed-rules)
(flet
@@ -220,17 +237,10 @@
entity
,@(loop for component in rule-body collect
`(display-parse-tree ,component syntax pane))))))
- (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body name))))
- (shake-up-defclasses (forms)
- (append
- (remove-if #'(lambda (e)
- (and (consp e)
- (not (eq (car e) 'defclass)))) forms)
- (remove-if #'(lambda (e)
- (and (consp e)
- (eq (car e) 'defclass))) forms))))
+ (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body
+ name)))))
`(progn
- ,@(shake-up-defclasses
+ ,@(sort-definitions
(loop for rule in rules
appending (destructuring-bind (=-thingy rule-name &body rule-body)
rule
--- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2005/08/15 23:31:22 1.3
+++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/03/03 19:38:57 1.4
@@ -21,7 +21,7 @@
;;; Boston, MA 02111-1307 USA.
(defpackage :climacs-ttcn3-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
:climacs-syntax :flexichain :climacs-pane)
(:export))
(in-package :climacs-ttcn3-syntax)
@@ -183,6 +183,23 @@
(string-equal (coerce (buffer-sequence (buffer word) (start-offset word) (end-offset word)) 'string)
string))
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun sort-definitions (forms)
+ (loop for form in forms
+ for name = (and (consp form) (car form))
+ if (eq name 'defclass)
+ collect form into defclasses
+ else if (eq name 'define-simple-list)
+ collect form into simple-lists
+ else if (eq name 'define-simple-nonempty-list)
+ collect form into nonempty-lists
+ else collect form into others
+ end
+ finally (return `(, at defclasses
+ , at simple-lists
+ , at nonempty-lists
+ , at others)))))
+
(defmacro define-parsing-rules ((grammar entry terminal syntax) &body rules)
(let (already-processed-rules)
(flet
@@ -235,17 +252,10 @@
entity
,@(loop for component in rule-body collect
`(display-parse-tree ,component syntax pane))))))
- (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body name))))
- (shake-up-defclasses (forms)
- (append
- (remove-if #'(lambda (e)
- (and (consp e)
- (not (eq (car e) 'defclass)))) forms)
- (remove-if #'(lambda (e)
- (and (consp e)
- (eq (car e) 'defclass))) forms))))
+ (t (error "Unrecognized rule body ~S for rule ~S~%" rule-body
+ name)))))
`(progn
- ,@(shake-up-defclasses
+ ,@(sort-definitions
(loop for rule in rules
appending (destructuring-bind (=-thingy rule-name &body rule-body)
rule
--- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/01/09 04:15:12 1.4
+++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/03/03 19:38:57 1.5
@@ -43,7 +43,7 @@
(parent-height (rectangle-height parent-region))
(parent-width (rectangle-width parent-region))
(filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing.
- (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
+ (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget)))
(assert (member constellation children))
(when first-split-p (setf (sheet-region filler) (sheet-region parent))
--- /project/climacs/cvsroot/climacs/colors.lisp 2006/03/03 19:38:58 NONE
+++ /project/climacs/cvsroot/climacs/colors.lisp 2006/03/03 19:38:58 1.1
;;; -*- Mode: Lisp; Package: clim-extensions -*-
;;; (c) copyright 2006 by
;;; Tim Moore (moore at bricoworks.com)
;;; 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.
;;; Color definitions from McCLIM that don't exist in Classic CLIM
(in-package :clim-extensions)
#-mcclim
(progn
(defparameter +blue-violet+ (make-rgb-color 0.5412 0.1686 0.8863))
(defparameter +gray50+ (make-gray-color 0.4980))
(defparameter +gray85+ (make-gray-color 0.8510))
(defparameter +dark-blue+ (make-rgb-color 0.0 0.0 0.5451))
(defparameter +dark-green+ (make-rgb-color 0.0000 0.3922 0.0000))
(defparameter +dark-violet+ (make-rgb-color 0.5804 0.0000 0.8275))
(defparameter +maroon+ (make-rgb-color 0.6902 0.1882 0.3765))
(defparameter +purple+ (make-rgb-color 0.6275 0.1255 0.9412)))
More information about the Climacs-cvs
mailing list