(herald st)				; @(#)st.t	1.3 88/06/30
;;; SchemeTeX --- Simple support for literate programming in Scheme.
;;; February 1988, John D. Ramsdell.
;;;
;;; Copyright 1988 by The MITRE Corporation.
;;; Permission to use, copy, modify, and distribute this
;;; software and its documentation for any purpose and without
;;; fee is hereby granted, provided that the above copyright
;;; notice appear in all copies.  The MITRE Corporation
;;; makes no representations about the suitability of this
;;; software for any purpose.  It is provided "as is" without
;;; express or implied warranty.
;;;
;;; SchemeTeX
;;; defines a new source file format in which source lines are divided
;;; into text and code.  Lines of code start with a line beginning with
;;; '(', and continue until the line that contains the matching ')'.  The
;;; text lines remain, and they are treated as comments.  When producing
;;; a document, both the text lines and the code lines are copied into
;;; the document source file, but the code lines are surrounded by a pair
;;; of formatting commands.  The formatting commands are in begin-code
;;; and end-code.  SchemeTeX is currently set up for use with LaTeX.
;;;
;;; Exports: load-st, compile-st, and TeX-st.
;;; (load-st filespec optional-load-env)      Loads Scheme TeX source.
;;; (compile-st filespec)                     Compiles Scheme TeX source.
;;; (tex-st filespec)                         Makes LaTeX input.

(define st-extension 'st)
(define src-extension 't)
(define tex-extension 'tex)

(define (load-st filespec . options)
  (let ((t-filename (tangle filespec)))
    (and t-filename
	 (apply load t-filename options))))

(define (compile-st filespec)
  (let ((t-filename (tangle filespec)))
    (and t-filename
	 (compile-file t-filename))))

(define (tex-st st-filespec)
  (let* ((st-filename (st-filespec->st-filename st-filespec))
	 (tex-filename (st-filename->filename st-filename tex-extension)))
    (with-open-streams ((st-port (open st-filename '(in)))
			(tex-port (open tex-filename '(out))))
		       (if (weave-port st-port tex-port)
			   'done
			   'failed))))

(define (tangle st-filespec)		; => t-filename or false.
  (let* ((st-filename (st-filespec->st-filename st-filespec))
	 (t-filename (st-filename->filename st-filename src-extension)))
    (if (and (file-exists? t-filename)
	     (file-newer? t-filename st-filename))
	t-filename			; No need to tangle.
	(with-open-streams ((st-port (open st-filename '(in)))
			    (t-port (open t-filename '(out))))
			   (and (tangle-port st-port t-port)
				t-filename)))))

(define (st-filespec->st-filename st-filespec)
  (->filename
   (cond ((symbol? st-filespec)
	  (list '() st-filespec st-extension))
	 ((and (pair? st-filespec)
	       (= (length st-filespec) 2))
	  (append st-filespec (list st-extension)))
	 (else st-filespec))))
  
(define (st-filename->filename st-filename default-type)
  (make-filename
   (filename-fs st-filename)
   (filename-dir st-filename)
   (filename-name st-filename)
   (if (eq? default-type (filename-type st-filename))
       '()
       default-type)
   ;;broken?  (filename-generation st-filename)
   ))

(define (tangle-port st-port t-port)	; => false on failure.
  (labels
      (((tex-mode-and-saw-newline)
	(let ((ch (read-char st-port)))
	  (cond ((eof? ch) '#t)
		((char= ch #\left-paren)
		 (unread-char st-port)
		 (t-mode))
		((char= ch #\newline)
		 (tex-mode-and-saw-newline))
		(else (tex-mode-within-a-line)))))
       ((tex-mode-within-a-line)
	(if (eof? (read-line st-port))
	    '#t
	    (tex-mode-and-saw-newline)))
       ((t-mode)			; This routine should return
	(print (read-refusing-eof st-port) t-port)
	(newline t-port)		; #f when read-refusing-eof 
	(tex-mode-within-a-line)))	; obtains an error.
    (tex-mode-and-saw-newline)))

(define begin-code "\\begin{astyped}")
(define end-code "\\end{astyped}")
(define begin-comment "\\notastyped{")
	      
(define (weave-port st-port tex-port)
  (let ((spaces 0)			; Expansion of tabs into spaces.
	(hpos 0))			; Used in get-char and get-line.
    (catch leave			; Exit with leave when EOF is found.
      (labels				; All input is read with
	  (((get-char eof-value)	; get-char and get-line.
	    (if (fx> spaces 0)
		(block (set spaces (fx- spaces 1)) #\space)
		(let ((ch (read-char st-port)))
		  (cond ((eof? ch) (leave eof-value))
			((char= ch #\tab)
			 (set spaces (fx- 8 (logand 7 hpos)))
			 (set hpos (fx+ hpos spaces))
			 (get-char eof-value))
			((char= ch #\newline)
			 (set hpos 0) ch)
			(else (set hpos (fx+ hpos 1)) ch)))))
	   ((get-line eof-value)
	    (set hpos 0)
	    (let ((ch (read-line st-port)))
	      (if (eof? ch)
		  (leave eof-value)
		  ch)))
	   ((tex-write-char ch)		; Write to TeX file
	    (if (or (char= ch #\\)	; escaping TeX's special
		    (char= ch #\{)	; characters.
		    (char= ch #\})
		    (char= ch #\$)
		    (char= ch #\&)
		    (char= ch #\#)
		    (char= ch #\^)
		    (char= ch #\_)
		    (char= ch #\%)
		    (char= ch #\~))
		(format tex-port "\\verb-~a-" ch)
		(write-char tex-port ch)))
	   ((tex-mode-and-saw-newline)	; State at which decision must
	    (let ((ch (get-char '#t)))	; be made if to go into T code
	      (if (char= ch #\left-paren) ; mode or stay in TeX mode.
		  (t-mode)
		  (block
		    (if (not (char= ch #\semicolon)) ; For those who want
			(write-char tex-port ch)) ; to use regular load.
		    (if (char= ch #\newline) 
			(tex-mode-and-saw-newline)
			(tex-mode-within-a-line))))))
	   ((tex-mode-within-a-line)	; Copy out TeX line.
	    (let ((line (get-line '#t)))
	      (write-line tex-port line)
	      (tex-mode-and-saw-newline)))
	   ((t-mode)			; Change from TeX mode 
	    (write-line tex-port begin-code) ; to T code mode.
	    (write-char tex-port #\()
	    (sexpr 1))
	   ((sexpr parens)		; parens is used to watch
	    (let ((ch (get-char '#f)))	; for the closing paren
	      (cond ((char= ch #\semicolon) ; used to detect the
		     (copy-comment '#f)	; end of T code mode.
		     (sexpr parens))
		    (else
		     (sexpr-write-char parens ch)))))
	   ((copy-comment eof-value)	; Handle comment.
	    (let ((line (get-line eof-value)))
	      (write-string tex-port begin-comment)
	      (write-char tex-port #\semicolon)
	      (write-string tex-port line)
	      (write-char tex-port #\})
	      (newline tex-port)))
	   ((sexpr-write-char parens ch)
	    (tex-write-char ch)
	    (cond ((char= ch #\left-paren)
		   (sexpr (fx+ parens 1)))
		  ((char= ch #\right-paren)
		   (if (fx= 1 parens)	; Done reading sexpr.
		       (t-mode-after-sexpr)
		       (sexpr (fx- parens 1))))
		  ((char= ch #\")
		   (copy-out-string parens))
		  ((char= ch #\#)	; Worrying about #\( and #\).
		   (maybe-char-syntax parens))
		  (else (sexpr parens))))
	   ((copy-out-string parens)
	    (let ((ch (get-char '#f)))
	      (tex-write-char ch)
	      (cond ((char= ch #\\)
		     (let ((ch (get-char '#f)))
		       (tex-write-char ch)
		       (copy-out-string parens)))
		    ((char= ch #\")
		     (sexpr parens))
		    (else (copy-out-string parens)))))
	   ((maybe-char-syntax parens)
	    (let ((ch (get-char '#f)))
	      (cond ((char= ch #\backslash)
		     (tex-write-char ch)
		     (let ((ch (get-char '#f)))
		       (tex-write-char ch)
		       (sexpr parens)))
		    (else
		     (unread-char st-port)
		     (sexpr parens)))))
	   ((t-mode-after-sexpr)
	    (let ((ch (get-char '#t)))
	      (cond ((char= ch #\semicolon)
		     (copy-comment '#t)
		     (t-mode-merge))
		    ((char= ch #\newline)
		     (newline tex-port)
		     (t-mode-merge))
		    ((char= ch #\space)
		     (tex-write-char ch)
		     (t-mode-after-sexpr))
		    (else
		     (read-error st-port "Bad text following code")))))
	   ((t-mode-merge)
	    (let ((ch (get-char '#t)))
	      (cond ((char= ch #\left-paren)
		     (write-char tex-port ch)
		     (sexpr 1))
		    (else
		     (write-line tex-port end-code)
		     (write-char tex-port ch)
		     (if (char= ch #\newline)
			 (tex-mode-and-saw-newline)
			 (tex-mode-within-a-line)))))))
	(tex-mode-and-saw-newline)))))