Changeset 7025 for branches


Ignore:
Timestamp:
Aug 12, 2007, 1:19:41 AM (17 years ago)
Author:
Gary Byers
Message:

Create branch for current bleeding.

Location:
branches/working-0708
Files:
29 edited
6 copied

Legend:

Unmodified
Added
Removed

  • branches/working-0708/cocoa-ide

    • Property svn:ignore set to
      *~.*
      *fsl

  • branches/working-0708/cocoa-ide/cocoa-editor.lisp

    r7007 r7025  
    369369     (edit-count :foreign-type :int)
    370370     (cache :foreign-type :id)
    371      (styles :foreign-type :id))
     371     (styles :foreign-type :id)
     372     (selection-set-by-search :foreign-type :<BOOL>))
    372373  (:metaclass ns:+ns-object))
    373374
    … …  
    503504  (#_NSLog #@"Attributes at index: %d storage %@" :unsigned index :id self)
    504505  (with-slots (cache styles) self
     506    (when (>= index (#/length cache))
     507      (#_NSLog #@"Attributes at index: %d cache: %@" :unsigned index :id cache))
    505508    (let* ((attrs (#/attributesAtIndex:effectiveRange: cache index rangeptr)))
    506509      (when (eql 0 (#/count attrs))
    … …  
    747750
    748751(objc:defmethod (#/updateSelection:length:affinity: :void)
    749     ((self hemlock-textstorage-text-view)
    750     (pos :int)
    751     (length :int)
    752     (affinity :<NSS>election<A>ffinity))
     752                ((self hemlock-textstorage-text-view)
     753                (pos :int)
     754                (length :int)
     755                (affinity :<NSS>election<A>ffinity))
    753756  (when (eql length 0)
    754757    (update-blink self))
    755758  (rlet ((range :ns-range :location pos :length length))
    756     (%call-next-objc-method self
    757                             hemlock-textstorage-text-view
    758                             (@selector #/setSelectedRange:affinity:stillSelecting:)
    759                             '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
    760                             range
    761                             affinity
    762                             nil)
    763     (#/scrollRangeToVisible: self range)))
     759        (%call-next-objc-method self
     760                                hemlock-textstorage-text-view
     761                                (@selector #/setSelectedRange:affinity:stillSelecting:)
     762                                '(:void :<NSR>ange :<NSS>election<A>ffinity :<BOOL>)
     763                                range
     764                                affinity
     765                                nil)
     766        (#/scrollRangeToVisible: self range)
     767        (when (> length 0)
     768          (let* ((ts (#/textStorage self)))
     769            (with-slots (selection-set-by-search) ts
     770              (when (prog1 (eql #$YES selection-set-by-search)
     771                      (setq selection-set-by-search #$NO))
     772                (highlight-search-selection self pos length)))))
     773))
     774
     775(defloadvar *can-use-show-find-indicator-for-range*
     776            (coerce-from-bool (#_class_respondsToSelector
     777                               (@class "NSTextView")
     778                               (@selector "showFindIndicatorForRange:"))))
     779
     780;;; Add transient highlighting to a selection established via a search
     781;;; primitive, if the OS supports it.
     782(defun highlight-search-selection (tv pos length)
     783  (when *can-use-show-find-indicator-for-range*
     784    (ns:with-ns-range (r pos length)
     785      (objc-message-send tv "showFindIndicatorForRange:" :<NSR>ange r :void))))
    764786 
    765787;;; A specialized NSTextView. The NSTextView is part of the "pane"
    … …  
    770792     (char-height :foreign-type :<CGF>loat :accessor text-view-char-height))
    771793  (:metaclass ns:+ns-object))
     794
     795
     796#+debug
     797(objc:defmethod (#/viewDidEndLiveResize :void)
     798    ((self hemlock-textstorage-text-view))
     799  (#_NSLog #@"end resize: %@" :address (#/class self))
     800  (call-next-method))
     801
    772802
    773803
    … …  
    942972                  (setq bits (logior bits (hemlock-ext::key-event-modifier-mask
    943973                                         (cdr map)))))))
     974            (let* ((char (code-char c)))
     975              (when (and char (standard-char-p char))
     976                (setq bits (logandc2 bits hi::+shift-event-mask+))))
    944977            (hemlock-ext::make-key-event c bits)))))))
    945978
    … …  
    11901223        (#/setFrame: modeline modeline-frame)))))
    11911224
    1192 ;;; We want to constrain the scrolling that happens under program control,
    1193 ;;; so that the clipview is always scrolled in character-sized increments.
    1194 #+doesnt-work-yet
    1195 (objc:defmethod (#/scrollClipView:toPoint: :void)
    1196     ((self modeline-scroll-view)
    1197      clip-view
    1198      (p :ns-point))
    1199   #+debug
    1200   (#_NSLog #@"Scrolling to point %@" :id (#_NSStringFromPoint p))
    1201   (let* ((char-height (#/verticalLineScroll self)))
    1202     (ns:with-ns-point (proposed (ns:ns-point-x p) (* char-height (round (ns:ns-point-y p) char-height)))
    1203     #+debug
    1204     (#_NSLog #@" Proposed point = %@" :id
    1205              (#_NSStringFromPoint proposed)))
    1206     (call-next-method clip-view proposed)))
     1225
    12071226
    12081227
    … …  
    17911810          (unless (eq (hi::mark-%kind mark) :right-inserting)
    17921811            (decf pos n))
    1793           #+debug
     1812          #+debug 
    17941813          (#_NSLog #@"insert: pos = %d, n = %d" :int pos :int n)
    17951814          ;;(reset-buffer-cache display)
    … …  
    18011820               cache replacerange replacestring)))
    18021821          (#/setAttributes:range: cache font (ns:make-ns-range pos n))
     1822          #+debug (#_NSLog #@"cache = %@" :id cache)
    18031823          #-all-in-cocoa-thread
    18041824          (textstorage-note-insertion-at-position textstorage pos n)
    … …  
    19511971                (not (string= curname name)))
    19521972          (setf (hi::variable-value 'hemlock::current-package :buffer buffer) name))))))
     1973
     1974(defun hi::document-note-selection-set-by-search (doc)
     1975  (with-slots (textstorage) doc
     1976    (when textstorage
     1977      (with-slots (selection-set-by-search) textstorage
     1978        (setq selection-set-by-search #$YES)))))
    19531979
    19541980(objc:defmethod (#/validateMenuItem: :<BOOL>)
    … …  
    21062132  (call-next-method path type save-operation))
    21072133
     2134(objc:defmethod (#/writeToURL:ofType:forSaveOperation:originalContentsURL:error:
     2135                 :<BOOL>)
     2136                ((self hemlock-editor-document)
     2137                 url
     2138                 type
     2139                 (op :<NSS>ave<O>peration<T>ype)
     2140                 original
     2141                 (error (:* :id)))
     2142  (#_NSLog #@"url = %@, original url = %@" :id url :id original)
     2143  (call-next-method url type op original error))
     2144
    21082145(def-cocoa-default *editor-keep-backup-files* :bool t "maintain backup files")
    21092146
    … …  
    22662303         (sv-height (ns:ns-size-height (#/contentSize sv)))
    22672304         (nlines (floor sv-height char-height))
    2268          (point (hi::current-point)))
     2305         (point (hi::current-point-collapsing-selection)))
    22692306    (or (hi::line-offset point (* n nlines))       
    22702307        (if (< n 0)

  • branches/working-0708/cocoa-ide/hemlock/src/bindings.lisp

    r7013 r7025  
    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")
    … …  
    142154
    143155(bind-key "Forward Word" #k"meta-f")
     156(bind-key "Select Forward Word" #k"meta-F")
    144157(bind-key "Backward Word" #k"meta-b")
     158(bind-key "Select Backward Word" #k"meta-B")
    145159
    146160(bind-key "Forward Paragraph" #k"meta-]")
    … …  
    364378(bind-key "Arglist On Space" #k"Space" :mode "Lisp")
    365379(bind-key "Defindent" #k"control-meta-#")
    366 (bind-key "Beginning of Defun" #k"control-meta-[")
    367 (bind-key "End of Defun" #k"control-meta-]")
    368380(bind-key "Beginning of Defun" #k"control-meta-a")
     381(bind-key "Select to Beginning of Defun" #k"control-meta-A")
    369382(bind-key "End of Defun" #k"control-meta-e")
     383(bind-key "Select to End of Defun" #k"control-meta-E")
    370384(bind-key "Forward Form" #k"control-meta-f")
     385(bind-key "Select Forward Form" #k"control-meta-F")
    371386(bind-key "Backward Form" #k"control-meta-b")
     387(bind-key "Select Backward Form" #k"control-meta-B")
    372388(bind-key "Forward List" #k"control-meta-n")
     389(bind-key "Select Forward List" #k"control-meta-N")
    373390(bind-key "Backward List" #k"control-meta-p")
     391(bind-key "Select Backward List" #k"control-meta-P")
    374392(bind-key "Transpose Forms" #k"control-meta-t")
    375393(bind-key "Forward Kill Form" #k"control-meta-k")
    … …  
    925943(setf (logical-key-event-p #k"control-g" :abort) t)
    926944(setf (logical-key-event-p #k"escape" :exit) t)
    927 (setf (logical-key-event-p #k"leftdown" :exit) t)
     945(setf (logical-key-event-p #k"leftdown" :mouse-exit) t)
    928946(setf (logical-key-event-p #k"y" :yes) t)
    929947(setf (logical-key-event-p #k"space" :yes) t)

  • branches/working-0708/cocoa-ide/hemlock/src/buffer.lisp

    r7007 r7025  
    325325  (buffer-point *current-buffer*))
    326326
    327 (defun current-point-for-movement ()
     327
     328
     329(defun current-point-collapsing-selection ()
    328330  "Return the Buffer-Point of the current buffer, deactivating the
    329    region unless the shift modifier was set in *last-key-event-typed*"
     331   region."
    330332  (let* ((b *current-buffer*)
    331          (point (buffer-point b))
    332          (shift-key-p (logtest +shift-event-mask+
    333                                (hemlock-ext::key-event-bits
    334                                 *last-key-event-typed*))))
    335     (if shift-key-p
    336       ;; If the region is active, keep it active.  Otherwise,
    337       ;; establish a new (empty) region at point.
    338       (unless (%buffer-current-region-p b)
    339         (push-buffer-mark (copy-mark point) t))
    340       ;; Deactivate the region
    341       (setf (buffer-region-active b) nil))
     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))
    342347    point))
    343348

  • branches/working-0708/cocoa-ide/hemlock/src/cocoa-hemlock.lisp

    r7007 r7025  
    9393            (clear-echo-area)
    9494            (throw 'editor-top-level-catcher nil)))
    95         (let* ((event (event-queue-node-event e))
    96                (bits  (hemlock-ext::key-event-bits event))
    97                (keysym (hemlock-ext::key-event-keysym event)))
    98           (setq *last-key-event-typed* event)
    99           (when (and (logtest +shift-event-mask+ bits)
    100                      (not (frame-event-queue-quoted-insert q)))
    101             (setq event (hemlock-ext::make-key-event
    102                          (let* ((char (code-char keysym)))
    103                            (if char
    104                              (char-code (char-downcase char))
    105                              keysym))
    106                          (logandc2 bits +shift-event-mask+))))
    107         (values event
     95        (values (setq *last-key-event-typed* (event-queue-node-event e))
    10896                (prog1 (frame-event-queue-quoted-insert q)
    109                   (setf (frame-event-queue-quoted-insert q) nil)))))
     97                  (setf (frame-event-queue-quoted-insert q) nil))))
    11098    (if (typep e 'buffer-operation)
    11199      (catch 'command-loop-catcher
    … …  
    208196      (editor-error)
    209197      (hi::edit-definition fun-name))))
     198
     199;;; Search highlighting
     200(defun note-selection-set-by-search (&optional (buffer (current-buffer)))
     201  (let* ((doc (buffer-document buffer)))
     202    (when doc (hi::document-note-selection-set-by-search doc))))

  • branches/working-0708/cocoa-ide/hemlock/src/command.lisp

    r7007 r7025  
    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."
     63  "Move the point of the current buffer forward p characters, collapsing the selection."
    6464  (let* ((p (or p 1))
    65          (point (current-point-for-movement)))
     65         (point (current-point-collapsing-selection)))
    6666    (cond ((character-offset point p))
    6767          ((= p 1)
    … …  
    7575           (editor-error "Not enough characters.")))))
    7676
     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
    7795(defcommand "Backward Character" (p)
    78   "Move the point backward one character.
     96  "Move the point backward one character, collapsing the selection.
    7997  With prefix argument move that many characters backward."
    80   "Move the point p characters backward."
     98  "Move the point p characters backward, collapsing the selection."
    8199  (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)))
    82106
    83107#|
    … …  
    167191
    168192(defcommand "Forward Word" (p)
    169   "Moves forward one word.
     193  "Moves forward one word, collapsing the selection.
    170194  With prefix argument, moves the point forward over that many words."
    171   "Moves the point forward p words."
    172   (let* ((point (current-point-for-movement)))
     195  "Moves the point forward p words, collapsing the selection."
     196  (let* ((point (current-point-collapsing-selection)))
    173197    (cond ((word-offset point (or p 1)))
    174198          ((and p (minusp p))
    … …  
    179203           (editor-error "No next word.")))))
    180204
     205(defcommand "Select Forward Word" (p)
     206  "Moves forward one word, extending the selection.
     207  With prefix argument, moves the point forward over that many words."
     208  "Moves the point forward p words, extending the selection."
     209  (let* ((point (current-point-extending-selection)))
     210    (cond ((word-offset point (or p 1)))
     211          ((and p (minusp p))
     212           (buffer-start point)
     213           (editor-error "No previous word."))
     214          (t
     215           (buffer-end point)
     216           (editor-error "No next word.")))))
     217
    181218(defcommand "Backward Word" (p)
    182219  "Moves forward backward word.
    … …  
    185222  (forward-word-command (- (or p 1))))
    186223
     224(defcommand "Select Backward Word" (p)
     225  "Moves forward backward word, extending the selection.
     226  With prefix argument, moves the point back over that many words."
     227  "Moves the point backward p words, extending the selection."
     228  (select-forward-word-command (- (or p 1))))
     229
    187230
    188231
    … …  
    204247
    205248(defcommand "Next Line" (p)
    206   "Moves the point to the next line.
     249  "Moves the point to the next line, collapsing the selection.
    207250   With prefix argument, moves the point that many lines down (or up if
    208251   the prefix is negative)."
    209   "Moves the down p lines."
    210   (let* ((point (current-point-for-movement))
     252  "Moves the down p lines, collapsing the selection."
     253  (let* ((point (current-point-collapsing-selection))
    211254         (target (set-target-column point)))
    212255    (unless (line-offset point (or p 1))
    … …  
    225268    (setf (last-command-type) :line-motion)))
    226269
     270(defcommand "Select Next Line" (p)
     271  "Moves the point to the next line, extending the selection.
     272   With prefix argument, moves the point that many lines down (or up if
     273   the prefix is negative)."
     274  "Moves the down p lines, extendin the selection."
     275  (let* ((point (current-point-extending-selection))
     276         (target (set-target-column point)))
     277    (unless (line-offset point (or p 1))
     278      (when (value next-line-inserts-newlines)
     279        (cond ((not p)
     280               (when (same-line-p point (buffer-end-mark (current-buffer)))
     281                 (line-end point))
     282               (insert-character point #\newline))
     283              ((minusp p)
     284               (buffer-start point)
     285               (editor-error "No previous line."))
     286              (t
     287               (buffer-end point)
     288               (when p (editor-error "No next line."))))))
     289    (unless (move-to-column point target) (line-end point))
     290    (setf (last-command-type) :line-motion)))
     291
    227292
    228293(defcommand "Previous Line" (p)
    229   "Moves the point to the previous line.
     294  "Moves the point to the previous line, collapsing the selection.
    230295  With prefix argument, moves the point that many lines up (or down if
    231296  the prefix is negative)."
    232   "Moves the point up p lines."
     297  "Moves the point up p lines, collapsing the selection."
    233298  (next-line-command (- (or p 1))))
     299
     300(defcommand "Select Previous Line" (p)
     301  "Moves the point to the previous line, collapsing the selection.
     302  With prefix argument, moves the point that many lines up (or down if
     303  the prefix is negative)."
     304  "Moves the point up p lines, collapsing the selection."
     305  (select-next-line-command (- (or p 1))))
    234306
    235307(defcommand "Mark to End of Buffer" (p)
    … …  
    246318
    247319(defcommand "Beginning of Buffer" (p)
    248   "Moves the point to the beginning of the current buffer."
    249   "Moves the point to the beginning of the current buffer."
    250   (declare (ignore p))
    251   (let ((point (current-point-for-movement)))
     320  "Moves the point to the beginning of the current buffer, collapsing the selection."
     321  "Moves the point to the beginning of the current buffer, collapsing the selection."
     322  (declare (ignore p))
     323  (let ((point (current-point-collapsing-selection)))
    252324    (push-buffer-mark (copy-mark point))
    253325    (buffer-start point)))
    … …  
    257329  "Moves the point to the end of the current buffer."
    258330  (declare (ignore p))
    259   (let ((point (current-point-for-movement)))
     331  (let ((point (current-point-collapsing-selection)))
    260332    (push-buffer-mark (copy-mark point))
    261333    (buffer-end point)))
    262334
    263335(defcommand "Beginning of Line" (p)
    264   "Moves the point to the beginning of the current line.
     336  "Moves the point to the beginning of the current line, collapsing the selection.
    265337  With prefix argument, moves the point to the beginning of the prefix'th
    266338  next line."
    267   "Moves the point down p lines and then to the beginning of the line."
    268   (let ((point (current-point-for-movement)))
     339  "Moves the point down p lines and then to the beginning of the line, collapsing the selection."
     340  (let ((point (current-point-collapsing-selection)))
    269341    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
    270342    (line-start point)))
    271343
     344(defcommand "Select to Beginning of Line" (p)
     345  "Moves the point to the beginning of the current line, extending the selection.
     346  With prefix argument, moves the point to the beginning of the prefix'th
     347  next line."
     348  "Moves the point down p lines and then to the beginning of the line, extending the selection."
     349  (let ((point (current-point-extending-selection)))
     350    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
     351    (line-start point)))
     352
    272353(defcommand "End of Line" (p)
    273   "Moves the point to the end of the current line.
     354  "Moves the point to the end of the current line, collapsing the selection.
    274355  With prefix argument, moves the point to the end of the prefix'th next line."
    275   "Moves the point down p lines and then to the end of the line."
    276   (let ((point (current-point-for-movement)))
     356  "Moves the point down p lines and then to the end of the line, collapsing the selection."
     357  (let ((point (current-point-collapsing-selection)))
     358    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
     359    (line-end point)))
     360
     361(defcommand "Select to End of Line" (p)
     362  "Moves the point to the end of the current line, extending the selection.
     363  With prefix argument, moves the point to the end of the prefix'th next line."
     364  "Moves the point down p lines and then to the end of the line, extending the selection."
     365  (let ((point (current-point-extending-selection)))
    277366    (unless (line-offset point (if p p 0)) (editor-error "No such line."))
    278367    (line-end point)))

  • branches/working-0708/cocoa-ide/hemlock/src/echo.lisp

    r6790 r7025  
    720720(define-logical-key-event "Keep"
    721721  "This key-event means exit but keep something around.")
    722 
     722(define-logical-key-event "Mouse Exit"
     723  "This key-event means exit completely.")
    723724
    724725

  • branches/working-0708/cocoa-ide/hemlock/src/key-event.lisp

    r6998 r7025  
    480480;;;
    481481(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)))))))
    482488  (let* ((high-byte (ash keysym -8))
    483489         (low-byte-vector (svref *keysym-high-bytes* high-byte)))

  • branches/working-0708/cocoa-ide/hemlock/src/lispmode.lisp

    r7007 r7025  
    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          (tab-width (value spaces-per-tab)))
     1229         ()
     1230      (case (next-character m)
     1231        (#\space (incf p))
     1232        (#\tab (setq p (* tab-width (ceiling (1+ p) tab-width))))
     1233        (t (return p)))
     1234      (character-offset m 1))))
     1235
     1236;;; Don't do anything if M's line is already correctly indented.
     1237(defun ensure-lisp-indentation (m)
     1238  (let* ((col (lisp-indentation m)))
     1239    (unless (= (count-leading-whitespace m) col)
     1240      (delete-horizontal-space m)
     1241      (funcall (value indent-with-tabs) m col))))
     1242
    12271243
    12281244
    … …  
    12321248
    12331249(defcommand "Beginning of Defun" (p)
    1234   "Move the point to the beginning of a top-level form.
     1250  "Move the point to the beginning of a top-level form, collapsing the selection.
    12351251  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-for-movement))
     1252  "Move the point to the beginning of a top-level form, collapsing the selection."
     1253  (let ((point (current-point-collapsing-selection))
     1254        (count (or p 1)))
     1255    (pre-command-parse-check point)
     1256    (if (minusp count)
     1257        (end-of-defun-command (- count))
     1258        (unless (top-level-offset point (- count))
     1259          (editor-error)))))
     1260
     1261(defcommand "Select to Beginning of Defun" (p)
     1262  "Move the point to the beginning of a top-level form, extending the selection.
     1263  with an argument, skips the previous p top-level forms."
     1264  "Move the point to the beginning of a top-level form, extending the selection."
     1265  (let ((point (current-point-extending-selection))
    12381266        (count (or p 1)))
    12391267    (pre-command-parse-check point)
    … …  
    12521280;;;
    12531281(defcommand "End of Defun" (p)
    1254   "Move the point to the end of a top-level form.
     1282  "Move the point to the end of a top-level form, collapsing the selection.
    12551283   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-for-movement))
     1284  "Move the point to the end of a top-level form, collapsing the selection."
     1285  (let ((point (current-point-collapsing-selection))
    12581286        (count (or p 1)))
    12591287    (pre-command-parse-check point)
    … …  
    12741302                 (move-mark point m)))))))
    12751303
     1304(defcommand "Select to End of Defun" (p)
     1305  "Move the point to the end of a top-level form, extending the selection.
     1306   With an argument, skips the next p top-level forms."
     1307  "Move the point to the end of a top-level form, extending the selection."
     1308  (let ((point (current-point-extending-selection))
     1309        (count (or p 1)))
     1310    (pre-command-parse-check point)
     1311    (if (minusp count)
     1312        (beginning-of-defun-command (- count))
     1313        (with-mark ((m point)
     1314                    (dummy point))
     1315          (cond ((not (mark-top-level-form m dummy))
     1316                 (editor-error "No current or next top level form."))
     1317                (t
     1318                 (unless (top-level-offset m (1- count))
     1319                   (editor-error "Not enough top level forms."))
     1320                 ;; We might be one unparsed for away.
     1321                 (pre-command-parse-check m)
     1322                 (unless (form-offset m 1)
     1323                   (editor-error "Not enough top level forms."))
     1324                 (when (blank-after-p m) (line-offset m 1 0))
     1325                 (move-mark point m)))))))
     1326
    12761327(defcommand "Forward List" (p)
    1277   "Skip over the next Lisp list.
     1328  "Skip over the next Lisp list, collapsing the selection.
    12781329  With argument, skips the next p lists."
    1279   "Skip over the next Lisp list."
    1280   (let ((point (current-point-for-movement))
     1330  "Skip over the next Lisp list, collapsing the selection."
     1331  (let ((point (current-point-collapsing-selection))
    12811332        (count (or p 1)))
    12821333    (pre-command-parse-check point)
    12831334    (unless (list-offset point count) (editor-error))))
    12841335
     1336(defcommand "Select Forward List" (p)
     1337  "Skip over the next Lisp list, extending the selection.
     1338  With argument, skips the next p lists."
     1339  "Skip over the next Lisp list, extending the selection."
     1340  (let ((point (current-point-extending-selection))
     1341        (count (or p 1)))
     1342    (pre-command-parse-check point)
     1343    (unless (list-offset point count) (editor-error))))
     1344
    12851345(defcommand "Backward List" (p)
    1286   "Skip over the previous Lisp list.
     1346  "Skip over the previous Lisp list, collapsing the selection.
    12871347  With argument, skips the previous p lists."
    1288   "Skip over the previous Lisp list."
    1289   (let ((point (current-point-for-movement))
     1348  "Skip over the previous Lisp list, collapsing the selection."
     1349  (let ((point (current-point-collapsing-selection))
    12901350        (count (- (or p 1))))
    12911351    (pre-command-parse-check point)
    12921352    (unless (list-offset point count) (editor-error))))
    12931353
     1354(defcommand "Select Backward List" (p)
     1355  "Skip over the previous Lisp list, extending the selection.
     1356  With argument, skips the previous p lists."
     1357  "Skip over the previous Lisp list, extending the selection."
     1358  (let ((point (current-point-extending-selection))
     1359        (count (- (or p 1))))
     1360    (pre-command-parse-check point)
     1361    (unless (list-offset point count) (editor-error))))
     1362
    12941363(defcommand "Forward Form" (p)
    1295   "Skip over the next Form.
     1364  "Skip over the next Form, collapsing the selection.
    12961365  With argument, skips the next p Forms."
    1297   "Skip over the next Form."
    1298   (let ((point (current-point-for-movement))
     1366  "Skip over the next Form, collapsing the selection."
     1367  (let ((point (current-point-collapsing-selection))
    12991368        (count (or p 1)))
    13001369    (pre-command-parse-check point)
    13011370    (unless (form-offset point count) (editor-error))))
    13021371
     1372(defcommand "Select Forward Form" (p)
     1373  "Skip over the next Form, extending the selection.
     1374  With argument, skips the next p Forms."
     1375  "Skip over the next Form, extending the selection."
     1376  (let ((point (current-point-extending-selection))
     1377        (count (or p 1)))
     1378    (pre-command-parse-check point)
     1379    (unless (form-offset point count) (editor-error))))
     1380
    13031381(defcommand "Backward Form" (p)
    1304   "Skip over the previous Form.
     1382  "Skip over the previous Form, collapsing the selection.
    13051383  With argument, skips the previous p Forms."
    1306   "Skip over the previous Form."
    1307   (let ((point (current-point-for-movement))
     1384  "Skip over the previous Form, collaspsing the selection."
     1385  (let ((point (current-point-collapsing-selection))
     1386        (count (- (or p 1))))
     1387    (pre-command-parse-check point)
     1388    (unless (form-offset point count) (editor-error))))
     1389
     1390(defcommand "Select Backward Form" (p)
     1391  "Skip over the previous Form, extending the selection.
     1392  With argument, skips the previous p Forms."
     1393  "Skip over the previous Form, extending the selection."
     1394  (let ((point (current-point-extending-selection))
    13081395        (count (- (or p 1))))
    13091396    (pre-command-parse-check point)
    … …  
    15181605  "Move forward past a one containing )."
    15191606  "Move forward past a one containing )."
    1520   (let ((point (current-point-for-movement))
     1607  (let ((point (current-point-collapsing-selection))
    15211608        (count (or p 1)))
    15221609    (pre-command-parse-check point)
    … …  
    15311618  "Move backward past a one containing (."
    15321619  "Move backward past a one containing (."
    1533   (let ((point (current-point-for-movement))
     1620  (let ((point (current-point-collapsing-selection))
    15341621        (count (or p 1)))
    15351622    (pre-command-parse-check point)
    … …  
    15461633   level."
    15471634  "Move down a level in list structure."
    1548   (let ((point (current-point-for-movement))
     1635  (let ((point (current-point-collapsing-selection))
    15491636        (count (or p 1)))
    15501637    (pre-command-parse-check point)

  • branches/working-0708/cocoa-ide/hemlock/src/package.lisp

    r7007 r7025  
    6262   #:current-point-for-deletion
    6363   #:current-point-unless-selection
    64    #:current-point-for-movement
     64   #:current-point-collapsing-selection
     65   #:current-point-extending-selection
    6566   #:current-point
    6667   #:current-mark

  • branches/working-0708/cocoa-ide/hemlock/src/searchcoms.lisp

    r6790 r7025  
    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)
    8385             (editor-error)))))
    … …  
    191193      (case (%i-search-char-eval next-key-event string point trailer
    192194                                 direction failure)
     195        (:mouse-exit
     196         (clear-echo-area)
     197         (throw 'exit-i-search nil))
    193198        (:cancel
    194199         (%i-search-echo-refresh string direction failure)
    … …  
    314319    (cond (found-offset
    315320            (cond ((eq direction :forward)
    316                    (character-offset (move-mark point trailer) found-offset))
     321                   (character-offset (move-mark point trailer) found-offset)
     322                   (push-buffer-mark (copy-mark trailer) t))
    317323                  (t
    318324                   (move-mark point trailer)

  • branches/working-0708/compiler/arch.lisp

    r5529 r7025  
    2828(defconstant tcr-flag-bit-foreign 0)
    2929(defconstant tcr-flag-bit-awaiting-preset 1)
     30(defconstant tcr-flag-bit-alt-suspend 2)
     31(defconstant tcr-flag-bit-propagate-exception 3)
     32(defconstant tcr-flag-bit-suspend-ack-pending 4)
     33(defconstant tcr-flag-bit-pending-exception 5)
     34(defconstant tcr-flag-bit-foreign-exception 6)
     35(defconstant tcr-flag-bit-pending-suspend 7)       
    3036
    3137

  • branches/working-0708/darwin-x86-headers64/libc/C/populate.sh

    r5904 r7025  
    11#!/bin/sh
    2 SDK=/Developer/SDKs/MacOSX10.4u.sdk
     2SDK=/Developer/SDKs/MacOSX10.5.sdk
    33if [ $# -eq 1 ]
    44then
    … …  
    618618h-to-ffi.sh -include ${SDK}/usr/include/sys/types.h ${SDK}/usr/include/vis.h
    619619h-to-ffi.sh ${SDK}/usr/include/zconf.h
     620h-to-ffi.sh ${SDK}/usr/include/sys/xattr.h
    620621h-to-ffi.sh ${SDK}/usr/include/zlib.h
     622

  • branches/working-0708/level-0/X86/x86-misc.lisp

    r6568 r7025  
    765765  (single-value-return))
    766766
     767(defx86lapfunction %check-deferred-gc ()
     768  (btq ($ (+ arch::tcr-flag-bit-pending-suspend target::fixnumshift)) (@ (% :rcontext) x8664::tcr.flags))
     769  (movl ($ x8664::nil-value) (% arg_z.l))
     770  (jae @done)
     771  (ud2a)
     772  (:byte 3)
     773  (movl ($ x8664::t-value) (% arg_z.l))
     774  @done
     775  (single-value-return))
     776
    767777;;; end of x86-misc.lisp

  • branches/working-0708/level-0/l0-hash.lisp

    r6918 r7025  
    569569
    570570
    571 
     571(defun lock-hash-table (hash)
     572  (let* ((lock (nhash.exclusion-lock hash)))
     573    (if lock
     574      (write-lock-rwlock lock)
     575      (progn (unless (eq (nhash.owner hash) *current-process*)
     576               (allowing-deferred-gc (error "Not owner of hash table ~s" hash)))))))
     577
     578(defun unlock-hash-table (hash)
     579  (let* ((lock (nhash.exclusion-lock hash)))
     580    (if lock
     581      (unlock-rwlock lock))))
    572582
    573583
    … …  
    654664
    655665
    656 (defun lock-hash-table (hash)
    657   (let* ((lock (nhash.exclusion-lock hash)))
    658     (if lock
    659       (write-lock-rwlock lock)
    660       (progn (unless (eq (nhash.owner hash) *current-process*)
    661                (error "Not owner of hash table ~s" hash))))))
    662 
    663 (defun unlock-hash-table (hash)
    664   (let* ((lock (nhash.exclusion-lock hash)))
    665     (if lock
    666       (unlock-rwlock lock))))
     666
    667667
    668668(defun gethash (key hash &optional default)
    … …  
    674674  (let* ((value nil)
    675675         (vector-key nil)
    676          (gc-locked nil)
    677676         (foundp nil))
    678     (without-interrupts
    679      (lock-hash-table hash)
    680      (let* ((vector (nhash.vector hash)))
    681        (if (and (eq key (nhash.vector.cache-key vector))
    682                 ;; Check twice: the GC might nuke the cached key/value pair
    683                 (progn (setq value (nhash.vector.cache-value vector))
    684                        (eq key (nhash.vector.cache-key vector))))
    685          (setq foundp t)
    686          (loop
    687            (let* ((vector-index (funcall (nhash.find hash) hash key)))
    688              (declare (fixnum vector-index))
    689              ;; Referencing both key and value here - and referencing
    690              ;; value first - is an attempt to compensate for the
    691              ;; possibility that the GC deletes a weak-on-key pair.
    692              (setq value (%svref vector (the fixnum (1+ vector-index)))
    693                    vector-key (%svref vector vector-index))
    694              (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
    695                                       (not (eq vector-key deleted-hash-key-marker))))
    696                     (setf (nhash.vector.cache-key vector) vector-key
    697                           (nhash.vector.cache-value vector) value
    698                           (nhash.vector.cache-idx vector) (vector-index->index
    699                                                            vector-index))
    700                     (return))
    701                ((%needs-rehashing-p hash)
    702                 (setq gc-locked t)
    703                 (%lock-gc-lock)
    704                 (%rehash hash))
    705                (t (return)))))))
    706      (when gc-locked (%unlock-gc-lock))
    707      (unlock-hash-table hash))
     677    (with-deferred-gc
     678        (lock-hash-table hash)
     679      (when (%needs-rehashing-p hash)
     680        (%rehash hash))
     681      (let* ((vector (nhash.vector hash)))
     682        (if (and (eq key (nhash.vector.cache-key vector))
     683                 ;; Check twice: the GC might nuke the cached key/value pair
     684                 (setq value (nhash.vector.cache-value vector)))
     685          (setq foundp t)
     686          (let* ((vector-index (funcall (nhash.find hash) hash key)))
     687            (declare (fixnum vector-index))
     688            ;; Referencing both key and value here - and referencing
     689            ;; value first - is an attempt to compensate for the
     690            ;; possibility that the GC deletes a weak-on-key pair.
     691            (setq value (%svref vector (the fixnum (1+ vector-index)))
     692                  vector-key (%svref vector vector-index))
     693            (when (setq foundp (and (not (eq vector-key free-hash-key-marker))
     694                                    (not (eq vector-key deleted-hash-key-marker))))
     695              (setf (nhash.vector.cache-key vector) vector-key
     696                    (nhash.vector.cache-value vector) value
     697                    (nhash.vector.cache-idx vector) (vector-index->index
     698                                                     vector-index)))))
     699        (unlock-hash-table hash)))
    708700    (if foundp
    709701      (values value t)
    … …  
    716708    (setq hash (require-type hash 'hash-table)))
    717709  (let* ((foundp nil))
    718     (without-interrupts
     710    (with-deferred-gc
    719711     (lock-hash-table hash)
    720      (%lock-gc-lock)
    721712     (when (%needs-rehashing-p hash)
    722713       (%rehash hash))   
    … …  
    729720                        (the fixnum (nhash.vector.cache-idx vector)))
    730721               (unlock-hash-table hash)
    731                (%unlock-gc-lock)
    732                (error "Can't remove key ~s during iteration on hash-table ~s"
    733                       key hash)))
     722               (allowing-deferred-gc
     723                (error "Can't remove key ~s during iteration on hash-table ~s"
     724                      key hash))))
    734725           (setf (nhash.vector.cache-key vector) free-hash-key-marker
    735726                 (nhash.vector.cache-value vector) nil)
    … …  
    750741                          (the fixnum (vector-index->index vector-index)))
    751742                 (unlock-hash-table hash)
    752                  (%unlock-gc-lock)
    753                  (error "Can't remove key ~s during iteration on hash-table ~s"
    754                         key hash)))
     743                 (allowing-deferred-gc
     744                  (error "Can't remove key ~s during iteration on hash-table ~s"
     745                         key hash))))
    755746             ;; always clear the cache cause I'm too lazy to call the
    756747             ;; comparison function and don't want to keep a possibly
    … …  
    781772               (nhash.vector.weak-deletions-count vector) 0)))
    782773     ;; Return T if we deleted something
    783      (%unlock-gc-lock)
    784774     (unlock-hash-table hash))
    785775    foundp))
    … …  
    789779  (unless (hash-table-p hash)
    790780    (report-bad-arg hash 'hash-table))
    791   (without-interrupts
     781  (with-deferred-gc
    792782   (block protected
    793783     (tagbody
    794784        (lock-hash-table hash)
    795785        AGAIN
    796         (%lock-gc-lock)
    797786        (when (%needs-rehashing-p hash)
    798787          (%rehash hash))
    … …  
    806795                       (not (funcall test (%svref vector index) key)))
    807796              (unlock-hash-table hash)
    808               (%unlock-gc-lock)
    809               (error "Can't add key ~s during iteration on hash-table ~s"
    810                      key hash))))
     797              (allowing-deferred-gc
     798               (error "Can't add key ~s during iteration on hash-table ~s"
     799                      key hash)))))
    811800        (let ((vector (nhash.vector  hash)))     
    812801          (when (eq key (nhash.vector.cache-key vector))
    … …  
    836825                  ((eq old-value free-hash-key-marker)
    837826                   (when (eql 0 (nhash.grow-threshold hash))
    838                      (%unlock-gc-lock)
    839827                     (grow-hash-table hash)
    840828                     (go AGAIN))
    … …  
    849837                  (nhash.vector.cache-key vector) key
    850838                  (nhash.vector.cache-value vector) value)))))
    851    (%unlock-gc-lock)
    852839   (unlock-hash-table hash))
    853840  value)
    … …  
    912899                    (nhash.vector.flags old-vector) flags-sans-weak)      ; disable GC weak stuff
    913900              (%normalize-hash-table-count hash)
    914               (setq vector (%cons-nhash-vector total-size 0))
     901              (setq vector (allowing-deferred-gc (%cons-nhash-vector total-size 0)))
    915902              (do* ((index 0 (1+ index))
    916903                    (vector-index (index->vector-index 0) (+ vector-index 2)))
    … …  
    12561243                 (>= (uvsize rehash-bits) size))
    12571244      (return-from %make-rehash-bits
    1258         (setf (nhash.rehash-bits hash) (make-array size :element-type 'bit :initial-element 0))))
     1245        (setf (nhash.rehash-bits hash) (allowing-deferred-gc (make-array size :element-type 'bit :initial-element 0)))))
    12591246    (fill (the simple-bit-vector rehash-bits) 0)))
    12601247

  • branches/working-0708/level-0/l0-io.lisp

    r6181 r7025  
    3131
    3232
    33 ; write nbytes bytes from buffer buf to file-descriptor fd.
     33(defun utf-8-octets-in-string (string start end)
     34  (if (>= end start)
     35    (do* ((noctets 0)
     36          (i start (1+ i)))
     37         ((= i end) noctets)
     38      (declare (fixnum noctets))
     39      (let* ((code (char-code (schar string i))))
     40        (declare (type (mod #x110000) code))
     41        (incf noctets
     42              (if (< code #x80)
     43                1
     44                (if (< code #x800)
     45                  2
     46                  (if (< code #x10000)
     47                    3
     48                    4))))))
     49    0))
     50
     51(defun utf-8-memory-encode (string pointer idx start end)
     52  (declare (fixnum idx))
     53  (do* ((i start (1+ i)))
     54       ((>= i end) idx)
     55    (let* ((code (char-code (schar string i))))
     56      (declare (type (mod #x110000) code))
     57      (cond ((< code #x80)
     58             (setf (%get-unsigned-byte pointer idx) code)
     59             (incf idx))
     60            ((< code #x800)
     61             (setf (%get-unsigned-byte pointer idx)
     62                   (logior #xc0 (the fixnum (ash code -6))))
     63             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     64                   (logior #x80 (the fixnum (logand code #x3f))))
     65             (incf idx 2))
     66            ((< code #x10000)
     67             (setf (%get-unsigned-byte pointer idx)
     68                   (logior #xe0 (the fixnum (ash code -12))))
     69             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     70                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
     71             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
     72                   (logior #x80 (the fixnum (logand code #x3f))))
     73             (incf idx 3))
     74            (t
     75             (setf (%get-unsigned-byte pointer idx)
     76                   (logior #xf0
     77                           (the fixnum (logand #x7 (the fixnum (ash code -18))))))
     78             (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
     79                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
     80             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
     81                   (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
     82             (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
     83                   (logand #x3f code))
     84             (incf idx 4))))))
     85
     86(defun utf-8-memory-decode (pointer noctets idx string)
     87  (declare (fixnum noctets idx))
     88  (do* ((i 0 (1+ i))
     89        (end (+ idx noctets))
     90        (index idx (1+ index)))
     91       ((>= index end) (if (= index end) index 0))
     92    (let* ((1st-unit (%get-unsigned-byte pointer index)))
     93      (declare (type (unsigned-byte 8) 1st-unit))
     94      (let* ((char (if (< 1st-unit #x80)
     95                     (code-char 1st-unit)
     96                     (if (>= 1st-unit #xc2)
     97                       (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
     98                         (declare (type (unsigned-byte 8) 2nd-unit))
     99                         (if (< 1st-unit #xe0)
     100                           (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     101                             (code-char
     102                              (logior
     103                               (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
     104                               (the fixnum (logxor 2nd-unit #x80)))))
     105                           (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
     106                             (declare (type (unsigned-byte 8) 3rd-unit))
     107                             (if (< 1st-unit #xf0)
     108                               (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     109                                        (< (the fixnum (logxor 3rd-unit #x80)) #x40)
     110                                        (or (>= 1st-unit #xe1)
     111                                            (>= 2nd-unit #xa0)))
     112                                 (code-char (the fixnum
     113                                              (logior (the fixnum
     114                                                        (ash (the fixnum (logand 1st-unit #xf))
     115                                                             12))
     116                                                      (the fixnum
     117                                                        (logior
     118                                                         (the fixnum
     119                                                           (ash (the fixnum (logand 2nd-unit #x3f))
     120                                                                6))
     121                                                         (the fixnum (logand 3rd-unit #x3f))))))))
     122                               (if (< 1st-unit #xf8)
     123                                 (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
     124                                   (declare (type (unsigned-byte 8) 4th-unit))
     125                                   (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
     126                                            (< (the fixnum (logxor 3rd-unit #x80)) #x40)
     127                                            (< (the fixnum (logxor 4th-unit #x80)) #x40)
     128                                            (or (>= 1st-unit #xf1)
     129                                                (>= 2nd-unit #x90)))
     130                                     (code-char
     131                                      (logior
     132                                       (the fixnum
     133                                         (logior
     134                                          (the fixnum
     135                                            (ash (the fixnum (logand 1st-unit 7)) 18))
     136                                          (the fixnum
     137                                            (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
     138                                       (the fixnum
     139                                         (logior
     140                                          (the fixnum
     141                                            (ash (the fixnum (logxor 3rd-unit #x80)) 6))
     142                                          (the fixnum (logxor 4th-unit #x80)))))))))))))))))
     143        (setf (schar string i) (or char #\Replacement_Character))))))
     144
     145(defun utf-8-length-of-memory-encoding (pointer noctets start)
     146  (do* ((i start)
     147        (end (+ start noctets))
     148        (nchars 0 (1+ nchars)))
     149       ((= i end) (values nchars i))
     150    (let* ((code (%get-unsigned-byte pointer i))
     151           (nexti (+ i (cond ((< code #x80) 1)
     152                             ((< code #xe0) 2)
     153                             ((< code #xf0) 3)
     154                             (t 4)))))
     155      (declare (type (unsigned-byte 8) code))
     156      (if (> nexti end)
     157        (return (values nchars i))
     158        (setq i nexti)))))
     159
     160
     161
     162;;; write nbytes bytes from buffer buf to file-descriptor fd.
    34163(defun fd-write (fd buf nbytes)
    35164  (syscall syscalls::write fd buf nbytes))
    … …  
    42171
    43172(defun fd-open (path flags &optional (create-mode #o666))
    44   (with-cstrs ((p path))
     173  (with-utf-8-cstrs ((p path))
    45174    (syscall syscalls::open p flags create-mode)))
    46175

  • branches/working-0708/level-0/l0-misc.lisp

    r6917 r7025  
    275275         (stack-free)
    276276         (stack-used-by-thread nil))
    277     (with-other-threads-suspended
    278         (without-gcing
    279          (setq freebytes (%freebytes))
    280          (when verbose
    281            (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)
    282              (%usedbytes))
    283            (setq lispheap (+ freebytes usedbytes)
    284                  reserved (%reservedbytes)
    285                  static (+ static-used staticlib-used hons-space-size))
    286            (multiple-value-setq (stack-total stack-used stack-free)
    287              (%stack-space))
    288            (unless (eq verbose :default)
    289              (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
     277    (progn
     278      (progn
     279        (setq freebytes (%freebytes))
     280        (when verbose
     281          (multiple-value-setq (usedbytes static-used staticlib-used hons-space-size)
     282            (%usedbytes))
     283          (setq lispheap (+ freebytes usedbytes)
     284                reserved (%reservedbytes)
     285                static (+ static-used staticlib-used hons-space-size))
     286          (multiple-value-setq (stack-total stack-used stack-free)
     287            (%stack-space))
     288          (unless (eq verbose :default)
     289            (setq stack-used-by-thread (%stack-space-by-lisp-thread))))))
    290290    (format t "~&Approximately ~:D bytes of memory can be allocated ~%before the next full GC is triggered. ~%" freebytes)
    291291    (when verbose
    … …  
    390390    (declare (fixnum end))))
    391391
     392(defun %get-utf-8-cstring (pointer)
     393  (do* ((end 0 (1+ end)))
     394       ((zerop (the (unsigned-byte 8) (%get-unsigned-byte pointer end)))
     395        (let* ((len (utf-8-length-of-memory-encoding pointer end 0))
     396               (string (make-string len)))
     397          (utf-8-memory-decode pointer end 0 string)
     398          string))
     399    (declare (fixnum end))))
     400
    392401;;; This is mostly here so we can bootstrap shared libs without
    393402;;; having to bootstrap #_strcmp.

  • branches/working-0708/level-1/l1-unicode.lisp

    r6945 r7025  
    28622862               (setf (schar string i) (or char #\Replacement_Character)))))))
    28632863    :memory-encode-function
    2864     (nfunction
    2865      utf-8-memory-encode
    2866      (lambda (string pointer idx start end)
    2867        (declare (fixnum idx))
    2868        (do* ((i start (1+ i)))
    2869             ((>= i end) idx)
    2870          (let* ((code (char-code (schar string i))))
    2871            (declare (type (mod #x110000) code))
    2872            (cond ((< code #x80)
    2873                   (setf (%get-unsigned-byte pointer idx) code)
    2874                   (incf idx))
    2875                  ((< code #x800)
    2876                   (setf (%get-unsigned-byte pointer idx)
    2877                         (logior #xc0 (the fixnum (ash code -6))))
    2878                   (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
    2879                         (logior #x80 (the fixnum (logand code #x3f))))
    2880                   (incf idx 2))
    2881                  ((< code #x10000)
    2882                   (setf (%get-unsigned-byte pointer idx)
    2883                         (logior #xe0 (the fixnum (ash code -12))))
    2884                   (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
    2885                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
    2886                   (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
    2887                         (logior #x80 (the fixnum (logand code #x3f))))
    2888                   (incf idx 3))
    2889                  (t
    2890                   (setf (%get-unsigned-byte pointer idx)
    2891                         (logior #xf0
    2892                                 (the fixnum (logand #x7 (the fixnum (ash code -18))))))
    2893                   (setf (%get-unsigned-byte pointer (the fixnum (1+ idx)))
    2894                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -12))))))
    2895                   (setf (%get-unsigned-byte pointer (the fixnum (+ idx 2)))
    2896                         (logior #x80 (the fixnum (logand #x3f (the fixnum (ash code -6))))))
    2897                   (setf (%get-unsigned-byte pointer (the fixnum (+ idx 3)))
    2898                         (logand #x3f code))
    2899                   (incf idx 4)))))))
     2864    #'utf-8-memory-encode
    29002865    :memory-decode-function
    2901     (nfunction
    2902      utf-8-memory-decode
    2903      (lambda (pointer noctets idx string)
    2904        (declare (fixnum noctets idx))
    2905        (do* ((i 0 (1+ i))
    2906              (end (+ idx noctets))
    2907              (index idx (1+ index)))
    2908             ((>= index end) (if (= index end) index 0))
    2909          (let* ((1st-unit (%get-unsigned-byte pointer index)))
    2910            (declare (type (unsigned-byte 8) 1st-unit))
    2911            (let* ((char (if (< 1st-unit #x80)
    2912                           (code-char 1st-unit)
    2913                           (if (>= 1st-unit #xc2)
    2914                             (let* ((2nd-unit (%get-unsigned-byte pointer (incf index))))
    2915                               (declare (type (unsigned-byte 8) 2nd-unit))
    2916                               (if (< 1st-unit #xe0)
    2917                                 (if (< (the fixnum (logxor 2nd-unit #x80)) #x40)
    2918                                   (code-char
    2919                                    (logior
    2920                                     (the fixnum (ash (the fixnum (logand #x1f 1st-unit)) 6))
    2921                                     (the fixnum (logxor 2nd-unit #x80)))))
    2922                                 (let* ((3rd-unit (%get-unsigned-byte pointer (incf index))))
    2923                                   (declare (type (unsigned-byte 8) 3rd-unit))
    2924                                   (if (< 1st-unit #xf0)
    2925                                     (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
    2926                                              (< (the fixnum (logxor 3rd-unit #x80)) #x40)
    2927                                              (or (>= 1st-unit #xe1)
    2928                                                  (>= 2nd-unit #xa0)))
    2929                                       (code-char (the fixnum
    2930                                                    (logior (the fixnum
    2931                                                              (ash (the fixnum (logand 1st-unit #xf))
    2932                                                                   12))
    2933                                                            (the fixnum
    2934                                                              (logior
    2935                                                               (the fixnum
    2936                                                                 (ash (the fixnum (logand 2nd-unit #x3f))
    2937                                                                      6))
    2938                                                               (the fixnum (logand 3rd-unit #x3f))))))))
    2939                                     (if (< 1st-unit #xf8)
    2940                                       (let* ((4th-unit (%get-unsigned-byte pointer (incf index))))
    2941                                         (declare (type (unsigned-byte 8) 4th-unit))
    2942                                         (if (and (< (the fixnum (logxor 2nd-unit #x80)) #x40)
    2943                                                  (< (the fixnum (logxor 3rd-unit #x80)) #x40)
    2944                                                  (< (the fixnum (logxor 4th-unit #x80)) #x40)
    2945                                                  (or (>= 1st-unit #xf1)
    2946                                                      (>= 2nd-unit #x90)))
    2947                                           (code-char
    2948                                            (logior
    2949                                             (the fixnum
    2950                                               (logior
    2951                                                (the fixnum
    2952                                                  (ash (the fixnum (logand 1st-unit 7)) 18))
    2953                                                (the fixnum
    2954                                                  (ash (the fixnum (logxor 2nd-unit #x80)) 12))))
    2955                                             (the fixnum
    2956                                               (logior
    2957                                                (the fixnum
    2958                                                  (ash (the fixnum (logxor 3rd-unit #x80)) 6))
    2959                                                (the fixnum (logxor 4th-unit #x80)))))))))))))))))
    2960              (setf (schar string i) (or char #\Replacement_Character)))))))
     2866    #'utf-8-memory-decode
    29612867    :octets-in-string-function
    2962     (nfunction
    2963      utf-8-octets-in-string
    2964      (lambda (string start end)
    2965        (if (>= end start)
    2966          (do* ((noctets 0)
    2967                (i start (1+ i)))
    2968               ((= i end) noctets)
    2969            (declare (fixnum noctets))
    2970            (let* ((code (char-code (schar string i))))
    2971              (declare (type (mod #x110000) code))
    2972              (incf noctets
    2973                    (if (< code #x80)
    2974                      1
    2975                      (if (< code #x800)
    2976                        2
    2977                        (if (< code #x10000)
    2978                          3
    2979                          4))))))
    2980          0)))
     2868    #'utf-8-octets-in-string
    29812869    :length-of-vector-encoding-function
    29822870    (nfunction
    … …  
    29992887             (setq nchars (1+ nchars) i nexti))))))
    30002888    :length-of-memory-encoding-function
    3001     (nfunction
    3002      utf-8-length-of-memory-encoding
    3003      (lambda (pointer noctets start)
    3004        (do* ((i start)
    3005              (end (+ start noctets))
    3006              (nchars 0 (1+ nchars)))
    3007             ((= i end) (values nchars i))
    3008          (let* ((code (%get-unsigned-byte pointer i))
    3009                 (nexti (+ i (cond ((< code #x80) 1)
    3010                                   ((< code #xe0) 2)
    3011                                   ((< code #xf0) 3)
    3012                                   (t 4)))))
    3013            (declare (type (unsigned-byte 8) code))
    3014            (if (> nexti end)
    3015              (return (values nchars i))
    3016              (setq i nexti))))))
     2889    #'utf-8-length-of-memory-encoding
    30172890    :decode-literal-code-unit-limit #x80
    30182891    :encode-literal-char-code-limit #x80   

  • branches/working-0708/level-1/linux-files.lisp

    r6947 r7025  
    156156                     ((< len bufsize)
    157157                      (setf (%get-unsigned-byte buf len) 0)
    158                       (values (%get-cstring buf) len))
     158                      (values (%get-utf-8-cstring buf) len))
    159159                     (t (values nil len)))))))
    160160    (do* ((string nil)
    … …  
    176176
    177177(defun %chdir (dirname)
    178   (with-cstrs ((dirname dirname))
     178  (with-utf-8-cstrs ((dirname dirname))
    179179    (syscall syscalls::chdir dirname)))
    180180
    181181(defun %mkdir (name mode)
    182   (let* ((last (1- (length name))))
    183     (with-cstrs ((name name))
    184       (when (and (>= last 0)
    185                  (eql (%get-byte name last) (char-code #\/)))
    186         (setf (%get-byte name last) 0))
    187     (syscall syscalls::mkdir name mode))))
     182  (let* ((name name)
     183         (len (length name)))
     184    (when (and (> len 0) (eql (char name (1- len)) #\/))
     185      (setq name (subseq name 0 (1- len))))
     186    (with-utf-8-cstrs ((name name))
     187      (syscall syscalls::mkdir name mode))))
    188188
    189189(defun getenv (key)
    … …  
    239239
    240240(defun %%stat (name stat)
    241   (with-cstrs ((cname name))
     241  (with-utf-8-cstrs ((cname name))
    242242    (%stat-values
    243243     #+linux-target
    … …  
    256256
    257257(defun %%lstat (name stat)
    258   (with-cstrs ((cname name))
     258  (with-utf-8-cstrs ((cname name))
    259259    (%stat-values
    260260     #+linux-target
    … …  
    369369    (setq namestring (current-directory-name)))
    370370  (%stack-block ((resultbuf #$PATH_MAX))
    371     (with-cstrs ((name (tilde-expand namestring)))
     371    (with-utf-8-cstrs ((name namestring #|(tilde-expand namestring)|#))
    372372      (let* ((result (#_realpath name resultbuf)))
    373373        (declare (dynamic-extent result))
    374374        (unless (%null-ptr-p result)
    375           (%get-cstring result))))))
     375          (%get-utf-8-cstring result))))))
    376376
    377377;;; Return fully resolved pathname & file kind, or (values nil nil)
    … …  
    428428
    429429(defun %utimes (namestring)
    430   (with-cstrs ((cnamestring namestring))
     430  (with-utf-8-cstrs ((cnamestring namestring))
    431431    (let* ((err (#_utimes cnamestring (%null-ptr))))
    432432      (declare (fixnum err))
    … …  
    446446
    447447(defun %open-dir (namestring)
    448   (with-cstrs ((name namestring))
     448  (with-utf-8-cstrs ((name namestring))
    449449    (let* ((DIR (#_opendir name)))
    450450      (unless (%null-ptr-p DIR)
    … …  
    457457  (let* ((res (#_readdir dir)))
    458458    (unless (%null-ptr-p res)       
    459       (%get-cstring (pref res :dirent.d_name)))))
     459      (%get-utf-8-cstring (pref res :dirent.d_name)))))
    460460
    461461(defun tcgetpgrp (fd)
    … …  
    481481        (let* ((err (#_getpwuid_r userid pwd buf buflen result)))
    482482          (if (eql 0 err)
    483             (return (%get-cstring (pref pwd :passwd.pw_dir)))
     483            (return (%get-utf-8-cstring (pref pwd :passwd.pw_dir)))
    484484            (unless (eql err #$ERANGE)
    485485              (return nil))))))))

  • branches/working-0708/lib/hash.lisp

    r2584 r7025  
    226226       (%rehash hash)))))
    227227 
    228 ;;; this is as fast as the lappy version
    229228
    230229(defun do-hash-table-iteration (state)

  • branches/working-0708/lib/macros.lisp

    r6929 r7025  
    15811581             ,@body))))))
    15821582
     1583(defmacro with-utf-8-cstr ((sym str) &body body)
     1584  (let* ((data (gensym))
     1585         (offset (gensym))
     1586         (string (gensym))
     1587         (len (gensym))
     1588         (noctets (gensym))
     1589         (end (gensym)))
     1590    `(let* ((,string ,str)
     1591            (,len (length ,string)))
     1592      (multiple-value-bind (,data ,offset) (array-data-and-offset ,string)
     1593        (let* ((,end (+ ,offset ,len))
     1594               (,noctets (utf-8-octets-in-string ,data ,offset ,end)))
     1595          (%stack-block ((,sym (1+ ,noctets)))
     1596            (utf-8-memory-encode ,data ,sym 0 ,offset ,end)
     1597            (setf (%get-unsigned-byte ,sym ,noctets) 0)
     1598            ,@body))))))
     1599
    15831600
    15841601
    … …  
    15921609(defmacro with-cstrs (speclist &body body)
    15931610   (with-specs-aux 'with-cstr speclist body))
     1611
     1612(defmacro with-utf-8-cstrs (speclist &body body)
     1613   (with-specs-aux 'with-utf-8-cstr speclist body))
    15941614
    15951615(defmacro with-encoded-cstr ((encoding-name (sym string &optional start end))
    … …  
    25742594      `(let* ((,htab ,hash-table)
    25752595              (,state (vector nil nil nil
    2576                               nil nil)))
     2596                              nil nil nil nil)))
    25772597        (declare (dynamic-extent ,state))
    25782598        (unwind-protect
    … …  
    29883008      ,@body)
    29893009    (%unlock-gc-lock)))
     3010
     3011(defmacro with-deferred-gc (&body body)
     3012  "Execute BODY without responding to the signal used to suspend
     3013threads for GC.  BODY must be very careful not to do anything which
     3014could cause an exception (note that attempting to allocate lisp memory
     3015may cause an exception.)"
     3016  `(let* ((*interrupt-level* -2))
     3017    ,@body))
     3018
     3019(defmacro allowing-deferred-gc (&body body)
     3020  "Within the extent of a surrounding WITH-DEFERRED-GC, allow GC."
     3021  `(let* ((*interrupt-level* -1))
     3022    (%check-deferred-gc)
     3023    ,@body))
     3024 
     3025
    29903026
    29913027(defmacro with-pointer-to-ivector ((ptr ivector) &body body)

  • branches/working-0708/lisp-kernel/darwinx8664/Makefile

    r6034 r7025  
    8585
    8686OSEARLYLIBS = -lcrt1.o
    87 OSLATELIBS = -lSystem
     87OSLATELIBS = -lSystem -licucore
    8888
    8989OSMIDDLELIBS =

  • branches/working-0708/lisp-kernel/thread_manager.c

    r6904 r7025  
    298298  TCR *tcr = get_interrupt_tcr(false);
    299299
    300   if (signo == thread_suspend_signal) {
     300  if (TCR_INTERRUPT_LEVEL(tcr) <= (-2<<fixnumshift)) {
     301    SET_TCR_FLAG(tcr,TCR_FLAG_BIT_PENDING_SUSPEND);
     302  } else {
     303    if (signo == thread_suspend_signal) {
    301304#if 0
    302     sigset_t wait_for;
    303 #endif
    304 
    305     tcr->suspend_context = context;
     305      sigset_t wait_for;
     306#endif
     307
     308      tcr->suspend_context = context;
    306309#if 0
    307     sigfillset(&wait_for);
    308 #endif
    309     SEM_RAISE(tcr->suspend);
     310      sigfillset(&wait_for);
     311#endif
     312      SEM_RAISE(tcr->suspend);
    310313#if 0
    311     sigdelset(&wait_for, thread_resume_signal);
     314      sigdelset(&wait_for, thread_resume_signal);
    312315#endif
    313316#if 1
    314317#if RESUME_VIA_RESUME_SEMAPHORE
    315     SEM_WAIT_FOREVER(tcr->resume);
     318      SEM_WAIT_FOREVER(tcr->resume);
    316319#if SUSPEND_RESUME_VERBOSE
    317     fprintf(stderr, "got  resume in 0x%x\n",tcr);
    318 #endif
    319     tcr->suspend_context = NULL;
     320      fprintf(stderr, "got  resume in 0x%x\n",tcr);
     321#endif
     322      tcr->suspend_context = NULL;
    320323#else
    321     sigsuspend(&wait_for);
     324      sigsuspend(&wait_for);
    322325#endif
    323326#else
    … …  
    326329    } while (tcr->suspend_context);
    327330#endif 
    328   } else {
    329     tcr->suspend_context = NULL;
     331    } else {
     332      tcr->suspend_context = NULL;
    330333#if SUSEPEND_RESUME_VERBOSE
    331     fprintf(stderr,"got  resume in in 0x%x\n",tcr);
    332 #endif
    333   }
     334      fprintf(stderr,"got  resume in in 0x%x\n",tcr);
     335#endif
     336    }
    334337#if WAIT_FOR_RESUME_ACK
    335   SEM_RAISE(tcr->suspend);
    336 #endif
     338    SEM_RAISE(tcr->suspend);
     339#endif
     340  }
    337341#ifdef DARWIN_GS_HACK
    338342  if (gs_was_tcr) {

  • branches/working-0708/lisp-kernel/x86-asmutils64.s

    r6520 r7025  
    173173       
    174174        __ifdef([DARWIN_GS_HACK])
    175 /* Check (in and ugly, non-portale way) to see if %gs is addressing
     175/* Check (in and ugly, non-portable way) to see if %gs is addressing
    176176   pthreads data.  If it was, return 0; otherwise, assume that it's
    177177   addressing a lisp tcr and set %gs to point to the tcr's tcr.osid,

  • branches/working-0708/lisp-kernel/x86-constants.h

    r6905 r7025  
    2525#define TCR_FLAG_BIT_PENDING_EXCEPTION (fixnumshift+5)
    2626#define TCR_FLAG_BIT_FOREIGN_EXCEPTION (fixnumshift+6)
     27#define TCR_FLAG_BIT_PENDING_SUSPEND (fixnumshift+7)
    2728#define TCR_STATE_FOREIGN (1)
    2829#define TCR_STATE_LISP    (0)

  • branches/working-0708/lisp-kernel/x86-constants64.s

    r6907 r7025  
    753753TCR_FLAG_BIT_PENDING_EXCEPTION = (fixnumshift+5)
    754754TCR_FLAG_BIT_FOREIGN_EXCEPTION = (fixnumshift+6)
     755TCR_FLAG_BIT_PENDING_SUSPEND = (fixnumshift+7)       
    755756       
    756757target_most_positive_fixnum = 1152921504606846975

  • branches/working-0708/lisp-kernel/x86-exceptions.c

    r6908 r7025  
    962962  old_valence = prepare_to_wait_for_exception_lock(tcr, context);
    963963#endif
     964  if (tcr->flags & (1<<TCR_FLAG_BIT_PENDING_SUSPEND)) {
     965    CLR_TCR_FLAG(tcr, TCR_FLAG_BIT_PENDING_SUSPEND);
     966    pthread_kill(pthread_self(), thread_suspend_signal);
     967  }
    964968  wait_for_exception_lock_in_handler(tcr,context, &xframe_link);
    965969

  • branches/working-0708/lisp-kernel/x86-exceptions.h

    r6527 r7025  
    9999#define XUUO_TLB_TOO_SMALL 1
    100100#define XUUO_INTERRUPT_NOW 2
     101#define XUUO_SUSPEND_NOW 3
    101102
    102103void

  • branches/working-0708/lisp-kernel/x86-spentry64.s

    r6909 r7025  
    24482448        __(_car(%arg_z,%arg_x))
    24492449        __(_cdr(%arg_z,%arg_z))
    2450         __(addl $node_size,%imm0_l)
     2450        __(addw $node_size,%imm0_w)
     2451        __(js 8f)
    24512452        __(compare_reg_to_nil(%arg_z))
    24522453        __(push %arg_x)
    24532454        __(jne 1b)
    245424552:      __(addw %imm0_w,%nargs)
     2456        __(js 8f)
    24552457        __(jne 4f)
    245624583:      __(addq $2*node_size,%rsp)
    … …  
    24662468        __(je 3b)
    24672469        __(jmp *%ra0)
     2470/* Discard everything that's been pushed already, complain   */
     24718:      __(lea (%rsp,%imm0),%rsp)
     2472        __(movq %arg_y,%arg_z)  /* recover original   */
     2473        __(movq $XTMINPS,%arg_y)
     2474        __(set_nargs(2))
     2475        __(push %ra0)
     2476        __(jmp _SPksignalerr)
    24682477/* Discard everything that's been pushed already, complain   */
    246924789:      __(lea (%rsp,%imm0),%rsp)
    … …  
    34623471       
    34633472_spentry(unbind_interrupt_level)
     3473        __(btq $TCR_FLAG_BIT_PENDING_SUSPEND,%rcontext:tcr.flags)
    34643474        __(movq %rcontext:tcr.db_link,%imm1)
    34653475        __(movq %rcontext:tcr.tlb_pointer,%arg_x)
    34663476        __(movq INTERRUPT_LEVEL_BINDING_INDEX(%arg_x),%imm0)
    3467         __(testq %imm0,%imm0)
     3477        __(jc 5f)
     34780:      __(testq %imm0,%imm0)
    34683479        __(movq binding.val(%imm1),%temp0)
    34693480        __(movq binding.link(%imm1),%imm1)
    34703481        __(movq %temp0,INTERRUPT_LEVEL_BINDING_INDEX(%arg_x))
    34713482        __(movq %imm1,%rcontext:tcr.db_link)
    3472         __(js,pn 1f)
    3473 0:      __(repret)
    3474 1:      __(testq %temp0,%temp0)
    3475         __(js 0b)
    3476         __(check_pending_enabled_interrupt(2f))
    3477 2:      __(repret)     
     3483        __(js,pn 3f)
     34842:      __(repret)
     34853:      __(testq %temp0,%temp0)
     3486        __(js 2b)
     3487        __(check_pending_enabled_interrupt(4f))
     34884:      __(repret)
     34895:       /* Missed a suspend request; force suspend now if we're restoring
     3490          interrupt level to -1 or greater */
     3491        __(cmpq $-2<<fixnumshift,%imm0)
     3492        __(jne 0b)
     3493        __(movq binding.val(%imm1),%temp0)
     3494        __(cmpq %imm0,%temp0)
     3495        __(je 0b)
     3496        __(movq $-1<<fixnumshift,INTERRUPT_LEVEL_BINDING_INDEX(%arg_x))
     3497        __(suspend_now())
     3498        __(jmp 0b)
    34783499_endsubp(unbind_interrupt_level)
    34793500

  • branches/working-0708/lisp-kernel/x86-uuo.s

    r5458 r7025  
    6363])             
    6464
     65define([suspend_now],[
     66        xuuo(3)
     67])             
     68
    6569define([uuo_error_reg_not_fixnum],[
    6670        int [$]0xf0|$1
Note: See TracChangeset for help on using the changeset viewer.