;;; SchemeTeX --- Simple support for literate programming in Scheme.

(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)))))