Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp (revision 8062) @@ -94,7 +94,7 @@ (setf (buffer-%pathname buffer) pathname)) -(defun buffer-modeline-fields (window) +(defun buffer-modeline-fields (buffer) "Return a copy of the buffer's modeline fields list." - (do ((finfos (buffer-%modeline-fields window) (cdr finfos)) + (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos)) (result () (cons (ml-field-info-field (car finfos)) result))) ((null finfos) (nreverse result)))) @@ -126,66 +126,8 @@ -;;;; Variable binding -- winding and unwinding. - -(defmacro unbind-variable-bindings (bindings) - `(do ((binding ,bindings (binding-across binding))) - ((null binding)) - (setf (car (binding-cons binding)) - (variable-object-down (binding-object binding))))) - -(defmacro bind-variable-bindings (bindings) - `(do ((binding ,bindings (binding-across binding))) - ((null binding)) - (let ((cons (binding-cons binding)) - (object (binding-object binding))) - (setf (variable-object-down object) (car cons) - (car cons) object)))) - -;;; UNWIND-BINDINGS -- Internal -;;; -;;; Unwind buffer variable bindings and all mode bindings up to and -;;; including mode. Return a list of the modes unwound in reverse order. -;;; (buffer-mode-objects *current-buffer*) is clobbered. If "mode" is NIL -;;; unwind all bindings. -;;; -(defun unwind-bindings (buffer mode) - (assert (buffer-bindings-wound-p buffer)) - (setf (buffer-bindings-wound-p buffer) nil) - (unbind-variable-bindings (buffer-var-values buffer)) - (do ((curmode (buffer-mode-objects buffer)) - (unwound ()) cw) - (()) - (setf cw curmode curmode (cdr curmode) (cdr cw) unwound unwound cw) - (unbind-variable-bindings (mode-object-var-values (car unwound))) - (when (or (null curmode) (eq (car unwound) mode)) - (setf (buffer-mode-objects buffer) curmode) - (return unwound)))) - -;;; WIND-BINDINGS -- Internal -;;; -;;; Add "modes" to the mode bindings currently in effect. -;;; -(defun wind-bindings (buffer modes) - (assert (not (buffer-bindings-wound-p buffer))) - (setf (buffer-bindings-wound-p buffer) t) - (do ((curmode (buffer-mode-objects buffer)) cw) - ((null modes) (setf (buffer-mode-objects buffer) curmode)) - (bind-variable-bindings (mode-object-var-values (car modes))) - (setf cw modes modes (cdr modes) (cdr cw) curmode curmode cw)) - (bind-variable-bindings (buffer-var-values buffer))) - - - -(defun setup-buffer-bindings (buffer) - (wind-bindings buffer (shiftf (buffer-mode-objects buffer) nil))) - -(defun revert-buffer-bindings (buffer) - (setf (buffer-mode-objects buffer) (unwind-bindings buffer nil))) - - ;;;; BUFFER-MAJOR-MODE. (defmacro with-mode-and-buffer ((name major-p buffer) &body forms) - `(let ((mode (get-mode-object name))) + `(let ((mode (get-mode-object ,name))) (setq ,name (mode-object-name mode)) (,(if major-p 'unless 'when) (mode-object-major-p mode) @@ -196,5 +138,4 @@ ;;; BUFFER-MAJOR-MODE -- Public ;;; -;;; The major mode is the first on the list, so just return that. ;;; (defun buffer-major-mode (buffer) @@ -202,12 +143,7 @@ use Setf." (check-type buffer buffer) - (car (buffer-modes buffer))) + (mode-object-name (buffer-major-mode-object buffer))) ;;; %SET-BUFFER-MAJOR-MODE -- Public -;;; -;;; Unwind all modes in effect and add the major mode specified. -;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers -;;;other than the current buffer, and in the reverse order in the -;;;current buffer. ;;; (defun %set-buffer-major-mode (buffer name) @@ -215,17 +151,9 @@ (with-mode-and-buffer (name t buffer) (invoke-hook hemlock::buffer-major-mode-hook buffer name) - (cond - ((buffer-bindings-wound-p buffer) - (let ((old-mode (car (last (buffer-mode-objects buffer))))) - (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) - (funcall (mode-object-cleanup-function old-mode) buffer) - (wind-bindings buffer (cons mode (cdr (unwind-bindings buffer old-mode)))))) - (t - (let ((old-mode (car (buffer-mode-objects buffer)))) - (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) - (funcall (mode-object-cleanup-function old-mode) buffer)) - (setf (car (buffer-mode-objects buffer)) mode))) + (let ((old-mode (buffer-major-mode-object buffer))) + (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil) + (funcall (mode-object-cleanup-function old-mode) buffer)) + (setf (buffer-major-mode-object buffer) mode) (invalidate-shadow-attributes buffer) - (setf (car (buffer-modes buffer)) name) (funcall (mode-object-setup-function mode) buffer) (invoke-hook (%value (mode-object-hook-name mode)) buffer t)) @@ -245,5 +173,5 @@ A minor mode can be turned on or off with Setf." (with-mode-and-buffer (name nil buffer) - (not (null (member mode (buffer-mode-objects buffer)))))) + (not (null (member mode (buffer-minor-mode-objects buffer)))))) (declaim (special *mode-names*)) @@ -255,48 +183,35 @@ ;;; (defun %set-buffer-minor-mode (buffer name new-value) - (let ((objects (buffer-mode-objects buffer))) - (with-mode-and-buffer (name nil buffer) - (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value) - (cond - ;; Already there or not there, nothing to do. - ((if (member mode (buffer-mode-objects buffer)) new-value (not new-value))) - ;; Adding a new mode. - (new-value - (let ((wound-p (buffer-bindings-wound-p buffer))) - (when wound-p - (revert-buffer-bindings buffer)) - (do ((m (cdr objects) (cdr m)) - (prev objects m)) - ((or (null m) - (>= (mode-object-precedence (car m)) - (mode-object-precedence mode))) - (setf (cdr prev) (cons mode m)))) - (when wound-p - (setup-buffer-bindings buffer))) - ;; - ;; Add the mode name. - (let ((bm (buffer-modes buffer))) - (setf (cdr bm) - (merge 'list (cdr bm) (list name) #'< :key - #'(lambda (x) - (mode-object-precedence (getstring x *mode-names*)))))) - - (funcall (mode-object-setup-function mode) buffer) - (invoke-hook (%value (mode-object-hook-name mode)) buffer t)) - (t - ;; Removing an active mode. - (invoke-hook (%value (mode-object-hook-name mode)) buffer nil) - (funcall (mode-object-cleanup-function mode) buffer) - ;; In the current buffer, unwind buffer and any mode bindings on top - ;; pop off the mode and wind the rest back on. - (cond ((buffer-bindings-wound-p buffer) - (wind-bindings buffer (cdr (unwind-bindings buffer mode)))) - (t - (setf (buffer-mode-objects buffer) - (delq mode (buffer-mode-objects buffer))))) - ;; We always use the same string, so we can delq it (How Tense!) - (setf (buffer-modes buffer) (delq name (buffer-modes buffer)))))) - new-value)) - + (with-mode-and-buffer (name nil buffer) + (let ((objects (buffer-minor-mode-objects buffer))) + (unless (if (member mode objects) new-value (not new-value)) + (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value) + (cond + ;; Adding a new mode, insert sorted. + (new-value + (do ((m objects (cdr m)) + (prev nil m)) + ((or (null m) + (< (mode-object-precedence (car m)) + (mode-object-precedence mode))) + (if prev + (setf (cdr prev) (cons mode m)) + (setf (buffer-minor-mode-objects buffer) (setq objects (cons mode m)))))) + (funcall (mode-object-setup-function mode) buffer) + (invoke-hook (%value (mode-object-hook-name mode)) buffer t)) + (t + ;; Removing an active mode. + (invoke-hook (%value (mode-object-hook-name mode)) buffer nil) + (funcall (mode-object-cleanup-function mode) buffer) + (setf (buffer-minor-mode-objects buffer) (delq mode (buffer-minor-mode-objects buffer))))))) + new-value)) + +;;; BUFFER-MODES -- Public +;;; List of buffer mode names, in precendence order, major mode first. +;;; +(defun buffer-modes (buffer) + "Return the list of the names of the modes active in a given buffer." + (cons (buffer-major-mode buffer) + (nreverse (mapcar #'mode-object-name (buffer-minor-mode-objects buffer))))) @@ -492,5 +407,5 @@ #+GZ (when (getstring name *buffer-names*) - (warn "~s already exists, trying to delete" name *buffer-names*) + (cerror "Try to delete" "~s already exists" name) (let ((buffer (getstring name *buffer-names*))) (delete-buffer buffer))) @@ -505,6 +420,5 @@ :%name name :%region region - :modes (list (mode-object-name object)) - :mode-objects (list object) + :major-mode-object object :bindings (make-hash-table) :point (copy-mark (region-end region)) @@ -570,9 +484,7 @@ ;; Make it look like there is a make-buffer-hook... (setf (get 'hemlock::make-buffer-hook 'hemlock-variable-value) - (make-variable-object "foo" "bar")) + (make-variable-object 'foo)) (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental") :modeline-fields nil)) - (wind-bindings *current-buffer* nil) - ;; Make the bogus variable go away... (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value) @@ -582,4 +494,3 @@ ;; Bash the real mode object into the buffer. (let ((obj (getstring "Fundamental" *mode-names*))) - (setf (car (buffer-mode-objects *current-buffer*)) obj - (car (buffer-modes *current-buffer*)) (mode-object-name obj)))) + (setf (buffer-major-mode-object *current-buffer*) obj))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp (revision 8062) @@ -190,4 +190,6 @@ letters are in one list sorted by most recently used. \"Completion Bucket Size\" limits the number of completions saved in each list.") + +(defvar *completion-modeline-field* (modeline-field :completion)) (defcommand "Completion Mode" (p) @@ -505,6 +507,4 @@ (defvar *completion-mode-possibility* "") -(defvar *completion-modeline-field* (modeline-field :completion)) - (defun display-possible-completion (prefix &optional (prefix-length (length prefix))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp (revision 8062) @@ -297,5 +297,5 @@ :help "Enter mode to describe." :default - (car (buffer-modes (current-buffer))))))) + (buffer-major-mode (current-buffer)))))) (with-pop-up-display (s :title (format nil "~A mode" name)) (format s "~A mode description:~%" name) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp (revision 8062) @@ -342,9 +342,8 @@ "Returns a list of all the variable tables currently established globally, by the current buffer, and by any modes for the current buffer." - (do ((tables (list (buffer-variables *current-buffer*) - *global-variable-names*) - (cons (mode-object-variables (car mode)) tables)) - (mode (buffer-mode-objects *current-buffer*) (cdr mode))) - ((null mode) tables))) + (nconc (list (buffer-variables *current-buffer*)) + (mapcar #'mode-object-variables (buffer-minor-mode-objects *current-buffer*)) + (list (mode-object-variables (buffer-major-mode-object *current-buffer*))) + (list *global-variable-names*))) (defun keyword-verification-function (eps string) @@ -567,5 +566,5 @@ (cond ((eql n 0) (let ((key (eps-parse-default eps)) - (cmd (and key (with-buffer-bindings (buffer) + (cmd (and key (let ((*current-buffer* buffer)) (get-command key :current))))) (if (commandp cmd) @@ -577,5 +576,5 @@ (vector-push-extend key-event key) (let ((cmd (if (eps-parse-value-must-exist eps) - (with-buffer-bindings (buffer) (get-command key :current)) + (let ((*current-buffer* buffer)) (get-command key :current)) :prefix))) (cond ((commandp cmd) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp (revision 8062) @@ -251,23 +251,36 @@ ;;; (defun get-current-binding (key) - (let ((res (get-table-entry (buffer-bindings *current-buffer*) key))) - (cond - (res (values res nil)) - (t - (do ((mode (buffer-mode-objects *current-buffer*) (cdr mode)) - (t-bindings ())) - ((null mode) - (values (get-table-entry *global-command-table* key) - (nreverse t-bindings))) - (declare (list t-bindings)) - (let* ((res (or (get-table-entry (mode-object-bindings (car mode)) key) - (let ((default (mode-object-default-command (car mode)))) - (and default (getstring default *command-names*)))))) - (when res - (if (or (mode-object-transparent-p (car mode)) - (and (commandp res) (command-transparent-p res))) - (push res t-bindings) - (return (values res (nreverse t-bindings))))))))))) - + (let ((buffer *current-buffer*) + (t-bindings nil) res t-res) + (multiple-value-setq (res t-res) (get-binding-in-buffer key buffer)) + (when t-res (push t-res t-bindings)) + (loop while (null res) + for mode in (buffer-minor-mode-objects buffer) + do (multiple-value-setq (res t-res) (get-binding-in-mode key mode)) + do (when t-res (push t-res t-bindings))) + (when (null res) + (multiple-value-setq (res t-res) + (get-binding-in-mode key (buffer-major-mode-object buffer))) + (when t-res (push t-res t-bindings))) + (values (or res (get-table-entry *global-command-table* key)) + (nreverse t-bindings)))) + +(defun get-binding-in-buffer (key buffer) + (let ((res (get-table-entry (buffer-bindings buffer) key))) + (when res + (if (and (commandp res) (command-transparent-p res)) + (values nil res) + (values res nil))))) + +(defun get-binding-in-mode (key mode) + (let* ((res (or (get-table-entry (mode-object-bindings mode) key) + (let ((default (mode-object-default-command mode))) + (and default (getstring default *command-names*)))))) + (when res + (if (or (mode-object-transparent-p mode) + (and (commandp res) (command-transparent-p res))) + (values nil res) + (values res nil))))) + ;;; GET-COMMAND -- Public. Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp (revision 8062) @@ -326,13 +326,15 @@ (if (lisp-info-begins-quoted line-info) - (deal-with-string-quote mark line-info) - (setf (lisp-info-ending-quoted line-info) nil)) + (deal-with-string-quote mark line-info) + (setf (lisp-info-ending-quoted line-info) nil)) + (assert (eq (hi::mark-buffer mark) (current-buffer))) + (unless (lisp-info-ending-quoted line-info) (loop - (unless (find-lisp-char mark) + + (unless (find-lisp-char mark) (error "Expected at least a newline!")) - - (ecase (character-attribute :lisp-syntax (next-character mark)) + (case (character-attribute :lisp-syntax (next-character mark)) (:open-paren @@ -366,6 +368,10 @@ (unless (deal-with-string-quote mark line-info) (setf (lisp-info-ending-quoted line-info) t) - (return t)))))) - + (return t))) + (t (ERROR "character attribute of: ~s is ~s, at ~s" + (next-character mark) + (character-attribute :lisp-syntax (next-character mark)) + mark))))) + (setf (lisp-info-net-open-parens line-info) net-open-parens) (setf (lisp-info-net-close-parens line-info) net-close-parens) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp (revision 8062) @@ -45,5 +45,5 @@ ;;; (defmacro with-variable-object (name &body forms) - `(let ((obj (get ,name 'hemlock-variable-value))) + `(let ((obj (get-variable-object ,name :current))) (unless obj (undefined-variable-error ,name)) ,@forms)) @@ -70,24 +70,4 @@ (progn ,@sets nil ,@forms) ,@unsets)))) - -;; WITH-BUFFER-BINDINGS -;; -;; Execute body with buffer's bindings in effect. Also binds *current-buffer*, -;; (unless buffer _is_ *current-buffer*) because anything that looks at bindings -;; probably looks at *current-buffer* as well. - -(defmacro with-buffer-bindings ((buffer) &body body) - (let ((buffer-var (gensym)) - (setup-p (gensym))) - `(let* ((,buffer-var ,buffer) - (,setup-p nil) - ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var)))) - (unwind-protect - (progn - (unless (buffer-bindings-wound-p ,buffer-var) - (setup-buffer-bindings ,buffer-var) - (setq ,setup-p t)) - ,@body) - (when ,setup-p (revert-buffer-bindings ,buffer-var)))))) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp (revision 8062) @@ -112,10 +112,9 @@ "Returns buffer's modes followed by one space." (let* ((m ())) - (dolist (mode (buffer-mode-objects buffer)) - (unless (or (hi::mode-object-major-p mode) - (hi::mode-object-hidden mode)) + (dolist (mode (buffer-minor-mode-objects buffer)) + (unless (mode-object-hidden mode) (push (mode-object-name mode) m))) - (format nil "~A " (cons (hi::buffer-major-mode buffer) - (nreverse m)))))) + (format nil "~A " (cons (buffer-major-mode buffer) + (nreverse m)))))) (make-modeline-field Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp (revision 8062) @@ -91,8 +91,7 @@ %region ; the buffer's region %pathname ; associated pathname - modes ; list of buffer's mode names - mode-objects ; list of buffer's mode objects + major-mode-object ; buffer's major mode mode object + minor-mode-objects ; list of buffer's minor mode objects, reverse precedence order bindings ; buffer's command table - bindings-wound-p ; true if all the mode bindings have been wound. (shadow-syntax nil) ; buffer's changes to syntax attributes. point ; current position in buffer @@ -121,10 +120,9 @@ ) + (defstruct (font-region-node (:include ccl::dll-node) (:constructor make-font-region-node (region))) region) -(setf (documentation 'buffer-modes 'function) - "Return the list of the names of the modes active in a given buffer.") (setf (documentation 'buffer-point 'function) "Return the mark that is the current focus of attention in a buffer.") @@ -206,11 +204,10 @@ (variable-object-name object)))) (:copier nil) - (:constructor make-variable-object (documentation name))) + (:constructor make-variable-object (symbol-name))) value ; The value of this variable. hooks ; The hook list for this variable. - down ; The variable-object for the previous value. documentation ; The documentation. - name) ; The string name. - + name ; The string name. + symbol-name) ; The corresponding symbol name. ;;;; Attribute descriptors. Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp (revision 8062) @@ -393,13 +393,13 @@ (defun %init-shadow-attributes (buffer) - (let* ((mode (car (if (buffer-bindings-wound-p buffer) - (last (buffer-mode-objects buffer)) - (buffer-mode-objects buffer)))) + (let* ((mode (buffer-major-mode-object buffer)) (ss (or (buffer-shadow-syntax buffer) (setf (buffer-shadow-syntax buffer) (make-shadow-syntax))))) - #+GZ (setq mode (ccl:require-type mode 'mode-object)) (loop for (desc . vals) in (mode-object-character-attributes mode) - do (%init-one-shadow-attribute ss desc vals)))) - + do (%init-one-shadow-attribute ss desc vals)) + (setf (ss-last-find-attribute-attribute ss) nil) + (setf (ss-last-find-attribute-function ss) nil) + (setf (ss-global-syntax-tick ss) *global-syntax-tick*))) + (declaim (special *mode-names*)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp (revision 8062) @@ -16,15 +16,4 @@ (in-package :hemlock-internals) - -(defstruct (binding - (:type vector) - (:copier nil) - (:constructor make-binding (cons object across symbol))) - cons ; The cons which holds the value for the property. - object ; The variable-object for the binding. - across ; The next binding in this place. - symbol) ; The symbol name for the variable bound. - - ;;; UNDEFINED-VARIABLE-ERROR -- Internal @@ -54,8 +43,6 @@ ;;; of binding Binding, or NIL if none. ;;; -(defun find-binding (name binding) - (do ((b binding (binding-across b))) - ((null b) nil) - (when (eq (binding-symbol b) name) (return b)))) +(defun find-binding (symbol-name bindings) + (find symbol-name bindings :key #'variable-object-symbol-name :test #'eq)) ;;; GET-VARIABLE-OBJECT -- Internal @@ -64,32 +51,25 @@ ;;; or die trying. ;;; -(defun get-variable-object (name kind where) - (case kind +(defun get-variable-object (name kind &optional where) + (or (lookup-variable-object name kind where) + (undefined-variable-error name))) + +(defun lookup-variable-object (name kind where) + (ecase kind (:current - (let ((obj (get name 'hemlock-variable-value))) - (if obj obj (undefined-variable-error name)))) + (let ((buffer (current-buffer))) + (if (null buffer) + (lookup-variable-object name :global t) + (or (find-binding name (buffer-var-values buffer)) + (loop for mode in (buffer-minor-mode-objects buffer) + thereis (find-binding name (mode-object-var-values mode))) + (find-binding name (mode-object-var-values (buffer-major-mode-object buffer))) + (get name 'hemlock-variable-value))))) (:buffer - (check-type where buffer) - (let ((binding (find-binding name (buffer-var-values where)))) - (unless binding - (error "~S is not a defined Hemlock variable in buffer ~S." name where)) - (binding-object binding))) + (find-binding name (buffer-var-values (ccl:require-type where 'buffer)))) + (:mode + (find-binding name (mode-object-var-values (get-mode-object where)))) (:global - (do ((obj (get name 'hemlock-variable-value) - (variable-object-down obj)) - (prev nil obj)) - ((symbolp obj) - (unless prev (undefined-variable-error name)) - (unless (eq obj :global) - (error "Hemlock variable ~S is not globally defined." name)) - prev))) - (:mode - (let ((binding (find-binding name (mode-object-var-values - (get-mode-object where))))) - (unless binding - (error "~S is not a defined Hemlock variable in mode ~S." name where)) - (binding-object binding))) - (t - (error "~S is not a defined value for Kind." kind)))) + (get name 'hemlock-variable-value)))) ;;; VARIABLE-VALUE -- Public @@ -100,23 +80,4 @@ "Return the value of the Hemlock variable given." (variable-object-value (get-variable-object name kind where))) - -;;; %VALUE -- Internal -;;; -;;; This function is called by the expansion of Value. -;;; -(defun %value (name) - (let ((obj (get name 'hemlock-variable-value))) - (unless obj (undefined-variable-error name)) - (variable-object-value obj))) - -;;; %SET-VALUE -- Internal -;;; -;;; The setf-inverse of Value, set the current value. -;;; -(defun %set-value (var new-value) - (let ((obj (get var 'hemlock-variable-value))) - (unless obj (undefined-variable-error var)) - (invoke-hook (variable-object-hooks obj) var :current nil new-value) - (setf (variable-object-value obj) new-value))) ;;; %SET-VARIABLE-VALUE -- Internal @@ -129,4 +90,19 @@ (setf (variable-object-value obj) new-value))) +;;; %VALUE -- Internal +;;; +;;; This function is called by the expansion of Value. +;;; +(defun %value (name) + (variable-value name :current t)) + +;;; %SET-VALUE -- Internal +;;; +;;; The setf-inverse of Value, set the current value. +;;; +(defun %set-value (name new-value) + (%set-variable-value name :current t new-value)) + + ;;; VARIABLE-HOOKS -- Public ;;; @@ -173,16 +149,6 @@ "Returns T Name is a Hemlock variable defined in the specifed place, or NIL otherwise." - (case kind - (:current (not (null (get name 'hemlock-variable-value)))) - (:buffer - (check-type where buffer) - (not (null (find-binding name (buffer-var-values where))))) - (:global - (do ((obj (get name 'hemlock-variable-value) - (variable-object-down obj))) - ((symbolp obj) (eq obj :global)))) - (:mode - (not (null (find-binding name (mode-object-var-values - (get-mode-object where)))))))) + (not (null (lookup-variable-object name kind where)))) + (declaim (special *global-variable-names*)) @@ -194,63 +160,31 @@ (defun defhvar (name documentation &key mode buffer (hooks nil hook-p) (value nil value-p)) - (let* ((symbol-name (string-to-variable name)) - (new-binding (make-variable-object documentation name)) - (plist (symbol-plist symbol-name)) - (prop (cdr (or (member 'hemlock-variable-value plist) - (setf (symbol-plist symbol-name) - (list* 'hemlock-variable-value nil plist))))) - (kind :global) where string-table) + (let* ((symbol-name (string-to-variable name)) var) (cond - (mode - (setq kind :mode where mode) - (let* ((obj (get-mode-object where)) - (vars (mode-object-var-values obj))) - (setq string-table (mode-object-variables obj)) - (unless (find-binding symbol-name vars) - (let ((binding (make-binding prop new-binding vars symbol-name))) - (cond ((member obj (buffer-mode-objects *current-buffer*)) - (let ((l (unwind-bindings *current-buffer* obj))) - (setf (mode-object-var-values obj) binding) - (wind-bindings *current-buffer* l))) - (t - (setf (mode-object-var-values obj) binding))))))) - (buffer - (check-type buffer buffer) - (setq kind :buffer where buffer string-table (buffer-variables buffer)) - (let ((vars (buffer-var-values buffer))) - (unless (find-binding symbol-name vars) - (let ((binding (make-binding prop new-binding vars symbol-name))) - (setf (buffer-var-values buffer) binding) - (when (buffer-bindings-wound-p buffer) - (setf (variable-object-down new-binding) (car prop) - (car prop) new-binding)))))) - (t - (setq string-table *global-variable-names*) - (unless (hemlock-bound-p symbol-name :global) - (setf (variable-object-down new-binding) :global) - (when *current-buffer* - (let ((l (unwind-bindings *current-buffer* nil))) - (setf (car prop) new-binding) - (wind-bindings *current-buffer* l)))))) - (setf (getstring name string-table) symbol-name) + (mode + (let* ((mode-obj (get-mode-object mode))) + (setf (getstring name (mode-object-variables mode-obj)) symbol-name) + (unless (setq var (find-binding symbol-name (mode-object-var-values mode-obj))) + (push (setq var (make-variable-object symbol-name)) + (mode-object-var-values mode-obj))))) + (buffer + (check-type buffer buffer) + (setf (getstring name (buffer-variables buffer)) symbol-name) + (unless (setq var (find-binding symbol-name (buffer-var-values buffer))) + (push (setq var (make-variable-object symbol-name)) + (buffer-var-values buffer)))) + (t + (setf (getstring name *global-variable-names*) symbol-name) + (unless (setq var (get symbol-name 'hemlock-variable-value)) + (setf (get symbol-name 'hemlock-variable-value) + (setq var (make-variable-object symbol-name)))))) + (setf (variable-object-name var) name) + (when (> (length documentation) 0) + (setf (variable-object-documentation var) documentation)) (when hook-p - (setf (variable-hooks symbol-name kind where) hooks)) + (setf (variable-object-hooks var) hooks)) (when value-p - (setf (variable-value symbol-name kind where) value))) + (setf (variable-object-value var) value))) name) - -;;; DELETE-BINDING -- Internal -;;; -;;; Delete a binding from a list of bindings. -;;; -(defun delete-binding (binding bindings) - (do ((b bindings (binding-across b)) - (prev nil b)) - ((eq b binding) - (cond (prev - (setf (binding-across prev) (binding-across b)) - bindings) - (t - (binding-across bindings)))))) ;;; DELETE-VARIABLE -- Public @@ -263,13 +197,11 @@ (let* ((obj (get-variable-object name kind where)) (sname (variable-object-name obj))) - (case kind + (ecase kind (:buffer (let* ((values (buffer-var-values where)) (binding (find-binding name values))) (invoke-hook hemlock::delete-variable-hook name :buffer where) - (delete-string sname (buffer-variables where)) - (setf (buffer-var-values where) (delete-binding binding values)) - (when (buffer-bindings-wound-p where) - (setf (car (binding-cons binding)) (variable-object-down obj))))) + (delete-string sname (buffer-variables where)) + (setf (buffer-var-values where) (delete binding values)))) (:mode (let* ((mode (get-mode-object where)) @@ -278,17 +210,8 @@ (invoke-hook hemlock::delete-variable-hook name :mode where) (delete-string sname (mode-object-variables mode)) - (if (member mode (buffer-mode-objects *current-buffer*)) - (let ((l (unwind-bindings *current-buffer* mode))) - (setf (mode-object-var-values mode) - (delete-binding binding values)) - (wind-bindings *current-buffer* l)) - (setf (mode-object-var-values mode) - (delete-binding binding values))))) + (setf (mode-object-var-values mode) (delete binding values)))) (:global (invoke-hook hemlock::delete-variable-hook name :global nil) (delete-string sname *global-variable-names*) - (let ((l (unwind-bindings *current-buffer* nil))) - (setf (get name 'hemlock-variable-value) nil) - (wind-bindings *current-buffer* l))) - (t (error "Invalid variable kind: ~S" kind))) + (setf (get name 'hemlock-variable-value) nil))) nil)) Index: /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp =================================================================== --- /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 8061) +++ /branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp (revision 8062) @@ -246,16 +246,15 @@ (text-buffer (hemlock-view-buffer view)) (mod (buffer-modification-state text-buffer))) - (with-buffer-bindings (*current-buffer*) - (modifying-buffer-storage (*current-buffer*) - (restart-case - (handler-bind ((error #'lisp-error-error-handler)) - (execute-hemlock-key view key)) - (exit-event-handler () :report "Exit from hemlock event handler"))) - ;; Update display - (if *next-view-start* - (destructuring-bind (how . where) *next-view-start* - (hemlock-ext:scroll-view view how where)) - (unless (equal mod (buffer-modification-state text-buffer)) - ;; Modified buffer, make sure user sees what happened - (hemlock-ext:ensure-selection-visible view))) - (update-echo-area-after-command view)))))) + (modifying-buffer-storage (*current-buffer*) + (restart-case + (handler-bind ((error #'lisp-error-error-handler)) + (execute-hemlock-key view key)) + (exit-event-handler () :report "Exit from hemlock event handler"))) + ;; Update display + (if *next-view-start* + (destructuring-bind (how . where) *next-view-start* + (hemlock-ext:scroll-view view how where)) + (unless (equal mod (buffer-modification-state text-buffer)) + ;; Modified buffer, make sure user sees what happened + (hemlock-ext:ensure-selection-visible view))) + (update-echo-area-after-command view)))))