1167 lines
45 KiB
Scheme
1167 lines
45 KiB
Scheme
|
#! /usr/bin/scheme --program
|
||
|
|
|
||
|
|
;;; scheme-prep.ss
|
||
|
|
;;;
|
||
|
|
;;; Copyright (c) 1998-2016 R. Kent Dybvig and Oscar Waddell
|
||
|
|
;;;
|
||
|
|
;;; Permission is hereby granted, free of charge, to any person obtaining a
|
||
|
|
;;; copy of this software and associated documentation files (the "Software"),
|
||
|
|
;;; to deal in the Software without restriction, including without limitation
|
||
|
|
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
|
||
|
|
;;; and/or sell copies of the Software, and to permit persons to whom the
|
||
|
|
;;; Software is furnished to do so, subject to the following conditions:
|
||
|
|
;;;
|
||
|
|
;;; The above copyright notice and this permission notice shall be included in
|
||
|
|
;;; all copies or substantial portions of the Software.
|
||
|
|
;;;
|
||
|
|
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
|
||
|
|
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
|
||
|
|
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
|
||
|
|
;;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
|
||
|
|
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
||
|
|
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
|
||
|
|
;;; DEALINGS IN THE SOFTWARE.
|
||
|
|
|
||
|
|
;;; primitive commands
|
||
|
|
|
||
|
|
;;; \genlab
|
||
|
|
;;; \generated ... \endgenerated ; inject and process string returned by enclosed Scheme code
|
||
|
|
;;; \hindex
|
||
|
|
;;; \index
|
||
|
|
;;; \raw
|
||
|
|
;;; \scheme
|
||
|
|
;;; \schemeinit ... \endschemeinit
|
||
|
|
;;; \schemedisplay ... \endschemedisplay
|
||
|
|
;;; \schemedisplay[number-lines] ... \endschemedisplay ; insert line numbers
|
||
|
|
;;; \schemeverbatim ... \endschemeverbatim
|
||
|
|
;;; \schlbrace
|
||
|
|
;;; \schrbrace
|
||
|
|
;;; \transcript ... \endtranscript
|
||
|
|
;;; \transcript[endtranscript] ... \endtranscript
|
||
|
|
;;; \var
|
||
|
|
;;; \xdef
|
||
|
|
;;; \xedef
|
||
|
|
|
||
|
|
;;; \schemeoutput[mode]{filename} ; divert schemedisplay code to file
|
||
|
|
;;; \schemeoutput{} ; closes the open scheme output file
|
||
|
|
|
||
|
|
;;; commands inserted into the output
|
||
|
|
|
||
|
|
;;; \$, \&, \%, \#, \\
|
||
|
|
;;; \dots
|
||
|
|
;;; \endschemedisplay
|
||
|
|
;;; \hindex
|
||
|
|
;;; \is
|
||
|
|
;;; \label
|
||
|
|
;;; \null
|
||
|
|
;;; \schemeindent
|
||
|
|
;;; \scheme
|
||
|
|
;;; \schemeblankline
|
||
|
|
;;; \schemedisplay
|
||
|
|
;;; \schemelinestart ; relies on defn of \schemeindent=
|
||
|
|
;;; \schatsign
|
||
|
|
;;; \schbackslash
|
||
|
|
;;; \schcarat
|
||
|
|
;;; \schdot
|
||
|
|
;;; \schlbrace
|
||
|
|
;;; \schrbrace
|
||
|
|
;;; \schtilde
|
||
|
|
;;; \schunderscore
|
||
|
|
;;; \si
|
||
|
|
;;; The transerr, etc. commands require an empty argument so that
|
||
|
|
;;; we can put them in a \raw{} in the schemedisplay we generate for
|
||
|
|
;;; the transcript and still keep both htmlprep and latex happy with
|
||
|
|
;;; the result. html-prep would also accept {\transin}, but latex
|
||
|
|
;;; was not happy with that.
|
||
|
|
;;; \transerr{} ... \endtranserr{} ; transcript error msg typesetting
|
||
|
|
;;; \transin{} ... \endtransin{} ; transcript user input typesetting
|
||
|
|
;;; \transout{} ... \endtransout{} ; transcript program output typesetting
|
||
|
|
;;; \var
|
||
|
|
;;; \vdots
|
||
|
|
;;; any undefined input command
|
||
|
|
;;; anything else inserted by \raw
|
||
|
|
|
||
|
|
;;; Valid within \scheme{...}
|
||
|
|
;;; \dots
|
||
|
|
;;; \raw{<text>}
|
||
|
|
;;; \var{<text>}
|
||
|
|
;;; \var{<text>_<subscript>}
|
||
|
|
;;; \
|
||
|
|
;;; all other characters besides } and newline
|
||
|
|
|
||
|
|
;;; Valid within \schemedisplay ... \endschemedisplay
|
||
|
|
;;; \dots
|
||
|
|
;;; \raw{<text>}
|
||
|
|
;;; \var{<text>}
|
||
|
|
;;; \var{<text>_<subscript>}
|
||
|
|
;;; \vdots
|
||
|
|
;;; \
|
||
|
|
;;; all other characters besides }
|
||
|
|
;;; \label{text} may appear immediately after \schemedisplay
|
||
|
|
|
||
|
|
;;; index and hindex entries follow makeindex 2.13 syntax except that
|
||
|
|
;;; the special characters !, @, |, ", and \ are freely allowed within
|
||
|
|
;;; embeded {, } pairs in the "actual entry" portion of a level (the
|
||
|
|
;;; portion following @, if any). a modified version of makeindex 2.13
|
||
|
|
;;; that supports this extension (with the -d [allow delimited special
|
||
|
|
;;; chars] flag) is available here as well.
|
||
|
|
;;;
|
||
|
|
;;; in \index input, we also allow \scheme{...} to appear, with embedded
|
||
|
|
;;; special characters.
|
||
|
|
|
||
|
|
;;; \index syntax
|
||
|
|
;;; \index{levels}
|
||
|
|
;;; \index{levels|pageformat}
|
||
|
|
;;; levels --> level
|
||
|
|
;;; --> level!levels
|
||
|
|
;;; level --> keyentry (key and entry same)
|
||
|
|
;;; level --> key@entry (separate key and entry)
|
||
|
|
;;;
|
||
|
|
;;; Valid within keyentry
|
||
|
|
;;; \scheme{...}
|
||
|
|
|
||
|
|
;;; If multiple filenames are supplied on the command line, each file is
|
||
|
|
;;; processed in the same runtime image. Thus an \xdef in an earlier file
|
||
|
|
;;; persists through the processing of subsequent files.
|
||
|
|
|
||
|
|
#!chezscheme
|
||
|
|
(import (except (chezscheme) open-input-file) (dsm) (preplib) (script))
|
||
|
|
|
||
|
|
(define use-interaction-window (make-parameter #f))
|
||
|
|
(define interaction-window-width (make-parameter 28))
|
||
|
|
|
||
|
|
(define copy-through-newline
|
||
|
|
(lambda (ip op)
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\newline) (write-char c op)]
|
||
|
|
[(eof) (void)]
|
||
|
|
[else (write-char c op) (copy-through-newline ip op)])))
|
||
|
|
|
||
|
|
(define dovar
|
||
|
|
(lambda (ip op)
|
||
|
|
(read-open-brace ip)
|
||
|
|
(display "\\var{" op)
|
||
|
|
(let f ()
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\}) (write-char c op)]
|
||
|
|
[(#\') (display "$'$" op) (f)]
|
||
|
|
[(#\_)
|
||
|
|
(display "$_" op)
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(eof) (input-error "unexpected eof in \\var{}")]
|
||
|
|
[(#\{) (fprintf op "{~a}" (read-bracketed-text ip 1))]
|
||
|
|
[else (write-char c op)])
|
||
|
|
(write-char #\$ op)
|
||
|
|
(f)]
|
||
|
|
[(eof) (input-error "unexpected eof in \\var{}")]
|
||
|
|
[else (write-char c op) (f)]))))
|
||
|
|
|
||
|
|
(define (sscheme ip op) ; within \scheme
|
||
|
|
; unlike schemedisplay, does not allow { or }. { and } must be expressed
|
||
|
|
; as \schlbrace and \schrbrace
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\{) (input-error "unexpected { within \\scheme{}")]
|
||
|
|
[(#\}) (void)]
|
||
|
|
[(#\\)
|
||
|
|
; use read-alpha-command instead of read-command to avoid
|
||
|
|
; improper handling of special characters that follow a slash,
|
||
|
|
; including }
|
||
|
|
(let ([cmd (read-alpha-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(dots)
|
||
|
|
(display "{\\dots}" op)
|
||
|
|
(sscheme ip op)]
|
||
|
|
[(raw)
|
||
|
|
(display (read-bracketed-text ip) op)
|
||
|
|
(sscheme ip op)]
|
||
|
|
[(var)
|
||
|
|
(dovar ip op)
|
||
|
|
(sscheme ip op)]
|
||
|
|
[(schlbrace)
|
||
|
|
(display "\\schlbrace" op)
|
||
|
|
(sscheme ip op)]
|
||
|
|
[(schrbrace)
|
||
|
|
(display "\\schrbrace" op)
|
||
|
|
(sscheme ip op)]
|
||
|
|
[else ; assume random \ possibly followed by alphabetic chars
|
||
|
|
(fprintf op "{\\schbackslash}~a" cmd)
|
||
|
|
(sscheme ip op)]))]
|
||
|
|
[(#\.) (display "{\\schdot}" op) (sscheme ip op)]
|
||
|
|
[(#\~) (display "{\\schtilde}" op) (sscheme ip op)]
|
||
|
|
[(#\^) (display "{\\schcarat}" op) (sscheme ip op)]
|
||
|
|
[(#\@) (display "{\\schatsign}" op) (sscheme ip op)]
|
||
|
|
[(#\_) (display "{\\schunderscore}" op) (sscheme ip op)]
|
||
|
|
[(#\space) (display "~" op) (sscheme ip op)]
|
||
|
|
[(#\$ #\& #\% #\#) (fprintf op "\\~c" c) (sscheme ip op)]
|
||
|
|
[(#\newline) (input-error "line ended within \\scheme{}")]
|
||
|
|
[(eof) (input-error "file ended within \\scheme{}")]
|
||
|
|
[else (write-char c op) (sscheme ip op)]))
|
||
|
|
|
||
|
|
(define sschemedisplay
|
||
|
|
(P lambda (number-lines? labels) ; within a schemedisplay
|
||
|
|
; number-lines?
|
||
|
|
; Flag is true if we want the lines numbered.
|
||
|
|
;
|
||
|
|
; labels
|
||
|
|
; A list of labels to be attached to this schemedisplay.
|
||
|
|
; We insert them after the first newline in the schemedisplay
|
||
|
|
; (or before the \endschemedisplay if no newline) so that the
|
||
|
|
; label is attached to something other than whitespace (this
|
||
|
|
; prevents labels from referring to the preceeding page when the
|
||
|
|
; start of a schemedisplay falls right on a page break).
|
||
|
|
(define print-line-start
|
||
|
|
(lambda (line op)
|
||
|
|
(if number-lines?
|
||
|
|
(fprintf op "\\schemelinestartnumbered{~s}~%" line)
|
||
|
|
(fprintf op "\\schemelinestart~%"))))
|
||
|
|
(fprintf op "\\schemelinestart~%")
|
||
|
|
(when sout (newline sout))
|
||
|
|
(let loop ([n? #f] [line 0] [labels labels])
|
||
|
|
; n? is true if we've just passed a new line within the display; we use
|
||
|
|
; it to determine whether to insert \\\schemelinestart. (We insert
|
||
|
|
; \schemelinestart after \\ to prevent \\ from sucking up ensuing
|
||
|
|
; whitespace---including spaces used for indentation on the following
|
||
|
|
; line.)
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\\)
|
||
|
|
; use read-alpha-command instead of read-alpha-command to avoid
|
||
|
|
; improper handling of special characters that follow a slash
|
||
|
|
(let ([cmd (read-alpha-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(endschemedisplay)
|
||
|
|
(unless (null? labels)
|
||
|
|
(for-each (lambda (l) (fprintf op "\\label{~a}" l)) labels))
|
||
|
|
(display "\\endschemedisplay" op)]
|
||
|
|
[else
|
||
|
|
(when n? (display "\\\\\n" op) (print-line-start line op))
|
||
|
|
(case cmd
|
||
|
|
[(dots)
|
||
|
|
(display "{\\dots}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(var)
|
||
|
|
(dovar ip op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(raw)
|
||
|
|
(fprintf op "~a" (read-bracketed-text ip))
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(vdots)
|
||
|
|
(display "{\\vdots}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[else ; assume random \ possibly followed by alphabetic chars
|
||
|
|
(fprintf op "{\\schbackslash}~a" cmd)
|
||
|
|
(when sout (fprintf sout "\\~a" cmd))
|
||
|
|
(loop #f line labels)])]))]
|
||
|
|
[else
|
||
|
|
(when n? (display "\\\\\n" op) (print-line-start line op))
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(state-case (c c)
|
||
|
|
[(#\;)
|
||
|
|
; convert ;=> into \is and ;== into \si
|
||
|
|
(state-case (c (peek-char ip))
|
||
|
|
[(#\=)
|
||
|
|
(read-char ip)
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(state-case (c (peek-char ip))
|
||
|
|
[(#\>)
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(read-char ip)
|
||
|
|
(display "\\is" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\=)
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(read-char ip)
|
||
|
|
(display "\\si" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[else
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(display ";=" op)
|
||
|
|
(loop #f line labels)])]
|
||
|
|
[(#\-) ; should abstract this
|
||
|
|
(read-char ip)
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(state-case (c (peek-char ip))
|
||
|
|
[(#\>)
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(read-char ip)
|
||
|
|
(display "\\becomes" op) ; would prefer something else here
|
||
|
|
(loop #f line labels)]
|
||
|
|
[else
|
||
|
|
(when sout (write-char c sout))
|
||
|
|
(display ";-" op)
|
||
|
|
(loop #f line labels)])]
|
||
|
|
[else
|
||
|
|
(write-char #\; op)
|
||
|
|
(loop #f line labels)])]
|
||
|
|
;; Convert space to ~ since \obeyspaces doesn't seem to work for us
|
||
|
|
;; when \schemedisplay appears within a macro (see f2002/quiz02.stex).
|
||
|
|
[(#\space) (display "~" op) (loop #f line labels)]
|
||
|
|
[(#\.)
|
||
|
|
(display "{\\schdot}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\~)
|
||
|
|
(display "{\\schtilde}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\^)
|
||
|
|
(display "{\\schcarat}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\@)
|
||
|
|
(display "{\\schatsign}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\_)
|
||
|
|
(display "{\\schunderscore}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\{)
|
||
|
|
(display "{\\schlbrace}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\})
|
||
|
|
(display "{\\schrbrace}" op)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\$ #\& #\% #\#)
|
||
|
|
(fprintf op "\\~c" c)
|
||
|
|
(loop #f line labels)]
|
||
|
|
[(#\newline)
|
||
|
|
(unless (null? labels)
|
||
|
|
(for-each (lambda (l) (fprintf op "\\label{~a}" l)) labels))
|
||
|
|
(state-case (c (peek-char ip))
|
||
|
|
[(#\newline)
|
||
|
|
(read-char ip)
|
||
|
|
(fprintf op "~%\\schemeblankline")
|
||
|
|
(print-line-start line op)
|
||
|
|
(when sout (newline sout))
|
||
|
|
(loop #f (fx+ line 2) '())]
|
||
|
|
[else
|
||
|
|
(loop #t (fx+ line 1) '())])]
|
||
|
|
[(eof) (errorf #f "file ended within schemedisplay")]
|
||
|
|
[else (write-char c op) (loop #f line labels)])]))))
|
||
|
|
|
||
|
|
(define (sindex ip op)
|
||
|
|
; 1. read entire contents of \index{} form, w/o intepreting \scheme{...}
|
||
|
|
; separate at !s into 1 or more levels plus page format
|
||
|
|
; after |, if present; separate levels at @ into sort key
|
||
|
|
; and text, if present
|
||
|
|
; 2. for each level,
|
||
|
|
; a. compute output sort key
|
||
|
|
; - if input sort key is given, use it
|
||
|
|
; - otherwise use stripped version of input text
|
||
|
|
; - insert quotes where needed
|
||
|
|
; b. preprocess input text to produce output text
|
||
|
|
; - expand \scheme{...}
|
||
|
|
; - insert quotes where needed
|
||
|
|
; 3. produce output
|
||
|
|
; a. print \index{
|
||
|
|
; b. for each level, if output text is same as output sort key,
|
||
|
|
; print <output text>.
|
||
|
|
; otherwise print <output text>@<output sort key>
|
||
|
|
; c. separate levels with !
|
||
|
|
; d. print |<page format> if present in input
|
||
|
|
; e. print }
|
||
|
|
(define strip-sort-key
|
||
|
|
; presently strips only \scheme{ and matching }
|
||
|
|
(let ([buf (open-output-string)])
|
||
|
|
(lambda (ip)
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\\)
|
||
|
|
(let ([cmd (read-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(scheme)
|
||
|
|
(read-open-brace ip)
|
||
|
|
(display (read-bracketed-text ip 1) buf)
|
||
|
|
(strip-sort-key ip)]
|
||
|
|
[else (unexpected-command cmd)]))]
|
||
|
|
[(eof) (get-output-string buf)]
|
||
|
|
[else (write-char c buf) (strip-sort-key ip)]))))
|
||
|
|
(call-with-values
|
||
|
|
(lambda () (parse-index ip #t))
|
||
|
|
(lambda (levels page-format)
|
||
|
|
(let ([keys (map (lambda (s) (insert-quotes (open-input-string s) #f))
|
||
|
|
(map (lambda (level)
|
||
|
|
(if (car level)
|
||
|
|
(car level)
|
||
|
|
; strip text to create sort key
|
||
|
|
(strip-sort-key
|
||
|
|
(open-input-string (cdr level)))))
|
||
|
|
levels))]
|
||
|
|
[texts (map (lambda (level)
|
||
|
|
(insert-quotes
|
||
|
|
(open-input-string
|
||
|
|
(expand-entry (open-input-string (cdr level))))
|
||
|
|
#f))
|
||
|
|
levels)])
|
||
|
|
(let f ([keys keys] [texts texts] [delim #\{])
|
||
|
|
(unless (null? keys)
|
||
|
|
(write-char delim op)
|
||
|
|
(let ([key (car keys)] [text (car texts)])
|
||
|
|
(if (string=? key text)
|
||
|
|
(display text op)
|
||
|
|
(fprintf op "~a@~a" key text)))
|
||
|
|
(f (cdr keys) (cdr texts) #\!)))
|
||
|
|
(unless (string=? page-format "") (fprintf op "|~a" page-format))
|
||
|
|
(write-char #\} op)))))
|
||
|
|
|
||
|
|
(define expand-entry
|
||
|
|
; expands \scheme{} forms
|
||
|
|
(let ([buf (open-output-string)])
|
||
|
|
(lambda (ip)
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\\)
|
||
|
|
(let ([cmd (read-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(scheme)
|
||
|
|
(read-open-brace ip)
|
||
|
|
(display "\\scheme{" buf)
|
||
|
|
(sscheme ip buf)
|
||
|
|
(write-char #\} buf)
|
||
|
|
(expand-entry ip)]
|
||
|
|
[else
|
||
|
|
(fprintf buf "\\~a" cmd)
|
||
|
|
(expand-entry ip)]))]
|
||
|
|
[(eof) (get-output-string buf)]
|
||
|
|
[else (write-char c buf) (expand-entry ip)]))))
|
||
|
|
|
||
|
|
(define insert-quotes
|
||
|
|
(let ([buf (open-output-string)])
|
||
|
|
; if proper-nesting? is true, the characters ", @, !, and | lose their
|
||
|
|
; special meaning within nested groups.
|
||
|
|
(lambda (ip proper-nesting?)
|
||
|
|
(let loop ()
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\" #\@ #\! #\|)
|
||
|
|
(write-char #\" buf)
|
||
|
|
(write-char c buf)
|
||
|
|
(loop)]
|
||
|
|
[(#\\)
|
||
|
|
(state-case (c (peek-char ip))
|
||
|
|
[(#\@ #\! #\|) (write-char #\" buf)]
|
||
|
|
[else (void)])
|
||
|
|
(write-char c buf)
|
||
|
|
(loop)]
|
||
|
|
[(#\{)
|
||
|
|
(if proper-nesting?
|
||
|
|
(fprintf buf "{~a}" (read-bracketed-text ip 1))
|
||
|
|
(write-char c buf))
|
||
|
|
(loop)]
|
||
|
|
[(eof) (get-output-string buf)]
|
||
|
|
[else (write-char c buf) (loop)])))))
|
||
|
|
|
||
|
|
(define-syntactic-monad P
|
||
|
|
ip ; current input port
|
||
|
|
op ; current output port
|
||
|
|
ips ; input port stack; does not include ip
|
||
|
|
ops ; output port stack; does not include op
|
||
|
|
ifiles ; stack of input files [(cons ip ips) w/o string ports]
|
||
|
|
eofconts ; stack of continuations to call on eof
|
||
|
|
sout ; output port for code within schemedisplay or #f
|
||
|
|
)
|
||
|
|
|
||
|
|
(define process-string
|
||
|
|
(P lambda (s k)
|
||
|
|
(P s0
|
||
|
|
([ip (open-input-string s)]
|
||
|
|
[ips (cons ip ips)]
|
||
|
|
[eofconts (cons (P lambda ()
|
||
|
|
(P k
|
||
|
|
([op (car ops)] [ops (cdr ops)])
|
||
|
|
(get-output-string op)))
|
||
|
|
eofconts)]
|
||
|
|
[op (open-output-string)]
|
||
|
|
[ops (cons op ops)]))))
|
||
|
|
|
||
|
|
(define s0
|
||
|
|
(P lambda ()
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\\)
|
||
|
|
(let ([cmd (read-command ip)])
|
||
|
|
(cond
|
||
|
|
[(get-def cmd '()) =>
|
||
|
|
(lambda (proc)
|
||
|
|
(unless (or (command-symbol? cmd)
|
||
|
|
(eq? cmd 'schemedisplay)
|
||
|
|
(eq? cmd 'schemeinit)
|
||
|
|
(eq? cmd 'transcript))
|
||
|
|
(suppress-white-space ip))
|
||
|
|
(P proc))]
|
||
|
|
[else (fprintf op "\\~a" cmd) (P s0)]))]
|
||
|
|
[(#\%)
|
||
|
|
(write-char #\% op)
|
||
|
|
(copy-through-newline ip op)
|
||
|
|
(P s0)]
|
||
|
|
[(eof)
|
||
|
|
(close-port ip)
|
||
|
|
(if (null? ips)
|
||
|
|
(when sout (close-port sout))
|
||
|
|
(P (car eofconts)
|
||
|
|
([ip (car ips)]
|
||
|
|
[ips (cdr ips)]
|
||
|
|
[ifiles (if (eq? ip (car ifiles)) (pop-ifile ifiles) ifiles)]
|
||
|
|
[eofconts (cdr eofconts)])))]
|
||
|
|
[else (write-char c op) (P s0)])))
|
||
|
|
|
||
|
|
;--------------------------------------------------------------------------
|
||
|
|
|
||
|
|
(define go
|
||
|
|
(lambda (fn)
|
||
|
|
(let ([ip (open-input-file (format "~a.stex" fn))])
|
||
|
|
(let ([op (open-output-file (format "~a.tex" fn) 'replace)])
|
||
|
|
(fprintf op "%%% DO NOT EDIT THIS FILE~%")
|
||
|
|
(fprintf op "%%% Edit the .stex version instead~%~%")
|
||
|
|
; preplib parameters
|
||
|
|
(parameterize ([current-ifile #f]
|
||
|
|
[genlab-prefix "s"]
|
||
|
|
[genlab-counters '()])
|
||
|
|
(P s0
|
||
|
|
([ip ip]
|
||
|
|
[op op]
|
||
|
|
[ips '()]
|
||
|
|
[ops '()]
|
||
|
|
[ifiles (push-ifile ip '())]
|
||
|
|
[eofconts (list s0)]
|
||
|
|
[sout #f]))
|
||
|
|
(close-port op))))))
|
||
|
|
|
||
|
|
(global-def genlab
|
||
|
|
(P lambda ()
|
||
|
|
(display (genlab) op)
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
(global-def hindex
|
||
|
|
(P lambda ()
|
||
|
|
(P process-string () (read-bracketed-text ip)
|
||
|
|
(P lambda (lab)
|
||
|
|
(fprintf op "\\hindex{~a}" lab)
|
||
|
|
(read-open-brace ip)
|
||
|
|
(sindex ip op)
|
||
|
|
(P s0)))))
|
||
|
|
|
||
|
|
(global-def index
|
||
|
|
(P lambda ()
|
||
|
|
(let ([lab (genlab)])
|
||
|
|
(fprintf op "\\label{~a}\\hindex{~a}" lab lab))
|
||
|
|
(read-open-brace ip)
|
||
|
|
(sindex ip op)
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
(global-def raw
|
||
|
|
(P lambda ()
|
||
|
|
(display (read-bracketed-text ip) op)
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
(global-def scheme
|
||
|
|
(P lambda ()
|
||
|
|
(read-open-brace ip)
|
||
|
|
(display "\\scheme{" op)
|
||
|
|
(sscheme ip op)
|
||
|
|
(write-char #\} op)
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
(global-def schemedisplay
|
||
|
|
(P lambda ()
|
||
|
|
(display "\\schemedisplay\n" op)
|
||
|
|
(let loop ([options '()] [labels '()])
|
||
|
|
; currently a bit sloppy on the grammar
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\\)
|
||
|
|
; use read-alpha-command instead of read-command to avoid
|
||
|
|
; improper handling of special characters that follow a slash
|
||
|
|
(let ([cmd (read-alpha-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(label)
|
||
|
|
(loop options (cons (read-bracketed-text ip) labels))]
|
||
|
|
[(raw)
|
||
|
|
(fprintf op "\\raw{~a}~%" (read-bracketed-text ip))
|
||
|
|
(loop options labels)]
|
||
|
|
[else
|
||
|
|
(input-error "invalid command \\~s following \\schemedisplay" cmd)]))]
|
||
|
|
[(#\newline)
|
||
|
|
(P sschemedisplay () (memq 'number-lines options) labels)]
|
||
|
|
[(#\[)
|
||
|
|
(unread-char c ip)
|
||
|
|
(let ([opt (read-optional-arg ip)])
|
||
|
|
(if (equal? opt "number-lines")
|
||
|
|
(loop (cons 'number-lines options) labels)
|
||
|
|
(input-error "unexpected optional argument ~a to \\schemedisplay" opt)))]
|
||
|
|
[else (input-error "expected newline after \\schemedisplay")]))
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
(global-def schemeoutput
|
||
|
|
(P lambda ()
|
||
|
|
(let* ([mode (if (equal? (read-optional-arg ip) "append") 'append 'replace)]
|
||
|
|
[filename (read-bracketed-text ip)])
|
||
|
|
(when sout (close-port sout))
|
||
|
|
(if (eq? filename "")
|
||
|
|
(P s0 ([sout #f]))
|
||
|
|
(P s0 ([sout (open-output-file filename mode)]))))))
|
||
|
|
|
||
|
|
(global-def var
|
||
|
|
(P lambda ()
|
||
|
|
(display "\\scheme{" op)
|
||
|
|
(dovar ip op)
|
||
|
|
(write-char #\} op)
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
(global-def def
|
||
|
|
(P lambda ()
|
||
|
|
(let* ([cmd (state-case (c (read-char ip))
|
||
|
|
[(#\\) (read-command ip)]
|
||
|
|
[else (input-error "invalid \\def syntax")])]
|
||
|
|
[pattern (read-def-pattern ip)]
|
||
|
|
[template (read-bracketed-text ip)])
|
||
|
|
(fprintf op "\\def\\~a" cmd)
|
||
|
|
(for-each
|
||
|
|
(lambda (x)
|
||
|
|
(cond
|
||
|
|
[(char? x) (write-char x op)]
|
||
|
|
[(number? x) (fprintf op "#~a" x)]
|
||
|
|
[else (errorf #f "unexpected parsed pattern element ~s" x)]))
|
||
|
|
pattern)
|
||
|
|
(fprintf op "{~a}" template)
|
||
|
|
(P s0))))
|
||
|
|
|
||
|
|
(global-def xdef
|
||
|
|
(P lambda ()
|
||
|
|
(let* ([cmd (state-case (c (read-char ip))
|
||
|
|
[(#\\) (read-command ip)]
|
||
|
|
[else (input-error "invalid \\xdef syntax")])]
|
||
|
|
[pattern (read-def-pattern ip)]
|
||
|
|
[template (read-bracketed-text ip)])
|
||
|
|
(set-def! cmd '() #f
|
||
|
|
(P lambda ()
|
||
|
|
(P s0
|
||
|
|
([ip (open-input-string
|
||
|
|
(expand-template template
|
||
|
|
(read-args ip pattern cmd) cmd))]
|
||
|
|
[ips (cons ip ips)]
|
||
|
|
[eofconts (cons s0 eofconts)]))))
|
||
|
|
(P s0))))
|
||
|
|
|
||
|
|
(global-def xedef
|
||
|
|
(P lambda ()
|
||
|
|
(let* ([cmd (state-case (c (read-char ip))
|
||
|
|
[(#\\) (read-command ip)]
|
||
|
|
[else (input-error "invalid \\xedef syntax")])]
|
||
|
|
[pattern (read-def-pattern ip)]
|
||
|
|
[template (read-bracketed-text ip)])
|
||
|
|
(P process-string () template
|
||
|
|
(P lambda (template)
|
||
|
|
(set-def! cmd '() #f
|
||
|
|
(P lambda ()
|
||
|
|
(P s0
|
||
|
|
([ip (open-input-string
|
||
|
|
(expand-template template
|
||
|
|
(read-args ip pattern cmd) cmd))]
|
||
|
|
[ips (cons ip ips)]
|
||
|
|
[eofconts (cons s0 eofconts)]))))
|
||
|
|
(P s0))))))
|
||
|
|
|
||
|
|
(global-def schemeverbatim
|
||
|
|
(P lambda ()
|
||
|
|
(display "\\begin{verbatim}\n" op)
|
||
|
|
(let f ()
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\\)
|
||
|
|
(let ([cmd (read-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(endschemeverbatim) (void)]
|
||
|
|
[else (write-char c op) (display cmd op) (f)]))]
|
||
|
|
[(eof) (unexpected-eof "after \\schemeverbatim")]
|
||
|
|
[else (write-char c op) (f)]))
|
||
|
|
(display "\\end{verbatim}\n" op)
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
(global-def timestamp
|
||
|
|
(P lambda ()
|
||
|
|
(display (date-and-time) op)
|
||
|
|
(P s0)))
|
||
|
|
|
||
|
|
;--------------------------------------------------------------------------
|
||
|
|
(let ()
|
||
|
|
|
||
|
|
(define-syntax define-enumeration
|
||
|
|
(lambda (x)
|
||
|
|
(define iota
|
||
|
|
(case-lambda
|
||
|
|
[(n) (iota 0 n)]
|
||
|
|
[(i n) (if (= i n) '() (cons i (iota (+ i 1) n)))]))
|
||
|
|
(syntax-case x ()
|
||
|
|
[(_ name (enum ...))
|
||
|
|
(and (identifier? #'name) (andmap identifier? #'(enum ...)))
|
||
|
|
(with-syntax ([len (length #'(enum ...))])
|
||
|
|
(with-syntax ([(i ...) (iota #'len)])
|
||
|
|
#'(begin (define enum i) ... (define name len))))])))
|
||
|
|
|
||
|
|
(define-record tag (markup entity))
|
||
|
|
|
||
|
|
(define make-tag-port
|
||
|
|
(lambda (ip)
|
||
|
|
; To preserve the indentation of Scheme expressions in the .stex source,
|
||
|
|
; we have to add the leading whitespace the user would have entered to
|
||
|
|
; compensate for the indentation---due to the prompt---of the first line.
|
||
|
|
; We compute the current indentation level when writing non-echo output.
|
||
|
|
; We indent subsequent input lines after we read the first line that
|
||
|
|
; follows some output.
|
||
|
|
(define-enumeration num-modes (writing reading indenting))
|
||
|
|
(define mode writing)
|
||
|
|
(define indent 0)
|
||
|
|
(define adjust-indent ; called by output routine
|
||
|
|
(lambda (x)
|
||
|
|
(define do-char
|
||
|
|
(lambda (c)
|
||
|
|
(set! indent (if (char=? c #\newline) 0 (fx+ indent 1)))))
|
||
|
|
; shouldn't do this if we're printing on behalf of the repl
|
||
|
|
(begin ; unless (use-interaction-window)
|
||
|
|
(unless (fx= mode writing) (set! indent 0))
|
||
|
|
(set! mode writing)
|
||
|
|
(if (char? x)
|
||
|
|
(do-char x)
|
||
|
|
(let ([len (string-length x)])
|
||
|
|
(do ([i 0 (fx+ i 1)]) ((fx= i len))
|
||
|
|
(do-char (string-ref x i))))))))
|
||
|
|
(define whitespace?
|
||
|
|
(lambda (x)
|
||
|
|
(if (char? x)
|
||
|
|
(char-whitespace? x)
|
||
|
|
(let loop ([i (fx- (string-length x) 1)])
|
||
|
|
(or (fx< i 0)
|
||
|
|
(and (char-whitespace? (string-ref x i))
|
||
|
|
(loop (fx- i 1))))))))
|
||
|
|
(let ([line '()] [bline '()] [buffer '()] [ip ip])
|
||
|
|
(define (handler msg . args)
|
||
|
|
(record-case (cons msg args)
|
||
|
|
[char-ready? (p)
|
||
|
|
(critical-section
|
||
|
|
(or (not (null? line)) (char-ready? ip)))]
|
||
|
|
[peek-char (p)
|
||
|
|
(define read-line
|
||
|
|
(lambda ()
|
||
|
|
(when (fx= mode writing) (set! mode reading))
|
||
|
|
(when (fx= mode indenting)
|
||
|
|
(unless (fx= indent 0)
|
||
|
|
(set! buffer
|
||
|
|
(cons (make-tag #f (make-string indent #\space))
|
||
|
|
buffer))))
|
||
|
|
(let loop ()
|
||
|
|
(let ([c (read-char ip)])
|
||
|
|
(if (eof-object? c)
|
||
|
|
'()
|
||
|
|
(let ([x (make-tag #f c)])
|
||
|
|
(set! buffer (cons x buffer))
|
||
|
|
(if (eqv? c #\newline)
|
||
|
|
(begin (set! mode indenting) (list x))
|
||
|
|
(cons x (loop)))))))))
|
||
|
|
(critical-section
|
||
|
|
(if (null? line)
|
||
|
|
(let ([old bline])
|
||
|
|
(set! line (read-line))
|
||
|
|
(set! bline '())
|
||
|
|
(if (null? line)
|
||
|
|
(begin
|
||
|
|
; When the last expression in a transcript calls read
|
||
|
|
; and then prints something in the transcript window,
|
||
|
|
; we have to be sure that the newline character that
|
||
|
|
; sent the line of buffered text is properly tagged as
|
||
|
|
; having been read via the transcript input port since
|
||
|
|
; read simply peeks at the whitespace character and the
|
||
|
|
; subsequent repl read (returning #!eof) will usurp the
|
||
|
|
; newline unless we patch it up here.
|
||
|
|
(when (and (> (length old) 1)
|
||
|
|
(eqv? (tag-entity (car old)) #\newline)
|
||
|
|
(eq? (tag-markup (cadr old)) 'transin))
|
||
|
|
(set-tag-markup! (car old) 'transin))
|
||
|
|
#!eof)
|
||
|
|
(tag-entity (car line))))
|
||
|
|
(tag-entity (car line))))]
|
||
|
|
[unread-char (c p)
|
||
|
|
(critical-section
|
||
|
|
(when (null? bline)
|
||
|
|
(errorf 'unread-char "too many consecutive unreads from ~s" p))
|
||
|
|
(let ([x (car bline)])
|
||
|
|
(set! bline (cdr bline))
|
||
|
|
(set-tag-markup! x #f)
|
||
|
|
(set-tag-entity! x c)
|
||
|
|
(set! line (cons x line))))]
|
||
|
|
[clear-input-port (p)
|
||
|
|
(critical-section
|
||
|
|
(set! line '())
|
||
|
|
(set! bline '()))]
|
||
|
|
[clear-output-port (p) (void)]
|
||
|
|
[close-port (p) (mark-port-closed! p)]
|
||
|
|
[flush-output-port (p) (void)]
|
||
|
|
[file-position (p . pos)
|
||
|
|
(if (null? pos)
|
||
|
|
(most-negative-fixnum)
|
||
|
|
(errorf 'transcript-port "cannot reposition"))]
|
||
|
|
[port-name (p) "tag-port"]
|
||
|
|
; intentionally missing block-read and read-char
|
||
|
|
[tag-read-char (markup p)
|
||
|
|
(critical-section
|
||
|
|
(let ([c (peek-char p)])
|
||
|
|
(unless (null? line)
|
||
|
|
(let ([x (car line)])
|
||
|
|
(set! line (cdr line))
|
||
|
|
(set-tag-markup! x markup)
|
||
|
|
(set! bline (cons x bline))))
|
||
|
|
c))]
|
||
|
|
[tag-write-entity (markup x p)
|
||
|
|
(critical-section
|
||
|
|
(adjust-indent x)
|
||
|
|
(set! buffer (cons (make-tag markup x) buffer)))]
|
||
|
|
[tag-get-repl-interaction-strings ()
|
||
|
|
(let ([repl (open-output-string)] [intr (open-output-string)])
|
||
|
|
(define maxcols (interaction-window-width))
|
||
|
|
(define col 0)
|
||
|
|
(define col-display
|
||
|
|
(lambda (entity p)
|
||
|
|
(define col-write-char
|
||
|
|
(lambda (c p)
|
||
|
|
(cond
|
||
|
|
[(char=? c #\newline) (set! col 0)]
|
||
|
|
[(= col maxcols) (newline p) (set! col 0)])
|
||
|
|
(write-char c p)
|
||
|
|
(set! col (+ col 1))))
|
||
|
|
(if (char? entity)
|
||
|
|
(col-write-char entity p)
|
||
|
|
(for-each (lambda (c) (col-write-char c p)) (string->list entity)))))
|
||
|
|
(define choose-port
|
||
|
|
(lambda (mkup)
|
||
|
|
(case mkup
|
||
|
|
[(#f transerr traceout) repl]
|
||
|
|
[(transin transout) intr]
|
||
|
|
[else (errorf 'scheme-prep.ss "unexpected markup ~s" mkup)])))
|
||
|
|
(define reclaim-first-newline
|
||
|
|
; the newline that we entered after the expression in the repl window should
|
||
|
|
; be charged to the repl window, not the interaction window.
|
||
|
|
; (misattributed as being read by transin since the repl's read just peeks at
|
||
|
|
; the newline, and subsequent read during eval phase claims the newline)
|
||
|
|
(lambda (ls)
|
||
|
|
(let f ([ls ls])
|
||
|
|
(if (null? ls)
|
||
|
|
'()
|
||
|
|
(let ([x (car ls)])
|
||
|
|
(case (tag-markup x)
|
||
|
|
[(transin) (when (eqv? (tag-entity x) #\newline) (set-tag-markup! x #f))]
|
||
|
|
[(transout) (void)]
|
||
|
|
[else (f (cdr ls))]))))
|
||
|
|
ls))
|
||
|
|
(let loop ([ls (reclaim-first-newline (reverse buffer))] [markup #f])
|
||
|
|
(if (null? ls)
|
||
|
|
(begin
|
||
|
|
(set! buffer '())
|
||
|
|
(when markup (fprintf (choose-port markup) "\\raw{\\end~s{}}" markup))
|
||
|
|
(values
|
||
|
|
(get-output-string repl)
|
||
|
|
(let ([x (get-output-string intr)])
|
||
|
|
(if (eq? x "") #f x))))
|
||
|
|
(let ([x (car ls)])
|
||
|
|
(let ([new (tag-markup x)] [entity (tag-entity x)])
|
||
|
|
(unless (eq? new markup)
|
||
|
|
(when markup (fprintf (choose-port markup) "\\raw{\\end~s{}}" markup))
|
||
|
|
(when new (fprintf (choose-port new) "\\raw{\\~s{}}" new)))
|
||
|
|
(let ([p (choose-port new)])
|
||
|
|
(if (eq? p repl)
|
||
|
|
(display entity p)
|
||
|
|
(col-display entity p)))
|
||
|
|
(loop (cdr ls) new))))))]
|
||
|
|
[tag-get-output-string ()
|
||
|
|
(let ([op (open-output-string)])
|
||
|
|
(let loop ([ls (reverse buffer)] [markup #f])
|
||
|
|
(if (null? ls)
|
||
|
|
(begin
|
||
|
|
(set! buffer '())
|
||
|
|
(when markup (fprintf op "\\raw{\\end~s{}}" markup))
|
||
|
|
(get-output-string op))
|
||
|
|
(let ([x (car ls)])
|
||
|
|
(let ([new (tag-markup x)] [entity (tag-entity x)])
|
||
|
|
(unless (eq? new markup)
|
||
|
|
(when markup (fprintf op "\\raw{\\end~s{}}" markup))
|
||
|
|
(when new (fprintf op "\\raw{\\~s{}}" new)))
|
||
|
|
(display entity op)
|
||
|
|
(loop (cdr ls) new))))))]
|
||
|
|
[delete-last-line-if-unmarked ()
|
||
|
|
; clean up the "\n> \n" at the end of the transcript
|
||
|
|
; by deleting everything from the last newline upto, but
|
||
|
|
; not including the second newline.
|
||
|
|
(let trim ([ls buffer] [n? #f])
|
||
|
|
(if (or (null? ls) (tag-markup (car ls)))
|
||
|
|
(set! buffer ls)
|
||
|
|
(let foo ([first (tag-entity (car ls))])
|
||
|
|
(cond
|
||
|
|
[(string? first)
|
||
|
|
(let scan ([i (- (string-length first) 1)] [n? n?])
|
||
|
|
(cond
|
||
|
|
[(fx< i 0) (trim (cdr ls) n?)]
|
||
|
|
[(char=? (string-ref first i) #\newline)
|
||
|
|
(if (not n?)
|
||
|
|
(scan (fx- i 1) #t)
|
||
|
|
(begin
|
||
|
|
(set-tag-entity!
|
||
|
|
(car ls)
|
||
|
|
(substring first 0 i))
|
||
|
|
(set! buffer ls)))]
|
||
|
|
[else (scan (fx- i 1) n?)]))]
|
||
|
|
[(char=? first #\newline)
|
||
|
|
(if (not n?)
|
||
|
|
(trim (cdr ls) #t)
|
||
|
|
(set! buffer (cdr ls)))]
|
||
|
|
[else (trim (cdr ls) n?)]))))
|
||
|
|
; trim the last newline at the end of the transcript
|
||
|
|
; since transcript env will insert some vspace of its own
|
||
|
|
(unless (null? buffer)
|
||
|
|
(let ([first (car buffer)])
|
||
|
|
(when (eqv? (tag-entity first) #\newline)
|
||
|
|
(set! buffer (cdr buffer)))))]
|
||
|
|
[else (errorf 'tag-port "operation ~s not handled" msg)]))
|
||
|
|
(make-input/output-port handler "" ""))))
|
||
|
|
|
||
|
|
(define make-markup-port
|
||
|
|
(lambda (tag-p imarkup omarkup)
|
||
|
|
(define (handler msg . args)
|
||
|
|
(record-case (cons msg args)
|
||
|
|
[block-read (p str cnt)
|
||
|
|
(critical-section
|
||
|
|
(let ([c (peek-char p)])
|
||
|
|
(if (eof-object? c)
|
||
|
|
c
|
||
|
|
(if (= cnt 0)
|
||
|
|
0
|
||
|
|
(begin
|
||
|
|
(read-char p)
|
||
|
|
(string-set! str 0 c)
|
||
|
|
1)))))]
|
||
|
|
[char-ready? (p) (char-ready? tag-p)]
|
||
|
|
[clear-input-port (p) (clear-input-port tag-p)]
|
||
|
|
[clear-output-port (p) (clear-output-port tag-p)]
|
||
|
|
[close-port (p) (mark-port-closed! p) (close-port tag-p)]
|
||
|
|
[flush-output-port (p) (flush-output-port tag-p)]
|
||
|
|
[file-position (p . pos)
|
||
|
|
(if (null? pos)
|
||
|
|
(most-negative-fixnum)
|
||
|
|
(errorf 'transcript-port "cannot reposition"))]
|
||
|
|
[port-name (p) "markup"]
|
||
|
|
[peek-char (p) (peek-char tag-p)]
|
||
|
|
[read-char (p) ((port-handler tag-p) 'tag-read-char imarkup tag-p)]
|
||
|
|
[unread-char (c p) (unread-char c tag-p)]
|
||
|
|
[write-char (c p) ((port-handler tag-p) 'tag-write-entity omarkup c tag-p)]
|
||
|
|
[block-write (p str cnt)
|
||
|
|
((port-handler tag-p)
|
||
|
|
'tag-write-entity
|
||
|
|
omarkup
|
||
|
|
(substring str 0 cnt)
|
||
|
|
tag-p)
|
||
|
|
cnt]
|
||
|
|
[else (errorf 'markup-port "operation ~s not handled" msg)]))
|
||
|
|
(make-input/output-port handler "" "")))
|
||
|
|
|
||
|
|
(define scheme-transcript
|
||
|
|
(P lambda (console-input labels)
|
||
|
|
(let ([tp (make-tag-port (open-input-string console-input))])
|
||
|
|
(let ([normal (make-markup-port tp #f #f)]
|
||
|
|
[trace (make-markup-port tp #f 'traceout)]
|
||
|
|
[effect (make-markup-port tp 'transin 'transout)]
|
||
|
|
[errors (make-markup-port tp #f 'transerr)]
|
||
|
|
[handler (port-handler tp)])
|
||
|
|
(handler 'tag-write-entity #f "\\schemedisplay" tp)
|
||
|
|
(for-each
|
||
|
|
(lambda (l)
|
||
|
|
(handler 'tag-write-entity #f (format "\\label{~a}" l) tp))
|
||
|
|
labels)
|
||
|
|
(handler 'tag-write-entity #f "\n" tp)
|
||
|
|
(parameterize ([console-input-port normal]
|
||
|
|
[console-output-port normal]
|
||
|
|
[console-error-port normal]
|
||
|
|
[current-input-port effect]
|
||
|
|
[current-output-port effect]
|
||
|
|
[current-error-port effect]
|
||
|
|
[trace-output-port trace])
|
||
|
|
(new-cafe
|
||
|
|
(lambda (x)
|
||
|
|
(with-exception-handler default-exception-handler
|
||
|
|
(lambda ()
|
||
|
|
(eval x))))))
|
||
|
|
; We could do this with string bashing. I modified the port.
|
||
|
|
(handler 'delete-last-line-if-unmarked tp)
|
||
|
|
(handler 'tag-write-entity #f "\\endschemedisplay\n" tp)
|
||
|
|
(if (use-interaction-window)
|
||
|
|
(let-values ([(repl interaction) (handler 'tag-get-repl-interaction-strings tp)])
|
||
|
|
(P s0
|
||
|
|
([ip
|
||
|
|
(if (not interaction)
|
||
|
|
(open-input-string repl)
|
||
|
|
(open-input-string
|
||
|
|
(string-append
|
||
|
|
"\\startrepl{}" repl
|
||
|
|
"\\endrepl{}\\startinteraction{}\\schemedisplay\n"
|
||
|
|
interaction
|
||
|
|
"\\endschemedisplay\\endinteraction{}")))]
|
||
|
|
[ips (cons ip ips)]
|
||
|
|
[eofconts (cons s0 eofconts)])))
|
||
|
|
(let ([transcript (handler 'tag-get-output-string tp)])
|
||
|
|
(P s0
|
||
|
|
([ip (open-input-string transcript)]
|
||
|
|
[ips (cons ip ips)]
|
||
|
|
[eofconts (cons s0 eofconts)]))))))))
|
||
|
|
|
||
|
|
(define make-string-evaluator
|
||
|
|
(lambda (start-mark evaluator)
|
||
|
|
(P lambda ()
|
||
|
|
(define text-upto
|
||
|
|
(let ([op (open-output-string)])
|
||
|
|
(lambda (endmark)
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\\)
|
||
|
|
(let ([mk (read-alpha-command ip)])
|
||
|
|
(if (eq? mk endmark)
|
||
|
|
(get-output-string op)
|
||
|
|
(begin
|
||
|
|
(write-char #\\ op)
|
||
|
|
(display mk op)
|
||
|
|
(text-upto endmark))))]
|
||
|
|
[(eof) (unexpected-eof (format "after \\~a" start-mark))]
|
||
|
|
[else
|
||
|
|
(write-char c op)
|
||
|
|
(text-upto endmark)]))))
|
||
|
|
(let loop ([endmark #f] [labels '()])
|
||
|
|
(state-case (c (read-char ip))
|
||
|
|
[(#\[) ;]
|
||
|
|
(when endmark
|
||
|
|
(input-error "expected newline after \\~a[~a]" start-mark endmark))
|
||
|
|
(unread-char c ip)
|
||
|
|
(let ([ls (string->list (read-optional-arg ip))])
|
||
|
|
(when (null? ls)
|
||
|
|
(input-error "empty optional argument to \\~a" start-mark))
|
||
|
|
(when (not (char=? (car ls) #\\))
|
||
|
|
(input-error "\\~a terminator must begin with \\" start-mark))
|
||
|
|
(let ([rest (cdr ls)])
|
||
|
|
(when (or (null? rest) (not (andmap char-alphabetic? (cdr ls))))
|
||
|
|
(input-error
|
||
|
|
"\\~a terminator must be \\ followed by alphabetic character(s)" start-mark))
|
||
|
|
(loop (string->symbol (list->string rest)) labels)))]
|
||
|
|
[(#\\)
|
||
|
|
; currently a bit sloppy on the grammar
|
||
|
|
; could require all labels one after the other
|
||
|
|
; use read-alpha-command instead of read-command to avoid
|
||
|
|
; improper handling of special characters that follow a slash
|
||
|
|
(let ([cmd (read-alpha-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(label)
|
||
|
|
(loop endmark (cons (read-bracketed-text ip) labels))]
|
||
|
|
[else
|
||
|
|
(input-error "invalid command \\~s following \\~a" cmd start-mark)]))]
|
||
|
|
[(#\newline)
|
||
|
|
(let ([endmark
|
||
|
|
(or endmark
|
||
|
|
(string->symbol (string-append "end" start-mark)))])
|
||
|
|
(P evaluator () (text-upto endmark) endmark (reverse labels)))]
|
||
|
|
[(#\space #\tab) (loop endmark labels)]
|
||
|
|
[else
|
||
|
|
(let ([txt (format "expected newline after \\~a" start-mark)])
|
||
|
|
(input-error
|
||
|
|
(if endmark
|
||
|
|
(string-append txt (format "[~a]" endmark))
|
||
|
|
txt)))])))))
|
||
|
|
|
||
|
|
(global-def schemeinit
|
||
|
|
; whitespace has not suppressed when we are invoked
|
||
|
|
(make-string-evaluator "schemeinit"
|
||
|
|
(P lambda (s endmark labels)
|
||
|
|
(unless (null? labels) (input-error "what on earth do you mean putting \\label after \\schemeinit ???"))
|
||
|
|
; We could perhaps make this easier by not trying to share the
|
||
|
|
; make-string-evaluator code with \transcript and instead let
|
||
|
|
; the code simply read from the true ip instead, so that input-error
|
||
|
|
; does its job without our assistance. Unfortunately, I just thought
|
||
|
|
; of that and don't have the heart to do any more than document the
|
||
|
|
; possibility.
|
||
|
|
(let ([real-abort-handler (abort-handler)])
|
||
|
|
(let ([sip (open-input-string s)])
|
||
|
|
; nesting is not an issue.
|
||
|
|
(let f ()
|
||
|
|
; scan ahead to first non-whitespace character, if any
|
||
|
|
(let skip-whitespace ()
|
||
|
|
(let ([c (peek-char sip)])
|
||
|
|
(when (and (char? c) (char-whitespace? c))
|
||
|
|
(read-char sip)
|
||
|
|
(skip-whitespace))))
|
||
|
|
; record the current file position so we adjust the true
|
||
|
|
; file-position based on the string-input-port's file position
|
||
|
|
; if we run into an error
|
||
|
|
(let ([last-sip-pos (file-position sip)])
|
||
|
|
(define scout ; be prepared
|
||
|
|
(lambda (thunk)
|
||
|
|
(parameterize
|
||
|
|
([abort-handler
|
||
|
|
(lambda args
|
||
|
|
(let ([end (file-position ip)]
|
||
|
|
[endmark-len
|
||
|
|
(+ 1
|
||
|
|
(string-length (symbol->string endmark)))])
|
||
|
|
(file-position
|
||
|
|
ip
|
||
|
|
(- end
|
||
|
|
endmark-len
|
||
|
|
(- (string-length s) last-sip-pos))))
|
||
|
|
(parameterize ([abort-handler real-abort-handler])
|
||
|
|
(input-error
|
||
|
|
"previous error occurred within \\schemeinit")))])
|
||
|
|
(thunk))))
|
||
|
|
(let ([x (scout (lambda () (read sip)))])
|
||
|
|
(unless (eof-object? x)
|
||
|
|
(scout (lambda () (eval x)))
|
||
|
|
(f)))))))
|
||
|
|
(P s0 ()))))
|
||
|
|
|
||
|
|
(global-def generated
|
||
|
|
(P lambda ()
|
||
|
|
(let ([sop (open-output-string)])
|
||
|
|
(let loop ()
|
||
|
|
(state-case (c (peek-char ip))
|
||
|
|
[(#\space #\tab #\newline) (read-char ip) (loop)]
|
||
|
|
[(#\\)
|
||
|
|
(read-char ip)
|
||
|
|
(let ([cmd (read-alpha-command ip)])
|
||
|
|
(case cmd
|
||
|
|
[(endgenerated)
|
||
|
|
(P s0 ([ip (open-input-string (get-output-string sop))]
|
||
|
|
[ips (cons ip ips)]
|
||
|
|
[eofconts (cons s0 eofconts)]))]
|
||
|
|
[else (input-error "unexpected command \\~s following \\generated" cmd)]))]
|
||
|
|
[else
|
||
|
|
(parameterize ([current-output-port sop])
|
||
|
|
(eval (read ip))) ; should protect against errors
|
||
|
|
(loop)])))))
|
||
|
|
|
||
|
|
(global-def transcript
|
||
|
|
; whitespace has not suppressed when we are invoked
|
||
|
|
(make-string-evaluator "transcript"
|
||
|
|
(P lambda (s endmark labels)
|
||
|
|
(P scheme-transcript () s labels))))
|
||
|
|
|
||
|
|
(global-def useinteractionwindow
|
||
|
|
(P lambda ()
|
||
|
|
(use-interaction-window #t)
|
||
|
|
(P s0 ())))
|
||
|
|
|
||
|
|
(global-def enduseinteractionwindow
|
||
|
|
(P lambda ()
|
||
|
|
(use-interaction-window #f)
|
||
|
|
(P s0 ())))
|
||
|
|
|
||
|
|
(global-def interactionwindowwidth
|
||
|
|
(P lambda ()
|
||
|
|
(let ([s (read-bracketed-text ip)])
|
||
|
|
(let ([n (string->number s)])
|
||
|
|
(unless n (errorf #f "expected numeric argument to \\interactionwindowwidth"))
|
||
|
|
; should be more clever here to make it work in bgroup ... egroup fashion
|
||
|
|
(interaction-window-width n)
|
||
|
|
(P s0 ())))))
|
||
|
|
|
||
|
|
)
|
||
|
|
|
||
|
|
(populate-source-directories)
|
||
|
|
|
||
|
|
(command-line-case (command-line)
|
||
|
|
[((keyword --help)) (usage)]
|
||
|
|
[(filename* ...)
|
||
|
|
(for-each go
|
||
|
|
(let ([found (find-filename "scheme-prep.tex")])
|
||
|
|
(if found
|
||
|
|
(cons found filename*)
|
||
|
|
filename*)))])
|