Changeset 7666


Ignore:
Timestamp:
Nov 16, 2007, 11:58:32 PM (12 years ago)
Author:
rme
Message:

Merge trunk changes r7361:7663.

Location:
branches/ia32
Files:
6 deleted
82 edited
20 copied

Legend:

Unmodified
Added
Removed
  • branches/ia32/cocoa-ide/Info.plist-proto

    r6883 r7666  
    11<?xml version="1.0" encoding="UTF-8"?>
    2 <!DOCTYPE plist SYSTEM "file://localhost/System/Library/DTDs/PropertyList.dtd">
     2<!DOCTYPE plist PUBLIC "-//Apple//DTD PLIST 1.0//EN" "http://www.apple.com/DTDs/PropertyList-1.0.dtd">
    33<plist version="1.0">
    44<dict>
     
    1111                        <array>
    1212                                <string>lisp</string>
     13                        </array>
     14                        <key>CFBundleTypeIconFile</key>
     15                        <string>openmcl-icon.icns</string>
     16                        <key>CFBundleTypeName</key>
     17                        <string>Lisp source code</string>
     18                        <key>CFBundleTypeRole</key>
     19                        <string>Editor</string>
     20                        <key>LSIsAppleDefaultForType</key>
     21                        <true/>
     22                        <key>NSDocumentClass</key>
     23                        <string>HemlockEditorDocument</string>
     24                </dict>
     25                <dict>
     26                        <key>CFBundleTypeIconFile</key>
     27                        <string>openmcl-icon.icns</string>
     28                        <key>CFBundleTypeName</key>
     29                        <string>Listener</string>
     30                        <key>CFBundleTypeRole</key>
     31                        <string>Editor</string>
     32                        <key>NSDocumentClass</key>
     33                        <string>HemlockListenerDocument</string>
     34                </dict>
     35                <dict>
     36                        <key>CFBundleTypeExtensions</key>
     37                        <array>
     38                                <string>txt</string>
     39                                <string>text</string>
    1340                                <string>*</string>
    1441                        </array>
     
    1744                        <key>CFBundleTypeOSTypes</key>
    1845                        <array>
    19                                 <string>TEXT</string>
     46                                <string>****</string>
    2047                        </array>
    2148                        <key>CFBundleTypeRole</key>
    2249                        <string>Editor</string>
    23                         <key>CFBundleTypeName</key>
    24                         <string>Lisp source file</string>
    2550                        <key>NSDocumentClass</key>
    2651                        <string>HemlockEditorDocument</string>
    27                         <key>CFBundleTypeIconFile</key>
    28                         <string>openmcl-icon.icns</string>
    29                 </dict>
    30                 <dict>
    31                         <key>CFBundleTypeName</key>
    32                         <string>Listener</string>
    33                         <key>CFBundleTypeRole</key>
    34                         <string>Editor</string>
    35                         <key>NSDocumentClass</key>
    36                         <string>HemlockListenerDocument</string>
    37                         <key>CFBundleTypeIconFile</key>
    38                         <string>openmcl-icon.icns</string>
    3952                </dict>
    4053                <dict>
     
    4558                        <key>NSDocumentClass</key>
    4659                        <string>DisplayDocument</string>
    47                 </dict> </array>
     60                </dict>
     61        </array>
     62        <key>CFBundleExecutable</key>
     63        <string>OPENMCL-KERNEL</string>
    4864        <key>CFBundleHelpBookFolder</key>
    4965        <string>Help</string>
    5066        <key>CFBundleHelpBookName</key>
    5167        <string>OpenMCL Help</string>
    52         <key>CFBundleExecutable</key>
    53         <string>OPENMCL-KERNEL</string>
     68        <key>CFBundleIconFile</key>
     69        <string>openmcl-icon.icns</string>
     70        <key>CFBundleIdentifier</key>
     71        <string>OPENMCL-IDENTIFIER</string>
    5472        <key>CFBundleInfoDictionaryVersion</key>
    5573        <string>6.0</string>
     74        <key>CFBundleName</key>
     75        <string>OPENMCL-NAME</string>
    5676        <key>CFBundlePackageType</key>
    5777        <string>APPL</string>
     
    5979        <string>OMCL</string>
    6080        <key>CFBundleVersion</key>
    61         <string>0.2</string>
     81        <string>OPENMCL-VERSION</string>
    6282        <key>NSMainNibFile</key>
    6383        <string>MainMenu</string>
    6484        <key>NSPrincipalClass</key>
    6585        <string>LispApplication</string>
    66         <key>CFBundleName</key>
    67         <string>OpenMCL</string>
    68         <key>CFBundleIdentifier</key>
    69         <string>com.clozure.OpenMCL</string>
    70         <key>CFBundleIconFile</key>
    71         <string>openmcl-icon.icns</string>
     86        <key>UTExportedTypeDeclarations</key>
     87        <array>
     88                <dict>
     89                        <key>UTTypeConformsTo</key>
     90                        <string>public.source-code</string>
     91                        <key>UTTypeDescription</key>
     92                        <string>Lisp source file</string>
     93                        <key>UTTypeIdentifier</key>
     94                        <string>org.lisp.lisp-source</string>
     95                        <key>UTTypeReferenceURL</key>
     96                        <string></string>
     97                        <key>UTTypeTagSpecification</key>
     98                        <dict>
     99                                <key>public.filename-extension</key>
     100                                <array>
     101                                        <string>lisp</string>
     102                                        <string>lsp</string>
     103                                        <string>cl</string>
     104                                </array>
     105                        </dict>
     106                </dict>
     107        </array>
    72108</dict>
    73109</plist>
  • branches/ia32/cocoa-ide/build-application.lisp

    r7362 r7666  
    7070    ;; copy IDE resources into the application bundle
    7171    (recursive-copy-directory (path ide-bundle-path "Contents" "Resources/")
    72                               (path app-bundle  "Contents" "Resources/"))
     72                              (path app-bundle  "Contents" "Resources/")
     73                              :if-exists :overwrite)
    7374    ;; copy user-supplied nibfiles into the bundle
    7475    (when nibfiles
     
    8687            (if (probe-file dest)
    8788                (error "The destination nibfile '~A' already exists" dest)
    88                 (recursive-copy-directory n dest))))))
     89                (recursive-copy-directory n dest :if-exists :overwrite))))))
    8990    ;; save the application image
    9091    (save-application image-path
  • branches/ia32/cocoa-ide/builder-utilities.lisp

    r7362 r7666  
    2828                   app)
    2929         app))
    30 
    31 ;;; PATHNAME-SEPARATOR
    32 ;;; returns the character used to separate elements of a pathname
    33 ;;; on this platform.
    34 ;;; TODO: add conditional compiles to support platforms where
    35 ;;;       the path separator is not "/" (if we ever care about that)
    36 (defun pathname-separator () #\/)
    37 
    38 ;;; ENSURE-DIRECTORY-PATHNAME p
    39 ;;; Returns the input pathname P, but ensures that it ends with a
    40 ;;; path separator, so that it will be parsed as a directory
    41 (defmethod ensure-directory-pathname ((p string))
    42   (let ((pstr (namestring p)))
    43     (if (char= (pathname-separator)
    44                (elt pstr (1- (length pstr))))
    45         p
    46         (pathname (concatenate 'string p (string (pathname-separator)))))))
    47 
    48 (defmethod ensure-directory-pathname ((p pathname))
    49   (ensure-directory-pathname (namestring p)))
    5030
    5131;;; BASENAME path
     
    8262                           (ensure-directory-pathname (car components))))))
    8363
    84 
    85 ;;; RECURSIVE-COPY-DIRECTORY source-path dest-path
    86 ;;; Copies the contents of the SOURCE-PATH to the DEST-PATH.
    87 ;;;
    88 ;;; TODO: - add an ignore-list ability, so I can prevent
    89 ;;;         this function from copying CVS and .svn directories
    90 ;;;       - add some flags to control what do do if the dest
    91 ;;;         already exists, and that sort of thing. Currently,
    92 ;;;         this function just clobbers naything that is already
    93 ;;;         in DEST-PATH
    94 (defun recursive-copy-directory (source-path dest-path)
    95   (ensure-directories-exist (ensure-directory-pathname dest-path))
    96   (let ((files (directory (path source-path "*.*") :directories nil :files t))
    97         (subdirs (directory (path source-path "*.*") :directories t :files nil)))
    98 ;    (format t "~%files = ~S" files)
    99 ;    (format t "~%subdirs = ~S~%" subdirs)
    100     (dolist (f files)
    101       (let* ((src-name (file-namestring f))
    102              (dest-file (path dest-path src-name)))
    103         (ccl:copy-file f dest-file
    104                        :if-exists :supersede
    105                        :preserve-attributes t)))
    106     (dolist (d subdirs)
    107       (let* ((subdir-name (first (last (pathname-directory d))))
    108              (dest-dir (ensure-directory-pathname (path dest-path subdir-name))))
    109         (recursive-copy-directory d dest-dir)))
    110     dest-path
    111     ))
    11264
    11365;;; WRITE-PKGINFO path package-type bundle-signature
     
    151103           (ide-bundle (#/mainBundle ns:ns-bundle))
    152104           (ide-bundle-path-nsstring (#/bundlePath ide-bundle))
    153            (ide-bundle-path (pathname
    154                              (ensure-directory-pathname
    155                               (lisp-string-from-nsstring ide-bundle-path-nsstring))))
     105           (ide-bundle-path (ensure-directory-pathname
     106                             (lisp-string-from-nsstring ide-bundle-path-nsstring)))
    156107           (ide-plist-path-str (namestring (path ide-bundle-path
    157108                                                 "Contents" "Info.plist")))
  • branches/ia32/cocoa-ide/cocoa-application.lisp

    r6884 r7666  
    2121  (use-interface-dir :cocoa))
    2222
     23;;; loading cocoa.lisp creates an IDE bundle in *cocoa-application-path*,
     24;;; perhaps copying headers as per *cocoa-application-copy-headers-p*
     25(defvar *cocoa-application-path* "ccl:Clozure CL.app;")
     26(defvar *cocoa-application-copy-headers-p* t)
    2327(require "COCOA")
    24 ;;; Alternately, one could
    25 ;;; (require "COCOA-INSPECTOR").  I haven't tried this yet, but think
    26 ;;; that it -should- work.
    27 
    28 
    29 
    3028
    3129(defclass cocoa-application (application)
     
    5048    (#_ _exit -1))
    5149  (setq *standalone-cocoa-ide* t)
     50  ;; TODO: to avoid confusion, should now reset *cocoa-application-path* to
     51  ;; actual bundle path where started up.
    5252  (start-cocoa-application))
    5353
    5454
    55 ;;; Wait until we're sure that the Cocoa event loop has started.
    56 (wait-on-semaphore *cocoa-application-finished-launching*)
     55  ;;; The saved image will be an instance of COCOA-APPLICATION (mostly
     56  ;;; so that it'll ignore its argument list.)  When it starts up, it'll
     57  ;;; run the Cocoa event loop in the cocoa event process.
     58  ;;; If you use an init file ("home:ccl-init"), it'll be loaded
     59  ;;; in an environment in which *STANDARD-INPUT* always generates EOF
     60  ;;; and where output and error streams are directed to the OSX console
     61  ;;; (see below).  If that causes problems, you may want to suppress
     62  ;;; the loading of your init file (via an :INIT-FILE nil arg to
     63  ;;; the call to SAVE-APPLICATION, below.)
    5764
    58  
    59 ;;; The saved image will be an instance of COCOA-APPLICATION (mostly
    60 ;;; so that it'll ignore its argument list.)  When it starts up, it'll
    61 ;;; run the Cocoa event loop in the cocoa event process.
    62 ;;; If you use an init file ("home:openmcl-init"), it'll be loaded
    63 ;;; in an environment in which *STANDARD-INPUT* always generates EOF
    64 ;;; and where output and error streams are directed to the OSX console
    65 ;;; (see below).  If that causes problems, you may want to suppress
    66 ;;; the loading of your init file (via an :INIT-FILE nil arg to
    67 ;;; the call to SAVE-APPLICATION, below.)
     65(defun build-ide (bundle-path)
     66  (setq bundle-path (ensure-directory-pathname bundle-path))
    6867
    69 ;;; As things are distributed, the file "dppccl" in the application
    70 ;;; bundle is just a placeholder.  LaunchServices may have already
    71 ;;; decided that the application isn't really executable and may
    72 ;;; have cached that fact; touching the bundle directory
    73 ;;; here is an attempt to force LaunchServices to discard that
    74 ;;; cached information.
     68  ;; The bundle is expected to exists, we'll just add the executable into it.
     69  (assert (probe-file bundle-path))
    7570
    76 (touch "ccl:cocoa-ide;openmcl.app;")
     71  ;; Wait until we're sure that the Cocoa event loop has started.
     72  (wait-on-semaphore *cocoa-application-finished-launching*)
    7773
    78 (save-application
    79  (make-pathname
    80   :directory (pathname-directory (translate-logical-pathname "ccl:cocoa-ide;OpenMCL.app;Contents;MacOS;"))
    81   :name (standard-kernel-name))
    82  :prepend-kernel t
    83  :application-class 'cocoa-application)
     74  (require :easygui)
     75
     76  (maybe-map-objc-classes t)
     77  (let* ((missing ()))
     78    (do-interface-dirs (d)
     79      (cdb-enumerate-keys
     80       (db-objc-classes d)
     81       (lambda (name)
     82         (let* ((class (lookup-objc-class name nil))) (unless (objc-class-id  class) (push name missing))))))
     83    (when missing
     84      (break "ObjC classes ~{~&~a~} are declared but not defined." missing)))
     85
     86  (touch bundle-path)
     87
     88  (let ((image-file (make-pathname :name (standard-kernel-name) :type nil :version nil
     89                                   :defaults (merge-pathnames ";Contents;MacOS;" bundle-path))))
     90    (format *error-output* "~2%Saving application to ~a~2%" (truename bundle-path))
     91    (force-output *error-output*)
     92    (ensure-directories-exist image-file)
     93    (save-application image-file
     94                      :prepend-kernel t
     95                      :application-class 'cocoa-application)))
    8496
    8597;;; If things go wrong, you might see some debugging information via
     
    8799;;; and error output for the initial lisp process will be directed
    88100;;; there.
    89 
     101(build-ide *cocoa-application-path*)
  • branches/ia32/cocoa-ide/cocoa-defaults.lisp

    r7244 r7666  
    110110             (unless (%null-ptr-p nsstring)
    111111               (set name (lisp-string-from-nsstring nsstring)))))
    112           (:color
     112          ((:color :font)
    113113           (let* ((data (#/dataForKey: domain key)))
    114114             (unless (%null-ptr-p data)
     
    130130                                        ns:ns-archiver
    131131                                        (apply #'color-values-to-nscolor value)))
     132                               (:font (#/archivedDataWithRootObject:
     133                                       ns:ns-archiver
     134                                       (funcall value)))
    132135                               (:bool (if value #@"YES" #@"NO"))
    133136                               (t
  • branches/ia32/cocoa-ide/cocoa-doc.lisp

    r6866 r7666  
    11(in-package "CCL")
    22
    3 (def-cocoa-default *hyperspec-http-url-string* :string "http://www.lisp.org/HyperSpec/" "HTTP URL for HyperSpec lookup")
    4 
    5 (def-cocoa-default *hyperspec-file-url-string* :string "/" "filesystem path for HyperSpec lookup")
     3(def-cocoa-default *hyperspec-url-string* :string "http://www.lispworks.com/documentation/HyperSpec/" "HTTP URL for HyperSpec lookup")
    64
    75(defloadvar *hyperspec-root-url* nil)
    86(defloadvar *hyperspec-map-sym-hash* nil)
    9 
    10 
    117(defloadvar *hyperspec-map-sym-url* nil)
    12 
    13 (def-cocoa-default *hyperspec-use-file-url* :bool nil "selects hyperspec url scheme")
    14 
    158
    169(def-cocoa-default *hyperspec-lookup-enabled* :bool nil "enables hyperspec lookup"
     
    9992(defun hyperspec-root-url ()
    10093  (or *hyperspec-root-url*
    101       (set *hyperspec-root-url* (setup-hyperspec-root-url))))
     94      (setq *hyperspec-root-url* (setup-hyperspec-root-url))))
    10295
    10396(defun setup-hyperspec-root-url ()
    10497  (make-instance 'ns:ns-url
    10598                 :with-string
    106                  (%make-nsstring
    107                   (if *hyperspec-use-file-url*
    108                     *hyperspec-file-url-string*
    109                     *hyperspec-http-url-string*))))
    110    
    111                                
    112                              
     99                 (%make-nsstring *hyperspec-url-string*)))
    113100
    114101(defun hyperspec-map-hash (document)
  • branches/ia32/cocoa-ide/cocoa-editor.lisp

    r7287 r7666  
    1818  (defconstant large-number-for-text (float 1.0f7 +cgfloat-zero+)))
    1919
     20(def-cocoa-default *editor-font* :font #'(lambda ()
     21                                           (#/fontWithName:size:
     22                                            ns:ns-font
     23                                            #@"Monaco" 10.0))
     24                   "Default font for editor windows")
     25
    2026(def-cocoa-default *editor-rows* :int 24 "Initial height of editor windows, in characters")
    2127(def-cocoa-default *editor-columns* :int 80 "Initial width of editor windows, in characters")
    2228
    2329(def-cocoa-default *editor-background-color* :color '(1.0 1.0 1.0 1.0) "Editor background color")
     30(def-cocoa-default *wrap-lines-to-window* :bool nil
     31                   "Soft wrap lines to window width")
    2432
    2533(defmacro nsstring-encoding-to-nsinteger (n)
     
    3341   (64 n)))
    3442
     43;;; Create a paragraph style, mostly so that we can set tabs reasonably.
     44(defun rme-create-paragraph-style (font line-break-mode)
     45  (let* ((p (make-instance 'ns:ns-mutable-paragraph-style))
     46         (charwidth (fround (nth-value 1 (size-of-char-in-font font)))))
     47    (#/setLineBreakMode: p
     48                         (ecase line-break-mode
     49                           (:char #$NSLineBreakByCharWrapping)
     50                           (:word #$NSLineBreakByWordWrapping)
     51                           ;; This doesn't seem to work too well.
     52                           ((nil) #$NSLineBreakByClipping)))
     53    ;; Clear existing tab stops.
     54    (#/setTabStops: p (#/array ns:ns-array))
     55    ;; And set the "default tab interval".
     56    (#/setDefaultTabInterval: p (* *tab-width* charwidth))
     57    p))
     58
     59(defun rme-create-text-attributes (&key (font *editor-font*)
     60                                   (line-break-mode :char)
     61                                   (color nil)
     62                                   (obliqueness nil)
     63                                   (stroke-width nil))
     64  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
     65    (#/setObject:forKey: dict (rme-create-paragraph-style font line-break-mode)
     66                         #&NSParagraphStyleAttributeName)
     67    (#/setObject:forKey: dict font #&NSFontAttributeName)
     68    (when color
     69      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
     70    (when stroke-width
     71      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
     72                           #&NSStrokeWidthAttributeName))
     73    (when obliqueness
     74      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
     75                           #&NSObliquenessAttributeName))
     76    dict))
     77
     78(defun rme-make-editor-style-map ()
     79  (let* ((font *editor-font*)
     80         (fm (#/sharedFontManager ns:ns-font-manager))
     81         (bold-font (#/convertFont:toHaveTrait: fm font #$NSBoldFontMask))
     82         (oblique-font (#/convertFont:toHaveTrait: fm font #$NSItalicFontMask))
     83         (bold-oblique-font (#/convertFont:toHaveTrait:
     84                             fm font (logior #$NSItalicFontMask
     85                                             #$NSBoldFontMask)))
     86         (colors (vector (#/blackColor ns:ns-color)))
     87         (fonts (vector font bold-font oblique-font bold-oblique-font))
     88         (styles (make-instance 'ns:ns-mutable-array)))
     89    (dotimes (c (length colors))
     90      (dotimes (i 4)
     91        (let* ((mask (logand i 3))
     92               (f (svref fonts mask)))
     93          (#/addObject: styles
     94                        (rme-create-text-attributes :font f
     95                                                    :color (svref colors c)
     96                                                    :obliqueness
     97                                                    (if (logbitp 1 i)
     98                                                      (when (eql f font)
     99                                                        0.15f0))
     100                                                    :stroke-width
     101                                                    (if (logbitp 0 i)
     102                                                      (when (eql f font)
     103                                                        -10.0f0)))))))
     104    styles))
     105
     106(defun make-editor-style-map ()
     107  (rme-make-editor-style-map))
     108
     109#+nil
    35110(defun make-editor-style-map ()
    36111  (let* ((font-name *default-font-name*)
     
    71146(defun make-hemlock-buffer (&rest args)
    72147  (let* ((buf (apply #'hi::make-buffer args)))
    73     (if buf
    74       (progn
    75         (setf (hi::buffer-gap-context buf) (hi::make-buffer-gap-context))
    76         buf)
    77       (progn
    78         (format t "~& couldn't make hemlock buffer with args ~s" args)
    79         ;;(dbg)
    80         nil))))
    81          
     148    (assert buf)
     149    buf))
     150
    82151;;; Define some key event modifiers.
    83152
     
    161230                                                buffer-p))
    162231  (when buffer-p (setf (buffer-cache-buffer d) buffer))
    163   (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     232  (let* ((hi::*current-buffer* buffer)
    164233         (workline (hi::mark-line
    165234                    (hi::buffer-start-mark buffer))))
     
    174243(defun adjust-buffer-cache-for-insertion (display pos n)
    175244  (if (buffer-cache-workline display)
    176     (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context (buffer-cache-buffer display))))
     245    (let* ((hi::*current-buffer* (buffer-cache-buffer display)))
    177246      (if (> (buffer-cache-workline-offset display) pos)
    178247        (incf (buffer-cache-workline-offset display) n)
     
    193262(defun update-line-cache-for-index (cache index)
    194263  (let* ((buffer (buffer-cache-buffer cache))
    195          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     264         (hi::*current-buffer* buffer)
    196265         (line (or
    197266                (buffer-cache-workline cache)
     
    222291;;; Ask Hemlock to count the characters in the buffer.
    223292(defun hemlock-buffer-length (buffer)
    224   (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
     293  (let* ((hi::*current-buffer* buffer))
    225294    (hemlock::count-characters (hemlock::buffer-region buffer))))
    226295
     
    229298;;; in that line or the trailing #\newline, as appropriate.
    230299(defun hemlock-char-at-index (cache index)
    231   (let* ((hi::*buffer-gap-context*
    232           (hi::buffer-gap-context (buffer-cache-buffer cache))))
     300  (let* ((hi::*current-buffer* (buffer-cache-buffer cache)))
    233301    (multiple-value-bind (line idx) (update-line-cache-for-index cache index)
    234302      (let* ((len (hemlock::line-length line)))
     
    240308;;; offset on the appropriate line.
    241309(defun move-hemlock-mark-to-absolute-position (mark cache abspos)
    242   (let* ((hi::*buffer-gap-context*
    243           (hi::buffer-gap-context (buffer-cache-buffer cache))))
     310  (let* ((hi::*current-buffer* (buffer-cache-buffer cache)))
    244311    (multiple-value-bind (line idx) (update-line-cache-for-index cache abspos)
    245312      #+debug
     
    255322;;; number of preceding lines.
    256323(defun mark-absolute-position (mark)
    257   (let* ((pos (hi::mark-charpos mark))
    258          (hi::*buffer-gap-context*
    259           (hi::buffer-gap-context (hi::line-%buffer (hi::mark-line mark)))))
     324  (let* ((hi::*current-buffer* (hi::line-%buffer (hi::mark-line mark)))
     325         (pos (hi::mark-charpos mark)))
    260326    (+ (hi::get-line-origin (hi::mark-line mark)) pos)))
    261327
     
    286352         (index (ns:ns-range-location r))
    287353         (length (ns:ns-range-length r))
    288          (hi::*buffer-gap-context*
    289           (hi::buffer-gap-context (buffer-cache-buffer cache))))
     354         (hi::*current-buffer* (buffer-cache-buffer cache)))
    290355    #+debug
    291356    (#_NSLog #@"get characters: %d/%d"
     
    316381         (index (pref r :<NSR>ange.location))
    317382         (length (pref r :<NSR>ange.length))
    318          (hi::*buffer-gap-context*
    319           (hi::buffer-gap-context (buffer-cache-buffer cache))))
     383         (hi::*current-buffer* (buffer-cache-buffer cache)))
    320384    #+debug
    321385    (#_NSLog #@"get line start: %d/%d"
     
    385449;;; Return true iff we're inside a "beginEditing/endEditing" pair
    386450(objc:defmethod (#/editingInProgress :<BOOL>) ((self hemlock-text-storage))
     451  ;; This is meaningless outside the event thread, since you can't tell what
     452  ;; other edit-count changes have already been queued up for execution on
     453  ;; the event thread before it gets to whatever you might queue up next.
     454  (assume-cocoa-thread)
    387455  (> (slot-value self 'edit-count) 0))
     456
     457(defmethod assume-not-editing ((ts hemlock-text-storage))
     458  #+debug (assert (eql (slot-value ts 'edit-count) 0)))
    388459
    389460(defun textstorage-note-insertion-at-position (self pos n)
     
    401472                                                                  (extra :<NSI>nteger))
    402473  (declare (ignorable extra))
     474  (assume-cocoa-thread)
    403475  (let* ((mirror (#/mirror self))
    404476         (hemlock-string (#/hemlockString self))
    405477         (display (hemlock-buffer-string-cache hemlock-string))
    406478         (buffer (buffer-cache-buffer display))
    407          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     479         (hi::*current-buffer* buffer)
    408480         (font (buffer-active-font buffer))
    409          (document (#/document self)))
     481         (document (#/document self))
     482         (undo-mgr (and document (#/undoManager document))))
    410483    #+debug
    411484    (#_NSLog #@"insert: pos = %ld, n = %ld" :long pos :long n)
     
    417490      (ns:with-ns-range (replacerange pos 0)
    418491        (#/replaceCharactersInRange:withString:
    419          mirror replacerange replacestring)))
     492         mirror replacerange replacestring))
     493      (when (and undo-mgr (not (#/isUndoing undo-mgr)))
     494        (#/replaceCharactersAtPosition:length:withString:
     495         (#/prepareWithInvocationTarget: undo-mgr self)
     496         pos n #@"")))
    420497    (#/setAttributes:range: mirror font (ns:make-ns-range pos n))   
    421     (textstorage-note-insertion-at-position self pos n)
    422     ;; Arguably, changecount stuff should happen via the document's NSUndoManager.
    423     ;; At some point in time, we'll know whether or not we have and are using
    424     ;; an NSUndoManager; while we're in limbo about that, do it here.
    425     (#/updateChangeCount: document #$NSChangeDone)))
    426 
     498    (textstorage-note-insertion-at-position self pos n)))
    427499
    428500(objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void) ((self hemlock-text-storage)
     
    431503                                                                 (extra :<NSI>nteger))
    432504  (declare (ignorable extra))
     505  #+debug
     506  (#_NSLog #@"delete: pos = %ld, n = %ld" :long pos :long n)
    433507  (ns:with-ns-range (range pos n)
    434     ;; It seems to be necessary to call #/edited:range:changeInLength: before
    435     ;; deleting from the mirror attributed string.  It's not clear whether this
    436     ;; is also true of insertions and modifications.
    437     (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
    438                                                  #$NSTextStorageEditedAttributes)
    439                                     range (- n))
    440     (#/deleteCharactersInRange: (#/mirror self) range))
    441   (let* ((display (hemlock-buffer-string-cache (#/hemlockString self))))
    442     (reset-buffer-cache display)
    443     (update-line-cache-for-index display pos))
    444   ;; Arguably, changecount stuff should happen via the document's NSUndoManager.
    445   ;; At some point in time, we'll know whether or not we have and are using
    446   ;; an NSUndoManager; while we're in limbo about that, do it here.
    447   (#/updateChangeCount: (#/document self) #$NSChangeDone))
    448  
     508    (let* ((mirror (#/mirror self))
     509           (deleted-string (#/substringWithRange: (#/string mirror) range))
     510           (document (#/document self))
     511           (undo-mgr (and document (#/undoManager document)))
     512           (display (hemlock-buffer-string-cache (#/hemlockString self))))
     513      ;; It seems to be necessary to call #/edited:range:changeInLength: before
     514      ;; deleting from the mirror attributed string.  It's not clear whether this
     515      ;; is also true of insertions and modifications.
     516      (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
     517                                                   #$NSTextStorageEditedAttributes)
     518                                      range (- n))
     519      (#/deleteCharactersInRange: mirror range)
     520      (when (and undo-mgr (not (#/isUndoing undo-mgr)))
     521        (#/replaceCharactersAtPosition:length:withString:
     522         (#/prepareWithInvocationTarget: undo-mgr self)
     523         pos 0 deleted-string))
     524      (reset-buffer-cache display)
     525      (update-line-cache-for-index display pos))))
    449526
    450527(objc:defmethod (#/noteHemlockModificationAtPosition:length: :void) ((self hemlock-text-storage)
     
    453530                                                                     (extra :<NSI>nteger))
    454531  (declare (ignorable extra))
    455   (let* ((hemlock-string (#/hemlockString self))
    456          (mirror (#/mirror self)))
    457     (ns:with-ns-range (range pos n)
     532  #+debug
     533  (#_NSLog #@"modify: pos = %ld, n = %ld" :long pos :long n)
     534  (ns:with-ns-range (range pos n)
     535    (let* ((hemlock-string (#/hemlockString self))
     536           (mirror (#/mirror self))
     537           (deleted-string (#/substringWithRange: (#/string mirror) range))
     538           (document (#/document self))
     539           (undo-mgr (and document (#/undoManager document))))
    458540      (#/replaceCharactersInRange:withString:
    459541       mirror range (#/substringWithRange: hemlock-string range))
    460542      (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
    461                                                    #$NSTextStorageEditedAttributes) range 0)))
    462   ;; Arguably, changecount stuff should happen via the document's NSUndoManager.
    463   ;; At some point in time, we'll know whether or not we have and are using
    464   ;; an NSUndoManager; while we're in limbo about that, do it here.
    465   (#/updateChangeCount: (#/document self) #$NSChangeDone))
    466 
     543                                                   #$NSTextStorageEditedAttributes) range 0)
     544      (when (and undo-mgr (not (#/isUndoing undo-mgr)))
     545        (#/replaceCharactersAtPosition:length:withString:
     546         (#/prepareWithInvocationTarget: undo-mgr self)
     547         pos n deleted-string)))))
    467548
    468549(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void) ((self hemlock-text-storage)
     
    487568         
    488569(objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage))
     570  (assume-cocoa-thread)
    489571  (with-slots (edit-count) self
    490572    #+debug
     
    496578
    497579(objc:defmethod (#/endEditing :void) ((self hemlock-text-storage))
     580  (assume-cocoa-thread)
    498581  (with-slots (edit-count) self
    499582    #+debug
    500583    (#_NSLog #@"end-editing")
    501584    (call-next-method)
     585    (assert (> edit-count 0))
    502586    (decf edit-count)
    503587    #+debug
     
    592676      attrs)))
    593677
    594 000
     678(objc:defmethod (#/replaceCharactersAtPosition:length:withString: :void)
     679    ((self hemlock-text-storage) (pos <NSUI>nteger) (len <NSUI>nteger) string)
     680  (let* ((document (#/document self))
     681         (undo-mgr (and document (#/undoManager document))))
     682    (when (and undo-mgr (not (#/isRedoing undo-mgr)))
     683      (let ((replaced-string (#/substringWithRange: (#/hemlockString self) (ns:make-ns-range pos len))))
     684        (#/replaceCharactersAtPosition:length:withString:
     685         (#/prepareWithInvocationTarget: undo-mgr self)
     686         pos (#/length string) replaced-string)))
     687    (ns:with-ns-range (r pos len)
     688      (#/replaceCharactersInRange:withString: self r string))))
     689
    595690(objc:defmethod (#/replaceCharactersInRange:withString: :void)
    596691    ((self hemlock-text-storage) (r :<NSR>ange) string)
    597   #+debug 0 (#_NSLog #@"Replace in range %ld/%ld with %@"
     692  #+debug (#_NSLog #@"Replace in range %ld/%ld with %@"
    598693                    :<NSI>nteger (pref r :<NSR>ange.location)
    599694                    :<NSI>nteger (pref r :<NSR>ange.length)
     
    601696  (let* ((cache (hemlock-buffer-string-cache (#/hemlockString  self)))
    602697         (buffer (if cache (buffer-cache-buffer cache)))
    603          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     698         (hi::*current-buffer* buffer)
    604699         (location (pref r :<NSR>ange.location))
    605700         (length (pref r :<NSR>ange.length))
     
    608703           (document (if buffer (hi::buffer-document buffer)))
    609704           (textstorage (if document (slot-value document 'textstorage))))
    610       (when textstorage (#/beginEditing textstorage))
     705      #+gz (unless (eql textstorage self) (break "why is self.ne.textstorage?"))
     706      (when textstorage
     707        (assume-cocoa-thread)
     708        (#/beginEditing textstorage))
    611709      (setf (hi::buffer-region-active buffer) nil)
    612710      (hi::with-mark ((start point :right-inserting))
     
    622720         (lambda (tv)
    623721           (hi::disable-self-insert
    624             (hemlock-frame-event-queue (#/window tv)))))
     722            (hemlock-frame-event-queue (#/window tv)))))
    625723        (#/ensureSelectionVisible textstorage)))))
    626724
     
    654752;;; This needs to happen on the main thread.
    655753(objc:defmethod (#/ensureSelectionVisible :void) ((self hemlock-text-storage))
     754  (assume-cocoa-thread)
    656755  (for-each-textview-using-storage
    657756   self
    658757   #'(lambda (tv)
     758       (assume-not-editing tv)
    659759       (#/scrollRangeToVisible: tv (#/selectedRange tv)))))
    660760
     
    713813     (peer :foreign-type :id))
    714814  (:metaclass ns:+ns-object))
     815
     816
     817(defmethod assume-not-editing ((tv hemlock-textstorage-text-view))
     818  (assume-not-editing (#/textStorage tv)))
    715819
    716820(objc:defmethod (#/changeColor: :void) ((self hemlock-textstorage-text-view)
     
    796900         (buffer (buffer-cache-buffer d)))
    797901    (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
    798       (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     902      (let* ((hi::*current-buffer* buffer)
    799903             (point (hi::buffer-point buffer)))
    800904        #+debug (#_NSLog #@"Syntax check for blinking")
     
    829933                 (length :int)
    830934                 (affinity :<NSS>election<A>ffinity))
     935  (assume-cocoa-thread)
    831936  (when (eql length 0)
    832937    (update-blink self))
     
    839944                                affinity
    840945                                nil)
     946        (assume-not-editing self)
    841947        (#/scrollRangeToVisible: self range)
    842948        (when (> length 0)
     
    866972  (:metaclass ns:+ns-object))
    867973
    868 
    869 
    870 
    871 
     974(objc:defmethod (#/evalSelection: :void) ((self hemlock-text-view) sender)
     975  (declare (ignore sender))
     976  (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
     977         (doc (#/documentForWindow: dc (#/window self)))
     978         (buffer (hemlock-document-buffer doc))
     979         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
     980         (pathname (hi::buffer-pathname buffer))
     981         (ranges (#/selectedRanges self))
     982         (text (#/string self)))
     983    (dotimes (i (#/count ranges))
     984      (let* ((r (#/rangeValue (#/objectAtIndex: ranges i)))
     985             (s (#/substringWithRange: text r)))
     986        (setq s (lisp-string-from-nsstring s))
     987        (ui-object-eval-selection *NSApp* (list package-name pathname s))))))
     988
     989(objc:defmethod (#/loadBuffer: :void) ((self hemlock-text-view) sender)
     990  (declare (ignore sender))
     991  (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
     992         (doc (#/documentForWindow: dc (#/window self)))
     993         (buffer (hemlock-document-buffer doc))
     994         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
     995         (pathname (hi::buffer-pathname buffer)))
     996    (ui-object-load-buffer *NSApp* (list package-name pathname))))
     997
     998(objc:defmethod (#/compileBuffer: :void) ((self hemlock-text-view) sender)
     999  (declare (ignore sender))
     1000  (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
     1001         (doc (#/documentForWindow: dc (#/window self)))
     1002         (buffer (hemlock-document-buffer doc))
     1003         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
     1004         (pathname (hi::buffer-pathname buffer)))
     1005    (ui-object-compile-buffer *NSApp* (list package-name pathname))))
     1006
     1007(objc:defmethod (#/compileAndLoadBuffer: :void) ((self hemlock-text-view) sender)
     1008  (declare (ignore sender))
     1009  (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
     1010         (doc (#/documentForWindow: dc (#/window self)))
     1011         (buffer (hemlock-document-buffer doc))
     1012         (package-name (hi::variable-value 'hemlock::current-package :buffer buffer))
     1013         (pathname (hi::buffer-pathname buffer)))
     1014    (ui-object-compile-and-load-buffer *NSApp* (list package-name pathname))))
    8721015
    8731016(defloadvar *text-view-context-menu* ())
     
    9701113
    9711114;;; Access the underlying buffer in one swell foop.
    972 (defmethod text-view-buffer ((self hemlock-text-view))
     1115(defmethod text-view-buffer ((self hemlock-textstorage-text-view))
    9731116  (buffer-cache-buffer (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))))
    9741117
     
    9921135                  (buffer (if cache (buffer-cache-buffer cache))))
    9931136             (when (and buffer (string= (hi::buffer-major-mode buffer) "Lisp"))
    994                (let* ((hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
     1137               (let* ((hi::*current-buffer* buffer))
    9951138                 (hi::with-mark ((m1 (hi::buffer-point buffer)))
    9961139                   (move-hemlock-mark-to-absolute-position m1 cache index)
     
    10611204      (hi::event-queue-insert q op))))
    10621205
    1063  
     1206
     1207
    10641208;;; Process a key-down NSEvent in a Hemlock text view by translating it
    10651209;;; into a Hemlock key event and passing it into the Hemlock command
     
    10821226
    10831227(objc:defmethod (#/mouseDown: :void) ((self hemlock-text-view) event)
    1084   (let* ((q (hemlock-frame-event-queue (#/window self))))
    1085     (hi::enqueue-key-event q #k"leftdown"))
     1228  ;; If no modifier keys are pressed, send hemlock a no-op.
     1229  (unless (logtest #$NSDeviceIndependentModifierFlagsMask (#/modifierFlags event))
     1230    (let* ((q (hemlock-frame-event-queue (#/window self))))
     1231      (hi::enqueue-key-event q #k"leftdown")))
    10861232  (call-next-method event))
    10871233
     
    11081254    (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
    11091255           (buffer (buffer-cache-buffer d))
    1110            (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     1256           (hi::*current-buffer* buffer)
    11111257           (point (hi::buffer-point buffer))
    11121258           (location (pref r :<NSR>ange.location))
     
    11741320;;; the current values of the buffer's modeline fields.
    11751321
     1322(defparameter *modeline-grays* #(255 255 253 247 242 236 231
     1323                                 224 229 234 239 245 252 255))
     1324
     1325(defparameter *modeline-height* 14)
     1326(defloadvar *modeline-pattern-image* nil)
     1327
     1328(defun create-modeline-pattern-image ()
     1329  (let* ((n (length *modeline-grays*)))
     1330    (multiple-value-bind (samples-array samples-macptr)
     1331        (make-heap-ivector n '(unsigned-byte 8))
     1332      (dotimes (i n)
     1333        (setf (aref samples-array i) (aref *modeline-grays* i)))
     1334      (rlet ((p :address samples-macptr))
     1335        (let* ((rep (make-instance 'ns:ns-bitmap-image-rep
     1336                                   :with-bitmap-data-planes p
     1337                                   :pixels-wide 1
     1338                                   :pixels-high n
     1339                                   :bits-per-sample 8
     1340                                   :samples-per-pixel 1
     1341                                   :has-alpha #$NO
     1342                                   :is-planar #$NO
     1343                                   :color-space-name #&NSDeviceWhiteColorSpace
     1344                                   :bytes-per-row 1
     1345                                   :bits-per-pixel 8))
     1346               (image (make-instance 'ns:ns-image
     1347                                     :with-size (ns:make-ns-size 1 n))))
     1348          (#/addRepresentation: image rep)
     1349          (#/release rep)
     1350          (setf *modeline-pattern-image* image))))))
     1351
    11761352(defclass modeline-view (ns:ns-view)
    1177     ((pane :foreign-type :id :accessor modeline-view-pane))
     1353    ((pane :foreign-type :id :accessor modeline-view-pane)
     1354     (text-attributes :foreign-type :id :accessor modeline-text-attributes))
    11781355  (:metaclass ns:+ns-object))
    11791356
    1180 
    1181 ;;; Attributes to use when drawing the modeline fields.  There's no
    1182 ;;; simple way to make the "placard" taller, so using fonts larger than
    1183 ;;; about 12pt probably wouldn't look too good.  10pt Courier's a little
    1184 ;;; small, but allows us to see more of the modeline fields (like the
    1185 ;;; full pathname) in more cases.
    1186 
    1187 (defloadvar *modeline-text-attributes* nil)
    1188 
    1189 (def-cocoa-default *modeline-font-name* :string "Courier New Bold Italic"
    1190                    "Name of font to use in modelines")
    1191 (def-cocoa-default  *modeline-font-size* :float 10.0 "Size of font to use in modelines")
    1192 
     1357(objc:defmethod #/initWithFrame: ((self modeline-view) (frame :<NSR>ect))
     1358  (call-next-method frame)
     1359  (unless *modeline-pattern-image*
     1360    (create-modeline-pattern-image))
     1361  (let* ((size (#/smallSystemFontSize ns:ns-font))
     1362         (font (#/systemFontOfSize: ns:ns-font size))
     1363         (dict (#/dictionaryWithObject:forKey: ns:ns-dictionary font #&NSFontAttributeName)))
     1364    (setf (modeline-text-attributes self) (#/retain dict)))
     1365  self)
    11931366
    11941367;;; Find the underlying buffer.
     
    12051378;;; used in the event dispatch mechanism,
    12061379(defun draw-modeline-string (the-modeline-view)
    1207   (let* ((pane (modeline-view-pane the-modeline-view))
    1208          (buffer (buffer-for-modeline-view the-modeline-view)))
    1209     (when buffer
    1210       ;; You don't want to know why this is done this way.
    1211       (unless *modeline-text-attributes*
    1212         (setq *modeline-text-attributes*
    1213               (create-text-attributes :color (#/blackColor ns:ns-color)
    1214                                       :font (default-font
    1215                                                 :name *modeline-font-name*
    1216                                               :size *modeline-font-size*))))
    1217       (let* ((string
    1218               (apply #'concatenate 'string
    1219                      (mapcar
    1220                       #'(lambda (field)
    1221                           (funcall (hi::modeline-field-function field)
    1222                                    buffer pane))
    1223                       (hi::buffer-modeline-fields buffer)))))
    1224         (#/drawAtPoint:withAttributes: (%make-nsstring string)
    1225                                        (ns:make-ns-point 0 0)
    1226                                        *modeline-text-attributes*)))))
     1380  (with-slots (pane text-attributes) the-modeline-view
     1381    (let* ((buffer (buffer-for-modeline-view the-modeline-view)))
     1382      (when buffer
     1383        (let* ((string
     1384                (apply #'concatenate 'string
     1385                       (mapcar
     1386                        #'(lambda (field)
     1387                            (funcall (hi::modeline-field-function field)
     1388                                     buffer pane))
     1389                        (hi::buffer-modeline-fields buffer)))))
     1390          (#/drawAtPoint:withAttributes: (%make-nsstring string)
     1391                                         (ns:make-ns-point 5 1)
     1392                                         text-attributes))))))
    12271393
    12281394;;; Draw the underlying buffer's modeline string on a white background
     
    12301396(objc:defmethod (#/drawRect: :void) ((self modeline-view) (rect :<NSR>ect))
    12311397  (declare (ignorable rect))
    1232   (let* ((frame (#/bounds self)))
    1233      (#_NSDrawWhiteBezel frame frame)
    1234      (draw-modeline-string self)))
     1398  (let* ((bounds (#/bounds self))
     1399         (context (#/currentContext ns:ns-graphics-context)))
     1400    (#/saveGraphicsState context)
     1401    (ns:with-ns-point (p0 0 (ns:ns-rect-height bounds))
     1402      (let ((p1 (#/convertPoint:toView: self p0 +null-ptr+)))
     1403        (#/setPatternPhase: context p1)))
     1404    (#/set (#/colorWithPatternImage: ns:ns-color *modeline-pattern-image*))
     1405    (#_NSRectFill bounds)
     1406    (#/set (#/colorWithCalibratedWhite:alpha: ns:ns-color 0.3333 1.0))
     1407    (ns:with-ns-rect (r 0 0.5 (ns:ns-rect-width bounds) 0.5)
     1408      (#_NSRectFill r))
     1409    (ns:with-ns-rect (r 0 (- (ns:ns-rect-height bounds) 0.5)
     1410                        (ns:ns-rect-width bounds) (- (ns:ns-rect-height bounds) 0.5))
     1411      (#_NSRectFill r))
     1412    (#/set (#/blackColor ns:ns-color))
     1413    (draw-modeline-string self)
     1414    (#/restoreGraphicsState context)))
    12351415
    12361416;;; Hook things up so that the modeline is updated whenever certain buffer
     
    13451525                       'modeline-scroll-view
    13461526                       :with-frame (ns:make-ns-rect x y width height)))))
    1347     (#/setBorderType: scrollview #$NSBezelBorder)
     1527    (#/setBorderType: scrollview #$NSNoBorder)
    13481528    (#/setHasVerticalScroller: scrollview t)
    13491529    (#/setHasHorizontalScroller: scrollview t)
     
    13751555                (#/setMaxSize: tv (ns:make-ns-size large-number-for-text large-number-for-text))
    13761556                (#/setRichText: tv nil)
    1377                 (#/setHorizontallyResizable: tv t)
    1378                 (#/setVerticallyResizable: tv t)
    13791557                (#/setAutoresizingMask: tv #$NSViewWidthSizable)
    13801558                (#/setBackgroundColor: tv color)
     
    13851563                (#/setUsesFontPanel: tv nil)
    13861564                (#/setMenu: tv (text-view-context-menu))
    1387                 (#/setWidthTracksTextView: container tracks-width)
    1388                 (#/setHeightTracksTextView: container nil)
     1565
     1566                ;;  The container tracking and the text view sizability along a
     1567                ;;  particular axis must always be different, or else things can
     1568                ;;  get really confused (possibly causing an infinite loop).
     1569
     1570                (if (or tracks-width *wrap-lines-to-window*)
     1571                  (progn
     1572                    (#/setWidthTracksTextView: container t)
     1573                    (#/setHeightTracksTextView: container nil)
     1574                    (#/setHorizontallyResizable: tv nil)
     1575                    (#/setVerticallyResizable: tv t))
     1576                  (progn
     1577                    (#/setWidthTracksTextView: container nil)
     1578                    (#/setHeightTracksTextView: container nil)
     1579                    (#/setHorizontallyResizable: tv t)
     1580                    (#/setVerticallyResizable: tv t)))
     1581
    13891582                (#/setDocumentView: scrollview tv)           
    13901583                (values tv scrollview)))))))))
     
    14401633
    14411634(objc:defmethod (#/activateHemlockView :void) ((self echo-area-view))
     1635  (assume-cocoa-thread)
    14421636  (let* ((the-hemlock-frame (#/window self)))
    14431637    #+debug
     
    14561650
    14571651(defmethod deactivate-hemlock-view ((self echo-area-view))
     1652  (assume-cocoa-thread)
    14581653  #+debug (#_NSLog #@"deactivating echo area")
    14591654  (let* ((ts (#/textStorage self)))
     
    14681663
    14691664
    1470 (defmethod text-view-buffer ((self echo-area-view))
    1471   (buffer-cache-buffer (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self)))))
    1472 
    14731665;;; The "document" for an echo-area isn't a real NSDocument.
    14741666(defclass echo-area-document (ns:ns-object)
    14751667    ((textstorage :foreign-type :id))
    14761668  (:metaclass ns:+ns-object))
     1669
     1670(objc:defmethod (#/undoManager :<BOOL>) ((self echo-area-document))
     1671  nil) ;For now, undo is not supported for echo-areas
    14771672
    14781673(defmethod update-buffer-package ((doc echo-area-document) buffer)
     
    14991694(defloadvar *hemlock-frame-count* 0)
    15001695
    1501 (defun make-echo-area (the-hemlock-frame x y width height gap-context color)
     1696(defun make-echo-area (the-hemlock-frame x y width height main-buffer color)
    15021697  (let* ((box (make-instance 'ns:ns-view :with-frame (ns:make-ns-rect x y width height))))
    15031698    (#/setAutoresizingMask: box #$NSViewWidthSizable)
     
    15191714             (textstorage
    15201715              (progn
    1521                 (setf (hi::buffer-gap-context buffer) gap-context)
     1716                ;; What's the reason for sharing this?  Is it just the lock?
     1717                (setf (hi::buffer-gap-context buffer) (hi::buffer-gap-context main-buffer))
    15221718                (make-textstorage-for-hemlock-buffer buffer)))
    15231719             (doc (make-instance 'echo-area-document))
     
    15521748          (values echo box))))))
    15531749                   
    1554 (defun make-echo-area-for-window (w gap-context-for-echo-area-buffer color)
     1750(defun make-echo-area-for-window (w main-buffer color)
    15551751  (let* ((content-view (#/contentView w))
    15561752         (bounds (#/bounds content-view)))
     
    15611757                                         (- (ns:ns-rect-width bounds) 16.0f0)
    15621758                                         20.0f0
    1563                                          gap-context-for-echo-area-buffer
     1759                                         main-buffer
    15641760                                         color)
    15651761      (#/addSubview: content-view box)
     
    16361832
    16371833(defun hi::report-hemlock-error (condition)
    1638   (report-condition-in-hemlock-frame condition (#/window (hi::current-window))))
     1834  (let ((pane (hi::current-window)))
     1835    (when (and pane (not (%null-ptr-p pane)))
     1836      (report-condition-in-hemlock-frame condition (#/window pane)))))
    16391837                       
    1640                        
     1838
    16411839(defun hemlock-thread-function (q buffer pane echo-buffer echo-window)
    16421840  (let* ((hi::*real-editor-input* q)
     
    16611859         (hi::*last-key-event-typed* nil)
    16621860         (hi::*input-transcript* nil)
    1663          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
    16641861         (hemlock::*target-column* 0)
    16651862         (hemlock::*last-comment-start* " ")
     
    16671864         (hi::*current-command* (make-array 10 :fill-pointer 0 :adjustable t))
    16681865         (hi::*current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
    1669          #+no
    1670          (hemlock::*last-search-string* ())
    1671          #+no
    1672          (hemlock::*last-search-pattern*
    1673             (hemlock::new-search-pattern :string-insensitive :forward ""))
    16741866         (hi::*prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
    16751867         (hi::*command-key-event-buffer* buffer))
     
    17561948(defun nsstring-to-buffer (nsstring buffer)
    17571949  (let* ((document (hi::buffer-document buffer))
    1758          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     1950         (hi::*current-buffer* buffer)
    17591951         (region (hi::buffer-region buffer)))
    17601952    (setf (hi::buffer-document buffer) nil)
     
    17811973;;; This function must run in the main event thread.
    17821974(defun %hemlock-frame-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
     1975  (assume-cocoa-thread)
    17831976  (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style))
    17841977         (frame (#/window pane))
    17851978         (buffer (text-view-buffer (text-pane-text-view pane)))
    1786          (echo-area (make-echo-area-for-window frame (hi::buffer-gap-context buffer) color))
     1979         (echo-area (make-echo-area-for-window frame buffer color))
    17871980         (tv (text-pane-text-view pane)))
    17881981    (with-slots (peer) tv
     
    17911984      (setq peer tv))
    17921985    (hi::activate-hemlock-view pane)
    1793     (setf (slot-value frame 'echo-area-view)
    1794           echo-area
    1795           (slot-value frame 'pane)
    1796           pane
    1797           (slot-value frame 'command-thread)
     1986    (setf (slot-value frame 'echo-area-view) echo-area
     1987          (slot-value frame 'pane) pane)
     1988    (setf (slot-value frame 'command-thread)
    17981989          (process-run-function (format nil "Hemlock window thread for ~s"
    17991990                                        (hi::buffer-name buffer))
     
    18182009
    18192010(defun hi::lock-buffer (b)
    1820   (grab-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b))))
     2011  (grab-lock (hi::buffer-lock b)))
    18212012
    18222013(defun hi::unlock-buffer (b)
    1823   (release-lock (hi::buffer-gap-context-lock (hi::buffer-gap-context b))))
    1824  
     2014  (release-lock (hi::buffer-lock b)))
     2015
    18252016(defun hi::document-begin-editing (document)
    18262017  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     
    18312022
    18322023(defun document-edit-level (document)
     2024  (assume-cocoa-thread) ;; see comment in #/editingInProgress
    18332025  (slot-value (slot-value document 'textstorage) 'edit-count))
    18342026
     
    18982090    (#/objectAtIndex: styles style)))
    18992091     
     2092;; Note that inserted a string of length n at mark.  Assumes this is called after
     2093;; buffer marks were updated.
    19002094(defun hi::buffer-note-insertion (buffer mark n)
    19012095  (when (hi::bufferp buffer)
     
    19042098      (when textstorage
    19052099        (let* ((pos (mark-absolute-position mark)))
    1906           (unless (eq (hi::mark-%kind mark) :right-inserting)
     2100          (when (eq (hi::mark-%kind mark) :left-inserting)
     2101            ;; Make up for the fact that the mark moved forward with the insertion.
     2102            ;; For :right-inserting and :temporary marks, they should be left back.
    19072103            (decf pos n))
    19082104          (perform-edit-change-notification textstorage
     
    20252221  (#/updateChangeCount: self #$NSChangeCleared))
    20262222
     2223(defmethod assume-not-editing ((doc hemlock-editor-document))
     2224  (assume-not-editing (slot-value doc 'textstorage)))
    20272225
    20282226(defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
     
    20492247    (cond ((eql action (@selector #/hyperSpecLookUp:))
    20502248           ;; For now, demand a selection.
    2051            (and *hyperspec-root-url*
     2249           (and *hyperspec-lookup-enabled*
     2250                (hyperspec-root-url)
    20522251                (not (eql 0 (ns:ns-range-length (#/selectedRange self))))))
    20532252          ((eql action (@selector #/cut:))
     
    20552254             (and (> (ns:ns-range-length selection))
    20562255                  (#/shouldChangeTextInRange:replacementString: self selection #@""))))
    2057           (t (call-next-method item)))))
     2256          ((eql action (@selector #/evalSelection:))
     2257           (not (eql 0 (ns:ns-range-length (#/selectedRange self)))))
     2258          ;; if this hemlock-text-view is in an editor windowm and its buffer has
     2259          ;; an associated pathname, then activate the Load Buffer item
     2260          ((or (eql action (@selector #/loadBuffer:))
     2261               (eql action (@selector #/compileBuffer:))
     2262               (eql action (@selector #/compileAndLoadBuffer:)))
     2263           (let* ((d (hemlock-buffer-string-cache (#/hemlockString (#/textStorage self))))
     2264                  (buffer (buffer-cache-buffer d))
     2265                  (pathname (hi::buffer-pathname buffer)))
     2266             (not (null pathname))))
     2267          (t (call-next-method item)))))
    20582268
    20592269(defmethod user-input-style ((doc hemlock-editor-document))
     
    20882298    ((self hemlock-editor-document) filename filetype)
    20892299  (declare (ignore filetype))
     2300  (assume-cocoa-thread)
    20902301  #+debug
    20912302  (#_NSLog #@"revert to saved from file %@ of type %@"
     
    20982309         (buffer (hemlock-document-buffer self))
    20992310         (old-length (hemlock-buffer-length buffer))
    2100          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     2311         (hi::*current-buffer* buffer)
    21012312         (textstorage (slot-value self 'textstorage))
    21022313         (point (hi::buffer-point buffer))
     
    21532364                            (make-textstorage-for-hemlock-buffer b))
    21542365                      b)))
    2155            (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
    21562366           (selected-encoding (slot-value (#/sharedDocumentController (find-class 'hemlock-document-controller)) 'last-encoding))
    21572367           (string
     
    21632373               perror)
    21642374              +null-ptr+)))
     2375
    21652376      (if (%null-ptr-p string)
    21662377        (progn
     
    21772388        (hi::queue-buffer-change buffer)
    21782389        (hi::document-begin-editing self)
    2179         (nsstring-to-buffer string buffer)
     2390        (nsstring-to-buffer string buffer)
     2391
    21802392        (let* ((textstorage (slot-value self 'textstorage))
    21812393               (display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
     2394
    21822395          (reset-buffer-cache display)
     2396
    21832397          (#/updateMirror textstorage)
     2398
    21842399          (update-line-cache-for-index display 0)
     2400
    21852401          (textstorage-note-insertion-at-position
    21862402           textstorage
    21872403           0
    21882404           (hemlock-buffer-length buffer)))
     2405
    21892406        (hi::document-end-editing self)
     2407
    21902408        (setf (hi::buffer-modified buffer) nil)
    21912409        (hi::process-file-options buffer pathname)
     
    22352453        (when cache (buffer-cache-buffer cache))))))
    22362454
     2455(defmethod hi:window-buffer ((frame hemlock-frame))
     2456  (let* ((dc (#/sharedDocumentController ns:ns-document-controller))
     2457         (doc (#/documentForWindow: dc frame)))
     2458    ;; Sometimes doc is null.  Why?  What would cause a hemlock frame to
     2459    ;; not have a document?  (When it happened, there seemed to be a hemlock
     2460    ;; frame in (windows) that didn't correspond to any visible window).
     2461    (unless (%null-ptr-p doc)
     2462      (hemlock-document-buffer doc))))
     2463
     2464(defmethod hi:window-buffer ((pane text-pane))
     2465  (hi:window-buffer (#/window pane)))
     2466
     2467(defun ordered-hemlock-windows ()
     2468  (delete-if-not #'(lambda (win)
     2469                     (and (typep win 'hemlock-frame)
     2470                          (hi:window-buffer win)))
     2471                   (windows)))
     2472
    22372473(defmethod hi::document-panes ((document hemlock-editor-document))
    22382474  (let* ((ts (slot-value document 'textstorage))
     
    22562492                                               panel)
    22572493  (with-slots (encoding) self
    2258     (let* ((popup (build-encodings-popup (#/sharedDocumentController ns:ns-document-controller) encoding)))
     2494    (let* ((popup (build-encodings-popup (#/sharedDocumentController hemlock-document-controller) encoding)))
    22592495      (#/setAction: popup (@selector #/noteEncodingChange:))
    22602496      (#/setTarget: popup self)
     
    22622498  (#/setExtensionHidden: panel nil)
    22632499  (#/setCanSelectHiddenExtension: panel nil)
     2500  (#/setAllowedFileTypes: panel +null-ptr+)
    22642501  (call-next-method panel))
    22652502
     
    24542691  (:metaclass ns:+ns-object))
    24552692
    2456 (defloadvar *hemlock-document-controller* nil "Shared document controller")
    2457 
    2458 (objc:defmethod #/sharedDocumentController ((self +hemlock-document-controller))
    2459   (or *hemlock-document-controller*
    2460       (setq *hemlock-document-controller* (#/init (#/alloc self)))))
    2461 
    24622693(objc:defmethod #/init ((self hemlock-document-controller))
    2463   (if *hemlock-document-controller*
    2464     (progn
    2465       (#/release self)
    2466       *hemlock-document-controller*)
    2467     (prog1
    2468       (setq *hemlock-document-controller* (call-next-method))
    2469       (setf (slot-value *hemlock-document-controller* 'last-encoding) 0))))
     2694  (prog1
     2695      (call-next-method)
     2696    (setf (slot-value self 'last-encoding) 0)))
    24702697
    24712698(defun iana-charset-name-of-nsstringencoding (ns)
     
    25462773   self (@selector #/saveDocumentAs:) +null-ptr+ t))
    25472774
     2775(defmethod hi::save-hemlock-document-to ((self hemlock-editor-document))
     2776  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2777   self (@selector #/saveDocumentTo:) +null-ptr+ t))
     2778
    25482779(defun initialize-user-interface ()
    2549   (#/sharedDocumentController hemlock-document-controller)
    2550   (#/sharedPanel lisp-preferences-panel)
     2780  ;; The first created instance of an NSDocumentController (or
     2781  ;; subclass thereof) becomes the shared document controller.  So it
     2782  ;; may look like we're dropping this instance on the floor, but
     2783  ;; we're really not.
     2784  (make-instance 'hemlock-document-controller)
     2785  ;(#/sharedPanel lisp-preferences-panel)
    25512786  (make-editor-style-map))
    25522787
    25532788;;; This needs to run on the main thread.
    25542789(objc:defmethod (#/updateHemlockSelection :void) ((self hemlock-text-storage))
     2790  (assume-cocoa-thread)
    25552791  (let* ((string (#/hemlockString self))
    25562792         (buffer (buffer-cache-buffer (hemlock-buffer-string-cache string)))
    2557          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     2793         (hi::*current-buffer* buffer)
    25582794         (point (hi::buffer-point buffer))
    25592795         (pointpos (mark-absolute-position point))
     
    26482884(defun hi::edit-definition (name)
    26492885  (let* ((info (get-source-files-with-types&classes name)))
     2886    (when (null info)
     2887      (let* ((seen (list name))
     2888             (found ())
     2889             (pname (symbol-name name)))
     2890        (dolist (pkg (list-all-packages))
     2891          (let ((sym (find-symbol pname pkg)))
     2892            (when (and sym (not (member sym seen)))
     2893              (let ((new (get-source-files-with-types&classes sym)))
     2894                (when new
     2895                  (setq info (append new info))
     2896                  (push sym found)))
     2897              (push sym seen))))
     2898        (when found
     2899          ;; Unfortunately, this puts the message in the wrong buffer (would be better in the destination buffer).
     2900          (hi::loud-message "No definitions for ~s, using ~s instead"
     2901                            name (if (cdr found) found (car found))))))
    26502902    (if info
    26512903      (if (cdr info)
    26522904        (edit-definition-list name info)
    2653         (edit-single-definition name (car info))))))
     2905        (edit-single-definition name (car info)))
     2906      (hi::editor-error "No known definitions for ~s" name))))
    26542907
    26552908
    26562909(defun find-definition-in-document (name indicator document)
    26572910  (let* ((buffer (hemlock-document-buffer document))
    2658          (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
     2911         (hi::*current-buffer* buffer))
    26592912    (hemlock::find-definition-in-buffer buffer name indicator)))
    26602913
     
    27292982                 title
    27302983                 string)
     2984  (assume-cocoa-thread)
    27312985  (let* ((doc (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+)))
    27322986    (unless (%null-ptr-p doc)
     
    27442998           string)
    27452999          (#/endEditing ts))
    2746         (#/makeKeyAndOrderFront:
    2747          window
    2748          self)))))
     3000        (#/makeKeyAndOrderFront: window self)))
     3001    doc))
    27493002
    27503003(defun hi::revert-document (doc)
     
    27583011;;; Enable CL:ED
    27593012(defun cocoa-edit (&optional arg)
    2760   (let* ((document-controller (#/sharedDocumentController ns:ns-document-controller)))
     3013  (let* ((document-controller (#/sharedDocumentController hemlock-document-controller)))
    27613014    (cond ((null arg)
    27623015           (#/performSelectorOnMainThread:withObject:waitUntilDone:
  • branches/ia32/cocoa-ide/cocoa-grep.lisp

    r7362 r7666  
    3434        (#/makeWindowControllers document))
    3535      (let* ((buffer (hemlock-document-buffer document))
    36              (hi::*current-buffer* buffer)
    37              (hi::*buffer-gap-context* (hi::buffer-gap-context buffer)))
     36             (hi::*current-buffer* buffer))
    3837        (edit-grep-line-in-buffer line-num))
    3938      (#/updateHemlockSelection (slot-value document 'textstorage))
     
    7069(defun grep-comment-line-p (line)
    7170  (multiple-value-bind (file line-num) (parse-grep-line line)
     71    #+gz (when (member "archive" (pathname-directory file) :test #'equalp)
     72           (return-from grep-comment-line-p t))
    7273    (with-open-file (stream file)
    7374      (loop while (> line-num 0)
     
    9495    while (< pos end)))
    9596
     97(defvar *grep-ignore-case* t)
     98(defvar *grep-include-pattern* "*.lisp")
     99(defvar *grep-exclude-pattern* "*~.lisp")
    96100
    97 (defun grep (pattern directory &key ignore-case (include "*.lisp") (exclude "*~.lisp"))
     101(defun grep (pattern directory &key (ignore-case *grep-ignore-case*)
     102                                    (include *grep-include-pattern*)
     103                                    (exclude *grep-exclude-pattern*))
    98104  (with-output-to-string (stream)
    99105    (let* ((proc (run-program *grep-program*
  • branches/ia32/cocoa-ide/cocoa-listener.lisp

    r7362 r7666  
    66  (require "COCOA-EDITOR")
    77  (require "PTY"))
     8
     9(def-cocoa-default *listener-input-font* :font #'(lambda ()
     10                                                   (#/fontWithName:size:
     11                                                    ns:ns-font
     12                                                    #@"Monaco" 10.0))
     13                   "Default font for listener input")
     14(def-cocoa-default *listener-output-font* :font #'(lambda ()
     15                                                    (#/fontWithName:size:
     16                                                     ns:ns-font
     17                                                     #@"Monaco" 10.0))
     18                   "Default font for listener output")
    819
    920(def-cocoa-default *listener-rows* :int 16 "Initial height of listener windows, in characters")
     
    313324                  (textview-background-color self)
    314325                  (user-input-style self)))
     326         (listener-styles (#/arrayWithObjects: ns:ns-mutable-array
     327                                               (rme-create-text-attributes
     328                                                :font *listener-input-font*)
     329                                               (rme-create-text-attributes
     330                                                :font *listener-output-font*)
     331                                               +null-ptr+))
    315332         (controller (make-instance
    316333                      'hemlock-listener-window-controller
    317334                      :with-window window))
    318335         (listener-name (hi::buffer-name (hemlock-document-buffer self))))
     336    (with-slots (styles) textstorage
     337      ;; We probably should be more disciplined about
     338      ;; Cocoa memory management.  Having retain/release in
     339      ;; random places all over the code is going to get
     340      ;; unwieldy.
     341      (#/release styles)
     342      (setf styles (#/retain listener-styles)))
    319343    ;; Disabling background layout on listeners is an attempt to work
    320344    ;; around a bug.  The bug's probably gone ...
     
    448472      (let* ((action (#/action item)))
    449473        (cond
    450           ((eql action (@selector #/revertDocumentToSaved:))
     474          ((or (eql action (@selector #/revertDocumentToSaved:))
     475               (eql action (@selector #/saveDocument:))
     476               (eql action (@selector #/saveDocumentAs:)))
    451477           (values t nil))
    452           ((eql action (@selector #/makeKeyAndOrderFront:))
    453            (let* ((target (#/target item))
    454                   (window (cocoa-listener-process-window process)))
    455              (if (eql target window)
    456                (progn
    457                  (#/setKeyEquivalent: item #@"L")
    458                  (#/setKeyEquivalentModifierMask: item #$NSCommandKeyMask))
    459                (#/setKeyEquivalent: item #@""))
    460              (values t t)))
    461478          ((eql action (@selector #/interrupt:)) (values t t))
    462479          ((eql action (@selector #/continue:))
     
    532549(defun hemlock::evaluate-input-selection (selection)
    533550  (application-ui-operation *application* :eval-selection selection))
    534                            
     551 
    535552(defmethod ui-object-choose-listener-for-selection ((app ns:ns-application)
    536553                                                    selection)
    537554  (declare (ignore selection))
     555  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     556   (#/delegate *NSApp*) (@selector #/ensureListener:) +null-ptr+ #$YES)
    538557  (let* ((top-listener-document (#/topListener hemlock-listener-document)))
    539558    (if top-listener-document
     
    549568                           app selection)))
    550569    (if (typep target-listener 'cocoa-listener-process)
    551       (destructuring-bind (package path string) selection
     570        (destructuring-bind (package path string) selection
    552571        (hi::send-string-to-listener-process target-listener string :package package :path path)))))
    553572
    554 ;;; Give the windows menu item for the top listener a command-key
    555 ;;; equivalent of cmd-L.  Remove command-key equivalents from other windows.
    556 ;;; (There are probably other ways of doing this.)
    557 (objc:defmethod (#/validateMenuItem: :<BOOL>) ((self hemlock-listener-frame)
    558                                                item)
    559   (let* ((action (#/action item)))
    560     (when (eql action (@selector #/makeKeyAndOrderFront:))
    561       (let* ((target (#/target item)))
    562         (when (eql target self)
    563           (let* ((top-doc (#/topListener hemlock-listener-document))
    564                  (our-doc (#/document (#/windowController self))))
    565             (if (eql our-doc top-doc)
    566               (progn
    567                 (#/setKeyEquivalent: item #@"l")
    568                 (#/setKeyEquivalentModifierMask: item #$NSCommandKeyMask))
    569               (#/setKeyEquivalent: item #@"")))))))
    570   (call-next-method item))
    571 
    572 
    573 
     573(defmethod ui-object-load-buffer ((app ns:ns-application) selection)
     574  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
     575    (if (typep target-listener 'cocoa-listener-process)
     576        (destructuring-bind (package path) selection
     577          (let ((string (format nil "(load ~S)" path)))
     578            (hi::send-string-to-listener-process target-listener string :package package :path path))))))
     579
     580(defmethod ui-object-compile-buffer ((app ns:ns-application) selection)
     581  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
     582    (if (typep target-listener 'cocoa-listener-process)
     583        (destructuring-bind (package path) selection
     584          (let ((string (format nil "(compile-file ~S)" path)))
     585            (hi::send-string-to-listener-process target-listener string :package package :path path))))))
     586
     587(defmethod ui-object-compile-and-load-buffer ((app ns:ns-application) selection)
     588  (let* ((target-listener (ui-object-choose-listener-for-selection app nil)))
     589    (if (typep target-listener 'cocoa-listener-process)
     590        (destructuring-bind (package path) selection
     591          (let ((string (format nil "(progn (compile-file ~S)(load ~S))"
     592                                path
     593                                (make-pathname :directory (pathname-directory path)
     594                                               :name (pathname-name path)
     595                                               :type (pathname-type path)))))
     596            (hi::send-string-to-listener-process target-listener string :package package :path path))))))
    574597
    575598       
  • branches/ia32/cocoa-ide/cocoa-prefs.lisp

    r7244 r7666  
    8989    (when (is-fixed-pitch-font f)
    9090      (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
    91         (#/setValue:forKey: values (#/fontName f) #@"modelineFontName:")
     91        (#/setValue:forKey: values (#/fontName f) #@"modelineFontName")
    9292        (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"modelineFontSize")))))
    9393
     
    133133            +null-ptr+)
    134134           #$NSOKButton)
    135       (let* ((filename (#/pathWithComponents: ns:ns-string
    136                                               (#/arrayWithObjects:
    137                                                ns:ns-array
    138                                                (#/objectAtIndex: (#/filenames panel) 0)
    139                                                #@""
    140                                                +null-ptr+))))
     135      ;; #/stringByStandardizingPath seems to strip trailing slashes
     136      (let* ((filename (#/stringByAppendingString:
     137                        (#/stringByStandardizingPath (#/objectAtIndex: (#/filenames panel) 0))
     138                         #@"/")))
    141139        (#/setValue:forKey: values filename #@"cclDirectory")))))
    142140
     
    159157             (let* ((controller (make-instance lisp-preferences-window-controller
    160158                                             :with-window-nib-name #@"preferences"))
    161                   (window (#/window controller)))
     159                    (window (#/window controller)))
    162160               (unless (%null-ptr-p window)
    163161                 (#/setFloatingPanel: window t)
  • branches/ia32/cocoa-ide/cocoa-typeout.lisp

    r6866 r7666  
    2828  (#/delete: self +null-ptr+))
    2929
    30 (objc:defmethod (#/insertText: :void) ((self typeout-text-view) text)
     30(objc:defmethod (#/insertString: :void) ((self typeout-text-view) text)
    3131  (#/setEditable: self t)
    32   (call-next-method text)
     32  (#/insertText: self text)
    3333  (#/setEditable: self nil))
    3434
     
    175175    (#/performSelectorOnMainThread:withObject:waitUntilDone:
    176176     text-view
    177      (@selector #/insertText:)
     177     (@selector #/insertString:)
    178178     (%make-nsstring (get-output-stream-string (slot-value stream 'string-stream)))
    179179     t)))
  • branches/ia32/cocoa-ide/cocoa-utils.lisp

    r7340 r7666  
    1616
    1717(objc:defmethod #/init ((self sequence-window-controller))
     18  (call-next-method)
    1819  (let* ((w (new-cocoa-window :activate nil))
    1920         (contentview (#/contentView w))
     
    2122         (scrollview (make-instance 'ns:ns-scroll-view :with-frame contentframe)))
    2223    (#/setWindow: self w)
     24    (#/setDelegate: w self)
     25    (#/setWindowController: w self)
    2326    (#/setHasVerticalScroller: scrollview t)
    2427    (#/setHasHorizontalScroller: scrollview t)
     28    (#/setAutohidesScrollers: scrollview t)
    2529    (#/setRulersVisible: scrollview nil)
    2630    (#/setAutoresizingMask: scrollview (logior
     
    3034    (let* ((table-view (make-instance 'ns:ns-table-view)))
    3135      (#/setDocumentView: scrollview table-view)
     36      (#/release table-view)
     37      (#/setColumnAutoresizingStyle: table-view #$NSTableViewUniformColumnAutoresizingStyle)
    3238      (setf (slot-value self 'table-view) table-view)
    3339      (let* ((column (make-instance 'ns:ns-table-column :with-identifier #@"")))
    3440        (#/setEditable: column nil)
    35         (#/addTableColumn: table-view column))
     41        (#/setResizingMask: column #$NSTableColumnAutoresizingMask)
     42        (#/addTableColumn: table-view column)
     43        (#/release column))
    3644      (#/setAutoresizingMask: table-view (logior
    3745                                          #$NSViewWidthSizable
     
    4452      (#/setDoubleAction: table-view (@selector #/sequenceDoubleClick:))
    4553      (#/addSubview: contentview scrollview)
     54      (#/release scrollview)
    4655      self)))
     56
     57(objc:defmethod (#/dealloc :void) ((self sequence-window-controller))
     58  (call-next-method))
     59
     60(objc:defmethod (#/windowWillClose: :void) ((self sequence-window-controller)
     61                                            notification)
     62  (declare (ignore notification))
     63  (#/autorelease self))
    4764
    4865(objc:defmethod (#/sequenceDoubleClick: :void)
     
    6380  (declare (ignore column view))
    6481  (with-slots (display sequence) self
    65     (%make-nsstring (with-output-to-string (s)
    66                       (funcall display (elt sequence row) s)))))
     82    (#/autorelease
     83     (%make-nsstring (with-output-to-string (s)
     84                       (funcall display (elt sequence row) s))))))
    6785
    6886(defmethod initialize-instance :after ((self sequence-window-controller) &key &allow-other-keys)
     
    96114      (push (#/objectAtIndex: win-arr i) ret))
    97115    (nreverse ret)))
     116
     117(defun log-debug (format-string &rest args)
     118  (#_NSLog (ccl::%make-nsstring (apply #'format nil format-string args))))
     119
     120(defun assume-cocoa-thread ()
     121  #+debug (assert (eq *current-process* *initial-process*)))
     122
     123(defmethod assume-not-editing ((whatever t)))
     124
  • branches/ia32/cocoa-ide/cocoa-window.lisp

    r7244 r7666  
    151151    "LispApplicationDelegate")
    152152
     153
    153154#+apple-objc
    154155(defun enable-foreground ()
    155   (%stack-block ((psn 8))
    156     (external-call "_GetCurrentProcess" :address psn)
    157     (external-call "_CPSEnableForegroundOperation" :address psn)
    158     (eql 0 (external-call "_SetFrontProcess" :address psn :signed-halfword))))
     156  (rlet ((psn :<P>rocess<S>erial<N>umber))
     157    (#_GetCurrentProcess psn)
     158    (#_TransformProcessType psn #$kProcessTransformToForegroundApplication)
     159    (eql 0 (#_SetFrontProcess psn))))
    159160
    160161;;; I'm not sure if there's another way to recognize events whose
     
    168169    (call-next-method e)))
    169170
    170 
     171#+nil
    171172(objc:defmethod (#/showPreferences: :void) ((self lisp-application) sender)
    172173  (declare (ignore sender))
     
    264265          (let* ((fontname (#/stringWithCString: ns:ns-string name))
    265266                 (font (#/fontWithName:matrix: ns:ns-font fontname matrix))
    266                  
     267               
    267268                 (implemented-attributes ()))
    268269            (if (or (%null-ptr-p font)
     
    305306                                    (obliqueness nil)
    306307                                    (stroke-width nil))
    307   (let* ((dict (#/retain (make-instance 'ns:ns-mutable-dictionary :with-capacity 5))))
    308     (#/setObject:forKey: dict (create-paragraph-style font line-break-mode) #&NSParagraphStyleAttributeName)
     308  (let* ((dict (make-instance 'ns:ns-mutable-dictionary :with-capacity 5)))
     309    (#/setObject:forKey: dict (create-paragraph-style font line-break-mode)
     310                         #&NSParagraphStyleAttributeName)
    309311    (#/setObject:forKey: dict font #&NSFontAttributeName)
    310312    (when color
    311313      (#/setObject:forKey: dict color #&NSForegroundColorAttributeName))
    312314    (when stroke-width
    313       (#/setObject:forKey: dict (make-instance 'ns:ns-number
    314                                                :with-float (float stroke-width)) #&NSStrokeWidthAttributeName))
     315      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number stroke-width)
     316                          #&NSStrokeWidthAttributeName))
    315317    (when obliqueness
    316       (#/setObject:forKey:  dict (make-instance 'ns:ns-number
    317                                                 :with-float (float obliqueness)) #&NSObliquenessAttributeName))
     318      (#/setObject:forKey: dict (#/numberWithFloat: ns:ns-number obliqueness)
     319                          #&NSObliquenessAttributeName))
    318320    dict))
    319321
     
    388390            (get-cocoa-window-flag w :auto-display)
    389391            auto-display)
     392      (#/setBackgroundColor: w (#/whiteColor ns:ns-color))
    390393      (when activate (activate-window w))
    391394      (when title (set-window-title w title))
  • branches/ia32/cocoa-ide/cocoa.lisp

    r7244 r7666  
    22
    33;;; We need to be able to point the CoreFoundation and Cocoa libraries
    4 ;;; at some bundle very early in the process.  If you want to use some
    5 ;;; other bundle path, you may need to change the call to FAKE-CFBUNDLE-PATH
    6 ;;; below.
     4;;; at some bundle very early in the process, so do that before anything
     5;;; else.
     6;;;
     7;;; If you're using this file to load something other than the IDE,
     8;;; you might want to change create-ide-bundle...
     9
     10(defvar *cocoa-application-path* "ccl:temp bundle.app;")
     11(defvar *cocoa-application-copy-headers-p* nil)
     12
     13(defun create-ide-bundle (bundle-path &key (source "ccl:cocoa-ide;ide-contents;")
     14                                           (source-ignore '(".svn" "cvs" ".cvsignore"))
     15                                           (copy-headers *cocoa-application-copy-headers-p*)
     16                                           (if-exists :overwrite))
     17  ;; TODO: Right now if the bundle exists, we leave alone any files that we don't replace.
     18  ;; I'd like :if-exists :supersede mean to remove such files, for clean builds, but
     19  ;; recursive-copy-directory doesn't support :if-exists :supersede yet...
     20  (flet ((subdir (dir sub)
     21           (ensure-directory-pathname (make-pathname :name sub :defaults dir)))
     22         (ignore-test (p)
     23           (flet ((backup-p (name)
     24                    (and (stringp name)
     25                         (let ((len (length name)))
     26                           (and (> len 0)
     27                                (or (eql (aref name (1- len)) #\~)
     28                                    (eql (aref name 0) #\#)))))))
     29             (not (or (member (car (last (pathname-directory p))) source-ignore :test #'equalp)
     30                      (backup-p (pathname-name p))
     31                      (backup-p (pathname-type p))
     32                      (member (pathname-name p) source-ignore :test #'equalp))))))
     33    (let* ((source-dir (ensure-directory-pathname source))
     34           (target-dir (ensure-directory-pathname bundle-path))
     35           (contents-dir (subdir target-dir "Contents")))
     36      (recursive-copy-directory source-dir contents-dir :if-exists if-exists :test #'ignore-test)
     37      (when copy-headers
     38        (let* ((subdirs (cdb-subdirectory-path))
     39               (ccl-headers (make-pathname :host "ccl" :directory `(:absolute ,@subdirs)))
     40               (dest-headers (make-pathname :host (pathname-host contents-dir)
     41                                            :directory (append (pathname-directory contents-dir)
     42                                                               (cons "Resources" subdirs)))))
     43          (recursive-copy-directory ccl-headers dest-headers :if-exists if-exists :test #'ignore-test)))
     44      ;; Is this necessary?
     45      (let* ((image-name (standard-kernel-name))
     46             (ccl-image (make-pathname :name image-name :host "ccl"))
     47             (dest-image (make-pathname :name image-name
     48                                        :defaults (subdir contents-dir "MacOS"))))
     49        (ensure-directories-exist dest-image)
     50        (copy-file ccl-image dest-image :if-exists :supersede :preserve-attributes t))
     51      (touch target-dir))))
    752
    853#+darwin-target
    954(progn
    1055  (require "FAKE-CFBUNDLE-PATH")
    11   (fake-cfbundle-path "ccl:cocoa-ide;OpenMCL.app;" "ccl:cocoa-ide;Info.plist-proto"))
     56  (create-ide-bundle *cocoa-application-path*)
     57  (fake-cfbundle-path *cocoa-application-path* "ccl:cocoa-ide;Info.plist-proto" "com.clozure"))
    1258
    1359
     
    2066
    2167 
    22 (require "COCOA-UTILS")
    23 (require "COCOA-WINDOW")
    24 (require "COCOA-DOC")
    25 (require "COCOA-LISTENER")
    26 (require "COCOA-GREP")
    27 (require "COCOA-BACKTRACE")
    28 (require "COCOA-INSPECTOR")
     68(defvar *ide-files*
     69  '("cocoa-utils"
     70    "cocoa-defaults"
     71    "cocoa-prefs"
     72    "cocoa-typeout"
     73    "cocoa-window"
     74    "cocoa-doc"
     75    "cocoa-editor" ;; this loads hemlock
     76    "cocoa-listener"
     77    ;; tools
     78    "cocoa-grep"
     79    "cocoa-backtrace"
     80    "cocoa-inspector"
     81    "preferences"
     82    "processes-window"
     83    "apropos-window"
     84    "app-delegate"
     85    ))
    2986
    30 (def-cocoa-default *ccl-directory* :string (ensure-directory-namestring (namestring (ccl-directory))) nil #'(lambda (old new) (unless (equal old new) (replace-base-translation "ccl:" new))))
     87(defun load-ide (&optional force-compile)
     88  (with-compilation-unit ()
     89     (dolist (name *ide-files*)
     90       (let* ((source (merge-pathnames *.lisp-pathname* (make-pathname :name name :defaults "ccl:cocoa-ide;")))
     91              (fasl (merge-pathnames *.fasl-pathname* source)))
     92         (if (needs-compile-p fasl (list source) force-compile)
     93           (compile-file source :output-file fasl :verbose t :load t)
     94           (load fasl :verbose t))
     95         (provide (string-upcase name))))))
     96
     97(load-ide t)
    3198
    3299
    33 ;;; The application delegate gets notified of state changes in the
    34 ;;; application object.
    35 (defclass lisp-application-delegate (ns:ns-object)
    36     ()
    37   (:metaclass ns:+ns-object))
     100(def-cocoa-default *ccl-directory* :string "" nil #'(lambda (old new)
     101                                                      (when (equal new "") (setq new nil))
     102                                                      (unless (and new (equal old new))
     103                                                        (init-interfaces-root)
     104                                                        (replace-base-translation "ccl:"
     105                                                                                  (or new (find-ccl-directory))))))
    38106
     107;; If there are interfaces inside the bundle, use those rather than the ones
     108;; in CCL:, since they're more likely to be valid.  CCL: could be some random
     109;; sources we're just using just for meta-.
     110(defun init-interfaces-root ()
     111  (let* ((subpath (cdb-subdirectory-path))
     112         (path (pathname-directory (ccl-directory))))
     113    (when (and *standalone-cocoa-ide*
     114               (equalp (last path 2) '("Contents" "MacOS")))
     115      (setq path (butlast path))
     116      (when (or (probe-file (make-pathname :directory (append path subpath)))
     117                (probe-file (make-pathname :directory (append (setq path `(,@path "Resources")) subpath))))
     118        (setq *interfaces-root* (make-pathname :directory path))))))
    39119
    40 (objc:defmethod (#/applicationWillFinishLaunching: :void)
    41     ((self lisp-application-delegate) notification)
    42   (declare (ignore notification))
    43   (initialize-user-interface))
    44 
    45 (objc:defmethod (#/applicationWillTerminate: :void)
    46     ((self lisp-application-delegate) notification)
    47   (declare (ignore notification))
    48   ;; UI has decided to quit; terminate other lisp threads.
    49   (prepare-to-quit))
    50 
    51 (objc:defmethod (#/newListener: :void) ((self lisp-application-delegate)
    52                                         sender)
    53   (declare (ignore sender))
    54   (#/openUntitledDocumentOfType:display:
    55    (#/sharedDocumentController ns:ns-document-controller)
    56    #@"Listener"
    57    t))
    58 
    59 (defvar *cocoa-application-finished-launching* (make-semaphore)
    60   "Semaphore that's signaled when the application's finished launching ...")
    61 
    62 (objc:defmethod (#/applicationDidFinishLaunching: :void)
    63     ((self lisp-application-delegate) notification)
    64   (declare (ignore notification))
    65   (signal-semaphore *cocoa-application-finished-launching*))
    66 
    67 (objc:defmethod (#/applicationOpenUntitledFile: :<BOOL>)
    68     ((self lisp-application-delegate) app)
    69   (when (zerop *cocoa-listener-count*)
    70     (#/newListener: self app)
    71     t))
    72 
     120(defun find-ccl-directory ()
     121  (let* ((path (ccl-directory))
     122         (dir (pathname-directory path)))
     123    (if (equalp (last dir 2) '("Contents" "MacOS"))
     124        (make-pathname :directory (butlast dir 3))
     125        path)))
    73126
    74127(defmethod ui-object-do-operation ((o ns:ns-application)
  • branches/ia32/cocoa-ide/compile-hemlock.lisp

    r6885 r7666  
    9090    "register"
    9191    "completion"
     92    "symbol-completion"
    9293    "bindings"
    9394    "bindings-gb"                       ;Gilbert's bindings
  • branches/ia32/cocoa-ide/hemlock/src/bindings.lisp

    r7244 r7666  
    4343(bind-key "Select to Beginning of Line" #k"control-A")
    4444(bind-key "Delete Next Character" #k"control-d")
     45(bind-key "Delete Next Character" #k"del")
    4546(bind-key "End of Line" #k"control-e")
    4647(bind-key "Select to End of Line" #k"control-E")
     
    185186;(bind-key "Count Lines Page" #k"control-x l")
    186187
     188(bind-key "Expand Dynamic Abbreviation" #k"meta-/") ;; Aquamacs and LW binding
     189(bind-key "Expand Dynamic Abbreviation" #k"meta-`") ;; MCL binding
    187190
    188191
     
    290293;;; Rebind some standard commands to behave better.
    291294;;;
    292 (bind-key "Kill Parse" #k"control-u" :mode "Echo Area")
     295;;(bind-key "Kill Parse" #k"control-u" :mode "Echo Area")
    293296(bind-key "Insert Parse Default" #k"control-i" :mode "Echo Area")
    294297(bind-key "Insert Parse Default" #k"tab" :mode "Echo Area")
     
    331334(bind-key "POP Or Delete Forward" #k"control-d" :mode "Listener")
    332335(bind-key "Reenter Interactive Input" #k"control-return" :mode "Listener")
     336
     337;;; Make the user use C-x C-w to save the file, and take care
     338;;; not to associate the Listener document with any particular
     339;;; file or type.
     340(bind-key "Illegal" #k"control-x control-s" :mode "Listener")
     341(bind-key "Save To File" #k"control-x control-w" :mode "Listener")
    333342
    334343(bind-key "Editor Evaluate Expression" #k"control-meta-escape")
     
    610619
    611620
    612 ;;;; X commands:
    613 
    614 #+clx
    615 (progn
    616 (bind-key "Insert Cut Buffer" #k"insert")
    617 (bind-key "Region to Cut Buffer" #k"meta-insert")
    618 )
    619 
    620 
    621 
    622621;;;; Mailer commands.
    623622#+mail-mode
     
    958957(setf (logical-key-event-p #k"control-q" :quote) t)
    959958(setf (logical-key-event-p #k"k" :keep) t)
     959(setf (logical-key-event-p #k"control-w" :extend-search-word) t)
  • branches/ia32/cocoa-ide/hemlock/src/buffer.lisp

    r7244 r7666  
    454454  (multiple-value-bind (flag args)
    455455                       (let ((*in-a-recursive-edit* t)
    456                              (doc (buffer-document *current-buffer*)))
     456                             #+nil (doc (buffer-document *current-buffer*))
     457                             )
    457458                         (catch 'leave-recursive-edit
    458459                           (unwind-protect
    459460                                (progn
    460                                   ;(when doc (document-end-editing doc))
     461                                  #+nil (when doc (document-end-editing doc))
    461462                                  (if handle-abort
    462463                                    (loop (catch 'editor-top-level-catcher
     
    494495  (invoke-hook hemlock::abort-recursive-edit-hook args)
    495496  (throw 'leave-recursive-edit (values :abort args)))
    496 
    497497
    498498
  • branches/ia32/cocoa-ide/hemlock/src/cocoa-hemlock.lisp

    r7244 r7666  
    127127  (setf (frame-event-queue-quoted-insert q) t))
    128128
    129 (defun disable-self-insert (q)
     129(defmethod disable-self-insert ((q frame-event-queue))
    130130  (setf (frame-event-queue-quoted-insert q) nil))
    131131
  • branches/ia32/cocoa-ide/hemlock/src/command.lisp

    r7244 r7666  
    5555  "Reads a key-event from *editor-input* and inserts it at the point."
    5656  (declare (ignore p))
    57   (hi::enable-self-insert *editor-input*))
     57  (hi::enable-self-insert hi::*editor-input*))
    5858
    5959(defcommand "Forward Character" (p)
     
    465465  (clear-echo-area)
    466466  (write-string "C-U " *echo-area-stream*)
    467   (let* ((key-event (get-key-event *editor-input*))
     467  (let* ((key-event (get-key-event hi::*editor-input*))
    468468         (char (hemlock-ext:key-event-char key-event)))
    469469    (if char
     
    471471          (#\-
    472472           (write-char #\- *echo-area-stream*)
    473            (universal-argument-loop (get-key-event *editor-input*) -1))
     473           (universal-argument-loop (get-key-event hi::*editor-input*) -1))
    474474          (#\+
    475475           (write-char #\+ *echo-area-stream*)
    476            (universal-argument-loop (get-key-event *editor-input*) -1))
     476           (universal-argument-loop (get-key-event hi::*editor-input*) -1))
    477477          (t
    478478           (universal-argument-loop key-event 1)))
     
    487487  (clear-echo-area)
    488488  (write-string "C-U -" *echo-area-stream*)
    489   (universal-argument-loop (get-key-event *editor-input*) -1))
     489  (universal-argument-loop (get-key-event hi::*editor-input*) -1))
    490490
    491491(defcommand "Argument Digit" (p)
     
    517517               (write-char char *echo-area-stream*)
    518518               (setf result (+ digit (* 10 result)))
    519                (setf key-event (get-key-event *editor-input*))
     519               (setf key-event (get-key-event hi::*editor-input*))
    520520               (setf stripped-key-event (if key-event
    521521                                            (hemlock-ext:make-key-event key-event)))
     
    525525               (write-string " C-U " *echo-area-stream*)
    526526               (universal-argument-loop
    527                 (get-key-event *editor-input*) 1
     527                (get-key-event hi::*editor-input*) 1
    528528                (prefix sign multiplier read-some-digit-p result))
    529529               (return))
    530530              (t
    531                (unget-key-event key-event *editor-input*)
     531               (unget-key-event key-event hi::*editor-input*)
    532532               (setf (prefix-argument)
    533533                     (prefix sign multiplier read-some-digit-p result))
  • branches/ia32/cocoa-ide/hemlock/src/completion.lisp

    r6 r7666  
    6565;;;
    6666(defvar default-lisp-wordchars
    67   '(#\~ #\! #\@ #\$ #\% #\^ #\& #\+ #\= #\: #\< #\> #\. #\/ #\?))
     67  '(#\~ #\! #\@ #\$ #\% #\^ #\& #\+ #\= #\< #\> #\. #\/ #\?))
    6868
    6969(dolist (char default-lisp-wordchars)
  • branches/ia32/cocoa-ide/hemlock/src/cursor.lisp

    r6578 r7666  
    146146(defun cached-real-line-length (line width start end)
    147147  (declare (fixnum width start end) (ignore line))
    148   (let ((offset (- *right-open-pos* *left-open-pos*))
     148  (let ((offset (- (current-right-open-pos) (current-left-open-pos)))
    149149        (bound 0))
    150150    (declare (fixnum offset bound))
    151151    (cond
    152      ((>= start *left-open-pos*)
     152     ((>= start (current-left-open-pos))
    153153      (setq start (+ start offset)  bound (setq end (+ end offset))))
    154      ((> end *left-open-pos*)
    155       (setq bound *left-open-pos*  end (+ end offset)))
     154     ((> end (current-left-open-pos))
     155      (setq bound (current-left-open-pos)  end (+ end offset)))
    156156     (t
    157157      (setq bound end)))
     
    166166      (when (= start bound)
    167167        (when (= start end) (return (values xpos ypos)))
    168         (setq start *right-open-pos*  bound end))
    169       (setq losing (%fcwa *open-chars* start bound losing-char))
     168        (setq start (current-right-open-pos)  bound end))
     169      (setq losing (%fcwa (current-open-chars) start bound losing-char))
    170170      (cond
    171171       (losing
     
    173173          (truncate (+ xpos (- losing start)) width))
    174174        (setq ypos (+ ypos dy)  start losing)
    175         (do ((last (or (%fcwa *open-chars* start bound winning-char) bound)) str)
     175        (do ((last (or (%fcwa (current-open-chars) start bound winning-char) bound)) str)
    176176            ((= start last))
    177177          (declare (fixnum last))
    178           (setq str (get-rep (schar *open-chars* start)))
     178          (setq str (get-rep (schar (current-open-chars) start)))
    179179          (incf start)
    180180          (unless (simple-string-p str) (setq str (funcall str xpos)))
     
    298298  (let ((charpos (mark-charpos mark))
    299299        (line (mark-line mark)))
    300     (if (eq line *open-line*)
     300    (if (current-open-line-p line)
    301301        (values (cached-real-line-length line 10000 0 charpos))
    302302        (values (real-line-length line 10000 0 charpos)))))
     
    310310;;;
    311311(defun find-position (line position start end width)
    312   (do* ((cached (eq line *open-line*))
     312  (do* ((cached (current-open-line-p line))
    313313        (lo start)
    314314        (hi (1- end))
  • branches/ia32/cocoa-ide/hemlock/src/decls.lisp

    r711 r7666  
    6363;;; need to invent a new language to advise the compiler of that ...
    6464(declaim (special *mode-names* *current-buffer* *echo-area-buffer*
    65                   *buffer-gap-context*
    6665                  *the-sentinel*
    6766                  *in-the-editor* *buffer-list* *things-to-do-once*
  • branches/ia32/cocoa-ide/hemlock/src/echo.lisp

    r7244 r7666  
    719719(define-logical-key-event "Mouse Exit"
    720720  "This key-event means exit completely.")
     721(define-logical-key-event "Extend Search Word"
     722  "This key-event means to extend the incremental search string by the word after the point")
    721723
    722724
  • branches/ia32/cocoa-ide/hemlock/src/edit-defs.lisp

    r7244 r7666  
    7171        (if fun-name
    7272            (get-def-info-and-go-to-it fun-name (or
    73                                                  (find-package
    74                                                   (variable-value 'current-package :buffer (current-buffer)))
     73                                                 (buffer-package (current-buffer))
    7574                                                 *package*))
    7675            (beep)))))
  • branches/ia32/cocoa-ide/hemlock/src/filecoms.lisp

    r7244 r7666  
    523523  (let* ((pathname (pathname pathname))
    524524         (probed-pathname (probe-file pathname))
    525          (hi::*buffer-gap-context*
    526           (or (hi::buffer-gap-context buffer)
    527               (setf (hi::buffer-gap-context buffer)
    528                     (hi::make-buffer-gap-context)))))
     525         (hi::*current-buffer* buffer))
    529526    (cond (probed-pathname
    530527           (read-file probed-pathname (buffer-point buffer))
     
    621618      (hi::save-hemlock-document-as document))))
    622619
     620(defcommand "Save To File" (p &optional (buffer (current-buffer)))
     621  "Writes the contents of Buffer, which defaults to the current buffer to
     622  the file named by Pathname.  The prefix argument is ignored."
     623  "Prompts for a file to write the contents of the current Buffer to.
     624  The prefix argument is ignored."
     625  (declare (ignore p))
     626  (let* ((document (hi::buffer-document buffer)))
     627    (when document
     628      (hi::save-hemlock-document-to document))))
     629
    623630(defcommand "Save File" (p &optional (buffer (current-buffer)))
    624631  "Writes the contents of the current buffer to the associated file.  If there
  • branches/ia32/cocoa-ide/hemlock/src/font.lisp

    r6599 r7666  
    100100)
    101101
    102 
    103 
    104 
    105 ;;;; Referencing and setting font ids.
    106 
    107 #+clx
    108 (progn
    109 (defun window-font (window font)
    110   "Returns a font id for window and font."
    111   (svref (font-family-map (bitmap-hunk-font-family (window-hunk window))) font))
    112 
    113 (defun %set-window-font (window font font-object)
    114   (unless (and (>= font 0) (< font font-map-size))
    115     (error "Font number ~S out of range." font))
    116   (setf (bitmap-hunk-trashed (window-hunk window)) :font-change)
    117   (let ((family (bitmap-hunk-font-family (window-hunk window))))
    118     (when (eq family *default-font-family*)
    119       (setq family (copy-font-family family))
    120       (setf (font-family-map family) (copy-seq (font-family-map family)))
    121       (setf (bitmap-hunk-font-family (window-hunk window)) family))
    122     (setf (svref (font-family-map family) font) font-object)))
    123 
    124 (defun default-font (font)
    125   "Returns the font id for font out of the default font family."
    126   (svref (font-family-map *default-font-family*) font))
    127 
    128 (defun %set-default-font (font font-object)
    129   (unless (and (>= font 0) (< font font-map-size))
    130     (error "Font number ~S out of range." font))
    131   (dolist (w *window-list*)
    132     (when (eq (bitmap-hunk-font-family (window-hunk w)) *default-font-family*)
    133       (setf (bitmap-hunk-trashed (window-hunk w)) :font-change)))
    134   (setf (svref (font-family-map *default-font-family*) font) font-object))
    135 )
  • branches/ia32/cocoa-ide/hemlock/src/htext1.lisp

    r6601 r7666  
    3838;;;
    3939;;; The open line is represented by 4 special variables:
    40 ;;;     *Open-Line*: the line object that is opened
    41 ;;;     *Open-Chars*: the vector of cached characters
    42 ;;;     *Left-Open-Pos*: index of first free character in the gap
    43 ;;;     *Right-Open-Pos*: index of first used character after the gap
     40;;;     (current-open-line): the line object that is opened
     41;;;     (current-open-chars): the vector of cached characters
     42;;;     (current-left-open-pos): index of first free character in the gap
     43;;;     (current-right-open-pos): index of first used character after the gap
    4444;;;
    4545;;; Note:
     
    7878  "Index to first used character to right of mark in *Open-Chars*.")
    7979
    80 (defun grow-open-chars (&optional (new-length (* *line-cache-length* 2)))
    81   "Grows *Open-Chars* to twice its current length, or the New-Length if
     80(defun grow-open-chars (&optional (new-length (* (current-line-cache-length) 2)))
     81  "Grows (current-open-chars) to twice its current length, or the New-Length if
    8282  specified."
    83   (let ((new-chars (make-string new-length))
    84         (new-right (- new-length (- *line-cache-length* *right-open-pos*))))
    85     (%sp-byte-blt *open-chars* 0 new-chars 0 *left-open-pos*)
    86     (%sp-byte-blt *open-chars* *right-open-pos* new-chars new-right new-length)
    87     (setf *right-open-pos* new-right)
    88     (setf *open-chars* new-chars)
    89     (setf *line-cache-length* new-length)))
     83  (let* ((old-chars (current-open-chars))
     84         (old-right (current-right-open-pos))
     85         (new-chars (make-string new-length))
     86         (new-right (- new-length (- (current-line-cache-length) old-right))))
     87    (%sp-byte-blt old-chars 0 new-chars 0 (current-left-open-pos))
     88    (%sp-byte-blt old-chars old-right new-chars new-right new-length)
     89    (setf (current-right-open-pos) new-right)
     90    (setf (current-open-chars) new-chars)
     91    (setf (current-line-cache-length) new-length)))
    9092
    9193
    9294(defun close-line ()
    9395  "Stuffs the characters in the currently open line back into the line they
    94   came from, and sets *open-line* to Nil."
    95   (when *open-line*
     96  came from, and sets (current-open-line) to Nil."
     97  (when (current-open-line)
    9698    (hemlock-ext:without-interrupts
    97       (let* ((length (+ *left-open-pos* (- *line-cache-length* *right-open-pos*)))
     99      (let* ((open-chars (current-open-chars))
     100             (right-pos (current-right-open-pos))
     101             (left-pos (current-left-open-pos))
     102             (length (+ left-pos (- (current-line-cache-length) right-pos)))
    98103             (string (make-string length)))
    99         (%sp-byte-blt *open-chars* 0 string 0 *left-open-pos*)
    100         (%sp-byte-blt *open-chars* *right-open-pos*  string *left-open-pos* length)
    101         (setf (line-chars *open-line*) string)
    102         (setf *open-line* nil)))))
     104        (%sp-byte-blt open-chars 0 string 0 left-pos)
     105        (%sp-byte-blt open-chars right-pos string left-pos length)
     106        (setf (line-chars (current-open-line)) string)
     107        (setf (current-open-line) nil)))))
    103108
    104109;;; We stick decrementing fixnums in the line-chars slot of the open line
     
    111116
    112117(defun open-line (line mark)
    113   "Closes the current *Open-Line* and opens the given Line at the Mark.
     118  "Closes the current open line and opens the given Line at the Mark.
    114119  Don't call this, use modifying-line instead."
    115   (cond ((eq line *open-line*)
    116            (let ((charpos (mark-charpos mark)))
    117              (cond ((< charpos *left-open-pos*) ; BLT 'em right!
    118                     (let ((right-start (- *right-open-pos*
    119                                           (- *left-open-pos* charpos))))
    120                       (%sp-byte-blt *open-chars*
     120  (cond ((current-open-line-p line)
     121           (let ((charpos (mark-charpos mark))
     122                 (open-chars (current-open-chars)))
     123             (cond ((< charpos (current-left-open-pos)) ; BLT 'em right!
     124                    (let ((right-start (- (current-right-open-pos)
     125                                          (- (current-left-open-pos) charpos))))
     126                      (%sp-byte-blt open-chars
    121127                                    charpos
    122                                     *open-chars*
     128                                    open-chars
    123129                                    right-start
    124                                     *right-open-pos*)
    125                       (setf *left-open-pos* charpos)
    126                       (setf *right-open-pos* right-start)))
    127                    ((> charpos *left-open-pos*) ; BLT 'em left!
    128                     (%sp-byte-blt *open-chars*
    129                                   *right-open-pos*
    130                                   *open-chars*
    131                                   *left-open-pos*
     130                                    (current-right-open-pos))
     131                      (setf (current-left-open-pos) charpos)
     132                      (setf (current-right-open-pos) right-start)))
     133                   ((> charpos (current-left-open-pos)) ; BLT 'em left!
     134                    (%sp-byte-blt open-chars
     135                                  (current-right-open-pos)
     136                                  open-chars
     137                                  (current-left-open-pos)
    132138                                  charpos)
    133                     (setf *right-open-pos*
    134                           (+ *right-open-pos*
    135                              (- charpos *left-open-pos*)))
    136                     (setf *left-open-pos* charpos)))))
     139                    (incf (current-right-open-pos) (- charpos (current-left-open-pos)))
     140                    (setf (current-left-open-pos) charpos)))))
    137141
    138142          (t
     
    141145                  (len (length chars)))
    142146             (declare (simple-string chars))
    143              (when (> len *line-cache-length*)
    144                (setf *line-cache-length* (* len 2))
    145                (setf *open-chars* (make-string *line-cache-length*)))
    146              (setf *open-line* line)
    147              (setf *left-open-pos* (mark-charpos mark))
    148              (setf *right-open-pos*
    149                    (- *line-cache-length*
    150                       (- (length chars) *left-open-pos*)))
    151              (%sp-byte-blt chars 0 *open-chars* 0
    152                            *left-open-pos*)
    153              (%sp-byte-blt chars *left-open-pos*
    154                            *open-chars*
    155                            *right-open-pos*
    156                            *line-cache-length*)))))
     147             (when (> len (current-line-cache-length))
     148               (setf (current-line-cache-length) (* len 2))
     149               (setf (current-open-chars) (make-string (current-line-cache-length))))
     150             (setf (current-open-line) line)
     151             (setf (current-left-open-pos) (mark-charpos mark))
     152             (setf (current-right-open-pos)
     153                   (- (current-line-cache-length)
     154                      (- (length chars) (current-left-open-pos))))
     155             (%sp-byte-blt chars 0 (current-open-chars) 0
     156                           (current-left-open-pos))
     157             (%sp-byte-blt chars (current-left-open-pos)
     158                           (current-open-chars)
     159                           (current-right-open-pos)
     160                           (current-line-cache-length))))))
    157161
    158162
     
    162166(defmacro modifying-line (line mark)
    163167  "Checks to see if the Line is already opened at the Mark, and calls Open-Line
    164   if not.  Sticks a tick in the *open-line*'s chars.  This must be called within
     168  if not.  Sticks a tick in the current-open-line's chars.  This must be called within
    165169  the body of a Modifying-Buffer form."
    166170  `(progn
    167     (unless (and (= (mark-charpos ,mark) *left-open-pos*) (eq ,line *open-line*))
     171    (unless (and (= (mark-charpos ,mark) (current-left-open-pos)) (current-open-line-p ,line))
    168172      (open-line ,line ,mark))
    169     (setf (line-chars *open-line*) (decf *cache-modification-tick*))))
     173    (setf (line-chars (current-open-line)) (decf *cache-modification-tick*))))
    170174
    171175;;; Now-Tick tells us when now is and isn't.
     
    356360  "Returns the characters in the line as a string.  The resulting string
    357361  must not be destructively modified.  This may be set with Setf."
    358   (if (eq line *open-line*)
     362  (if (current-open-line-p line)
    359363    (close-line))
    360364  (line-chars line))
     
    365369      (unless (simple-string-p string)
    366370        (setq string (coerce string 'simple-string)))
    367       (when (eq line *open-line*) (setq *open-line* nil))
     371      (when (current-open-line-p line) (setf (current-open-line) nil))
    368372      (let ((length (length (the simple-string string))))
    369373        (dolist (m (line-marks line))
     
    376380  "Return the Index'th character in Line.  If the index is the length of the
    377381  line then #\newline is returned."
    378   (if (eq line *open-line*)
    379       (if (< index *left-open-pos*)
    380           (schar *open-chars* index)
    381           (let ((index (+ index (- *right-open-pos* *left-open-pos*))))
    382             (if (= index *line-cache-length*)
     382  (if (current-open-line-p line)
     383      (if (< index (current-left-open-pos))
     384          (schar (current-open-chars) index)
     385          (let ((index (+ index (- (current-right-open-pos) (current-left-open-pos)))))
     386            (if (= index (current-line-cache-length))
    383387                #\newline
    384                 (schar *open-chars* index))))
     388                (schar (current-open-chars) index))))
    385389      (let ((chars (line-chars line)))
    386390        (declare (simple-string chars))
     
    558562  or otherwise."
    559563  (let ((line (mark-line mark)))
    560     (if (eq line *open-line*)
    561         (and (= *left-open-pos* 0) (= *right-open-pos* *line-cache-length*))
     564    (if (current-open-line-p line)
     565        (and (= (current-left-open-pos) 0) (= (current-right-open-pos) (current-line-cache-length)))
    562566        (= (length (line-chars line)) 0))))
    563567
     
    574578;;;
    575579(defun blank-between-positions (line start end)
    576   (if (eq line *open-line*)
    577       (let ((gap (- *right-open-pos* *left-open-pos*)))
    578         (cond ((>= start *left-open-pos*)
    579                (check-range *open-chars* (+ start gap) (+ end gap)))
    580               ((<= end *left-open-pos*)
    581                (check-range *open-chars* start end))
     580  (if (current-open-line-p line)
     581      (let ((gap (- (current-right-open-pos) (current-left-open-pos))))
     582        (cond ((>= start (current-left-open-pos))
     583               (check-range (current-open-chars) (+ start gap) (+ end gap)))
     584              ((<= end (current-left-open-pos))
     585               (check-range (current-open-chars) start end))
    582586              (t
    583                (and (check-range *open-chars* start *left-open-pos*)
    584                     (check-range *open-chars* *right-open-pos* (+ end gap))))))
     587               (and (check-range (current-open-chars) start (current-left-open-pos))
     588                    (check-range (current-open-chars) (current-right-open-pos) (+ end gap))))))
    585589      (let ((chars (line-chars line)))
    586590        (check-range chars start end))))
  • branches/ia32/cocoa-ide/hemlock/src/htext2.lisp

    r6602 r7666  
    2424
    2525
    26 (defun region-to-string (region)
     26(defun region-to-string (region &optional output-string)
    2727  "Returns a string containing the characters in the given Region."
    2828  (close-line)
    2929  (let* ((dst-length (count-characters region))
    30          (string (make-string dst-length))
     30         (string (if (and output-string
     31                          (<= dst-length (length output-string)))
     32                     output-string
     33                     (make-string dst-length)))
    3134         (start-mark (region-start region))
    3235         (end-mark (region-end region))
     
    5457            (setf (char string index) #\newline)
    5558            (setq index (1+ index)))))
    56     string))
     59    (values string dst-length)))
    5760
    5861
     
    105108            #\newline
    106109            nil)
    107         (if (eq line *open-line*)
    108             (char (the simple-string *open-chars*)
    109                   (if (<= charpos *left-open-pos*)
     110        (if (current-open-line-p line)
     111            (char (the simple-string (current-open-chars))
     112                  (if (<= charpos (current-left-open-pos))
    110113                      (1- charpos)
    111                       (1- (+ *right-open-pos* (- charpos *left-open-pos*)))))
     114                      (1- (+ (current-right-open-pos) (- charpos (current-left-open-pos))))))
    112115            (schar (line-chars line) (1- charpos))))))
    113116
     
    116119  (let ((line (mark-line mark))
    117120        (charpos (mark-charpos mark)))
    118     (if (eq line *open-line*)
    119         (if (= charpos (- *line-cache-length* (- *right-open-pos* *left-open-pos*)))
     121    (if (current-open-line-p line)
     122        (if (= charpos (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos))))
    120123            (if (line-next line)
    121124                #\newline
    122125                nil)
    123             (schar *open-chars*
    124                    (if (< charpos *left-open-pos*)
     126            (schar (current-open-chars)
     127                   (if (< charpos (current-left-open-pos))
    125128                       charpos
    126                        (+ *right-open-pos* (- charpos *left-open-pos*)))))
     129                       (+ (current-right-open-pos) (- charpos (current-left-open-pos))))))
    127130        (let ((chars (line-chars line)))
    128131          (if (= charpos (strlen chars))
     
    148151      (modifying-line line mark)
    149152      (cond ((= (mark-charpos mark)
    150                 (- *line-cache-length* (- *right-open-pos* *left-open-pos*)))
     153                (- (current-line-cache-length) (- (current-right-open-pos) (current-left-open-pos))))
    151154             ;; The mark is at the end of the line.
    152155             (unless next
     
    157160               (let ((chars (line-chars next)))
    158161                 (declare (simple-string chars))
    159                  (setq *right-open-pos* (- *line-cache-length* (length chars)))
    160                  (when (<= *right-open-pos* *left-open-pos*)
    161                    (grow-open-chars (* (+ (length chars) *left-open-pos* 1) 2)))
    162                  (%sp-byte-blt chars 0 *open-chars* *right-open-pos*
    163                                *line-cache-length*)
    164                  (setf (schar *open-chars* *left-open-pos*) character)
    165                  (incf *left-open-pos*))
     162                 (setf (current-right-open-pos) (- (current-line-cache-length) (length chars)))
     163                 (when (<= (current-right-open-pos) (current-left-open-pos))
     164                   (grow-open-chars (* (+ (length chars) (current-left-open-pos) 1) 2)))
     165                 (%sp-byte-blt chars 0 (current-open-chars) (current-right-open-pos)
     166                               (current-line-cache-length))
     167                 (setf (schar (current-open-chars) (current-left-open-pos)) character)
     168                 (incf (current-left-open-pos)))
    166169               (move-some-marks (charpos next line)
    167                                 (+ charpos *left-open-pos*))
     170                                (+ charpos (current-left-open-pos)))
    168171               (setq next (line-next next))
    169172               (setf (line-next line) next)
     
    171174            ((char= character #\newline)
    172175             ;; The char is being changed to a newline, so we must split lines.
    173              (incf *right-open-pos*)
    174              (let* ((len (- *line-cache-length* *right-open-pos*))         
     176             (incf (current-right-open-pos))
     177             (let* ((len (- (current-line-cache-length) (current-right-open-pos)))         
    175178                    (chars (make-string len))
    176179                    (new (make-line :chars chars  :previous line
    177180                                    :next next  :%buffer buffer)))
    178                (%sp-byte-blt *open-chars* *right-open-pos* chars 0 len)
    179                (maybe-move-some-marks* (charpos line new) *left-open-pos*
    180                                        (- charpos *left-open-pos* 1))
     181               (%sp-byte-blt (current-open-chars) (current-right-open-pos) chars 0 len)
     182               (maybe-move-some-marks* (charpos line new) (current-left-open-pos)
     183                                       (- charpos (current-left-open-pos) 1))
    181184               (setf (line-next line) new)
    182185               (when next (setf (line-previous next) new))
    183                (setq *right-open-pos* *line-cache-length*)
     186               (setf (current-right-open-pos) (current-line-cache-length))
    184187               (number-line new)))
    185188            (t
    186              (setf (char (the simple-string *open-chars*) *right-open-pos*)
     189             (setf (char (the simple-string (current-open-chars)) (current-right-open-pos))
    187190                   character)
    188191             (hi::buffer-note-modification buffer mark 1)))))
     
    380383
    381384(defun %print-whole-line (structure stream)
    382   (cond ((eq structure *open-line*)
    383          (write-string *open-chars* stream :end *left-open-pos*)
    384          (write-string *open-chars* stream :start *right-open-pos*
    385                        :end *line-cache-length*))
    386         (t
    387          (write-string (line-chars structure) stream))))
     385  (let* ((hi::*current-buffer* (line-buffer structure)))
     386    (cond ((current-open-line-p structure)
     387           (write-string (current-open-chars) stream :end (current-left-open-pos))
     388           (write-string (current-open-chars) stream :start (current-right-open-pos)
     389                         :end (current-line-cache-length)))
     390          (t
     391           (write-string (line-chars structure) stream)))))
    388392
    389393(defun %print-before-mark (mark stream)
    390   (if (mark-line mark)
    391       (let* ((line (mark-line mark))
    392              (chars (line-chars line))
    393              (charpos (mark-charpos mark))
    394              (length (line-length line)))
    395         (declare (simple-string chars))
    396         (cond ((or (> charpos length) (< charpos 0))
    397                (write-string "{bad mark}" stream))
    398               ((eq line *open-line*)
    399                (cond ((< charpos *left-open-pos*)
    400                       (write-string *open-chars* stream :end charpos))
    401                      (t
    402                       (write-string *open-chars* stream :end *left-open-pos*)
    403                       (let ((p (+ charpos (- *right-open-pos* *left-open-pos*))))
    404                         (write-string *open-chars* stream  :start *right-open-pos*
    405                                       :end p)))))
    406               (t
    407                (write-string chars stream :end charpos))))
    408       (write-string "{deleted mark}" stream)))
     394  (let* ((hi::*current-buffer* (line-buffer (mark-line mark))))
     395    (if (mark-line mark)
     396        (let* ((line (mark-line mark))
     397               (chars (line-chars line))
     398               (charpos (mark-charpos mark))
     399               (length (line-length line)))
     400          (declare (simple-string chars))
     401          (cond ((or (> charpos length) (< charpos 0))
     402                 (write-string "{bad mark}" stream))
     403                ((current-open-line-p line)
     404                 (cond ((< charpos (current-left-open-pos))
     405                        (write-string (current-open-chars) stream :end charpos))
     406                       (t
     407                        (write-string (current-open-chars) stream :end (current-left-open-pos))
     408                        (let ((p (+ charpos (- (current-right-open-pos) (current-left-open-pos)))))
     409                          (write-string (current-open-chars) stream  :start (current-right-open-pos)
     410                                        :end p)))))
     411                (t
     412                 (write-string chars stream :end charpos))))
     413        (write-string "{deleted mark}" stream))))
    409414
    410415
    411416(defun %print-after-mark (mark stream)
    412   (if (mark-line mark)
    413       (let* ((line (mark-line mark))
    414              (chars (line-chars line))
    415              (charpos (mark-charpos mark))
    416              (length (line-length line)))
    417         (declare (simple-string chars))
    418         (cond ((or (> charpos length) (< charpos 0))
    419                (write-string "{bad mark}" stream))
    420               ((eq line *open-line*)
    421                (cond ((< charpos *left-open-pos*)
    422                       (write-string *open-chars* stream  :start charpos
    423                                     :end *left-open-pos*)
    424                       (write-string *open-chars* stream  :start *right-open-pos*
    425                                     :end *line-cache-length*))
    426                      (t
    427                       (let ((p (+ charpos (- *right-open-pos* *left-open-pos*))))
    428                         (write-string *open-chars* stream :start p
    429                                       :end *line-cache-length*)))))
    430               (t
    431                (write-string chars stream  :start charpos  :end length))))
    432       (write-string "{deleted mark}" stream)))
     417  (let* ((hi::*current-buffer* (line-buffer (mark-line mark))))
     418    (if (mark-line mark)
     419        (let* ((line (mark-line mark))
     420               (chars (line-chars line))
     421               (charpos (mark-charpos mark))
     422               (length (line-length line)))
     423          (declare (simple-string chars))
     424          (cond ((or (> charpos length) (< charpos 0))
     425                 (write-string "{bad mark}" stream))
     426                ((current-open-line-p line)
     427                 (cond ((< charpos (current-left-open-pos))
     428                        (write-string (current-open-chars) stream  :start charpos
     429                                      :end (current-left-open-pos))
     430                        (write-string (current-open-chars) stream  :start (current-right-open-pos)
     431                                      :end (current-line-cache-length)))
     432                       (t
     433                        (let ((p (+ charpos (- (current-right-open-pos) (current-left-open-pos)))))
     434                          (write-string (current-open-chars) stream :start p
     435                                        :end (current-line-cache-length))))))
     436                (t
     437                 (write-string chars stream  :start charpos  :end length))))
     438        (write-string "{deleted mark}" stream))))
    433439
    434440(defun %print-hline (structure stream d)
     
    440446(defun %print-hmark (structure stream d)
    441447  (declare (ignore d))
    442   (write-string "#<Hemlock Mark \"" stream)
    443   (%print-before-mark structure stream)
    444   (write-string "^" stream)
    445   (%print-after-mark structure stream)
    446   (write-string "\">" stream)) 
     448  (let ((hi::*current-buffer* (line-buffer (mark-line structure))))
     449    (write-string "#<Hemlock Mark \"" stream)
     450    (%print-before-mark structure stream)
     451    (write-string "^" stream)
     452    (%print-after-mark structure stream)
     453    (write-string "\">" stream)))
    447454
    448455(defvar *print-region* 10
     
    454461  (let* ((start (region-start region))
    455462         (end (region-end region))
     463         (hi::*current-buffer* (line-buffer (mark-line start)))
    456464         (first-line (mark-line start))
    457465         (last-line (mark-line end)))
     
    469477                ((or (< cs 0) (> ce len))
    470478                 (write-string "{bad region}" stream))
    471                 ((eq first-line *open-line*)
    472                  (let ((gap (- *right-open-pos* *left-open-pos*)))
     479                ((current-open-line-p first-line)
     480                 (let ((gap (- (current-right-open-pos) (current-left-open-pos))))
    473481                   (cond
    474                     ((<= ce *left-open-pos*)
    475                      (write-string *open-chars* stream  :start cs  :end ce))
    476                     ((>= cs *left-open-pos*)
    477                      (write-string *open-chars* stream  :start (+ cs gap)
     482                    ((<= ce (current-left-open-pos))
     483                     (write-string (current-open-chars) stream  :start cs  :end ce))
     484                    ((>= cs (current-left-open-pos))
     485                     (write-string (current-open-chars) stream  :start (+ cs gap)
    478486                                   :end (+ ce gap)))
    479487                    (t
    480                      (write-string *open-chars* stream :start cs
    481                                    :end *left-open-pos*)
    482                      (write-string *open-chars* stream :start *right-open-pos*
     488                     (write-string (current-open-chars) stream :start cs
     489                                   :end (current-left-open-pos))
     490                     (write-string (current-open-chars) stream :start (current-right-open-pos)
    483491                                   :end (+ gap ce))))))
    484492                (t
  • branches/ia32/cocoa-ide/hemlock/src/htext3.lisp

    r6658 r7666  
    5353                      (cond ((char= character #\newline)
    5454                             (let* ((next (line-next line))
    55                                     (new-chars (subseq (the simple-string *open-chars*)
    56                                                        0 *left-open-pos*))
     55                                    (new-chars (subseq (the simple-string (current-open-chars))
     56                                                       0 (current-left-open-pos)))
    5757                                    (new-line (make-line :%buffer buffer
    5858                                                         :chars (decf *cache-modification-tick*)
    5959                                                         :previous line
    6060                                                         :next next)))
    61                                (maybe-move-some-marks (charpos line new-line) *left-open-pos*
    62                                                       (- charpos *left-open-pos*))
     61                               (maybe-move-some-marks (charpos line new-line) (current-left-open-pos)
     62                                                      (- charpos (current-left-open-pos)))
    6363                               (setf (line-%chars line) new-chars)
    6464                               (setf (line-next line) new-line)
    6565                               (if next (setf (line-previous next) new-line))
    6666                               (number-line new-line)
    67                                (setq *open-line* new-line  *left-open-pos* 0)))
     67                               (setf (current-open-line) new-line
     68                                     (current-left-open-pos) 0)))
    6869                            (t
    69                              (if (= *right-open-pos* *left-open-pos*)
     70                             (if (= (current-right-open-pos) (current-left-open-pos))
    7071                               (grow-open-chars))
    7172             
    72                              (maybe-move-some-marks (charpos line) *left-open-pos*
     73                             (maybe-move-some-marks (charpos line) (current-left-open-pos)
    7374                                                    (1+ charpos))
    7475             
    7576                             (cond
    7677                               ((eq (mark-%kind mark) :right-inserting)
    77                                 (decf *right-open-pos*)
    78                                 (setf (char (the simple-string *open-chars*) *right-open-pos*)
     78                                (decf (current-right-open-pos))
     79                                (setf (char (the simple-string (current-open-chars)) (current-right-open-pos))
    7980                                      character))
    8081                               (t
    81                                 (setf (char (the simple-string *open-chars*) *left-open-pos*)
     82                                (setf (char (the simple-string (current-open-chars)) (current-left-open-pos))
    8283                                      character)
    83                                 (incf *left-open-pos*)))))
     84                                (incf (current-left-open-pos))))))
    8485                      (adjust-line-origins-forward line)
    8586                      (buffer-note-insertion buffer mark 1))))
     
    102103         (progn
    103104           (modifying-line line mark)
    104            (if (<= *right-open-pos* (+ *left-open-pos* len))
    105              (grow-open-chars (* (+ *line-cache-length* len) 2)))
    106            (maybe-move-some-marks (charpos line) *left-open-pos*
     105           (if (<= (current-right-open-pos) (+ (current-left-open-pos) len))
     106             (grow-open-chars (* (+ (current-line-cache-length) len) 2)))
     107           (maybe-move-some-marks (charpos line) (current-left-open-pos)
    107108                                  (+ charpos len))
    108109           (cond
    109110             ((eq (mark-%kind mark) :right-inserting)
    110               (let ((new (- *right-open-pos* len)))
    111                 (%sp-byte-blt string 0 *open-chars* new *right-open-pos*)
    112                 (setq *right-open-pos* new)))
     111              (let ((new (- (current-right-open-pos) len)))
     112                (%sp-byte-blt string 0 (current-open-chars) new (current-right-open-pos))
     113                (setf (current-right-open-pos) new)))
    113114             (t
    114               (let ((new (+ *left-open-pos* len)))
    115                 (%sp-byte-blt string 0 *open-chars* *left-open-pos* new)
    116                 (setq *left-open-pos* new)))))
     115              (let ((new (+ (current-left-open-pos) len)))
     116                (%sp-byte-blt string 0 (current-open-chars) (current-left-open-pos) new)
     117                (setf (current-left-open-pos) new)))))
    117118         (adjust-line-origins-forward line)
    118119         (buffer-note-insertion buffer mark (length string)))))))
     
    137138     ((eq first-line last-line)
    138139      ;; simple case -- just BLT the characters in with insert-string
    139       (if (eq first-line *open-line*) (close-line))
     140      (if (current-open-line-p first-line) (close-line))
    140141      (let* ((string (line-chars first-line)))
    141142        (unless (and (eql first-charpos 0)
     
    210211     ((eq first-line last-line)
    211212      ;; Simple case -- just BLT the characters in with insert-string.
    212       (if (eq first-line *open-line*) (close-line))
     213      (if (current-open-line-p first-line) (close-line))
    213214      (let* ((string (line-chars first-line)))
    214215        (unless (and (eq first-charpos 0)
  • branches/ia32/cocoa-ide/hemlock/src/htext4.lisp

    r7244 r7666  
    4444                         (cond
    4545                           ((minusp n)
    46                             (setq *left-open-pos* (+ *left-open-pos* n))
     46                            (setf (current-left-open-pos) (+ (current-left-open-pos) n))
    4747                            (move-some-marks (pos line)
    48                                              (if (> pos *left-open-pos*)
    49                                                (if (<= pos charpos) *left-open-pos* (+ pos n))
     48                                             (if (> pos (current-left-open-pos))
     49                                               (if (<= pos charpos) (current-left-open-pos) (+ pos n))
    5050                                               pos)))
    5151         
    5252                           (t
    53                             (setq *right-open-pos* (+ *right-open-pos* n))
     53                            (setf (current-right-open-pos) (+ (current-right-open-pos) n))
    5454                            (let ((bound (+ charpos n)))
    5555                              (move-some-marks (pos line)
    5656                                               (if (> pos charpos)
    57                                                  (if (<= pos bound) *left-open-pos* (- pos n))
     57                                                 (if (<= pos bound) (current-left-open-pos) (- pos n))
    5858                                                 pos)))))
    5959                         (adjust-line-origins-forward line)
     
    9898               (modifying-line first-line start)
    9999               (let ((num (- last-charpos first-charpos)))
    100                  (setq *right-open-pos* (+ *right-open-pos* num))
     100                 (setf (current-right-open-pos) (+ (current-right-open-pos) num))
    101101                 ;; and fix up any marks in there:
    102102                 (move-some-marks (charpos first-line)
     
    177177                   (modifying-line first-line start)
    178178                   (let* ((num (- last-charpos first-charpos))
    179                           (new-right (+ *right-open-pos* num))
     179                          (new-right (+ (current-right-open-pos) num))
    180180                          (new-chars (make-string num))
    181181                          (new-line (make-line
     
    183183                                     :%buffer (incf *disembodied-buffer-counter*))))
    184184                     (declare (simple-string new-chars))
    185                      (%sp-byte-blt *open-chars* *right-open-pos* new-chars 0 num)
    186                      (setq *right-open-pos* new-right)
     185                     (%sp-byte-blt (current-open-chars) (current-right-open-pos) new-chars 0 num)
     186                     (setf (current-right-open-pos) new-right)
    187187                     ;; and fix up any marks in there:
    188188                     (move-some-marks (charpos first-line)
     
    278278    (cond
    279279     ((eq first-line last-line)
    280       (when (eq first-line *open-line*) (close-line))
     280      (when (current-open-line-p first-line) (close-line))
    281281      (let* ((length (- last-charpos first-charpos))
    282282             (chars (make-string length))
     
    355355      (modifying-line end-line end)
    356356      (cond ((eq start-line end-line)
    357              (let* ((res (fcs function (subseq *open-chars* first last)))
     357             (let* ((res (fcs function (subseq (current-open-chars) first last)))
    358358                    (rlen (length res))
    359359                    (new-left (+ first rlen))
    360                     (delta (- new-left *left-open-pos*)))
     360                    (delta (- new-left (current-left-open-pos))))
    361361               (declare (simple-string res))
    362                (when (> new-left *right-open-pos*)
    363                  (grow-open-chars (+ new-left *line-cache-length*)))
    364                (%sp-byte-blt res 0 *open-chars* first *left-open-pos*)
     362               (when (> new-left (current-right-open-pos))
     363                 (grow-open-chars (+ new-left (current-line-cache-length))))
     364               (%sp-byte-blt res 0 (current-open-chars) first (current-left-open-pos))
    365365               ;;
    366366               ;; Move marks to start or end of region, depending on kind.
     
    373373                                   new-left first)
    374374                               (+ charpos delta))))))
    375                (setq *left-open-pos* new-left)))
     375               (setf (current-left-open-pos) new-left)))
    376376            (t
    377377             ;;
     
    406406             ;;
    407407             ;; Do the last line, which is cached.
    408              (let* ((res (fcs function (subseq (the simple-string *open-chars*)
     408             (let* ((res (fcs function (subseq (the simple-string (current-open-chars))
    409409                                               0 last)))
    410410                    (rlen (length res))
    411411                    (delta (- rlen last)))
    412412               (declare (simple-string res))
    413                (when (> rlen *right-open-pos*)
    414                  (grow-open-chars (+ rlen *line-cache-length*)))
    415                (%sp-byte-blt res 0 *open-chars* 0 rlen)
    416                (setq *left-open-pos* rlen)
     413               (when (> rlen (current-right-open-pos))
     414                 (grow-open-chars (+ rlen (current-line-cache-length))))
     415               (%sp-byte-blt res 0 (current-open-chars) 0 rlen)
     416               (setf (current-left-open-pos) rlen)
    417417               ;;
    418418               ;; Adjust marks after the end of the region and save ones in it.
  • branches/ia32/cocoa-ide/hemlock/src/indent.lisp

    r7244 r7666  
    9191      (cond ((or (not p) (zerop p))
    9292             (funcall (value indent-function) mark)
    93              (move-mark point mark))
     93             (when (mark< point mark)
     94               (move-mark point mark)))
    9495            (t
    9596             (if (plusp p)
  • branches/ia32/cocoa-ide/hemlock/src/interp.lisp

    r7244 r7666  
    222222                              "~&Error while trying to bind key ~A: ~A~%"
    223223                              key condition)
    224                       (return-from bind-key nil))))
     224                      (return-from bind-key nil))))
    225225                (let ((cmd (getstring name *command-names*))
    226226                      (table (get-right-table kind where))
  • branches/ia32/cocoa-ide/hemlock/src/kbdmac.lisp

    r675 r7666  
    6767(defun trash-character ()
    6868  "Throw away a character on *editor-input*."
    69   (get-key-event *editor-input*))
     69  (get-key-event hi::*editor-input*))
    7070
    7171;;; Save-Kbdmac-Input  --  Internal
     
    304304            (let* ((stream (or *kbdmac-stream* (make-kbdmac-stream)))
    305305                   (*kbdmac-stream* nil)
    306                    (*editor-input* stream)
     306                   (hi::*editor-input* stream)
    307307                   (*in-a-keyboard-macro* t)
    308308                   (*kbdmac-done* nil)
     
    448448  (declare (ignore p))
    449449  (unless (or (interactive) *kbdmac-dont-ask*)
    450     (let ((*editor-input* *real-editor-input*))
     450    (let ((hi::*editor-input* *real-editor-input*))
    451451      (command-case (:prompt "Keyboard Macro Query: "
    452452                     :help "Type one of these characters to say what to do:"
     
    472472         (reprompt))
    473473        (t
    474          (unget-key-event key-event *editor-input*)
     474         (unget-key-event key-event hi::*editor-input*)
    475475         (throw 'exit-kbdmac nil))))))
  • branches/ia32/cocoa-ide/hemlock/src/key-event.lisp

    r7244 r7666  
    693693  (define-key-event-modifier "Lock" "Lock")
    694694
    695   #+clx (define-clx-modifier (xlib:make-state-mask :shift) "Shift")
    696   #+clx (define-clx-modifier (xlib:make-state-mask :mod-1) "Meta")
    697   #+clx (define-clx-modifier (xlib:make-state-mask :control) "Control")
    698   #+clx (define-clx-modifier (xlib:make-state-mask :lock) "Lock"))
     695)
    699696
    700697;;; Initialize stuff if not already initialized.
  • branches/ia32/cocoa-ide/hemlock/src/line.lisp

    r6611 r7666  
    137137(defmacro line-length* (line)
    138138  "Returns the number of characters on the line, but it's a macro!"
    139   `(cond ((eq ,line *open-line*)
    140           (+ *left-open-pos* (- *line-cache-length* *right-open-pos*)))
     139  `(cond ((current-open-line-p ,line)
     140          (+ (current-left-open-pos) (- (current-line-cache-length) (current-right-open-pos))))
    141141         (t
    142142          (length (the simple-string (line-%chars ,line))))))
  • branches/ia32/cocoa-ide/hemlock/src/linimage.lisp

    r6606 r7666  
    297297(defun compute-cached-line-image (index dis-line xpos width)
    298298  (declare (fixnum index width) (type (or fixnum null) xpos))
    299   (prog ((gap (- *right-open-pos* *left-open-pos*))
     299  (prog ((gap (- (current-right-open-pos) (current-left-open-pos)))
    300300         (dest (dis-line-chars dis-line))
    301          (done-p (= *right-open-pos* *line-cache-length*))
     301         (done-p (= (current-right-open-pos) (current-line-cache-length)))
    302302         (losing 0)
    303303         string underhang)
     
    310310     ((null xpos)
    311311      (update-and-punt dis-line width nil 0 index))
    312      ((>= index *left-open-pos*)
     312     ((>= index (current-left-open-pos))
    313313      (go RIGHT-START)))
    314     (setq losing (%fcwa *open-chars* index *left-open-pos* losing-char))
     314    (setq losing (%fcwa (current-open-chars) index (current-left-open-pos) losing-char))
    315315    (cond
    316316     (losing
    317       (display-some-chars *open-chars* index losing dest xpos width nil)
     317      (display-some-chars (current-open-chars) index losing dest xpos width nil)
    318318      ;; If we we didn't wrap then display some losers...
    319319      (if xpos
    320           (display-losing-chars *open-chars* index *left-open-pos* dest xpos
     320          (display-losing-chars (current-open-chars) index (current-left-open-pos) dest xpos
    321321                                width string underhang string-get-rep
    322                                 (and done-p (= index *left-open-pos*)))
     322                                (and done-p (= index (current-left-open-pos))))
    323323          (update-and-punt dis-line width nil 0 index)))
    324324     (t
    325       (display-some-chars *open-chars* index *left-open-pos* dest xpos width done-p)))
     325      (display-some-chars (current-open-chars) index (current-left-open-pos) dest xpos width done-p)))
    326326    (go LEFT-LOOP)
    327327
     
    334334     ((null xpos)
    335335      (update-and-punt dis-line width nil 0 (- index gap)))
    336      ((= index *line-cache-length*)
     336     ((= index (current-line-cache-length))
    337337      (update-and-punt dis-line xpos nil nil (- index gap))))
    338     (setq losing (%fcwa *open-chars* index *line-cache-length* losing-char))
     338    (setq losing (%fcwa (current-open-chars) index (current-line-cache-length) losing-char))
    339339    (cond
    340340     (losing
    341       (display-some-chars *open-chars* index losing dest xpos width nil)
     341      (display-some-chars (current-open-chars) index losing dest xpos width nil)
    342342      (cond
    343343       ;; Did we wrap?
     
    345345        (update-and-punt dis-line width nil 0 (- index gap)))
    346346       (t
    347         (display-losing-chars *open-chars* index *line-cache-length* dest xpos
     347        (display-losing-chars (current-open-chars) index (current-line-cache-length) dest xpos
    348348                              width string underhang string-get-rep))))
    349349     (t
    350       (display-some-chars *open-chars* index *line-cache-length* dest xpos width t)))
     350      (display-some-chars (current-open-chars) index (current-line-cache-length) dest xpos width t)))
    351351    (go RIGHT-LOOP)))
    352352
     
    442442                  (setq min charpos  min-mark m)))))
    443443          (unless min-mark (return nil))
    444           (let ((len (if (eq line *open-line*)
     444          (let ((len (if (current-open-line-p line)
    445445                         (cached-real-line-length line 10000 offset min)
    446446                         (real-line-length line 10000 offset min))))
     
    469469       ((null xpos)
    470470        (values string underhang offset))         
    471        ((eq line *open-line*)
     471       ((current-open-line-p line)
    472472        (compute-cached-line-image offset dis-line xpos width))
    473473       (t
    474474        (compute-normal-line-image line offset dis-line xpos width)))))
    475    ((eq line *open-line*)
     475   ((current-open-line-p line)
    476476    (compute-cached-line-image offset dis-line 0 width))
    477477   (t
  • branches/ia32/cocoa-ide/hemlock/src/lispmode.lisp

    r7244 r7666  
    881881(defindent "eval-when" 1)
    882882(defindent "flet" 1)
     883(defindent "if" 1)
    883884(defindent "labels" 1)
    884885(defindent "lambda" 1)
     
    969970(defindent "print-unreadable-object" 1)
    970971(defindent "defmethod" 2)
     972(defindent "make-instance" 1)
    971973
    972974;;; System forms.
    973975;;;
     976(defindent "rlet" 1)
    974977
    975978;;; Multiprocessing forms.
     
    18901893            (buffer-first-in-package-form buffer))))
    18911894
    1892 
    1893 
    1894    
     1895(defun buffer-package (buffer)
     1896  (when (hemlock-bound-p 'current-package :buffer buffer)
     1897    (let ((package-name (variable-value 'current-package :buffer buffer)))
     1898      (find-package package-name))))
     1899
    18951900(defun setup-lisp-mode (buffer)
    18961901  (unless (hemlock-bound-p 'current-package :buffer buffer)
     
    19791984                (return nil)))))))))
    19801985
     1986(hi:defcommand "Show Callers" (p)
     1987  "Display a scrolling list of the callers of the symbol at point.
     1988   Double-click a row to go to the caller's definition."
     1989  (declare (ignore p))
     1990  (with-mark ((mark1 (current-point))
     1991              (mark2 (current-point)))
     1992    (mark-symbol mark1 mark2)
     1993    (with-input-from-region (s (region mark1 mark2))
     1994      (let* ((symbol (read s)))
     1995        (make-instance 'ccl::sequence-window-controller
     1996          :sequence (ccl::callers symbol)
     1997          :title (format nil "Callers of ~a" symbol)
     1998          :result-callback #'(lambda (item)
     1999                               (get-def-info-and-go-to-it (symbol-name item)
     2000                                                          (symbol-package item))))))))
     2001
    19812002#||
    19822003(defcommand "Set Package Name" (p)
  • branches/ia32/cocoa-ide/hemlock/src/macros.lisp

    r6790 r7666  
    161161(defmacro defcommand (name lambda-list command-doc function-doc
    162162                           &body forms)
    163   "Defcommand Name Lambda-List Command-Doc Function-Doc {Declaration}* {Form}*
     163  "Defcommand Name Lambda-List Command-Doc [Function-Doc] {Declaration}* {Form}*
    164164
    165165  Define a new Hemlock command named Name.  Lambda-List becomes the
     
    182182
    183183  (unless (stringp function-doc)
    184     (error "Command function documentation is not a string: ~S."
    185                   function-doc))
     184    (setq forms (cons function-doc forms))
     185    (setq function-doc command-doc))
    186186  (when (atom lambda-list)
    187187    (error "Command argument list is not a list: ~S." lambda-list))
     
    600600  (throw 'editor-top-level-catcher nil))
    601601
    602 #+no
    603 (defun lisp-error-error-handler (condition &optional internalp)
    604   (invoke-debugger condition)
    605   (handler-bind ((editor-error #'(lambda (condx)
    606                                    (declare (ignore condx))
    607                                    (beep)
    608                                    (throw 'command-loop-catcher nil)))
    609                  (error #'(lambda (condition)
    610                             (declare (ignore condition))
    611                             (let ((device (device-hunk-device
    612                                            (window-hunk (current-window)))))
    613                               (funcall (device-exit device) device))
    614                             (invoke-debugger
    615                              (make-condition
    616                               'simple-condition
    617                               :format-control
    618                               "Error in error handler; Hemlock broken.")))))
    619     (princ condition)
    620     (clear-echo-area)
    621     (clear-editor-input *editor-input*)
    622     (beep)
    623     (if internalp (write-string "Internal error: " *echo-area-stream*))
    624     (princ condition *echo-area-stream*)
    625     (let* ((*editor-input* *real-editor-input*)
    626            (key-event (get-key-event *editor-input*)))
    627       (if (eq key-event #k"?")
    628           (loop
    629             (command-case (:prompt "Debug: "
    630                            :help
    631                            "Type one of the Hemlock debug command characters:")
    632               (#\d "Enter a break loop."
    633                (let ((device (device-hunk-device
    634                               (window-hunk (current-window)))))
    635                  (funcall (device-exit device) device)
    636                  (unwind-protect
    637                      (with-simple-restart
    638                          (continue "Return to Hemlock's debug loop.")
    639                        (invoke-debugger condition))
    640                    (funcall (device-init device) device))))
    641               #|| GB
    642               (#\b "Do a stack backtrace."
    643                  (with-pop-up-display (*debug-io* :height 100)
    644                  (debug:backtrace)))
    645               ||#
    646               (#\e "Show the error."
    647                (with-pop-up-display (*standard-output*)
    648                  (princ condition)))
    649               ((#\q :exit) "Throw back to Hemlock top-level."
    650                (throw 'editor-top-level-catcher nil))
    651               #||
    652               (#\r "Try to restart from this error."
    653                (let ((cases (compute-restarts)))
    654                  (declare (list cases))
    655                  (with-pop-up-display (s :height (1+ (length cases)))
    656                    (debug::show-restarts cases s))
    657                  (invoke-restart-interactively
    658                   (nth (prompt-for-integer :prompt "Restart number: ")
    659                        cases))))
    660               ||#
    661               ))
    662           (unget-key-event key-event *editor-input*))
    663       (throw 'editor-top-level-catcher nil))))
    664 
    665602(defmacro handle-lisp-errors (&body body)
    666603  "Handle-Lisp-Errors {Form}*
  • branches/ia32/cocoa-ide/hemlock/src/main.lisp

    r671 r7666  
    127127  (defhvar "Default Modes"
    128128    "This variable contains the default list of modes for new buffers."
    129     :value '("Fundamental" "Save"))
     129    :value '("Fundamental"))
    130130  (defhvar "Echo Area Height"
    131131    "Number of lines in the echo area window."
     
    260260         *after-editor-initializations-funs*))
    261261
    262 #+clx
    263 (defun cl-user::hemlock (&optional x
    264                          &key (init t)
    265                               (display (hemlock-ext:getenv "DISPLAY")))
    266   "Invokes the editor, Hemlock.  If X is supplied and is a symbol, the
    267    definition of X is put into a buffer, and that buffer is selected.  If X is
    268    a pathname, the file specified by X is visited in a new buffer.  If X is not
    269    supplied or Nil, the editor is entered in the same state as when last
    270    exited.  When :init is supplied as t (the default), the file
    271    \"hemlock-init.lisp\", or \".hemlock-init.lisp\" is loaded from the home
    272    directory, but the Lisp command line switch -hinit can be used to specify a
    273    different name.  Any compiled version of the source is preferred when
    274    choosing the file to load.  If the argument is non-nil and not t, then it
    275    should be a pathname that will be merged with the home directory."
    276   (when *in-the-editor* (error "You are already in the editor, you bogon!"))
    277   (let ((*in-the-editor* t)
    278         (display (unless *editor-has-been-entered*
    279                    (maybe-load-hemlock-init init)
    280                    ;; Device dependent initializaiton.
    281                    (init-raw-io display))))
    282     (catch 'editor-top-level-catcher
    283       (site-wrapper-macro
    284        (unless *editor-has-been-entered*
    285          ;; Make an initial window, and set up redisplay's internal
    286          ;; data structures.
    287          (%init-redisplay display)
    288          (setq *editor-has-been-entered* t)
    289          ;; Pick up user initializations to be done after initialization.
    290          (invoke-hook (reverse *after-editor-initializations-funs*)))
    291        (catch 'hemlock-exit
    292          (catch 'editor-top-level-catcher
    293            (cond ((and x (symbolp x))
    294                   (let* ((name (nstring-capitalize
    295                                 (concatenate 'simple-string "Edit " (string x))))
    296                          (buffer (or (getstring name *buffer-names*)
    297                                      (make-buffer name)))
    298                          (*print-case* :downcase))
    299                     (delete-region (buffer-region buffer))
    300                     (with-output-to-mark
    301                         (*standard-output* (buffer-point buffer))
    302                       (eval `(grindef ,x))      ; hackish, I know...
    303                       (terpri)
    304                       (hemlock::change-to-buffer buffer)
    305                       (buffer-start (buffer-point buffer)))))
    306                  ((or (stringp x) (pathnamep x))
    307                   (hemlock::find-file-command () x))
    308                  (x
    309                   (error
    310                    "~S is not a symbol or pathname.  I can't edit it!" x))))
    311          
    312          (invoke-hook hemlock::entry-hook)
    313          (unwind-protect
    314            (loop
    315             (catch 'editor-top-level-catcher
    316               (handler-bind ((error #'(lambda (condition)
    317                                         (lisp-error-error-handler condition
    318                                                                   :internal))))
    319                 (invoke-hook hemlock::abort-hook)
    320                 (%command-loop))))
    321            (invoke-hook hemlock::exit-hook)))))))
    322 
    323262(defun maybe-load-hemlock-init (init)
    324263  (when init
  • branches/ia32/cocoa-ide/hemlock/src/morecoms.lisp

    r7244 r7666  
    459459    (cond ((< x 2)
    460460           (loop
    461              (when (listen-editor-input *editor-input*) (return))
     461             (when (listen-editor-input hi::*editor-input*) (return))
    462462             (scroll-window window -1)
    463463             (redisplay)
     
    477477    (cond ((< x 2)
    478478           (loop
    479              (when (listen-editor-input *editor-input*) (return))
     479             (when (listen-editor-input hi::*editor-input*) (return))
    480480             (scroll-window window 1)
    481481             (redisplay)
  • branches/ia32/cocoa-ide/hemlock/src/package.lisp

    r7244 r7666  
    8787   #:buffer-windows
    8888   #:buffer-delete-hook
     89   #:buffer-package
    8990   #:delete-buffer
    9091   #:delete-buffer-if-possible
     
    180181   #:unshadow-attribute
    181182   #:find-attribute
     183   #:find-not-attribute
    182184   #:reverse-find-attribute
     185   #:reverse-find-not-attribute
    183186   #:character-attribute-hooks
    184187   #:current-window
     
    436439   ;; from input.lisp
    437440   #:get-key-event #:unget-key-event #:clear-editor-input #:listen-editor-input
    438    #:*last-key-event-typed* #:*key-event-history* #:*editor-input*
    439    #:*real-editor-input* #:input-waiting #:last-key-event-cursorpos
     441   #:*last-key-event-typed* #:*key-event-history*
     442   #:input-waiting #:last-key-event-cursorpos
    440443
    441444   ;; from macros.lisp
  • branches/ia32/cocoa-ide/hemlock/src/rompsite.lisp

    r6790 r7666  
    1515
    1616(in-package :hi)
    17 
    18 ;;; WITHOUT-HEMLOCK -- Public.
    19 ;;;
    20 ;;; Code:lispinit.lisp uses this for a couple interrupt handlers, and
    21 ;;; eval-server.lisp.
    22 ;;;
    23 #+CMU
    24 (defmacro without-hemlock (&body body)
    25   "When in the editor and not in the debugger, call the exit method of Hemlock's
    26    device, so we can type.  Do the same thing on exit but call the init method."
    27   `(progn
    28      (when (and *in-the-editor* (not debug::*in-the-debugger*))
    29        (let ((device (device-hunk-device (window-hunk (current-window)))))
    30          (funcall (device-exit device) device)))
    31      ,@body
    32      (when (and *in-the-editor* (not debug::*in-the-debugger*))
    33        (let ((device (device-hunk-device (window-hunk (current-window)))))
    34          (funcall (device-init device) device)))))
    35 #-CMU
    36 (defmacro without-hemlock (&body body)
    37   "When in the editor and not in the debugger, call the exit method of Hemlock's
    38    device, so we can type.  Do the same thing on exit but call the init method."
    39   `(progn
    40      (when (and *in-the-editor* )
    41        (let ((device (device-hunk-device (window-hunk (current-window)))))
    42          (funcall (device-exit device) device)))
    43      ,@body
    44      (when (and *in-the-editor* )
    45        (let ((device (device-hunk-device (window-hunk (current-window)))))
    46          (funcall (device-init device) device)))))
    47 
    48 
    49 
    5017
    5118;;;; SITE-INIT.
     
    9865    #+clx
    9966    :hooks #+clx '(reverse-video-hook-fun))
    100   #+clx
    101   (defhvar "Cursor Bitmap File"
    102     "File to read to setup cursors for Hemlock windows.  The mask is found by
    103      merging this name with \".mask\"."
    104     :value (make-pathname :name "hemlock11" :type "cursor"
    105                           :defaults hemlock-system:*hemlock-base-directory*))
    10667  (defhvar "Enter Window Hook"
    10768    "When the mouse enters an editor window, this hook is invoked.  These
     
    176137(defvar *editor-file-descriptor*)
    177138
    178 
    179 ;;; This is a hack, so screen can tell how to initialize screen management
    180 ;;; without re-opening the display.  It is set in INIT-RAW-IO and referenced
    181 ;;; in WINDOWED-MONITOR-P.
    182 ;;;
    183 (defvar *editor-windowed-input* nil)
    184 
    185 ;;; These are used for selecting X events.
    186 #+clx
    187 (eval-when (:compile-toplevel :load-toplevel :execute)
    188   (defvar group-interesting-xevents
    189     '(:structure-notify)))
    190 #+clx
    191 (defvar group-interesting-xevents-mask
    192   (apply #'xlib:make-event-mask group-interesting-xevents))
    193 
    194 #+clx
    195 (eval-when (:compile-toplevel :load-toplevel :execute)
    196   (defvar child-interesting-xevents
    197     '(:key-press :button-press :button-release :structure-notify :exposure
    198                  :enter-window :leave-window)))
    199 #+clx
    200 (defvar child-interesting-xevents-mask
    201   (apply #'xlib:make-event-mask child-interesting-xevents))
    202 
    203 #+clx
    204 (eval-when (:compile-toplevel :load-toplevel :execute)
    205   (defvar random-typeout-xevents
    206     '(:key-press :button-press :button-release :enter-window :leave-window
    207                  :exposure)))
    208 #+clx
    209 (defvar random-typeout-xevents-mask
    210   (apply #'xlib:make-event-mask random-typeout-xevents))
    211 
    212 
    213 #+clx
    214 (declaim (special hemlock::*open-paren-highlight-font*
    215                   hemlock::*active-region-highlight-font*))
    216 
    217 #+clx
    218 (defparameter lisp-fonts-pathnames '("fonts/"))
    219 
    220139(declaim (special *editor-input* *real-editor-input*))
    221140
    222 (declaim (special *editor-input* *real-editor-input*))
    223 
    224 ;;; INIT-RAW-IO  --  Internal
    225 ;;;
    226 ;;;    This function should be called whenever the editor is entered in a new
    227 ;;; lisp.  It sets up process specific data structures.
    228 ;;;
    229 #+clx
    230 (defun init-raw-io (display)
    231   #-clx (declare (ignore display))
    232   (setf *editor-windowed-input* nil)
    233   (cond #+clx
    234         (display
    235          (setf *editor-windowed-input*
    236                #+(or CMU scl) (ext:open-clx-display display)
    237                #+(or sbcl openmcl)  (xlib::open-default-display #+nil display)
    238                #-(or sbcl CMU scl openmcl) (xlib:open-display "localhost"))
    239          (setf *editor-input* (make-windowed-editor-input))
    240          (setup-font-family *editor-windowed-input*))
    241         (t ;; The editor's file descriptor is Unix standard input (0).
    242            ;; We don't need to affect system:*file-input-handlers* here
    243            ;; because the init and exit methods for tty redisplay devices
    244            ;; take care of this.
    245            ;;
    246          (setf *editor-file-descriptor* 0)
    247          (setf *editor-input* (make-tty-editor-input 0))))
    248   (setf *real-editor-input* *editor-input*)
    249   *editor-windowed-input*)
    250 
    251 ;;; Stop flaming from compiler due to CLX macros expanding into illegal
    252 ;;; declarations.
    253 ;;;
    254141(declaim (declaration values))
    255142(declaim (special *default-font-family*))
     
    258145;;; assume it to be special, issuing a nasty warning.
    259146;;;
    260 #+clx
    261 (defconstant font-map-size 16
    262   "The number of possible fonts in a font-map.")
    263 #-clx
    264147(defconstant font-map-size 32)
    265148
    266 ;;; SETUP-FONT-FAMILY sets *default-font-family*, opening the three font names
    267 ;;; passed in.  The font family structure is filled in from the first argument.
    268 ;;; Actually, this ignores default-highlight-font and default-open-paren-font
    269 ;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting
    270 ;;; Font" when these are defined.
    271 ;;;
    272 #+clx
    273 (defun setup-font-family (display)
    274   (let* ((font-family (make-font-family :map (make-array font-map-size
    275                                                          :initial-element 0)
    276                                         :cursor-x-offset 0
    277                                         :cursor-y-offset 0))
    278          (font-family-map (font-family-map font-family)))
    279     (declare (simple-vector font-family-map))
    280     (setf *default-font-family* font-family)
    281     (let ((font (xlib:open-font display (variable-value 'hemlock::default-font))))
    282       (unless font
    283         (error "Cannot open font -- ~S" (variable-value 'hemlock::default-font)))
    284       (fill font-family-map font)
    285       (let ((width (xlib:max-char-width font)))
    286         (setf (font-family-width font-family) width)
    287         (setf (font-family-cursor-width font-family) width))
    288       (let* ((baseline (xlib:font-ascent font))
    289              (height (+ baseline (xlib:font-descent font))))
    290         (setf (font-family-height font-family) height)
    291         (setf (font-family-cursor-height font-family) height)
    292         (setf (font-family-baseline font-family) baseline)))
    293     (setup-one-font display
    294                     (variable-value 'hemlock::open-paren-highlighting-font)
    295                     font-family-map
    296                     hemlock::*open-paren-highlight-font*)
    297     (setup-one-font display
    298                     (variable-value 'hemlock::active-region-highlighting-font)
    299                     font-family-map
    300                     hemlock::*active-region-highlight-font*)
    301     ;; GB
    302     (setup-one-font display
    303                     "-*-lucidatypewriter-medium-r-*-*-*-120-*-*-*-*-iso8859-1"
    304                     font-family-map
    305                     7)))
    306 
    307 ;;; SETUP-ONE-FONT tries to open font-name for display, storing the result in
    308 ;;; font-family-map at index.  XLIB:OPEN-FONT will return font stuff regardless
    309 ;;; if the request is valid or not, so we finish the output to get synch'ed
    310 ;;; with the server which will cause any errors to get signaled.  At this
    311 ;;; level, we want to deal with this error here returning nil if the font
    312 ;;; couldn't be opened.
    313 ;;;
    314 #+clx
    315 (defun setup-one-font (display font-name font-family-map index)
    316   (handler-case (let ((font (xlib:open-font display (namestring font-name))))
    317                   (xlib:display-finish-output display)
    318                   (setf (svref font-family-map index) font))
    319     (xlib:name-error ()
    320      (warn "Cannot open font -- ~S" font-name)
    321      nil)))
    322 
    323149
    324150
    325151;;;; HEMLOCK-BEEP.
    326152
    327 (defvar *editor-bell* (make-string 1 :initial-element #\bell))
    328 
    329 ;;; TTY-BEEP is used in Hemlock for beeping when running under a terminal.
    330 ;;; Send a #\bell to unix standard output.
    331 ;;;
    332 #+NIL
    333 (defun tty-beep (&optional device stream)
    334   (declare (ignore device stream))
    335   (when (variable-value 'hemlock::bell-style)
    336     (unix:unix-write 1 *editor-bell* 0 1)))
    337 
    338 (declaim (special *current-window*))
    339 
    340 ;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed
    341 ;;; input.
    342 ;;;
    343 #+clx
    344 (defun bitmap-beep (device stream)
    345   (declare (ignore stream))
    346   (let ((display (bitmap-device-display device)))
    347     (ecase (variable-value 'hemlock::bell-style)
    348       (:border-flash
    349        (flash-window-border *current-window*))
    350       (:feep
    351        (xlib:bell display)
    352        (xlib:display-force-output display))
    353       (:border-flash-and-feep
    354        (xlib:bell display)
    355        (xlib:display-force-output display)
    356        (flash-window-border *current-window*))
    357       (:flash
    358        (flash-window *current-window*))
    359       (:flash-and-feep
    360        (xlib:bell display)
    361        (xlib:display-force-output display)
    362        (flash-window *current-window*))
    363       ((nil) ;Do nothing.
    364        ))))
    365 
    366 #+clx
    367 (declaim (special *foreground-background-xor*))
    368 
    369 #+clx
    370 (defun flash-window-border (window)
    371   (let* ((hunk (window-hunk window))
    372          (xwin (bitmap-hunk-xwindow hunk))
    373          (gcontext (bitmap-hunk-gcontext hunk))
    374          (display (bitmap-device-display (device-hunk-device hunk)))
    375          (border (variable-value 'hemlock::beep-border-width))
    376          (h (or (bitmap-hunk-modeline-pos hunk) (bitmap-hunk-height hunk)))
    377          (top-border (min (ash h -1) border))
    378          (w (bitmap-hunk-width hunk))
    379          (side-border (min (ash w -1) border))
    380          (top-width (max 0 (- w (ash side-border 1))))
    381          (right-x (- w side-border))
    382          (bottom-y (- h top-border)))
    383     (xlib:with-gcontext (gcontext :function xlib::boole-xor
    384                                   :foreground *foreground-background-xor*)
    385       (flet ((zot ()
    386                (xlib:draw-rectangle xwin gcontext 0 0 side-border h t)
    387                (xlib:draw-rectangle xwin gcontext side-border bottom-y
    388                                     top-width top-border t)
    389                (xlib:draw-rectangle xwin gcontext right-x 0 side-border h t)
    390                (xlib:draw-rectangle xwin gcontext side-border 0
    391                                     top-width top-border t)))
    392         (zot)
    393         (xlib:display-force-output display)
    394         (sleep 0.1)
    395         (zot)
    396         (xlib:display-force-output display)))))
    397 
    398 #+clx
    399 (defun flash-window (window)
    400   (let* ((hunk (window-hunk window))
    401          (xwin (bitmap-hunk-xwindow hunk))
    402          (gcontext (bitmap-hunk-gcontext hunk))
    403          (display (bitmap-device-display (device-hunk-device hunk)))
    404          (width (bitmap-hunk-width hunk))
    405          (height (or (bitmap-hunk-modeline-pos hunk)
    406                      (bitmap-hunk-height hunk))))
    407     (xlib:with-gcontext (gcontext :function xlib::boole-xor
    408                                   :foreground *foreground-background-xor*)
    409       (xlib:draw-rectangle xwin gcontext 0 0 width height t)
    410       (xlib:display-force-output display)
    411       (sleep 0.1)
    412       (xlib:draw-rectangle xwin gcontext 0 0 width height t)
    413       (xlib:display-force-output display))))
    414 
    415 (defun hemlock-beep (stream)
    416   "Using the current window, calls the device's beep function on stream."
    417   (let ((device (device-hunk-device (window-hunk (current-window)))))
    418     (funcall (device-beep device) device stream)))
    419 
    420 
    421 ;;; *BEEP-FUNCTION* and BEEP are in SYSTEM package in CMUCL.
    422 ;;;
    423153(defvar *beep-function* #'(lambda () (print "BEEP!")))
    424154
    425155(defun beep (&optional (stream *terminal-io*))
    426156  (funcall *beep-function* stream))
    427 
    428 
    429 
    430 ;;;; GC messages.
    431 
    432 ;;; HEMLOCK-GC-NOTIFY-BEFORE and HEMLOCK-GC-NOTIFY-AFTER both MESSAGE GC
    433 ;;; notifications when Hemlock is not running under X11.  It cannot affect
    434 ;;; its window's without using its display connection.  Since GC can occur
    435 ;;; inside CLX request functions, using the same display confuses CLX.
    436 ;;;
    437 
    438 (defun hemlock-gc-notify-before (bytes-in-use)
    439   (let ((control "~%[GC threshold exceeded with ~:D bytes in use.  ~
    440                   Commencing GC.]~%"))
    441     (cond ((not hi::*editor-windowed-input*)
    442            (beep)
    443            #|(message control bytes-in-use)|#)
    444           (t
    445            ;; Can't call BEEP since it would use Hemlock's display connection.
    446            #+nil (lisp::default-beep-function *standard-output*)
    447            (format t control bytes-in-use)
    448            (finish-output)))))
    449 
    450 (defun hemlock-gc-notify-after (bytes-retained bytes-freed trigger)
    451   (let ((control
    452          "[GC completed with ~:D bytes retained and ~:D bytes freed.]~%~
    453           [GC will next occur when at least ~:D bytes are in use.]~%"))
    454     (cond ((not hi::*editor-windowed-input*)
    455            (beep)
    456            #|(message control bytes-retained bytes-freed)|#)
    457           (t
    458            ;; Can't call BEEP since it would use Hemlock's display connection.
    459            #+nil (lisp::default-beep-function *standard-output*)
    460            (format t control bytes-retained bytes-freed trigger)
    461            (finish-output)))))
    462 
    463 
    464 
    465 
    466 ;;;; Site-Wrapper-Macro and standard device init/exit functions.
    467 
    468 (defun in-hemlock-standard-input-read (stream &rest ignore)
    469   (declare (ignore ignore))
    470   (error "You cannot read off this stream while in Hemlock -- ~S"
    471          stream))
    472 
    473 (defvar *illegal-read-stream*
    474   #+CMU (lisp::make-lisp-stream :in #'in-hemlock-standard-input-read)
    475   #-CMU (make-broadcast-stream))
    476 
    477 (defmacro site-wrapper-macro (&body body)
    478   `(unwind-protect
    479      (progn
    480        (when *editor-has-been-entered*
    481          (let ((device (device-hunk-device (window-hunk (current-window)))))
    482            (funcall (device-init device) device)))
    483        (let ((*beep-function* #'hemlock-beep)
    484              (*gc-notify-before* #'hemlock-gc-notify-before)
    485              (*gc-notify-after* #'hemlock-gc-notify-after)
    486              (*standard-input* *illegal-read-stream*)
    487              (*query-io* *illegal-read-stream*))
    488          (cond ((not *editor-windowed-input*)
    489                 ,@body)
    490                (t
    491                 #+clx
    492                 (hemlock-ext:with-clx-event-handling
    493                     (*editor-windowed-input* #'hemlock-ext:object-set-event-handler)
    494                   ,@body)))))
    495      (let ((device (device-hunk-device (window-hunk (current-window)))))
    496        (funcall (device-exit device) device))))
    497 
    498 
    499 
    500 (declaim (special *echo-area-window*))
    501 
    502 ;;; Maybe bury/unbury hemlock window when we go to and from Lisp.
    503 ;;; This should do something more sophisticated when we know what that is.
    504 ;;;
    505 #+clx
    506 (defun default-hemlock-window-mngt (display on)
    507   (let ((xparent (window-group-xparent
    508                   (bitmap-hunk-window-group (window-hunk *current-window*))))
    509         (echo-xparent (window-group-xparent
    510                        (bitmap-hunk-window-group
    511                         (window-hunk *echo-area-window*)))))
    512     (cond (on (setf (xlib:window-priority echo-xparent) :above)
    513               (clear-editor-input *editor-input*)
    514               (setf (xlib:window-priority xparent) :above))
    515           (t (setf (xlib:window-priority echo-xparent) :below)
    516              (setf (xlib:window-priority xparent) :below))))
    517   (xlib:display-force-output display))
    518 
    519 (defvar *hemlock-window-mngt* nil;#'default-hemlock-window-mngt
    520   "This function is called by HEMLOCK-WINDOW, passing its arguments.  This may
    521    be nil.")
    522 
    523 (defun hemlock-window (display on)
    524   "Calls *hemlock-window-mngt* on the argument ON when *current-window* is
    525   bound.  This is called in the device init and exit methods for X bitmap
    526   devices."
    527   (when (and *hemlock-window-mngt* *current-window*)
    528     (funcall *hemlock-window-mngt* display on)))
    529 
    530157
    531158
     
    662289(defun sleep-for-time (time)
    663290  (timed-wait-for-key-event *editor-input* time))
    664 
    665 
    666 
    667 
    668 ;;;; Showing a mark.
    669 
    670 
    671 
    672 
    673 
    674 #+clx
    675 (defun bitmap-show-mark (window x y time)
    676   (cond ((listen-editor-input *editor-input*))
    677         (x (let* ((hunk (window-hunk window))
    678                   (display (bitmap-device-display (device-hunk-device hunk))))
    679              (internal-redisplay)
    680              (hunk-show-cursor hunk x y)
    681              (drop-cursor)
    682              (xlib:display-finish-output display)
    683              (sleep-for-time time)
    684              (lift-cursor)
    685              t))
    686         (t nil)))
    687291
    688292
     
    758362          (write-string doc *standard-output*))))
    759363
    760 
    761 
    762 
    763 
    764 
    765 ;;;; X Stuff.
    766 ;;; Setting window cursors ...
    767 ;;;
    768 
    769 #+clx
    770 (declaim (special *default-foreground-pixel* *default-background-pixel*))
    771 
    772 #+clx
    773 (defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.")
    774 
    775 ;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook".
    776 ;;;
    777 #+clx
    778 (defun define-window-cursor (window)
    779   (setf (xlib:window-cursor (bitmap-hunk-xwindow (window-hunk window)))
    780         *hemlock-cursor*))
    781 
    782 ;;; These are set in INIT-BITMAP-SCREEN-MANAGER and REVERSE-VIDEO-HOOK-FUN.
    783 ;;;
    784 #+clx
    785 (defvar *cursor-foreground-color* nil)
    786 #+clx
    787 (defvar *cursor-background-color* nil)
    788 #+clx
    789 (defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0))
    790 #+clx
    791 (defun make-black-color () (xlib:make-color :red 0.0 :green 0.0 :blue 0.0))
    792 
    793 
    794 ;;; GET-HEMLOCK-CURSOR is used in INIT-BITMAP-SCREEN-MANAGER to load the
    795 ;;; hemlock cursor for DEFINE-WINDOW-CURSOR.
    796 ;;;
    797 #+clx
    798 (defun get-hemlock-cursor (display)
    799   (when *hemlock-cursor* (xlib:free-cursor *hemlock-cursor*))
    800   (let* ((cursor-file (truename (variable-value 'hemlock::cursor-bitmap-file)))
    801          (mask-file (probe-file (make-pathname :type "mask"
    802                                                :defaults cursor-file)))
    803          (root (xlib:screen-root (xlib:display-default-screen display)))
    804          (mask-pixmap (if mask-file (get-cursor-pixmap root mask-file))))
    805     (multiple-value-bind (cursor-pixmap cursor-x-hot cursor-y-hot)
    806                          (get-cursor-pixmap root cursor-file)
    807       (setf *hemlock-cursor*
    808             (xlib:create-cursor :source cursor-pixmap :mask mask-pixmap
    809                                 :x cursor-x-hot :y cursor-y-hot
    810                                 :foreground *cursor-foreground-color*
    811                                 :background *cursor-background-color*))
    812       (xlib:free-pixmap cursor-pixmap)
    813       (when mask-pixmap (xlib:free-pixmap mask-pixmap)))))
    814 
    815 #+clx
    816 (defun get-cursor-pixmap (root pathname)
    817   (let* ((image (xlib:read-bitmap-file pathname))
    818          (pixmap (xlib:create-pixmap :width 16 :height 16
    819                                      :depth 1 :drawable root))
    820          (gc (xlib:create-gcontext
    821               :drawable pixmap :function boole-1
    822               :foreground *default-foreground-pixel*
    823               :background *default-background-pixel*)))
    824     (xlib:put-image pixmap gc image :x 0 :y 0 :width 16 :height 16)
    825     (xlib:free-gcontext gc)
    826     (values pixmap (xlib:image-x-hot image) (xlib:image-y-hot image))))
    827 
    828 
    829 ;;; Setting up grey borders ...
    830 ;;;
    831 
    832 #+clx
    833 (defparameter hemlock-grey-bitmap-data
    834   '(#*10 #*01))
    835 
    836 #+clx
    837 (defun get-hemlock-grey-pixmap (display)
    838   (let* ((screen (xlib:display-default-screen display))
    839          (depth (xlib:screen-root-depth screen))
    840          (root (xlib:screen-root screen))
    841          (height (length hemlock-grey-bitmap-data))
    842          (width (length (car hemlock-grey-bitmap-data)))
    843          (image (apply #'xlib:bitmap-image hemlock-grey-bitmap-data))
    844          (pixmap (xlib:create-pixmap :width width :height height
    845                                      :depth depth :drawable root))
    846          (gc (xlib:create-gcontext :drawable pixmap
    847                                    :function boole-1
    848                                    :foreground *default-foreground-pixel*
    849                                    :background *default-background-pixel*)))
    850     (xlib:put-image pixmap gc image
    851                     :x 0 :y 0 :width width :height height :bitmap-p t)
    852     (xlib:free-gcontext gc)
    853     pixmap))
    854 
    855 
    856 ;;; Cut Buffer manipulation ...
    857 ;;;
    858 
    859 #+clx
    860 (defun store-cut-string (display string)
    861   (check-type string simple-string)
    862   (setf (xlib:cut-buffer display) string))
    863 
    864 #+clx
    865 (defun fetch-cut-string (display)
    866   (xlib:cut-buffer display))
    867 
    868 
    869 ;;; Window naming ...
    870 ;;;
    871 #+clx
    872 (defun set-window-name-for-buffer-name (buffer new-name)
    873   (dolist (ele (buffer-windows buffer))
    874     (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk ele))
    875                                   :icon-name new-name)))
    876  
    877 #+clx
    878 (defun set-window-name-for-window-buffer (window new-buffer)
    879   (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window))
    880                                 :icon-name (buffer-name new-buffer)))
    881 
    882 
    883 
    884 ;;;; Some hacks for supporting Hemlock under Mach.
    885 
    886 ;;; WINDOWED-MONITOR-P is used by the reverse video variable's hook function
    887 ;;; to determine if it needs to go around fixing all the windows.
    888 ;;;
    889 (defun windowed-monitor-p ()
    890   "This returns whether the monitor is being used with a window system.  It
    891    returns the console's CLX display structure."
    892   *editor-windowed-input*)
    893 
    894 #||
    895 (defun get-terminal-name ()
    896   (cdr (assoc :term *environment-list* :test #'eq)))
    897 
    898 (defun get-termcap-env-var ()
    899   (cdr (assoc :termcap *environment-list* :test #'eq)))
    900 
    901 
    902 ;;; GET-EDITOR-TTY-INPUT reads from stream's Unix file descriptor queuing events
    903 ;;; in the stream's queue.
    904 ;;;
    905 (defun get-editor-tty-input (fd)
    906   (alien:with-alien ((buf (alien:array c-call:unsigned-char 256)))
    907     (multiple-value-bind
    908         (len errno)
    909         (unix:unix-read fd (alien:alien-sap buf) 256)
    910       (declare (type (or null fixnum) len))
    911       (unless len
    912         (error "Problem with tty input: ~S"
    913                (unix:get-unix-error-msg errno)))
    914       (dotimes (i len t)
    915         (q-event *real-editor-input*
    916                  (hemlock-ext:char-key-event (code-char (alien:deref buf i))))))))
    917 
    918 #+NIL
    919 (defun editor-tty-listen (stream)
    920   (alien:with-alien ((nc c-call:int))
    921     (and (unix:unix-ioctl (tty-editor-input-fd stream)
    922                           unix::FIONREAD
    923                           (alien:alien-sap (alien:addr nc)))
    924          (> nc 0))))
    925 ||#
    926 
    927 #||
    928 (defvar old-flags)
    929 
    930 (defvar old-tchars)
    931 
    932 #-glibc2
    933 (defvar old-ltchars)
    934 
    935 #+(or hpux irix bsd glibc2)
    936 (progn
    937   (defvar old-c-iflag)
    938   (defvar old-c-oflag)
    939   (defvar old-c-cflag)
    940   (defvar old-c-lflag)
    941   (defvar old-c-cc))
    942 
    943 (defun setup-input ()
    944   (let ((fd *editor-file-descriptor*))
    945     (when (unix:unix-isatty 0)
    946       #+(or hpux irix bsd glibc2)
    947       (alien:with-alien ((tios (alien:struct unix:termios)))
    948         (multiple-value-bind
    949             (val err)
    950             (unix:unix-tcgetattr fd (alien:alien-sap tios))
    951           (when (null val)
    952             (error "Could not tcgetattr, unix error ~S."
    953                    (unix:get-unix-error-msg err))))
    954         (setf old-c-iflag (alien:slot tios 'unix:c-iflag))
    955         (setf old-c-oflag (alien:slot tios 'unix:c-oflag))
    956         (setf old-c-cflag (alien:slot tios 'unix:c-cflag))
    957         (setf old-c-lflag (alien:slot tios 'unix:c-lflag))
    958         (setf old-c-cc
    959               (vector (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp)
    960                       (alien:deref (alien:slot tios 'unix:c-cc) unix:veof)
    961                       (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr)
    962                       (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit)
    963                       (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart)
    964                       (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop)
    965                       (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp)
    966                       (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin)
    967                       (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime)))
    968         (setf (alien:slot tios 'unix:c-lflag)
    969               (logand (alien:slot tios 'unix:c-lflag)
    970                       (lognot (logior unix:tty-echo unix:tty-icanon))))
    971         (setf (alien:slot tios 'unix:c-iflag)
    972               (logand (alien:slot tios 'unix:c-iflag)
    973                       (lognot (logior unix:tty-icrnl unix:tty-ixon))))
    974         (setf (alien:slot tios 'unix:c-oflag)
    975               (logand (alien:slot tios 'unix:c-oflag)
    976                       (lognot #-bsd unix:tty-ocrnl
    977                               #+bsd unix:tty-onlcr)))
    978         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp) #xff)
    979         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:veof) #xff)
    980         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr)
    981               (if *editor-windowed-input* #xff 28))
    982         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit) #xff)
    983         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart) #xff)
    984         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop) #xff)
    985         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp) #xff)
    986         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin) 1)
    987         (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime) 0)
    988         (multiple-value-bind
    989             (val err)
    990             (unix:unix-tcsetattr fd unix:tcsaflush (alien:alien-sap tios))
    991           (when (null val)
    992             (error "Could not tcsetattr, unix error ~S."
    993                    (unix:get-unix-error-msg err)))))
    994       #-(or hpux irix bsd glibc2)
    995       (alien:with-alien ((sg (alien:struct unix:sgttyb)))
    996         (multiple-value-bind
    997             (val err)
    998             (unix:unix-ioctl fd unix:TIOCGETP (alien:alien-sap sg))
    999           (unless val
    1000             (error "Could not get tty information, unix error ~S."
    1001                    (unix:get-unix-error-msg err))))
    1002         (let ((flags (alien:slot sg 'unix:sg-flags)))
    1003           (setq old-flags flags)
    1004           (setf (alien:slot sg 'unix:sg-flags)
    1005                 (logand #-(or hpux irix bsd glibc2) (logior flags unix:tty-cbreak)
    1006                         (lognot unix:tty-echo)
    1007                         (lognot unix:tty-crmod)))
    1008           (multiple-value-bind
    1009               (val err)
    1010               (unix:unix-ioctl fd unix:TIOCSETP (alien:alien-sap sg))
    1011             (if (null val)
    1012                 (error "Could not set tty information, unix error ~S."
    1013                        (unix:get-unix-error-msg err))))))
    1014       #-(or hpux irix bsd glibc2)
    1015       (alien:with-alien ((tc (alien:struct unix:tchars)))
    1016         (multiple-value-bind
    1017             (val err)
    1018             (unix:unix-ioctl fd unix:TIOCGETC (alien:alien-sap tc))
    1019           (unless val
    1020             (error "Could not get tty tchars information, unix error ~S."
    1021                    (unix:get-unix-error-msg err))))
    1022         (setq old-tchars
    1023               (vector (alien:slot tc 'unix:t-intrc)
    1024                       (alien:slot tc 'unix:t-quitc)
    1025                       (alien:slot tc 'unix:t-startc)
    1026                       (alien:slot tc 'unix:t-stopc)
    1027                       (alien:slot tc 'unix:t-eofc)
    1028                       (alien:slot tc 'unix:t-brkc)))
    1029         (setf (alien:slot tc 'unix:t-intrc)
    1030               (if *editor-windowed-input* -1 28))
    1031         (setf (alien:slot tc 'unix:t-quitc) -1)
    1032         (setf (alien:slot tc 'unix:t-startc) -1)
    1033         (setf (alien:slot tc 'unix:t-stopc) -1)
    1034         (setf (alien:slot tc 'unix:t-eofc) -1)
    1035         (setf (alien:slot tc 'unix:t-brkc) -1)
    1036         (multiple-value-bind
    1037             (val err)
    1038             (unix:unix-ioctl fd unix:TIOCSETC (alien:alien-sap tc))
    1039           (unless val
    1040             (error "Failed to set tchars, unix error ~S."
    1041                    (unix:get-unix-error-msg err)))))
    1042 
    1043       ;; Needed even under HpUx to suppress dsuspc.
    1044       #-(or glibc2 irix)
    1045       (alien:with-alien ((tc (alien:struct unix:ltchars)))
    1046         (multiple-value-bind
    1047             (val err)
    1048             (unix:unix-ioctl fd unix:TIOCGLTC (alien:alien-sap tc))
    1049           (unless val
    1050             (error "Could not get tty ltchars information, unix error ~S."
    1051                    (unix:get-unix-error-msg err))))
    1052         (setq old-ltchars
    1053               (vector (alien:slot tc 'unix:t-suspc)
    1054                       (alien:slot tc 'unix:t-dsuspc)
    1055                       (alien:slot tc 'unix:t-rprntc)
    1056                       (alien:slot tc 'unix:t-flushc)
    1057                       (alien:slot tc 'unix:t-werasc)
    1058                       (alien:slot tc 'unix:t-lnextc)))
    1059         (setf (alien:slot tc 'unix:t-suspc) -1)
    1060         (setf (alien:slot tc 'unix:t-dsuspc) -1)
    1061         (setf (alien:slot tc 'unix:t-rprntc) -1)
    1062         (setf (alien:slot tc 'unix:t-flushc) -1)
    1063         (setf (alien:slot tc 'unix:t-werasc) -1)
    1064         (setf (alien:slot tc 'unix:t-lnextc) -1)
    1065         (multiple-value-bind
    1066             (val err)
    1067             (unix:unix-ioctl fd unix:TIOCSLTC (alien:alien-sap tc))
    1068           (unless val
    1069             (error "Failed to set ltchars, unix error ~S."
    1070                    (unix:get-unix-error-msg err))))))))
    1071 
    1072 (defun reset-input ()
    1073   (when (unix:unix-isatty 0)
    1074     (let ((fd *editor-file-descriptor*))
    1075       #+(or hpux irix bsd glibc2)
    1076       (when (boundp 'old-c-lflag)
    1077         (alien:with-alien ((tios (alien:struct unix:termios)))
    1078           (multiple-value-bind
    1079               (val err)
    1080               (unix:unix-tcgetattr fd (alien:alien-sap tios))
    1081             (when (null val)
    1082               (error "Could not tcgetattr, unix error ~S."
    1083                      (unix:get-unix-error-msg err))))
    1084           (setf (alien:slot tios 'unix:c-iflag) old-c-iflag)
    1085           (setf (alien:slot tios 'unix:c-oflag) old-c-oflag)
    1086           (setf (alien:slot tios 'unix:c-cflag) old-c-cflag)
    1087           (setf (alien:slot tios 'unix:c-lflag) old-c-lflag)
    1088           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp)
    1089                 (svref old-c-cc 0))
    1090           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:veof)
    1091                 (svref old-c-cc 1))
    1092           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr)
    1093                 (svref old-c-cc 2))
    1094           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit)
    1095                 (svref old-c-cc 3))
    1096           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart)
    1097                 (svref old-c-cc 4))
    1098           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop)
    1099                 (svref old-c-cc 5))
    1100           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp)
    1101                 (svref old-c-cc 6))
    1102           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin)
    1103                 (svref old-c-cc 7))
    1104           (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime)
    1105                 (svref old-c-cc 8))
    1106           (multiple-value-bind
    1107               (val err)
    1108               (unix:unix-tcsetattr fd unix:tcsaflush (alien:alien-sap tios))
    1109             (when (null val)
    1110               (error "Could not tcsetattr, unix error ~S."
    1111                      (unix:get-unix-error-msg err))))))
    1112       #-(or hpux irix bsd glibc2)
    1113       (when (boundp 'old-flags)
    1114         (alien:with-alien ((sg (alien:struct unix:sgttyb)))
    1115           (multiple-value-bind
    1116               (val err)
    1117               (unix:unix-ioctl fd unix:TIOCGETP (alien:alien-sap sg))
    1118             (unless val
    1119               (error "Could not get tty information, unix error ~S."
    1120                      (unix:get-unix-error-msg err)))
    1121             (setf (alien:slot sg 'unix:sg-flags) old-flags)
    1122             (multiple-value-bind
    1123                 (val err)
    1124                 (unix:unix-ioctl fd unix:TIOCSETP (alien:alien-sap sg))
    1125               (unless val
    1126                 (error "Could not set tty information, unix error ~S."
    1127                        (unix:get-unix-error-msg err)))))))
    1128       #-(or hpux irix bsd glibc2)
    1129       (when (and (boundp 'old-tchars)
    1130                  (simple-vector-p old-tchars)
    1131                  (eq (length old-tchars) 6))
    1132         (alien:with-alien ((tc (alien:struct unix:tchars)))
    1133           (setf (alien:slot tc 'unix:t-intrc) (svref old-tchars 0))
    1134           (setf (alien:slot tc 'unix:t-quitc) (svref old-tchars 1))
    1135           (setf (alien:slot tc 'unix:t-startc) (svref old-tchars 2))
    1136           (setf (alien:slot tc 'unix:t-stopc) (svref old-tchars 3))
    1137           (setf (alien:slot tc 'unix:t-eofc) (svref old-tchars 4))
    1138           (setf (alien:slot tc 'unix:t-brkc) (svref old-tchars 5))
    1139           (multiple-value-bind
    1140               (val err)
    1141               (unix:unix-ioctl fd unix:TIOCSETC (alien:alien-sap tc))
    1142             (unless val
    1143               (error "Failed to set tchars, unix error ~S."
    1144                      (unix:get-unix-error-msg err))))))
    1145       #-glibc2
    1146       (when (and (boundp 'old-ltchars)
    1147                  (simple-vector-p old-ltchars)
    1148                  (eq (length old-ltchars) 6))
    1149         (alien:with-alien ((tc (alien:struct unix:ltchars)))
    1150           (setf (alien:slot tc 'unix:t-suspc) (svref old-ltchars 0))
    1151           (setf (alien:slot tc 'unix:t-dsuspc) (svref old-ltchars 1))
    1152           (setf (alien:slot tc 'unix:t-rprntc) (svref old-ltchars 2))
    1153           (setf (alien:slot tc 'unix:t-flushc) (svref old-ltchars 3))
    1154           (setf (alien:slot tc 'unix:t-werasc) (svref old-ltchars 4))
    1155           (setf (alien:slot tc 'unix:t-lnextc) (svref old-ltchars 5))
    1156           (multiple-value-bind
    1157               (val err)
    1158               (unix:unix-ioctl fd unix:TIOCSLTC (alien:alien-sap tc))
    1159             (unless val
    1160               (error "Failed to set ltchars, unix error ~S."
    1161                      (unix:get-unix-error-msg err)))))))))
    1162 
    1163 (defun pause-hemlock ()
    1164   "Pause hemlock and pop out to the Unix Shell."
    1165   (without-hemlock
    1166    (unix:unix-kill (unix:unix-getpid) :sigstop))
    1167   T)
    1168 
    1169 ||#
  • branches/ia32/cocoa-ide/hemlock/src/searchcoms.lisp

    r7244 r7666  
    2424  (new-search-pattern :string-insensitive :forward "Foo")
    2525  "Search pattern we keep around so we don't cons them all the time.")
     26(defvar *search-wrapped-p* nil "True if search wrapped")
    2627
    2728(defhvar "String Search Ignore Case"
     
    5657         (point (current-point))
    5758         (mark (copy-mark point))
     59         ;; find-pattern moves point to start of match, and returns is # chars matched
    5860         (won (find-pattern point pattern)))
    5961    (cond (won (move-mark mark point)
     
    105107    (clear-echo-area)
    106108    (format *echo-area-stream*
    107             "~:[~;Failing ~]~:[Reverse I-Search~;I-Search~]: ~A"
    108             failure (eq direction :forward) string)))
     109            "~:[~;Failing ~]~:[~;Overwrapped ~]~:[Reverse I-Search~;I-Search~]: ~A"
     110            failure *search-wrapped-p* (eq direction :forward) string)))
    109111
    110112(defcommand "Incremental Search" (p)
     
    114116  repeats forward, and ^R repeats backward.  ^R or ^S with empty string
    115117  either changes the direction or yanks the previous search string.
    116   Altmode exits the search unless the string is empty.  Altmode with
     118  Escape exits the search unless the string is empty.  Escape with
    117119  an empty search string calls the non-incremental search command. 
    118120  Other control characters cause exit and execution of the appropriate
    119121  command.  If the search fails at some point, ^G and backspace may be
    120122  used to backup to a non-failing point; also, ^S and ^R may be used to
    121   look the other way.  ^G during a successful search aborts and returns
     123  look the other way.  ^W extends the search string to include the the word
     124  after the point. ^G during a successful search aborts and returns
    122125  point to where it started."
    123126  "Search for input string as characters are typed in.
     
    126129  (setf (last-command-type) nil)
    127130  (%i-search-echo-refresh "" :forward nil)
    128   (let* ((point (current-point))
     131  (let* ((*search-wrapped-p* nil)
     132         (point (current-point))
    129133         (save-start (copy-mark point :temporary)))
    130134    (with-mark ((here point))
     
    158162  (setf (last-command-type) nil)
    159163  (%i-search-echo-refresh "" :backward nil)
    160   (let* ((point (current-point))
     164  (let* ((*search-wrapped-p* nil)
     165         (point (current-point))
    161166         (save-start (copy-mark point :temporary)))
    162167    (with-mark ((here point))
     
    184189        (curr-trailer (copy-mark trailer :temporary)))
    185190       (nil)
    186     (let ((next-key-event (recursive-get-key-event *editor-input* t)))
    187       (case (%i-search-char-eval next-key-event string point trailer
    188                                  direction failure)
     191    (let* ((next-key-event (recursive-get-key-event hi::*editor-input* t))
     192           (val (%i-search-char-eval next-key-event string point trailer
     193                                 direction failure))
     194           (empty-string-p (zerop (length string))))
     195      (case val
    189196        (:mouse-exit
    190197         (clear-echo-area)
     
    192199        (:cancel
    193200         (%i-search-echo-refresh string direction failure)
    194          (unless (zerop (length string))
    195            (i-search-pattern string direction)))
    196         (:return-cancel
    197          (unless (zerop (length string)) (return :cancel))
    198          (beep))
     201         (unless empty-string-p
     202           (i-search-pattern string direction))) ;sets *last-search-pattern*
     203        (:return-cancel ;backspace was typed
     204         (if empty-string-p
     205             (beep)
     206             (return :cancel)))
    199207        (:control-g
    200208         (when failure (return :control-g))
    201209         (%i-search-echo-refresh string direction nil)
    202          (unless (zerop (length string))
    203            (i-search-pattern string direction))))
     210         (unless empty-string-p
     211           (i-search-pattern string direction)))) ;*last-search-pattern*
    204212      (move-mark point curr-point)
    205213      (move-mark trailer curr-trailer))))
     
    219227                                   direction failure))
    220228        ((logical-key-event-p key-event :cancel) :return-cancel)
     229        ((logical-key-event-p key-event :extend-search-word)
     230         (with-mark ((end point))
     231           (word-offset end 1)
     232           (let ((extension (region-to-string (region point end))))
     233             (%i-search-extend-string string extension point trailer direction failure))))           
    221234        ((logical-key-event-p key-event :abort)
    222235         (unless failure
     
    226239         :control-g)
    227240        ((logical-key-event-p key-event :quote)
    228          (%i-search-printed-char (get-key-event *editor-input* t)
     241         (%i-search-printed-char (get-key-event hi::*editor-input* t)
    229242                                 string point trailer direction failure))
    230243        ((and (zerop (length string)) (logical-key-event-p key-event :exit))
     
    235248        (t
    236249         (unless (logical-key-event-p key-event :exit)
    237            (unget-key-event key-event *editor-input*))
     250           (unget-key-event key-event hi::*editor-input*))
    238251         (unless (zerop (length string))
    239252           (setf *last-search-string* string))
     
    252265           (%i-search-empty-string point trailer direction forward-direction-p
    253266                                   forward-character-p))
    254           ((eq forward-direction-p forward-character-p)
    255            (if failure
    256                (%i-search string point trailer direction failure)
    257                (%i-search-find-pattern string point (move-mark trailer point)
    258                                        direction)))
     267          ((eq forward-direction-p forward-character-p) ;keep searching in the same direction
     268           (cond ((eq failure :first-failure)
     269                  (cond (forward-direction-p
     270                         (buffer-start point)
     271                         (buffer-start trailer)
     272                         (character-offset trailer (length string)))
     273                        (t
     274                         (buffer-end point)
     275                         (buffer-end trailer)))
     276                  (push-buffer-mark (copy-mark point))
     277                  (let ((*search-wrapped-p* t))
     278                    (%i-search-echo-refresh string direction nil)
     279                    (%i-search-find-pattern string point trailer direction)))
     280                  (failure
     281                   (%i-search string point trailer direction t))
     282                  (t
     283                   (%i-search-find-pattern string point (move-mark trailer point)
     284                                           direction))))
    259285          (t
    260286           (let ((new-direction (if forward-character-p :forward :backward)))
    261287             (%i-search-echo-refresh string new-direction nil)
    262              (i-search-pattern string new-direction)
     288             (i-search-pattern string new-direction) ;sets *last-search-pattern*
    263289             (%i-search-find-pattern string point (move-mark trailer point)
    264290                                     new-direction))))))
     
    278304        (*last-search-string*
    279305         (%i-search-echo-refresh *last-search-string* direction nil)
    280          (i-search-pattern *last-search-string* direction)
     306         (i-search-pattern *last-search-string* direction) ;sets *last-search-pattern*
    281307         (%i-search-find-pattern *last-search-string* point trailer direction))
    282308        (t (beep))))
     
    296322      (force-output *echo-area-stream*))
    297323    (let ((new-string (concatenate 'simple-string string (string tchar))))
    298       (i-search-pattern new-string direction)
     324      (i-search-pattern new-string direction) ;sets *last-search-pattern*
    299325      (cond (failure (%i-search new-string point trailer direction failure))
    300326            ((and (eq direction :backward) (next-character trailer))
     
    303329            (t
    304330             (%i-search-find-pattern new-string point trailer direction))))))
     331
     332(defun %i-search-extend-string (string extension point trailer direction failure)
     333  (when (interactive)
     334    (insert-string (buffer-point *echo-area-buffer*) extension)
     335    (force-output *echo-area-stream*))
     336  (let ((new-string (concatenate 'simple-string string extension)))
     337    (i-search-pattern new-string direction) ;sets *last-search-pattern*
     338    (cond (failure (%i-search new-string point trailer direction failure))
     339          ((and (eq direction :backward) (next-character trailer))
     340           (%i-search-find-pattern new-string point (mark-after trailer)
     341                                   direction))
     342          (t
     343           (%i-search-find-pattern new-string point trailer direction)))))
    305344
    306345
     
    325364               (beep)
    326365               (editor-error "I-Search failed."))
    327            (%i-search string point trailer direction t)))))
     366           (%i-search string point trailer direction :first-failure)))))
    328367
    329368
     
    512551                 (:exit "Exit immediately."
    513552                        (return nil))
    514                  (t (unget-key-event key-event *editor-input*)
     553                 (t (unget-key-event key-event hi::*editor-input*)
    515554                    (return nil))))))
    516555       (length (the list *query-replace-undo-data*))))))
  • branches/ia32/cocoa-ide/hemlock/src/struct.lisp

    r6691 r7666  
    101101  #+clx
    102102  windows                     ; List of all windows into this buffer.
    103   #-clx
     103  #+clozure ;; should be #+Cocoa
    104104  document                    ; NSDocument object associated with this buffer
    105105  var-values                  ; the buffer's local variables
     
    693693)
    694694
    695 (define-symbol-macro *line-cache-length* (buffer-gap-context-line-cache-length *buffer-gap-context*))
    696 (define-symbol-macro *open-line* (buffer-gap-context-open-line *buffer-gap-context*))
    697 (define-symbol-macro *open-chars* (buffer-gap-context-open-chars *buffer-gap-context*))
    698 (define-symbol-macro *left-open-pos* (buffer-gap-context-left-open-pos *buffer-gap-context*))
    699 (define-symbol-macro *right-open-pos* (buffer-gap-context-right-open-pos *buffer-gap-context*))
    700 
     695(defun ensure-buffer-gap-context (buffer)
     696  (or (buffer-gap-context buffer)
     697      (setf (buffer-gap-context buffer) (make-buffer-gap-context))))
     698
     699(defun buffer-lock (buffer)
     700  (buffer-gap-context-lock (ensure-buffer-gap-context buffer)))
     701
     702(defun current-gap-context ()
     703  (unless (boundp '*current-buffer*)
     704    (error "Gap context not bound"))
     705  (ensure-buffer-gap-context *current-buffer*))
     706
     707(defun current-line-cache-length ()
     708  (buffer-gap-context-line-cache-length (current-gap-context)))
     709
     710(defun (setf current-line-cache-length) (len)
     711  (setf (buffer-gap-context-line-cache-length (current-gap-context)) len))
     712
     713(defun current-open-line ()
     714  (buffer-gap-context-open-line (current-gap-context)))
     715
     716(defun current-open-line-p (line)
     717  (eq line (current-open-line)))
     718
     719(defun (setf current-open-line) (value)
     720  (setf (buffer-gap-context-open-line (current-gap-context)) value))
     721
     722(defun current-open-chars ()
     723  (buffer-gap-context-open-chars (current-gap-context)))
     724
     725(defun (setf current-open-chars) (value)
     726  (setf (buffer-gap-context-open-chars (current-gap-context)) value))
     727 
     728(defun current-left-open-pos ()
     729  (buffer-gap-context-left-open-pos (current-gap-context)))
     730
     731(defun (setf current-left-open-pos) (value)
     732  (setf (buffer-gap-context-left-open-pos (current-gap-context)) value))
     733
     734(defun current-right-open-pos ()
     735  (buffer-gap-context-right-open-pos (current-gap-context)))
     736
     737(defun (setf current-right-open-pos) (value)
     738  (setf (buffer-gap-context-right-open-pos (current-gap-context)) value))
  • branches/ia32/cocoa-ide/hemlock/src/syntax.lisp

    r6581 r7666  
    456456;;;
    457457(defmacro cache-find-attribute (start result vector mask)
    458   `(let ((gap (- *right-open-pos* *left-open-pos*)))
     458  `(let ((gap (- (current-right-open-pos) (current-left-open-pos))))
    459459     (declare (fixnum gap))
    460460     (cond
    461       ((>= ,start *left-open-pos*)
     461      ((>= ,start (current-left-open-pos))
    462462       (setq ,result
    463463             (%sp-find-character-with-attribute
    464               *open-chars* (+ ,start gap) *line-cache-length* ,vector ,mask))
     464              (current-open-chars) (+ ,start gap) (current-line-cache-length) ,vector ,mask))
    465465       (when ,result (decf ,result gap)))
    466466      ((setq ,result (%sp-find-character-with-attribute
    467                       *open-chars* ,start *left-open-pos* ,vector ,mask)))
     467                      (current-open-chars) ,start (current-left-open-pos) ,vector ,mask)))
    468468      (t
    469469       (setq ,result
    470470             (%sp-find-character-with-attribute
    471               *open-chars* *right-open-pos* *line-cache-length* ,vector ,mask))
     471              (current-open-chars) (current-right-open-pos) (current-line-cache-length) ,vector ,mask))
    472472       (when ,result (decf ,result gap))))))
    473473); eval-when (:compile-toplevel :execute)
     
    484484    (cond
    485485     ((cond
    486        ((eq line *open-line*)
     486       ((current-open-line-p line)
    487487        (when (cache-find-attribute charpos charpos vector mask)
    488488          (setf (mark-charpos mark) charpos) mark))
     
    504504              (return (line-end mark prev))
    505505              (return nil)))
    506          ((eq line *open-line*)
     506         ((current-open-line-p line)
    507507          (when (cache-find-attribute 0 charpos vector mask)
    508508            (return (move-to-position mark charpos line))))
     
    511511            (return (move-to-position mark charpos line))))))))))
    512512
     513(defun find-not-attribute (mark attribute)
     514  (find-attribute mark attribute #'zerop))
    513515
    514516
     
    524526;;;
    525527(defmacro rev-cache-find-attribute (start result vector mask)
    526   `(let ((gap (- *right-open-pos* *left-open-pos*)))
     528  `(let ((gap (- (current-right-open-pos) (current-left-open-pos))))
    527529     (declare (fixnum gap))
    528530     (cond
    529531      ,@(when start
    530           `(((<= ,start *left-open-pos*)
     532          `(((<= ,start (current-left-open-pos))
    531533             (setq ,result
    532534                   (%sp-reverse-find-character-with-attribute
    533                     *open-chars* 0 ,start ,vector ,mask)))))
     535                    (current-open-chars) 0 ,start ,vector ,mask)))))
    534536      ((setq ,result (%sp-reverse-find-character-with-attribute
    535                       *open-chars* *right-open-pos*
    536                       ,(if start `(+ ,start gap) '*line-cache-length*)
     537                      (current-open-chars) (current-right-open-pos)
     538                      ,(if start `(+ ,start gap) '(current-line-cache-length))
    537539                      ,vector ,mask))
    538540       (decf ,result gap))
     
    540542       (setq ,result
    541543             (%sp-reverse-find-character-with-attribute
    542               *open-chars* 0 *left-open-pos* ,vector ,mask))))))
     544              (current-open-chars) 0 (current-left-open-pos) ,vector ,mask))))))
    543545
    544546); eval-when (:compile-toplevel :execute)
    545547;;;
     548;;; This moves the mark so that previous-character satisfies the test.
    546549(defun reverse-find-attribute (mark attribute &optional (test #'not-zerop))
    547550  "Find the previous character whose attribute value satisfies test."
     
    553556    (cond
    554557     ((cond
    555        ((eq line *open-line*)
     558       ((current-open-line-p line)
    556559        (when (rev-cache-find-attribute charpos charpos vector mask)
    557560          (setf (mark-charpos mark) (1+ charpos)) mark))
     
    572575              (return (line-start mark next))
    573576              (return nil)))
    574          ((eq line *open-line*)
     577         ((current-open-line-p line)
    575578          (when (rev-cache-find-attribute nil charpos vector mask)
    576579            (return (move-to-position mark (1+ charpos) line))))
     
    578581          (when (rev-normal-find-attribute line nil charpos vector mask)
    579582            (return (move-to-position mark (1+ charpos) line))))))))))
     583
     584(defun reverse-find-not-attribute (mark attribute)
     585  (reverse-find-attribute mark attribute #'zerop))
  • branches/ia32/compiler/PPC/ppc2.lisp

    r7244 r7666  
    15741574            (if needs-memoization
    15751575              (progn
    1576                 (ppc2-four-untargeted-reg-forms seg
     1576                (ppc2-four-targeted-reg-forms seg
    15771577                                                array ($ ppc::temp0)
    15781578                                                i ($ ppc::arg_x)
  • branches/ia32/compiler/X86/X8664/x8664-backend.lisp

    r7244 r7666  
    489489                    (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset
    490490                                                                   (incf memory-arg-offset (* 8 (ceiling bits 64)))))))
    491                          (dynamic-extent-names name))
     491                    (dynamic-extent-names name))
    492492                  (progn
    493493                    (rlets (list name (foreign-record-type-name argtype)))
     
    511511                               (:unsigned-byte '%get-unsigned-byte)
    512512                               (:address
    513                                 (dynamic-extent-names name)
     513                                ;(dynamic-extent-names name)
    514514                                '%get-ptr))
    515515                             ,stack-ptr
  • branches/ia32/compiler/X86/X8664/x8664-vinsns.lisp

    r7244 r7666  
    813813  (movq (:@ (:%seg :rcontext) x8664::tcr.save-allocptr) (:%q x8664::allocptr))
    814814  (rcmpq (:%q x8664::allocptr) (:@ (:%seg :rcontext) x8664::tcr.save-allocbase))
    815   (jg :no-trap)
     815  (:byte #x7f) (:byte #x02) ;(jg :no-trap)
    816816  (uuo-alloc)
    817817  :no-trap
     
    11391139  (movq (:@ (:%seg :rcontext) x8664::tcr.save-allocptr) (:%q freeptr))
    11401140  (rcmpq (:%q freeptr) (:@ (:%seg :rcontext) x8664::tcr.save-allocbase))
    1141   (jg :no-trap)
     1141  (:byte #x7f) (:byte #x02) ;(jg :no-trap)
    11421142  (uuo-alloc)
    11431143  :no-trap
     
    19131913     ((entry (:label 1))))
    19141914  (:talign 4)
    1915   (jmp (:@ .SPspecref))
    1916   :back
     1915  (call (:@ .SPspecref))
    19171916  (leaq (:@ (:^ entry) (:% x8664::rip)) (:%q x8664::fn)))
    19181917
  • branches/ia32/compiler/X86/x862.lisp

    r7665 r7666  
    50555055            (x862-close-undo)
    50565056            (x862-temp-pop-node seg *x862-temp0*)
    5057             (x862-invoke-fn seg *x862-temp0* nil nil xfer label)))
     5057            (x862-invoke-fn seg *x862-temp0* nil nil xfer label)
     5058            (when label
     5059              ;; Pushed a label earlier, then returned to it.
     5060              (setq *x862-top-vstack-lcell* (lcell-parent *x862-top-vstack-lcell*))
     5061              (x862-adjust-vstack (- *x862-target-node-size*)))))
    50585062        (unless recursive-p
    50595063          (if mv-p
     
    64256429            (x862-explicit-non-fixnum-type-p form2))
    64266430      (x862-binary-builtin seg vreg xfer name form1 form2)
    6427       (x862-inline-numcmp seg vreg xfer cc name form1 form2))))
     6431      (let* ((fix1 (acode-fixnum-form-p form1))
     6432             (fix2 (acode-fixnum-form-p form2)))
     6433        (if (and fix1 fix2)
     6434          (if (funcall name fix1 fix2)
     6435            (x862-t seg vreg xfer)
     6436            (x862-nil seg vreg xfer))
     6437          (x862-inline-numcmp seg vreg xfer cc name form1 form2))))))
    64286438
    64296439(defun x862-inline-numcmp (seg vreg xfer cc name form1 form2)
     
    64556465      (multiple-value-bind (cr-bit true-p) (acode-condition-to-x86-cr-bit cc)
    64566466        (when otherform
    6457           (unless (or fix2 (eq cr-bit x86::x86-e-bits))
     6467          (unless (or (and fix2 (not fix1)) (eq cr-bit x86::x86-e-bits))
    64586468            (setq cr-bit (x862-reverse-cr-bit cr-bit))))
    64596469        (if (not true-p)
  • branches/ia32/darwin-x86-headers64/cocoa/C/populate.sh

    r6973 r7666  
    33rm -rf System Developer usr
    44SDK=/Developer/SDKs/MacOSX10.5.sdk
    5 CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK}"; export CFLAGS
     5CFLAGS="-m64 -fobjc-abi-version=2 -isysroot ${SDK} -mmacosx-version-min=10.5"; export CFLAGS
    66h-to-ffi.sh ${SDK}/usr/include/objc/objc-runtime.h
    77h-to-ffi.sh ${SDK}/usr/include/objc/objc-exception.h
  • branches/ia32/examples/cocoa

    • Property svn:ignore
      •  

        old new  
        11*~.*
         2*fsl
  • branches/ia32/level-0/l0-aprims.lisp

    r6559 r7666  
    7171        (when nul-terminated
    7272          (setf (%get-byte pointer n) 0)))
    73       nil))
    74   (%cstr-segment-pointer string pointer 0 (length string) nul-terminated))
     73      nil)
     74    (%cstr-segment-pointer string pointer 0 (length string) nul-terminated)))
    7575
    7676(defun %cstr-segment-pointer (string pointer start end &optional (nul-terminated t))
  • branches/ia32/level-0/l0-cfm-support.lisp

    r6484 r7666  
    137137                 (dynamic-entries (pref map :link_map.l_ld)))
    138138    (let* ((soname-offset nil))
    139       ;;; Walk over the entries in the file's dynamic segment; the
    140       ;;; last such entry will have a tag of #$DT_NULL.  Note the
    141       ;;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD)
    142       ;;; address of the dynamic string table and the offset of the
    143       ;;; #$DT_SONAME string in that string table.
     139      ;; Walk over the entries in the file's dynamic segment; the
     140      ;; last such entry will have a tag of #$DT_NULL.  Note the
     141      ;; (loaded,on Linux; relative to link_map.l_addr on FreeBSD)
     142      ;; address of the dynamic string table and the offset of the
     143      ;; #$DT_SONAME string in that string table.
     144      ;; Actually, the above isn't quite right; there seem to
     145      ;; be cases (involving vDSO) where the address of a library's
     146      ;; dynamic string table is expressed as an offset relative
     147      ;; to link_map.l_addr as well.
    144148      (loop
    145149          (case #+32-bit-target (pref dynamic-entries :<E>lf32_<D>yn.d_tag)
     
    154158            (#. #$DT_STRTAB
    155159                (%setf-macptr dyn-strings
    156                               #+32-bit-target
    157                               (pref dynamic-entries
    158                                     :<E>lf32_<D>yn.d_un.d_ptr)
    159                               #+(and 64-bit-target linux-target)
    160                               (pref dynamic-entries
    161                                     :<E>lf64_<D>yn.d_un.d_ptr)
    162                               #+(and 64-bit-target freebsd-target)
    163                               (%inc-ptr (pref map :link_map.l_addr)
    164                                         (pref dynamic-entries
    165                                               :<E>lf64_<D>yn.d_un.d_val)))))
     160                              ;; Try to guess whether we're dealing
     161                              ;; with a displacement or with an
     162                              ;; absolute address.  There may be
     163                              ;; a better way to determine this,
     164                              ;; but for now we assume that absolute
     165                              ;; addresses aren't negative and that
     166                              ;; displacements are.
     167                               (let* ((disp (%get-signed-natural
     168                                             dynamic-entries
     169                                             target::node-size)))
     170                                 #+freebsd-target
     171                                 (%inc-ptr (pref map :link_map.l_addr) disp)
     172                                 #-freebsd-target
     173                                 (%int-to-ptr
     174                                  (if (< disp 0)
     175                                    (+ disp (pref map :link_map.l_addr))
     176                                    disp))))))
    166177          (%setf-macptr dynamic-entries
    167178                        (%inc-ptr dynamic-entries
  • branches/ia32/level-0/l0-init.lisp

    r7334 r7666  
    2727    :openmcl
    2828    :clozure
     29    :clozure-common-lisp
    2930    :ansi-cl
    3031    :unix
  • branches/ia32/level-0/l0-pred.lisp

    r5671 r7666  
    217217(defun macptrp (x)
    218218  (= (the fixnum (typecode x)) target::subtag-macptr))
     219
     220(defun dead-macptr-p (x)
     221  (= (the fixnum (typecode x)) target::subtag-dead-macptr))
    219222
    220223
  • branches/ia32/level-1/l1-application.lisp

    r7287 r7666  
    293293
    294294(defmethod application-init-file ((app lisp-development-system))
    295   "home:openmcl-init")
    296 
     295  ;; This is the init file loaded before cocoa.
     296  #+clozure-common-lisp '("home:ccl-init" "home:openmcl-init") ;; transitional kludge
     297  #-clozure-common-lisp "home:openmcl-init")
    297298
    298299(defmethod application-error ((a application) condition error-pointer)