diff options
Diffstat (limited to 'guile')
| -rw-r--r-- | guile/header.scm | 440 | ||||
| -rw-r--r-- | guile/make-header.scm | 195 |
2 files changed, 635 insertions, 0 deletions
diff --git a/guile/header.scm b/guile/header.scm new file mode 100644 index 00000000..d3fa5ece --- /dev/null +++ b/guile/header.scm @@ -0,0 +1,440 @@ +;; $Id$ + +(define cpu-type '(("name" . "cpu") + ("label" . "CPU Usage") + ("fields" . (list + (("name" . "total") + ("label" . "Total CPU Usage") + ("type" . "unsigned long")) + (("name" . "user") + ("type" . "unsigned long")) + (("name" . "nice") + ("type" . "unsigned long")) + (("name" . "sys") + ("type" . "unsigned long")) + (("name" . "idle") + ("type" . "unsigned long")) + (("name" . "name") + ("type" . "const char") + ("pointer" . #t)) + (("name" . "test")) + ) + ) + ) + ) + +(define main-function + (lambda (definition) + (letrec ((default-type "unsigned long") + (struct-label-comments #t) + (struct-name-comments #f) + (default-name-tabs-first 3) + (default-name-tabs 4) + (default-type-tabs 2) + (default-comment-tabs 5) + (default-definition-tabs 3) + (default-definition-value-tabs 2) + (default-max-line-length 60) + ;; set default values for unspecified fields + (check-field-definition + (lambda (fields) + (let ((newlist (list))) + (for-each + (lambda (field) + (if (not (assoc-ref field "type")) + (set! field (assoc-set! field "type" default-type))) + (if (assoc-ref field "label") + (set! field (assoc-set! field "has-label" #t)) + (begin + (set! field (assoc-set! field "label" (assoc-ref field "name"))) + (set! field (assoc-set! field "has-label" #f)) + ) + ) + (set! newlist (append newlist (list field))) + ) + (cdr fields)) + (set-cdr! fields newlist) + ) + ) + ) + ;; number fields sequentially + (make-field-numbers + (lambda (fields) + (let ((pos 0) (newlist (list))) + (for-each + (lambda (field) + (set! field (assoc-set! field "number" pos)) + (set! newlist (append newlist (list field))) + (set! pos (+ pos 1)) + ) + (cdr fields)) + (set-cdr! fields newlist) + (set! definition (assoc-set! definition "max-fields" pos)) + ) + ) + ) + ;; pad string with up to 'tabs' tabs + (tabify-string + (lambda (string tabs) + (let ((length (string-length string)) + (tlength (* tabs 8))) + (if (> tlength length) + (let* ((diff (- tlength length)) + (count (quotient (+ diff 7) 8))) + (string-append string + (make-string count #\tab)) + ) + (string-append string + #\space) + ) + ) + ) + ) + ;; pad string with spaces + (spacify-string + (lambda (string tabs) + (let ((length (string-length string)) + (tlength (* tabs 8))) + (if (> tlength length) + (string-append string + (make-string (- tlength length) #\space)) + (string-append string + #\space) + ) + ) + ) + ) + ;; creates comment string + (make-comment-string + (lambda (comment) + (if comment + (string "/* " + (spacify-string comment + default-comment-tabs) + " */") + (string) + ) + ) + ) + ;; create constant for entry (eg. GLIBTOP_CPU_TOTAL) + (entry-constant-name + (lambda (name) + (string-upcase! (string "GLIBTOP_" + (assoc-ref definition "name") + "_" + name + ) + ) + ) + ) + ;; create text that is displayed as comment along with entry + (entry-comment-text + (lambda (name label) + (if label + (if struct-label-comments label #f) + (if struct-name-comments (entry-constant-name name) #f) + ) + ) + ) + ;; starts struct definition + (make-struct-definition-head + (lambda () + (let* ((class (assoc-ref definition "name")) + ) + (string "struct _glibtop_" class "\n" + "{\n" + ) + ) + ) + ) + ;; terminates struct definition + (make-struct-definition-tail + (lambda () + (string "};\n\n") + ) + ) + ;; generate struct definition body + (make-struct-definition-body + (lambda (fields) + (letrec ((output (string)) + (is-first-entry #t) + (current-type #f) + (current-name #f) + (current-label #f) + (current-pointer #f) + ;; close entry (other = next entry is of other type) + (entry-end + (lambda (other) + (let ((old-first is-first-entry)) + (set! is-first-entry other) + (if current-type + (string (tabify-string (string (string (if current-pointer "*" "")) + current-name + (string (if other ";" ",")) + ) + (if old-first + default-name-tabs-first + default-name-tabs + ) + ) + (make-comment-string (entry-comment-text + current-name current-label)) + "\n") + (string) + ) + ) + ) + ) + ;; start new entry + (entry-start + (lambda (name type) + (if current-type + (if (equal? current-type type) + (string (entry-end #f) "\t\t") + (string (entry-end #t) "\t" + (tabify-string type default-type-tabs) + ) + ) + (string "\t" + (tabify-string type default-type-tabs) + ) + ) + ) + ) + ) + ;; main function + (for-each + (lambda (field) + (let ((name (assoc-ref field "name")) + (type (assoc-ref field "type")) + (pointer (assoc-ref field "pointer")) + (label (if (assoc-ref field "has-label") + (assoc-ref field "label") + #f) + ) + ) + (set! output (string-append output + (string (entry-start name type)) + ) + ) + ;; save current data + (set! current-type type) + (set! current-name name) + (set! current-label label) + (set! current-pointer pointer) + ) + ) + (cdr fields)) + ;; close last entry + (string-append output (entry-end #t)) + ) + ) + ) + ;; display complete struct definition + (make-struct-definition + (lambda (fields) + (string-append (make-struct-definition-head) + (make-struct-definition-body fields) + (make-struct-definition-tail) + ) + ) + ) + ;; make constant definition + (make-const-definition + (lambda (name value comment) + (let* ((nstring (string-upcase! (string "GLIBTOP_" name))) + (tabname (tabify-string nstring default-definition-tabs)) + (tabvalue (if comment + (tabify-string (string value) default-definition-value-tabs) + (string value)) + ) + (ctext (make-comment-string comment)) + (line (string "#define " tabname tabvalue ctext "\n")) + ) + line) + ) + ) + ;; creates constant definitions + (make-struct-constants + (lambda (fields) + (let ((class (assoc-ref definition "name")) + (output (string)) + ) + (for-each + (lambda (field) + (let* ((name (assoc-ref field "name")) + (number (assoc-ref field "number")) + (key (string class "_" name)) + (value (number->string number)) + (label (if (assoc-ref field "has-label") + (assoc-ref field "label") + #f) + ) + (line (make-const-definition key + value + (entry-comment-text name label) + ) + ) + ) + (set! output (string-append output line)) + ) + ) + (cdr fields)) + output) + ) + ) + ;; creates definition of maximum constant + (make-struct-max-constant + (lambda () + (let* ((class (assoc-ref definition "name")) + (max (assoc-ref definition "max-fields")) + ) + (make-const-definition (string "MAX_" class) + (number->string max) + #f) + ) + ) + ) + ;; adds new list element to string, inserting newline if necessary + (add-to-string + (lambda (output line element separator indent max-length) + (let* ((slen (string-length line)) + (elen (string-length element)) + (tlen (+ slen elen)) + (bsep (if separator + (string separator " ") + (string) + ) + ) + (nsep (string (if separator separator "") "\n")) + ) + (if (and (> slen 0) (> tlen max-length)) + (begin + (set! output (string-append output line nsep)) + (set! line (string indent element)) + ) + (set! line (string-append line bsep element)) + ) + (list output line) + ) + ) + ) + ;; create general list definition + (make-general-list-definition + (lambda (fields name symbol line-length make-element-string) + (letrec ((class (assoc-ref definition "name")) + (make-general-list-definition-head + (lambda () + (string "const char *" + "glibtop_" + symbol + "_" + class + " " + "[GLIBTOP_MAX_" + (string-upcase! (string class)) + "] = \n{ " + ) + ) + ) + (make-general-list-definition-tail + (lambda () + (string "\n};\n") + ) + ) + (make-general-list-definition-body + (lambda () + (let* ((first #t) (output (string)) (line (string))) + (for-each + (lambda (field) + (let* ((element (assoc-ref field name)) + (olist (add-to-string output line + (make-element-string element) + (if first #f ",") + " " + line-length)) + ) + (set! output (car olist)) + (set! line (car (cdr olist))) + (set! first #f) + ) + ) + (cdr fields)) + (set! output (string-append output line)) + output) + ) + ) + ) + ;; main function + (string-append (make-general-list-definition-head) + (make-general-list-definition-body) + (make-general-list-definition-tail) + ) + ) + ) + ) + ;; create name list definition + (make-name-list-definition + (lambda (fields) + (make-general-list-definition fields + "name" + "names" + default-max-line-length + (lambda (x) + (string #\" x #\") + ) + ) + ) + ) + ;; create label list definition + (make-label-list-definition + (lambda (fields) + (make-general-list-definition fields + "label" + "labels" + 0 + (lambda (x) + (string "gettext_noop (" #\" x #\" ")") + ) + ) + ) + ) + ;; create description list definition + (make-description-list-definition + (lambda (fields) + (make-general-list-definition fields + "description" + "descriptions" + default-max-line-length + (lambda (x) + (if x + (string "gettext_noop (" #\" x #\" ")") + (string "NULL") + ) + ) + ) + ) + ) + ) + ;; start of main function + (let ((fielddef (assoc-ref definition "fields"))) + (display fielddef) (newline) (newline) + (check-field-definition fielddef) + (make-field-numbers fielddef) + (display fielddef) (newline) (newline) + (display (make-struct-definition fielddef)) + (display (make-struct-constants fielddef)) (newline) + (display (make-struct-max-constant)) (newline) (newline) + (display (make-name-list-definition fielddef)) (newline) + (display (make-label-list-definition fielddef)) (newline) + (display (make-description-list-definition fielddef)) (newline) + ) + ) + ) + ) + +(begin + (main-function cpu-type) + (newline) + ) + diff --git a/guile/make-header.scm b/guile/make-header.scm new file mode 100644 index 00000000..ec51216b --- /dev/null +++ b/guile/make-header.scm @@ -0,0 +1,195 @@ +(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) + ) + |