nyacc: cleaned up documentation
[mes.git] / module / nyacc / lang / c99 / util2.scm
1 ;;; nyacc/lang/c99/util2.scm - C processing code
2 ;;; 
3 ;;; Copyright (C) 2015-2017 Matthew R. Wette
4 ;;;
5 ;;; This program is free software: you can redistribute it and/or modify
6 ;;; it under the terms of the GNU General Public License as published by 
7 ;;; the Free Software Foundation, either version 3 of the License, or 
8 ;;; (at your option) any later version.
9 ;;;
10 ;;; This program is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 ;;; GNU General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU General Public License
16 ;;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
17
18 ;; utilities for processing output trees
19
20 ;; The idea is to convert declarations into something like
21 ;; @example
22 ;; const char *args[21];  /* command arguments */
23 ;; @end example
24 ;; @noindent
25 ;; into
26 ;; @example
27 ;; ("args" (comment " command arguments ")
28 ;;  (array-of 21) (pointer-to) (fixed "char"))
29 ;; @end example
30 ;; @noindent
31 ;; or without the comment.  It is a question whether we need the fixed part.
32 ;; In addition, we want to reduce to a set of canonical types.  So something
33 ;; like @code{foo_t} should be expanded.
34
35 ;; KEEPING STRUCTS ENUMS etc
36 ;; if have typename and want to keep it, then change
37 ;;   (typename "foo_t")
38 ;; to
39 ;;   (typename (@ (base "struct")) "foo_t")
40
41 ;; ALSO
42 ;;  (make-proxy comp-udecl) => udecl
43 ;;  (revert-proxy udecl) => comp-udecl
44
45 (define-module (nyacc lang c99 util2)
46   #:export (tree->udict
47             stripdown stripdown-2
48             udecl->mspec
49             udecl->mspec/comm
50
51             unwrap-decl
52             canize-enum-def-list
53             fix-fields
54             fixed-width-int-names
55
56             match-decl match-comp-decl match-param-decl
57             declr->ident
58             expand-decl-typerefs
59             )
60   #:use-module (nyacc lang c99 pprint)
61   #:use-module (ice-9 pretty-print)
62   #:use-module (srfi srfi-1)
63   #:use-module ((sxml fold) #:select (foldts foldts*))
64   #:use-module (sxml match)
65   #:use-module (nyacc lang util)
66   #:use-module (nyacc lang c99 pprint)
67   )
68
69 ;; Use the term @dfn{udecl}, or unit-declaration, for a declaration which has
70 ;; only one decl-item.  That is where,
71 ;; @example
72 ;; @end example
73 ;; (decl (decl-spec-list ...) (init-declr-list (init-declr ...) ...))
74 ;; @noindent
75 ;; has been replaced by
76 ;; (decl (decl-spec-list ...) (init-declr ...))
77 ;; ...
78 ;; @example
79 ;; @end example
80
81 ;; mspec is
82 ;; ("foo" (pointer-to) (array-of 3) (fixed-type "unsigned int"))
83 ;; which can be converted to
84 ;; ("(*foo) (array-of 3) (fixed-type "unsigned int"))
85 ;; which can be converted to
86 ;; (("((*foo)[0])" (fixed-type "unsigned int"))
87 ;;  ("((*foo)[1])" (fixed-type "unsigned int"))
88 ;;  ("((*foo)[2])" (fixed-type "unsigned int"))
89
90 ;; may need to replace (typename "int32_t") with (fixed-type "int32_t")
91
92
93 ;; @deffn {Procedure} declr->ident declr => (ident "name")
94 ;; just match the declarator
95 ;; (init-declr <declr> [<initzer>])
96 ;; See also: declr->id-name in body.scm.
97 ;; @end deffn
98 (define (declr->ident declr)
99   (sxml-match declr
100     ((init-declr ,declr . ,rest) (declr->ident declr))
101     ((comp-declr ,declr) (declr->ident declr))
102     ((param-declr ,declr) (declr->ident declr))
103     ((ident ,name) declr)
104     ((array-of ,dir-declr ,array-spec) (declr->ident dir-declr))
105     ((array-of ,dir-declr) (declr->ident dir-declr))
106     ((ptr-declr ,pointer ,dir-declr) (declr->ident dir-declr))
107     ((ftn-declr ,dir-declr ,rest ...) (declr->ident dir-declr))
108     ((scope ,declr) (declr->ident declr))
109     (,otherwise (throw 'util-error "c99/util2: unknown declarator: " declr))))
110
111 ;; @deffn {Procedure} unwrap-decl decl seed => seed
112 ;; This is a fold to break up multiple declarators.
113 ;; @example
114 ;; (decl (decl-spec-list ...) (init-declr-list (init-declr ...) ...))
115 ;; =>
116 ;; ((decl (decl-spec-list ...) (init-declr ...))
117 ;;  (decl (decl-spec-list ...) (init-declr ...))
118 ;;  ...)
119 ;; @end example
120 ;; @end deffn
121 (define (unwrap-decl decl seed)
122   (cond
123    ((not (eqv? 'decl (car decl))) seed)
124    ((< (length decl) 3) seed)           ; this should catch struct-ref etc.
125    (else
126     (let* ((tag (sx-ref decl 0))
127            (attr (sx-attr decl))
128            (spec (sx-ref decl 1))       ; (decl-spec-list ...)
129            (id-l (sx-ref decl 2))       ; (init-declr-list ...)
130            (tail (sx-tail decl 3)))     ; comment
131       (let iter ((res seed) (idl (cdr id-l)))
132         (if (null? idl) res
133             (let* ((declr (sx-ref (car idl) 1))
134                    (ident (declr->ident declr))
135                    (name (cadr ident)))
136               (iter (cons (if attr
137                               (cons* tag attr spec (car idl) tail)
138                               (cons* tag spec (car idl) tail))
139                           res)
140                     (cdr idl)))))))))
141
142
143 ;; @deffn {Procedure} tree->udict tree => udict
144 ;; Turn a C parse tree into a assoc-list of names and definitions.
145 ;; This will unwrap @code{init-declr-list} into list of decls w/
146 ;; @code{init-declr}.
147 ;; BUG: need to add struct and union defn's: struct foo { int x; };
148 ;; how to deal with this
149 ;; lookup '(struct . "foo"), "struct foo", ???
150 ;; wanted "struct" -> dict but that is not great
151 ;; solution: match-decl => '(struct . "foo") then filter to generate
152 ;; ("struct" ("foo" . decl) ..)
153 ;; ("union" ("bar" . decl) ..)
154 ;; @end deffn
155 (define (tree->udict tree)
156   (if (pair? tree)
157       (fold match-decl '() (cdr tree))
158       '()))
159
160 ;; @deffn {Procedure} match-decl decl seed
161 ;; This procedure is intended to be used with @code{fold}.  It breaks up
162 ;; up the init-declr-list into individual init-declr items and associates
163 ;; with the identifier being declared.  So this is a fold iterator to
164 ;; provide a dictionary of declared names.
165 ;; @example
166 ;; (decl (decl-spec-list ...) (init-declr-list (init-declr ...) ...))
167 ;; @end example
168 ;; @noindent
169 ;; has been replaced by
170 ;; @example
171 ;; (decl (decl-spec-list ...) (init-declr ...))
172 ;; (decl (decl-spec-list ...) ...)
173 ;; @end example
174 ;; Here we generate a dictionary of all declared items:
175 ;; @example
176 ;; (let* ((sx0 (with-input-from-file src-file parse-c))
177 ;;        (sx1 (merge-inc-trees! sx0))
178 ;;        (name-dict (fold match-decl-1 '() (cdr sx1))))
179 ;; @end example
180 ;; TODO: add enums because they are global!!
181 ;; turn enum { ABC = 123 }; into '(ABC . (enum .. "ABC" "123" .. )
182 ;; @end deffn
183 (define (match-decl decl seed)
184   (let* ((tag (sx-ref decl 0)) (attr (sx-attr decl)))
185     (case tag
186       ((decl)
187        (let* ((spec (sx-ref decl 1))    ; (decl-spec-list ...)
188               (tbd (sx-ref decl 2)))    ; (init-declr-list ...) OR ...
189          (cond
190           ((or (not tbd) (eqv? 'comment (sx-tag tbd)))
191            ;; no init-declr-list => struct or union def or param-decl enum
192            ;;(display "spec:\n") (pretty-print decl)
193            (sxml-match spec
194              ((decl-spec-list
195                (type-spec
196                 (struct-def (ident ,name) . ,rest2) . ,rest1))
197               (acons `(struct . ,name) decl seed))
198              ((decl-spec-list
199                (type-spec
200                 (union-def (ident ,name) . ,rest2) . ,rest1))
201               (acons `(union . ,name) decl seed))
202              ((decl-spec-list
203                (type-spec
204                 (enum-def
205                  (enum-def-list
206                   (enum-defn
207                    (ident "ABC")
208                    (p-expr (fixed "123")))))))
209               ;; TODO
210               seed)
211              (,otherwise
212               ;; e.g., enum { VAL = 1 };
213               ;;(simple-format #t "+++ otherwise: ~S\n" tbd) (pretty-print decl)
214               seed)))
215           (else ;; decl with init-declr-list
216            (let* ((id-l tbd) (tail (sx-tail decl 3)))
217              (let iter ((res seed) (idl (cdr id-l)))
218                (if (null? idl) res
219                    (let* ((declr (sx-ref (car idl) 1))
220                           (ident (declr->ident declr))
221                           (name (cadr ident)))
222                      (iter
223                       (acons name
224                              (if attr
225                                  (cons* tag attr spec (car idl) tail)
226                                  (cons* tag spec (car idl) tail))
227                              res)
228                       (cdr idl))))))))))
229       (else seed))))
230
231 ;; @deffn {Procedure} match-comp-decl decl seed
232 ;; This will turn
233 ;; @example
234 ;; (comp-decl (decl-spec-list (type-spec "int"))
235 ;;            (comp-decl-list
236 ;;             (comp-declr (ident "a")) (comp-declr (ident "b"))))
237 ;; @end example
238 ;; @noindent
239 ;; into
240 ;; @example
241 ;; ("a" . (comp-decl (decl-spec-list ...) (comp-declr (ident "a"))))
242 ;; ("b" . (comp-decl (decl-spec-list ...) (comp-declr (ident "b"))))
243 ;; @end example
244 ;; @noindent
245 ;; This is coded to be used with fold-right in order to preserve order
246 ;; in @code{struct} and @code{union} field lists.
247 ;; @end deffn
248 (define (match-comp-decl decl seed)
249   (if (not (eqv? 'comp-decl (car decl))) seed
250       (let* ((tag (sx-ref decl 0))
251              (attr (sx-attr decl))
252              (spec (sx-ref decl 1))     ; (type-spec ...)
253              (id-l (sx-ref decl 2))     ; (init-declr-list ...)
254              (tail (sx-tail decl 3)))   ; opt comment, different here
255         ;;(simple-format #t "1: ~S\n" id-l)
256         (let iter ((res seed) (idl (cdr id-l)))
257           (if (null? idl) res
258               (let* ((declr (sx-ref (car idl) 1))
259                      (ident (declr->ident declr))
260                      (name (cadr ident)))
261                 ;;(pretty-print `(comp-decl ,spec ,(car idl) . ,tail))
262                 (acons name
263                        (if attr
264                            (cons* tag attr spec (car idl) tail)
265                            (cons* tag spec (car idl) tail))
266                        (iter res (cdr idl)))))))))
267
268 ;; @deffn {Procedure} match-param-decl param-decl seed
269 ;; This will turn
270 ;; @example
271 ;; (param-decl (decl-spec-list (type-spec "int")) (param-declr (ident "a")))
272 ;; @end example
273 ;; @noindent
274 ;; into
275 ;; @example
276 ;; ("a" . (comp-decl (decl-spec-list ...) (comp-declr (ident "a"))))
277 ;; @end example
278 ;; @noindent
279 ;; This is coded to be used with fold-right in order to preserve order
280 ;; in @code{struct} and @code{union} field lists.
281 ;; @end deffn
282 (define (match-param-decl decl seed)
283   (if (not (eqv? 'param-decl (car decl))) seed
284       (let* ((tag (sx-ref decl 0))
285              (attr (sx-attr decl))
286              (spec (sx-ref decl 1))     ; (type-spec ...)
287              (declr (sx-ref decl 2))    ; (param-declr ...)
288              (ident (declr->ident declr))
289              (name (cadr ident)))
290         (acons name decl seed))))
291         
292 ;; @deffn find-special udecl-alist seed => ..
293 ;; NOT DONE
294 ;; @example
295 ;; '((struct . ("foo" ...) ...)
296 ;;   (union . ("bar" ...) ...)
297 ;;   (enum . ("bar" ...) ...)
298 ;;   seed)
299 ;; @end example
300 ;; @end deffn
301 (define (find-special udecl-alist seed)
302   (let iter ((struct '()) (union '()) (enum '()) (udal udecl-alist))
303     (if (null? udal) (cons* (cons 'struct struct)
304                           (cons 'union union)
305                           (cons 'enum enum)
306                           seed)
307         '())))
308
309 (define tmap-fmt
310   '(("char" "%hhd")
311     ("unsigned char" "%hhu")
312     ("short int" "%hd")
313     ("unsigned short int" "%hu")
314     ("int" "%d")
315     ("unsigned int" "%u")
316     ("long int" "%ld")
317     ("unsigned long int" "%lu")
318     ("long long int" "%lld")
319     ("unsigned long long int" "%llu")))
320
321 (define fixed-width-int-names
322   '("int8_t" "uint8_t" "int16_t" "uint16_t"
323     "int32_t" "uint32_t" "int64_t" "uint64_t"))
324
325 ;; @deffn {Procedure} typedef-decl? decl)
326 ;; @end deffn
327 (define (typedef-decl? decl)
328   (sxml-match decl
329     ((decl (decl-spec-list (stor-spec (typedef)) . ,r1) . ,r2) #t)
330     (,otherwise #f)))
331
332 ;; @deffn {Procedure} splice-declarators orig-declr tdef-declr => 
333 ;; Splice the original declarator into the typedef declarator.
334 ;; This is a helper for @code{expand-*-typename-ref} procecures.
335 ;; @end deffn
336 (define (splice-declarators orig-declr tdef-declr)
337   
338   (define (fD seed tree)                ; => (values seed tree)
339     (sxml-match tree
340       ((param-list . ,rest) (values tree '())) ; don't process
341       ((ident ,name) (values (reverse (cadr orig-declr)) '())) ; replace
342       (,otherwise (values '() tree))))
343
344   (define (fU seed kseed tree)
345     (let ((ktree (case (car kseed)
346                    ((param-list ident) kseed)
347                    (else (reverse kseed)))))
348       (if (null? seed) ktree (cons ktree seed))))
349
350   (define (fH seed tree)
351     (cons tree seed))
352
353   ;; This cons transfers the tag from orig-declr to the result.
354   (cons
355    (car orig-declr)                     ; init-declr or comp-declr
356    (cdr (foldts* fD fU fH '() tdef-declr)))) ; always init-declr
357
358
359 ;; @deffn {Procedure} repl-typespec decl-spec-list replacement
360 ;; This is a helper for expand-decl-typerefs
361 ;; @end deffn
362 (define (repl-typespec decl-spec-list replacement)
363   (fold-right
364    (lambda (item seed)
365      (cond ((symbol? item) (cons item seed))
366            ((eqv? 'type-spec (car item))
367             (if (pair? (car replacement))
368                 (append replacement seed)
369                 (cons replacement seed)))
370            (else (cons item seed))))
371    '() decl-spec-list))
372
373 ;; @deffn {Procedure} expand-decl-typerefs udecl udecl-dict => udecl
374 ;; Given a declaration or component-declaration, expand all typename,
375 ;; struct, union and enum refs.
376 ;; @example
377 ;; typedef const int  (*foo_t)(int a, double b);
378 ;; extern    foo_t    fctns[2];
379 ;; =>
380 ;; extern const int  (*fctns[2])(int a, double b);
381 ;; @end example
382 ;; @noindent
383 ;; Cool. Eh? (but is it done?)
384 ;; @end deffn
385 (define* (expand-decl-typerefs udecl udecl-dict #:key (keep '()))
386   ;;(display "FIXME: some decls have no init-declr-list\n")
387   ;; between adding (init-declr-list) to those or having predicate
388   ;; (has-init-declr? decl)
389   (let* ((tag (sx-tag udecl))           ; decl or comp-decl
390          (attr (sx-attr udecl))         ; (@ ...)
391          (specl (sx-ref udecl 1))       ; decl-spec-list
392          (declr (or (sx-find 'init-declr udecl)
393                     (sx-find 'comp-declr udecl)))
394          (tail (if declr (sx-tail udecl 3) (sx-tail udecl 2))) ; opt comment
395          (tspec (cadr (sx-find 'type-spec specl))))
396     ;;(simple-format #t "=D> ~S\n" decl-spec-list)
397     ;;(simple-format #t "init-declr: ~S\n" init-declr)
398     (case (car tspec)
399       ((typename)
400        (cond
401         ((member (cadr tspec) keep) udecl)
402         (else ;; splice in the typedef
403          (let* ((name (sx-ref tspec 1))
404                 (decl (or (assoc-ref udecl-dict name) ; decl for typename
405                           (throw 'c99-error "util2 decl error")))
406                 (tdef-specl (sx-ref decl 1)) ; decl-spec-list for typename
407                 (tdef-declr (sx-ref decl 2)) ; init-declr for typename
408                 ;; splice the typedef specifiers into target:
409                 (fixd-specl (repl-typespec specl (sx-tail tdef-specl 2)))
410                 (fixd-declr (splice-declarators declr tdef-declr))
411                 (fixed-udecl (cons* tag fixd-specl fixd-declr tail)))
412            (expand-decl-typerefs fixed-udecl udecl-dict #:keep keep)))))
413
414       ((struct-ref union-ref)
415        (simple-format (current-error-port)
416                       "+++ c99/util2: struct/union-ref: more to do?\n")
417        ;;(simple-format #t "\nstruct-ref:\n") (pretty-print udecl)
418        udecl)
419
420       ((struct-def union-def)
421        (let* ((ident (sx-find 'ident tspec))
422               (field-list (sx-find 'field-list tspec))
423               (orig-flds (cdr field-list))
424               (unit-flds (map cdr (fold-right match-comp-decl '() orig-flds)))
425               (fixd-flds (map
426                           (lambda (fld)
427                             (expand-decl-typerefs fld udecl-dict #:keep keep))
428                           unit-flds))
429               (fixd-tspec
430                (if #f ;;ident
431                    `(type-spec (struct-def ,ident (field-list ,@fixd-flds)))
432                    `(type-spec (struct-def (field-list ,@fixd-flds)))))
433               (fixd-specl (repl-typespec specl fixd-tspec)))
434          (if declr (cons* tag fixd-specl declr tail)
435              (cons* tag fixd-specl tail))))
436       
437       ((enum-def)
438        (let* ((enum-def-list (sx-find 'enum-def-list tspec))
439               (fixd-def-list (canize-enum-def-list enum-def-list))
440               (fixd-tspec `(type-spec (enum-def ,fixd-def-list)))
441               (fixd-specl (repl-typespec specl fixd-tspec))
442               (fixed-decl (cons* tag fixd-specl declr tail))) ;; !!!
443          fixed-decl))
444
445       ((enum-ref)
446        (simple-format (current-error-port) "chack: enum-ref NOT DONE\n")
447        udecl)
448
449       (else udecl))))
450   
451 ;; @deffn {Procedure} canize-enum-def-list
452 ;; Fill in constants for all entries of an enum list.
453 ;; @end deffn
454 (define (canize-enum-def-list enum-def-list)
455   (define (get-used edl)
456     (let iter ((uzd '()) (edl edl))
457          (cond
458           ((null? edl) uzd)
459           ((assq-ref (cdar edl) 'p-expr) =>
460            (lambda (x)
461              (iter (cons (string->number (cadar x)) uzd) (cdr edl))))
462           (else
463            (iter uzd (cdr edl))))))
464   (let ((used (get-used (cdr enum-def-list))))
465     (let iter ((rez '()) (ix 0) (edl (cdr enum-def-list)))
466       (cond
467        ((null? edl) (cons (car enum-def-list) (reverse rez)))
468        ((assq-ref (cdar edl) 'p-expr)
469         (iter (cons (car edl) rez) ix (cdr edl)))
470        (else
471         (let* ((ix1 (let iter ((ix (1+ ix)))
472                       (if (memq ix used) (iter (1+ ix)) ix)))
473                (is1 (number->string ix1)))
474           (iter (cons (append (car edl) `((p-expr (fixed ,is1)))) rez)
475                 ix1 (cdr edl))))))))
476
477 ;; @deffn stripdown udecl decl-dict => decl
478 ;; 1) remove stor-spec
479 ;; 2) expand typenames
480 ;; @example
481 ;; typedef int *x_t;
482 ;; x_t a[10];
483 ;; (spec (typename x_t)) (init-declr (array-of 10 (ident a)))
484 ;; (spec (typedef) (fixed-type "int")) (init-declr (pointer) (ident "x_t"))
485 ;; =>
486 ;; [TO BE DOCUMENTED]
487 ;; @end example
488 ;; @end deffn
489 (define* (stripdown udecl decl-dict #:key (keep '()))
490
491   ;;(define strip-list '(stor-spec type-qual comment))
492   (define strip-list '(stor-spec type-qual))
493
494   (define (fsD seed tree)
495     '())
496
497   (define (fsU seed kseed tree)
498     (if (memq (car tree) strip-list)
499         seed
500         (if (null? seed)
501             (reverse kseed)
502             (cons (reverse kseed) seed))))
503         
504   (define (fsH seed tree)
505     (cons tree seed))
506
507   (let* ((xdecl (expand-decl-typerefs udecl decl-dict #:keep keep))
508          (tag (sx-tag xdecl))
509          (attr (sx-attr xdecl))
510          (specl (sx-ref xdecl 1))
511          (declr (sx-ref xdecl 2))
512          (specl1 (foldts fsD fsU fsH '() specl)))
513     (list tag specl1 declr)))
514
515 ;; This one experimental for guile ffi.
516 (define* (stripdown-2 udecl decl-dict #:key (keep '()))
517
518   ;;(define strip-list '(stor-spec type-qual comment))
519   (define strip-list '(stor-spec type-qual))
520
521   (define (fsD seed tree)
522     '())
523
524   (define (fsU seed kseed tree)
525     (if (memq (car tree) strip-list)
526         seed
527         (if (null? seed)
528             (reverse kseed)
529             (cons (reverse kseed) seed))))
530         
531   (define (fsH seed tree)
532     (cons tree seed))
533
534   (let* ((speclt (sx-tail udecl 1)))    ; decl-spec-list tail
535     ;; don't expand typedefs, structure specs etc,
536     (cond
537      ((and (eqv? 'stor-spec (caar speclt))
538            (eqv? 'typedef (cadar speclt)))
539       udecl)
540      ;; lone struct ref
541      (else
542       (let* ((xdecl (expand-decl-typerefs udecl decl-dict #:keep keep))
543              (tag (sx-tag xdecl))
544              (attr (sx-attr xdecl))
545              (specl (sx-ref xdecl 1))
546              (declr (sx-ref xdecl 2))
547              (specl1 (foldts fsD fsU fsH '() specl)))
548         (list tag specl1 declr))))
549       ))
550
551
552 ;; @deffn {Procedure} udecl->mspec sudecl
553 ;; Turn a stripped-down unit-declaration into an m-spec.
554 ;; This assumes decls have been run through @code{stripdown}.
555 ;; @end deffn
556 (define (udecl->mspec decl . rest)
557
558   (define (cnvt-array-size size-spec)
559     (with-output-to-string (lambda () (pretty-print-c99 size-spec))))
560
561   (define (unwrap-specl specl)
562     (let ((tspec (cadadr specl)))
563       ;;(simple-format #t "tspec:\n") (pretty-print tspec)
564       (sxml-match tspec
565         ((xxx-struct-def (field-list . ,rest))
566          `(struct-def ,@rest))
567         (,otherwise
568          tspec))))
569     
570   (define (unwrap-declr declr)
571     (sxml-match declr
572       ((ident ,name)
573        (list name))
574       ((init-declr ,item)
575        (unwrap-declr item))
576       ((comp-declr ,item)
577        (unwrap-declr item))
578       ((ptr-declr (pointer . ,r) ,dir-declr)
579        (cons '(pointer-to) (unwrap-declr dir-declr)))
580       ((array-of ,dir-declr ,size)
581        (cons `(array-of ,(cnvt-array-size size)) (unwrap-declr dir-declr)))
582       ((ftn-declr ,dir-declr ,params)
583        (cons '(function-returning) (unwrap-declr dir-declr)))
584       ((scope ,expr)
585        (unwrap-declr expr))
586       (,otherwise
587        (simple-format #t "unwrap-declr: OTHERWISE\n") (pretty-print otherwise)
588        ;; failed got: (array-of (ident "foo")) FROM const char foo[];
589        #f)))
590
591   (define (find-type-spec decl-spec-list)
592     (let iter ((tsl (cdr decl-spec-list)))
593       (if (eqv? 'type-spec (caar tsl)) (car tsl)
594           (iter (cdr tsl))))) 
595   
596   (let* ((decl-dict (if (pair? rest) (car rest) '()))
597          (specl (sx-ref decl 1))
598          (declr (sx-ref decl 2))
599          (comm (sx-ref decl 3))
600          (m-specl (unwrap-specl specl))
601          (m-declr (unwrap-declr declr))
602          (m-decl (reverse (cons m-specl m-declr))))
603     m-decl))
604
605 ;; @deffn {Procedure} udecl->mspec/comm decl [dict] [#:def-comm ""]
606 ;; Convert declaration tree to an mspec
607 ;; @example
608 ;; (decl ... (comment "state vector")
609 ;; =>
610 ;; ("x" "state vector" (array-of 10) (float "double")
611 ;; @end example
612 ;; @end deffn
613 (define* (udecl->mspec/comm decl #:optional (dict '()) #:key (def-comm ""))
614   (let* ((comm (or (and=> (sx-ref decl 3) cadr) def-comm))
615          (spec (udecl->mspec decl dict)))
616     (cons* (car spec) comm (cdr spec))))
617
618 ;; @deffn {Procedure} fix-fields flds => flds
619 ;; This will take a list of fields from a struct and remove lone comments.
620 ;; If a field following a lone comment has no code-comment, the lone comment
621 ;; will be used.  For example,
622 ;; @example
623 ;;   /* foo */
624 ;;   int x;
625 ;; @end example
626 ;; @noindent
627 ;; will be treated as if it was denereed
628 ;; @example
629 ;;   int x; /* foo */
630 ;; @end example
631 ;; @noindent
632 ;; @end deffn
633 (define (fix-fields flds)
634   (let iter ((rz '()) (cl '()) (fl flds))
635     ;;(pretty-print fl)
636     (cond
637      ((null? fl) (reverse rz))
638      ((eqv? 'comment (caar fl))
639       (iter rz (cons (cadar fl) cl) (cdr fl)))
640      ((eqv? 'comp-decl (caar fl))
641       (if (eq? 4 (length (car fl)))
642           (iter (cons (car fl) rz) '() (cdr fl))         ; has comment
643           (let* ((cs (apply string-append (reverse cl))) ; add comment
644                  (fd (append (car fl) (list (list 'comment cs)))))
645             (iter (cons fd rz) '() (cdr fl)))))
646      (else
647       (error "bad field")))))
648
649 ;; --- last line ---