|
|
- <!doctype html>
-
- <title>CodeMirror: Common Lisp mode</title>
- <meta charset="utf-8"/>
- <link rel=stylesheet href="../../doc/docs.css">
-
- <link rel="stylesheet" href="../../lib/codemirror.css">
- <script src="../../lib/codemirror.js"></script>
- <script src="commonlisp.js"></script>
- <style>.CodeMirror {background: #f8f8f8;}</style>
- <div id=nav>
- <a href="http://codemirror.net"><h1>CodeMirror</h1><img id=logo src="../../doc/logo.png"></a>
-
- <ul>
- <li><a href="../../index.html">Home</a>
- <li><a href="../../doc/manual.html">Manual</a>
- <li><a href="https://github.com/codemirror/codemirror">Code</a>
- </ul>
- <ul>
- <li><a href="../index.html">Language modes</a>
- <li><a class=active href="#">Common Lisp</a>
- </ul>
- </div>
-
- <article>
- <h2>Common Lisp mode</h2>
- <form><textarea id="code" name="code">(in-package :cl-postgres)
-
- ;; These are used to synthesize reader and writer names for integer
- ;; reading/writing functions when the amount of bytes and the
- ;; signedness is known. Both the macro that creates the functions and
- ;; some macros that use them create names this way.
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (defun integer-reader-name (bytes signed)
- (intern (with-standard-io-syntax
- (format nil "~a~a~a~a" '#:read- (if signed "" '#:u) '#:int bytes))))
- (defun integer-writer-name (bytes signed)
- (intern (with-standard-io-syntax
- (format nil "~a~a~a~a" '#:write- (if signed "" '#:u) '#:int bytes)))))
-
- (defmacro integer-reader (bytes)
- "Create a function to read integers from a binary stream."
- (let ((bits (* bytes 8)))
- (labels ((return-form (signed)
- (if signed
- `(if (logbitp ,(1- bits) result)
- (dpb result (byte ,(1- bits) 0) -1)
- result)
- `result))
- (generate-reader (signed)
- `(defun ,(integer-reader-name bytes signed) (socket)
- (declare (type stream socket)
- #.*optimize*)
- ,(if (= bytes 1)
- `(let ((result (the (unsigned-byte 8) (read-byte socket))))
- (declare (type (unsigned-byte 8) result))
- ,(return-form signed))
- `(let ((result 0))
- (declare (type (unsigned-byte ,bits) result))
- ,@(loop :for byte :from (1- bytes) :downto 0
- :collect `(setf (ldb (byte 8 ,(* 8 byte)) result)
- (the (unsigned-byte 8) (read-byte socket))))
- ,(return-form signed))))))
- `(progn
- ;; This causes weird errors on SBCL in some circumstances. Disabled for now.
- ;; (declaim (inline ,(integer-reader-name bytes t)
- ;; ,(integer-reader-name bytes nil)))
- (declaim (ftype (function (t) (signed-byte ,bits))
- ,(integer-reader-name bytes t)))
- ,(generate-reader t)
- (declaim (ftype (function (t) (unsigned-byte ,bits))
- ,(integer-reader-name bytes nil)))
- ,(generate-reader nil)))))
-
- (defmacro integer-writer (bytes)
- "Create a function to write integers to a binary stream."
- (let ((bits (* 8 bytes)))
- `(progn
- (declaim (inline ,(integer-writer-name bytes t)
- ,(integer-writer-name bytes nil)))
- (defun ,(integer-writer-name bytes nil) (socket value)
- (declare (type stream socket)
- (type (unsigned-byte ,bits) value)
- #.*optimize*)
- ,@(if (= bytes 1)
- `((write-byte value socket))
- (loop :for byte :from (1- bytes) :downto 0
- :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
- socket)))
- (values))
- (defun ,(integer-writer-name bytes t) (socket value)
- (declare (type stream socket)
- (type (signed-byte ,bits) value)
- #.*optimize*)
- ,@(if (= bytes 1)
- `((write-byte (ldb (byte 8 0) value) socket))
- (loop :for byte :from (1- bytes) :downto 0
- :collect `(write-byte (ldb (byte 8 ,(* byte 8)) value)
- socket)))
- (values)))))
-
- ;; All the instances of the above that we need.
-
- (integer-reader 1)
- (integer-reader 2)
- (integer-reader 4)
- (integer-reader 8)
-
- (integer-writer 1)
- (integer-writer 2)
- (integer-writer 4)
-
- (defun write-bytes (socket bytes)
- "Write a byte-array to a stream."
- (declare (type stream socket)
- (type (simple-array (unsigned-byte 8)) bytes)
- #.*optimize*)
- (write-sequence bytes socket))
-
- (defun write-str (socket string)
- "Write a null-terminated string to a stream \(encoding it when UTF-8
- support is enabled.)."
- (declare (type stream socket)
- (type string string)
- #.*optimize*)
- (enc-write-string string socket)
- (write-uint1 socket 0))
-
- (declaim (ftype (function (t unsigned-byte)
- (simple-array (unsigned-byte 8) (*)))
- read-bytes))
- (defun read-bytes (socket length)
- "Read a byte array of the given length from a stream."
- (declare (type stream socket)
- (type fixnum length)
- #.*optimize*)
- (let ((result (make-array length :element-type '(unsigned-byte 8))))
- (read-sequence result socket)
- result))
-
- (declaim (ftype (function (t) string) read-str))
- (defun read-str (socket)
- "Read a null-terminated string from a stream. Takes care of encoding
- when UTF-8 support is enabled."
- (declare (type stream socket)
- #.*optimize*)
- (enc-read-string socket :null-terminated t))
-
- (defun skip-bytes (socket length)
- "Skip a given number of bytes in a binary stream."
- (declare (type stream socket)
- (type (unsigned-byte 32) length)
- #.*optimize*)
- (dotimes (i length)
- (read-byte socket)))
-
- (defun skip-str (socket)
- "Skip a null-terminated string."
- (declare (type stream socket)
- #.*optimize*)
- (loop :for char :of-type fixnum = (read-byte socket)
- :until (zerop char)))
-
- (defun ensure-socket-is-closed (socket &key abort)
- (when (open-stream-p socket)
- (handler-case
- (close socket :abort abort)
- (error (error)
- (warn "Ignoring the error which happened while trying to close PostgreSQL socket: ~A" error)))))
- </textarea></form>
- <script>
- var editor = CodeMirror.fromTextArea(document.getElementById("code"), {lineNumbers: true});
- </script>
-
- <p><strong>MIME types defined:</strong> <code>text/x-common-lisp</code>.</p>
-
- </article>
|
