Judge, Condemn and Redeem

26/05/2016
/* The following three hooks are used when we're doing a thorough
   redisplay of the frame.  We don't explicitly know which scroll bars
   are going to be deleted, because keeping track of when windows go
   away is a real pain - "Can you say set-window-configuration, boys
   and girls?"  Instead, we just assert at the beginning of redisplay
   that *all* scroll bars are to be removed, and then save a scroll bar
   from the fiery pit when we actually redisplay its window.  */

/* Arrange for all scroll bars on FRAME to be removed at the next call
   to `*judge_scroll_bars_hook'.  A scroll bar may be spared if
   `*redeem_scroll_bar_hook' is applied to its window before the judgment.  */

static void
w32_condemn_scroll_bars (struct frame *frame)
{
  if (!NILP (FRAME_SCROLL_BARS (frame)))
    {
      if (!NILP (FRAME_CONDEMNED_SCROLL_BARS (frame)))
        {
          /* Prepend scrollbars to already condemned ones.  */
          Lisp_Object last = FRAME_SCROLL_BARS (frame);

          while (!NILP (XSCROLL_BAR (last)->next))
            last = XSCROLL_BAR (last)->next;

          XSCROLL_BAR (last)->next = FRAME_CONDEMNED_SCROLL_BARS (frame);
          XSCROLL_BAR (FRAME_CONDEMNED_SCROLL_BARS (frame))->prev = last;
        }

      fset_condemned_scroll_bars (frame, FRAME_SCROLL_BARS (frame));
      fset_scroll_bars (frame, Qnil);
    }
}


/* Un-mark WINDOW's scroll bar for deletion in this judgment cycle.
   Note that WINDOW isn't necessarily condemned at all.  */

static void
w32_redeem_scroll_bar (struct window *w)
{
  struct scroll_bar *bar;
  Lisp_Object barobj;
  struct frame *f;

  /* We can't redeem this window's scroll bar if it doesn't have one.  */
  if (NILP (w->vertical_scroll_bar) && NILP (w->horizontal_scroll_bar))
    emacs_abort ();

  if (!NILP (w->vertical_scroll_bar) && WINDOW_HAS_VERTICAL_SCROLL_BAR (w))
    {
      bar = XSCROLL_BAR (w->vertical_scroll_bar);
      /* Unlink it from the condemned list.  */
      f = XFRAME (WINDOW_FRAME (w));
      if (NILP (bar->prev))
        {
          /* If the prev pointer is nil, it must be the first in one of
             the lists.  */
          if (EQ (FRAME_SCROLL_BARS (f), w->vertical_scroll_bar))
            /* It's not condemned.  Everything's fine.  */
            goto horizontal;
          else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f),
                       w->vertical_scroll_bar))
            fset_condemned_scroll_bars (f, bar->next);
          else
            /* If its prev pointer is nil, it must be at the front of
               one or the other!  */
            emacs_abort ();
        }
      else
        XSCROLL_BAR (bar->prev)->next = bar->next;

      if (! NILP (bar->next))
        XSCROLL_BAR (bar->next)->prev = bar->prev;

      bar->next = FRAME_SCROLL_BARS (f);
      bar->prev = Qnil;
      XSETVECTOR (barobj, bar);
      fset_scroll_bars (f, barobj);
      if (! NILP (bar->next))
        XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
    }

 horizontal:
  if (!NILP (w->horizontal_scroll_bar) && WINDOW_HAS_HORIZONTAL_SCROLL_BAR (w))
    {
      bar = XSCROLL_BAR (w->horizontal_scroll_bar);
      /* Unlink it from the condemned list.  */
      f = XFRAME (WINDOW_FRAME (w));
      if (NILP (bar->prev))
        {
          /* If the prev pointer is nil, it must be the first in one of
             the lists.  */
          if (EQ (FRAME_SCROLL_BARS (f), w->horizontal_scroll_bar))
            /* It's not condemned.  Everything's fine.  */
            return;
          else if (EQ (FRAME_CONDEMNED_SCROLL_BARS (f),
                       w->horizontal_scroll_bar))
            fset_condemned_scroll_bars (f, bar->next);
          else
            /* If its prev pointer is nil, it must be at the front of
               one or the other!  */
            emacs_abort ();
        }
      else
        XSCROLL_BAR (bar->prev)->next = bar->next;

      if (! NILP (bar->next))
        XSCROLL_BAR (bar->next)->prev = bar->prev;

      bar->next = FRAME_SCROLL_BARS (f);
      bar->prev = Qnil;
      XSETVECTOR (barobj, bar);
      fset_scroll_bars (f, barobj);
      if (! NILP (bar->next))
        XSETVECTOR (XSCROLL_BAR (bar->next)->prev, bar);
    }
}

