#! /usr/sqps/bin/sqpsi -f

(define (print-sgml the-sgml the-output-port)
  (let
   ((the-dtd (car the-sgml))
    (the-doc (cdr the-sgml)))
   
   ;;; predicates ;;;
   
   (define (is-element? thingy)
	   (and
	    (list? thingy)
	    (list? (car thingy))))
   
   (define (element-name element)
	   (caar element))
   
   (define (has-attributes? element)
	   (and
	    (is-element? element)
	    (> (length (car element)) 1)))
   
   (define (what-is-it thingy)
	   (cond
	    ((string? thingy) 'text)
	    ((list? thingy)
	     (cond
	      ((list? (car thingy)) 'element)
	      ((eq? (car thingy) 'entity) 'entity)
	      ((eq? (car thingy) 'whitespace) 'whitespace)
	      (else 'unknown-list)))
	    (else 'unknown)))
   
   ;;; output helpers ;;;
   
   (define (do-attributes the-element)
	   (if (has-attributes? the-element)
	       ;; then
	       (for-each
		(lambda (pair)
			(output-string
			 (format " ~a \"~a\"" (car pair) (cdr pair))))
		(cdar the-element))
	       ;; else
	       #f))
   
   ;; the main entry point:
   (define (do-element the-element)
	   ;; start tag
	   (begin
	    (output-string (format "<~a" (element-name the-element)))
	    (do-attributes the-element)
	    (output-string (format "~a>")))

	   ;; the contents
	   (do-content the-element)

	   ;; the end tag
	   (output-string (format "</~a>" (element-name the-element))))
   
   ;; the main workhorse routine:
   (define (do-content the-element)
	   (for-each
	    (lambda (item)
		    (flush the-output-port)
		    (case (what-is-it item)
			  ((element) (do-element item))
			  ((entity) (do-entity item))
			  ((text) (do-text item))
			  ((whitespace) #f)
			  (else
			   (begin
			    (output-string (format "\\\" ERROR ~a" item))
			    (end-of-line)))))
	    (cdr the-element)))
   
   ;; other output routines:
   (define (do-entity the-entity)
	   (output-string
	    (format "\\*[~a]" (cadr the-entity))))
   
   (define (do-text the-text)
	   (output-string the-text))
  
  ;;; low-level i/o
  (define (ends-in-newline? str)
	  (let ((the-chars (string->list str)))
	       (eq? (list-ref the-chars (- (length the-chars) 1)) #\newline)))
  
  (define at-start-of-line #t)
  
  (define (output-string string)
	  (display string the-output-port)
	  ;(set! at-start-of-line (ends-in-newline? string))
	  )
  
  (define (end-of-line)
	  (if at-start-of-line
	      ;; then do nothing
	      #f
	      ;; else output a newline
	      (output-string "\n")))
  
  (define (must-be-at-start-of-line)
	  (if at-start-of-line
	      ;; then do nothing
	      #f
	      ;; else output a newline
	      (output-string "\n")))
  
  ;;;;;;;;;;;;;;;;;;
  
  ;; the header
  (output-string "<!DOCTYPE File SYTSTEM \"doc.dtd\">")
  
  ;; the body -- only do the first document if there are multuiple ones.
  (do-element (car the-doc))
  
  ;; the trailer
  ;; (no trailer)
  ))

(display "1\n")
;(define the-sgml (read-sgml (current-input-port)))
(display "2\n")
;(print-sgml the-sgml (current-output-port))
