forked from qitab/cl-protobufs
-
Notifications
You must be signed in to change notification settings - Fork 0
/
define-proto.lisp
1621 lines (1473 loc) · 81.7 KB
/
define-proto.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; Copyright 2012-2020 Google LLC
;;;
;;; Use of this source code is governed by an MIT-style
;;; license that can be found in the LICENSE file or at
;;; https://opensource.org/licenses/MIT.
(in-package #:cl-protobufs.implementation)
;;; Protocol buffer defining macros
#|
Notes on macroexpansion:
The lisp generated proto file should look like:
-------------------------------
;; In a package named "cl-protobufs.<the-proto-package-name>"
;; With a local-nickname pi for cl-protobufs.implementation
(pi:define-message color-wheel1 ()
;; Nested messages.
(pi:define-message color-wheel1.metadata1 ()
;; Fields.
(author :index 1 :type cl:string :label (:optional) :typename "string")
(revision :index 2 :type cl:string :label (:optional) :typename "string")
(date :index 3 :type cl:string :label (:optional) :typename "string"))
;; Fields.
(name :index 1 :type cl:string :label (:required) :typename "string")
(colors :index 2 :type (list-of color1) :label (:repeated :list)
:typename "Color1")
(metadata :index 3 :type (cl:or cl:null color-wheel1.metadata1)
:label (:optional) :typename "Metadata1"))
(cl:eval-when (:compile-toplevel :load-toplevel :execute)
(pi:add-file-descriptor #P"third_party/lisp/cl_protobufs/tests/serialization.proto"
pi::*file-descriptors*))
(export ...)
-------------------------------
The define-schema form stores the file-descriptor for the current file in
*current-file-descriptor*. The file-descriptor holds the protobuf-service
objects that are generated by the define-service macro.
TODO(jgodbout): Remove all schema.
Next we get into the define-* macro's.
The possible top level define macros are:
- define-enum
- define-message
- define-extend
- define-service
Inside of those macros there may also be define-* forms:
- define-enum
- define-message
- define-extension
- define-extend
- define-service
- define-map
- define-oneof
The most common define-* forms are those that define messages, which generate
MESSAGE-DESCRIPTOR classes and create the message structures that hold
data. These are:
- define-message
- define-extend
DEFINE-ENUM:
The define-enum macro creates a ENUM-DESCRIPTOR meta-object, as well as methods
to access the default value, and convert from the enum keyword to the numerical
value and back.
DEFINE-EXTENSION:
Creates an EXTENSION-DESCRIPTOR and stores it in the containing message. This
descriptor simply defines the allowed range of indices for extending the
message.
DEFINE-EXTEND:
The define-extend macro creates a PROTOBUF-MESSAGE meta-object that overrides a
PROTOBUF-MESSAGE meta-object created in define-message. The new meta-object
is identical to the original but with extra fields.
We return forms to create this meta-object as well as accessors and
setters for the new fields.
DEFINE-MESSAGE:
The define-message macro works much the same way. It takes the type (message
name) and a list of sub-elements which may include define-message,
define-extension, define-extend, define-enum, or a field which is just a
declaration of the field object in a proto.
Example: (author :index 1 :type cl:string :label (:optional) :typename "string")
First we create the PROTOBUF-MESSAGE meta-object that is defined in the
define-message lambda list and store it in *current-message-descriptor*. If we
see a define-message we recursively call the define macro to create a submessage
named:
top-level-message.submessage1.submessage2
We save the resultant forms that are output so define-message may output them
at the and of the macro-call.
If we see a define-enum, define-message, or define-extend macro
we save the resultant form to a list of forms to output.
The deprecated "group" feature is handled in the protoc plug-in by generating
both a nested message and a field that uses the nested message.
If we see a field we call process-field which creates a FIELD-DESCRIPTOR
containing details of the field and returns a form to create this meta-object.
We save the form for both output and future processing.
Next we call MAKE-STRUCTURE-CLASS-FORMS that takes the field meta-objects
and creates forms for creating defstruct form for the proto data container
that will be used in client code. This is where the accessors, setters, and has
functions are defined. It outputs all of the forms to create these objects.
Finally we output all of the created forms.
DEFINE-SERVICE:
The define-service macro creates forms that make the SERVICE-DESCRIPTOR, add it to the
PROTOBUF-SCHEMA meta-object, and create method stubs for the service implementation.
Note: Actually using services require a gRPC plugin.
DEFINE-ONEOF:
The define-oneof macro takes a body of field defintions and creates a ONEOF-DESCRIPTOR
meta-object which holds field descriptors for the fields in its body. This
ONEOF-DESCRIPTOR gets appended to the message's PROTO-ONEOFS slot. Then,
MAKE-STRUCTURE-CLASS-FORMS will use the PROTO-ONEOFS slot to create forms for accessing
the oneof and its nested fields.
|#
(defvar *current-file-descriptor* nil
"The file-descriptor for the file currently being loaded.")
(defvar *current-message-descriptor* nil
"The message-descriptor for the message or group currently being loaded.")
;;; TODO(jgodbout): remove this, we already have field-descriptor
;;; "The only reason you would ever want a field-data struct instead of a
;;; field-descriptor is when you define a slot on the object which doesn't
;;; constitute a field (i.e. the %%BOOL-VALUES and %%IS-SET vectors). So in
;;; that sense, the name field-data is quite bad." --bkuehnert
(defstruct field-data
"Keep field metadata for making the structure object."
(internal-slot-name nil :type symbol)
(external-slot-name nil :type symbol)
(container nil :type (member nil :vector :list))
(accessor nil)
(type nil)
(kind nil)
(initarg nil)
(initform nil))
(defun validate-imports (file-descriptor imports)
"Validates that all of the IMPORTS (a list of file names) have
already been loaded. FILE-DESCRIPTOR is the descriptor of the
file doing the importing."
(dolist (import (reverse imports))
(let* ((imported (find-file-descriptor (if (stringp import) (pathname import) import))))
(unless imported
(protobuf-error "Could not find file ~S imported by ~S" import file-descriptor)))))
(defun define-schema (type &key name syntax edition package import
optimize options)
"Define a schema named TYPE, corresponding to a .proto file of that name.
NAME can be used to override the defaultly generated Protobufs name.
SYNTAX, EDITION, and PACKAGE are as they would be in a .proto file.
IMPORT is a list of pathname strings to be imported.
OPTIMIZE can be either :space (the default) or :speed; if it is :speed, the
serialization code will be much faster, but much less compact.
OPTIONS is a property list, i.e., (\"key1\" \"val1\" \"key2\" \"val2\" ...)."
(let* ((name (or name (class-name->proto type)))
(package (and package (if (stringp package)
package
(string-downcase (string package)))))
(options (remove-options
(loop for (key val) on options by #'cddr
collect (make-option
(if (symbolp key)
(slot-name->proto key)
key)
val))
"optimize_for"))
(imports (if (listp import) import (list import)))
(descriptor (make-instance
'file-descriptor
:class type
:name name
;; CCL requires syntax to be OR'd with :proto2, :proto3, or :editions
;; in case syntax is NIL.
:syntax (or syntax :proto2 :proto3 :editions)
:edition edition
:package package
:imports imports
:options (if optimize
(append options
(list (make-option
"optimize_for"
(if (eq optimize :speed)
"SPEED"
"CODE_SIZE")
'symbol)))
options))))
(record-file-descriptor descriptor)
(setf *current-file-descriptor* descriptor)
(validate-imports descriptor imports)))
(defgeneric enum-int-to-keyword (enum-type integer)
(:documentation
"Converts INTEGER to the corresponding enum keyword. If there are multiple
keywords assigned to the same value (i.e., allow_alias = true in the enum
source) then the first one is returned. ENUM-TYPE is the enum type name.
If no enum exists for the specified integer return nil."))
(defgeneric enum-keyword-to-int (enum-type keyword)
(:documentation
"Converts a KEYWORD to its corresponding integer value. ENUM-TYPE is the
enum-type name."))
(defun make-enum-conversion-forms (type open-type value-descriptors)
"Generates forms for enum <-> integer conversion functions. TYPE is the enum
type name. OPEN-TYPE is a type including the possibility of unknown enum keywords
as well as type. VALUE-DESCRIPTORS is a list of enum-value-descriptor objects."
(let ((key2int (fintern "~A-KEYWORD-TO-INT" type))
(int2key (fintern "~A-INT-TO-KEYWORD" type)))
`(progn
(defun ,key2int (enum)
(declare (type ,open-type enum))
(let ((int (case enum
,@(loop for desc in value-descriptors
collect `(,(enum-value-descriptor-name desc)
,(enum-value-descriptor-value desc)))
(t (parse-integer (subseq (symbol-name enum)
+%undefined--length+)
:junk-allowed t)))))
int))
(defun ,int2key (numeral)
(declare (type int32 numeral))
(the (or null ,type)
(let ((key (case numeral
,@(loop with mapped = (make-hash-table)
for desc in value-descriptors
for int = (enum-value-descriptor-value desc)
for already-set-p = (gethash int mapped)
do (setf (gethash int mapped) t)
unless already-set-p
collect `(,int ,(enum-value-descriptor-name desc))))))
key)))
(setf (get ',type 'enum-int-to-keyword) ',int2key)
(setf (get ',type 'enum-keyword-to-int) ',key2int)
(defmethod cl-protobufs:enum-keyword-to-int
((e (eql ',type)) keyword)
(,key2int keyword))
(defmethod cl-protobufs:enum-int-to-keyword
((e (eql ',type)) numeral)
(,int2key numeral)))))
(defgeneric enum-default-value (enum-type)
(:documentation
"Get the default enum value for ENUM-TYPE"))
(defmethod enum-default-value (enum-type)
"If no default enum value function can be found for a specific ENUM-TYPE
return nil."
nil)
(defun make-enum-constant-forms (type enum-values)
"Generates forms for defining a constant for each enum value in ENUM-VALUES.
TYPE is the enum type name. ENUM-VALUES is a list of ENUM-VALUE-DESCRIPTORs.
Constant names are in the form of +<message_name>.<value_name>+ when the enum is defined in a
message, and of +<value_name>+ when the enum is defined at top-level."
(let* ((enum-name (symbol-name type))
(dot (position #\. enum-name :test #'char= :from-end t))
;; Use C/C++ enum scope.
(scope (and dot (subseq enum-name 0 dot)))
(constants
(loop for v in enum-values
for c = (fintern "+~@[~A.~]~A+" scope (enum-value-descriptor-name v))
collect `(defconstant ,c ,(enum-value-descriptor-value v)))))
`(progn
,@constants
(export ',(mapcar #'second constants)))))
(defconstant +%undefined--length+ 11
"The length of %undefined- which is used frequently below")
(defun keyword-contains-%undefined-int-p (enum-keyword)
"An unknown ENUM-KEYWORD will be compiled as :%undefined-{integer} so our type
predicate must check that."
(when (keywordp enum-keyword)
(let ((keyword-name (symbol-name enum-keyword)))
(and (> (length keyword-name) +%undefined--length+)
(starts-with keyword-name "%UNDEFINED-")
(parse-integer (subseq keyword-name +%undefined--length+) :junk-allowed t)))))
(defun enum-open-type (type)
"We want the deftype of an enum TYPE to be a strict set of the keywords,
but we want an internal version for the case where we deserialized an unknown
(newer) version of hte enum with an unknown field."
(intern (format nil "%%%%~a" type)
(symbol-package type)))
(defmacro define-enum (type (&key name) &body values)
"Define a Lisp type given the data for a protobuf enum type.
Also generates conversion functions between enum values and integers:
<enum_name>-keyword-to-int and <enum_name>-int-to-keyword. Both
accept an optional default value argument.
Parameters:
TYPE: The name of the type.
NAME: Override for the protobuf enum type name.
VALUES: The possible values for the enum in the form (name :index value)."
(let ((name (or name (class-name->proto type)))
(open-type (enum-open-type type)))
(with-collectors ((names collect-name) ; keyword symbols
(forms collect-form)
(value-descriptors collect-value-descriptor))
;; The middle value is :index, useful for readability of generated code...
;; (Except that the value is not actually an index, nor is the slot called index anymore.)
(loop for (name nil value) in values do
(let* ((val-desc (make-enum-value-descriptor :value value :name name)))
(collect-name name)
(collect-value-descriptor val-desc)))
(let ((enum (make-enum-descriptor :class type
:name name
:values value-descriptors)))
(collect-form `(deftype ,open-type ()
'(or (member ,@names)
(satisfies keyword-contains-%undefined-int-p))))
(collect-form `(deftype ,type () '(member ,@names)))
(collect-form (make-enum-conversion-forms type open-type value-descriptors))
(collect-form (make-enum-constant-forms type value-descriptors))
;; The default value is the keyword associated with the first element.
(collect-form `(defmethod enum-default-value ((e (eql ',type)))
,(enum-value-descriptor-name (car value-descriptors))))
(collect-form `(record-protobuf-object ',type ,enum :enum))
(collect-form `(export '(,open-type)))
;; Register it by the full symbol name.
(record-protobuf-object type enum :enum))
`(progn ,@forms))))
(defmacro define-map (field-name &key key-type value-type json-name index
value-kind val-default)
"Define a Lisp type given the data for a protobuf map type.
Parameters:
FIELD-NAME: Lisp name of the field containing this map.
KEY-TYPE: Lisp type of the map's keys.
VALUE-TYPE: Lisp type of the map's values.
JSON-NAME: String to use for the map field when reading/writing JSON.
Either the value of the json_name field option or derived from the
field name.
VALUE-KIND: Category of the value type: :scalar, :message, :enum, etc.
INDEX: Message field number of this map type.
VAL-DEFAULT: Default value for the map entries, or nil to use $empty-default."
(assert json-name)
(assert value-kind)
(check-type index integer)
(let* ((internal-slot-name (fintern "%~A" field-name))
(qual-name (make-qualified-name *current-message-descriptor*
(slot-name->proto field-name)))
(class (fintern (uncamel-case qual-name)))
(mdata (make-field-data
:internal-slot-name internal-slot-name
:external-slot-name field-name
:type 'hash-table
:initform (if (eql key-type 'cl:string)
'(make-hash-table :test #'equal)
'(make-hash-table :test #'eq))
:accessor field-name))
(mfield (make-instance 'field-descriptor
:name (slot-name->proto field-name)
:class class
:qualified-name qual-name
:label :optional
:index index
:internal-field-name internal-slot-name
:external-field-name field-name
:json-name json-name
:type 'cl:hash-table
:default (or val-default
$empty-default)
:kind :map
:field-offset nil))
(map-desc (make-map-descriptor :key-type key-type
:value-type value-type
:value-kind value-kind)))
(record-protobuf-object class map-desc :map)
`((record-protobuf-object ',class ,map-desc :map)
,mfield
,mdata)))
(defmacro define-oneof (name (&key synthetic-p) &body fields)
"Creates a oneof descriptor and the defining forms for its fields.
Parameters:
NAME: The name of the oneof.
SYNTHETIC-P: If true, this oneof is automatically generated by protoc, in
which case the special oneof accessors should not be created.
FIELDS: Field as output by protoc."
(let* ((internal-name (fintern "%~A" name))
(field-descriptors (make-array (length fields))))
(loop for field in fields
for oneof-offset from 0
do
;; TODO(cgay): this doesn't currently handle groups. If we want to
;; support this we need to handle define-message and fields with :kind
;; :group here.
(destructuring-bind (slot &key type name (default nil default-p)
lazy json-name index kind &allow-other-keys)
field
(assert json-name)
(assert index)
(let ((default (if default-p default $empty-default)))
(setf (aref field-descriptors oneof-offset)
(make-instance 'field-descriptor
:name (or name (slot-name->proto slot))
:type type
:kind kind
:class type
:qualified-name (make-qualified-name
*current-message-descriptor*
(or name (slot-name->proto slot)))
:label :optional
:index index
;; Oneof fields don't have a bit in the %%is-set vector, as field
;; presence is tracked via the SET-FIELD slot of the oneof struct.
:field-offset nil
:internal-field-name internal-name
:external-field-name slot
:json-name json-name
:oneof-offset oneof-offset
:default default
:lazy (and lazy t))))))
`(progn
,(make-oneof-descriptor :internal-name internal-name
:external-name name
:synthetic-p (and synthetic-p t)
:fields field-descriptors))))
(defun-inline proto-%%bytes (obj)
"Returns the %%bytes field of the proto object OBJ."
(slot-value obj '%%bytes))
(defun-inline (setf proto-%%bytes) (new-value obj)
"Sets the %bytes field of the proto object OBJ with NEW-VALUE."
(setf (slot-value obj '%%bytes) new-value))
(defstruct field-accessors
"Structure containing the get, set, and has functions
for a proto-message field."
(get nil :type symbol)
(set nil :type list)
(has nil :type symbol)
(clear nil :type symbol))
(defun set-field-accessor-functions (message-name field-name)
"Set the get, set, and has functions for a proto field on a field's symbol p-list.
Parameters:
MESSAGE-NAME: The symbol name of the protobuf message containing the field.
FIELD-NAME: The symbol name for the field."
(setf (get field-name message-name)
(make-field-accessors
:get (proto-slot-function-name message-name field-name :get)
:set `(setf ,(proto-slot-function-name message-name field-name :get))
:has (proto-slot-function-name message-name field-name :internal-has)
:clear (proto-slot-function-name message-name field-name :clear))))
(defun make-common-forms-for-structure-class (proto-type public-slot-name slot-name field)
"Create the common forms needed for all message fields: has, is-set, clear, set.
Parameters:
PROTO-TYPE: The Lisp type name of the proto message.
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix).
SLOT-NAME: Slot name for the field (with the #\% prefix).
FIELD: The class object field definition of the field."
(let ((public-accessor-name (proto-slot-function-name proto-type public-slot-name :get))
(is-set-accessor (fintern "~A-%%IS-SET" proto-type))
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
(internal-has-function-name
(proto-slot-function-name proto-type public-slot-name :internal-has))
(external-has-function-name
(proto-slot-function-name proto-type public-slot-name :has))
(default-form (get-default-form (proto-type field)
(proto-default field)
(proto-container field)
(proto-type field)))
(index (proto-field-offset field))
(clear-function-name (proto-slot-function-name proto-type public-slot-name :clear))
(bool-index (proto-bool-index field))
(bit-field-name (fintern "~A-%%BOOL-VALUES" proto-type))
(field-type (cond ((eq (proto-container field) :vector)
`(cl-protobufs:vector-of ,(proto-type field)))
((eq (proto-container field) :list)
`(cl-protobufs:list-of ,(proto-type field)))
(t (proto-type field)))))
;; If index is nil, then this field does not have a reserved bit in the %%is-set vector.
;; This means that the field is proto3-style optional, so checking for field presence must
;; be done by checking if the bound value is default.
(with-gensyms (obj new-value cur-value)
`(
(defun-inline (setf ,public-accessor-name) (,new-value ,obj)
(declare (type ,field-type ,new-value))
,(when index
`(setf (bit (,is-set-accessor ,obj) ,index) 1))
,(if bool-index
`(setf (bit (,bit-field-name ,obj) ,bool-index)
(if ,new-value 1 0))
`(setf (,hidden-accessor-name ,obj) ,new-value)))
;; For proto3-style optional fields, the has-* function is repurposed. It now answers the
;; question: "Is this field set to the default value?". This is done so that the optimized
;; serializer can use the has-* function to check if an optional field should be serialized.
(defun-inline ,internal-has-function-name (,obj)
,(if index
`(= (bit (,is-set-accessor ,obj) ,index) 1)
`(let ((,cur-value ,(if bool-index
`(plusp (bit (,bit-field-name ,obj) ,bool-index))
`(,hidden-accessor-name ,obj))))
,(case (proto-container field)
(:vector `(not (= (length ,cur-value) 0)))
(:list `(and ,cur-value t))
(t (case (proto-type field)
((byte-vector cl:string) `(> (length ,cur-value) 0))
((cl:double-float cl:float) `(not (= ,cur-value ,default-form)))
(cl:hash-table `(> (hash-table-count ,cur-value) 0))
;; Otherwise, the type is integral. EQ suffices to check equality.
(t `(not (eq ,cur-value ,default-form)))))))))
;; has-* functions are not exported for proto3-style optional fields. They are only for
;; internal usage.
,@(unless (eq (proto-syntax *current-file-descriptor*) :proto3)
`((defun-inline ,external-has-function-name (,obj)
(,internal-has-function-name ,obj))
(export '(,external-has-function-name))))
;; Clear function
;; Map type clear functions are created in make-map-accessor-forms.
;; todo(benkuehnert): rewrite map types/definers so that this isn't necessary
,@(unless (eq (proto-kind field) :map)
`((defun-inline ,clear-function-name (,obj)
,(when index
`(setf (bit (,is-set-accessor ,obj) ,index) 0))
,(if bool-index
`(setf (bit (,bit-field-name ,obj) ,bool-index)
,(if default-form 1 0))
`(setf (,hidden-accessor-name ,obj) ,default-form)))))
;; Create defmethods to allow for getting/setting compatibly
;; with the standard-classes.
(defmethod ,public-slot-name ((,obj ,proto-type))
(,public-accessor-name ,obj))
(defmethod (setf ,public-slot-name) (,new-value (,obj ,proto-type))
(setf (,public-accessor-name ,obj) ,new-value))
(set-field-accessor-functions ',proto-type ',public-slot-name)
,(unless (eq (proto-kind field) :map)
`(export '(,clear-function-name)))
(export '(,public-accessor-name))))))
(defun make-repeated-field-accessors (proto-type field)
"Make and return forms that define functions that accesses a proto
repeated slot.
A push function pushes onto the front for a list repeated field,
and onto the back for a vector repeated field. It returns the element added.
A length function returns a fixnum of the number of the elements in the
repeated field.
An nth function returns the nth element in a repeated field,
or signals an out of bounds error.
Parameters:
PROTO-TYPE: The Lisp name of the containing message.
FIELD: The field we are making the functions for."
(let* ((public-slot-name (proto-external-field-name field))
(public-accessor-name (proto-slot-function-name
proto-type public-slot-name :get))
(push-function-name (proto-slot-function-name
proto-type public-slot-name :push))
(push-method-name (fintern "PUSH-~A" public-slot-name))
(length-function-name (proto-slot-function-name
proto-type public-slot-name :length-OF))
(length-method-name (fintern "LENGTH-OF-~A" public-slot-name))
(nth-function-name (proto-slot-function-name
proto-type public-slot-name :nth))
(nth-method-name (fintern "NTH-~A" public-slot-name))
(field-type (proto-type field)))
(with-gensyms (obj element n)
`((defun ,push-function-name (,element ,obj)
(declare (type ,proto-type ,obj)
(type ,field-type ,element))
,(if (eq (proto-container field) :vector)
`(progn (vector-push-extend ,element
(,public-accessor-name ,obj))
,element)
`(push ,element (,public-accessor-name ,obj))))
(defun ,length-function-name (,obj)
(declare (type ,proto-type ,obj))
(the fixnum
(length (,public-accessor-name ,obj))))
(defun ,nth-function-name (,n ,obj)
(declare (type ,proto-type ,obj)
(type fixnum ,n))
(the ,field-type
(let ((length (length (,public-accessor-name ,obj))))
(when (i< length ,n)
(protobuf-error "Repeated field ~S is length ~D but element ~D was requested."
',public-slot-name length ,n))
,(if (eq (proto-container field) :vector)
`(aref (,public-accessor-name ,obj) ,n)
`(nth ,n (,public-accessor-name ,obj))))))
(defmethod ,push-method-name (,element (,obj ,proto-type))
(,push-function-name ,element ,obj))
(defmethod ,length-method-name ((,obj ,proto-type))
(,length-function-name ,obj))
(defmethod ,nth-method-name ((,n integer) (,obj ,proto-type))
(,nth-function-name ,n ,obj))
(export '(,push-method-name ,push-function-name
,nth-function-name ,nth-method-name
,length-function-name ,length-method-name))))))
(defun make-oneof-accessor-forms (proto-type oneof)
"Make and return forms that define accessor functions for a oneof and its fields.
Paramters:
PROTO-TYPE: The lisp name of the containing message of this oneof.
ONEOF: The oneof-descriptor of the oneof to make accessors for."
(let* ((public-slot-name (oneof-descriptor-external-name oneof))
(hidden-slot-name (oneof-descriptor-internal-name oneof))
(hidden-accessor-name (fintern "~A-~A" proto-type hidden-slot-name))
(case-function-name (proto-slot-function-name proto-type public-slot-name :case))
(internal-has-function-name
(proto-slot-function-name proto-type public-slot-name :internal-has))
(external-has-function-name
(proto-slot-function-name proto-type public-slot-name :has))
(clear-function-name (proto-slot-function-name proto-type public-slot-name :clear)))
(with-gensyms (obj)
`(
;; Since the oneof struct stores an integer to indicate which field is set, it is not
;; particularly useful for the user when writing code surrounding oneof types. This
;; creates a function which returns a symbol with the same name as the field which
;; is currently set. If the field is not set, this function returns nil.
(defun-inline ,case-function-name (,obj)
(ecase (oneof-set-field (,hidden-accessor-name ,obj))
,@(loop for field across (oneof-descriptor-fields oneof)
collect
`(,(proto-oneof-offset field) ',(proto-external-field-name field)))
((nil) nil)))
(defun-inline ,internal-has-function-name (,obj)
(not (eql (oneof-set-field (,hidden-accessor-name ,obj)) nil)))
(defun-inline ,external-has-function-name (,obj)
(,internal-has-function-name ,obj))
(defun-inline ,clear-function-name (,obj)
(setf (oneof-value (,hidden-accessor-name ,obj)) nil)
(setf (oneof-set-field (,hidden-accessor-name ,obj)) nil))
;; Special oneof forms are only created when ONEOF is not synthetic.
,(unless (oneof-descriptor-synthetic-p oneof)
`(export '(,case-function-name ,external-has-function-name ,clear-function-name)))
;; Fields inside of a oneof need special accessors, since they need to consult
;; with the oneof struct. This creates those special accessors for each field.
;; This mostly mirrors what happens in make-common-forms-for-structure-class
;; and make-structure-class-forms-non-lazy, but they consult the oneof struct
;; to check if they are set.
,@(loop
for field across (oneof-descriptor-fields oneof)
append
(let* ((public-slot-name (proto-external-field-name field))
(public-accessor-name (proto-slot-function-name
proto-type public-slot-name :get))
(internal-has-function-name (proto-slot-function-name
proto-type public-slot-name :internal-has))
(external-has-function-name (proto-slot-function-name
proto-type public-slot-name :has))
(clear-function-name (proto-slot-function-name
proto-type public-slot-name :clear))
(default-form (get-default-form (proto-type field)
(proto-default field)
(proto-container field)
(proto-kind field)))
(field-type (proto-type field))
(oneof-offset (proto-oneof-offset field)))
;; If a field isn't currently set inside of the oneof, just return its
;; default value.
(with-gensyms (obj new-value bytes field-obj)
`((defun-inline ,public-accessor-name (,obj)
(if (eq (oneof-set-field (,hidden-accessor-name ,obj))
,oneof-offset)
,(if (proto-lazy-p field)
`(let* ((,field-obj (oneof-value (,hidden-accessor-name ,obj)))
(,bytes (and ,field-obj (proto-%%bytes ,field-obj))))
(if ,bytes
(setf (oneof-value (,hidden-accessor-name ,obj))
(%deserialize ',(proto-class field)
,bytes nil nil))))
`(oneof-value (,hidden-accessor-name ,obj)))
,default-form))
(defun-inline (setf ,public-accessor-name) (,new-value ,obj)
(declare (type ,field-type ,new-value))
(setf (oneof-set-field (,hidden-accessor-name ,obj))
,oneof-offset)
(setf (oneof-value (,hidden-accessor-name ,obj)) ,new-value))
(defun-inline ,internal-has-function-name (,obj)
(eq (oneof-set-field (,hidden-accessor-name ,obj))
,oneof-offset))
(defun-inline ,external-has-function-name (,obj)
(,internal-has-function-name ,obj))
(defun-inline ,clear-function-name (,obj)
(when (,internal-has-function-name ,obj)
(setf (oneof-value (,hidden-accessor-name ,obj)) nil)
(setf (oneof-set-field (,hidden-accessor-name ,obj)) nil)))
(defmethod ,public-slot-name ((,obj ,proto-type))
(,public-accessor-name ,obj))
(defmethod (setf ,public-slot-name) (,new-value (,obj ,proto-type))
(setf (,public-accessor-name ,obj) ,new-value))
(set-field-accessor-functions ',proto-type ',public-slot-name)
(export '(,external-has-function-name
,clear-function-name
,public-accessor-name))))))))))
(defun make-map-accessor-forms (proto-type public-slot-name slot-name field)
"This creates forms that define map accessors which are type safe. Using these will
guarantee that the resulting map can be properly serialized, whereas if one modifies
the underlying map (which is accessed via the make-common-forms-for-structure-class
function) then there is no guarantee on the serialize function working properly.
Parameters:
PROTO-TYPE: The Lisp type name of the proto message.
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix).
SLOT-NAME: Slot name for the field (with the #\% prefix).
FIELD: The class object field definition of the field."
(let* ((public-accessor-name (proto-slot-function-name proto-type public-slot-name :map-get))
(public-remove-name (proto-slot-function-name proto-type public-slot-name :map-rem))
(clear-function-name (proto-slot-function-name proto-type public-slot-name :clear))
(method-accessor-name (fintern "~A-gethash" public-slot-name))
(method-remove-name (fintern "~A-remhash" public-slot-name))
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
(map-descriptor (find-map-descriptor (proto-class field)))
(key-type (proto-key-type map-descriptor))
(value-type (proto-value-type map-descriptor))
(value-kind (proto-value-kind map-descriptor))
(val-default-form
(get-default-form value-type (proto-default field) nil value-kind)))
(with-gensyms (obj new-val new-key)
`(
(defun-inline (setf ,public-accessor-name) (,new-val ,new-key ,obj)
(declare (type ,key-type ,new-key)
(type ,value-type ,new-val))
(setf (gethash ,new-key (,hidden-accessor-name ,obj)) ,new-val))
;; If the map's value type is a message, then the default value returned
;; should be nil. However, we do not want to allow the user to insert nil
;; into the map, so this binding only applies to get function.
,@(let ((val-type (if (member value-kind '(:message :group :extends))
(list 'or 'null value-type)
value-type)))
`((defun-inline ,public-accessor-name (,new-key ,obj)
(declare (type ,key-type ,new-key))
(the (values ,(if (eq value-kind :enum)
(enum-open-type val-type)
val-type)
t)
(multiple-value-bind (val flag)
(gethash ,new-key (,hidden-accessor-name ,obj))
(if flag
(values val flag)
(values ,val-default-form nil)))))))
(defun-inline ,public-remove-name (,new-key ,obj)
(declare (type ,key-type ,new-key))
(remhash ,new-key (,hidden-accessor-name ,obj)))
(defun-inline ,clear-function-name (,obj)
(clrhash (,hidden-accessor-name ,obj)))
;; These defmethods have the same functionality as the functions defined above
;; but they don't require a refernece to the message type, so using them is more
;; convenient.
(defmethod (setf ,method-accessor-name) (,new-val ,new-key (,obj ,proto-type))
(setf (,public-accessor-name ,new-key ,obj) ,new-val))
(defmethod ,method-accessor-name (,new-key (,obj ,proto-type))
(,public-accessor-name ,new-key ,obj))
(defmethod ,method-remove-name (,new-key (,obj ,proto-type))
(,public-remove-name ,new-key ,obj))
(export '(,public-accessor-name
,public-remove-name
,clear-function-name
,method-accessor-name
,method-remove-name))))))
(defun make-structure-class-forms-lazy (proto-type field public-slot-name)
"Makes forms for the lazy fields of a proto message using STRUCTURE-CLASS.
Parameters:
PROTO-TYPE: The Lisp type name of the proto message.
FIELD: The field definition for which to define accessors.
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix)."
(let* ((slot-name (proto-internal-field-name field))
(repeated (eq (proto-label field) :repeated))
(vectorp (eq :vector (proto-container field)))
(public-accessor-name (proto-slot-function-name proto-type public-slot-name :get))
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
(accessor-return-type
(cond ((eq (proto-container field) :vector)
`(cl-protobufs:vector-of ,(proto-type field)))
((eq (proto-container field) :list)
`(cl-protobufs:list-of ,(proto-type field)))
((member (proto-kind field) '(:message :group :extends))
`(or null ,(proto-type field)))
(t (proto-type field)))))
(with-gensyms (obj field-obj bytes)
`((defun-inline ,public-accessor-name (,obj)
(the
,accessor-return-type
,(if (not repeated)
`(let* ((,field-obj (,hidden-accessor-name ,obj))
(,bytes (and ,field-obj (proto-%%bytes ,field-obj))))
(if ,bytes
(setf (,hidden-accessor-name ,obj)
;; Re-create the field object by deserializing its %%bytes
;; field.
(%deserialize ',(proto-class field) ,bytes nil nil))
,field-obj))
`(let ((,field-obj (,hidden-accessor-name ,obj)))
(if (notany #'proto-%%bytes ,field-obj)
,field-obj
,(with-gensyms (maybe-deserialize field-element)
`(flet ((,maybe-deserialize (,field-element)
(let ((,bytes (proto-%%bytes ,field-element)))
(if ,bytes
;; Re-create the field object by deserializing
;; its %%bytes field.
(%deserialize ',(proto-class field) ,bytes nil nil)
,field-element))))
(setf (,hidden-accessor-name ,obj)
,(if vectorp
`(map 'vector #',maybe-deserialize
(the vector ,field-obj))
`(mapcar #',maybe-deserialize ,field-obj))))))))))
,@(make-common-forms-for-structure-class proto-type public-slot-name slot-name field)))))
(defun make-structure-class-forms-non-lazy (proto-type field public-slot-name)
"Makes forms for the non-lazy fields of a proto message.
Parameters:
PROTO-TYPE: The Lisp type name of the proto message.
FIELD: The field definition for which to define accessors.
PUBLIC-SLOT-NAME: Public slot name for the field (without the #\% prefix)."
(let* ((slot-name (proto-internal-field-name field))
(public-accessor-name (proto-slot-function-name proto-type public-slot-name :get))
(hidden-accessor-name (fintern "~A-~A" proto-type slot-name))
(bool-index (proto-bool-index field))
(bit-field-name (fintern "~A-%%BOOL-VALUES" proto-type))
(field-type (proto-type field))
(accessor-return-type
(cond ((eq (proto-container field) :vector)
`(cl-protobufs:vector-of ,field-type))
((eq (proto-container field) :list)
`(cl-protobufs:list-of ,field-type))
((member (proto-kind field) '(:message :group :extends))
`(or null ,field-type))
(t field-type))))
(with-gensyms (obj)
`((defun-inline ,public-accessor-name (,obj)
(the ,accessor-return-type
,(if bool-index
`(plusp (bit (,bit-field-name ,obj) ,bool-index))
`(,hidden-accessor-name ,obj))))
,@(make-common-forms-for-structure-class
proto-type public-slot-name slot-name field)
,@(when (proto-container field)
(make-repeated-field-accessors proto-type field))
;; Make special map forms.
,@(when (typep (find-map-descriptor (proto-class field)) 'map-descriptor)
(make-map-accessor-forms
proto-type public-slot-name slot-name field))))))
(let ((defaults (make-hash-table)))
(loop for type in '(int32 uint32 fixed32 sfixed32 sint32
int64 uint64 fixed64 sfixed64 sint64)
do (setf (gethash type defaults) 0))
(setf (gethash 'double-float defaults) 0.0d0)
(setf (gethash 'float defaults) 0.0)
(setf (gethash 'boolean defaults) nil)
(setf (gethash 'string defaults) "")
(setf (gethash 'byte-vector defaults) '(make-byte-vector 0 :adjustable t))
;; Home grown types
(setf (gethash 'cl:keyword defaults) :default-keyword)
(setf (gethash 'cl:symbol defaults) nil)
(defun get-default-form (type default container kind)
"Find the default value for a specified type.
Parameters:
TYPE: The type we want to get the default form for.
DEFAULT: A user defined default or one of nil $empty-default.
CONTAINER: If the field we're getting the default for is repeated then
the type of container to hold the repeated data in.
KIND: The kind of message this is, one of :group :message :extends
:enum :scalar."
(let ((possible-default (gethash type defaults)))
(cond
((not (member default (list $empty-default nil)))
default)
((eq container :vector)
`(make-array 0 :element-type ',type
:adjustable t
:fill-pointer 0))
((eq container :list) nil)
((member kind '(:group :message :extends))
nil)
((eq type :map)
'(make-hash-table))
((or possible-default
(eq type 'cl:boolean))
possible-default)))))
(defun make-structure-class-forms (proto-type slots non-lazy-fields lazy-fields oneofs)
"Makes the definition forms for the define-message macro.
Parameters:
PROTO-TYPE: The Lisp type name of the proto message.
SLOTS: Slot definitions created by PROCESS-FIELD.
NON-LAZY-FIELDS: Field definitions for non-lazy fields.
LAZY-FIELDS: Field definitions for lazy fields.
ONEOFS: A list of oneof descriptors for the message/group."
(let* ((public-constructor-name (fintern "MAKE-~A" proto-type))
(hidden-constructor-name (fintern "%MAKE-~A" proto-type))
(public-lazy-slot-names (mapcar #'proto-external-field-name lazy-fields))
(public-non-lazy-slot-names (mapcar #'proto-external-field-name non-lazy-fields))
(is-set-name (fintern "~A-%%IS-SET" proto-type))
(clear-is-set-name (fintern "~A.CLEAR-%%IS-SET" proto-type))
(additional-slots '(%%is-set))
(oneof-fields (loop for oneof in oneofs
append (coerce (oneof-descriptor-fields oneof) 'list))))
(with-gensyms (obj)
`(progn
;; DEFSTRUCT form.
(declaim (inline ,hidden-constructor-name))
(defstruct (,proto-type (:constructor ,hidden-constructor-name)
(:include message)
;; Yet more class->struct code we have to add,
;; todo(jgodbout):delete asap
(:predicate nil))
,@(remove nil
(append
(mapcar (lambda (slot)
(let ((name (field-data-internal-slot-name slot))
(type (field-data-type slot))