Changeset 8062


Ignore:
Timestamp:
Jan 12, 2008, 2:15:41 PM (17 years ago)
Author:
gz
Message:

Get rid of the variable "winding" scheme (which used to swap the
current buffer's variable bindings into symbol plists), simplify
variable and mode handing.

Fix a shadow attribute caching bug.

Location:
branches/event-ide/ccl/cocoa-ide/hemlock/src
Files:
12 edited

Legend:

Unmodified
Added
Removed

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/buffer.lisp

    r7993 r8062  
    9494  (setf (buffer-%pathname buffer) pathname))
    9595
    96 (defun buffer-modeline-fields (window)
     96(defun buffer-modeline-fields (buffer)
    9797  "Return a copy of the buffer's modeline fields list."
    98   (do ((finfos (buffer-%modeline-fields window) (cdr finfos))
     98  (do ((finfos (buffer-%modeline-fields buffer) (cdr finfos))
    9999       (result () (cons (ml-field-info-field (car finfos)) result)))
    100100      ((null finfos) (nreverse result))))
    … …  
    126126
    127127
    128 ;;;; Variable binding -- winding and unwinding.
    129 
    130 (defmacro unbind-variable-bindings (bindings)
    131   `(do ((binding ,bindings (binding-across binding)))
    132        ((null binding))
    133      (setf (car (binding-cons binding))
    134            (variable-object-down (binding-object binding)))))
    135 
    136 (defmacro bind-variable-bindings (bindings)
    137   `(do ((binding ,bindings (binding-across binding)))
    138        ((null binding))
    139      (let ((cons (binding-cons binding))
    140            (object (binding-object binding)))
    141        (setf (variable-object-down object) (car cons)
    142              (car cons) object))))
    143 
    144 ;;; UNWIND-BINDINGS  --  Internal
    145 ;;;
    146 ;;;    Unwind buffer variable bindings and all mode bindings up to and
    147 ;;; including mode.  Return a list of the modes unwound in reverse order.
    148 ;;; (buffer-mode-objects *current-buffer*) is clobbered.  If "mode" is NIL
    149 ;;; unwind all bindings.
    150 ;;;
    151 (defun unwind-bindings (buffer mode)
    152   (assert (buffer-bindings-wound-p buffer))
    153   (setf (buffer-bindings-wound-p buffer) nil)
    154   (unbind-variable-bindings (buffer-var-values buffer))
    155   (do ((curmode (buffer-mode-objects buffer))
    156        (unwound ()) cw)
    157       (())
    158     (setf cw curmode  curmode (cdr curmode)  (cdr cw) unwound  unwound cw)
    159     (unbind-variable-bindings (mode-object-var-values (car unwound)))
    160     (when (or (null curmode) (eq (car unwound) mode))
    161       (setf (buffer-mode-objects buffer) curmode)
    162       (return unwound))))
    163 
    164 ;;; WIND-BINDINGS  --  Internal
    165 ;;;
    166 ;;;    Add "modes" to the mode bindings currently in effect.
    167 ;;;
    168 (defun wind-bindings (buffer modes)
    169   (assert (not (buffer-bindings-wound-p buffer)))
    170   (setf (buffer-bindings-wound-p buffer) t)
    171   (do ((curmode (buffer-mode-objects buffer)) cw)
    172       ((null modes) (setf (buffer-mode-objects buffer) curmode))
    173     (bind-variable-bindings (mode-object-var-values (car modes)))
    174     (setf cw modes  modes (cdr modes)  (cdr cw) curmode  curmode cw))
    175   (bind-variable-bindings (buffer-var-values buffer)))
    176 
    177 
    178 
    179 (defun setup-buffer-bindings (buffer)
    180   (wind-bindings buffer (shiftf (buffer-mode-objects buffer) nil)))
    181 
    182 (defun revert-buffer-bindings (buffer)
    183   (setf (buffer-mode-objects buffer) (unwind-bindings buffer nil)))
    184 
    185 
    186128;;;; BUFFER-MAJOR-MODE.
    187129
    188130(defmacro with-mode-and-buffer ((name major-p buffer) &body forms)
    189   `(let ((mode (get-mode-object name)))
     131  `(let ((mode (get-mode-object ,name)))
    190132    (setq ,name (mode-object-name mode))
    191133    (,(if major-p 'unless 'when) (mode-object-major-p mode)
    … …  
    196138;;; BUFFER-MAJOR-MODE  --  Public
    197139;;;
    198 ;;;    The major mode is the first on the list, so just return that.
    199140;;;
    200141(defun buffer-major-mode (buffer)
    … …  
    202143  use Setf."
    203144  (check-type buffer buffer)
    204   (car (buffer-modes buffer)))
     145  (mode-object-name (buffer-major-mode-object buffer)))
    205146
    206147;;; %SET-BUFFER-MAJOR-MODE  --  Public
    207 ;;;
    208 ;;;    Unwind all modes in effect and add the major mode specified.
    209 ;;;Note that BUFFER-MODE-OBJECTS is in order of invocation in buffers
    210 ;;;other than the current buffer, and in the reverse order in the
    211 ;;;current buffer.
    212148;;;
    213149(defun %set-buffer-major-mode (buffer name)
    … …  
    215151  (with-mode-and-buffer (name t buffer)
    216152    (invoke-hook hemlock::buffer-major-mode-hook buffer name)
    217     (cond
    218      ((buffer-bindings-wound-p buffer)
    219       (let ((old-mode (car (last (buffer-mode-objects buffer)))))
    220         (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
    221         (funcall (mode-object-cleanup-function old-mode) buffer)
    222         (wind-bindings buffer (cons mode (cdr (unwind-bindings buffer old-mode))))))
    223      (t
    224       (let ((old-mode (car (buffer-mode-objects buffer))))
    225         (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
    226         (funcall (mode-object-cleanup-function old-mode) buffer))
    227       (setf (car (buffer-mode-objects buffer)) mode)))
     153    (let ((old-mode (buffer-major-mode-object buffer)))
     154      (invoke-hook (%value (mode-object-hook-name old-mode)) buffer nil)
     155      (funcall (mode-object-cleanup-function old-mode) buffer))
     156    (setf (buffer-major-mode-object buffer) mode)
    228157    (invalidate-shadow-attributes buffer)
    229     (setf (car (buffer-modes buffer)) name)
    230158    (funcall (mode-object-setup-function mode) buffer)
    231159    (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
    … …  
    245173  A minor mode can be turned on or off with Setf."
    246174  (with-mode-and-buffer (name nil buffer)
    247     (not (null (member mode (buffer-mode-objects buffer))))))
     175    (not (null (member mode (buffer-minor-mode-objects buffer))))))
    248176   
    249177(declaim (special *mode-names*))
    … …  
    255183;;;
    256184(defun %set-buffer-minor-mode (buffer name new-value)
    257   (let ((objects (buffer-mode-objects buffer)))   
    258     (with-mode-and-buffer (name nil buffer)
    259       (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value)
    260       (cond
    261        ;; Already there or not there, nothing to do.
    262        ((if (member mode (buffer-mode-objects buffer)) new-value (not new-value)))
    263        ;; Adding a new mode.
    264        (new-value
    265         (let ((wound-p (buffer-bindings-wound-p buffer)))
    266           (when wound-p
    267             (revert-buffer-bindings buffer))
    268           (do ((m (cdr objects) (cdr m))
    269                (prev objects m))
    270               ((or (null m)
    271                    (>= (mode-object-precedence (car m))
    272                        (mode-object-precedence mode)))
    273                (setf (cdr prev) (cons mode m))))
    274           (when wound-p
    275             (setup-buffer-bindings buffer)))
    276         ;;
    277         ;; Add the mode name.
    278         (let ((bm (buffer-modes buffer)))
    279           (setf (cdr bm)
    280                 (merge 'list (cdr bm) (list name) #'<  :key
    281                        #'(lambda (x)
    282                            (mode-object-precedence (getstring x *mode-names*))))))
    283 
    284         (funcall (mode-object-setup-function mode) buffer)
    285         (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
    286        (t
    287         ;; Removing an active mode.
    288         (invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
    289         (funcall (mode-object-cleanup-function mode) buffer)
    290         ;; In the current buffer, unwind buffer and any mode bindings on top
    291         ;; pop off the mode and wind the rest back on.
    292         (cond ((buffer-bindings-wound-p buffer)
    293                (wind-bindings buffer (cdr (unwind-bindings buffer mode))))
    294               (t
    295                (setf (buffer-mode-objects buffer)
    296                      (delq mode (buffer-mode-objects buffer)))))
    297         ;; We always use the same string, so we can delq it (How Tense!)
    298         (setf (buffer-modes buffer) (delq name (buffer-modes buffer))))))
    299   new-value))
    300 
     185  (with-mode-and-buffer (name nil buffer)
     186    (let ((objects (buffer-minor-mode-objects buffer)))
     187      (unless (if (member mode objects) new-value (not new-value))
     188        (invoke-hook hemlock::buffer-minor-mode-hook buffer name new-value)
     189        (cond
     190         ;; Adding a new mode, insert sorted.
     191         (new-value
     192          (do ((m objects (cdr m))
     193               (prev nil m))
     194              ((or (null m)
     195                   (< (mode-object-precedence (car m))
     196                      (mode-object-precedence mode)))
     197               (if prev
     198                 (setf (cdr prev) (cons mode m))
     199                 (setf (buffer-minor-mode-objects buffer) (setq objects (cons mode m))))))
     200          (funcall (mode-object-setup-function mode) buffer)
     201          (invoke-hook (%value (mode-object-hook-name mode)) buffer t))
     202         (t
     203          ;; Removing an active mode.
     204          (invoke-hook (%value (mode-object-hook-name mode)) buffer nil)
     205          (funcall (mode-object-cleanup-function mode) buffer)
     206          (setf (buffer-minor-mode-objects buffer) (delq mode (buffer-minor-mode-objects buffer)))))))
     207    new-value))
     208
     209;;; BUFFER-MODES -- Public
     210;;; List of buffer mode names, in precendence order, major mode first.
     211;;;
     212(defun buffer-modes (buffer)
     213  "Return the list of the names of the modes active in a given buffer."
     214  (cons (buffer-major-mode buffer)
     215        (nreverse (mapcar #'mode-object-name (buffer-minor-mode-objects buffer)))))
    301216
    302217
    … …  
    492407  #+GZ
    493408  (when (getstring name *buffer-names*)
    494     (warn "~s already exists, trying to delete" name *buffer-names*)
     409    (cerror "Try to delete" "~s already exists" name)
    495410    (let ((buffer (getstring name *buffer-names*)))
    496411      (delete-buffer buffer)))
    … …  
    505420                         :%name name
    506421                         :%region region
    507                          :modes (list (mode-object-name object))
    508                          :mode-objects (list object)
     422                         :major-mode-object object
    509423                         :bindings (make-hash-table)
    510424                         :point (copy-mark (region-end region))
    … …  
    570484  ;; Make it look like there is a make-buffer-hook...
    571485  (setf (get 'hemlock::make-buffer-hook 'hemlock-variable-value)
    572         (make-variable-object "foo" "bar"))
     486        (make-variable-object 'foo))
    573487  (setq *current-buffer* (make-buffer "Main" :modes '("Fundamental")
    574488                                      :modeline-fields nil))
    575   (wind-bindings *current-buffer* nil)
    576 
    577489  ;; Make the bogus variable go away...
    578490  (remf (symbol-plist 'hemlock::make-buffer-hook) 'hemlock-variable-value)
    … …  
    582494  ;; Bash the real mode object into the buffer.
    583495  (let ((obj (getstring "Fundamental" *mode-names*)))
    584     (setf (car (buffer-mode-objects *current-buffer*)) obj
    585           (car (buffer-modes *current-buffer*)) (mode-object-name obj))))
     496    (setf (buffer-major-mode-object *current-buffer*) obj)))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/completion.lisp

    r8055 r8062  
    190190   letters are in one list sorted by most recently used.  \"Completion Bucket
    191191   Size\" limits the number of completions saved in each list.")
     192
     193(defvar *completion-modeline-field* (modeline-field :completion))
    192194
    193195(defcommand "Completion Mode" (p)
    … …  
    505507(defvar *completion-mode-possibility* "")
    506508
    507 (defvar *completion-modeline-field* (modeline-field :completion))
    508 
    509509(defun display-possible-completion (prefix
    510510                                    &optional (prefix-length (length prefix)))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/doccoms.lisp

    r7993 r8062  
    297297                                      :help "Enter mode to describe."
    298298                                      :default
    299                                       (car (buffer-modes (current-buffer)))))))
     299                                      (buffer-major-mode (current-buffer))))))
    300300    (with-pop-up-display (s :title (format nil "~A mode" name))
    301301      (format s "~A mode description:~%" name)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/echo.lisp

    r7993 r8062  
    342342  "Returns a list of all the variable tables currently established globally,
    343343   by the current buffer, and by any modes for the current buffer."
    344   (do ((tables (list (buffer-variables *current-buffer*)
    345                      *global-variable-names*)
    346                (cons (mode-object-variables (car mode)) tables))
    347        (mode (buffer-mode-objects *current-buffer*) (cdr mode)))
    348       ((null mode) tables)))
     344  (nconc (list (buffer-variables *current-buffer*))
     345         (mapcar #'mode-object-variables (buffer-minor-mode-objects *current-buffer*))
     346         (list (mode-object-variables (buffer-major-mode-object *current-buffer*)))
     347         (list *global-variable-names*)))
    349348
    350349(defun keyword-verification-function (eps string)
    … …  
    567566                 (cond ((eql n 0)
    568567                        (let ((key (eps-parse-default eps))
    569                               (cmd (and key (with-buffer-bindings (buffer)
     568                              (cmd (and key (let ((*current-buffer* buffer))
    570569                                              (get-command key :current)))))
    571570                          (if (commandp cmd)
    … …  
    577576      (vector-push-extend key-event key)
    578577      (let ((cmd (if (eps-parse-value-must-exist eps)
    579                    (with-buffer-bindings (buffer) (get-command key :current))
     578                   (let ((*current-buffer* buffer)) (get-command key :current))
    580579                   :prefix)))
    581580        (cond ((commandp cmd)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/interp.lisp

    r7993 r8062  
    251251;;;
    252252(defun get-current-binding (key)
    253   (let ((res (get-table-entry (buffer-bindings *current-buffer*) key)))
    254     (cond
    255      (res (values res nil))
    256      (t
    257       (do ((mode (buffer-mode-objects *current-buffer*) (cdr mode))
    258            (t-bindings ()))
    259           ((null mode)
    260            (values (get-table-entry *global-command-table* key)
    261                    (nreverse t-bindings)))
    262         (declare (list t-bindings))
    263         (let* ((res (or (get-table-entry (mode-object-bindings (car mode)) key)
    264                         (let ((default (mode-object-default-command (car mode))))
    265                           (and default (getstring default *command-names*))))))
    266           (when res
    267             (if (or (mode-object-transparent-p (car mode))
    268                     (and (commandp res) (command-transparent-p res)))
    269                 (push res t-bindings)
    270                 (return (values res (nreverse t-bindings)))))))))))
    271 
     253  (let ((buffer *current-buffer*)
     254        (t-bindings nil) res t-res)
     255    (multiple-value-setq (res t-res) (get-binding-in-buffer key buffer))
     256    (when t-res (push t-res t-bindings))
     257    (loop while (null res)
     258      for mode in (buffer-minor-mode-objects buffer)
     259      do (multiple-value-setq (res t-res) (get-binding-in-mode key mode))
     260      do (when t-res (push t-res t-bindings)))
     261    (when (null res)
     262      (multiple-value-setq (res t-res)
     263        (get-binding-in-mode key (buffer-major-mode-object buffer)))
     264      (when t-res (push t-res t-bindings)))
     265    (values (or res (get-table-entry *global-command-table* key))
     266            (nreverse t-bindings))))
     267
     268(defun get-binding-in-buffer (key buffer)
     269  (let ((res (get-table-entry (buffer-bindings buffer) key)))
     270    (when res
     271      (if (and (commandp res) (command-transparent-p res))
     272        (values nil res)
     273        (values res nil)))))
     274
     275(defun get-binding-in-mode (key mode)
     276  (let* ((res (or (get-table-entry (mode-object-bindings mode) key)
     277                  (let ((default (mode-object-default-command mode)))
     278                    (and default (getstring default *command-names*))))))
     279    (when res
     280      (if (or (mode-object-transparent-p mode)
     281              (and (commandp res) (command-transparent-p res)))
     282        (values nil res)
     283        (values res nil)))))
     284 
    272285
    273286;;; GET-COMMAND -- Public.

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/lispmode.lisp

    r8029 r8062  
    326326   
    327327    (if (lisp-info-begins-quoted line-info)
    328         (deal-with-string-quote mark line-info)
    329         (setf (lisp-info-ending-quoted line-info) nil))
     328      (deal-with-string-quote mark line-info)
     329      (setf (lisp-info-ending-quoted line-info) nil))
    330330   
     331    (assert (eq (hi::mark-buffer mark) (current-buffer)))
     332
    331333    (unless (lisp-info-ending-quoted line-info)
    332334      (loop
    333         (unless (find-lisp-char mark)
     335
     336        (unless (find-lisp-char mark)
    334337          (error "Expected at least a newline!"))
    335 
    336         (ecase (character-attribute :lisp-syntax (next-character mark))
     338        (case (character-attribute :lisp-syntax (next-character mark))
    337339         
    338340          (:open-paren
    … …  
    366368           (unless (deal-with-string-quote mark line-info)
    367369             (setf (lisp-info-ending-quoted line-info) t)
    368              (return t))))))
    369    
     370             (return t)))
     371          (t (ERROR "character attribute of: ~s is ~s, at ~s"
     372                    (next-character mark)
     373                    (character-attribute :lisp-syntax (next-character mark))
     374                    mark)))))
     375
    370376    (setf (lisp-info-net-open-parens line-info) net-open-parens)
    371377    (setf (lisp-info-net-close-parens line-info) net-close-parens)

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/macros.lisp

    r7993 r8062  
    4545;;;
    4646(defmacro with-variable-object (name &body forms)
    47   `(let ((obj (get ,name 'hemlock-variable-value)))
     47  `(let ((obj (get-variable-object ,name :current)))
    4848     (unless obj (undefined-variable-error ,name))
    4949     ,@forms))
    … …  
    7070         (progn ,@sets nil ,@forms)
    7171         ,@unsets))))
    72 
    73 ;; WITH-BUFFER-BINDINGS
    74 ;;
    75 ;; Execute body with buffer's bindings in effect.  Also binds *current-buffer*,
    76 ;; (unless buffer _is_ *current-buffer*) because anything that looks at bindings
    77 ;; probably looks at *current-buffer* as well.
    78 
    79 (defmacro with-buffer-bindings ((buffer) &body body)
    80   (let ((buffer-var (gensym))
    81         (setup-p (gensym)))
    82     `(let* ((,buffer-var ,buffer)
    83             (,setup-p nil)
    84             ,@(unless (eq buffer '*current-buffer*) `((*current-buffer* ,buffer-var))))
    85        (unwind-protect
    86            (progn
    87              (unless (buffer-bindings-wound-p ,buffer-var)
    88                (setup-buffer-bindings ,buffer-var)
    89                (setq ,setup-p t))
    90              ,@body)
    91        (when ,setup-p (revert-buffer-bindings ,buffer-var))))))
    9272
    9373

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/modeline.lisp

    r7995 r8062  
    112112               "Returns buffer's modes followed by one space."
    113113               (let* ((m ()))
    114                  (dolist (mode (buffer-mode-objects buffer))
    115                    (unless (or (hi::mode-object-major-p mode)
    116                                (hi::mode-object-hidden mode))
     114                 (dolist (mode (buffer-minor-mode-objects buffer))
     115                   (unless (mode-object-hidden mode)
    117116                     (push (mode-object-name mode) m)))
    118                (format nil "~A  " (cons (hi::buffer-major-mode buffer)
    119                                         (nreverse m))))))
     117                 (format nil "~A  " (cons (buffer-major-mode buffer)
     118                                          (nreverse m))))))
    120119
    121120(make-modeline-field

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/struct.lisp

    r7993 r8062  
    9191  %region                     ; the buffer's region
    9292  %pathname                   ; associated pathname
    93   modes                       ; list of buffer's mode names
    94   mode-objects                ; list of buffer's mode objects
     93  major-mode-object           ; buffer's major mode mode object
     94  minor-mode-objects          ; list of buffer's minor mode objects, reverse precedence order
    9595  bindings                    ; buffer's command table
    96   bindings-wound-p            ; true if all the mode bindings have been wound.
    9796  (shadow-syntax nil)         ; buffer's changes to syntax attributes.
    9897  point                       ; current position in buffer
    … …  
    121120  )
    122121
     122
    123123(defstruct (font-region-node (:include ccl::dll-node)
    124124                             (:constructor make-font-region-node (region)))
    125125  region)
    126126
    127 (setf (documentation 'buffer-modes 'function)
    128   "Return the list of the names of the modes active in a given buffer.")
    129127(setf (documentation 'buffer-point 'function)
    130128  "Return the mark that is the current focus of attention in a buffer.")
    … …  
    206204                       (variable-object-name object))))
    207205            (:copier nil)
    208             (:constructor make-variable-object (documentation name)))
     206            (:constructor make-variable-object (symbol-name)))
    209207  value         ; The value of this variable.
    210208  hooks         ; The hook list for this variable.
    211   down          ; The variable-object for the previous value.
    212209  documentation ; The documentation.
    213   name)         ; The string name.
    214 
     210  name          ; The string name.
     211  symbol-name)  ; The corresponding symbol name.
    215212
    216213;;;; Attribute descriptors.

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/syntax.lisp

    r7911 r8062  
    393393
    394394(defun %init-shadow-attributes (buffer)
    395   (let* ((mode (car (if (buffer-bindings-wound-p buffer)
    396                       (last (buffer-mode-objects buffer))
    397                       (buffer-mode-objects buffer))))
     395  (let* ((mode (buffer-major-mode-object buffer))
    398396         (ss (or (buffer-shadow-syntax buffer)
    399397                 (setf (buffer-shadow-syntax buffer) (make-shadow-syntax)))))
    400     #+GZ (setq mode (ccl:require-type mode 'mode-object))
    401398    (loop for (desc .  vals) in (mode-object-character-attributes mode)
    402       do (%init-one-shadow-attribute ss desc vals))))
    403            
     399      do (%init-one-shadow-attribute ss desc vals))
     400    (setf (ss-last-find-attribute-attribute ss) nil)
     401    (setf (ss-last-find-attribute-function ss) nil)
     402    (setf (ss-global-syntax-tick ss) *global-syntax-tick*)))
     403
    404404(declaim (special *mode-names*))
    405405

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/vars.lisp

    r7833 r8062  
    1616
    1717(in-package :hemlock-internals)
    18 
    19 (defstruct (binding
    20             (:type vector)
    21             (:copier nil)
    22             (:constructor make-binding (cons object across symbol)))
    23   cons          ; The cons which holds the value for the property.
    24   object        ; The variable-object for the binding.
    25   across        ; The next binding in this place.
    26   symbol)       ; The symbol name for the variable bound.
    27 
    28 
    2918
    3019;;; UNDEFINED-VARIABLE-ERROR  --  Internal
    … …  
    5443;;; of binding Binding, or NIL if none.
    5544;;;
    56 (defun find-binding (name binding)
    57   (do ((b binding (binding-across b)))
    58       ((null b) nil)
    59     (when (eq (binding-symbol b) name) (return b))))
     45(defun find-binding (symbol-name bindings)
     46  (find symbol-name bindings :key #'variable-object-symbol-name :test #'eq))
    6047
    6148;;; GET-VARIABLE-OBJECT  --  Internal
    … …  
    6451;;; or die trying.
    6552;;;
    66 (defun get-variable-object (name kind where)
    67   (case kind
     53(defun get-variable-object (name kind &optional where)
     54  (or (lookup-variable-object name kind where)
     55      (undefined-variable-error name)))
     56
     57(defun lookup-variable-object (name kind where)
     58  (ecase kind
    6859    (:current
    69      (let ((obj (get name 'hemlock-variable-value)))
    70        (if obj obj (undefined-variable-error name))))
     60     (let ((buffer (current-buffer)))
     61       (if (null buffer)
     62         (lookup-variable-object name :global t)
     63         (or (find-binding name (buffer-var-values buffer))
     64             (loop for mode in (buffer-minor-mode-objects buffer)
     65               thereis (find-binding name (mode-object-var-values mode)))
     66             (find-binding name (mode-object-var-values (buffer-major-mode-object buffer)))
     67             (get name 'hemlock-variable-value)))))
    7168    (:buffer
    72      (check-type where buffer)
    73      (let ((binding (find-binding name (buffer-var-values where))))
    74        (unless binding
    75          (error "~S is not a defined Hemlock variable in buffer ~S." name where))
    76        (binding-object binding)))
     69     (find-binding name (buffer-var-values (ccl:require-type where 'buffer))))
     70    (:mode
     71     (find-binding name (mode-object-var-values (get-mode-object where))))
    7772    (:global
    78      (do ((obj (get name 'hemlock-variable-value)
    79                (variable-object-down obj))
    80           (prev nil obj))
    81          ((symbolp obj)
    82           (unless prev (undefined-variable-error name))
    83           (unless (eq obj :global)
    84             (error "Hemlock variable ~S is not globally defined." name))
    85           prev)))
    86     (:mode
    87      (let ((binding (find-binding name (mode-object-var-values
    88                                         (get-mode-object where)))))
    89        (unless binding
    90          (error "~S is not a defined Hemlock variable in mode ~S." name where))
    91        (binding-object binding)))
    92     (t
    93      (error "~S is not a defined value for Kind." kind))))
     73     (get name 'hemlock-variable-value))))
    9474
    9575;;; VARIABLE-VALUE  --  Public
    … …  
    10080  "Return the value of the Hemlock variable given."
    10181  (variable-object-value (get-variable-object name kind where)))
    102 
    103 ;;; %VALUE  --  Internal
    104 ;;;
    105 ;;;    This function is called by the expansion of Value.
    106 ;;;
    107 (defun %value (name)
    108   (let ((obj (get name 'hemlock-variable-value)))
    109     (unless obj (undefined-variable-error name))
    110     (variable-object-value obj)))
    111 
    112 ;;; %SET-VALUE  --  Internal
    113 ;;;
    114 ;;;    The setf-inverse of Value, set the current value.
    115 ;;;
    116 (defun %set-value (var new-value)
    117   (let ((obj (get var 'hemlock-variable-value)))
    118     (unless obj (undefined-variable-error var))
    119     (invoke-hook (variable-object-hooks obj) var :current nil new-value)
    120     (setf (variable-object-value obj) new-value)))
    12182
    12283;;; %SET-VARIABLE-VALUE  --  Internal
    … …  
    12990    (setf (variable-object-value obj) new-value)))
    13091
     92;;; %VALUE  --  Internal
     93;;;
     94;;;    This function is called by the expansion of Value.
     95;;;
     96(defun %value (name)
     97  (variable-value name :current t))
     98
     99;;; %SET-VALUE  --  Internal
     100;;;
     101;;;    The setf-inverse of Value, set the current value.
     102;;;
     103(defun %set-value (name new-value)
     104  (%set-variable-value name :current t new-value))
     105
     106
    131107;;; VARIABLE-HOOKS  --  Public
    132108;;;
    … …  
    173149  "Returns T Name is a Hemlock variable defined in the specifed place, or
    174150  NIL otherwise."
    175   (case kind
    176     (:current (not (null (get name 'hemlock-variable-value))))
    177     (:buffer
    178      (check-type where buffer)
    179      (not (null (find-binding name (buffer-var-values where)))))
    180     (:global
    181      (do ((obj (get name 'hemlock-variable-value)
    182                (variable-object-down obj)))
    183          ((symbolp obj) (eq obj :global))))
    184     (:mode
    185      (not (null (find-binding name (mode-object-var-values
    186                                     (get-mode-object where))))))))
     151  (not (null (lookup-variable-object name kind where))))
     152
    187153
    188154(declaim (special *global-variable-names*))
    … …  
    194160(defun defhvar (name documentation &key mode buffer (hooks nil hook-p)
    195161                     (value nil value-p))
    196   (let* ((symbol-name (string-to-variable name))
    197          (new-binding (make-variable-object documentation name))
    198          (plist (symbol-plist symbol-name))
    199          (prop (cdr (or (member 'hemlock-variable-value plist)
    200                         (setf (symbol-plist symbol-name)
    201                               (list* 'hemlock-variable-value nil plist)))))
    202          (kind :global) where string-table)
     162  (let* ((symbol-name (string-to-variable name)) var)
    203163    (cond
    204       (mode
    205        (setq kind :mode  where mode)
    206        (let* ((obj (get-mode-object where))
    207               (vars (mode-object-var-values obj)))
    208          (setq string-table (mode-object-variables obj))
    209          (unless (find-binding symbol-name vars)
    210            (let ((binding (make-binding prop new-binding vars symbol-name)))
    211              (cond ((member obj (buffer-mode-objects *current-buffer*))
    212                     (let ((l (unwind-bindings *current-buffer* obj)))
    213                       (setf (mode-object-var-values obj) binding)
    214                       (wind-bindings *current-buffer* l)))
    215                    (t
    216                     (setf (mode-object-var-values obj) binding)))))))
    217       (buffer
    218        (check-type buffer buffer)
    219        (setq kind :buffer  where buffer  string-table (buffer-variables buffer))
    220        (let ((vars (buffer-var-values buffer)))
    221          (unless (find-binding symbol-name vars)
    222            (let ((binding (make-binding prop new-binding vars symbol-name)))
    223              (setf (buffer-var-values buffer) binding)
    224              (when (buffer-bindings-wound-p buffer)
    225                (setf (variable-object-down new-binding) (car prop)
    226                      (car prop) new-binding))))))
    227       (t
    228        (setq string-table *global-variable-names*)
    229        (unless (hemlock-bound-p symbol-name :global)
    230          (setf (variable-object-down new-binding) :global)
    231          (when *current-buffer*
    232            (let ((l (unwind-bindings *current-buffer* nil)))
    233              (setf (car prop) new-binding)
    234              (wind-bindings *current-buffer* l))))))
    235     (setf (getstring name string-table) symbol-name)
     164     (mode
     165      (let* ((mode-obj (get-mode-object mode)))
     166        (setf (getstring name (mode-object-variables mode-obj)) symbol-name)
     167        (unless (setq var (find-binding symbol-name (mode-object-var-values mode-obj)))
     168          (push (setq var (make-variable-object symbol-name))
     169                (mode-object-var-values mode-obj)))))
     170     (buffer
     171      (check-type buffer buffer)
     172      (setf (getstring name (buffer-variables buffer)) symbol-name)
     173      (unless (setq var (find-binding symbol-name (buffer-var-values buffer)))
     174        (push (setq var (make-variable-object symbol-name))
     175              (buffer-var-values buffer))))
     176     (t
     177      (setf (getstring name *global-variable-names*) symbol-name)
     178      (unless (setq var (get symbol-name 'hemlock-variable-value))
     179        (setf (get symbol-name 'hemlock-variable-value)
     180              (setq var (make-variable-object symbol-name))))))
     181    (setf (variable-object-name var) name)
     182    (when (> (length documentation) 0)
     183      (setf (variable-object-documentation var) documentation))
    236184    (when hook-p
    237       (setf (variable-hooks symbol-name kind where) hooks))
     185      (setf (variable-object-hooks var) hooks))
    238186    (when value-p
    239       (setf (variable-value symbol-name kind where) value)))
     187      (setf (variable-object-value var) value)))
    240188  name)
    241 
    242 ;;; DELETE-BINDING  --  Internal
    243 ;;;
    244 ;;;    Delete a binding from a list of bindings.
    245 ;;;
    246 (defun delete-binding (binding bindings)
    247   (do ((b bindings (binding-across b))
    248        (prev nil b))
    249       ((eq b binding)
    250        (cond (prev
    251               (setf (binding-across prev) (binding-across b))
    252               bindings)
    253              (t
    254               (binding-across bindings))))))
    255189
    256190;;; DELETE-VARIABLE  --  Public
    … …  
    263197  (let* ((obj (get-variable-object name kind where))
    264198         (sname (variable-object-name obj)))
    265     (case kind
     199    (ecase kind
    266200      (:buffer
    267201       (let* ((values (buffer-var-values where))
    268202              (binding (find-binding name values)))
    269203         (invoke-hook hemlock::delete-variable-hook name :buffer where)
    270          (delete-string sname (buffer-variables where))
    271          (setf (buffer-var-values where) (delete-binding binding values))
    272          (when (buffer-bindings-wound-p where)
    273            (setf (car (binding-cons binding)) (variable-object-down obj)))))
     204         (delete-string sname (buffer-variables where))
     205         (setf (buffer-var-values where) (delete binding values))))
    274206      (:mode
    275207       (let* ((mode (get-mode-object where))
    … …  
    278210         (invoke-hook hemlock::delete-variable-hook name :mode where)
    279211         (delete-string sname (mode-object-variables mode))
    280          (if (member mode (buffer-mode-objects *current-buffer*))
    281              (let ((l (unwind-bindings *current-buffer* mode)))
    282                (setf (mode-object-var-values mode)
    283                      (delete-binding binding values))
    284                (wind-bindings *current-buffer* l))
    285              (setf (mode-object-var-values mode)
    286                    (delete-binding binding values)))))
     212         (setf (mode-object-var-values mode) (delete binding values))))
    287213      (:global
    288214       (invoke-hook hemlock::delete-variable-hook name :global nil)
    289215       (delete-string sname *global-variable-names*)
    290        (let ((l (unwind-bindings *current-buffer* nil)))
    291          (setf (get name 'hemlock-variable-value) nil)
    292          (wind-bindings *current-buffer* l)))
    293       (t (error "Invalid variable kind: ~S" kind)))
     216       (setf (get name 'hemlock-variable-value) nil)))
    294217    nil))

  • branches/event-ide/ccl/cocoa-ide/hemlock/src/views.lisp

    r7993 r8062  
    246246             (text-buffer (hemlock-view-buffer view))
    247247             (mod (buffer-modification-state text-buffer)))
    248         (with-buffer-bindings (*current-buffer*)
    249           (modifying-buffer-storage (*current-buffer*)
    250             (restart-case
    251                 (handler-bind ((error #'lisp-error-error-handler))
    252                   (execute-hemlock-key view key))
    253               (exit-event-handler () :report "Exit from hemlock event handler")))
    254           ;; Update display
    255           (if *next-view-start*
    256             (destructuring-bind (how . where) *next-view-start*
    257               (hemlock-ext:scroll-view view how where))
    258             (unless (equal mod (buffer-modification-state text-buffer))
    259               ;; Modified buffer, make sure user sees what happened
    260               (hemlock-ext:ensure-selection-visible view)))
    261           (update-echo-area-after-command view))))))
     248        (modifying-buffer-storage (*current-buffer*)
     249          (restart-case
     250              (handler-bind ((error #'lisp-error-error-handler))
     251                (execute-hemlock-key view key))
     252            (exit-event-handler () :report "Exit from hemlock event handler")))
     253        ;; Update display
     254        (if *next-view-start*
     255          (destructuring-bind (how . where) *next-view-start*
     256            (hemlock-ext:scroll-view view how where))
     257          (unless (equal mod (buffer-modification-state text-buffer))
     258            ;; Modified buffer, make sure user sees what happened
     259            (hemlock-ext:ensure-selection-visible view)))
     260        (update-echo-area-after-command view)))))
Note: See TracChangeset for help on using the changeset viewer.