diff options
author | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
---|---|---|
committer | Norbert Preining <norbert@preining.info> | 2019-09-02 13:46:59 +0900 |
commit | e0c6872cf40896c7be36b11dcc744620f10adf1d (patch) | |
tree | 60335e10d2f4354b0674ec22d7b53f0f8abee672 /support/schemetex/st.t |
Initial commit
Diffstat (limited to 'support/schemetex/st.t')
-rw-r--r-- | support/schemetex/st.t | 233 |
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))))) |