Changeset 7244


Ignore:
Timestamp:
Sep 17, 2007, 5:53:32 PM (12 years ago)
Author:
rme
Message:

Merged trunk changes r6975:7243

Location:
branches/ia32
Files:
60 edited
6 copied

Legend:

Unmodified
Added
Removed
  • branches/ia32/ChangeLog

    r6974 r7244  
     12007-09-17 06:10  gb
     2
     3        * level-0/l0-numbers.lisp: Simply clearing the top bit of the
     4        intermediate result from %NEXT-RANDOM-PAIR had the effect of using
     5        doing (mod result (expt 2 31)), not (mod result (1- (expt 2 31))).
     6        Do a real MOD to obtain the next item in the series and update the
     7        state with that value.  (This means that the high bit of the high
     8        half of the result is always clear; or in the sign bit from the low
     9        half.)
     10
     112007-09-16 18:10  gb
     12
     13        * compiler/X86/x862.lisp: X862-BIND-LAMBDA: bind &rest before &key
     14        ...
     15
     162007-09-16 17:10  gb
     17
     18        * compiler/PPC/ppc2.lisp: PPC2-BIND-LAMBDA: rest arg is in scope
     19        before key arg(s), so assign it an address before processing &key
     20        initforms.
     21
     222007-09-15 17:10  gb
     23
     24        * level-1/l1-readloop-lds.lisp: Observe *BACKTRACE-PRINT-LEVEL*,
     25        -LENGTH* when printing break messages.
     26
     272007-09-13 20:10  gb
     28
     29        * level-1/: l1-streams.lisp, linux-files.lisp: Add support for
     30        :element-type to ccl:run-program to allow for binary streams
     31
     322007-09-13 06:55  gb
     33
     34        * cocoa-ide/hemlock/: README, doc/scribe-converter/README,
     35        src/elisp/README, src/spell/README: Restore some README files,
     36        which had somehow gotten lost in translation.
     37
     382007-09-13 06:54  gb
     39
     40        *
     41        cocoa-ide/OpenMCL.app/Contents/Resources/English.lproj/lispeditor.n
     42        ib/: classes.nib, info.nib, keyedobjects.nib: not used
     43
     442007-09-13 06:52  gb
     45
     46        * compiler/X86/: x862.lisp, X8664/x8664-vinsns.lisp: Push labels
     47        for certain kinds of MULTIPLE-VALUE-CALL differently; in
     48        particular, note the effect of pushing such a label on stack depth.
     49
     502007-09-13 06:50  gb
     51
     52        * cocoa-ide/OpenMCL.app/Contents/MacOS/.cvsignore,
     53        examples/cocoa/.cvsignore: New file, mostly to help ensure that the
     54        containing directory exists in cvs.
     55
     562007-09-06 14:10  gb
     57
     58        * cocoa-ide/builder-utilities.lisp: added key 'CFBundleName' to
     59        write-info-plist
     60
     612007-09-04 23:11  gb
     62
     63        * cocoa-ide/cocoa-editor.lisp: New! Improved!
     64       
     65        The code which arranges for editing changes to be processed in the
     66        main thread now does so via an NSInvocation (ObjC's notion of a
     67        closure, sort of); the methods which run in the main thread handle
     68        the job of synchronizing the underlying the Hemlock string and the
     69        "real" NSMutableAttributedString as well as informing the text
     70        system of pending editing changes via
     71        #/edited:range:changeInLength:.  The code which processes deletions
     72        does the change processing before modifying the string (other
     73        methods do it after the change); this seems to be necessary to
     74        avoid some things that could cause ticket:50.  (I'm not sure if
     75        this fixes ticket:50, but it does seem to fix a reproducible case.)
     76       
     77        The #/replaceCharactersInRange:withString: method on
     78        hemlock-text-storage (which handles buffer changes originating from
     79        non-Hemlock sources) is careful to use a :right-inserting temporary
     80        mark when modifying the buffer, to help ensure that
     81        insertions/deletions take place at the correct absolute position.
     82        (This may at least partially address bugs related to things getting
     83        confused/out-of-bounds errors when doing lots of cutting and
     84        pasting, though it's hard to know without reproducible cases.)
     85       
     86        The macros NSSTRING-ENCODING-TO-NSINTEGER and
     87        NSINTEGER-TO-NSSTRING-ENCODING are defined before they're used (at
     88        least one of them wasn't.)
     89       
     90        The handling of text encoding for editor documents has changed in a
     91        few ways.  If "automatic" encoding is used in an "Open ..." dialog
     92        and is successfully able to infer a text file's encoding, the
     93        encoding that was inferred becomes the document's encoding (used in
     94        subsequent "save" operations.)  On some OSX versions, the automatic
     95        detection mechanism can only recognize UTF-16 files that contain a
     96        leading BOM (and the editor's code for dealing with the automatic
     97        mechanism didn't expect this to ever work.)  On other systems, the
     98        automatic mechanism can return something correct (I've seen UTF-8)
     99        but possibly suboptimal.
     100       
     101        The Open... dialog now defaults to something derived from the
     102        user's setting of CCL:*DEFAULT-FILE-CHARACTER-ENCODING*; because
     103        "automatic" is a little unpredictable, the new default is probably
     104        better.
     105       
     106        The NSDocument mechanism for creating backup files (with names of
     107        the form "name~.ext") is not used; when backup files are created,
     108        we try to copy the original to a file whose name conforms to the
     109        (simple, non-versioned) Emacs scheme ("name.ext~").  More things
     110        seem to work better when the Emacs scheme is used (though I suppose
     111        some people might prefer the NSDocument scheme and we could make
     112        this a preference.)
     113
     1142007-09-04 22:11  gb
     115
     116        * cocoa-ide/cocoa-listener.lisp: Don't call #/setFileName: when
     117        creating a Listener, since (a) that method's deprecated in favor of
     118        #/setFileURL: and (b) a newly-created Listener doesn't really have
     119        an associated filename, and so shouldn't get the icon and popup in
     120        its titlebar.
     121       
     122        Do arrange that (unless/until a listener document is saved to a
     123        file) its window title is based on the underlying Hemlock buffer's
     124        name.  (If one ever attempts to save a listener document, the
     125        proposed file name is the internal NSDocument name; we might or
     126        might not want to change that.)
     127
     1282007-09-04 22:10  gb
     129
     130        * cocoa-ide/cocoa-prefs.lisp: Suppress warnings about
     131        *MODELINE-FONT-NAME*, -SIZE*.
     132
     1332007-09-04 19:13  gb
     134
     135        * lisp-kernel/: gc.h, memory.c, pmcl-kernel.c, ppc-exceptions.c,
     136        ppc-gc.c, x86-exceptions.c, x86-gc.c: Lose "HeapHighWaterMark",
     137        which was supposed to allow us to track the high end of a range of
     138        pages that'd been written to and not freed (so we'd zero them
     139        lazily when they were reallocated.)  Such a scheme would really
     140        need to track both ends of such a range, and the old scheme wound
     141        up being overly zealous and often zeroed pages that were already
     142        zeroed.  Zero the range between the old free pointer and the new
     143        one after each GC, instead.
     144       
     145        At least partly address ticket:101, by doing GROW-DYNAMIC-AREA more
     146        carefully.
     147
     1482007-09-04 19:12  gb
     149
     150        * level-0/: l0-numbers.lisp, PPC/ppc-numbers.lisp: Fix to 64-bit
     151        %NEXT-RANDOM-SEED, random algorithm comments from Bernd Beuster.
     152
     1532007-09-04 19:11  gb
     154
     155        * lib/: ffi-darwinppc32.lisp, ffi-darwinppc64.lisp,
     156        ffi-linuxppc32.lisp, ffi-linuxppc64.lisp, macros.lisp: Don't coerce
     157        single-float results to double-floats in DEFCALLBACK-BODY.  Do do
     158        this in the PPC backends.
     159       
     160        (This needs testing ...)
     161
     1622007-09-04 19:10  gb
     163
     164        * compiler/X86/X8664/x8664-backend.lisp: Don't assume that
     165        :single-float callback results have been coerced to :double-float
     166        on x8664.
     167
     1682007-09-03 18:10  gb
     169
     170        * cocoa-ide/hemlock/src/edit-defs.lisp: Make meta-. use either the
     171        selection or the symbol around point, regardless of global parsing
     172        state (Ticket:95).  While in there, make meta-. with a numarg
     173        prompt for symbol to look up.
     174
     1752007-08-30 20:10  gb
     176
     177        * level-1/l1-error-system.lisp: Add a restart for unbound
     178        variable/undefined function errors -- if there is a unique
     179        bound/fbound symbol of the same name in another package, offer to
     180        use it instead.
     181
     1822007-08-30 19:10  gb
     183
     184        * cocoa-ide/cocoa-grep.lisp: Tell grep not to complain about
     185        inaccesible files; it might return an exit status of 2 if it finds
     186        such files, so treat that as "success" for now (ticket:98).
     187
     1882007-08-30 18:11  gb
     189
     190        * cocoa-ide/hemlock/src/doccoms.lisp: Fix format call in Show
     191        Variable command output (ticket:97).
     192
     1932007-08-30 18:10  gb
     194
     195        * cocoa-ide/hemlock/src/listener.lisp: EVAL-REGION uses
     196        VARIABLE-VALUE to access buffer's package (ticket:82).
     197
     1982007-08-30 15:11  gb
     199
     200        * cocoa-ide/: build-application.lisp, builder-utilities.lisp: added
     201        code to copy user-supplied nibfiles into a saved application bundle
     202
     2032007-08-30 14:10  gb
     204
     205        * cocoa-ide/hemlock/src/: command.lisp, listener.lisp: Make sure
     206        all callers of current-point-for-deletion handle the nil return
     207        value case.  This fixes ticket:85
     208
     2092007-08-29 20:11  gb
     210
     211        * cocoa-ide/: cocoa-editor.lisp, cocoa.lisp, hemlock/TODO,
     212        hemlock/doc/scribe-converter/NOTES, hemlock/maint/publish,
     213        hemlock/src/bindings.lisp, hemlock/src/buffer.lisp,
     214        hemlock/src/charmacs.lisp, hemlock/src/command.lisp,
     215        hemlock/src/comments.lisp, hemlock/src/completion.lisp,
     216        hemlock/src/cursor.lisp, hemlock/src/defsyn.lisp,
     217        hemlock/src/doccoms.lisp, hemlock/src/echo.lisp,
     218        hemlock/src/echocoms.lisp, hemlock/src/edit-defs.lisp,
     219        hemlock/src/filecoms.lisp, hemlock/src/files.lisp,
     220        hemlock/src/fill.lisp, hemlock/src/font.lisp,
     221        hemlock/src/htext1.lisp, hemlock/src/htext2.lisp,
     222        hemlock/src/htext3.lisp, hemlock/src/htext4.lisp,
     223        hemlock/src/icom.lisp, hemlock/src/indent.lisp,
     224        hemlock/src/interp.lisp, hemlock/src/kbdmac.lisp,
     225        hemlock/src/key-event.lisp, hemlock/src/keysym-defs.lisp,
     226        hemlock/src/killcoms.lisp, hemlock/src/line.lisp,
     227        hemlock/src/linimage.lisp, hemlock/src/lispmode.lisp,
     228        hemlock/src/macros.lisp, hemlock/src/main.lisp,
     229        hemlock/src/morecoms.lisp, hemlock/src/package.lisp,
     230        hemlock/src/pop-up-stream.lisp, hemlock/src/register.lisp,
     231        hemlock/src/ring.lisp, hemlock/src/rompsite.lisp,
     232        hemlock/src/search1.lisp, hemlock/src/search2.lisp,
     233        hemlock/src/searchcoms.lisp, hemlock/src/srccom.lisp,
     234        hemlock/src/streams.lisp, hemlock/src/struct.lisp,
     235        hemlock/src/syntax.lisp, hemlock/src/table.lisp,
     236        hemlock/src/text.lisp, hemlock/src/undo.lisp,
     237        hemlock/src/vars.lisp, hemlock/src/archive/abbrev.lisp,
     238        hemlock/src/archive/auto-save.lisp,
     239        hemlock/src/archive/bit-display.lisp,
     240        hemlock/src/archive/bit-screen.lisp,
     241        hemlock/src/archive/bufed.lisp, hemlock/src/archive/debug.lisp,
     242        hemlock/src/archive/dired.lisp, hemlock/src/archive/diredcoms.lisp,
     243        hemlock/src/archive/display.lisp, hemlock/src/archive/dylan.lisp,
     244        hemlock/src/archive/eval-server.lisp,
     245        hemlock/src/archive/group.lisp, hemlock/src/archive/highlight.lisp,
     246        hemlock/src/archive/hunk-draw.lisp, hemlock/src/archive/input.lisp,
     247        hemlock/src/archive/lisp-lib.lisp,
     248        hemlock/src/archive/lispbuf.lisp,
     249        hemlock/src/archive/lispeval.lisp, hemlock/src/archive/mh.lisp,
     250        hemlock/src/archive/netnews.lisp,
     251        hemlock/src/archive/overwrite.lisp,
     252        hemlock/src/archive/pascal.lisp, hemlock/src/archive/rcs.lisp,
     253        hemlock/src/archive/screen.lisp, hemlock/src/archive/scribe.lisp,
     254        hemlock/src/archive/shell.lisp, hemlock/src/archive/spell-aug.lisp,
     255        hemlock/src/archive/spell-corr.lisp,
     256        hemlock/src/archive/spell-rt.lisp,
     257        hemlock/src/archive/spellcoms.lisp,
     258        hemlock/src/archive/srccom.lisp, hemlock/src/archive/ts-buf.lisp,
     259        hemlock/src/archive/ts-stream.lisp,
     260        hemlock/src/archive/unixcoms.lisp, hemlock/src/archive/window.lisp,
     261        hemlock/src/archive/winimage.lisp, hemlock/src/archive/xcoms.lisp,
     262        hemlock/src/spell/spellcoms.lisp, hemlock/src/tty/termcap.lisp,
     263        hemlock/src/tty/tty-disp-rt.lisp, hemlock/src/tty/tty-display.lisp,
     264        hemlock/src/tty/tty-screen.lisp, hemlock/src/wire/remote.lisp,
     265        hemlock/src/wire/wire.lisp, hemlock/unused/bit-stream.lisp,
     266        hemlock/unused/clx-ext.lisp, hemlock/unused/ed-integrity.lisp,
     267        hemlock/unused/gosmacs.lisp, hemlock/unused/hemcom.lisp,
     268        hemlock/unused/hi-integrity.lisp, hemlock/unused/keytran.lisp,
     269        hemlock/unused/keytrandefs.lisp, hemlock/unused/spell-build.lisp,
     270        hemlock/unused/struct-ed.lisp, hemlock/unused/tty-stream.lisp,
     271        hemlock/website/index.html.in: umm, load cocoa-grep where it will
     272        work...
     273
     2742007-08-29 20:10  gb
     275
     276        * cocoa-ide/cocoa-editor.lisp: load cocoa-grep
     277
     2782007-08-29 13:11  gb
     279
     280        * cocoa-ide/cocoa-grep.lisp: Implement m-x grep
     281
     2822007-08-29 12:12  gb
     283
     284        * cocoa-ide/hemlock/src/indent.lisp: Indent command: if no prefix
     285        arg (simple case), move point to the location of the temporary mark
     286        after calling the indent function.
     287
     2882007-08-29 12:11  gb
     289
     290        * cocoa-ide/hemlock/src/lispmode.lisp: COUNT-LEADING-WHITESPACE
     291        returns 2 values: the "column" (with tabs expanded) of the first
     292        non-whitespace character on the line and that character's position.
     293         ENSURE-LISP-INDENTATION moves the (temporary) mark to that
     294        position if no changes are necessary.
     295
     2962007-08-29 12:10  gb
     297
     298        * cocoa-ide/cocoa-editor.lisp: In HEMLOCK-TEXT-VIEW #/paste:
     299        method, make an NS-MUTABLE-STRING even if the string from the
     300        clipboard already appears to be an NS-MUTABLE-STRING.  (NSCFString
     301        is apparently a subclass of NS-MUTABLE-STRING, but isn't really ...
     302         mutable.) For ticket:84.
     303
     3042007-08-28 23:10  gb
     305
     306        * cocoa-ide/: cocoa-editor.lisp, hemlock/src/command.lisp: Make
     307        hi::scroll-window actually scroll, not just move insertion point
     308        around.  Fixes ticket:88.
     309
     3102007-08-26 13:11  gb
     311
     312        * cocoa-ide/: build-application.lisp, builder-utilities.lisp: new
     313        keyword argument to build-application: main-nib-name; names the
     314        nigfile that is to be the main nib of the built application
     315
     3162007-08-26 12:10  gb
     317
     318        * cocoa-ide/: build-application.lisp, builder-utilities.lisp: added
     319        application bulder to trunk
     320
     3212007-08-25 02:13  gb
     322
     323        * cocoa-ide/cocoa-listener.lisp:
     324        HI::SEND-STRING-TO-LISTENER-PROCESS quotes #\^d, sends unquoted
     325        #\^d after sending the string.  (This is just a workaround for
     326        ticket:82; the trailing #\^d is just treated as whitespace and
     327        terminates calls to READ.  We really want some way of recognizing
     328        "end of selection" and treating that like a transient EOF in some
     329        cases.)
     330
     3312007-08-25 02:12  gb
     332
     333        * cocoa-ide/cocoa-editor.lisp: In COCOA-EDIT, invoke
     334        #/openDocumentWithContentsOfURL:display:error:, since calling
     335        #/openDocumentWithContentsOfURL:display: complains that
     336        #/dataRepresentationOfType: isn't implemented in 32-bit versions of
     337        Cocoa.  (Note that we'd been calling
     338        #/openDocumentWithContentsOfURL:display:error: as part of the m-.
     339        implementation without incident.)
     340
     3412007-08-25 02:11  gb
     342
     343        * cocoa-ide/hemlock/src/morecoms.lisp: "Capitalize Word" command
     344        notes buffer modification.
     345
     3462007-08-25 02:10  gb
     347
     348        * cocoa-ide/hemlock/src/htext4.lisp: FILTER-REGION notes buffer
     349        modification.
     350
     3512007-08-23 17:17  gb
     352
     353        * cocoa-ide/cocoa-listener.lisp: Remove a duplicate #/continue:
     354        method.
     355
     3562007-08-23 17:16  gb
     357
     358        * cocoa-ide/cocoa-editor.lisp: Remove a duplicate
     359        #/editingInProgress method.  Add some more (conditionalized) debug
     360        info.  If ticket:50 bug is encountered, try to force DBG on Hemlock
     361        command thread as well as in Cocoa thread.  Make sure that Hemlock
     362        command thread has bindings of command-processing data structures,
     363        prompt data structures.  Do not bind *LAST-SEARCH-STRING* or
     364        *LAST-SEARCH-PATTERN*; note that *LAST-SEARCH-STRING* is usually
     365        only set by isearch when it exits.
     366
     3672007-08-23 17:15  gb
     368
     369        * cocoa-ide/cocoa-backtrace.lisp: Use new defaults-based backtrace
     370        font name and size; initially, Monaco 9.  (Not yet changeable
     371        through preferences panel.) Adjust outline view's row height based
     372        on font height.  Set the data cell to "non-editable" (could have
     373        done this in IB).  Provide handlers for some menu commands
     374        (continue, restarts, exitBreak); no need to validate menu items for
     375        them (those commands should be available whenever backtrace dialog
     376        is active.)
     377
     3782007-08-23 17:14  gb
     379
     380        * cocoa-ide/hemlock/src/searchcoms.lisp: Use
     381        RECURSIVE-GET-KEY-EVENT in isearch, query-replace.
     382
     3832007-08-23 17:13  gb
     384
     385        * cocoa-ide/hemlock/src/package.lisp: Export
     386        RECURSIVE-GET-KEY-EVENT.
     387
     3882007-08-23 17:12  gb
     389
     390        * cocoa-ide/hemlock/src/lispmode.lisp: Ignore erorrs when trying to
     391        read symbol for arglist.  (Should probably be more careful
     392        elsewhere, too.)
     393
     3942007-08-23 17:11  gb
     395
     396        * cocoa-ide/hemlock/src/interp.lisp: Keep track of
     397        *COMMAND-KEY-EVENT-BUFFER* in %COMMAND-LOOP, to enable the
     398        RECURSIVE-GET-KEY-EVENT redisplay mechanism.
     399
     4002007-08-23 17:10  gb
     401
     402        * cocoa-ide/hemlock/src/echo.lisp: Don't call
     403        DOCUMENT-SET-POINT-POSITION in CLEAR-ECHO-AREA: editing changes may
     404        still be pending on the echo area (how ?), and
     405        DOCUMENT-SET-POINT-POSITION may need to do layout/display updates.
     406        Use RECURSIVE-GET-KEY-EVENT when prompting in the echo area.
     407
     4082007-08-23 16:11  gb
     409
     410        * cocoa-ide/hemlock/src/cocoa-hemlock.lisp: Define
     411        RECURSIVE-GET-KEY-EVENT, to allow redisplay on the buffer
     412        designated as *COMMAND-KEY-EVENT-BUFFER* in while getting key
     413        events in some modal loop in a command.  (The idea is that toplevel
     414        editing commands inhibit redisplay in the main buffer while they're
     415        active; commands which recursively process key events and which may
     416        make changes to that buffer should allow redisplay while they're
     417        waiting in RECURSIVE-GET-KEY-EVENT.)
     418
     4192007-08-23 16:10  gb
     420
     421        * cocoa-ide/hemlock/src/filecoms.lisp: Use the NSDocument-based
     422        revert.
     423
     4242007-08-18 19:11  gb
     425
     426        * level-1/: l1-dcode.lisp, l1-dcode.lisp: Define and use
     427        %GF-DISPATCH-TABLE-STORE-CONDITIONAL; this is intended to avoid
     428        race conditions where two threads try to update a distpatch table
     429        index with different {wrapper, combined-method} pairs at the same
     430        time.  (As it's written, if the store-conditional fails because a
     431        slot that we thought was free is now in use, we simply don't cache
     432        the pair and get a cache miss the next time; that may or may not be
     433        more work than repeating the whole process would be.)
     434       
     435        The store-conditional is used on attempt to update the
     436        combined-method slot in the pair; the wrapper slot is only updated
     437        if the store-conditional succeeds.  Code which probes the wrapper
     438        slots shouldn't be confused by a half-updated pair (should never
     439        see a non-null wrapper slot and a null combined-method slot.)
     440
     4412007-08-18 17:11  gb
     442
     443        * lib/db-io.lisp: Don't treat (:* :void) as (:* nil) in
     444        %DECODE-TYPE.
     445
     4462007-08-18 16:10  gb
     447
     448        * cocoa-ide/cocoa-editor.lisp: Use #/instancesRespondToSelector: to
     449        determine if selection highlighting can be used, since
     450        #_class_respondsToSelector requires ObjC-2.0)
     451
     4522007-08-16 08:22  gb
     453
     454        * cocoa-ide/cocoa-editor.lisp: Hemlock text storage can use
     455        extended selection highlighting if it's supported.
     456       
     457        Clear the shift bit from key events associated with standard-chars.
     458
     4592007-08-16 08:20  gb
     460
     461        * cocoa-ide/hemlock/src/bindings.lisp: Shifted and unshifted keys
     462        bound to movement commands run different commands.
     463       
     464        Left-mouse has the :mouse-exit logical attribute.
     465
     4662007-08-16 08:19  gb
     467
     468        * cocoa-ide/hemlock/src/buffer.lisp:
     469        CURRENT-POINT-COLLAPSING-SELECTION and
     470        CURRENT-POINT-EXTENDING-SELECTION replace
     471        CURRENT-POINT-FOR-MOVEMENT.
     472
     4732007-08-16 08:18  gb
     474
     475        * cocoa-ide/hemlock/src/cocoa-hemlock.lisp: Simplify key-event
     476        translation.
     477       
     478        Define NOTE-SELECTION-SET-BY-SEARCH, which can cause special
     479        selection highlighting under Leopard.
     480
     4812007-08-16 08:16  gb
     482
     483        * cocoa-ide/hemlock/src/command.lisp: Movement commands come in
     484        "shifted" and "unshifted" variants.
     485
     4862007-08-16 08:15  gb
     487
     488        * cocoa-ide/hemlock/src/echo.lisp: :mouse-exit is a new logical key
     489        attribute.
     490
     4912007-08-16 08:14  gb
     492
     493        * cocoa-ide/hemlock/src/key-event.lisp: GET-KEY-EVENT*: clear shift
     494        bit for standard-char (and upper-case.) This means that
     495        #k"ctrl-shift-a" and #k"ctrl-A" both refer to the same key event
     496        (in which the shift modifier isn't explicitly set) and that
     497        #k"rightarrow" and #k"shift-rightarrow" are distinct (and the shift
     498        modifier is set in the latter.)
     499
     5002007-08-16 08:13  gb
     501
     502        * cocoa-ide/hemlock/src/lispmode.lisp: When indenting, don't change
     503        the buffer if the line's already indented properly.
     504       
     505        Movement commands come in two variants: those that collapse and
     506        those that extend the selection.
     507
     5082007-08-16 08:12  gb
     509
     510        * cocoa-ide/hemlock/src/package.lisp: Export
     511        CURRENT-POINT-EXTENDING-SELECTION and
     512        CURRENT-POINT-COLLAPSING-SELECTION.  Don't export
     513        CURRENT-POINT-FOR-MOVEMENT.
     514
     5152007-08-16 08:10  gb
     516
     517        * cocoa-ide/hemlock/src/searchcoms.lisp: Hilite the selection more
     518        empatically (under Leopard) after successful (non incremental)
     519        search.
     520       
     521        Incremental search also hilites the selection, but doesn't yet
     522        manage the selection on failure.
     523
     5242007-08-16 07:10  gb
     525
     526        * cocoa-ide/cocoa-editor.lisp: activate-hemlock-view: implemenent
     527        by invoking #/activateHemlockView on main thread; call
     528        deactivate-hemlock-view on the peer.
     529       
     530        Not sure if edit-count fuss in deactivate-hemlock-view is correct,
     531        but I'm fairly sure that this stuff needs to happen on the main
     532        thread.
     533
     5342007-08-09 16:10  gb
     535
     536        * lib/arglist.lisp: Use PRINC-TO-STRING (not PRIN1-TO-STRING) in
     537        ARGLIST-STRING, to avoid prinding package qualfiers (ticket:30).
     538
     5392007-08-07 15:10  gb
     540
     541        * cocoa-ide/hemlock/src/bindings.lisp: Bind home and end to
     542        beginning of buffer and end of buffer.  It's Mac standard, and I
     543        use it a lot.  Home was bound to "Help".
     544       
     545        Make clicking the mouse while incremental searching exit instead of
     546        abort, leaving the insertion point where you click instead of where
     547        the isearch was started.
     548
     5492007-08-06 23:10  gb
     550
     551        * cocoa-ide/: hemlock/src/bindings.lisp, hemlock/src/buffer.lisp,
     552        hemlock/src/cocoa-hemlock.lisp, hemlock/src/command.lisp,
     553        hemlock/src/lispmode.lisp, hemlock/src/morecoms.lisp,
     554        hemlock/src/package.lisp, cocoa-editor.lisp: When generating a
     555        hemlock key event, set the hemlock shift bit if the the Cocoa shift
     556        bit was set.  In HI::GET-KEY-EVENT, return an event with the shift
     557        bit cleared and the keysym downcased (if necessary).  Leave
     558        HI::*LAST-KEY-EVENT-TYPED* as the unmodified event (which may have
     559        shift bits set.) Define HI:CURRENT-POINT-FOR-MOVEMENT, which
     560        deactivates the region ("collapses the selection") if the shift bit
     561        was clear in HI::*LAST-KEY-EVENT-TYPED* and ensures that a region
     562        is active otherwise.  Use HI:CURRENT-POINT-FOR-MOVEMENT in (most,
     563        hopefully all) movement commands, to address ticket:36 .  Define a
     564        "Do Nothing" hemlock command, bind #k"leftdown" (left mouse down)
     565        to it to address ticket:44 .
     566
     5672007-08-06 19:10  gb
     568
     569        * objc-bridge/objc-support.lisp: careful with db stuff
     570
     5712007-08-04 13:12  gb
     572
     573        * cocoa-ide/cocoa-editor.lisp: Conditionalize an #_NSLog call.
     574        Post a #k"leftdown" to Hemlock on mouseDown: in the main text view.
     575         (Should maybe do this on mousedown in the echo area, too.) Some
     576        indentation changes.
     577
     5782007-08-04 12:14  gb
     579
     580        * cocoa-ide/hemlock/src/bindings.lisp: Make #k"leftdown" a logical
     581        :abort key event.
     582
     5832007-08-04 12:13  gb
     584
     585        * cocoa-ide/hemlock/src/doccoms.lisp: Fix format string in window
     586        title for show lossage command.
     587
     5882007-08-04 12:12  gb
     589
     590        * cocoa-ide/hemlock/src/keysym-defs.lisp: Define the keysym for
     591        left mouse down, so that we can use #k"leftdown".
     592
     5932007-08-04 12:11  gb
     594
     595        * cocoa-ide/hemlock/src/key-event.lisp: Revive mouse-event stuff.
     596
     5972007-08-03 15:10  gb
     598
     599        * compiler/X86/x86-disassemble.lisp: Correct spelling errors.
     600
     6012007-08-03 10:10  gb
     602
     603        * lib/backquote.lisp: Use list-to-vector, not (apply #'vector ...),
     604        since the latter can run into problems with CALL-ARGUMENTS-LIMIT.
     605
     6062007-08-03 09:10  gb
     607
     608        * level-0/l0-array.lisp: Define list-to-vector.
     609
     6102007-08-02 07:16  gb
     611
     612        * cocoa-ide/cocoa-prefs.lisp: Don't make font panel broadcast
     613        #/changeFont:; use targeted messages.  Ensure that font panel picks
     614        up the right font.
     615
     6162007-08-02 07:16  gb
     617
     618        * cocoa-ide/cocoa-window.lisp: Don't enable "metal" style by
     619        default.
     620
     6212007-08-02 07:15  gb
     622
     623        * cocoa-ide/cocoa-editor.lisp: Make "peer" text view (main text
     624        view, echo area) unselectable when activating via Hemlock command.
     625        Text views don't use font panel by default; enable/disable font
     626        panel when setting text color.
     627
     6282007-08-02 07:14  gb
     629
     630        * cocoa-ide/.cvsignore: New.
     631
     6322007-08-02 07:13  gb
     633
     634        * lib/: ccl-export-syms.lisp, compile-ccl.lisp: Define and export
     635        CREATE-INTERFACES.
     636
     6372007-08-02 07:12  gb
     638
     639        * cocoa-ide/cocoa-defaults.lisp: Don't need carbon interfaces.
     640
     6412007-08-02 07:11  gb
     642
     643        * library/parse-ffi.lisp: Don't be verbose about explict struct
     644        returns.
     645
     6462007-08-02 07:10  gb
     647
     648        * objc-bridge/objc-runtime.lisp: Don't use carbon  interfaces
     649        anymore.
     650
    16512007-07-31 19:10  gb
    2652
  • branches/ia32/cocoa-ide

    • Property svn:ignore set to
      *~.*
  • branches/ia32/cocoa-ide/cocoa-backtrace.lisp

    r6866 r7244  
    5656       (eql self (frame-label-controller thing))))
    5757
     58(def-cocoa-default *backtrace-font-name* :string "Monaco" "Name of font used in backtrace views")
     59(def-cocoa-default *backtrace-font-size* :float 9.0f0 "Size of font used in backtrace views")
     60
     61
    5862(objc:defmethod (#/windowDidLoad :void) ((self backtrace-window-controller))
    5963  (let* ((outline (slot-value self 'outline-view))
    60          (font (default-font :name "Monaco" :size 12)))
     64         (font (default-font :name *backtrace-font-name* :size *backtrace-font-size*)))
    6165    (unless (%null-ptr-p outline)
    6266      (#/setTarget: outline self)
     67      (#/setRowHeight: outline  (size-of-char-in-font font))
    6368      (#/setDoubleAction: outline (@selector #/backtraceDoubleClick:))
    6469      (#/setShouldCascadeWindows: self nil)
     
    6772          (let* ((column (#/objectAtIndex:  columns i))
    6873                 (data-cell (#/dataCell column)))
     74            (#/setEditable: data-cell nil)
    6975            (#/setFont: data-cell font)
    7076            (when (eql i 0)
     
    8187                                (class-name (class-of break-condition))
    8288                                break-condition))))
    83                 (#/setFont: header-cell (default-font :attributes '(:bold)))
     89                (#/setFont: header-cell (default-font :name "Courier" :size 10 :attributes '(:bold)))
    8490                (#/setStringValue: header-cell (%make-nsstring break-condition-string))))))))
    8591    (let* ((window (#/window  self)))
     
    102108                                        (process-serial-number process)
    103109                                        (bt.break-level context)))))))))
     110
     111(objc:defmethod (#/continue: :void) ((self backtrace-window-controller) sender)
     112  (declare (ignore sender))
     113  (let* ((context (backtrace-controller-context self))
     114         (process (and context (tcr->process (bt.tcr context)))))
     115    (when process (process-interrupt process #'continue))))
     116
     117(objc:defmethod (#/exitBreak: :void) ((self backtrace-window-controller) sender)
     118  (declare (ignore sender))
     119  (let* ((context (backtrace-controller-context self))
     120         (process (and context (tcr->process (bt.tcr context)))))
     121    (when process (process-interrupt process #'abort-break))))
     122
     123(objc:defmethod (#/restarts: :void) ((self backtrace-window-controller) sender)
     124  (let* ((context (backtrace-controller-context self)))
     125    (when context
     126      (#/showWindow: (restarts-controller-for-context context) sender))))
     127
    104128
    105129
  • branches/ia32/cocoa-ide/cocoa-defaults.lisp

    r6866 r7244  
    1919(eval-when (:compile-toplevel :execute)
    2020  (use-interface-dir :cocoa)
     21  #+nomore
    2122  (use-interface-dir :carbon))
    2223
  • branches/ia32/cocoa-ide/cocoa-editor.lisp

    r6892 r7244  
    99
    1010(eval-when (:compile-toplevel :execute)
    11   ;; :ALL-IN-COCOA-THREAD selects code that does all rendering
    12   ;; in the Cocoa event thread.
    13   ;; Something else that could be conditionalized (and might
    14   ;; be similarly named) would force all Hemlock commands -
    15   ;; as well as rendering and event handling - to happen in
    16   ;; the Cocoa thread.
    17   (pushnew :all-in-cocoa-thread *features*)
    1811  (use-interface-dir :cocoa))
    1912
     
    3023(def-cocoa-default *editor-background-color* :color '(1.0 1.0 1.0 1.0) "Editor background color")
    3124
     25(defmacro nsstring-encoding-to-nsinteger (n)
     26  (target-word-size-case
     27   (32 `(u32->s32 ,n))
     28   (64 n)))
     29
     30(defmacro nsinteger-to-nsstring-encoding (n)
     31  (target-word-size-case
     32   (32 `(s32->u32 ,n))
     33   (64 n)))
    3234
    3335(defun make-editor-style-map ()
     
    4244                      (unless (eql f font) f)))
    4345         (color-class (find-class 'ns:ns-color))
    44          (colors (vector (#/blackColor color-class)
    45                          (#/whiteColor  color-class)
    46                          (#/darkGrayColor color-class)
    47                          (#/lightGrayColor color-class)
    48                          (#/redColor color-class)
    49                          (#/blueColor color-class)
    50                          (#/greenColor color-class)
    51                          (#/yellowColor color-class)))
     46         (colors (vector (#/blackColor color-class)))
    5247         (styles (make-instance 'ns:ns-mutable-array
    5348                                :with-capacity (the fixnum (* 4 (length colors)))))
     
    309304                       (char-code #\Newline)
    310305                       line (hi::line-next line)
    311                        len (if line (hi::line-length line))
     306                       len (if line (hi::line-length line) 0)
    312307                       idx 0))))))))
    313308
     
    369364     (edit-count :foreign-type :int)
    370365     (cache :foreign-type :id)
    371      (styles :foreign-type :id))
     366     (styles :foreign-type :id)
     367     (selection-set-by-search :foreign-type :<BOOL>))
    372368  (:metaclass ns:+ns-object))
    373369
     
    389385;;; Return true iff we're inside a "beginEditing/endEditing" pair
    390386(objc:defmethod (#/editingInProgress :<BOOL>) ((self hemlock-text-storage))
    391   (not (eql (slot-value self 'edit-count) 0)))
     387  (> (slot-value self 'edit-count) 0))
    392388
    393389(defun textstorage-note-insertion-at-position (self pos n)
     
    397393    (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters r 0)))
    398394
    399 (objc:defmethod (#/noteInsertion: :void) ((self hemlock-text-storage) params)
    400   (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
    401          (n (#/longValue (#/objectAtIndex: params 1))))
    402     (textstorage-note-insertion-at-position self pos n)))
    403 
    404 (objc:defmethod (#/noteDeletion: :void) ((self hemlock-text-storage) params)
    405   (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
    406          (n (#/longValue (#/objectAtIndex: params 1))))
    407     (#/edited:range:changeInLength: self #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n))
    408     (let* ((display (hemlock-buffer-string-cache (#/hemlockString self))))
    409       (reset-buffer-cache display)
    410       (update-line-cache-for-index display pos))))
    411 
    412 (objc:defmethod (#/noteModification: :void) ((self hemlock-text-storage) params)
    413   (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
    414          (n (#/longValue (#/objectAtIndex: params 1))))
    415     #+debug 0
    416     (#_NSLog #@"Note modification: pos = %d, n = %d" :int pos :int n)
     395
     396;;; This runs on the main thread; it synchronizes the "real" NSMutableAttributedString
     397;;; with the hemlock string and informs the textstorage of the insertion.
     398(objc:defmethod (#/noteHemlockInsertionAtPosition:length: :void) ((self hemlock-text-storage)
     399                                                                  (pos :<NSI>nteger)
     400                                                                  (n :<NSI>nteger)
     401                                                                  (extra :<NSI>nteger))
     402  (declare (ignorable extra))
     403  (let* ((cache (#/cache self))
     404         (hemlock-string (#/hemlockString self))
     405         (display (hemlock-buffer-string-cache hemlock-string))
     406         (buffer (buffer-cache-buffer display))
     407         (hi::*buffer-gap-context* (hi::buffer-gap-context buffer))
     408         (font (buffer-active-font buffer))
     409         (document (#/document self)))
     410    #+debug
     411    (#_NSLog #@"insert: pos = %ld, n = %ld" :long pos :long n)
     412    ;; We need to update the hemlock string cache here so that #/substringWithRange:
     413    ;; will work on the hemlock buffer string.
     414    (adjust-buffer-cache-for-insertion display pos n)
     415    (update-line-cache-for-index display pos)
     416    (let* ((replacestring (#/substringWithRange: hemlock-string (ns:make-ns-range pos n))))
     417      (ns:with-ns-range (replacerange pos 0)
     418        (#/replaceCharactersInRange:withString:
     419         cache replacerange replacestring)))
     420    (#/setAttributes:range: cache 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
     427
     428(objc:defmethod (#/noteHemlockDeletionAtPosition:length: :void) ((self hemlock-text-storage)
     429                                                                 (pos :<NSI>nteger)
     430                                                                 (n :<NSI>nteger)
     431                                                                 (extra :<NSI>nteger))
     432  (declare (ignorable extra))
     433  (ns:with-ns-range (range pos n)
     434    ;; It seems to be necessary to call #/edited:range:changeInLength: before
     435    ;; deleting from the cached attributed string.  It's not clear whether this
     436    ;; is also true of insertions and modifications.
    417437    (#/edited:range:changeInLength: self (logior #$NSTextStorageEditedCharacters
    418                                                  #$NSTextStorageEditedAttributes) (ns:make-ns-range pos n) 0)))
    419 
    420 (objc:defmethod (#/noteAttrChange: :void) ((self hemlock-text-storage) params)
    421   (let* ((pos (#/longValue (#/objectAtIndex: params 0)))
    422          (n (#/longValue (#/objectAtIndex: params 1))))
    423     #+debug (#_NSLog #@"attribute-change at %d/%d" :int pos :int n)
    424     (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes (ns:make-ns-range pos n) 0)))
    425 
     438                                                 #$NSTextStorageEditedAttributes)
     439                                    range (- n))
     440    (#/deleteCharactersInRange: (#/cache 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 
     449
     450(objc:defmethod (#/noteHemlockModificationAtPosition:length: :void) ((self hemlock-text-storage)
     451                                                                     (pos :<NSI>nteger)
     452                                                                     (n :<NSI>nteger)
     453                                                                     (extra :<NSI>nteger))
     454  (declare (ignorable extra))
     455  (let* ((hemlock-string (#/hemlockString self))
     456         (cache (#/cache self)))
     457    (ns:with-ns-range (range pos n)
     458      (#/replaceCharactersInRange:withString:
     459       cache range (#/substringWithRange: hemlock-string range))
     460      (#/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
     467
     468(objc:defmethod (#/noteHemlockAttrChangeAtPosition:length: :void) ((self hemlock-text-storage)
     469                                                                   (pos :<NSI>nteger)
     470                                                                   (n :<NSI>nteger)
     471                                                                   (fontnum :<NSI>nteger))
     472  (ns:with-ns-range (range pos n)
     473    (#/setAttributes:range: (#/cache self) (#/objectAtIndex: (#/styles self) fontnum) range)
     474    (#/edited:range:changeInLength: self #$NSTextStorageEditedAttributes range 0)))
     475
     476(defloadvar *buffer-change-invocation*
     477    (with-autorelease-pool
     478        (#/retain
     479                   (#/invocationWithMethodSignature: ns:ns-invocation
     480                                                     (#/instanceMethodSignatureForSelector:
     481                                                      hemlock-text-storage
     482                                            (@selector #/noteHemlockInsertionAtPosition:length:))))))
     483
     484(defstatic *buffer-change-invocation-lock* (make-lock))
     485
     486         
     487         
    426488(objc:defmethod (#/beginEditing :void) ((self hemlock-text-storage))
    427489  (with-slots (edit-count) self
     
    439501    (call-next-method)
    440502    (decf edit-count)
    441     (when (< edit-count 0)
    442       (#_NSLog #@"after endEditing on %@, edit-count now = %d" :id self :int edit-count))))
    443 
    444 ;;; Return true iff we're inside a "beginEditing/endEditing" pair
    445 (objc:defmethod (#/editingInProgress :<BOOL>) ((self hemlock-text-storage))
    446   (not (eql (slot-value self 'edit-count) 0)))
     503    #+debug
     504    (#_NSLog #@"after endEditing on %@, edit-count now = %d" :id self :int edit-count)))
     505
     506
    447507
    448508 
     
    464524(objc:defmethod #/styles ((self hemlock-text-storage))
    465525  (slot-value self 'styles))
     526
     527(objc:defmethod #/document ((self hemlock-text-storage))
     528  (or
     529   (let* ((string (#/hemlockString self)))
     530     (unless (%null-ptr-p string)
     531       (let* ((cache (hemlock-buffer-string-cache string)))
     532         (when cache
     533           (let* ((buffer (buffer-cache-buffer cache)))
     534             (when buffer
     535               (hi::buffer-document buffer)))))))
     536   +null-ptr+))
    466537
    467538(objc:defmethod #/initWithString: ((self hemlock-text-storage) s)
     
    501572    ((self hemlock-text-storage) (index :<NSUI>nteger) (rangeptr (* :<NSR>ange)))
    502573  #+debug
    503   (#_NSLog #@"Attributes at index: %d storage %@" :unsigned index :id self)
     574  (#_NSLog #@"Attributes at index: %lu storage %@" :<NSUI>nteger index :id self)
    504575  (with-slots (cache styles) self
     576    (when (>= index (#/length cache))
     577      (#_NSLog #@"Attributes at index: %lu  edit-count: %d cache: %@ layout: %@" :<NSUI>nteger index ::unsigned (slot-value self 'edit-count) :id cache :id (#/objectAtIndex: (#/layoutManagers self) 0))
     578      (for-each-textview-using-storage self
     579                                       (lambda (tv)
     580                                         (let* ((w (#/window tv))
     581                                                (proc (slot-value w 'command-thread)))
     582                                           (process-interrupt proc #'dbg))))
     583      (dbg))
    505584    (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr)))
    506585      (when (eql 0 (#/count attrs))
     
    513592      attrs)))
    514593
     594000
    515595(objc:defmethod (#/replaceCharactersInRange:withString: :void)
    516596    ((self hemlock-text-storage) (r :<NSR>ange) string)
    517   #+debug (#_NSLog #@"Replace in range %ld/%ld with %@"
     597  #+debug 0 (#_NSLog #@"Replace in range %ld/%ld with %@"
    518598                    :<NSI>nteger (pref r :<NSR>ange.location)
    519599                    :<NSI>nteger (pref r :<NSR>ange.length)
     
    525605         (length (pref r :<NSR>ange.length))
    526606         (point (hi::buffer-point buffer)))
    527     (let* ((lisp-string (lisp-string-from-nsstring string))
     607    (let* ((lisp-string (if (> (#/length string) 0) (lisp-string-from-nsstring string)))
    528608           (document (if buffer (hi::buffer-document buffer)))
    529609           (textstorage (if document (slot-value document 'textstorage))))
    530610      (when textstorage (#/beginEditing textstorage))
    531611      (setf (hi::buffer-region-active buffer) nil)
    532       (unless (zerop length)
    533         (hi::with-mark ((start point)
    534                         (end point))
    535           (move-hemlock-mark-to-absolute-position start cache location)
    536           (move-hemlock-mark-to-absolute-position end cache (+ location length))
    537           (hi::delete-region (hi::region start end))))
    538       (hi::insert-string point lisp-string)
     612      (hi::with-mark ((start point :right-inserting))
     613        (move-hemlock-mark-to-absolute-position start cache location)
     614        (unless (zerop length)
     615          (hi::delete-characters start length))
     616        (when lisp-string
     617          (hi::insert-string start lisp-string)))
    539618      (when textstorage
    540619        (#/endEditing textstorage)
     
    631710    ((blink-location :foreign-type :unsigned :accessor text-view-blink-location)
    632711     (blink-color-attribute :foreign-type :id :accessor text-view-blink-color)
    633      (blink-enabled :foreign-type :<BOOL> :accessor text-view-blink-enabled) )
     712     (blink-enabled :foreign-type :<BOOL> :accessor text-view-blink-enabled)
     713     (peer :foreign-type :id))
    634714  (:metaclass ns:+ns-object))
    635715
     
    720800        #+debug (#_NSLog #@"Syntax check for blinking")
    721801        (update-buffer-package (hi::buffer-document buffer) buffer)
    722          
    723802        (cond ((eql (hi::next-character point) #\()
    724803               (hemlock::pre-command-parse-check point)
    725                (when (hemlock::valid-spot point nil)
     804               (when (hemlock::valid-spot point t)
    726805                 (hi::with-mark ((temp point))
    727806                   (when (hemlock::list-offset temp 1)
     
    746825
    747826(objc:defmethod (#/updateSelection:length:affinity: :void)
    748     ((self hemlock-textstorage-text-view)
    749     (pos :int)
    750     (length :int)
    751     (affinity :<NSS>election<A>ffinity))
     827                ((self hemlock-textstorage-text-view)
     828                (pos :int)
     829                (length :int)
     830                (affinity :<NSS>election<A>ffinity))
    752831  (when (eql length 0)
    753832    (update-blink self))
    754833  (rlet ((range :ns-range :location pos :length length))
    755     (%call-next-objc-method self
    756                             hemlock-textstorage-text-view
    757                             (@selector #/setSelectedRange:affinity:stillSelecting:)
    758                             '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
    759                             range
    760                             affinity
    761                             nil)
    762     (#/scrollRangeToVisible: self range)))
     834        (%call-next-objc-method self
     835                                hemlock-textstorage-text-view
     836                                (@selector #/setSelectedRange:affinity:stillSelecting:)
     837                                '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
     838                                range
     839                                affinity
     840                                nil)
     841        (#/scrollRangeToVisible: self range)
     842        (when (> length 0)
     843          (let* ((ts (#/textStorage self)))
     844            (with-slots (selection-set-by-search) ts
     845              (when (prog1 (eql #$YES selection-set-by-search)
     846                      (setq selection-set-by-search #$NO))
     847                (highlight-search-selection self pos length)))))
     848))
     849
     850(defloadvar *can-use-show-find-indicator-for-range*
     851    (#/instancesRespondToSelector: ns:ns-text-view (@selector "showFindIndicatorForRange:")))
     852
     853;;; Add transient highlighting to a selection established via a search
     854;;; primitive, if the OS supports it.
     855(defun highlight-search-selection (tv pos length)
     856  (when *can-use-show-find-indicator-for-range*
     857    (ns:with-ns-range (r pos length)
     858      (objc-message-send tv "showFindIndicatorForRange:" :<NSR>ange r :void))))
    763859 
    764860;;; A specialized NSTextView. The NSTextView is part of the "pane"
     
    769865     (char-height :foreign-type :<CGF>loat :accessor text-view-char-height))
    770866  (:metaclass ns:+ns-object))
     867
     868
     869
     870
    771871
    772872
     
    793893               menu)))))
    794894
    795 (objc:defmethod (#/changeFont: :void)
    796     ((self hemlock-text-view) sender)
    797   (declare (ignorable sender))
    798   (#_NSLog #@"changefont!"))
     895
     896
    799897
    800898
     
    821919                            (slot-value window 'echo-area-view))))
    822920          (when echo-view (#/setBackgroundColor: echo-view color))))
    823       (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender)
     921      #+debug (#_NSLog #@"Updating backgroundColor to %@, sender = %@" :id color :id sender)
    824922      (#/setBackgroundColor: self color))))
    825923
     
    846944(objc:defmethod (#/updateTextColor: :void)
    847945    ((self hemlock-textstorage-text-view) sender)
    848     (%call-next-objc-method
    849      self
    850      hemlock-textstorage-text-view
    851      (@selector #/changeColor:)
    852      '(:void :id)
    853      sender)
     946  (unwind-protect
     947      (progn
     948        (#/setUsesFontPanel: self t)
     949        (%call-next-objc-method
     950         self
     951         hemlock-textstorage-text-view
     952         (@selector #/changeColor:)
     953         '(:void :id)
     954         sender))
     955    (#/setUsesFontPanel: self nil))
    854956  (#/setNeedsDisplay: self t))
    855957   
     
    9321034          (let* ((bits 0)
    9331035                 (useful-modifiers (logandc2 modifiers
    934                                              (logior #$NSShiftKeyMask
     1036                                             (logior ;#$NSShiftKeyMask
    9351037                                                     #$NSAlphaShiftKeyMask))))
    9361038            (unless quoted
     
    9391041                  (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
    9401042                                         (cdr map)))))))
     1043            (let* ((char (code-char c)))
     1044              (when (and char (standard-char-p char))
     1045                (setq bits (logandc2 bits hi::+shift-event-mask+))))
    9411046            (hemlock-ext::make-key-event c bits)))))))
    9421047
     
    9751080  (or (handle-key-down self event)
    9761081      (call-next-method event)))
     1082
     1083(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"))
     1086  (call-next-method event))
    9771087
    9781088;;; Update the underlying buffer's point (and "active region", if appropriate.
     
    11821292        (#/setFrame: modeline modeline-frame)))))
    11831293
    1184 ;;; We want to constrain the scrolling that happens under program control,
    1185 ;;; so that the clipview is always scrolled in character-sized increments.
    1186 #+doesnt-work-yet
    1187 (objc:defmethod (#/scrollClipView:toPoint: :void)
    1188     ((self modeline-scroll-view)
    1189      clip-view
    1190      (p :ns-point))
    1191   #+debug
    1192   (#_NSLog #@"Scrolling to point %@" :id (#_NSStringFromPoint p))
    1193   (let* ((char-height (#/verticalLineScroll self)))
    1194     (ns:with-ns-point (proposed (ns:ns-point-x p) (* char-height (round (ns:ns-point-y p) char-height)))
    1195     #+debug
    1196     (#_NSLog #@" Proposed point = %@" :id
    1197              (#_NSStringFromPoint proposed)))
    1198     (call-next-method clip-view proposed)))
     1294
    11991295
    12001296
     
    12871383                (#/setAllowsUndo: tv nil) ; don't want NSTextView undo
    12881384                (#/setUsesFindPanel: tv t)
    1289                 (#/setUsesFontPanel: tv t)
     1385                (#/setUsesFontPanel: tv nil)
    12901386                (#/setMenu: tv (text-view-context-menu))
    12911387                (#/setWidthTracksTextView: container tracks-width)
     
    13171413
    13181414
     1415(objc:defmethod (#/activateHemlockView :void) ((self text-pane))
     1416  (let* ((the-hemlock-frame (#/window self))
     1417         (text-view (text-pane-text-view self)))
     1418    #+debug (#_NSLog #@"Activating text pane")
     1419    (with-slots ((echo peer)) text-view
     1420      (deactivate-hemlock-view echo))
     1421    (#/setEditable: text-view t)
     1422    (#/makeFirstResponder: the-hemlock-frame text-view)))
     1423
    13191424(defmethod hi::activate-hemlock-view ((view text-pane))
    1320   (let* ((the-hemlock-frame (#/window view))
    1321          (text-view (text-pane-text-view view)))
    1322     #+debug (#_NSLog #@"Activating text pane")
    1323     (#/makeFirstResponder: the-hemlock-frame text-view)))
    1324 
     1425  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1426   view
     1427   (@selector #/activateHemlockView)
     1428   +null-ptr+
     1429   t))
     1430
     1431
     1432
     1433(defmethod deactivate-hemlock-view ((self hemlock-text-view))
     1434  #+debug (#_NSLog #@"deactivating text view")
     1435  (#/setSelectable: self nil))
    13251436
    13261437(defclass echo-area-view (hemlock-textstorage-text-view)
     
    13281439  (:metaclass ns:+ns-object))
    13291440
    1330 (defmethod hi::activate-hemlock-view ((view echo-area-view))
    1331   (let* ((the-hemlock-frame (#/window view)))
     1441(objc:defmethod (#/activateHemlockView :void) ((self echo-area-view))
     1442  (let* ((the-hemlock-frame (#/window self)))
    13321443    #+debug
    13331444    (#_NSLog #@"Activating echo area")
    1334     (#/makeFirstResponder: the-hemlock-frame view)))
     1445    (with-slots ((pane peer)) self
     1446      (deactivate-hemlock-view pane))
     1447    (#/setEditable: self t)
     1448  (#/makeFirstResponder: the-hemlock-frame self)))
     1449
     1450(defmethod hi::activate-hemlock-view ((view echo-area-view))
     1451  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1452   view
     1453   (@selector #/activateHemlockView)
     1454   +null-ptr+
     1455   t))
     1456
     1457(defmethod deactivate-hemlock-view ((self echo-area-view))
     1458  #+debug (#_NSLog #@"deactivating echo area")
     1459  (let* ((ts (#/textStorage self)))
     1460    #+debug 0
     1461    (when (#/editingInProgress ts)
     1462      (#_NSLog #@"deactivating %@, edit-count = %d" :id self :int (slot-value ts 'edit-count)))
     1463    (do* ()
     1464         ((not (#/editingInProgress ts)))
     1465      (#/endEditing ts))
     1466
     1467    (#/setSelectable: self nil)))
     1468
    13351469
    13361470(defmethod text-view-buffer ((self echo-area-view))
     
    13551489     (change :<NSD>ocument<C>hange<T>ype))
    13561490  (declare (ignore change)))
     1491
     1492(objc:defmethod (#/documentChangeCleared :void) ((self echo-area-document)))
    13571493
    13581494(objc:defmethod (#/keyDown: :void) ((self echo-area-view) event)
     
    14181554(defun make-echo-area-for-window (w gap-context-for-echo-area-buffer color)
    14191555  (let* ((content-view (#/contentView w))
    1420         (bounds (#/bounds content-view)))
    1421       (multiple-value-bind (echo-area box)
    1422           (make-echo-area w
    1423                           0.0f0
    1424                           0.0f0
    1425                           (- (ns:ns-rect-width bounds) 24.0f0)
    1426                           20.0f0
    1427                           gap-context-for-echo-area-buffer
    1428                           color)
    1429         (#/addSubview: content-view box)
    1430         echo-area)))
     1556        (bounds (#/bounds content-view)))
     1557    (multiple-value-bind (echo-area box)
     1558                        (make-echo-area w
     1559                                        0.0f0
     1560                                        0.0f0
     1561                                         (- (ns:ns-rect-width bounds) 16.0f0)
     1562                                        20.0f0
     1563                                        gap-context-for-echo-area-buffer
     1564                                        color)
     1565      (#/addSubview: content-view box)
     1566      echo-area)))
    14311567               
    14321568(defclass hemlock-frame (ns:ns-window)
     
    15281664         (hemlock::*target-column* 0)
    15291665         (hemlock::*last-comment-start* " ")
     1666         (hi::*translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t))
     1667         (hi::*current-command* (make-array 10 :fill-pointer 0 :adjustable t))
     1668         (hi::*current-translation* (make-array 10 :fill-pointer 0 :adjustable t))
     1669         #+no
    15301670         (hemlock::*last-search-string* ())
     1671         #+no
    15311672         (hemlock::*last-search-pattern*
    1532             (hemlock::new-search-pattern :string-insensitive :forward "Foo"))
    1533          )
     1673            (hemlock::new-search-pattern :string-insensitive :forward ""))
     1674         (hi::*prompt-key* (make-array 10 :adjustable t :fill-pointer 0))
     1675         (hi::*command-key-event-buffer* buffer))
    15341676   
    15351677    (setf (hi::current-buffer) buffer)
     
    15721714(defun add-pane-to-window (w &key (reserve-above 0.0f0) (reserve-below 0.0f0))
    15731715  (let* ((window-content-view (#/contentView w))
    1574         (window-frame (#/frame window-content-view)))
     1716        (window-frame (#/frame window-content-view)))
    15751717    (ns:with-ns-rect (pane-rect  0 reserve-below (ns:ns-rect-width window-frame) (- (ns:ns-rect-height window-frame) (+ reserve-above reserve-below)))
    1576       (let* ((pane (make-instance 'text-pane :with-frame pane-rect)))
    1577         (#/addSubview: window-content-view pane)
    1578         pane))))
     1718       (let* ((pane (make-instance 'text-pane :with-frame pane-rect)))
     1719        (#/addSubview: window-content-view pane)
     1720        pane))))
    15791721
    15801722(defun textpane-for-textstorage (class ts ncols nrows container-tracks-text-view-width color style)
     
    16411783  (let* ((pane (textpane-for-textstorage class ts ncols nrows container-tracks-text-view-width color style))
    16421784         (frame (#/window pane))
    1643          (buffer (text-view-buffer (text-pane-text-view pane))))
     1785         (buffer (text-view-buffer (text-pane-text-view pane)))
     1786         (echo-area (make-echo-area-for-window frame (hi::buffer-gap-context buffer) color))
     1787         (tv (text-pane-text-view pane)))
     1788    (with-slots (peer) tv
     1789      (setq peer echo-area))
     1790    (with-slots (peer) echo-area
     1791      (setq peer tv))
     1792    (hi::activate-hemlock-view pane)
    16441793    (setf (slot-value frame 'echo-area-view)
    1645           (make-echo-area-for-window frame (hi::buffer-gap-context buffer) color)
     1794          echo-area
    16461795          (slot-value frame 'pane)
    16471796          pane
    16481797          (slot-value frame 'command-thread)
    1649           (process-run-function (format nil "Hemlock window thread")
     1798          (process-run-function (format nil "Hemlock window thread for ~s"
     1799                                        (hi::buffer-name buffer))
    16501800                                #'(lambda ()
    16511801                                    (hemlock-thread-function
     
    16741824 
    16751825(defun hi::document-begin-editing (document)
    1676   #-all-in-cocoa-thread
    1677   (#/beginEditing (slot-value document 'textstorage))
    1678   #+all-in-cocoa-thread
    16791826  (#/performSelectorOnMainThread:withObject:waitUntilDone:
    16801827   (slot-value document 'textstorage)
     
    16871834
    16881835(defun hi::document-end-editing (document)
    1689   #-all-in-cocoa-thread
    1690   (#/endEditing (slot-value document 'textstorage))
    1691   #+all-in-cocoa-thread
    16921836  (#/performSelectorOnMainThread:withObject:waitUntilDone:
    16931837   (slot-value document 'textstorage)
     
    17061850
    17071851
    1708 (defun perform-edit-change-notification (textstorage selector pos n)
    1709   (let* ((number-for-pos
    1710           (#/initWithLong: (#/alloc ns:ns-number) pos))
    1711          (number-for-n
    1712           (#/initWithLong: (#/alloc ns:ns-number) n)))
    1713     (rlet ((paramptrs (:array :id 2)))
    1714       (setf (paref paramptrs (:* :id) 0) number-for-pos
    1715             (paref paramptrs (:* :id) 1) number-for-n)
    1716       (let* ((params (#/initWithObjects:count: (#/alloc ns:ns-array) paramptrs 2)))
    1717         (#/performSelectorOnMainThread:withObject:waitUntilDone:
    1718          textstorage selector params  t)
    1719         (#/release params)
    1720         (#/release number-for-n)
    1721         (#/release number-for-pos)))))
     1852(defun perform-edit-change-notification (textstorage selector pos n &optional (extra 0))
     1853  (with-lock-grabbed (*buffer-change-invocation-lock*)
     1854    (let* ((invocation *buffer-change-invocation*))
     1855      (rlet ((ppos :<NSI>nteger pos)
     1856             (pn :<NSI>nteger n)
     1857             (pextra :<NSI>nteger extra))
     1858        (#/setTarget: invocation textstorage)
     1859        (#/setSelector: invocation selector)
     1860        (#/setArgument:atIndex: invocation ppos 2)
     1861        (#/setArgument:atIndex: invocation pn 3)
     1862        (#/setArgument:atIndex: invocation pextra 4))
     1863      (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1864       invocation
     1865       (@selector #/invoke)
     1866       +null-ptr+
     1867       t))))
    17221868
    17231869(defun textstorage-note-insertion-at-position (textstorage pos n)
     
    17341880    (let* ((document (hi::buffer-document buffer))
    17351881           (textstorage (if document (slot-value document 'textstorage)))
    1736            (styles (#/styles textstorage))
    1737            (cache (#/cache textstorage))
    17381882           (pos (mark-absolute-position (hi::region-start region)))
    17391883           (n (- (mark-absolute-position (hi::region-end region)) pos)))
    1740       #+debug
    1741       (#_NSLog #@"Setting font attributes for %d/%d to %@" :int pos :int n :id (#/objectAtIndex: styles font))
    1742       (#/setAttributes:range: cache (#/objectAtIndex: styles font) (ns:make-ns-range pos n))
    17431884      (perform-edit-change-notification textstorage
    1744                                         (@selector #/noteAttrChange:)
     1885                                        (@selector #/noteHemlockAttrChangeAtPosition:length:)
    17451886                                        pos
    1746                                         n))))
     1887                                        n
     1888                                        font))))
    17471889
    17481890(defun buffer-active-font (buffer)
     
    17611903           (textstorage (if document (slot-value document 'textstorage))))
    17621904      (when textstorage
    1763         (let* ((pos (mark-absolute-position mark))
    1764                (cache (#/cache textstorage))
    1765                (hemlock-string (#/hemlockString textstorage))
    1766                (display (hemlock-buffer-string-cache hemlock-string))
    1767                (buffer (buffer-cache-buffer display))
    1768                (font (buffer-active-font buffer)))
     1905        (let* ((pos (mark-absolute-position mark)))
    17691906          (unless (eq (hi::mark-%kind mark) :right-inserting)
    17701907            (decf pos n))
    1771           #+debug
    1772           (#_NSLog #@"insert: pos = %d, n = %d" :int pos :int n)
    1773           ;;(reset-buffer-cache display)
    1774           (adjust-buffer-cache-for-insertion display pos n)
    1775           (update-line-cache-for-index display pos)
    1776           (let* ((replacestring (#/substringWithRange: hemlock-string (ns:make-ns-range pos n))))
    1777             (ns:with-ns-range (replacerange pos 0)
    1778               (#/replaceCharactersInRange:withString:
    1779                cache replacerange replacestring)))
    1780           (#/setAttributes:range: cache font (ns:make-ns-range pos n))
    1781           #-all-in-cocoa-thread
    1782           (textstorage-note-insertion-at-position textstorage pos n)
    1783           #+all-in-cocoa-thread
    17841908          (perform-edit-change-notification textstorage
    1785                                             (@selector "noteInsertion:")
     1909                                            (@selector #/noteHemlockInsertionAtPosition:length:)
    17861910                                            pos
    17871911                                            n))))))
     
    17921916           (textstorage (if document (slot-value document 'textstorage))))
    17931917      (when textstorage
    1794         (let* ((hemlock-string (#/hemlockString textstorage))
    1795                (cache (#/cache textstorage))
    1796                (pos (mark-absolute-position mark)))
    1797           (ns:with-ns-range (range pos n)
    1798             (#/replaceCharactersInRange:withString:
    1799              cache range (#/substringWithRange: hemlock-string range))
    1800             #+debug
    1801             (#_NSLog #@"enqueue modify: pos = %d, n = %d"
    1802                      :int pos
    1803                      :int n)
    1804             #-all-in-cocoa-thread
    1805             (#/edited:range:changeInLength:
    1806              textstorage
    1807              (logior #$NSTextStorageEditedCharacters
    1808                      #$NSTextStorageEditedAttributes)
    1809              range
    1810              0)
    1811             #+all-in-cocoa-thread
    18121918            (perform-edit-change-notification textstorage
    1813                                               (@selector #/noteModification:)
     1919                                              (@selector #/noteHemlockModificationAtPosition:length:)
    18141920                                              (mark-absolute-position mark)
    1815                                               n)))))))
     1921                                              n)))))
    18161922 
    18171923
     
    18211927           (textstorage (if document (slot-value document 'textstorage))))
    18221928      (when textstorage
    1823         (let* ((pos (mark-absolute-position mark))
    1824                (cache (#/cache textstorage)))
    1825           #-all-in-cocoa-thread
    1826           (progn
    1827             (#/edited:range:changeInLength:
    1828              textstorage #$NSTextStorageEditedCharacters (ns:make-ns-range pos n) (- n))
    1829             (let* ((display (hemlock-buffer-string-cache (#/hemlockString textstorage))))
    1830               (reset-buffer-cache display)
    1831               (update-line-cache-for-index display pos)))
    1832           (#/deleteCharactersInRange: cache (ns:make-ns-range pos (abs n)))
    1833           #+all-in-cocoa-thread
     1929        (let* ((pos (mark-absolute-position mark)))
    18341930          (perform-edit-change-notification textstorage
    1835                                             (@selector #/noteDeletion:)
     1931                                            (@selector #/noteHemlockDeletionAtPosition:length:)
    18361932                                            pos
    18371933                                            (abs n)))))))
    18381934
     1935
     1936
    18391937(defun hi::set-document-modified (document flag)
    1840   (#/updateChangeCount: document (if flag #$NSChangeDone #$NSChangeCleared)))
     1938  (unless flag
     1939    (#/performSelectorOnMainThread:withObject:waitUntilDone:
     1940     document
     1941     (@selector #/documentChangeCleared)
     1942     +null-ptr+
     1943     t)))
    18411944
    18421945
     
    19162019(defclass hemlock-editor-document (ns:ns-document)
    19172020    ((textstorage :foreign-type :id)
    1918      (encoding :foreign-type :<NSS>tring<E>ncoding))
     2021     (encoding :foreign-type :<NSS>tring<E>ncoding :initform (get-default-encoding)))
    19192022  (:metaclass ns:+ns-object))
     2023
     2024(objc:defmethod (#/documentChangeCleared :void) ((self hemlock-editor-document))
     2025  (#/updateChangeCount: self #$NSChangeCleared))
     2026
    19202027
    19212028(defmethod update-buffer-package ((doc hemlock-editor-document) buffer)
     
    19292036                (not (string= curname name)))
    19302037          (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
     2038
     2039(defun hi::document-note-selection-set-by-search (doc)
     2040  (with-slots (textstorage) doc
     2041    (when textstorage
     2042      (with-slots (selection-set-by-search) textstorage
     2043        (setq selection-set-by-search #$YES)))))
    19312044
    19322045(objc:defmethod (#/validateMenuItem: :<BOOL>)
     
    20502163               perror)
    20512164              +null-ptr+)))
    2052       (when (%null-ptr-p string)
    2053         (if (zerop selected-encoding)
    2054           (setq selected-encoding (get-default-encoding)))
    2055         (setq string (#/stringWithContentsOfURL:encoding:error:
    2056                       ns:ns-string
    2057                       url
    2058                       selected-encoding
    2059                       perror)))
     2165      (if (%null-ptr-p string)
     2166        (progn
     2167          (if (zerop selected-encoding)
     2168            (setq selected-encoding (get-default-encoding)))
     2169          (setq string (#/stringWithContentsOfURL:encoding:error:
     2170                        ns:ns-string
     2171                        url
     2172                        selected-encoding
     2173                        perror)))
     2174        (setq selected-encoding (pref pused-encoding :<NSS>tring<E>ncoding)))
    20602175      (unless (%null-ptr-p string)
    20612176        (with-slots (encoding) self (setq encoding selected-encoding))
     
    20772192        t))))
    20782193
    2079 #+experimental
    2080 (objc:defmethod (#/writeWithBackupToFile:ofType:saveOperation: :<BOOL>)
    2081     ((self hemlock-editor-document) path type (save-operation :<NSS>ave<O>peration<T>ype))
    2082   #+debug
    2083   (#_NSLog #@"saving file to %@" :id path)
    2084   (call-next-method path type save-operation))
     2194
     2195
     2196
    20852197
    20862198(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files")
    20872199
    20882200(objc:defmethod (#/keepBackupFile :<BOOL>) ((self hemlock-editor-document))
    2089   *editor-keep-backup-files*)
    2090 
     2201  ;;; Don't use the NSDocument backup file scheme.
     2202  nil)
     2203
     2204(objc:defmethod (#/writeSafelyToURL:ofType:forSaveOperation:error: :<BOOL>)
     2205    ((self hemlock-editor-document)
     2206     absolute-url
     2207     type
     2208     (save-operation :<NSS>ave<O>peration<T>ype)
     2209     (error (:* :id)))
     2210  (when (and *editor-keep-backup-files*
     2211             (eql save-operation #$NSSaveOperation))
     2212    (write-hemlock-backup-file (#/fileURL self)))
     2213  (call-next-method absolute-url type save-operation error))
     2214
     2215(defun write-hemlock-backup-file (url)
     2216  (unless (%null-ptr-p url)
     2217    (when (#/isFileURL url)
     2218      (let* ((path (#/path url)))
     2219        (unless (%null-ptr-p path)
     2220          (let* ((newpath (#/stringByAppendingString: path #@"~"))
     2221                 (fm (#/defaultManager ns:ns-file-manager)))
     2222            ;; There are all kinds of ways for this to lose.
     2223            ;; In order for the copy to succeed, the destination can't exist.
     2224            ;; (It might exist, but be a directory, or there could be
     2225            ;; permission problems ...)
     2226            (#/removeFileAtPath:handler: fm newpath +null-ptr+)
     2227            (#/copyPath:toPath:handler: fm path newpath +null-ptr+)))))))
     2228
     2229             
    20912230
    20922231(defmethod hemlock-document-buffer (document)
     
    21552294
    21562295
    2157 ;;; Shadow the setFileName: method, so that we can keep the buffer
     2296;;; Shadow the setFileURL: method, so that we can keep the buffer
    21582297;;; name and pathname in synch with the document.
    21592298(objc:defmethod (#/setFileURL: :void) ((self hemlock-editor-document)
     
    22342373  (call-next-method))
    22352374
    2236 
    2237 
    2238 
     2375(defun window-visible-range (text-view)
     2376  (let* ((rect (#/visibleRect text-view))
     2377         (layout (#/layoutManager text-view))
     2378         (text-container (#/textContainer text-view))
     2379         (container-origin (#/textContainerOrigin text-view)))
     2380    ;; Convert from view coordinates to container coordinates
     2381    (decf (pref rect :<NSR>ect.origin.x) (pref container-origin :<NSP>oint.x))
     2382    (decf (pref rect :<NSR>ect.origin.y) (pref container-origin :<NSP>oint.y))
     2383    (let* ((glyph-range (#/glyphRangeForBoundingRect:inTextContainer:
     2384                         layout rect text-container))
     2385           (char-range (#/characterRangeForGlyphRange:actualGlyphRange:
     2386                        layout glyph-range +null-ptr+)))
     2387      (values (pref char-range :<NSR>ange.location)
     2388              (pref char-range :<NSR>ange.length)))))
     2389   
    22392390(defun hi::scroll-window (textpane n)
    2240   (let* ((n (or n 0))
    2241          (sv (text-pane-scroll-view textpane))
    2242          (tv (text-pane-text-view textpane))
    2243          (char-height (text-view-char-height tv))
    2244          (sv-height (ns:ns-size-height (#/contentSize sv)))
    2245          (nlines (floor sv-height char-height))
    2246          (point (hi::current-point)))
    2247     (or (hi::line-offset point (* n nlines))       
    2248         (if (< n 0)
    2249           (hi::buffer-start point)
    2250           (hi::buffer-end point)))))
     2391  (when n
     2392    (let* ((sv (text-pane-scroll-view textpane))
     2393           (tv (text-pane-text-view textpane))
     2394           (char-height (text-view-char-height tv))
     2395           (sv-height (ns:ns-size-height (#/contentSize sv)))
     2396           (nlines (floor sv-height char-height))
     2397           (count (case n
     2398                    (:page-up (- nlines))
     2399                    (:page-down nlines)
     2400                    (t n))))
     2401      (multiple-value-bind (pages lines) (floor (abs count) nlines)
     2402        (dotimes (i pages)
     2403          (if (< count 0)
     2404              (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2405               tv
     2406               (@selector #/scrollPageUp:)
     2407               +null-ptr+
     2408               t)
     2409              (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2410               tv
     2411               (@selector #/scrollPageDown:)
     2412               +null-ptr+
     2413               t)))
     2414        (dotimes (i lines)
     2415          (if (< count 0)
     2416              (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2417               tv
     2418               (@selector #/scrollLineUp:)
     2419               +null-ptr+
     2420               t)
     2421              (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2422               tv
     2423               (@selector #/scrollLineDown:)
     2424               +null-ptr+
     2425               t))))
     2426      ;; If point is not on screen, move it.
     2427      (let* ((point (hi::current-point))
     2428             (point-pos (mark-absolute-position point)))
     2429        (multiple-value-bind (win-pos win-len) (window-visible-range tv)
     2430          (unless (and (<= win-pos point-pos) (< point-pos (+ win-pos win-len)))
     2431            (let* ((point (hi::current-point-collapsing-selection))
     2432                   (cache (hemlock-buffer-string-cache
     2433                           (#/hemlockString (#/textStorage tv)))))
     2434              (move-hemlock-mark-to-absolute-position point cache win-pos)
     2435              ;; We should be done, but unfortunately, well, we're not.
     2436              ;; Something insists on recentering around point, so fake it out
     2437              #-work-around-overeager-centering
     2438              (or (hi::line-offset point (floor nlines 2))
     2439                  (if (< count 0)
     2440                      (hi::buffer-start point)
     2441                      (hi::buffer-end point))))))))))
     2442
    22512443
    22522444(defmethod hemlock::center-text-pane ((pane text-pane))
     
    23082500
    23092501
    2310 (defmacro nsstring-encoding-to-nsinteger (n)
    2311   (target-word-size-case
    2312    (32 `(u32->s32 ,n))
    2313    (64 n)))
    2314 
    2315 (defmacro nsinteger-to-nsstring-encoding (n)
    2316   (target-word-size-case
    2317    (32 `(s32->u32 ,n))
    2318    (64 n)))
     2502
    23192503
    23202504
     
    23232507;;; user isn't interested in.)
    23242508(defmethod build-encodings-popup ((self hemlock-document-controller)
    2325                                   &optional (preferred-encoding 0))
     2509                                  &optional (preferred-encoding (get-default-encoding)))
    23262510  (let* ((id-list (supported-nsstring-encodings))
    23272511         (popup (make-instance 'ns:ns-pop-up-button)))
     
    24412625    (unless (%null-ptr-p string)
    24422626      (unless (zerop (ns:ns-range-length (#/rangeOfString: string *ns-cr-string*)))
    2443         (unless (typep string 'ns:ns-mutable-string)
    2444           (setq string (make-instance 'ns:ns-mutable-string :with-string string)))
     2627        (setq string (make-instance 'ns:ns-mutable-string :with-string string))
    24452628        (#/replaceOccurrencesOfString:withString:options:range:
    24462629                string *ns-cr-string* *ns-lf-string* #$NSLiteralSearch (ns:make-ns-range 0 (#/length string))))
     
    25362719                                       
    25372720(objc:defmethod (#/documentClassForType: :<C>lass) ((self hemlock-document-controller)
    2538                                          type)
     2721                                                    type)
    25392722  (if (#/isEqualToString: type #@"html")
    2540     display-document
    2541     (call-next-method type)))
     2723      display-document
     2724      (call-next-method type)))
    25422725     
    25432726
    25442727(objc:defmethod #/newDisplayDocumentWithTitle:content:
    2545     ((self hemlock-document-controller)
    2546     title
    2547     string)
     2728                ((self hemlock-document-controller)
     2729                title
     2730                string)
    25482731  (let* ((doc (#/makeUntitledDocumentOfType:error: self #@"html" +null-ptr+)))
    25492732    (unless (%null-ptr-p doc)
     
    25512734      (#/makeWindowControllers doc)
    25522735      (let* ((window (#/window (#/objectAtIndex: (#/windowControllers doc) 0))))
    2553         (#/setTitle: window title)
    2554         (let* ((tv (slot-value doc 'text-view))
    2555                (lm (#/layoutManager tv))
    2556                (ts (#/textStorage lm)))
    2557           (#/beginEditing ts)
    2558           (#/replaceCharactersInRange:withAttributedString:
    2559            ts
    2560            (ns:make-ns-range 0 (#/length ts))
    2561            string)
    2562           (#/endEditing ts))
    2563         (#/makeKeyAndOrderFront:
    2564          window
    2565          self)))))
    2566 
    2567 
     2736        (#/setTitle: window title)
     2737        (let* ((tv (slot-value doc 'text-view))
     2738               (lm (#/layoutManager tv))
     2739               (ts (#/textStorage lm)))
     2740          (#/beginEditing ts)
     2741          (#/replaceCharactersInRange:withAttributedString:
     2742           ts
     2743           (ns:make-ns-range 0 (#/length ts))
     2744           string)
     2745          (#/endEditing ts))
     2746        (#/makeKeyAndOrderFront:
     2747         window
     2748         self)))))
     2749
     2750(defun hi::revert-document (doc)
     2751  (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2752   doc
     2753   (@selector #/revertDocumentToSaved:)
     2754   +null-ptr+
     2755   t))
     2756
     2757
     2758;;; Enable CL:ED
     2759(defun cocoa-edit (&optional arg)
     2760  (let* ((document-controller (#/sharedDocumentController ns:ns-document-controller)))
     2761    (cond ((null arg)
     2762           (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2763            document-controller
     2764            (@selector #/newDocument:)
     2765            +null-ptr+
     2766            t))
     2767          ((or (typep arg 'string)
     2768               (typep arg 'pathname))
     2769           (unless (probe-file arg)
     2770             (touch arg))
     2771           (with-autorelease-pool
     2772             (let* ((url (pathname-to-url arg))
     2773                    (signature (#/methodSignatureForSelector:
     2774                                document-controller
     2775                                (@selector #/openDocumentWithContentsOfURL:display:error:)))
     2776                    (invocation (#/invocationWithMethodSignature: ns:ns-invocation
     2777                                                                  signature)))
     2778             
     2779               (#/setTarget: invocation document-controller)
     2780               (#/setSelector: invocation (@selector #/openDocumentWithContentsOfURL:display:error:))
     2781               (rlet ((p :id)
     2782                      (q :<BOOL>)
     2783                      (perror :id +null-ptr+))
     2784                 (setf (pref p :id) url
     2785                       (pref q :<BOOL>) #$YES)
     2786                 (#/setArgument:atIndex: invocation p 2)
     2787                 (#/setArgument:atIndex: invocation q 3)
     2788                 (#/setArgument:atIndex: invocation perror 4)
     2789                 (#/performSelectorOnMainThread:withObject:waitUntilDone:
     2790                  invocation
     2791                  (@selector #/invoke)
     2792                  +null-ptr+
     2793                  t)))))
     2794          ((valid-function-name-p arg)
     2795           (hi::edit-definition arg))
     2796          (t (report-bad-arg arg '(or null string pathname (satisifies valid-function-name-p)))))
     2797    t))
     2798
     2799(setq ccl::*resident-editor-hook* 'cocoa-edit)
    25682800
    25692801(provide "COCOA-EDITOR")
  • branches/ia32/cocoa-ide/cocoa-listener.lisp

    r6887 r7244  
    204204  (call-next-method))
    205205
     206(objc:defmethod #/windowTitleForDocumentDisplayName: ((self hemlock-listener-window-controller) name)
     207  (let* ((doc (#/document self)))
     208    (if (or (%null-ptr-p doc)
     209            (not (%null-ptr-p (#/fileURL doc))))
     210      (call-next-method name)
     211      (let* ((buffer (hemlock-document-buffer doc))
     212             (bufname (if buffer (hi::buffer-name buffer))))
     213        (if bufname
     214          (%make-nsstring bufname)
     215          (call-next-method name))))))
    206216
    207217
     
    272282                                    "Listener-~d" *cocoa-listener-count*)))
    273283             (buffer (hemlock-document-buffer doc)))
    274         (#/setFileName: doc  (%make-nsstring listener-name))
    275284        (setf (hi::buffer-pathname buffer) nil
    276285              (hi::buffer-minor-mode buffer "Listener") t
     
    357366      (ccl::force-break-in-listener process))))
    358367
    359 (objc:defmethod (#/continue: :void) ((self hemlock-listener-document) sender)
    360   (declare (ignore sender))
    361   (let* ((buffer (hemlock-document-buffer self))
    362          (process (if buffer (hi::buffer-process buffer))))
    363     (when (typep process 'cocoa-listener-process)
    364       (process-interrupt process #'continue))))
     368
    365369
    366370(objc:defmethod (#/exitBreak: :void) ((self hemlock-listener-document) sender)
     
    506510                         (eql ch #\^p)
    507511                         (eql ch #\newline)
    508                          (eql ch #\^q))
     512                         (eql ch #\^q)
     513                         (eql ch #\^d))
    509514                 (out-raw-char #\^q))
    510515               (out-raw-char ch))
     
    519524      (out-raw-char #\newline)
    520525      (out-string string)
     526      (out-raw-char #\^d)
    521527      (force-output stream))))
    522528
  • branches/ia32/cocoa-ide/cocoa-prefs.lisp

    r6866 r7244  
    4949
    5050(defclass lisp-preferences-window-controller (ns:ns-window-controller)
    51     ((selected-font-index :foreign-type :int))
     51    ()
    5252  (:metaclass ns:+ns-object))
    5353
    5454(objc:defmethod (#/fontPanelForDefaultFont: :void)
    5555    ((self lisp-preferences-window-controller) sender)
    56   (with-slots (selected-font-index) self
    57     (setq selected-font-index 1))
     56  (let* ((fm (#/sharedFontManager ns:ns-font-manager)))
     57    (#/setSelectedFont:isMultiple: fm (default-font) nil)
     58    (#/setEnabled: fm t)
     59    (#/setTarget: fm self)
     60    (#/setAction: fm (@selector #/changeDefaultFont:)))
    5861  (#/orderFrontFontPanel: *NSApp* sender))
    5962
    6063
    6164(objc:defmethod (#/fontPanelForModelineFont: :void)
    62     ((self lisp-preferences-window-controller) sender)
    63   (with-slots (selected-font-index) self
    64     (setq selected-font-index 2))
     65                ((self lisp-preferences-window-controller) sender)
     66  (declare (special *modeline-font-name* *modeline-font-size*))
     67  (let* ((fm (#/sharedFontManager ns:ns-font-manager)))
     68    (#/setSelectedFont:isMultiple: fm (default-font
     69                                          :name *modeline-font-name*
     70                                        :size *modeline-font-size*)
     71                                   nil)
     72    (#/setTarget: fm self)
     73    (#/setAction: fm (@selector #/changeModelineFont:)))
    6574  (#/orderFrontFontPanel: *NSApp* sender))
    6675
    67 (objc:defmethod (#/changeFont: :void) ((self lisp-preferences-window-controller) sender)
    68   #+debug (#_NSLog #@"ChangeFont.")
    69   (with-slots ((idx selected-font-index)) self
    70     (when (> idx 0)
    71       (let* ((f (#/convertFont: sender (default-font))))
    72         (when (is-fixed-pitch-font f)
    73           (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
    74             (#/setValue:forKey: values (#/fontName f) (if (eql 1 idx) #@"defaultFontName" #@"modelineFontName:"))
    75             (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) (if (eql 1 idx) #@"defaultFontSize" #@"modelineFontSize"))))))))
     76
     77(objc:defmethod (#/changeDefaultFont: :void) ((self lisp-preferences-window-controller) sender)
     78  (let* ((f (#/convertFont: sender (default-font))))
     79    (when (is-fixed-pitch-font f)
     80      (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
     81        (#/setValue:forKey: values (#/fontName f) #@"defaultFontName")
     82        (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"defaultFontSize")))))
     83
     84(objc:defmethod (#/changeModelineFont: :void) ((self lisp-preferences-window-controller) sender)
     85  (declare (special *modeline-font-name* *modeline-font-size*))
     86  (let* ((f (#/convertFont: sender (default-font
     87                                          :name *modeline-font-name*
     88                                        :size *modeline-font-size*))))
     89    (when (is-fixed-pitch-font f)
     90      (let* ((values (#/values (#/sharedUserDefaultsController ns:ns-user-defaults-controller))))
     91        (#/setValue:forKey: values (#/fontName f) #@"modelineFontName:")
     92        (#/setValue:forKey: values (#/stringWithFormat: ns:ns-string #@"%u" (round (#/pointSize f))) #@"modelineFontSize")))))
    7693
    7794
  • branches/ia32/cocoa-ide/cocoa-window.lisp

    r6866 r7244  
    359359                         (closable t)
    360360                         (iconifyable t)
    361                          (metal t)
     361                         (metal nil)
    362362                         (expandable t)
    363363                         (backing :buffered)
  • branches/ia32/cocoa-ide/cocoa.lisp

    r6886 r7244  
    2424(require "COCOA-DOC")
    2525(require "COCOA-LISTENER")
     26(require "COCOA-GREP")
    2627(require "COCOA-BACKTRACE")
    2728(require "COCOA-INSPECTOR")
  • branches/ia32/cocoa-ide/hemlock/src/bindings.lisp

    r6794 r7244  
    4141
    4242(bind-key "Beginning of Line" #k"control-a")
     43(bind-key "Select to Beginning of Line" #k"control-A")
    4344(bind-key "Delete Next Character" #k"control-d")
    4445(bind-key "End of Line" #k"control-e")
     46(bind-key "Select to End of Line" #k"control-E")
    4547(bind-key "Forward Character" #k"control-f")
    4648(bind-key "Forward Character" #k"rightarrow")
     49(bind-key "Select Forward Character" #k"control-F")
     50(bind-key "Select Forward Character" #k"shift-rightarrow")
    4751(bind-key "Backward Character" #k"control-b")
    4852(bind-key "Backward Character" #k"leftarrow")
     53(bind-key "Select Backward Character" #k"control-B")
     54(bind-key "Select Backward Character" #k"shift-leftarrow")
    4955(bind-key "Kill Line" #k"control-k")
    5056(bind-key "Refresh Screen" #k"control-l")
    5157(bind-key "Next Line" #k"control-n")
    5258(bind-key "Next Line" #k"downarrow")
     59(bind-key "Select Next Line" #k"control-N")
     60(bind-key "Select Next Line" #k"shift-downarrow")
    5361(bind-key "Previous Line" #k"control-p")
    5462(bind-key "Previous Line" #k"uparrow")
     63(bind-key "Select Previous Line" #k"control-P")
     64(bind-key "Select Previous Line" #k"shift-uparrow")
    5565(bind-key "Query Replace" #k"meta-%")
    5666(bind-key "Reverse Incremental Search" #k"control-r")
     
    6171(bind-key "Universal Argument" #k"control-u")
    6272(bind-key "Scroll Window Down" #k"control-v")
     73(bind-key "Scroll Window Down" #k"pagedown")
    6374(bind-key "Scroll Window Up" #k"meta-v")
     75(bind-key "Scroll Window Up" #k"pageup")
    6476(bind-key "Scroll Next Window Down" #k"control-meta-v")
    6577(bind-key "Scroll Next Window Up" #k"control-meta-V")
    6678
     79(bind-key "Do Nothing" #k"leftdown")
     80
     81
    6782(bind-key "Process File Options" #k"control-x m" :global)
    6883(bind-key "Ensure File Options Line" #k"control-meta-M" :global)
    69 (bind-key "Help" #k"home")
     84(bind-key "Beginning of Buffer" #k"home")
     85(bind-key "End of Buffer" #k"end")
    7086(bind-key "Undo" #k"control-_")
    7187(bind-key "Describe Key" #k"meta-?")
     
    138154
    139155(bind-key "Forward Word" #k"meta-f")
     156(bind-key "Select Forward Word" #k"meta-F")
    140157(bind-key "Backward Word" #k"meta-b")
     158(bind-key "Select Backward Word" #k"meta-B")
    141159
    142160(bind-key "Forward Paragraph" #k"meta-]")
     
    360378(bind-key "Arglist On Space" #k"Space" :mode "Lisp")
    361379(bind-key "Defindent" #k"control-meta-#")
    362 (bind-key "Beginning of Defun" #k"control-meta-[")
    363 (bind-key "End of Defun" #k"control-meta-]")
    364380(bind-key "Beginning of Defun" #k"control-meta-a")
     381(bind-key "Select to Beginning of Defun" #k"control-meta-A")
    365382(bind-key "End of Defun" #k"control-meta-e")
     383(bind-key "Select to End of Defun" #k"control-meta-E")
    366384(bind-key "Forward Form" #k"control-meta-f")
     385(bind-key "Select Forward Form" #k"control-meta-F")
    367386(bind-key "Backward Form" #k"control-meta-b")
     387(bind-key "Select Backward Form" #k"control-meta-B")
    368388(bind-key "Forward List" #k"control-meta-n")
     389(bind-key "Select Forward List" #k"control-meta-N")
    369390(bind-key "Backward List" #k"control-meta-p")
     391(bind-key "Select Backward List" #k"control-meta-P")
    370392(bind-key "Transpose Forms" #k"control-meta-t")
    371393(bind-key "Forward Kill Form" #k"control-meta-k")
     
    921943(setf (logical-key-event-p #k"control-g" :abort) t)
    922944(setf (logical-key-event-p #k"escape" :exit) t)
     945(setf (logical-key-event-p #k"leftdown" :mouse-exit) t)
    923946(setf (logical-key-event-p #k"y" :yes) t)
    924947(setf (logical-key-event-p #k"space" :yes) t)
  • branches/ia32/cocoa-ide/hemlock/src/buffer.lisp

    r6695 r7244  
    325325  (buffer-point *current-buffer*))
    326326
     327
     328
     329(defun current-point-collapsing-selection ()
     330  "Return the Buffer-Point of the current buffer, deactivating the
     331   region."
     332  (let* ((b *current-buffer*)
     333         (point (buffer-point b)))
     334    ;; Deactivate the region
     335    (setf (buffer-region-active b) nil)
     336    point))
     337
     338(defun current-point-extending-selection ()
     339  "Return the Buffer-Point of the current buffer, deactivating the
     340   region."
     341  (let* ((b *current-buffer*)
     342         (point (buffer-point b)))
     343    ;; If the region is active, keep it active.  Otherwise,
     344    ;; establish a new (empty) region at point.
     345    (unless (%buffer-current-region-p b)
     346      (push-buffer-mark (copy-mark point) t))
     347    point))
     348
    327349(defun current-point-for-insertion ()
    328350  "Check to see if the current buffer can be modified at its
  • branches/ia32/cocoa-ide/hemlock/src/cocoa-hemlock.lisp

    r6696 r7244  
    4545      t)))
    4646
    47 
     47(defvar *command-key-event-buffer* nil)
    4848
    4949 
     
    8383  `(member (event-queue-node-event ,key-event) editor-abort-key-events))
    8484
    85 
     85(defconstant +shift-event-mask+ (hemlock-ext::key-event-modifier-mask "Shift"))
     86   
    8687(defun get-key-event (q &optional ignore-pending-aborts)
    8788  (do* ((e (dequeue-key-event q) (dequeue-key-event q)))
     
    99100        (funcall (buffer-operation-thunk e))))))
    100101
     102(defun recursive-get-key-event (q &optional ignore-pending-aborts)
     103  (let* ((buffer *command-key-event-buffer*)
     104         (doc (when buffer (buffer-document buffer))))
     105    (if (null doc)
     106      (get-key-event q ignore-pending-aborts)
     107      (unwind-protect
     108           (progn
     109             (document-end-editing doc)
     110             (get-key-event q ignore-pending-aborts))
     111        (document-begin-editing doc)))))
     112
     113
    101114(defun listen-editor-input (q)
    102115  (ccl::with-locked-dll-header (q)
     
    195208      (editor-error)
    196209      (hi::edit-definition fun-name))))
     210
     211;;; Search highlighting
     212(defun note-selection-set-by-search (&optional (buffer (current-buffer)))
     213  (let* ((doc (buffer-document buffer)))
     214    (when doc (hi::document-note-selection-set-by-search doc))))
  • branches/ia32/cocoa-ide/hemlock/src/command.lisp

    r6697 r7244  
    5858
    5959(defcommand "Forward Character" (p)
    60   "Move the point forward one character.
     60  "Move the point forward one character, collapsing the selection.
    6161   With prefix argument move that many characters, with negative argument
    6262   go backwards."
    63   "Move the point of the current buffer forward p characters."
    64   (let ((p (or p 1)))
    65     (cond ((character-offset (current-point) p))
     63  "Move the point of the current buffer forward p characters, collapsing the selection."
     64  (let* ((p (or p 1))
     65         (point (current-point-collapsing-selection)))
     66    (cond ((character-offset point p))
    6667          ((= p 1)
    6768           (editor-error "No next character."))
     
    7071          (t
    7172           (if (plusp p)
    72                (buffer-end (current-point))
    73                (buffer-start (current-point)))
     73               (buffer-end point)
     74               (buffer-start point))
    7475           (editor-error "Not enough characters.")))))
    7576
     77(defcommand "Select Forward Character" (p)
     78  "Move the point forward one character, extending the selection.
     79   With prefix argument move that many characters, with negative argument
     80   go backwards."
     81  "Move the point of the current buffer forward p characters, extending the selection."
     82  (let* ((p (or p 1))
     83         (point (current-point-extending-selection)))
     84    (cond ((character-offset point p))
     85          ((= p 1)
     86           (editor-error "No next character."))
     87          ((= p -1)
     88           (editor-error "No previous character."))
     89          (t
     90           (if (plusp p)
     91               (buffer-end point)
     92               (buffer-start point))
     93           (editor-error "Not enough characters.")))))
     94
    7695(defcommand "Backward Character" (p)
    77   "Move the point backward one character.
     96  "Move the point backward one character, collapsing the selection.
    7897  With prefix argument move that many characters backward."
    79   "Move the point p characters backward."
     98  "Move the point p characters backward, collapsing the selection."
    8099  (forward-character-command (if p (- p) -1)))
     100
     101(defcommand "Select Backward Character" (p)
     102  "Move the point backward one character, extending the selection.
     103  With prefix argument move that many characters backward."
     104  "Move the point p characters backward, extending the selection."
     105  (select-forward-character-command (if p (- p) -1)))
    81106
    82107#|
     
    105130  "Deletes p characters to the right of the point."
    106131  (let* ((point (current-point-for-deletion)))
    107     (cond ((kill-characters point (or p 1)))
    108           ((and p (minusp p))
    109            (editor-error "Not enough previous characters."))
    110           (t
    111            (editor-error "Not enough next characters.")))))
     132    (when point
     133      (cond ((kill-characters point (or p 1)))
     134            ((and p (minusp p))
     135             (editor-error "Not enough previous characters."))
     136            (t
     137             (editor-error "Not enough next characters."))))))
    112138
    113139(defcommand "Delete Previous Character" (p)
     
    166192
    167193(defcommand "Forward Word" (p)
    168   "Moves forward one word.
     194  "Moves forward one word, collapsing the selection.
    169195  With prefix argument, moves the point forward over that many words."
    170   "Moves the point forward p words."
    171   (cond ((word-offset (current-point) (or p 1)))
    172         ((and p (minusp p))
    173          (buffer-start (current-point))
    174          (editor-error "No previous word."))
    175         (t
    176          (buffer-end (current-point))
    177          (editor-error "No next word."))))
     196  "Moves the point forward p words, collapsing the selection."
     197  (let* ((point (current-point-collapsing-selection)))
     198    (cond ((word-offset point (or p 1)))
     199          ((and p (minusp p))
     200           (buffer-start point)
     201           (editor-error "No previous word."))
     202          (t
     203           (buffer-end point)
     204           (editor-error "No next word.")))))
     205
     206(defcommand "Select Forward Word" (p)
     207  "Moves forward one word, extending the selection.
     208  With prefix argument, moves the point forward over that many words."
     209  "Moves the point forward p words, extending the selection."
     210  (let* ((point (current-point-extending-selection)))
     211    (cond ((word-offset point (or p 1)))
     212          ((and p (minusp p))
     213           (buffer-start point)
     214           (editor-error "No previous word."))
     215          (t
     216           (buffer-end point)
     217           (editor-error "No next word.")))))
    178218
    179219(defcommand "Backward Word" (p)
     
    183223  (forward-word-command (- (or p 1))))
    184224
     225(defcommand "Select Backward Word" (p)
     226  "Moves forward backward word, extending the selection.
     227  With prefix argument, moves the point back over that many words."
     228  "Moves the point backward p words, extending the selection."
     229  (select-forward-word-command (- (or p 1))))
     230
    185231
    186232
     
    202248
    203249(defcommand "Next Line" (p)
    204   "Moves the point to the next line.
     250  "Moves the point to the next line, collapsing the selection.
    205251   With prefix argument, moves the point that many lines down (or up if
    206252   the prefix is negative)."
    207   "Moves the down p lines."
    208   (let* ((point (current-point))
     253  "Moves the down p lines, collapsing the selection."
     254  (let* ((point (current-point-collapsing-selection))
    209255         (target (set-target-column point)))
    210256    (unless (line-offset point (or p 1))
     
    223269    (setf (last-command-type) :line-motion)))
    224270
     271(defcommand "Select Next Line" (p)
     272  "Moves the point to the next line, extending the selection.
     273   With prefix argument, moves the point that many lines down (or up if
     274   the prefix is negative)."
     275  "Moves the down p lines, extendin the selection."
     276  (let* ((point (current-point-extending-selection))
     277         (target (set-target-column point)))
     278    (unless (line-offset point (or p 1))
     279      (when (value next-line-inserts-newlines)
     280        (cond ((not p)
     281               (when (same-line-p point (buffer-end-mark (current-buffer)))
     282                 (line-end point))
     283               (insert-character point #\newline))
     284              ((minusp p)
     285               (buffer-start point)
     286               (editor-error "No previous line."))
     287              (t
     288               (buffer-end point)
     289               (when p (editor-error "No next line."))))))
     290    (unless (move-to-column point target) (line-end point))
     291    (setf (last-command-type) :line-motion)))
     292
    225293
    226294(defcommand "Previous Line" (p)
    227   "Moves the point to the previous line.
     295  "Moves the point to the previous line, collapsing the selection.
    228296  With prefix argument, moves the point that many lines up (or down if
    229297  the prefix is negative)."
    230   "Moves the point up p lines."
     298  "Moves the point up p lines, collapsing the selection."
    231299  (next-line-command (- (or p 1))))
     300
     301(defcommand "Select Previous Line" (p)
     302  "Moves the point to the previous line, collapsing the selection.
     303  With prefix argument, moves the point that many lines up (or down if
     304  the prefix is negative)."
     305  "Moves the point up p lines, collapsing the selection."
     306  (select-next-line-command (- (or p 1))))
    232307
    233308(defcommand "Mark to End of Buffer" (p)
     
    244319
    245320(defcommand "Beginning of Buffer" (p)
    246   "Moves the point to the beginning of the current buffer."
    247   "Moves the point to the beginning of the current buffer."
    248   (declare (ignore p))
    249   (let ((point (current-point)))
     321  "Moves the point to the beginning of the current buffer, collapsing the selection."
     322  "Moves the point to the beginning of the current buffer, collapsing the selection."
     323  (declare (ignore p))
     324  (let ((point (current-point-collapsing-selection)))
    250325    (push-buffer-mark (copy-mark point))
    251326    (buffer-start point)))
     
    255330  "Moves the point to the end of the current buffer."
    256331  (declare (ignore p))
    257   (let ((point (current-point)))
     332  (let ((point (current-point-collapsing-selection)))
    258333    (push-buffer-mark (copy-mark point))
    259334    (buffer-end point)))
    260335
    261336(defcommand "Beginning of Line" (p)
    262   "Moves the point to the beginning of the current line.
     337  "Moves the point to the beginning of the current line, collapsing the selection.
    263338  With prefix argument, moves the point to the beginning of the prefix'th
    264339  next line."
    265   "Moves the point down p lines and then to the beginning of the line."
    266   (let ((point (current-point)))
     340  "Moves the point down p lines and then to the beginning of the line, collapsing the selection."
     341  (let ((point (current-point-collapsing-selection)))
    267342    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
    268343    (line-start point)))
    269344
     345(defcommand "Select to Beginning of Line" (p)
     346  "Moves the point to the beginning of the current line, extending the selection.
     347  With prefix argument, moves the point to the beginning of the prefix'th
     348  next line."
     349  "Moves the point down p lines and then to the beginning of the line, extending the selection."
     350  (let ((point (current-point-extending-selection)))
     351    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
     352    (line-start point)))
     353
    270354(defcommand "End of Line" (p)
    271   "Moves the point to the end of the current line.
     355  "Moves the point to the end of the current line, collapsing the selection.
    272356  With prefix argument, moves the point to the end of the prefix'th next line."
    273   "Moves the point down p lines and then to the end of the line."
    274   (let ((point (current-point)))
     357  "Moves the point down p lines and then to the end of the line, collapsing the selection."
     358  (let ((point (current-point-collapsing-selection)))
     359    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
     360    (line-end point)))
     361
     362(defcommand "Select to End of Line" (p)
     363  "Moves the point to the end of the current line, extending the selection.
     364  With prefix argument, moves the point to the end of the prefix'th next line."
     365  "Moves the point down p lines and then to the end of the line, extending the selection."
     366  (let ((point (current-point-extending-selection)))
    275367    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
    276368    (line-end point)))
     
    297389  window, down one screenfull.  If P is supplied then scroll that
    298390  many lines."
    299   (scroll-window window (or p 1)))
     391  (scroll-window window (or p :page-down)))
    300392
    301393(defcommand "Scroll Window Up" (p &optional (window (current-window)))
     
    305397  window, up one screenfull.  If P is supplied then scroll that
    306398  many lines."
    307   (scroll-window window (or p -1)))
     399  (scroll-window window (if p (- p) :page-up)))
    308400
    309401(defcommand "Scroll Next Window Down" (p)
     
    321413    (scroll-window-up-command p win)))
    322414
    323 (defcommand "Top of Window" (p)
    324   "Move the point to the top of the current window.
    325   The point is left before the first character displayed in the window."
    326   "Move the point to the top of the current window."
    327   (declare (ignore p))
    328   (move-mark (current-point) (window-display-start (current-window))))
    329 
    330 (defcommand "Bottom of Window" (p)
    331   "Move the point to the bottom of the current window.
    332   The point is left at the start of the bottom line."
    333   "Move the point to the bottom of the current window."
    334   (declare (ignore p))
    335   (line-start (current-point)
    336               (mark-line (window-display-end (current-window)))))
     415
    337416
    338417
  • branches/ia32/cocoa-ide/hemlock/src/doccoms.lisp

    r6790 r7244  
    264264                        :help "Name of variable to describe."
    265265                        :prompt "Variable: ")
    266     (with-pop-up-display (s :title (format nil "~S Variable documentation"))
     266    (with-pop-up-display (s :title (format nil "~S Variable documentation" name))
    267267      (show-variable s name var))))
    268268
     
    347347  "Display the last 60 characters typed."
    348348  (declare (ignore p))
    349   (with-pop-up-display (s :title (format nil "The last ~d characters typed") :height 7)
     349  (with-pop-up-display (s :title (format nil "The last characters typed") :height 7)
    350350    (let ((num (ring-length *key-event-history*)))
    351351      (format s "The last ~D characters typed:~%" num)
  • branches/ia32/cocoa-ide/hemlock/src/echo.lisp

    r6790 r7244  
    114114(defun clear-echo-area ()
    115115  "You guessed it."
    116   ;(maybe-wait)
    117   (let* ((b (current-buffer))
    118          (doc (buffer-document *echo-area-buffer*)))
     116  ;;(maybe-wait)
     117  (let* ((b (current-buffer)))
    119118    (unwind-protect
    120119         (progn
     
    123122            (delete-region *echo-area-region*))
    124123           (setf (buffer-modified *echo-area-buffer*) nil))
    125       (when doc
    126         (document-set-point-position doc))
    127124      (setf (current-buffer) b))))
    128125
     
    498495                                            (if defaultp (if default "Y" "N"))))
    499496          (loop
    500             (let ((key-event (get-key-event *editor-input*)))
     497            (let ((key-event (recursive-get-key-event *editor-input*)))
    501498              (cond ((or (eq key-event #k"y")
    502499                         (eq key-event #k"Y"))
     
    532529            (setf (current-window) *echo-area-window*))
    533530          (display-prompt-nicely prompt)
    534           (get-key-event *editor-input* t))
     531          (recursive-get-key-event *editor-input* t))
    535532      (when change-window (setf (current-window) old-window)))))
    536533
     
    554551                (declare (vector key))
    555552                TOP
    556                 (setf key-event (get-key-event *editor-input*))
     553                (setf key-event (recursive-get-key-event *editor-input*))
    557554                (cond ((logical-key-event-p key-event :quote)
    558                        (setf key-event (get-key-event *editor-input* t)))
     555                       (setf key-event (recursive-get-key-event *editor-input* t)))
    559556                      ((logical-key-event-p key-event :confirm)
    560557                       (cond ((and default (zerop (length key)))
     
    720717(define-logical-key-event "Keep"
    721718  "This key-event means exit but keep something around.")
    722 
     719(define-logical-key-event "Mouse Exit"
     720  "This key-event means exit completely.")
    723721
    724722
  • branches/ia32/cocoa-ide/hemlock/src/edit-defs.lisp

    r6700 r7244  
    3131(declaim (simple-string *last-go-to-def-string*))
    3232 
    33 
    34 
    35 
    36 
    37 
    38 
    39 (defcommand "Goto Definition" (p)
    40   "Go to the current function/macro's definition."
    41   "Go to the current function/macro's definition."
    42   (declare (ignore p))
    43   (let* ((point (current-point))
    44          (buffer (current-buffer)))
    45     (pre-command-parse-check point)
    46     (when (valid-spot point t)
    47       (with-mark ((mark1 point)
    48                   (mark2 point))
    49         (if (hi::%buffer-current-region-p buffer)
    50           (let* ((mark (hi::buffer-%mark buffer)))
    51             (if (mark< mark point)
     33(defun symbol-at-point (buffer point)
     34  "Returns symbol at point, or contents of selection if there is one"
     35  (with-mark ((mark1 point)
     36              (mark2 point))
     37    (if (hi::%buffer-current-region-p buffer)
     38        (let* ((mark (hi::buffer-%mark buffer)))
     39          (if (mark< mark point)
    5240              (move-mark mark1 mark)
    5341              (move-mark mark2 mark)))
    54           (progn
    55             (form-offset mark1 -1)
    56             (form-offset (move-mark mark2 mark1) 1)))
    57         (unless (mark= mark1 mark2)
    58           (let ((fun-name (region-to-string (region mark1 mark2))))
    59             (get-def-info-and-go-to-it fun-name (or
    60                                                  (find-package
    61                                                   (variable-value 'current-package :buffer (current-buffer)))
    62                                                  *package*))))))))
     42        ;; This doesn't handle embedded #'s or escaped chars in names.
     43        ;; So let them report it as a bug...
     44        (progn
     45          (when (test-char (previous-character point) :lisp-syntax :constituent)
     46            (or (rev-scan-char mark1 :lisp-syntax (not :constituent))
     47                (buffer-start mark1))
     48            (scan-char mark1 :lisp-syntax :constituent))
     49          (when (test-char (next-character point) :lisp-syntax :constituent)
     50            (or (scan-char mark2 :lisp-syntax (not :constituent))
     51                (buffer-end mark2)))
     52          (when (mark= mark1 mark2)
     53            ;; Try to get whole form
     54            (pre-command-parse-check point)
     55            (when (valid-spot point t)
     56              (move-mark mark1 point)
     57              (form-offset mark1 -1)
     58              (move-mark mark2 mark1)
     59              (form-offset mark2 1)))))
     60    (unless (mark= mark1 mark2)
     61      (region-to-string (region mark1 mark2)))))
     62
     63(defcommand "Goto Definition" (p)
     64  "Go to the current function/macro's definition.  With a numarg, prompts for name to go to."
     65  "Go to the current function/macro's definition."
     66  (if p
     67      (edit-definition-command nil)
     68      (let* ((point (current-point))
     69             (buffer (current-buffer))
     70             (fun-name (symbol-at-point buffer point)))
     71        (if fun-name
     72            (get-def-info-and-go-to-it fun-name (or
     73                                                 (find-package
     74                                                  (variable-value 'current-package :buffer (current-buffer)))
     75                                                 *package*))
     76            (beep)))))
    6377
    6478(defcommand "Edit Definition" (p)
  • branches/ia32/cocoa-ide/hemlock/src/filecoms.lisp

    r6790 r7244  
    349349   current buffer. Without, reverts to the last checkpoint or last saved
    350350   version, whichever is more recent."
    351   (let* ((buffer (current-buffer))
    352          (buffer-pn (buffer-pathname buffer))
    353          (point (current-point))
    354          (lines (1- (count-lines (region (buffer-start-mark buffer) point)))))
    355     (multiple-value-bind (revert-pn used-checkpoint)
    356                          (if p buffer-pn (revert-pathname buffer))
    357       (unless revert-pn
    358         (editor-error "No file associated with buffer to revert to!"))
    359       (when (or (not (value revert-file-confirm))
    360                 (not (buffer-modified buffer))
    361                 (prompt-for-y-or-n
    362                  :prompt
    363                  "Buffer contains changes, are you sure you want to revert? "
    364                  :help (list
    365  "Reverting the file will undo any changes by reading in the last ~
    366  ~:[saved version~;checkpoint file~]." used-checkpoint)
    367                  :default t))
    368         (read-buffer-file revert-pn buffer)
    369         (when used-checkpoint
    370           (setf (buffer-modified buffer) t)
    371           (setf (buffer-pathname buffer) buffer-pn)
    372           (message "Reverted to checkpoint file ~A." (namestring revert-pn)))
    373         (unless (line-offset point lines)
    374           (buffer-end point))))))
     351  (declare (ignore p))
     352  (let* ((doc (hi::buffer-document (current-buffer))))
     353    (when doc
     354      (hi::revert-document doc)))
     355  (clear-echo-area))
    375356
    376357;;; REVERT-PATHNAME -- Internal
  • branches/ia32/cocoa-ide/hemlock/src/htext4.lisp

    r6701 r7244  
    341341   newlines."
    342342  (let* ((start (region-start region))
     343         (count (hemlock::count-characters region))
     344         (origin (copy-mark start :right-inserting))
    343345         (start-line (mark-line start))
    344346         (first (mark-charpos start))
     
    436438                        (setf (mark-line m) start-line)
    437439                        (push m (line-marks start-line)))))))))
     440    (hi::buffer-note-modification buffer origin count)
     441    (delete-mark origin)
    438442    region))
  • branches/ia32/cocoa-ide/hemlock/src/indent.lisp

    r6 r7244  
    9090    (with-mark ((mark point :left-inserting))
    9191      (cond ((or (not p) (zerop p))
    92              (funcall (value indent-function) mark))
     92             (funcall (value indent-function) mark)
     93             (move-mark point mark))
    9394            (t
    9495             (if (plusp p)
  • branches/ia32/cocoa-ide/hemlock/src/interp.lisp

    r6771 r7244  
    482482                          (let ((punt t))
    483483                            (catch 'command-loop-catcher
    484                               (let* ((doc (buffer-document *current-buffer*)))
     484                              (let* ((buffer *current-buffer*)
     485                                     (*command-key-event-buffer* buffer)
     486                                     (doc (buffer-document buffer)))
    485487                                (unwind-protect
    486488                                     (progn
    487                                        (when doc (hi::document-begin-editing doc))
     489                                       (when doc
     490                                         (hi::document-begin-editing doc))
    488491                                       (dolist (c t-bindings)
    489492                                         (funcall *invoke-hook* c *prefix-argument*))
    490493                                       (funcall *invoke-hook* res *prefix-argument*)
    491494                                       (setf punt nil))
    492                                   (when doc (hi::document-end-editing doc)))))
     495                                  (when doc
     496                                    (hi::document-end-editing doc)))))
    493497                            (when punt (invoke-hook hemlock::command-abort-hook)))
    494498                          (if *command-type-set*
  • branches/ia32/cocoa-ide/hemlock/src/key-event.lisp

    r6703 r7244  
    111111
    112112
    113 
     113(defvar *mouse-translation-info*)
     114
     115;;; MOUSE-TRANSLATION-INFO -- Internal.
     116;;;
     117;;; This returns the requested information, :keysym or :shifted-modifier-name,
     118;;; for the button cross event-key.  If the information is undefined, this
     119;;; signals an error.
     120;;;
     121(defun mouse-translation-info (button event-key info)
     122  (let ((event-dispatch (svref *mouse-translation-info* button)))
     123    (unless event-dispatch
     124      (error "No defined mouse translation information for button ~S." button))
     125    (let ((data (ecase event-key
     126                  (:button-press (button-press-info event-dispatch))
     127                  (:button-release (button-release-info event-dispatch)))))
     128      (unless data
     129        (error
     130         "No defined mouse translation information for button ~S and event ~S."
     131         button event-key))
     132      (ecase info
     133        (:keysym (button-keysym data))
     134        (:shifted-modifier-name (button-shifted-modifier-name data))))))
     135
     136
     137(eval-when (:compile-toplevel :execute)
     138  (defmacro button-press-info (event-dispatch) `(car ,event-dispatch))
     139  (defmacro button-release-info (event-dispatch) `(cdr ,event-dispatch))
     140  (defmacro button-keysym (info) `(car ,info))
     141  (defmacro button-shifted-modifier-name (info) `(cdr ,info))
     142)
     143
     144;;; MOUSE-TRANSLATION-INFO -- Internal.
     145;;;
     146;;; This returns the requested information, :keysym or :shifted-modifier-name,
     147;;; for the button cross event-key.  If the information is undefined, this
     148;;; signals an error.
     149;;;
     150(defun mouse-translation-info (button event-key info)
     151  (let ((event-dispatch (svref *mouse-translation-info* button)))
     152    (unless event-dispatch
     153      (error "No defined mouse translation information for button ~S." button))
     154    (let ((data (ecase event-key
     155                  (:button-press (button-press-info event-dispatch))
     156                  (:button-release (button-release-info event-dispatch)))))
     157      (unless data
     158        (error
     159         "No defined mouse translation information for button ~S and event ~S."
     160         button event-key))
     161      (ecase info
     162        (:keysym (button-keysym data))
     163        (:shifted-modifier-name (button-shifted-modifier-name data))))))
     164
     165;;; (setf MOUSE-TRANSLATION-INFO) -- Internal.
     166;;;
     167;;; This walks into *mouse-translation-info* the same way MOUSE-TRANSLATION-INFO
     168;;; does, filling in the data structure on an as-needed basis, and stores
     169;;; the value for the indicated info.
     170;;;
     171(defun (setf mouse-translation-info) (value button event-key info)
     172  (let ((event-dispatch (svref *mouse-translation-info* button)))
     173    (unless event-dispatch
     174      (setf event-dispatch
     175            (setf (svref *mouse-translation-info* button) (cons nil nil))))
     176    (let ((data (ecase event-key
     177                  (:button-press (button-press-info event-dispatch))
     178                  (:button-release (button-release-info event-dispatch)))))
     179      (unless data
     180        (setf data
     181              (ecase event-key
     182                (:button-press
     183                 (setf (button-press-info event-dispatch) (cons nil nil)))
     184                (:button-release
     185                 (setf (button-release-info event-dispatch) (cons nil nil))))))
     186      (ecase info
     187        (:keysym
     188         (setf (button-keysym data) value))
     189        (:shifted-modifier-name
     190         (setf (button-shifted-modifier-name data) value))))))
     191
     192
     193
     194;;; DEFINE-MOUSE-KEYSYM -- Public.
     195;;;
     196(defun define-mouse-keysym (button keysym name shifted-bit event-key)
     197  "This defines keysym named name for the X button cross the X event-key.
     198   Shifted-bit is a defined modifier name that TRANSLATE-MOUSE-KEY-EVENT sets
     199   in the key-event it returns whenever the X shift bit is on."
     200  (unless (<= 1 button 5)
     201    (error "Buttons are number 1-5, not ~D." button))
     202  (setf (gethash keysym *keysyms-to-names*) (list name))
     203  (setf (gethash  (get-name-case-right name) *names-to-keysyms*) keysym)
     204  (setf (mouse-translation-info button event-key :keysym) keysym)
     205  (setf (mouse-translation-info button event-key :shifted-modifier-name)
     206        shifted-bit))
    114207
    115208
     
    387480;;;
    388481(defun get-key-event* (keysym bits)
     482  (let* ((char (code-char keysym)))
     483    (when (and char (standard-char-p char))
     484      (let* ((mask (key-event-modifier-mask "Shift")))
     485        (when (logtest bits mask)
     486          (setq bits (logandc2 bits mask)
     487                keysym (char-code (char-upcase char)))))))
    389488  (let* ((high-byte (ash keysym -8))
    390489         (low-byte-vector (svref *keysym-high-bytes* high-byte)))
     
    579678  (setf *modifier-translations* ())
    580679  (setf *modifiers-to-internal-masks* ())
     680  (setf *mouse-translation-info* (make-array 6 :initial-element nil))
    581681  (setf *modifier-count* 0)
    582682  (setf *all-modifier-names* ())
  • branches/ia32/cocoa-ide/hemlock/src/keysym-defs.lisp

    r6659 r7244  
    155155(hemlock-ext:define-keysym 47 "/") (hemlock-ext:define-keysym 63 "?")
    156156
     157
     158(hemlock-ext::define-mouse-keysym 1 #xe000 "Leftdown" "Super" :button-press)
     159
    157160;;;
    158161
  • branches/ia32/cocoa-ide/hemlock/src/lispmode.lisp

    r6850 r7244  
    12061206               (nil)
    12071207             (line-start bol line)
    1208              (insert-lisp-indentation bol)
     1208             (ensure-lisp-indentation bol)
    12091209             (let ((line-info (getf (line-plist line) 'lisp-info)))
    12101210               (parse-lisp-line-info bol line-info prev-line-info)
     
    12201220  (line-start mark)
    12211221  (pre-command-parse-check mark)
    1222   (insert-lisp-indentation mark))
    1223 
    1224 (defun insert-lisp-indentation (m)
    1225   (delete-horizontal-space m)
    1226   (funcall (value indent-with-tabs) m (lisp-indentation m)))
     1222  (ensure-lisp-indentation mark))
     1223
     1224(defun count-leading-whitespace (mark)
     1225  (with-mark ((m mark))
     1226    (line-start m)
     1227    (do* ((p 0)
     1228          (q 0 (1+ q))
     1229          (tab-width (value spaces-per-tab)))
     1230         ()
     1231      (case (next-character m)
     1232        (#\space (incf p))
     1233        (#\tab (setq p (* tab-width (ceiling (1+ p) tab-width))))
     1234        (t (return (values p q))))
     1235      (character-offset m 1))))
     1236
     1237;;; Don't do anything if M's line is already correctly indented.
     1238(defun ensure-lisp-indentation (m)
     1239  (let* ((col (lisp-indentation m)))
     1240    (multiple-value-bind (curcol curpos) (count-leading-whitespace m)
     1241      (cond ((= curcol col) (setf (mark-charpos m) curpos))
     1242            (t
     1243             (delete-horizontal-space m)
     1244             (funcall (value indent-with-tabs) m col))))))
     1245
    12271246
    12281247
     
    12321251
    12331252(defcommand "Beginning of Defun" (p)
    1234   "Move the point to the beginning of a top-level form.
     1253  "Move the point to the beginning of a top-level form, collapsing the selection.
    12351254  with an argument, skips the previous p top-level forms."
    1236   "Move the point to the beginning of a top-level form."
    1237   (let ((point (current-point))
     1255  "Move the point to the beginning of a top-level form, collapsing the selection."
     1256  (let ((point (current-point-collapsing-selection))
     1257        (count (or p 1)))
     1258    (pre-command-parse-check point)
     1259    (if (minusp count)
     1260        (end-of-defun-command (- count))
     1261        (unless (top-level-offset point (- count))
     1262          (editor-error)))))
     1263
     1264(defcommand "Select to Beginning of Defun" (p)
     1265  "Move the point to the beginning of a top-level form, extending the selection.
     1266  with an argument, skips the previous p top-level forms."
     1267  "Move the point to the beginning of a top-level form, extending the selection."
     1268  (let ((point (current-point-extending-selection))
    12381269        (count (or p 1)))
    12391270    (pre-command-parse-check point)
     
    12521283;;;
    12531284(defcommand "End of Defun" (p)
    1254   "Move the point to the end of a top-level form.
     1285  "Move the point to the end of a top-level form, collapsing the selection.
    12551286   With an argument, skips the next p top-level forms."
    1256   "Move the point to the end of a top-level form."
    1257   (let ((point (current-point))
     1287  "Move the point to the end of a top-level form, collapsing the selection."
     1288  (let ((point (current-point-collapsing-selection))
    12581289        (count (or p 1)))
    12591290    (pre-command-parse-check point)
     
    12741305                 (move-mark point m)))))))
    12751306
     1307(defcommand "Select to End of Defun" (p)
     1308  "Move the point to the end of a top-level form, extending the selection.
     1309   With an argument, skips the next p top-level forms."
     1310  "Move the point to the end of a top-level form, extending the selection."
     1311  (let ((point (current-point-extending-selection))
     1312        (count (or p 1)))
     1313    (pre-command-parse-check point)
     1314    (if (minusp count)
     1315        (beginning-of-defun-command (- count))
     1316        (with-mark ((m point)
     1317                    (dummy point))
     1318          (cond ((not (mark-top-level-form m dummy))
     1319                 (editor-error "No current or next top level form."))
     1320                (t
     1321                 (unless (top-level-offset m (1- count))
     1322                   (editor-error "Not enough top level forms."))
     1323                 ;; We might be one unparsed for away.
     1324                 (pre-command-parse-check m)
     1325                 (unless (form-offset m 1)
     1326                   (editor-error "Not enough top level forms."))
     1327                 (when (blank-after-p m) (line-offset m 1 0))
     1328                 (move-mark point m)))))))
     1329
    12761330(defcommand "Forward List" (p)
    1277   "Skip over the next Lisp list.
     1331  "Skip over the next Lisp list, collapsing the selection.
    12781332  With argument, skips the next p lists."
    1279   "Skip over the next Lisp list."
    1280   (let ((point (current-point))
     1333  "Skip over the next Lisp list, collapsing the selection."
     1334  (let ((point (current-point-collapsing-selection))
    12811335        (count (or p 1)))
    12821336    (pre-command-parse-check point)
    12831337    (unless (list-offset point count) (editor-error))))
    12841338
     1339(defcommand "Select Forward List" (p)
     1340  "Skip over the next Lisp list, extending the selection.
     1341  With argument, skips the next p lists."
     1342  "Skip over the next Lisp list, extending the selection."
     1343  (let ((point (current-point-extending-selection))
     1344        (count (or p 1)))
     1345    (pre-command-parse-check point)
     1346    (unless (list-offset point count) (editor-error))))
     1347
    12851348(defcommand "Backward List" (p)
    1286   "Skip over the previous Lisp list.
     1349  "Skip over the previous Lisp list, collapsing the selection.
    12871350  With argument, skips the previous p lists."
    1288   "Skip over the previous Lisp list."
    1289   (let ((point (current-point))
     1351  "Skip over the previous Lisp list, collapsing the selection."
     1352  (let ((point (current-point-collapsing-selection))
    12901353        (count (- (or p 1))))
    12911354    (pre-command-parse-check point)
    12921355    (unless (list-offset point count) (editor-error))))
    12931356
     1357(defcommand "Select Backward List" (p)
     1358  "Skip over the previous Lisp list, extending the selection.
     1359  With argument, skips the previous p lists."
     1360  "Skip over the previous Lisp list, extending the selection."
     1361  (let ((point (current-point-extending-selection))
     1362        (count (- (or p 1))))
     1363    (pre-command-parse-check point)
     1364    (unless (list-offset point count) (editor-error))))
     1365
    12941366(defcommand "Forward Form" (p)
    1295   "Skip over the next Form.
     1367  "Skip over the next Form, collapsing the selection.
    12961368  With argument, skips the next p Forms."
    1297   "Skip over the next Form."
    1298   (let ((point (current-point))
     1369  "Skip over the next Form, collapsing the selection."
     1370  (let ((point (current-point-collapsing-selection))
    12991371        (count (or p 1)))
    13001372    (pre-command-parse-check point)
    13011373    (unless (form-offset point count) (editor-error))))
    13021374
     1375(defcommand "Select Forward Form" (p)
     1376  "Skip over the next Form, extending the selection.
     1377  With argument, skips the next p Forms."
     1378  "Skip over the next Form, extending the selection."
     1379  (let ((point (current-point-extending-selection))
     1380        (count (or p 1)))
     1381    (pre-command-parse-check point)
     1382    (unless (form-offset point count) (editor-error))))
     1383
    13031384(defcommand "Backward Form" (p)
    1304   "Skip over the previous Form.
     1385  "Skip over the previous Form, collapsing the selection.
    13051386  With argument, skips the previous p Forms."
    1306   "Skip over the previous Form."
    1307   (let ((point (current-point))
     1387  "Skip over the previous Form, collaspsing the selection."
     1388  (let ((point (current-point-collapsing-selection))
     1389        (count (- (or p 1))))
     1390    (pre-command-parse-check point)
     1391    (unless (form-offset point count) (editor-error))))
     1392
     1393(defcommand "Select Backward Form" (p)
     1394  "Skip over the previous Form, extending the selection.
     1395  With argument, skips the previous p Forms."
     1396  "Skip over the previous Form, extending the selection."
     1397  (let ((point (current-point-extending-selection))
    13081398        (count (- (or p 1))))
    13091399    (pre-command-parse-check point)
     
    15181608  "Move forward past a one containing )."
    15191609  "Move forward past a one containing )."
    1520   (let ((point (current-point))
     1610  (let ((point (current-point-collapsing-selection))
    15211611        (count (or p 1)))
    15221612    (pre-command-parse-check point)
     
    15311621  "Move backward past a one containing (."
    15321622  "Move backward past a one containing (."
    1533   (let ((point (current-point))
     1623  (let ((point (current-point-collapsing-selection))
    15341624        (count (or p 1)))
    15351625    (pre-command-parse-check point)
     
    15461636   level."
    15471637  "Move down a level in list structure."
    1548   (let ((point (current-point))
     1638  (let ((point (current-point-collapsing-selection))
    15491639        (count (or p 1)))
    15501640    (pre-command-parse-check point)
     
    18371927  :mode "Lisp")
    18381928
    1839 (defun string-to-arglist (string buffer &optional quiet-if-unknown) 
    1840   (let* ((name
    1841           (let* ((*package* (or
    1842                              (find-package
    1843                               (variable-value 'current-package :buffer buffer))
    1844                              *package*)))
    1845             (read-from-string string))))
    1846     (when (typep name 'symbol)
    1847       (multiple-value-bind (arglist win)
    1848           (ccl::arglist-string name)
    1849         (if (or win (not quiet-if-unknown))
    1850           (format nil "~S : ~A" name (if win (or arglist "()") "(unknown)")))))))
     1929(defun string-to-arglist (string buffer &optional quiet-if-unknown)
     1930  (multiple-value-bind (name error)
     1931      (let* ((*package* (or
     1932                         (find-package
     1933                          (variable-value 'current-package :buffer buffer))
     1934                         *package*)))
     1935        (ignore-errors (values (read-from-string string))))
     1936    (unless error
     1937      (when (typep name 'symbol)
     1938        (multiple-value-bind (arglist win)
     1939            (ccl::arglist-string name)
     1940          (if (or win (not quiet-if-unknown))
     1941            (format nil "~S : ~A" name (if win (or arglist "()") "(unknown)"))))))))
    18511942
    18521943(defcommand "Current Function Arglist" (p)
  • branches/ia32/cocoa-ide/hemlock/src/listener.lisp

    r6790 r7244  
    1919  (let ((name (gensym)) (package (gensym)))
    2020    `(handle-lisp-errors
    21       (let* ((,name (value current-package))
     21      (let* ((,name (variable-value 'current-package :buffer (current-buffer)))
    2222             (,package (and ,name (find-package ,name))))
    2323        (progv (if ,package '(*package*)) (if ,package (list ,package))
     
    208208  (let* ((input-mark (value buffer-input-mark))
    209209         (point (current-point-for-deletion)))
    210     (if (and (null (next-character point))
    211              (null (next-character input-mark)))
    212       (listener-document-send-string (hi::buffer-document (current-buffer)) *pop-string*)
    213       (delete-next-character-command p))))
     210    (when point
     211      (if (and (null (next-character point))
     212               (null (next-character input-mark)))
     213          (listener-document-send-string (hi::buffer-document (current-buffer)) *pop-string*)
     214          (delete-next-character-command p)))))
    214215
    215216             
     
    452453(defun eval-region (region
    453454                    &key
    454                     (package (value current-package))
     455                    (package (variable-value 'current-package :buffer (current-buffer)))
    455456                    (path (buffer-pathname (current-buffer))))
    456457  (evaluate-input-selection
  • branches/ia32/cocoa-ide/hemlock/src/morecoms.lisp

    r6790 r7244  
    3333        (editor-error))))
    3434
     35;;; Do nothing, but do it well ...
     36(defcommand "Do Nothing" (p)
     37  "Do nothing."
     38  "Absolutely nothing."
     39  (declare (ignore p)))
    3540
    3641
     
    8792          (character-offset start 1))
    8893        (setf (next-character start) (char-upcase (next-character start)))
     94        (hi::buffer-note-modification (current-buffer) start 1)
    8995        (mark-after start)
    9096        (filter-region #'string-downcase region)))))
  • branches/ia32/cocoa-ide/hemlock/src/package.lisp

    r6662 r7244  
    6262   #:current-point-for-deletion
    6363   #:current-point-unless-selection
     64   #:current-point-collapsing-selection
     65   #:current-point-extending-selection
    6466   #:current-point
    6567   #:current-mark
     
    237239   #:get-key-event
    238240   #:unget-key-event
     241   #:recursive-get-key-event
    239242   #:clear-editor-input
    240243   #:listen-editor-input
  • branches/ia32/cocoa-ide/hemlock/src/searchcoms.lisp

    r6790 r7244  
    5757         (mark (copy-mark point))
    5858         (won (find-pattern point pattern)))
    59     (cond (won (character-offset point won)
    60                (if (region-active-p)
    61                    (delete-mark mark)
    62                    (push-buffer-mark mark)))
     59    (cond (won (move-mark mark point)
     60               (character-offset point won)
     61               (push-buffer-mark mark t)
     62               (hi::note-selection-set-by-search))
    6363          (t (delete-mark mark)
    64              (editor-error)))))
     64             (editor-error)))
     65    (clear-echo-area)))
    6566
    6667(defcommand "Reverse Search" (p &optional string)
    6768  "Do a backward search for a string.
    68   Prompt for the string and leave the point before where it is found."
     69   Prompt for the string and leave the point before where it is found."
    6970  "Searches backwards for the specified String in the current buffer."
    7071  (declare (ignore p))
     
    7778         (mark (copy-mark point))
    7879         (won (find-pattern point pattern)))
    79     (cond (won (if (region-active-p)
    80                    (delete-mark mark)
    81                    (push-buffer-mark mark)))
     80    (cond (won (move-mark mark point)
     81               (character-offset mark won)
     82               (push-buffer-mark mark t)
     83               (hi::note-selection-set-by-search))
    8284          (t (delete-mark mark)
    83              (editor-error)))))
     85             (editor-error)))
     86    (clear-echo-area)))
    8487
    8588
     
    179182(defun %i-search (string point trailer direction failure)
    180183  (do* ((curr-point (copy-mark point :temporary))
    181         (curr-trailer (copy-mark trailer :temporary))
    182         (doc (hi::buffer-document
    183               (hi::line-%buffer (hi::mark-line point)))))
     184        (curr-trailer (copy-mark trailer :temporary)))
    184185       (nil)
    185     (let ((next-key-event
    186            (unwind-protect
    187                 (progn
    188                   (hi::document-end-editing doc)
    189                   (get-key-event *editor-input* t))
    190              (hi::document-begin-editing doc))))
     186    (let ((next-key-event (recursive-get-key-event *editor-input* t)))
    191187      (case (%i-search-char-eval next-key-event string point trailer
    192188                                 direction failure)
     189        (:mouse-exit
     190         (clear-echo-area)
     191         (throw 'exit-i-search nil))
    193192        (:cancel
    194193         (%i-search-echo-refresh string direction failure)
     
    318317                   (move-mark point trailer)
    319318                   (character-offset trailer found-offset)))
     319            (push-buffer-mark (copy-mark trailer) t)
     320            (hi::note-selection-set-by-search)
    320321            (%i-search string point trailer direction nil))
    321322          (t
  • branches/ia32/compiler/PPC/ppc2.lisp

    r6950 r7244  
    764764              (ppc2-bind-var seg var vloc lcell))
    765765            (setq vloc (+ vloc *ppc2-target-node-size*)))))))
    766   (when keys
    767     (apply #'ppc2-init-keys seg vloc lcells keys)
    768     (setq vloc (+ vloc (* 2 *ppc2-target-node-size* nkeys))
    769           lcells (nthcdr (+ nkeys nkeys) lcells)))
    770766  (when rest
    771767    (if lexpr
     
    781777              (ppc2-note-top-cell rest)
    782778              (ppc2-bind-var seg rest loc *ppc2-top-vstack-lcell*)))))
    783       (progn
     779      (let* ((rvloc (+ vloc (* 2 *ppc2-target-node-size* nkeys))))
    784780        (if (setq reg (ppc2-assign-register-var rest))
    785           (ppc2-init-regvar seg rest reg (ppc2-vloc-ea vloc))
    786           (ppc2-bind-var seg rest vloc (pop lcells)))
    787         (setq vloc (+ vloc *ppc2-target-node-size*)))))
     781          (ppc2-init-regvar seg rest reg (ppc2-vloc-ea rvloc))
     782          (ppc2-bind-var seg rest rvloc (pop lcells))))))
     783  (when keys
     784    (apply #'ppc2-init-keys seg vloc lcells keys)) 
    788785  (ppc2-seq-bind seg (%car auxen) (%cadr auxen)))
    789786
  • branches/ia32/compiler/X86/X8664/x8664-backend.lisp

    r7063 r7244  
    542542                    (:signed-doubleword '%%get-signed-longlong)
    543543                    (:unsigned-doubleword '%%get-unsigned-longlong)
    544                     ((:double-float :single-float)
    545                      '%get-double-float)
     544                    (:double-float '%get-double-float)
     545                    (:single-float '%get-single-float)
    546546                    (:unsigned-fullword '%get-unsigned-long)
    547547                    (t '%%get-signed-longlong )
  • branches/ia32/compiler/X86/X8664/x8664-vinsns.lisp

    r7063 r7244  
    15521552
    15531553
    1554 (define-x8664-vinsn start-mv-call (()
    1555                                    ((label :label)))
     1554(define-x8664-vinsn (vpush-label :push :node :vsp) (()
     1555                                                 ((label :label)))
    15561556  (leaq (:@ (:^ label) (:%q x8664::fn)) (:%q x8664::ra0))
    15571557  (pushq (:%q x8664::ra0)))
  • branches/ia32/compiler/X86/x86-disassemble.lisp

    r7220 r7244  
    22742274           (setf (x86-di-mnemonic instruction)
    22752275                 (case intop
    2276                    (#xc0 "uuo-error-two-few-args")
    2277                    (#xc1 "uuo-error-two-many-args")
     2276                   (#xc0 "uuo-error-too-few-args")
     2277                   (#xc1 "uuo-error-too-many-args")
    22782278                   (#xc2 "uuo-error-wrong-number-of-args")
    22792279                   (#xc4 (progn (setq stop nil) "uuo-gc-trap"))
  • branches/ia32/compiler/X86/x862.lisp

    r7216 r7244  
    961961              (x862-bind-var seg var vloc lcell))
    962962            (setq vloc (+ vloc *x862-target-node-size*)))))))
    963   (when keys
    964     (apply #'x862-init-keys seg vloc lcells keys)
    965     (setq vloc (+ vloc (* 2 *x862-target-node-size* nkeys))
    966           lcells (nthcdr (+ nkeys nkeys) lcells)))
     963
    967964  (when rest
    968965    (if lexpr
     
    976973              (x862-note-top-cell rest)
    977974              (x862-bind-var seg rest loc *x862-top-vstack-lcell*))))
    978       (progn
     975      (let* ((rvloc (+ vloc (* 2 *x862-target-node-size* nkeys))))
    979976        (if (setq reg (x862-assign-register-var rest))
    980           (x862-init-regvar seg rest reg (x862-vloc-ea vloc))
    981           (x862-bind-var seg rest vloc (pop lcells)))
    982         (setq vloc (+ vloc *x862-target-node-size*)))))
     977          (x862-init-regvar seg rest reg (x862-vloc-ea rvloc))
     978          (x862-bind-var seg rest rvloc (pop lcells))))))
     979    (when keys
     980      (apply #'x862-init-keys seg vloc lcells keys))
    983981  (x862-seq-bind seg (%car auxen) (%cadr auxen)))
     982
    984983
    985984(defun x862-initopt (seg vloc spvloc lcells splcells vars inits spvars)
     
    28562855  (with-x86-local-vinsn-macros (seg)
    28572856    (when mv-label
    2858       (! start-mv-call (aref *backend-labels* mv-label))
    2859       (setq *x862-vstack* (+  *x862-vstack* *x862-target-node-size*)))
     2857      (x862-vpush-label seg (aref *backend-labels* mv-label)))
    28602858    (when (car args)
    28612859      (! reserve-outgoing-frame)
     
    36053603      (! vpush-register src)
    36063604      (x862-new-vstack-lcell (or why :node) *x862-target-lcell-size* (or attr 0) info)
     3605      (x862-adjust-vstack *x862-target-node-size*))))
     3606
     3607
     3608;;; Need to track stack usage when pushing label for mv-call.
     3609(defun x862-vpush-label (seg label)
     3610  (with-x86-local-vinsn-macros (seg)
     3611    (prog1
     3612      (! vpush-label label)
     3613      (x862-new-vstack-lcell :label *x862-target-lcell-size* 0 nil)
    36073614      (x862-adjust-vstack *x862-target-node-size*))))
    36083615
     
    48614868          (let* ((label (when (or recursive-p (x862-mvpass-p xfer)) (backend-get-next-label))))
    48624869            (when label
    4863               (! start-mv-call (aref *backend-labels* label)))
     4870              (x862-vpush-label seg (aref *backend-labels* label)))
    48644871            (x862-temp-push-node seg (x862-one-untargeted-reg-form seg fn *x862-arg-z*))
    48654872            (x862-multiple-value-body seg (pop arglist))
  • branches/ia32/level-0/PPC/ppc-numbers.lisp

    r6008 r7244  
    313313    ab mod m = ((u + v) mod 2^n) + 1   :  u+v >= 2^n
    314314
    315 What we do is use 2b and 2n so we can do arithemetic mod 2^32 instead of
     315What we do is use 2b and 2^n so we can do arithemetic mod 2^32 instead of
    3163162^31.  This reduces the whole generator to 5 instructions on the 680x0 or
    31731780x86, and 8 on the 60x.
  • branches/ia32/level-0/l0-array.lisp

    r5513 r7244  
    484484    fill))
    485485
    486 ; Could avoid potential memoization somehow
     486;;; Could avoid potential memoization somehow
    487487(defun vector (&lexpr vals)
    488488  "Construct a SIMPLE-VECTOR from the given objects."
     
    492492    (dotimes (i n v) (setf (%svref v i) (%lexpr-ref vals n i)))))
    493493
     494;;; CALL-ARGUMENTS-LIMIT.
     495(defun list-to-vector (elts)
     496  (let* ((n (length elts)))
     497    (declare (fixnum n))
     498    (if (< n (floor #x8000 target::node-size))
     499      (apply #'vector elts)
     500      (make-array n :initial-contents elts))))
     501
     502             
     503   
    494504(defun %gvector (subtag &lexpr vals)
    495505  (let* ((n (%lexpr-count vals))
  • branches/ia32/level-0/l0-numbers.lisp

    r6007 r7244  
    17711771    ab mod m = ((u + v) mod 2^n) + 1   :  u+v >= 2^n
    17721772
    1773 What we do is use 2b and 2n so we can do arithemetic mod 2^32 instead of
     1773What we do is use 2b and 2^n so we can do arithemetic mod 2^32 instead of
    177417742^31.  This reduces the whole generator to 5 instructions on the 680x0 or
    1775177580x86, and 8 on the 60x.
     
    17811781#+64-bit-target
    17821782(defun %next-random-pair (high low)
    1783   (let* ((n (nth-value
    1784              1
    1785              (%multiply 42871 (dpb (ldb (byte 15 0) high)
    1786                                       (byte 16 16)
    1787                                       (ldb (byte 16 0) low ))))))
    1788     (values (ldb (byte 16 16) n)
     1783  (declare (type (unsigned-byte 16) high low))
     1784  (let* ((n0
     1785          (%i* 42871
     1786             (the  (unsigned-byte 31)
     1787               (logior (the (unsigned-byte 31)
     1788                         (ash (ldb (byte 15 0) high) 16))
     1789                       (the (unsigned-byte 16)
     1790                         (ldb (byte 16 0) low))))))
     1791         (n (fast-mod n0 (1- (expt 2 31)))))
     1792    (declare (fixnum n))
     1793    (values (ldb (byte 15 16) n)
    17891794            (ldb (byte 16 0) n))))
    17901795
     
    17921797  (multiple-value-bind (high low) (%next-random-pair (%svref state 1)
    17931798                                                     (%svref state 2))
    1794     (setf (%svref state 1) (ldb (byte 15 0) high)
     1799    (declare (type (unsigned-byte 15) high)
     1800             (type (unsigned-byte 16) low))
     1801    (setf (%svref state 1) high
    17951802          (%svref state 2) low)
    1796     high
    1797     ))
     1803    (logior high (the fixnum (logand low (ash 1 15))))))
    17981804
    17991805
  • branches/ia32/level-1/l1-dcode.lisp

    r6488 r7244  
    182182        (setf (%gf-dispatch-table gf) new)))))
    183183
     184(defun %gf-dispatch-table-store-conditional (dt index new)
     185  "Returns T if the new value can be stored in DT at INDEX, replacing a NIL.
     186   Returns NIL - without storing anything - if the value already in DT
     187   at INDEX is non-NIL at the time of the store."
     188  (%store-node-conditional (+ (ash (%i+ index %gf-dispatch-table-first-data)
     189                                   target::word-shift)
     190                              target::misc-data-offset)
     191                           dt nil new))
     192
    184193(defun grow-gf-dispatch-table (gf-or-cm wrapper table-entry &optional obsolete-wrappers-p)
    185194  ;; Grow the table associated with gf and insert table-entry as the value for
     
    849858                         (find-gf-dispatch-table-index table wrapper)
    850859      (if index
    851         (setf (%gf-dispatch-table-ref table index) wrapper
    852               (%gf-dispatch-table-ref table (%i+ index 1)) combined-method)
     860        (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
     861          (setf (%gf-dispatch-table-ref table index) wrapper))
    853862        (grow-gf-dispatch-table gf wrapper combined-method obsolete-wrappers-p)))
    854863    combined-method))
     
    10131022
    10141023
    1015 ; called from %%call-next-method-with-args - its the key-or-init-fn
    1016 ; called from call-next-method-with-args - just check the blooming keys
    1017 ; dont invoke any methods - maybe use x%%check-keywords with last vector elt nil
     1024;;; called from %%call-next-method-with-args - its the key-or-init-fn
     1025;;; called from call-next-method-with-args - just check the blooming keys
     1026;;; dont invoke any methods - maybe use x%%check-keywords with last vector elt nil
    10181027; means dont call any methods - but need the gf or method for error message
    10191028(defun x-%%check-keywords (vector-arg ARGS)
     
    10631072
    10641073
    1065 ; Map an effective-method to it's generic-function.
    1066 ; This is only used for effective-method's which are not combined-method's
    1067 ; (e.g. those created by non-STANDARD method-combination)
     1074;;; Map an effective-method to it's generic-function.
     1075;;; This is only used for effective-method's which are not combined-method's
     1076;;; (e.g. those created by non-STANDARD method-combination)
    10681077(defvar *effective-method-gfs* (make-hash-table :test 'eq :weak :key))
    10691078
     
    11101119(defvar *initialization-functions-alist* nil)
    11111120
    1112 ; This could be in-line above, but I was getting confused.
    1113 
    1114 ; ok
     1121;;; This could be in-line above, but I was getting confused.
     1122
     1123;;; ok
    11151124(defun make-cnm-combined-method (gf methods method-list keywords)
    11161125  (setq gf (combined-method-gf gf))
     
    12321241  ;; Compute it and add it to the table.  This code will remain in Lisp.
    12331242  (multiple-value-bind (combined-method sub-dispatch?)
    1234                        (compute-nth-arg-combined-method
    1235                         gf-or-cm (%gf-dispatch-table-methods table) argnum args
    1236                         wrapper)
     1243      (compute-nth-arg-combined-method
     1244       gf-or-cm (%gf-dispatch-table-methods table) argnum args
     1245       wrapper)
    12371246    (multiple-value-bind (index obsolete-wrappers-p)
    1238                          ( find-gf-dispatch-table-index table wrapper)
     1247        ( find-gf-dispatch-table-index table wrapper)
    12391248      (if index
    1240         (setf (%gf-dispatch-table-ref table index) wrapper
    1241               (%gf-dispatch-table-ref table (%i+ index 1)) combined-method)
     1249        (if (%gf-dispatch-table-store-conditional table (%i+ index 1) combined-method)
     1250           (setf (%gf-dispatch-table-ref table index) wrapper))
    12421251        (grow-gf-dispatch-table gf-or-cm wrapper combined-method obsolete-wrappers-p)))
    12431252    (if sub-dispatch?
  • branches/ia32/level-1/l1-error-system.lisp

    r6937 r7244  
    634634;; Some simple restarts for simple error conditions.  Callable from the kernel.
    635635
     636(defun find-unique-homonym (name &optional test)
     637  (let ((pname (and name (symbolp name) (symbol-name name)))
     638        (other-name nil))
     639    (dolist (pkg (list-all-packages) other-name)
     640      (let ((candidate (find-symbol pname pkg)))
     641        (when (and candidate
     642                   (not (eq candidate name))
     643                   (or (null test) (funcall test candidate)))
     644          (when (and other-name (neq other-name candidate))
     645            (return nil)) ;; more than one, too complicated, give up
     646          (setq other-name candidate))))))
    636647
    637648
     
    639650  (unless *level-1-loaded*
    640651    (dbg cell-name))       ;  user should never see this.
    641   (let ((condition (make-condition 'unbound-variable :name cell-name)))
     652  (let ((condition (make-condition 'unbound-variable :name cell-name))
     653        (other-variable (find-unique-homonym cell-name #'boundp)))
    642654    (flet ((new-value ()
    643655             (catch-cancel
     
    651663                  :report (lambda (s) (format s "Retry getting the value of ~S." cell-name))
    652664                  (symbol-value cell-name))
     665        (use-homonym ()
     666                     :test (lambda (c) (and (or (null c) (eq c condition)) other-variable))
     667                     :report (lambda (s) (format s "Use the value of ~s this time." other-variable))
     668                     (symbol-value other-variable))
    653669        (use-value (value)
    654670                   :interactive new-value
     
    881897  (let ((condition (make-condition 'undefined-function-call
    882898                                   :name function-name
    883                                    :function-arguments args)))
     899                                   :function-arguments args))
     900        (other-function (find-unique-homonym function-name #'fboundp)))
    884901    (restart-case (%error condition nil frame-ptr)
    885902      (continue ()
    886903                :report (lambda (s) (format s "Retry applying ~S to ~S." function-name args))
    887904                (apply function-name args))
     905      (use-homonym ()
     906                   :test (lambda (c) (and (or (null c) (eq c condition)) other-function))
     907                   :report (lambda (s) (format s "Apply ~s to ~S this time." other-function args))
     908                   (apply other-function args))
    888909      (use-value (function)
    889910                 :interactive (lambda ()
  • branches/ia32/level-1/l1-readloop-lds.lisp

    r6943 r7244  
    410410        (*print-escape* t)
    411411        (*print-gensym* t)
    412         (*print-length* nil)  ; ?
    413         (*print-level* nil)   ; ?
     412        (*print-length* *backtrace-print-length*)  ; ?
     413        (*print-level* *backtrace-print-level*)   ; ?
    414414        (*print-lines* nil)
    415415        (*print-miser-width* nil)
     
    524524        (if *continuablep*
    525525          (let* ((*print-circle* *error-print-circle*)
     526                 (*print-level* *backtrace-print-level*)
     527                 (*print-length* *backtrace-print-length*)
    526528                                        ;(*print-pretty* nil)
    527529                 (*print-array* nil))
  • branches/ia32/level-1/l1-streams.lisp

    r6944 r7244  
    54175417        'fd-binary-io-stream
    54185418        'fd-binary-input-stream)
    5419       'fd-character-output-stream)))
     5419      'fd-binary-output-stream)))
    54205420
    54215421(defstruct (input-selection (:include dll-node))
  • branches/ia32/level-1/linux-files.lisp

    r6947 r7244  
    677677
    678678(defun get-descriptor-for (object proc close-in-parent close-on-error
    679                                   &rest keys &key direction
     679                                  &rest keys &key direction (element-type 'character)
    680680                                  &allow-other-keys)
    681681  (etypecase object
     
    697697                  (make-fd-stream write-pipe
    698698                                  :direction :output
     699                                  :element-type element-type
    699700                                  :interactive nil)
    700701                  (cons read-pipe close-in-parent)
     
    704705                  (make-fd-stream read-pipe
    705706                                  :direction :input
     707                                  :element-type element-type
    706708                                  :interactive nil)
    707709                  (cons write-pipe close-in-parent)
     
    859861                            output (if-output-exists :error)
    860862                            (error :output) (if-error-exists :error)
    861                             status-hook)
     863                            status-hook (element-type 'character))
    862864  "Invoke an external program as an OS subprocess of lisp."
    863865  (declare (ignore pty))
     
    888890           (multiple-value-setq (in-fd in-stream close-in-parent close-on-error)
    889891             (get-descriptor-for input proc  nil nil :direction :input
    890                                  :if-does-not-exist if-input-does-not-exist))
     892                                 :if-does-not-exist if-input-does-not-exist
     893                                 :element-type element-type))
    891894           (multiple-value-setq (out-fd out-stream close-in-parent close-on-error)
    892895             (get-descriptor-for output proc close-in-parent close-on-error
    893896                                 :direction :output
    894                                  :if-exists if-output-exists))
     897                                 :if-exists if-output-exists
     898                                 :element-type element-type))
    895899           (multiple-value-setq (error-fd error-stream close-in-parent close-on-error)
    896900             (if (eq error :output)
     
    898902               (get-descriptor-for error proc close-in-parent close-on-error
    899903                                   :direction :output
    900                                    :if-exists if-error-exists)))
     904                                   :if-exists if-error-exists
     905                                   :element-type element-type)))
    901906           (setf (external-process-input proc) in-stream
    902907                 (external-process-output proc) out-stream
  • branches/ia32/lib/arglist.lisp

    r6924 r7244  
    5757     (if (stringp res)
    5858       res
    59        (and res (prin1-to-string res)))
     59       (and res (princ-to-string res)))
    6060     type)))
    6161
  • branches/ia32/lib/backquote.lisp

    r2830 r7244  
    322322
    323323(defun backquote-aux (form)
    324   ;Doesn't try to optimize multiple CONS's into LIST/LIST*'s, leaving it up
    325   ;to the compiler.  The code here is mainly concerned with folding
    326   ;constants, since the compiler is not allowed to do that in general.
     324  ;;Doesn't try to optimize multiple CONS's into LIST/LIST*'s, leaving it up
     325  ;;to the compiler.  The code here is mainly concerned with folding
     326  ;;constants, since the compiler is not allowed to do that in general.
    327327  (cond
    328328   ((simple-vector-p form)
     
    331331      (multiple-value-bind (elts quotedp) (backquote-aux elts)
    332332        (if quotedp
    333           (values (apply #'vector elts) t)
    334           (list 'apply '#'vector elts)))))
     333          (values (list-to-vector elts) t)
     334          (list 'list-to-vector elts)))))
    335335   ((self-evaluating-p form) (values form t))
    336336   ((atom form) (values form t))
  • branches/ia32/lib/ccl-export-syms.lisp

    r6956 r7244  
    563563     use-interface-dir
    564564     unuse-interface-dir
     565     create-interfaces
    565566     ;;
    566567     run-program
  • branches/ia32/lib/compile-ccl.lisp

    r7241 r7244  
    542542                                                 
    543543               
     544(defun create-interfaces (dirname &key target populate-arg)
     545  (let* ((backend (if target (find-backend target) *target-backend*))
     546         (*default-pathname-defaults* nil)
     547         (ftd (backend-target-foreign-type-data backend))
     548         (d (use-interface-dir dirname ftd))
     549         (populate (merge-pathnames "C/populate.sh"
     550                                    (merge-pathnames
     551                                     (interface-dir-subdir d)
     552                                     (ftd-interface-db-directory ftd))))
     553         (cdir (make-pathname :directory (pathname-directory (translate-logical-pathname populate))))
     554         (args (list "-c"
     555                     (format nil "cd ~a && /bin/sh ~a ~@[~a~]"
     556                             (native-translated-namestring cdir)
     557                             (native-translated-namestring populate)
     558                             populate-arg))))
     559    (format t "~&;[Running interface translator via ~s to produce .ffi file(s) from headers]~&" populate)
     560    (force-output t)
     561    (multiple-value-bind (status exit-code)
     562        (external-process-status
     563         (run-program "/bin/sh" args :output t))
     564      (if (and (eq status :exited)
     565               (eql exit-code 0))
     566        (let* ((f 'parse-standard-ffi-files))
     567          (require "PARSE-FFI")
     568          (format t "~%~%;[Parsing .ffi files; may create new .cdb files for ~s]" dirname)
     569          (funcall f dirname target)
     570          (format t "~%~%;[Parsing .ffi files again to resolve forward-referenced constants]")
     571          (funcall f dirname target))))))
  • branches/ia32/lib/db-io.lisp

    r6502 r7244  
    15481548      (#.encoded-type-double-float (values (parse-foreign-type :double) q))
    15491549      (#.encoded-type-pointer (multiple-value-bind (target qq)
    1550                                     (if (eql (%get-unsigned-byte buf q)
    1551                                              encoded-type-void)
    1552                                       (values nil (1+ q))
    1553                                       (%decode-type buf q ftd suppress-typedef-expansion))
     1550                                  (%decode-type buf q ftd suppress-typedef-expansion)
    15541551                                (values (make-foreign-pointer-type
    15551552                                         :to target
  • branches/ia32/lib/ffi-darwinppc32.lisp

    r6036 r7244  
    224224(defun darwin32::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    225225  (unless (eq return-type *void-foreign-type*)
     226    ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
     227    (when (typep return-type 'foreign-single-float-type)
     228      (setq result `(float ,result 0.0d0)))   
    226229    (when (typep return-type 'foreign-record-type)
    227230      ;;; Would have been mapped to :VOID unless record-type contained
  • branches/ia32/lib/ffi-darwinppc64.lisp

    r6209 r7244  
    511511(defun darwin64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg)
    512512  (unless (eq return-type *void-foreign-type*)
     513    (when (typep return-type 'foreign-single-float-type)
     514      (setq result `(float ,result 0.0d0)))   
    513515    (if (typep return-type 'foreign-record-type)
    514516      ;;; Would have been mapped to :VOID unless record-type contained
  • branches/ia32/lib/ffi-linuxppc32.lisp

    r5881 r7244  
    195195  (declare (ignore fp-args-ptr))
    196196  (unless (eq return-type *void-foreign-type*)
     197    (when (typep return-type 'foreign-single-float-type)
     198      (setq result `(float ,result 0.0d0)))   
    197199    (let* ((return-type-keyword
    198200            (if (typep return-type 'foreign-record-type)
  • branches/ia32/lib/ffi-linuxppc64.lisp

    r5918 r7244  
    180180  (declare (ignore struct-return-arg))
    181181  (unless (eq return-type *void-foreign-type*)
     182    (when (typep return-type 'foreign-single-float-type)
     183      (setq result `(float ,result 0.0d0)))   
    182184    (let* ((return-type-keyword (foreign-type-to-representation-type return-type))
    183185           (result-ptr (case return-type-keyword
  • branches/ia32/lib/macros.lisp

    r6929 r7244  
    24622462                  (declare (ignorable ,result)
    24632463                           (dynamic-extent ,result))
    2464                   ,@(progn
    2465                      ;; Coerce SINGLE-FLOAT result to DOUBLE-FLOAT
    2466                      (when (typep return-type 'foreign-single-float-type)
    2467                        (setq result `(float ,result 0.0d0)))
    2468                      nil)
     2464
    24692465                  ,(funcall (ftd-callback-return-value-function *target-ftd*)
    24702466                            stack-ptr
  • branches/ia32/library/parse-ffi.lisp

    r5830 r7244  
    716716         (*target-ftd* ftd)
    717717         (*target-backend* backend)
    718          (*ffi-struct-return-explicit* t #|(getf (ftd-attributes ftd) :struct-return-explicit)|#)
     718         (*ffi-struct-return-explicit* nil)
    719719         (d (use-interface-dir dirname ftd))
    720720         (interface-dir (merge-pathnames
  • branches/ia32/lisp-kernel/gc.h

    r4579 r7244  
    5454
    5555
    56 extern BytePtr HeapHighWaterMark; /* highest zeroed dynamic address  */
     56extern void zero_memory_range(BytePtr,BytePtr);
    5757extern LispObj GCarealow, GCareadynamiclow;
    5858extern natural GCndnodes_in_area, GCndynamic_dnodes_in_area;
  • branches/ia32/lisp-kernel/memory.c

    r4545 r7244  
    176176
    177177
     178void
     179zero_memory_range(BytePtr start, BytePtr end)
     180{
     181  bzero(start,end-start);
     182}
     183
    178184
    179185 
     
    190196{
    191197  extern int page_size;
    192   natural protbytes, zerobytes;
    193198  area *a = active_dynamic_area;
    194199  BytePtr newlimit, protptr, zptr;
    195200  int psize = page_size;
    196   /*
    197      Zero the region between the new freepointer and the end of the
    198      containing segment.
    199   */
    200   zptr = (BytePtr) align_to_power_of_2(newfree,log2_heap_segment_size);
    201   zerobytes = zptr-newfree;
    202   HeapHighWaterMark = zptr;
    203 
    204   while (zerobytes >= psize) {
    205     zptr -= psize;
    206     zerobytes -= psize;
    207     zero_page(zptr);
    208   }
    209  
    210   if (zerobytes) {
    211     bzero(newfree, zerobytes);
    212   }
    213201  if (free_space_size) {
    214202    BytePtr lowptr = a->active;
     
    217205    if (newlimit > a->high) {
    218206      return grow_dynamic_area(newlimit-a->high);
    219     } else if ((HeapHighWaterMark + free_space_size) < a->high) {
     207    } else if ((lowptr + free_space_size) < a->high) {
    220208      shrink_dynamic_area(a->high-newlimit);
    221209      return true;
  • branches/ia32/lisp-kernel/pmcl-kernel.c

    r7017 r7244  
    408408*/
    409409
    410 BytePtr
    411 HeapHighWaterMark = NULL;
    412 
    413410void
    414411uncommit_pages(void *start, size_t len)
     
    427424    }
    428425  }
    429   if (HeapHighWaterMark > (BytePtr) start) {
    430     HeapHighWaterMark = start;
    431   }
    432426}
    433427
     
    468462      if (addr == start) {
    469463        if (touch_all_pages(start, len)) {
    470           HeapHighWaterMark = ((BytePtr)start) + len;
    471464          return true;
    472465        }
     
    701694}
    702695
     696
    703697void *
    704698allocate_from_reserved_area(natural size)
     
    783777    return false;
    784778  }
     779
     780  if (!commit_pages(a->high,delta)) {
     781    return false;
     782  }
     783
     784
    785785  if (!allocate_from_reserved_area(delta)) {
    786786    return false;
    787787  }
    788   /*
    789     commit_pages(a->high,delta);
    790   */
    791   commit_pages(HeapHighWaterMark,(a->high+delta)-HeapHighWaterMark);
     788
    792789
    793790  a->high += delta;
  • branches/ia32/lisp-kernel/ppc-exceptions.c

    r6546 r7244  
    597597  xpGPR(xp,allocbase) = (LispObj) oldlimit;
    598598
    599   while (HeapHighWaterMark < (BytePtr)newlimit) {
    600     zero_page(HeapHighWaterMark);
    601     HeapHighWaterMark+=page_size;
    602   }
    603599  return true;
    604600}
  • branches/ia32/lisp-kernel/ppc-gc.c

    r6393 r7244  
    27392739    }
    27402740
     2741    zero_memory_range(a->active, oldfree);
     2742
    27412743    resize_dynamic_heap(a->active,
    27422744                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
  • branches/ia32/lisp-kernel/x86-exceptions.c

    r6908 r7244  
    9999  tcr->save_allocbase = (void *) oldlimit;
    100100
    101   while (HeapHighWaterMark < (BytePtr)newlimit) {
    102     zero_page(HeapHighWaterMark);
    103     HeapHighWaterMark+=page_size;
    104   }
    105101  return true;
    106102}
  • branches/ia32/lisp-kernel/x86-gc.c

    r6528 r7244  
    26532653    }
    26542654
     2655    zero_memory_range(a->active, oldfree);
     2656
    26552657    resize_dynamic_heap(a->active,
    26562658                        (GCephemeral_low == 0) ? lisp_heap_gc_threshold : 0);
  • branches/ia32/objc-bridge/objc-runtime.lisp

    r6856 r7244  
    4545  (progn
    4646    (use-interface-dir :cocoa)
     47    #+nomore
    4748    (use-interface-dir :carbon))        ; need :carbon for things in this file
    4849  #+gnu-objc
  • branches/ia32/objc-bridge/objc-support.lisp

    r6856 r7244  
    9191(let* ((nclasses 0))
    9292  (declare (fixnum nclasses))
    93   (defun maybe-map-objc-classes ()
     93  (defun maybe-map-objc-classes (&optional use-db)
    9494    (let* ((new (count-objc-classes)))
    9595      (declare (fixnum new))
    9696    (unless (= nclasses new)
    9797      (setq nclasses new)
    98       (map-objc-classes)
     98      (map-objc-classes use-db)
    9999      t)))
    100100  (defun reset-objc-class-count ()
     
    102102
    103103(register-objc-class-decls)
    104 (maybe-map-objc-classes)
     104(maybe-map-objc-classes t)
    105105(register-objc-init-messages)
    106106
Note: See TracChangeset for help on using the changeset viewer.