libgtop/guile/make-header.scm

(define cpu-type '(("name" . "cpu")
		   ("label" . "CPU Usage")
		   ("fields" . (("unsigned long" ("total" "Total CPU Usage")
						 ("user") ("nice") ("sys") ("idle"))
				("const char" ("name"))
				)
			     )
		   )
  )

;; computes constant for struct field (eg. GLIBTOP_CPU_TOTAL)

(define field-name-constant
  (lambda (name field)
    (string "GLIBTOP_"
	    (string-upcase! (string name))
	    "_"
	    (string-upcase! (string field)))
    )
  )

;; computes structure name (eg. glibtop_cpu)

(define make-struct-name
  (lambda (type)
    (string "glibtop_" (assoc-ref type "name"))
    )
  )

(define tab-pad-string
  (lambda (string tabs)
    (string-append string (make-string (- (* tabs 8) (string-length string)) #\space))
    )
  )

(define make-field-list
  (lambda (name type fields)
    (let* ((output (string)) (pos 1))
      (map
       (lambda (x)
	 (let* ((sep   (if (= pos (length fields)) ";" ","))
		(start (if (= pos 1)
			   (string "\t"
				   (tab-pad-string (string type) 2))
			   (string "\t\t"))
		       )
		(comment (string (if (= pos 1) "" "\t") "/* "
				 (tab-pad-string (field-name-constant name (car x)) 3)
				 " */"))
		(field (tab-pad-string (string-append (string (car x)) sep) 2))
		)
	   (set! pos (+ pos 1))
	   (string-append start field comment "\n")
	   )
	 )
       fields)
      )
    )
  )

(define make-struct-body
  (lambda (type)
    (let* ((name   (assoc-ref type "name"))
	   (data   (assoc-ref type "fields"))
	   (output (string))
	   )
      (for-each
       (lambda (y)
	 (for-each
	  (lambda (z)
	    (set! output (string-append output z))
	    )
	  y)
	 )
       (map
	(lambda (x) (make-field-list name (car x) (cdr x)))
	data)
       )
      output)
    )
  )

(define make-struct
  (lambda (type)
    (let* ((name   (assoc-ref type "name"))
	   (data   (assoc-ref type "fields"))
	   (output (string-append
		    (tab-pad-string
		     (string "typedef struct _glibtop_" name)
		     5)
		    (string "glibtop_" name ";\n\n"
			    "struct glibtop_" name "\n{\n\t"
			    "unsigned long\tflags;\n")
		    )
		   )
	   )
      (string-append output (make-struct-body type) "};\n")
      )
    )
  )

(define make-field-name-list
  (lambda (type)
    (let* ((name   (assoc-ref type "name"))
	   (data   (assoc-ref type "fields"))
	   (return (list))
	   )
      (map
       (lambda (x)
	 (map
	  (lambda (y) (set! return (append return (list (car y)))))
	  (cdr x)
	  )
	 )
       data)
      return)
    )
  )

(define make-field-constants
  (lambda (type)
    (let* ((name   (assoc-ref type "name"))
	   (data   (make-field-name-list type))
	   (output (string
		    (tab-pad-string
		     (string "#define GLIBTOP_MAX_"
			     (string-upcase! (string name))
			     ) 5)
		    (number->string (length data))
		    "\n\n"
		    )
		   )
	   (pos 0)
	   )
      (for-each
       (lambda (x)
	 (set! output (string-append output (string
					     (tab-pad-string
					      (string "#define GLIBTOP_"
						      (string-upcase! (string name))
						      "_"
						      (string-upcase! (string x))
						      ) 5)
					     (number->string pos)
					     "\n"
					     )
				     )
	       )
	 (set! pos (+ pos 1))
	 )
       data)
      output)
    )
  )

(define make-extern-defs
  (lambda (type)
    (let* ((name   (assoc-ref type "name"))
	   )
      (string
       (tab-pad-string (string "extern void glibtop_get_" name) 6)
       "__P(glibtop *, glibtop_" name " *);\n\n"
       "#ifdef HAVE_GUILE\n\n"
       "/* You need to link with -lgtop_guile to get this stuff here. */\n\n"
       (tab-pad-string (string "extern SCM glibtop_get_" name) 6)
       "__P(void);\n\n"
       "#endif /* HAVE_GUILE */\n\n"
       "#ifdef GLIBTOP_GUILE_NAMES\n\n"
       "/* You need to link with -lgtop_guile_names to get this stuff here. */\n\n"
       (tab-pad-string (string "extern SCM glibtop_guile_names_" name) 6)
       "__P(void);\n"
       (tab-pad-string (string "extern SCM glibtop_guile_labels_" name) 6)
       "__P(void);\n"
       (tab-pad-string (string "extern SCM glibtop_guile_descriptions_" name) 6)
       "__P(void);\n\n"
       "#endif /* GLIBTOP_GUILE_NAMES */\n\n"
       "#ifdef GLIBTOP_NAMES\n\n"
       "/* You need to link with -lgtop_names to get this stuff here. */\n\n"
       (tab-pad-string (string "extern const char *glibtop_names_" name) 6)
       "[];\n"
       (tab-pad-string (string "extern const char *glibtop_labels_" name) 6)
       "[];\n"
       (tab-pad-string (string "extern const char *glibtop_descriptions_" name) 6)
       "[];\n\n"
       "#endif /* GLIBTOP_NAMES */\n\n")
      )
    )
  )

(begin
  (display (make-field-constants cpu-type)) (newline)
  (display (make-struct cpu-type)) (newline)
  (display (make-extern-defs cpu-type)) (newline)
  )