Start rewriting the Common Lisp plugin in Lisp

protoc/package.lisp

@@ -0,0 +1,238 @@
+;;;; Copyright 2012 Google Inc.  All Rights Reserved
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;;     * Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;     * Redistributions in binary form must reproduce the above
+;;;; copyright notice, this list of conditions and the following disclaimer
+;;;; in the documentation and/or other materials provided with the
+;;;; distribution.
+;;;;     * Neither the name of Google Inc. nor the names of its
+;;;; contributors may be used to endorse or promote products derived from
+;;;; this software without specific prior written permission.
+
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;;; Author: brown@google.com (Robert Brown)
+
+(in-package #:common-lisp-user)
+
+(defpackage #:protoc
+  (:documentation "Protocol buffer Common Lisp plugin.")
+  (:use #:common-lisp
+        #:com.google.base)
+  (:import-from #:com.google.protobuf
+                ;; Constants
+                #:+field-descriptor-proto-label-label-optional+
+                #:+field-descriptor-proto-label-label-repeated+
+                #:+field-descriptor-proto-label-label-required+
+                #:+field-descriptor-proto-type-type-bool+
+                #:+field-descriptor-proto-type-type-bytes+
+                #:+field-descriptor-proto-type-type-double+
+                #:+field-descriptor-proto-type-type-enum+
+                #:+field-descriptor-proto-type-type-fixed32+
+                #:+field-descriptor-proto-type-type-fixed64+
+                #:+field-descriptor-proto-type-type-float+
+                #:+field-descriptor-proto-type-type-group+
+                #:+field-descriptor-proto-type-type-int32+
+                #:+field-descriptor-proto-type-type-int64+
+                #:+field-descriptor-proto-type-type-message+
+                #:+field-descriptor-proto-type-type-sfixed32+
+                #:+field-descriptor-proto-type-type-sfixed64+
+                #:+field-descriptor-proto-type-type-sint32+
+                #:+field-descriptor-proto-type-type-sint64+
+                #:+field-descriptor-proto-type-type-string+
+                #:+field-descriptor-proto-type-type-uint32+
+                #:+field-descriptor-proto-type-type-uint64+
+                #:+field-options-ctype-cord+
+                #:+field-options-ctype-string+
+                #:+field-options-ctype-string-piece+
+                #:+file-options-optimize-mode-code-size+
+                #:+file-options-optimize-mode-lite-runtime+
+                #:+file-options-optimize-mode-speed+
+                #:+maximum-field-descriptor-proto-label+
+                #:+maximum-field-descriptor-proto-type+
+                #:+maximum-field-options-ctype+
+                #:+maximum-file-options-optimize-mode+
+                #:+minimum-field-descriptor-proto-label+
+                #:+minimum-field-descriptor-proto-type+
+                #:+minimum-field-options-ctype+
+                #:+minimum-file-options-optimize-mode+
+                ;; Classes
+                #:descriptor-proto
+                #:descriptor-proto-extension-range
+                #:enum-descriptor-proto
+                #:enum-options
+                #:enum-value-descriptor-proto
+                #:enum-value-options
+                #:field-descriptor-proto
+                #:field-descriptor-proto-label
+                #:field-descriptor-proto-type
+                #:field-options
+                #:field-options-ctype
+                #:file-descriptor-proto
+                #:file-descriptor-set
+                #:file-options
+                #:file-options-optimize-mode
+                #:message-options
+                #:method-descriptor-proto
+                #:method-options
+                #:service-descriptor-proto
+                #:service-options
+                #:source-code-info-location
+                #:uninterpreted-option-name-part
+                ;; Functions
+                #:aggregate-value
+                #:cc-generic-services
+                #:clear-aggregate-value
+                #:clear-cc-generic-services
+                #:clear-ctype
+                #:clear-default-value
+                #:clear-dependency
+                #:clear-deprecated
+                #:clear-double-value
+                #:clear-end
+                #:clear-enum-type
+                #:clear-experimental-map-key
+                #:clear-extendee
+                #:clear-extension
+                #:clear-extension-range
+                #:clear-field
+                #:clear-file
+                #:clear-identifier-value
+                #:clear-input-type
+                #:clear-is-extension
+                #:clear-java-generate-equals-and-hash
+                #:clear-java-generic-services
+                #:clear-java-multiple-files
+                #:clear-java-outer-classname
+                #:clear-java-package
+                #:clear-label
+                #:clear-location
+                #:clear-message-set-wire-format
+                #:clear-message-type
+                #:clear-method
+                #:clear-name
+                #:clear-name-part
+                #:clear-negative-int-value
+                #:clear-nested-type
+                #:clear-no-standard-descriptor-accessor
+                #:clear-number
+                #:clear-optimize-for
+                #:clear-options
+                #:clear-output-type
+                #:clear-package
+                #:clear-packed
+                #:clear-path
+                #:clear-positive-int-value
+                #:clear-py-generic-services
+                #:clear-service
+                #:clear-source-code-info
+                #:clear-span
+                #:clear-start
+                #:clear-string-value
+                #:clear-type
+                #:clear-type-name
+                #:clear-uninterpreted-option
+                #:clear-value
+                #:ctype
+                #:default-value
+                #:dependency
+                #:deprecated
+                #:double-value
+                #:end
+                #:enum-type
+                #:experimental-map-key
+                #:extendee
+                #:extension
+                #:extension-range
+                #:field
+                #:file
+                #:has-aggregate-value
+                #:has-cc-generic-services
+                #:has-ctype
+                #:has-default-value
+                #:has-deprecated
+                #:has-double-value
+                #:has-end
+                #:has-experimental-map-key
+                #:has-extendee
+                #:has-identifier-value
+                #:has-input-type
+                #:has-is-extension
+                #:has-java-generate-equals-and-hash
+                #:has-java-generic-services
+                #:has-java-multiple-files
+                #:has-java-outer-classname
+                #:has-java-package
+                #:has-label
+                #:has-message-set-wire-format
+                #:has-name
+                #:has-name-part
+                #:has-negative-int-value
+                #:has-no-standard-descriptor-accessor
+                #:has-number
+                #:has-optimize-for
+                #:has-options
+                #:has-output-type
+                #:has-package
+                #:has-packed
+                #:has-positive-int-value
+                #:has-py-generic-services
+                #:has-source-code-info
+                #:has-start
+                #:has-string-value
+                #:has-type
+                #:has-type-name
+                #:identifier-value
+                #:input-type
+                #:is-extension
+                #:java-generate-equals-and-hash
+                #:java-generic-services
+                #:java-multiple-files
+                #:java-outer-classname
+                #:java-package
+                #:label
+                #:location
+                #:message-set-wire-format
+                #:message-type
+                #:name
+                #:name-part
+                #:negative-int-value
+                #:nested-type
+                #:no-standard-descriptor-accessor
+                #:optimize-for
+                #:options
+                #:output-type
+                #:packed
+                #:path
+                #:positive-int-value
+                #:py-generic-services
+                #:service
+                #:source-code-info
+                #:span
+                #:start
+                #:string-value
+                #:type-name
+                #:uninterpreted-option
+                #:value)
+  ;; Descriptor symbols that conflict with standard Common Lisp symbols.
+  (:shadowing-import-from #:com.google.protobuf
+                          #:method
+                          #:number
+                          #:package
+                          #:type)
+  (:export #:main))

protoc/protoc.asd

@@ -0,0 +1,51 @@
+;;;; Copyright 2012 Google Inc.  All Rights Reserved
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;;     * Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;     * Redistributions in binary form must reproduce the above
+;;;; copyright notice, this list of conditions and the following disclaimer
+;;;; in the documentation and/or other materials provided with the
+;;;; distribution.
+;;;;     * Neither the name of Google Inc. nor the names of its
+;;;; contributors may be used to endorse or promote products derived from
+;;;; this software without specific prior written permission.
+
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;;; Author: brown@google.com (Robert Brown)
+
+(in-package #:common-lisp-user)
+
+(defpackage #:protoc-system
+  (:documentation "System definition for package PROTOC.")
+  (:use #:common-lisp #:asdf))
+
+(in-package #:protoc-system)
+
+(defsystem protoc
+  :name "Lisp Protoc"
+  :description "Protocol buffer compiler Common Lisp plugin"
+  :version "0.1.0"
+  :author "Robert Brown"
+  :license "See file COPYING and the copyright messages in individual files."
+  :defsystem-depends-on (protobuf)
+  :depends-on (com.google.base)
+  ;; :in-order-to ((test-op (test-op protoc-test)))
+  :components
+  ((:protobuf-source-file "descriptor" :proto-pathname "../google/protobuf/descriptor")
+   (:file "package" :depends-on ("descriptor"))
+   (:file "protoc" :depends-on ("package" "descriptor"))))

protoc/protoc.lisp

@@ -0,0 +1,102 @@
+;;;; Copyright 2012 Google Inc.  All Rights Reserved
+
+;;;; Redistribution and use in source and binary forms, with or without
+;;;; modification, are permitted provided that the following conditions are
+;;;; met:
+
+;;;;     * Redistributions of source code must retain the above copyright
+;;;; notice, this list of conditions and the following disclaimer.
+;;;;     * Redistributions in binary form must reproduce the above
+;;;; copyright notice, this list of conditions and the following disclaimer
+;;;; in the documentation and/or other materials provided with the
+;;;; distribution.
+;;;;     * Neither the name of Google Inc. nor the names of its
+;;;; contributors may be used to endorse or promote products derived from
+;;;; this software without specific prior written permission.
+
+;;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+;;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+;;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+;;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+;;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+;;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+;;;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+;;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+;;;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+;;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;;;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+;;;; Author: brown@google.com (Robert Brown)
+
+;;;; Protocol buffer compiler Common Lisp plugin.
+
+(in-package #:protoc)
+(declaim #.*optimize-default*)
+
+(defparameter *parsed-proto* "unittest_import.pb")
+
+(defun read-file-descriptor-set ()
+  (with-open-file (input *parsed-proto* :direction :input :element-type 'octet)
+    (let* ((size (file-length input))
+           (buffer (make-octet-vector size))
+           (file-descriptor-set (make-instance 'file-descriptor-set)))
+      (read-sequence buffer input)
+      (pb:merge-from-array file-descriptor-set buffer 0 size)
+      file-descriptor-set)))
+
+
+(defun hyphenate-studly-caps (string)
+  (let ((state 'unknown)
+        (result '()))
+    (dotimes (i (length string))
+      (let ((char (aref string i)))
+        (push char result)
+        (ecase state
+          (unknown
+           (when (alpha-char-p char)
+             (setf state (if (upper-case-p char) 'upper 'lower))))
+          (lower
+           (when (< i (1- (length string)))
+             ;; We can look ahead one character.
+             (let ((next (aref string (1+ i))))
+               (cond ((not (alpha-char-p next)) (setf state 'unknown))
+                     ((upper-case-p next)
+                      (push #\- result)
+                      (setf state 'upper))))))
+          (upper
+           (when (< i (- (length string) 2))
+             ;; We can look two characters ahead.
+             (let ((next (aref string (1+ i))))
+               (cond ((not (alpha-char-p next)) (setf state 'unknown))
+                     ((lower-case-p next) (setf state 'lower))
+                     (t (let ((following (aref string (+ i 2))))
+                          (when (and (alpha-char-p following) (lower-case-p following))
+                            (push #\- result)
+                            (push next result)
+                            (incf i)
+                            (setf state 'lower)))))))))))
+    (make-array (length result)
+                :element-type 'character
+                :initial-contents (reverse result))))
+
+(defun lispify-name (name)
+  (let ((hyphenated (hyphenate-studly-caps name)))
+    (intern (string-upcase (substitute #\- #\_ hyphenated)))))
+
+(defun class-symbol (descriptor)
+  (lispify-name (pb:string-value (name descriptor))))
+
+(defun slot-definition (descriptor)
+  (declare (ignore descriptor))
+  '())
+
+(defun message-defclass (descriptor)
+  (let ((class-symbol (class-symbol descriptor))
+        (field-count (length (field descriptor)))
+        (slot-definitions (loop for field across (field descriptor)
+                                collect (slot-definition field))))
+    `((defclass ,class-symbol (pb:protocol-buffer)
+        (,slot-definitions
+         (%has-bits% :accessor %has-bits% :initform 0 :type (unsigned-byte ,field-count))
+         (pb::%cached-size% :initform 0 :type vector-index)))
+      (export ',class-symbol))))