summaryrefslogtreecommitdiff
path: root/xdelta1/libedsio/edsio.el
diff options
context:
space:
mode:
Diffstat (limited to 'xdelta1/libedsio/edsio.el')
-rw-r--r--xdelta1/libedsio/edsio.el1864
1 files changed, 0 insertions, 1864 deletions
diff --git a/xdelta1/libedsio/edsio.el b/xdelta1/libedsio/edsio.el
deleted file mode 100644
index 8c15215..0000000
--- a/xdelta1/libedsio/edsio.el
+++ /dev/null
@@ -1,1864 +0,0 @@
1;; -*- Emacs-Lisp -*-
2
3(require 'cl)
4(require 'pp)
5
6(eval-and-compile (setq load-path (cons ".." (cons "." load-path))))
7(provide 'edsio)
8(eval-and-compile (setq load-path (cdr (cdr load-path))))
9
10;; Turn of assertions in compiled code.
11(eval-and-compile
12 (setq cl-optimize-speed 3)
13 (setq cl-optimize-safety 1)
14 )
15
16;; Begin
17
18(defconst *definition-state* nil
19 "List of all the names of variables containing state from the
20definition file so that operations may be performed on everything in
21the definition file.")
22(defconst *definition-attrs* nil
23 "List of attributes for sharing indices.")
24(defconst *all-objects* nil)
25(defconst *output-files* nil
26 "List of lists (NAME BUFFER) used during output of headers.")
27(defconst *output-prefix* nil
28 "Prefix used for outputing header files.")
29(defconst *cpp-extension* "c")
30
31;; This defines several functions and one macro. The indirection makes
32;; it a little bit confusing to read. It defines the macro DEFDNAME,
33;; a function DEFDNAME*, MAKE-DNAME, and a setter and getter for each arg.
34(eval-and-compile
35(defmacro attr-index (attr)
36 `(- (length *definition-attrs*) (length (memq ,attr *definition-attrs*))))
37
38(defmacro defastmacro(dtype args attrs)
39 "Defines a macro named DEFDTYPE for defining various AST properties."
40 (let ((def-macr (intern (format "def%s" dtype)))
41 (def-func (intern (format "def%s*" dtype)))
42 (make-func (intern (format "make-%s" dtype)))
43 (state (intern (format "*%s-defs*" dtype)))
44 (exprs nil))
45 (if (not *definition-attrs*)
46 (setq *definition-attrs* '(menunode menuline)))
47 (let ((fields (append args attrs)))
48 (while fields
49 (if (not (memq (car fields) *definition-attrs*))
50 (setq *definition-attrs* (append *definition-attrs* (list (car fields)))))
51 (setq fields (cdr fields))
52 )
53 )
54 ;; Add it to *definition-state*
55 (setq *definition-state* (cons state *definition-state*))
56 ;; DEFCONST it
57 (setq exprs (cons (list 'defconst state (quote nil)) exprs))
58 ;; DEFMACRO DEFDTYPE
59 (setq exprs (cons (list 'defmacro
60 def-macr
61 args
62 (append (list 'list (list 'quote def-func))
63 (mapcar (function (lambda (x)
64 (list 'list (list 'quote 'quote) x)
65 )
66 )
67 args)
68 )
69 )
70 exprs
71 )
72 )
73 ;; DEFUN DEFDTYPE*
74 (setq exprs (cons (list 'defun
75 def-func
76 args
77 (list 'setq
78 state
79 (list 'cons
80 (cons make-func args)
81 state
82 )
83 )
84 )
85 exprs
86 )
87 )
88 ;; MAKE-DTYPE
89 (setq exprs (cons (list 'defun
90 make-func
91 args
92 (list 'let (list (list 'it (list 'make-vector (length *definition-attrs*) nil)))
93 (if args
94 (cons 'progn (mapcar
95 (function
96 (lambda (x)
97 (list 'aset 'it (attr-index x) x)
98 )
99 )
100 args
101 )
102 )
103 )
104 (if attrs
105 (cons 'progn (mapcar
106 (function
107 (lambda (x)
108 (list 'aset 'it (attr-index x) nil)
109 )
110 )
111 attrs
112 )
113 )
114 )
115 (if (memq 'menu args)
116 (list 'progn
117 (list 'aset 'it (attr-index 'menunode) (list 'function (intern (format "%s-menunode" dtype))))
118 (list 'aset 'it (attr-index 'menuline) (list 'function (intern (format "%s-menuline" dtype))))
119 )
120 )
121 (list 'cons (list 'quote dtype) 'it)
122 )
123 )
124 exprs
125 )
126 )
127 ;; Add the fake arguments:
128 (if (memq 'menu args)
129 (setq attrs (append (list 'menunode 'menuline) attrs)))
130 (setq args (append args attrs))
131 (while args
132 (let* ((thearg (car args))
133 (arg-set (intern (format "%s-%s-set" dtype thearg)))
134 (arg-get (intern (format "%s-%s-get" dtype thearg))))
135 ;; DTYPE-ARG-GET
136 (setq exprs (cons (list 'defmacro
137 (intern (format "%s-%s-get" dtype thearg))
138 '(obj)
139 (list 'list
140 (list 'quote 'aref)
141 (list 'list (list 'quote 'cdr) 'obj)
142 (attr-index thearg))
143 )
144 exprs
145 )
146 )
147 ;; DTYPE-ARG-SET
148 (setq exprs (cons (list 'defmacro
149 (intern (format "%s-%s-set" dtype thearg))
150 '(obj val)
151 (list 'list
152 (list 'quote 'aset)
153 (list 'list (list 'quote 'cdr) 'obj)
154 (attr-index thearg)
155 'val)
156 )
157 exprs
158 )
159 )
160 )
161 (setq args (cdr args))
162 )
163 ;; To see what it's generating uncomment the next 2 lines.
164 ;;(setq message-log-max t)
165 ;;(mapcar (function pp) exprs)
166 (cons 'progn exprs)
167 )
168 )
169
170
171;; This is, as the name suggests, really bogus. Basically, each DEFASTMACRO
172;; call adds to the list *definition-state*. To compile it, however, it has
173;; to be done at compile time, so this macro gets evaluated when being compiled
174;; and clears the list. Then the DEFASTMACRO calls are made, and then DEFCDS
175;; is called to define CLEAR-DEFINITION-STATE which resets the list to the
176;; compile-time computed value of *definition-state*, it would otherwise be
177;; empty when running compiled code.
178(defmacro bogus ()
179 (setq *definition-state* nil)
180 (setq *definition-attrs* nil)
181 )
182
183 (bogus)
184
185;; Each DEFASTMACRO statement defines a directive for the definition
186;; file along with it's argument names.
187(defastmacro sertype (name number fields transients) ())
188(defastmacro module (name id header pheader) ())
189(defastmacro import (name) (prefix))
190
191(defastmacro event (name level uargs sargs desc) ())
192(defastmacro etype (name ctype) ())
193
194(defastmacro prophost (name letter ctype persist) (proptypes))
195(defastmacro prophosttype (host type) ())
196
197(defmacro defcds ()
198 (let ((exprs nil))
199 (setq exprs (list (list 'defun 'clear-definition-state nil
200 '(setq *all-objects* nil)
201 (list 'setq '*definition-state* (list 'quote *definition-state*))
202 (list 'setq '*definition-attrs* (list 'quote *definition-attrs*))
203 '(mapcar (function (lambda (x) (set x nil))) *definition-state*)
204 )
205
206 )
207 )
208 (mapcar
209 (function
210 (lambda (x)
211 (setq exprs (cons (list 'defmacro
212 (intern (format "obj-%s-get" x))
213 '(obj)
214 (list 'list
215 (list 'quote 'aref)
216 (list 'list (list 'quote 'cdr) 'obj)
217 (attr-index x))
218 )
219 exprs
220 )
221 )
222 (setq exprs (cons (list 'defmacro
223 (intern (format "obj-%s-set" x))
224 '(obj val)
225 (list 'list
226 (list 'quote 'aset)
227 (list 'list (list 'quote 'cdr) 'obj)
228 (attr-index x)
229 'val)
230 )
231 exprs
232 )
233 )
234 (let ((get (intern (format "obj-%s-get" x))))
235 (setq exprs (cons (list 'defun
236 (intern (format "obj-%s-eq" x))
237 '(val olist)
238 `(let ((ret nil))
239 (while (and (not ret) olist)
240 (if (eq val (,get (car olist)))
241 (setq ret (car olist))
242 )
243 (setq olist (cdr olist))
244 )
245 ret
246 )
247 )
248 exprs
249 )
250 )
251 )
252 )
253 )
254 *definition-attrs*
255 )
256 ;;(setq message-log-max t)
257 ;;(mapcar (function pp) exprs)
258 (cons 'progn exprs)
259 )
260 )
261
262(defcds)
263)
264;; Entry Points
265
266(defun generate-ser-noargs ()
267 (interactive)
268 (generate-ser "edsio.ser" "edsio")
269 )
270
271(defun generate-ser (input-file output-prefix)
272 ;(interactive "finput: \nsoutput: \nsid: ")
273 (let ((make-backup-files nil)
274 (executing-kbd-macro t))
275 (clear-definition-state)
276
277 (do-it input-file output-prefix)
278 )
279 )
280
281(defconst *library-id* nil
282 "Identifier of this library.")
283
284(defconst *library-header* nil
285 "Header of this library.")
286(defconst *library-pheader* nil
287 "Header of this library.")
288
289(defconst *prefix-with-library-header* t)
290
291(defun load-defs(file)
292 (load-file file)
293 (setq *import-defs* (reverse *import-defs*))
294 (setq *module-defs* (reverse *module-defs*))
295 (setq *sertype-defs* (reverse *sertype-defs*))
296
297 (setq *event-defs* (reverse *event-defs*))
298 (setq *etype-defs* (reverse *etype-defs*))
299
300 (setq *prophost-defs* (reverse *prophost-defs*))
301 (setq *prophosttype-defs* (reverse *prophosttype-defs*))
302 )
303
304(defconst *header-typedef-marker* nil)
305(defconst *source-init-marker* nil)
306(defconst *source-top-marker* nil)
307
308(defun do-it (input-file output-prefix)
309 (setq *output-files* nil)
310 (setq *output-prefix* output-prefix)
311
312 (load-defs input-file)
313
314 (if (not *module-defs*)
315 (error "no defmodule in %s" input-file))
316
317 (if (> (length *module-defs*) 1)
318 (error "too many defmodules in %s" input-file))
319
320 (setq *library-id* (module-id-get (car *module-defs*)))
321 (setq *library-header* (module-header-get (car *module-defs*)))
322 (setq *library-pheader* (module-pheader-get (car *module-defs*)))
323
324 (when (not *library-header*)
325 (setq *prefix-with-library-header* nil)
326 (setq *library-header* (format "%s_edsio.h" *output-prefix*))
327 )
328
329 (if (or (<= *library-id* 0)
330 (>= *library-id* 256))
331 (error "Library-id is out of range"))
332
333 (if (> (length *sertype-defs*) 24)
334 (error "no more than 24 types"))
335
336 (unwind-protect
337 (progn
338
339 (output-header-file "_edsio")
340
341 (read-imports)
342
343 (insert "/* Initialize this library. */\n\n")
344 (insert "gboolean " *output-prefix* "_edsio_init (void);\n\n")
345
346 (insert "/* Types defined here. */\n\n")
347 (setq *header-typedef-marker* (point-marker))
348
349 (insert "/* Functions declared here. */\n\n")
350
351 (output-source-file "_edsio")
352
353 (insert "#include \"" *library-header* "\"\n\n")
354 (insert "#include <errno.h>\n\n")
355
356 (if *library-pheader*
357 (insert "#include \"" *library-pheader* "\"\n\n"))
358
359 (insert "/* Declarations. */\n\n")
360 (setq *source-top-marker* (point-marker))
361
362 (insert "\n")
363
364 (insert "/* initialize this library. */\n\n")
365 (insert "gboolean\n" *output-prefix* "_edsio_init (void)\n{\n")
366 (insert " static gboolean once = FALSE;\n")
367 (insert " static gboolean result = FALSE;\n")
368 (insert " if (once) return result;\n")
369 (insert " once = TRUE;\n")
370
371 (setq *source-init-marker* (point-marker))
372
373 (insert (format " edsio_library_register (%d, \"%s\");\n" *library-id* *output-prefix*))
374 (insert " result = TRUE;\n")
375 (insert " return TRUE;\n")
376 (insert "};\n\n")
377
378 (if *prophosttype-defs*
379 (generate-properties))
380
381 (if *sertype-defs*
382 (generate-code))
383
384 (if *event-defs*
385 (generate-events))
386
387; (message "source file:\n%s" (buffer-string))
388
389 (mapcar (function (lambda (x) (output-finish-file x))) *output-files*)
390 )
391 (mapcar (function (lambda (x) (kill-buffer (cadr x)))) *output-files*)
392 )
393 )
394
395(defvar *all-sertype-defs* nil)
396(defvar *all-prophost-defs* nil)
397(defvar *all-etype-defs* nil)
398
399(defun read-imports ()
400
401 (setq *all-sertype-defs* *sertype-defs*)
402 (setq *all-etype-defs* *etype-defs*)
403 (setq *all-prophost-defs* *prophost-defs*)
404
405 (let ((mods *module-defs*)
406 (imps0 *import-defs*)
407 (imps *import-defs*)
408 (types *sertype-defs*)
409 (events *event-defs*)
410 (etypes *etype-defs*)
411 (phosts *prophost-defs*)
412 (phts *prophosttype-defs*)
413 )
414
415 (while imps
416 (clear-definition-state)
417
418 (load-defs (import-name-get (car imps)))
419
420 (setq *all-sertype-defs* (append *all-sertype-defs* *sertype-defs*))
421 (setq *all-etype-defs* (append *all-etype-defs* *etype-defs*))
422 (setq *all-prophost-defs* (append *all-prophost-defs* *prophost-defs*))
423
424 (import-prefix-set (car imps) (module-name-get (car *module-defs*)))
425
426 (when (or *sertype-defs* *event-defs*)
427 (output-header-file "_edsio")
428 (insert (format "#include \"%s_edsio.h\"\n\n" (import-prefix-get (car imps))))
429 )
430
431 (setq imps (cdr imps))
432 )
433
434 (setq *module-defs* mods)
435 (setq *import-defs* imps0)
436 (setq *sertype-defs* types)
437 (setq *event-defs* events)
438 (setq *etype-defs* etypes)
439 (setq *prophost-defs* phosts)
440 (setq *prophosttype-defs* phts)
441 )
442 )
443
444
445(defun output-header-file (name)
446 (output-file (format "%s.h" name) 'c-header *output-prefix*))
447
448(defun output-source-file (name)
449 (output-file (format "%s.%s" name *cpp-extension*) 'c *output-prefix*))
450
451(defun output-source-include-file (name)
452 (output-file (format "%s.%si" name *cpp-extension*) 'c *output-prefix*))
453
454(defun output-plain-file (name)
455 (output-file (format "%s" name) 'plain ""))
456
457(defun output-file (name type prefix)
458 (let* ((name (format "%s%s" prefix name))
459 (it (assoc name *output-files*)))
460 (if it
461 (set-buffer (cadr it))
462 (let ((nbuf (get-buffer-create (generate-new-buffer-name name))))
463 (setq *output-files* (cons (list name nbuf type) *output-files*))
464 (set-buffer nbuf)
465 )
466 )
467 )
468 )
469
470(defun output-finish-file (file)
471 (let ((name (car file))
472 (buf (cadr file))
473 (type (caddr file)))
474 (set-buffer buf)
475 ;(message "printing %s: %s" file (buffer-string))
476 (cond ((eq type 'c)
477 (output-to-c name nil))
478 ((eq type 'c-header)
479 (output-to-c name t))
480 )
481 (write-file-if-different buf name)
482 )
483 )
484
485(defun output-to-c (name is-header)
486 (goto-char (point-min))
487 (insert "/* -*-Mode: C;-*-
488 * Copyright (C) 1997, 1998, 1999 Josh MacDonald
489 *
490 * This program is free software; you can redistribute it and/or modify
491 * it under the terms of the GNU General Public License as published by
492 * the Free Software Foundation; either version 2 of the License, or
493 * (at your option) any later version.
494 *
495 * This program is distributed in the hope that it will be useful,
496 * but WITHOUT ANY WARRANTY; without even the implied warranty of
497 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
498 * GNU General Public License for more details.
499 *
500 * You should have received a copy of the GNU General Public License
501 * along with this program; if not, write to the Free Software
502 * Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
503 *
504 * Author: Josh MacDonald <jmacd@CS.Berkeley.EDU>
505 *
506 * This file was AUTOMATICALLY GENERATED using:
507 *
508 * $Id: edsio.el 1.1 Sun, 28 Jan 2007 10:02:26 -0800 jmacd $
509 */
510
511")
512
513 (if is-header
514 (let ((cppname (string-replace-regexp (upcase name) "[-./]" "_")))
515 (insert "#include \"edsio.h\"\n\n")
516
517 (if *prefix-with-library-header*
518 (insert "#include \"" *library-header* "\"\n\n"))
519
520 (insert "#ifndef _" cppname "_\n")
521 (insert "#define _" cppname "_\n\n")
522 (insert "#ifdef __cplusplus\n")
523 (insert "extern \"C\" {\n")
524 (insert "#endif\n\n")
525 (goto-char (point-max))
526 (insert "#ifdef __cplusplus\n")
527 (insert "}\n")
528 (insert "#endif\n")
529 (insert "\n#endif /* _" cppname "_ */\n\n")
530 )
531 )
532 )
533
534(defun string-replace-regexp (str regexp to-string)
535 "Result of replacing all occurrences in STR of REGEXP by TO-STRING. The
536replacement is as for replace-regexp."
537 (let ((work (get-buffer-create "*string-tmp*")))
538 (save-excursion
539 (set-buffer work)
540 (erase-buffer)
541 (insert str)
542 (beginning-of-buffer)
543 (while (re-search-forward regexp nil t)
544 (replace-match to-string nil nil))
545 (buffer-string))))
546
547(defun write-file-if-different (buf filename)
548 (save-excursion
549 (if (not (file-exists-p filename))
550 (write-file filename)
551 (set-buffer buf)
552 (let ((old (get-buffer-create (generate-new-buffer-name filename)))
553 (bmin (point-min))
554 (bmax (point-max)))
555 (unwind-protect
556 (progn
557 (set-buffer old)
558 (insert-file filename)
559 (let ((omin (point-min))
560 (omax (point-max))
561 (case-fold-search nil))
562 (if (= 0 (compare-buffer-substrings old omin omax buf bmin bmax))
563 (message "Output file %s is unchanged." filename)
564 (set-buffer buf)
565 (write-file filename)
566 )
567 )
568 )
569 (kill-buffer old)
570 )
571 )
572 )
573 )
574 )
575
576
577(defun format-comlist (func l)
578 (let ((x ""))
579 (while l
580 (setq x (concat x (funcall func (car l))))
581 (if (cdr l)
582 (setq x (concat x ", ")))
583 (setq l (cdr l))
584 )
585 x
586 )
587 )
588
589(defun format-semilist (func l)
590 (let ((x ""))
591 (while l
592 (setq x (concat x (funcall func (car l))))
593 (if (cdr l)
594 (setq x (concat x "; ")))
595 (setq l (cdr l))
596 )
597 x
598 )
599 )
600
601(defun format-numbered-comlist (func l)
602 (let ((x "")
603 (n 0))
604 (while l
605 (setq x (concat x (funcall func (car l) n)))
606 (setq n (+ n 1))
607 (if (cdr l)
608 (setq x (concat x ", ")))
609 (setq l (cdr l))
610 )
611 x
612 )
613 )
614
615(defun capitalize1(s)
616 (let ((work (get-buffer-create "*string-tmp*")))
617 (save-excursion
618 (set-buffer work)
619 (erase-buffer)
620 (insert (format "%s" s))
621 (upcase-region (point-min) (+ (point-min) 1))
622 (buffer-substring-no-properties (point-min) (point-max))
623 )
624 )
625 )
626
627(defun upcase-string (s)
628 (let ((work (get-buffer-create "*string-tmp*")))
629 (save-excursion
630 (set-buffer work)
631 (erase-buffer)
632 (insert (format "%s" s))
633 (upcase-region (point-min) (point-max))
634 (buffer-substring-no-properties (point-min) (point-max))
635 )
636 )
637 )
638
639(defun downcase-string (s)
640 (let ((work (get-buffer-create "*string-tmp*")))
641 (save-excursion
642 (set-buffer work)
643 (erase-buffer)
644 (insert (format "%s" s))
645 (downcase-region (point-min) (point-max))
646 (buffer-substring-no-properties (point-min) (point-max))
647 )
648 )
649 )
650
651;; HERE IT IS
652
653(defun generate-code ()
654
655 (let ((all-codes nil))
656 (mapcar
657 (function
658 (lambda (st)
659 (let ((x (sertype-number-get st)))
660 (cond ((member x all-codes)
661 (error "serial type number %d defined twice" x))
662 ((> x 24)
663 (error "serial type value %d too high" x))
664 ((< x 0)
665 (error "serial type value %d too low" x))
666 (t (setq all-codes (cons x all-codes))))))
667 )
668 *sertype-defs*)
669 )
670
671 (output-header-file "_edsio")
672
673 (insert "/* Serial Types */\n\n")
674 (insert (format "enum _Serial%sType {\n" (capitalize1 *output-prefix*)))
675 (insert (format-comlist
676 (function
677 (lambda (x)
678 (format "\n ST_%s = (1<<(%d+EDSIO_LIBRARY_OFFSET_BITS))+%d" (sertype-name-get x) (sertype-number-get x) *library-id*))) *sertype-defs*))
679 (insert "\n};\n\n")
680
681 (insert "\n\n")
682
683 (output-source-file "_edsio")
684
685 (save-excursion
686 (goto-char *source-top-marker*)
687
688 (insert "static void print_spaces (guint n) { int i; for (i = 0; i < n; i += 1) g_print (\" \"); }\n\n")
689 )
690
691 (mapcar (function generate-code-entry) *sertype-defs*)
692
693 )
694
695(defun generate-code-entry (entry)
696 (let ((ent-upcase (sertype-name-get entry))
697 (ent-downcase (downcase-string (sertype-name-get entry))))
698
699 (output-header-file "_edsio")
700
701 ;; The typedef, structure, and declarations.
702
703 (save-excursion
704 (goto-char *header-typedef-marker*)
705 (insert (format "typedef struct _Serial%s Serial%s;\n" ent-upcase ent-upcase))
706 )
707
708 (insert (format "/* %s Structure\n */\n\n" ent-upcase))
709
710 (insert (format "struct _Serial%s {\n" ent-upcase))
711
712 (apply (function insert)
713 (mapcar (function
714 (lambda (x)
715 (format " %s;\n" x)))
716 (entry-typename-pairs entry nil)))
717
718 (apply (function insert)
719 (mapcar (function
720 (lambda (x)
721 (format " %s;\n" x)))
722 (sertype-transients-get entry)))
723
724 (insert "};\n\n")
725
726 (insert (format "void serializeio_print_%s_obj (Serial%s* obj, guint indent_spaces);\n\n" ent-downcase ent-upcase))
727
728 (insert (format "gboolean unserialize_%s (SerialSource *source, Serial%s**);\n" ent-downcase ent-upcase))
729 (insert (format "gboolean unserialize_%s_internal (SerialSource *source, Serial%s** );\n" ent-downcase ent-upcase))
730 (insert (format "gboolean unserialize_%s_internal_noalloc (SerialSource *source, Serial%s* );\n" ent-downcase ent-upcase))
731 (insert (format "gboolean serialize_%s (SerialSink *sink%s);\n" ent-downcase (entry-arglist t entry)))
732 (insert (format "gboolean serialize_%s_obj (SerialSink *sink, const Serial%s* obj);\n" ent-downcase ent-upcase))
733 (insert (format "gboolean serialize_%s_internal (SerialSink *sink%s);\n" ent-downcase (entry-arglist t entry)))
734 (insert (format "gboolean serialize_%s_obj_internal (SerialSink *sink, Serial%s* obj);\n" ent-downcase ent-upcase))
735 (insert (format "guint serializeio_count_%s (%s);\n" ent-downcase (entry-arglist nil entry)))
736 (insert (format "guint serializeio_count_%s_obj (Serial%s const* obj);\n" ent-downcase ent-upcase))
737 (insert (format "\n"))
738
739 (output-source-file "_edsio")
740
741 ;; The init entry
742
743 (save-excursion
744 (goto-char *source-init-marker*)
745 (insert (format " serializeio_initialize_type (\"ST_%s\", ST_%s, &unserialize_%s_internal, &serialize_%s_obj_internal, &serializeio_count_%s_obj, &serializeio_print_%s_obj);\n" ent-upcase ent-upcase ent-downcase ent-downcase ent-downcase ent-downcase))
746 )
747
748 ;; Count code
749
750 (insert (format "/* %s Count\n */\n\n" ent-upcase))
751
752 (insert (format "guint\nserializeio_count_%s (%s) {\n" ent-downcase (entry-arglist nil entry)))
753 (insert (format " guint size = sizeof (Serial%s);\n" ent-upcase))
754 (apply (function insert)
755 (mapcar (function (lambda (x) (concat
756 (format " ALIGN_8 (size);\n")
757 (entry-count-field entry x (format "%s" (car x)) " " t))))
758 (sertype-fields-get entry)))
759 (insert (format " ALIGN_8 (size);\n"))
760 (insert (format " return size;\n"))
761 (insert (format "}\n\n"))
762
763 ;; Count Object code
764
765 (insert (format "guint\nserializeio_count_%s_obj (Serial%s const* obj) {\n" ent-downcase ent-upcase))
766 (insert (format " return serializeio_count_%s (%s);\n" ent-downcase (entry-plist t nil "obj->" entry)))
767 (insert (format "}\n\n"))
768
769 ;; Print object code
770
771 (insert (format "/* %s Print\n */\n\n" ent-upcase))
772
773 (insert (format "void\nserializeio_print_%s_obj (Serial%s* obj, guint indent_spaces) {\n" ent-downcase ent-upcase))
774 (insert (format " print_spaces (indent_spaces);\n"))
775
776 (insert (format " g_print (\"[ST_%s]\\n\");\n" ent-upcase))
777
778 (apply (function insert)
779 (mapcar (function (lambda (x) (entry-print-field entry x (format "obj->%s" (car x)) " " t)))
780 (sertype-fields-get entry)))
781
782 (insert (format "}\n\n"))
783
784 ;; Print internal code
785
786 ;; Serialize code
787
788 (insert (format "/* %s Serialize\n */\n\n" ent-upcase))
789
790 (insert (format "gboolean\nserialize_%s_internal (SerialSink *sink%s)\n" ent-downcase (entry-arglist t entry)))
791 (insert (format "{\n"))
792
793 (apply (function insert)
794 (mapcar (function (lambda (x) (entry-serialize-field entry x (format "%s" (car x)) " " t)))
795 (sertype-fields-get entry)))
796
797 (insert (format " return TRUE;\n"))
798 (if (sertype-fields-get entry)
799 (insert (format "bail:\n return FALSE;\n")))
800 (insert (format "}\n\n"))
801
802 ;; Internal Serialize Object code
803
804 (insert (format "gboolean\nserialize_%s_obj_internal (SerialSink *sink, Serial%s* obj)\n" ent-downcase ent-upcase))
805 (insert (format "{\n"))
806 (insert (format " return serialize_%s_internal (sink%s);\n" ent-downcase (entry-plist t t "obj->" entry)))
807 (insert (format "}\n\n"))
808
809 ;; External Serialize code
810
811 (insert (format "gboolean\nserialize_%s (SerialSink *sink%s)\n" ent-downcase (entry-arglist t entry)))
812 (insert (format "{\n"))
813
814 (insert (format " if (! (* sink->sink_type) (sink, ST_%s, serializeio_count_%s (%s), TRUE)) goto bail;\n" ent-upcase ent-downcase (entry-plist nil nil "" entry)))
815
816 (insert (format " if (! serialize_%s_internal (sink%s)) goto bail;\n" ent-downcase (entry-plist nil t "" entry)))
817 (insert (format " if (sink->sink_quantum && ! sink->sink_quantum (sink)) goto bail;\n"))
818
819 (insert (format " return TRUE;\n"))
820 (insert (format "bail:\n"))
821 (insert (format " return FALSE;\n"))
822 (insert (format "}\n\n"))
823
824 ;; External serialize_obj
825
826 (insert (format "gboolean\nserialize_%s_obj (SerialSink *sink, const Serial%s* obj) {\n\n" ent-downcase ent-upcase))
827 (insert (format " return serialize_%s (sink%s);\n" ent-downcase (entry-plist t t "obj->" entry)))
828 (insert (format "}\n\n"))
829
830 ;; Unserialize code
831
832 (insert (format "/* %s Unserialize\n */\n\n" ent-upcase))
833
834 (insert (format "gboolean\nunserialize_%s_internal_noalloc (SerialSource *source, Serial%s* result)\n" ent-downcase ent-upcase))
835 (insert (format "{\n"))
836
837 (apply (function insert)
838 (mapcar (function (lambda (x) (entry-unserialize-field entry x (format "result->%s" (car x)) " ")))
839 (sertype-fields-get entry)))
840
841 (insert (format " return TRUE;\n"))
842 (if (sertype-fields-get entry)
843 (insert (format "bail:\n return FALSE;\n")))
844 (insert (format "}\n\n"))
845
846
847 (insert (format "gboolean\nunserialize_%s_internal (SerialSource *source, Serial%s** result)\n" ent-downcase ent-upcase))
848 (insert (format "{\n"))
849
850 (insert (format " Serial%s* unser;\n" ent-upcase))
851 (insert (format " (*result) = NULL;\n"))
852 (insert (format " unser = serializeio_source_alloc (source, sizeof (Serial%s));\n" ent-upcase))
853 (insert (format " if (! unser) goto bail;\n"))
854
855 (insert (format " if (! unserialize_%s_internal_noalloc (source, unser)) goto bail;\n" ent-downcase))
856
857 (insert (format " (*result) = unser;\n"))
858 (insert (format " return TRUE;\n"))
859 (insert (format "bail:\n"))
860 (insert (format " return FALSE;\n"))
861 (insert (format "}\n\n"))
862
863 ;; External unserialize
864
865 (insert (format "gboolean\nunserialize_%s (SerialSource *source, Serial%s** result)\n" ent-downcase ent-upcase))
866 (insert (format "{\n"))
867
868 (insert (format " if ( (* source->source_type) (source, TRUE) != ST_%s) goto bail;\n" ent-upcase))
869
870 (insert (format " if (! unserialize_%s_internal (source, result)) goto bail;\n" ent-downcase))
871
872 (insert (format " return TRUE;\n"))
873 (insert (format "bail:\n"))
874 (insert (format " return FALSE;\n"))
875
876 (insert (format "}\n\n"))
877
878 )
879 )
880
881(defun entry-typename-pairs (entry is-param)
882 (let ((pairs nil)
883 (fields (sertype-fields-get entry)))
884 (while fields
885 (let ((field (car fields)))
886 (when (or (equal (cadr field) 'bytes)
887 (and (consp (cadr field)) (equal (caadr field) 'array)))
888 (setq pairs (cons (format "guint32 %s_len" (car field)) pairs))
889 )
890 (when (equal (cadr field) 'object)
891 (setq pairs (cons (format "guint32 %s_type" (car field)) pairs))
892 )
893 (setq pairs (cons (field-decl field is-param) pairs))
894 )
895 (setq fields (cdr fields))
896 )
897 (nreverse pairs)
898 )
899 )
900
901(defun entry-param-names (prefix entry need_pbr)
902 (let ((pairs nil)
903 (fields (sertype-fields-get entry)))
904 (while fields
905 (let ((field (car fields)))
906 (when (or (equal (cadr field) 'bytes)
907 (and (consp (cadr field)) (equal (caadr field) 'array)))
908 (setq pairs (cons (format "%s%s_len" prefix (car field)) pairs))
909 )
910 (when (equal (cadr field) 'object)
911 (setq pairs (cons (format "%s%s_type" prefix (car field)) pairs))
912 )
913 (setq pairs (cons (format "%s%s%s" (if (and need_pbr (needs-ref field)) "&" "") prefix (car field)) pairs))
914 )
915 (setq fields (cdr fields))
916 )
917 (nreverse pairs)
918 )
919 )
920
921(defun field-ctype (field)
922 (cond ((equal (cadr field) 'string)
923 "const gchar*")
924 ((equal (cadr field) 'uint)
925 "guint32")
926 ((equal (cadr field) 'uint32)
927 "guint32")
928 ((equal (cadr field) 'uint16)
929 "guint16")
930 ((equal (cadr field) 'uint8)
931 "guint8")
932 ((equal (cadr field) 'boolean)
933 "gboolean")
934 ((equal (cadr field) 'bytes)
935 "const guint8*")
936 ((equal (cadr field) 'object)
937 "void*")
938 ((member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
939 (format "Serial%s" (cadr field)))
940 ((equal (car (cadr field)) 'bytes)
941 "const guint8*")
942 ((member (car (cadr field)) '(array ptr))
943 (concat (field-ctype (cadr field)) "*"))
944 (t (error "unrecognized field type: %s" (cadr field))))
945 )
946
947(defun field-decl (field is-param)
948 (if (and (consp (cadr field))
949 (equal (car (cadr field)) 'bytes))
950 (format "%sguint8 %s[%d]" (if is-param "const " "") (car field) (cadr (cadr field)))
951 ;(message "foo %s %s" field (member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*)))
952 (format "%s %s"
953 (cond ((member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
954 (format "Serial%s%s" (cadr field) (if is-param " const*" "")))
955 ((equal (cadr field) 'string)
956 "const gchar*")
957 ((equal (cadr field) 'uint)
958 "guint32")
959 ((equal (cadr field) 'uint32)
960 "guint32")
961 ((equal (cadr field) 'uint16)
962 "guint16")
963 ((equal (cadr field) 'uint8)
964 "guint8")
965 ((equal (cadr field) 'boolean)
966 "gboolean")
967 ((equal (cadr field) 'bytes)
968 "const guint8*")
969 ((equal (cadr field) 'object)
970 "void*")
971 ((member (car (cadr field)) '(array ptr))
972 (concat (field-ctype (cadr field)) (if is-param " const*" "*")))
973 (t (error "unrecognized field type: %s" (cadr field))))
974 (car field)))
975 )
976
977(defun entry-arglist (need_first entry)
978 (concat
979 (if (and need_first (sertype-fields-get entry)) ", " "")
980 (format-comlist (function (lambda (x) x)) (entry-typename-pairs entry t))))
981
982(defun needs-ref (field)
983 (member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
984 )
985
986(defun entry-plist (need_pbr need_first prefix entry)
987 (concat
988 (if (and need_first (sertype-fields-get entry)) ", " "")
989 (format-comlist (function (lambda (x) (format "%s" x)))
990 (entry-param-names prefix entry need_pbr))))
991
992(defun entry-unserialize-field (entry field name prefix)
993 (cond ((equal (cadr field) 'uint)
994 (format "%sif (! (* source->next_uint) (source, &%s)) goto bail;\n" prefix name))
995 ((equal (cadr field) 'uint32)
996 (format "%sif (! (* source->next_uint32) (source, &%s)) goto bail;\n" prefix name))
997 ((equal (cadr field) 'uint16)
998 (format "%sif (! (* source->next_uint16) (source, &%s)) goto bail;\n" prefix name))
999 ((equal (cadr field) 'uint8)
1000 (format "%sif (! (* source->next_uint8) (source, &%s)) goto bail;\n" prefix name))
1001 ((equal (cadr field) 'boolean)
1002 (format "%sif (! (* source->next_bool) (source, &%s)) goto bail;\n" prefix name))
1003 ((equal (cadr field) 'string)
1004 (format "%sif (! (* source->next_string) (source, &%s)) goto bail;\n" prefix name))
1005 ((equal (cadr field) 'bytes)
1006 (format "%sif (! (* source->next_bytes) (source, &%s, &%s_len)) goto bail;\n" prefix name name))
1007 ((equal (cadr field) 'object)
1008 (format "%sif (! serializeio_unserialize_generic_internal (source, &%s_type, &%s, FALSE)) goto bail;\n" prefix name name))
1009 ((member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1010 (format "%sif (! unserialize_%s_internal_noalloc (source, &%s)) goto bail;\n" prefix (downcase-string (cadr field)) name))
1011 ((and (equal (car (cadr field)) 'ptr)
1012 (member (cadr (cadr field)) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*)))
1013 (format "%sif (! unserialize_%s_internal (source, &%s)) goto bail;\n" prefix (downcase-string (cadr (cadr field))) name))
1014 ((equal (car (cadr field)) 'bytes)
1015 (format "%sif (! (* source->next_bytes_known) (source, %s, %d)) goto bail;\n" prefix name (cadr (cadr field))))
1016 ((equal (car (cadr field)) 'array)
1017 (format "%s{
1018%s gint i;
1019%s if (! (* source->next_uint) (source, &%s_len)) goto bail;
1020%s if ((%s_len > 0) && ! (%s = serializeio_source_alloc (source, sizeof (%s) * %s_len))) goto bail;
1021%s for (i = 0; i < %s_len; i += 1)
1022%s {
1023%s%s }
1024%s}
1025"
1026 prefix
1027 prefix prefix
1028 name
1029 prefix
1030 name
1031 name
1032 (field-ctype (cadr field))
1033 name
1034 prefix
1035 name
1036 prefix
1037 prefix
1038 (entry-unserialize-field entry (cadr field) (concat "(" name "[i])") (concat prefix " "))
1039 prefix
1040 ))
1041 (t (error "unrecognized field type: %s" (cadr field)))))
1042
1043
1044(defun entry-serialize-field (entry field name prefix is-param)
1045 (cond ((equal (cadr field) 'uint)
1046 (format "%sif (! (* sink->next_uint) (sink, %s)) goto bail;\n" prefix name))
1047 ((equal (cadr field) 'uint16)
1048 (format "%sif (! (* sink->next_uint16) (sink, %s)) goto bail;\n" prefix name))
1049 ((equal (cadr field) 'uint8)
1050 (format "%sif (! (* sink->next_uint8) (sink, %s)) goto bail;\n" prefix name))
1051 ((equal (cadr field) 'uint32)
1052 (format "%sif (! (* sink->next_uint32) (sink, %s)) goto bail;\n" prefix name))
1053 ((equal (cadr field) 'boolean)
1054 (format "%sif (! (* sink->next_bool) (sink, %s)) goto bail;\n" prefix name))
1055 ((equal (cadr field) 'string)
1056 (format "%sif (! (* sink->next_string) (sink, %s)) goto bail;\n" prefix name))
1057 ((equal (cadr field) 'bytes)
1058 (format "%sif (! (* sink->next_bytes) (sink, %s, %s_len)) goto bail;\n" prefix name name))
1059 ((equal (cadr field) 'object)
1060 (format "%sif (! serializeio_serialize_generic_internal (sink, %s_type, %s, FALSE)) goto bail;\n" prefix name name))
1061 ((member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1062 (format "%sif (! serialize_%s_internal (sink%s)) goto bail;\n" prefix (downcase-string (cadr field))
1063 (entry-plist t t (concat name (if is-param "->" ".")) (obj-name-eq (cadr field) *all-sertype-defs*))))
1064 ((and (equal (car (cadr field)) 'ptr)
1065 (member (cadr (cadr field)) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*)))
1066 (format "%sif (! serialize_%s_internal (sink%s)) goto bail;\n" prefix (downcase-string (cadr (cadr field)))
1067 (entry-plist t t (concat name "->") (obj-name-eq (cadr (cadr field)) *all-sertype-defs*))))
1068 ((equal (car (cadr field)) 'bytes)
1069 (format "%sif (! (* sink->next_bytes_known) (sink, %s, %d)) goto bail;\n" prefix name (cadr (cadr field))))
1070 ((equal (car (cadr field)) 'array)
1071 (format "%s{
1072%s gint i;
1073%s if (! (* sink->next_uint) (sink, %s_len)) goto bail;
1074%s for (i = 0; i < %s_len; i += 1)
1075%s {
1076%s%s }
1077%s}
1078"
1079 prefix prefix prefix
1080 name
1081 prefix
1082 name
1083 prefix
1084 prefix
1085 (entry-serialize-field entry (cadr field) (array-index name (cadr field)) (concat prefix " ") nil)
1086 prefix
1087 ))
1088 (t (error "unrecognized field type: %s" (cadr field)))))
1089
1090(defun array-index (name field)
1091 ;(concat "(" (if (needs-ref field) "&" "") name "[i])")
1092 (concat "(" name "[i])")
1093 )
1094
1095(defun entry-count-field (entry field name prefix is-param)
1096 (cond ((equal (cadr field) 'uint)
1097 ;(format "%ssize += sizeof (guint32);\n" prefix)
1098 ""
1099 )
1100 ((equal (cadr field) 'uint32)
1101 ;(format "%ssize += sizeof (guint32);\n" prefix)
1102 ""
1103 )
1104 ((equal (cadr field) 'uint16)
1105 ;(format "%ssize += sizeof (guint16);\n" prefix)
1106 ""
1107 )
1108 ((equal (cadr field) 'uint8)
1109 ;(format "%ssize += sizeof (guint8);\n" prefix)
1110 ""
1111 )
1112 ((equal (cadr field) 'boolean)
1113 ;(format "%ssize += sizeof (gboolean);\n" prefix)
1114 ""
1115 )
1116 ((equal (cadr field) 'string)
1117 (format "%ssize += strlen (%s) + 1;\n" prefix name)
1118 )
1119 ((equal (cadr field) 'bytes)
1120 (format "%ssize += %s_len;\n" prefix name)
1121 )
1122 ((equal (cadr field) 'object)
1123 (format "%ssize += serializeio_generic_count (%s_type, %s);\n" prefix name name)
1124 )
1125 ((member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1126 (format "%ssize += serializeio_count_%s_obj (%s%s) - sizeof (Serial%s);\n"
1127 prefix
1128 (downcase-string (cadr field))
1129 (if is-param "" "& ")
1130 name
1131 (cadr field)
1132 )
1133 )
1134 ((and (equal (car (cadr field)) 'ptr)
1135 (member (cadr (cadr field)) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*)))
1136 (format "%ssize += serializeio_count_%s_obj (%s);\n" prefix (downcase-string (cadr (cadr field))) name)
1137 )
1138 ((equal (car (cadr field)) 'bytes)
1139 ;(format "%ssize += 0;\n" prefix (cadr (cadr field)))
1140 ""
1141 )
1142 ((equal (car (cadr field)) 'array)
1143 (format "%s{
1144%s gint i;
1145%s for (i = 0; i < %s_len; i += 1)
1146%s {
1147%s%s }
1148%s}
1149"
1150 prefix prefix prefix
1151 name
1152 prefix
1153 prefix
1154 (entry-count-array-field entry (cadr field) (array-index name (cadr field)) (concat prefix " ") nil)
1155 prefix
1156 ))
1157 (t (error "unrecognized field type: %s" (cadr field)))))
1158
1159(defun entry-count-array-field (entry field name prefix is-param)
1160 (cond ((equal (cadr field) 'uint)
1161 (format "%ssize += sizeof (guint32);\n" prefix)
1162 )
1163 ((equal (cadr field) 'uint32)
1164 (format "%ssize += sizeof (guint32);\n" prefix)
1165 )
1166 ((equal (cadr field) 'uint16)
1167 (format "%ssize += sizeof (guint16);\n" prefix)
1168 )
1169 ((equal (cadr field) 'uint8)
1170 (format "%ssize += sizeof (guint8);\n" prefix)
1171 )
1172 ((equal (cadr field) 'boolean)
1173 (format "%ssize += sizeof (gboolean);\n" prefix)
1174 )
1175 ((equal (cadr field) 'string)
1176 (format "%ssize += strlen (%s) + 1 + sizeof (void*);\n" prefix name)
1177 )
1178 ((equal (cadr field) 'bytes)
1179 (error "can't do that: bytes1")
1180 )
1181 ((equal (cadr field) 'object)
1182 (error "can't do that: object")
1183 )
1184 ((member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1185 (format "%ssize += serializeio_count_%s_obj (%s%s);\n"
1186 prefix
1187 (downcase-string (cadr field))
1188 (if is-param "" "& ")
1189 name
1190 (cadr field)
1191 )
1192 )
1193 ((and (equal (car (cadr field)) 'ptr)
1194 (member (cadr (cadr field)) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*)))
1195 (format "%ssize += serializeio_count_%s_obj (%s) + sizeof (void*);\n" prefix (downcase-string (cadr (cadr field))) name)
1196 )
1197 ((equal (car (cadr field)) 'bytes)
1198 (error "can't do that: bytes2")
1199 )
1200 ((equal (car (cadr field)) 'array)
1201 (error "can't do that: array")
1202 )
1203 (t (error "unrecognized field type: %s" (cadr field)))))
1204
1205(defun entry-print-field (entry field name prefix is-param)
1206 (concat
1207 (format "%sprint_spaces (indent_spaces);\n" prefix)
1208 (if is-param (format "%sg_print (\"%s = \");\n" prefix (car field)) "")
1209 (cond ((equal (cadr field) 'uint)
1210 (format "%sg_print (\"%%d\\n\", %s);\n" prefix name))
1211 ((equal (cadr field) 'uint32)
1212 (format "%sg_print (\"%%d\\n\", %s);\n" prefix name))
1213 ((equal (cadr field) 'uint16)
1214 (format "%sg_print (\"%%d\\n\", %s);\n" prefix name))
1215 ((equal (cadr field) 'uint8)
1216 (format "%sg_print (\"%%d\\n\", %s);\n" prefix name))
1217 ((equal (cadr field) 'boolean)
1218 (format "%sg_print (\"%%s\\n\", %s ? \"true\" : \"false\");\n" prefix name))
1219 ((equal (cadr field) 'string)
1220 (format "%sg_print (\"%%s\\n\", %s);\n" prefix name))
1221 ((equal (cadr field) 'bytes)
1222 (format "%sserializeio_print_bytes (%s, %s_len);\n" prefix name name))
1223 ((equal (cadr field) 'object)
1224 (concat
1225 (if is-param (format "%sg_print (\"{\\n\");\n" prefix) "")
1226 (format "%sserializeio_generic_print (%s_type, %s, indent_spaces + 2);\n" prefix name name)
1227 (format "%sprint_spaces (indent_spaces);\n;\n" prefix)
1228 (if is-param (format "%sg_print (\"}\\n\");\n" prefix) "")
1229 )
1230 )
1231 ((member (cadr field) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1232 (concat
1233 (if is-param (format "%sg_print (\"{\\n\");\n" prefix) "")
1234 (format "%sserializeio_print_%s_obj (& %s, indent_spaces + 2);\n" prefix (downcase-string (cadr field)) name name)
1235 (format "%sprint_spaces (indent_spaces);\n;\n" prefix)
1236 (if is-param (format "%sg_print (\"}\\n\");\n" prefix) "")
1237 )
1238 )
1239 ((and (equal (car (cadr field)) 'ptr)
1240 (member (cadr (cadr field)) (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*)))
1241 (concat
1242 (if is-param (format "%sg_print (\"{\\n\");\n" prefix) "")
1243 (format "%sserializeio_print_%s_obj (%s, indent_spaces + 2);\n"
1244 prefix (downcase-string (cadr (cadr field))) name name)
1245 (format "%sprint_spaces (indent_spaces);\n;\n" prefix)
1246 (if is-param (format "%sg_print (\"}\\n\");\n" prefix) "")
1247 )
1248 )
1249 ((equal (car (cadr field)) 'bytes)
1250 (format "%sserializeio_print_bytes (%s, %d);\n" prefix name (cadr (cadr field))))
1251 ((equal (car (cadr field)) 'array)
1252 (concat
1253 (if is-param (format "%sg_print (\"{\\n\");\n" prefix) "")
1254 (format "%s{
1255%s gint i;
1256%s for (i = 0; i < %s_len; i += 1)
1257%s {
1258%s print_spaces (indent_spaces);
1259%s g_print (\"%%d:\\n\", i);
1260%s%s }
1261%s}
1262"
1263 prefix prefix prefix
1264 name
1265 prefix
1266 prefix
1267 prefix
1268 prefix
1269 (entry-print-field entry (cadr field) (array-index name (cadr field)) (concat prefix " ") nil)
1270 prefix
1271 )
1272 (if is-param (format "%sg_print (\"}\\n\");\n" prefix) "")))
1273 (t (error "unrecognized field type: %s" (cadr field)))))
1274 )
1275
1276(defconst *event-id* 0)
1277
1278(defconst *event-types* nil)
1279
1280(defun generate-events ()
1281 (let ((events *event-defs*))
1282 (while events
1283
1284 (let* ((event (car events))
1285 (uargs (event-uargs-get event))
1286 (sargs (event-sargs-get event))
1287 (type-prefix (intern (apply (function concat)
1288 (append (mapcar (function (lambda (x) (capitalize1 (cadr x)))) uargs)
1289 (mapcar (function (lambda (x) (capitalize1 x))) sargs)))))
1290 (capprefix (capitalize1 *output-prefix*)))
1291
1292 (if (and (not uargs) (not sargs))
1293 (setq type-prefix "Void"))
1294
1295 (when (not (member type-prefix *event-types*))
1296 (setq *event-types* (cons type-prefix *event-types*))
1297
1298 (output-header-file "_edsio")
1299
1300 (save-excursion
1301 (goto-char *header-typedef-marker*)
1302
1303 (insert (format "/* %s%sEventCode.\n */\n\n" capprefix type-prefix))
1304
1305 (insert (format "typedef struct _%s%sEventCode %s%sEventCode;\n" capprefix type-prefix capprefix type-prefix))
1306 (insert (format "struct _%s%sEventCode { gint code; };\n\n" capprefix type-prefix))
1307
1308 (insert (format "typedef struct _%s%sEvent %s%sEvent;\n" capprefix type-prefix capprefix type-prefix))
1309 (insert (format "struct _%s%sEvent { gint code; const char* srcfile; guint srcline;%s%s };\n\n" capprefix type-prefix (event-struct-entries event) (event-struct-sys-entries event)))
1310 )
1311
1312 (insert (format "void %s_generate_%s_event_internal (%s%sEventCode code, const char* srcfile, gint srcline%s);\n"
1313 *output-prefix*
1314 (downcase-string type-prefix)
1315 capprefix
1316 type-prefix
1317 (event-uargs-plist uargs t)
1318 ))
1319 (insert (format "#define %s_generate_%s_event(ecode%s) %s_generate_%s_event_internal((ecode),__FILE__,__LINE__%s)\n\n"
1320 *output-prefix*
1321 (downcase-string type-prefix)
1322 (event-uargs-alist uargs t)
1323 *output-prefix*
1324 (downcase-string type-prefix)
1325 (event-uargs-mlist uargs t)))
1326
1327 (output-source-file "_edsio")
1328
1329 (insert (format "void\n%s_generate_%s_event_internal (%s%sEventCode _code, const char* _srcfile, gint _srcline%s)\n"
1330 *output-prefix*
1331 (downcase-string type-prefix)
1332 capprefix
1333 type-prefix
1334 (event-uargs-plist uargs t)
1335 ))
1336 (insert (format "{\n"))
1337 (insert (format " %s%sEvent *_e = g_new0 (%s%sEvent, 1);\n" capprefix type-prefix capprefix type-prefix))
1338 (insert (format " _e->code = _code.code;\n _e->srcline = _srcline;\n _e->srcfile = _srcfile;\n"))
1339 (insert (event-uargs-copy "_e" event))
1340 (insert (event-sargs-copy "_e" event))
1341 (insert (format " eventdelivery_event_deliver ((GenericEvent*) _e);\n"))
1342 (insert (format "}\n\n"))
1343
1344 ;; Field to string def
1345
1346 (unless (equal type-prefix "Void")
1347 (save-excursion
1348 (goto-char *source-top-marker*)
1349 (insert (format "static const char* %s_%s_event_field_to_string (GenericEvent* ev, gint field);\n" capprefix type-prefix))
1350 )
1351
1352 (insert (format "const char*\n%s_%s_event_field_to_string (GenericEvent* ev, gint field)\n"
1353 capprefix type-prefix))
1354 (insert (format "{\n"))
1355
1356 (unless (equal type-prefix (intern "Ssl"))
1357 (insert (format " %s%sEvent* it = (%s%sEvent*) ev;\n" capprefix type-prefix capprefix type-prefix)))
1358 (insert (format " switch (field)\n"))
1359 (insert (format " {\n"))
1360
1361 (let ((uargs (event-uargs-get event))
1362 (i 0))
1363 (while uargs
1364 (let ((uarg (car uargs)))
1365 (insert (format " case %d: return eventdelivery_%s_to_string (it->%s);\n" i (cadr uarg) (car uarg)))
1366 )
1367 (setq i (+ i 1))
1368 (setq uargs (cdr uargs))
1369 )
1370 )
1371
1372 (if (< 1 (length (event-sargs-get event)))
1373 (error "unhandled case, too many sargs"))
1374
1375 (when (event-sargs-get event)
1376 (let ((sarg (car (event-sargs-get event))))
1377 (insert (format " case %d: " (length (event-uargs-get event))))
1378
1379 (if (not (member sarg '(ssl errno)))
1380 (error "what type of sarg is %s" sarg))
1381
1382 (if (eq sarg 'errno)
1383 (insert (format "return g_strdup (g_strerror (it->ev_errno));\n")))
1384
1385 (if (eq sarg 'ssl)
1386 (insert (format "return eventdelivery_ssl_errors_to_string ();\n")))
1387 )
1388 )
1389
1390 (insert (format " default: abort ();\n"))
1391 (insert (format " }\n"))
1392
1393 (insert (format "}\n\n"))
1394 )
1395 )
1396
1397 (output-header-file "_edsio")
1398
1399 (insert (format "extern const %s%sEventCode EC_%s%s;\n"
1400 capprefix
1401 type-prefix
1402 capprefix
1403 (event-name-get event)))
1404
1405 (insert (format "#define EC_%s%sValue ((%d<<EDSIO_LIBRARY_OFFSET_BITS)+%d)\n\n"
1406 capprefix
1407 (event-name-get event)
1408 *event-id*
1409 *library-id*))
1410
1411 (output-source-file "_edsio")
1412
1413 (insert (format "const %s%sEventCode EC_%s%s = { EC_%s%sValue };\n\n"
1414 capprefix
1415 type-prefix
1416 capprefix
1417 (event-name-get event)
1418 capprefix
1419 (event-name-get event)))
1420
1421
1422 (save-excursion
1423 (goto-char *source-init-marker*)
1424
1425 (insert (format " eventdelivery_initialize_event_def (EC_%s%sValue, EL_%s, %s, \"%s\", \"%s\", %s);\n"
1426 capprefix
1427 (event-name-get event)
1428 (event-level-get event)
1429 (event-flags-string event)
1430 (event-name-get event)
1431 (fixup-oneline event (event-desc-get event))
1432 (if (equal type-prefix "Void")
1433 "NULL"
1434 (format "& %s_%s_event_field_to_string" capprefix type-prefix))))
1435 )
1436
1437 (setq *event-id* (+ 1 *event-id*))
1438
1439 )
1440
1441 (setq events (cdr events))
1442 )
1443 )
1444 )
1445
1446(defun event-flags-string (event)
1447 (if (member 'ssl (event-sargs-get event))
1448 "EF_OpenSSL"
1449 "EF_None")
1450 )
1451
1452(defun event-struct-entries (event)
1453 (apply (function concat)
1454 (mapcar (function (lambda (x) (format " %s %s;" (event-type-to-ctype (cadr x)) (car x))))
1455 (event-uargs-get event)))
1456 )
1457
1458(defun event-struct-sys-entries (event)
1459 (if (member 'errno (event-sargs-get event))
1460 " gint ev_errno;"
1461 "")
1462 )
1463
1464(defun event-uargs-copy (name event)
1465 (apply (function concat)
1466 (mapcar (function (lambda (x) (format " %s->%s = %s;\n" name (car x) (car x))))
1467 (event-uargs-get event)))
1468 )
1469
1470(defun event-sargs-copy (name event)
1471 (if (member 'errno (event-sargs-get event))
1472 (format " %s->ev_errno = errno;\n" name)
1473 "")
1474 )
1475
1476(defun event-type-to-ctype (etype)
1477 (let ((it (obj-name-eq etype *all-etype-defs*)))
1478 (if (not it)
1479 (message "no ctype for %s" etype))
1480 (etype-ctype-get it)
1481 )
1482 )
1483
1484(defun event-uargs-plist(uargs need_first)
1485 (concat
1486 (if (and need_first uargs) ", " "")
1487 (format-comlist (function (lambda (x) (format "%s %s" (event-type-to-ctype (cadr x)) (car x)))) uargs))
1488 )
1489
1490(defun event-uargs-alist(uargs need_first)
1491 (concat
1492 (if (and need_first uargs) ", " "")
1493 (format-comlist (function (lambda (x) (format "%s" (car x)))) uargs))
1494 )
1495
1496(defun event-uargs-mlist(uargs need_first)
1497 (concat
1498 (if (and need_first uargs) ", " "")
1499 (format-comlist (function (lambda (x) (format "(%s)" (car x)))) uargs))
1500 )
1501
1502(defun fixup-oneline (event oneline)
1503 (let ((work (get-buffer-create "*string-tmp2*")))
1504 (save-excursion
1505 (set-buffer work)
1506 (erase-buffer)
1507 (insert oneline)
1508 (beginning-of-buffer)
1509
1510 (while (re-search-forward "${\\(\\w+\\)}" nil t)
1511
1512 (let* ((it (intern (downcase-string (match-string 1))))
1513 (uargs (event-uargs-get event))
1514 (i 0)
1515 (repl nil))
1516
1517 (while uargs
1518
1519 (if (eq (car (car uargs)) it)
1520 (setq repl (format "${%d}" i)))
1521
1522 (setq uargs (cdr uargs))
1523 (setq i (+ i 1))
1524 )
1525
1526 (when (eq it 'strerror)
1527 (if repl
1528 (error "No wildcards named STRERROR"))
1529 (setq repl (format "${%d}" i))
1530 )
1531
1532 (when (eq it 'ssl)
1533 (if repl
1534 (error "No wildcards named SSL"))
1535 (setq repl (format "${%d}" i))
1536 )
1537
1538 (if (not repl)
1539 (error "Illegal wildcard %s in %s" it oneline))
1540
1541 (replace-match repl nil nil)
1542 )
1543 )
1544
1545 (buffer-string)
1546 )
1547 )
1548 )
1549
1550;; Properties
1551
1552(defun generate-properties ()
1553 (let ((cap-prefix (capitalize1 *output-prefix*))
1554 (unique-types nil))
1555 (output-header-file "_edsio")
1556
1557 (insert (format "/* Property definitions */\n\n"))
1558
1559 ;; Types
1560
1561 (output-source-file "_edsio")
1562
1563 (mapcar
1564 (function
1565 (lambda (pht)
1566 (let ((type (prophosttype-type-get pht)))
1567 (unless (member type unique-types)
1568 (setq unique-types (cons type unique-types))
1569
1570 (save-excursion
1571 (goto-char *source-init-marker*)
1572
1573 ;(message "%s -> %s %s" type (type-free-func type) (member type (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*)))
1574
1575 (insert (format " edsio_initialize_property_type (\"%s\", %s, %s, %s, %s, %s);\n"
1576 type
1577 (type-free-func type)
1578 (type-gs-func type "getter")
1579 (type-gs-func type "setter")
1580 (type-serialize-func type)
1581 (type-unserialize-func type)))
1582 )
1583 )
1584 )
1585 )
1586 )
1587 *prophosttype-defs*
1588 )
1589
1590 ;; Host reg
1591
1592 (mapcar
1593 (function
1594 (lambda (prophost)
1595 (save-excursion
1596 (goto-char *source-init-marker*)
1597 (insert (format " edsio_initialize_host_type (\"%s\", %s, %s, %s, %s, %s);\n"
1598 (prophost-name-get prophost)
1599 (format "(PropertyTableFunc) & edsio_%s_property_table"
1600 (downcase-string (prophost-name-get prophost)))
1601 (prophost-persist prophost "source")
1602 (prophost-persist prophost "sink")
1603 (prophost-persist prophost "isset")
1604 (prophost-persist prophost "unset")
1605 ))
1606 )
1607 )
1608 )
1609 *prophost-defs*)
1610
1611 ;; Compute each distinct (host type) x (prop type)
1612
1613 (mapcar
1614 (function
1615 (lambda (prophost)
1616
1617 (mapcar
1618 (function
1619 (lambda (prophosttype)
1620
1621 (when (equal (prophosttype-host-get prophosttype) (prophost-name-get prophost))
1622
1623 (when (not (member (prophosttype-type-get prophosttype) (prophost-proptypes-get prophost)))
1624 (prophost-proptypes-set prophost (cons (prophosttype-type-get prophosttype) (prophost-proptypes-get prophost)))
1625 )
1626 )))
1627 *prophosttype-defs*
1628 )
1629
1630 ;; Output the get/set functions for each property type
1631
1632 (mapcar
1633 (function
1634 (lambda (type)
1635
1636 (let ((it (property-code-typename type prophost)))
1637
1638 ;; Header
1639
1640 (output-header-file "_edsio")
1641
1642 (insert (format "/* Property get/set for %s/%s\n */\n\n" (prophost-name-get prophost) type))
1643
1644 (insert (format "typedef struct _%s %s;\n" it it))
1645
1646 (insert (format "struct _%s { guint32 code; };\n\n" it))
1647
1648 (insert (format "gboolean edsio_new_%s_%s_property (const char* name, guint32 flags, %s* prop);\n"
1649 (downcase-string (prophost-name-get prophost))
1650 (type-canon-name type)
1651 it
1652 ))
1653
1654 (insert (format "gboolean %s_get_%s (%s obj, %s prop%s);\n"
1655 (downcase-string (prophost-name-get prophost))
1656 (type-canon-name type)
1657 (prophost-ctype-get prophost)
1658 it
1659 (prop-type-to-get-fps type)))
1660
1661 (insert (format "gboolean %s_set_%s (%s obj, %s prop%s);\n"
1662 (downcase-string (prophost-name-get prophost))
1663 (type-canon-name type)
1664 (prophost-ctype-get prophost)
1665 it
1666 (prop-type-to-set-fps type)))
1667
1668 (insert (format "gboolean %s_unset_%s (%s obj, %s prop);\n"
1669 (downcase-string (prophost-name-get prophost))
1670 (type-canon-name type)
1671 (prophost-ctype-get prophost)
1672 it))
1673
1674 (insert (format "gboolean %s_isset_%s (%s obj, %s prop);\n\n"
1675 (downcase-string (prophost-name-get prophost))
1676 (type-canon-name type)
1677 (prophost-ctype-get prophost)
1678 it))
1679
1680 ;; Source
1681
1682 (output-source-file "_edsio")
1683
1684 (insert (format "gboolean edsio_new_%s_%s_property (const char* name, guint32 flags, %s* prop)\n{\n"
1685 (downcase-string (prophost-name-get prophost))
1686 (type-canon-name type)
1687 it
1688 ))
1689 (insert (format " return edsio_new_property (name, \"%s\", \"%s\", flags, (EdsioGenericProperty*) prop);\n" (prophost-name-get prophost) type))
1690 (insert (format "}\n\n"))
1691
1692 (insert (format "gboolean\n%s_get_%s (%s obj, %s prop%s)\n{\n"
1693 (downcase-string (prophost-name-get prophost))
1694 (type-canon-name type)
1695 (prophost-ctype-get prophost)
1696 it
1697 (prop-type-to-get-fps type)))
1698 (insert (format " EdsioProperty* ep;\n"))
1699 (insert (format " g_return_val_if_fail (obj, FALSE);\n"))
1700 (insert (format " return (* edsio_property_getter (\"%s\", \"%s\", prop.code, & ep)) (obj, ep%s);\n"
1701 (prophost-name-get prophost)
1702 type
1703 (prop-type-to-args type)
1704 ))
1705
1706 (insert (format "}\n\n"))
1707
1708 (insert (format "gboolean\n%s_set_%s (%s obj, %s prop%s)\n{\n"
1709 (downcase-string (prophost-name-get prophost))
1710 (type-canon-name type)
1711 (prophost-ctype-get prophost)
1712 it
1713 (prop-type-to-set-fps type)))
1714 (insert (format " EdsioProperty* ep;\n"))
1715 (insert (format " g_return_val_if_fail (obj, FALSE);\n"))
1716 (insert (format " return (* edsio_property_setter (\"%s\", \"%s\", prop.code, & ep)) (obj, ep%s);\n"
1717 (prophost-name-get prophost)
1718 type
1719 (prop-type-to-args type)
1720 ))
1721
1722 (insert (format "}\n\n"))
1723
1724 (insert (format "gboolean\n%s_unset_%s (%s obj, %s prop)\n{\n"
1725 (downcase-string (prophost-name-get prophost))
1726 (type-canon-name type)
1727 (prophost-ctype-get prophost)
1728 it))
1729 (insert (format " g_return_val_if_fail (obj, FALSE);\n"))
1730 (insert (format " return edsio_property_unset (\"%s\", \"%s\", prop.code, obj);\n"
1731 (prophost-name-get prophost)
1732 type
1733 ""
1734 ))
1735
1736 (insert (format "}\n\n"))
1737
1738 (insert (format "gboolean\n%s_isset_%s (%s obj, %s prop)\n{\n"
1739 (downcase-string (prophost-name-get prophost))
1740 (type-canon-name type)
1741 (prophost-ctype-get prophost)
1742 it))
1743 (insert (format " g_return_val_if_fail (obj, FALSE);\n"))
1744 (insert (format " return edsio_property_isset (\"%s\", \"%s\", prop.code, obj);\n"
1745 (prophost-name-get prophost)
1746 type
1747 ))
1748
1749 (insert (format "}\n\n"))
1750
1751 )
1752 )
1753 )
1754 (prophost-proptypes-get prophost)
1755 )
1756 )
1757 )
1758 *all-prophost-defs*
1759 )
1760 )
1761 )
1762
1763(defun property-code-typename(type prophost)
1764 (format "%s%s%sProperty"
1765 (capitalize1 *output-prefix*)
1766 (prophost-name-get prophost)
1767 (capitalize1 type))
1768 )
1769
1770(defun prop-typename-ctypes (type)
1771 (cond ((equal type 'string)
1772 (list (list 'arg "const gchar*")))
1773 ((equal type 'uint)
1774 (list (list 'arg "guint32")))
1775 ((equal type 'uint32)
1776 (list (list 'arg "guint32")))
1777 ((equal type 'uint16)
1778 (list (list 'arg "guint16")))
1779 ((equal type 'uint8)
1780 (list (list 'arg "guint8")))
1781 ((equal type 'boolean)
1782 (list (list 'arg "gboolean")))
1783 ((equal type 'bytes)
1784 (list (list 'arg "const guint8*") (list 'arg_len "guint32")))
1785 ((equal type 'object)
1786 (list (list 'arg "void*") (list 'arg_type "guint32")))
1787 ((member type (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1788 (list (list 'arg (format "Serial%s*" type))))
1789 ((equal (car type) 'bytes)
1790 (list (list 'arg "const guint8*")))
1791 ((equal (car type) 'array)
1792 (list (list 'arg (format "%s*" (cadr (car (prop-typename-ctypes (cadr type))))))
1793 (list 'arg_len "guint32")))
1794 ((equal (car type) 'ptr)
1795 (list (list 'arg (format "%s*" (cadr (car (prop-typename-ctypes (cadr type))))))))
1796 (t (error "unrecognized field type: %s" type)))
1797 )
1798
1799(defun prop-type-to-get-fps (type)
1800 (concat ", "
1801 (format-comlist
1802 (function
1803 (lambda (pair)
1804 (format "%s* %s" (cadr pair) (car pair))
1805 )
1806 )
1807 (prop-typename-ctypes type))
1808 )
1809 )
1810
1811(defun prop-type-to-set-fps (type)
1812 (concat ", "
1813 (format-comlist
1814 (function
1815 (lambda (pair)
1816 (format "%s %s" (cadr pair) (car pair))
1817 )
1818 )
1819 (prop-typename-ctypes type))
1820 )
1821 )
1822
1823(defun prop-type-to-args (type)
1824 (concat ", "
1825 (format-comlist
1826 (function
1827 (lambda (pair)
1828 (format "%s" (car pair))
1829 )
1830 )
1831 (prop-typename-ctypes type))
1832 )
1833 )
1834
1835(defun type-canon-name (type)
1836 ; @@@ does not work for (array ...), etc
1837 (downcase-string type))
1838
1839(defun type-serialize-func (type)
1840 (format "serialize_%s_obj" (downcase-string type))
1841 )
1842
1843(defun type-unserialize-func (type)
1844 (format "unserialize_%s" (downcase-string type))
1845 )
1846
1847(defun type-gs-func (type name)
1848 (if (member type (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1849 (format "& edsio_property_vptr_%s" name)
1850 (format "& edsio_property_%s_%s" type name)))
1851
1852(defun type-free-func (type)
1853 (if (member type (mapcar (lambda (x) (sertype-name-get x)) *all-sertype-defs*))
1854 (format "& edsio_property_vptr_free")
1855 (format "& edsio_property_%s_free" type)))
1856
1857(defun prophost-persist (prophost func)
1858 (if (prophost-persist-get prophost)
1859 (format "(Persist%sFunc) & %s_persist_%s_%s"
1860 (capitalize1 func)
1861 *output-prefix*
1862 (downcase-string (prophost-name-get prophost))
1863 func)
1864 "NULL"))
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-08 00:58:25 +0000