/* Remove all scroll bars on FRAME that haven't been saved since the
   last call to `*condemn_scroll_bars_hook'.  */

static void
w32_judge_scroll_bars (struct frame *f)
{
  Lisp_Object bar, next;

  bar = FRAME_CONDEMNED_SCROLL_BARS (f);

  /* Clear out the condemned list now so we won't try to process any
     more events on the hapless scroll bars.  */
  fset_condemned_scroll_bars (f, Qnil);

  for (; ! NILP (bar); bar = next)
    {
      struct scroll_bar *b = XSCROLL_BAR (bar);

      x_scroll_bar_remove (b);

      next = b->next;
      b->next = b->prev = Qnil;
    }

  /* Now there should be no references to the condemned scroll bars,
     and they should get garbage-collected.  */
}

Source.


C-C-COMPILE IT IN

02/05/2016

I am implementing MAL (again), this time in ChucK. Why an audio programming language? Well, as I wielded it to implement a pseudo-theremin, it dawned upon me that it exposed more than enough language features to allow for implementing something lispier in it. A good chance to learn OOP, I thought to myself[1].

It’s not too fun to write loads of code in a language without a proper major mode for it[2], so I decided to give CC Mode a try, this time for creating a mode with it. Half a day and loads of cursing later, I was done. Most of my gripes with it stemmed from the documentation not covering that use case (and the examples being outdated), so in case you plan to go down that road, I found the sources of d-mode and csharp-mode highly useful. I’ll concentrate on a single, innocent looking warning I got while developing it to show a less obvious reason for hating this piece of Emacs with the force of a thousand suns.

If you byte-compile chuck-mode.el (or FWIW, csharp-mode.el), you’ll get two warnings:

chuck-mode.el:152:4:Warning: (lambda nil ...) quoted with ' rather than with #'
chuck-mode.el:152:4:Warning: (lambda nil ...) quoted with ' rather than with #'

Following the line numbers isn’t particularly enlightening as they point to the wrong place. I was already familiar with these warnings as I’ve seen them before for csharp-mode, but this time I had something much smaller to bisect. Commenting out (c-init-language-vars) made them disappear, so I looked up its definition and as it’s a macro expanding to a trivial looking function call, that one’s source as well. Here it is, in all of its glory:

