summaryrefslogtreecommitdiff
path: root/support/schemetex/st.t
diff options
context:
space:
mode:
authorNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
committerNorbert Preining <norbert@preining.info>2019-09-02 13:46:59 +0900
commite0c6872cf40896c7be36b11dcc744620f10adf1d (patch)
tree60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/schemetex/st.t
Initial commit
Diffstat (limited to 'support/schemetex/st.t')
-rw-r--r--support/schemetex/st.t233
1 files changed, 233 insertions, 0 deletions
diff --git a/support/schemetex/st.t b/support/schemetex/st.t
new file mode 100644
index 0000000000..98ee6738a1
--- /dev/null
+++ b/support/schemetex/st.t
@@ -0,0 +1,233 @@
+(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)))))