Changeset 7666 for branches


Ignore:
Timestamp:
Nov 16, 2007, 3:58:32 PM (17 years ago)
Author:
R. Matthew Emerson
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)

  • branches/ia32/level-1/l1-aprims.lisp

    r6432 r7666  
    184184(defun nthcdr (index list)
    185185  "Performs the cdr function n times on a list."
     186  (setq list (require-type list 'list))
    186187  (if (and (typep index 'fixnum)
    187188           (>= (the fixnum index) 0))
    … …  
    864865  "Return CHAR converted to lower-case if that is possible."
    865866  (let* ((code (char-code c)))
    866     (if (and (%i>= code (char-code #\A))(%i<= code (char-code #\Z)))
     867    (declare (type (mod #x110000) code))
     868    (if (and (>= code (char-code #\A))(<= code (char-code #\Z)))
    867869      (%code-char (%i+ code #.(- (char-code #\a)(char-code #\A))))
    868     c)))
     870      (or (and (>= code #x80)
     871               (%non-standard-lower-case-equivalent c))
     872          c))))
    869873
    870874
    … …  
    899903   lowercase eszet (U+DF)."
    900904  (let* ((code (char-code c)))
    901     (if (and (%i>= code (char-code #\a))(%i<= code (char-code #\z)))
     905    (declare (type (mod #x110000) code))
     906    (if (and (>= code (char-code #\a))(<= code (char-code #\z)))
    902907      (%code-char (%i- code #.(- (char-code #\a)(char-code #\A))))
    903       c)))
     908      (or (and (>= code #x80) (%non-standard-upper-case-equivalent c))
     909          c))))
    904910
    905911
    … …  
    10891095         (g1 (%fixnum-ref g2 target::area.younger))
    10901096         (g0 (%fixnum-ref g1 target::area.younger)))
    1091     (values (ash (the fixnum (%fixnum-ref g0 target::area.threshold)) -8)
    1092             (ash (the fixnum (%fixnum-ref g1 target::area.threshold)) -8)
    1093             (ash (the fixnum (%fixnum-ref g2 target::area.threshold)) -8))))
     1097    (values (ash (the fixnum (%fixnum-ref g0 target::area.threshold)) (- (- 10 target::fixnum-shift)))
     1098            (ash (the fixnum (%fixnum-ref g1 target::area.threshold)) (- (- 10 target::fixnum-shift)))
     1099            (ash (the fixnum (%fixnum-ref g2 target::area.threshold)) (- (- 10 target::fixnum-shift))))))
    10941100
    10951101
    … …  
    10991105are rounded up to a multiple of 64Kbytes in OpenMCL 0.14 and to a multiple
    11001106of 32KBytes in earlier versions.)"
    1101   (unless (egc-active-p)
    1102     (setq e2size (logand (lognot #xffff) (+ #xffff (ash (require-type e2size '(unsigned-byte 18)) 10)))
    1103           e1size (logand (lognot #xffff) (+ #xffff (ash (require-type e1size '(unsigned-byte 18)) 10)))
    1104           e0size (logand (lognot #xffff) (+ #xffff (ash (require-type e0size '(integer 1 #.(ash 1 18))) 10))))
    1105     (%configure-egc e0size e1size e2size)))
     1107  (let* ((was-enabled (egc-active-p)))
     1108    (unwind-protect
     1109         (progn
     1110           (egc nil)
     1111           (setq e2size (logand (lognot #xffff) (+ #xffff (ash (require-type e2size '(unsigned-byte 18)) 10)))
     1112                 e1size (logand (lognot #xffff) (+ #xffff (ash (require-type e1size '(unsigned-byte 18)) 10)))
     1113                 e0size (logand (lognot #xffff) (+ #xffff (ash (require-type e0size '(integer 1 #.(ash 1 18))) 10))))
     1114           (%configure-egc e0size e1size e2size))
     1115      (egc was-enabled))))
    11061116
    11071117
    … …  
    11321142       (= (uvsize p) target::xmacptr.element-count)))
    11331143
    1134 
    1135 ;True for a-z.
     1144(defstatic *non-standard-lower-to-upper* (make-hash-table :test #'eq)
     1145  "Maps non-STANDARD-CHAR lowercase chars to uppercase equivalents")
     1146
     1147(defstatic *non-standard-upper-to-lower* (make-hash-table :test #'eq)
     1148  "Maps non-STANDARD-CHAR uppercase chars to lowercase equivalents")
     1149
     1150;;; This alist is automatically (and not to cleverly ...) generated.
     1151;;; The (upper . lower) pairs have the property that UPPER is the
     1152;;; value "simple uppercase equivalent" entry for LOWER in the
     1153;;; UnicodeData.txt file and LOWER is the corresponding entry for
     1154;;; UPPER.
     1155(dolist (pair '((#\Latin_Capital_Letter_A_With_Grave . #\Latin_Small_Letter_A_With_Grave)
     1156                (#\Latin_Capital_Letter_A_With_Acute . #\Latin_Small_Letter_A_With_Acute)
     1157                (#\Latin_Capital_Letter_A_With_Circumflex
     1158                 . #\Latin_Small_Letter_A_With_Circumflex)
     1159                (#\Latin_Capital_Letter_A_With_Tilde . #\Latin_Small_Letter_A_With_Tilde)
     1160                (#\Latin_Capital_Letter_A_With_Diaeresis
     1161                 . #\Latin_Small_Letter_A_With_Diaeresis)
     1162                (#\Latin_Capital_Letter_A_With_Ring_Above
     1163                 . #\Latin_Small_Letter_A_With_Ring_Above)
     1164                (#\Latin_Capital_Letter_Ae . #\Latin_Small_Letter_Ae)
     1165                (#\Latin_Capital_Letter_C_With_Cedilla . #\Latin_Small_Letter_C_With_Cedilla)
     1166                (#\Latin_Capital_Letter_E_With_Grave . #\Latin_Small_Letter_E_With_Grave)
     1167                (#\Latin_Capital_Letter_E_With_Acute . #\Latin_Small_Letter_E_With_Acute)
     1168                (#\Latin_Capital_Letter_E_With_Circumflex
     1169                 . #\Latin_Small_Letter_E_With_Circumflex)
     1170                (#\Latin_Capital_Letter_E_With_Diaeresis
     1171                 . #\Latin_Small_Letter_E_With_Diaeresis)
     1172                (#\Latin_Capital_Letter_I_With_Grave . #\Latin_Small_Letter_I_With_Grave)
     1173                (#\Latin_Capital_Letter_I_With_Acute . #\Latin_Small_Letter_I_With_Acute)
     1174                (#\Latin_Capital_Letter_I_With_Circumflex
     1175                 . #\Latin_Small_Letter_I_With_Circumflex)
     1176                (#\Latin_Capital_Letter_I_With_Diaeresis
     1177                 . #\Latin_Small_Letter_I_With_Diaeresis)
     1178                (#\Latin_Capital_Letter_Eth . #\Latin_Small_Letter_Eth)
     1179                (#\Latin_Capital_Letter_N_With_Tilde . #\Latin_Small_Letter_N_With_Tilde)
     1180                (#\Latin_Capital_Letter_O_With_Grave . #\Latin_Small_Letter_O_With_Grave)
     1181                (#\Latin_Capital_Letter_O_With_Acute . #\Latin_Small_Letter_O_With_Acute)
     1182                (#\Latin_Capital_Letter_O_With_Circumflex
     1183                 . #\Latin_Small_Letter_O_With_Circumflex)
     1184                (#\Latin_Capital_Letter_O_With_Tilde . #\Latin_Small_Letter_O_With_Tilde)
     1185                (#\Latin_Capital_Letter_O_With_Diaeresis
     1186                 . #\Latin_Small_Letter_O_With_Diaeresis)
     1187                (#\Latin_Capital_Letter_O_With_Stroke . #\Latin_Small_Letter_O_With_Stroke)
     1188                (#\Latin_Capital_Letter_U_With_Grave . #\Latin_Small_Letter_U_With_Grave)
     1189                (#\Latin_Capital_Letter_U_With_Acute . #\Latin_Small_Letter_U_With_Acute)
     1190                (#\Latin_Capital_Letter_U_With_Circumflex
     1191                 . #\Latin_Small_Letter_U_With_Circumflex)
     1192                (#\Latin_Capital_Letter_U_With_Diaeresis
     1193                 . #\Latin_Small_Letter_U_With_Diaeresis)
     1194                (#\Latin_Capital_Letter_Y_With_Acute . #\Latin_Small_Letter_Y_With_Acute)
     1195                (#\Latin_Capital_Letter_Thorn . #\Latin_Small_Letter_Thorn)
     1196                (#\Latin_Capital_Letter_A_With_Macron . #\Latin_Small_Letter_A_With_Macron)
     1197                (#\Latin_Capital_Letter_A_With_Breve . #\Latin_Small_Letter_A_With_Breve)
     1198                (#\Latin_Capital_Letter_A_With_Ogonek . #\Latin_Small_Letter_A_With_Ogonek)
     1199                (#\Latin_Capital_Letter_C_With_Acute . #\Latin_Small_Letter_C_With_Acute)
     1200                (#\Latin_Capital_Letter_C_With_Circumflex
     1201                 . #\Latin_Small_Letter_C_With_Circumflex)
     1202                (#\Latin_Capital_Letter_C_With_Dot_Above
     1203                 . #\Latin_Small_Letter_C_With_Dot_Above)
     1204                (#\Latin_Capital_Letter_C_With_Caron . #\Latin_Small_Letter_C_With_Caron)
     1205                (#\Latin_Capital_Letter_D_With_Caron . #\Latin_Small_Letter_D_With_Caron)
     1206                (#\Latin_Capital_Letter_D_With_Stroke . #\Latin_Small_Letter_D_With_Stroke)
     1207                (#\Latin_Capital_Letter_E_With_Macron . #\Latin_Small_Letter_E_With_Macron)
     1208                (#\Latin_Capital_Letter_E_With_Breve . #\Latin_Small_Letter_E_With_Breve)
     1209                (#\Latin_Capital_Letter_E_With_Dot_Above
     1210                 . #\Latin_Small_Letter_E_With_Dot_Above)
     1211                (#\Latin_Capital_Letter_E_With_Ogonek . #\Latin_Small_Letter_E_With_Ogonek)
     1212                (#\Latin_Capital_Letter_E_With_Caron . #\Latin_Small_Letter_E_With_Caron)
     1213                (#\Latin_Capital_Letter_G_With_Circumflex
     1214                 . #\Latin_Small_Letter_G_With_Circumflex)
     1215                (#\Latin_Capital_Letter_G_With_Breve . #\Latin_Small_Letter_G_With_Breve)
     1216                (#\Latin_Capital_Letter_G_With_Dot_Above
     1217                 . #\Latin_Small_Letter_G_With_Dot_Above)
     1218                (#\Latin_Capital_Letter_G_With_Cedilla . #\Latin_Small_Letter_G_With_Cedilla)
     1219                (#\Latin_Capital_Letter_H_With_Circumflex
     1220                 . #\Latin_Small_Letter_H_With_Circumflex)
     1221                (#\Latin_Capital_Letter_H_With_Stroke . #\Latin_Small_Letter_H_With_Stroke)
     1222                (#\Latin_Capital_Letter_I_With_Tilde . #\Latin_Small_Letter_I_With_Tilde)
     1223                (#\Latin_Capital_Letter_I_With_Macron . #\Latin_Small_Letter_I_With_Macron)
     1224                (#\Latin_Capital_Letter_I_With_Breve . #\Latin_Small_Letter_I_With_Breve)
     1225                (#\Latin_Capital_Letter_I_With_Ogonek . #\Latin_Small_Letter_I_With_Ogonek)
     1226                (#\Latin_Capital_Ligature_Ij . #\Latin_Small_Ligature_Ij)
     1227                (#\Latin_Capital_Letter_J_With_Circumflex
     1228                 . #\Latin_Small_Letter_J_With_Circumflex)
     1229                (#\Latin_Capital_Letter_K_With_Cedilla . #\Latin_Small_Letter_K_With_Cedilla)
     1230                (#\Latin_Capital_Letter_L_With_Acute . #\Latin_Small_Letter_L_With_Acute)
     1231                (#\Latin_Capital_Letter_L_With_Cedilla . #\Latin_Small_Letter_L_With_Cedilla)
     1232                (#\Latin_Capital_Letter_L_With_Caron . #\Latin_Small_Letter_L_With_Caron)
     1233                (#\Latin_Capital_Letter_L_With_Middle_Dot
     1234                 . #\Latin_Small_Letter_L_With_Middle_Dot)
     1235                (#\Latin_Capital_Letter_L_With_Stroke . #\Latin_Small_Letter_L_With_Stroke)
     1236                (#\Latin_Capital_Letter_N_With_Acute . #\Latin_Small_Letter_N_With_Acute)
     1237                (#\Latin_Capital_Letter_N_With_Cedilla . #\Latin_Small_Letter_N_With_Cedilla)
     1238                (#\Latin_Capital_Letter_N_With_Caron . #\Latin_Small_Letter_N_With_Caron)
     1239                (#\Latin_Capital_Letter_Eng . #\Latin_Small_Letter_Eng)
     1240                (#\Latin_Capital_Letter_O_With_Macron . #\Latin_Small_Letter_O_With_Macron)
     1241                (#\Latin_Capital_Letter_O_With_Breve . #\Latin_Small_Letter_O_With_Breve)
     1242                (#\Latin_Capital_Letter_O_With_Double_Acute
     1243                 . #\Latin_Small_Letter_O_With_Double_Acute)
     1244                (#\Latin_Capital_Ligature_Oe . #\Latin_Small_Ligature_Oe)
     1245                (#\Latin_Capital_Letter_R_With_Acute . #\Latin_Small_Letter_R_With_Acute)
     1246                (#\Latin_Capital_Letter_R_With_Cedilla . #\Latin_Small_Letter_R_With_Cedilla)
     1247                (#\Latin_Capital_Letter_R_With_Caron . #\Latin_Small_Letter_R_With_Caron)
     1248                (#\Latin_Capital_Letter_S_With_Acute . #\Latin_Small_Letter_S_With_Acute)
     1249                (#\Latin_Capital_Letter_S_With_Circumflex
     1250                 . #\Latin_Small_Letter_S_With_Circumflex)
     1251                (#\Latin_Capital_Letter_S_With_Cedilla . #\Latin_Small_Letter_S_With_Cedilla)
     1252                (#\Latin_Capital_Letter_S_With_Caron . #\Latin_Small_Letter_S_With_Caron)
     1253                (#\Latin_Capital_Letter_T_With_Cedilla . #\Latin_Small_Letter_T_With_Cedilla)
     1254                (#\Latin_Capital_Letter_T_With_Caron . #\Latin_Small_Letter_T_With_Caron)
     1255                (#\Latin_Capital_Letter_T_With_Stroke . #\Latin_Small_Letter_T_With_Stroke)
     1256                (#\Latin_Capital_Letter_U_With_Tilde . #\Latin_Small_Letter_U_With_Tilde)
     1257                (#\Latin_Capital_Letter_U_With_Macron . #\Latin_Small_Letter_U_With_Macron)
     1258                (#\Latin_Capital_Letter_U_With_Breve . #\Latin_Small_Letter_U_With_Breve)
     1259                (#\Latin_Capital_Letter_U_With_Ring_Above
     1260                 . #\Latin_Small_Letter_U_With_Ring_Above)
     1261                (#\Latin_Capital_Letter_U_With_Double_Acute
     1262                 . #\Latin_Small_Letter_U_With_Double_Acute)
     1263                (#\Latin_Capital_Letter_U_With_Ogonek . #\Latin_Small_Letter_U_With_Ogonek)
     1264                (#\Latin_Capital_Letter_W_With_Circumflex
     1265                 . #\Latin_Small_Letter_W_With_Circumflex)
     1266                (#\Latin_Capital_Letter_Y_With_Circumflex
     1267                 . #\Latin_Small_Letter_Y_With_Circumflex)
     1268                (#\Latin_Capital_Letter_Y_With_Diaeresis
     1269                 . #\Latin_Small_Letter_Y_With_Diaeresis)
     1270                (#\Latin_Capital_Letter_Z_With_Acute . #\Latin_Small_Letter_Z_With_Acute)
     1271                (#\Latin_Capital_Letter_Z_With_Dot_Above
     1272                 . #\Latin_Small_Letter_Z_With_Dot_Above)
     1273                (#\Latin_Capital_Letter_Z_With_Caron . #\Latin_Small_Letter_Z_With_Caron)
     1274                (#\Latin_Capital_Letter_B_With_Hook . #\Latin_Small_Letter_B_With_Hook)
     1275                (#\Latin_Capital_Letter_B_With_Topbar . #\Latin_Small_Letter_B_With_Topbar)
     1276                (#\Latin_Capital_Letter_Tone_Six . #\Latin_Small_Letter_Tone_Six)
     1277                (#\Latin_Capital_Letter_Open_O . #\Latin_Small_Letter_Open_O)
     1278                (#\Latin_Capital_Letter_C_With_Hook . #\Latin_Small_Letter_C_With_Hook)
     1279                (#\Latin_Capital_Letter_African_D . #\Latin_Small_Letter_D_With_Tail)
     1280                (#\Latin_Capital_Letter_D_With_Hook . #\Latin_Small_Letter_D_With_Hook)
     1281                (#\Latin_Capital_Letter_D_With_Topbar . #\Latin_Small_Letter_D_With_Topbar)
     1282                (#\Latin_Capital_Letter_Reversed_E . #\Latin_Small_Letter_Turned_E)
     1283                (#\Latin_Capital_Letter_Schwa . #\Latin_Small_Letter_Schwa)
     1284                (#\Latin_Capital_Letter_Open_E . #\Latin_Small_Letter_Open_E)
     1285                (#\Latin_Capital_Letter_F_With_Hook . #\Latin_Small_Letter_F_With_Hook)
     1286                (#\Latin_Capital_Letter_G_With_Hook . #\Latin_Small_Letter_G_With_Hook)
     1287                (#\Latin_Capital_Letter_Gamma . #\Latin_Small_Letter_Gamma)
     1288                (#\Latin_Capital_Letter_Iota . #\Latin_Small_Letter_Iota)
     1289                (#\Latin_Capital_Letter_I_With_Stroke . #\Latin_Small_Letter_I_With_Stroke)
     1290                (#\Latin_Capital_Letter_K_With_Hook . #\Latin_Small_Letter_K_With_Hook)
     1291                (#\Latin_Capital_Letter_Turned_M . #\Latin_Small_Letter_Turned_M)
     1292                (#\Latin_Capital_Letter_N_With_Left_Hook
     1293                 . #\Latin_Small_Letter_N_With_Left_Hook)
     1294                (#\Latin_Capital_Letter_O_With_Middle_Tilde . #\Latin_Small_Letter_Barred_O)
     1295                (#\Latin_Capital_Letter_O_With_Horn . #\Latin_Small_Letter_O_With_Horn)
     1296                (#\Latin_Capital_Letter_Oi . #\Latin_Small_Letter_Oi)
     1297                (#\Latin_Capital_Letter_P_With_Hook . #\Latin_Small_Letter_P_With_Hook)
     1298                (#\Latin_Letter_Yr . #\Latin_Letter_Small_Capital_R)
     1299                (#\Latin_Capital_Letter_Tone_Two . #\Latin_Small_Letter_Tone_Two)
     1300                (#\Latin_Capital_Letter_Esh . #\Latin_Small_Letter_Esh)
     1301                (#\Latin_Capital_Letter_T_With_Hook . #\Latin_Small_Letter_T_With_Hook)
     1302                (#\Latin_Capital_Letter_T_With_Retroflex_Hook
     1303                 . #\Latin_Small_Letter_T_With_Retroflex_Hook)
     1304                (#\Latin_Capital_Letter_U_With_Horn . #\Latin_Small_Letter_U_With_Horn)
     1305                (#\Latin_Capital_Letter_Upsilon . #\Latin_Small_Letter_Upsilon)
     1306                (#\Latin_Capital_Letter_V_With_Hook . #\Latin_Small_Letter_V_With_Hook)
     1307                (#\Latin_Capital_Letter_Y_With_Hook . #\Latin_Small_Letter_Y_With_Hook)
     1308                (#\Latin_Capital_Letter_Z_With_Stroke . #\Latin_Small_Letter_Z_With_Stroke)
     1309                (#\Latin_Capital_Letter_Ezh . #\Latin_Small_Letter_Ezh)
     1310                (#\Latin_Capital_Letter_Ezh_Reversed . #\Latin_Small_Letter_Ezh_Reversed)
     1311                (#\Latin_Capital_Letter_Tone_Five . #\Latin_Small_Letter_Tone_Five)
     1312                (#\Latin_Capital_Letter_Dz_With_Caron . #\Latin_Small_Letter_Dz_With_Caron)
     1313                (#\Latin_Capital_Letter_Lj . #\Latin_Small_Letter_Lj)
     1314                (#\Latin_Capital_Letter_Nj . #\Latin_Small_Letter_Nj)
     1315                (#\Latin_Capital_Letter_A_With_Caron . #\Latin_Small_Letter_A_With_Caron)
     1316                (#\Latin_Capital_Letter_I_With_Caron . #\Latin_Small_Letter_I_With_Caron)
     1317                (#\Latin_Capital_Letter_O_With_Caron . #\Latin_Small_Letter_O_With_Caron)
     1318                (#\Latin_Capital_Letter_U_With_Caron . #\Latin_Small_Letter_U_With_Caron)
     1319                (#\Latin_Capital_Letter_U_With_Diaeresis_And_Macron
     1320                 . #\Latin_Small_Letter_U_With_Diaeresis_And_Macron)
     1321                (#\Latin_Capital_Letter_U_With_Diaeresis_And_Acute
     1322                 . #\Latin_Small_Letter_U_With_Diaeresis_And_Acute)
     1323                (#\Latin_Capital_Letter_U_With_Diaeresis_And_Caron
     1324                 . #\Latin_Small_Letter_U_With_Diaeresis_And_Caron)
     1325                (#\Latin_Capital_Letter_U_With_Diaeresis_And_Grave
     1326                 . #\Latin_Small_Letter_U_With_Diaeresis_And_Grave)
     1327                (#\Latin_Capital_Letter_A_With_Diaeresis_And_Macron
     1328                 . #\Latin_Small_Letter_A_With_Diaeresis_And_Macron)
     1329                (#\Latin_Capital_Letter_A_With_Dot_Above_And_Macron
     1330                 . #\Latin_Small_Letter_A_With_Dot_Above_And_Macron)
     1331                (#\Latin_Capital_Letter_Ae_With_Macron . #\Latin_Small_Letter_Ae_With_Macron)
     1332                (#\Latin_Capital_Letter_G_With_Stroke . #\Latin_Small_Letter_G_With_Stroke)
     1333                (#\Latin_Capital_Letter_G_With_Caron . #\Latin_Small_Letter_G_With_Caron)
     1334                (#\Latin_Capital_Letter_K_With_Caron . #\Latin_Small_Letter_K_With_Caron)
     1335                (#\Latin_Capital_Letter_O_With_Ogonek . #\Latin_Small_Letter_O_With_Ogonek)
     1336                (#\Latin_Capital_Letter_O_With_Ogonek_And_Macron
     1337                 . #\Latin_Small_Letter_O_With_Ogonek_And_Macron)
     1338                (#\Latin_Capital_Letter_Ezh_With_Caron . #\Latin_Small_Letter_Ezh_With_Caron)
     1339                (#\Latin_Capital_Letter_Dz . #\Latin_Small_Letter_Dz)
     1340                (#\Latin_Capital_Letter_G_With_Acute . #\Latin_Small_Letter_G_With_Acute)
     1341                (#\Latin_Capital_Letter_Hwair . #\Latin_Small_Letter_Hv)
     1342                (#\Latin_Capital_Letter_Wynn . #\Latin_Letter_Wynn)
     1343                (#\Latin_Capital_Letter_N_With_Grave . #\Latin_Small_Letter_N_With_Grave)
     1344                (#\Latin_Capital_Letter_A_With_Ring_Above_And_Acute
     1345                 . #\Latin_Small_Letter_A_With_Ring_Above_And_Acute)
     1346                (#\Latin_Capital_Letter_Ae_With_Acute . #\Latin_Small_Letter_Ae_With_Acute)
     1347                (#\Latin_Capital_Letter_O_With_Stroke_And_Acute
     1348                 . #\Latin_Small_Letter_O_With_Stroke_And_Acute)
     1349                (#\Latin_Capital_Letter_A_With_Double_Grave
     1350                 . #\Latin_Small_Letter_A_With_Double_Grave)
     1351                (#\Latin_Capital_Letter_A_With_Inverted_Breve
     1352                 . #\Latin_Small_Letter_A_With_Inverted_Breve)
     1353                (#\Latin_Capital_Letter_E_With_Double_Grave
     1354                 . #\Latin_Small_Letter_E_With_Double_Grave)
     1355                (#\Latin_Capital_Letter_E_With_Inverted_Breve
     1356                 . #\Latin_Small_Letter_E_With_Inverted_Breve)
     1357                (#\Latin_Capital_Letter_I_With_Double_Grave
     1358                 . #\Latin_Small_Letter_I_With_Double_Grave)
     1359                (#\Latin_Capital_Letter_I_With_Inverted_Breve
     1360                 . #\Latin_Small_Letter_I_With_Inverted_Breve)
     1361                (#\Latin_Capital_Letter_O_With_Double_Grave
     1362                 . #\Latin_Small_Letter_O_With_Double_Grave)
     1363                (#\Latin_Capital_Letter_O_With_Inverted_Breve
     1364                 . #\Latin_Small_Letter_O_With_Inverted_Breve)
     1365                (#\Latin_Capital_Letter_R_With_Double_Grave
     1366                 . #\Latin_Small_Letter_R_With_Double_Grave)
     1367                (#\Latin_Capital_Letter_R_With_Inverted_Breve
     1368                 . #\Latin_Small_Letter_R_With_Inverted_Breve)
     1369                (#\Latin_Capital_Letter_U_With_Double_Grave
     1370                 . #\Latin_Small_Letter_U_With_Double_Grave)
     1371                (#\Latin_Capital_Letter_U_With_Inverted_Breve
     1372                 . #\Latin_Small_Letter_U_With_Inverted_Breve)
     1373                (#\Latin_Capital_Letter_S_With_Comma_Below
     1374                 . #\Latin_Small_Letter_S_With_Comma_Below)
     1375                (#\Latin_Capital_Letter_T_With_Comma_Below
     1376                 . #\Latin_Small_Letter_T_With_Comma_Below)
     1377                (#\Latin_Capital_Letter_Yogh . #\Latin_Small_Letter_Yogh)
     1378                (#\Latin_Capital_Letter_H_With_Caron . #\Latin_Small_Letter_H_With_Caron)
     1379                (#\Latin_Capital_Letter_N_With_Long_Right_Leg
     1380                 . #\Latin_Small_Letter_N_With_Long_Right_Leg)
     1381                (#\Latin_Capital_Letter_Ou . #\Latin_Small_Letter_Ou)
     1382                (#\Latin_Capital_Letter_Z_With_Hook . #\Latin_Small_Letter_Z_With_Hook)
     1383                (#\Latin_Capital_Letter_A_With_Dot_Above
     1384                 . #\Latin_Small_Letter_A_With_Dot_Above)
     1385                (#\Latin_Capital_Letter_E_With_Cedilla . #\Latin_Small_Letter_E_With_Cedilla)
     1386                (#\Latin_Capital_Letter_O_With_Diaeresis_And_Macron
     1387                 . #\Latin_Small_Letter_O_With_Diaeresis_And_Macron)
     1388                (#\Latin_Capital_Letter_O_With_Tilde_And_Macron
     1389                 . #\Latin_Small_Letter_O_With_Tilde_And_Macron)
     1390                (#\Latin_Capital_Letter_O_With_Dot_Above
     1391                 . #\Latin_Small_Letter_O_With_Dot_Above)
     1392                (#\Latin_Capital_Letter_O_With_Dot_Above_And_Macron
     1393                 . #\Latin_Small_Letter_O_With_Dot_Above_And_Macron)
     1394                (#\Latin_Capital_Letter_Y_With_Macron . #\Latin_Small_Letter_Y_With_Macron)
     1395                (#\Latin_Capital_Letter_A_With_Stroke . #\U+2C65)
     1396                (#\Latin_Capital_Letter_C_With_Stroke . #\Latin_Small_Letter_C_With_Stroke)
     1397                (#\Latin_Capital_Letter_L_With_Bar . #\Latin_Small_Letter_L_With_Bar)
     1398                (#\Latin_Capital_Letter_T_With_Diagonal_Stroke . #\U+2C66)
     1399                (#\Latin_Capital_Letter_Glottal_Stop . #\Latin_Small_Letter_Glottal_Stop)
     1400                (#\Latin_Capital_Letter_B_With_Stroke . #\Latin_Small_Letter_B_With_Stroke)
     1401                (#\Latin_Capital_Letter_U_Bar . #\Latin_Small_Letter_U_Bar)
     1402                (#\Latin_Capital_Letter_Turned_V . #\Latin_Small_Letter_Turned_V)
     1403                (#\Latin_Capital_Letter_E_With_Stroke . #\Latin_Small_Letter_E_With_Stroke)
     1404                (#\Latin_Capital_Letter_J_With_Stroke . #\Latin_Small_Letter_J_With_Stroke)
     1405                (#\Latin_Capital_Letter_Small_Q_With_Hook_Tail
     1406                 . #\Latin_Small_Letter_Q_With_Hook_Tail)
     1407                (#\Latin_Capital_Letter_R_With_Stroke . #\Latin_Small_Letter_R_With_Stroke)
     1408                (#\Latin_Capital_Letter_Y_With_Stroke . #\Latin_Small_Letter_Y_With_Stroke)
     1409                (#\Greek_Capital_Letter_Alpha_With_Tonos
     1410                 . #\Greek_Small_Letter_Alpha_With_Tonos)
     1411                (#\Greek_Capital_Letter_Epsilon_With_Tonos
     1412                 . #\Greek_Small_Letter_Epsilon_With_Tonos)
     1413                (#\Greek_Capital_Letter_Eta_With_Tonos . #\Greek_Small_Letter_Eta_With_Tonos)
     1414                (#\Greek_Capital_Letter_Iota_With_Tonos
     1415                 . #\Greek_Small_Letter_Iota_With_Tonos)
     1416                (#\Greek_Capital_Letter_Omicron_With_Tonos
     1417                 . #\Greek_Small_Letter_Omicron_With_Tonos)
     1418                (#\Greek_Capital_Letter_Upsilon_With_Tonos
     1419                 . #\Greek_Small_Letter_Upsilon_With_Tonos)
     1420                (#\Greek_Capital_Letter_Omega_With_Tonos
     1421                 . #\Greek_Small_Letter_Omega_With_Tonos)
     1422                (#\Greek_Capital_Letter_Alpha . #\Greek_Small_Letter_Alpha)
     1423                (#\Greek_Capital_Letter_Beta . #\Greek_Small_Letter_Beta)
     1424                (#\Greek_Capital_Letter_Gamma . #\Greek_Small_Letter_Gamma)
     1425                (#\Greek_Capital_Letter_Delta . #\Greek_Small_Letter_Delta)
     1426                (#\Greek_Capital_Letter_Epsilon . #\Greek_Small_Letter_Epsilon)
     1427                (#\Greek_Capital_Letter_Zeta . #\Greek_Small_Letter_Zeta)
     1428                (#\Greek_Capital_Letter_Eta . #\Greek_Small_Letter_Eta)
     1429                (#\Greek_Capital_Letter_Theta . #\Greek_Small_Letter_Theta)
     1430                (#\Greek_Capital_Letter_Iota . #\Greek_Small_Letter_Iota)
     1431                (#\Greek_Capital_Letter_Kappa . #\Greek_Small_Letter_Kappa)
     1432                (#\Greek_Capital_Letter_Lamda . #\Greek_Small_Letter_Lamda)
     1433                (#\Greek_Capital_Letter_Mu . #\Greek_Small_Letter_Mu)
     1434                (#\Greek_Capital_Letter_Nu . #\Greek_Small_Letter_Nu)
     1435                (#\Greek_Capital_Letter_Xi . #\Greek_Small_Letter_Xi)
     1436                (#\Greek_Capital_Letter_Omicron . #\Greek_Small_Letter_Omicron)
     1437                (#\Greek_Capital_Letter_Pi . #\Greek_Small_Letter_Pi)
     1438                (#\Greek_Capital_Letter_Rho . #\Greek_Small_Letter_Rho)
     1439                (#\Greek_Capital_Letter_Sigma . #\Greek_Small_Letter_Sigma)
     1440                (#\Greek_Capital_Letter_Tau . #\Greek_Small_Letter_Tau)
     1441                (#\Greek_Capital_Letter_Upsilon . #\Greek_Small_Letter_Upsilon)
     1442                (#\Greek_Capital_Letter_Phi . #\Greek_Small_Letter_Phi)
     1443                (#\Greek_Capital_Letter_Chi . #\Greek_Small_Letter_Chi)
     1444                (#\Greek_Capital_Letter_Psi . #\Greek_Small_Letter_Psi)
     1445                (#\Greek_Capital_Letter_Omega . #\Greek_Small_Letter_Omega)
     1446                (#\Greek_Capital_Letter_Iota_With_Dialytika
     1447                 . #\Greek_Small_Letter_Iota_With_Dialytika)
     1448                (#\Greek_Capital_Letter_Upsilon_With_Dialytika
     1449                 . #\Greek_Small_Letter_Upsilon_With_Dialytika)
     1450                (#\Greek_Letter_Archaic_Koppa . #\Greek_Small_Letter_Archaic_Koppa)
     1451                (#\Greek_Letter_Stigma . #\Greek_Small_Letter_Stigma)
     1452                (#\Greek_Letter_Digamma . #\Greek_Small_Letter_Digamma)
     1453                (#\Greek_Letter_Koppa . #\Greek_Small_Letter_Koppa)
     1454                (#\Greek_Letter_Sampi . #\Greek_Small_Letter_Sampi)
     1455                (#\Coptic_Capital_Letter_Shei . #\Coptic_Small_Letter_Shei)
     1456                (#\Coptic_Capital_Letter_Fei . #\Coptic_Small_Letter_Fei)
     1457                (#\Coptic_Capital_Letter_Khei . #\Coptic_Small_Letter_Khei)
     1458                (#\Coptic_Capital_Letter_Hori . #\Coptic_Small_Letter_Hori)
     1459                (#\Coptic_Capital_Letter_Gangia . #\Coptic_Small_Letter_Gangia)
     1460                (#\Coptic_Capital_Letter_Shima . #\Coptic_Small_Letter_Shima)
     1461                (#\Coptic_Capital_Letter_Dei . #\Coptic_Small_Letter_Dei)
     1462                (#\Greek_Capital_Letter_Sho . #\Greek_Small_Letter_Sho)
     1463                (#\Greek_Capital_Lunate_Sigma_Symbol . #\Greek_Lunate_Sigma_Symbol)
     1464                (#\Greek_Capital_Letter_San . #\Greek_Small_Letter_San)
     1465                (#\Greek_Capital_Reversed_Lunate_Sigma_Symbol
     1466                 . #\Greek_Small_Reversed_Lunate_Sigma_Symbol)
     1467                (#\Greek_Capital_Dotted_Lunate_Sigma_Symbol
     1468                 . #\Greek_Small_Dotted_Lunate_Sigma_Symbol)
     1469                (#\Greek_Capital_Reversed_Dotted_Lunate_Sigma_Symbol
     1470                 . #\Greek_Small_Reversed_Dotted_Lunate_Sigma_Symbol)
     1471                (#\Cyrillic_Capital_Letter_Ie_With_Grave
     1472                 . #\Cyrillic_Small_Letter_Ie_With_Grave)
     1473                (#\Cyrillic_Capital_Letter_Io . #\Cyrillic_Small_Letter_Io)
     1474                (#\Cyrillic_Capital_Letter_Dje . #\Cyrillic_Small_Letter_Dje)
     1475                (#\Cyrillic_Capital_Letter_Gje . #\Cyrillic_Small_Letter_Gje)
     1476                (#\Cyrillic_Capital_Letter_Ukrainian_Ie
     1477                 . #\Cyrillic_Small_Letter_Ukrainian_Ie)
     1478                (#\Cyrillic_Capital_Letter_Dze . #\Cyrillic_Small_Letter_Dze)
     1479                (#\Cyrillic_Capital_Letter_Byelorussian-Ukrainian_I
     1480                 . #\Cyrillic_Small_Letter_Byelorussian-Ukrainian_I)
     1481                (#\Cyrillic_Capital_Letter_Yi . #\Cyrillic_Small_Letter_Yi)
     1482                (#\Cyrillic_Capital_Letter_Je . #\Cyrillic_Small_Letter_Je)
     1483                (#\Cyrillic_Capital_Letter_Lje . #\Cyrillic_Small_Letter_Lje)
     1484                (#\Cyrillic_Capital_Letter_Nje . #\Cyrillic_Small_Letter_Nje)
     1485                (#\Cyrillic_Capital_Letter_Tshe . #\Cyrillic_Small_Letter_Tshe)
     1486                (#\Cyrillic_Capital_Letter_Kje . #\Cyrillic_Small_Letter_Kje)
     1487                (#\Cyrillic_Capital_Letter_I_With_Grave
     1488                 . #\Cyrillic_Small_Letter_I_With_Grave)
     1489                (#\Cyrillic_Capital_Letter_Short_U . #\Cyrillic_Small_Letter_Short_U)
     1490                (#\Cyrillic_Capital_Letter_Dzhe . #\Cyrillic_Small_Letter_Dzhe)
     1491                (#\Cyrillic_Capital_Letter_A . #\Cyrillic_Small_Letter_A)
     1492                (#\Cyrillic_Capital_Letter_Be . #\Cyrillic_Small_Letter_Be)
     1493                (#\Cyrillic_Capital_Letter_Ve . #\Cyrillic_Small_Letter_Ve)
     1494                (#\Cyrillic_Capital_Letter_Ghe . #\Cyrillic_Small_Letter_Ghe)
     1495                (#\Cyrillic_Capital_Letter_De . #\Cyrillic_Small_Letter_De)
     1496                (#\Cyrillic_Capital_Letter_Ie . #\Cyrillic_Small_Letter_Ie)
     1497                (#\Cyrillic_Capital_Letter_Zhe . #\Cyrillic_Small_Letter_Zhe)
     1498                (#\Cyrillic_Capital_Letter_Ze . #\Cyrillic_Small_Letter_Ze)
     1499                (#\Cyrillic_Capital_Letter_I . #\Cyrillic_Small_Letter_I)
     1500                (#\Cyrillic_Capital_Letter_Short_I . #\Cyrillic_Small_Letter_Short_I)
     1501                (#\Cyrillic_Capital_Letter_Ka . #\Cyrillic_Small_Letter_Ka)
     1502                (#\Cyrillic_Capital_Letter_El . #\Cyrillic_Small_Letter_El)
     1503                (#\Cyrillic_Capital_Letter_Em . #\Cyrillic_Small_Letter_Em)
     1504                (#\Cyrillic_Capital_Letter_En . #\Cyrillic_Small_Letter_En)
     1505                (#\Cyrillic_Capital_Letter_O . #\Cyrillic_Small_Letter_O)
     1506                (#\Cyrillic_Capital_Letter_Pe . #\Cyrillic_Small_Letter_Pe)
     1507                (#\Cyrillic_Capital_Letter_Er . #\Cyrillic_Small_Letter_Er)
     1508                (#\Cyrillic_Capital_Letter_Es . #\Cyrillic_Small_Letter_Es)
     1509                (#\Cyrillic_Capital_Letter_Te . #\Cyrillic_Small_Letter_Te)
     1510                (#\Cyrillic_Capital_Letter_U . #\Cyrillic_Small_Letter_U)
     1511                (#\Cyrillic_Capital_Letter_Ef . #\Cyrillic_Small_Letter_Ef)
     1512                (#\Cyrillic_Capital_Letter_Ha . #\Cyrillic_Small_Letter_Ha)
     1513                (#\Cyrillic_Capital_Letter_Tse . #\Cyrillic_Small_Letter_Tse)
     1514                (#\Cyrillic_Capital_Letter_Che . #\Cyrillic_Small_Letter_Che)
     1515                (#\Cyrillic_Capital_Letter_Sha . #\Cyrillic_Small_Letter_Sha)
     1516                (#\Cyrillic_Capital_Letter_Shcha . #\Cyrillic_Small_Letter_Shcha)
     1517                (#\Cyrillic_Capital_Letter_Hard_Sign . #\Cyrillic_Small_Letter_Hard_Sign)
     1518                (#\Cyrillic_Capital_Letter_Yeru . #\Cyrillic_Small_Letter_Yeru)
     1519                (#\Cyrillic_Capital_Letter_Soft_Sign . #\Cyrillic_Small_Letter_Soft_Sign)
     1520                (#\Cyrillic_Capital_Letter_E . #\Cyrillic_Small_Letter_E)
     1521                (#\Cyrillic_Capital_Letter_Yu . #\Cyrillic_Small_Letter_Yu)
     1522                (#\Cyrillic_Capital_Letter_Ya . #\Cyrillic_Small_Letter_Ya)
     1523                (#\Cyrillic_Capital_Letter_Omega . #\Cyrillic_Small_Letter_Omega)
     1524                (#\Cyrillic_Capital_Letter_Yat . #\Cyrillic_Small_Letter_Yat)
     1525                (#\Cyrillic_Capital_Letter_Iotified_E . #\Cyrillic_Small_Letter_Iotified_E)
     1526                (#\Cyrillic_Capital_Letter_Little_Yus . #\Cyrillic_Small_Letter_Little_Yus)
     1527                (#\Cyrillic_Capital_Letter_Iotified_Little_Yus
     1528                 . #\Cyrillic_Small_Letter_Iotified_Little_Yus)
     1529                (#\Cyrillic_Capital_Letter_Big_Yus . #\Cyrillic_Small_Letter_Big_Yus)
     1530                (#\Cyrillic_Capital_Letter_Iotified_Big_Yus
     1531                 . #\Cyrillic_Small_Letter_Iotified_Big_Yus)
     1532                (#\Cyrillic_Capital_Letter_Ksi . #\Cyrillic_Small_Letter_Ksi)
     1533                (#\Cyrillic_Capital_Letter_Psi . #\Cyrillic_Small_Letter_Psi)
     1534                (#\Cyrillic_Capital_Letter_Fita . #\Cyrillic_Small_Letter_Fita)
     1535                (#\Cyrillic_Capital_Letter_Izhitsa . #\Cyrillic_Small_Letter_Izhitsa)
     1536                (#\Cyrillic_Capital_Letter_Izhitsa_With_Double_Grave_Accent
     1537                 . #\Cyrillic_Small_Letter_Izhitsa_With_Double_Grave_Accent)
     1538                (#\Cyrillic_Capital_Letter_Uk . #\Cyrillic_Small_Letter_Uk)
     1539                (#\Cyrillic_Capital_Letter_Round_Omega . #\Cyrillic_Small_Letter_Round_Omega)
     1540                (#\Cyrillic_Capital_Letter_Omega_With_Titlo
     1541                 . #\Cyrillic_Small_Letter_Omega_With_Titlo)
     1542                (#\Cyrillic_Capital_Letter_Ot . #\Cyrillic_Small_Letter_Ot)
     1543                (#\Cyrillic_Capital_Letter_Koppa . #\Cyrillic_Small_Letter_Koppa)
     1544                (#\Cyrillic_Capital_Letter_Short_I_With_Tail
     1545                 . #\Cyrillic_Small_Letter_Short_I_With_Tail)
     1546                (#\Cyrillic_Capital_Letter_Semisoft_Sign
     1547                 . #\Cyrillic_Small_Letter_Semisoft_Sign)
     1548                (#\Cyrillic_Capital_Letter_Er_With_Tick
     1549                 . #\Cyrillic_Small_Letter_Er_With_Tick)
     1550                (#\Cyrillic_Capital_Letter_Ghe_With_Upturn
     1551                 . #\Cyrillic_Small_Letter_Ghe_With_Upturn)
     1552                (#\Cyrillic_Capital_Letter_Ghe_With_Stroke
     1553                 . #\Cyrillic_Small_Letter_Ghe_With_Stroke)
     1554                (#\Cyrillic_Capital_Letter_Ghe_With_Middle_Hook
     1555                 . #\Cyrillic_Small_Letter_Ghe_With_Middle_Hook)
     1556                (#\Cyrillic_Capital_Letter_Zhe_With_Descender
     1557                 . #\Cyrillic_Small_Letter_Zhe_With_Descender)
     1558                (#\Cyrillic_Capital_Letter_Ze_With_Descender
     1559                 . #\Cyrillic_Small_Letter_Ze_With_Descender)
     1560                (#\Cyrillic_Capital_Letter_Ka_With_Descender
     1561                 . #\Cyrillic_Small_Letter_Ka_With_Descender)
     1562                (#\Cyrillic_Capital_Letter_Ka_With_Vertical_Stroke
     1563                 . #\Cyrillic_Small_Letter_Ka_With_Vertical_Stroke)
     1564                (#\Cyrillic_Capital_Letter_Ka_With_Stroke
     1565                 . #\Cyrillic_Small_Letter_Ka_With_Stroke)
     1566                (#\Cyrillic_Capital_Letter_Bashkir_Ka . #\Cyrillic_Small_Letter_Bashkir_Ka)
     1567                (#\Cyrillic_Capital_Letter_En_With_Descender
     1568                 . #\Cyrillic_Small_Letter_En_With_Descender)
     1569                (#\Cyrillic_Capital_Ligature_En_Ghe . #\Cyrillic_Small_Ligature_En_Ghe)
     1570                (#\Cyrillic_Capital_Letter_Pe_With_Middle_Hook
     1571                 . #\Cyrillic_Small_Letter_Pe_With_Middle_Hook)
     1572                (#\Cyrillic_Capital_Letter_Abkhasian_Ha
     1573                 . #\Cyrillic_Small_Letter_Abkhasian_Ha)
     1574                (#\Cyrillic_Capital_Letter_Es_With_Descender
     1575                 . #\Cyrillic_Small_Letter_Es_With_Descender)
     1576                (#\Cyrillic_Capital_Letter_Te_With_Descender
     1577                 . #\Cyrillic_Small_Letter_Te_With_Descender)
     1578                (#\Cyrillic_Capital_Letter_Straight_U . #\Cyrillic_Small_Letter_Straight_U)
     1579                (#\Cyrillic_Capital_Letter_Straight_U_With_Stroke
     1580                 . #\Cyrillic_Small_Letter_Straight_U_With_Stroke)
     1581                (#\Cyrillic_Capital_Letter_Ha_With_Descender
     1582                 . #\Cyrillic_Small_Letter_Ha_With_Descender)
     1583                (#\Cyrillic_Capital_Ligature_Te_Tse . #\Cyrillic_Small_Ligature_Te_Tse)
     1584                (#\Cyrillic_Capital_Letter_Che_With_Descender
     1585                 . #\Cyrillic_Small_Letter_Che_With_Descender)
     1586                (#\Cyrillic_Capital_Letter_Che_With_Vertical_Stroke
     1587                 . #\Cyrillic_Small_Letter_Che_With_Vertical_Stroke)
     1588                (#\Cyrillic_Capital_Letter_Shha . #\Cyrillic_Small_Letter_Shha)
     1589                (#\Cyrillic_Capital_Letter_Abkhasian_Che
     1590                 . #\Cyrillic_Small_Letter_Abkhasian_Che)
     1591                (#\Cyrillic_Capital_Letter_Abkhasian_Che_With_Descender
     1592                 . #\Cyrillic_Small_Letter_Abkhasian_Che_With_Descender)
     1593                (#\Cyrillic_Letter_Palochka . #\Cyrillic_Small_Letter_Palochka)
     1594                (#\Cyrillic_Capital_Letter_Zhe_With_Breve
     1595                 . #\Cyrillic_Small_Letter_Zhe_With_Breve)
     1596                (#\Cyrillic_Capital_Letter_Ka_With_Hook
     1597                 . #\Cyrillic_Small_Letter_Ka_With_Hook)
     1598                (#\Cyrillic_Capital_Letter_El_With_Tail
     1599                 . #\Cyrillic_Small_Letter_El_With_Tail)
     1600                (#\Cyrillic_Capital_Letter_En_With_Hook
     1601                 . #\Cyrillic_Small_Letter_En_With_Hook)
     1602                (#\Cyrillic_Capital_Letter_En_With_Tail
     1603                 . #\Cyrillic_Small_Letter_En_With_Tail)
     1604                (#\Cyrillic_Capital_Letter_Khakassian_Che
     1605                 . #\Cyrillic_Small_Letter_Khakassian_Che)
     1606                (#\Cyrillic_Capital_Letter_Em_With_Tail
     1607                 . #\Cyrillic_Small_Letter_Em_With_Tail)
     1608                (#\Cyrillic_Capital_Letter_A_With_Breve
     1609                 . #\Cyrillic_Small_Letter_A_With_Breve)
     1610                (#\Cyrillic_Capital_Letter_A_With_Diaeresis
     1611                 . #\Cyrillic_Small_Letter_A_With_Diaeresis)
     1612                (#\Cyrillic_Capital_Ligature_A_Ie . #\Cyrillic_Small_Ligature_A_Ie)
     1613                (#\Cyrillic_Capital_Letter_Ie_With_Breve
     1614                 . #\Cyrillic_Small_Letter_Ie_With_Breve)
     1615                (#\Cyrillic_Capital_Letter_Schwa . #\Cyrillic_Small_Letter_Schwa)
     1616                (#\Cyrillic_Capital_Letter_Schwa_With_Diaeresis
     1617                 . #\Cyrillic_Small_Letter_Schwa_With_Diaeresis)
     1618                (#\Cyrillic_Capital_Letter_Zhe_With_Diaeresis
     1619                 . #\Cyrillic_Small_Letter_Zhe_With_Diaeresis)
     1620                (#\Cyrillic_Capital_Letter_Ze_With_Diaeresis
     1621                 . #\Cyrillic_Small_Letter_Ze_With_Diaeresis)
     1622                (#\Cyrillic_Capital_Letter_Abkhasian_Dze
     1623                 . #\Cyrillic_Small_Letter_Abkhasian_Dze)
     1624                (#\Cyrillic_Capital_Letter_I_With_Macron
     1625                 . #\Cyrillic_Small_Letter_I_With_Macron)
     1626                (#\Cyrillic_Capital_Letter_I_With_Diaeresis
     1627                 . #\Cyrillic_Small_Letter_I_With_Diaeresis)
     1628                (#\Cyrillic_Capital_Letter_O_With_Diaeresis
     1629                 . #\Cyrillic_Small_Letter_O_With_Diaeresis)
     1630                (#\Cyrillic_Capital_Letter_Barred_O . #\Cyrillic_Small_Letter_Barred_O)
     1631                (#\Cyrillic_Capital_Letter_Barred_O_With_Diaeresis
     1632                 . #\Cyrillic_Small_Letter_Barred_O_With_Diaeresis)
     1633                (#\Cyrillic_Capital_Letter_E_With_Diaeresis
     1634                 . #\Cyrillic_Small_Letter_E_With_Diaeresis)
     1635                (#\Cyrillic_Capital_Letter_U_With_Macron
     1636                 . #\Cyrillic_Small_Letter_U_With_Macron)
     1637                (#\Cyrillic_Capital_Letter_U_With_Diaeresis
     1638                 . #\Cyrillic_Small_Letter_U_With_Diaeresis)
     1639                (#\Cyrillic_Capital_Letter_U_With_Double_Acute
     1640                 . #\Cyrillic_Small_Letter_U_With_Double_Acute)
     1641                (#\Cyrillic_Capital_Letter_Che_With_Diaeresis
     1642                 . #\Cyrillic_Small_Letter_Che_With_Diaeresis)
     1643                (#\Cyrillic_Capital_Letter_Ghe_With_Descender
     1644                 . #\Cyrillic_Small_Letter_Ghe_With_Descender)
     1645                (#\Cyrillic_Capital_Letter_Yeru_With_Diaeresis
     1646                 . #\Cyrillic_Small_Letter_Yeru_With_Diaeresis)
     1647                (#\Cyrillic_Capital_Letter_Ghe_With_Stroke_And_Hook
     1648                 . #\Cyrillic_Small_Letter_Ghe_With_Stroke_And_Hook)
     1649                (#\Cyrillic_Capital_Letter_Ha_With_Hook
     1650                 . #\Cyrillic_Small_Letter_Ha_With_Hook)
     1651                (#\Cyrillic_Capital_Letter_Ha_With_Stroke
     1652                 . #\Cyrillic_Small_Letter_Ha_With_Stroke)
     1653                (#\Cyrillic_Capital_Letter_Komi_De . #\Cyrillic_Small_Letter_Komi_De)
     1654                (#\Cyrillic_Capital_Letter_Komi_Dje . #\Cyrillic_Small_Letter_Komi_Dje)
     1655                (#\Cyrillic_Capital_Letter_Komi_Zje . #\Cyrillic_Small_Letter_Komi_Zje)
     1656                (#\Cyrillic_Capital_Letter_Komi_Dzje . #\Cyrillic_Small_Letter_Komi_Dzje)
     1657                (#\Cyrillic_Capital_Letter_Komi_Lje . #\Cyrillic_Small_Letter_Komi_Lje)
     1658                (#\Cyrillic_Capital_Letter_Komi_Nje . #\Cyrillic_Small_Letter_Komi_Nje)
     1659                (#\Cyrillic_Capital_Letter_Komi_Sje . #\Cyrillic_Small_Letter_Komi_Sje)
     1660                (#\Cyrillic_Capital_Letter_Komi_Tje . #\Cyrillic_Small_Letter_Komi_Tje)
     1661                (#\Cyrillic_Capital_Letter_Reversed_Ze . #\Cyrillic_Small_Letter_Reversed_Ze)
     1662                (#\Cyrillic_Capital_Letter_El_With_Hook
     1663                 . #\Cyrillic_Small_Letter_El_With_Hook)
     1664                (#\Armenian_Capital_Letter_Ayb . #\Armenian_Small_Letter_Ayb)
     1665                (#\Armenian_Capital_Letter_Ben . #\Armenian_Small_Letter_Ben)
     1666                (#\Armenian_Capital_Letter_Gim . #\Armenian_Small_Letter_Gim)
     1667                (#\Armenian_Capital_Letter_Da . #\Armenian_Small_Letter_Da)
     1668                (#\Armenian_Capital_Letter_Ech . #\Armenian_Small_Letter_Ech)
     1669                (#\Armenian_Capital_Letter_Za . #\Armenian_Small_Letter_Za)
     1670                (#\Armenian_Capital_Letter_Eh . #\Armenian_Small_Letter_Eh)
     1671                (#\Armenian_Capital_Letter_Et . #\Armenian_Small_Letter_Et)
     1672                (#\Armenian_Capital_Letter_To . #\Armenian_Small_Letter_To)
     1673                (#\Armenian_Capital_Letter_Zhe . #\Armenian_Small_Letter_Zhe)
     1674                (#\Armenian_Capital_Letter_Ini . #\Armenian_Small_Letter_Ini)
     1675                (#\Armenian_Capital_Letter_Liwn . #\Armenian_Small_Letter_Liwn)
     1676                (#\Armenian_Capital_Letter_Xeh . #\Armenian_Small_Letter_Xeh)
     1677                (#\Armenian_Capital_Letter_Ca . #\Armenian_Small_Letter_Ca)
     1678                (#\Armenian_Capital_Letter_Ken . #\Armenian_Small_Letter_Ken)
     1679                (#\Armenian_Capital_Letter_Ho . #\Armenian_Small_Letter_Ho)
     1680                (#\Armenian_Capital_Letter_Ja . #\Armenian_Small_Letter_Ja)
     1681                (#\Armenian_Capital_Letter_Ghad . #\Armenian_Small_Letter_Ghad)
     1682                (#\Armenian_Capital_Letter_Cheh . #\Armenian_Small_Letter_Cheh)
     1683                (#\Armenian_Capital_Letter_Men . #\Armenian_Small_Letter_Men)
     1684                (#\Armenian_Capital_Letter_Yi . #\Armenian_Small_Letter_Yi)
     1685                (#\Armenian_Capital_Letter_Now . #\Armenian_Small_Letter_Now)
     1686                (#\Armenian_Capital_Letter_Sha . #\Armenian_Small_Letter_Sha)
     1687                (#\Armenian_Capital_Letter_Vo . #\Armenian_Small_Letter_Vo)
     1688                (#\Armenian_Capital_Letter_Cha . #\Armenian_Small_Letter_Cha)
     1689                (#\Armenian_Capital_Letter_Peh . #\Armenian_Small_Letter_Peh)
     1690                (#\Armenian_Capital_Letter_Jheh . #\Armenian_Small_Letter_Jheh)
     1691                (#\Armenian_Capital_Letter_Ra . #\Armenian_Small_Letter_Ra)
     1692                (#\Armenian_Capital_Letter_Seh . #\Armenian_Small_Letter_Seh)
     1693                (#\Armenian_Capital_Letter_Vew . #\Armenian_Small_Letter_Vew)
     1694                (#\Armenian_Capital_Letter_Tiwn . #\Armenian_Small_Letter_Tiwn)
     1695                (#\Armenian_Capital_Letter_Reh . #\Armenian_Small_Letter_Reh)
     1696                (#\Armenian_Capital_Letter_Co . #\Armenian_Small_Letter_Co)
     1697                (#\Armenian_Capital_Letter_Yiwn . #\Armenian_Small_Letter_Yiwn)
     1698                (#\Armenian_Capital_Letter_Piwr . #\Armenian_Small_Letter_Piwr)
     1699                (#\Armenian_Capital_Letter_Keh . #\Armenian_Small_Letter_Keh)
     1700                (#\Armenian_Capital_Letter_Oh . #\Armenian_Small_Letter_Oh)
     1701                (#\Armenian_Capital_Letter_Feh . #\Armenian_Small_Letter_Feh)
     1702                (#\U+10A0 . #\U+2D00) (#\U+10A1 . #\U+2D01) (#\U+10A2 . #\U+2D02)
     1703                (#\U+10A3 . #\U+2D03) (#\U+10A4 . #\U+2D04) (#\U+10A5 . #\U+2D05)
     1704                (#\U+10A6 . #\U+2D06) (#\U+10A7 . #\U+2D07) (#\U+10A8 . #\U+2D08)
     1705                (#\U+10A9 . #\U+2D09) (#\U+10AA . #\U+2D0A) (#\U+10AB . #\U+2D0B)
     1706                (#\U+10AC . #\U+2D0C) (#\U+10AD . #\U+2D0D) (#\U+10AE . #\U+2D0E)
     1707                (#\U+10AF . #\U+2D0F) (#\U+10B0 . #\U+2D10) (#\U+10B1 . #\U+2D11)
     1708                (#\U+10B2 . #\U+2D12) (#\U+10B3 . #\U+2D13) (#\U+10B4 . #\U+2D14)
     1709                (#\U+10B5 . #\U+2D15) (#\U+10B6 . #\U+2D16) (#\U+10B7 . #\U+2D17)
     1710                (#\U+10B8 . #\U+2D18) (#\U+10B9 . #\U+2D19) (#\U+10BA . #\U+2D1A)
     1711                (#\U+10BB . #\U+2D1B) (#\U+10BC . #\U+2D1C) (#\U+10BD . #\U+2D1D)
     1712                (#\U+10BE . #\U+2D1E) (#\U+10BF . #\U+2D1F) (#\U+10C0 . #\U+2D20)
     1713                (#\U+10C1 . #\U+2D21) (#\U+10C2 . #\U+2D22) (#\U+10C3 . #\U+2D23)
     1714                (#\U+10C4 . #\U+2D24) (#\U+10C5 . #\U+2D25) (#\U+1E00 . #\U+1E01)
     1715                (#\U+1E02 . #\U+1E03) (#\U+1E04 . #\U+1E05) (#\U+1E06 . #\U+1E07)
     1716                (#\U+1E08 . #\U+1E09) (#\U+1E0A . #\U+1E0B) (#\U+1E0C . #\U+1E0D)
     1717                (#\U+1E0E . #\U+1E0F) (#\U+1E10 . #\U+1E11) (#\U+1E12 . #\U+1E13)
     1718                (#\U+1E14 . #\U+1E15) (#\U+1E16 . #\U+1E17) (#\U+1E18 . #\U+1E19)
     1719                (#\U+1E1A . #\U+1E1B) (#\U+1E1C . #\U+1E1D) (#\U+1E1E . #\U+1E1F)
     1720                (#\U+1E20 . #\U+1E21) (#\U+1E22 . #\U+1E23) (#\U+1E24 . #\U+1E25)
     1721                (#\U+1E26 . #\U+1E27) (#\U+1E28 . #\U+1E29) (#\U+1E2A . #\U+1E2B)
     1722                (#\U+1E2C . #\U+1E2D) (#\U+1E2E . #\U+1E2F) (#\U+1E30 . #\U+1E31)
     1723                (#\U+1E32 . #\U+1E33) (#\U+1E34 . #\U+1E35) (#\U+1E36 . #\U+1E37)
     1724                (#\U+1E38 . #\U+1E39) (#\U+1E3A . #\U+1E3B) (#\U+1E3C . #\U+1E3D)
     1725                (#\U+1E3E . #\U+1E3F) (#\U+1E40 . #\U+1E41) (#\U+1E42 . #\U+1E43)
     1726                (#\U+1E44 . #\U+1E45) (#\U+1E46 . #\U+1E47) (#\U+1E48 . #\U+1E49)
     1727                (#\U+1E4A . #\U+1E4B) (#\U+1E4C . #\U+1E4D) (#\U+1E4E . #\U+1E4F)
     1728                (#\U+1E50 . #\U+1E51) (#\U+1E52 . #\U+1E53) (#\U+1E54 . #\U+1E55)
     1729                (#\U+1E56 . #\U+1E57) (#\U+1E58 . #\U+1E59) (#\U+1E5A . #\U+1E5B)
     1730                (#\U+1E5C . #\U+1E5D) (#\U+1E5E . #\U+1E5F) (#\U+1E60 . #\U+1E61)
     1731                (#\U+1E62 . #\U+1E63) (#\U+1E64 . #\U+1E65) (#\U+1E66 . #\U+1E67)
     1732                (#\U+1E68 . #\U+1E69) (#\U+1E6A . #\U+1E6B) (#\U+1E6C . #\U+1E6D)
     1733                (#\U+1E6E . #\U+1E6F) (#\U+1E70 . #\U+1E71) (#\U+1E72 . #\U+1E73)
     1734                (#\U+1E74 . #\U+1E75) (#\U+1E76 . #\U+1E77) (#\U+1E78 . #\U+1E79)
     1735                (#\U+1E7A . #\U+1E7B) (#\U+1E7C . #\U+1E7D) (#\U+1E7E . #\U+1E7F)
     1736                (#\U+1E80 . #\U+1E81) (#\U+1E82 . #\U+1E83) (#\U+1E84 . #\U+1E85)
     1737                (#\U+1E86 . #\U+1E87) (#\U+1E88 . #\U+1E89) (#\U+1E8A . #\U+1E8B)
     1738                (#\U+1E8C . #\U+1E8D) (#\U+1E8E . #\U+1E8F) (#\U+1E90 . #\U+1E91)
     1739                (#\U+1E92 . #\U+1E93) (#\U+1E94 . #\U+1E95) (#\U+1EA0 . #\U+1EA1)
     1740                (#\U+1EA2 . #\U+1EA3) (#\U+1EA4 . #\U+1EA5) (#\U+1EA6 . #\U+1EA7)
     1741                (#\U+1EA8 . #\U+1EA9) (#\U+1EAA . #\U+1EAB) (#\U+1EAC . #\U+1EAD)
     1742                (#\U+1EAE . #\U+1EAF) (#\U+1EB0 . #\U+1EB1) (#\U+1EB2 . #\U+1EB3)
     1743                (#\U+1EB4 . #\U+1EB5) (#\U+1EB6 . #\U+1EB7) (#\U+1EB8 . #\U+1EB9)
     1744                (#\U+1EBA . #\U+1EBB) (#\U+1EBC . #\U+1EBD) (#\U+1EBE . #\U+1EBF)
     1745                (#\U+1EC0 . #\U+1EC1) (#\U+1EC2 . #\U+1EC3) (#\U+1EC4 . #\U+1EC5)
     1746                (#\U+1EC6 . #\U+1EC7) (#\U+1EC8 . #\U+1EC9) (#\U+1ECA . #\U+1ECB)
     1747                (#\U+1ECC . #\U+1ECD) (#\U+1ECE . #\U+1ECF) (#\U+1ED0 . #\U+1ED1)
     1748                (#\U+1ED2 . #\U+1ED3) (#\U+1ED4 . #\U+1ED5) (#\U+1ED6 . #\U+1ED7)
     1749                (#\U+1ED8 . #\U+1ED9) (#\U+1EDA . #\U+1EDB) (#\U+1EDC . #\U+1EDD)
     1750                (#\U+1EDE . #\U+1EDF) (#\U+1EE0 . #\U+1EE1) (#\U+1EE2 . #\U+1EE3)
     1751                (#\U+1EE4 . #\U+1EE5) (#\U+1EE6 . #\U+1EE7) (#\U+1EE8 . #\U+1EE9)
     1752                (#\U+1EEA . #\U+1EEB) (#\U+1EEC . #\U+1EED) (#\U+1EEE . #\U+1EEF)
     1753                (#\U+1EF0 . #\U+1EF1) (#\U+1EF2 . #\U+1EF3) (#\U+1EF4 . #\U+1EF5)
     1754                (#\U+1EF6 . #\U+1EF7) (#\U+1EF8 . #\U+1EF9) (#\U+1F08 . #\U+1F00)
     1755                (#\U+1F09 . #\U+1F01) (#\U+1F0A . #\U+1F02) (#\U+1F0B . #\U+1F03)
     1756                (#\U+1F0C . #\U+1F04) (#\U+1F0D . #\U+1F05) (#\U+1F0E . #\U+1F06)
     1757                (#\U+1F0F . #\U+1F07) (#\U+1F18 . #\U+1F10) (#\U+1F19 . #\U+1F11)
     1758                (#\U+1F1A . #\U+1F12) (#\U+1F1B . #\U+1F13) (#\U+1F1C . #\U+1F14)
     1759                (#\U+1F1D . #\U+1F15) (#\U+1F28 . #\U+1F20) (#\U+1F29 . #\U+1F21)
     1760                (#\U+1F2A . #\U+1F22) (#\U+1F2B . #\U+1F23) (#\U+1F2C . #\U+1F24)
     1761                (#\U+1F2D . #\U+1F25) (#\U+1F2E . #\U+1F26) (#\U+1F2F . #\U+1F27)
     1762                (#\U+1F38 . #\U+1F30) (#\U+1F39 . #\U+1F31) (#\U+1F3A . #\U+1F32)
     1763                (#\U+1F3B . #\U+1F33) (#\U+1F3C . #\U+1F34) (#\U+1F3D . #\U+1F35)
     1764                (#\U+1F3E . #\U+1F36) (#\U+1F3F . #\U+1F37) (#\U+1F48 . #\U+1F40)
     1765                (#\U+1F49 . #\U+1F41) (#\U+1F4A . #\U+1F42) (#\U+1F4B . #\U+1F43)
     1766                (#\U+1F4C . #\U+1F44) (#\U+1F4D . #\U+1F45) (#\U+1F59 . #\U+1F51)
     1767                (#\U+1F5B . #\U+1F53) (#\U+1F5D . #\U+1F55) (#\U+1F5F . #\U+1F57)
     1768                (#\U+1F68 . #\U+1F60) (#\U+1F69 . #\U+1F61) (#\U+1F6A . #\U+1F62)
     1769                (#\U+1F6B . #\U+1F63) (#\U+1F6C . #\U+1F64) (#\U+1F6D . #\U+1F65)
     1770                (#\U+1F6E . #\U+1F66) (#\U+1F6F . #\U+1F67) (#\U+1F88 . #\U+1F80)
     1771                (#\U+1F89 . #\U+1F81) (#\U+1F8A . #\U+1F82) (#\U+1F8B . #\U+1F83)
     1772                (#\U+1F8C . #\U+1F84) (#\U+1F8D . #\U+1F85) (#\U+1F8E . #\U+1F86)
     1773                (#\U+1F8F . #\U+1F87) (#\U+1F98 . #\U+1F90) (#\U+1F99 . #\U+1F91)
     1774                (#\U+1F9A . #\U+1F92) (#\U+1F9B . #\U+1F93) (#\U+1F9C . #\U+1F94)
     1775                (#\U+1F9D . #\U+1F95) (#\U+1F9E . #\U+1F96) (#\U+1F9F . #\U+1F97)
     1776                (#\U+1FA8 . #\U+1FA0) (#\U+1FA9 . #\U+1FA1) (#\U+1FAA . #\U+1FA2)
     1777                (#\U+1FAB . #\U+1FA3) (#\U+1FAC . #\U+1FA4) (#\U+1FAD . #\U+1FA5)
     1778                (#\U+1FAE . #\U+1FA6) (#\U+1FAF . #\U+1FA7) (#\U+1FB8 . #\U+1FB0)
     1779                (#\U+1FB9 . #\U+1FB1) (#\U+1FBA . #\U+1F70) (#\U+1FBB . #\U+1F71)
     1780                (#\U+1FBC . #\U+1FB3) (#\U+1FC8 . #\U+1F72) (#\U+1FC9 . #\U+1F73)
     1781                (#\U+1FCA . #\U+1F74) (#\U+1FCB . #\U+1F75) (#\U+1FCC . #\U+1FC3)
     1782                (#\U+1FD8 . #\U+1FD0) (#\U+1FD9 . #\U+1FD1) (#\U+1FDA . #\U+1F76)
     1783                (#\U+1FDB . #\U+1F77) (#\U+1FE8 . #\U+1FE0) (#\U+1FE9 . #\U+1FE1)
     1784                (#\U+1FEA . #\U+1F7A) (#\U+1FEB . #\U+1F7B) (#\U+1FEC . #\U+1FE5)
     1785                (#\U+1FF8 . #\U+1F78) (#\U+1FF9 . #\U+1F79) (#\U+1FFA . #\U+1F7C)
     1786                (#\U+1FFB . #\U+1F7D) (#\U+1FFC . #\U+1FF3) (#\U+2132 . #\U+214E)
     1787                (#\U+2160 . #\U+2170) (#\U+2161 . #\U+2171) (#\U+2162 . #\U+2172)
     1788                (#\U+2163 . #\U+2173) (#\U+2164 . #\U+2174) (#\U+2165 . #\U+2175)
     1789                (#\U+2166 . #\U+2176) (#\U+2167 . #\U+2177) (#\U+2168 . #\U+2178)
     1790                (#\U+2169 . #\U+2179) (#\U+216A . #\U+217A) (#\U+216B . #\U+217B)
     1791                (#\U+216C . #\U+217C) (#\U+216D . #\U+217D) (#\U+216E . #\U+217E)
     1792                (#\U+216F . #\U+217F) (#\U+2183 . #\U+2184) (#\U+24B6 . #\U+24D0)
     1793                (#\U+24B7 . #\U+24D1) (#\U+24B8 . #\U+24D2) (#\U+24B9 . #\U+24D3)
     1794                (#\U+24BA . #\U+24D4) (#\U+24BB . #\U+24D5) (#\U+24BC . #\U+24D6)
     1795                (#\U+24BD . #\U+24D7) (#\U+24BE . #\U+24D8) (#\U+24BF . #\U+24D9)
     1796                (#\U+24C0 . #\U+24DA) (#\U+24C1 . #\U+24DB) (#\U+24C2 . #\U+24DC)
     1797                (#\U+24C3 . #\U+24DD) (#\U+24C4 . #\U+24DE) (#\U+24C5 . #\U+24DF)
     1798                (#\U+24C6 . #\U+24E0) (#\U+24C7 . #\U+24E1) (#\U+24C8 . #\U+24E2)
     1799                (#\U+24C9 . #\U+24E3) (#\U+24CA . #\U+24E4) (#\U+24CB . #\U+24E5)
     1800                (#\U+24CC . #\U+24E6) (#\U+24CD . #\U+24E7) (#\U+24CE . #\U+24E8)
     1801                (#\U+24CF . #\U+24E9) (#\U+2C00 . #\U+2C30) (#\U+2C01 . #\U+2C31)
     1802                (#\U+2C02 . #\U+2C32) (#\U+2C03 . #\U+2C33) (#\U+2C04 . #\U+2C34)
     1803                (#\U+2C05 . #\U+2C35) (#\U+2C06 . #\U+2C36) (#\U+2C07 . #\U+2C37)
     1804                (#\U+2C08 . #\U+2C38) (#\U+2C09 . #\U+2C39) (#\U+2C0A . #\U+2C3A)
     1805                (#\U+2C0B . #\U+2C3B) (#\U+2C0C . #\U+2C3C) (#\U+2C0D . #\U+2C3D)
     1806                (#\U+2C0E . #\U+2C3E) (#\U+2C0F . #\U+2C3F) (#\U+2C10 . #\U+2C40)
     1807                (#\U+2C11 . #\U+2C41) (#\U+2C12 . #\U+2C42) (#\U+2C13 . #\U+2C43)
     1808                (#\U+2C14 . #\U+2C44) (#\U+2C15 . #\U+2C45) (#\U+2C16 . #\U+2C46)
     1809                (#\U+2C17 . #\U+2C47) (#\U+2C18 . #\U+2C48) (#\U+2C19 . #\U+2C49)
     1810                (#\U+2C1A . #\U+2C4A) (#\U+2C1B . #\U+2C4B) (#\U+2C1C . #\U+2C4C)
     1811                (#\U+2C1D . #\U+2C4D) (#\U+2C1E . #\U+2C4E) (#\U+2C1F . #\U+2C4F)
     1812                (#\U+2C20 . #\U+2C50) (#\U+2C21 . #\U+2C51) (#\U+2C22 . #\U+2C52)
     1813                (#\U+2C23 . #\U+2C53) (#\U+2C24 . #\U+2C54) (#\U+2C25 . #\U+2C55)
     1814                (#\U+2C26 . #\U+2C56) (#\U+2C27 . #\U+2C57) (#\U+2C28 . #\U+2C58)
     1815                (#\U+2C29 . #\U+2C59) (#\U+2C2A . #\U+2C5A) (#\U+2C2B . #\U+2C5B)
     1816                (#\U+2C2C . #\U+2C5C) (#\U+2C2D . #\U+2C5D) (#\U+2C2E . #\U+2C5E)
     1817                (#\U+2C60 . #\U+2C61) (#\U+2C62 . #\Latin_Small_Letter_L_With_Middle_Tilde)
     1818                (#\U+2C63 . #\U+1D7D) (#\U+2C64 . #\Latin_Small_Letter_R_With_Tail)
     1819                (#\U+2C67 . #\U+2C68) (#\U+2C69 . #\U+2C6A) (#\U+2C6B . #\U+2C6C)
     1820                (#\U+2C75 . #\U+2C76) (#\U+2C80 . #\U+2C81) (#\U+2C82 . #\U+2C83)
     1821                (#\U+2C84 . #\U+2C85) (#\U+2C86 . #\U+2C87) (#\U+2C88 . #\U+2C89)
     1822                (#\U+2C8A . #\U+2C8B) (#\U+2C8C . #\U+2C8D) (#\U+2C8E . #\U+2C8F)
     1823                (#\U+2C90 . #\U+2C91) (#\U+2C92 . #\U+2C93) (#\U+2C94 . #\U+2C95)
     1824                (#\U+2C96 . #\U+2C97) (#\U+2C98 . #\U+2C99) (#\U+2C9A . #\U+2C9B)
     1825                (#\U+2C9C . #\U+2C9D) (#\U+2C9E . #\U+2C9F) (#\U+2CA0 . #\U+2CA1)
     1826                (#\U+2CA2 . #\U+2CA3) (#\U+2CA4 . #\U+2CA5) (#\U+2CA6 . #\U+2CA7)
     1827                (#\U+2CA8 . #\U+2CA9) (#\U+2CAA . #\U+2CAB) (#\U+2CAC . #\U+2CAD)
     1828                (#\U+2CAE . #\U+2CAF) (#\U+2CB0 . #\U+2CB1) (#\U+2CB2 . #\U+2CB3)
     1829                (#\U+2CB4 . #\U+2CB5) (#\U+2CB6 . #\U+2CB7) (#\U+2CB8 . #\U+2CB9)
     1830                (#\U+2CBA . #\U+2CBB) (#\U+2CBC . #\U+2CBD) (#\U+2CBE . #\U+2CBF)
     1831                (#\U+2CC0 . #\U+2CC1) (#\U+2CC2 . #\U+2CC3) (#\U+2CC4 . #\U+2CC5)
     1832                (#\U+2CC6 . #\U+2CC7) (#\U+2CC8 . #\U+2CC9) (#\U+2CCA . #\U+2CCB)
     1833                (#\U+2CCC . #\U+2CCD) (#\U+2CCE . #\U+2CCF) (#\U+2CD0 . #\U+2CD1)
     1834                (#\U+2CD2 . #\U+2CD3) (#\U+2CD4 . #\U+2CD5) (#\U+2CD6 . #\U+2CD7)
     1835                (#\U+2CD8 . #\U+2CD9) (#\U+2CDA . #\U+2CDB) (#\U+2CDC . #\U+2CDD)
     1836                (#\U+2CDE . #\U+2CDF) (#\U+2CE0 . #\U+2CE1) (#\U+2CE2 . #\U+2CE3)
     1837                (#\U+FF21 . #\U+FF41) (#\U+FF22 . #\U+FF42) (#\U+FF23 . #\U+FF43)
     1838                (#\U+FF24 . #\U+FF44) (#\U+FF25 . #\U+FF45) (#\U+FF26 . #\U+FF46)
     1839                (#\U+FF27 . #\U+FF47) (#\U+FF28 . #\U+FF48) (#\U+FF29 . #\U+FF49)
     1840                (#\U+FF2A . #\U+FF4A) (#\U+FF2B . #\U+FF4B) (#\U+FF2C . #\U+FF4C)
     1841                (#\U+FF2D . #\U+FF4D) (#\U+FF2E . #\U+FF4E) (#\U+FF2F . #\U+FF4F)
     1842                (#\U+FF30 . #\U+FF50) (#\U+FF31 . #\U+FF51) (#\U+FF32 . #\U+FF52)
     1843                (#\U+FF33 . #\U+FF53) (#\U+FF34 . #\U+FF54) (#\U+FF35 . #\U+FF55)
     1844                (#\U+FF36 . #\U+FF56) (#\U+FF37 . #\U+FF57) (#\U+FF38 . #\U+FF58)
     1845                (#\U+FF39 . #\U+FF59) (#\U+FF3A . #\U+FF5A) (#\U+10400 . #\U+10428)
     1846                (#\U+10401 . #\U+10429) (#\U+10402 . #\U+1042A) (#\U+10403 . #\U+1042B)
     1847                (#\U+10404 . #\U+1042C) (#\U+10405 . #\U+1042D) (#\U+10406 . #\U+1042E)
     1848                (#\U+10407 . #\U+1042F) (#\U+10408 . #\U+10430) (#\U+10409 . #\U+10431)
     1849                (#\U+1040A . #\U+10432) (#\U+1040B . #\U+10433) (#\U+1040C . #\U+10434)
     1850                (#\U+1040D . #\U+10435) (#\U+1040E . #\U+10436) (#\U+1040F . #\U+10437)
     1851                (#\U+10410 . #\U+10438) (#\U+10411 . #\U+10439) (#\U+10412 . #\U+1043A)
     1852                (#\U+10413 . #\U+1043B) (#\U+10414 . #\U+1043C) (#\U+10415 . #\U+1043D)
     1853                (#\U+10416 . #\U+1043E) (#\U+10417 . #\U+1043F) (#\U+10418 . #\U+10440)
     1854                (#\U+10419 . #\U+10441) (#\U+1041A . #\U+10442) (#\U+1041B . #\U+10443)
     1855                (#\U+1041C . #\U+10444) (#\U+1041D . #\U+10445) (#\U+1041E . #\U+10446)
     1856                (#\U+1041F . #\U+10447) (#\U+10420 . #\U+10448) (#\U+10421 . #\U+10449)
     1857                (#\U+10422 . #\U+1044A) (#\U+10423 . #\U+1044B) (#\U+10424 . #\U+1044C)
     1858                (#\U+10425 . #\U+1044D) (#\U+10426 . #\U+1044E) (#\U+10427 . #\U+1044F)))
     1859  (destructuring-bind (upper . lower) pair
     1860    (setf (gethash upper *non-standard-upper-to-lower*) lower
     1861          (gethash lower *non-standard-lower-to-upper*) upper)))
     1862
     1863(defun %non-standard-upper-case-equivalent (char)
     1864  (gethash char *non-standard-lower-to-upper*))
     1865
     1866;;;True for a-z, and maybe other things.
    11361867(defun lower-case-p (c)
    11371868  "The argument must be a character object; LOWER-CASE-P returns T if the
    11381869   argument is a lower-case character, NIL otherwise."
    11391870  (let ((code (char-code c)))
    1140     (and (>= code (char-code #\a))
    1141          (<= code (char-code #\z)))))
    1142 
    1143 ;True for a-z A-Z
     1871    (if (< code #x80)
     1872      (and (>= code (char-code #\a))
     1873           (<= code (char-code #\z)))
     1874     (not (null (%non-standard-upper-case-equivalent c))))))
     1875
     1876
     1877;;;True for a-z A-Z, others.
    11441878
    11451879
    11461880(defun alpha-char-p (c)
    11471881  "The argument must be a character object. ALPHA-CHAR-P returns T if the
    1148    argument is an alphabetic character, A-Z or a-z; otherwise NIL."
     1882   argument is an alphabetic character; otherwise NIL."
    11491883  (let* ((code (char-code c)))
    11501884    (declare (fixnum code))
    11511885    (or (and (>= code (char-code #\A)) (<= code (char-code #\Z)))
    1152         (and (>= code (char-code #\a)) (<= code (char-code #\z))))))
    1153 
    1154 
    1155 
    1156 
    1157 ; def-accessors type-tracking stuff.  Used by inspector
     1886        (and (>= code (char-code #\a)) (<= code (char-code #\z)))
     1887        (and (>= code #x80)
     1888             (or (not (null (%non-standard-upper-case-equivalent c)))
     1889                 (not (null (%non-standard-lower-case-equivalent c))))))))
     1890
     1891
     1892
     1893
     1894;;; def-accessors type-tracking stuff.  Used by inspector
    11581895(defvar *def-accessor-types* nil)
    11591896

  • branches/ia32/level-1/l1-boot-1.lisp

    r4827 r7666  
    3030|#
    3131
    32 (defun lisp-implementation-type () "OpenMCL")
     32(defun lisp-implementation-type ()
     33  #+clozure-common-lisp "Clozure Common Lisp"
     34  #-clozure-common-lisp "OpenMCL")
    3335
    3436

  • branches/ia32/level-1/l1-boot-lds.lisp

    r5893 r7666  
    2929(defun startup-ccl (&optional init-file)
    3030  (with-simple-restart (abort "Abort startup.")
    31     (when init-file
    32       (with-simple-restart (continue "Skip loading init file.")
    33         (load init-file :if-does-not-exist nil :verbose nil)))
     31    (let ((init-files (if (listp init-file) init-file (list init-file))))
     32      (dolist (init-file init-files)
     33        (with-simple-restart (continue "Skip loading init file.")
     34          (when (load init-file :if-does-not-exist nil :verbose nil)
     35            #+clozure-common-lisp ;; Kludge to help people transition
     36            (when (equalp (pathname-name init-file) "openmcl-init")
     37              (warn ">>>>>> The use of openmcl-init.lisp is deprecated.  Please rename your init file to ccl-init.lisp"))
     38            (return)))))
    3439    (flet ((eval-string (s)
    3540             (with-simple-restart (continue "Skip evaluation of ~a" s)

  • branches/ia32/level-1/l1-files.lisp

    r6939 r7666  
    312312
    313313(defun ensure-directory-namestring (string)
    314   (let* ((len (length string)))
    315     (if (and (> len 1)
    316              (not (eql (char string (1- len)) #\/)))
    317       (concatenate 'string string "/")
    318       string)))
     314  (namestring (ensure-directory-pathname string)))
     315
     316(defun ensure-directory-pathname (pathname)
     317  (let ((path (pathname pathname)))
     318    (if (directory-pathname-p path)
     319        path
     320        (cons-pathname (append (or (pathname-directory path)
     321                                   ;; This makes sure "ccl:foo" maps to "ccl:foo;" (not
     322                                   ;; "ccl:;foo;"), but "foo" maps to "foo/" (not "/foo/").
     323                                   (if (eq (pathname-host path) :unspecific)
     324                                       '(:relative)
     325                                       '(:absolute)))
     326                               ;; Don't use file-namestring, because that
     327                               ;; includes the version for logical names.
     328                               (list (file-namestring-from-parts
     329                                      (pathname-name path)
     330                                      (pathname-type path)
     331                                      nil)))
     332                       nil nil (pathname-host path)))))
    319333
    320334(defun %directory-list-namestring (list &optional logical-p)
    … …  
    12861300  (let ((mod-path (make-pathname :name (string-downcase module) :defaults nil)) path)
    12871301        (dolist (path-cand *module-search-path* nil)
    1288           (when (setq path (find-load-file (merge-pathnames mod-path path-cand)))
    1289             (return path)))))
     1302          (let ((mod-cand (merge-pathnames mod-path path-cand)))
     1303            (if (wild-pathname-p path-cand)
     1304                (let* ((untyped-p (member (pathname-type mod-cand) '(nil :unspecific)))
     1305                       (matches (if untyped-p
     1306                                    (or (directory (merge-pathnames mod-cand *.lisp-pathname*))
     1307                                        (directory (merge-pathnames mod-cand *.fasl-pathname*)))
     1308                                    (directory mod-cand))))
     1309                  (when (and matches (null (cdr matches)))
     1310                    (return (if untyped-p
     1311                                (make-pathname :type nil :defaults (car matches))
     1312                                (car matches)))))
     1313                (when (setq path (find-load-file (merge-pathnames mod-path path-cand)))
     1314                  (return path)))))))
    12901315
    12911316(defun wild-pathname-p (pathname &optional field-key)

  • branches/ia32/level-1/l1-io.lisp

    r6192 r7666  
    224224(defvar *current-length* nil) ; must be nil at top level
    225225
     226(defvar *print-catch-errors* t)
    226227
    227228;;;; ======================================================================
    … …  
    450451                                                          (%i- list-kludge 1)
    451452                                                          list-kludge)))))
     453
     454(defmethod print-object :around ((object t) stream)
     455  (if *print-catch-errors*
     456    (handler-case (call-next-method)
     457      (error () (write-string "#<error printing object>" stream)))
     458    (call-next-method)))
    452459
    453460(defmethod print-object ((object t) stream)

  • branches/ia32/level-1/l1-lisp-threads.lisp

    r7362 r7666  
    5252          (if (and (< result 0)
    5353                   (eql (%get-errno) (- #$EINTR)))
    54             (psetq aptr bptr bptr aptr)
     54            ;; x86-64 Leopard bug.
     55            (let* ((asec (pref aptr :timespec.tv_sec))
     56                   (bsec (pref bptr :timespec.tv_sec)))
     57              (if (and (>= bsec 0)
     58                       (or (< bsec asec)
     59                           (and (= bsec asec)
     60                                (< (pref bptr :timespec.tv_nsec)
     61                                   (pref aptr :timespec.tv_nsec)))))
     62                (psetq aptr bptr bptr aptr)
     63                (return)))
    5564            (return)))))))
    5665

  • branches/ia32/level-1/l1-pathnames.lisp

    r6941 r7666  
    2424(in-package "CCL")
    2525
    26 (defloadvar *heap-image-name*
    27     (let* ((p (%null-ptr)))
    28       (declare (dynamic-extent p))
    29       (%get-cstring (%get-kernel-global-ptr 'image-name p))))
     26(defun heap-image-name ()
     27  (let* ((p (%null-ptr)))
     28    (declare (dynamic-extent p))
     29    (%get-cstring (%get-kernel-global-ptr 'image-name p))))
     30
     31(defloadvar *heap-image-name* (heap-image-name))
    3032
    3133(defloadvar *command-line-argument-list*
    … …  
    629631      (native-to-directory-pathname dirpath)
    630632      (let* ((directory-containing-heap-image
    631               (make-pathname :directory (pathname-directory (%realpath *heap-image-name*))))
     633              (make-pathname :directory (pathname-directory (%realpath (heap-image-name)))))
    632634             (rpath (merge-pathnames
    633635                     #+darwinppc-target "../Resources/ccl/"
    … …  
    701703(defparameter *module-search-path* (list
    702704                                    (cons-pathname '(:absolute "bin") nil nil "ccl")
    703                                     (cons-pathname  '(:absolute "openmcl" "modules") nil nil "home")
     705                                    (cons-pathname '(:absolute "openmcl" "modules") nil nil "home")
    704706                                    (cons-pathname '(:absolute "lib") nil nil "ccl")
    705707                                    (cons-pathname '(:absolute "library") nil nil "ccl")
    706                                     (cons-pathname '(:absolute "examples") nil nil "ccl")
     708                                    (cons-pathname '(:absolute "examples" :wild-inferiors) nil nil "ccl")
    707709                                    (cons-pathname '(:absolute "tools") nil nil "ccl")
    708710                                    (cons-pathname '(:absolute "objc-bridge") nil nil "ccl")

  • branches/ia32/level-1/l1-reader.lisp

    r6637 r7666  
    18961896                        (set-schar str 4 #\^@)
    18971897                        (set-schar str 5 #\^J)
     1898                        (set-schar str 0 #\Space)
    18981899                        (set-schar str 6 (code-char #xa0))
    18991900                        str))
    … …  
    19631964    (dotimes (ch (1+ (char-code #\Space)))
    19641965      (uvset ttab ch $cht_wsp))
     1966    (uvset ttab #xa0 $cht_wsp)
    19651967    (uvset ttab (char-code #\\) $cht_sesc)
    19661968    (uvset ttab (char-code #\|) $cht_mesc)
    … …  
    27032705           (list sharp-comma-token (read stream t nil t)))))))
    27042706
     2707;;; Read a valid, non-numeric token string from stream; *READ-SUPPRESS*
     2708;;; is known to be false.
     2709(defun read-symbol-token (stream)
     2710  (multiple-value-bind (firstch attr) (%next-non-whitespace-char-and-attr-no-eof stream)
     2711    (declare (fixnum attr))
     2712    (with-token-buffer (tb)
     2713      (if (or (= attr $CHT_ILL)
     2714              (logbitp $cht_macbit attr)
     2715              (multiple-value-bind (escapes explicit-package nondots) (%collect-xtoken tb stream firstch)
     2716                (declare (ignore nondots))
     2717                (%casify-token tb (unless (atom escapes) escapes))
     2718                (or explicit-package
     2719                    (and (not escapes)
     2720                         (%token-to-number tb (%validate-radix *read-base*))))))
     2721        (%err-disp $XBADSYM)
     2722        (%string-from-token tb)))))
     2723
    27052724(set-dispatch-macro-character
    27062725 #\#
    … …  
    27092728     (require-no-numarg subchar numarg)
    27102729     (if (not *read-suppress*)
    2711          (multiple-value-bind (firstch attr) (%next-non-whitespace-char-and-attr-no-eof stream)
    2712            (declare (fixnum attr))
    2713            (with-token-buffer (tb)
    2714              (if (or (= attr $CHT_ILL)
    2715                      (logbitp $cht_macbit attr)
    2716                      (multiple-value-bind (escapes explicit-package nondots) (%collect-xtoken tb stream firstch)
    2717                        (declare (ignore nondots))
    2718                        (%casify-token tb (unless (atom escapes) escapes))
    2719                        (or explicit-package
    2720                            (and (not escapes)
    2721                                 (%token-to-number tb (%validate-radix *read-base*))))))
    2722                (%err-disp $XBADSYM)
    2723                (make-symbol (%string-from-token tb)))))
    2724          (progn
    2725            (%read-list-expression stream nil)
    2726            nil))))
     2730       (make-symbol (read-symbol-token stream))
     2731       (progn
     2732         (%read-list-expression stream nil)
     2733         nil))))
    27272734
    27282735(set-dispatch-macro-character

  • branches/ia32/level-1/l1-sockets.lisp

    r6914 r7666  
    14451445                ((%null-ptr-p q) (nreverse res))
    14461446             (let* ((addr (pref q :ifaddrs.ifa_addr)))
    1447                (when (eql (pref addr :sockaddr.sa_family) #$AF_INET)
     1447               (when (and (not (%null-ptr-p addr))
     1448                          (eql (pref addr :sockaddr.sa_family) #$AF_INET))
    14481449                 (push (make-ip-interface
    14491450                                   :name (%get-cstring (pref q :ifaddrs.ifa_name))

  • branches/ia32/level-1/l1-streams.lisp

    r7340 r7666  
    6262;;; stream's current position, if that makes sense.  Return NIL
    6363;;; if it doesn't make sense.
    64 (defmethod stream-surrounding-characters ((s stream))
     64;;; Catch cases where this is used when STREAM-ERRORs (SOCKET-ERRORs)
     65;;; are signaled on non-STREAMs.
     66(defmethod stream-surrounding-characters ((s t))
     67  (declare (ignore s))
    6568  nil)
    6669
    … …  
    33343337
    33353338(defmethod stream-external-format ((s character-stream))
    3336   (make-external-format :character-encoding #+big-endian-target :utf32-be #+little-endian-target :utf32-le :line-termination :unix))
     3339  (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix))
    33373340
    33383341

  • branches/ia32/level-1/linux-files.lisp

    r7340 r7666  
    186186        (setf (%get-byte name last) 0))
    187187    (syscall syscalls::mkdir name mode))))
     188
     189(defun %rmdir (name)
     190  (let* ((last (1- (length name))))
     191    (with-cstrs ((name name))
     192      (when (and (>= last 0)
     193                 (eql (%get-byte name last) (char-code #\/)))
     194        (setf (%get-byte name last) 0))
     195    (syscall syscalls::rmdir name))))
    188196
    189197(defun getenv (key)
    … …  
    13651373    (percentage-of-resident-pages address nbytes)))
    13661374 
     1375#+x86-target
     1376(progn
     1377(defloadvar *last-rdtsc-time* 0)
     1378
     1379(defstatic *rdtsc-estimated-increment* 1 "Should be positive ...")
     1380
     1381(defun rdtsc-monotonic ()
     1382  "Return monotonically increasing values, partly compensating for
     1383   OSes that don't keep the TSCs of all processorsin synch."
     1384  (loop
     1385    (let* ((old *last-rdtsc-time*)
     1386           (new (rdtsc)))
     1387      (when (< new old)
     1388        ;; We're running on a CPU whose TSC is behind the one
     1389        ;; on the last CPU we were scheduled on.
     1390        (setq new (+ old *rdtsc-estimated-increment*)))
     1391      (when (%store-node-conditional target::symbol.vcell *last-rdtsc-time* old new)
     1392        (return new)))))
     1393
     1394(defun estimate-rdtsc-skew (&optional (niter 1000000))
     1395  (do* ((i 0 (1+ i))
     1396        (last (rdtsc) next)
     1397        (next (rdtsc) (rdtsc))
     1398        (skew 1))
     1399       ((>= i niter) (setq *rdtsc-estimated-increment* skew))
     1400    (declare (fixnum last next skew))
     1401    (when (> last next)
     1402      (let* ((s (- last next)))
     1403        (declare (fixnum s))
     1404        (when (> s skew) (setq skew s))))))
     1405)
     1406
     1407

  • branches/ia32/lib/backtrace.lisp

    r6928 r7666  
    4848
    4949(defun %show-stack-frame (p context lfun pc)
    50   (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context)
    51     (declare (fixnum count))
    52     (dotimes (i count)
    53       (multiple-value-bind (var type name)
    54           (nth-value-in-frame p i context lfun pc vsp parent-vsp)
    55         (format t "~&  ~D " i)
    56         (when name (format t "~s" name))
    57         (let* ((*print-length* *backtrace-print-length*)
    58                (*print-level* *backtrace-print-level*))
    59           (format t ": ~s" var))
    60         (when type (format t " (~S)" type)))))
     50  (handler-case
     51      (multiple-value-bind (count vsp parent-vsp) (count-values-in-frame p context)
     52        (declare (fixnum count))
     53        (dotimes (i count)
     54          (multiple-value-bind (var type name)
     55                               (nth-value-in-frame p i context lfun pc vsp parent-vsp)
     56            (format t "~&  ~D " i)
     57            (when name (format t "~s" name))
     58            (let* ((*print-length* *backtrace-print-length*)
     59                   (*print-level* *backtrace-print-level*))
     60              (format t ": ~s" var))
     61            (when type (format t " (~S)" type)))))
     62    (error () (format t "#<error printing frame>")))
    6163  (terpri)
    6264  (terpri))
    6365
    6466(defun %show-args-and-locals (p context lfun pc)
    65   (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc)
    66     (format t "~&  ~s" (arglist-from-map lfun))
    67     (let* ((*print-length* *backtrace-print-length*)
    68            (*print-level* *backtrace-print-level*))
    69       (flet ((show-pair (pair prefix)
    70                (destructuring-bind (name . val) pair
    71                  (format t "~&~a~s: " prefix name)
    72                  (if (eq val (%unbound-marker))
    73                    (format t "#<Unavailable>")
    74                    (format t "~s" val)))))
    75         (dolist (arg args)
    76           (show-pair arg "   "))
    77         (terpri)
    78         (terpri)
    79         (dolist (loc locals)
    80           (show-pair loc "  "))
    81         (terpri)
    82         (terpri)))))
     67  (handler-case
     68      (let* ((unavailable (cons nil nil)))
     69        (multiple-value-bind (args locals) (arguments-and-locals context p lfun pc unavailable)
     70          (format t "~&  ~s" (arglist-from-map lfun))
     71          (let* ((*print-length* *backtrace-print-length*)
     72                 (*print-level* *backtrace-print-level*))
     73            (flet ((show-pair (pair prefix)
     74                     (destructuring-bind (name . val) pair
     75                       (format t "~&~a~s: " prefix name)
     76                       (if (eq val unavailable)
     77                         (format t "#<Unavailable>")
     78                         (format t "~s" val)))))
     79              (dolist (arg args)
     80                (show-pair arg "   "))
     81              (terpri)
     82              (terpri)
     83              (dolist (loc locals)
     84                (show-pair loc "  "))))))
     85    (error () (format t "#<error printing args and locals>")))
     86  (terpri)
     87  (terpri))
    8388
    8489
    … …  
    212217             (match-local-name cellno (function-symbol-map lfun) pc))))))))
    213218
     219(defun map-entry-value (context cfp lfun pc idx unavailable)
     220  (declare (fixnum pc idx))
     221  (let* ((info (function-symbol-map lfun)))
     222    (if (null info)
     223      unavailable
     224      (let* ((addrs (cdr info))
     225             (i (* 3 idx))
     226             (addr (svref addrs i))
     227             (startpc (svref addrs (the fixnum (+ i 1))))
     228             (endpc (svref addrs (the fixnum (+ i 2)))))
     229        (declare (fixnum i addr startpc endpc))
     230        (if (or (< pc startpc)
     231                (>= pc endpc))
     232          unavailable
     233          (let* ((value (if (= #o77 (ldb (byte 6 0) addr))
     234                          (raw-frame-ref cfp context (ash addr (- (+ target::word-shift 6)))
     235                                         unavailable)
     236                          (find-register-argument-value context cfp addr unavailable))))
     237            (if (typep value 'value-cell)
     238              (uvref value 0)
     239              value)))))))
     240
    214241(defun argument-value (context cfp lfun pc name &optional (quote t))
    215242  (declare (fixnum pc))
    … …  
    346373  ;; at relative program counter PC, using the function's symbol map.
    347374  ;; The list will be ordered so that least-recent bindings appear first.
     375  ;; Return a list of the matching symbol map entries as a second value
    348376  (when pc
    349377    (locally (declare (fixnum pc))
    … …  
    352380             (info (cdr map)))
    353381        (when map
    354           (let* ((vars ()))
    355             (dotimes (i (length names) vars)
     382          (let* ((vars ())
     383                 (indices ()))
     384            (dotimes (i (length names) (values vars indices))
    356385              (let* ((start-pc (aref info (1+ (* 3 i))))
    357386                     (end-pc (aref info (+ 2 (* 3 i)))))
    … …  
    359388                (when (and (>= pc start-pc)
    360389                           (< pc end-pc))
     390                  (push i indices)
    361391                  (push (svref names i) vars))))))))))
    362392
    363 (defun arguments-and-locals (context cfp lfun pc)
    364   (let* ((vars (variables-in-scope lfun pc)))
     393(defun arguments-and-locals (context cfp lfun pc &optional unavailable)
     394  (multiple-value-bind (vars map-indices) (variables-in-scope lfun pc)
    365395    (collect ((args)
    366396              (locals))
    367     (multiple-value-bind (valid req opt rest keys)
    368         (arg-names-from-map lfun pc)
    369       (when valid
    370         (flet ((get-arg-value (name)
    371                  (let* ((avail (member name vars :test #'eq)))
    372                    (if avail
    373                      (setf (car (member name vars :test #'eq)) nil))
    374                    (args (cons name (argument-value context cfp lfun pc name nil)))))
    375                (get-local-value (name)
    376                  (when name
    377                    (locals (cons name (argument-value context cfp lfun pc name nil))))))
    378           (dolist (name req)
    379             (get-arg-value name))
    380           (dolist (name opt)
    381             (get-arg-value name))
    382           (when rest
    383             (get-arg-value rest))
    384           (dolist (name keys)
    385             (get-arg-value name))
    386           (dolist (name vars)
    387             (get-local-value name))))
    388       (values (args) (locals))))))
     397      (multiple-value-bind (valid req opt rest keys)
     398          (arg-names-from-map lfun pc)
     399        (when valid
     400          (let* ((nargs (+ (length req) (length opt) (if rest 1 0) (length keys)))
     401                 (nlocals (- (length vars) nargs))
     402                 (local-vars (nthcdr nargs vars))
     403                 (local-indices (nthcdr nargs map-indices))
     404                 (arg-vars (nbutlast vars nlocals))
     405                 (arg-indices (nbutlast map-indices nlocals)))
     406            (flet ((get-arg-value (name)
     407                     (let* ((pos (position name arg-vars :test #'eq)))
     408                       (when pos
     409                         (args (cons name (map-entry-value context cfp lfun pc (nth pos arg-indices) unavailable))))))
     410                   (get-local-value (name)
     411                     (when name
     412                       (locals (cons name (map-entry-value context cfp lfun pc (pop local-indices) unavailable))))))
     413              (dolist (name req)
     414                (get-arg-value name))
     415              (dolist (name opt)
     416                (get-arg-value name))
     417              (when rest
     418                (get-arg-value rest))
     419              (dolist (name keys)
     420                (get-arg-value name))
     421              #+no
     422              (setq local-vars (nreverse local-vars)
     423                    local-indices (nreverse local-indices))
     424              (dolist (name local-vars)
     425                (get-local-value name)))))
     426        (values (args) (locals))))))
    389427                   
    390428           

  • branches/ia32/lib/chars.lisp

    r5328 r7666  
    8181
    8282
     83(defun %non-standard-lower-case-equivalent (char)
     84  (gethash char *non-standard-upper-to-lower*))
     85
     86
    8387
    8488(defun upper-case-p (c)
    … …  
    8791  (let* ((code (char-code c)))
    8892    (declare (type (mod #x110000) code))
    89     (and (>= code (char-code #\A))
    90          (<= code (char-code #\Z)))))
     93    (or (and (>= code (char-code #\A))
     94             (<= code (char-code #\Z)))
     95        (and (>= code #x80)
     96             (not (null (%non-standard-lower-case-equivalent c)))))))
    9197
    9298
    … …  
    115121          (<= code (char-code #\z)))
    116122     (and (>= code (char-code #\A))
    117           (<= code (char-code #\Z))))))
     123          (<= code (char-code #\Z)))
     124     (and (> code #x80)
     125          (or (not (null (%non-standard-upper-case-equivalent c)))
     126              (not (null (%non-standard-lower-case-equivalent c))))))))
    118127
    119128(defun char= (ch &rest others)
    … …  
    297306  (%strdown string start end))
    298307
     308
    299309(defun %strdown (string start end)
    300   (declare (fixnum start end))
    301   (loop
    302     (when (>= start end)(return string))
    303     (let ((code (%scharcode string start)))
    304       (when (and (%i>= code (char-code #\A))(%i<= code (char-code #\Z)))
    305         (setq code (%i+ code #.(- (char-code #\a)(char-code #\A))))
    306         (setf (%scharcode string start) code))
    307       (setq start (%i+ 1 start)))))
     310  (declare (fixnum start end)
     311           (optimize (speed 3) (safety 0)))
     312  (unless (typep string 'simple-string)
     313    (check-type string simple-string))
     314  (do* ((i start (1+ i)))
     315       ((>= i end) string)
     316    (declare (fixnum i))
     317    (let* ((ch (schar string i))
     318           (code (char-code ch))
     319           (lower (if (and (char<= ch #\Z)
     320                           (char>= ch #\A))
     321                    (%code-char (the (unsigned-byte 8)
     322                                  (+ code (- (char-code #\a)(char-code #\A)))))
     323                    (if (>= code #x80)
     324                      (%non-standard-lower-case-equivalent ch)))))
     325      (declare (character ch) (type (mod #x11000) code))
     326      (when lower
     327        (setf (schar string i) lower)))))
     328
     329
    308330
    309331
    … …  
    328350
    329351(defun %strup (string start end)
    330   (declare (fixnum start end))
    331   (loop
    332     (when (>= start end)(return string))
    333     (let ((code (%scharcode string start)))
    334       (when (and (%i>= code (char-code #\a))(%i<= code (char-code #\z)))
    335         (setq code (%i- code #.(- (char-code #\a)(char-code #\A))))
    336         (setf (%scharcode string start) code))
    337       (setq start (%i+ 1 start)))))
     352  (declare (fixnum start end)
     353           (optimize (speed 3) (safety 0)))
     354  (unless (typep string 'simple-string)
     355    (check-type string simple-string))
     356  (do* ((i start (1+ i)))
     357       ((>= i end) string)
     358    (declare (fixnum i))
     359    (let* ((ch (schar string i))
     360           (code (char-code ch))
     361           (upper (if (and (char<= ch #\z)
     362                           (char>= ch #\a))
     363                    (%code-char (the (unsigned-byte 8)
     364                                  (- code (- (char-code #\a)(char-code #\A)))))
     365                    (if (>= code #x80)
     366                      (%non-standard-upper-case-equivalent ch)))))
     367      (declare (character ch) (type (mod #x11000) code))
     368      (when upper
     369        (setf (schar string i) upper)))))
    338370
    339371

  • branches/ia32/lib/describe.lisp

    r7362 r7666  
    11531153     1                                  ; name
    11541154     1                                  ; arglist
     1155     (let* ((doc (documentation (inspector-object f) t)))
     1156       (if doc 1 0))
    11551157     (compute-disassembly-lines f)))
    11561158
    11571159(defmethod line-n ((f function-inspector) n)
    1158   (let ((o (inspector-object f)))
     1160  (let* ((o (inspector-object f))
     1161         (doc (documentation o t)))
    11591162    (case n
    11601163      (0 (values o ""))
    … …  
    11631166           (let ((label (if type (format nil "Arglist (~(~a~))" type) "Arglist unknown")))
    11641167             (values arglist label (if type :colon '(:comment (:plain)))))))
    1165       (t (disassembly-line-n f (- n 3))))))
     1168      (3 (if doc
     1169           (values (substitute #\space #\newline doc) "Documentation" :colon)
     1170           (disassembly-line-n f (- n 3))))
     1171      (t (disassembly-line-n f (- n (if doc 4 3)))))))
    11661172
    11671173(defmethod compute-line-count ((f closure-inspector))

  • branches/ia32/lib/ffi-darwinppc32.lisp

    r7244 r7666  
    217217                    (lets (list name `(%inc-ptr ,stack-ptr ,offset ))))))
    218218              (lets (list name (next-scalar-arg argtype))))
     219            #+nil
    219220            (when (or (typep argtype 'foreign-pointer-type)
    220221                      (typep argtype 'foreign-array-type))

  • branches/ia32/lib/ffi-darwinppc64.lisp

    r7244 r7666  
    504504                                          ,(* 8 (1- fp-arg-num)))))))))))))
    505505                (lets (list name (next-scalar-arg argtype))))
     506              #+nil
    506507              (when (or (typep argtype 'foreign-pointer-type)
    507508                        (typep argtype 'foreign-array-type))

  • branches/ia32/lib/ffi-linuxppc32.lisp

    r7244 r7666  
    188188                          ,(+ target bias))))
    189189                  (lets (list name access-form))
     190                  #+nil
    190191                  (when (eq spec :address)
    191192                    (dynamic-extent-names name))

  • branches/ia32/lib/macros.lisp

    r7287 r7666  
    31863186                        (collect-normal-expander ',n-value ',kind args))
    31873187                macros))))
    3188     `(macrolet ,macros (let* ,(nreverse binds) ,@body))))
     3188    `(macrolet ,macros (let* ,(nreverse binds) (declare (ignorable ,@binds)) ,@body))))
    31893189
    31903190

  • branches/ia32/lib/pathnames.lisp

    r7287 r7666  
    131131        (values new-name original (truename new-name))))))
    132132
     133(defun recursive-copy-directory (source-path dest-path &key test (if-exists :error))
     134  ;; TODO: Support :if-exists :supersede to blow away any files not in source dir
     135  (setq if-exists (require-type if-exists '(member :overwrite :error)))
     136  (setq dest-path (ensure-directory-pathname dest-path))
     137  (when (eq if-exists :error)
     138    (when (probe-file dest-path)
     139      (if-exists if-exists dest-path))
     140    ;; Skip the probe-file in recursive calls, already know ok.
     141    (setq if-exists :overwrite))
     142  (let* ((source-dir (ensure-directory-pathname source-path))
     143         (pattern (make-pathname :name :wild :type :wild :defaults source-dir))
     144         (source-files (directory pattern :test test :directories t :files t)))
     145    (ensure-directories-exist dest-path)
     146    (dolist (f source-files)
     147      (when (or (null test) (funcall test f))
     148        (if (directory-pathname-p f)
     149            (let ((dest-file (make-pathname :name (first (last (pathname-directory f)))
     150                                            :defaults dest-path)))
     151              (recursive-copy-directory f dest-file :test test :if-exists if-exists))
     152            (let* ((dest-file (make-pathname :name (pathname-name f)
     153                                             :type (pathname-type f)
     154                                             :defaults dest-path)))
     155              (copy-file f dest-file :if-exists :supersede :preserve-attributes t)))))))
     156
     157;;; use with caution!
     158;;; blows away a directory and all its contents
     159(defun recursive-delete-directory (path &key (if-does-not-exist :error))
     160  (setq path (ensure-directory-pathname path))
     161  (setq if-does-not-exist (require-type if-does-not-exist '(member :error nil)))
     162  (when (eq if-does-not-exist :error)
     163    (unless (probe-file path)
     164      (if-does-not-exist if-does-not-exist path)))
     165  (when (probe-file path)
     166      (if (directoryp path)
     167          ;; it's a directory: blow it away
     168          (let* ((pattern (make-pathname :name :wild :type :wild :defaults path))
     169                 (files (directory pattern :directories nil :files t))
     170                 (subdirs (directory pattern :directories t :files nil))
     171                 (target-pathname (native-translated-namestring path)))
     172            (dolist (f files)
     173              (delete-file f))
     174            (dolist (d subdirs)
     175              (recursive-delete-directory d :if-does-not-exist if-does-not-exist))
     176            (%rmdir target-pathname))
     177          ;; it's not a directory: for safety's sake, signal an error
     178          (error "Pathname '~A' is not a directory" path))))
    133179
    134180;;; It's not clear that we can support anything stronger than

  • branches/ia32/library/x8664-freebsd-syscalls.lisp

    r4832 r7666  
    8282(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::access 33 (:address :unsigned-fullword) :signed-fullword)
    8383
    84 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::sync 162 () :unsigned-fullword )
     84(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::sync 36 () :signed-fullword )
    8585(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::kill 37 (:signed-fullword :unsigned-fullword) :signed-fullword )
    8686(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::rename 128 (:address :address) :signed-fullword )
    … …  
    126126(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::connect 98 (:signed-fullword :address :signed-fullword)
    127127                :signed-fullword )
    128 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::accept 43 (:signed-fullword :address :address)
     128(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::accept 30 (:signed-fullword :address :address)
    129129                :signed-fullword )
    130130(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::sendto 133 (:unsigned-fullword :address :unsigned-fullword :unsigned-fullword :address :unsigned-fullword)
    … …  
    138138(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::listen 106 (:signed-fullword  :signed-fullword)
    139139                :signed-fullword )
    140 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::getsockname 31 (:signed-fullword :address :address)
    141                 :signed-fullword )
    142 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::getpeername 52 (:signed-fullword :address :address)
     140(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::getpeername 31 (:signed-fullword :address :address)
     141                :signed-fullword )
     142(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::getsockname 32 (:signed-fullword :address :address)
    143143                :signed-fullword )
    144144(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::socketpair 135 (:signed-fullword :signed-fullword :signed-fullword  :address)
    … …  
    174174(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::symlink 83 () )
    175175(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::oldlstat 84 () )
    176 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::readlink 85 () )
     176(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::readlink 58 () )
    177177(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::uselib 86 () )
    178178(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::swapon 87 () )
    … …  
    195195(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::idle 112 () )
    196196(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::vm86 113 () )
    197 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::wait4 114 () )
     197(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::wait4 7 () )
    198198(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::swapoff 115 () )
    199199(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::sysinfo 116 () )
    … …  
    268268
    269269(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::mmap 9 () )
    270 (define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::munmap 11 () )
     270(define-syscall (logior platform-os-freebsd platform-cpu-x86 platform-word-size-64)  syscalls::munmap 73 () )
    271271
    272272)

  • branches/ia32/lisp-kernel/x86-exceptions.c

    r7287 r7666  
    11391139arbstack_signal_handler(int signum, siginfo_t *info, ExceptionInformation *context)
    11401140{
    1141   TCR *tcr = get_interrupt_tcr(false);
    1142   area *vs = tcr->vs_area;
    1143   BytePtr current_sp = (BytePtr) current_stack_pointer();
    1144 
    1145   if ((current_sp >= vs->low) &&
    1146       (current_sp < vs->high)) {
    1147     handle_signal_on_foreign_stack(tcr,
    1148                                    signal_handler,
    1149                                    signum,
    1150                                    info,
    1151                                    context,
    1152                                    (LispObj)__builtin_return_address(0)
     1141  TCR *tcr = get_interrupt_tcr(false);
     1142#if 1
     1143  if (tcr->valence != TCR_STATE_LISP) {
     1144    FBug(context, "exception in foreign context");
     1145  }
     1146#endif
     1147  {
     1148    area *vs = tcr->vs_area;
     1149    BytePtr current_sp = (BytePtr) current_stack_pointer();
     1150
     1151    if ((current_sp >= vs->low) &&
     1152        (current_sp < vs->high)) {
     1153      handle_signal_on_foreign_stack(tcr,
     1154                                     signal_handler,
     1155                                     signum,
     1156                                     info,
     1157                                     context,
     1158                                     (LispObj)__builtin_return_address(0)
    11531159#ifdef DARWIN_GS_HACK
    1154                                  , false
    1155 #endif
    1156 
    1157                                    );
    1158   } else {
    1159     signal_handler(signum, info, context, tcr, 0);
     1160                                     , false
     1161#endif
     1162
     1163                                     );
     1164    } else {
     1165      signal_handler(signum, info, context, tcr, 0);
     1166    }
    11601167  }
    11611168}

  • branches/ia32/objc-bridge/bridge.lisp

    r7340 r7666  
    2323(require "OBJC-RUNTIME")
    2424(require "NAME-TRANSLATION")
    25 
    26 #-apple-objc-2.0
    27 (progn
    28   (def-foreign-type :<CGF>loat :float)
    29   (def-foreign-type :<NSUI>nteger :unsigned)
    30   (def-foreign-type :<NSI>nteger :signed)
    31   )
    32 
    33 (defconstant +cgfloat-zero+
    34   #+(and apple-objc-2.0 64-bit-target) 0.0d0
    35   #-(and apple-objc-2.0 64-bit-target) 0.0f0)
    36 
    37 (deftype cgfloat ()
    38   #+(and apple-objc-2.0 64-bit-target) 'double-float
    39   #-(and apple-objc-2.0 64-bit-target) 'single-float)
    40 
    41 (deftype cg-float () 'cgfloat)
    42 
    43 (deftype nsuinteger ()
    44   #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64)
    45   #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32))
    46 
    47 (deftype nsinteger ()
    48   #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64)
    49   #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32))
    5025
    5126;;; Used in PRINT-OBJECT methods.
    … …  
    763738
    764739
    765 (defvar *objc-message-info* (make-hash-table :test #'equal :size 500))
     740(defvar *objc-message-info* (make-hash-table :test #'equal :size 800))
    766741
    767742(defun result-type-requires-structure-return (result-type)
    … …  
    782757  (or (gethash sig *objc-method-signatures*)
    783758      (setf (gethash sig *objc-method-signatures*)
    784             (make-objc-method-signature-info :type-signature sig))))
     759            (make-objc-method-signature-info
     760             :type-signature sig
     761             :function (compile-send-function-for-signature  sig)
     762             :super-function (%compile-send-function-for-signature  sig t)))))
    785763
    786764(defun concise-foreign-type (ftype)
    … …  
    940918  (let* ((objc-name (objc-message-info-message-name message-info))
    941919         (lisp-name (or (objc-message-info-lisp-name message-info)
    942                             (setf (objc-message-info-lisp-name message-info)
    943                                   (compute-objc-to-lisp-function-name  objc-name))))
     920                        (setf (objc-message-info-lisp-name message-info)
     921                              (compute-objc-to-lisp-function-name  objc-name))))
    944922         (gf (or (fboundp lisp-name)
    945923                 (setf (fdefinition lisp-name)
    … …  
    950928            (ensure-objc-selector (objc-message-info-message-name message-info))))
    951929   
    952   (flet ((reduce-to-ffi-type (ftype)
    953            (concise-foreign-type ftype)))
    954     (flet ((ensure-method-signature (m)
    955              (or (objc-method-info-signature m)
    956                  (setf (objc-method-info-signature m)
    957                        (let* ((sig
    958                                (cons (reduce-to-ffi-type
    959                                       (objc-method-info-result-type m))
    960                                      (mapcar #'reduce-to-ffi-type
    961                                              (objc-method-info-arglist m)))))
    962                          (setf (objc-method-info-signature-info m)
    963                                (objc-method-signature-info sig))
    964                          sig)))))
    965       (let* ((methods (objc-message-info-methods message-info))
    966              (signatures ())
    967              (protocol-methods)
    968              (signature-alist ()))
    969         (labels ((signatures-equal (xs ys)
    970                    (and xs
    971                         ys
    972                         (do* ((xs xs (cdr xs))
    973                               (ys ys (cdr ys)))
    974                              ((null xs) (null ys))
    975                           (unless (foreign-type-= (ensure-foreign-type (car xs))
    976                                                   (ensure-foreign-type (car ys)))
    977                             (return nil))))))
     930    (flet ((reduce-to-ffi-type (ftype)
     931             (concise-foreign-type ftype)))
     932      (flet ((ensure-method-signature (m)
     933               (or (objc-method-info-signature m)
     934                   (setf (objc-method-info-signature m)
     935                         (let* ((sig
     936                                 (cons (reduce-to-ffi-type
     937                                        (objc-method-info-result-type m))
     938                                       (mapcar #'reduce-to-ffi-type
     939                                               (objc-method-info-arglist m)))))
     940                           (setf (objc-method-info-signature-info m)
     941                                 (objc-method-signature-info sig))
     942                           sig)))))
     943        (let* ((methods (objc-message-info-methods message-info))
     944               (signatures ())
     945               (protocol-methods)
     946               (signature-alist ()))
     947          (labels ((signatures-equal (xs ys)
     948                     (and xs
     949                          ys
     950                          (do* ((xs xs (cdr xs))
     951                                (ys ys (cdr ys)))
     952                               ((null xs) (null ys))
     953                            (unless (foreign-type-= (ensure-foreign-type (car xs))
     954                                                    (ensure-foreign-type (car ys)))
     955                              (return nil))))))
    978956            (dolist (m methods)
    979957              (let* ((signature (ensure-method-signature m)))
    980958                (pushnew signature signatures :test #'signatures-equal)
    981             (if (getf (objc-method-info-flags m) :protocol)
    982               (push m protocol-methods)
    983               (let* ((pair (assoc signature signature-alist :test #'signatures-equal)))
    984                 (if pair
    985                   (push m (cdr pair))
    986                   (push (cons signature (list m)) signature-alist)))))))
    987         (setf (objc-message-info-ambiguous-methods message-info)
    988               (mapcar #'cdr
    989                       (sort signature-alist
    990                             #'(lambda (x y)
    991                                 (< (length (cdr x))
    992                                    (length (cdr y)))))))
    993         (setf (objc-message-info-flags message-info) nil)
    994         (setf (objc-message-info-protocol-methods message-info)
    995               protocol-methods)
    996         (when (cdr signatures)
    997           (setf (getf (objc-message-info-flags message-info) :ambiguous) t))
    998         (let* ((first-method (car methods))
    999                (first-sig (objc-method-info-signature first-method))
    1000                (first-sig-len (length first-sig)))
    1001           (setf (objc-message-info-req-args message-info)
    1002                 (1- first-sig-len))
    1003           ;; Whether some arg/result types vary or not, we want to insist
    1004           ;; on (a) either no methods take a variable number of arguments,
    1005           ;; or all do, and (b) either no method uses structure-return
    1006           ;; conventions, or all do. (It's not clear that these restrictions
    1007           ;; are entirely reasonable in the long run; in the short term,
    1008           ;; they'll help get things working.)
    1009           (flet ((method-returns-structure (m)
    1010                    (result-type-requires-structure-return
    1011                     (objc-method-info-result-type m)))
    1012                  (method-accepts-varargs (m)
    1013                    (eq (car (last (objc-method-info-arglist m)))
    1014                        *void-foreign-type*))
    1015                  (method-has-structure-arg (m)
    1016                    (dolist (arg (objc-method-info-arglist m))
    1017                      (when (typep (ensure-foreign-type arg) 'foreign-record-type)
    1018                        (return t)))))
    1019             (when (dolist (method methods)
    1020                     (when (method-has-structure-arg method)
    1021                       (return t)))
    1022               (setf (compiler-macro-function lisp-name)
    1023                     'hoist-struct-constructors))
    1024             (let* ((first-result-is-structure (method-returns-structure first-method))
    1025                    (first-accepts-varargs (method-accepts-varargs first-method)))
    1026               (if (dolist (m (cdr methods) t)
    1027                     (unless (eq (method-returns-structure m)
    1028                                 first-result-is-structure)
    1029                       (return nil)))
    1030                 (if first-result-is-structure
    1031                   (setf (getf (objc-message-info-flags message-info)
    1032                               :returns-structure) t)))
    1033               (if (dolist (m (cdr methods) t)
    1034                     (unless (eq (method-accepts-varargs m)
    1035                                 first-accepts-varargs)
    1036                       (return nil)))
    1037                 (if first-accepts-varargs
    1038                   (progn
     959                (if (getf (objc-method-info-flags m) :protocol)
     960                  (push m protocol-methods)
     961                  (let* ((pair (assoc signature signature-alist :test #'signatures-equal)))
     962                    (if pair
     963                      (push m (cdr pair))
     964                      (push (cons signature (list m)) signature-alist)))))))
     965          (setf (objc-message-info-ambiguous-methods message-info)
     966                (mapcar #'cdr
     967                        (sort signature-alist
     968                              #'(lambda (x y)
     969                                  (< (length (cdr x))
     970                                     (length (cdr y)))))))
     971          (setf (objc-message-info-flags message-info) nil)
     972          (setf (objc-message-info-protocol-methods message-info)
     973                protocol-methods)
     974          (when (cdr signatures)
     975            (setf (getf (objc-message-info-flags message-info) :ambiguous) t))
     976          (let* ((first-method (car methods))
     977                 (first-sig (objc-method-info-signature first-method))
     978                 (first-sig-len (length first-sig)))
     979            (setf (objc-message-info-req-args message-info)
     980                  (1- first-sig-len))
     981            ;; Whether some arg/result types vary or not, we want to insist
     982            ;; on (a) either no methods take a variable number of arguments,
     983            ;; or all do, and (b) either no method uses structure-return
     984            ;; conventions, or all do. (It's not clear that these restrictions
     985            ;; are entirely reasonable in the long run; in the short term,
     986            ;; they'll help get things working.)
     987            (flet ((method-returns-structure (m)
     988                     (result-type-requires-structure-return
     989                      (objc-method-info-result-type m)))
     990                   (method-accepts-varargs (m)
     991                     (eq (car (last (objc-method-info-arglist m)))
     992                         *void-foreign-type*))
     993                   (method-has-structure-arg (m)
     994                     (dolist (arg (objc-method-info-arglist m))
     995                       (when (typep (ensure-foreign-type arg) 'foreign-record-type)
     996                         (return t)))))
     997              (when (dolist (method methods)
     998                      (when (method-has-structure-arg method)
     999                        (return t)))
     1000                (setf (compiler-macro-function lisp-name)
     1001                      'hoist-struct-constructors))
     1002              (let* ((first-result-is-structure (method-returns-structure first-method))
     1003                     (first-accepts-varargs (method-accepts-varargs first-method)))
     1004                (if (dolist (m (cdr methods) t)
     1005                      (unless (eq (method-returns-structure m)
     1006                                  first-result-is-structure)
     1007                        (return nil)))
     1008                  (if first-result-is-structure
    10391009                    (setf (getf (objc-message-info-flags message-info)
    1040                                 :accepts-varargs) t)
    1041                     (decf (objc-message-info-req-args message-info)))))))))
    1042       (reinitialize-instance gf :message-info message-info)))))
     1010                                :returns-structure) t)))
     1011                (if (dolist (m (cdr methods) t)
     1012                      (unless (eq (method-accepts-varargs m)
     1013                                  first-accepts-varargs)
     1014                        (return nil)))
     1015                  (if first-accepts-varargs
     1016                    (progn
     1017                      (setf (getf (objc-message-info-flags message-info)
     1018                                  :accepts-varargs) t)
     1019                      (decf (objc-message-info-req-args message-info)))))))))
     1020        (reinitialize-instance gf :message-info message-info)))))
    10431021         
    10441022;;; -may- need to invalidate cached info whenever new interface files
    … …  
    14391417      (send-objc-init-message (#/alloc class) ks vs))))
    14401418
     1419
     1420
     1421
     1422
    14411423;;; Provide the BRIDGE module
    14421424

  • branches/ia32/objc-bridge/fake-cfbundle-path.lisp

    r6889 r7666  
    1111;;; before the CoreFoundation library's initialized.
    1212
    13 (defun fake-cfbundle-path (bundle-root info-plist-proto-path)
     13(defun fake-cfbundle-path (bundle-root info-plist-proto-path bundle-prefix)
    1414  (let* ((kernel-name (standard-kernel-name))
    15          (needle "OPENMCL-KERNEL")
    1615         (translated-root (translate-logical-pathname bundle-root))
     16         (bundle-name (let* ((name (if (directory-pathname-p translated-root)
     17                                       (car (last (pathname-directory translated-root)))
     18                                       (file-namestring translated-root)))
     19                             (len (length name)))
     20                        (if (and (> len 4)
     21                                 (string-equal name ".app" :start1 (- len 4)))
     22                            (subseq name 0 (- len 4))
     23                            name)))
     24         (bundle-id (concatenate 'string bundle-prefix "." bundle-name))
     25         (bundle-version (format nil "~d" *openmcl-svn-revision*))
     26         (needles `(("OPENMCL-KERNEL" . ,kernel-name)
     27                    ("OPENMCL-NAME" . ,bundle-name)
     28                    ("OPENMCL-IDENTIFIER" . ,bundle-id)
     29                    ("OPENMCL-VERSION" . ,bundle-version)))
    1730         (executable-path (merge-pathnames
    1831                           (make-pathname :directory "Contents/MacOS/"
    … …  
    3548        (do* ((line (read-line in nil nil) (read-line in nil nil)))
    3649             ((null line))
    37           (let* ((pos (search needle line)))
    38             (when pos
    39               (setq line
    40                     (concatenate 'string
    41                                  (subseq line 0 pos)
    42                                  kernel-name
    43                                  (subseq line (+ pos (length needle)))))))
     50          (dolist (needle needles)
     51            (let* ((pos (search (car needle) line)))
     52              (when pos
     53                (setq line
     54                      (concatenate 'string
     55                                   (subseq line 0 pos)
     56                                   (cdr needle)
     57                                   (subseq line (+ pos (length (car needle)))))))))
    4458          (write-line line out))))
    4559    (touch executable-path)

  • branches/ia32/objc-bridge/name-translation.lisp

    r6873 r7666  
    7979#+gnu-objc
    8080(define-special-objc-word "GS")
    81 
    8281
    8382;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  • branches/ia32/objc-bridge/objc-clos.lisp

    r7340 r7666  
    601601  (let* ((bits (foreign-type-bits foreign-type)))
    602602    (if (or (= bits 1)
    603             (not (= bits (foreign-type-alignment foreign-type))))
     603            (and (not (typep foreign-type 'foreign-mem-block-type))
     604                 (not (= bits (foreign-type-alignment foreign-type)))))
    604605      bit-offset
    605606      (ash bit-offset -3))))

  • branches/ia32/objc-bridge/objc-runtime.lisp

    r7340 r7666  
    5757  (require "NAME-TRANSLATION")
    5858  (require "OBJC-CLOS"))
     59
     60;;; NSInteger and NSUInteger probably belong here.
     61;;; CGFloat not so much.
     62
     63#-apple-objc-2.0
     64(progn
     65  (def-foreign-type :<CGF>loat :float)
     66  (def-foreign-type :<NSUI>nteger :unsigned)
     67  (def-foreign-type :<NSI>nteger :signed)
     68  )
     69
     70(defconstant +cgfloat-zero+
     71  #+(and apple-objc-2.0 64-bit-target) 0.0d0
     72  #-(and apple-objc-2.0 64-bit-target) 0.0f0)
     73
     74(deftype cgfloat ()
     75  #+(and apple-objc-2.0 64-bit-target) 'double-float
     76  #-(and apple-objc-2.0 64-bit-target) 'single-float)
     77
     78(deftype cg-float () 'cgfloat)
     79
     80(deftype nsuinteger ()
     81  #+(and apple-objc-2.0 64-bit-target) '(unsigned-byte 64)
     82  #-(and apple-objc-2.0 64-bit-target) '(unsigned-byte 32))
     83
     84(deftype nsinteger ()
     85  #+(and apple-objc-2.0 64-bit-target) '(signed-byte 64)
     86  #-(and apple-objc-2.0 64-bit-target) '(signed-byte 32))
     87
    5988
    6089(defloadvar *NSApp* nil )
    … …  
    602631             (meta-id (objc-class-id->objc-metaclass-id i))
    603632             (m (id->objc-metaclass meta-id)))
    604         (%revive-macptr c)
    605         (%revive-macptr m)
     633        (unless (typep c 'macptr)
     634          (%revive-macptr c)
     635          (%setf-macptr c (%null-ptr)))
     636        (unless (typep m 'macptr)
     637          (%revive-macptr m)
     638          (%setf-macptr m (%null-ptr)))
    606639        (unless (splay-tree-get class-map c)
    607640          (%set-pointer-to-objc-class-address (objc-class-id-foreign-name i) c)
    … …  
    18241857                   (:<BOOL> (call `(%coerce-to-bool ,arg)))
    18251858                   (:id (call `(%coerce-to-address ,arg)))
     1859                   (:<CGF>loat (call `(float ,arg +cgfloat-zero+)))
    18261860                   (t
    18271861                    (call arg)))))
Note: See TracChangeset for help on using the changeset viewer.