;;; log-cogen.scm - code generation for PIW log types.
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Copyright (C) 1998 UUNET Technologies, Inc.
;;;
;;; See the file "COPYING.PIW" for further information
;;; about the copyright status of this work.
;;;


(define-module (piw log-cogen)
  :use-module (piw log-formats)
  :use-module (cogen autogen)
  :use-module (data-structures ratlist)
  :use-module (data-structures string-fun)
  :use-module (unix file-utils))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Generating Code Related to Log Entries
;;;

(define record-specs (apply append (map cadr (record-type-sections))))

(define (log-cogen-generates)
  `(("logging.h"	,(lambda ()
			   (gen-log-structure-definitions record-specs)
			   (gen-binary-log-function-prototypes record-specs)))
    ("logging.c"	,(lambda ()
			   (display "#include \"hackerlab/piw/log.h\"\n")
			   (display "#include \"hackerlab/piw-malloc/logging.h\"\n")
			   (display "\n\n")
			   (for-each (lambda (x) (display* x #\nl)) record-generation-decls)
			   (display "\n\n")
			   (gen-binary-log-functions record-specs)))
    ("log-printing.h"	,(lambda ()
			   (gen-text-log-function-decls record-specs)
			   (display* "typedef void (*formatter_fn)();\n\n")
			   (display* "extern struct piw_formatter\n")
			   (display* "{\n");
			   (display* "  t_uchar * name;\n")
			   (display* "  formatter_fn fn;\n")
			   (display* "} piw_formatters[];\n\n")))
    ("log-printing.c"	,(lambda ()
			   (display "#include \"hackerlab/vu/vu.h\"\n")
			   (display "#include \"hackerlab/vu/vfdbuf.h\"\n")
			   (display "#include \"hackerlab/vu/printfmt.h\"\n")
			   (display "#include \"hackerlab/bugs/panic.h\"\n")
			   (display "#include \"hackerlab/piw-malloc/logging.h\"\n")
			   (display "#include \"hackerlab/piw-malloc/log-printing.h\"\n")
			   (display "\n\n")
			   (gen-text-log-formatter-structure record-specs)
			   (gen-text-log-printing-functions record-specs)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; The List of All Record Types
;;;

(define-public (all-record-types) (map (lambda (spec) (cons (car spec) (map cadr (cadr spec)))) record-specs))
  


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Structure Definitions
;;;
;;; For every log entry type, there is a corresponding structure
;;; type.   The structure type defines the format of a binary
;;; log entry.
;;;

;; gen-log-structure-definitions specs
;;
;; Given a list of record type specifications, generate 
;; structure definitions for those record types.
;;
(define (gen-log-structure-definitions specs)
  (for-each (lambda (s) (gen-log-structure-definition s "" #t)) specs))

;; gen-log-structure-definition spec indent comment?
;;
;; Generate one structure definition from "spec".
;; Preceed each line of output with "indent".
;; If "comment?" is not nil, include a comment that mentions the
;; name of the record type.
;;
(define (gen-log-structure-definition spec indent comment?)
  (display* indent "struct " (struct-name spec))
  (if comment?
      (begin
	(display* " /* record-type: " (record-type spec) " */")))
  (display "\n")
  (display* indent "{\n")
  (for-each (lambda (field)
	      (display* indent "  " (field-type field) " " (field-name field) ";\n"))
	    (fields spec))
  (display* indent "};\n\n"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Binary Log Functions
;;;
;;; For every record type, there is a C function that prints a 
;;; binary log entry of that type.  These Scheme functions generate
;;; those C functions from record type specifications.
;;;

(define (gen-binary-log-functions specs)
  (for-each gen-binary-log-function specs))

(define (gen-binary-log-function-prototypes specs)
  (for-each gen-binary-log-function-prototype specs))

(define (gen-binary-log-function spec)
  (display* "void\npiw_log_" (record-type spec) " ("
	    (apply string-append-with-separator
		   ", "
		   (apply append (map (lambda (field)
					 (if (field-expression field)
					     ()
					     (list (string-append (field-type field)
								  " "
								  (field-name field)))))
				       (fields spec))))
	    ")\n{\n")
  (display* "  struct " (struct-name spec) " data;\n")
  (display (apply string-append
		  (map (lambda (field)
			 (string-append "  data."
					(field-name field)
					" = "
					(let ((s (or (field-expression field) 
						     (field-name field))))
					  (if (string? s)
					      s
					      (->string s)))
					";\n"))
		       (fields spec))))
  (display* "  piw_log(\"" (record-type spec) "\", (void *)&data, sizeof (data));\n")
  (if (record-type-real-time? spec)
      (display* "  piw_flush_log ();\n"))
  (display "}\n\n"))

(define (gen-binary-log-function-prototype spec)
  (display* "extern void piw_log_" (record-type spec) " ("
	    (apply string-append-with-separator
		   ", "
		   (apply append (map (lambda (field)
					(if (field-expression field)
					    ()
					    (list (string-append (field-type field)
								 " "
								 (field-name field)))))
				      (fields spec))))
	    ");\n"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Text Log Functions
;;;
;;; For every record type, there is a C function that prints a 
;;; textual log entry given a structure from a binary log entry.
;;;
;;; These Scheme functions generate those C functions.
;;;

(define (gen-text-log-printing-functions specs)
  (for-each gen-text-log-printing-function specs))

(define (gen-text-log-printing-function spec)
  (display "void\n")
  (display* (text-log-function-name spec) " (int fd, struct " (struct-name spec) " * data)\n")
  (display* "{\n")
  (display* "  int errn;\n")
  (display* "  if (0 > printfmt (&errn, fd,\n")
  (display* "                    \"(" (c-id->scheme (record-type spec))
	    (apply string-append
		   (map (lambda (field)
			  (string-append
			   " "
			   (cond
			    ((string=? (field-type field) 'int)			"%d")
			    ((string=? (field-type field) "unsigned int")	"%u")
			    ((string=? (field-type field) "unsigned long")	"%lu")
			    ((string=? (field-type field) '"void *")		"%lu")
			    (#t (error 'unrecognized-field-type (field-type field))))))
			(fields spec)))
	    ")\\n\""
	    (if (fields spec)
		",\n"
		""))
  (display* (apply string-append-with-separator
		   ",\n"
		   (map (lambda (field)
			  (string-append "                    data->" (field-name field)))
			(fields spec)))
	    "))\n")
  (display* "    panic (\"I/O error while printing record\");\n")
  (if (record-type-real-time? spec)
      (begin
	(display* "  if (0 > vfdbuf_flush (&errn, fd))\n")
	(display* "    panic (\"I/O error flushing text-log buffer\");\n")))
  (display* "}\n\n"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Text Log Function Declarations and Formatter Table
;;;
;;; These functions generate:
;;;	1. A list of declarations of the functions that print
;;;	   text log entries.
;;;	2. A table mapping names of log record types to functions
;;;	   that print text log entries.
;;;

;; gen-text-log-function-decls specs
;;
;; Generate declarations for functions that print text log entries.
;; The declarations are generated as a CPP macro definition.
;;
(define (gen-text-log-function-decls specs)
  (for-each (lambda (spec)
	      (display* "struct " (struct-name spec) ";\n")
	      (display* "void " (text-log-function-name spec) "(int fd, struct " (struct-name spec) " *);\n"))
	    specs)
  (display "\n\n"))

;; gen-text-log-formatter-structure specs
;;
;; Generate a table of functions that print text log entries.
;;
(define (gen-text-log-formatter-structure specs)
  (display "struct piw_formatter piw_formatters[] = \n")
  (display "{\n")
  (for-each (lambda (spec)
	      (display* "  {\"" (record-type spec) "\", " (text-log-function-name spec) "},\n"))
	    specs)
  (display* "  { 0, 0 }\n")
  (display "};\n\n"))

(define (c-id->scheme n)
  (apply string-append-with-separator
	 "-"
	 (separate-fields-discarding-char #\_ n list)))

