Changeset 569

Timestamp:

Feb 26, 2004, 11:58:06 AM (21 years ago)

Author:

Gary Byers

Message:

QUIT typechecks arg before it's too late to do so.

Location:

trunk/ccl

Files:

• examples/cocoa-editor.lisp (modified) (3 diffs)
• examples/cocoa-listener.lisp (modified) (2 diffs)
• examples/cocoa-window.lisp (modified) (3 diffs)
• examples/hemlock-textstorage.lisp (modified) (15 diffs)
• hemlock/src/bindings.lisp (modified) (1 diff)
• hemlock/src/buffer.lisp (modified) (1 diff)
• hemlock/src/cocoa-hemlock.lisp (modified) (1 diff)
• hemlock/src/filecoms.lisp (modified) (1 diff)
• hemlock/src/htext1.lisp (modified) (2 diffs)
• hemlock/src/htext2.lisp (modified) (1 diff)
• hemlock/src/htext3.lisp (modified) (2 diffs)
• hemlock/src/modeline.lisp (modified) (1 diff)
• hemlock/src/struct.lisp (modified) (1 diff)
• level-1/l1-readloop.lisp (modified) (1 diff)

trunk/ccl/examples/cocoa-editor.lisp

@@ -95 +95 @@
 (define-objc-method ((:id init) lisp-editor-document)
   (let* ((doc (send-super 'init)))
-    (setf (slot-value doc 'textstorage)
-          (make-textstorage-for-hemlock-buffer
-           (hemlock-buffer-from-nsstring
-            #@""
-            (lisp-string-from-nsstring (send doc 'display-name))
-            "Lisp")))
+    (unless (%null-ptr-p doc)
+      (let* ((buffer (hi::make-buffer
+                      (lisp-string-from-nsstring (send doc 'display-name))
+                      :modes '("Lisp"))))
+        (setf (slot-value doc 'textstorage)
+              (make-textstorage-for-hemlock-buffer
+               buffer)
+              (hi::buffer-document buffer) doc)))
     doc))
                      
+
+(define-objc-method ((:id :read-from-file filename
+                          :of-type type)
+                     lisp-editor-document)
+  (declare (ignorable type))
+  (let* ((pathname (lisp-string-from-nsstring filename))
+         (buffer-name (hi::pathname-to-buffer-name pathname))
+         (buffer (hi::make-buffer buffer-name))
+         (data (make-objc-instance 'ns:ns-data
+                                   :with-contents-of-file filename))
+         (string (make-objc-instance 'ns:ns-string
+                                     :with-data data
+                                     :encoding #$NSMacOSRomanStringEncoding)))
+    (setf (hi::buffer-pathname buffer) pathname)
+    (nsstring-to-buffer string buffer)
+    (hi::buffer-start (hi::buffer-point buffer))
+    (setf (hi::buffer-modified buffer) nil)
+    (hi::process-file-options buffer pathname)
+    (setf (slot-value self 'textstorage)
+          (make-textstorage-for-hemlock-buffer buffer)
+          (hi::buffer-document buffer) (%setf-macptr (%null-ptr) self))))
+    
+  
+
+(define-objc-method ((:id :data-representation-of-type type)
+                      lisp-editor-document)
+  (declare (ignorable type))
+  (send (send (slot-value self 'text-view) 'string)
+        :data-using-encoding #$NSASCIIStringEncoding
+        :allow-lossy-conversion t))
 
 (define-objc-method ((:void make-window-controllers) lisp-editor-document)
@@ -110 +142 @@
                                     (slot-value self 'textstorage) nil nil))))
     (send self :add-window-controller controller)
-    (send controller 'release)))
-
-(define-objc-method ((:<BOOL> :load-data-representation data :of-type type)
-                     lisp-editor-document)
-    (declare (ignorable data type))
-  (let* ((nsstring 
-  nil)
-  
-
-(define-objc-method ((:id :data-representation-of-type ((* :char) type))
-                      lisp-editor-document)
-  (declare (ignorable type))
-  (send (send (slot-value self 'text-view) 'string)
-        :data-using-encoding #$NSASCIIStringEncoding
-        :allow-lossy-conversion t))
-
-         
+    (send controller 'release)))         
 
 #|
@@ -174 +190 @@
 (define-objc-method ((:void close) lisp-editor-document)
   (send-super 'close)
+  (let* ((textstorage (slot-value self 'textstorage)))
+    (setf (slot-value self 'textstorage) (%null-ptr))
+    (unless (%null-ptr-p textstorage)
+      (close-hemlock-textstorage textstorage)))
   (let* ((info (info-from-document self)))
     (when info

trunk/ccl/examples/cocoa-listener.lisp

@@ -297 +297 @@
 
 
-  
+)  
 ;;; The LispListenerDocument class.
 
@@ -305 +305 @@
   (:metaclass ns:+ns-object))
 
+#-hemlock
+(progn
 (define-objc-class-method ((:id top-listener) lisp-listener-document)
   (let* ((all-documents (send *NSApp* 'ordered-Documents)))

trunk/ccl/examples/cocoa-window.lisp

@@ -271 +271 @@
 (defparameter *default-font-size* 12.0e0)
 
+(defparameter *font-attribute-names*
+  '((:bold . #.#$NSBoldFontMask)
+    (:italic . #.#$NSItalicFontMask)
+    (:small-caps . #.#$NSSmallCapsFontMask)))
     
 ;;; Try to find the specified font.  If it doesn't exist (or isn't
 ;;; fixed-pitch), try to find a fixed-pitch font of the indicated size.
 (defun default-font (&key (name *default-font-name*)
-                          (size *default-font-size*))
+                          (size *default-font-size*)
+                          (attributes ()))
+                                
   (setq size (float size 0.0f0))
   (with-cstrs ((name name))
@@ -284 +290 @@
           (let* ((fontname (send (@class ns-string) :string-with-c-string name))
                  (font (send (@class ns-font)
-                                  :font-with-name fontname :matrix matrix)))
+                                  :font-with-name fontname :matrix matrix))
+                 (implemented-attributes ()))
             (if (or (%null-ptr-p font)
                     (and 
@@ -291 +298 @@
               (setq font (send (@class ns-font)
                                :user-fixed-pitch-font-of-size size)))
-            font)))))
+            (when attributes
+              (dolist (attr-name attributes)
+                (let* ((pair (assoc attr-name *font-attribute-names*))
+                       (newfont))
+                  (when pair
+                    (setq newfont
+                          (send
+                           (send (@class "NSFontManager") 'shared-font-manager)
+                           :convert-font font
+                           :to-have-trait (cdr pair)))
+                    (unless (eql font newfont)
+                      (setq font newfont)
+                      (push attr-name implemented-attributes))))))
+            (values font implemented-attributes))))))
 
 (defparameter *tab-width* 8)

trunk/ccl/examples/hemlock-textstorage.lisp

@@ -224 +224 @@
               (unless (eq buffer hi::*current-buffer*)
                 (setf (hi::current-buffer) buffer))
+              (let* ((pane (text-view-pane self)))
+                (unless (eql pane (hi::current-window))
+                  (setf (hi::current-window) pane)))
+              #+debug
+              (format t "~& key-event = ~s" key-event)
               (hi::interpret-key-event key-event info))))))))
 
@@ -242 +247 @@
 
 (defun make-textstorage-for-hemlock-buffer (buffer)
-  (setf (hi::buffer-text-storage buffer)
-        (make-objc-instance 'lisp-text-storage
-                            :with-string
-                            (make-instance
-                             'hemlock-buffer-string
-                             :display
-                             (reset-display-cache
-                              (make-hemlock-display)
-                              buffer)))))
+  (make-objc-instance 'lisp-text-storage
+                      :with-string
+                      (make-instance
+                       'hemlock-buffer-string
+                       :display
+                       (reset-display-cache
+                        (make-hemlock-display)
+                        buffer))))
 
 (defclass modeline-view (ns:ns-view)
@@ -257 +261 @@
 
 
-(defloadvar *modeline-text-attributes*
-    (create-text-attributes :color (send (@class "NSColor") 'black-color)
-                            :font (default-font
-                                      :name "Courier New Bold Italic"
-                                      :size 10.0)))
+(defloadvar *modeline-text-attributes* nil)
+(defparameter *modeline-font-name* "Courier New Bold Italic")
+(defparameter *modeline-font-size* 10.0)
 
 (defun buffer-for-modeline-view (mv)
@@ -279 +281 @@
          (buffer (buffer-for-modeline-view modeline-view)))
     (when buffer
+      ;; You don't want to know why this is done this way.
+      (unless *modeline-text-attributes*
+        (setq *modeline-text-attributes*
+              (create-text-attributes :color (send (@class "NSColor") 'black-color)
+                                      :font (default-font
+                                              :name *modeline-font-name*
+                                              :size *modeline-font-size*))))
+      
       (let* ((string
               (apply #'concatenate 'string
@@ -470 +480 @@
 
 (defun new-hemlock-document-window (&key
-                                    (x 0.0)
-                                    (y 0.0)
+                                    (x 200.0)
+                                    (y 200.0)
                                     (height 200.0)
                                     (width 500.0)
@@ -537 +547 @@
 (defun hemlock-buffer-from-nsstring (nsstring name &rest modes)
   (let* ((buffer (hi::make-buffer name :modes modes)))
+    (nsstring-to-buffer nsstring buffer)))
+
+(defun nsstring-to-buffer (nsstring buffer)    
     (hi::delete-region (hi::buffer-region buffer))
     (hi::modifying-buffer buffer)
@@ -542 +555 @@
       (let* ((string-len (send nsstring 'length))
              (line-start 0)
+             (first-line-terminator ())
              (first-line (hi::mark-line mark))
              (previous first-line)
@@ -550 +564 @@
             (do* ((number (+ (hi::line-number first-line) hi::line-increment)
                           (+ number hi::line-increment)))
-                 ((= line-start string-len))
+                 ((= line-start string-len)
+                  (let* ((line (hi::mark-line mark)))
+                    (hi::insert-string mark (make-string 0))
+                    (setf (hi::line-next previous) line
+                          (hi::line-previous line) previous))
+                  nil)
               (setf (pref remaining-range :<NSR>ange.location) line-start)
               (send nsstring
@@ -558 +577 @@
                     :for-range remaining-range)
               (let* ((contents-end (pref contents-end-index :unsigned))
+                     (line-end (pref line-end-index :unsigned))
                      (chars (make-string (- contents-end line-start))))
                 (do* ((i line-start (1+ i))
@@ -563 +583 @@
                      ((= i contents-end))
                   (setf (schar chars j) (code-char (send nsstring :character-at-index i))))
+                (unless first-line-terminator
+                  (let* ((terminator (code-char
+                                      (send nsstring :character-at-index
+                                            contents-end))))
+                    (setq first-line-terminator
+                    (case terminator
+                      (#\return (if (= line-end (+ contents-end 2))
+                                  :cp/m
+                                  :mac))
+                      (t :unix)))))
                 (if (eq previous first-line)
                   (progn
@@ -577 +607 @@
                       (setf (hi::line-next previous) line)
                       (setq previous line))))
-                (setq line-start (pref line-end-index :unsigned))))))))
+                (setq line-start line-end)))))
+        (when first-line-terminator
+          (setf (hi::buffer-external-format buffer) first-line-terminator))))
     (setf (hi::buffer-modified buffer) nil)
-    buffer))
-
+    buffer)
+
+
+
+        
+        
 (setq hi::*beep-function* #'(lambda (stream)
                               (declare (ignore stream))
@@ -616 +652 @@
                 (funcall f tv)))))))))
   
-(defun hi::textstorage-begin-editing (textstorage)
-  (send textstorage 'begin-editing))
-
-(defun hi::textstorage-end-editing (textstorage)
-  (send textstorage 'end-editing))
-
-(defun hi::textstorage-set-point-position (textstorage)
-  (let* ((string (send textstorage 'string))
+(defun hi::document-begin-editing (document)
+  (send (slot-value document 'textstorage) 'begin-editing))
+
+(defun hi::document-end-editing (document)
+  (send (slot-value document 'textstorage) 'end-editing))
+
+(defun hi::document-set-point-position (document)
+  (let* ((textstorage (slot-value document 'textstorage))
+         (string (send textstorage 'string))
          (buffer (hemlock-display-buffer (hemlock-buffer-string-display string)))
          (point (hi::buffer-point buffer))
@@ -637 +674 @@
 (defun hi::buffer-note-insertion (buffer mark n)
   (when (hi::bufferp buffer)
-    (let* ((textstorage (hi::buffer-text-storage buffer)))
+    (let* ((document (hi::buffer-document buffer))
+           (textstorage (if document (slot-value document 'textstorage))))
       (when textstorage
         (let* ((pos (mark-absolute-position mark)))
@@ -655 +693 @@
                 :change-in-length 0))))))
 
+  
 
 (defun hi::buffer-note-deletion (buffer mark n)
   (when (hi::bufferp buffer)
-    (let* ((textstorage (hi::buffer-text-storage buffer)))
+    (let* ((document (hi::buffer-document buffer))
+           (textstorage (if document (slot-value document 'textstorage))))
       (when textstorage
         (let* ((pos (mark-absolute-position mark)))
@@ -671 +711 @@
                 :change-in-length (- n)))))))
 
-            
+(defun hi::set-document-modified (document flag)
+  (let* ((windowcontrollers (send document 'window-controllers)))
+    (dotimes (i (send windowcontrollers 'length))
+      (send (send windowcontrollers :object-at-index i)
+            :set-document-edited flag))))
+
+(defun hi::document-panes (document)
+  (let* ((ts (slot-value document 'textstorage))
+         (panes ()))
+    (for-each-textview-using-storage
+     ts
+     #'(lambda (tv)
+         (let* ((pane (text-view-pane tv)))
+           (unless (%null-ptr-p pane)
+             (push pane panes)))))
+    panes))
     
+         
+    

trunk/ccl/hemlock/src/bindings.lisp

@@ -65 +65 @@
 (bind-key "Scroll Next Window Up" #k"control-meta-V")
 
+(bind-key "Process File Options" #k"control-meta-m")
+(bind-key "Ensure File Options Line" #k"control-meta-M")
 (bind-key "Help" #k"home")
 (bind-key "Help" #k"control-_")

trunk/ccl/hemlock/src/buffer.lisp

@@ -46 +46 @@
       (setf (buffer-modified-tick buffer) (tick))
       (setf (buffer-unmodified-tick buffer) (tick)))
+  (let* ((document (buffer-document buffer)))
+    (if document (set-document-modified document sense)))
   sense)
 

trunk/ccl/hemlock/src/cocoa-hemlock.lisp

@@ -6 +6 @@
 
 (in-package :hemlock-internals)
+
+(defun buffer-windows (buffer)
+  (let* ((doc (buffer-document buffer)))
+    (when doc
+      (document-panes doc))))
+
+(defvar *current-window* ())
+
+(defvar *window-list* ())
+(defun current-window ()
+  "Return the current window.  The current window is specially treated by
+  redisplay in several ways, the most important of which is that is does
+  recentering, ensuring that the Buffer-Point of the current window's
+  Window-Buffer is always displayed.  This may be set with Setf."
+  *current-window*)
+
+(defun %set-current-window (new-window)
+  #+not-yet
+  (invoke-hook hemlock::set-window-hook new-window)
+  #+clx
+  (move-mark (window-point *current-window*)
+             (buffer-point (window-buffer *current-window*)))
+  #+clx
+  (move-mark (buffer-point (window-buffer new-window))
+             (window-point new-window))
+  (setq *current-window* new-window))
+

trunk/ccl/hemlock/src/filecoms.lisp

@@ -212 +212 @@
   (declare (ignore p))
   (process-file-options (current-buffer)))
+
+(defcommand "Ensure File Options Line" (p)
+  "Insert a default file options line at the beginning of the buffer, unless such a line already exists."
+  "Insert a default file options line at the beginning of the buffer, unless such a line already exists."
+  (declare (ignore p))
+  (let* ((buffer (current-buffer))
+         (string
+          (line-string (mark-line (buffer-start-mark buffer))))
+         (found (search "-*-" string))
+         (end (if found (search "-*-" string :start2 (+ found 3)))))
+    (unless end
+      (let* ((mode (buffer-major-mode buffer)))
+        (unless mode
+          ;; Try to derive the buffer's major mode from its pathname's
+          ;; type.
+          (let* ((pathname (buffer-pathname buffer))
+                 (type (if pathname (pathname-type pathname)))
+                 (hook (if type
+                         (assoc (string-downcase type) *file-type-hooks*
+                                :test #'string=))))
+            (when hook
+              (funcall (cdr hook) buffer type)
+              (setq mode (buffer-major-mode buffer)))))
+        (with-mark ((mark (buffer-start-mark buffer)))
+          (if (string-equal mode "Lisp")
+            (let* ((package-name
+                    (if (hemlock-bound-p 'current-package :buffer buffer)
+                      (variable-value 'hemlock::current-package
+                                      :buffer buffer)
+                      "CL-USER")))
+              (insert-string
+               mark
+               (format nil ";;; -*- Mode: Lisp; Package: ~a -*-" package-name)))
+            (insert-string
+             mark
+             (format nil ";;; -*- Mode: ~a -*-" (or mode "Fundamental"))))
+          (insert-character mark #\NewLine))))
+    (buffer-start (buffer-point buffer))))
+    
+    
+                         
+                           
+            
+        
+            
+            
+          
+                 
+        
+  
 
 (defcommand "Insert File" (p &optional pathname (buffer (current-buffer)))

trunk/ccl/hemlock/src/htext1.lisp

@@ -162 +162 @@
   `(incf now-tick))
 
-(defun buffer-textstorage-begin-editing (buffer)
+(defun buffer-document-begin-editing (buffer)
   (when (bufferp buffer)
-    (let* ((textstorage (buffer-text-storage buffer)))
-      (when textstorage (textstorage-begin-editing textstorage)))))
-
-(defun buffer-textstorage-end-editing (buffer)
+    (let* ((document (buffer-document buffer)))
+      (when document (document-begin-editing document)))))
+
+(defun buffer-document-end-editing (buffer)
   (when (bufferp buffer)
-    (let* ((textstorage (buffer-text-storage buffer)))
-      (when textstorage (textstorage-end-editing textstorage)))))
+    (let* ((document (buffer-document buffer)))
+      (when document (document-end-editing document)))))
 
 
@@ -194 +194 @@
       (unwind-protect
            (progn
-             (if ,bp (buffer-textstorage-begin-editing ,b))
+             (if ,bp (buffer-document-begin-editing ,b))
              (hemlock-ext:without-interrupts ,@forms))
-        (if ,bp (buffer-textstorage-end-editing ,b))))))
+        (if ,bp (buffer-document-end-editing ,b))))))
 
 (defmacro always-change-line (mark new-line)

trunk/ccl/hemlock/src/htext2.lisp

@@ -22 +22 @@
   (let* ((line (mark-line mark))
          (buffer (if line (line-%buffer line)))
-         (textstorage (if buffer (buffer-text-storage buffer))))
+         (document (if buffer (buffer-document buffer))))
     (if (and buffer
              (eq mark (buffer-point buffer))
-             textstorage)
-      (textstorage-set-point-position textstorage))
+             document)
+      (document-set-point-position document))
     mark))
     

trunk/ccl/hemlock/src/htext3.lisp

@@ -27 +27 @@
          (buffer (line-%buffer line)))
     (modifying-buffer buffer
-      (modifying-line line mark)
-      (cond ((char= character #\newline)
-             (let* ((next (line-next line))
-                    (new-chars (subseq (the simple-string *open-chars*)
-                                       0 *left-open-pos*))
-                    (new-line (make-line :%buffer buffer
-                                         :chars (decf *cache-modification-tick*)
-                                         :previous line
-                                         :next next)))
-               (maybe-move-some-marks (charpos line new-line) *left-open-pos*
-                                      (- charpos *left-open-pos*))
-               (setf (line-%chars line) new-chars)
-               (setf (line-next line) new-line)
-               (if next (setf (line-previous next) new-line))
-               (number-line new-line)
-               (setq *open-line* new-line  *left-open-pos* 0)))
-            (t
-             (if (= *right-open-pos* *left-open-pos*)
-                 (grow-open-chars))
+                      (modifying-line line mark)
+                      (cond ((char= character #\newline)
+                             (let* ((next (line-next line))
+                                    (new-chars (subseq (the simple-string *open-chars*)
+                                                       0 *left-open-pos*))
+                                    (new-line (make-line :%buffer buffer
+                                                         :chars (decf *cache-modification-tick*)
+                                                         :previous line
+                                                         :next next)))
+                               (maybe-move-some-marks (charpos line new-line) *left-open-pos*
+                                                      (- charpos *left-open-pos*))
+                               (setf (line-%chars line) new-chars)
+                               (setf (line-next line) new-line)
+                               (if next (setf (line-previous next) new-line))
+                               (number-line new-line)
+                               (setq *open-line* new-line  *left-open-pos* 0)))
+                            (t
+                             (if (= *right-open-pos* *left-open-pos*)
+                               (grow-open-chars))
              
-             (maybe-move-some-marks (charpos line) *left-open-pos*
-                                    (1+ charpos))
+                             (maybe-move-some-marks (charpos line) *left-open-pos*
+                                                    (1+ charpos))
              
-             (cond
-              ((eq (mark-%kind mark) :right-inserting)
-               (decf *right-open-pos*)
-               (setf (char (the simple-string *open-chars*) *right-open-pos*)
-                     character))
-              (t
-               (setf (char (the simple-string *open-chars*) *left-open-pos*)
-                     character)
-               (incf *left-open-pos*)))))
-      (buffer-note-insertion buffer mark 1))))
+                             (cond
+                               ((eq (mark-%kind mark) :right-inserting)
+                                (decf *right-open-pos*)
+                                (setf (char (the simple-string *open-chars*) *right-open-pos*)
+                                      character))
+                               (t
+                                (setf (char (the simple-string *open-chars*) *left-open-pos*)
+                                      character)
+                                (incf *left-open-pos*)))))
+                      (buffer-note-insertion buffer mark 1))))
 
 
@@ -71 +71 @@
     (declare (simple-string string))
     (unless (zerop (- end start))
-      (modifying-buffer buffer
-        (modifying-line line mark)
-        (if (%sp-find-character string start end #\newline)
-            (with-mark ((mark mark :left-inserting))
-              (do ((left-index start (1+ right-index))
-                   (right-index
-                    (%sp-find-character string start end #\newline)
-                    (%sp-find-character string (1+ right-index) end #\newline)))
-                  ((null right-index)
-                   (if (/= left-index end)
-                       (insert-string mark string left-index end)))
-                (insert-string mark string left-index right-index)
-                (insert-character mark #\newline)))
-            (let ((length (- end start)))
-              (if (<= *right-open-pos* (+ *left-open-pos* end))
-                  (grow-open-chars (* (+ *line-cache-length* end) 2)))
+      (modifying-buffer
+       buffer
+       (modifying-line line mark)
+       (if (%sp-find-character string start end #\newline)
+         (with-mark ((mark mark :left-inserting))
+           (do ((left-index start (1+ right-index))
+                (right-index
+                 (%sp-find-character string start end #\newline)
+                 (%sp-find-character string (1+ right-index) end #\newline)))
+               ((null right-index)
+                (if (/= left-index end)
+                  (insert-string mark string left-index end)))
+             (insert-string mark string left-index right-index)
+             (insert-character mark #\newline)))
+         (let ((length (- end start)))
+           (if (<= *right-open-pos* (+ *left-open-pos* end))
+             (grow-open-chars (* (+ *line-cache-length* end) 2)))
               
-              (maybe-move-some-marks (charpos line) *left-open-pos*
-                                     (+ charpos length))
-              (cond
-               ((eq (mark-%kind mark) :right-inserting)
-                (let ((new (- *right-open-pos* length)))
-                  (%sp-byte-blt string start *open-chars* new *right-open-pos*)
-                  (setq *right-open-pos* new)))
-               (t
-                (let ((new (+ *left-open-pos* length)))
-                  (%sp-byte-blt string start *open-chars* *left-open-pos* new)
-                  (setq *left-open-pos* new))))))
-        (buffer-note-insertion buffer mark (- end start))))))
+           (maybe-move-some-marks (charpos line) *left-open-pos*
+                                  (+ charpos length))
+           (cond
+             ((eq (mark-%kind mark) :right-inserting)
+              (let ((new (- *right-open-pos* length)))
+                (%sp-byte-blt string start *open-chars* new *right-open-pos*)
+                (setq *right-open-pos* new)))
+             (t
+              (let ((new (+ *left-open-pos* length)))
+                (%sp-byte-blt string start *open-chars* *left-open-pos* new)
+                (setq *left-open-pos* new))))))
+       (buffer-note-insertion buffer mark (- end start))))))
 
 

trunk/ccl/hemlock/src/modeline.lisp

@@ -100 +100 @@
                                    "Hemlock "))
 
-(make-modeline-field :name :external-format :width 4
-                     :function #'(lambda (buffer window)
-                                   "Returns indication of buffer's external-format"
-                                   (declare (ignore window))
-                                   (format nil "[~c] "
-                                           (schar
-                                            (string (buffer-external-format buffer)) 0))))
+(make-modeline-field
+ :name :external-format
+ :function #'(lambda (buffer window)
+               "Returns an indication of buffer's external-format, iff it's
+other than :DEFAULT"
+               (declare (ignore window))
+               (let* ((external-format (buffer-external-format buffer)))
+                 (case external-format
+                   ((:unix nil))
+                   (:mac "[CR] ")
+                   (:cp/m "[CRLF] ")))))
+
 
 (make-modeline-field

trunk/ccl/hemlock/src/struct.lisp

@@ -96 +96 @@
   windows                     ; List of all windows into this buffer.
   #-clx
-  text-storage                ; text storage object associated with this buffer
+  document                    ; NSDocument object associated with this buffer
   var-values                  ; the buffer's local variables
   variables                   ; string-table of local variables

trunk/ccl/level-1/l1-readloop.lisp

@@ -158 +158 @@
 
 (defun quit (&optional (exit-status 0))
+  (unless (typep exit-status '(signed-byte 32))
+    (report-bad-arg exit-status '(signed-byte 32)))
   (let* ((ip *initial-process*)
          (cp *current-process*))