(defun c-make-init-lang-vars-fun (mode)
  "Create a function that initializes all the language dependent variables
for the given mode.

This function should be evaluated at compile time, so that the
function it returns is byte compiled with all the evaluated results
from the language constants.  Use the `c-init-language-vars' macro to
accomplish that conveniently."

  (if (cc-bytecomp-is-compiling)
      ;; No need to byte compile this lambda since the byte compiler is
      ;; smart enough to detect the `funcall' construct in the
      ;; `c-init-language-vars' macro below and compile it all straight
      ;; into the function that contains `c-init-language-vars'.
      `(lambda ()

         ;; This let sets up the context for `c-mode-var' and similar
         ;; that could be in the result from `c--macroexpand-all'.
         (let ((c-buffer-is-cc-mode ',mode)
               current-var source-eval)
           (c-make-emacs-variables-local)
           (condition-case err

               (if (eq c-version-sym ',c-version-sym)
                   (setq ,@(let ((c-buffer-is-cc-mode mode)
                                 (c-lang-const-expansion 'immediate))
                             ;; `c-lang-const' will expand to the evaluated
                             ;; constant immediately in `c--macroexpand-all'
                             ;; below.
                              (c--mapcan
                               (lambda (init)
                                 `(current-var ',(car init)
                                               ,(car init) ,(c--macroexpand-all
                                                             (elt init 1))))
                               ;; Note: The following `append' copies the
                               ;; first argument.  That list is small, so
                               ;; this doesn't matter too much.
                               (append (cdr c-emacs-variable-inits)
                                       (cdr c-lang-variable-inits)))))

                 ;; This diagnostic message isn't useful for end
                 ;; users, so it's disabled.
                 ;;(unless (get ',mode 'c-has-warned-lang-consts)
                 ;;  (message ,(concat "%s compiled with CC Mode %s "
                 ;;                    "but loaded with %s - evaluating "
                 ;;                    "language constants from source")
                 ;;           ',mode ,c-version c-version)
                 ;;  (put ',mode 'c-has-warned-lang-consts t))

                 (setq source-eval t)
                 (let ((init ',(append (cdr c-emacs-variable-inits)
                                       (cdr c-lang-variable-inits))))
                   (dolist (var-init init)
                     (setq current-var (car var-init))
                     (set (car var-init) (eval (cadr var-init))))))

             (error
              (if current-var
                  (message "Eval error in the `c-lang-defvar' or `c-lang-setvar' for `%s'%s: %S"
                           current-var
                           (if source-eval
                               (format "\
 (fallback source eval - %s compiled with CC Mode %s but loaded with %s)"
                                       ',mode ,c-version c-version)
                             "")
                           err)
                (signal (car err) (cdr err)))))))

    ;; Being evaluated from source.  Always use the dynamic method to
    ;; work well when `c-lang-defvar's in this file are reevaluated
    ;; interactively.
    `(lambda ()
       (require 'cc-langs)
       (let ((c-buffer-is-cc-mode ',mode)
             (init (append (cdr c-emacs-variable-inits)
                           (cdr c-lang-variable-inits)))
             current-var)
         (c-make-emacs-variables-local)
         (condition-case err

             (dolist (var-init init)
               (setq current-var (car var-init))
               (set (car var-init) (eval (cadr var-init))))

           (error
            (if current-var
                (message
                 "Eval error in the `c-lang-defvar' or `c-lang-setver' for `%s' (source eval): %S"
                 current-var err)
              (signal (car err) (cdr err)))))))
    ))

For clarification, CC Mode expects you to define constants for your language. The above monstrosity turns these constants into values applied to each buffer using the derived mode, but does it differently, depending on whether you are in the process of byte-compiling its file or just load it (like, for re-evaluation while doing some development). As the mechanism for that backquotes a lambda and replaces parts of it, the byte-compiler will naturally warn us about it as it prohibits it from byte-compiling the lambda (unlike what the comment suggests).

This means that any differences between the two implementations will have fun side effects, such as you no longer being able to test your mode meaningfully by re-evaluating parts of it (forcing you to recompile and load, ideally in a new instance). When it comes to its worst, you’re going to have a broken mode just because it wasn’t compiled with a CC Mode compiled with the same Emacs version. Seriously. Don’t do that. It just angers people for no real reason. Do what every other major mode does and just set the damn variables buffer-locally. Thank you for your understanding.

[1]I found out quickly that while ChucK’s idea of OOP is clearly Java-inspired, it doesn’t implement nearly as much and is significantly more limited, so I ended up working against it most of the time.
[2]I got by initially with an abandoned mode, but found it annoying that it wasn’t defined properly (which made Evil start in the wrong state for me), had way too magic behaviour for = and terrible indentation. That’s why I picked this yak to shave…

The Mysteries of IDN

17/04/2016

Chances are that you’ve taken a glance at the colourful output of htop before and wondered why exactly your Emacs process has spawned a persistent idn child process. In this post I’ll attempt showing how I’ve found out about the reasons for this mystery and what it tells us about Emacs.

First of all, let’s search the Emacs sources for "idn. This yields a hit in message.el:

(defcustom message-use-idna
  (and (or (mm-coding-system-p 'utf-8)
           (condition-case nil
               (let (mucs-ignore-version-incompatibilities)
                 (require 'un-define))
             (error)))
       (condition-case nil
           (require 'idna)
         (file-error)
         (invalid-operation))
       idna-program
       (executable-find idna-program)
       (string= (idna-to-ascii "räksmörgås") "xn--rksmrgs-5wao1o")
       t)
  "Whether to encode non-ASCII in domain names into ASCII according to IDNA.
GNU Libidn, and in particular the elisp package \"idna.el\" and
the external program \"idn\", must be installed for this
functionality to work."
  :version "22.1"
  :group 'message-headers
  :link '(custom-manual "(message)IDNA")
  :type '(choice (const :tag "Ask" ask)
                 (const :tag "Never" nil)
                 (const :tag "Always" t)))

This is interesting. idna.el is provided by the idn program here, so this file will only be available if the site-lisp directory has been loaded up before in this session. It explains why I couldn’t reproduce this behaviour when using emacs -Q as this disables loading that directory. It’s very likely that you’ll have it installed on your system as it is a dependency to curl, wget, systemd, mutt and more. And due to the way idna.el works, using idna-to-ascii in this customizable will start a process and keep it around until one calls idna-shutdown. So, never. Unless you’ve customized it before to prevent it from being used in the first place. This is hardly the only case of non-trivial customization variables doing unexpected things to detect optional functionality, but it doesn’t appear to attract any attention unless it worsens your init file startup time

Now, what exactly in my setup would cause message.el to be loaded? After all, I’m not using any Email client inside Emacs, so I had to bisect my init file to figure out that head scratcher. It turned out that magit was the culprit. If you’re wondering what part of it would need that, it avoids loading it initially, but declares message-goto-body for usage in magit-remote.el to do pull requests. You know, real pull requests, not the GitHub thing.


Function Signature From Hell

22/02/2016

I’ve finally given in to the sweet temptation of record-style types, despite being wary of them at first. To have an idea how the constructor syntax looks in practice, I grepped the Emacs sources for examples and located package-buffer-info. If you have eldoc enabled, put point inside the package-desc-from-define form and wait for it to kick in, you’ll see the following:

package-desc-from-define: (NAME-STRING VERSION-STRING &optional
SUMMARY REQUIREMENTS &rest REST-PLIST &AUX (NAME (INTERN
NAME-STRING)) (VERSION (VERSION-TO-LIST VERSION-STRING)) (REQS
(MAPCAR #'(LAMBDA (ELT) (LIST (CAR ELT) (VERSION-TO-LIST (CADR
ELT)))) (IF (EQ 'QUOTE (CAR REQUIREMENTS)) (NTH 1 REQUIREMENTS)
REQUIREMENTS))) (KIND (PLIST-GET REST-PLIST :KIND)) (ARCHIVE
(PLIST-GET REST-PLIST :ARCHIVE)) (EXTRAS (LET (ALIST) (WHILE
REST-PLIST (UNLESS (MEMQ (CAR REST-PLIST) '(:KIND :ARCHIVE)) (LET
((VALUE (CADR REST-PLIST))) (WHEN VALUE (PUSH (CONS (CAR
REST-PLIST) (IF (EQ (CAR-SAFE VALUE) 'QUOTE) (CADR VALUE) VALUE))
ALIST)))) (SETQ REST-PLIST (CDDR REST-PLIST))) ALIST)))

This prompted me to customize eldoc to never make it happen again:

(setq eldoc-echo-area-use-multiline-p nil)

Like Spinning Plates

04/02/2016

The tried and true way of doing network requests is sending an asynchronous one with a callback to be used upon completion or failure. That’s why we have url-retrieve and url-retrieve-synchronously instead of url-retrieve and url-retrieve-asynchronously. It’s fairly obvious how the asynchronous variant is implemented[1], the synchronous one less so.

(defun url-retrieve-synchronously (url &optional silent inhibit-cookies)
  "Retrieve URL synchronously.
Return the buffer containing the data, or nil if there are no data
associated with it (the case for dired, info, or mailto URLs that need
no further processing).  URL is either a string or a parsed URL."
  (url-do-setup)

  (let ((retrieval-done nil)
        (asynch-buffer nil))
    (setq asynch-buffer
          (url-retrieve url (lambda (&rest ignored)
                              (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer))
                              (setq retrieval-done t
                                    asynch-buffer (current-buffer)))
                        nil silent inhibit-cookies))
    (if (null asynch-buffer)
        ;; We do not need to do anything, it was a mailto or something
        ;; similar that takes processing completely outside of the URL
        ;; package.
        nil
      (let ((proc (get-buffer-process asynch-buffer)))
        ;; If the access method was synchronous, `retrieval-done' should
        ;; hopefully already be set to t.  If it is nil, and `proc' is also
        ;; nil, it implies that the async process is not running in
        ;; asynch-buffer.  This happens e.g. for FTP files.  In such a case
        ;; url-file.el should probably set something like a `url-process'
        ;; buffer-local variable so we can find the exact process that we
        ;; should be waiting for.  In the mean time, we'll just wait for any
        ;; process output.
        (while (not retrieval-done)
          (url-debug 'retrieval
                     "Spinning in url-retrieve-synchronously: %S (%S)"
                     retrieval-done asynch-buffer)
          (if (buffer-local-value 'url-redirect-buffer asynch-buffer)
              (setq proc (get-buffer-process
                          (setq asynch-buffer
                                (buffer-local-value 'url-redirect-buffer
                                                    asynch-buffer))))
            (if (and proc (memq (process-status proc)
                                '(closed exit signal failed))
                     ;; Make sure another process hasn't been started.
                     (eq proc (or (get-buffer-process asynch-buffer) proc)))
                ;; FIXME: It's not clear whether url-retrieve's callback is
                ;; guaranteed to be called or not.  It seems that url-http
                ;; decides sometimes consciously not to call it, so it's not
                ;; clear that it's a bug, but even then we need to decide how
                ;; url-http can then warn us that the download has completed.
                ;; In the mean time, we use this here workaround.
                ;; XXX: The callback must always be called.  Any
                ;; exception is a bug that should be fixed, not worked
                ;; around.
                (progn ;; Call delete-process so we run any sentinel now.
                  (delete-process proc)
                  (setq retrieval-done t)))
            ;; We used to use `sit-for' here, but in some cases it wouldn't
            ;; work because apparently pending keyboard input would always
            ;; interrupt it before it got a chance to handle process input.
            ;; `sleep-for' was tried but it lead to other forms of
            ;; hanging.  --Stef
            (unless (or (with-local-quit
                          (accept-process-output proc))
                        (null proc))
              ;; accept-process-output returned nil, maybe because the process
              ;; exited (and may have been replaced with another).  If we got
              ;; a quit, just stop.
              (when quit-flag
                (delete-process proc))
              (setq proc (and (not quit-flag)
                              (get-buffer-process asynch-buffer)))))))
      asynch-buffer)))

If you still had doubts whether using the asynchronous interface is worth it, there’s your answer.

[1]Emacs has asynchronous “network processes” which unlike your usual asynchronous processes are not really processes, but rather a combination of select(2) and connect(2) with the semantics of an Emacs process.