Commit 79460817 authored by Timothy Moore's avatar Timothy Moore

Changes for running climacs in Allegro Common Lisp with Classic CLIM (tm)....

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
parent fcb433aa
......@@ -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
......
......@@ -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
......
;;; -*- Mode: Lisp; Package: clim-extensions -*-
;;; (c) copyright 2006 by
;;; Tim Moore (moore@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)))
......@@ -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
......
......@@ -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 @@ a plus) sign. C-u 3 4 = 34, C-u - 3 4 = -34. Note that C-u 3 - prints 3 '-'s.
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 @@ In the absence of a prefix arg returns 1 (and nil)."
(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 @@ In the absence of a prefix arg returns 1 (and nil)."
(*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 @@ In the absence of a prefix arg returns 1 (and nil)."
;;;
;;; 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 @@ In the absence of a prefix arg returns 1 (and nil)."
: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 @@ In the absence of a prefix arg returns 1 (and nil)."
(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 @@ In the absence of a prefix arg returns 1 (and nil)."
(define-command-table global-example-table
:inherit-from (global-esa-table keyboard-macro-table))
......@@ -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)
......
......@@ -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*)))
......
......@@ -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)
......
......@@ -148,6 +148,6 @@ is empty a new entry is pushed."))
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
......@@ -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"))
......
......@@ -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))
......
......@@ -300,12 +300,23 @@ is made to alter a buffer which has been set read only."))
(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))
......
......@@ -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) ())
......
......@@ -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)))
......
......@@ -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
......
......@@ -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
......
......@@ -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))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment