Permalink
Browse files

Initial commit!

  • Loading branch information...
0 parents commit 5d98d4891cb043452e430ad6751413efceb41c31 @flambard committed May 29, 2010
Showing with 2,999 additions and 0 deletions.
  1. +21 −0 LICENSE
  2. +51 −0 atom-cache.lisp
  3. +60 −0 byte-functions.lisp
  4. +172 −0 classes.lisp
  5. +84 −0 cleric.asd
  6. +82 −0 cleric.mbd
  7. +61 −0 conditions.lisp
  8. +89 −0 constants.lisp
  9. +221 −0 control-message.lisp
  10. +170 −0 distribution-header.lisp
  11. +157 −0 epmd.lisp
  12. +29 −0 generic-functions.lisp
  13. +162 −0 handshake.lisp
  14. +11 −0 ieee-floats.lisp
  15. +6 −0 md5.lisp
  16. +129 −0 node-protocol.lisp
  17. +102 −0 package.lisp
  18. +34 −0 remote-node.lisp
  19. +49 −0 special-variables.lisp
  20. +5 −0 test.lisp
  21. +1,289 −0 translation.lisp
  22. +15 −0 type-erlang-translatable.lisp
@@ -0,0 +1,21 @@
+The MIT License
+
+Copyright (c) 2009 Markus Flambard
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in
+all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+THE SOFTWARE.
@@ -0,0 +1,51 @@
+;;;; Atom cache
+
+(in-package :cleric)
+
+(defstruct (atom-cache (:constructor make-atom-cache ())
+ (:print-object print-atom-cache))
+ "Erlang atom cache"
+ (segments (make-array '(8 256) :element-type 'symbol :initial-element nil)
+ :type '(array symbol (8 256))
+ :read-only t))
+
+(defun print-atom-cache (cache stream)
+ (print-unreadable-object (cache stream :type t :identity t)
+ (format stream "~a/2048"
+ (loop
+ for index upto 2047
+ counting (row-major-aref (atom-cache-segments cache) index)))))
+
+(defun atom-cache-print-atoms (cache &optional (stream *standard-output*))
+ (dotimes (segment 8)
+ (loop
+ for internal upto 255
+ for atom = (aref (atom-cache-segments cache) segment internal)
+ if atom do (format stream "~&~d ~3d: ~a" segment internal atom))))
+
+(defun atom-cache-location-of (symbol cache)
+ (dotimes (segment 8)
+ (loop
+ for internal upto 255
+ if (eq symbol (aref (atom-cache-segments cache) segment internal))
+ do (return-from atom-cache-location-of (cons segment internal)))))
+
+(defun atom-cache-find-free (cache)
+ (dotimes (segment 8)
+ (loop
+ for internal upto 255
+ if (null (aref (atom-cache-segments cache) segment internal))
+ do (return-from atom-cache-find-free (cons segment internal)))))
+
+(defun atom-cache-get (cache s-index internal-s-index)
+ (aref (atom-cache-segments cache) s-index internal-s-index))
+
+(defun atom-cache-add (symbol cache s-index internal-s-index)
+ (setf (aref (atom-cache-segments cache) s-index internal-s-index) symbol))
+
+(defun atom-cache-add-new (symbol cache)
+ (let ((location (atom-cache-location-of symbol cache)))
+ (if location
+ (atom-cache-add symbol cache (car location) (cdr location))
+ (let ((free (atom-cache-find-free cache)))
+ (atom-cache-add symbol cache (car free) (cdr free))))))
@@ -0,0 +1,60 @@
+(in-package :cleric)
+
+(defun bytes-to-unsigned-integer (bytes &optional (number-of-bytes nil) (pos 0))
+ (let ((n (if number-of-bytes number-of-bytes (length bytes))))
+ (usocket:octet-buffer-to-integer bytes n :start pos)))
+
+(defun bytes-to-uint16 (bytes &optional (pos 0))
+ (bytes-to-unsigned-integer bytes 2 pos))
+
+(defun bytes-to-uint32 (bytes &optional (pos 0))
+ (bytes-to-unsigned-integer bytes 4 pos))
+
+
+(defun read-uint16 (stream)
+ (bytes-to-unsigned-integer (read-bytes 2 stream) 2))
+
+(defun read-uint32 (stream)
+ (bytes-to-unsigned-integer (read-bytes 4 stream) 4))
+
+
+(defun bytes-to-signed-int32 (bytes &optional (pos 0))
+ (let ((int 0))
+ (setf (ldb (byte 7 24) int) (svref bytes (+ 0 pos))) ;; All bits except the sign
+ (setf (ldb (byte 8 16) int) (svref bytes (+ 1 pos)))
+ (setf (ldb (byte 8 8) int) (svref bytes (+ 2 pos)))
+ (setf (ldb (byte 8 0) int) (svref bytes (+ 3 pos)))
+ (if (= 1 (ldb (byte 1 7) (svref bytes (+ 0 pos)))) ;; The sign bit
+ (- (1+ (logxor int #x7FFFFFFF))) ;; Two's complement
+ int)))
+
+(defun read-signed-int32 (stream)
+ (bytes-to-signed-int32 (read-bytes 4 stream)))
+
+
+(defun unsigned-integer-to-bytes (uint number-of-bytes)
+ (let ((bytes (make-array number-of-bytes :element-type '(unsigned-byte 8))))
+ (usocket:integer-to-octet-buffer uint bytes number-of-bytes)))
+
+(defun uint16-to-bytes (int)
+ (unsigned-integer-to-bytes int 2))
+
+(defun uint32-to-bytes (int)
+ (unsigned-integer-to-bytes int 4))
+
+
+(defun string-to-bytes (string)
+ (map 'simple-array #'char-code string))
+
+(defun bytes-to-string (bytes &optional length (pos 0))
+ (map 'string #'code-char (subseq bytes pos (when length (+ pos length)))))
+
+
+(defun read-bytes (n stream)
+ (let ((bytes (make-array n :element-type '(unsigned-byte 8))))
+ (read-sequence bytes stream)
+ ;; Does it block until the whole sequence is filled when reading from a socket?
+ bytes))
+
+(defun read-bytes-as-string (n stream)
+ (bytes-to-string (read-bytes n stream)))
@@ -0,0 +1,172 @@
+(in-package :cleric)
+
+(defclass erlang-object ()
+ ())
+
+(defmethod make-instance :around ((class (eql 'erlang-object)) &rest initargs &key &allow-other-keys)
+ (declare (ignore initargs))
+ (error "Not possible to make an instance of class ~s" class))
+
+
+(defclass erlang-binary (erlang-object)
+ ((bytes :reader bytes
+ :initarg :bytes
+ :documentation "Returns a vector of bytes from an Erlang binary.")
+ (bits :reader bits-in-last-byte
+ :initarg :bits
+ :initform 8
+ :documentation
+ "The number of bits in the last byte of an Erlang binary."))
+ (:documentation "Erlang binary."))
+
+(defmethod print-object ((object erlang-binary) stream)
+ (print-unreadable-object (object stream :type t)
+ (if (= 8 (bits-in-last-byte object))
+ (format stream "<~{~s~^ ~}>" (coerce (bytes object) 'list))
+ (format stream "<~{~s~^ ~}:~a>" (coerce (bytes object) 'list)
+ (bits-in-last-byte object)))))
+
+(defun binary (&rest bytes)
+ "Creates an Erlang binary from BYTES."
+ (assert (every #'(lambda (b) (typep b '(unsigned-byte 8))) bytes))
+ (make-instance 'erlang-binary :bytes (coerce bytes 'vector)))
+
+(defun string-to-binary (string)
+ "Creates an Erlang binary from the characters in STRING."
+ (make-instance 'erlang-binary :bytes (string-to-bytes string)))
+
+(defun bytes-to-binary (bytes)
+ "Creates an Erlang binary from BYTES."
+ (assert (every #'(lambda (b) (typep b '(unsigned-byte 8))) bytes))
+ (make-instance 'erlang-binary :bytes (coerce bytes 'vector)))
+
+(defun binary-to-string (binary)
+ "Translates the bytes in BINARY to an ASCII string."
+ (bytes-to-string (bytes binary)))
+
+(defmethod size ((x erlang-binary))
+ "The byte-size of Erlang binary X."
+ (length (bytes x)))
+
+
+(defclass erlang-fun (erlang-object)
+ ((module :reader module :initarg :module)
+ (arity :reader arity :initarg :arity :documentation "The arity of an Erlang Fun."))
+ (:documentation "Erlang fun."))
+
+(defmethod make-instance :around ((class (eql 'erlang-fun)) &rest initargs &key &allow-other-keys)
+ (declare (ignore initargs))
+ (error "Not possible to make an instance of class ~s" class))
+
+;;; fun M:F/A
+(defclass erlang-external-fun (erlang-fun)
+ ((function :initarg :function))
+ (:documentation "Erlang fun in external format (module:function/arity)."))
+
+(defmethod print-object ((object erlang-external-fun) stream)
+ (print-unreadable-object (object stream :type t)
+ (with-slots (module arity function) object
+ (format stream "~a:~a/~a" module function arity))))
+
+;;; fun F/A or fun (...) -> ...
+(defclass erlang-internal-fun (erlang-fun)
+ ((pid :initarg :pid)
+ (index :initarg :index)
+ (uniq :initarg :uniq)
+ (free-vars :reader free-vars :initarg :free-vars))
+ (:documentation "Erlang fun in internal format."))
+
+(defclass erlang-new-internal-fun (erlang-internal-fun)
+ ((new-uniq :initarg :uniq)
+ (new-index :initarg :index))
+ (:documentation "Erlang fun in new internal format."))
+
+;; (defmethod old-uniq ((fun erlang-new-internal-fun))
+;; (slot-value fun 'uniq))
+
+;; (defmethod old-index ((fun erlang-new-internal-fun))
+;; (slot-value fun 'index))
+
+
+(defclass erlang-identifier (erlang-object)
+ ((node :reader node :initarg :node)
+ (id :initarg :id)
+ (creation :initarg :creation)))
+
+(defmethod make-instance :around ((class (eql 'erlang-identifier)) &rest initargs &key &allow-other-keys)
+ (declare (ignore initargs))
+ (error "Not possible to make an instance of class ~s" class))
+
+(defclass erlang-pid (erlang-identifier)
+ ((serial :initarg :serial))
+ (:documentation "Erlang PID."))
+
+(defmethod print-object ((object erlang-pid) stream)
+ (print-unreadable-object (object stream :type t)
+ (with-slots (node id serial) object
+ (format stream "~a <~a.~a>"
+ node (bytes-to-uint32 id) (bytes-to-uint32 serial)))))
+
+;; Pids in Erlang are printed like this <X.id.serial>
+;; where X = some number representing the node.
+
+(defun make-pid ()
+ "Create a new Erlang PID."
+ (make-instance 'erlang-pid
+ :node (make-symbol *this-node*)
+ :id (generate-new-pid-id)
+ :serial #(0 0 0 0) ;; What to set here?
+ :creation 1)) ;; What to set here?
+
+(defun generate-new-pid-id ()
+ (uint32-to-bytes (incf *pid-id-counter*)))
+
+;; Not mentioned in the documentation: Serial only uses the least significant 13 bits!
+
+(defclass erlang-port (erlang-identifier)
+ ()
+ (:documentation "Erlang port."))
+
+(defmethod print-object ((object erlang-port) stream)
+ (print-unreadable-object (object stream :type t)
+ (with-slots (node id) object
+ (format stream "~a <~a>" node (bytes-to-uint32 id)))))
+
+
+(defclass erlang-reference (erlang-identifier)
+ ()
+ (:documentation "Erlang ref."))
+
+(defmethod print-object ((object erlang-reference) stream)
+ (print-unreadable-object (object stream :type t)
+ (with-slots (node id) object
+ (format stream "~a <~{~a~^.~}>" node
+ (nreverse (mapcar #'bytes-to-uint32 (four-byte-blocks id)))))))
+
+(defun four-byte-blocks (bytes)
+ (loop
+ repeat (/ (length bytes) 4)
+ for pos from 0 by 4
+ collect (subseq bytes pos (+ 4 pos))))
+
+
+(defclass erlang-tuple (erlang-object)
+ ((elements :reader elements :initarg :elements))
+ (:documentation "Erlang tuple."))
+
+(defmethod print-object ((object erlang-tuple) stream)
+ (print-unreadable-object (object stream :type t)
+ (format stream "{~{~s~^ ~}}" (coerce (elements object) 'list))))
+
+(defun tuple (&rest erlang-translatable-objects)
+ "Create an Erlang tuple"
+ (make-instance 'erlang-tuple
+ :elements (coerce erlang-translatable-objects 'vector)))
+
+(defmethod arity ((x erlang-tuple))
+ "The number of elements of Erlang tuple X."
+ (length (elements x)))
+
+(defmethod size ((x erlang-tuple))
+ "The number of elements of Erlang tuple X."
+ (arity x))
@@ -0,0 +1,84 @@
+(defpackage :common-lisp-erlang-interface-system
+ (:nicknames :cleric-system)
+ (:use :cl :asdf))
+
+(in-package :cleric-system)
+
+(defsystem :cleric
+ :description "Common Lisp Erlang Interface - An implementation of the Erlang distribution protocol."
+ :author "Markus Flambard <mflambard@common-lisp.net>"
+ :version "0.0.2"
+ :license "MIT License"
+ :depends-on (:usocket :md5 :ieee-floats)
+ :components ((:file "package")
+ (:file "generic-functions"
+ :depends-on ("package"
+ "constants"))
+ (:file "remote-node"
+ :depends-on ("package"
+ "atom-cache"
+ "special-variables"))
+ (:file "conditions"
+ :depends-on ("package"))
+ (:file "constants"
+ :depends-on ("package"))
+ (:file "atom-cache"
+ :depends-on ("package"))
+ (:file "special-variables"
+ :depends-on ("package"))
+ (:file "byte-functions"
+ :depends-on ("package"))
+ (:file "classes"
+ :depends-on ("package"
+ "special-variables"))
+ (:file "type-erlang-translatable"
+ :depends-on ("package"
+ "classes"))
+ (:file "distribution-header"
+ :depends-on ("package"
+ "constants"
+ "conditions"
+ "byte-functions"))
+ (:file "ieee-floats" ;; Needs IEEE-Floats library
+ :depends-on ("package"
+ "byte-functions"))
+ (:file "epmd"
+ :depends-on ("package"
+ "conditions"
+ "remote-node"
+ "byte-functions"
+ "constants"))
+ (:file "translation"
+ :depends-on ("package"
+ "conditions"
+ "byte-functions"
+ "generic-functions"
+ "constants"
+ "special-variables"
+ "classes"
+ "ieee-floats"
+ "md5"
+ "atom-cache"
+ "type-erlang-translatable"))
+ (:file "handshake"
+ :depends-on ("package"
+ "conditions"
+ "byte-functions"
+ "constants"))
+ (:file "md5" ;; Needs MD5 library
+ :depends-on ("package"))
+ (:file "control-message"
+ :depends-on ("package"
+ "generic-functions"
+ "constants"
+ "classes"))
+ (:file "node-protocol"
+ :depends-on ("package"
+ "conditions"
+ "distribution-header"
+ "classes"
+ "translation"
+ "byte-functions"
+ "control-message"
+ "remote-node"))
+ ))
Oops, something went wrong.

0 comments on commit 5d98d48

Please sign in to comment.