;codeset.ss
;SLaTeX Version 2.4
;Displays the typeset code made by SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1995

(module SLaTeX.)

(local display-tex-line display-scm-line do-token
  output-token data-token?)

(define display-tex-line
  (lambda (line)
    (cond;;((and (flush-comment-line? line)
      ;;          (char=? (of line =char / 1) #\%))
      ;;     (display "\\ZZZZschemecodebreak" *out*)
      ;;     (newline *out*))
      (else
        (let loop ((i (if (flush-comment-line? line) 1 0)))
          (let ((c (of line =char / i)))
            (if (char=? c #\newline)
                (if (eq? (of line =tab / i) &void-tab) 'skip
                  (newline *out*))
                (begin (display c *out*) (loop (+ i 1))))))))))

(define display-scm-line
  (lambda (line)
    (let loop ((i 0))
      (let ((c (of line =char / i)))
	(cond ((char=? c #\newline)
	       (let ((tab (of line =tab / i)))
		 (cond ((eq? tab &tabbed-crg-ret)
			(display "\\\\" *out*)
			(newline *out*))
		       ((eq? tab &plain-crg-ret) (newline *out*))
		       ((eq? tab &void-tab)
			(display #\% *out*)
			(newline *out*)))))
	      ((eq? (of line =notab / i) &begin-comment)
	       (display-tab (of line =tab / i) *out*)
	       (display c *out*)
	       (loop (+ i 1)))
	      ((eq? (of line =notab / i) &mid-comment)
	       (display c *out*)
	       (loop (+ i 1)))
	      ((eq? (of line =notab / i) &begin-string)
	       (display-tab (of line =tab / i) *out*)
	       (display "\\dt{" *out*)
	       (if (char=? c #\space)
		   (display-space (of line =space / i) *out*)
		   (display-tex-char c *out*))
	       (loop (+ i 1)))
	      ((eq? (of line =notab / i) &mid-string)
	       (if (char=? c #\space)
		   (display-space (of line =space / i) *out*)
		   (display-tex-char c *out*))
	       (loop (+ i 1)))
	      ((eq? (of line =notab / i) &end-string)
	       (if (char=? c #\space)
		   (display-space (of line =space / i) *out*)
		   (display-tex-char c *out*))
	       (display "}" *out*)
	       (if *in-qtd-tkn* (set! *in-qtd-tkn* #f)
	           (if *in-mac-tkn* (set! *in-mac-tkn* #f)))
	       (loop (+ i 1)))
	      ((eq? (of line =notab / i) &begin-math)
	       (display-tab (of line =tab / i) *out*)
	       (display c *out*)
	       (loop (+ i 1)))
	      ((eq? (of line =notab / i) &mid-math)
	       (display c *out*)
	       (loop (+ i 1)))
	      ((eq? (of line =notab / i) &end-math)
	       (display c *out*)
	       (if *in-qtd-tkn* (set! *in-qtd-tkn* #f)
 	           (if *in-mac-tkn* (set! *in-mac-tkn* #f)))
	       (loop (+ i 1)))
;	      ((memq (of line =notab / i) (list &mid-math &end-math))
;	       (display c *out*)
;	       (loop (+ i 1)))
	      ((char=? c #\space)
	       (display-tab (of line =tab / i) *out*)
	       (display-space (of line =space / i) *out*)
	       (loop (+ i 1)))
	      ((char=? c #\')
	       (display-tab (of line =tab / i) *out*)
	       (display c *out*)
	       (if (or *in-qtd-tkn* (> *in-bktd-qtd-exp* 0)) 'skip
		 (set! *in-qtd-tkn* #t))
	       (loop (+ i 1)))
	      ((char=? c #\`)
	       (display-tab (of line =tab / i) *out*)
	       (display c *out*)
	       (if (or (null? *bq-stack*)
		     (of (car *bq-stack*) =in-comma))
		   (set! *bq-stack*
		     (cons (let ((f (make-bq-frame)))
			     (setf (of f =in-comma) #f)
			     (setf (of f =in-bq-tkn) #t)
			     (setf (of f =in-bktd-bq-exp) 0)
			     f)
		       *bq-stack*)))
	       (loop (+ i 1)))
	      ((char=? c #\,)
	       (display-tab (of line =tab / i) *out*)
	       (display c *out*)
	       (if (or (null? *bq-stack*)
		     (of (car *bq-stack*) =in-comma)) 'skip
		     (set! *bq-stack*
		       (cons (let ((f (make-bq-frame)))
			       (setf (of f =in-comma) #t)
			       (setf (of f =in-bq-tkn) #t)
			       (setf (of f =in-bktd-bq-exp) 0)
			       f)
			 *bq-stack*)))
	       (if (char=? (of line =char / (+ i 1)) #\@)
		   (begin (display-tex-char #\@ *out*) (loop (+ 2 i)))
		   (loop (+ i 1))))
	      ((memv c '(#\( #\[))
	       (display-tab (of line =tab / i) *out*)
	       (display c *out*)
	       (cond (*in-qtd-tkn* (set! *in-qtd-tkn* #f)
		       (set! *in-bktd-qtd-exp* 1))
		     ((> *in-bktd-qtd-exp* 0)
		      (set! *in-bktd-qtd-exp* (+ *in-bktd-qtd-exp* 1))))
	       (cond (*in-mac-tkn* (set! *in-mac-tkn* #f)
		       (set! *in-bktd-mac-exp* 1))
		     ((> *in-bktd-mac-exp* 0) ;is this possible?
		      (set! *in-bktd-mac-exp* (+ *in-bktd-mac-exp* 1))))
	       (if (null? *bq-stack*) 'skip
		 (let ((top (car *bq-stack*)))
		   (cond ((of top =in-bq-tkn)
			  (setf (of top =in-bq-tkn) #f)
			  (setf (of top =in-bktd-bq-exp) 1))
			 ((> (of top =in-bktd-bq-exp) 0)
			  (setf (of top =in-bktd-bq-exp)
			    (+ (of top =in-bktd-bq-exp) 1))))))
	       (if (null? *case-stack*) 'skip
		 (let ((top (car *case-stack*)))
		   (cond ((of top =in-ctag-tkn)
			  (setf (of top =in-ctag-tkn) #f)
			  (setf (of top =in-bktd-ctag-exp) 1))
			 ((> (of top =in-bktd-ctag-exp) 0)
			  (setf (of top =in-bktd-ctag-exp)
			    (+ (of top =in-bktd-ctag-exp) 1)))
			 ((> (of top =in-case-exp) 0)
			  (setf (of top =in-case-exp)
			    (+ (of top =in-case-exp) 1))
			  (if (= (of top =in-case-exp) 2)
			      (set! *in-qtd-tkn* #t))))))
	       (loop (+ i 1)))
	      ((memv c '(#\) #\]))
	       (display-tab (of line =tab / i) *out*)
	       (display c *out*)
	       (if (> *in-bktd-qtd-exp* 0)
		   (set! *in-bktd-qtd-exp* (- *in-bktd-qtd-exp* 1)))
	       (if (> *in-bktd-mac-exp* 0)
		   (set! *in-bktd-mac-exp* (- *in-bktd-mac-exp* 1)))
	       (if (null? *bq-stack*) 'skip
		 (let ((top (car *bq-stack*)))
		   (if (> (of top =in-bktd-bq-exp) 0)
		       (begin
			 (setf (of top =in-bktd-bq-exp)
			   (- (of top =in-bktd-bq-exp) 1))
			 (if (= (of top =in-bktd-bq-exp) 0)
			     (set! *bq-stack* (cdr *bq-stack*)))))))
	       (let loop ()
		 (if (null? *case-stack*) 'skip
		   (let ((top (car *case-stack*)))
		     (cond ((> (of top =in-bktd-ctag-exp) 0)
			    (setf (of top =in-bktd-ctag-exp)
			      (- (of top =in-bktd-ctag-exp) 1))
			    (if (= (of top =in-bktd-ctag-exp) 0)
				(setf (of top =in-case-exp) 1)))
			   ((> (of top =in-case-exp) 0)
			    (setf (of top =in-case-exp)
			      (- (of top =in-case-exp) 1))
			    (if (= (of top =in-case-exp) 0)
				(begin
				  (set! *case-stack* (cdr *case-stack*))
				  (loop))))))))
	       (loop (+ i 1)))
	      (else (display-tab (of line =tab / i) *out*)
		    (loop (do-token line i))))))))

(define do-token
  (let ((token-delims (list #\( #\) #\[ #\] #\space *return*
			#\newline #\, #\;)))
    (lambda (line i)
      (let loop ((buf '()) (i i))
	(let ((c (of line =char / i)))
	  (cond ((char=? c #\\ )
		 (loop (cons (of line =char / (+ i 1)) (cons c buf))
		       (+ i 2)))
		((or (memv c token-delims)
		     (memv c *math-triggerers*))
		 (output-token (list->string (reverse! buf)))
		 i)
		((char? c) (loop (cons (of line =char / i) buf) (+ i 1)))
		(else (error 'do-token 1))))))))

(define output-token
  (lambda (token)
    (if (null? *case-stack*) 'skip
      (let ((top (car *case-stack*)))
	(if (of top =in-ctag-tkn)
	    (begin
	     (setf (of top =in-ctag-tkn) #f)
	     (setf (of top =in-case-exp) 1)))))
    (if (assoc-token token special-symbols)
        (begin
          (if *in-qtd-tkn* (set! *in-qtd-tkn* #f)
              (if *in-mac-tkn* (set! *in-mac-tkn* #f)))
          (display (cdr (assoc-token token special-symbols)) *out*))
	(display-token token
	  (cond (*in-qtd-tkn* (set! *in-qtd-tkn* #f)
		  (cond ((equal? token "else") 'syntax)
		  	((data-token? token) 'data)
		  	(else 'constant)))
		((data-token? token) 'data)
		((> *in-bktd-qtd-exp* 0) 'constant)
		((and (not (null? *bq-stack*))
		      (not (of (car *bq-stack*) =in-comma))) 'constant)
		(*in-mac-tkn* (set! *in-mac-tkn* #f)
                  (set-keyword token) 'syntax)
		((> *in-bktd-mac-exp* 0) (set-keyword token) 'syntax)
		((member-token token constant-tokens) 'constant)
		((member-token token variable-tokens) 'variable)
		((member-token token keyword-tokens)
		 (cond ((token=? token "quote") (set! *in-qtd-tkn* #t))
		       ((member-token token macro-definers)
			(set! *in-mac-tkn* #t))
		       ((member-token token case-and-ilk)
			(set! *case-stack*
			  (cons (let ((f (make-case-frame)))
				  (setf (of f =in-ctag-tkn) #t)
				  (setf (of f =in-bktd-ctag-exp) 0)
				  (setf (of f =in-case-exp) 0)
				  f)
			    *case-stack*))))
		 'syntax)
		(else 'variable))
	  *out*))
    (if (and (not (null? *bq-stack*)) (of (car *bq-stack*) =in-bq-tkn))
      (set! *bq-stack* (cdr *bq-stack*)))))

(define data-token?
  (lambda (token)
    ;token cannot be empty string!
    (or (char=? (string-ref token 0) #\#)
	(string->number token))))