diff options
Diffstat (limited to 'guile/header.scm')
| -rw-r--r-- | guile/header.scm | 440 |
1 files changed, 440 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) + ) + |