climacs-cvs

Download

climacs-cvs@common-lisp.net

March 2006

3 participants
22 discussions

[climacs-cvs] CVS climacs
by tmoore 03 Mar '06

03 Mar '06

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 `(,@defclasses + ,@simple-lists + ,@nonempty-lists + ,@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 `(,@defclasses + ,@simple-lists + ,@nonempty-lists + ,@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(a)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)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 01 Mar '06

01 Mar '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv27613 Modified Files: lisp-syntax.lisp Log Message: Removed *climacs-features* since it wasn't used for its intended purpose and got out of sync with *features*. Also added +'s to the name of a symbol naming a constant. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/02/09 15:26:08 1.45 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/03/01 19:32:07 1.46 @@ -1388,8 +1388,6 @@ (call-next-method))) (call-next-method)))) -(defparameter climacs-gui::*climacs-features* (copy-list *features*)) - (defgeneric eval-feature-conditional (conditional-form syntax)) (defmethod eval-feature-conditional (conditional-form (syntax lisp-syntax)) @@ -1397,7 +1395,7 @@ ;; Adapted from slime.el -(defconstant keyword-package (find-package :keyword) +(defconstant +keyword-package+ (find-package :keyword) "The KEYWORD package.") (defmethod eval-feature-conditional ((conditional token-mixin) (syntax lisp-syntax)) @@ -1405,8 +1403,8 @@ (start-offset conditional) (end-offset conditional)) 'string)) - (symbol (parse-symbol string keyword-package))) - (member symbol climacs-gui::*climacs-features*))) + (symbol (parse-symbol string +keyword-package+))) + (member symbol *features*))) (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) (let ((children (children conditional))) @@ -1424,7 +1422,7 @@ (start-offset type) (end-offset type)) 'string)) - (type-symbol (parse-symbol type-string keyword-package))) + (type-symbol (parse-symbol type-string +keyword-package+))) (case type-symbol (:and (funcall #'every #'eval-fc conditionals)) (:or (funcall #'some #'eval-fc conditionals)) @@ -1795,7 +1793,7 @@ "Find the symbol named STRING. Return the symbol and a flag indicating whether the symbol was found." (multiple-value-bind (symbol-name package-name) (parse-token string) - (let ((package (cond ((string= package-name "") keyword-package) + (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (find-package package-name)) (t package)))) (if package

1 0