Changeset 14985


Ignore:
Timestamp:
Sep 16, 2011, 6:39:24 PM (8 years ago)
Author:
gfoy
Message:

Updates for ccl 1.7

Location:
trunk/cocoa-ide-contrib/foy
Files:
3 added
2 deleted
26 edited

Legend:

Unmodified
Added
Removed
  • trunk/cocoa-ide-contrib/foy/cl-documentation-cm/cl-documentation-2.lisp

    r12784 r14985  
    1010;;;      This code adds an alphabetical index of :CL commands to the Context-Menu
    1111;;;      mechanism.  Command-Right-Click displays a list of letter submenus.
    12 ;;;      Popping the submenu displays entries for all Hemlock Commands starting with
     12;;;      Popping the submenu displays entries for all CL functions starting with
    1313;;;      that letter.  Selecting an entry opens a documentation dialog.
    1414;;;
     
    2626;;; ----------------------------------------------------------------------------
    2727;;;
    28 (defclass CL-ALPHABETICAL-MENU-ITEM (ns:ns-menu-item)
     28(defClass CL-ALPHABETICAL-MENU-ITEM (ns:ns-menu-item)
    2929  ((symbol :initarg :symbol :accessor item-symbol))
    3030  (:documentation "Support for the CL alphabetical menu.")
     
    5858    menu-item))
    5959
    60 (defparameter *ABCs* "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
     60(defParameter *abcs* "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
    6161
    6262;;; ----------------------------------------------------------------------------
    6363;;;
    64 (defclass CL-ALPHABETICAL-MENU (ns:ns-menu)
     64(defClass CL-ALPHABETICAL-MENU (ns:ns-menu)
    6565  ((tool-menu :initform nil :accessor tool-menu)
    6666   (text-view :initform nil :accessor text-view)
     
    7272  (display-cl-doc (item-symbol sender) (text-view m)))
    7373
    74 (defmethod initialize-instance :after ((menu cl-alphabetical-menu) &key)
     74#+install-cl-doc-as-context-menu
     75(defMethod initialize-instance :after ((menu cl-alphabetical-menu) &key)
    7576  (setf (tool-menu menu) (cmenu:add-default-tool-menu menu)))
    7677
    77 (defmethod add-submenus ((menu cl-alphabetical-menu))
     78;;; (defmethod add-submenus ((menu cl-alphabetical-menu))
     79(defun add-submenus (menu)
    7880  (let* ((letter-array-length (length *ABCs*))
    7981         (letter-array (make-array letter-array-length :initial-element nil))
     
    9698
    9799(objc:defmethod (#/update :void) ((self cl-alphabetical-menu))
    98   (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self))
     100  (when (tool-menu self)
     101    (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self)))
    99102  (call-next-method))
    100103
     
    103106(add-submenus *cl-alphabetical-menu*)
    104107
     108#-install-cl-doc-as-context-menu
     109(let ((menu-item (make-instance ns:ns-menu-item)))
     110  (#/setTitle: menu-item (ccl::%make-nsstring "Common Lisp, Alphabetical"))
     111  (#/setSubmenu: menu-item *cl-alphabetical-menu*)
     112  (#/addItem: *help-menu* menu-item))
    105113
    106114
  • trunk/cocoa-ide-contrib/foy/cl-documentation-cm/cl-documentation.lisp

    r12735 r14985  
    1414;;;      functional group.  Selecting a function open a documentation dialog.
    1515;;;
     16;;;      See the NOTE: below about selecting the Help Menu or the Context-Menu.
     17;;;
    1618;;;      This software is offered "as is", without warranty of any kind.
    1719;;;
     
    2325;;; ----------------------------------------------------------------------------
    2426
    25 (defpackage "CL-DOCUMENTATION" (:nicknames "CLDOC") (:use :cl :ccl))
     27(defPackage "CL-DOCUMENTATION" (:nicknames "CLDOC") (:use :cl :ccl))
    2628(in-package "CL-DOCUMENTATION")
    2729
     
    2931(cmenu:check-hyperspec-availability "CL-Documentation-CM")
    3032
    31 (defparameter *cl-documentation-menu* nil "The cl-documentation-menu instance.")
    32 (defparameter *cl-alphabetical-menu* nil "The cl-alphabetical-menu instance.")
     33;;; NOTE:
     34;;; If you want this utility in the context menu, uncomment the pushnew.
     35;;; If you want it under the Help Menu, leave as is.
     36;;; (pushnew :install-cl-doc-as-context-menu *features*)
     37
     38(defParameter *cl-documentation-menu* nil "The cl-documentation-menu instance.")
     39(defParameter *cl-alphabetical-menu* nil "The cl-alphabetical-menu instance.")
    3340
    3441
     
    4754
    4855(objc:defmethod (#/update :void) ((m cl-documentation-menu))
    49   (cmenu:update-tool-menu m (tool-menu m) :sub-title (sub-title m))
     56  (when (tool-menu m)
     57    (cmenu:update-tool-menu m (tool-menu m) :sub-title (sub-title m)))
    5058  (call-next-method))
    5159
    52 (defmethod initialize-instance :after ((m cl-documentation-menu) &key)
     60#+install-cl-doc-as-context-menu
     61(defMethod initialize-instance :after ((m cl-documentation-menu) &key)
    5362  (setf (tool-menu m) (cmenu:add-default-tool-menu m :doc-file (doc-path m))))
    5463
     
    470479         *cl-documentation-menu*)))
    471480
     481#-install-cl-doc-as-context-menu
     482(defParameter *help-menu*
     483  (#/submenu (#/itemWithTitle: (#/mainMenu (ccl::application-ui-object ccl::*application*)) #@"Help")))
     484
     485#-install-cl-doc-as-context-menu
     486(let ((menu-item (make-instance ns:ns-menu-item)))
     487  (#/setTitle: menu-item (ccl::%make-nsstring "Common Lisp, Functional Groups"))
     488  (#/setSubmenu: menu-item *cl-documentation-menu*)
     489  (#/addItem: *help-menu* menu-item))
     490
     491#+install-cl-doc-as-context-menu
    472492(cmenu:register-tool "CL-Documentation-CM" #'get-cl-documentation-menu)
  • trunk/cocoa-ide-contrib/foy/context-menu-cm/context-menu-dialogs.lisp

    r12802 r14985  
    1717;;; ----------------------------------------------------------------------------
    1818
    19 (defpackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
     19(defPackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
    2020(in-package "CONTEXT-MENU")
    2121
    2222(export '(notify window-with-path active-hemlock-window window-path echo-msg))
    2323
    24 (defparameter *clozure-jpg* (merge-pathnames ";Clozure.jpg" cl-user::*context-menu-directory*))
    25 (defparameter *graphic-p* t "To use, or not to use the Clozure graphic.")
     24(defParameter *clozure-jpg* (merge-pathnames ";Clozure.jpg" cl-user::*context-menu-directory*))
     25(defParameter *graphic-p* t "To use, or not to use the Clozure graphic.")
    2626
    2727
     
    7171      (gui::alert-window :title "Notification" :message message-string))))
    7272
    73 (defparameter *notify-dialog* nil "The notification-dialog instance.")
     73(defParameter *notify-dialog* nil "The notification-dialog instance.")
    7474
    7575;;; ----------------------------------------------------------------------------
    7676;;;
    77 (defclass NOTIFICATION-DIALOG (ns:ns-window)
     77(defClass NOTIFICATION-DIALOG (ns:ns-window)
    7878  ((message-field :initform nil :accessor nd-message-field)
    7979   (okay-button :initform nil :accessor nd-okay-button))
     
    120120|#
    121121
    122 (defmethod get-notify-items ((d notification-dialog))
     122(defMethod get-notify-items ((d notification-dialog))
    123123  (append
    124124   (make-notify-graphic)
  • trunk/cocoa-ide-contrib/foy/context-menu-cm/context-menu.lisp

    r13662 r14985  
    1717;;;
    1818;;;      Mod History, most recent first:
     19;;;      8/14/11 Added a "save histories" context menu-item.
     20;;;      1/6/10  Bogus param to format in add-default-tool-menu.
    1921;;;      9/2/9   Changed the appearance of the Default Tool submenu.
    2022;;;      8/31/9  version 0.1b1
     
    2426;;; ----------------------------------------------------------------------------
    2527
    26 (defpackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
     28(defPackage "CONTEXT-MENU" (:nicknames "CMENU") (:use :cl :ccl))
    2729(in-package "CONTEXT-MENU")
    2830
     
    3234          *wine-red-color* check-hyperspec-availability))
    3335
    34 (defparameter *menu-manager* nil "The context-menu-manager instance.")
    35 
    36 (defparameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
    37 (defparameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.28 0.28 1.0))
    38 (defparameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
    39 (defparameter *light-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0))
    40 
    41 (defparameter *hemlock-menu-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     36(defParameter *menu-manager* nil "The context-menu-manager instance.")
     37
     38(defParameter *DARK-BLUE-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
     39(defParameter *DARK-TURQUOISE-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.28 0.28 1.0))
     40(defParameter *WINE-RED-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
     41(defParameter *LIGHT-GRAY-COLOR* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0))
     42
     43(defParameter *HEMLOCK-MENU-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    4244(#/setObject:forKey: *hemlock-menu-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    4345(#/setObject:forKey: *hemlock-menu-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
    4446
    45 (defparameter *tool-label-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     47(defParameter *TOOL-LABEL-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    4648(#/setObject:forKey: *tool-label-dictionary* (#/systemFontOfSize: ns:ns-font (#/systemFontSize ns:ns-font)) #&NSFontAttributeName)
    4749(#/setObject:forKey: *tool-label-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
    4850
    49 (defparameter *tool-doc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     51(defParameter *TOOL-DOC-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    5052(#/setObject:forKey: *tool-doc-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    5153(#/setObject:forKey: *tool-doc-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
    5254
    53 (defparameter *tool-key-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     55(defParameter *TOOL-KEY-DICTIONARY* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    5456(#/setObject:forKey: *tool-key-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    5557(#/setObject:forKey: *tool-key-dictionary* *wine-red-color* #&NSForegroundColorAttributeName)
     
    5759;;; ----------------------------------------------------------------------------
    5860;;;
    59 (defclass CONTEXT-MENU-MANAGER ()
     61(defClass CONTEXT-MENU-MANAGER ()
    6062  ((tool-alist :initform nil :accessor tool-alist)
    6163   (default-tool :initform nil :accessor default-tool))
    6264  (:documentation "A class to manage Hemlock's contextual popup menu, supporting access by multiple tools."))
    6365
    64 (defmethod display-menu ((manager context-menu-manager) view event)
     66(defMethod display-menu ((manager context-menu-manager) view event)
    6567  (when (default-tool manager)
    6668    (let ((entry (assoc (default-tool manager) (tool-alist manager) :test #'string-equal)))
     
    7173  (display-menu *menu-manager* view event))
    7274
    73 (defun register-tool (tool-name menu-function)
     75(defun REGISTER-TOOL (tool-name menu-function)
    7476  "Register the new tool with the menu-manager.  The last tool registered becomes the default tool."
    7577  (let ((entry (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car)))
     
    8486           (set-default-tool tool-name)))))
    8587
    86 (defun set-default-tool (tool-name)
     88(defun SET-DEFAULT-TOOL (tool-name)
    8789  "Set the menu-manager's default tool.  Right-Click will display this tool's menu."
    8890  (let ((registered-name (car (find tool-name (tool-alist *menu-manager*) :test #'string-equal :key #'car))))
     
    9395;;; ----------------------------------------------------------------------------
    9496;;;
    95 (defclass DEFAULT-TOOL-MENU-ITEM (ns:ns-menu-item)
     97(defClass DEFAULT-TOOL-MENU-ITEM (ns:ns-menu-item)
    9698  ((name :accessor tool-name)) ; Lisp string
    9799  (:documentation "Support for the Tool submenu.")
     
    100102;;; ----------------------------------------------------------------------------
    101103;;;
    102 (defclass DEFAULT-TOOL-DOC-MENU-ITEM (ns:ns-menu-item)
     104(defClass DEFAULT-TOOL-DOC-MENU-ITEM (ns:ns-menu-item)
    103105  ((filename :accessor tool-filename))
    104106  (:documentation "A menu-item to display the default tool's documentation.")
     
    107109;;; ----------------------------------------------------------------------------
    108110;;;
    109 (defclass DEFAULT-TOOL-MENU (ns:ns-menu)
     111(defClass DEFAULT-TOOL-MENU (ns:ns-menu)
    110112  ()
    111113  (:documentation "A submenu displaying all registered tools.")
     
    117119(objc:defmethod (#/hemlockDefaultToolDocAction: :void) ((m default-tool-menu) (sender :id))
    118120  (display-doc (tool-filename sender)))
     121
     122;;; silence the compiler:
     123(defPackage "LIST-DEFINITIONS" (:nicknames "LDEFS") (:use :cl :ccl))
     124(declaim (ftype function ldefs::write-history-files))
     125
     126(objc:defmethod (#/hemlockDefaultToolHistoryAction: :void) ((m default-tool-menu) (sender :id))
     127  (declare (ignore sender))
     128  (ldefs::write-history-files))
    119129
    120130(defun display-doc (path)
     
    125135                                 (ccl::%make-nsstring "TextEdit"))))
    126136 
    127 (defmethod populate-menu ((menu default-tool-menu))
     137(defMethod populate-menu ((menu default-tool-menu))
    128138  (dotimes (count (#/numberOfItems menu))
    129139    (#/removeItemAtIndex: menu 0))
     
    145155      (create-menu-item (car entry)))))
    146156
    147 (defun add-default-tool-menu (menu &key doc-file)
     157(defun ADD-DEFAULT-TOOL-MENU (menu &key doc-file)
    148158  "Add the default tool submenu and possibly a documentation menu-item to MENU."
    149159  (let ((default-item (make-instance ns:ns-menu-item))
     
    156166                 (attributed-string (#/initWithString:attributes:
    157167                                     (#/alloc ns:ns-attributed-string)
    158                                      (ccl::%make-nsstring (format nil "~A     doc..." (default-tool *menu-manager*)))
     168                                     (ccl::%make-nsstring (format nil "     doc..."))
     169                                     *tool-doc-dictionary*))
     170                 (save-histories-item (make-instance 'default-tool-doc-menu-item))
     171                 (attributed-string-2 (#/initWithString:attributes:
     172                                     (#/alloc ns:ns-attributed-string)
     173                                     (ccl::%make-nsstring (format nil "     save histories"))
    159174                                     *tool-doc-dictionary*)))
    160175             (#/setAttributedTitle: doc-item attributed-string)
     
    162177             (#/setTarget: doc-item  tool-menu)
    163178             (setf (tool-filename doc-item) doc-file)
    164              (#/insertItem:atIndex: menu doc-item 1))
    165           (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 2))
     179             (#/insertItem:atIndex: menu doc-item 1)
     180
     181             (#/setAttributedTitle: save-histories-item attributed-string-2)
     182             (#/setAction: save-histories-item (ccl::@selector "hemlockDefaultToolHistoryAction:"))
     183             (#/setTarget: save-histories-item  tool-menu)
     184;;             (setf (tool-filename doc-item) doc-file)
     185             (#/insertItem:atIndex: menu save-histories-item 2))
     186          (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 3))
    166187          (t
    167            (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 1)))
     188           (let ((save-histories-item (make-instance 'default-tool-doc-menu-item))
     189                 (attributed-string-2 (#/initWithString:attributes:
     190                                     (#/alloc ns:ns-attributed-string)
     191                                     (ccl::%make-nsstring (format nil "     save histories"))
     192                                     *tool-doc-dictionary*)))
     193             (#/setAttributedTitle: save-histories-item attributed-string-2)
     194             (#/setAction: save-histories-item (ccl::@selector "hemlockDefaultToolHistoryAction:"))
     195             (#/setTarget: save-histories-item  tool-menu)
     196;;             (setf (tool-filename save-histories-item) nil)
     197             (#/insertItem:atIndex: menu save-histories-item 1)
     198             (#/insertItem:atIndex: menu (#/separatorItem ns:ns-menu-item) 2))))
    168199    tool-menu))
    169200
    170 (defun update-tool-menu (menu default-menu &key sub-title)
     201(defun UPDATE-TOOL-MENU (menu default-menu &key sub-title)
    171202  "Update MENU's Tool submenu."
    172203  (let ((first-item (#/itemAtIndex: menu 0))
     
    182213
    183214(let (checked-p)
    184 (defun check-hyperspec-availability (tool-name)
     215(defun CHECK-HYPERSPEC-AVAILABILITY (tool-name)
    185216  "Some tools require the HyperSpec."
    186217  (unless (or checked-p gui::*hyperspec-root-url*)
  • trunk/cocoa-ide-contrib/foy/hemlock-commands-cm/hemlock-commands-1.lisp

    r12745 r14985  
    1212;;;      for the new users.  Selecting an entry executes the command.
    1313;;;
     14;;;      See the NOTE: below about selecting the Help Menu or the Context-Menu.
     15;;;
    1416;;;      This software is offered "as is", without warranty of any kind.
    1517;;;
    1618;;;      Mod History, most recent first:
     19;;;      1/6/10  Editor Compile Defun and Editor Evaluate Defun bit the dust.
     20;;;              Editor Execute Defun instead.
    1721;;;      9/2/9   Removed doc-path from hemlock-commands-menu.
    1822;;;      8/31/9  version 0.1b1
     
    2125;;; ----------------------------------------------------------------------------
    2226
    23 (defpackage "HEMLOCK-COMMANDS" (:nicknames "HCOM") (:use :cl :ccl))
     27(defPackage "HEMLOCK-COMMANDS" (:nicknames "HCOM") (:use :cl :ccl :hemlock-internals))
    2428(in-package "HEMLOCK-COMMANDS")
    2529
     
    2731(cmenu:check-hyperspec-availability "Hemlock-Commands-CM")
    2832
    29 (defparameter *hemlock-commands-menu* nil "The hemlock-commands-menu instance.")
    30 (defparameter *hemlock-commands-keyword-menu* nil "The hemlock-commands-keyword-menu instance.")
    31 
    32 ;;; ----------------------------------------------------------------------------
    33 ;;;
    34 (defclass HEMLOCK-COMMAND-MENU-ITEM (ns:ns-menu-item)
    35   ((key-event :initform nil :accessor key-event))
     33;;; NOTE:
     34;;; If you want this utility in the context menu, uncomment the pushnew.
     35;;; If you want it under the help menu, leave as is.
     36;;; (pushnew :install-hemlock-doc-as-context-menu *features*)
     37
     38(defParameter *hemlock-commands-menu* nil "The hemlock-commands-menu instance.")
     39(defParameter *hemlock-commands-keyword-menu* nil "The hemlock-commands-keyword-menu instance.")
     40
     41;;; ----------------------------------------------------------------------------
     42;;;
     43(defClass HEMLOCK-COMMAND-MENU-ITEM (ns:ns-menu-item)
     44  ((key-event :initform nil :accessor key-event)
     45   (name :initform nil :accessor name))
    3646  (:documentation "Support for the hemlock-commands-menu.")
    3747  (:metaclass ns:+ns-object))
     
    4050;;; ----------------------------------------------------------------------------
    4151;;;
    42 (defclass HEMLOCK-COMMANDS-MENU (ns:ns-menu)
     52(defClass HEMLOCK-COMMANDS-MENU (ns:ns-menu)
    4353  ((tool-menu :initform nil :accessor tool-menu)
    4454   (sub-title :initform "basic commands" :reader sub-title)
     
    4757  (:metaclass ns:+ns-object))
    4858
     59(defun get-value-node-command (name)
     60  (dotimes (index (hi::string-table-num-nodes hi::*command-names*))
     61    (let* ((command (hi::value-node-value (aref (hi::string-table-value-nodes hi::*command-names*) index)))
     62           (command-name (hi::command-%name command)))
     63      (when (string-equal name command-name)
     64        (return command)))))
     65
    4966(objc:defmethod (#/hemlockCommandAction: :void) ((m hemlock-commands-menu) (sender :id))
    50   (let ((key-event (key-event sender))) ; can be a vector of events
    51     (cond ((typep key-event 'hi::key-event)
    52            (hi::handle-hemlock-event (gui::hemlock-view (text-view m)) key-event))
    53           ((typep (key-event sender) 'simple-vector)
    54            (hi::handle-hemlock-event (gui::hemlock-view (text-view m)) (aref key-event 0))
    55            (hi::handle-hemlock-event (gui::hemlock-view (text-view m)) (aref key-event 1))))))
    56 
    57 (defmethod initialize-instance :after ((menu hemlock-commands-menu) &key)
    58   (flet ((create-menu-item (name key-event)
     67  (let* ((command (get-value-node-command (name sender))))
     68    (when command (display-doc command))))
     69#|
     70    ;; *** do we really want to execute the command here??
     71    (when (null (text-view m)) (setf (text-view m) (get-key-window-text-view)))
     72    (when (text-view m)
     73      (cond ((typep key-event 'hi::key-event)
     74             (hi::handle-hemlock-event (gui::hemlock-view (text-view m)) key-event))
     75            ((typep (key-event sender) 'simple-vector)
     76             (hi::handle-hemlock-event (gui::hemlock-view (text-view m)) (aref key-event 0))
     77             (hi::handle-hemlock-event (gui::hemlock-view (text-view m)) (aref key-event 1)))))))
     78|#
     79
     80(defMethod initialize-instance :after ((menu hemlock-commands-menu) &key)
     81  (flet ((create-menu-item (long-name name key-event)
    5982           (let ((menu-item (make-instance 'hemlock-command-menu-item))
    6083                 (attributed-string (#/initWithString:attributes:
    6184                                     (#/alloc ns:ns-attributed-string)
    62                                      (ccl::%make-nsstring name)
     85                                     (ccl::%make-nsstring long-name)
    6386                                     cmenu:*hemlock-menu-dictionary*)))
    6487             (#/setAttributedTitle: menu-item attributed-string)
     
    6689             (#/setTarget: menu-item  menu)
    6790             (setf (key-event menu-item) key-event)
     91             (setf (name menu-item) name)
    6892             (#/addItem: menu menu-item))))
     93
     94#+install-hemlock-doc-as-context-menu
    6995    (setf (tool-menu menu) (cmenu:add-default-tool-menu menu))
    7096   
    7197    ;;; Hemlock's Greatest Hits:
    72     (create-menu-item "Inspect Symbol  (control-x, control-i)"
     98    (create-menu-item "Inspect Symbol  (control-x, control-i)"
     99                      "Inspect Symbol"
    73100                      #k"control-x control-i")
    74101    (create-menu-item "Symbol Documentation  (control-x, control-d)"
     102                      "Symbol Documentation"
    75103                      #k"control-x control-d")
    76104    (#/addItem: menu (#/separatorItem ns:ns-menu-item))
    77     (create-menu-item "Current Function Arglist  (control-x, control-a)"
     105    (create-menu-item "Current Function Arglist  (control-x, control-a)"
     106                      "Current Function Arglist"
    78107                      #k"control-x control-a")
    79108    (create-menu-item "Goto Definition  (meta-.)"
     109                      "Goto Definition"
    80110                      #k"meta-.")
    81111    (create-menu-item "Show Callers  (control-meta-c)"
     112                      "Show Callers"
    82113                      #k"control-meta-c")
    83114    (#/addItem: menu (#/separatorItem ns:ns-menu-item))
    84     (create-menu-item "Macroexpand-1 Expression  (control-m)"
     115    (create-menu-item "Editor Macroexpand-1 Expression  (control-m)"
     116                      "Editor Macroexpand-1 Expression"
    85117                      #k"control-m")
    86     (create-menu-item "Macroexpand Expression  (control-x, control-m)"
     118    (create-menu-item "Editor Macroexpand Expression  (control-x, control-m)"
     119                      "Editor Macroexpand Expression"
    87120                      #k"control-x control-m")
    88121    (#/addItem: menu (#/separatorItem ns:ns-menu-item))
    89     (create-menu-item "Editor Evaluate Defun  (control-x, control-e)"
     122    (create-menu-item "Editor Execute Defun  (control-x, control-c)"
     123                      "Editor Execute Defun"
     124                      #k"control-x control-c")
     125    (create-menu-item "Editor Execute Expression  (control-x, control-e)"
     126                      "Editor Execute Expression"
    90127                      #k"control-x control-e")
    91     (create-menu-item "Editor Compile Defun  (control-x, control-c)"
    92                       #k"control-x control-c")
     128#|
    93129    (create-menu-item "Editor Evaluate Region  (Enter)"
    94                       #k"enter")
    95     #|
     130                      "Editor Evaluate Region"
     131                      #k"enter")
    96132    (create-menu-item "Editor Compile Region  (unbound)"
    97133                      #k"enter")
     
    100136    (create-menu-item "Editor Compile Buffer File  (unbound)"
    101137                      #k"enter")
    102     |#
     138|#
    103139    (#/addItem: menu (#/separatorItem ns:ns-menu-item))
    104140    (create-menu-item "Incremental Search  (control-s)"
     141                      "Incremental Search"
    105142                      #k"control-s")
    106143    (create-menu-item "I-Search Repeat Forward  (control-s)"
     144                      "I-Search Repeat Forward"
    107145                      #k"control-s")
    108146    (create-menu-item "I-Search Repeat Backward  (control-r)"
     147                      "I-Search Repeat Backward"
    109148                      #k"control-r")
    110149    (create-menu-item "I-Search Abort  (control-g)"
     150                      "I-Search Abort"
    111151                      #k"control-g")
    112152    (#/addItem: menu (#/separatorItem ns:ns-menu-item))
     153    (create-menu-item "Delete Next Character  (control-d)"
     154                      "Delete Next Character"
     155                      #k"control-d")
     156    (create-menu-item "Delete Previous Character  (delete)"
     157                      "Delete Previous Character"
     158                      #k"delete")
     159    (create-menu-item "Kill Next Word  (meta-d)"
     160                      "Kill Next Word"
     161                      #k"meta-d")
     162    (create-menu-item "Kill Previous Word  (meta-delete)"
     163                      "Kill Previous Word"
     164                      #k"meta-delete")
    113165    (create-menu-item "Kill Line  (control-k)"
     166                      "Kill Line"
    114167                      #k"control-k")
    115168    (create-menu-item "Un-Kill  (control-y)"
     169                      "Un-Kill"
    116170                      #k"control-y")
    117171    (#/addItem: menu (#/separatorItem ns:ns-menu-item))
    118172    (create-menu-item "Forward Character  (control-f)"
     173                      "Forward Character"
    119174                      #k"control-f")
    120175    (create-menu-item "Backward Character  (control-b)"
     176                      "Backward Character"
    121177                      #k"control-b")
    122178    (create-menu-item "Beginning of Line  (control-a)"
     179                      "Beginning of Line"
    123180                      #k"control-a")
    124181    (create-menu-item "End of Line  (control-e)"
     182                      "End of Line"
    125183                      #k"control-e")
    126184    (create-menu-item "Previous Line  (control-p)"
     185                      "Previous Line"
    127186                      #k"control-p")
    128187    (create-menu-item "Next Line  (control-n)"
     188                      "Next Line"
    129189                      #k"control-n")
    130190    (create-menu-item "Beginning of Buffer  (meta-<)"
     191                      "Beginning of Buffer"
    131192                      #k"meta-\<")
    132193    (create-menu-item "End of Buffer  (meta->)"
     194                      "End of Buffer"
    133195                      #k"meta-\>")
    134196    (create-menu-item "Scroll Window Down  (control-v)"
     197                      "Scroll Window Down"
    135198                      #k"control-v")
    136199    (create-menu-item "Scroll Window Up  (meta-v)"
     200                      "Scroll Window Up"
    137201                      #k"meta-v")))
    138202
    139203(objc:defmethod (#/update :void) ((self hemlock-commands-menu))
    140   (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self))
     204  (when (tool-menu self)
     205    (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self)))
    141206  (call-next-method))
    142207
    143208(setq *hemlock-commands-menu* (make-instance 'hemlock-commands-menu))
     209
     210#|
     211(defun get-key-window-text-view ()
     212  (let ((active-hemlock-window (cmenu:active-hemlock-window)))
     213    (when active-hemlock-window
     214      (slot-value (slot-value active-hemlock-window 'gui::pane) 'gui::text-view))))
     215|#
    144216
    145217(defun get-hemlock-commands-menu (view event)
     
    151223         *hemlock-commands-keyword-menu*)))
    152224
     225#-install-hemlock-doc-as-context-menu
     226(defParameter *help-menu*
     227  (#/submenu (#/itemWithTitle: (#/mainMenu (ccl::application-ui-object ccl::*application*)) #@"Help")))
     228
     229#-install-hemlock-doc-as-context-menu
     230(let ((menu-item (make-instance ns:ns-menu-item)))
     231  (#/setTitle: menu-item (ccl::%make-nsstring "Hemlock, Basic Commands"))
     232  (#/setSubmenu: menu-item *hemlock-commands-menu*)
     233  (#/addItem: *help-menu* menu-item))
     234
     235#+install-hemlock-doc-as-context-menu
    153236(cmenu:register-tool "Hemlock-Commands-CM" #'get-hemlock-commands-menu)
    154237
  • trunk/cocoa-ide-contrib/foy/hemlock-commands-cm/hemlock-commands-2.lisp

    r12735 r14985  
    2525;;; ----------------------------------------------------------------------------
    2626;;;
    27 (defclass HEMLOCK-COMMAND-KEYWORD-MENU-ITEM (ns:ns-menu-item)
     27(defClass HEMLOCK-COMMAND-KEYWORD-MENU-ITEM (ns:ns-menu-item)
    2828  ((command :initform nil :accessor item-command))
    2929  (:documentation "Support for the hemlock command keyword menu.")
     
    3232(defun display-doc (command)
    3333  "Open the documentation dialog for COMMAND."
     34  ;; (format t "~%bindings: ~S" (hi::command-%bindings command))
    3435  (let ((keystroke-string
    35          (do* ((bindings (hi::command-%bindings command) (rest bindings))
     36         (do* ((bindings (remove-duplicates (hi::command-%bindings command) :test 'equalp)
     37                         (rest bindings))
    3638               (bindings-length (length bindings))
    3739               (binding (car bindings) (car bindings))
     
    9496    menu-item))
    9597
    96 (defparameter *hemlock-command-keywords*
     98(defParameter *hemlock-command-keywords*
    9799  '("auto" "backward" "beginning" "buffer" "character" "command" "comment" "compile" "completion" "count" "defun" "delete" "describe"
    98100    "down" "echo" "editor" "end" "evaluate" "expression" "file" "form" "forward" "function" "goto" "help" "i-search"
     
    103105;;; ----------------------------------------------------------------------------
    104106;;;
    105 (defclass HEMLOCK-COMMANDS-KEYWORD-MENU (ns:ns-menu)
     107(defClass HEMLOCK-COMMANDS-KEYWORD-MENU (ns:ns-menu)
    106108  ((tool-menu :initform nil :accessor tool-menu)
    107109   (sub-title :initform "keyword filters" :reader sub-title)
     
    113115  (display-doc (item-command sender)))
    114116
    115 (defmethod initialize-instance :after ((menu hemlock-commands-keyword-menu) &key)
     117#+install-hemlock-doc-as-context-menu
     118(defMethod initialize-instance :after ((menu hemlock-commands-keyword-menu) &key)
    116119  (setf (tool-menu menu) (cmenu:add-default-tool-menu menu :doc-file (doc-path menu))))
    117120
    118 (defmethod add-submenus ((menu hemlock-commands-keyword-menu))
     121(defMethod add-submenus ((menu hemlock-commands-keyword-menu))
    119122  (let ((keyword-array (make-array  (length *hemlock-command-keywords*) :initial-element nil))
    120123        miscellaneous)
     
    138141    (when miscellaneous
    139142      (#/addItem: menu (#/separatorItem ns:ns-menu-item))   
    140       (let ((submenu-item (make-submenu-item "Commands Without Keywords:" miscellaneous)))
     143      (let ((submenu-item (make-submenu-item "Others:" miscellaneous)))
    141144        (#/addItem: menu submenu-item)))))
    142145
    143146
    144147(objc:defmethod (#/update :void) ((self hemlock-commands-keyword-menu))
    145   (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self))
     148  (when (tool-menu self)
     149    (cmenu:update-tool-menu self (tool-menu self) :sub-title (sub-title self)))
    146150  (call-next-method))
    147151
     
    151155(add-submenus *hemlock-commands-keyword-menu*)
    152156
     157#-install-hemlock-doc-as-context-menu
     158(let ((menu-item (make-instance ns:ns-menu-item)))
     159  (#/setTitle: menu-item (ccl::%make-nsstring "Hemlock, Keyword Sort"))
     160  (#/setSubmenu: menu-item *hemlock-commands-keyword-menu*)
     161  (#/addItem: *help-menu* menu-item))
    153162
    154163
    155164
     165
     166
     167
  • trunk/cocoa-ide-contrib/foy/hemlock-commands-cm/hemlock-commands-new.lisp

    r12745 r14985  
    88;;;      (Permission is granted to Clozure Associates to distribute this file.)
    99;;;
    10 ;;;      This code implements a two new Hemlock commands.
     10;;;      This code implements a three new Hemlock commands.
    1111;;;
    1212;;;      This software is offered "as is", without warranty of any kind.
     
    2121(in-package "HEMLOCK-COMMANDS")
    2222
    23 (defparameter *MCL-doc* (merge-pathnames ";MCL-doc.lisp" cl-user::*hemlock-commands-directory*))
     23(defParameter *mcl-doc* (merge-pathnames ";MCL-doc.lisp" cl-user::*hemlock-commands-directory*))
    2424
    2525;;; Hemlock has some internal code to do this, but it appears to be broken
     
    5959        symbol))))
    6060
    61 (hemlock::defcommand "Inspect Symbol" (p)
     61(defCommand "Inspect Symbol" (p)
    6262  "Open the Inspector for the symbol at point."
    6363  (declare (ignore p))
     
    7070(hi::bind-key "Inspect Symbol" #k"control-x control-i")
    7171
    72 (defun MCL-documentation (symbol)
     72(defun mcl-documentation (symbol)
    7373  "Fetch the MCL documentation for SYMBOL."
    7474  (let ((path *MCL-doc*))
     
    123123       :text-view text-view :symbol sym) t)))
    124124 
    125 (hi:defcommand "Symbol Documentation" (p)
     125(defCommand "Symbol Documentation" (p)
    126126  "Display the documentation for the symbol at point."
    127127  (declare (ignore p))
     
    144144(hi::bind-key "Symbol Documentation" #k"control-x control-d")
    145145
    146 (hi:defcommand "Show Callers" (p)
     146(defCommand "Show Callers" (p)
    147147  "Display a scrolling list of the callers of the symbol at point.
    148148   Double-click a row to go to the caller's definition."
  • trunk/cocoa-ide-contrib/foy/hemlock-commands-cm/hemlock-documentation-dialog.lisp

    r12781 r14985  
    2020(in-package "HEMLOCK-COMMANDS")
    2121
    22 (defparameter *doc-dialog* nil)
    23 (defparameter *hemlock-jpg* (merge-pathnames ";Hemlock.jpg" cl-user::*hemlock-commands-directory*))
     22(defParameter *doc-dialog* nil)
     23(defParameter *hemlock-jpg* (merge-pathnames ";Hemlock.jpg" cl-user::*hemlock-commands-directory*))
    2424;;; I don't know the name of the artist who drew this graphic, but it is quite nice.
    2525;;; I also don't know what the copyright issues are, so this will have to be replaced when I get a chance:
    26 (defparameter *graphic-p* nil "To use, or not to use the eye candy.")
     26(defParameter *graphic-p* t "To use, or not to use the eye candy.")
    2727
    2828
    2929;;; ----------------------------------------------------------------------------
    3030;;;
    31 (defclass doc-dialog (ns:ns-window)
     31(defClass DOC-DIALOG (ns:ns-window)
    3232  ((name :accessor name)
    3333   (symbol :accessor symbol)
     
    6565         (let* ((search-string (format nil "(defcommand \"~A\"" (name d)))
    6666                (hemlock-src-dir (merge-pathnames "cocoa-ide/hemlock/src/" (native-translated-namestring "ccl:")))
    67                 (files (mapcar #'namestring
    68                                (remove-if #'(lambda (path)
    69                                               (string-not-equal (pathname-type path) "lisp"))
    70                                           (directory (merge-pathnames hemlock-src-dir "*.lisp") :files t :directories nil))))
     67                (files (cons (namestring (merge-pathnames ";hemlock-commands-new.lisp" cl-user::*hemlock-commands-directory*))
     68                             (mapcar #'namestring
     69                                     (remove-if #'(lambda (path)
     70                                                    (string-not-equal (pathname-type path) "lisp"))
     71                                                (directory (merge-pathnames hemlock-src-dir "*.lisp") :files t :directories nil)))))
    7172                (args (cons "-l" (cons search-string files)))
    7273                (source-path (string-trim '(#\newline #\space) (gui::call-grep args))))
     
    8990(defun open-documentation-dialog (name key-or-type doc &key symbol hemlock-p text-view)
    9091  "Open the dialog displaying the documentation for NAME."
     92  (when (null text-view) (setq text-view (get-listener-text-view)))
    9193  (let* ((name-string (#/initWithString:attributes: (#/alloc ns:ns-attributed-string)
    9294                                                   (ccl::%make-nsstring
     
    127129             (#/setEnabled: (hyperspec-button *doc-dialog*) t)
    128130             (#/setEnabled: (hyperspec-button *doc-dialog*) nil))
     131           ;; (#/setDefaultButtonCell: dialog (okay-button dialog))
    129132           (#/setStringValue: (name-field *doc-dialog*) name-string)
    130133           (#/setStringValue: (key-field *doc-dialog*) key-string)
     
    183186        (gui::lookup-hyperspec-symbol sym text-view))))
    184187
    185 (defmethod get-items ((d doc-dialog))
     188(defun get-listener-text-view ()
     189  "If the menu is installed under the Help Menu, there is no text-view.  Borrow the Listener text-view."
     190  (let* ((listeners (gui::active-listener-windows))
     191         (listener (first listeners)))
     192    (when listener
     193      (slot-value (slot-value listener 'gui::pane) 'gui::text-view))))
     194
     195(defMethod get-items ((d doc-dialog))
    186196  (append
    187197   (when *graphic-p*
  • trunk/cocoa-ide-contrib/foy/list-definitions-cm/history-lists.lisp

    r13039 r14985  
    2020;;;
    2121;;;      Mod History, most recent first:
    22 ;;;      8/31/9  version 0.2b2
    23 ;;;              Modified to work with Context-Menu mechanism.
     22;;;      9/9/11  update for ccl 1.7
     23;;;      1/6/9   Editor Evaluate Defun and Editor Compile Defun bit the dust.
     24;;;      8/31/9  Modified to work with Context-Menu mechanism.
    2425;;;      8/17/9  version 0.2b1
    2526;;;              This file added.
     
    211212      entry)))
    212213
    213 (defmethod remove-path ((hl file-history-list) path)
     214(defMethod remove-path ((hl file-history-list) path)
    214215  (setf (hl-list hl) (delete path (hl-list hl)
    215216                             :test #'string-equal :key #'hle-path)))
     
    240241;;; ----------------------------------------------------------------------------
    241242;;;
    242 (defclass POSITION-MENU-ITEM (ns:ns-menu-item)
     243(defClass POSITION-MENU-ITEM (ns:ns-menu-item)
    243244   ((path :accessor position-path)
    244245    (name :accessor position-name))
     
    248249;;; ----------------------------------------------------------------------------
    249250;;;
    250 (defclass POSITIONS-MENU (ns:ns-menu)
     251(defClass POSITIONS-MENU (ns:ns-menu)
    251252  ((tool-menu :initform nil :accessor tool-menu)
    252253   (sub-title :initform "position history" :reader sub-title))
     
    325326;;; ----------------------------------------------------------------------------
    326327;;;
    327 (defclass FILE-MENU-ITEM (ns:ns-menu-item)
     328(defClass FILE-MENU-ITEM (ns:ns-menu-item)
    328329   ((path :accessor file-path)
    329330    (name :accessor file-name))
     
    333334;;; ----------------------------------------------------------------------------
    334335;;;
    335 (defclass FILE-MENU (ns:ns-menu)
     336(defClass FILE-MENU (ns:ns-menu)
    336337  ((tool-menu :initform nil :accessor tool-menu)
    337338   (sub-title :initform "file history" :reader sub-title))
     
    434435(defMethod write-history-list ((hl position-history-list) stream)
    435436  (format stream "~s~%" (length (hl-list hl)))
    436   (dolist (entry (nreverse (hl-list hl)))
     437  (dolist (entry (reverse (hl-list hl)))
    437438    (format stream "~s~%" (hle-info entry))
    438439    (format stream "~s~%" (hle-path entry))))
     
    440441(defMethod write-history-list ((hl file-history-list) stream)
    441442  (format stream "~s~%" (length (hl-list hl)))
    442   (dolist (entry (nreverse (hl-list hl)))
     443  (dolist (entry (reverse (hl-list hl)))
    443444    (format stream "~s~%" (hle-name entry))
    444445    (format stream "~s~%" (hle-path entry))))
     
    472473;;; File History Interface:
    473474;;;
    474 ;;; *** Instead of doing all this stuff need the equivalent of:
    475 ;;; *** (setf ccl::*default-editor-class* 'derived-hemlock-frame-class)
    476475#-syntax-styling
    477 (objc:defMethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame))
     476(objc:defmethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame))
    478477  (let* ((path (cmenu:window-path w))
    479          (name (when (and path (string-equal (pathname-type path) "lisp"))
    480                  (concatenate 'string (pathname-name path) ".lisp"))))
     478         (name (when (and path (or (string-equal (pathname-type path) "lisp")
     479                                   (string-equal (pathname-type path) "scm")
     480                                   (string-equal (pathname-type path) "clj")))
     481                 (concatenate 'string (pathname-name path) "." (pathname-type path)))))
    481482    (when (and name path)
    482483      (maybe-add-history-entry *file-history-list* name path)))
     
    488489(defMethod become-key-window ((w gui::hemlock-frame))
    489490  (let* ((path (cmenu:window-path w))
    490          (name (when (and path (string-equal (pathname-type path) "lisp"))
    491                  (concatenate 'string (pathname-name path) ".lisp"))))
     491         (name (when (and path (or (string-equal (pathname-type path) "lisp")
     492                                   (string-equal (pathname-type path) "scm")
     493                                   (string-equal (pathname-type path) "clj")))
     494                 (concatenate 'string (pathname-name path) "." (pathname-type path)))))
    492495    (when (and name path)
    493496      (maybe-add-history-entry *file-history-list* name path))))
     
    532535        (maybe-add-history-entry *position-history-list* def-info path)))))
    533536
    534 ;;; *** These three redefinitions are not a great way of doing this ***
    535 ;;; *** Where's CLOS when you need it ...
     537;;; *** redefinitions ***
     538;;;
     539(hemlock::defCommand "Editor Execute Defun" (p)
     540  "Executes the current or next top-level form in the editor Lisp."
     541  (declare (ignore p))
     542  (if (hemlock::region-active-p)
     543    (hemlock::eval-region (hemlock::current-region))
     544    (hemlock::eval-region (hemlock::defun-region (hi::current-point))))
     545  (add-top-level-position))
     546
     547(hemlock::defcommand "Editor Execute Expression" (p)
     548  "Executes the current region in the editor Lisp. Ensures the result is visible."
     549  (declare (ignore p))
     550  (let* ((region (hi::copy-region (hemlock::current-form-region)))
     551         (form (when hemlock::*echo-expression-to-listener* (hi::region-to-string region)))
     552         (doc (gui::top-listener-document))
     553         (buf (when doc (gui::hemlock-buffer doc))))
     554    (when buf
     555      (let ((hi::*current-buffer* buf))
     556        (hi::move-mark (hi::current-point) (hi::region-end (hi::buffer-region buf)))))
     557    (when form (format (HEMLOCK-EXT:TOP-LISTENER-OUTPUT-STREAM) "~A~&" form))
     558    (hemlock::eval-region region))
     559  (add-top-level-position))
     560
     561#|
    536562(hemlock::defcommand "Editor Evaluate Defun" (p)
    537563  "Evaluates the current or next top-level form in the editor Lisp.
     
    555581      (hemlock::editor-compile-region (hemlock::defun-region (hi::current-point)) t))
    556582  (add-top-level-position))
     583|#
    557584
    558585;;; gui::cocoa-edit-single-definition didn't last long.
     
    568595(read-history-files)
    569596
    570 ;;; Hemlock-Commands needs this, for now:
    571 (pushnew :list-definitions *features*)
     597
  • trunk/cocoa-ide-contrib/foy/list-definitions-cm/list-definitions-cm.lisp

    r12717 r14985  
    1818  (load file))
    1919
     20(pushnew :list-definitions *features*)
    2021(provide :list-definitions-cm)
    2122
  • trunk/cocoa-ide-contrib/foy/list-definitions-cm/list-definitions.lisp

    r12852 r14985  
    1616;;;
    1717;;;      Mod History, most recent first:
     18;;;      9/9/11  update for ccl 1.7
     19;;;      7/17/11 Added support for Scheme and Clojure files.
     20;;;              Sharp-stroke commented functions ignored.
     21;;;      1/6/10  Added parse-over-block to display-position.
    1822;;;      9/19/9  Added parse-over-block to list-definitions.
    1923;;;      8/31/9  Modified to work with Context-Menu mechanism.
     
    2529;;; ----------------------------------------------------------------------------
    2630
    27 (defpackage "LIST-DEFINITIONS" (:nicknames "LDEFS") (:use :cl :ccl))
     31;;; So that we can use some parsing code, if available:
     32(defPackage syntax-styling (:use :cl :ccl :hemlock-internals) (:nicknames "SAX"))
     33
     34(defPackage "LIST-DEFINITIONS" (:nicknames "LDEFS") (:use :cl :ccl))
    2835(in-package "LIST-DEFINITIONS")
    2936
     
    3845(defParameter *slash-search-pattern* (hi::new-search-pattern :character :forward #\/))
    3946
     47(defParameter *sharp-stroke-search-pattern* (hi::new-search-pattern :string-sensitive :forward "#|"))
     48(defParameter *stroke-sharp-search-pattern* (hi::new-search-pattern :string-sensitive :forward "|#"))
     49
    4050(defVar *position-history-list* nil "The position-history-list instance.")
    4151(defVar *file-history-list* nil "The file-history-list instance.")
    4252
    43 (defmacro clone (mark) `(hi::copy-mark ,mark :temporary))
     53(defMacro clone (mark) `(hi::copy-mark ,mark :temporary))
    4454
    4555;;; ----------------------------------------------------------------------------
    4656;;;
    47 (defclass list-definitions-menu (ns:ns-menu)
     57(defClass LIST-DEFINITIONS-MENU (ns:ns-menu)
    4858  ((text-view :initarg :menu-text-view :reader menu-text-view)
    4959   (path :initarg :menu-path :reader menu-path) ; *** history-path
     
    6474(defun display-position (text-view mark)
    6575  "Display the position of MARK in TEXT-VIEW."
    66   (let* ((def-pos (hi::mark-absolute-position mark))
     76  (let* ((buffer (gui::hemlock-buffer text-view))
     77         (hi::*current-buffer* buffer)
     78         (def-pos (hi::mark-absolute-position mark))
    6779         (def-end-pos (let ((temp-mark (clone mark)))
    6880                        (when (hemlock::form-offset temp-mark 1)
    6981                          (hi::mark-absolute-position temp-mark)))))
     82    (hemlock::parse-over-block (hi::mark-line (hi::buffer-start-mark buffer))
     83                               (hi::mark-line (hi::buffer-end-mark buffer)))
    7084    (unless def-end-pos (when def-pos (setq def-end-pos (1+ def-pos))))
    7185    (when (and def-pos def-end-pos)
     
    7791;;; ----------------------------------------------------------------------------
    7892;;;
    79 (defclass list-definitions-menu-item (ns:ns-menu-item)
     93(defClass LIST-DEFINITIONS-MENU-ITEM (ns:ns-menu-item)
    8094  ((mark :accessor item-mark)
    8195   (path :accessor item-path)
     
    8498  (:metaclass ns:+ns-object))
    8599
    86 (defparameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
    87 (defparameter *dark-green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.1 1.0))
    88 (defparameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.1 0.1 0.1 1.0))
    89 (defparameter *dark-brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.3 0.05 0.0 1.0))
    90 (defparameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.3 1.0))
    91 (defparameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
    92 
    93 (defparameter *generic-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     100(defParameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
     101(defParameter *dark-green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.1 1.0))
     102(defParameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.1 0.1 0.1 1.0))
     103(defParameter *dark-brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.3 0.05 0.0 1.0))
     104(defParameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.3 1.0))
     105(defParameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
     106
     107(defParameter *generic-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    94108(#/setObject:forKey: *generic-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    95109(#/setObject:forKey: *generic-dictionary* *dark-gray-color* #&NSForegroundColorAttributeName)
    96110
    97 (defparameter *file-history-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     111(defParameter *file-history-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    98112(#/setObject:forKey: *file-history-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    99113(#/setObject:forKey: *file-history-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
    100114
    101 (defparameter *defclass-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
     115(defParameter *defclass-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
    102116(#/setObject:forKey: *defclass-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    103117(#/setObject:forKey: *defclass-dictionary* *wine-red-color* #&NSForegroundColorAttributeName)
    104118(#/setObject:forKey: *defclass-dictionary* (#/numberWithInt: ns:ns-number 1) #&NSUnderlineStyleAttributeName)
    105119
    106 (defparameter *defstruct-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
     120(defParameter *defstruct-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
    107121(#/setObject:forKey: *defstruct-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    108122(#/setObject:forKey: *defstruct-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
    109123(#/setObject:forKey: *defstruct-dictionary* (#/numberWithInt: ns:ns-number 1) #&NSUnderlineStyleAttributeName)
    110124
    111 (defparameter *defmethod-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     125(defParameter *defmethod-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    112126(#/setObject:forKey: *defmethod-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    113127(#/setObject:forKey: *defmethod-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
    114128
    115 (defparameter *defun-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     129(defParameter *defun-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    116130(#/setObject:forKey: *defun-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    117131(#/setObject:forKey: *defun-dictionary* *dark-green-color* #&NSForegroundColorAttributeName)
    118132
    119 (defparameter *defmacro-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     133(defParameter *defmacro-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    120134(#/setObject:forKey: *defmacro-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    121135(#/setObject:forKey: *defmacro-dictionary* *dark-brown-color* #&NSForegroundColorAttributeName)
    122136
    123 (defparameter *objc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     137(defParameter *objc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    124138(#/setObject:forKey: *objc-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    125139(#/setObject:forKey: *objc-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
     
    191205        (list-definitions-context-menu view t)))))
    192206
    193 ;;; This includes definitions in sharp-stroke comments.  We'll claim it's a feature.
     207(declaim (special sax::*segment-array* sax::*buf*))
     208;;; And to silence the compiler:
     209(declaim (ftype function sax::embedded-in-segment-p sax::make-segment-array sax::create-sharp-stroke-comment-list))
     210
     211;;; If syntax-styling is provided this will skip definitions in sharp-stroke comments.
     212;;; Otherwise they are also listed.  (We'll call it a feature)
    194213(defun list-definitions (hemlock &optional alpha-p)
    195214  "Create a list of all the top-level definitions in the file."
    196   (labels ((get-name (entry)
    197              (let ((def-info (car entry)))
    198                (second def-info)))
    199            (get-defs (mark pattern &optional objc-p)
    200              (do ((def-found-p (hi::find-pattern mark pattern)
    201                                (hi::find-pattern mark pattern))
    202                   alist)
    203                  ((not def-found-p) (when alist
    204                                       (if alpha-p
    205                                         (sort alist #'string-lessp :key #'get-name)
    206                                         (nreverse alist))))
    207                (when (zerop (hi::mark-charpos mark))
    208                  (let ((def-info (definition-info (clone mark) objc-p)))
    209                    (when def-info
    210                      (push (cons def-info (hi::line-start (clone mark))) alist))))
    211                (hi::line-end mark))))
    212     (let* ((pane (slot-value hemlock 'gui::pane))
    213            (text-view (gui::text-pane-text-view pane))
    214            (buffer (gui::hemlock-buffer text-view))
    215            (hi::*current-buffer* buffer))
    216       (hemlock::parse-over-block (hi::mark-line (hi::buffer-start-mark buffer))
    217                                  (hi::mark-line (hi::buffer-end-mark buffer)))
    218       (let* ((def-mark (clone (hi::buffer-start-mark buffer)))
    219              (objc-mark (clone (hi::buffer-start-mark buffer)))
    220              (def-alist (get-defs def-mark *def-search-pattern*))
    221              (objc-alist (get-defs objc-mark *objc-defmethod-search-pattern* t)))
    222         (when objc-alist
    223           (setq def-alist
    224                 (if alpha-p
    225                   (merge 'list def-alist objc-alist #'string-lessp :key #'get-name)
    226                   (merge 'list def-alist objc-alist #'hi::mark< :key #'cdr))))
    227         def-alist))))
     215  (let ((syntax-styling-p (member "SYNTAX-STYLING" *modules* :test #'string=)))
     216    (labels ((get-name (entry)
     217               (let ((def-info (car entry)))
     218                 (second def-info)))
     219             (get-defs (mark pattern &optional objc-p)
     220               (do ((def-found-p (hi::find-pattern mark pattern)
     221                                 (hi::find-pattern mark pattern))
     222                    alist)
     223                   ((not def-found-p) (when alist
     224                                        (if alpha-p
     225                                          (sort alist #'string-lessp :key #'get-name)
     226                                          (nreverse alist))))
     227                 
     228                 (when (and (zerop (hi::mark-charpos mark))
     229                            (if syntax-styling-p
     230                              (not (sax::embedded-in-segment-p mark))
     231                              t))
     232                   (let ((def-info (definition-info (clone mark) objc-p)))
     233                     (when def-info
     234                       (push (cons def-info (hi::line-start (clone mark))) alist))))
     235                 (hi::line-end mark))))
     236      (let* ((pane (slot-value hemlock 'gui::pane))
     237             (text-view (gui::text-pane-text-view pane))
     238             (buffer (gui::hemlock-buffer text-view))
     239             (hi::*current-buffer* buffer)
     240             (sax::*buf* buffer))
     241        (hemlock::parse-over-block (hi::mark-line (hi::buffer-start-mark buffer))
     242                                   (hi::mark-line (hi::buffer-end-mark buffer)))
     243        (when syntax-styling-p
     244          (setf sax::*segment-array*
     245                (sax::make-segment-array
     246                 (sax::create-sharp-stroke-comment-list (sax::buffer-start-mark buffer)
     247                                                        (sax::buffer-end-mark buffer) t))))
     248        (let* ((def-mark (clone (hi::buffer-start-mark buffer)))
     249               (objc-mark (clone (hi::buffer-start-mark buffer)))
     250               (def-alist (get-defs def-mark *def-search-pattern*))
     251               (objc-alist (get-defs objc-mark *objc-defmethod-search-pattern* t)))
     252          (when objc-alist
     253            (setq def-alist
     254                  (if alpha-p
     255                    (merge 'list def-alist objc-alist #'string-lessp :key #'get-name)
     256                    (merge 'list def-alist objc-alist #'hi::mark< :key #'cdr))))
     257          def-alist)))))
    228258
    229259(defun definition-info (mark &optional objc-p)
     
    250280        (let ((name (hi::region-to-string (hi::region start end)))
    251281              param-string specializer)
     282
     283          ;; Handle Scheme 'defun' style defines: (name arg arg ...)
     284          (when (char= (hi::next-character start) #\()
     285            (setq name (string-left-trim '(#\() name))
     286            (setq name (subseq name 0 (or (position #\space name) (length name)))))
     287
    252288          (when (and (stringp name) (string-not-equal name ""))
    253289            (case def-type
     
    350386
    351387;;; This is used by the Hemlock-Commands tool. 
    352 (defun find-and-display-definition (name path)
     388(defun FIND-AND-DISPLAY-DEFINITION (name path)
    353389  "Display the file and scroll to the definition position."
    354390  (let ((window (cmenu:window-with-path path))
  • trunk/cocoa-ide-contrib/foy/list-definitions/history-lists.lisp

    r13038 r14985  
    2020;;;
    2121;;;      Mod History, most recent first:
     22;;;      9/9/11  update for ccl 1.7
    2223;;;      8/17/9  version 0.2b1
    2324;;;              This file added.
     
    228229      entry)))
    229230
    230 (defmethod remove-path ((hl file-history-list) path)
     231(defMethod remove-path ((hl file-history-list) path)
    231232  (setf (hl-list hl) (delete path (hl-list hl)
    232233                             :test #'string-equal :key #'hle-path)))
     
    257258;;; ----------------------------------------------------------------------------
    258259;;;
    259 (defclass POSITION-MENU-ITEM (ns:ns-menu-item)
     260(defClass POSITION-MENU-ITEM (ns:ns-menu-item)
    260261   ((path :accessor position-path)
    261262    (name :accessor position-name))
     
    265266;;; ----------------------------------------------------------------------------
    266267;;;
    267 (defclass POSITIONS-MENU (ns:ns-menu)
     268(defClass POSITIONS-MENU (ns:ns-menu)
    268269  ()
    269270  (:documentation "A popup menu of most-recently-visited definition positions.")
     
    336337;;; ----------------------------------------------------------------------------
    337338;;;
    338 (defclass FILE-MENU-ITEM (ns:ns-menu-item)
     339(defClass FILE-MENU-ITEM (ns:ns-menu-item)
    339340   ((path :accessor file-path)
    340341    (name :accessor file-name))
     
    344345;;; ----------------------------------------------------------------------------
    345346;;;
    346 (defclass FILE-MENU (ns:ns-menu)
     347(defClass FILE-MENU (ns:ns-menu)
    347348  ()
    348349  (:documentation "A popup menu of most-recently-visited files.")
     
    439440(defMethod write-history-list ((hl position-history-list) stream)
    440441  (format stream "~s~%" (length (hl-list hl)))
    441   (dolist (entry (nreverse (hl-list hl)))
     442  (dolist (entry (reverse (hl-list hl)))
    442443    (format stream "~s~%" (hle-info entry))
    443444    (format stream "~s~%" (hle-path entry))))
     
    445446(defMethod write-history-list ((hl file-history-list) stream)
    446447  (format stream "~s~%" (length (hl-list hl)))
    447   (dolist (entry (nreverse (hl-list hl)))
     448  (dolist (entry (reverse (hl-list hl)))
    448449    (format stream "~s~%" (hle-name entry))
    449450    (format stream "~s~%" (hle-path entry))))
     
    477478;;; File History Interface:
    478479;;;
    479 ;;; *** Instead of doing all this stuff need the equivalent of:
    480 ;;; *** (setf ccl::*default-editor-class* 'derived-hemlock-frame-class)
    481480#-syntax-styling
    482 (objc:defMethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame))
    483   (let* ((path (cmenu:window-path w))
    484          (name (when (and path (string-equal (pathname-type path) "lisp"))
    485                  (concatenate 'string (pathname-name path) ".lisp"))))
     481(objc:defmethod (#/becomeKeyWindow :void) ((w gui::hemlock-frame))
     482  (let* ((path (window-path w))
     483         (name (when (and path (or (string-equal (pathname-type path) "lisp")
     484                                   (string-equal (pathname-type path) "scm")
     485                                   (string-equal (pathname-type path) "clj")))
     486                 (concatenate 'string (pathname-name path) "." (pathname-type path)))))
    486487    (when (and name path)
    487488      (maybe-add-history-entry *file-history-list* name path)))
     
    492493#+syntax-styling
    493494(defMethod become-key-window ((w gui::hemlock-frame))
    494   (let* ((path (cmenu:window-path w))
    495          (name (when (and path (string-equal (pathname-type path) "lisp"))
    496                  (concatenate 'string (pathname-name path) ".lisp"))))
     495  (let* ((path (window-path w))
     496         (name (when (and path (or (string-equal (pathname-type path) "lisp")
     497                                   (string-equal (pathname-type path) "scm")
     498                                   (string-equal (pathname-type path) "clj")))
     499                 (concatenate 'string (pathname-name path) "." (pathname-type path)))))
    497500    (when (and name path)
    498501      (maybe-add-history-entry *file-history-list* name path))))
     
    514517(hemlock::bind-key "Add Definition Position" #k"control-shift-space")
    515518
    516 ;;; *** buffer?
    517519(defun add-top-level-position (&optional buffer)
    518520  "Maybe add the top-level definition position to the position history list."
     
    526528      (setq start-mark (hemlock::top-level-offset mark -1)))
    527529    (when start-mark
    528       (setq def-info (definition-info start-mark))
     530      (let* ((line-end (hi::line-end (hi::copy-mark start-mark :temporary)))
     531             (def-mark (hi::copy-mark start-mark :temporary))
     532             (objc-mark (hi::copy-mark start-mark :temporary))
     533             (def-p (hi::find-pattern def-mark *def-search-pattern* line-end))
     534             (objc-p (hi::find-pattern objc-mark *objc-defmethod-search-pattern* line-end)))
     535        (cond (def-p
     536               (setq def-info (definition-info start-mark)))
     537              (objc-p
     538               (setq def-info (definition-info start-mark t)))))
    529539      (when (and def-info path)
    530540        (maybe-add-history-entry *position-history-list* def-info path)))))
    531541
    532 ;;; *** These three redefinitions are not a great way of doing this ***
    533 ;;; *** Where's CLOS when you need it ...
     542;;; *** redefinitions ***
     543;;;
     544(hemlock::defCommand "Editor Execute Defun" (p)
     545  "Executes the current or next top-level form in the editor Lisp."
     546  (declare (ignore p))
     547  (if (hemlock::region-active-p)
     548    (hemlock::eval-region (hemlock::current-region))
     549    (hemlock::eval-region (hemlock::defun-region (hi::current-point))))
     550  (add-top-level-position))
     551
     552(hemlock::defcommand "Editor Execute Expression" (p)
     553  "Executes the current region in the editor Lisp. Ensures the result is visible."
     554  (declare (ignore p))
     555  (let* ((region (hi::copy-region (hemlock::current-form-region)))
     556         (form (when hemlock::*echo-expression-to-listener* (hi::region-to-string region)))
     557         (doc (gui::top-listener-document))
     558         (buf (when doc (gui::hemlock-buffer doc))))
     559    (when buf
     560      (let ((hi::*current-buffer* buf))
     561        (hi::move-mark (hi::current-point) (hi::region-end (hi::buffer-region buf)))))
     562    (when form (format (HEMLOCK-EXT:TOP-LISTENER-OUTPUT-STREAM) "~A~&" form))
     563    (hemlock::eval-region region))
     564  (add-top-level-position))
     565
     566#|
    534567(hemlock::defcommand "Editor Evaluate Defun" (p)
    535568  "Evaluates the current or next top-level form in the editor Lisp.
     
    553586      (hemlock::editor-compile-region (hemlock::defun-region (hi::current-point)) t))
    554587  (add-top-level-position))
     588|#
    555589
    556590;;; gui::cocoa-edit-single-definition didn't last long.
  • trunk/cocoa-ide-contrib/foy/list-definitions/list-definitions.lisp

    r12851 r14985  
    1616;;;
    1717;;;      Mod History, most recent first:
     18;;;      9/9/11  update for ccl 1.7
    1819;;;      9/19/9  Added parse-over-block to list-definitions.
    1920;;;      8/17/9  Added position history list and file history list.
     
    2324;;; ----------------------------------------------------------------------------
    2425
    25 
    26 (defpackage "LIST-DEFINITIONS" (:nicknames "LDEFS") (:use :cl :ccl))
     26;;; So that we can use some parsing code, if available:
     27(defPackage syntax-styling (:use :cl :ccl :hemlock-internals) (:nicknames "SAX"))
     28
     29(defPackage "LIST-DEFINITIONS" (:nicknames "LDEFS") (:use :cl :ccl))
    2730(in-package "LIST-DEFINITIONS")
    2831
     
    3639(defVar *file-history-list* nil "The file-history-list instance.")
    3740
    38 (defmacro clone (mark) `(hi::copy-mark ,mark :temporary))
    39 
    40 (defun active-hemlock-window ()
     41(defMacro clone (mark) `(hi::copy-mark ,mark :temporary))
     42
     43(defun ACTIVE-HEMLOCK-WINDOW ()
    4144  "Return the active hemlock-frame."
    4245  (gui::first-window-satisfying-predicate
     
    4649            (#/isKeyWindow w)))))
    4750
    48 (defun window-path (w)
     51(defun WINDOW-PATH (w)
    4952  "Return the window's path."
    5053  (let* ((pane (slot-value w 'gui::pane))
     
    5558;;; ----------------------------------------------------------------------------
    5659;;;
    57 (defclass list-definitions-menu (ns:ns-menu)
     60(defClass LIST-DEFINITIONS-MENU (ns:ns-menu)
    5861  ((text-view :initarg :menu-text-view :reader menu-text-view)
    5962   (path :initarg :menu-path :reader menu-path))
     
    6770(defun display-position (text-view mark)
    6871  "Display the position of MARK in TEXT-VIEW."
    69   (let* ((def-pos (hi::mark-absolute-position mark))
     72  (let* ((buffer (gui::hemlock-buffer text-view))
     73         (hi::*current-buffer* buffer)
     74         (def-pos (hi::mark-absolute-position mark))
    7075         (def-end-pos (let ((temp-mark (clone mark)))
    7176                        (when (hemlock::form-offset temp-mark 1)
    7277                          (hi::mark-absolute-position temp-mark)))))
     78    (hemlock::parse-over-block (hi::mark-line (hi::buffer-start-mark buffer))
     79                               (hi::mark-line (hi::buffer-end-mark buffer)))
    7380    (unless def-end-pos (when def-pos (setq def-end-pos (1+ def-pos))))
    7481    (when (and def-pos def-end-pos)
     
    8087;;; ----------------------------------------------------------------------------
    8188;;;
    82 (defclass list-definitions-menu-item (ns:ns-menu-item)
     89(defClass LIST-DEFINITIONS-MENU-ITEM (ns:ns-menu-item)
    8390  ((mark :accessor item-mark)
    8491   (path :accessor item-path)
     
    8794  (:metaclass ns:+ns-object))
    8895
    89 (defparameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
    90 (defparameter *dark-green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.1 1.0))
    91 (defparameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.1 0.1 0.1 1.0))
    92 (defparameter *dark-brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.3 0.05 0.0 1.0))
    93 (defparameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.3 1.0))
    94 (defparameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
    95 
    96 (defparameter *generic-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     96(defParameter *dark-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.2 0.2 0.5 1.0))
     97(defParameter *dark-green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.1 1.0))
     98(defParameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.1 0.1 0.1 1.0))
     99(defParameter *dark-brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.3 0.05 0.0 1.0))
     100(defParameter *dark-turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.3 1.0))
     101(defParameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.4 0.1 0.2 1.0))
     102
     103(defParameter *generic-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    97104(#/setObject:forKey: *generic-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    98105(#/setObject:forKey: *generic-dictionary* *dark-gray-color* #&NSForegroundColorAttributeName)
    99106
    100 (defparameter *file-history-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     107(defParameter *file-history-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    101108(#/setObject:forKey: *file-history-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    102109(#/setObject:forKey: *file-history-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
    103110
    104 (defparameter *defclass-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
     111(defParameter *defclass-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
    105112(#/setObject:forKey: *defclass-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    106113(#/setObject:forKey: *defclass-dictionary* *wine-red-color* #&NSForegroundColorAttributeName)
    107114(#/setObject:forKey: *defclass-dictionary* (#/numberWithInt: ns:ns-number 1) #&NSUnderlineStyleAttributeName)
    108115
    109 (defparameter *defstruct-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
     116(defParameter *defstruct-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 3))
    110117(#/setObject:forKey: *defstruct-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    111118(#/setObject:forKey: *defstruct-dictionary* *dark-turquoise-color* #&NSForegroundColorAttributeName)
    112119(#/setObject:forKey: *defstruct-dictionary* (#/numberWithInt: ns:ns-number 1) #&NSUnderlineStyleAttributeName)
    113120
    114 (defparameter *defmethod-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     121(defParameter *defmethod-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    115122(#/setObject:forKey: *defmethod-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    116123(#/setObject:forKey: *defmethod-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
    117124
    118 (defparameter *defun-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     125(defParameter *defun-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    119126(#/setObject:forKey: *defun-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    120127(#/setObject:forKey: *defun-dictionary* *dark-green-color* #&NSForegroundColorAttributeName)
    121128
    122 (defparameter *defmacro-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     129(defParameter *defmacro-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    123130(#/setObject:forKey: *defmacro-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    124131(#/setObject:forKey: *defmacro-dictionary* *dark-brown-color* #&NSForegroundColorAttributeName)
    125132
    126 (defparameter *objc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
     133(defParameter *objc-dictionary* (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    127134(#/setObject:forKey: *objc-dictionary* (#/systemFontOfSize: ns:ns-font (#/smallSystemFontSize ns:ns-font)) #&NSFontAttributeName)
    128135(#/setObject:forKey: *objc-dictionary* *dark-blue-color* #&NSForegroundColorAttributeName)
     
    189196        (list-definitions-context-menu view t)))))
    190197
    191 ;;; This includes definitions in sharp-stroke comments.  We'll claim it's a feature.
     198(declaim (special sax::*segment-array* sax::*buf*))
     199;;; And to silence the compiler:
     200(declaim (ftype function sax::embedded-in-segment-p sax::make-segment-array sax::create-sharp-stroke-comment-list))
     201
     202;;; If syntax-styling is provided this will skip definitions in sharp-stroke comments.
     203;;; Otherwise they are also listed.  (We'll call it a feature)
    192204(defun list-definitions (hemlock &optional alpha-p)
    193205  "Create a list of all the top-level definitions in the file."
    194   (labels ((get-name (entry)
    195              (let ((def-info (car entry)))
    196                (second def-info)))
    197            (get-defs (mark pattern &optional objc-p)
    198              (do ((def-found-p (hi::find-pattern mark pattern)
    199                                (hi::find-pattern mark pattern))
    200                   alist)
    201                  ((not def-found-p) (when alist
    202                                       (if alpha-p
    203                                         (sort alist #'string-lessp :key #'get-name)
    204                                         (nreverse alist))))
    205                (when (zerop (hi::mark-charpos mark))
    206                  (let ((def-info (definition-info (clone mark) objc-p)))
    207                    (when def-info
    208                      (push (cons def-info (hi::line-start (clone mark))) alist))))
    209                (hi::line-end mark))))
    210     (let* ((pane (slot-value hemlock 'gui::pane))
    211            (text-view (gui::text-pane-text-view pane))
    212            (buffer (gui::hemlock-buffer text-view))
    213            (hi::*current-buffer* buffer))
    214       (hemlock::parse-over-block (hi::mark-line (hi::buffer-start-mark buffer))
    215                                  (hi::mark-line (hi::buffer-end-mark buffer)))
    216       (let* ((def-mark (clone (hi::buffer-start-mark buffer)))
    217              (objc-mark (clone (hi::buffer-start-mark buffer)))
    218              (def-alist (get-defs def-mark *def-search-pattern*))
    219              (objc-alist (get-defs objc-mark *objc-defmethod-search-pattern* t)))
    220         (when objc-alist
    221           (setq def-alist
    222                 (if alpha-p
    223                   (merge 'list def-alist objc-alist #'string-lessp :key #'get-name)
    224                   (merge 'list def-alist objc-alist #'hi::mark< :key #'cdr))))
    225         def-alist))))
     206  (let ((syntax-styling-p (member "SYNTAX-STYLING" *modules* :test #'string=)))
     207    (labels ((get-name (entry)
     208               (let ((def-info (car entry)))
     209                 (second def-info)))
     210             (get-defs (mark pattern &optional objc-p)
     211               (do ((def-found-p (hi::find-pattern mark pattern)
     212                                 (hi::find-pattern mark pattern))
     213                    alist)
     214                   ((not def-found-p) (when alist
     215                                        (if alpha-p
     216                                          (sort alist #'string-lessp :key #'get-name)
     217                                          (nreverse alist))))
     218                 
     219                 (when (and (zerop (hi::mark-charpos mark))
     220                            (if syntax-styling-p
     221                              (not (sax::embedded-in-segment-p mark))
     222                              t))
     223                   (let ((def-info (definition-info (clone mark) objc-p)))
     224                     (when def-info
     225                       (push (cons def-info (hi::line-start (clone mark))) alist))))
     226                 (hi::line-end mark))))
     227      (let* ((pane (slot-value hemlock 'gui::pane))
     228             (text-view (gui::text-pane-text-view pane))
     229             (buffer (gui::hemlock-buffer text-view))
     230             (hi::*current-buffer* buffer)
     231             (sax::*buf* buffer))
     232        (hemlock::parse-over-block (hi::mark-line (hi::buffer-start-mark buffer))
     233                                   (hi::mark-line (hi::buffer-end-mark buffer)))
     234        (when syntax-styling-p
     235          (setf sax::*segment-array*
     236                (sax::make-segment-array
     237                 (sax::create-sharp-stroke-comment-list (sax::buffer-start-mark buffer)
     238                                                        (sax::buffer-end-mark buffer)))))
     239        (let* ((def-mark (clone (hi::buffer-start-mark buffer)))
     240               (objc-mark (clone (hi::buffer-start-mark buffer)))
     241               (def-alist (get-defs def-mark *def-search-pattern*))
     242               (objc-alist (get-defs objc-mark *objc-defmethod-search-pattern* t)))
     243          (when objc-alist
     244            (setq def-alist
     245                  (if alpha-p
     246                    (merge 'list def-alist objc-alist #'string-lessp :key #'get-name)
     247                    (merge 'list def-alist objc-alist #'hi::mark< :key #'cdr))))
     248          def-alist)))))
    226249
    227250(defun definition-info (mark &optional objc-p)
     
    248271        (let ((name (hi::region-to-string (hi::region start end)))
    249272              param-string specializer)
     273
     274          ;; Handle Scheme 'defun' style defines: (name arg arg ...)
     275          (when (char= (hi::next-character start) #\()
     276            (setq name (string-left-trim '(#\() name))
     277            (setq name (subseq name 0 (or (position #\space name) (length name)))))
     278
    250279          (when (and (stringp name) (string-not-equal name ""))
    251280            (case def-type
  • trunk/cocoa-ide-contrib/foy/list-definitions/load-list-definitions.lisp

    r12751 r14985  
    1818  (load file))
    1919
     20(pushnew :list-definitions *features*)
    2021(provide :list-definitions)
    2122
  • trunk/cocoa-ide-contrib/foy/syntax-styling/syntax-styling-comments.lisp

    r13040 r14985  
    1 ;;;-*- Mode: Lisp; Package: (SYNTAX-STYLING (CL CCL HEMLOCK-INTERNALS)) -*-
     1;;;-*- Mode: Lisp; Package: syntax-styling -*-
    22
    33;;; ****************************************************************************
     
    55;;;      syntax-styling-comments.lisp
    66;;;
    7 ;;;      copyright © 2009 Glen Foy, all rights reserved,
     7;;;      copyright © 2009, 2011 Glen Foy, all rights reserved,
    88;;;
    99;;;     These classes support the styling of semi-colon and sharp-stroke comments,
     
    1212;;;
    1313;;;      Mod history, most recent first:
     14;;;      9/7/11    update for ccl 1.7
     15;;;      7/17/11   style-semi-colon-comments beginning of buffer bug.
    1416;;;      10/18/9   first cut.
    1517;;;
     
    2830(defClass STYLED-SEMI-COLON-COMMENT (styled-comment) ())
    2931
     32(defMethod style-comment ((comment styled-semi-colon-comment))
     33  (set-style-attributes (attribute-dictionary (language-semi-colon-comment-style))
     34                        (comment-start comment) (comment-end comment)))
     35
    3036(defClass STYLED-SHARP-COMMENT (styled-comment) ())
    3137
    32 (defMethod style-comment ((comment styled-semi-colon-comment))
    33   (set-style-attributes (attribute-dictionary *semi-colon-comment-style*)
    34                         (comment-start comment) (comment-end comment)))
    35 
    3638(defMethod style-comment ((comment styled-sharp-comment))
    37   (set-style-attributes (attribute-dictionary *sharp-comment-style*)
     39  (set-style-attributes (attribute-dictionary (language-sharp-comment-style))
    3840                        (comment-start comment) (comment-end comment)))
    3941
     
    4749(defMethod style-string ((string styled-string))
    4850  (cond (*inc-p* ; if dynamic, never style past *inc-pos*
    49          (set-style-attributes (attribute-dictionary *string-style*)
     51         (set-style-attributes (attribute-dictionary (language-string-style))
    5052                               (string-start string) *inc-pos*))
    5153        (t
    52          (set-style-attributes (attribute-dictionary *string-style*)
     54         (set-style-attributes (attribute-dictionary (language-string-style))
    5355                               (string-start string) (string-end string)))))
    5456
     
    7173  #-sax-debug (call-next-method))
    7274
    73 (defmethod dump-segment-array ((a segment-array))
    74   (format t "~%~%segment-array length: ~S" (segment-array-length a))
     75(defMethod dump-segment-array ((a segment-array))
     76  (format t "~%segment-array length: ~S" (segment-array-length a))
    7577  (dotimes (idx (segment-array-length a))
    76     (format t "~%   ~S" (aref (segment-array-array a) idx 0))
    77     (format t "~%   ~S~%" (aref (segment-array-array a) idx 1))))
     78    (format t "~%~%   ~S" (aref (segment-array-array a) idx 0))
     79    (format t "~%   ~S" (aref (segment-array-array a) idx 1))))
    7880
    7981(defun unify-segment-lists (segment-list-1 segment-list-2)
     
    182184              (setf position (mark-next position))))))
    183185
    184 ;;; This is only called by get-combined-segment-list, when doing vanilla styling.
    185 (defun create-sharp-stroke-comment-list (start end )
     186(defun create-sharp-stroke-comment-list (start end &optional semi-colon-p)
    186187  "Return a list of the form, (start end), for each comment in buffer."
     188  #+sax-debug (when *create-sharp-stroke-comment-list-debug*
     189                (debug-out "~%~%~S" 'create-sharp-stroke-comment-list))
    187190  (do* ((position (clone start))
    188191        comment-list comment-end)
    189        ((or (null position) (mark> position end)) (nreverse comment-list))
     192       ((or (null position) (mark> position end))
     193        #+sax-debug (when *create-sharp-stroke-comment-list-debug*
     194                      (debug-out "~%comment-list: ~S" (reverse comment-list)))
     195        (nreverse comment-list))
     196    #+sax-debug (when *create-sharp-stroke-comment-list-debug*
     197                  (debug-out "~%position: ~S" position))
    190198    (cond ((and (eql (mark-char position) #\#)
    191199                (eql (mark-char (mark-next position)) #\|)
    192                 (mark> position (buf-start-mark))
    193                 (not (eql (mark-char (mark-prev position)) #\\)))
    194            (setf comment-end (pattern-search position *stroke-sharp-forward-pattern* end))
    195            (cond ((and comment-end (mark<= comment-end end))
     200                (mark>= position (buf-start-mark))
     201                (not (and (mark-prev position)
     202                          (eql (mark-char (mark-prev position)) #\\)))
     203                (not (and (> (mark-charpos position) 0)
     204                          semi-colon-p
     205                          (pattern-search position
     206                                          %semicolon-backward-pattern%
     207                                          (hi::line-start (clone position))))))
     208           (setf comment-end (pattern-search position %stroke-sharp-forward-pattern% end))
     209           (cond ((and comment-end (mark<= comment-end end)
     210                       (not (and (> (mark-charpos position) 0)
     211                                 semi-colon-p
     212                                 (pattern-search position
     213                                                 %semicolon-backward-pattern%
     214                                                 (hi::line-start (clone comment-end))))))
    196215                  (push (list position comment-end) comment-list)
    197216                  (setf position (mark-next comment-end)))
    198                  (t
     217                 (t ; ***
    199218                  (return (nreverse comment-list)))))
    200219          (t
     
    226245               (mark> (aref (segment-array-array array) index 1) position))
    227246      ;; embedded - return the end of the containing segment as the second value:
    228       (return (values nil (aref (segment-array-array array) index 1))))
     247      (return (values nil (aref (segment-array-array array) index 0))))
    229248    (cond ((mark<= position (aref (segment-array-array array) index 0))
    230249           (setf top (1- index)))
     
    234253
    235254(defun embedded-in-segment-p (pos)
     255  #+sax-debug (when *embedded-in-segment-p-debug*
     256               (debug-out "~%~%~S" 'embedded-in-segment-p))
    236257  (when *segment-array*
    237     (multiple-value-bind (not-embedded-p end-of-segment)
     258    (multiple-value-bind (not-embedded-p start-of-segment)
    238259                         (not-embedded-in-segment-p *segment-array* pos)
    239       (values (not not-embedded-p) end-of-segment))))
     260      #+sax-debug (when *embedded-in-segment-p-debug*
     261                    (debug-out "~%not-embedded-p: ~S" not-embedded-p)
     262                    (debug-out "~%start-of-segment: ~S" start-of-segment))
     263      (values (not not-embedded-p) start-of-segment))))
    240264
    241265(defun style-strings (&optional (start (buf-start-mark)) (end (buf-end-mark))
     
    267291  (let ((comment-instances nil)
    268292        (comment-segment-list nil))
    269     (do* ((start-comment (pattern-search start *semicolon-forward-pattern* end)
    270                          (pattern-search end-comment *semicolon-forward-pattern* end))
     293    (do* ((start-comment (pattern-search start %semicolon-forward-pattern% end)
     294                         (pattern-search end-comment %semicolon-forward-pattern% end))
    271295          (end-comment (when start-comment (line-end (clone start-comment)))
    272296                       (when start-comment (line-end (clone start-comment)))))
     
    281305      (when (or (and (mark= start-comment (mark-line-start start-comment))
    282306                     (or (not *inc-p*)
    283                          (and *inc-p*
     307                         (and *inc-p*
     308                              (mark-prev *inc-pos*)
    284309                              (mark>= *inc-pos* start-comment)
    285310                              (mark<= (mark-prev *inc-pos*) end-comment))))
     
    294319        (when (or (not *inc-p*)
    295320                  (and *inc-p*
     321                       (mark-prev *inc-pos*)
    296322                       (mark>= *inc-pos* start-comment)
    297323                       (mark<= (mark-prev *inc-pos*) end-comment)))
     
    308334    comment-instances))
    309335
    310 (defun style-sharp-comments (&optional (start (buf-start-mark)) (end (buf-end-mark)))
     336(defun style-sharp-comments (start end &optional comment-segment-list)
    311337  (flet ((find-end-comment (start-comment)
    312338           (do* ((level-count 1)
    313                  (next-end-comment (pattern-search start-comment *stroke-sharp-forward-pattern* end)
     339                 (next-end-comment (pattern-search start-comment %stroke-sharp-forward-pattern% end)
    314340                                   (when next-start-comment
    315                                      (pattern-search (nmark-offset next-start-comment 2) *stroke-sharp-forward-pattern* end)))
    316                  (next-start-comment (pattern-search (nmark-offset start-comment 2) *sharp-stroke-forward-pattern* end)
     341                                     (pattern-search (nmark-offset next-start-comment 2) %stroke-sharp-forward-pattern% end)))
     342                 (next-start-comment (pattern-search (nmark-offset start-comment 2) %sharp-stroke-forward-pattern% end)
    317343                                     (when next-start-comment
    318                                        (pattern-search (nmark-offset next-start-comment 2) *sharp-stroke-forward-pattern* end))))
     344                                       (pattern-search (nmark-offset next-start-comment 2) %sharp-stroke-forward-pattern% end))))
    319345                ((null next-end-comment))
    320346             (when (and next-start-comment (mark< next-start-comment next-end-comment))
     
    323349             (decf level-count)
    324350             (when (= level-count 0) (return next-end-comment)))))
    325     (let ((comment-instances nil)
    326           (comment-segment-list nil))
    327       (do* ((start-comment (pattern-search start *sharp-stroke-forward-pattern* end)
    328                            (pattern-search end-comment *sharp-stroke-forward-pattern* end))
    329             (end-comment (when (and start-comment (mark<= start-comment end)) ; *** redundant
    330                            (find-end-comment start-comment))
    331                          (when (and start-comment (mark<= start-comment end))
    332                            (find-end-comment start-comment))))
    333            ((or (not start-comment)
    334                 (not end-comment)))
    335         (cond ((and (not-embedded-in-segment-p *segment-array* start-comment)
    336                     (not-embedded-in-segment-p *segment-array* end-comment)
    337                     (or (not *inc-p*)
    338                         (and *inc-p*
    339                              (mark>= *inc-pos* start-comment)
    340                              (mark<= (mark-offset *inc-pos* -3) end-comment))))
    341                (push (list start-comment end-comment) comment-segment-list)
    342                (push (make-instance 'styled-sharp-comment
    343                        :comment-start (mark-offset start-comment -2)
    344                        :comment-end (mark-offset end-comment 2))
    345                      comment-instances))))
     351    (let (comment-instances)
     352      (if comment-segment-list
     353        (do* ((segments comment-segment-list (rest segments))
     354              (segment (first segments) (first segments))
     355              (start-comment (when segment (first segment)) (when segment (first segment)))
     356              (end-comment (when segment (second segment)) (when segment (second segment))))
     357             ((or (not start-comment)
     358                  (not end-comment)))
     359          (cond ((and (not-embedded-in-segment-p *segment-array* start-comment)
     360                      (not-embedded-in-segment-p *segment-array* end-comment)
     361                      (or (not *inc-p*)
     362                          (and *inc-p*
     363                               (mark>= *inc-pos* start-comment)
     364                               (mark<= (mark-offset *inc-pos* -3) end-comment))))
     365                 (push (make-instance 'styled-sharp-comment
     366                         ;; :comment-start (mark-offset start-comment -2)
     367                         :comment-start start-comment
     368                         :comment-end (mark-offset end-comment 2))
     369                       comment-instances))))
     370        (do* ((start-comment (pattern-search start %sharp-stroke-forward-pattern% end)
     371                             (pattern-search end-comment %sharp-stroke-forward-pattern% end))
     372              (end-comment (when (and start-comment (mark<= start-comment end)) ; *** redundant
     373                             (find-end-comment start-comment))
     374                           (when (and start-comment (mark<= start-comment end))
     375                             (find-end-comment start-comment))))
     376             ((or (not start-comment) (not end-comment))
     377              (setq comment-segment-list (nreverse comment-segment-list)))
     378          (cond ((and (not-embedded-in-segment-p *segment-array* start-comment)
     379                      (not-embedded-in-segment-p *segment-array* end-comment)
     380                      (or (not *inc-p*)
     381                          (and *inc-p*
     382                               (mark>= *inc-pos* start-comment)
     383                               (mark<= (mark-offset *inc-pos* -3) end-comment))))
     384                 (push (list start-comment end-comment) comment-segment-list)
     385                 (push (make-instance 'styled-sharp-comment
     386                         ;; :comment-start (mark-offset start-comment -2)
     387                         :comment-start start-comment
     388                         :comment-end (mark-offset end-comment 2))
     389                       comment-instances)))))
    346390      (when comment-instances
    347         (setf *segment-list* (unify-segment-lists (nreverse comment-segment-list) *segment-list*))
     391        (setf *segment-list* (unify-segment-lists comment-segment-list *segment-list*))
    348392        (setf *segment-array* (make-segment-array *segment-list*))
    349393        (setf comment-instances (nreverse comment-instances))
     
    352396        comment-instances))))
    353397
    354 (defun style-comments (start end)
     398(defun style-comments (start end &optional sharp-comment-list)
    355399  (style-strings start end)
    356400  (style-semi-colon-comments start end)
    357   (style-sharp-comments start end))
     401  (style-sharp-comments start end sharp-comment-list))
    358402
    359403(defun dynamically-style-comments (start end style-strings-p style-semi-colon-comments-p)
     
    375419         (semi-colon-comment-list (create-semi-colon-comment-list start end))
    376420         (sharp-stroke-comment-list (create-sharp-stroke-comment-list start end))
    377          (cocoa-function-list (create-cocoa-syntax-list start end *sharp-slash-forward-pattern*))
    378          (cocoa-constant1-list (create-cocoa-syntax-list start end *sharp-dollar-forward-pattern*))
    379          (cocoa-constant2-list (create-cocoa-syntax-list start end *sharp-ampersand-forward-pattern*))
    380          (cocoa-constant3-list (create-cocoa-syntax-list start end *colon-lessthan-forward-pattern*))
    381          (cocoa-constant4-list (create-cocoa-syntax-list start end *sharp-backslash-forward-pattern*)))
     421         (cocoa-function-list (create-cocoa-syntax-list start end %sharp-slash-forward-pattern%))
     422         (cocoa-constant1-list (create-cocoa-syntax-list start end %sharp-dollar-forward-pattern%))
     423         (cocoa-constant2-list (create-cocoa-syntax-list start end %sharp-ampersand-forward-pattern%))
     424         (cocoa-constant3-list (create-cocoa-syntax-list start end %colon-lessthan-forward-pattern%))
     425         (cocoa-constant4-list (create-cocoa-syntax-list start end %sharp-backslash-forward-pattern%))
     426         (cocoa-constant5-list (create-cocoa-syntax-list start end %sharp-greaterthan-forward-pattern%)))
    382427    (unify-segment-lists
    383428     string-list
     
    391436         cocoa-constant4-list
    392437         (unify-segment-lists
    393           cocoa-function-list
     438          cocoa-constant5-list
    394439          (unify-segment-lists
    395            semi-colon-comment-list
    396            sharp-stroke-comment-list)))))))))
    397 
    398 
    399 
    400 
     440           cocoa-function-list
     441           (unify-segment-lists
     442            semi-colon-comment-list
     443            sharp-stroke-comment-list))))))))))
     444
     445
     446
     447
  • trunk/cocoa-ide-contrib/foy/syntax-styling/syntax-styling-specials.lisp

    r13041 r14985  
    1 ;;;-*- Mode: Lisp; Package: SYNTAX-STYLING -*-
     1;;;-*- Mode: Lisp; Package: syntax-styling -*-
    22
    33;;; ****************************************************************************
     
    55;;;      syntax-styling-specials.lisp
    66;;;
    7 ;;;      copyright (c) 2009 Glen Foy
     7;;;      copyright (c) 2009, 2011 Glen Foy
    88;;;      (Permission is granted to Clozure Associates to distribute this file.)
    99;;;
     
    1313;;;
    1414;;;      Mod History, most recent first:
     15;;;      9/7/11    update for ccl 1.7
    1516;;;      10/18/9   First cut.
    1617;;;
     
    2223(in-package "SAX")
    2324
    24 (defParameter *style-case-p* t "To set case, or not to set case.")
    25 
    26 ;;; ----------------------------------------------------------------------------
    27 ;;; Configure your style by hacking the colors and style parameters below:
    28 ;;; ----------------------------------------------------------------------------
    29 ;;;
    30 (defParameter *black-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.0 0.0 1.0))
    31 (defParameter *gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.92 0.92 0.92 1.0))
    32 (defParameter *medium-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.30 0.30 0.30 1.0))
    33 (defParameter *darker-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.11 0.11 0.11 1.0))
    34 (defParameter *dark-gray-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.01 0.01 0.01 1.0))
    35 (defParameter *blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.1 0.65 1.0))
    36 (defParameter *light-blue-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.35 0.65 1.0))
    37 (defParameter *green-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.2 0.0 1.0))
    38 (defParameter *turquoise-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.3 0.4 1.0))
    39 (defParameter *violet-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.15 0.1 0.7 1.0))
    40 (defParameter *wine-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.5 0.1 0.2 1.0))
    41 (defParameter *medium-red-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.8 0.0 0.2 1.0))
    42 (defParameter *magenta-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.75 0.0 0.5 1.0))
    43 (defParameter *dark-magenta-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.35 0.0 0.25 1.0))
    44 (defParameter *brown-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.35 0.2 0.0 1.0))
    45 
    46 (defParameter *generic-symbol-color* *blue-color*)
    47 (defParameter *generic-macro-color* *wine-red-color*)
     25;;; This is for exported symbol styling in the prefs dialog.
     26(export '(common-lisp-user::pizza-to-go) :common-lisp-user)
     27
     28(defConstant %syntax-styling-version% "Version 0.2.1")
     29
     30(defVar *styling-p* t "To style or not to style.")
     31(defVar *do-case-styling* t)
     32(defVar *do-keyword-package* t)
     33(defVar *do-exported-symbols* nil)
     34(defVar *do-language-package* t)
     35
     36;;; These three are actually defined by defstyle.  Doing it here to muffle warnings:
     37(defVar *clojure-java-style* nil)
     38(defVar *vanilla-style* nil)
     39(defVar *generic-text-style* nil)
     40
     41(defParameter *generic-symbol-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.0 0.1 0.65 1.0))
     42(defParameter *generic-macro-color* (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color 0.5 0.1 0.2 1.0))
    4843
    4944;;; Convert style-spec to an ns-dictionary with the specified attributes.
     
    5146(defun spec-to-dict (font-spec)
    5247  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 2))
    53          (color (getf font-spec :font-color))
     48         (color (encoded-color-to-ns-color (getf font-spec :font-color)))
    5449         (underline (getf font-spec :font-underline)) ; :single :double :thick
    5550         (underline-int (case underline (:single 1) (:double 2) (:thick 3))))
     
    6156    dict))
    6257
    63 ;;; ----------------------------------------------------------------------------
    64 ;;; The Styles:
    65 ;;; ----------------------------------------------------------------------------
    66 ;;;
    67 ;;; The cdr of each dotted-pair is the capitalization spec:
    68 (defParameter *vanilla-styling* (cons (spec-to-dict (list :font-color *black-color*)) :down))
    69 (defParameter *generic-text-style* (cons (spec-to-dict (list :font-color *darker-gray-color*)) :down))
    70 (defParameter *generic-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap3))
    71 (defParameter *generic-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
    72 (defParameter *generic-function-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) 
    73 (defParameter *embedded-function-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down)) 
    74 ;;; This is also the style for lambda-list keywords:
    75 (defParameter *keyword-package-style* (cons (spec-to-dict (list :font-color *dark-magenta-color*)) :down))
    76 (defParameter *cl-package-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
    77 (defParameter *exported-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :double)) :up))
    78 
    79 (defParameter *semi-colon-comment-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged))
    80 (defParameter *sharp-comment-style* (cons (spec-to-dict (list :font-color *medium-gray-color*)) :unchanged))
    81 (defParameter *string-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged))
    82 
    83 (defParameter *superparen-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :unchanged))
    84 (defParameter *eval-when-superparen-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :unchanged))
    85 (defParameter *loop-superparen-style* (cons (spec-to-dict (list :font-color *turquoise-color*)) :unchanged))
    86 
    87 (defParameter *variable-definition-symbol-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down))
    88 (defParameter *defstruct-field-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
    89 (defParameter *defstruct-ancestor-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
    90 (defParameter *defclass-derivation-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
    91 (defParameter *defclass-slot-style* (cons (spec-to-dict (list :font-color *blue-color*)) :down))
    92 (defParameter *parameter-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down))
    93 (defParameter *specializer-style* (cons (spec-to-dict (list :font-color *green-color*)) :unchanged))
    94 (defParameter *case-match-style* (cons (spec-to-dict (list :font-color *light-blue-color*)) :down))
    95 
    96 (defParameter *defpackage-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
    97 (defParameter *defparameter-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
    98 (defParameter *defvar-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
    99 (defParameter *defconstant-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color*)) :down))
    100 (defParameter *defclass-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :up))
    101 (defParameter *defun-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
    102 (defParameter *defmacro-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
    103 (defParameter *defgeneric-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
    104 (defParameter *defmethod-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
    105 (defParameter *objc-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :unchanged))
    106 (defParameter *defcommand-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :unchanged))
    107 (defParameter *defstruct-symbol-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :up))
    108 
    109 (defParameter *lambda-macro-style* (cons (spec-to-dict (list :font-color *generic-symbol-color* :font-underline :single)) :down))
    110 (defParameter *loop-macro-style* (cons (spec-to-dict (list :font-color *magenta-color*)) :up))
    111 (defParameter *loop-keyword-style* (cons (spec-to-dict (list :font-color *dark-magenta-color*)) :down))
    112 (defParameter *defun-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :down))
    113 (defParameter *objc-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap8))
    114 (defParameter *defcommand-macro-style* (cons (spec-to-dict (list :font-color *generic-macro-color*)) :cap12))
     58(defun encoded-color-to-ns-color (color)
     59  (when (integerp color)
     60    (multiple-value-bind (red green blue)
     61                         (color-values color)
     62      (#/retain (#/colorWithCalibratedRed:green:blue:alpha: ns:ns-color red green blue 1.0)))))
     63
     64(defun ns-color-to-encoded-color (ns-color)
     65  "Returns an encoded color from an ns-color"
     66  (let ((red (truncate (* (#/redComponent ns-color) 65535)))
     67        (green (truncate (* (#/greenComponent ns-color) 65535)))
     68        (blue (truncate (* (#/blueComponent ns-color) 65535))))
     69    (make-color red green blue)))
     70
     71;;; some color encoding code stolen from MCL (may she rest in peace):
     72(defun make-color (red green blue)
     73  "Given red, green, and blue, returns an encoded rgb value"
     74  (flet ((check-color (color)
     75           (unless (and (fixnump color)
     76                        (<= 0 (the fixnum color))
     77                        (<= (the fixnum color) 65535))
     78             (error "Illegal color component: ~s" color))))
     79    (declare (inline check-color))
     80    (check-color red)
     81    (check-color green)
     82    (check-color blue))
     83  (locally (declare (fixnum red green blue))
     84    (let* ((r (logand red #xff00))
     85           (g (logand green #xff00))
     86           (b (logand blue #xff00)))
     87      (declare (fixnum r g b))
     88      (logior (the fixnum (ash  r 8))
     89              (the fixnum g)
     90              (the fixnum (ash b -8))))))
     91
     92(defun color-red (color &optional (component (logand (the fixnum (lsh color -16)) #xff)))
     93  "Returns the red portion of the color"
     94  (declare (fixnum component))
     95  (the fixnum (+ (the fixnum (ash component 8)) component)))
     96
     97(defun color-green (color &optional (component (logand (the fixnum (lsh color -8)) #xff)))
     98  "Returns the green portion of the color"
     99  (declare (fixnum component))
     100  (the fixnum (+ (the fixnum (ash component 8)) component)))
     101
     102(defun color-blue (color &optional (component (logand color #xff)))
     103  "Returns the blue portion of the color"
     104  (declare (fixnum component))
     105  (the fixnum (+ (the fixnum (ash component 8)) component)))
     106
     107(defun color-values (color)
     108  "Given an encoded color, returns the red, green, and blue components"
     109  (values
     110   (/ (float (color-red color)) (float 65535))
     111   (/ (float (color-green color)) (float 65535))
     112   (/ (float (color-blue color)) (float 65535))))
    115113
    116114;;; ----------------------------------------------------------------------------
     
    118116;;; ----------------------------------------------------------------------------
    119117;;;
    120 (defParameter *styling-p* t "To style or not to style.")
    121 (defParameter *buf* nil "The target buffer.")
    122 (defParameter *layout* nil "The NSLayoutManager of the target text-view.")
    123 (defParameter *current-package* nil "Package used to style exported symbols.")
     118(defVar *buf* nil "The target buffer.")
     119(defVar *layout* nil "The NSLayoutManager of the target text-view.")
     120(defVar *current-package* nil "Package used to style exported symbols.")
    124121;;; consolidate these two:
    125 (defParameter *inc-p* nil "Styling incrementally?")
    126 (defParameter *inc-pos* nil "Buffer-point during an incremental parse.")
    127 (defParameter *inside-semi-colon-comment-p* nil)
    128 (defParameter *paste-p* nil "Is a paste in progress?")
    129 (defParameter *paste-start* nil "Starting position of a paste operation.")
    130 (defParameter *paste-end* nil "Ending position of a paste operation.")
    131 
    132 ;;; test
    133 (defParameter *style-screen-p* t "To style or not to style the screen after a given operation.")
    134 (defParameter *style-top-level-form-p* nil "To style or not to style the top-level form after a given operation.")
    135 (defParameter *segment-list* nil "Comment and string code data structure.")
    136 (defParameter *segment-array* nil "Comment and string code data structure.")
    137 
    138 (defParameter *form-style* nil "The style of the atom being processed incrementally.")
    139 (defParameter *form-start* nil "The start position of the atom being processed incrementally.")
    140 (defParameter *form-end* nil "The end position of the atom being processed incrementally.")
    141 (defParameter *superparen-closure* nil "An ugly hack to style superparens.")
     122(defVar *inc-p* nil "Styling incrementally?")
     123(defVar *inc-pos* nil "Buffer-point during an incremental parse.")
     124(defVar *inside-semi-colon-comment-p* nil)
     125(defVar *paste-p* nil "Is a paste in progress?")
     126(defVar *paste-start* nil "Starting position of a paste operation.")
     127(defVar *paste-end* nil "Ending position of a paste operation.")
     128(defVar *prev-event* nil "The previous key-event to track control-x commands.")
     129
     130(defParameter *common-lisp-hash-table* (make-hash-table :test 'equal))
     131(defParameter *scheme-syntax-hash-table* (make-hash-table :test 'equal))
     132(defParameter *clojure-hash-table* (make-hash-table :test 'equal))
     133
     134(defVar *style-screen-p* t "To style or not to style the screen after a given operation.")
     135(defVar *style-top-level-form-p* nil "To style or not to style the top-level form after a given operation.")
     136(defVar *segment-list* nil "Comment and string code data structure.")
     137(defVar *segment-array* nil "Comment and string code data structure.")
     138(defVar *form-style* nil "The style of the atom being processed incrementally.")
     139(defVar *form-start* nil "The start position of the atom being processed incrementally.")
     140(defVar *form-end* nil "The end position of the atom being processed incrementally.")
     141(defVar *superparen-closure* nil "An ugly hack to style superparens.")
    142142
    143143;;; key-event constants:
    144 (defParameter %control-y% #k"control-y")
    145 (defParameter %control-meta-q% #k"control-meta-q")
    146 (defParameter %control-d% #k"control-d")
    147 (defParameter %backspace% #k"Backspace")
    148 (defParameter %control-j% #k"control-j")
    149 (defparameter %backward-char-event% (hi::get-key-event* 98 8))
    150 
    151 ;;; Search patterns:
    152 (defparameter *l-paren-forward-pattern* (new-search-pattern :character :forward #\())
    153 (defparameter *l-paren-backward-pattern* (new-search-pattern :character :backward #\())
    154 (defparameter *sharp-stroke-forward-pattern* (new-search-pattern :string-insensitive :forward "#|"))
    155 (defparameter *stroke-sharp-forward-pattern* (new-search-pattern :string-insensitive :forward "|#"))
    156 (defparameter *semicolon-forward-pattern* (new-search-pattern :character :forward #\;))
    157 (defParameter *sharp-slash-forward-pattern* (new-search-pattern :string-insensitive :forward "#/"))
    158 (defParameter *sharp-backslash-forward-pattern* (new-search-pattern :string-insensitive :forward "#\\"))
    159 (defParameter *sharp-dollar-forward-pattern* (new-search-pattern :string-insensitive :forward "#$"))
    160 (defParameter *sharp-ampersand-forward-pattern* (new-search-pattern :string-insensitive :forward "#&"))
    161 (defParameter *colon-lessthan-forward-pattern* (new-search-pattern :string-insensitive :forward ":<"))
     144(defConstant %control-y% #k"control-y")
     145(defConstant %control-v% #k"control-v")
     146(defConstant %control-x% #k"control-x")
     147(defConstant %control-meta-q% #k"control-meta-q")
     148(defConstant %control-e% #k"control-e")
     149(defConstant %control-c% #k"control-c")
     150(defConstant %control-d% #k"control-d")
     151(defConstant %backspace% #k"Backspace")
     152(defConstant %control-j% #k"control-j")
     153(defConstant %backward-char-event% (hi::get-key-event* 98 8))
     154
     155;;; Search pattern constants:
     156(defConstant %l-paren-forward-pattern% (new-search-pattern :character :forward #\())
     157(defConstant %l-paren-backward-pattern% (new-search-pattern :character :backward #\())
     158(defConstant %l-bracket-forward-pattern% (new-search-pattern :character :forward #\[))
     159(defConstant %r-bracket-forward-pattern% (new-search-pattern :character :forward #\]))
     160(defConstant %l-curly-brace-forward-pattern% (new-search-pattern :character :forward #\{))
     161(defConstant %r-curly-brace-forward-pattern% (new-search-pattern :character :forward #\}))
     162(defConstant %forward-slash-forward-pattern% (new-search-pattern :character :forward #\/))
     163(defConstant %semicolon-forward-pattern% (new-search-pattern :character :forward #\;))
     164(defConstant %semicolon-backward-pattern% (new-search-pattern :character :backward #\;))
     165(defConstant %dot-forward-pattern% (new-search-pattern :character :forward #\.))
     166(defConstant %percent-forward-pattern% (new-search-pattern :character :forward #\%))
     167(defConstant %lambda-forward-pattern% (new-search-pattern :string-insensitive :forward "lambda"))
     168(defConstant %sharp-stroke-forward-pattern% (new-search-pattern :string-insensitive :forward "#|"))
     169(defConstant %stroke-sharp-forward-pattern% (new-search-pattern :string-insensitive :forward "|#"))
     170(defConstant %sharp-slash-forward-pattern% (new-search-pattern :string-insensitive :forward "#/"))
     171(defConstant %sharp-greaterthan-forward-pattern% (new-search-pattern :string-insensitive :forward "#>"))
     172(defConstant %sharp-backslash-forward-pattern% (new-search-pattern :string-insensitive :forward "#\\"))
     173(defConstant %sharp-dollar-forward-pattern% (new-search-pattern :string-insensitive :forward "#$"))
     174(defConstant %sharp-ampersand-forward-pattern% (new-search-pattern :string-insensitive :forward "#&"))
     175(defConstant %colon-lessthan-forward-pattern% (new-search-pattern :string-insensitive :forward ":<"))
    162176
    163177;;; ----------------------------------------------------------------------------
     
    170184;;; are usually provided, using the prepended "n" convention for destructive functions.
    171185
    172 (defmacro clone (mark) `(hi::copy-mark ,mark :temporary))
    173 
    174 (defmacro set-storage (storage source)
     186(defMacro clone (mark) `(when ,mark (hi::copy-mark ,mark :temporary)))
     187
     188(defMacro set-storage (storage source)
    175189  `(progn
    176190     (setf (mark-charpos ,storage) (mark-charpos ,source))
     
    181195;;; only evaluating MARK-OR-FORM once.
    182196;;; No error, if MARK-OR-FORM evaluates to nil, just return nil.
    183 (defmacro mark-next (mark-or-form)
     197(defMacro mark-next (mark-or-form)
    184198  (let ((param (gensym))
    185199        (new-mark (gensym)))
     
    192206           ,new-mark)))))
    193207
    194 (defmacro nmark-next (mark-or-form)
     208(defMacro nmark-next (mark-or-form)
    195209  (let ((param (gensym)))
    196210    `(let ((,param ,mark-or-form))
    197211       (when ,param (mark-after ,param)))))
    198212
    199 (defmacro mark-prev (mark-or-form)
     213(defMacro mark-prev (mark-or-form)
    200214  (let ((param (gensym))
    201215        (new-mark (gensym)))
     
    208222           ,new-mark)))))
    209223
    210 (defmacro nmark-prev (mark-or-form)
     224(defMacro nmark-prev (mark-or-form)
    211225  (let ((param (gensym)))
    212226    `(let ((,param ,mark-or-form))
     
    214228
    215229;;; This does not cross lines
    216 (defmacro mark-char (mark &optional offset)
     230(defMacro mark-char (mark &optional offset)
    217231  (if offset
    218232    (let ((line (gensym))
     
    233247         (next-character ,mark))))
    234248
    235 (defmacro mark-move (mark pos)
     249(defMacro mark-move (mark pos)
    236250  (let ((new-mark (gensym)))
    237251    `(when ,mark
     
    239253         (move-to-position ,new-mark ,pos)))))
    240254
    241 (defmacro nmark-move (mark pos)
     255(defMacro nmark-move (mark pos)
    242256  `(move-to-position ,mark ,pos))
    243257
    244 (defmacro mark-line-start (mark)
     258(defMacro mark-line-start (mark)
    245259  (let ((new-mark (gensym)))
    246260    `(when ,mark
     
    248262         (line-start ,new-mark)))))
    249263
    250 (defmacro mark-offset (mark offset)
     264(defMacro mark-offset (mark offset)
    251265  (let ((new-mark (gensym)))
    252266    `(when ,mark
     
    254268         (character-offset ,new-mark ,offset)))))
    255269
    256 (defmacro nmark-offset (mark offset)
     270(defMacro nmark-offset (mark offset)
    257271  `(when ,mark
    258272     (character-offset ,mark ,offset)
     
    263277(defMacro mark-max (m1 m2) `(if (mark> ,m1 ,m2) ,m1 ,m2))
    264278
    265 (defmacro buf-end-mark (&optional buffer)
     279(defMacro buf-end-mark (&optional buffer)
    266280  `(clone (buffer-end-mark (if ,buffer ,buffer *buf*))))
    267281
    268 (defmacro buf-start-mark (&optional buffer)
     282(defMacro buf-start-mark (&optional buffer)
    269283  `(clone (buffer-start-mark (if ,buffer ,buffer *buf*))))
    270284
     
    273287;;; ----------------------------------------------------------------------------
    274288;;;
    275 (defmacro buffer-empty-p () `(mark= (buffer-start-mark *buf*) (buffer-end-mark *buf*)))
     289(defMacro buffer-empty-p () `(mark= (buffer-start-mark *buf*) (buffer-end-mark *buf*)))
    276290
    277291(defun buffer-line-start (buffer &optional storage)
     
    296310;;; ----------------------------------------------------------------------------
    297311;;;
    298 (defmacro sexpr-end (start)
     312(defMacro sexpr-end (start)
    299313    (let ((sexpr-start (gensym))
    300314          (sexpr-end (gensym)))
     
    305319             ,sexpr-end
    306320             #+sax-debug (when *sexpr-end-debug*
    307                            (debug-out "~%sexpr-end returning nil - start-mark: ~S" ,start)))))))
    308 
    309 (defmacro sexpr-start (pos)
     321                             (debug-out "~%sexpr-end returning nil - start-mark: ~S" ,start)))))))
     322
     323(defMacro sexpr-start (pos)
    310324  (let ((sexpr-start (gensym)))
    311325    `(when ,pos
     
    316330                         (debug-out "~%sexpr-start returning nil - pos-mark: ~S" ,pos)))))))
    317331
    318 (defmacro limited-sexpr-end (start limit)
     332(defMacro limited-sexpr-end (start limit)
    319333  (let ((sexpr-start (gensym))
    320334        (sexpr-end (gensym)))
     
    333347                         (debug-out "~%limited-sexpr-end returning nil - start-mark: ~S" ,start)))))))
    334348
    335 (defmacro next-sexpr-start (mark-or-form)
     349(defMacro next-sexpr-start (mark)
    336350  (let ((position (gensym))
     351        (previous-position (gensym))
    337352        (forward (gensym))
    338353        (start (gensym))
    339354        (param (gensym)))
    340     ;; evaluate mark-or-form once, only:
    341     `(let ((,param ,mark-or-form))
     355    `(let ((,param (clone ,mark))
     356           (,previous-position nil))
    342357       (when ,param
    343358         #+sax-debug (when *next-sexpr-start-debug*
    344                       (debug-out "~%next-sexpr-start mark-or-form: ~S" ,mark-or-form)
    345                       (debug-out "~%next-sexpr-start param: ~S" ,param))
    346          (do* ((,position (clone ,param))
    347                (,forward (when (hemlock::form-offset ,position 1) ,position)
    348                          (when (hemlock::form-offset ,position 1) ,position))
    349                (,start (when ,forward (when (hemlock::form-offset ,forward -1) ,forward))
    350                        (when ,forward (when (hemlock::form-offset ,forward -1) ,forward))))
    351               ((or (null ,start) (mark>= ,start ,param))
    352                #+sax-debug (when (and *next-sexpr-start-debug* (null ,start))
    353                             (debug-out "~%next-sexpr-start returning nil"))
     359                       (debug-out "~%~%~S" 'next-sexpr-start)
     360                       (debug-out "~%next-sexpr-start mark: ~S" ,mark))
     361         (do* ((,position (clone ,param) (clone ,param))
     362               (,forward (cond ((hemlock::form-offset ,position 1)
     363                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: forward: ~S" ,position))
     364                                ,position)
     365                               (t
     366                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: (form-offset position 1) failed"))
     367                                nil))
     368                         (cond ((hemlock::form-offset ,position 1)
     369                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: forward: ~S" ,position))
     370                                ,position)
     371                               (t
     372                                #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: (form-offset position 1) failed"))
     373                               nil)))
     374               (,start (when ,forward (when (hemlock::form-offset ,forward -1)
     375                                        #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: start: ~S" ,forward))
     376                                        ,forward))
     377                       (when ,forward (when (hemlock::form-offset ,forward -1)
     378                                        #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%do: start: ~S" ,forward))
     379                                        ,forward))))
     380              ((or (null ,start) (mark>= ,start ,mark))
     381               #+sax-debug (when *next-sexpr-start-debug*
     382                             (debug-out "~%forward: ~S" ,forward)
     383                             (debug-out "~%start: ~S" ,start))
     384               #+sax-debug (when (and *next-sexpr-start-debug* (null ,start)) (debug-out "~%next-sexpr-start returning nil"))
    354385               (if *inc-p*
    355386                 (when (and ,start (mark< ,start *inc-pos*))
    356387                   ,start)
    357388                 ,start))
    358            #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%start: ~S" ,start))
    359            (hemlock::form-offset ,position 1)
    360            #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%(form-offset position 1): ~S" ,position))
    361            (cond ((null ,position)
    362                   #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%next-sexpr-start returning nil"))
    363                   (return nil))
    364                  ((mark<= ,position ,param)
    365                   ;; wretched special case: avoid getting stuck:  ie.  (eq ,errsym #.^#$ o )
    366                   #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%next-sexpr-start returning (mark-next ,position)"))
    367                   (set-storage ,position ,param)
    368                   (return (mark-next ,position)))))))))
     389           (hemlock::form-offset ,param 1)
     390           #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%(form-offset param 1): ~S" ,param))
     391
     392           ;; This COND is a kludge to compensate for what appears to be a bug in hemlock::form-offset.
     393           ;; When there is a semicolon comment directly after a form like so:
     394           ;;      (pushnew 'foo list);offending comment
     395           ;; form-offset does not go to the next form. If the comment has a space:
     396           ;;      (pushnew 'foo list) ;comment with space
     397           ;; things work as advertised. 7-15-11
     398           (cond ((null ,param) (return nil))
     399                 ((null ,previous-position)
     400                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%setting previous-position: ~S" ,param))
     401                  (setq ,previous-position (clone ,param)))
     402                 ((mark= ,previous-position ,param) ; avoiding an endless loop is good ...
     403                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%repeated position: ~S, doing form-offset again." ,param))
     404                  (setq ,previous-position nil)
     405                  (hemlock::form-offset ,param 1)
     406                  #+sax-debug (when *next-sexpr-start-debug* (debug-out "~%form-offset again: ~S" ,param)))
     407                 (t
     408                  (setq ,previous-position (clone ,param)))))))))
    369409
    370410(defMacro nnext-sexpr-start (mark-or-form)
     
    376416       (when ,param
    377417         #+sax-debug (when *nnext-sexpr-start-debug*
    378                       (debug-out "~%nnext-sexpr-start mark-or-form: ~S" ,mark-or-form)
    379                       (debug-out "~%nnext-sexpr-start param: ~S" ,param))
     418                       (debug-out "~%~%~S"'nnext-sexpr-start)
     419                       (debug-out "~%mark-or-form: ~S" ,mark-or-form)
     420                       (debug-out "~%param: ~S" ,param))
    380421         (let* ((,position ,param)
    381422                (,forward (when (hemlock::form-offset ,position 1) ,position))
     
    449490      (when (find-pattern m pattern) m))))
    450491
     492(defun language-string-style ()
     493  (cond ((lisp-file-p) (string-style))
     494        ((scheme-file-p) (scheme-string-style))
     495        ((clojure-file-p) (clojure-string-style))))
     496
     497(defun language-documentation-style ()
     498  (cond ((lisp-file-p) (documentation-style))
     499        ;;; ***
     500        ((scheme-file-p) (documentation-style))
     501        ((clojure-file-p) (clojure-documentation-style))))
     502
     503(defun language-generic-text-style ()
     504  (cond ((lisp-file-p) (generic-text-style))
     505        ((scheme-file-p) (scheme-generic-text-style))
     506        ((clojure-file-p) (clojure-generic-text-style))))
     507
     508(defun language-semi-colon-comment-style ()
     509  (cond ((lisp-file-p) (semi-colon-comment-style))
     510        ((scheme-file-p) (scheme-semi-colon-comment-style))
     511        ((clojure-file-p) (clojure-semi-colon-comment-style))))
     512
     513(defun language-sharp-comment-style ()
     514  (cond ((lisp-file-p) (sharp-comment-style))
     515        ((scheme-file-p) (scheme-sharp-comment-style))))
     516
     517(defun language-keyword-style ()
     518  (cond ((lisp-file-p) (keyword-package-style))
     519        ((clojure-file-p) (clojure-keyword-style))))
     520
    451521#|
    452522;;; (buffer-writable buffer) is broken
     
    462532(defMethod writable-p ((hemlock-view hi::hemlock-view))
    463533  (let ((buffer (hemlock-view-buffer hemlock-view)))
    464     (or (not *style-case-p*)
     534    (or (not *do-case-styling*)
    465535        (format t "~%view-writable-p: ~S" (buffer-writable buffer))
    466536        ;; *** broken
     
    470540  (let* ((hemlock-view (gui::hemlock-view text-view))
    471541         (buffer (hemlock-view-buffer hemlock-view)))
    472     (or (not *style-case-p*)
     542    (or (not *do-case-styling*)
    473543        (format t "~%writable-p: ~S" (buffer-writable buffer))
    474544        (buffer-writable buffer))))
     
    477547  (let* ((hemlock-view (gui::hemlock-view window))
    478548         (buffer (hemlock-view-buffer hemlock-view)))
    479     (or (not *style-case-p*)
     549    (or (not *do-case-styling*)
    480550        (format t "~%writable-p: ~S" (buffer-writable buffer))
    481551        (buffer-writable buffer))))
     
    497567    (when buffer (hi::buffer-pathname buffer))))
    498568
    499 (defmacro char-eolp (char)
     569(defMacro char-eolp (char)
    500570  `(member ,char '(#\return #\linefeed #\newline ,(code-char #x2028) ,(code-char #x2029))))
    501571
    502 (defun ed-beep () (#_NSBeep)) ; *** this beeper doesn't beep
     572(defun ed-beep () ())
     573;;; (#_nsbeep))
    503574
    504575(define-symbol-macro *listener-output* (hemlock-ext::top-listener-output-stream))
     
    522593       (= (hi::key-event-bits k1) (hi::key-event-bits k2))))
    523594
    524 (defmethod hemlock-update ((view hi:hemlock-view) start end &optional count)
     595(defMethod hemlock-update ((view hi:hemlock-view) start end &optional count)
    525596  (let* ((buffer (hemlock-view-buffer view))
    526597         (document (hi::buffer-document buffer))
     
    528599         (location (mark-absolute-position start))
    529600         (length (or count (- (mark-absolute-position end) location))))
    530 ;         (count (hemlock::count-characters (region start end))))
    531601    #+sax-debug (when *hemlock-update-debug*
    532602                   (debug-out "~%~%~S" 'hemlock-update)
     
    538608    (gui::perform-edit-change-notification
    539609     text-storage
    540      (objc:@selector #/noteHemlockAttrChangeAtPosition:length:)
    541      location length 0)))       
    542 
    543 (defmethod hemlock-update ((frame gui::hemlock-frame) start end &optional count)
     610     (objc:@selector #/noteHemlockAttrChangeAtPosition:length:fontNum:)
     611     location length 0)))
     612
     613(defMethod hemlock-update ((frame gui::hemlock-frame) start end &optional count)
    544614  (let ((hemlock-view (gui::hemlock-view frame)))
    545615    (hemlock-update hemlock-view start end count)))
     
    552622                                        (end (buf-end-mark)))
    553623  #+sax-debug (when *set-style-attributes-debug*
    554                  (debug-out "~%~%~S" 'set-style-attributes)
    555                  (debug-out "~%dictionary: ~S" dictionary)
    556                  (debug-out "~%start: ~S" start)
    557                  (debug-out "~%end: ~S" end))
    558 
    559   (ns:with-ns-range (range)
    560     (let* ((location (mark-absolute-position start))
    561            (length (- (mark-absolute-position end) location)))
    562       (setf (ns:ns-range-location range) location)
    563       (setf (ns:ns-range-length range) length)
    564       ;; Remove all temporary attributes from the character range
    565       (#/removeTemporaryAttribute:forCharacterRange:
    566        *layout* #&NSForegroundColorAttributeName range)
    567       (#/removeTemporaryAttribute:forCharacterRange:
    568        *layout* #&NSUnderlineStyleAttributeName range)
    569       (#/addTemporaryAttributes:forCharacterRange: *layout* dictionary range))))
     624                (debug-out "~%~%~S" 'set-style-attributes)
     625                (debug-out "~%dictionary: ~S" dictionary)
     626                (debug-out "~%start: ~S" start)
     627                (debug-out "~%end: ~S" end))
     628  (when (and start end)
     629    (ns:with-ns-range (range)
     630      (let* ((location (mark-absolute-position start))
     631             (length (- (mark-absolute-position end) location)))
     632        (setf (ns:ns-range-location range) location)
     633        (setf (ns:ns-range-length range) length)
     634        ;; Remove all temporary attributes from the character range
     635        (#/removeTemporaryAttribute:forCharacterRange:
     636         *layout* #&NSForegroundColorAttributeName range)
     637        (#/removeTemporaryAttribute:forCharacterRange:
     638         *layout* #&NSUnderlineStyleAttributeName range)
     639        (#/addTemporaryAttributes:forCharacterRange: *layout* dictionary range)))))
    570640
    571641(defun set-generic-text-style (text-view &optional (start (buf-start-mark)) (end (buf-end-mark)))
     
    579649           layout #&NSBackgroundColorAttributeName
    580650           char-range)))))
    581   ;; *** maybe chuck this:
    582   (set-style-attributes  (attribute-dictionary *generic-text-style*) start end))
     651  (set-style-attributes  (attribute-dictionary (language-generic-text-style)) start end))
    583652
    584653(defun downcase-region (start end)
     
    618687  (capitalize-region (mark-offset start 8) (mark-offset start 9)))
    619688
     689;;; *** hemlock::defCommand
    620690(defMethod set-style-case ((case (eql :cap12)) start end)
    621691  (set-style-case :down start end)
     
    638708     (when (or (and *inc-p* (not *paste-p*)
    639709                    (mark>= *inc-pos* ,start)
    640                     (mark<= *inc-pos* ,end))
     710                    ;; mark-next to accommodate styling after a space char
     711                    (mark<= *inc-pos* (mark-next ,end)))
    641712               (not *inc-p*)
    642713               (and *paste-p*
     
    644715                    (mark<= ,end *paste-end*)))
    645716
    646        (when (and *style-case-p* ,set-case-p (style-case ,style))
     717       (when (and *do-case-styling* ,set-case-p (style-case ,style))
    647718         #+sax-debug (when *style-region-debug*
    648719                      (debug-out "~%set-style-case, case: ~S" (style-case ,style))
     
    661732             (t
    662733              #+sax-debug (when *style-region-debug*
    663                              (if (equalp ,style *generic-text-style*)
    664                                (debug-out "~%*** styling-region-generically: ~S ***"
    665                                           (region-to-string (region ,start ,end)))
    666                                (debug-out "~%*** styling-region: ~S ***"
    667                                           (region-to-string (region ,start ,end))))
    668                              (debug-out "~%style: ~S" ,style))
     734                            (if (or (equalp ,style *generic-text-style*)
     735                                    (equalp ,style *scheme-generic-text-style*)
     736                                    (equalp ,style *clojure-generic-text-style*))
     737                              (debug-out "~%*** styling-region-generically: ~S ***"
     738                                         (region-to-string (region ,start ,end)))
     739                              (debug-out "~%*** styling-region: ~S ***"
     740                                         (region-to-string (region ,start ,end))))
     741                            (debug-out "~%style: ~S" ,style))
    669742              (set-style-attributes (attribute-dictionary ,style) ,start ,end))))))
    670743
    671 
     744 
     745
     746
  • trunk/cocoa-ide-contrib/foy/syntax-styling/syntax-styling.lisp

    r13040 r14985  
    1616            (merge-pathnames ";syntax-styling-specials.lisp" *syntax-styling-directory*)
    1717            (merge-pathnames ";syntax-styling-comments.lisp" *syntax-styling-directory*)
    18             (merge-pathnames ";syntax-styling-1.lisp" *syntax-styling-directory*)
    19             (merge-pathnames ";syntax-styling-2.lisp" *syntax-styling-directory*)
     18            (merge-pathnames ";syntax-styling-engine.lisp" *syntax-styling-directory*)
     19            (merge-pathnames ";syntax-styling-prefs.lisp" *syntax-styling-directory*)
     20            (merge-pathnames ";syntax-styling-defstyle.lisp" *syntax-styling-directory*)
    2021            #+sax-debug (merge-pathnames ";testing1.lisp" *syntax-styling-directory*)
    2122            #+sax-debug (merge-pathnames ";testing2.lisp" *syntax-styling-directory*)
     
    2324 
    2425(dolist (file *syntax-styling-files*)
    25   (load file))
     26  (load file :verbose nil))
    2627
     28(pushnew :syntax-styling *features*)
    2729(provide :syntax-styling)
    2830
  • trunk/cocoa-ide-contrib/foy/window-parking-cm/window-parking-dialogs.lisp

    r12801 r14985  
    1919(in-package "WINDOW-PARKING")
    2020
    21 (defparameter *dps-dialog* nil "The define-parking-spot-dialog instance.")
    22 (defparameter *del-dialog* nil "The delete-parking-spot-dialog instance.")
     21(defParameter *dps-dialog* nil "The define-parking-spot-dialog instance.")
     22(defParameter *del-dialog* nil "The delete-parking-spot-dialog instance.")
    2323
    2424
    2525;;; ----------------------------------------------------------------------------
    2626;;;
    27 (defclass DEFINE-PARKING-SPOT-DIALOG (ns:ns-window)
     27(defClass DEFINE-PARKING-SPOT-DIALOG (ns:ns-window)
    2828  ((path :initform nil :accessor psd-path)
    2929   (okay-button :initform nil :accessor psd-okay-button)
     
    3333  (:metaclass ns:+ns-object))
    3434
    35 (defmethod selected-function-key ((d define-parking-spot-dialog))
     35(defMethod selected-function-key ((d define-parking-spot-dialog))
    3636  (read-from-string (ccl::lisp-string-from-nsstring
    3737                     (#/title (#/selectedCell (psd-function-key-matrix d))))))
     
    5151                                                     (format nil "~A" path))
    5252                                                    cmenu::*tool-key-dictionary*)))
    53     (flet ((selectFunctionKey (num)
     53    (flet ((selectfunctionkey (num)
    5454             (dolist (button (psd-function-key-buttons *dps-dialog*))
    5555               (let ((key (read-from-string (ccl::lisp-string-from-nsstring (#/title button)))))
     
    8787                 (when (zerop ret) (selected-function-key dialog)))))))))
    8888
    89 (defmethod get-items ((d define-parking-spot-dialog))
     89(defMethod get-items ((d define-parking-spot-dialog))
    9090  (append
    9191   (make-prompt-field)
     
    190190;;; ----------------------------------------------------------------------------
    191191;;;
    192 (defclass DELETE-PARKING-SPOT-DIALOG (ns:ns-window)
     192(defClass DELETE-PARKING-SPOT-DIALOG (ns:ns-window)
    193193  ((path :initform nil :accessor psd-path)
    194194   (okay-button :initform nil :accessor psd-okay-button)
     
    198198  (:metaclass ns:+ns-object))
    199199
    200 (defmethod selected-function-key ((d delete-parking-spot-dialog))
     200(defMethod selected-function-key ((d delete-parking-spot-dialog))
    201201  (read-from-string (ccl::lisp-string-from-nsstring
    202202                     (#/title (#/selectedCell (psd-function-key-matrix d))))))
     
    238238             (when (zerop ret) (selected-function-key dialog)))))))
    239239
    240 (defmethod get-delete-items ((d delete-parking-spot-dialog))
     240(defMethod get-delete-items ((d delete-parking-spot-dialog))
    241241  (append
    242242   (make-delete-prompt-field)
  • trunk/cocoa-ide-contrib/foy/window-parking-cm/window-parking.lisp

    r13037 r14985  
    2121
    2222
    23 (defpackage "WINDOW-PARKING" (:nicknames "WP") (:use :cl :ccl))
     23(defPackage "WINDOW-PARKING" (:nicknames "WP") (:use :cl :ccl))
    2424(in-package "WINDOW-PARKING")
    2525
     
    2727(require :list-definitions-cm)
    2828
    29 (defparameter *window-parker* nil "The window-parker instance.")
    30 (defparameter *window-parking-menu* nil "The window-parking-menu instance.")
     29(defParameter *window-parker* nil "The window-parker instance.")
     30(defParameter *window-parking-menu* nil "The window-parking-menu instance.")
    3131(defParameter *park-p* t "To park or not to park.")
    3232
     
    5151                 (open-define-parking-spot-dialog path current-function-key)
    5252                 (open-define-parking-spot-dialog path)))))
     53    (unless window
     54      (cmenu:notify (format nil "First open a window, adjusting its size and position.") ))
    5355    (when defined-function-key
    5456      (cond (current-function-key
     
    7678  (call-next-method))
    7779
    78 (defmethod initialize-instance :after ((m window-parking-menu) &key)
     80(defMethod initialize-instance :after ((m window-parking-menu) &key)
    7981  (setf (tool-menu m) (cmenu:add-default-tool-menu m :doc-file (doc-path m)))
    8082  (flet ((create-menu-item (name action)
     
    104106;;; ----------------------------------------------------------------------------
    105107;;;
    106 (defclass PARKABLE-HEMLOCK-FRAME (gui::hemlock-frame)
     108(defClass PARKABLE-HEMLOCK-FRAME (gui::hemlock-frame)
    107109  ((parked-p :initform nil :accessor parked-p)
    108110   (front-p :initform nil :accessor front-p))
    109111  (:metaclass ns:+ns-object))
    110112
    111 (defmethod init-parking ((w parkable-hemlock-frame))
     113(defMethod init-parking ((w parkable-hemlock-frame))
    112114  (setf (parked-p w) nil)
    113115  (setf (front-p w) nil))
    114116
    115 (defmethod h-position ((w parkable-hemlock-frame))
     117(defMethod h-position ((w parkable-hemlock-frame))
    116118  (let ((rect (#/frame w)))
    117     (pref rect :<NSR>ect.origin.x)))
    118 
    119 (defmethod v-position ((w parkable-hemlock-frame))
     119    (pref rect :<nsr>ect.origin.x)))
     120
     121(defMethod v-position ((w parkable-hemlock-frame))
    120122  (let ((rect (#/frame w)))
    121     (pref rect :<NSR>ect.origin.y)))
    122 
    123 (defmethod h-dimension ((w parkable-hemlock-frame))
     123    (pref rect :<nsr>ect.origin.y)))
     124
     125(defMethod h-dimension ((w parkable-hemlock-frame))
    124126  (let ((rect (#/frame w)))
    125     (pref rect :<NSR>ect.size.width)))
    126 
    127 (defmethod v-dimension ((w parkable-hemlock-frame))
     127    (pref rect :<nsr>ect.size.width)))
     128
     129(defMethod v-dimension ((w parkable-hemlock-frame))
    128130  (let ((rect (#/frame w)))
    129     (pref rect :<NSR>ect.size.height)))
     131    (pref rect :<nsr>ect.size.height)))
    130132
    131133(objc:defmethod (#/close :void) ((w parkable-hemlock-frame))
     
    133135  (call-next-method))
    134136
    135 (defmethod modified-p ((w parkable-hemlock-frame))
     137(defMethod modified-p ((w parkable-hemlock-frame))
    136138  (when w
    137139    (let* ((pane (slot-value w 'gui::pane))
     
    141143        (hi::buffer-modified buffer)))))
    142144
    143 (defmethod print-object ((w parkable-hemlock-frame) stream)
     145(defMethod print-object ((w parkable-hemlock-frame) stream)
    144146  (format stream "<parkable-hemlock-frame: ~S>" (namestring (cmenu:window-path w))))
    145147
     
    224226                        (#/visibleFrame (#/mainScreen ns:ns-screen))
    225227                        (#/visibleFrame screen)))
    226          (screen-left (pref screen-rect :<NSR>ect.origin.x))
    227          (screen-right (+ screen-left (pref screen-rect :<NSR>ect.size.width)))
    228          (screen-bottom (pref screen-rect :<NSR>ect.origin.y))
    229          (screen-top (+ screen-bottom (pref screen-rect :<NSR>ect.size.height))))
     228         (screen-left (pref screen-rect :<nsr>ect.origin.x))
     229         (screen-right (+ screen-left (pref screen-rect :<nsr>ect.size.width)))
     230         (screen-bottom (pref screen-rect :<nsr>ect.origin.y))
     231         (screen-top (+ screen-bottom (pref screen-rect :<nsr>ect.size.height))))
    230232    (and (>= (ps-h-position ps) screen-left)
    231233         (<= (+ (ps-h-position ps) (ps-h-dimension ps)) screen-right)
Note: See TracChangeset for help on using the changeset viewer.