emacs/banana.el

   1 ;;;; Banana -- allows network abstraction, nearly always.
   2 ;;;; by Allen Short <washort@twistedmatrix.com>
   3 ;;;; This file is in the public domain.
   4
   5 "'Get into a rut early: Do the same processes the same way. Accumulate
   6   idioms. Standardize. The only difference(!) between Shakespeare and you was
   7   the size of his idiom list -- not the size of his vocabulary.'
   8     -- Alan Perlis, Programming Epigram #10"
   9
  10 (provide 'banana)
  11 (require 'cl)
  12
  13 ;; (defconst default-vocabulary
  14 ;;   ;; Jelly Data Types
  15 ;;   '((None .-1)
  16 ;;     (class . -2)
  17 ;;     (dereference . -3)
  18 ;;     (reference . -4)
  19 ;;     (dictionary . -5)
  20 ;;     (function . -6)
  21 ;;     (instance . -7)
  22 ;;     (list . -8)
  23 ;;     (module . -9)
  24 ;;     (persistent . -10)
  25 ;;     (tuple . -11)
  26 ;;     (unpersistable . -12)
  27 ;;     ;; PB Data Types
  28 ;;     (copy . -13)
  29 ;;     (cache . -14)
  30 ;;     (cached . -15)
  31 ;;     (remote . -16)
  32 ;;     (local . -17)
  33 ;;     (lcache . -18)
  34 ;;     ;; PB Protocol Messages
  35 ;;     (version . -19)
  36 ;;     (login . -20)
  37 ;;     (password . -21)
  38 ;;     (challenge . -22)
  39 ;;     (logged-in . -23)
  40 ;;     (not-logged-in . -24)
  41 ;;     (cachemessage . -25)
  42 ;;     (message . -26)
  43 ;;     (answer . -27)
  44 ;;     (error . -28)
  45 ;;     (decref . -29)
  46 ;;     (decache . -30)
  47 ;;     (uncache . -31)))
  48
  49 (defun banana-int-char (c)
  50   c)
  51
  52 (defconst high-bit (banana-int-char 128))
  53 (defconst list-type (banana-int-char 128))
  54 (defconst int-type (banana-int-char 129))
  55 (defconst string-type (banana-int-char 130))
  56 (defconst neg-type (banana-int-char 131))
  57 (defconst float-type (banana-int-char 132))
  58
  59 (defmacro special-case (expr &rest clauses)
  60   (append (list 'ecase expr)
  61           (mapcar
  62            (lambda (i)
  63              (cons (eval (car i)) (cdr i))) clauses)))
  64
  65 (defun read-integer-base128 (string)
  66   (loop for i = 0 then (+ i (* (char-int char) (expt 128 place)))
  67         for place = 0 then (1+ place)
  68         for char across string
  69         finally return i))
  70
  71 (defun make-banana-decoder (data-received connection-ready)
  72   (lexical-let ((-stack- ())
  73                 (-buffer- "")
  74                 (-output- ())
  75                 (-data-received- data-received)
  76                 (-connection-ready- connection-ready)
  77                 (-vocab- nil))
  78     (lambda (socket chunk)
  79       (block nil
  80         (flet ((eat-item (item)
  81                  (if -stack-
  82                      (setf (cdar -stack-) (nconc (cdar -stack-) (list item)))
  83                    (setf -output-  item))))
  84         (let ((buffer (concat -buffer- chunk)))
  85           (while (/= (length buffer) 0)
  86             (let* ((pos (let ((i 0)) (loop ;junk
  87                                        for ch across buffer
  88                                        while (< ch high-bit)
  89                                        do (incf i)) i))
  90                    (num-string (substring buffer 0 pos))
  91                    (num (read-integer-base128 num-string))
  92                    (type-byte (aref buffer pos))
  93                    (rest (substring buffer (1+ pos))))
  94               (setq -buffer- buffer)
  95               (special-case type-byte
  96                 (list-type
  97                  (setq -stack- (acons num '() -stack-))
  98                  (setq buffer rest))
  99                 (string-type
 100                  (if (>= (length rest) num)
 101                      (progn
 102                        (setq buffer (substring rest num))
 103                        (eat-item (substring rest 0 num)))
 104                    (return)))
 105                 (int-type
 106                  (setf buffer rest)
 107                  (eat-item num))
 108                 (neg-type
 109                  (setf buffer rest)
 110                  (eat-item (- num)))
 111                 (float-type
 112                  (setf buffer rest)
 113                  (string-to-number num-string)))
 114               (loop while (and -stack-
 115                                (= (length (cdar -stack-))
 116                                   (caar -stack-)))
 117                 do (eat-item (cdr (pop -stack-))))))
 118           (setf -buffer- ""))))
 119       (when (null -stack-)
 120         ;; (print -output- (get-buffer-create "*banana-debug*"))
 121         (if -vocab-
 122             (progn
 123               (funcall -data-received- -output-) (setf -output- nil))
 124           (progn
 125             (setf -vocab- "none")
 126             (banana-send-encoded socket "none")
 127             (funcall -connection-ready-)))))))
 128
 129 (defun print-integer-base128 (int stream)
 130   (if (= int 0)
 131       (print (banana-int-char 0) stream)
 132     (if (< int 0)
 133         (error "positive numbers only. blame Allen for breaking it")
 134       (loop
 135         until (<= int 0)
 136         do (write-char (banana-int-char (logand int 127)) stream)
 137            (setf int (ash int -7))))))
 138
 139
 140
 141 (defun banana-encode (obj stream)
 142   (cond
 143    ((listp obj)
 144     (print-integer-base128 (length obj) stream)
 145     (write-char list-type stream)
 146     (mapc (lambda (x) (banana-encode x stream)) obj))
 147    ((integerp obj)
 148     (print-integer-base128 (abs obj) stream)
 149     (if (>= obj 0)
 150         (write-char int-type stream)
 151       (write-char neg-type stream)))
 152    ((floatp obj)
 153     (prin1 obj stream)
 154     (write-char float-type))
 155    ((stringp obj)
 156     (print-integer-base128 (length obj) stream)
 157     (write-char string-type stream)
 158     (princ obj stream))
 159    ((symbolp obj)
 160     ;; (let ((code (cdr (assoc obj default-vocabulary))))
 161     ;;       (if (null code)
 162     ;;           (error "Unrecognised jelly symbol"))
 163     ;;       (when (< code 0)
 164     ;;           (print-integer-base128 (- code) stream)
 165     ;;           (write-char vocab-type stream)))
 166     (let ((my-symbol-name (symbol-name obj)))
 167       (print-integer-base128 (length my-symbol-name) stream)
 168       (write-char string-type stream)
 169       (princ my-symbol-name stream)))
 170    (t (error "Couldn't send object"))))
 171
 172 (defun banana-send-encoded (bse-process obj)
 173     (banana-encode obj (lambda (data) (process-send-string bse-process (if (stringp data) data (string data))))))