;peephole.ss
;SLaTeX Version 2.3
;Peephole adjuster used by the SLaTeX typesetter
;(c) Dorai Sitaram, Rice U., 1991, 1994

(module SLaTeX.)

(local display-tex-line display-scm-line get-line
  peephole-adjust add-some-tabs remove-some-tabs
  clean-init-spaces clean-inner-spaces blank-line?
  flush-comment-line? do-all-lines)

(define get-line
  (let ((curr-notab &void-notab))
    (lambda (line)
      ;read the current tex line into "line";
      ;returns false on eof
      (let ((graphic-char-seen? #f))
	(let loop ((i 0))
	  (let ((c (read-char *in*)))
	    (cond (graphic-char-seen? 'already-seen)
		  ((or (eof-object? c)
		   (char=? c *return*)
		   (char=? c #\newline)
		   (char=? c #\space) (char=? c *tab*))
		   'not-yet)
		  (else (set! graphic-char-seen? #t)))
	    (cond
	      ((eof-object? c)
	       (cond ((eq? curr-notab &mid-string)
		      (if (> i 0)
			(setf (of line =notab / (- i 1)) &end-string)))
		     ((eq? curr-notab &mid-comment)
		      (set! curr-notab &void-notab))
		     ((eq? curr-notab &mid-math)
		      (error 'get-line 'runaway-math-subformula)))
	       (setf (of line =char / i) #\newline)
	       (setf (of line =space / i) &void-space)
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i) &void-notab)
	       (setf (of line =rtedge) i)
	       (if (eq? (of line =notab / 0) &mid-string)
		 (setf (of line =notab / 0) &begin-string))
	       (if (= i 0) #f #t))
	      ((or (char=? c *return*) (char=? c #\newline))
	       (if (and (eq? *op-sys* 'dos) (char=? c *return*))
    	 	   (if (char=? (peek-char *in*) #\newline)
		       (read-char *in*)))
	       (cond ((eq? curr-notab &mid-string)
		      (if (> i 0)
			(setf (of line =notab / (- i 1)) &end-string)))
		     ((eq? curr-notab &mid-comment)
		      (set! curr-notab &void-notab))
		     ((eq? curr-notab &mid-math)
		      (error 'get-line 'runaway-math-subformula)))
	       (setf (of line =char / i) #\newline)
	       (setf (of line =space / i) &void-space)
	       (setf (of line =tab / i)
		 (cond ((eof-object? (peek-char *in*)) &plain-crg-ret)
		       (*intext?* &plain-crg-ret)
		       (else &tabbed-crg-ret)))
	       (setf (of line =notab / i) &void-notab)
	       (setf (of line =rtedge) i)
	       (if (eq? (of line =notab / 0) &mid-string)
		 (setf (of line =notab / 0) &begin-string))
	       #t)
	      ((eq? curr-notab &mid-comment)
	       (setf (of line =char / i) c)
	       (setf (of line =space / i)
		 (cond ((char=? c #\space) &plain-space)
		       ((char=? c *tab*) &plain-space)
		       (else &void-space)))
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i) &mid-comment)
	       (loop (+ i 1)))
	      ((char=? c #\\)
	       (setf (of line =char / i) c)
	       (setf (of line =space / i) &void-space)
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i) curr-notab)
	       (let ((i+1 (+ i 1)) (c+1 (read-char *in*)))
		 (if (char=? c+1 *tab*) (set! c+1 #\space))
		 (setf (of line =char / i+1) c+1)
		 (setf (of line =space / i+1)
		   (if (char=? c+1 #\space) &plain-space
		     &void-space))
		 (setf (of line =tab / i+1) &void-tab)
		 (setf (of line =notab / i+1) curr-notab)
		 (loop (+ i+1 1))))
	      ((eq? curr-notab &mid-math)
	       (if (char=? c *tab*) (set! c #\space))
	       (setf (of line =space / i)
		 (if (char=? c #\space) &plain-space
		   &void-space))
	       (setf (of line =tab / i) &void-tab)
	       (cond ((memv c *math-triggerers*)
		      (setf (of line =char / i) #\$)
		      (setf (of line =notab / i) &end-math)
		      (setf curr-notab &void-notab))
		     (else (setf (of line =char / i) c)
			   (setf (of line =notab / i) &mid-math)))
	       (loop (+ i 1)))
	      ((eq? curr-notab &mid-string)
	       (if (char=? c *tab*) (set! c #\space))
	       ;or should tab and space be treated differently?
	       (setf (of line =char / i) c)
	       (setf (of line =space / i)
		 (if (char=? c #\space) &inner-space &void-space))
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i)
		 (cond ((char=? c #\")
			(set! curr-notab &void-notab)
			&end-string)
		       (else &mid-string)))
	       (loop (+ i 1)))
	      ;henceforth curr-notab is &void-notab
	      ((char=? c #\space)
	       (setf (of line =char / i) c)
	       (setf (of line =space / i)
		 (cond (*intext?* &plain-space)
		       (graphic-char-seen? &inner-space)
		       (else &init-space)))
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i) &void-notab)
	       (loop (+ i 1)))
	      ((char=? c *tab*)
	       (let loop2 ((i i) (j 0))
		 (if (< j 8)
                  (begin
		   (setf (of line =char / i) #\space)
		   (setf (of line =space / i)
		     (cond (*intext?* &plain-space)
			   (graphic-char-seen? &inner-space)
			   (else &init-space)))
		   (setf (of line =tab / i) &void-tab)
		   (setf (of line =notab / i) &void-notab)
		   (loop2 (+ i 1) (+ j 1)))))
	       (loop (+ i 8)))
	      ((char=? c #\")
	       (setf (of line =char / i) c)
	       (setf (of line =space / i) &void-space)
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i) &begin-string)
	       (set! curr-notab &mid-string)
	       (loop (+ i 1)))
	      ((char=? c #\;)
	       (setf (of line =char / i) c)
	       (setf (of line =space / i) &void-space)
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i) &begin-comment)
	       (set! curr-notab &mid-comment)
	       (loop (+ i 1)))
	      ((memv c *math-triggerers*)
	       (setf (of line =char / i) #\$)
	       (setf (of line =space / i) &void-space)
	       (setf (of line =tab / i) &void-tab)
	       (setf (of line =notab / i) &begin-math)
	       (set! curr-notab &mid-math)
	       (loop (+ i 1)))
	      (else (setf (of line =char / i) c)
		    (setf (of line =space / i) &void-space)
		    (setf (of line =tab / i) &void-tab)
		    (setf (of line =notab / i) &void-notab)
		    (loop (+ i 1))))))))))

(define peephole-adjust
  (lambda (curr prev)
    ;adjust the tabbing information on the current line curr and
    ;its previous line prev relative to each other
    (if (or (blank-line? curr) (flush-comment-line? curr))
	(if *latex-paragraph-mode?* 'skip
          (begin
	   (set! *latex-paragraph-mode?* #t)
	   (if *intext?* 'skip
	     (begin
	      (remove-some-tabs prev 0)
	      (let ((prev-rtedge (of prev =rtedge)))
	        (if (eq? (of prev =tab / prev-rtedge) &tabbed-crg-ret)
		    (setf (of prev =tab / (of prev =rtedge))
			  &plain-crg-ret)))))))
	(begin
	  (if *latex-paragraph-mode?*
	      (set! *latex-paragraph-mode?* #f)
	      (if *intext?* 'skip
		(let ((remove-tabs-from #f))
		  (let loop ((i 0))
		    (cond
		      ((char=? (of curr =char / i) #\newline)
		       (set! remove-tabs-from i))
		      ((char=? (of prev =char / i) #\newline)
		       (set! remove-tabs-from #f))
		      ((eq? (of curr =space / i) &init-space)
		       ;eating initial space of curr
		       (if (eq? (of prev =notab / i) &void-notab)
			(begin
			 (cond
			   ((or (char=? (of prev =char / i) #\()
				(eq? (of prev =space / i) &paren-space))
			    (setf (of curr =space / i) &paren-space))
			   ((or (char=? (of prev =char / i) #\[)
				(eq? (of prev =space / i) &bracket-space))
			    (setf (of curr =space / i) &bracket-space))
			   ((or (memv (of prev =char / i) '(#\' #\` #\,))
				(eq? (of prev =space / i) &quote-space))
			    (setf (of curr =space / i) &quote-space)))
			 (if (memq (of prev =tab / i)
				     (list &set-tab &move-tab))
			   (setf (of curr =tab / i) &move-tab))))
		       (loop (+ i 1)))
		      ;finished tackling &init-spaces of curr
		      ((= i 0) ;curr starts left-flush
		       (set! remove-tabs-from 0))
		      ;at this stage, curr[notab,i]
		      ;is either #f or a &begin-comment/string
		      ((not (eq? (of prev =tab / i) &void-tab))
		       ;curr starts with nice alignment with prev
		       (set! remove-tabs-from (+ i 1))
		       (if (memq (of prev =tab / i)
				   (list &set-tab &move-tab))
			 (setf (of curr =tab / i) &move-tab)))
		      ((memq (of prev =space / i)
			     (list &init-space &init-plain-space
			       &paren-space &bracket-space &quote-space))
		       ;curr starts while prev is still empty
		       (set! remove-tabs-from (+ i 1)))
		      ((and (char=? (of prev =char / (- i 1)) #\space)
			    (eq? (of prev =notab / (- i 1)) &void-notab))
		       ;curr can induce new alignment straightaway
		       (set! remove-tabs-from (+ i 1))
		       (setf (of prev =tab / i) &set-tab)
		       (setf (of curr =tab / i) &move-tab))
		      (else ;curr stakes its &move-tab (modulo parens/bkts)
			;and induces prev to have corresp &set-tab
			(set! remove-tabs-from (+ i 1))
			(let loop1 ((j (- i 1)))
			  (cond ((<= j 0) 'exit-loop1)
				((not (eq? (of curr =tab / j) &void-tab))
				 'exit-loop1)
				((memq (of curr =space / j)
				       (list &paren-space &bracket-space
					 &quote-space))
				 (loop1 (- j 1)))
				((or (not (eq? (of prev =notab / j)
					       &void-notab))
				     (char=? (of prev =char / j) #\space))
				 (let ((k (+ j 1)))
				   (if (memq (of prev =notab / k)
						 (list &mid-comment
						   &mid-math &end-math
						   &mid-string &end-string))
				       'skip
			            (begin
				     (if (eq? (of prev =tab / k) &void-tab)
				       (setf (of prev =tab / k) &set-tab))
				     (setf (of curr =tab / k) &move-tab)))))
				(else 'anything-else?)
				)))))
		  (remove-some-tabs prev remove-tabs-from))))
	  (if *intext?* 'skip (add-some-tabs curr))
	  (clean-init-spaces curr)
	  (clean-inner-spaces curr)))))

(define add-some-tabs
  (lambda (line)
    ;add some tabs in the body of line "line" so the next line
    ;can exploit them
    (let loop ((i 1) (succ-parens? #f))
      (let ((c (of line =char / i)))
	(cond ((char=? c #\newline) 'exit-loop)
	      ((not (eq? (of line =notab / i) &void-notab))
	       (loop (+ i 1) #f))
	      ((char=? c #\[)
	       (if (eq? (of line =tab / i) &void-tab)
		 (setf (of line =tab / i) &set-tab))
	       (loop (+ i 1) #f))
	      ((char=? c #\()
	       (if (eq? (of line =tab / i) &void-tab)
		 (if succ-parens? 'skip
		   (setf (of line =tab / i) &set-tab)))
	       (loop (+ i 1) #t))
	      (else (loop (+ i 1) #f)))))))

(define remove-some-tabs
  (lambda (line i)
    ;remove useless tabs on line "line" after index i
    (if i
      (let loop ((i i))
	(cond ((char=? (of line =char / i) #\newline) 'exit)
	      ((eq? (of line =tab / i) &set-tab)
	       (setf (of line =tab / i) &void-tab)
	       (loop (+ i 1)))
	      (else (loop (+ i 1))))))))

(define clean-init-spaces
  (lambda (line)
    ;remove init-spaces on line "line" because
    ;tabs make them defunct
    (let loop ((i (of line =rtedge)))
      (cond ((< i 0) 'exit-loop)
	    ((eq? (of line =tab / i) &move-tab)
	     (let loop2 ((i (- i 1)))
	       (cond ((< i 0) 'exit-loop2)
		     ((memq (of line =space / i)
			    (list &init-space &paren-space &bracket-space
			      &quote-space))
		      (setf (of line =space / i) &init-plain-space)
		      (loop2 (- i 1)))
		     (else (loop2 (- i 1))))))
	    (else (loop (- i 1)))))))

(define clean-inner-spaces
  (lambda (line)
    ;remove single inner spaces in line "line" since
    ;paragraph mode takes care of them
    (let loop ((i 0) (succ-inner-spaces? #f))
      (cond ((char=? (of line =char / i) #\newline) 'exit-loop)
	    ((eq? (of line =space / i) &inner-space)
	     (if succ-inner-spaces? 'skip
	       (setf (of line =space / i) &plain-space))
	     (loop (+ i 1) #t))
	    (else (loop (+ i 1) #f))))))

(define blank-line?
  (lambda (line)
    ;check if line "line" is blank
    (let loop ((i 0))
      (let ((c (of line =char / i)))
	(cond ((char=? c #\space)
	       (if (eq? (of line =notab / i) &void-notab)
		   (loop (+ i 1)) #f))
	      ((char=? c #\newline)
	       (let loop2 ((j (- i 1)))
		 (if (<= j 0) 'skip
		   (begin
		    (setf (of line =space / i) &void-space)
		    (loop2 (- j 1)))))
	       #t)
	      (else #f))))))

(define flush-comment-line?
  (lambda (line)
    ;check if line "line" is one with ; in the leftmost column
    (and (char=? (of line =char / 0) #\;)
	 (eq? (of line =notab / 0) &begin-comment)
	 (not (char=? (of line =char / 1) #\;)))))

(define do-all-lines
  (lambda ()
    ;process all lines, adjusting each adjacent pair
    (let loop ((line1 *line1*) (line2 *line2*))
      (let* ((line2-paragraph? *latex-paragraph-mode?*)
	     (more? (get-line line1)))
	;
	(peephole-adjust line1 line2)
	;
	(funcall (if line2-paragraph?
		     display-tex-line display-scm-line) line2)
	;
	(if (eq? line2-paragraph? *latex-paragraph-mode?*) 'else
	  (funcall (if *latex-paragraph-mode?* display-end-sequence
		     display-begin-sequence) *out*))
	;
	(if more? (loop line2 line1))))))

;scheme2tex is the "interface" procedure supplied by this file --
;it takes Scheme code from inport and produces LaTeX source for same
;in outport

(define scheme2tex
  (lambda (inport outport)
    ;create a typeset version of scheme code from inport
    ;in outport;
    ;local setting of keywords, etc.?
    (set! *in* inport)
    (set! *out* outport)
    (set! *latex-paragraph-mode?* #t)
    (set! *in-qtd-tkn* #f)
    (set! *in-bktd-qtd-exp* 0)
    (set! *in-mac-tkn* #f)
    (set! *in-bktd-mac-exp* 0)
    (set! *case-stack* '())
    (set! *bq-stack* '())
    (let ((flush-line  ;needed anywhere else?
	    (lambda (line)
	      (setf (of line =rtedge) 0)
	      (setf (of line =char / 0) #\newline)
	      (setf (of line =space / 0) &void-space)
	      (setf (of line =tab / 0) &void-tab)
	      (setf (of line =notab / 0) &void-notab))))
      (funcall flush-line *line1*)
      (funcall flush-line *line2*))
    (do-all-lines)))