;texread.scm
;SLaTeX v. 2.3
;Various token-readers used on TeX files by SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994

(module SLaTeX.)

(local eat-till-newline read-ctrl-seq eat-tabspace
  eat-whitespace eat-tex-whitespace chop-off-whitespace
  read-grouped-latexexp read-filename read-schemeid
  read-delimed-commaed-filenames read-grouped-commaed-filenames
  read-bktd-commaed-filenames read-grouped-schemeids
  eat-delimed-text eat-bktd-text eat-grouped-text)

(define eat-till-newline
  (lambda (in)
    ;;skip all characters from port in till newline inclusive or eof
    (let loop ()
      (let ((c (read-char in)))
	(cond ((eof-object? c) 'done)
	      ((char=? c #\newline) 'done)
	      (else (loop)))))))

(define read-ctrl-seq
  (lambda (in)
    ;assuming we've just read a backslash, read the remaining
    ;part of a latex control sequence from port in
    (let ((c (read-char in)))
      (if (eof-object? c) (error 'read-ctrl-exp 1))
      (if (char-alphabetic? c)
	  (list->string
	    (reverse!
	      (let loop ((s (list c)))
		(let ((c (peek-char in)))
		  (cond ((eof-object? c) s)
			((char-alphabetic? c) (read-char in)
			 (loop (cons c s)))
			((char=? c #\%) (eat-till-newline in)
			 (loop s))
			(else s))))))
	  (string c)))))

(define eat-tabspace
  (lambda (in)
    ;;skip to the next non-space and non-tab character from port in
    (let loop ()
      (let ((c (peek-char in)))
	(cond ((eof-object? c) 'done)
	      ((or (char=? c #\space) (char=? c *tab*))
	       (read-char in) (loop))
	      (else 'done))))))

(define eat-whitespace
  (lambda (in)
    ;;skip to the next whitespace character from port in
    (let loop ()
      (let ((c (peek-char in)))
	(cond ((eof-object? c) 'done)
	      ((char-whitespace? c)
	       (read-char in) (loop))
	      (else 'done))))))

(define eat-tex-whitespace
  (lambda (in)
    ;;skip to the next whitespace character from port in;
    ;;skips past latex comments too
    (let loop ()
      (let ((c (peek-char in)))
	(cond ((eof-object? c) 'done)
	      ((char-whitespace? c) (read-char in) (loop))
	      ((char=? c #\%) (eat-till-newline in))
	      (else 'done))))))

(define chop-off-whitespace
  (lambda (l)
    ;removes leading whitespace from character-list l
    (ormapcdr (lambda (d) (if (char-whitespace? (car d)) #f d)) l)))

(define read-grouped-latexexp
  (lambda (in)
    ;;reads a latex grouped expression from port in
    ;;(removes the groups)
    (eat-tex-whitespace in)
    (let ((c (read-char in)))
      (if (eof-object? c) (error 'read-grouped-latexexp 1))
      (if (char=? c #\{) 'ok (error 'read-grouped-latexexp 2))
      (eat-tex-whitespace in)
      (list->string
	(reverse!
	  (chop-off-whitespace
	    (let loop ((s '()) (nesting 0) (escape? #f))
	      (let ((c (read-char in)))
		(if (eof-object? c) (error 'read-grouped-latexexp 3))
		(cond (escape? (loop (cons c s) nesting #f))
		      ((char=? c #\\)
		       (loop (cons c s) nesting #t))
		      ((char=? c #\%) (eat-till-newline in)
		       (loop s nesting #f))
		      ((char=? c #\{)
		       (loop (cons c s) (+ nesting 1) #f))
		      ((char=? c #\})
		       (if (= nesting 0) s
			 (loop (cons c s) (- nesting 1) #f)))
		      (else
			(loop (cons c s) nesting #f)))))))))))

(define read-filename
  (let ((filename-delims (list #\{ #\} #\[ #\] #\( #\) #\# #\% #\\ #\,
			   #\space *return* #\newline *tab* #\\)))
    (lambda (in)
      ;;reads a filename as allowed in latex syntax from port in
      (eat-tex-whitespace in)
      (let ((c (peek-char in)))
	(if (eof-object? c) (error 'read-filename 1))
	(if (char=? c #\{) (read-grouped-latexexp in)
	  (list->string
	    (reverse!
	      (let loop ((s '()) (escape? #f))
		(let ((c (peek-char in)))
		  (cond ((eof-object? c)
			 (if escape? (error 'read-filename 2) s))
			(escape? (read-char in)
			  (loop (cons c s) #f))
			((char=? c #\\) (read-char in)
			 (loop (cons c s) #t))
			((memv c filename-delims) s)
			(else (read-char in)
			       (loop (cons c s) #f))))))))))))

(define read-schemeid
  (let ((schemeid-delims (list #\{ #\} #\[ #\] #\( #\)
			   #\space *return* #\newline *tab*)))
    (lambda (in)
      ;reads a scheme identifier from port in
      (eat-whitespace in)
      (list->string
	(reverse!
	  (let loop ((s '()) (escape? #f))
	    (let ((c (peek-char in)))
	      (cond ((eof-object? c) s)
		    (escape? (read-char in) (loop (cons c s) #f))
		    ((char=? c #\\) (read-char in)
		     (loop (cons c s) #t))
		    ((memv c schemeid-delims) s)
		    (else (read-char in) (loop (cons c s) #f))))))))))

(define read-delimed-commaed-filenames
  (lambda (in lft-delim rt-delim)
    ;reads a filename from port in, assuming it's delimited by
    ;lft- and rt-delims
    (eat-tex-whitespace in)
    (let ((c (read-char in)))
      (if (eof-object? c) (error 'read-delimed-commaed-filenames 1))
      (if (char=? c lft-delim) 'ok
	  (error 'read-delimed-commaed-filenames 2))
      (let loop ((s '()))
	(eat-tex-whitespace in)
	(let ((c (peek-char in)))
	  (if (eof-object? c) (error 'read-delimed-commaed-filenames 3))
	  (if (char=? c rt-delim)
	      (begin (read-char in) (reverse! s))
	      (let ((s (cons (read-filename in) s)))
		(eat-tex-whitespace in)
		(let ((c (peek-char in)))
		  (if (eof-object? c)
		    (error 'read-delimed-commaed-filenames 4))
		  (cond
		    ((char=? c #\,) (read-char in))
		    ((char=? c rt-delim) 'void)
		    (else (error 'read-delimed-commaed-filenames 5)))
		  (loop s)))))))))

(define read-grouped-commaed-filenames
  (lambda (in)
    ;read a filename from port in, assuming it's grouped
    (read-delimed-commaed-filenames in #\{ #\})))

(define read-bktd-commaed-filenames
  (lambda (in)
    ;read a filename from port in, assuming it's bracketed
    (read-delimed-commaed-filenames in #\[ #\])))

(define read-grouped-schemeids
  (lambda (in)
    ;read a list of scheme identifiers from port in,
    ;assuming they're all grouped
    (eat-tex-whitespace in)
    (let ((c (read-char in)))
      (if (eof-object? c) (error 'read-grouped-schemeids 1))
      (if (char=? c #\{) 'ok (error 'read-grouped-schemeids 2))
      (let loop ((s '()))
	(eat-whitespace in)
	(let ((c (peek-char in)))
	  (if (eof-object? c) (error 'read-grouped-schemeids 3))
	  (if (char=? c #\})
	      (begin (read-char in) (reverse! s))
	      (loop (cons (read-schemeid in) s))))))))

(define eat-delimed-text
  (lambda (in lft-delim rt-delim)
    (eat-tex-whitespace in)
    (let ((c (peek-char in)))
      (if (eof-object? c) 'exit
          (if (char=? c lft-delim)
              (let loop ()
                (let ((c (read-char in)))
                  (if (eof-object? c) 'exit
                      (if (char=? c rt-delim) 'exit
                          (loop))))))))))

(define eat-bktd-text
  (lambda (in)
    (eat-delimed-text in #\[ #\])))

(define eat-grouped-text
  (lambda (in)
    (eat-delimed-text in #\{ #\})))

;(trace read-filename)