diff --git a/collects/combinator-parser/combinator-unit.rkt b/collects/combinator-parser/combinator-unit.rkt deleted file mode 100644 index 516ded8985..0000000000 --- a/collects/combinator-parser/combinator-unit.rkt +++ /dev/null @@ -1,11 +0,0 @@ -(module combinator-unit mzscheme - - (require "private-combinator/combinator-parser.scm" - "private-combinator/parser-sigs.rkt") - - (provide combinator-parser-tools@ - combinator-parser^ err^ - error-format-parameters^ language-format-parameters^ language-dictionary^ - terminals recurs) - - ) diff --git a/collects/combinator-parser/doc.txt b/collects/combinator-parser/doc.txt deleted file mode 100644 index caf400d8c9..0000000000 --- a/collects/combinator-parser/doc.txt +++ /dev/null @@ -1,133 +0,0 @@ -_combinator-parser_ - -This documentation provides directions on using the combinator parser library. It assumes familiarity with lexing and with combinator parsers. - -_combinator-unit.ss_ -This library provides a unit implementing four higher-order functions -that can be used to build a combinator parser, and the export and -import signatures related to it. The functions contained in this unit -automatically build error reporting mechanisms in the event that no parse -is found. Unlike other combinator parsers, this system assumes that the -input is already lexed into tokens using _lex.ss_. This library relies on -_(lib "lazy.ss" "lazy")_. - -The unit _combinator-parser-tools_ exports the signature -_combinator-parser^_ and imports the signatures _error-format-parameters^_, _language-format-parameters^_, and _language-dictionary^_. - -The signature combinator-parser^ references functions to build combinators, -a function to build a runable parser using a combinator, a structure for -recording errors and macro definitions to specify combinators with: - - >(terminal predicate result name spell-check case-check type-check) -> - (list token) -> parser-result - The returned function accepts one terminal from a token stream, and - returns produces an opaque value that interacts with other combinators. - - predicate: token -> boolean - check that the token is the expected one - result: token -> beta - create the ast node for this terminal - name: string - human-language name for this terminal - spell-check, case-check, type-check: (U bool (token -> bool)) - optional arguments, default to #f, perform spell checking, case - checking, and kind checking on incorrect tokens - - >(seq sequence result name) -> (list token) -> parser-result - The returned function accepts a term made up of a sequence of smaller - terms, and produces an opaque value that interacts with other - combinators. - - sequence: (listof ((list token) -> parser-result)) - the subterms - result: (list alpha) -> beta - create the ast node for this sequence. - Input list matches length of sequence list - name: human-language name for this term - - >(choice options name) -> (list token) -> parser-result - The returned function selects between different terms, and produces an - opaque value that interacts with other combinators - - options: (listof ((list token) -> parser-result) - the possible terms - name: human-language name for this term - - >(repeat term) -> (list token) -> parser-result - The returned function accepts 0 or more instances of term, and produces - an opaque value that interacts with other combinators - - term: (list token) -> parser-result - - >(parser term) -> (list token) location -> ast-or-error - Returns a function that parses a list of tokens, producing either the - result of calling all appropriate result functions or an err - - term: (list token) -> parser-result - location: string | editor - Either the string representing the file name or the editor being read, - typically retrieved from file-path - ast-or-error: AST | err - AST is the result of calling the given result function - - The err structure is: - >(make-err string source-list) - - >(err-msg err) -> string - The error message - >(err-src err) -> (list location line-k col-k pos-k span-k) - This list is suitable for calling raise-read-error, - *-k are positive integers - - The language forms provided are: - >(define-simple-terminals NAME (simple-spec ...)) - Expands to a define-empty-tokens and one terminal definition per - simple-spec - - NAME is an identifier specifying a group of tokens - - simple-spec = NAME | (NAME string) | (NAME proc) | (NAME string proc) - NAME is an identifier specifying a token/terminal with no value - proc: token -> ast - A procedure from tokens to AST nodes. id is used - by default. The token will be a symbol. - string is the human-language name for the terminal, NAME is used by - default - - >(define-terminals NAME (terminal-spec ...)) - Like define-simple-terminals, except uses define-tokens - - terminal-spec = (NAME proc) | (NAME string proc) - proc: token -> ast - a procedure from tokens to AST node. - The token will be the token defined as NAME and will be a value token. - - >(sequence (NAME ...) proc string) - Generates a call to seq with the specified names in a list, - proc => result and string => name. - The name can be omitted when nested in another sequence or choose - - >(sequence (NAME_ID ...) proc string) - where NAME_ID is either NAME or (^ NAME) - The ^ form identifies a parser production that can be used to identify - this production in an error message. Otherwise the same as above - - >(choose (NAME ...) string) - Generates a call to choice using the given terms as the list of options, - string => name. - The name can be omitted when nested in another sequence or choose - - >(eta NAME) - Eta expands name with a wrapping that properly mimcs a parser term - -The _error-format-parameters^_ signature requires five names: - src?: boolean- will the lexer include source information - input-type: string- used to identify the source of input - show-options: boolean- presently ignored - max-depth: int- The depth of errors reported - max-choice-depth: int- The max number of options listed in an error - -The _language-format-parameters^_ requires two names - class-type: string - general term for language keywords - input->output-name: token -> string - translates tokens into strings - -The _language-dictionary^_ requires three names - misspelled: string string -> number - - check the spelling of the second arg against the first, return a number - that is the probability that the second is a misspelling of the first - misscap: string string -> boolean - - check the capitalization of the second arg against the first - missclass: string string -> boolean - - check if the second arg names a correct token kind diff --git a/collects/combinator-parser/examples/combinator-example.rkt b/collects/combinator-parser/examples/combinator-example.rkt deleted file mode 100644 index 5d804300cb..0000000000 --- a/collects/combinator-parser/examples/combinator-example.rkt +++ /dev/null @@ -1,63 +0,0 @@ -(module combinator-example scheme/base - -(require scheme/unit - parser-tools/lex - combinator-parser/combinator-unit) - -(define-unit support - (import) - (export error-format-parameters^ - language-format-parameters^ - language-dictionary^) - - (define src? #t) - (define input-type "file") - (define show-options #f) - (define max-depth 1) - (define max-choice-depth 2) - - (define class-type "keyword") - (define (input->output-name t) (token-name t)) - - (define (misspelled s1 s2) - (and (equal? s1 "lam") - (equal? s2 "lambda"))) - (define (misscap s1 s2) - (and (equal? s1 "lam") - (equal? s2 "Lam"))) - (define (missclass s1 s2) #f) - ) - -(define-signature parser^ (parse-prog)) - -(define-unit lambda-calc - (import combinator-parser^) - (export parser^) - - (define-simple-terminals keywords - (lam (O_paren "(") (C_paren ")"))) - - (define string->symbol* - (case-lambda - [(one) (string->symbol one)] - [(one two three) (error 'string->symbol* "Cannot accept so many arguments")])) - - (define-terminals ids - ((id "variable" string->symbol*) (number (lambda (x) (read (open-input-string x)))))) - - (define app - (sequence (O_paren (repeat (eta expr)) C_paren) - (lambda (id) id) - "application")) - - (define func - (sequence (O_paren lam O_paren (repeat id) (eta expr)) - (lambda (id) id) - "function")) - - (define expr (choose (id number app func) "expression")) - - (define parse-prog (parser expr)) - ) - - ) diff --git a/collects/combinator-parser/info.rkt b/collects/combinator-parser/info.rkt deleted file mode 100644 index 7e41f36e49..0000000000 --- a/collects/combinator-parser/info.rkt +++ /dev/null @@ -1,3 +0,0 @@ -#lang setup/infotab - -(define compile-omit-paths '("examples")) diff --git a/collects/combinator-parser/private-combinator/combinator-parser.scm b/collects/combinator-parser/private-combinator/combinator-parser.scm deleted file mode 100644 index 22b2478e84..0000000000 --- a/collects/combinator-parser/private-combinator/combinator-parser.scm +++ /dev/null @@ -1,217 +0,0 @@ -(module combinator-parser scheme/base - - (require scheme/list - scheme/unit - parser-tools/lex) - (require "structs.scm" "parser-sigs.ss" "combinator.scm" "errors.scm") - - (provide combinator-parser-tools@) - - (define-unit main-parser@ - (import error^ out^ error-format-parameters^ language-format-parameters^ ranking-parameters^) - (export parser^) - - (define (sort-used reses) - (sort reses - (lambda (a b) (> (res-used a) (res-used b))))) - (define (sort-repeats repeats) - (sort repeats - (lambda (a b) (> (res-used (repeat-res-a a)) - (res-used (repeat-res-a b)))))) - - (define (parser start) - (lambda (input file) - (let* ([first-src (and src? (pair? input) - (make-src-lst (position-token-start-pos (car input)) - (position-token-end-pos (car input))))] - [result (if first-src (start input first-src) (start input))] - [out - (cond - [(and (res? result) (res-a result) (null? (res-rest result))) - (car (res-a result))] - [(and (res? result) (res-a result) (res-possible-error result)) - (fail-type->message (res-possible-error result))] - [(and (res? result) (res-a result)) - (make-err - (format "Found extraneous input after ~a, starting with ~a, at the end of ~a." - (res-msg result) - (input->output-name (car (res-rest result))) input-type) - (and src? - (make-src-lst (position-token-start-pos (car (res-rest result))) - (position-token-end-pos (car (res-rest result))))))] - [(res? result) - (fail-type->message (res-msg result))] - [(lazy-opts? result) - #;(printf "lazy-opts ~a\n" result) - (let* ([finished? (lambda (o) - (cond [(res? o) - (and (not (null? (res-a o))) - (null? (res-rest o)))] - [(repeat-res? o) - (eq? (repeat-res-stop o) 'out-of-input)] - [else #f]))] - [possible-errors - (lambda (matches) - (map (lambda (r) - (or (and (res? r) (res-possible-error r)) - (and (repeat-res? r) (repeat-res-stop r)))) - (filter (lambda (r) - (or (and (res? r) (res-possible-error r)) - (and (repeat-res? r) (fail-type? (repeat-res-stop r))))) - matches)))] - [result-a - (lambda (res) - (cond - [(res? res) (res-a res)] - [(and (repeat-res? res) - (res? (repeat-res-a res))) - (res-a (repeat-res-a res))] - [else - (error 'parser-internal-errorcl (format "~a" res))]))]) - (let loop ([matched (lazy-opts-matches result)]) - (cond - [(and (pair? matched) (finished? (car matched))) (result-a (car matched))] - [(pair? matched) (loop (cdr matched))] - [(and matched (finished? matched)) (result-a matched)] - [(or (null? matched) matched) (loop (next-opt result))] - [else - (let ([p-errors (possible-errors (lazy-opts-matches result))]) - (cond - [(pair? p-errors) - (let ([fails (cons (lazy-opts-errors result) p-errors)]) - #;(printf "\nfails ~a\n\n" fails) - (fail-type->message - (make-options-fail (rank-choice (map fail-type-chance fails)) - #f - (if (lazy-choice? result) - (lazy-choice-name result) "program") - (rank-choice (map fail-type-used fails)) - (rank-choice (map fail-type-may-use fails)) - fails)))] - [(null? p-errors) - (fail-type->message (lazy-opts-errors result))]))])))] - [(or (choice-res? result) (pair? result)) - #;(printf "choice-res or pair? ~a\n" result) - (let* ([options (if (choice-res? result) (choice-res-matches result) result)] - [finished-options (filter (lambda (o) - (cond [(res? o) - (and (not (null? (res-a o))) - (null? (res-rest o)))] - [(repeat-res? o) - (eq? (repeat-res-stop o) 'out-of-input)])) - options)] - [possible-repeat-errors - (filter (lambda (r) (and (repeat-res? r) - (fail-type? (repeat-res-stop r)))) - options)] - [possible-errors - (filter res-possible-error - (map (lambda (a) (if (repeat-res? a) (repeat-res-a a) a)) - options))]) - #;(printf "length finished-options ~a\n" finished-options) - (cond - [(not (null? finished-options)) - #;(printf "finished an option\n") - (let ([first-fo (car finished-options)]) - (car (cond - [(res? first-fo) (res-a first-fo)] - [(and (repeat-res? first-fo) - (res? (repeat-res-a first-fo))) - (res-a (repeat-res-a first-fo))] - [else - (error 'parser-internal-errorcp - (format "~a" first-fo))])))] - #;[(not (null? possible-repeat-errors)) - (printf "possible-repeat error\n") - (fail-type->message - (car (repeat-res-stop - (sort-repeats possible-repeat-errors))))] - [(and (choice-res? result) (fail-type? (choice-res-errors result))) - #;(printf "choice res and choice res errors \n") - (cond - [(and (null? possible-repeat-errors) - (null? possible-errors)) (fail-type->message (choice-res-errors result))] - [(or #;(not (null? possible-repeat-errors)) - (not (null? possible-errors))) - (let ([fails (cons (choice-res-errors result) - (map res-possible-error possible-errors))]) - (fail-type->message - (make-options-fail (rank-choice (map fail-type-chance fails)) - #f - (choice-res-name result) - (rank-choice (map fail-type-used fails)) - (rank-choice (map fail-type-may-use fails)) - fails)))])] - [(not (null? possible-errors)) - ;(printf "choice or pair fail\n") - (fail-type->message - (res-possible-error (car (sort-used possible-errors))))] - [else - #;(printf "result ~a\n" result) - (let ([used-sort (sort-used options)]) - (if (and (choice-res? result) - (choice-res-errors result)) - (fail-type->message (choice-res-errors result)) - (make-err - (format "Found additional content after ~a, beginning with '~a'." - (res-msg (car used-sort)) - (input->output-name (car (res-rest (car used-sort))))) - (and src? - (make-src-lst (position-token-start-pos - (car (res-rest (car used-sort)))) - (position-token-end-pos - (car (res-rest (car used-sort)))))))))]))] - [(and (repeat-res? result) (eq? 'out-of-input (repeat-res-stop result))) - (res-a (repeat-res-a result))] - [(and (repeat-res? result) (fail-type? (repeat-res-stop result))) - ;(printf "repeat-fail\n") - (fail-type->message (repeat-res-stop result))] - [else (error 'parser (format "Internal error: received unexpected input ~a" - result))])]) - (cond - [(err? out) - (make-err (err-msg out) - (if (err-src out) - (list file - (first (err-src out)) - (second (err-src out)) - (third (err-src out)) - (fourth (err-src out))) - (list file 1 0 1 0)))] - [else out])))) - ) - - #;(define-unit rank-defaults@ - (import) - (export ranking-parameters^) - (define (rank-choice choices) (apply max choices)) - (define-values - (rank-misspell rank-caps rank-class rank-wrong rank-end) - (values 4/5 9/10 2/5 1/5 2/5))) - - (define-unit rank-defaults@ - (import) - (export ranking-parameters^) - (define (rank-choice choices) (apply max choices)) - (define-values - (rank-misspell rank-caps rank-class rank-wrong rank-end rank-repeat) - (values 16/71 18/71 8/71 4/71 8/71 17/71))) - - - (define-unit out-struct@ - (import) - (export out^) - (define-struct err (msg src) #:mutable)) - - (define-compound-unit/infer combinator-parser@ - (import error-format-parameters^ language-format-parameters^ language-dictionary^) - (export combinator-parser-forms^ parser^ out^) - (link out-struct@ main-parser@ rank-defaults@ error-formatting@ combinators@)) - - (define-unit/new-import-export combinator-parser-tools@ - (import error-format-parameters^ language-format-parameters^ language-dictionary^) - (export combinator-parser^ err^) - ((combinator-parser-forms^ parser^ out^) combinator-parser@ error-format-parameters^ language-format-parameters^ - language-dictionary^)) - - ) diff --git a/collects/combinator-parser/private-combinator/combinator.scm b/collects/combinator-parser/private-combinator/combinator.scm deleted file mode 100644 index e0412330cf..0000000000 --- a/collects/combinator-parser/private-combinator/combinator.scm +++ /dev/null @@ -1,932 +0,0 @@ -(module combinator scheme/base - - (require scheme/unit - scheme/list - (only-in (lib "etc.ss") opt-lambda)) - - (require "structs.scm" - "parser-sigs.ss" - parser-tools/lex) - - (provide (all-defined-out)) - - (define-unit combinators@ - (import error-format-parameters^ ranking-parameters^ language-dictionary^) - (export combinator-parser-forms^) - - (define return-name "dummy") - (define terminal-occurs "unique-eq") - - (define (make-weak-map) (make-weak-hasheq)) -  - (define (weak-map-put! m k v) - (hash-set! m k (make-ephemeron k (box v)))) -  - (define weak-map-get - (opt-lambda (m k [def-v (lambda () (error 'weak-map-get "value unset"))]) - (let ([v (hash-ref m k #f)]) - (if v - (let ([v (ephemeron-value v)]) - (if v - (unbox v) - def-v)) - def-v)))) - - ;terminal: ('a -> bool 'a -> 'b string) -> ( (list 'a) -> res ) - (define terminal - (opt-lambda (pred build name [spell? #f] [case? #f] [class? #f]) - (let* ([memo-table (make-weak-map)] - [fail-str (string-append "failed " name)] - [t-name (if src? (lambda (t) (token-name (position-token-token t))) token-name)] - [t-val (if src? (lambda (t) (token-value (position-token-token t))) token-value)] - [spell? (or spell? - (lambda (token) - (if (t-val token) (misspelled name (t-val token)) 0)))] - [case? (or case? - (lambda (token) - (and (t-val token) (misscap name (t-val token)))))] - [class? (or class? (lambda (token) (missclass name (t-name token))))] - [make-fail - (lambda (c n k i u) - (make-terminal-fail c (if (and src? i) - (make-src-lst (position-token-start-pos i) - (position-token-end-pos i)) - null) - n 0 u k (if src? (position-token-token i) i)))] - [value (lambda (t) (or (t-val t) name))] - [builder - (if src? - (lambda (token) (build (position-token-token token) - (position-token-start-pos token) - (position-token-end-pos token))) - build)]) - - (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) - #;(printf "terminal ~a\n" name) - #;(cond - [(eq? input return-name) (printf "name requested\n")] - [(null? input) (printf "null input\n")] - [else - (let ([token (position-token-token (car input))]) - (printf "Token given ~a, match? ~a\n" token (pred token)))]) - (cond - [(eq? input return-name) name] - [(eq? input terminal-occurs) (list (make-occurs name 1))] - [(weak-map-get memo-table input #f) (weak-map-get memo-table input)] - [else - (let ([result - (cond - [(null? input) - (fail-res null (make-terminal-fail rank-end last-src name 0 0 'end #f))] - [else - (let* ([curr-input (car input)] - [token (if src? (position-token-token curr-input) curr-input)]) - (cond - [(pred token) - (make-res (list (builder curr-input)) - (cdr input) name - (value curr-input) 1 #f curr-input)] - [else - #;(printf "Incorrect input for ~a : ~a miscase? ~a misspell? ~a \n" name - (cond - [(token-value token) (token-value token)] - [else (token-name token)]) - (case? curr-input) - (spell? curr-input)) - (fail-res (cdr input) - (let-values ([(chance kind may-use) - (cond - [(case? curr-input) (values rank-caps 'misscase 1)] - [(> (spell? curr-input) 3/5) - (values (* rank-misspell - (spell? curr-input)) 'misspell 1)] - [(class? curr-input) (values rank-class 'missclass 1)] - [else (values rank-wrong 'wrong 0)])]) - (make-fail chance name kind curr-input may-use)))]))])]) - (weak-map-put! memo-table input result) - result)]))))) - - ;seq: ( (list ((list 'a) -> res)) ((list 'b) -> 'c) string -> ((list 'a) -> result) - (define seq - (opt-lambda (sub-list build name [id-position 0]) - (let* ([sequence-length (length sub-list)] - [memo-table (make-weak-map)] - [terminal-counts #f] - [prev (lambda (x) - (cond [(eq? x return-name) "default previous"] - [else (fail-res null null)]))] - [builder - (lambda (r) - (cond - [(res? r) - (make-res (list (build (res-a r))) - (res-rest r) - name (res-id r) (res-used r) - (res-possible-error r) - (res-first-tok r))] - [(and (repeat-res? r) (res? repeat-res-a r)) - (make-res (list (build (res-a (repeat-res-a r)))) - (res-rest (repeat-res-a r)) - name (res-id (repeat-res-a r)) - (res-used (repeat-res-a r)) - (repeat-res-stop r) - (res-first-tok (repeat-res-a r)))] - [else (error 'parser-internal-error1 (format "~a" r))]))] - [my-error (sequence-error-gen name sequence-length)] - [my-walker (seq-walker id-position name my-error)]) - (opt-lambda (input [last-src (list 1 0 1 0)] [alts 1]) - #;(unless (eq? input return-name) (printf "seq ~a\n" name)) - (cond - [(eq? input return-name) name] - [(eq? input terminal-occurs) - (or terminal-counts - (begin - (set! terminal-counts 'counting) - (set! terminal-counts - (consolidate-count (map (lambda (symbol) (symbol terminal-occurs)) sub-list))) - terminal-counts))] - [(weak-map-get memo-table input #f) - (weak-map-get memo-table input)] - [(null? sub-list) - (builder (make-res null input name #f 0 #f #f))] - [else - (let* ([pre-build-ans (my-walker sub-list input prev #f #f #f null 0 alts last-src)] - [ans - (cond - [(and (res? pre-build-ans) (res-a pre-build-ans)) (builder pre-build-ans)] - [(and (pair? pre-build-ans) (null? (cdr pre-build-ans))) (builder (car pre-build-ans))] - [(pair? pre-build-ans) (map builder pre-build-ans)] - [else pre-build-ans])]) - (weak-map-put! memo-table input ans) - #;(printf "sequence ~a returning \n" name) - #;(printf "answer is ~a \n" ans) - ans)]))))) - - ;seq-walker: int string error-gen -> [(list parser) (list alpha) parser result (U bool string) (list string) int int -> result - (define (seq-walker id-position seq-name build-error) - (letrec ([next-res - (lambda (a id used tok rst) - (cond - [(res? rst) - (make-res (append a (res-a rst)) (res-rest rst) - seq-name (or id (res-id rst)) - (+ used (res-used rst)) (res-possible-error rst) tok)] - [(and (repeat-res? rst) (res? (repeat-res-a rst))) - (make-res (append a (res-a (repeat-res-a rst))) - (res-rest (repeat-res-a rst)) seq-name - (or id (res-id (repeat-res-a rst))) - (+ used (res-used (repeat-res-a rst))) - (repeat-res-stop rst) tok)] - [else (error 'parser-internal-error2 (format "~a" rst))] - ))] - [walker - (lambda (subs input previous? look-back look-back-ref curr-id seen used alts last-src) - (let* ([next-preds (cdr subs)] - [curr-pred (car subs)] - [id-spot? (= id-position (add1 (length seen)))] - [next-call - (lambda (old-result curr curr-ref curr-name new-id tok alts) - (cond - [(res? old-result) - (let* ([old-answer (res-a old-result)] - [rest (res-rest old-result)] - [old-used (res-used old-result)] - [rsts (walker next-preds rest curr-pred curr curr-ref - (or new-id curr-id) (cons curr-name seen) - (+ old-used used) alts - (if (and src? (res-first-tok old-result)) - (make-src-lst (position-token-start-pos (res-first-tok old-result)) - (position-token-end-pos (res-first-tok old-result))) - last-src))]) - #;(printf "next-call ~a ~a: ~a ~a ~a ~a\n" - seq-name (length seen) old-result (res? rsts) - (and (res? rsts) (res-a rsts)) - (and (res? rsts) (choice-fail? (res-possible-error rsts)))) - (cond - [(and (res? rsts) (res-a rsts)) - (next-res old-answer new-id old-used tok rsts)] - [(res? rsts) (fail-res rest (res-msg rsts))] - [(and (lazy-opts? rsts) (null? (lazy-opts-thunks rsts))) - (make-lazy-opts - (map (lambda (rst) (next-res old-answer new-id old-used tok rst)) - (lazy-opts-matches rsts)) - (make-options-fail 0 #f #f 0 0 null) null)] - [(and (lazy-opts? rsts) (not (lazy-choice? rsts))) - (make-lazy-opts - (map (lambda (rst) (next-res old-answer new-id old-used tok rst)) - (lazy-opts-matches rsts)) - (lazy-opts-errors rsts) - (map (lambda (thunk) - (lambda () - (let ([ans (next-opt rsts)]) - (and ans (next-res old-answer new-id old-used tok ans))))) - (lazy-opts-thunks rsts)))] - [(lazy-choice? rsts) - (make-lazy-choice - (map (lambda (rst) (next-res old-answer new-id old-used tok rst)) - (lazy-opts-matches rsts)) - (lazy-opts-errors rsts) - (map (lambda (thunk) - (lambda () - (let ([ans (next-opt rsts)]) - (and ans (next-res old-answer new-id old-used tok ans))))) - (lazy-opts-thunks rsts)) - (lazy-choice-name rsts))] - [(pair? rsts) - (map (lambda (rst) (next-res old-answer new-id old-used tok rst)) - (flatten (correct-list rsts)))] - [(choice-res? rsts) - #;(printf "next call, tail-end is choice ~a\n" rsts) - (map (lambda (rst) (next-res old-answer new-id old-used tok - (update-possible-fail rst rsts))) - (flatten (correct-list (choice-res-matches rsts))))] - [(repeat-res? rsts) - (next-res old-answer new-id old-used tok rsts)] - [else (error 'parser-internal-error3 (format "~a" rsts))]))] - [else (error 'parser-internal-error11 (format "~a" old-result))]))]) - (cond - [(null? subs) (error 'end-of-subs)] - [(null? next-preds) - #;(printf "seq-walker called: last case, ~a case of ~a \n" - seq-name (curr-pred return-name)) - (build-error (curr-pred input last-src) - (lambda () (previous? input)) - (previous? return-name) #f - look-back look-back-ref used curr-id seen alts last-src)] - [else - #;(printf "seq-walker called: else case, ~a case of ~a ~ath case \n" - seq-name (curr-pred return-name) (length seen)) - (let ([fst (curr-pred input last-src)]) - (cond - [(res? fst) - #;(printf "res case ~a ~a\n" seq-name (length seen)) - (cond - [(res-a fst) (next-call fst fst fst (res-msg fst) - (and id-spot? (res-id fst)) - (res-first-tok fst) alts)] - [else - #;(printf "error situation ~a ~a\n" seq-name (length seen)) - (build-error fst (lambda () (previous? input)) - (previous? return-name) - (car next-preds) look-back look-back-ref used curr-id - seen alts last-src)])] - [(repeat-res? fst) - #;(printf "repeat-res: ~a ~a\n" seq-name (length seen)) - #;(printf "res? ~a\n" (res? (repeat-res-a fst))) - (next-call (repeat-res-a fst) fst fst - (res-msg (repeat-res-a fst)) #f - (res-first-tok (repeat-res-a fst)) alts)] - [(lazy-opts? fst) - #;(printf "lazy res: ~a ~a ~a\n" fst seq-name (length seen)) - (let* ([opt-r (make-lazy-opts null - (make-options-fail 0 last-src seq-name 0 0 null) - null)] - [name (if (lazy-choice? fst) (lazy-choice-name fst) seq-name)] - [next-c (lambda (res) - (cond - [(res? res) - #;(printf "lazy-choice-res, res ~a ~a\n" seq-name (length seen)) - (next-call res fst res name (and id-spot? (res-id res)) - (res-first-tok res) alts)] - [(repeat-res? res) - #;(printf "lazy- choice-res, repeat-res ~a ~a ~a\n" - (res? (repeat-res-a res)) seq-name (length seen)) - (next-call (repeat-res-a res) res (repeat-res-a res) - (res-msg (repeat-res-a res)) #f - (res-first-tok (repeat-res-a res)) - alts)] - [else (error 'parser-internal-errora (format "~a" res))]))] - [parsed-options (map (lambda (res) (lambda () (next-c res))) - (lazy-opts-matches fst))] - [unparsed-options - (map - (lambda (thunked) - (lambda () - (let ([res (next-opt fst)]) - (if res - (next-c res) - (begin (set-lazy-opts-thunks! opt-r null) #f))))) - (lazy-opts-thunks fst))]) - (set-lazy-opts-thunks! opt-r (append parsed-options unparsed-options)) - (if (next-opt opt-r) - opt-r - (fail-res input (lazy-opts-errors opt-r)))) - ] - [(or (choice-res? fst) (pair? fst)) - #;(printf "choice-res: ~a ~a ~a\n" fst seq-name (length seen)) - (let*-values - ([(lst name curr) - (cond - [(choice-res? fst) - (values (choice-res-matches fst) - (lambda (_) (choice-res-name fst)) - (lambda (_) fst))] - [else (values fst res-msg (lambda (x) x))])] - [(new-alts) (+ alts (length lst))] - [(rsts) - (map (lambda (res) - (cond - [(res? res) - #;(printf "choice-res, res ~a ~a\n" seq-name (length seen)) - (next-call res (curr res) res (name res) - (and id-spot? (res-id res)) - (res-first-tok res) new-alts)] - [(repeat-res? res) - #;(printf "choice-res, repeat-res ~a ~a ~a\n" - (res? (repeat-res-a res)) seq-name (length seen)) - (next-call (repeat-res-a res) res (repeat-res-a res) - (res-msg (repeat-res-a res)) #f - (res-first-tok (repeat-res-a res)) - new-alts)] - [else (error 'parser-internal-error4 (format "~a" res))])) - (flatten lst))] - [(correct-rsts) (flatten (correct-list rsts))]) - #;(printf "case ~a ~a, choice case: intermediate results are ~a\n" - seq-name (length seen) lst) - (cond - [(and (null? correct-rsts) (or (not (lazy-choice? fst)) - (null? (lazy-opts-thunks fst)))) - #;(printf "correct-rsts null for ~a ~a \n" seq-name (length seen)) - (let ([fails - (map - (lambda (rst) - (res-msg - (build-error rst (lambda () (previous? input)) (previous? return-name) - (car next-preds) look-back look-back-ref used curr-id seen alts last-src))) - rsts)]) - (fail-res input - (make-options-fail - (rank-choice (map fail-type-chance fails)) - (if (equal? last-src (list 1 0 1 0)) - (map fail-type-src fails) - last-src) - seq-name - (rank-choice (map fail-type-used fails)) - (rank-choice (map fail-type-may-use fails)) fails)))] - [(and (null? correct-rsts) (lazy-choice? fst) (not (null? (lazy-opts-thunks fst)))) - (let loop ([next-res (next-opt fst)]) - (when next-res (loop (next-opt fst))))] - [else correct-rsts]))] - [else (error 'here3 (format "~a" fst))]))])))]) - walker)) - - ;get-fail-info: fail-type -> (values symbol 'a 'b) - (define (get-fail-info fail) - (cond - [(terminal-fail? fail) - (values (terminal-fail-kind fail) - (fail-type-name fail) - (terminal-fail-found fail))] - [(sequence-fail? fail) - (values 'sub-seq (sequence-fail-expected fail) fail)] - [(choice-fail? fail) (values 'choice null fail)] - [(options-fail? fail) (values 'options null fail)] - [else (error 'parser-internal-error5 (format "~a" fail))])) - - ;update-src: symbol src-list src-list token -> src-list - (define (update-src error-kind src prev-src tok) - (and src? - (case error-kind - [(choice options) prev-src] - [(sub-seq misscase misspell end) src] - [(missclass wrong) - (if tok - (update-src-start src (position-token-start-pos tok)) - src)]))) - - ;build-options-fail: name (list-of fail-type) -> fail-type - (define (build-options-fail name fails) - (make-options-fail (rank-choice (map fail-type-chance fails)) - #f - name - (rank-choice (map fail-type-used fails)) - (rank-choice (map fail-type-may-use fails)) - fails)) - - (define (add-to-choice-fails choice fail) - (let ([fails (choice-fail-messages choice)]) - (make-choice-fail - (rank-choice (cons (fail-type-chance fail) (map fail-type-chance fails))) - (fail-type-src choice) - (fail-type-name choice) - (rank-choice (cons (fail-type-used fail) (map fail-type-used fails))) - (rank-choice (cons (fail-type-may-use fail) (map fail-type-may-use fails))) - (choice-fail-options choice) - (choice-fail-names choice) - (choice-fail-ended? choice) - (cons fail fails)))) - - ;update-possible-rail result result -> result - (define (update-possible-fail res back) - #;(printf "update-possible-fail ~a, ~a\n" res back) - (cond - [(and (res? res) (not (res-possible-error res))) - (cond - [(res? back) - (make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res) - (res-possible-error back) (res-first-tok res))] - [(choice-res? back) - (make-res (res-a res) (res-rest res) (res-msg res) (res-id res) (res-used res) - (choice-res-errors back) (res-first-tok res))] - [else res])] - [(choice-res? res) - (cond - [(and (choice-res? back) (choice-res-errors back) (choice-res-errors res)) - (make-choice-res (choice-res-name res) - (choice-res-matches res) - (add-to-choice-fails (choice-res-errors res) - (choice-res-errors back)))] - - [else res])] - [else res])) - - ;build-sequence-error: result boolean result string int [U #f string] [listof string] int int -> result - (define (sequence-error-gen name len) - (letrec ([repeat->res - (lambda (rpt back) - (cond - [(pair? rpt) (map (lambda (r) (repeat->res r back)) (flatten rpt))] - [(and (repeat-res? rpt) (res? (repeat-res-a rpt))) - (let ([inn (repeat-res-a rpt)] - [stop (repeat-res-stop rpt)]) - #;(printf "in repeat->res for ~a\n" name) - #;(when (fail-type? stop) - (printf "stoped on ~a\n" (fail-type-name stop))) - #;(printf "stop ~a\n" stop) - #;(when (choice-res? back) - (printf "back on ~a\n" (choice-res-name back))) - #;(when (choice-res? back) (printf "choice-res-errors back ~a\n" - (choice-res-errors back))) - #;(when (and (fail-type? stop) - (choice-res? back) - (choice-res-errors back)) - (printf "chances ~a > ~a -> ~a \n" - (fail-type-chance (choice-res-errors back)) - (fail-type-chance stop) - (>= (fail-type-chance (choice-res-errors back)) - (fail-type-chance stop)))) - (cond - [(fail-type? stop) - (make-res (res-a inn) (res-rest inn) (res-msg inn) (res-id inn) (res-used inn) - stop - #;(if (and (zero? (res-used inn)) - (choice-res? back) (choice-res-errors back) - (>= (fail-type-chance (choice-res-errors back)) - (fail-type-chance stop))) - (build-options-fail name - (list (choice-res-errors back) - stop)) - stop) - (res-first-tok inn))] - [else inn]))] - [else rpt]))] - ) - (lambda (old-res prev prev-name next-pred look-back look-back-ref used id seen alts last-src) - (cond - [(and (pair? old-res) (null? (cdr old-res)) (res? (car old-res))) - (update-possible-fail (car old-res) look-back)] - [(and (pair? old-res) (null? (cdr old-res)) (repeat-res? (car old-res))) - (repeat->res (car old-res) look-back)] - [(or (and (res? old-res) (res-a old-res)) (choice-res? old-res) (lazy-opts? old-res)) - (update-possible-fail old-res look-back)] - [(repeat-res? old-res) - #;(printf "finished on repeat-res for ~a res \n" name #;old-res) - (repeat->res old-res look-back)] - [(pair? old-res) - #;(printf "finished on pairs of res for ~a\n" name #;old-res) - (map (lambda (r) (repeat->res r look-back)) (flatten old-res))] - [else - #;(printf "There was an error for ~a\n" name) - #;(printf "length seen ~a length rest ~a\n" (length seen) (length (res-rest old-res))) - (fail-res (res-rest old-res) - (let*-values ([(fail) (res-msg old-res)] - [(possible-fail) - (cond - [(and (repeat-res? look-back) - (fail-type? (repeat-res-stop look-back)) - (>= (fail-type-chance (repeat-res-stop look-back)) - (fail-type-chance fail))) - (repeat-res-stop look-back)] - [(and (choice-res? look-back) - (choice-res-errors look-back) - (>= (fail-type-chance (choice-res-errors look-back)) - (fail-type-chance fail))) - (choice-res-errors look-back)] - [(and (res? look-back) - (fail-type? (res-possible-error look-back)) - (>= (fail-type-chance (res-possible-error look-back)) - (fail-type-chance fail))) - (res-possible-error look-back)] - [else #f])] - [(next-ok?) - (and (= (fail-type-may-use fail) 1) - (not (null? (res-rest old-res))) - next-pred - (next-pred (cdr (res-rest old-res))))] - [(next-used) - (if (and next-ok? (res? next-ok?) (res-a next-ok?)) - (res-used next-ok?) - 0)] - [(kind expected found) (get-fail-info fail)] - [(new-src) (update-src kind - (fail-type-src fail) - last-src - (res-first-tok old-res))] - [(seen-len) (length seen)] - [(updated-len) (+ (- used seen-len) len)]) - #;(printf "sequence ~a failed.\n seen ~a\n" name (reverse seen)) - #;(when (repeat-res? look-back) - (printf "look-back repeat-res ~a : ~a vs ~a : ~a > ~a\n" - (fail-type? (repeat-res-stop look-back)) - (and (fail-type? (repeat-res-stop look-back)) (fail-type-name (repeat-res-stop look-back))) - (fail-type-name (res-msg old-res)) - (and (fail-type? (repeat-res-stop look-back)) (fail-type-chance (repeat-res-stop look-back))) - (fail-type-chance (res-msg old-res)))) - #;(when (choice-res? look-back) - (printf "look-back choice: ~a vs ~a : ~a > ~a\n" - (choice-res-name look-back) - (fail-type-name (res-msg old-res)) - (and (choice-res-errors look-back) - (fail-type-chance (choice-res-errors look-back))) - (fail-type-chance (res-msg old-res))) - (printf "look-back choice and useds: ~a vs ~a -- ~a \n" - used (and (res? look-back-ref) (res-used look-back-ref)) - (and (choice-res-errors look-back) - (fail-type-used (choice-res-errors look-back))))) - #;(when (pair? look-back) - (printf "look-back is a pair\n")) - #;(when (res? look-back) - (printf "look-back res ~a : ~a vs ~a : ~a > ~a\n" - (fail-type? (res-possible-error look-back)) - (and (fail-type? (res-possible-error look-back)) (fail-type-name (res-possible-error look-back))) - (fail-type-name (res-msg old-res)) - (and (fail-type? (res-possible-error look-back)) (fail-type-chance (res-possible-error look-back))) - (fail-type-chance (res-msg old-res))) - (printf "lookback ~a\n" (res-possible-error look-back))) - (let* ([seq-fail-maker - (lambda (fail used) - (let-values ([(kind expected found) (get-fail-info fail)]) - (make-sequence-fail - (compute-chance len seen-len used alts - (fail-type-may-use fail) - (fail-type-chance fail)) - (fail-type-src fail) - name used - (+ used (fail-type-may-use fail) next-used) - id kind (reverse seen) expected found - prev - prev-name)))] - [seq-fail (seq-fail-maker fail used)] - [pos-fail - (and possible-fail - (seq-fail-maker possible-fail - (if (and (choice-res? look-back) - (res? look-back-ref)) - (- used (res-used look-back-ref)) used)))] - [opt-fails (list seq-fail pos-fail)]) - #;(printf "pos-fail? ~a\n" (and pos-fail #t)) - #;(printf "seq-fail ~a\n" seq-fail) - #;(when pos-fail - (printf "used ~a look-back-ref used ~a \n" - used (when (res? look-back-ref) (res-used look-back-ref))) - (printf "opt-fails ~a\n" opt-fails)) - (if pos-fail - (make-options-fail (rank-choice (map fail-type-chance opt-fails)) - (map fail-type-src opt-fails) - name - (rank-choice (map fail-type-used opt-fails)) - (rank-choice (map fail-type-may-use opt-fails)) - opt-fails) - seq-fail))))])))) - - (define (compute-chance expected-length seen-length used-toks num-alts may-use sub-chance) - (let* ([revised-expectation (+ (- used-toks seen-length) expected-length)] - [possible-expectation (+ revised-expectation (max 0 (sub1 may-use)))] - #;[probability-with-sub (* (/ (+ may-use used-toks) possible-expectation) (/ 1 num-alts))] - [probability-with-sub (* (/ (add1 used-toks) revised-expectation) (/ 1 num-alts))] - [probability-without-sub (* (/ used-toks revised-expectation) (/ 1 num-alts))] - [expected-sub probability-with-sub] - [expected-no-sub probability-without-sub] - [probability (/ (* expected-sub sub-chance) (+ (* expected-sub sub-chance) - (* expected-no-sub (- 1 sub-chance))))]) - - #;(when (zero? used-toks) - (printf "compute-chance 0 case: ~a, ~a, ~a, ~a -> ~a\n" - sub-chance expected-length num-alts may-use - (* (/ 1 num-alts) sub-chance))) - (cond - #;[(zero? used-toks) (* (/ 1 num-alts) sub-chance)] - [(zero? used-toks) sub-chance #;probability-with-sub] - [else - #;(printf "compute-chance: args ~a ~a ~a ~a ~a ~a\n" - expected-length seen-length used-toks num-alts may-use sub-chance) - #;(printf "compute-chance: intermediate values: ~a ~a ~a ~a ~a ~a\n" - revised-expectation possible-expectation probability-with-sub probability-without-sub expected-sub expected-no-sub) - #;(printf "compute-chance answer ~a\n" probability) - probability]))) - - ;greedy-repeat: (list 'a) -> result -> (list 'a) -> result - (define (repeat-greedy sub) - (letrec ([repeat-name (lambda () (string-append "any number of " (sub return-name)))] - [memo-table (make-weak-map)] - [inner-memo-table (make-weak-map)] - [process-rest - (lambda (curr-ans rest-ans) - (cond - [(repeat-res? rest-ans) - #;(printf "building up the repeat answer for ~a\n" repeat-name) - (cond - [(res? curr-ans) - (let* ([a (res-a curr-ans)] - [rest (repeat-res-a rest-ans)] - [repeat-build - (lambda (r) - (cond - [(res? r) - #;(printf "rest is a res for ~a, res-a is ~a \n" a repeat-name) - (make-repeat-res - (make-res (append a (res-a r)) (res-rest r) (repeat-name) #f - (+ (res-used curr-ans) (res-used r)) - #f (res-first-tok r)) - (repeat-res-stop rest-ans))] - [else - (error 'parser-internal-error9 (format "~a" r))]))]) - (cond - [(and (pair? rest) (null? (cdr rest))) - #;(printf "rest is a one-element list for ~a\n" repeat-name) - (repeat-build (car rest))] - [(pair? rest) - #;(printf "rest is a pair for ~a ~a\n" repeat-name (length rest)) - (map repeat-build (flatten rest))] - [else (repeat-build rest)]))] - [else (error 'parser-internal-error12 (format "~a" curr-ans))])] - [(pair? rest-ans) - (map (lambda (r) (process-rest curr-ans r)) (flatten rest-ans))] - [else (error 'parser-internal-error10 (format "~a" rest-ans))]))] - [update-src - (lambda (input prev-src) - (cond - [(null? input) prev-src] - [src? (src-list (position-token-start-pos (car input)) - (position-token-end-pos (car input)))] - [else prev-src]))]) - (opt-lambda (input [start-src (list 1 0 1 0)] [alts 1]) - (cond - [(eq? input return-name) (repeat-name)] - [(eq? input terminal-occurs) (sub terminal-occurs)] - [(weak-map-get memo-table input #f)(weak-map-get memo-table input)] - [else - (let ([ans - (let loop ([curr-input input] [curr-src start-src]) - #;(printf "length of curr-input for ~a ~a\n" repeat-name (length curr-input)) - #;(printf "curr-input ~a\n" (map position-token-token curr-input)) - (cond - [(weak-map-get inner-memo-table curr-input #f)(weak-map-get inner-memo-table curr-input)] - [(null? curr-input) - #;(printf "out of input for ~a\n" (repeat-name)) - (make-repeat-res (make-res null null (repeat-name) "" 0 #f #f) 'out-of-input)] - [else - (let ([this-res (sub curr-input curr-src)]) - #;(printf "Repeat of ~a called it's repeated entity \n" (repeat-name)) - (cond - [(and (res? this-res) (res-a this-res)) - #;(printf "loop again case for ~a\n" (repeat-name)) - (process-rest this-res - (loop (res-rest this-res) - (update-src (res-rest this-res) curr-src)))] - [(res? this-res) - #;(printf "fail for error case of ~a: ~a ~a\n" - repeat-name - (cond - [(choice-fail? (res-msg this-res)) 'choice] - [(sequence-fail? (res-msg this-res)) 'seq] - [(options-fail? (res-msg this-res)) 'options] - [else 'terminal]) - (fail-type-chance (res-msg this-res))) - (let ([fail (make-repeat-res (make-res null curr-input (repeat-name) "" 0 #f #f) - (res-msg this-res))]) - (weak-map-put! inner-memo-table curr-input fail) - fail)] - [(repeat-res? this-res) - #;(printf "repeat-res case of ~a\n" repeat-name) - (process-rest (repeat-res-a this-res) - (res-rest (repeat-res-a this-res)))] - [(lazy-opts? this-res) - (let ([process (lambda (res) - (cond [(res? res) - (process-rest res (loop (res-rest res) (update-src (res-rest res) curr-src)))] - [(repeat-res? res) - (process-rest (repeat-res-a res) (res-rest (repeat-res-a res)))] - [else (error 'repeat-greedy-loop (format "Internal error, given ~a" res))]))]) - (update-lazy-opts this-res - (map process (lazy-opts-matches this-res)) - (map (lambda (t) - (lambda () - (let ([next-res (next-opt this-res)]) - (and next-res (process next-res))))) - (lazy-opts-thunks this-res))))] - [(or (choice-res? this-res) (pair? this-res)) - (let ([list-of-answer - (if (choice-res? this-res) (choice-res-matches this-res) (flatten this-res))]) - #;(printf "repeat call of ~a, choice-res ~a\n" - repeat-name - (and (choice-res? this-res) - (length list-of-answer))) - (cond - [(null? (cdr list-of-answer)) - (process-rest (car list-of-answer) - (loop (res-rest (car list-of-answer)) - (update-src (res-rest (car list-of-answer)) - curr-src)))] - [else - (map (lambda (match) - #;(printf "calling repeat loop again ~a, res-rest match ~a\n" - (repeat-name) (length (res-rest match))) - (process-rest match - (loop (res-rest match) - (update-src (res-rest match) curr-src)))) - list-of-answer)]))] - [else (error 'internal-parser-error8 (format "~a" this-res))]))]))]) - (weak-map-put! memo-table input ans) - #;(printf "repeat of ~a ended with ans \n" repeat-name #;ans) - ans)])))) - - ;choice: [list [[list 'a ] -> result]] name -> result - (define (choice opt-list name) - (let ([memo-table (make-weak-map)] - [terminal-counts #f] - [num-choices (length opt-list)] - [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) - (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) - #;(unless (eq? input return-name) (printf "choice ~a\n" name)) - #;(printf "possible options are ~a\n" (choice-names)) - (let ([sub-opts (sub1 (+ alts num-choices))]) - (cond - [(eq? input return-name) name] - [(eq? input terminal-occurs) - (or terminal-counts - (begin - (set! terminal-counts 'counting) - (set! terminal-counts - (consolidate-count (map (lambda (symbol) (symbol terminal-occurs)) opt-list))) - terminal-counts))] - [(weak-map-get memo-table input #f) (weak-map-get memo-table input)] - [else - #;(printf "choice ~a\n" name) - #;(printf "possible options are ~a\n" (choice-names)) - (let*-values - ([(options) (map (lambda (term) (term input last-src sub-opts)) opt-list)] - #;[a (printf "choice-options ~a \n ~a \n\n\n" choice-names options)] - [(fails) (map (lambda (x) - (cond - [(res? x) (res-msg x)] - [(repeat-res? x) (res-msg (repeat-res-a x))] - [(choice-res? x) (choice-res-errors x)] - [else (error 'here-non-res x)])) - (flatten options))] - [(corrects errors) (split-list options)] - [(fail-builder) - (lambda (fails) - (if (null? fails) - #f - (make-choice-fail (rank-choice (map fail-type-chance fails)) - (if (or (null? input) - (not (position-token? (car input)))) - last-src - (update-src-end - last-src - (position-token-end-pos (car input)))) - name - (rank-choice (map fail-type-used fails)) - (rank-choice (map fail-type-may-use fails)) - num-choices (choice-names) - (null? input) - fails)))] - [(ans) - (cond - [(null? corrects) (fail-res input (fail-builder fails))] - [else (make-choice-res name corrects (fail-builder errors))])]) - #;(printf "choice ~a is returning options were ~a \n" name (choice-names)) - #;(printf "corrects were ~a\n" corrects) - #;(printf "errors were ~a\n" errors) - (weak-map-put! memo-table input ans) ans)]))))) - - ;choice: [list [[list 'a ] -> result]] name -> result - (define (choice2 opt-list name) - (let ([memo-table (make-weak-map)] - [num-choices (length opt-list)] - [choice-names (lambda () (map (lambda (o) (o return-name)) opt-list))]) - (opt-lambda (input [last-src (list 0 0 0 0)] [alts 1]) - #;(unless (eq? input return-name) (printf "choice ~a\n" name)) - #;(printf "possible options are ~a\n" choice-names) - (let ([sub-opts (sub1 (+ alts num-choices))]) - (cond - [(weak-map-get memo-table input #f) (weak-map-get memo-table input)] - [(eq? input return-name) name] - [else - (let* ([options (map (lambda (term) (lambda () (term input last-src sub-opts))) opt-list)] - [initial-fail (make-choice-fail 0 - (if (or (null? input) (not (position-token? (car input)))) - last-src - (update-src-end last-src - (position-token-end-pos (car input)))) - name - 0 - 0 - num-choices - (choice-names) - (null? input) - null)] - [initial-ans (make-lazy-choice null initial-fail options name)] - [ans - (if (next-opt initial-ans) - initial-ans - (fail-res input (lazy-opts-errors initial-ans)))]) - #;(printf "choice ~a is returning options were ~a, answer is ~a \n" name (choice-names) ans) - (weak-map-put! memo-table input ans) ans)]))))) - - (define (flatten lst) - (cond - [(pair? lst) - (cond - [(pair? (car lst)) - (append (flatten (car lst)) - (flatten (cdr lst)))] - [else (cons (car lst) (flatten (cdr lst)))])] - [else null])) - - ;correct-list: (list result) -> (list result) - (define (correct-list subs) - (cond - [(pair? subs) - (cond - [(and (res? (car subs)) (res-a (car subs))) - (cons (car subs) (correct-list (cdr subs)))] - [(choice-res? (car subs)) - (append (choice-res-matches (car subs)) (correct-list (cdr subs)))] - [(repeat-res? (car subs)) - (cons (repeat-res-a (car subs)) (correct-list (cdr subs)))] - [(pair? (car subs)) - (append (car subs) (correct-list (cdr subs)))] - [else (correct-list (cdr subs))])] - [(null? subs) null] - [else (error 'parser-internal-error6 (format "~a" subs))])) - - (define (split-list subs) - (let loop ([in subs] [correct null] [incorrect null]) - (cond - [(pair? in) - (cond - [(and (res? (car in)) (res-a (car in))) - (loop (cdr in) (cons (car in) correct) incorrect)] - [(choice-res? (car in)) - (loop (cdr in) - (append (choice-res-matches (car in)) correct) - (if (choice-res-errors (car in)) - (cons (choice-res-errors (car in)) incorrect) - incorrect))] - [(repeat-res? (car in)) - (loop (cdr in) - (cons (repeat-res-a (car in)) correct) - incorrect)] - [(pair? (car in)) - (loop (cdr in) (append (car in) correct) incorrect)] - [(res? (car in)) - (loop (cdr in) correct (cons (res-msg (car in)) incorrect))] - [else (error 'split-list (car in))])] - [(null? in) - (values (flatten correct) (flatten incorrect))]))) - - (define (src-list src-s src-e) - (list (position-line src-s) - (position-col src-s) - (position-offset src-s) - (- (position-offset src-s) - (position-offset src-e)))) - - (define (update-src-start src new-start) - (list (position-line new-start) - (position-col new-start) - (position-offset new-start) - (+ (- (third src) - (position-offset new-start)) - (fourth src)))) - - (define (update-src-end src new-end) - (when (null? src) (error 'update-src-end)) - (list (max (first src) 1) - (second src) - (max (third src) 1) - (- (position-offset new-end) (third src)))) - - (define (repeat op) - (letrec ([name (lambda () (string-append "any number of " (op return-name)))] - [r* (opt-lambda (x [s (list 0 1 0 1)] [o 1]) - ((choice (list #;op - (seq (list op r*) (lambda (list-args) list-args) (name)) - (seq null (lambda (x) null) "epsilon")) - (name)) x s o))]) - r*)) - - ) - ) diff --git a/collects/combinator-parser/private-combinator/errors.scm b/collects/combinator-parser/private-combinator/errors.scm deleted file mode 100644 index 2133481439..0000000000 --- a/collects/combinator-parser/private-combinator/errors.scm +++ /dev/null @@ -1,353 +0,0 @@ -(module errors scheme/base - - (require "structs.scm" "parser-sigs.ss") - - (require scheme/unit) - - (provide (all-defined-out)) - - (define-unit error-formatting@ - (import error-format-parameters^ language-format-parameters^ out^) - (export (rename error^ (public-fail-type->message fail-type->message))) - - ;public-fail-type->message : fail-type -> err - (define (public-fail-type->message fail) - (fail-type->message fail null)) - - ;fail-type->message: fail-type (listof err) -> err - (define (fail-type->message fail-type message-to-date) - (let* ([name (fail-type-name fail-type)] - [a (a/an name)] - [msg (lambda (m) - (make-err m - (if (and (list? (fail-type-src fail-type)) - (list? (car (fail-type-src fail-type)))) - (car (fail-type-src fail-type)) - (fail-type-src fail-type))))]) - #;(printf "fail-type->message ~a\n" fail-type) - (cond - [(terminal-fail? fail-type) - (collapse-message - (add-to-message - (msg - (case (terminal-fail-kind fail-type) - [(end) (format "Expected to find ~a ~a, but ~a ended prematurely." - a name input-type)] - [(wrong) (format "Expected to find ~a ~a, but instead found ~a." - a name (input->output-name (terminal-fail-found fail-type)))] - [(misscase) (format "Expected to find ~a ~a, found ~a which may be miscapitalized." - a name (input->output-name (terminal-fail-found fail-type)))] - [(misspell) (format "Expected to find ~a ~a, found ~a which may be misspelled." - a name (input->output-name (terminal-fail-found fail-type)))] - [(missclass) (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a." - (input->output-name (terminal-fail-found fail-type)) a name class-type a name)])) - name #f message-to-date))] - [(sequence-fail? fail-type) - #;(printf "sequence-fail case: kind is ~a\n" (sequence-fail-kind fail-type)) - (let* ([curr-id (sequence-fail-id fail-type)] - [id-name - (if curr-id (string-append name " " (sequence-fail-id fail-type)) name)] - [expected (sequence-fail-expected fail-type)] - [a2 (a/an expected)] - [show-sequence (sequence-fail-correct fail-type)]) - (case (sequence-fail-kind fail-type) - [(end) - (collapse-message - (add-to-message - (msg (format "Expected ~a to contain ~a ~a to complete the ~a. \nFound ~a before ~a ended." - input-type a2 expected id-name (format-seen show-sequence) input-type)) - name curr-id message-to-date))] - [(wrong) - (collapse-message - (add-to-message - (msg - (let* ([poss-repeat ((sequence-fail-repeat? fail-type))] - [repeat? (and (res? poss-repeat) (res-a poss-repeat) (res-msg poss-repeat))]) - (cond - [repeat? - (format "Found a repitition of ~a; the required number are present. Expected ~a ~a next." - (sequence-fail-last-seen fail-type) a2 expected)] - [(null? show-sequence) - (format "Expected ~a ~a to begin this ~a, instead found ~a." - a2 expected id-name (input->output-name (sequence-fail-found fail-type)))] - [else - (format "Expected ~a ~a to continue this ~a. Instead, found ~a after ~a." - a2 expected id-name (input->output-name (sequence-fail-found fail-type)) - (format-seen show-sequence))]))) - name curr-id message-to-date))] - [(misscase) - (collapse-message - (add-to-message - (msg (format "Expected to find ~a ~a to continue this ~a, found ~a which may be miscapitalized." - a2 expected id-name (input->output-name (sequence-fail-found fail-type)))) - name curr-id message-to-date))] - [(misspell) - (collapse-message - (add-to-message - (msg (format "Expected to find ~a ~a to continue this ~a, found ~a which may be misspelled." - a2 expected id-name (input->output-name (sequence-fail-found fail-type)))) - name curr-id message-to-date))] - [(missclass) - (collapse-message - (add-to-message - (msg (format "Found ~a instead of ~a ~a, a ~a cannot be used as ~a ~a." - (input->output-name (sequence-fail-found fail-type)) a2 expected class-type a2 expected)) - name curr-id message-to-date))] - [(sub-seq choice) - (fail-type->message (sequence-fail-found fail-type) - (add-to-message (msg (format "An error occurred in ~a.\n" id-name)) - name (sequence-fail-id fail-type) message-to-date))] - [(options) - (let ([sorted-opts (sort (options-fail-opts (sequence-fail-found fail-type)) - (lambda (a b) (>= (fail-type-chance a) (fail-type-chance b))))]) - (if (null? show-sequence) - (fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts) - (add-to-message (msg (format "This ~a did not begin as expected." id-name)) - name (sequence-fail-id fail-type) message-to-date)) - (fail-type->message (sequence-fail-found fail-type) #;(car sorted-opts) - (add-to-message - (msg (format "There is an error in this ~a after ~a, the program resembles a(n) ~a here.\n" - id-name (car (reverse show-sequence)) - (fail-type-name (car sorted-opts)))) - name (sequence-fail-id fail-type) message-to-date))))]))] - [(options-fail? fail-type) - #;(printf "selecting for options on ~a\n" name) - (let* ([winners (select-errors (options-fail-opts fail-type))] - [top-names (map fail-type-name winners)] - [non-dup-tops (remove-dups top-names name)] - [top-name (car top-names)]) - (cond - [(and (> (length winners) 1) - (> (length non-dup-tops) 1) - (> (length winners) max-choice-depth)) - (collapse-message - (add-to-message - (msg (format "An error occurred in this ~a. Program resembles these: ~a.\n" - name (nice-list non-dup-tops))) - name #f message-to-date))] - [(and (> (length winners) 1) - (<= (length winners) max-choice-depth)) - (let ([messages (map (lambda (f) (fail-type->message f null)) winners)]) - (cond - [(identical-messages? messages) - (collapse-message - (add-to-message (car messages) name #f message-to-date))] - [else - (let ([msg (cond - [(apply equal? (map err-src messages)) (lambda (m) (make-err m (err-src (car messages))))] - [else msg])]) - (collapse-message - (add-to-message - (msg (format "An error occurred in the ~a. Possible errors were: \n ~a" - name - (alternate-error-list (map err-msg messages)))) - name #f message-to-date)))]))] - [else - (fail-type->message - (car winners) - (add-to-message - (msg - (format "There is an error in this ~a~a.\n" - name - (if (equal? top-name name) "" - (format ", program resembles ~a ~a" (a/an top-name) top-name)))) - name #f message-to-date))]))] - [(choice-fail? fail-type) - #;(printf "selecting for ~a\n message-to-date ~a\n" name message-to-date) - (let* ([winners (select-errors (choice-fail-messages fail-type))] - [top-names (map fail-type-name winners)] - [top-name (car top-names)] - [no-dup-names (remove-dups (choice-fail-names fail-type) name)]) - (cond - [(and (choice-fail-ended? fail-type) - (> (length winners) 1)) - (collapse-message - (add-to-message - (msg (format "Expected a ~a, possible options include ~a." name - (nice-list (first-n max-choice-depth no-dup-names)))) - name #f message-to-date))] - [(and (<= (choice-fail-options fail-type) max-choice-depth) - (> (length no-dup-names) 1) - (> (length winners) 1) - (equal? top-names no-dup-names)) - (collapse-message - (add-to-message - (msg (format "An error occurred in this ~a; expected ~a instead." - name (nice-list no-dup-names))) - name #f message-to-date))] - [(and (<= (choice-fail-options fail-type) max-choice-depth) - (> (length no-dup-names) 1) - (> (length winners) 1)) - (let ([messages (map (lambda (f) (fail-type->message f null)) winners)]) - (cond - [(identical-messages? messages) - (collapse-message - (add-to-message (car messages) #f #f - (add-to-message - (msg (format "An error occurred in this ~a, expected ~a instead." - name (nice-list no-dup-names))) - name #f message-to-date)))] - [else - (collapse-message - (add-to-message - (msg (format "An error occurred in this ~a; expected ~a instead. Possible errors were:\n~a" - name (nice-list no-dup-names) - (alternate-error-list (map err-msg messages)))) - name #f message-to-date))]))] - [(and (> (length no-dup-names) max-choice-depth) - (> (length winners) 1)) - (collapse-message - (add-to-message - (msg (format "An error occurred in this ~a. Possible options include ~a.\n" - name (nice-list - (first-n max-choice-depth no-dup-names)))) - name #f message-to-date))] - [else - (fail-type->message - (car winners) - (add-to-message - (msg (format "An error occurred in this ~a~a.~a\n" - name - (if (equal? name top-name) "" (format ", it is possible you intended ~a ~a here" - (a/an top-name) top-name)) - (if show-options " To see all options click here." ""))) - name #f message-to-date))]))]))) - - (define (chance-used a) (* (fail-type-chance a) (fail-type-used a))) - (define (chance-may-use a) (* (fail-type-chance a) (fail-type-may-use a))) - (define (chance a) (fail-type-chance a)) - (define (composite a) - (/ (+ (chance-used a) (chance-may-use a) (chance a)) 3)) - - (define (narrow-opts rank options) - (get-ties (sort options (lambda (a b) (> (rank a) (rank b)))) rank)) - - (define (select-errors opts-list) - (let* ([composite-winners - (narrow-opts composite opts-list)] - - [chance-used-winners - (narrow-opts chance-used composite-winners)] - - [chance-may-winners - (narrow-opts chance-may-use chance-used-winners)] - - [winners (narrow-opts chance chance-may-winners)]) - #;(printf "all options: ~a\n" opts-list) - #;(printf "~a ~a ~a ~a ~a\n" - (map fail-type-name opts-list) - (map fail-type-chance opts-list) - (map fail-type-used opts-list) - (map fail-type-may-use opts-list) - (map composite opts-list)) - #;(printf "composite round: ~a ~a \n" - (map fail-type-name composite-winners) - (map composite composite-winners)) - #;(printf "final sorting: ~a\n" (map fail-type-name winners)) - winners)) - - (define (first-n n lst) - (if (<= (length lst) n) - lst - (let loop ([count 0] [l lst]) - (cond - [(>= count n) null] - [else (cons (car l) (loop (add1 count) (cdr l)))])))) - - (define (get-ties lst evaluate) - (if (> (length lst) 1) - (letrec ([getter - (lambda (sub) - (cond - [(null? sub) null] - [(>= (- (evaluate (car lst)) (evaluate (car sub))) .0001) null] - [else (cons (car sub) (getter (cdr sub)))]))]) - (cons (car lst) (getter (cdr lst)))) - lst)) - - (define (a/an next-string) - (if (string? next-string) - (if (member (substring next-string 0 1) `("a" "e" "i" "o" "u")) - "an" "a") - "a")) - - (define (format-seen l) - (if (null? l) - "" - (string-append "'" - (car l) - (apply string-append - (map (lambda (i) (string-append " " i)) (cdr l))) - "'"))) - - (define (nice-list l) - (letrec ([formatter - (lambda (l) - (cond - [(null? l) ""] - [(null? (cdr l)) (string-append "or " (car l))] - [else (string-append (car l) ", " (formatter (cdr l)))]))]) - (cond - [(null? l) (error 'internal-error "nice-list in combinator-parser/errors.scm received null list")] - [(null? (cdr l)) (car l)] - [(null? (cddr l)) (string-append (car l) " or " (cadr l))] - [else (formatter l)]))) - - (define (alternate-error-list l) - (cond - [(null? l) ""] - [else - (let ([msg (if (equal? #\newline (string-ref (car l) (sub1 (string-length (car l))))) - (substring (car l) 0 (sub1 (string-length (car l)))) - (car l))]) - (string-append (format "~a~a\n" #\tab msg) - (alternate-error-list (cdr l))))])) - - (define (downcase string) - (string-append (string-downcase (substring string 0 1)) - (substring string 1 (string-length string)))) - - (define (identical-messages? msgs) - (andmap (lambda (err) (equal? (err-msg (car msgs)) - (err-msg err))) - (cdr msgs))) - - (define (remove-dups l n) - (cond - [(null? l) null] - [(equal? (car l) n) - (remove-dups (cdr l) n)] - [(member (car l) (cdr l)) - (remove-dups (cdr l) n)] - [else (cons (car l) (remove-dups (cdr l) n))])) - - (define-struct ms (who id? say)) - - ;add-to-message: err string bool (list err) -> (list err) - (define (add-to-message msg name id? rest) - (let ([next (make-ms name id? msg)] - [curr-len (length rest)]) - (cond - [(null? rest) (list next)] - [(equal? (ms-who (car rest)) name) (cons next (cdr rest))] - [(and id? (ms-id? (car rest)) (< curr-len max-depth)) (cons next rest)] - [(and id? (ms-id? (car rest))) (cons next (first-n (sub1 max-depth) rest))] - [id? (add-to-message msg name id? (cdr rest))] - [(< (length rest) max-depth) (cons next rest)] - [else (cons next (first-n (sub1 max-depth) rest))]))) - - ;combine-message: (list ms) -> err - (define (collapse-message messages) - (let loop ([end-msg (ms-say (car messages))] - [messages (cdr messages)]) - (cond - [(null? messages) end-msg] - [else - (loop - (make-err (string-append (err-msg (ms-say (car messages))) - (err-msg end-msg)) - (err-src end-msg)) - (cdr messages))]))) - - ) - ) diff --git a/collects/combinator-parser/private-combinator/parser-sigs.rkt b/collects/combinator-parser/private-combinator/parser-sigs.rkt deleted file mode 100644 index 174d5047b9..0000000000 --- a/collects/combinator-parser/private-combinator/parser-sigs.rkt +++ /dev/null @@ -1,199 +0,0 @@ -(module parser-sigs scheme - - (require (only-in mzlib/etc opt-lambda)) ; Required for expansion - (require parser-tools/lex - mzlib/string) - - (provide (all-defined-out)) - - (define-signature-form (terminals stx) - (syntax-case stx () - [(_ group (elt ...)) - (and (identifier? #'group) - (andmap identifier? (syntax->list #'(elt ...)))) - (syntax->list #`(elt ... - #,@(map (lambda (e) - (datum->syntax e - (string->symbol - (format "token-~a" (syntax-e e))))) - (syntax->list #'(elt ...)))))])) - - (define-signature-form (recurs stx) - (syntax-case stx () - [(_ id ...) - (andmap identifier? (syntax->list #'(id ...))) - (syntax->list #`(id ... - #,@(map (lambda (e) #`(define-syntaxes - (#,(datum->syntax e (string->symbol (format "~a@" (syntax-e e))))) - (values (syntax-id-rules () [_ (opt-lambda (x [s (list 0 1 0 1)] [o 1]) (#,e x s o))])))) - (syntax->list #'(id ...)))))])) - - (define-signature language-dictionary^ (misspelled misscap missclass)) - - (define-signature combinator-parser-forms^ - (terminal choice seq repeat repeat-greedy - (define-syntaxes (define-simple-terminals) - (values - (lambda (stx) - (syntax-case stx () - ((_ group elts) - (let ([name-string-thunks - (let loop ([elt-list (syntax elts)]) - (syntax-case elt-list (lambda) - [() null] - [(id . rest) - (identifier? (syntax id)) - (cons (list (syntax id) - (syntax (symbol->string (quote id))) - `(lambda (x . args) x)) - (loop (syntax rest)))] - [((id name) . rest) - (and (identifier? (syntax id)) (string? (syntax-e (syntax name)))) - (cons (list (syntax id) - (syntax name) - `(lambda (x . args) x)) - (loop (syntax rest)))] - [((id thunk) . rest) - (and (identifier? (syntax id)) (identifier? (syntax thunk))) - (cons (list (syntax id) - (syntax (symbol->string (quote id))) - (syntax thunk)) - (loop (syntax rest)))] - [((id (lambda x body ...)) . rest) - (identifier? (syntax id)) - (cons (list (syntax id) - (syntax (symbol->string (quote id))) - (syntax (lambda x body ...))) - (loop (syntax rest)))] - [((id name thunk) . rest) - (and (identifier? (syntax id)) (string? (syntax-e (syntax name)))) - (cons (list (syntax id) - (syntax name) - (syntax thunk)) - (loop (syntax rest)))]))]) - (with-syntax ([(id ...) (map car name-string-thunks)] - [(name ...) (map cadr name-string-thunks)] - [(thunk ...) (map caddr name-string-thunks)]) - (syntax - (begin - (define-empty-tokens group (id ...)) - (define id - (terminal - (lambda (token) (eq? (token-name token) (quote id))) - thunk - name)) ...))))))))) - - (define-syntaxes (define-terminals) - (values - (lambda (stx) - (syntax-case stx () - [(_ group elts) - (identifier? (syntax group)) - (let ([name-string-thunks - (let loop ([elt-list (syntax elts)]) - (syntax-case elt-list (lambda) - [() null] - [((id (lambda (arg1 ...) body ...)) . rest) - (identifier? (syntax id)) - (cons (list (syntax id) - (syntax (symbol->string (quote id))) - (syntax (lambda (arg1 ...) body ...))) - (loop (syntax rest)))] - [((id thunk) . rest) - (and (identifier? (syntax id)) (identifier? (syntax thunk))) - (cons (list (syntax id) - (syntax (symbol->string (quote id))) - (syntax thunk)) - (loop (syntax rest)))] - [((id name thunk) . rest) - (cons (list (syntax id) - (syntax name) - (syntax thunk)) - (loop (syntax rest)))]))]) - (with-syntax ([(id ...) (map car name-string-thunks)] - [(name ...) (map cadr name-string-thunks)] - [(thunk ...) (map caddr name-string-thunks)]) - (syntax - (begin - (define-tokens group (id ...)) - (define id - (terminal - (lambda (token) (eq? (token-name token) (quote id))) - (lambda (x . args) - (if (null? args) - (thunk (token-value x)) - (thunk (token-value x) (car args) (cadr args)))) - name - (lambda (token) 0) - (lambda (token) #f))) ...))))])))) - - (define-syntaxes (sequence choose ^) - (let ([insert-name - (lambda (stx name) - (let loop ([term stx] - [pos 0] - [id-pos 0] - [terms null]) - (syntax-case* term (sequence choose ^) - (lambda (a b) (eq? (syntax-e a) (syntax-e b))) - [((sequence a b) . rest) - (loop (syntax rest) (add1 pos) id-pos - (cons (quasisyntax (sequence a b #,name)) terms))] - [((choose a) . rest) - (loop (syntax rest) (add1 pos) id-pos - (cons (quasisyntax (choose a #,name)) terms))] - [((^ a) . rest) - (loop (syntax (a . rest)) - pos (add1 pos) terms)] - [(a . rest) - (loop (syntax rest) (add1 pos) id-pos (cons (syntax a) terms))] - [() (list (reverse terms) id-pos)])))]) - (values - (lambda (stx) - (syntax-case stx (^) - [(_ (term ...) proc) - (syntax - (seq (list term ...) proc (symbol->string (gensym 'seq))))] - [(_ terms proc name) - (let ([new-terms (insert-name (syntax terms) (syntax name))]) - (with-syntax (((term ...) (car new-terms)) - (id-pos (cadr new-terms))) - (syntax (seq (list term ...) proc name id-pos))))])) - (lambda (stx) - (syntax-case stx () - [(_ (term ...)) - (syntax - (choice (list term ...) (symbol->string (gensym 'choice))))] - [(_ terms name) - (with-syntax (((term ...) [car (insert-name (syntax terms) (syntax name))])) - (syntax - (choice (list term ...) name)))])) - (syntax-rules () - [(_ f) f])))) - - (define-syntaxes (eta) - (values (syntax-rules () - [(_ f) - (opt-lambda (x [s (list 0 1 0 1)] [o 1]) (f x s o))]))) - )) - - (define-signature parser^ (parser)) - (define-signature out^ ((struct err (msg src)))) - - (define-signature language-format-parameters^ (class-type input->output-name)) - - (define-signature error-format-parameters^ - (src? input-type show-options max-depth max-choice-depth)) - - (define-signature ranking-parameters^ - (rank-misspell rank-caps rank-class rank-wrong rank-end rank-choice rank-repeat)) - - (define-signature updating-rank^ - (blamed-terminal failed-last-parse)) - - (define-signature error^ (fail-type->message)) - - (define-signature combinator-parser^ extends combinator-parser-forms^ (parser)) - (define-signature err^ (err? err-msg err-src)) - - ) diff --git a/collects/combinator-parser/private-combinator/structs.scm b/collects/combinator-parser/private-combinator/structs.scm deleted file mode 100644 index 103b07ed5d..0000000000 --- a/collects/combinator-parser/private-combinator/structs.scm +++ /dev/null @@ -1,125 +0,0 @@ -(module structs scheme/base - - (provide (all-defined-out)) - - (require parser-tools/lex) - - ;fail-src: (list line col pos span loc) - - ;make-src-lst: position position -> src-list - (define (make-src-lst start end) - (list (position-line start) - (position-col start) - (position-offset start) - (- (position-offset end) - (position-offset start)))) - - ;(make-fail-type float fail-src string int int) - (define-struct fail-type (chance src name used may-use) #:transparent #:mutable) - ;(make-terminal-fail float fail-src string symbol 'a) - (define-struct (terminal-fail fail-type) (kind found)) - ;(make-sequence-fail float fail-src string symbol (list string) string 'a (-> boolean) string) - (define-struct (sequence-fail fail-type) (id kind correct expected found repeat? last-seen) #:transparent) - ;(make-choice-fail float fail-src string int (list string) (list fail-type) boolean) - (define-struct (choice-fail fail-type) (options names ended? (messages #:mutable)) #:transparent) - ;(make-options-fail float #f #f (list fail-type)) - (define-struct (options-fail fail-type) ((opts #:mutable)) #:transparent) - - ;result = res | choice-res | repeat-res | (listof (U res choice-res)) - - ;(make-res parse-build (listof 'a) (U string fail-type) (U string 'a) int) [U #f fail-type] token - (define-struct res (a rest msg id used possible-error first-tok) #:transparent) - ;make-choice-res string (listof res) fail-type) - (define-struct choice-res (name matches errors) #:transparent) - ;(make-repeat-res answer (U symbol fail-type)) - (define-struct repeat-res (a stop) #:transparent) - ;(make-lazy-opts (listof res) fail-type (listof (_ => res))) - (define-struct lazy-opts ((matches #:mutable) errors (thunks #:mutable)) #:transparent) - ;(make-lazy-choice (listof res) fail-type (listof (_ -> res)) string) - (define-struct (lazy-choice lazy-opts) (name) #:transparent) - - ;(make-count string int) - (define-struct occurs (terminal count)) - - (define (consolidate-count cts) - (cond - [(null? cts) cts] - [(eq? 'counting (car cts)) (consolidate-count cts)] - [(pair? (car cts)) (consolidate-count (append (car cts) (cdr cts)))] - [else - (let-values ([(front back) (augment-count (car cts) (cdr cts))]) - (cons front (consolidate-count back)))])) - (define (augment-count count rst) - (cond - [(null? rst) (values count rst)] - [(eq? 'counting (car rst)) (augment-count count (cdr rst))] - [(pair? (car rst)) (augment-count count (append (car rst) (cdr rst)))] - [else - (let-values ([(current back) (augment-count count (cdr rst))]) - (cond - [(equal? (occurs-terminal count) (occurs-terminal (car rst))) - (values (make-occurs (occurs-terminal count) (+ (occurs-count count) - (occurs-count current) - (occurs-count (car rst)))) - back)] - [else (values current (cons (car rst) back))]))])) - - - ;parse-build = answer | none - ;(make-answer 'b) - (define-struct answer (ast)) - (define-struct none ()) - - (define (update-lazy-errors failc mss) - (set-fail-type-chance! failc (max (fail-type-chance failc) (fail-type-chance mss))) - (set-fail-type-used! failc (max (fail-type-used failc) (fail-type-used mss))) - (set-fail-type-may-use! failc (max (fail-type-may-use failc) (fail-type-may-use mss))) - (if (choice-fail? failc) - (set-choice-fail-messages! failc (cons mss (choice-fail-messages failc))) - (set-options-fail-opts! failc (cons mss (options-fail-opts failc))))) - - - (define (next-opt lc) - (letrec ([next - (lambda (lc update-errors) - #;(printf "next-opt ~a\n" lc) - (cond - [(null? (lazy-opts-thunks lc)) #f] - [else - (let ([curr-res ((car (lazy-opts-thunks lc)))]) - (unless (null? (lazy-opts-thunks lc)) - (set-lazy-opts-thunks! lc (cdr (lazy-opts-thunks lc)))) - (cond - [(and (not curr-res) (null? (lazy-opts-thunks lc))) curr-res] - [(and (not curr-res) (not (null? (lazy-opts-thunks lc)))) (next lc update-errors)] - [(or (and (res? curr-res) (res-a curr-res)) (repeat-res? curr-res)) - (set-lazy-opts-matches! lc (cons curr-res (lazy-opts-matches lc))) - curr-res] - [(lazy-opts? curr-res) - (let* ([next-matches (map (lambda (m) (lambda () m)) (lazy-opts-matches curr-res))] - [remaining (map (lambda (t) - (lambda () - (next curr-res - (lambda (_ msg) (update-lazy-errors (lazy-opts-errors curr-res) msg))))) - (lazy-opts-thunks curr-res))]) - (set-lazy-opts-thunks! lc (append next-matches remaining (lazy-opts-thunks lc))) - (update-errors (lazy-opts-errors lc) (lazy-opts-errors curr-res)) - (next lc update-errors))] - [else - (update-errors (lazy-opts-errors lc) - (cond - [(res? curr-res) (res-msg curr-res)] - [else (error 'next (format "Internal error: failure other than res ~a" curr-res))])) - (next lc update-errors)]))]))]) - (next lc update-lazy-errors))) - - (define (update-lazy-opts old-opts matches thunks) - (cond - [(lazy-choice? old-opts) - (make-lazy-choice matches (lazy-opts-errors old-opts) thunks (lazy-choice-name old-opts))] - [(lazy-opts? old-opts) - (make-lazy-opts matches (lazy-opts-errors old-opts) thunks)])) - - (define (fail-res rst msg) (make-res #f rst msg "" 0 #f #f)) - -) diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index eb83ce0397..3165704534 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -543,9 +543,8 @@ mz-extras :+= (collects: "ffi/") (doc: "objc") ;; -------------------- preprocessor mz-extras :+= (package: "preprocessor/") (bin: "mzpp" "mztext") -;; -------------------- tex2page & slatex -plt-extras :+= (package: "tex2page") - (package: "slatex") +;; -------------------- slatex +plt-extras :+= (package: "slatex") (bin: "PDF SLaTeX") (doc+src: "slatex-wrap/") @@ -588,9 +587,6 @@ plt-extras :+= (package: "macro-debugger") ;; -------------------- lazy plt-extras :+= (package: "lazy") -;; -------------------- combinator-parser -plt-extras :+= (collects: "combinator-parser") - ;; -------------------- icons, images dr-extras :+= (collects: "icons/*.{jpg|png|gif|bmp|xbm|xpm}") dr-extras :+= (package: "images/") @@ -666,9 +662,6 @@ plt-extras :+= (- (+ (dll: "myssink") (package: "mysterx")) (cond (not win) => (src: ""))) -;; -------------------- temporary tool for converting old files -plt-extras :+= (package: "test-box-recovery") - ;; -------------------- redex plt-extras :+= (package: "redex") diff --git a/collects/meta/props b/collects/meta/props index 3dcfa108a8..8e563ca9a0 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -665,7 +665,6 @@ path/s is either such a string or a list of them. "collects/algol60" responsible (mflatt robby) "collects/at-exp" responsible (eli mflatt) "collects/browser" responsible (robby) -"collects/combinator-parser" responsible (kathyg) "collects/compiler" responsible (mflatt) "collects/compiler/commands/ctool.rkt" drdr:command-line #f "collects/compiler/commands/exe-dir.rkt" drdr:command-line #f @@ -999,7 +998,6 @@ path/s is either such a string or a list of them. "collects/teachpack/balls.ss" drdr:command-line (mzc *) "collects/teachpack/deinprogramm" responsible (sperber) "collects/teachpack/htdp/graphing.ss" drdr:command-line (mzc *) -"collects/test-box-recovery" responsible (mflatt) "collects/test-engine" responsible (kathyg) "collects/tests/algol60" responsible (mflatt robby) "collects/tests/compiler" responsible (jay) @@ -1486,7 +1484,6 @@ path/s is either such a string or a list of them. "collects/tests/xrepl/main.rkt" drdr:command-line #f "collects/tests/zo-path.rkt" responsible (mflatt) "collects/tests/zo-size.rkt" responsible (jay) -"collects/tex2page" responsible (jay) "collects/texpict" responsible (mflatt robby) "collects/texpict/face-demo.rkt" drdr:command-line (mzc *) "collects/trace" responsible (mflatt robby) @@ -1563,7 +1560,6 @@ path/s is either such a string or a list of them. "man/man1/racket.1" responsible (mflatt) "man/man1/raco.1" responsible (mflatt) "man/man1/setup-plt.1" responsible (mflatt) -"man/man1/tex2page.1" responsible (jay) "src" responsible (mflatt) "src/foreign" responsible (eli) diff --git a/collects/test-box-recovery/info.rkt b/collects/test-box-recovery/info.rkt deleted file mode 100644 index f8e813fb5d..0000000000 --- a/collects/test-box-recovery/info.rkt +++ /dev/null @@ -1,8 +0,0 @@ -#lang setup/infotab - -(define categories '(devtools)) -(define required-core-version "370") -(define tools (list '("tool.rkt"))) -(define tool-names (list "Test Box Recovery")) - -(define scribblings '(("test-box-recovery.scrbl" () (legacy)))) diff --git a/collects/test-box-recovery/test-box-recovery.scrbl b/collects/test-box-recovery/test-box-recovery.scrbl deleted file mode 100644 index ad8eb5fa57..0000000000 --- a/collects/test-box-recovery/test-box-recovery.scrbl +++ /dev/null @@ -1,19 +0,0 @@ -#lang scribble/doc -@(require scribble/manual - (for-label lang/htdp-beginner)) - -@title{Test Box Recovery Tool} - -The text-box recovery tool allows DrRacket or DrScheme v370 and later to read -programs created using v360 and earlier that include test-case boxes. - -When opened using this tool, test-case boxes are turned into -@racket[check-expect] forms. - -Test boxes plain-text tests and expected results are converted to -plain-text @racket[check-expect] forms. - -If either the test or expected-result expression contains non-text -(e.g., an image), the converted form is a comment box containing a -@racket[check-expect] form. The box should be easy to remove using the -@menuitem["Racket" "Uncomment"] menu item in DrRacket. diff --git a/collects/test-box-recovery/tool.rkt b/collects/test-box-recovery/tool.rkt deleted file mode 100644 index 3ab170c3f7..0000000000 --- a/collects/test-box-recovery/tool.rkt +++ /dev/null @@ -1,108 +0,0 @@ - -(module tool mzscheme - (require drscheme/tool - mred - mzlib/class - mzlib/unit - framework) - - (provide tool@) - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - - (define test-box-recovery-snipclass% - (class snip-class% - - (inherit reading-version) - - (define/private (strings? e) - (not (send e find-next-non-string-snip #f))) - - (define/private (extract-text e) - (regexp-replace* #rx"\r\n" (send e get-flattened-text) " ")) - - (define (make-string-snip s) - (make-object string-snip% s)) - - (define (make-comment-box . elems) - (let* ([s (new comment-box:snip%)] - [e (send s get-editor)]) - (for-each (lambda (elem) - (cond - [(string? elem) (send e insert elem)] - [(elem . is-a? . text%) - (let loop () - (let ([s (send elem find-first-snip)]) - (when s - (send elem release-snip s) - (send e insert s) - (loop))))] - [else (void)])) - elems) - s)) - - (define/override (read f) - (let ([enabled?-box (box 0)] - [collapsed?-box (box 0)] - [error-box?-box (box 0)] - [to-test (new text%)] - [expected (new text%)] - [predicate (new text%)] - [should-raise (new text%)] - [error-message (new text%)]) - (let ([vers (reading-version f)]) - (case vers - [(1) - ;; Discard comment: - (send (new text%) read-from-file f) - (send* to-test (erase) (read-from-file f)) - (send* expected (erase) (read-from-file f)) - ;; Nothing else is in the stream in version 1, - ;; so leave the defaults - ] - [(2) - (send* to-test (erase) (read-from-file f)) - (send* expected (erase) (read-from-file f)) - (send* predicate (erase) (read-from-file f)) - (send* should-raise (erase) (read-from-file f)) - (send* error-message (erase) (read-from-file f)) - (send f get enabled?-box) - (send f get collapsed?-box) - (send f get error-box?-box)])) - (if (zero? (unbox error-box?-box)) - (if (and (strings? to-test) - (strings? expected)) - (make-string-snip - (format "(check-expect ~a ~a)" - (extract-text to-test) - (extract-text expected))) - (make-comment-box "(check-expect " - to-test - " " - expected - ")")) - (if (strings? to-test) - (make-string-snip - (format "(check-error ~a ~s)" - (extract-text to-test) - (extract-text error-message))) - (make-comment-box "(check-error " - to-test - " " - (extract-text error-message) - ")"))))) - - (super-new))) - - (define (phase1) - (let ([sc (new test-box-recovery-snipclass%)]) - (send sc set-classname "test-case-box%") - (send sc set-version 2) - (send (get-the-snip-class-list) add sc))) - - (define (phase2) - (void))))) - diff --git a/collects/tex2page/info.rkt b/collects/tex2page/info.rkt deleted file mode 100644 index 89ad582935..0000000000 --- a/collects/tex2page/info.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang setup/infotab - -(define mzscheme-launcher-libraries (list "start.rkt")) -(define mzscheme-launcher-names (list "tex2page")) diff --git a/collects/tex2page/main.rkt b/collects/tex2page/main.rkt deleted file mode 100644 index 1b6a321d6b..0000000000 --- a/collects/tex2page/main.rkt +++ /dev/null @@ -1,4 +0,0 @@ -#lang scheme/base - -(require "tex2page.rkt") -(provide (all-from-out "tex2page.rkt")) diff --git a/collects/tex2page/start.rkt b/collects/tex2page/start.rkt deleted file mode 100644 index 2419ae88e1..0000000000 --- a/collects/tex2page/start.rkt +++ /dev/null @@ -1,12 +0,0 @@ -(module start mzscheme - (require "tex2page.rkt" - mzlib/cmdline) - - (command-line - "tex2page" - (current-command-line-arguments) - [once-each - [("--version") "Reports long help and version information" - (tex2page "--version")]] - [args file "Processes each " - (map tex2page file)])) diff --git a/collects/tex2page/tex2page-aux.rkt b/collects/tex2page/tex2page-aux.rkt deleted file mode 100644 index b7a1e29b82..0000000000 --- a/collects/tex2page/tex2page-aux.rkt +++ /dev/null @@ -1,10010 +0,0 @@ -;tex2page -;(c) Dorai Sitaram, 1997-2002 - -;; Based on the mzscheme-specific version of tex2page for PLT Scheme v372, -;; adjusted for v4.0 to use `r5rs', instead, since v4.0 makes pairs -;; immutable. - -;; Converting the code to use immutable pairs and boxes seemed to work -;; fine (after some testing), but switching to `r5rs' seems safer. - -(module tex2page-aux r5rs - (#%require (only mzscheme - require - require-for-syntax - provide)) - (require mzlib/process) - (require mzlib/date - (only mzscheme - make-hash-table hash-table-get hash-table-put! - hash-table-for-each - getenv file-exists? delete-file file-or-directory-modify-seconds - current-seconds seconds->date - date-hour date-minute date-day date-month date-year - string-upcase - version read-line error - unless when fluid-let - open-input-string open-output-string get-output-string eof - parameterize)) - (require-for-syntax mzscheme) - (provide (all-defined-except)) - -(define (ormap f l) - (if (null? l) - #f - (if (null? (cdr l)) - (f (car l)) - (or (f (car l)) (ormap f (cdr l)))))) - -(define (reverse! l) (reverse l)) -(define append! append) - -(define (eval-expr e) (eval e (interaction-environment))) - -(define make-table - (lambda z (if (null? z) (make-hash-table) (make-hash-table 'equal)))) - -(define table-get - (lambda (ht k . d) - (hash-table-get ht k (let ((d (if (null? d) #f (car d)))) (lambda () d))))) - -; ensure shell-magic above -;Configured for Scheme dialect plt by scmxlate, v 2004-09-08, -;(c) Dorai Sitaram, -;http://www.ccs.neu.edu/~dorai/scmxlate/scmxlate.html - -(define *tex2page-version* "20070609") - -(define *tex2page-website* - "http://www.ccs.neu.edu/~dorai/tex2page/tex2page-doc.html") - -(define *operating-system* - (if (getenv "COMSPEC") - (let ((term (getenv "TERM"))) - (if (and (string? term) (string=? term "cygwin")) 'cygwin 'windows)) - 'unix)) - -(define *enable-write-18?* #t) - -(define *output-extension* ".html") - -(define *ghostscript* - (case *operating-system* - ((windows) - (or (ormap - (lambda (f) (and (file-exists? f) f)) - '("c:\\cygwin\\bin\\gs.exe" - "g:\\cygwin\\bin\\gs.exe" - "c:\\aladdin\\gs6.01\\bin\\gswin32c.exe" - "d:\\aladdin\\gs6.01\\bin\\gswin32c.exe" - "d:\\gs\\gs8.00\\bin\\gswin32.exe" - "g:\\gs\\gs8.00\\bin\\gswin32.exe")) - "gswin32.exe")) - (else "gs"))) - -(define *use-closing-p-tag?* #t) - -(define *metapost* (case *operating-system* ((windows) "mp") (else "mpost"))) - -(define *navigation-sentence-begin* "Go to ") - -(define *navigation-first-name* "first") - -(define *navigation-previous-name* "previous") - -(define *navigation-next-name* "next") - -(define *navigation-page-name* " page") - -(define *navigation-contents-name* "contents") - -(define *navigation-index-name* "index") - -(define *navigation-sentence-end* "") - -(define *last-modified* "Last modified") - -(define *html-conversion-by* "HTML conversion by") - -(define *doctype* - (string-append - "html public " - "\"-//W3C//DTD HTML 4.01 Transitional//EN\" " - "\"http://www.w3.org/TR/html4/loose.dtd\"")) - -(define *scheme-version* (string-append "Racket " (version))) - -(define *path-separator* (if (eqv? *operating-system* 'windows) #\; #\:)) - -(define *directory-separator* (if (eqv? *operating-system* 'windows) "\\" "/")) - -(define *bye-tex* - (case *operating-system* ((windows) " \\bye") (else " \\\\bye"))) - -(define *int-corresp-to-0* (char->integer #\0)) - -(define *aux-file-suffix* "-Z-A") - -(define *bib-aux-file-suffix* "-Z-B") - -(define *css-file-suffix* "-Z-S.css") - -(define *eval-file-suffix* "-Z-E-") - -(define *html-node-prefix* "node_") - -(define *html-page-suffix* "-Z-H-") - -(define *img-file-suffix* "-Z-G-") - -(define *imgdef-file-suffix* "D-") - -(define *index-file-suffix* "-Z-I") - -(define *label-file-suffix* "-Z-L") - -(define *mfpic-tex-file-suffix* ".Z-M-tex") - -(define *toc-file-suffix* "-Z-C") - -(define *ghostscript-options* - " -q -dBATCH -dNOPAUSE -dNO_PAUSE -sDEVICE=ppmraw") - -(define *invisible-space* (list '*invisible-space*)) - -(define *month-names* - (vector - "January" - "February" - "March" - "April" - "May" - "June" - "July" - "August" - "September" - "October" - "November" - "December")) - -(define *if-aware-ctl-seqs* - '("\\csname" "\\else" "\\end" "\\eval" "\\fi" "\\let")) - -(define *html-ldquo* "“") - -(define *html-lsquo* "‘") - -(define *html-mdash* "—") - -(define *html-ndash* "–") - -(define *html-rdquo* "”") - -(define *html-rsquo* "’") - -(define *filename-delims* '()) - -(define *scm-token-delims* - (list #\( #\) #\[ #\] #\{ #\} #\' #\` #\" #\; #\, #\|)) - -(define *tex-extra-letters* '()) - -(define *return* (integer->char 13)) - -(define *tab* (integer->char 9)) - -(define *afterassignment* #f) - -(define *afterpar* '()) - -(define *afterbye* '()) - -(define *aux-dir* #f) - -(define *aux-dir/* "") - -(define *aux-port* #f) - -(define *bib-aux-port* #f) - -(define *bibitem-num* 0) - -(define *color-names* '()) - -(define *comment-char* #\%) - -(define *css-port* #f) - -(define *current-source-file* #f) - -(define *current-tex2page-input* #f) - -(define *display-justification* 'center) - -(define *dotted-counters* #f) - -(define *dumping-nontex?* #f) - -(define *equation-number* #f) - -(define *equation-numbered?* #t) - -(define *equation-position* 0) - -(define *esc-char* #\\) - -(define *esc-char-std* #\\) - -(define *esc-char-verb* #\|) - -(define *eval-file-count* 0) - -(define *eval-for-tex-only?* #f) - -(define *expand-escape?* #f) - -(define *external-label-tables* #f) - -(define *footnote-list* '()) - -(define *footnote-sym* 0) - -(define *global-texframe* #f) - -(define *graphics-file-extensions* '()) - -(define *html* #f) - -(define *html-head* #f) - -(define *html-only* 0) - -(define *html-page* #f) - -(define *html-page-count* #f) - -(define *ignore-timestamp?* #f) - -(define *ignore-active-space?* #f) - -(define *img-file-count* 0) - -(define *img-file-tally* 0) - -(define *imgdef-file-count* 0) - -(define *imgpreamble* #f) - -(define *imgpreamble-inferred* #f) - -(define *in-alltt?* #f) - -(define *in-display-math?* #f) - -(define *in-para?* #f) - -(define *in-small-caps?* #f) - -(define *includeonly-list* #f) - -(define *index-page-mention-alist* '()) - -(define *index-table* #f) - -(define *index-count* #f) - -(define *index-page* #f) - -(define *index-port* #f) - -(define *infructuous-calls-to-tex2page* #f) - -(define *input-line-no* 0) - -(define *input-streams* '()) - -(define *inputting-boilerplate?* #f) - -(define *inside-appendix?* #f) - -(define *inside-eplain-verbatim?* #f) - -(define *jobname* "texput") - -(define *label-port* #f) - -(define *label-source* #f) - -(define *label-table* #f) - -(define *last-modification-time* #f) - -(define *last-page-number* #f) - -(define *latex-probability* #f) - -(define *ligatures?* #f) - -(define *loading-external-labels?* #f) - -(define *log-file* #f) - -(define *log-port* #f) - -(define *main-tex-file* #f) - -(define *math-mode?* #f) - -(define *math-needs-image?* #f) - -(define *math-script-mode?* #f) - -(define *math-roman-mode?* #f) - -(define *mfpic-file-num* #f) - -(define *mfpic-file-stem* #f) - -(define *mfpic-port* #f) - -(define *missing-eps-files* #f) - -(define *missing-pieces* #f) - -(define *mp-files* #f) - -(define *not-processing?* #f) - -(define *output-streams* '()) - -(define *outputting-external-title?* #f) - -(define *outputting-to-non-html?* #f) - -(define *reading-control-sequence?* #f) - -(define *recent-node-name* #f) - -(define *remember-index-number* #f) - -(define *scm-builtins* '()) - -(define *scm-dribbling?* #f) - -(define *scm-keywords* - '("=>" - "and" - "begin" - "begin0" - "case" - "cond" - "define" - "define-macro" - "define-syntax" - "defmacro" - "defstruct" - "delay" - "do" - "else" - "flet" - "fluid-let" - "if" - "labels" - "lambda" - "let" - "let-syntax" - "let*" - "letrec" - "letrec-syntax" - "macrolet" - "or" - "quasiquote" - "quote" - "set!" - "syntax-case" - "syntax-rules" - "unless" - "unquote" - "unquote-splicing" - "when" - "with" - "with-handlers")) - -(define *scm-variables* '()) - -(define *section-counters* #f) - -(define *section-counter-dependencies* #f) - -(define *slatex-math-escape* #f) - -(define *source-changed-since-last-run?* #f) - -(define *stylesheets* #f) - -(define *subjobname* *jobname*) - -(define *tabular-stack* '()) - -(define *temp* #f) - -(define *temp-string-count* #f) - -(define *temporarily-use-ascii-for-math?* #f) - -(define *tex2page-inputs* '()) - -(define *tex-env* '()) - -(define *tex-format* #f) - -(define *tex-if-stack* '()) - -(define *tex-like-layout?* #f) - -(define *title* #f) - -(define *toc-list* #f) - -(define *toc-page* #f) - -(define *unresolved-xrefs* #f) - -(define *using-bibliography?* #f) - -(define *using-chapters?* #f) - -(define *using-index?* #f) - -(define *verb-display?* #f) - -(define *verb-port* #f) - -(define *verb-visible-space?* #f) - -(define *verb-written-files* '()) - -(define *write-log-max* 55) - -(define *write-log-index* 0) - -(define *write-log-possible-break?* #f) - -(define strftime-like - (lambda (ignore-format d) - (string-append - (date->string d #t) - (let ((tz (getenv "TZ"))) (if tz (string-append " " tz) ""))))) - -(define seconds->human-time - (lambda (s) (strftime-like "%a, %b %e, %Y, %l:%M %p %Z" (seconds->date s)))) - -(define number->roman - (lambda (n upcase?) - (unless (and (integer? n) (>= n 0)) - (terror 'number->roman "Missing number")) - (let ((roman-digits - '((1000 #\m 100) - (500 #\d 100) - (100 #\c 10) - (50 #\l 10) - (10 #\x 1) - (5 #\v 1) - (1 #\i 0))) - (approp-case (lambda (c) (if upcase? (char-upcase c) c)))) - (let loop ((n n) (dd roman-digits) (s '())) - (if (null? dd) - (if (null? s) "0" (list->string (reverse! s))) - (let* ((d (car dd)) - (val (car d)) - (char (approp-case (cadr d))) - (nextval (caddr d))) - (let loop2 ((q (quotient n val)) (r (remainder n val)) (s s)) - (if (= q 0) - (if (>= r (- val nextval)) - (loop - (remainder r nextval) - (cdr dd) - (cons char (cons (approp-case (cadr (assv nextval dd))) s))) - (loop r (cdr dd) s)) - (loop2 (- q 1) r (cons char s)))))))))) - -(define list-index - (lambda (L o) - (let loop ((L L) (i 0)) - (cond - ((null? L) #f) - ((eqv? (car L) o) i) - (else (loop (cdr L) (+ i 1))))))) - -(define string-index - (lambda (s c) - (let ((n (string-length s))) - (let loop ((i 0)) - (cond - ((>= i n) #f) - ((char=? (string-ref s i) c) i) - (else (loop (+ i 1)))))))) - -(define string-reverse-index - (lambda (s c) - (let loop ((i (- (string-length s) 1))) - (cond - ((< i 0) #f) - ((char=? (string-ref s i) c) i) - (else (loop (- i 1))))))) - -(define substring? - (lambda (s1 s2) - (let* ((s1-len (string-length s1)) - (s2-len (string-length s2)) - (n-give-up (+ 1 (- s2-len s1-len)))) - (let loop ((i 0)) - (if (< i n-give-up) - (let loop2 ((j 0) (k i)) - (if (< j s1-len) - (if (char=? (string-ref s1 j) (string-ref s2 k)) - (loop2 (+ j 1) (+ k 1)) - (loop (+ i 1))) - i)) - #f))))) - -(define list-position - (lambda (x s) - (let loop ((s s) (i 0)) - (cond - ((null? s) #f) - ((eq? (car s) x) i) - (else (loop (cdr s) (+ i 1))))))) - -(define-syntax defstruct - (lambda (so) - (datum->syntax-object - so - (let ((so-d (syntax-object->datum so))) - (let ((s (cadr so-d)) (ff (cddr so-d))) - (let ((s-s (symbol->string s)) (n (length ff))) - (let* ((n+1 (+ n 1)) (vv (make-vector n+1))) - (let loop ((i 1) (ff ff)) - (if (< i n+1) - (let ((f (car ff))) - (vector-set! vv i (if (pair? f) (cadr f) '(if #f #f))) - (loop (+ i 1) (cdr ff))))) - (let ((ff (map (lambda (f) (if (pair? f) (car f) f)) ff))) - `(begin - (define ,(string->symbol (string-append "make-" s-s)) - (lambda fvfv - (let ((st (make-vector ,n+1)) (ff ',ff)) - (vector-set! st 0 ',s) - ,@(let loop ((i 1) (r '())) - (if (>= i n+1) - r - (loop - (+ i 1) - (cons - `(vector-set! st ,i ,(vector-ref vv i)) - r)))) - (let loop ((fvfv fvfv)) - (unless (null? fvfv) - (vector-set! - st - (+ (list-position (car fvfv) ff) 1) - (cadr fvfv)) - (loop (cddr fvfv)))) - st))) - ,@(let loop ((i 1) (procs '())) - (if (>= i n+1) - procs - (loop - (+ i 1) - (let ((f (symbol->string (list-ref ff (- i 1))))) - (cons - `(define (unquote - (string->symbol - (string-append s-s "." f))) - (lambda (x) (vector-ref x ,i))) - (cons - `(define (unquote - (string->symbol - (string-append "set!" s-s "." f))) - (lambda (x v) (vector-set! x ,i v))) - procs)))))) - (define ,(string->symbol (string-append s-s "?")) - (lambda (x) - (and (vector? x) (eq? (vector-ref x 0) ',s))))))))))))) - -(define lassoc - (lambda (k al equ?) - (let loop ((al al)) - (if (null? al) - #f - (let ((c (car al))) (if (equ? (car c) k) c (loop (cdr al)))))))) - -(define ldelete - (lambda (y xx equ?) - (let loop ((xx xx) (r '())) - (if (null? xx) - (reverse! r) - (let ((x (car xx))) (loop (cdr xx) (if (equ? x y) r (cons x r)))))))) - -(defstruct counter (value 0) (within #f)) - -(defstruct tocentry level number page label header) - -(define string-trim-blanks - (lambda (s) - (let ((orig-n (string-length s))) - (let ((i 0) (n orig-n)) - (let loop ((k i)) - (cond - ((>= k n) (set! i n)) - ((char-whitespace? (string-ref s k)) (loop (+ k 1))) - (else (set! i k)))) - (let loop ((k (- n 1))) - (cond - ((<= k i) (set! n (+ k 1))) - ((char-whitespace? (string-ref s k)) (loop (- k 1))) - (else (set! n (+ k 1))))) - (if (and (= i 0) (= n orig-n)) s (substring s i n)))))) - -(define char-tex-alphabetic? - (lambda (c) - (or (char-alphabetic? c) - (ormap (lambda (d) (char=? c d)) *tex-extra-letters*)))) - -(define gen-temp-string - (lambda () - (set! *temp-string-count* (+ *temp-string-count* 1)) - (string-append "Temp_" (number->string *temp-string-count*)))) - -(define file-stem-name - (lambda (f) - (let ((slash (string-reverse-index f #\/))) - (when slash (set! f (substring f (+ slash 1) (string-length f)))) - (let ((dot (string-reverse-index f #\.))) - (if dot (substring f 0 dot) f))))) - -(define file-extension - (lambda (f) - (let ((slash (string-reverse-index f #\/)) - (dot (string-reverse-index f #\.))) - (if (and dot (not (= dot 0)) (or (not slash) (< (+ slash 1) dot))) - (substring f dot (string-length f)) - #f)))) - -(define ensure-file-deleted (lambda (f) (if (file-exists? f) (delete-file f)))) - -(define write-aux (lambda (e) (write e *aux-port*) (newline *aux-port*))) - -(define write-label - (lambda (e) - (unless *label-port* - (let ((f - (string-append *aux-dir/* *jobname* *label-file-suffix* ".scm"))) - (ensure-file-deleted f) - (set! *label-port* (open-output-file f)))) - (write e *label-port*) - (newline *label-port*))) - -(define write-bib-aux - (lambda (x) - (unless *bib-aux-port* - (let ((f - (string-append - *aux-dir/* - *jobname* - *bib-aux-file-suffix* - ".aux"))) - (ensure-file-deleted f) - (set! *bib-aux-port* (open-output-file f)))) - (display x *bib-aux-port*))) - -(define write-log - (lambda (x) - (unless *log-port* - (set! *log-file* (string-append *aux-dir/* *jobname* ".hlog")) - (ensure-file-deleted *log-file*) - (set! *log-port* (open-output-file *log-file*))) - (when (and - *write-log-possible-break?* - (char? x) - (ormap (lambda (c) (char=? x c)) '(#\) #\] #\} #\,))) - (set! *write-log-possible-break?* #f)) - (when (and - *write-log-possible-break?* - (> *write-log-index* *write-log-max*)) - (newline *log-port*) - (newline) - (set! *write-log-possible-break?* #f) - (set! *write-log-index* 0)) - (unless (and - (= *write-log-index* 0) - (or (eqv? x 'separation-newline) (eqv? x 'separation-space))) - (case x - ((#\newline separation-newline) - (when *write-log-possible-break?* - (set! *write-log-possible-break?* #f)) - (newline *log-port*) - (newline) - (set! *write-log-index* 0)) - ((separation-space) (set! *write-log-possible-break?* #t)) - (else - (when *write-log-possible-break?* - (write-char #\space *log-port*) - (write-char #\space) - (set! *write-log-index* (+ *write-log-index* 1)) - (set! *write-log-possible-break?* #f)) - (display x *log-port*) - (display x) - (flush-output) - (set! *write-log-index* - (+ - *write-log-index* - (cond - ((char? x) 1) - ((number? x) (string-length (number->string x))) - ((string? x) (string-length x)) - (else 1))))))))) - -(define display-error-context-lines - (lambda () - (let ((n (let ((c (find-count "\\errorcontextlines"))) (if c (cadr c) 0)))) - (when (and *current-source-file* (> n 0)) - (let* ((n1 (max 0 (- *input-line-no* (quotient (- n 1) 2)))) - (nf (+ n1 n -1)) - (ll - (call-with-input-file - *current-source-file* - (lambda (ip) - (let loop ((i 1) (ll '())) - (let ((L (read-line ip))) - (cond - ((eof-object? L) ll) - ((< i n1) (loop (+ i 1) ll)) - ((<= i nf) (loop (+ i 1) (cons (cons i L) ll))) - (else ll)))))))) - (unless (null? ll) - (let* ((border "__________________________...") - (only-1? (= (length ll) 1)) - (nf (caar ll)) - (ll (reverse! ll)) - (n1 (caar ll))) - (write-log "Likely error context: ") - (write-log *current-source-file*) - (write-log ", line") - (unless only-1? (write-log "s")) - (write-log " ") - (write-log n1) - (unless only-1? (write-log "-") (write-log nf)) - (write-log ":") - (write-log #\newline) - (write-log " /") - (write-log border) - (write-log #\newline) - (for-each - (lambda (L) - (write-log " | ") - (write-log (cdr L)) - (write-log #\newline)) - ll) - (write-log " |") - (write-log border) - (write-log #\newline) - (write-log "/")))))))) - -(define terror - (lambda (where . args) - (write-log 'separation-newline) - (write-log "! ") - (for-each write-log args) - (write-log 'separation-newline) - (write-log "l.") - (write-log *input-line-no*) - (write-log #\space) - (write-log where) - (write-log " failed.") - (write-log 'separation-newline) - (display-error-context-lines) - (close-all-open-ports) - (output-stats) - (display "Type e to edit file at point of error; x to quit.") - (newline) - (display "? ") - (flush-output) - (let ((c (read-char))) - (when (and (not (eof-object? c)) (char-ci=? c #\e)) - (edit-offending-file))) - (error "TeX2page fatal error"))) - -(define edit-offending-file - (lambda () - (let ((bad-texedit? #f) (cmd #f)) - (cond - ((getenv "TEXEDIT") - => - (lambda (s) - (cond - ((substring? "%d" s) - => - (lambda (i) - (set! s - (string-append - (substring s 0 i) - (number->string *input-line-no*) - (substring s (+ i 2) (string-length s)))))) - (else (set! bad-texedit? #t))) - (cond - ((and (not bad-texedit?) (substring? "%s" s)) - => - (lambda (i) - (set! s - (string-append - (substring s 0 i) - *current-source-file* - (substring s (+ i 2) (string-length s)))))) - (else (set! bad-texedit? #t))) - (cond - (bad-texedit? (display "Bad TEXEDIT; using EDITOR.") (newline)) - (else (set! cmd s)))))) - (cond - ((and (not cmd) (or (getenv "EDITOR") "vi")) - => - (lambda (s) - (set! cmd - (string-append - s - " +" - (number->string *input-line-no*) - " " - *current-source-file*))))) - (when cmd (system cmd))))) - -(define trace-if - (lambda (write? . args) - (when write? - (write-log 'separation-newline) - (when (> *input-line-no* 0) - (write-log "l.") - (write-log *input-line-no*) - (write-log #\space)) - (for-each write-log args) - (write-log 'separation-newline)))) - -(define do-errmessage - (lambda () - (write-log 'separation-newline) - (write-log "! ") - (write-log (tex-string->html-string (get-group))) - (write-log 'separation-newline) - (terror "\\errmessage"))) - -(define do-tracingall - (lambda () - (tex-def-count "\\tracingcommands" 1 #f) - (tex-def-count "\\tracingmacros" 1 #f))) - -(defstruct bport (port #f) (buffer '())) - -(define call-with-input-file/buffered - (lambda (f th) - (unless (file-exists? f) - (terror 'call-with-input-file/buffered "I can't find file " f)) - (call-with-input-file - f - (lambda (i) - (fluid-let - ((*current-tex2page-input* (make-bport 'port i)) - (*current-source-file* f) - (*input-line-no* 1)) - (th)))))) - -(define call-with-input-string/buffered - (lambda (s th) - (fluid-let - ((*current-tex2page-input* (make-bport 'buffer (string->list s))) - (*input-line-no* *input-line-no*)) - (th)))) - -(define call-with-input-string - (lambda (s p) - (let* ((i (open-input-string s)) (r (p i))) (close-input-port i) r))) - -(define snoop-char (lambda () (let ((c (get-char))) (toss-back-char c) c))) - -(define get-char - (lambda () - (let ((b (bport.buffer *current-tex2page-input*))) - (if (null? b) - (let ((p (bport.port *current-tex2page-input*))) - (if (not p) - eof - (let ((c (read-char p))) - (cond - ((eof-object? c) c) - ((char=? c #\newline) - (set! *input-line-no* (+ *input-line-no* 1)) - c) - (else c))))) - (let ((c (car b))) - (set!bport.buffer *current-tex2page-input* (cdr b)) - c))))) - -(define toss-back-string - (lambda (s) - (set!bport.buffer - *current-tex2page-input* - (append! (string->list s) (bport.buffer *current-tex2page-input*))))) - -(define toss-back-char - (lambda (c) - (set!bport.buffer - *current-tex2page-input* - (cons c (bport.buffer *current-tex2page-input*))))) - -(define emit (lambda (s) (display s *html*))) - -(define emit-newline (lambda () (newline *html*))) - -(define emit-visible-space - (lambda () (display "·" *html*))) - -(define invisible-space? (lambda (x) (eq? x *invisible-space*))) - -(define snoop-actual-char - (lambda () - (let ((c (snoop-char))) - (cond - ((eof-object? c) c) - ((invisible-space? c) (get-char) (snoop-actual-char)) - ((char=? c *return*) - (get-char) - (let ((c (snoop-actual-char))) - (if (and (not (eof-object? c)) (char=? c #\newline)) - c - (begin (toss-back-char #\newline) #\newline)))) - (else c))))) - -(define get-actual-char - (lambda () - (let ((c (get-char))) - (cond - ((eof-object? c) c) - ((invisible-space? c) (get-actual-char)) - ((char=? c *return*) - (let ((c (snoop-actual-char))) - (if (and (not (eof-object? c)) (char=? c #\newline)) - (get-actual-char) - #\newline))) - (else c))))) - -(define get-line - (lambda () - (let loop ((r '())) - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (if (null? r) c (list->string (reverse! r)))) - ((char=? c #\newline) (list->string (reverse! r))) - (else (loop (cons c r)))))))) - -(define ignorespaces - (lambda () - (unless (and (find-chardef #\space) (not *ignore-active-space?*)) - (let ((newline-active? (find-chardef #\newline)) - (newline-already-read? #f)) - (let loop () - (let ((c (snoop-char))) - (when (eqv? c *return*) (set! c (snoop-actual-char))) - (cond - ((eof-object? c) #t) - ((invisible-space? c) - (get-char) - (unless *reading-control-sequence?* (loop))) - ((char=? c #\newline) - (cond - (newline-active? #t) - (newline-already-read? (toss-back-char #\newline)) - (else - (get-actual-char) - (set! newline-already-read? #t) - (loop)))) - ((char-whitespace? c) (get-actual-char) (loop)) - (else #t)))))))) - -(define ignore-all-whitespace - (lambda () - (let loop () - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (when (char-whitespace? c) (get-actual-char) (loop))))))) - -(define munch-newlines - (lambda () - (let loop ((n 0)) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) n) - ((char=? c #\newline) (get-actual-char) (loop (+ n 1))) - ((char-whitespace? c) (get-actual-char) (loop n)) - (else n)))))) - -(define munched-a-newline? - (lambda () - (let loop () - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) #f) - ((char=? c #\newline) (get-actual-char) #t) - ((char-whitespace? c) (get-actual-char) (loop)) - (else #f)))))) - -(define do-xspace - (lambda () - (let ((c (snoop-actual-char))) - (unless (memv c '(#\space #\" #\. #\! #\, #\: #\; #\? #\/ #\' #\) #\-)) - (emit #\space))))) - -(define do-relax (lambda () #t)) - -(define get-ctl-seq - (lambda () - (let ((bs (get-actual-char))) - (unless (char=? bs *esc-char*) - (terror 'get-ctl-seq "Missing control sequence (" bs ")"))) - (let ((c (get-char))) - (cond - ((eof-object? c) "\\ ") - ((invisible-space? c) "\\ ") - ((char-tex-alphabetic? c) - (list->string - (reverse! - (let loop ((s (list c #\\))) - (let ((c (snoop-char))) - (cond - ((eof-object? c) s) - ((invisible-space? c) s) - ((char-tex-alphabetic? c) (get-char) (loop (cons c s))) - (else - (unless (or - *math-mode?* - *not-processing?* - (eq? *tex-format* 'texinfo)) - (fluid-let - ((*reading-control-sequence?* #t)) - (ignorespaces))) - s))))))) - (else (string #\\ c)))))) - -(define get-char-as-ctl-seq - (lambda () - (let* ((cs (get-ctl-seq)) (c (string-ref cs 1))) - (if (char=? c #\^) - (let ((c2 (snoop-actual-char))) - (if (char=? c2 #\^) - (begin - (get-actual-char) - (let ((c3 (get-actual-char))) - (case c3 - ((#\M) #\newline) - ((#\I) *tab*) - (else (terror 'get-char-as-ctl-seq))))) - c)) - c)))) - -(define ctl-seq? (lambda (z) (char=? (string-ref z 0) #\\))) - -(define if-aware-ctl-seq? - (lambda (z) - (or (ormap (lambda (y) (string=? z y)) *if-aware-ctl-seqs*) - (and (>= (string-length z) 3) - (char=? (string-ref z 1) #\i) - (char=? (string-ref z 2) #\f)) - (let ((z-th (find-corresp-prim-thunk z))) - (if (string? z-th) - #f - (ormap - (lambda (y) (eq? z-th (find-corresp-prim-thunk y))) - *if-aware-ctl-seqs*)))))) - -(define get-group-as-reversed-chars - (lambda () - (ignorespaces) - (let ((c (get-actual-char))) - (if (eof-object? c) (terror 'get-group "Runaway argument?")) - (unless (char=? c #\{) (terror 'get-group "Missing {")) - (let loop ((s (list c)) (nesting 0) (escape? #f)) - (let ((c (get-actual-char))) - (if (eof-object? c) (terror 'get-group "Runaway argument?")) - (cond - (escape? (loop (cons c s) nesting #f)) - ((char=? c *esc-char*) - (if *expand-escape?* - (let ((s1 - (begin - (toss-back-char c) - (let ((x - (fluid-let - ((*not-processing?* #t)) - (get-ctl-seq)))) - (cond - ((ormap - (lambda (z) (string=? x z)) - '("\\ " "\\{" "\\}")) - (string (string-ref x 1))) - (else - (fluid-let - ((*esc-char* *esc-char-std*)) - (tex-string->html-string x)))))))) - (loop (append! (reverse! (string->list s1)) s) nesting #f)) - (loop (cons c s) nesting #t))) - ((char=? c #\{) (loop (cons c s) (+ nesting 1) #f)) - ((char=? c #\}) - (if (= nesting 0) (cons c s) (loop (cons c s) (- nesting 1) #f))) - (else (loop (cons c s) nesting #f)))))))) - -(define get-group - (lambda () (list->string (reverse! (get-group-as-reversed-chars))))) - -(define get-peeled-group - (lambda () (string-trim-blanks (ungroup (get-group))))) - -(define get-token-or-peeled-group - (lambda () (string-trim-blanks (ungroup (get-token))))) - -(define get-grouped-environment-name-if-any - (lambda () - (let ((c (snoop-actual-char))) - (if (or (eof-object? c) (not (char=? c #\{))) - #f - (begin - (get-actual-char) - (let loop ((s '())) - (let ((c (snoop-actual-char))) - (cond - ((or (char-alphabetic? c) (char=? c #\*)) - (get-actual-char) - (loop (cons c s))) - ((and (pair? s) (char=? c #\})) - (get-actual-char) - (list->string (reverse! s))) - (else - (for-each toss-back-char s) - (toss-back-char #\{) - #f))))))))) - -(define get-bracketed-text-if-any - (lambda () - (ignorespaces) - (let ((c (snoop-actual-char))) - (if (or (eof-object? c) (not (char=? c #\[))) - #f - (begin - (get-actual-char) - (list->string - (reverse! - (let loop ((s '()) (nesting 0) (escape? #f)) - (let ((c (get-actual-char))) - (if (eof-object? c) - (terror 'get-bracketed-text-if-any "Runaway argument?")) - (cond - (escape? (loop (cons c s) nesting #f)) - ((char=? c *esc-char*) (loop (cons c s) nesting #t)) - ((char=? c #\{) (loop (cons c s) (+ nesting 1) #f)) - ((char=? c #\}) (loop (cons c s) (- nesting 1) #f)) - ((char=? c #\]) - (if (= nesting 0) s (loop (cons c s) nesting #f))) - (else (loop (cons c s) nesting #f)))))))))))) - -(define ungroup - (lambda (s) - (let* ((n (string-length s)) (n-1 (- n 1))) - (if (or (< n 2) - (not (char=? (string-ref s 0) #\{)) - (not (char=? (string-ref s n-1) #\}))) - s - (substring s 1 n-1))))) - -(define eat-alphanumeric-string - (lambda () - (ignorespaces) - (let loop () - (let ((c (snoop-actual-char))) - (when (or (char-alphabetic? c) (char-numeric? c)) - (get-actual-char) - (loop)))))) - -(define get-filename - (lambda (braced?) - (ignorespaces) - (when braced? - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\{)) - (get-actual-char) - (set! braced? #f)))) - (list->string - (reverse! - (let loop ((s '())) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) s) - ((and (not braced?) - (or (char-whitespace? c) - (and *comment-char* (char=? c *comment-char*)) - (ormap (lambda (d) (char=? c d)) *filename-delims*))) - (unless *not-processing?* (ignorespaces)) - s) - ((and braced? (char=? c #\})) (get-actual-char) s) - ((and *esc-char* (char=? c *esc-char*)) - (let ((x (get-ctl-seq))) - (if (string=? x "\\jobname") - (loop (append! (reverse! (string->list *jobname*)) s)) - (begin - (toss-back-char *invisible-space*) - (toss-back-string x) - s)))) - (else (get-actual-char) (loop (cons c s)))))))))) - -(define get-plain-filename (lambda () (get-filename #f))) - -(define get-filename-possibly-braced - (lambda () - (ignorespaces) - (let ((c (snoop-actual-char))) - (get-filename (and (char? c) (char=? c #\{)))))) - -(define get-integer - (lambda (base) - (ignorespaces) - (string->number - (list->string - (reverse! - (let loop ((s '())) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) s) - ((or (char-numeric? c) (and (= base 16) (char-alphabetic? c))) - (get-actual-char) - (loop (cons c s))) - (else (ignorespaces) s)))))) - base))) - -(define get-real - (lambda () - (ignorespaces) - (let ((minus? #f) (c (snoop-actual-char))) - (when (char=? c #\-) (set! minus? #t)) - (when (or minus? (char=? c #\+)) (get-actual-char)) - (let ((n - (string->number - (list->string - (reverse! - (let loop ((s '())) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) s) - ((or (char-numeric? c) (char=? c #\.)) - (get-actual-char) - (loop (cons c s))) - (else (ignorespaces) s))))))))) - (if minus? (- n) n))))) - -(define get-equal-sign - (lambda () - (ignorespaces) - (when (char=? (snoop-actual-char) #\=) (get-actual-char)))) - -(define get-by - (lambda () - (ignorespaces) - (when (char=? (snoop-actual-char) #\b) - (get-actual-char) - (if (char=? (snoop-actual-char) #\y) - (get-actual-char) - (toss-back-char #\b))))) - -(define get-to - (lambda () - (ignorespaces) - (when (char=? (snoop-actual-char) #\t) - (get-actual-char) - (cond - ((char=? (snoop-actual-char) #\o) (get-actual-char) (ignorespaces)) - (else (toss-back-char #\t)))))) - -(define get-number-corresp-to-ctl-seq - (lambda (x) - (cond - ((string=? x "\\the") (get-number-corresp-to-ctl-seq (get-ctl-seq))) - ((string=? x "\\active") 13) - ((string=? x "\\pageno") *html-page-count*) - ((string=? x "\\inputlineno") *input-line-no*) - ((string=? x "\\footnotenumber") (get-gcount "\\footnotenumber")) - ((string=? x "\\figurenumber") - (counter.value (table-get *dotted-counters* "figure"))) - ((string=? x "\\sectiondnumber") - (table-get *section-counters* (string->number (ungroup (get-token))) 0)) - ((find-count x) => cadr) - ((find-dimen x) => cadr) - (else (or (string->number (or (resolve-defs x) x))))))) - -(define get-number-or-false - (lambda () - (ignorespaces) - (let ((c (snoop-actual-char))) - (cond - ((char=? c *esc-char*) (get-number-corresp-to-ctl-seq (get-ctl-seq))) - ((char=? c #\') (get-actual-char) (get-integer 8)) - ((char=? c #\") (get-actual-char) (get-integer 16)) - ((char=? c #\`) - (get-actual-char) - (ignorespaces) - (char->integer - (if (char=? (snoop-actual-char) *esc-char*) - (string-ref (get-ctl-seq) 1) - (get-actual-char)))) - ((char=? c #\+) (get-actual-char) (get-number-or-false)) - ((char=? c #\-) - (get-actual-char) - (let ((n (get-number-or-false))) (and n (- n)))) - ((char-numeric? c) (get-integer 10)) - (else #f))))) - -(define get-number - (lambda () - (or (get-number-or-false) (terror 'get-number "Missing number.")))) - -(define get-tex-char-spec - (lambda () - (cond - ((get-number-or-false) => integer->char) - (else (terror 'get-tex-char-spec "not a char"))))) - -(define get-url - (lambda () - (ignorespaces) - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (terror 'get-url "Missing {")) - ((not (char=? c #\{)) (terror 'get-url "Missing {"))) - (string-trim-blanks - (list->string - (reverse! - (let loop ((nesting 0) (s '())) - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (terror 'get-url "Missing }")) - ((and *comment-char* (char=? c *comment-char*)) - (let ((c1 (snoop-actual-char))) - (loop - nesting - (if (and (char? c1) (char-whitespace? c1)) - (begin (ignore-all-whitespace) s) - (cons c s))))) - ((char=? c #\{) (loop (+ nesting 1) (cons c s))) - ((char=? c #\}) - (if (= nesting 0) s (loop (- nesting 1) (cons c s)))) - (else (loop nesting (cons c s)))))))))))) - -(define get-csv - (lambda () - (ignorespaces) - (let ((rev-lbl - (let loop ((s '()) (nesting 0)) - (let ((c (get-actual-char))) - (cond - ((eof-object? c) - (terror - 'get-csv - "Runaway argument of \\cite, " - "\\nocite, \\expandhtmlindex?") - s) - ((and (char=? c #\,) (= nesting 0)) s) - ((char=? c #\{) (loop (cons c s) (+ nesting 1))) - ((char=? c #\}) - (if (= nesting 0) - (begin (toss-back-char c) s) - (loop (cons c s) (- nesting 1)))) - (else (loop (cons c s) nesting))))))) - (if (null? rev-lbl) #f (list->string (reverse! rev-lbl)))))) - -(define get-raw-token - (lambda () - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) c) - ((char=? c *esc-char*) - (fluid-let ((*not-processing?* #t)) (get-ctl-seq))) - (else (string (get-actual-char))))))) - -(define get-raw-token/is - (lambda () - (ignorespaces) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) c) - ((char=? c *esc-char*) (get-ctl-seq)) - ((and *comment-char* (char=? c *comment-char*)) - (eat-till-eol) - (get-raw-token/is)) - (else (string (get-actual-char))))))) - -(define get-token - (lambda () - (ignorespaces) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) c) - ((char=? c *esc-char*) (get-ctl-seq)) - ((char=? c #\{) (get-group)) - ((and *comment-char* (char=? c *comment-char*)) - (eat-till-eol) - (get-token)) - (else (string (get-actual-char))))))) - -(define eat-word - (lambda (word) - (ignorespaces) - (let ((n (string-length word))) - (let loop ((i 0) (r '())) - (if (>= i n) - #t - (let ((c (snoop-actual-char))) - (cond - ((char=? c (string-ref word i)) - (get-actual-char) - (loop (+ i 1) (cons c r))) - (else (for-each toss-back-char r) #f)))))))) - -(define eat-skip-fluff - (lambda (full?) - (let ((go-ahead? #t)) - (cond - (full? (get-equal-sign)) - ((ormap eat-word '("plus" "minus")) #t) - (else (set! go-ahead? #f))) - (when go-ahead? - (fluid-let - ((*not-processing?* #t)) - (let loop ((first? full?)) - (ignorespaces) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) 'done) - ((and (char=? c *esc-char*) first?) (get-ctl-seq)) - ((or (char-numeric? c) (char=? c #\.)) (get-real) (loop first?)) - ((or (char=? c #\') (char=? c #\")) (get-number) (loop first?)) - ((ormap eat-word '("+" "-")) (loop first?)) - ((ormap - eat-word - '("bp" - "cc" - "cm" - "dd" - "em" - "ex" - "filll" - "fill" - "fil" - "in" - "minus" - "mm" - "pc" - "plus" - "pt" - "sp" - "true")) - (loop #f)) - (else 'done))))))))) - -(define eat-dimen (lambda () (eat-skip-fluff #t))) - -(define eat-integer - (lambda () - (fluid-let - ((*not-processing?* #t)) - (ignorespaces) - (get-equal-sign) - (get-number)))) - -(define scm-get-token - (lambda () - (list->string - (reverse! - (let loop ((s '()) (esc? #f)) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) s) - (esc? (get-actual-char) (loop (cons c s) #f)) - ((char=? c #\\) (get-actual-char) (loop (cons c s) #t)) - ((or (char-whitespace? c) (memv c *scm-token-delims*)) s) - (else (get-actual-char) (loop (cons c s) #f))))))))) - -(define emit-html-char - (lambda (c) - (unless (eof-object? c) - (cond - ((char=? c #\newline) (emit-newline)) - (*outputting-to-non-html?* (emit c)) - (else - (case c - ((#\<) (emit "<")) - ((#\>) (emit ">")) - ((#\") (emit """)) - ((#\&) (emit "&")) - (else (emit c)))))))) - -(define emit-html-string - (lambda (s) - (let ((n (string-length s))) - (let loop ((i 0)) - (unless (>= i n) (emit-html-char (string-ref s i)) (loop (+ i 1))))))) - -(define member/string-ci=? - (lambda (s ss) (ormap (lambda (x) (string-ci=? x s)) ss))) - -(defstruct - texframe - (definitions '()) - (chardefinitions '()) - (counts '()) - (toks '()) - (dimens '()) - (postludes '()) - (aftergroups '())) - -(define *primitive-texframe* (make-texframe)) - -(define *math-primitive-texframe* (make-texframe)) - -(define bgroup (lambda () (set! *tex-env* (cons (make-texframe) *tex-env*)))) - -(define egroup - (lambda () - (if (null? *tex-env*) (terror 'egroup "Too many }'s")) - (perform-postludes) - (perform-aftergroups) - (set! *tex-env* (cdr *tex-env*)))) - -(define perform-postludes - (lambda () (for-each (lambda (p) (p)) (texframe.postludes (top-texframe))))) - -(define perform-aftergroups - (lambda () - (let ((ags (texframe.aftergroups (top-texframe)))) - (unless (null? ags) (toss-back-char *invisible-space*)) - (for-each (lambda (ag) (ag)) ags)))) - -(define perform-afterassignment - (lambda () - (let ((z *afterassignment*)) - (when z (set! *afterassignment* #f) (do-tex-ctl-seq z))))) - -(define add-postlude-to-top-frame - (lambda (p) - (let ((fr (if (null? *tex-env*) *global-texframe* (car *tex-env*)))) - (set!texframe.postludes fr (cons p (texframe.postludes fr)))))) - -(define add-aftergroup-to-top-frame - (lambda (ag) - (let ((fr (if (null? *tex-env*) *global-texframe* (car *tex-env*)))) - (set!texframe.aftergroups fr (cons ag (texframe.aftergroups fr)))))) - -(define top-texframe - (lambda () (if (null? *tex-env*) *global-texframe* (car *tex-env*)))) - -(defstruct - tdef - (argpat '()) - (expansion "") - (optarg #f) - (thunk #f) - (prim #f) - (defer #f)) - -(defstruct cdef (argpat #f) (expansion #f) (optarg #f) (active #f)) - -(define kopy-tdef - (lambda (lft rt) - (set!tdef.argpat lft (tdef.argpat rt)) - (set!tdef.expansion lft (tdef.expansion rt)) - (set!tdef.optarg lft (tdef.optarg rt)) - (set!tdef.thunk lft (tdef.thunk rt)) - (set!tdef.prim lft (tdef.prim rt)) - (set!tdef.defer lft (tdef.defer rt)))) - -(define kopy-cdef - (lambda (lft rt) - (set!cdef.argpat lft (cdef.argpat rt)) - (set!cdef.expansion lft (cdef.expansion rt)) - (set!cdef.optarg lft (cdef.optarg rt)) - (set!cdef.active lft (cdef.active rt)))) - -(define cleanse-tdef - (lambda (d) - (set!tdef.argpat d '()) - (set!tdef.expansion d "") - (set!tdef.optarg d #f) - (set!tdef.thunk d #f) - (set!tdef.prim d #f) - (set!tdef.defer d #f))) - -(define tex-def - (lambda (name argpat expansion optarg thunk prim defer frame) - (unless frame (set! frame (top-texframe))) - (let ((d - (cond - ((lassoc name (texframe.definitions frame) string=?) => cdr) - (else - (let ((d (make-tdef))) - (set!texframe.definitions - frame - (cons (cons name d) (texframe.definitions frame))) - d))))) - (set!tdef.argpat d argpat) - (set!tdef.expansion d expansion) - (set!tdef.optarg d optarg) - (set!tdef.thunk d thunk) - (set!tdef.prim d prim) - (set!tdef.defer d defer)) - (perform-afterassignment))) - -(define tex-def-prim - (lambda (prim thunk) - (tex-def prim '() #f #f thunk prim #f *primitive-texframe*))) - -(define tex-def-0arg (lambda (cs expn) (tex-def cs '() expn #f #f #f #f #f))) - -(define find-def-0arg - (lambda (cs) (cond ((find-def cs) => tdef.expansion) (else #f)))) - -(define tex-gdef-0arg - (lambda (cs expn) (tex-def cs '() expn #f #f cs #f *global-texframe*))) - -(define tex-def-prim-0arg - (lambda (cs expn) (tex-def cs '() expn #f #f cs #f *primitive-texframe*))) - -(define get-0arg-expn (lambda (cs) (cond ((find-def cs) => tdef.expansion)))) - -(define tex2page-flag-value (lambda (cs) (string-ref (get-0arg-expn cs) 0))) - -(define tex2page-flag-boolean - (lambda (cs) - (not (memv (string-ref (get-0arg-expn cs) 0) '(#\0 #\f #\F #\n #\N))))) - -(define tex-let - (lambda (lft rt frame) - (unless frame (set! frame (top-texframe))) - (let ((lft-def - (cond - ((lassoc lft (texframe.definitions frame) string=?) => cdr) - (else - (let ((lft-def (make-tdef))) - (set!texframe.definitions - frame - (cons (cons lft lft-def) (texframe.definitions frame))) - lft-def))))) - (cond - ((find-def rt) => (lambda (rt-def) (kopy-tdef lft-def rt-def))) - (else (cleanse-tdef lft-def) (set!tdef.defer lft-def rt)))))) - -(define tex-let-prim (lambda (lft rt) (tex-let lft rt *primitive-texframe*))) - -(define tex-def-thunk - (lambda (name thunk frame) - (unless (inside-false-world?) - (tex-def name '() #f #f thunk name #f frame)))) - -(define tex-def-count - (lambda (name num g?) - (let ((frame (if g? *global-texframe* (top-texframe)))) - (cond - ((lassoc name (texframe.counts frame) string=?) - => - (lambda (c) (set-car! (cdr c) num))) - (else - (set!texframe.counts - frame - (cons (list name num) (texframe.counts frame)))))) - (perform-afterassignment))) - -(define tex-def-toks - (lambda (name tokens g?) - (let ((frame (if g? *global-texframe* (top-texframe)))) - (cond - ((lassoc name (texframe.toks frame) string=?) - => - (lambda (c) (set-car! (cdr c) tokens))) - (else - (set!texframe.toks - frame - (cons (list name tokens) (texframe.toks frame))))) - (perform-afterassignment)))) - -(define tex-def-dimen - (lambda (name len g?) - (let ((frame (if g? *global-texframe* (top-texframe)))) - (cond - ((lassoc name (texframe.dimens frame) string=?) - => - (lambda (c) (set-car! (cdr c) len))) - (else - (set!texframe.dimens - frame - (cons (list name len) (texframe.dimens frame))))) - (perform-afterassignment)))) - -(define tex-def-char - (lambda (char argpat expansion frame) - (unless frame (set! frame (top-texframe))) - (let ((d (ensure-cdef char frame))) - (set!cdef.argpat d argpat) - (set!cdef.expansion d expansion)) - (perform-afterassignment))) - -(define ensure-cdef - (lambda (c f) - (let ((x (assoc c (texframe.chardefinitions f)))) - (if x - (cdr x) - (let ((d (make-cdef))) - (set!texframe.chardefinitions - f - (cons (cons c d) (texframe.chardefinitions f))) - d))))) - -(define find-chardef - (lambda (c) - (let ((x - (or (ormap - (lambda (f) (assoc c (texframe.chardefinitions f))) - *tex-env*) - (assoc c (texframe.chardefinitions *global-texframe*)) - (assoc c (texframe.chardefinitions *primitive-texframe*))))) - (and x (let ((d (cdr x))) (and (cdef.active d) d)))))) - -(define find-chardef-in-top-frame - (lambda (c) - (let ((x - (if (null? *tex-env*) - (or (assoc c (texframe.chardefinitions *global-texframe*)) - (assoc c (texframe.chardefinitions *primitive-texframe*))) - (assoc c (texframe.chardefinitions (car *tex-env*)))))) - (and x (let ((d (cdr x))) (and (cdef.active d) d)))))) - -(define do-defcsactive - (lambda (g?) - (ignorespaces) - (let* ((cs (get-ctl-seq)) - (c (string-ref cs 1)) - (argpat (get-def-arguments c)) - (rhs (ungroup (get-group))) - (f (and g? *global-texframe*))) - (activate-cdef c) - (tex-def-char c argpat rhs f)))) - -(define activate-cdef - (lambda (c) - (let ((y - (cond - ((find-chardef-in-top-frame c) - => - (lambda (y) (set!cdef.active y #t) y)) - (else - (let* ((d (find-chardef c)) (y (ensure-cdef c (top-texframe)))) - (when d (kopy-cdef y d)) - (set!cdef.active y #t) - y))))) - (add-postlude-to-top-frame (lambda () (set!cdef.active y #f)))))) - -(define deactivate-cdef - (lambda (c) - (cond - ((find-chardef-in-top-frame c) => (lambda (y) (set!cdef.active y #f))) - ((find-chardef c) - => - (lambda (y) - (let ((d (ensure-cdef c (top-texframe)))) - (kopy-cdef d y) - (set!cdef.active d #f))))))) - -(define do-undefcsactive - (lambda () (ignorespaces) (deactivate-cdef (string-ref (get-ctl-seq) 1)))) - -(define do-catcode - (lambda () - (let* ((c (get-tex-char-spec)) (val (begin (get-equal-sign) (get-number)))) - (set-catcode c val)))) - -(define set-catcode - (lambda (c val) - (unless (= val 13) (deactivate-cdef c)) - (unless (= val 11) (ldelete c *tex-extra-letters* char=?)) - (case val - ((0) (set! *esc-char* 0)) - ((11) (set! *tex-extra-letters* (cons c *tex-extra-letters*))) - ((13) (activate-cdef c))))) - -(define do-global - (lambda () - (ignorespaces) - (let ((next (get-ctl-seq))) - (cond - ((string=? next "\\def") (do-def #t #f)) - ((string=? next "\\edef") (do-def #t #t)) - ((string=? next "\\let") (do-let #t)) - ((string=? next "\\newcount") (do-newcount #t)) - ((string=? next "\\newtoks") (do-newtoks #t)) - ((string=? next "\\newdimen") (do-newdimen #t)) - ((string=? next "\\advance") (do-advance #t)) - ((string=? next "\\multiply") (do-multiply #t)) - ((string=? next "\\divide") (do-divide #t)) - ((string=? next "\\read") (do-read #t)) - ((ormap (lambda (z) (string=? next z)) '("\\imgdef" "\\gifdef")) - (make-reusable-img #t)) - ((find-count next) (do-count= next #t)) - ((find-toks next) (do-toks= next #t)) - (else (toss-back-string next)))))) - -(define do-externaltitle - (lambda () - (write-aux `(!preferred-title ,(tex-string->html-string (get-group)))))) - -(define tex2page-string - (lambda (s) (call-with-input-string/buffered s (lambda () (generate-html))))) - -(define make-external-title - (lambda (title) - (fluid-let - ((*outputting-external-title?* #t)) - (bgroup) - (let ((s - (tex-string->html-string - (string-append - "\\let\\\\\\ignorespaces" - "\\def\\resizebox#1#2#3{}" - "\\let\\thanks\\TIIPgobblegroup" - "\\let\\urlh\\TIIPgobblegroup " - title)))) - (egroup) - s)))) - -(define output-external-title - (lambda () - (fluid-let - ((*outputting-external-title?* #t)) - (emit "") - (emit-newline) - (emit (or *title* *jobname*)) - (emit-newline) - (emit "") - (emit-newline)))) - -(define output-title - (lambda (title) - (emit "

") - (bgroup) - (tex2page-string (string-append "\\let\\\\\\break " title)) - (egroup) - (emit "

") - (emit-newline))) - -(define do-subject - (lambda () - (do-end-para) - (let ((title (get-group))) - (unless *title* (flag-missing-piece 'document-title)) - (write-aux `(!default-title ,(make-external-title title))) - (output-title title)))) - -(define do-latex-title - (lambda () - (let ((title (get-group))) - (unless *title* (flag-missing-piece 'document-title)) - (write-aux `(!default-title ,(make-external-title title))) - (toss-back-string title) - (toss-back-string "\\def\\TIIPtitle")))) - -(define do-title - (lambda () ((if (eqv? *tex-format* 'latex) do-latex-title do-subject)))) - -(define do-author (lambda () (toss-back-string "\\def\\TIIPauthor"))) - -(define do-date (lambda () (toss-back-string "\\def\\TIIPdate"))) - -(define do-today - (lambda () - (let ((m (get-gcount "\\month"))) - (if (= m 0) - (emit "[today]") - (begin - (emit (vector-ref *month-names* (- m 1))) - (emit " ") - (emit (get-gcount "\\day")) - (emit ", ") - (emit (get-gcount "\\year"))))))) - -(define add-afterpar (lambda (ap) (set! *afterpar* (cons ap *afterpar*)))) - -(define do-end-para - (lambda () - (when *in-para?* - (when *use-closing-p-tag?* (emit "

")) - (unless (null? *afterpar*) - (for-each (lambda (ap) (ap)) (reverse! *afterpar*)) - (set! *afterpar* '())) - (emit-newline) - (set! *in-para?* #f)))) - -(define do-para - (lambda () - (do-end-para) - (let ((in-table? - (and (not (null? *tabular-stack*)) - (memv (car *tabular-stack*) '(block))))) - (when in-table? (emit "") (emit-newline)) - (emit "

") - (set! *in-para?* #t)))) - -(define do-noindent - (lambda () - (do-end-para) - (emit-newline) - (emit "

") - (set! *in-para?* #t))) - -(define do-maketitle - (lambda () - (do-end-para) - (bgroup) - (tex2page-string - (string-append - "\\let\\\\\\break" - "\\let\\and\\break" - "\\let\\thanks\\symfootnote")) - (output-title "\\TIIPtitle") - (do-para) - (do-end-para) - (emit "

") - (emit-newline) - (tex2page-string "\\TIIPauthor") - (do-para) - (tex2page-string "\\TIIPdate") - (do-end-para) - (emit "
") - (emit-newline) - (egroup) - (do-para))) - -(define do-inputcss - (lambda () - (ignorespaces) - (let ((f (get-filename-possibly-braced))) - (when (null? *stylesheets*) (flag-missing-piece 'stylesheets)) - (write-aux `(!stylesheet ,f))))) - -(define do-csname - (lambda () - (ignorespaces) - (let loop ((r '())) - (let ((c (snoop-actual-char))) - (cond - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (cond - ((string=? x "\\endcsname") - (toss-back-char #\}) - (for-each toss-back-string r) - (toss-back-char *esc-char*) - (toss-back-char #\{) - (toss-back-string "TIIPcsname") - (toss-back-char *esc-char*)) - (else (loop (cons (expand-ctl-seq-into-string x) r)))))) - (else (get-actual-char) (loop (cons (string c) r)))))))) - -(define do-saved-csname - (lambda () (let ((x (get-peeled-group))) (do-tex-ctl-seq x)))) - -(define do-cssblock - (lambda () - (fluid-let - ((*dumping-nontex?* #t)) - (dump-till-end-env "cssblock" *css-port*)))) - -(define link-stylesheets - (lambda () - (emit "") - (emit-newline) - (for-each - (lambda (css) - (emit "") - (emit-newline)) - *stylesheets*))) - -(define increment-section-counter - (lambda (seclvl unnumbered?) - (unless unnumbered? - (hash-table-put! - *section-counters* - seclvl - (+ 1 (table-get *section-counters* seclvl 0)))) - (hash-table-for-each - *section-counters* - (lambda (k v) - (if (and (> k seclvl) (> k 0)) - (hash-table-put! *section-counters* k 0)))) - (when (= seclvl 0) (set-gcount! "\\footnotenumber" 0)) - (for-each - (lambda (counter-name) - (set!counter.value (table-get *dotted-counters* counter-name) 0)) - (table-get *section-counter-dependencies* seclvl '())))) - -(define section-counter-value - (lambda (seclvl) - (if (= seclvl -1) - (number->roman (table-get *section-counters* -1) #t) - (let ((i (if *using-chapters?* 0 1))) - (let ((outermost-secnum - (let ((n (table-get *section-counters* i 0))) - (if *inside-appendix?* - (string (integer->char (+ (char->integer #\A) -1 n))) - (number->string n))))) - (let loop ((i (+ i 1)) (r outermost-secnum)) - (if (> i seclvl) - r - (loop - (+ i 1) - (string-append - r - "." - (number->string (table-get *section-counters* i 0))))))))))) - -(define section-ctl-seq? - (lambda (s) - (cond - ((string=? s "\\sectiond") (string->number (ungroup (get-token)))) - ((string=? s "\\part") -1) - ((string=? s "\\chapter") - (!using-chapters) - (write-aux `(!using-chapters)) - (if (and (eqv? *tex-format* 'latex) (< (get-gcount "\\secnumdepth") -1)) - (set-gcount! "\\secnumdepth" 2)) - 0) - (else - (let ((n (string-length s))) - (cond - ((< n 8) #f) - ((and (>= n 10) (string=? (substring s (- n 9) n) "paragraph")) - (let ((n-9 (- n 9))) - (let loop ((i 1) (i+3 4) (k 4)) - (cond - ((> i+3 n-9) k) - ((string=? (substring s i i+3) "sub") - (loop i+3 (+ i+3 3) (+ k 1))) - (else #f))))) - ((string=? (substring s (- n 7) n) "section") - (let ((n-7 (- n 7))) - (let loop ((i 1) (i+3 4) (k 1)) - (cond - ((> i+3 n-7) k) - ((string=? (substring s i i+3) "sub") - (loop i+3 (+ i+3 3) (+ k 1))) - (else #f))))) - (else #f))))))) - -(define do-heading - (lambda (seclvl) - (let* ((starred? - (cond - ((char=? (snoop-actual-char) #\*) (get-actual-char) #t) - (else #f))) - (too-deep? - (let ((secnumdepth (get-gcount "\\secnumdepth"))) - (cond - ((< secnumdepth -1) #f) - ((> seclvl secnumdepth) #t) - (else #f)))) - (unnumbered? (or starred? too-deep?)) - (header - (fluid-let - ((*tabular-stack* (list 'header))) - (tex-string->html-string (get-group))))) - (when (<= seclvl 0) (do-eject)) - (increment-section-counter seclvl unnumbered?) - (let ((lbl-val (if unnumbered? #f (section-counter-value seclvl)))) - (do-heading-aux seclvl starred? unnumbered? #f lbl-val header))))) - -(define do-heading-aux - (lambda (seclvl starred? unnumbered? chapname lbl-val header) - (unless lbl-val (set! lbl-val "IGNORE")) - (let* ((htmlnum (max 1 (min 6 (if *using-chapters?* (+ seclvl 1) seclvl)))) - (lbl - (string-append - *html-node-prefix* - (case seclvl ((-1) "part") ((0) "chap") (else "sec")) - "_" - (if unnumbered? (gen-temp-string) lbl-val)))) - (unless #f - (tex-def-0arg "\\TIIPcurrentnodename" lbl) - (tex-def-0arg "\\@currentlabel" lbl-val)) - (do-end-para) - (emit-anchor lbl) - (emit-newline) - (ignore-all-whitespace) - (emit "") - (let ((write-to-toc? - (and *toc-page* - (not - (and (eqv? *tex-format* 'latex) - (string=? header "Contents")))))) - (case seclvl - ((-1) - (emit "
") - (if unnumbered? - (emit-nbsp 1) - (begin - (when write-to-toc? - (emit-page-node-link-start - *toc-page* - (string-append *html-node-prefix* "toc_" lbl))) - (tex2page-string (or chapname "\\partname")) - (emit " ") - (emit lbl-val) - (when write-to-toc? (emit-link-stop)))) - (emit "

") - (emit-newline)) - ((0) - (emit-newline) - (emit "
") - (if unnumbered? - (emit-nbsp 1) - (begin - (when write-to-toc? - (emit-page-node-link-start - *toc-page* - (string-append *html-node-prefix* "toc_" lbl))) - (tex2page-string - (or chapname - (if *inside-appendix?* "\\appendixname" "\\chaptername"))) - (emit " ") - (emit lbl-val) - (when write-to-toc? (emit-link-stop)))) - (emit "

") - (emit-newline))) - (when write-to-toc? - (emit-page-node-link-start - *toc-page* - (string-append *html-node-prefix* "toc_" lbl))) - (unless (or (<= seclvl 0) unnumbered?) (emit lbl-val) (emit-nbsp 2)) - (emit header) - (when write-to-toc? (emit-link-stop)) - (emit "") - (emit-newline) - (do-para) - (let ((tocdepth (get-gcount "\\tocdepth"))) - (when (and - write-to-toc? - (not (and (eqv? *tex-format* 'latex) starred?)) - (or (< tocdepth -1) (<= seclvl tocdepth))) - (write-aux - `(!toc-entry - ,(if (= seclvl -1) - -1 - (if *using-chapters?* seclvl (- seclvl 1))) - ,lbl-val - ,*html-page-count* - ,lbl - ,header))))) - (when *recent-node-name* - (do-label-aux *recent-node-name*) - (set! *recent-node-name* #f))))) - -(define section-type-to-depth - (lambda (sectype) - (cond - ((string->number sectype)) - ((string=? sectype "chapter") 0) - ((string=? sectype "section") 1) - ((string=? sectype "subsection") 2) - ((string=? sectype "subsubsection") 3) - ((string=? sectype "paragraph") 4) - ((string=? sectype "subparagraph") 5) - (else 3)))) - -(define do-write-to-toc-aux - (lambda (seclvl secnum sectitle) - (let ((node-name - (string-append - *html-node-prefix* - "sec_" - (if (string=? secnum "") (gen-temp-string) secnum)))) - (tex-def-0arg "\\TIIPcurrentnodename" node-name) - (tex-def-0arg "\\@currentlabel" secnum) - (emit-anchor node-name) - (emit-newline) - (write-aux - `(!toc-entry - ,seclvl - ,secnum - ,*html-page-count* - ,node-name - ,sectitle))))) - -(define do-writenumberedcontentsline - (lambda () - (let ((toc (get-peeled-group))) - (unless (string=? toc "toc") - (terror 'do-writenumberedcontentsline "only #1=toc supported")) - (do-writenumberedtocline)))) - -(define do-writenumberedtocline - (lambda () - (let* ((seclvl (section-type-to-depth (get-peeled-group))) - (secnum (tex-string->html-string (get-group))) - (sectitle (tex-string->html-string (get-group)))) - (do-write-to-toc-aux seclvl secnum sectitle)))) - -(define do-addcontentsline - (lambda () - (let* ((toc (get-peeled-group))) - (unless (string=? toc "toc") - (terror 'do-addcontentsline "only #1=toc supported")) - (let* ((seclvl (section-type-to-depth (get-peeled-group))) - (sectitle (tex-string->html-string (get-group)))) - (write-aux - `(!toc-entry - ,(if (= seclvl -1) -1 (if *using-chapters?* seclvl (- seclvl 1))) - ,(find-def-0arg "\\@currentlabel") - ,*html-page-count* - ,(find-def-0arg "\\TIIPcurrentnodename") - ,sectitle)))))) - -(define do-documentclass - (lambda () - (probably-latex) - (get-bracketed-text-if-any) - (let ((x (get-peeled-group))) - (when (ormap (lambda (z) (string=? x z)) '("report" "book")) - (!using-chapters) - (write-aux `(!using-chapters)))))) - -(define get-till-par - (lambda () - (let loop ((r '()) (newline? #f)) - (let ((c (get-actual-char))) - (cond - ((or (eof-object? c) (and newline? (char=? c #\newline))) - (list->string (reverse! r))) - (newline? - (if (char-whitespace? c) - (loop r #t) - (loop (cons c (cons #\space r)) #f))) - ((char=? c #\newline) (loop r #t)) - (else (loop (cons c r) #f))))))) - -(define do-beginsection - (lambda () - (do-para) - (ignorespaces) - (let ((header (get-till-par))) - (emit-newline) - (emit "

") - (bgroup) - (if (string=? header "") - (emit-nbsp 1) - (fluid-let - ((*tabular-stack* (list 'header))) - (tex2page-string header))) - (egroup) - (emit "

") - (emit-newline)))) - -(define do-appendix - (lambda () - (unless *inside-appendix?* - (set! *inside-appendix?* #t) - (hash-table-put! *section-counters* (if *using-chapters?* 0 1) 0)))) - -(define do-table-plain - (lambda () (do-end-para) (emit "
"))) - -(define do-end-table-plain - (lambda () (do-end-para) (emit "
"))) - -(define do-table/figure - (lambda (type) - (do-end-para) - (bgroup) - (when (and (eqv? type 'figure) (char=? (snoop-actual-char) #\*)) - (get-actual-char)) - (set! *tabular-stack* (cons type *tabular-stack*)) - (get-bracketed-text-if-any) - (let ((tbl-tag - (string-append - *html-node-prefix* - (if (eqv? type 'table) "tbl_" "fig_") - (gen-temp-string)))) - (tex-def-0arg "\\TIIPcurrentnodename" tbl-tag) - (emit-anchor tbl-tag) - (emit-newline) - (emit "
") - (emit "
")))) - -(define pop-tabular-stack - (lambda (type) - (if (null? *tabular-stack*) - (terror 'pop-tabular-stack "Bad environment closer: " type) - (set! *tabular-stack* (cdr *tabular-stack*))))) - -(define do-end-table/figure - (lambda (type) - (when (and (eqv? type 'figure) (char=? (snoop-actual-char) #\*)) - (get-actual-char)) - (do-end-para) - (emit "
") - (emit "
") - (pop-tabular-stack type) - (egroup) - (do-para))) - -(define bump-dotted-counter - (lambda (name) - (let* ((counter (table-get *dotted-counters* name)) - (new-value (+ 1 (counter.value counter)))) - (set!counter.value counter new-value) - (let ((num - (string-append - (cond - ((counter.within counter) - => - (lambda (sec-num) - (string-append (section-counter-value sec-num) "."))) - (else "")) - (number->string new-value)))) - (tex-def-0arg "\\@currentlabel" num) - num)))) - -(define do-caption - (lambda () - (do-end-para) - (let* ((i-fig (list-index *tabular-stack* 'figure)) - (i-tbl (list-index *tabular-stack* 'table)) - (type - (cond - ((and (not i-fig) (not i-tbl)) - (terror 'do-caption "Mislaid \\caption")) - ((not i-fig) 'table) - ((not i-tbl) 'figure) - ((< i-fig i-tbl) 'figure) - ((< i-tbl i-fig) 'table) - (else (terror 'do-caption "cant happen")))) - (counter-name (if (eqv? type 'table) "table" "figure")) - (caption-title (if (eqv? type 'table) "\\tablename" "\\figurename")) - (num (bump-dotted-counter counter-name))) - (get-bracketed-text-if-any) - (emit "") - (emit-newline) - (emit "") - (tex2page-string caption-title) - (emit " ") - (emit num) - (emit ":") - (emit-nbsp 2) - (tex2page-string (get-group)) - (emit "") - (emit-newline) - (emit "")))) - -(define do-marginpar - (lambda () - (get-bracketed-text-if-any) - (emit "
") - (tex2page-string (get-group)) - (emit "
"))) - -(define do-minipage - (lambda () - (get-bracketed-text-if-any) - (get-group) - (let ((in-table? - (and (not (null? *tabular-stack*)) - (memv (car *tabular-stack*) '(block figure table))))) - (if in-table? (emit "") (begin (do-para) (do-end-para))) - (emit "
") - (set! *tabular-stack* (cons 'minipage *tabular-stack*))))) - -(define do-endminipage - (lambda () - (pop-tabular-stack 'minipage) - (let ((in-table? - (and (not (null? *tabular-stack*)) - (memv (car *tabular-stack*) '(block figure table))))) - (emit "
") - (if in-table? (emit "") (do-para))))) - -(define do-tabbing - (lambda () (set! *tabular-stack* (cons 'tabbing *tabular-stack*)) (do-para))) - -(define do-end-tabbing (lambda () (pop-tabular-stack 'tabbing) (do-para))) - -(define do-equation - (lambda (type) - (cond - ((and (tex2page-flag-boolean "\\TZPmathimage") - (not *temporarily-use-ascii-for-math?*)) - (do-latex-env-as-image - (if (eqv? type 'equation) "equation" "eqnarray") - 'display)) - (else - (do-end-para) - (bgroup) - (when (and (eqv? type 'eqnarray) (eat-star)) (set! type 'eqnarray*)) - (set! *tabular-stack* (cons type *tabular-stack*)) - (set! *math-mode?* #t) - (set! *in-display-math?* #t) - (let ((eqn-tag - (string-append *html-node-prefix* "eqn_" (gen-temp-string)))) - (tex-def-0arg "\\TIIPcurrentnodename" eqn-tag) - (emit-anchor eqn-tag) - (emit-newline) - (unless (eqv? type 'eqnarray*) - (set! *equation-number* (bump-dotted-counter "equation"))) - (emit "
") - (emit-newline) - (emit "") - (unless (or - (and (not (null? *tabular-stack*)) - (eqv? (car *tabular-stack*) 'eqnarray*)) - (not *equation-numbered?*)) - (emit "")) - (emit "") - (emit-newline) - (emit "
")))))) - -(define do-end-equation - (lambda () - (do-end-para) - (emit "(") - (emit *equation-number*) - (emit ")
") - (pop-tabular-stack 'equation) - (set! *math-mode?* #f) - (set! *in-display-math?* #f) - (egroup) - (set! *equation-numbered?* #t) - (set! *equation-position* 0) - (do-para))) - -(define do-eqnarray - (lambda () - (do-end-para) - (bgroup) - (let ((star? (eat-star))) - (set! *tabular-stack* - (cons (if star? 'eqnarray* 'eqnarray) *tabular-stack*)) - (set! *math-mode?* #t) - (let ((eqn-tag - (string-append *html-node-prefix* "eqn_" (gen-temp-string)))) - (tex-def-0arg "\\TIIPcurrentnodename" eqn-tag) - (emit-anchor eqn-tag) - (emit-newline) - (emit "
") - (emit-newline) - (emit "
"))))) - -(define do-nonumber (lambda () (set! *equation-numbered?* #f))) - -(define indent-n-levels - (lambda (n) - (let loop ((i -1)) - (unless (>= i n) - (emit-nbsp 1) - (emit " ") - (emit-nbsp 1) - (emit " ") - (loop (+ i 1)))))) - -(define do-toc - (lambda () - (fluid-let - ((*subjobname* (string-append *jobname* *toc-file-suffix*)) - (*img-file-count* 0) - (*imgdef-file-count* 0)) - (when (eqv? *tex-format* 'latex) - (tex2page-string - (if *using-chapters?* - "\\chapter*{\\contentsname}" - "\\section*{\\contentsname}"))) - (emit-anchor (string-append *html-node-prefix* "toc_start")) - (!toc-page *html-page-count*) - (write-aux `(!toc-page ,*html-page-count*)) - (cond - ((null? *toc-list*) - (flag-missing-piece 'toc) - (non-fatal-error "Table of contents not generated; rerun TeX2page")) - (else - (do-noindent) - (let ((tocdepth (get-gcount "\\tocdepth"))) - (for-each - (lambda (x) - (let* ((lvl (tocentry.level x)) - (secnum (tocentry.number x)) - (seclabel (tocentry.label x)) - (subentries? - (or (= lvl -1) - (and (= lvl 0) - (or (< tocdepth -1) - (and *using-chapters?* (> tocdepth 0)) - (and (not *using-chapters?*) - (> tocdepth 1))))))) - (when subentries? - (if *tex-like-layout?* (do-bigskip 'medskip) (do-para)) - (do-noindent) - (emit "") - (emit-newline)) - (indent-n-levels lvl) - (emit-anchor - (string-append *html-node-prefix* "toc_" seclabel)) - (emit-page-node-link-start (tocentry.page x) seclabel) - (unless (or (string=? secnum "") (string=? secnum "IGNORE")) - (emit secnum) - (emit-nbsp 2)) - (fluid-let - ((*tabular-stack* (list 'header))) - (emit (tocentry.header x))) - (emit-link-stop) - (when subentries? (emit "")) - (emit "
") - (emit-newline))) - *toc-list*))))))) - -(defstruct footnotev mark text tag caller) - -(define do-numbered-footnote (lambda () (do-footnote-aux #f))) - -(define do-symfootnote - (lambda () - (set! *footnote-sym* (+ *footnote-sym* 1)) - (do-footnote-aux (number->footnote-symbol *footnote-sym*)))) - -(define number->footnote-symbol - (let ((symlist #f)) - (lambda (n) - (unless symlist - (set! symlist - (fluid-let - ((*temporarily-use-ascii-for-math?* #t)) - (map - tex-string->html-string - '("*" - "\\dag" - "\\ddag" - "\\S" - "\\P" - "$\\Vert$" - "**" - "\\dag\\dag" - "\\ddag\\ddag"))))) - (list-ref symlist (modulo (- n 1) 9))))) - -(define do-plain-footnote - (lambda () - (do-footnote-aux - (fluid-let - ((*temporarily-use-ascii-for-math?* #t)) - (tex-string->html-string (get-token)))))) - -(define do-footnote - (lambda () - ((if (eqv? *tex-format* 'latex) do-numbered-footnote do-plain-footnote)))) - -(define do-footnote-aux - (lambda (fnmark) - (let* ((fnno #f) - (fnlabel (gen-temp-string)) - (fntag (string-append *html-node-prefix* "footnote_" fnlabel)) - (fncalltag - (string-append *html-node-prefix* "call_footnote_" fnlabel))) - (unless fnmark - (set! fnno (+ (get-gcount "\\footnotenumber") 1)) - (set-gcount! "\\footnotenumber" fnno) - (set! fnmark (number->string fnno))) - (emit-anchor fncalltag) - (when fnno (emit "")) - (emit-page-node-link-start #f fntag) - (emit fnmark) - (emit-link-stop) - (when fnno (emit "")) - (do-vfootnote-aux fnmark fncalltag fntag)))) - -(define do-vfootnote - (lambda () - (do-vfootnote-aux - (fluid-let - ((*temporarily-use-ascii-for-math?* #t)) - (tex-string->html-string (get-token))) - #f - #f))) - -(define do-vfootnote-aux - (lambda (fnmark fncalltag fntag) - (ignorespaces) - (unless (char=? (get-actual-char) #\{) - (terror 'do-vfootnote-aux "Missing {")) - (bgroup) - (let ((old-html *html*) (fn-tmp-port (open-output-string))) - (set! *html* fn-tmp-port) - (when fncalltag - (tex-def-0arg "\\TIIPcurrentnodename" fntag) - (tex-def-0arg "\\@currentlabel" fnmark)) - (add-aftergroup-to-top-frame - (lambda () - (set! *footnote-list* - (cons - (make-footnotev - 'mark - fnmark - 'text - (get-output-string fn-tmp-port) - 'tag - fntag - 'caller - fncalltag) - *footnote-list*)) - (set! *html* old-html)))))) - -(define output-footnotes - (lambda () - (let ((n (length *footnote-list*))) - (unless (= n 0) - (emit "
") - (do-para) - (do-end-para) - (emit "
") - (let loop ((i (- n 1))) - (unless (< i 0) - (let* ((fv (list-ref *footnote-list* i)) - (fnmark (footnotev.mark fv)) - (fnno (string->number fnmark)) - (fncalltag (footnotev.caller fv))) - (do-para) - (when fncalltag - (emit-anchor (footnotev.tag fv)) - (when fnno (emit "")) - (emit-page-node-link-start #f fncalltag)) - (emit fnmark) - (when fncalltag - (emit-link-stop) - (when fnno (emit ""))) - (emit " ") - (emit (footnotev.text fv)) - (do-end-para) - (loop (- i 1))))) - (emit "
") - (emit-newline))))) - -(define rgb.dec->hex - (let ((f - (lambda (x) - (let* ((n (inexact->exact (round (* 1.0 x)))) - (s (number->string n 16))) - (if (< n 16) (string-append "0" s) s))))) - (lambda (r g b) (string-append (f r) (f g) (f b))))) - -(define rgb.frac->hex - (lambda (r g b) (rgb.dec->hex (* r 255) (* g 255) (* b 255)))) - -(define cmyk->rgb - (let ((f (lambda (x k) (- 1 (min (max (+ x k) 0) 1))))) - (lambda (c m y k) (rgb.frac->hex (f c k) (f m k) (f y k))))) - -(define do-color - (lambda () - (let ((model (get-bracketed-text-if-any))) - (do-switch - (cond - ((not model) 'colornamed) - ((string=? model "rgb") 'rgb) - ((string=? model "RGB") 'rgb255) - ((string=? model "cmyk") 'cmyk) - ((string=? model "gray") 'gray) - (else 'colornamed)))))) - -(define do-definecolor - (lambda () - (let* ((name (get-peeled-group)) - (model (get-peeled-group)) - (spec (get-peeled-group))) - (bgroup) - (set! *color-names* - (cons - (cons - name - (if (string=? model "named") - (let ((c (lassoc name *color-names* string=?))) - (if c - (cdr c) - (terror 'do-definecolor "Color name " name " not defined"))) - (let ((rgb #f)) - (call-with-input-string - (tex-string->html-string - (string-append "\\defcsactive\\,{ }" spec)) - (lambda (i) - (cond - ((string=? model "cmyk") - (let* ((c (read i)) (m (read i)) (y (read i)) (k (read i))) - (cmyk->rgb c m y k))) - ((string=? model "rgb") - (let* ((r (read i)) (g (read i)) (b (read i))) - (rgb.frac->hex r g b))) - ((string=? model "gray") (cmyk->rgb 0 0 0 (read i))) - (else (terror 'do-definecolor "Unknown color model")))))))) - *color-names*)) - (egroup)))) - -(define do-switch - (lambda (sw) - (unless *outputting-external-title?* - (add-postlude-to-top-frame - (case sw - ((rm) - (when *math-mode?* - (let ((old-math-roman-mode? *math-roman-mode?*)) - (set! *math-roman-mode?* #t) - (lambda () (set! *math-roman-mode?* old-math-roman-mode?))))) - ((em) (emit "") (lambda () (emit ""))) - ((it itshape) (emit "") (lambda () (emit ""))) - ((bf strong) (emit "") (lambda () (emit ""))) - ((sl) - (emit "") - (lambda () (emit ""))) - ((sf) - (emit "") - (lambda () (emit ""))) - ((tt) - (let ((old-ligatures? *ligatures?*)) - (set! *ligatures?* #f) - (emit "") - (lambda () (emit "") (set! *ligatures?* old-ligatures?)))) - ((sc scshape) - (let ((old-in-small-caps? *in-small-caps?*)) - (set! *in-small-caps?* #t) - (lambda () (set! *in-small-caps?* old-in-small-caps?)))) - ((span) - (emit "") - (lambda () (emit ""))) - ((div) - (emit "
") - (lambda () (emit "
"))) - ((tiny) (emit "") (lambda () (emit ""))) - ((scriptsize) - (emit "") - (lambda () (emit ""))) - ((footnotesize fiverm) - (emit "") - (lambda () (emit ""))) - ((small sevenrm) - (emit "") - (lambda () (emit ""))) - ((normalsize) - (emit "") - (lambda () (emit ""))) - ((large) (emit "") (lambda () (emit ""))) - ((large-cap) - (emit "") - (lambda () (emit ""))) - ((large-up) - (emit "") - (lambda () (emit ""))) - ((huge) (emit "") (lambda () (emit ""))) - ((huge-cap) - (emit "") - (lambda () (emit ""))) - ((cmyk) - (bgroup) - (call-with-input-string - (tex-string->html-string - (string-append "\\defcsactive\\,{ }" (get-token))) - (lambda (i) - (let* ((c (read i)) (m (read i)) (y (read i)) (k (read i))) - (ignorespaces) - (emit "rgb c m y k)) - (emit "\">")))) - (egroup) - (lambda () (emit ""))) - ((rgb) - (bgroup) - (call-with-input-string - (tex-string->html-string - (string-append "\\defcsactive\\,{ }" (get-token))) - (lambda (i) - (let* ((r (read i)) (g (read i)) (b (read i))) - (ignorespaces) - (emit "hex r g b)) - (emit "\">")))) - (egroup) - (lambda () (emit ""))) - ((rgb255) - (bgroup) - (call-with-input-string - (tex-string->html-string - (string-append "\\defcsactive\\,{ }" (get-token))) - (lambda (i) - (let* ((r (read i)) (g (read i)) (b (read i))) - (ignorespaces) - (emit "hex r g b)) - (emit "\">")))) - (egroup) - (lambda () (emit ""))) - ((gray) - (call-with-input-string - (tex-string->html-string (get-token)) - (lambda (i) - (let ((g (read i))) - (ignorespaces) - (emit "rgb 0 0 0 (- 1 g))) - (emit "\">")))) - (lambda () (emit ""))) - ((colornamed) - (let* ((name (get-peeled-group)) - (c (lassoc name *color-names* string=?))) - (ignorespaces) - (emit "") - (lambda () (emit "")))) - ((bgcolor) - (emit "number color 16) (emit "#")) - (emit color) - (emit "\">") - (lambda () (emit "")))) - ((strike) (emit "") (lambda () (emit ""))) - ((narrower) (emit "
") (lambda () (emit "
"))) - ((raggedleft) - (do-end-para) - (emit "
") - (lambda () (do-end-para) (emit "
") (do-para))) - (else - (emit "") - (lambda () (emit "")))))))) - -(define do-obeylines - (lambda () - (if (eqv? (snoop-actual-char) #\newline) (get-actual-char)) - (activate-cdef #\newline) - (tex-def-char #\newline '() "\\TIIPbr" #f))) - -(define do-obeyspaces - (lambda () - (activate-cdef #\space) - (tex-def-char #\space '() "\\TIIPnbsp" #f))) - -(define do-obeywhitespace (lambda () (do-obeylines) (do-obeyspaces))) - -(define do-block - (lambda (z) - (do-end-para) - (emit "
") - (set! *tabular-stack* (cons 'block *tabular-stack*)) - (emit "
") - (bgroup) - (emit-newline))) - -(define do-end-block - (lambda () - (do-end-para) - (egroup) - (emit "
") - (pop-tabular-stack 'block) - (emit-newline))) - -(define do-function - (lambda (fn) - (fluid-let - ((*math-mode?* *math-mode?*)) - (cond - (*outputting-external-title?* #f) - ((string=? fn "\\emph") (emit "")) - ((string=? fn "\\leftline") (do-end-para) (emit "
")) - ((string=? fn "\\centerline") - (do-end-para) - (emit "
 ")) - ((string=? fn "\\rightline") - (do-end-para) - (emit "
 ")) - ((string=? fn "\\underline") (emit "")) - ((string=? fn "\\textbf") (set! *math-mode?* #f) (emit "")) - ((ormap (lambda (z) (string=? fn z)) '("\\textit" "\\textsl")) - (set! *math-mode?* #f) - (emit "")) - ((string=? fn "\\textrm") (set! *math-mode?* #f)) - ((string=? fn "\\texttt") (set! *math-mode?* #f) (emit "")) - (else (terror 'do-function "Unknown function " fn))) - (bgroup) - (tex2page-string (get-token)) - (egroup) - (cond - (*outputting-external-title?* #f) - ((string=? fn "\\emph") (emit "")) - ((string=? fn "\\rightline") (emit "
") (emit-newline)) - ((ormap (lambda (z) (string=? fn z)) '("\\leftline" "\\centerline")) - (do-end-para) - (emit " 
") - (emit-newline)) - ((string=? fn "\\underline") (emit "")) - ((string=? fn "\\textbf") (emit "")) - ((ormap (lambda (z) (string=? fn z)) '("\\textsl" "\\textit")) - (emit "")) - ((string=? fn "\\texttt") (emit "")))))) - -(define do-discretionary - (lambda () (tex2page-string (get-group)) (get-group) (get-group))) - -(define do-aftergroup - (lambda () - (ignorespaces) - (let ((z (get-ctl-seq))) - (add-aftergroup-to-top-frame (lambda () (toss-back-string z)))))) - -(define do-afterassignment - (lambda () - (ignorespaces) - (let ((z (get-ctl-seq))) (set! *afterassignment* z)))) - -(define do-space (lambda () (emit #\space))) - -(define do-tab (lambda () (emit-nbsp 8))) - -(define emit-nbsp - (lambda (n) - (let loop ((n n)) (unless (<= n 0) (emit " ") (loop (- n 1)))))) - -(define scaled-point-equivalent-of - (lambda (unit) - (case unit - ((sp) 1) - ((pt) 65536) - ((bp) (* (/ 72) (scaled-point-equivalent-of 'in))) - ((cc) (* 12 (scaled-point-equivalent-of 'dd))) - ((dd) (* (/ 1238 1157) (scaled-point-equivalent-of 'pt))) - ((em) (* 10 (scaled-point-equivalent-of 'pt))) - ((ex) (* 4.5 (scaled-point-equivalent-of 'pt))) - ((in) (* 72.27 (scaled-point-equivalent-of 'pt))) - ((mm) (* 0.1 (scaled-point-equivalent-of 'cm))) - ((cm) (* (/ 2.54) (scaled-point-equivalent-of 'in))) - ((pc) (* 12 (scaled-point-equivalent-of 'pt)))))) - -(define tex-length - (lambda (num unit) (* num (scaled-point-equivalent-of unit)))) - -(define sp-to-ems (lambda (sp) (/ sp 65536 10.0))) - -(define find-dimen-in-sp (lambda (cs) (cadr (find-dimen cs)))) - -(define get-scaled-points - (lambda () - (let ((n (or (get-real) 1))) - (ignorespaces) - (* - n - (if (char=? (snoop-actual-char) *esc-char*) - (let ((x (get-ctl-seq))) (get-dimen x)) - (let loop () - (cond - ((eat-word "bp") (tex-length 1 'bp)) - ((eat-word "cc") (tex-length 1 'cc)) - ((eat-word "cm") (tex-length 1 'cm)) - ((eat-word "dd") (tex-length 1 'dd)) - ((eat-word "em") (tex-length 1 'em)) - ((eat-word "ex") (tex-length 1 'ex)) - ((eat-word "in") (tex-length 1 'in)) - ((eat-word "mm") (tex-length 1 'mm)) - ((eat-word "pc") (tex-length 1 'pc)) - ((eat-word "pt") (tex-length 1 'pt)) - ((eat-word "sp") 1) - ((eat-word "true") (loop)) - (else 1)))))))) - -(define get-points (lambda () (/ (get-scaled-points) 65536.0))) - -(define get-pixels (lambda () (inexact->exact (floor (get-points))))) - -(define do-font - (lambda () - (get-ctl-seq) - (get-equal-sign) - (eat-alphanumeric-string) - (cond ((eat-word "at") (eat-dimen)) ((eat-word "scaled") (get-number))))) - -(define do-hskip (lambda () (emit-nbsp (/ (get-pixels) 5)))) - -(define do-vskip - (lambda () - (let ((x (get-points))) - (eat-skip-fluff #f) - (emit "
") - (emit-newline) - (emit "

") - (set! *in-para?* #t)))) - -(define do-newline - (lambda () (when (>= (munch-newlines) 1) (do-para)) (emit-newline))) - -(define do-br - (lambda () - (if (or (find-chardef #\space) - (not (= (the-count "\\TIIPobeylinestrictly") 0))) - (emit "
") - (unless (eqv? (snoop-actual-char) #\newline) (emit "
"))) - (emit-newline))) - -(define do-sup - (lambda () - (emit "") - (fluid-let ((*math-script-mode?* #t)) (tex2page-string (get-token))) - (emit ""))) - -(define do-sub - (lambda () - (emit "") - (fluid-let ((*math-script-mode?* #t)) (tex2page-string (get-token))) - (emit ""))) - -(define do-hyphen - (lambda () - (cond - (*math-mode?* - (emit - (cond - (*math-roman-mode?* "-") - (*math-script-mode?* "-") - (else " - ")))) - ((not *ligatures?*) (emit #\-)) - (else - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\-)) - (begin (get-actual-char) (do-ndash)) - (emit #\-))))))) - -(define do-excl - (lambda () - (if (or *math-mode?* (not *ligatures?*)) - (emit #\!) - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\`)) - (begin (get-actual-char) (emit "¡")) - (emit #\!)))))) - -(define do-quest - (lambda () - (if (or *math-mode?* (not *ligatures?*)) - (emit #\?) - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\`)) - (begin (get-actual-char) (emit "¿")) - (emit #\?)))))) - -(define do-ndash - (lambda () - (emit - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\-)) - (begin (get-actual-char) *html-mdash*) - *html-ndash*))))) - -(define do-lsquo - (lambda () - (emit - (if (not *ligatures?*) - *html-lsquo* - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\`)) - (begin (get-actual-char) *html-ldquo*) - *html-lsquo*)))))) - -(define do-rsquo - (lambda () - (emit - (cond - (*math-mode?* - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\')) - (begin (get-actual-char) "″") - "′"))) - ((not *ligatures?*) *html-rsquo*) - (else - (let ((c (snoop-actual-char))) - (if (and (char? c) (char=? c #\')) - (begin (get-actual-char) *html-rdquo*) - *html-rsquo*))))))) - -(defstruct label (src #f) page name value) - -(define get-label - (lambda () - (let loop ((lbl (get-peeled-group))) - (let ((i - (or (string-index lbl #\space) - (string-index lbl *tab*) - (string-index lbl #\newline)))) - (if (not i) - lbl - (let loop ((s (string->list lbl)) (r '()) (ws? #f)) - (if (null? s) - (list->string (reverse! r)) - (let ((c (car s))) - (loop - (cdr s) - (if (char-whitespace? c) - (if ws? r (cons #\space r)) - (cons c r)) - (char-whitespace? c)))))))))) - -(define emit-anchor - (lambda (lbl) (emit ""))) - -(define emit-link-start - (lambda (link) (emit ""))) - -(define emit-ext-page-node-link-start - (lambda (extfile pageno node) - (emit ""))) - -(define emit-page-node-link-start - (lambda (pageno node) (emit-ext-page-node-link-start #f pageno node))) - -(define emit-link-stop (lambda () (emit ""))) - -(define do-anchor-for-potential-label - (lambda () - (let ((node-name - (string-append *html-node-prefix* "anchor_" (gen-temp-string)))) - (tex-def-0arg "\\TIIPcurrentnodename" node-name) - (emit-anchor node-name)))) - -(define do-label (lambda () (do-label-aux (get-label)))) - -(define do-node (lambda () (set! *recent-node-name* (get-peeled-group)))) - -(define do-label-aux - (lambda (label) - (let ((name (find-def-0arg "\\TIIPcurrentnodename")) - (value (find-def-0arg "\\@currentlabel"))) - (set! value (tex-string->html-string value)) - (!label label *html-page-count* name value) - (write-label `(!label ,label ,*html-page-count* ,name ,value))))) - -(define do-inputexternallabels - (lambda () - (let* ((f (get-filename-possibly-braced)) - (fq-f - (if (fully-qualified-pathname? f) f (string-append *aux-dir/* f))) - (ext-label-file (string-append fq-f *label-file-suffix* ".scm")) - (ext-label-table (table-get *external-label-tables* f))) - (unless ext-label-table - (set! ext-label-table (make-table 'equ string=?)) - (hash-table-put! *external-label-tables* f ext-label-table)) - (when (file-exists? ext-label-file) - (fluid-let - ((*label-source* fq-f) (*label-table* ext-label-table)) - (load-tex2page-data-file ext-label-file)))))) - -(define do-includeexternallabels - (lambda () - (let ((jobname (get-filename-possibly-braced))) - (let ((ext-label-file - (string-append - (if (fully-qualified-pathname? jobname) - jobname - (string-append *aux-dir/* jobname)) - *label-file-suffix* - ".scm"))) - (when (file-exists? ext-label-file) - (fluid-let - ((*label-source* jobname)) - (load-tex2page-data-file ext-label-file))))))) - -(define do-tag - (lambda () - (let ((tag-name (get-peeled-group))) (do-tag-aux tag-name (get-group))))) - -(define do-definexref - (lambda () - (let* ((tag (get-peeled-group)) (value (get-group)) (class (get-token))) - (do-tag-aux tag value)))) - -(define do-xrdef - (lambda () - (let ((tag (get-peeled-group))) - (do-tag-aux tag (number->string *html-page-count*))))) - -(define do-tag-aux - (lambda (tag-name tag-val) - (let ((node-name - (string-append *html-node-prefix* "tag_" (gen-temp-string)))) - (tex-def-0arg "\\TIIPcurrentnodename" node-name) - (tex-def-0arg "\\@currentlabel" tag-val) - (emit-anchor node-name) - (do-label-aux tag-name)))) - -(define do-htmlpagelabel - (lambda () - (let ((label (get-peeled-group))) - (!label label *html-page-count* #f #f) - (write-label `(!label ,label ,*html-page-count* #f #f))))) - -(define do-ref (lambda () (do-ref-aux (get-label) #f #f))) - -(define do-refexternal - (lambda () - (let ((ext-file (get-peeled-group))) - (do-ref-aux (get-label) ext-file #f)))) - -(define do-ref-aux - (lambda (label ext-file link-text) - (let* ((label-ref (label-bound? label ext-file)) - (label-text - (cond - (link-text (tex-string->html-string link-text)) - (label-ref (label.value label-ref)) - (else label)))) - (if label-ref - (emit-ext-page-node-link-start - (or ext-file (label.src label-ref)) - (label.page label-ref) - (label.name label-ref)) - (emit-link-start (string-append *jobname* ".hlog"))) - (emit label-text) - (emit-link-stop)))) - -(define maybe-label-page - (lambda (this-label-src this-label-pageno) - (if (and (not this-label-src) (= *html-page-count* this-label-pageno)) - "" - (string-append - (or this-label-src *jobname*) - (if (= this-label-pageno 0) - "" - (string-append - *html-page-suffix* - (number->string this-label-pageno))) - *output-extension*)))) - -(define do-htmlref - (lambda () - (let* ((text (get-group)) (lbl (get-peeled-group))) - (do-ref-aux lbl #f text)))) - -(define do-htmlrefexternal - (lambda () - (let* ((text (get-group)) - (extf (get-peeled-group)) - (lbl (get-peeled-group))) - (do-ref-aux lbl extf text)))) - -(define do-hyperref - (lambda () - (let* ((text (get-group)) - (lbl (begin (get-group) (get-group) (get-peeled-group)))) - (do-ref-aux lbl #f text)))) - -(define do-hypertarget - (lambda () (let ((lbl (get-peeled-group))) (do-tag-aux lbl "hypertarget")))) - -(define do-hyperlink - (lambda () - (emit-link-start - (fully-qualify-url (string-append "#" (get-peeled-group)))) - (tex2page-string (get-token)) - (emit-link-stop))) - -(define label-bound? - (lambda (label . ext-file) - (let* ((ext-file (if (pair? ext-file) (car ext-file) #f)) - (label-table - (if ext-file - (table-get *external-label-tables* ext-file) - *label-table*))) - (or (and label-table (table-get label-table label)) - (begin - (flag-unresolved-xref - (if ext-file - (string-append "{" ext-file " -> " label "}") - label)) - #f))))) - -(define flag-unresolved-xref - (lambda (xr) - (unless (member xr *unresolved-xrefs*) - (set! *unresolved-xrefs* (cons xr *unresolved-xrefs*))))) - -(define flag-missing-piece - (lambda (mp) - (unless (member mp *missing-pieces*) - (set! *missing-pieces* (cons mp *missing-pieces*))))) - -(define show-unresolved-xrefs-and-missing-pieces - (lambda () - (unless (and (null? *unresolved-xrefs*) (null? *missing-pieces*)) - (show-unresolved-xrefs) - (show-missing-pieces) - (write-log 'separation-newline) - (write-log "Rerun: tex2page ") - (write-log *main-tex-file*) - (write-log 'separation-newline) - (write-log "If problem persists, check for ") - (write-log "missing \\label's and \\bibitem's")))) - -(define show-unresolved-xrefs - (lambda () - (unless (null? *unresolved-xrefs*) - (write-log 'separation-newline) - (write-log "Unresolved cross-reference") - (if (> (length *unresolved-xrefs*) 1) (write-log "s")) - (write-log ": ") - (set! *unresolved-xrefs* (reverse! *unresolved-xrefs*)) - (write-log (car *unresolved-xrefs*)) - (for-each - (lambda (x) - (write-log #\,) - (write-log 'separation-space) - (write-log x)) - (cdr *unresolved-xrefs*)) - (write-log 'separation-newline)))) - -(define show-missing-pieces - (lambda () - (unless (null? *missing-pieces*) - (write-log 'separation-newline) - (when (memv 'document-title *missing-pieces*) - (write-log "Document title not determined") - (write-log 'separation-newline)) - (when (memv 'last-page *missing-pieces*) - (write-log "Last page not determined") - (write-log 'separation-newline)) - (when (memv 'last-modification-time *missing-pieces*) - (write-log "Last modification time not determined") - (write-log 'separation-newline)) - (when (memv 'stylesheets *missing-pieces*) - (write-log "Style sheets not determined") - (write-log 'separation-newline)) - (when (memv 'html-head *missing-pieces*) - (write-log "HTML header info not determined") - (write-log 'separation-newline)) - (when (memv 'toc *missing-pieces*) - (write-log "Table of contents not determined") - (write-log 'separation-newline)) - (cond - ((memv 'fresh-index *missing-pieces*) - (write-log "Index not refreshed") - (write-log 'separation-newline)) - ((memv 'index *missing-pieces*) - (write-log "Index not included") - (write-log 'separation-newline))) - (cond - ((memv 'fresh-bibliography *missing-pieces*) - (write-log "Bibliography not refreshed") - (write-log 'separation-newline)) - ((memv 'bibliography *missing-pieces*) - (write-log "Bibliography not included") - (write-log 'separation-newline))) - (when (memv 'metapost *missing-pieces*) - (write-log "MetaPost output not included") - (write-log 'separation-newline))))) - -(define do-pageref - (lambda () - (let ((label-ref (label-bound? (get-peeled-group)))) - (if label-ref - (let ((pageno (label.page label-ref))) - (emit-ext-page-node-link-start (label.src label-ref) pageno #f) - (emit pageno) - (emit-link-stop)) - (non-fatal-error "***"))))) - -(define do-htmlpageref - (lambda () - (let ((label (get-peeled-group))) - (let ((label-ref (label-bound? label))) - (emit "\"") - (if label-ref - (emit - (maybe-label-page (label.src label-ref) (label.page label-ref))) - (emit *log-file*)) - (emit "\""))))) - -(define fully-qualify-url - (lambda (url) - (let ((n (string-length url))) - (cond - ((and (> n 0) (char=? (string-ref url 0) #\#)) - (let* ((label (substring url 1 n)) (label-ref (label-bound? label))) - (if label-ref - (string-append - (maybe-label-page (label.src label-ref) (label.page label-ref)) - "#" - (label.name label-ref)) - url))) - ((fully-qualified-url? url) url) - (else (ensure-url-reachable url) url))))) - -(define do-url - (lambda () - (let ((url (get-url))) - (emit-link-start (fully-qualify-url url)) - (emit url) - (emit-link-stop)))) - -(define do-mailto - (lambda () - (let ((addr (get-url))) - (emit-link-start (string-append "mailto:" addr)) - (emit addr) - (emit-link-stop)))) - -(define do-urlh - (lambda () - (emit-link-start (fully-qualify-url (get-url))) - (bgroup) - (tex2page-string - (string-append "\\def\\\\{\\egroup\\endinput}" (get-token))) - (egroup) - (emit-link-stop))) - -(define do-urlhd (lambda () (do-urlh) (get-token))) - -(define do-urlp - (lambda () - (let ((link-text (get-token))) - (emit-link-start (fully-qualify-url (get-url))) - (tex2page-string link-text) - (emit-link-stop)))) - -(define do-hlstart - (lambda () - (let* ((cat (get-peeled-group)) (options (get-token)) (url (get-url))) - (when (string=? cat "url") - (emit-link-start (fully-qualify-url url)) - (bgroup) - (tex-let "\\hlend" "\\TIIPhlend" #f)) - (ignorespaces)))) - -(define do-hlend (lambda () (egroup) (emit-link-stop))) - -(define do-htmladdimg - (lambda () - (let* ((align-info (get-bracketed-text-if-any)) - (url (fully-qualify-url (get-url)))) - (emit "\"[")")))) - -(define do-pdfximage - (lambda () - (let ((height #f) (width #f) (depth #f)) - (let loop () - (cond - ((eat-word "height") (set! height (get-pixels)) (loop)) - ((eat-word "width") (set! width (get-pixels)) (loop)) - ((eat-word "depth") (set! depth (get-pixels)) (loop)) - (else #f))) - (emit "") - (ignorespaces) - (get-ctl-seq) - (ignorespaces) - (get-ctl-seq)))) - -(define do-cite - (lambda () - (let ((extra-text (get-bracketed-text-if-any))) - (emit "[") - (ignorespaces) - (unless (char=? (get-actual-char) #\{) (terror 'do-cite "Missing {")) - (let ((first-key? #t)) - (let loop () - (cond - ((get-csv) - => - (lambda (key) - (if first-key? - (set! first-key? #f) - (begin (emit ",") (emit-nbsp 1))) - (write-bib-aux "\\citation{") - (write-bib-aux key) - (write-bib-aux "}") - (write-bib-aux #\newline) - (do-ref-aux (string-append "cite{" key "}") #f #f) - (loop))) - (extra-text (emit ",") (emit-nbsp 1) (tex2page-string extra-text)))) - (unless (char=? (get-actual-char) #\}) (terror 'do-cite "Missing }")) - (if first-key? (terror 'do-cite "Empty \\cite"))) - (emit "]")))) - -(define do-nocite - (lambda () - (ignorespaces) - (unless (char=? (get-actual-char) #\{) (terror 'do-cite "Missing {")) - (let loop () - (cond - ((get-csv) - => - (lambda (key) - (write-bib-aux "\\citation{") - (write-bib-aux key) - (write-bib-aux "}") - (write-bib-aux #\newline) - (loop))))) - (unless (char=? (get-actual-char) #\}) (terror 'do-nocite "Missing }")))) - -(define do-bibliographystyle - (lambda () - (let ((s (ungroup (get-token)))) - (write-bib-aux "\\bibstyle{") - (write-bib-aux s) - (write-bib-aux "}") - (write-bib-aux #\newline)))) - -(define do-bibliography - (lambda () - (set! *using-bibliography?* #t) - (let ((bibdata (ungroup (get-token))) - (bbl-file - (string-append *aux-dir/* *jobname* *bib-aux-file-suffix* ".bbl"))) - (write-bib-aux "\\bibdata{") - (write-bib-aux bibdata) - (write-bib-aux "}") - (write-bib-aux #\newline) - (cond - ((file-exists? bbl-file) - (set! *bibitem-num* 0) - (tex2page-file bbl-file) - (emit-newline)) - (else - (flag-missing-piece 'bibliography) - (non-fatal-error "Bibliography not generated; rerun TeX2page")))))) - -(define do-thebibliography - (lambda () - (get-group) - (when (eqv? *tex-format* 'latex) - (tex2page-string - (if *using-chapters?* - "\\chapter*{\\bibname}" - "\\section*{\\refname}"))) - (bgroup) - (set! *bibitem-num* 0) - (tex2page-string "\\let\\em\\it") - (tex2page-string "\\def\\newblock{ }") - (tex2page-string "\\def\\providecommand#1#2{}") - (do-end-para) - (emit "") - (emit-newline))) - -(define do-bibitem - (lambda () - (let ((bibmark (get-bracketed-text-if-any))) - (do-end-para) - (unless (= *bibitem-num* 0) (emit "") (emit-newline)) - (set! *bibitem-num* (+ *bibitem-num* 1)) - (emit "") - (emit-newline) - (emit "
") - (let* ((bibitem-num-s (number->string *bibitem-num*)) - (key (string-append "cite{" (get-peeled-group) "}")) - (node-name - (string-append *html-node-prefix* "bib_" bibitem-num-s))) - (tex-def-0arg "\\TIIPcurrentnodename" node-name) - (unless bibmark (set! bibmark bibitem-num-s)) - (tex-def-0arg "\\@currentlabel" bibmark) - (emit-anchor node-name) - (emit "[") - (tex2page-string bibmark) - (emit "]") - (emit-nbsp 2) - (do-label-aux key) - (emit ""))))) - -(define display-index-entry - (lambda (s o) - (for-each - (lambda (c) (display (if (or (char=? c #\newline)) #\space c) o)) - (string->list s)))) - -(define do-index - (lambda () - (let ((idx-entry (ungroup (get-group)))) - (ignorespaces) - (unless (substring? "|)" idx-entry) - (set! *index-count* (+ *index-count* 2)) - (!index *index-count* *html-page-count*) - (write-aux `(!index ,*index-count* ,*html-page-count*)) - (let ((tag - (string-append - *html-node-prefix* - "idx_" - (number->string *index-count*)))) - (emit-anchor tag) - (unless *index-port* - (let ((idx-file - (string-append - *aux-dir/* - *jobname* - *index-file-suffix* - ".idx"))) - (ensure-file-deleted idx-file) - (set! *index-port* (open-output-file idx-file)))) - (display "\\indexentry{" *index-port*) - (cond - ((substring? "|see{" idx-entry) - (display-index-entry idx-entry *index-port*)) - ((substring? "|seealso{" idx-entry) - (display-index-entry idx-entry *index-port*)) - ((substring? "|(" idx-entry) - => - (lambda (i) - (display-index-entry (substring idx-entry 0 i) *index-port*) - (display "|expandhtmlindex" *index-port*))) - (else - (display-index-entry idx-entry *index-port*) - (display "|expandhtmlindex" *index-port*))) - (display "}{" *index-port*) - (display *index-count* *index-port*) - (display "}" *index-port*) - (newline *index-port*)))))) - -(define do-inputindex - (lambda (insert-heading?) - (set! *using-index?* #t) - (when insert-heading? - (tex2page-string - (if *using-chapters?* - "\\chapter*{\\indexname}" - "\\section*{\\indexname}")) - (emit-newline)) - (emit-anchor (string-append *html-node-prefix* "index_start")) - (!index-page *html-page-count*) - (write-aux `(!index-page ,*html-page-count*)) - (let ((ind-file - (string-append *aux-dir/* *jobname* *index-file-suffix* ".ind"))) - (cond - ((file-exists? ind-file) (tex2page-file ind-file)) - (else - (flag-missing-piece 'index) - (non-fatal-error "Index not generated; rerun TeX2page")))))) - -(define do-theindex - (lambda () - (bgroup) - (tex2page-string "\\let\\endtheindex\\egroup") - (tex2page-string "\\let\\indexspace\\medskip") - (tex2page-string "\\let\\item\\indexitem") - (tex2page-string "\\let\\subitem\\indexsubitem") - (tex2page-string "\\let\\subsubitem\\indexsubsubitem") - (tex2page-string "\\let\\(\\expandhtmlindex"))) - -(define expand-html-index - (lambda () - (let* ((s (get-peeled-group)) - (n (string->number s)) - (pageno (table-get *index-table* n))) - (emit-page-node-link-start - pageno - (string-append *html-node-prefix* "idx_" s)) - (emit pageno) - (cond - ((assv pageno *index-page-mention-alist*) - => - (lambda (c) - (let ((n (+ 1 (cdr c)))) - (emit (number->roman n #f)) - (set-cdr! c n)))) - (else - (set! *index-page-mention-alist* - (cons (cons pageno 1) *index-page-mention-alist*)))) - (emit-link-stop)))) - -(define do-see-also - (lambda () - (let* ((other-entry (get-group)) (discard (get-group))) - (emit "see also ") - (tex2page-string other-entry)))) - -(define do-indexitem - (lambda (indent) - (set! *index-page-mention-alist* '()) - (emit "
") - (emit-newline) - (emit-nbsp (* indent 4)))) - -(define do-description-item - (lambda () - (do-end-para) - (emit "
") - (let ((thing (get-bracketed-text-if-any))) - (when thing - (set! thing (string-trim-blanks thing)) - (unless (string=? thing "") - (bgroup) - (emit "") - (tex2page-string thing) - (emit "") - (egroup)))) - (emit "
"))) - -(define do-regular-item - (lambda () - (do-end-para) - (emit "
  • ") - (do-para) - (let ((thing (get-bracketed-text-if-any))) - (when thing - (emit "") - (bgroup) - (tex2page-string thing) - (egroup) - (emit "") - (emit-nbsp 2))))) - -(define do-plain-item - (lambda (n) - (do-end-para) - (emit "
    ") - (let loop ((n n)) - (unless (<= n 1) - (emit "") - (loop (- n 1)))) - (tex2page-string (get-group)) - (emit-nbsp 2) - (emit "") - (do-para) - (add-afterpar (lambda () (emit "
    "))))) - -(define do-item - (lambda () - (let ((a #f)) - (unless (null? *tabular-stack*) (set! a (car *tabular-stack*))) - (case a - ((description) (do-description-item)) - ((itemize enumerate) (do-regular-item)) - (else (do-plain-item 1)))))) - -(define do-bigskip - (lambda (type) - (do-end-para) - (emit "
    ") - (emit-newline) - (emit "

    ") - (set! *in-para?* #t) - (emit-newline))) - -(define do-hspace - (lambda () - (ignorespaces) - (if (eqv? (snoop-actual-char) #\*) (get-actual-char)) - (get-group) - (emit-nbsp 3))) - -(define do-vspace - (lambda () - (ignorespaces) - (if (eqv? (snoop-actual-char) #\*) (get-actual-char)) - (get-group) - (do-bigskip 'vspace))) - -(define do-htmlmathstyle - (lambda () - (call-with-input-string/buffered - (ungroup (get-group)) - (lambda () - (let loop () - (ignore-all-whitespace) - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (case (string->symbol (scm-get-token)) - ((image display-image) (tex-def-0arg "\\TZPmathimage" "1")) - ((no-image no-display-image) - (tex-def-0arg "\\TZPmathimage" "0"))) - (loop)))))))) - -(define do-htmldoctype - (lambda () - (let ((d (get-peeled-group))) - (when (string=? d "") (set! d 'none)) - (write-aux `(!doctype ,d))))) - -(define do-htmlcolophon - (lambda () - (call-with-input-string/buffered - (ungroup (get-group)) - (lambda () - (let loop () - (ignore-all-whitespace) - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (let ((directive (string->symbol (scm-get-token)))) - (!colophon directive) - (write-aux `(!colophon ,directive)) - (loop))))))))) - -(define output-colophon - (lambda () - (let ((colophon-mentions-last-mod-time? - (tex2page-flag-boolean "\\TZPcolophontimestamp")) - (colophon-mentions-tex2page? - (tex2page-flag-boolean "\\TZPcolophoncredit")) - (colophon-links-to-tex2page-website? - (tex2page-flag-boolean "\\TZPcolophonweblink"))) - (when (or colophon-mentions-last-mod-time? colophon-mentions-tex2page?) - (do-end-para) - (emit "

    ") - (when (and - colophon-mentions-last-mod-time? - *last-modification-time* - (> *last-modification-time* 0)) - (tex2page-string *last-modified*) - (emit ": ") - (emit (seconds->human-time *last-modification-time*)) - (emit "
    ")) - (when colophon-mentions-tex2page? - (emit "")) - (emit "
    ") - (emit-newline))))) - -(define point-to-adjacent-pages - (lambda () - (let* ((last-page-not-determined? (< *last-page-number* 0)) - (prev-page - (cond - ((= *html-page-count* 0) #f) - ((= *html-page-count* 1) - (string-append *jobname* *output-extension*)) - (else - (string-append - *jobname* - *html-page-suffix* - (number->string (- *html-page-count* 1)) - *output-extension*)))) - (next-page - (cond - ((= *html-page-count* *last-page-number*) #f) - (else - (string-append - *jobname* - *html-page-suffix* - (number->string (+ *html-page-count* 1)) - *output-extension*))))) - (unless (= *last-page-number* 0) - (when prev-page (emit-link-start prev-page)) - (emit "<···Prev ") - (when prev-page (emit-link-stop)) - (emit "||") - (when next-page (emit-link-start next-page)) - (emit " Next···>") - (when next-page (emit-link-stop)))))) - -(define output-head-or-foot-line - (lambda (head-or-foot) - (emit "
    ") - (cond - ((or *tex-like-layout?* (tex2page-flag-boolean "\\TZPtexlayout")) - (bgroup) - (tex-let "\\folio" "\\TIIPfolio" #f) - (tex2page-string - (if (eq? head-or-foot 'head) "\\the\\headline" "\\the\\footline")) - (egroup)) - (else (output-navigation-bar head-or-foot))) - (emit "
    ") - (emit-newline))) - -(define output-navigation-bar - (lambda (head-or-foot) - (let* ((first-page? (= *html-page-count* 0)) - (last-page-not-determined? (< *last-page-number* 0)) - (last-page? (= *html-page-count* *last-page-number*)) - (toc-page? (and *toc-page* (= *html-page-count* *toc-page*))) - (index-page? (and *index-page* (= *html-page-count* *index-page*))) - (first-page (string-append *jobname* *output-extension*)) - (prev-page - (cond - (first-page? #f) - ((= *html-page-count* 1) first-page) - (else - (string-append - *jobname* - *html-page-suffix* - (number->string (- *html-page-count* 1)) - *output-extension*)))) - (next-page - (cond - (last-page? #f) - (else - (string-append - *jobname* - *html-page-suffix* - (number->string (+ *html-page-count* 1)) - *output-extension*))))) - (unless (and - first-page? - (or last-page? - (and (eq? head-or-foot 'head) last-page-not-determined?))) - (emit "[") - (emit *navigation-sentence-begin*) - (emit "") - (unless first-page? (emit-link-start first-page)) - (emit *navigation-first-name*) - (unless first-page? (emit-link-stop)) - (emit ", ") - (unless first-page? (emit-link-start prev-page)) - (emit *navigation-previous-name*) - (unless first-page? (emit-link-stop)) - (emit "") - (emit "") - (when first-page? (emit "")) - (emit ", ") - (when first-page? (emit "")) - (unless last-page? (emit-link-start next-page)) - (emit *navigation-next-name*) - (unless last-page? (emit-link-stop)) - (emit "") - (emit *navigation-page-name*) - (when (or *toc-page* *index-page*) - (emit "; ") - (emit-nbsp 2) - (emit "") - (when *toc-page* - (emit "") - (unless toc-page? - (emit-page-node-link-start - *toc-page* - (string-append *html-node-prefix* "toc_start"))) - (emit *navigation-contents-name*) - (unless toc-page? (emit-link-stop)) - (emit "")) - (when *index-page* - (emit "") - (emit "") - (when *toc-page* (emit "; ") (emit-nbsp 2)) - (emit "") - (unless index-page? - (emit-page-node-link-start - *index-page* - (string-append *html-node-prefix* "index_start"))) - (emit *navigation-index-name*) - (unless index-page? (emit-link-stop)) - (emit ""))) - (emit *navigation-sentence-end*) - (emit "]"))))) - -(define do-eject - (lambda () - (unless (and - (eof-object? (snoop-actual-char)) - (eqv? *current-source-file* *main-tex-file*)) - (unless (> *last-page-number* 0) - (flag-missing-piece 'last-modification-time)) - (do-end-page) - (set! *html-page-count* (+ *html-page-count* 1)) - (set! *html-page* - (string-append - *aux-dir/* - *jobname* - *html-page-suffix* - (number->string *html-page-count*) - *output-extension*)) - (ensure-file-deleted *html-page*) - (set! *html* (open-output-file *html-page*)) - (do-start)))) - -(define output-html-preamble - (lambda () - (when (string? *doctype*) - (emit "") - (emit-newline)) - (emit "") - (emit-newline) - (emit "") - (emit-newline) - (emit "") - (emit-newline) - (output-external-title) - (link-stylesheets) - (emit "") - (emit-newline) - (for-each emit *html-head*) - (emit "") - (emit-newline) - (emit "") - (emit-newline) - (emit "
    ") - (emit-newline))) - -(define output-html-postamble - (lambda () - (do-end-para) - (emit "
    ") - (emit-newline) - (emit "") - (emit-newline) - (emit "") - (emit-newline))) - -(define do-start - (lambda () - (set! *footnote-list* '()) - (output-html-preamble) - (output-head-or-foot-line 'head) - (do-para))) - -(define do-end-page - (lambda () - (do-end-para) - (output-footnotes) - (do-bigskip 'smallskip) - (output-head-or-foot-line 'foot) - (do-para) - (let ((colophon-on-last-page? - (tex2page-flag-boolean "\\TZPcolophonlastpage"))) - (when (or - (and (not colophon-on-last-page?) (= *html-page-count* 0)) - (and colophon-on-last-page? - (= *html-page-count* *last-page-number*))) - (output-colophon))) - (output-html-postamble) - (write-log #\[) - (write-log *html-page-count*) - (write-log #\]) - (write-log 'separation-space) - (close-output-port *html*))) - -(define close-all-open-ports - (lambda () - (when *aux-port* (close-output-port *aux-port*)) - (when *css-port* (close-output-port *css-port*)) - (when *index-port* (close-output-port *index-port*)) - (when *label-port* (close-output-port *label-port*)) - (when *bib-aux-port* (close-output-port *bib-aux-port*)) - (when *verb-port* (close-output-port *verb-port*)) - (for-each - (lambda (c) (let ((p (cdr c))) (when p (close-input-port p)))) - *input-streams*) - (for-each - (lambda (c) (let ((p (cdr c))) (when p (close-output-port p)))) - *output-streams*))) - -(define output-stats - (lambda () - (write-log 'separation-newline) - (cond - (*main-tex-file* - (let ((num-pages (+ *html-page-count* 1))) - (write-log "Output written on ") - (write-log *aux-dir/*) - (write-log *jobname*) - (write-log *output-extension*) - (when (> num-pages 1) (write-log ", ...")) - (write-log " (") - (write-log num-pages) - (write-log " page") - (unless (= num-pages 1) (write-log #\s))) - (when (> *img-file-tally* 0) - (write-log ", ") - (write-log *img-file-tally*) - (write-log " image") - (unless (= *img-file-tally* 1) (write-log #\s))) - (write-log ").")) - (else (write-log "No pages of output."))) - (write-log #\newline) - (when *log-port* (close-output-port *log-port*)) - (display "Transcript written on ") - (display *log-file*) - (display ".") - (newline))) - -(define do-bye - (lambda () - (unless (null? *tex-if-stack*) - (let ((n (length *tex-if-stack*))) - (trace-if - #t - "(\\end occurred when " - n - " \\if" - (if (> n 1) "s were" " was") - " incomplete)"))) - (unless (null? *tex-env*) - (trace-if - #t - "\\end occurred inside a group at level " - (length *tex-env*))) - (perform-postludes) - (unless (or (>= *last-page-number* 0) (= *html-page-count* 0)) - (flag-missing-piece 'last-page)) - (!last-page-number *html-page-count*) - (write-aux `(!last-page-number ,*last-page-number*)) - (do-end-page) - (when *last-modification-time* - (write-aux `(!last-modification-time ,*last-modification-time*))) - (for-each (lambda (th) (th)) *afterbye*) - (note-down-tex2page-flags) - (close-all-open-ports) - (call-external-programs-if-necessary) - (show-unresolved-xrefs-and-missing-pieces))) - -(define note-down-tex2page-flags - (lambda () - (write-aux `(!head-line ,(get-toks "\\headline"))) - (write-aux `(!foot-line ,(get-toks "\\footline"))) - (cond - ((find-def "\\TZPtitle") - => - (lambda (d) - (write-aux - `(!preferred-title ,(tex-string->html-string (tdef.expansion d))))))) - (when (or *tex-like-layout?* (tex2page-flag-boolean "\\TZPtexlayout")) - (write-aux `(!tex-like-layout)) - (newline *css-port*) - (display "body { margin-top: " *css-port*) - (display - (sp-to-ems (+ (tex-length 0.5 'in) (find-dimen-in-sp "\\voffset"))) - *css-port*) - (display "em; }" *css-port*) - (newline *css-port*) - (display "body { margin-left: " *css-port*) - (display - (sp-to-ems (+ (tex-length 0.8 'in) (find-dimen-in-sp "\\hoffset"))) - *css-port*) - (display "em; }" *css-port*) - (newline *css-port*) - (unless (tex2page-flag-boolean "\\TZPraggedright") - (display "body { text-align: justify; }" *css-port*) - (newline *css-port*)) - (display "p { margin-bottom: 0pt; }" *css-port*) - (newline *css-port*) - (display "p { text-indent: " *css-port*) - (display (sp-to-ems (find-dimen-in-sp "\\parindent")) *css-port*) - (display "em; }" *css-port*) - (newline *css-port*) - (display "p { margin-top: " *css-port*) - (display (sp-to-ems (find-dimen-in-sp "\\parskip")) *css-port*) - (display "em; }" *css-port*) - (newline *css-port*) - (display ".mathdisplay { margin-top: " *css-port*) - (display (sp-to-ems (find-dimen-in-sp "\\abovedisplayskip")) *css-port*) - (display "em; margin-bottom: " *css-port*) - (display (sp-to-ems (find-dimen-in-sp "\\belowdisplayskip")) *css-port*) - (display "em; }" *css-port*) - (newline *css-port*) - (display "body { max-width: " *css-port*) - (display (sp-to-ems (find-dimen-in-sp "\\hsize")) *css-port*) - (display "em; }" *css-port*) - (newline *css-port*) - (display ".navigation { color: black; font-style: normal; }" *css-port*) - (newline *css-port*)))) - -(define insert-missing-end - (lambda () - (write-log 'separation-newline) - (write-log "! Missing \\end inserted.") - (write-log 'separation-newline))) - -(define do-diacritic-aux - (lambda (diac c) - (case diac - ((acute) - (case c - ((#\a #\e #\i #\o #\u #\y #\A #\E #\I #\O #\U #\Y) - (emit #\&) - (emit c) - (emit "acute;")) - ((#\space) (emit #\')) - (else (emit c) (emit #\')))) - ((cedilla) - (case c - ((#\c #\C) (emit #\&) (emit c) (emit "cedil;")) - ((#\space) (emit #\,)) - (else (emit c) (emit #\,)))) - ((circumflex) - (case c - ((#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U) - (emit #\&) - (emit c) - (emit "circ;")) - ((#\space) (emit #\^)) - (else (emit c) (emit #\^)))) - ((grave) - (case c - ((#\a #\e #\i #\o #\u #\A #\E #\I #\O #\U) - (emit #\&) - (emit c) - (emit "grave;")) - ((#\space) (emit #\`)) - (else (emit c) (emit #\`)))) - ((hacek) - (case c - ((#\s) (emit "š")) - ((#\S) (emit "Š")) - ((#\space) (emit #\^)) - (else (emit c) (emit #\^)))) - ((ring) - (case c - ((#\a #\A) (emit #\&) (emit c) (emit "ring;")) - ((#\space) (emit "°")) - (else (emit c) (emit "°")))) - ((tilde) - (case c - ((#\a #\n #\o #\A #\N #\O) (emit #\&) (emit c) (emit "tilde;")) - ((#\space) (emit #\~)) - (else (emit c) (emit #\~)))) - ((umlaut) - (case c - ((#\a #\e #\i #\o #\u #\y #\A #\E #\I #\O #\U) - (emit #\&) - (emit c) - (emit "uml;")) - ((#\Y) (emit "Ÿ")) - ((#\space) (emit """)) - (else (emit c) (emit """)))) - (else (emit "") (emit c) (emit ""))))) - -(define do-diacritic - (lambda (diac) - (let* ((x (ungroup (get-token))) - (c - (if (string=? x "\\i") - #\i - (case (string-length x) - ((0) #\space) - ((1) (string-ref x 0)) - (else (terror 'do-diacritic "`" x "' is not a character")))))) - (do-diacritic-aux diac c)))) - -(define do-mathdg - (lambda () - (fluid-let - ((*math-mode?* #t) - (*in-display-math?* #t) - (*tabular-stack* '()) - (*ligatures?* #f)) - (do-end-para) - (emit "
    ") - (tex2page-string (get-group)) - (emit "
    ") - (do-para)))) - -(define do-mathg - (lambda () - (fluid-let - ((*math-mode?* #t) - (*in-display-math?* #f) - (*tabular-stack* '()) - (*ligatures?* #f)) - (tex2page-string (get-group))))) - -(define dump-tex-preamble - (lambda (o) - (case *tex-format* - ((latex) - (display "\\documentclass{" o) - (display (if *using-chapters?* "report" "article") o) - (display "}" o) - (newline o) - (display *imgpreamble* o) - (newline o) - (when (memv 'includegraphics *imgpreamble-inferred*) - (display "\\ifx\\includegraphics\\UNDEFINED" o) - (display "\\usepackage{graphicx}\\fi" o) - (newline o)) - (when (memv 'epsfbox *imgpreamble-inferred*) - (display "\\ifx\\epsfbox\\UNDEFINED" o) - (display "\\usepackage{epsfig}\\fi" o) - (newline o)) - (display "\\thispagestyle{empty}" o) - (newline o) - (display "\\begin{document}" o) - (newline o)) - (else - (display *imgpreamble* o) - (newline o) - (when (memv 'includegraphics *imgpreamble-inferred*) - (display "\\ifx\\resetatcatcode\\UNDEFINED" o) - (display "\\input miniltx \\fi" o) - (newline o) - (display "\\ifx\\includegraphics\\UNDEFINED" o) - (display "\\input graphicx.sty \\fi" o) - (newline o)) - (when (memv 'epsfbox *imgpreamble-inferred*) - (display "\\ifx\\epsfbox\\UNDEFINED" o) - (display "\\input epsf \\fi" o) - (newline o)) - (display "\\nopagenumbers" o) - (newline o))))) - -(define dump-tex-postamble - (lambda (o) - (case *tex-format* - ((latex) (display "\\end{document}" o) (newline o)) - (else (display "\\bye" o) (newline o))))) - -(define skipping-img-file - (lambda () (set! *img-file-count* (+ *img-file-count* 1)))) - -(define next-html-image-file-stem - (lambda () - (set! *img-file-count* (+ *img-file-count* 1)) - (string-append - *subjobname* - *img-file-suffix* - (number->string *img-file-count*)))) - -(define call-with-html-image-port - (lambda (p . alt) - (let* ((alt (if (null? alt) #f (car alt))) - (img-file-stem (next-html-image-file-stem)) - (aux-tex-file (string-append img-file-stem ".tex"))) - (ensure-file-deleted aux-tex-file) - (call-with-output-file - aux-tex-file - (lambda (o) (dump-tex-preamble o) (p o) (dump-tex-postamble o))) - (tex-to-img img-file-stem) - (source-img-file img-file-stem alt)))) - -(define do-display-math - (lambda (tex-string) - (do-end-para) - (emit "
    ") - (let* ((alt-thunk - (lambda () - (fluid-let - ((*math-mode?* #t) - (*in-display-math?* #t) - (*tabular-stack* '())) - (emit "
    ") - (tex2page-string tex-string) - (emit "
    "))))) - (if (and (tex2page-flag-boolean "\\TZPmathimage") - (not *temporarily-use-ascii-for-math?*)) - (call-with-html-image-port - (lambda (o) (display "$$" o) (display tex-string o) (display "$$" o)) - tex-string) - (alt-thunk))) - (emit "
    ") - (do-noindent))) - -(define do-intext-math - (lambda (tex-string) - (fluid-let - ((*math-needs-image?* #f)) - (bgroup) - (let ((html-string - (fluid-let - ((*math-mode?* #t) - (*in-display-math?* #f) - (*tabular-stack* '())) - (tex-string->html-string tex-string)))) - (egroup) - (if (and (tex2page-flag-boolean "\\TZPmathimage") - *math-needs-image?* - (not *temporarily-use-ascii-for-math?*)) - (call-with-html-image-port - (lambda (o) (display #\$ o) (display tex-string o) (display #\$ o)) - tex-string) - (emit html-string)))))) - -(define do-mathp - (lambda () - (call-with-html-image-port - (lambda (o) (display #\$ o) (display (get-group) o) (display #\$ o))))) - -(define do-latex-intext-math - (lambda () - (do-intext-math - (let ((o (open-output-string))) - (dump-till-ctl-seq "\\)" o) - (get-output-string o))))) - -(define do-latex-display-math - (lambda () - (do-display-math - (let ((o (open-output-string))) - (dump-till-ctl-seq "\\]" o) - (get-output-string o))))) - -(define do-math - (lambda () - (let ((display? #f)) - (when (eqv? (snoop-actual-char) #\$) - (set! display? #t) - (get-actual-char)) - (let ((o (open-output-string))) - (dump-till-char #\$ o) - (when display? - (let ((c (get-actual-char))) - (when (or (eof-object? c) (not (char=? c #\$))) - (terror 'do-math "Display math should end with $$.")))) - ((if display? do-display-math do-intext-math) - (get-output-string o)))))) - -(define dump-till-char - (lambda (d o) - (let loop ((nesting 0) (escape? #f)) - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (terror 'dump-till-char "Missing " d ".")) - ((and (char=? c d) (= nesting 0)) #t) - (else - (display c o) - (cond - (escape? (loop nesting #f)) - ((char=? c #\{) (loop (+ nesting 1) #f)) - ((char=? c #\}) (loop (- nesting 1) #f)) - ((char=? c #\\) (loop nesting #t)) - (else (loop nesting #f))))))))) - -(define dump-till-ctl-seq - (lambda (cs o) - (fluid-let - ((*not-processing?* #t)) - (let loop ((nesting 0)) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) (terror 'dump-till-ctl-seq)) - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (if (string=? x cs) #t (begin (display x o) (loop nesting))))) - (else - (display (get-actual-char) o) - (cond - ((char=? c #\{) (loop (+ nesting 1))) - ((char=? c #\}) (loop (- nesting 1))) - (else (loop nesting)))))))))) - -(define dump-till-end-env - (lambda (env o) - (let* ((endenv (string-append "\\end" env)) - (endenv-prim (find-corresp-prim endenv)) - (endenv-prim-th (find-corresp-prim-thunk endenv))) - (fluid-let - ((*not-processing?* #t)) - (let loop ((brace-nesting 0) (env-nesting 0)) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) (terror 'dump-till-end-env env)) - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (cond - ((string=? (find-corresp-prim x) endenv-prim) #t) - ((string=? x "\\begin") - (display x o) - (let ((g (get-grouped-environment-name-if-any))) - (when g (display #\{ o) (display g o) (display #\} o)) - (loop - brace-nesting - (if (and g (string=? g env)) - (+ env-nesting 1) - env-nesting)))) - ((string=? x "\\end") - (let ((g (get-grouped-environment-name-if-any))) - (unless (and - g - (or *dumping-nontex?* (= env-nesting 0)) - (let ((endg (string-append "\\end" g))) - (or (string=? - (find-corresp-prim endg) - endenv-prim) - (eqv? - (find-corresp-prim-thunk endg) - endenv-prim-th)))) - (display x o) - (when g (display #\{ o) (display g o) (display #\} o)) - (loop - brace-nesting - (if (and g (string=? g env)) - (- env-nesting 1) - env-nesting))))) - (else (display x o) (loop brace-nesting env-nesting))))) - ((and (char=? c *comment-char*) (not *dumping-nontex?*)) - (do-comment) - (write-char #\% o) - (newline o) - (loop brace-nesting env-nesting)) - (else - (write-char (get-actual-char) o) - (cond - ((char=? c #\{) (loop (+ brace-nesting 1) env-nesting)) - ((char=? c #\}) (loop (- brace-nesting 1) env-nesting)) - (else (loop brace-nesting env-nesting))))))))))) - -(define dump-imgdef - (lambda (f) - (let ((aux-tex-file (string-append f ".tex"))) - (ensure-file-deleted aux-tex-file) - (call-with-output-file - aux-tex-file - (lambda (o) - (dump-tex-preamble o) - (display (ungroup (get-group)) o) - (dump-tex-postamble o)))))) - -(define do-img-preamble - (lambda () - (set! *imgpreamble* - (fluid-let - ((*not-processing?* #t)) - (let loop ((r *imgpreamble*)) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) - (terror 'do-img-preamble "Missing \\endimgpreamble")) - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (cond - ((ormap - (lambda (z) (string=? x z)) - '("\\endimgpreamble" - "\\endgifpreamble" - "\\endmathpreamble")) - r) - (else (loop (string-append r x)))))) - (else - (get-actual-char) - (loop (string-append r (string c))))))))))) - -(define pick-new-stream-number - (lambda (stream-list) - (let loop ((i 0)) - (if (or (assv i stream-list) (= i 16) (= i 18)) (loop (+ i 1)) i)))) - -(define do-new-stream - (lambda (type) - (let* ((x (get-ctl-seq)) - (sl (if (eqv? type 'out) *output-streams* *input-streams*)) - (n (pick-new-stream-number sl)) - (sl-new (cons (cons n #f) sl))) - (tex-def-count x n #t) - (case type - ((out) (set! *output-streams* sl-new)) - (else (set! *input-streams* sl-new)))))) - -(define do-open-stream - (lambda (type) - (let* ((n (get-number)) - (f (get-plain-filename)) - (sl (if (eqv? type 'out) *output-streams* *input-streams*)) - (c (assv n sl))) - (unless (and c (not (cdr c))) (terror 'do-open-stream)) - (case type - ((out) - (set! f (add-dot-tex-if-no-extension-provided f)) - (ensure-file-deleted f) - (set-cdr! c (open-output-file f))) - (else - (set! f (actual-tex-filename f #f)) - (set-cdr! c (make-bport 'port (open-input-file f)))))))) - -(define do-close-stream - (lambda (type) - (let* ((sl (if (eqv? type 'out) *output-streams* *input-streams*)) - (o (get-number)) - (c (assv o sl))) - (unless (and c (cdr c)) (terror 'do-close-stream)) - (case type - ((out) (close-output-port (cdr c))) - ((in) (close-output-port (bport.port (cdr c))))) - (set-cdr! c #f)))) - -(define tex-write-output-string - (lambda (s) - (let ((o (open-output-string))) - (fluid-let - ((*outputting-to-non-html?* #t) (*html* o)) - (call-with-input-string/buffered - s - (lambda () - (let loop () - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (case c - ((#\\) (do-tex-ctl-seq (get-ctl-seq))) - (else (emit-html-char (get-actual-char)))) - (loop))))))) - (get-output-string o)))) - -(define do-write-aux - (lambda (o) - (let ((output (tex-write-output-string (get-peeled-group)))) - (cond - ((and (= o 18) *enable-write-18?*) (system output)) - ((or (= o 16) (= o 18)) - (write-log output) - (write-log 'separation-space)) - ((assv o *output-streams*) - => - (lambda (c) - (let ((p (cdr c))) - (cond - ((not p) (terror 'do-write-aux)) - (else (display output p) (display #\space p)))))) - (else (terror 'do-write)))))) - -(define do-write (lambda () (do-write-aux (get-number)))) - -(define do-message (lambda () (do-write-aux 16))) - -(define read-tex-line - (lambda (p) - (fluid-let - ((*current-tex2page-input* p)) - (let loop ((r '())) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) (if (null? r) c (list->string (reverse! r)))) - ((char=? c #\newline) (get-actual-char) (list->string (reverse! r))) - ((char=? c #\{) - (string-append (list->string (reverse! r)) (get-group))) - (else (loop (cons (get-actual-char) r))))))))) - -(define do-read - (lambda (g?) - (let* ((i (get-number)) (x (begin (get-to) (get-ctl-seq))) (p #f)) - (cond - ((ormap (lambda (j) (= i j)) '(-1 16)) - (set! p (make-bport 'port (current-input-port))) - (unless (= i -1) (write-log x) (write-log #\=))) - ((assv i *input-streams*) - => - (lambda (c) (set! p (cdr c)) (unless p (terror 'do-read)))) - (else (terror 'do-read))) - ((if g? tex-gdef-0arg tex-def-0arg) - x - (let ((line (read-tex-line p))) (if (eof-object? line) "" line)))))) - -(define do-typein - (lambda () - (let ((ctlseq (get-bracketed-text-if-any)) - (p (make-bport 'port (current-input-port)))) - (write-log 'separation-newline) - (write-log (tex-string->html-string (get-group))) - (write-log 'separation-newline) - (write-log (or ctlseq "\\@typein")) - (write-log #\=) - (let ((L (read-tex-line p))) - (when (eof-object? L) (set! L "")) - (cond (ctlseq (tex-def-0arg ctlseq L)) (else (tex2page-string L))))))) - -(define do-ifeof - (lambda () - (let* ((i (get-number)) (c (assv i *input-streams*))) - (unless (and c (cdr c)) (terror 'do-ifeof)) - (if (eof-object? (read-char (cdr c))) do-iftrue do-iffalse)))) - -(define do-iffalse (lambda () (set! *tex-if-stack* (cons #f *tex-if-stack*)))) - -(define do-iftrue (lambda () (set! *tex-if-stack* (cons #t *tex-if-stack*)))) - -(define insert-tex-if (lambda (test) ((if test do-iftrue do-iffalse)))) - -(define do-ifx - (lambda () - (let* ((one (get-raw-token/is)) - (two (get-raw-token/is)) - (one2 one) - (two2 two)) - ((if (string=? one two) - do-iftrue - (begin - (when (ctl-seq? one) - (set! one2 - (cond - ((find-def one) - => - (lambda (d) (or (tdef.expansion d) (tdef.prim d)))) - ((find-math-def one) => (lambda (x) x)) - (else "UnDeFiNeD")))) - (when (ctl-seq? two) - (set! two2 - (cond - ((find-def two) - => - (lambda (d) (or (tdef.expansion d) (tdef.prim d)))) - ((find-math-def two) => (lambda (x) x)) - (else "UnDeFiNeD")))) - (if (or (eqv? one2 two2) - (and (string? one2) (string? two2) (string=? one2 two2))) - do-iftrue - do-iffalse))))))) - -(define do-ifdefined - (lambda () - (let ((x (get-raw-token/is))) - ((if (or (not (ctl-seq? x)) - (and (ctl-seq? x) (or (find-def x) (find-math-def x)))) - do-iftrue - do-iffalse))))) - -(define do-if-get-atomic - (lambda () - (let loop () - (let ((x (get-raw-token/is))) - (if (ctl-seq? x) - (cond - ((resolve-defs x) - => - (lambda (z) - (toss-back-char *invisible-space*) - (toss-back-string z) - (loop))) - (else x)) - x))))) - -(define do-if - (lambda () - (let* ((one (do-if-get-atomic)) (two (do-if-get-atomic))) - ((if (or (string=? one two) (and (ctl-seq? one) (ctl-seq? two))) - do-iftrue - do-iffalse))))) - -(define do-ifmmode - (lambda () (set! *tex-if-stack* (cons *math-mode?* *tex-if-stack*)))) - -(define do-ifnum - (lambda () - (let* ((one (get-number)) - (rel (string-ref (get-raw-token/is) 0)) - (two (get-number))) - ((if ((case rel - ((#\<) <) - ((#\=) =) - ((#\>) >) - (else (terror 'do-ifnum "Missing relation for \\ifnum."))) - one - two) - do-iftrue - do-iffalse))))) - -(define read-ifcase-clauses - (lambda () - (fluid-let - ((*not-processing?* #t)) - (let* ((else-clause #f) - (or-clauses - (let loop ((or-clauses '()) (else? #f)) - (let loop2 ((clause "")) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) - (terror 'read-ifcase-clauses "Incomplete \\ifcase.")) - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (cond - ((string=? x "\\or") - (ignorespaces) - (if else? - (terror 'read-ifcase-clauses "\\or after \\else") - (loop (cons clause or-clauses) #f))) - ((string=? x "\\else") - (ignorespaces) - (if else? - (terror - 'read-ifcase-clauses - "\\else after \\else") - (loop (cons clause or-clauses) #t))) - ((string=? x "\\fi") - (ignorespaces) - (if else? - (begin (set! else-clause clause) or-clauses) - (cons clause or-clauses))) - (else (loop2 (string-append clause x)))))) - (else - (get-actual-char) - (loop2 (string-append clause (string c)))))))))) - (cons else-clause or-clauses))))) - -(define do-ifcase - (lambda () - (let* ((num (get-number)) - (clauses (read-ifcase-clauses)) - (else-clause (car clauses)) - (or-clauses (reverse! (cdr clauses))) - (num-or-clauses (length or-clauses))) - (cond - ((< num num-or-clauses) (tex2page-string (list-ref or-clauses num))) - (else-clause (tex2page-string else-clause)))))) - -(define do-ifodd (lambda () ((if (odd? (get-number)) do-iftrue do-iffalse)))) - -(define do-else - (lambda () - (when (null? *tex-if-stack*) (terror 'do-else "Extra \\else")) - (let ((top-if (car *tex-if-stack*))) - (set-car! *tex-if-stack* (not top-if))))) - -(define do-fi - (lambda () - (when (null? *tex-if-stack*) (terror 'do-fi "Extra \\fi")) - (set! *tex-if-stack* (cdr *tex-if-stack*)))) - -(define do-newif - (lambda () - (let* ((iffoo (get-ctl-seq)) - (init-val #f) - (foo (string-append "\\" (substring iffoo 3 (string-length iffoo)))) - (foo-register (string-append foo "BOOLEANREGISTER"))) - (tex-def-count foo-register 0 #f) - (tex-def-thunk - iffoo - (lambda () - (set! *tex-if-stack* - (cons (> (the-count foo-register) 0) *tex-if-stack*))) - #f) - (tex-def-thunk - (string-append foo "true") - (lambda () (tex-def-count foo-register 1 #f)) - #f) - (tex-def-thunk - (string-append foo "false") - (lambda () (tex-def-count foo-register 0 #f)) - #f)))) - -(define do-htmlimg - (lambda (env) - (call-with-html-image-port (lambda (o) (dump-till-end-env env o))))) - -(define find-img-file-extn - (lambda () - (case (tex2page-flag-value "\\TZPimageformat") - ((#\p #\P) ".png") - ((#\j #\J) ".jpeg") - (else ".gif")))) - -(define do-htmlimageformat - (lambda () (tex-def-0arg "\\TZPimageformat" (get-peeled-group)))) - -(define do-htmlimageconversionprogram - (lambda () (tex-def-0arg "\\TZPimageconverter" (get-peeled-group)))) - -(define do-htmlimgmagnification (lambda () #t)) - -(define call-tex - (lambda (f) - (let ((dvifile (string-append f ".dvi")) - (call-to-tex - (string-append - (if (eq? *tex-format* 'latex) "la" "") - "tex " - f - *bye-tex*))) - (system call-to-tex) - (and (file-exists? dvifile) - (let ((logfile (string-append f ".log"))) - (or (not (file-exists? logfile)) - (call-with-input-file - logfile - (lambda (i) - (let loop () - (let ((x (read-line i))) - (cond - ((eof-object? x) #t) - ((substring? "! I can't find file" x) #f) - (else (loop))))))))))))) - -(define ps-to-img/gif/netpbm - (lambda (f) - (system - (string-append - *ghostscript* - *ghostscript-options* - " -sOutputFile=" - f - ".ppm.1 " - f - ".ps quit.ps")) - (system (string-append "pnmcrop " f ".ppm.1 > " f ".ppm.tmp")) - (system (string-append "ppmquant 256 < " f ".ppm.tmp > " f ".ppm")) - (system - (string-append - "ppmtogif -transparent rgb:ff/ff/ff < " - f - ".ppm > " - *aux-dir/* - f - ".gif")) - (for-each - (lambda (e) (ensure-file-deleted (string-append f e))) - '(".ppm" ".ppm.tmp" ".ppm.1")))) - -(define ps-to-img/png/netpbm - (lambda (f) - (system - (string-append - *ghostscript* - *ghostscript-options* - " -sOutputFile=" - f - ".ppm.1 " - f - ".ps quit.ps")) - (system (string-append "pnmcrop " f ".ppm.1 > " f ".ppm.tmp")) - '(system (string-append "ppmquant 256 < " f ".ppm.tmp > " f ".ppm")) - (system - (string-append - "pnmtopng -interlace -transparent \"#FFFFFF\" " - " < " - f - ".ppm.tmp > " - *aux-dir/* - f - ".png")) - (for-each - (lambda (e) (ensure-file-deleted (string-append f e))) - '(".ppm.1" ".ppm.tmp" ".ppm")))) - -(define ps-to-img/jpeg/netpbm - (lambda (f) - (system - (string-append - *ghostscript* - *ghostscript-options* - " -sOutputFile=" - f - ".ppm.1 " - f - ".ps quit.ps")) - (system (string-append "pnmcrop " f ".ppm.1 > " f ".ppm.tmp")) - (system (string-append "ppmquant 256 < " f ".ppm.tmp > " f ".ppm")) - (system - (string-append - "ppmtojpeg --grayscale < " - f - ".ppm > " - *aux-dir/* - f - ".jpeg")) - (for-each - (lambda (e) (ensure-file-deleted (string-append f e))) - '(".ppm.1" ".ppm.tmp" ".ppm")))) - -(define ps-to-img - (lambda (f) - (case (tex2page-flag-value "\\TZPimageconverter") - ((#\i #\I) - (system - (string-append - "convert -transparent white -trim " - f - ".ps " - f - (find-img-file-extn)))) - (else - ((case (tex2page-flag-value "\\TZPimageformat") - ((#\p #\P) ps-to-img/png/netpbm) - ((#\j #\J) ps-to-img/jpeg/netpbm) - (else ps-to-img/gif/netpbm)) - f))))) - -(define tex-to-img - (lambda (f) - (set! *img-file-tally* (+ *img-file-tally* 1)) - (let ((f.img (string-append *aux-dir/* f (find-img-file-extn)))) - (unless (file-exists? f.img) - (write-log 'separation-space) - (write-log #\{) - (write-log (string-append f ".tex")) - (write-log 'separation-space) - (write-log "->") - (write-log 'separation-space) - (cond - ((call-tex f) - (system (string-append "dvips " f ".dvi -o " f ".ps")) - (ps-to-img f) - (write-log f.img) - '(for-each - (lambda (e) (ensure-file-deleted (string-append f e))) - '(".aux" ".dvi" ".log" ".ps" ".tex"))) - (else (write-log "failed, try manually"))) - (write-log #\}) - (write-log 'separation-space))))) - -(define call-with-lazy-image-port - (lambda (eps-file img-file-stem p) - (let ((aux-tex-file (string-append img-file-stem ".tex"))) - (ensure-file-deleted aux-tex-file) - (call-with-output-file - aux-tex-file - (lambda (o) (dump-tex-preamble o) (p o) (dump-tex-postamble o))) - (if (file-exists? eps-file) - (tex-to-img img-file-stem) - (set! *missing-eps-files* - (cons (cons eps-file img-file-stem) *missing-eps-files*)))))) - -(define retry-lazy-image - (lambda (eps-file img-file-stem) - (cond - ((file-exists? eps-file) (tex-to-img img-file-stem)) - (else - (write-log "! I can't find EPS file ") - (write-log eps-file) - (write-log 'separation-newline))))) - -(define lazily-make-epsf-image-file - (lambda (eps-file img-file-stem) - (fluid-let - ((*imgpreamble-inferred* (cons 'epsfbox *imgpreamble-inferred*))) - (call-with-lazy-image-port - eps-file - img-file-stem - (lambda (o) - (display "\\epsfbox{" o) - (display eps-file o) - (display #\} o)))))) - -(define do-epsfbox - (lambda () - (let* ((b (get-bracketed-text-if-any)) (f (get-filename-possibly-braced))) - (unless *eval-for-tex-only?* - (let ((epsf-x-size (get-dimen "\\epsfxsize")) - (epsf-y-size (get-dimen "\\epsfysize"))) - (cond - ((and (= epsf-x-size 0) (= epsf-y-size 0)) - (let ((img-file-stem (next-html-image-file-stem))) - (lazily-make-epsf-image-file f img-file-stem) - (source-img-file img-file-stem))) - (else - (unless (= epsf-x-size 0) (tex2page-string "\\epsfxsize=0pt")) - (unless (= epsf-y-size 0) (tex2page-string "\\epsfysize=0pt")) - (fluid-let - ((*imgpreamble-inferred* (cons 'epsfbox *imgpreamble-inferred*))) - (call-with-html-image-port - (lambda (o) - (unless (= epsf-x-size 0) - (display "\\epsfxsize=" o) - (display epsf-x-size o) - (display "sp" o) - (newline o)) - (unless (= epsf-y-size 0) - (display "\\epsfysize=" o) - (display epsf-y-size o) - (display "sp" o) - (newline o)) - (display "\\epsfbox{" o) - (display f o) - (display #\} o))))))))))) - -(define do-epsfig - (lambda () - (fluid-let - ((*imgpreamble-inferred* (cons 'epsfbox *imgpreamble-inferred*))) - (call-with-html-image-port - (lambda (o) - (display "\\epsfig{" o) - (dump-groupoid o) - (display #\} o)))))) - -(define do-convertmptopdf - (lambda () - (let ((f (get-filename-possibly-braced)) - (img-file-stem (next-html-image-file-stem))) - (get-token) - (get-token) - (lazily-make-epsf-image-file f img-file-stem) - (source-img-file img-file-stem)))) - -(define do-includegraphics-web - (lambda (bracketed-text image-file) - (emit ""))) - -(define do-includegraphics - (lambda () - (let* ((star? (eat-star)) - (b1 (get-bracketed-text-if-any)) - (b2 (and b1 (get-bracketed-text-if-any))) - (f (get-filename-possibly-braced)) - (img-file-stem (next-html-image-file-stem)) - (ffull - (if (file-exists? f) - f - (ormap - (lambda (e) - (let ((f2 (string-append f e))) (and (file-exists? f2) f2))) - *graphics-file-extensions*))) - (ffull-ext (and ffull (file-extension ffull)))) - (cond - ((and ffull-ext - (ormap - (lambda (y) (string=? ffull-ext y)) - '(".jpg" ".jpeg" ".png"))) - (do-includegraphics-web b1 ffull)) - (else - (fluid-let - ((*imgpreamble-inferred* - (cons 'includegraphics *imgpreamble-inferred*))) - (call-with-lazy-image-port - (or ffull f) - img-file-stem - (lambda (o) - (display "\\includegraphics" o) - (if star? (display #\* o)) - (when b1 (display #\[ o) (display b1 o) (display #\] o)) - (when b2 (display #\[ o) (display b2 o) (display #\] o)) - (display #\{ o) - (display f o) - (display #\} o)))) - (source-img-file img-file-stem)))))) - -(define do-resizebox - (lambda () - (let* ((arg1 (get-group)) (arg2 (get-group)) (arg3 (get-group))) - (fluid-let - ((*imgpreamble-inferred* - (cons 'includegraphics *imgpreamble-inferred*))) - (call-with-html-image-port - (lambda (o) - (display "\\resizebox" o) - (display arg1 o) - (display arg2 o) - (display arg3 o))))))) - -(define do-mfpic-opengraphsfile - (lambda () - (set! *mfpic-file-stem* (get-filename-possibly-braced)) - (when *mfpic-port* (close-output-port *mfpic-port*)) - (let ((f (string-append *mfpic-file-stem* *mfpic-tex-file-suffix*))) - (ensure-file-deleted f) - (set! *mfpic-port* (open-output-file f))) - (set! *mfpic-file-num* 0) - (display "\\input mfpic \\usemetapost " *mfpic-port*) - (newline *mfpic-port*) - (display "\\opengraphsfile{" *mfpic-port*) - (display *mfpic-file-stem* *mfpic-port*) - (display #\} *mfpic-port*) - (newline *mfpic-port*) - (tex-def-prim - "\\headshape" - (lambda () - (let* ((g1 (get-group)) (g2 (get-group)) (g3 (get-group))) - (display "\\headshape" *mfpic-port*) - (display g1 *mfpic-port*) - (display g2 *mfpic-port*) - (display g3 *mfpic-port*) - (newline *mfpic-port*)))) - (tex-def-prim "\\mfpframesep" eat-dimen) - (tex-def-prim "\\mftitle" get-group))) - -(define do-mfpic-closegraphsfile - (lambda () - (display "\\closegraphsfile" *mfpic-port*) - (newline *mfpic-port*) - (close-output-port *mfpic-port*) - (let ((tex-f (string-append *mfpic-file-stem* *mfpic-tex-file-suffix*)) - (mp-f (string-append *mfpic-file-stem* ".mp"))) - (unless (file-exists? mp-f) - (fluid-let ((*tex-format* 'plain)) (call-tex tex-f))) - (when (file-exists? mp-f) - (system (string-append *metapost* " " *mfpic-file-stem*)))))) - -(define do-mfpic - (lambda () - (display "\\mfpic" *mfpic-port*) - (dump-till-end-env "mfpic" *mfpic-port*) - (display "\\endmfpic" *mfpic-port*) - (newline *mfpic-port*) - (set! *mfpic-file-num* (+ *mfpic-file-num* 1)) - (let ((f - (string-append - *mfpic-file-stem* - "." - (number->string *mfpic-file-num*))) - (img-file-stem (next-html-image-file-stem))) - (lazily-make-epsf-image-file f img-file-stem) - (source-img-file img-file-stem)))) - -(define do-following-latex-env-as-image - (lambda () (do-latex-env-as-image (ungroup (get-group)) 'display))) - -(define do-latex-env-as-image - (lambda (env inline-or-display?) - (when (char=? (snoop-actual-char) #\*) - (get-actual-char) - (set! env (string-append env "*"))) - (egroup) - (when (eq? inline-or-display? 'display) - (do-end-para) - (emit "
    ")) - (call-with-html-image-port - (lambda (o) - (display "\\begin{" o) - (display env o) - (display "}" o) - (dump-till-end-env env o) - (display "\\end{" o) - (display env o) - (display "}" o) - (newline o))) - (when (eq? inline-or-display? 'display) (emit "
    ") (do-para)))) - -(define do-box - (lambda () - (fluid-let ((*ignore-active-space?* #t)) (ignorespaces) (get-to)) - (eat-dimen) - (ignorespaces) - (let ((c (snoop-actual-char))) (case c ((#\{) #t) ((#\\) (get-ctl-seq)))) - (get-actual-char) - (bgroup) - (add-postlude-to-top-frame - (let ((old-math-mode? *math-mode?*) - (old-in-display-math? *in-display-math?*) - (old-tabular-stack *tabular-stack*) - (old-ligatures? *ligatures?*)) - (set! *math-mode?* #f) - (set! *in-display-math?* #f) - (set! *tabular-stack* '()) - (set! *ligatures?* #t) - (lambda () - (set! *math-mode?* old-math-mode?) - (set! *in-display-math?* old-in-display-math?) - (set! *tabular-stack* old-tabular-stack) - (set! *ligatures?* old-ligatures?)))))) - -(define do-latex-frac - (lambda () - (emit "(") - (tex2page-string (get-token)) - (emit "/") - (tex2page-string (get-token)) - (emit ")"))) - -(define do-tex-frac - (lambda () - (ignorespaces) - (let ((inner-level? - (or (not *in-display-math?*) (not (null? *tabular-stack*))))) - (fluid-let - ((*tabular-stack* (cons 'frac *tabular-stack*))) - (cond - (inner-level? - (emit "") - (tex2page-string (get-till-char #\/)) - (emit "/") - (get-actual-char) - (ignorespaces) - (tex2page-string (get-token)) - (emit "")) - (else - (emit "
    • ") - (tex2page-string (get-till-char #\/)) - (get-actual-char) - (ignorespaces) - (emit "
    ") - (tex2page-string (get-token)) - (emit "
    		"))))))) - -(define do-frac - (lambda () ((if (eqv? *tex-format* 'latex) do-latex-frac do-tex-frac)))) - -(define do-eqno - (lambda () - (unless *in-display-math?* - (terror 'do-eqno "You can't use \\eqno in math mode")) - (emit ""))) - -(define do-eqalign - (lambda (type) - (ignorespaces) - (let ((c (get-actual-char))) - (when (eof-object? c) (terror 'do-eqalign "Missing {")) - (unless (char=? c #\{) (terror 'do-eqalign "Missing {")) - (bgroup) - (set! *tabular-stack* (cons type *tabular-stack*)) - (add-postlude-to-top-frame - (lambda () - (emit "
    ") - (emit-newline) - (when *in-display-math?* (emit "

    		")) - (pop-tabular-stack type) - (set! *equation-position* 0))) - (when *in-display-math?* (emit "")) - (emit-newline) - (emit "
    ")))) - -(define do-noalign - (lambda () - (let* ((type (and (not (null? *tabular-stack*)) (car *tabular-stack*))) - (split? (memv type '(eqalignno displaylines)))) - (when split? - (egroup) - (emit "
    ") - (emit-newline) - (do-para)) - (tex2page-string (get-group)) - (cond - (split? - (do-end-para) - (emit-newline) - (emit "
    ") (emit-newline) (emit "
    ") - (toss-back-char #\{) - (do-eqalign type)) - (else (emit "
    ")))))) - -(define do-pmatrix - (lambda () - (ignorespaces) - (let ((c (get-actual-char))) - (if (eof-object? c) (terror 'do-pmatrix "Missing {")) - (unless (char=? c #\{) (terror 'do-pmatrix "Missing {")) - (bgroup) - (set! *tabular-stack* (cons 'pmatrix *tabular-stack*)) - (add-postlude-to-top-frame - (lambda () - (emit "
    ") - (when *in-display-math?* (emit "
    		")) - (emit-newline) - (pop-tabular-stack 'pmatrix))) - (when *in-display-math?* (emit "")) - (emit "") - (let loop ((tmplt tmplt) (ins " ")) - (let ((x (get-raw-token))) - (cond - ((eof-object? x) (terror 'expand-halign-line "Eof in \\halign")) - ((or (string=? x "&") (string=? x "\\cr")) - (let loop2 ((tmplt tmplt) (r "{")) - (if (null? tmplt) - (terror 'expand-halign-line "Eof in \\halign") - (let ((y (car tmplt))) - (case y - ((#f) - (emit "") - (if (string=? x "\\cr") - (begin (emit "") (emit-newline)) - (loop (cdr tmplt) " "))) - ((#t) (loop2 (cdr tmplt) (string-append r ins))) - (else (loop2 (cdr tmplt) (string-append r y)))))))) - (else (loop tmplt (string-append ins x)))))))) - -(define read-till-next-sharp - (lambda (k argpat) - (let ((n (length argpat))) - (let loop ((ss '())) - (let loop2 ((i k) (s '())) - (let ((c (if (< i n) (list-ref argpat i) #\#))) - (if (char=? c #\#) - (cons i (list->string (reverse! ss))) - (let ((d (snoop-actual-char))) - (cond - ((and (char=? c #\space) (char-whitespace? d)) - (ignorespaces) - '(if (char=? d #\newline) (get-actual-char) (ignorespaces)) - (loop2 (+ i 1) (cons c s))) - ((and *comment-char* (char=? d *comment-char*)) - (do-comment) - (loop2 i s)) - ((and (char=? c #\newline) - (char-whitespace? d) - (or (munched-a-newline?) (begin (toss-back-char d) #f))) - (loop2 (+ i 1) (cons c s))) - ((char=? c d) (get-actual-char) (loop2 (+ i 1) (cons c s))) - ((= i k) - (loop - (if (and (char=? d #\{) - (or (null? ss) (not (char=? (car ss) *esc-char*)))) - (append (get-group-as-reversed-chars) ss) - (begin - (if (and (char-whitespace? d) - (not (char=? d #\newline))) - (ignorespaces) - (get-actual-char)) - (cons d ss))))) - (else (loop (append s ss)))))))))))) - -(define read-macro-args - (lambda (argpat k r) - (let ((n (length argpat))) - (reverse! - (let loop ((k k) (r r)) - (if (>= k n) - r - (let ((c (list-ref argpat k))) - (cond - ((char=? c #\#) - (cond - ((= k (- n 1)) (cons (get-till-char #\{) r)) - ((= k (- n 2)) (cons (ungroup (get-token)) r)) - (else - (let ((c2 (list-ref argpat (+ k 2)))) - (if (char=? c2 #\#) - (loop (+ k 2) (cons (ungroup (get-token)) r)) - (let ((x (read-till-next-sharp (+ k 2) argpat))) - (loop (car x) (cons (cdr x) r)))))))) - (else - (let ((d (get-actual-char))) - (cond - ((eof-object? d) - (terror - 'read-macro-args - "Eof before macro got enough args")) - ((char=? c d) (loop (+ k 1) r)) - (else - (terror - 'read-macro-args - "Misformed macro call"))))))))))))) - -(define expand-edef-macro - (lambda (rhs) - (fluid-let - ((*not-processing?* #t)) - (let ((tmp-port (open-output-string))) - (call-with-input-string/buffered - rhs - (lambda () - (let loop () - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (display - (cond - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (toss-back-char *invisible-space*) - (cond - ((or (string=? x "\\the") (string=? x "\\number")) - (let ((x2 (get-raw-token/is))) - (toss-back-char *invisible-space*) - (toss-back-string x2) - (cond - ((ctl-seq? x2) - (cond - ((string=? x "\\the") (expand-the)) - ((string=? x "\\number") (get-number)) - (else "deadcode"))) - (else x)))) - ((string=? x "\\noexpand") - (let ((x2 (get-raw-token/is))) - (toss-back-char *invisible-space*) - x2)) - ((find-def x) - => - (lambda (y) - (cond - ((and (null? (tdef.argpat y)) - (not (tdef.optarg y)) - (not (tdef.thunk y)) - (not (tdef.prim y)) - (not (tdef.defer y))) - (toss-back-char *invisible-space*) - (toss-back-string (tdef.expansion y)) - "") - (else x)))) - (else x)))) - (else (get-actual-char) c)) - tmp-port) - (loop)))))) - (get-output-string tmp-port))))) - -(define expand-tex-macro - (lambda (optarg argpat rhs) - (let* ((k 0) - (r - (if (not optarg) - '() - (begin - (set! k 2) - (list - (cond - ((get-bracketed-text-if-any) => (lambda (s) s)) - (else optarg)))))) - (args (read-macro-args argpat k r)) - (rhs-n (string-length rhs))) - (list->string - (let aux ((k 0)) - (if (>= k rhs-n) - '() - (let ((c (string-ref rhs k))) - (cond - ((char=? c #\\) - (let loop ((j (+ k 1)) (s (list #\\))) - (if (>= j rhs-n) - (reverse! s) - (let ((c (string-ref rhs j))) - (cond - ((char-alphabetic? c) (loop (+ j 1) (cons c s))) - ((and (char=? c #\#) (> (length s) 1)) - (append (reverse! s) (cons #\space (aux j)))) - ((= (length s) 1) - (append (reverse! (cons c s)) (aux (+ j 1)))) - (else (append (reverse! s) (aux j)))))))) - ((char=? c #\#) - (if (= k (- rhs-n 1)) - (list #\#) - (let ((n (string-ref rhs (+ k 1)))) - (cond - ((char=? n #\#) (cons #\# (aux (+ k 2)))) - ((and (char-numeric? n) (<= (digit->int n) (length args))) - (append - (string->list (list-ref args (- (digit->int n) 1))) - (aux (+ k 2)))) - (else (cons #\# (aux (+ k 1)))))))) - (else (cons c (aux (+ k 1)))))))))))) - -(define do-verbatimescapechar - (lambda () - (ignorespaces) - (let* ((c1 (get-actual-char)) (c2 (get-actual-char))) - (unless (char=? c1 *esc-char*) - (terror 'do-verbatimescapechar "Arg must be \\")) - (set! *esc-char-verb* c2)))) - -(define do-verb-braced - (lambda (ignore) - (fluid-let - ((*esc-char* *esc-char-verb*) (*tex-extra-letters* '())) - (let loop ((nesting 0)) - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (terror 'do-verb-braced "Eof inside verbatim")) - ((char=? c *esc-char*) - (toss-back-char c) - (let ((x (fluid-let ((*not-processing?* #t)) (get-ctl-seq)))) - (cond - ((ormap (lambda (z) (string=? x z)) '("\\ " "\\{" "\\}")) - (emit (string-ref x 1))) - (else - (fluid-let - ((*esc-char* *esc-char-std*)) - (do-tex-ctl-seq-completely x))))) - (loop nesting)) - ((char=? c #\{) (emit #\{) (loop (+ nesting 1))) - ((char=? c #\}) - (unless (= nesting 0) (emit #\}) (loop (- nesting 1)))) - ((char=? c #\space) - (if *verb-visible-space?* (emit-visible-space) (emit #\space)) - (loop nesting)) - ((char=? c #\newline) - (cond - (*verb-display?* (emit " ") (emit-newline)) - (*verb-visible-space?* (emit-visible-space)) - (else (emit-newline))) - (loop nesting)) - (else (emit-html-char c) (loop nesting)))))))) - -(define do-verb-delimed - (lambda (d) - (let loop () - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (terror 'do-verb-delimed "Eof inside verbatim")) - ((char=? c d) 'done) - ((char=? c #\space) - (if *verb-visible-space?* (emit-visible-space) (emit #\space)) - (loop)) - ((char=? c #\newline) - (cond - (*verb-display?* (emit " ") (emit-newline)) - (*verb-visible-space?* (emit-visible-space)) - (else (emit-newline))) - (loop)) - (else (emit-html-char c) (loop))))))) - -(define do-verb - (lambda () - (ignorespaces) - (bgroup) - (fluid-let - ((*verb-visible-space?* (eat-star)) (*ligatures?* #f)) - (let ((d (get-actual-char))) - (fluid-let - ((*verb-display?* (munched-a-newline?))) - (cond - (*outputting-external-title?* #f) - (*verb-display?* (do-end-para) (emit "
    "))
-           (else (emit "")))
-          ((if (char=? d #\{) do-verb-braced do-verb-delimed) d)
-          (cond
-           (*outputting-external-title?* #f)
-           (*verb-display?* (emit "
    ") (do-para)) - (else (emit "")))))) - (egroup))) - -(define do-verbc - (lambda () - (ignorespaces) - (bgroup) - (fluid-let - ((*ligatures?* #f)) - (emit "") - (emit-html-char (get-actual-char)) - (emit "")) - (egroup))) - -(define do-verbatiminput - (lambda () - (ignorespaces) - (let ((f - (add-dot-tex-if-no-extension-provided - (get-filename-possibly-braced)))) - (cond - ((file-exists? f) - (do-end-para) - (bgroup) - (emit "
    ")
-        (call-with-input-file
-          f
-          (lambda (p)
-            (let loop ()
-              (let ((c (read-char p)))
-                (unless (eof-object? c) (emit-html-char c) (loop))))))
-        (emit "
    ") - (egroup) - (do-para)) - (else (non-fatal-error "File " f " not found")))))) - -(define do-verbwritefile - (lambda () - (let* ((f (get-filename-possibly-braced)) (e (file-extension f))) - (unless e (set! e ".tex") (set! f (string-append f e))) - (when *verb-port* (close-output-port *verb-port*)) - (ensure-file-deleted f) - (set! *verb-written-files* (cons f *verb-written-files*)) - (when (string-ci=? e ".mp") (set! *mp-files* (cons f *mp-files*))) - (set! *verb-port* (open-output-file f))))) - -(define verb-ensure-output-port - (lambda () - (unless *verb-port* - (let ((output-file (string-append *jobname* ".txt"))) - (ensure-file-deleted output-file) - (set! *verb-port* (open-output-file output-file)))))) - -(define dump-groupoid - (lambda (p) - (ignorespaces) - (let ((write-char write-char) (d (get-actual-char))) - (unless p (set! write-char (lambda (x y) #f))) - (case d - ((#\{) - (let loop ((nesting 0)) - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (terror 'dump-groupoid "Eof inside verbatim")) - ((char=? c *esc-char-verb*) - (write-char c p) - (write-char (get-actual-char) p) - (loop nesting)) - ((char=? c #\{) (write-char c p) (loop (+ nesting 1))) - ((char=? c #\}) - (unless (= nesting 0) (write-char c p) (loop (- nesting 1)))) - (else (write-char c p) (loop nesting)))))) - (else - (let loop () - (let ((c (get-actual-char))) - (cond - ((eof-object? c) (terror 'dump-groupoid "Eof inside verbatim")) - ((char=? c d) 'done) - (else (write-char c p) (loop)))))))))) - -(define do-makehtmlimage - (lambda () - (ignorespaces) - (unless (char=? (snoop-actual-char) #\{) - (terror 'do-makehtmlimage "\\makehtmlimage's argument must be a group")) - (call-with-html-image-port dump-groupoid))) - -(define do-verbwrite - (lambda () (verb-ensure-output-port) (dump-groupoid *verb-port*))) - -(define do-string - (lambda () - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) #f) - ((char=? c *esc-char*) - (get-actual-char) - (toss-back-char *invisible-space*) - (toss-back-string "\\TIIPbackslash")) - ((char=? c *comment-char*) (eat-till-eol) (do-string)) - (else (toss-back-char (get-actual-char))))))) - -(define do-verbatim - (lambda () - ((if (eqv? *tex-format* 'latex) do-verbatim-latex do-verbatim-eplain)))) - -(define do-verbatim-latex - (lambda () - (do-end-para) - (bgroup) - (fluid-let - ((*verb-visible-space?* (eat-star))) - (emit "
    ")
-      (munched-a-newline?)
-      (fluid-let
-        ((*ligatures?* #f))
-        (let loop ()
-          (let ((c (snoop-actual-char)))
-            (cond
-             ((eof-object? c)
-              (terror 'do-verbatim-latex "Eof inside verbatim"))
-             ((char=? c #\\)
-              (let ((end? (get-ctl-seq)))
-                (if (string=? end? "\\end")
-                  (cond
-                   ((get-grouped-environment-name-if-any)
-                    =>
-                    (lambda (e)
-                      (unless (or
-                               (and (not *verb-visible-space?*)
-                                    (string=? e "verbatim"))
-                               (and *verb-visible-space?*
-                                    (string=? e "verbatim*")))
-                        (emit-html-string end?)
-                        (emit-html-char #\{)
-                        (emit-html-string e)
-                        (emit-html-char #\})
-                        (loop))))
-                   (else (emit-html-string end?) (loop)))
-                  (begin (emit-html-string end?) (loop)))))
-             ((char=? c #\space)
-              (get-actual-char)
-              (if *verb-visible-space?* (emit-visible-space) (emit #\space))
-              (loop))
-             (else (emit-html-char (get-actual-char)) (loop))))))
-      (emit "
    ")) - (egroup) - (do-para))) - -(define do-verbatim-eplain - (lambda () - (fluid-let - ((*inside-eplain-verbatim?* #t) (*esc-char* *esc-char-verb*)) - (let loop () - (when *inside-eplain-verbatim?* - (let ((c (get-actual-char))) - (cond - ((eof-object? c) - (terror 'do-verbatim-eplain "Eof inside verbatim")) - ((char=? c *esc-char*) - (toss-back-char c) - (let ((x (fluid-let ((*not-processing?* #t)) (get-ctl-seq)))) - (cond - ((string=? x "\\ ") (emit " ")) - (else (do-tex-ctl-seq-completely x)))) - (loop)) - ((char=? c #\space) (emit " ") (loop)) - ((char=? c #\newline) (emit "
    ") (emit-newline) (loop)) - (else (emit-html-char c) (loop))))))))) - -(define do-endverbatim-eplain (lambda () (set! *inside-eplain-verbatim?* #f))) - -(define do-alltt - (lambda () - (do-end-para) - (bgroup) - (emit "
    ")
-    (munched-a-newline?)
-    (fluid-let
-      ((*in-alltt?* #t))
-      (let loop ()
-        (let ((c (snoop-actual-char)))
-          (if (eof-object? c)
-            (terror 'do-alltt "Eof inside alltt")
-            (begin
-              (case c
-                ((#\\) (do-tex-ctl-seq (get-ctl-seq)))
-                ((#\{) (get-actual-char) (bgroup))
-                ((#\}) (get-actual-char) (egroup))
-                (else (emit-html-char (get-actual-char))))
-              (if *in-alltt?* (loop)))))))))
-
-(define do-end-alltt
-  (lambda () (emit "
    ") (egroup) (do-para) (set! *in-alltt?* #f))) - -(define *scm-special-symbols* (make-table 'equ string=?)) - -(define do-scm-set-specialsymbol - (lambda () - (let* ((sym (get-peeled-group)) (xln (get-group))) - (hash-table-put! *scm-special-symbols* sym xln)))) - -(define do-scm-unset-specialsymbol - (lambda () - (call-with-input-string/buffered - (ungroup (get-group)) - (lambda () - (let loop () - (ignore-all-whitespace) - (unless (eof-object? (snoop-actual-char)) - (hash-table-put! *scm-special-symbols* (scm-get-token) #f) - (loop))))))) - -(define do-scm-set-builtins - (lambda () - (call-with-input-string/buffered - (ungroup (get-group)) - (lambda () - (let loop () - (ignore-all-whitespace) - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (let ((s (scm-get-token))) - (set! *scm-keywords* (ldelete s *scm-keywords* string=?)) - (set! *scm-variables* (ldelete s *scm-variables* string=?)) - (set! *scm-builtins* (cons s *scm-builtins*))) - (loop)))))))) - -(define do-scm-set-keywords - (lambda () - (call-with-input-string/buffered - (ungroup (get-group)) - (lambda () - (let loop () - (ignore-all-whitespace) - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (let ((s (scm-get-token))) - (set! *scm-builtins* (ldelete s *scm-builtins* string=?)) - (set! *scm-variables* (ldelete s *scm-variables* string=?)) - (set! *scm-keywords* (cons s *scm-keywords*))) - (loop)))))))) - -(define do-scm-set-variables - (lambda () - (call-with-input-string/buffered - (ungroup (get-group)) - (lambda () - (let loop () - (ignore-all-whitespace) - (let ((c (snoop-actual-char))) - (unless (eof-object? c) - (let ((s (scm-get-token))) - (set! *scm-builtins* (ldelete s *scm-builtins* string=?)) - (set! *scm-keywords* (ldelete s *scm-keywords* string=?)) - (set! *scm-variables* (cons s *scm-variables*))) - (loop)))))))) - -(define scm-emit-html-char - (lambda (c) - (unless (eof-object? c) - (when *scm-dribbling?* (write-char c *verb-port*)) - (emit-html-char c)))) - -(define scm-output-next-chunk - (lambda () - (let ((c (snoop-actual-char))) - (cond - ((and *slatex-math-escape* (char=? c *slatex-math-escape*)) - (scm-escape-into-math)) - ((char=? c #\;) (scm-output-comment) (do-end-para)) - ((char=? c #\") (scm-output-string)) - ((char=? c #\#) (scm-output-hash)) - ((char=? c #\,) - (get-actual-char) - (emit "") - (scm-emit-html-char c) - (let ((c (snoop-actual-char))) - (when (char=? c #\@) (get-actual-char) (scm-emit-html-char c))) - (emit "")) - ((or (char=? c #\') (char=? c #\`)) - (get-actual-char) - (emit "") - (scm-emit-html-char c) - (emit "")) - ((or (char-whitespace? c) (memv c *scm-token-delims*)) - (get-actual-char) - (scm-emit-html-char c)) - (else (scm-output-token (scm-get-token))))))) - -(define scm-set-mathescape - (lambda (yes?) - (let ((c - (fluid-let - ((*esc-char* (integer->char 0))) - (string-ref (ungroup (get-group)) 0)))) - (cond - (yes? - (set! *slatex-math-escape* c) - (set! *scm-token-delims* - (cons *slatex-math-escape* *scm-token-delims*))) - (else - (set! *slatex-math-escape* #f) - (set! *scm-token-delims* (ldelete c *scm-token-delims* char=?))))))) - -(define scm-escape-into-math - (lambda () - (get-actual-char) - (let ((math-text (get-till-char *slatex-math-escape*))) - (get-actual-char) - (unless (string=? math-text "") - (emit "") - (fluid-let - ((*esc-char* *esc-char-std*)) - (tex2page-string (string-append "$" math-text "$"))) - (emit ""))))) - -(define scm-output-slatex-comment - (lambda () - (let ((s (get-line))) - (emit "") - (when *scm-dribbling?* (display s *verb-port*) (newline *verb-port*)) - (fluid-let ((*esc-char* *esc-char-std*)) (tex2page-string s)) - (do-end-para) - (emit "") - (toss-back-char #\newline)))) - -(define scm-output-verbatim-comment - (lambda () - (emit "") - (let loop () - (let ((c (get-actual-char))) - (cond - ((or (eof-object? c) (char=? c #\newline)) - (emit "") - (scm-emit-html-char c)) - ((and (char-whitespace? c) - (let ((c2 (snoop-actual-char))) - (or (eof-object? c2) (char=? c2 #\newline)))) - (emit "") - (scm-emit-html-char (get-actual-char))) - (else (scm-emit-html-char c) (loop))))))) - -(define scm-output-comment - (lambda () - ((if (tex2page-flag-boolean "\\TZPslatexcomments") - scm-output-slatex-comment - scm-output-verbatim-comment)))) - -(define scm-output-extended-comment - (lambda () - (get-actual-char) - (emit "") - (scm-emit-html-char #\#) - (scm-emit-html-char #\|) - (let loop () - (let ((c (get-actual-char))) - (cond - ((eof-object? c) #t) - ((char=? c #\|) - (let ((c2 (snoop-actual-char))) - (cond - ((eof-object? c2) (scm-emit-html-char c)) - ((char=? c2 #\#) (get-actual-char)) - (else (scm-emit-html-char c) (loop))))) - (else (scm-emit-html-char c) (loop))))) - (scm-emit-html-char #\|) - (scm-emit-html-char #\#) - (emit ""))) - -(define scm-output-string - (lambda () - (get-actual-char) - (emit "") - (scm-emit-html-char #\") - (let loop ((esc? #f)) - (let ((c (get-actual-char))) - (case c - ((#\") (when esc? (scm-emit-html-char c) (loop #f))) - ((#\\) (scm-emit-html-char c) (loop (not esc?))) - (else (scm-emit-html-char c) (loop #f))))) - (scm-emit-html-char #\") - (emit ""))) - -(define scm-output-hash - (lambda () - (get-actual-char) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) - (emit "") - (scm-emit-html-char #\#) - (emit "")) - ((char=? c #\|) (scm-output-extended-comment)) - (else (toss-back-char #\#) (scm-output-token (scm-get-token))))))) - -(define scm-output-token - (lambda (s) - (case (scm-get-type s) - ((special-symbol) - (fluid-let - ((*esc-char* *esc-char-std*)) - (tex2page-string (table-get *scm-special-symbols* s)))) - ((keyword) - (emit "") - (scm-display-token s) - (emit "")) - ((global) - (emit "") - (scm-display-token s) - (emit "")) - ((selfeval) - (emit "") - (scm-display-token s) - (emit "")) - ((builtin) - (emit "") - (scm-display-token s) - (emit "")) - ((background) (scm-display-token s)) - (else - (emit "") - (scm-display-token s) - (emit ""))))) - -(define scm-display-token - (lambda (s) - (let ((n (string-length s))) - (let loop ((k 0)) - (when (< k n) (scm-emit-html-char (string-ref s k)) (loop (+ k 1))))))) - -(define do-scm-braced - (lambda (result?) - (get-actual-char) - (let ((display? (munched-a-newline?))) - (cond - ((not display?) - (emit "")) - (else (do-end-para) (emit "
    ")))
-      (bgroup)
-      (fluid-let
-        ((*esc-char* *esc-char-verb*) (*verb-display?* display?))
-        (let loop ((nesting 0))
-          (let ((c (snoop-actual-char)))
-            (cond
-             ((eof-object? c) (terror 'do-scm-braced "Eof inside verbatim"))
-             ((char=? c *esc-char*)
-              (let ((x (fluid-let ((*not-processing?* #t)) (get-ctl-seq))))
-                (cond
-                 ((ormap (lambda (z) (string=? x z)) '("\\ " "\\{" "\\}"))
-                  (scm-emit-html-char (string-ref x 1)))
-                 (else
-                  (fluid-let
-                    ((*esc-char* *esc-char-std*))
-                    (do-tex-ctl-seq-completely x)))))
-              (loop nesting))
-             ((char=? c #\{)
-              (get-actual-char)
-              (scm-emit-html-char c)
-              (loop (+ nesting 1)))
-             ((char=? c #\})
-              (get-actual-char)
-              (unless (= nesting 0)
-                (scm-emit-html-char c)
-                (loop (- nesting 1))))
-             (else (scm-output-next-chunk) (loop nesting))))))
-      (egroup)
-      (if (not display?) (emit "") (begin (emit "
    ") (do-para)))))) - -(define do-scm-delimed - (lambda (result?) - (let ((d (get-actual-char))) - (let ((display? (munched-a-newline?))) - (cond - ((not display?) - (emit "")) - (else (do-end-para) (emit "
    ")))
-        (fluid-let
-          ((*verb-display?* display?)
-           (*scm-token-delims* (cons d *scm-token-delims*)))
-          (let loop ()
-            (let ((c (snoop-actual-char)))
-              (cond
-               ((eof-object? c) (terror 'do-scm-delimed "Eof inside verbatim"))
-               ((char=? c d) (get-actual-char))
-               (else (scm-output-next-chunk) (loop))))))
-        (if (not display?)
-          (emit "")
-          (begin (emit "
    ") (do-para))))))) - -(define do-scm - (lambda (result?) - (cond - (*outputting-external-title?* (do-verb)) - (else - (ignorespaces) - (bgroup) - (fluid-let - ((*ligatures?* #f)) - ((if (char=? (snoop-actual-char) #\{) do-scm-braced do-scm-delimed) - result?)) - (egroup))))) - -(define do-scminput - (lambda () - (ignorespaces) - (do-end-para) - (bgroup) - (emit "
    ")
-    (let ((f
-           (add-dot-tex-if-no-extension-provided
-             (get-filename-possibly-braced))))
-      (call-with-input-file/buffered
-        f
-        (lambda ()
-          (let loop ()
-            (let ((c (snoop-actual-char)))
-              (unless (eof-object? c) (scm-output-next-chunk) (loop)))))))
-    (emit "
    ") - (egroup) - (do-para))) - -(define do-scmdribble - (lambda () - (verb-ensure-output-port) - (fluid-let ((*scm-dribbling?* #t)) (do-scm #f)) - (newline *verb-port*))) - -(define do-scm-slatex-lines - (lambda (env display? result?) - (let ((endenv (string-append "\\end" env)) - (in-table? - (and (not (null? *tabular-stack*)) - (memv (car *tabular-stack*) '(block figure table))))) - (cond (display? (do-end-para)) (in-table? (emit "    ") - (emit-newline) - (emit "") - (emit-newline) - (set! *equation-position* 0) - (emit "") - (cond - (*equation-numbered?* - (emit "")) - (else (set! *equation-numbered?* #t))) - (emit "") - (emit-newline) - (set! *equation-position* 0) - (emit "") (emit-newline) (emit "") - (emit-newline) - (emit "") - (emit-newline))) - -(define do-tex-logo (lambda () (emit "TEX"))) - -(define do-latex-logo (lambda () (emit "LA") (do-tex-logo))) - -(define do-romannumeral - (lambda (upcase?) - (cond - ((get-number-or-false) - => - (lambda (n) (emit (number->roman n upcase?))))))) - -(define do-uppercase - (lambda () (emit (string-upcase (tex-string->html-string (get-token)))))) - -(define set-latex-counter - (lambda (add?) - (let* ((counter-name (get-peeled-group)) - (new-value (string->number (get-token-or-peeled-group)))) - (cond - ((table-get *dotted-counters* counter-name) - => - (lambda (counter) - (set!counter.value - counter - (if add? (+ new-value (counter.value counter)) new-value)))) - (else - (let ((count-seq (string-append "\\" counter-name))) - (cond - ((section-ctl-seq? count-seq) - => - (lambda (n) - (hash-table-put! - *section-counters* - n - (if add? - (+ new-value (table-get *section-counters* n 0)) - new-value)))) - ((find-count count-seq) - (set-gcount! - count-seq - (if add? (+ new-value (get-gcount count-seq)) new-value))) - (else #f)))))))) - -(define do-tex-prim - (lambda (z) - (cond - ((find-def z) - => - (lambda (y) - (cond - ((tdef.defer y) => toss-back-string) - ((tdef.thunk y) => (lambda (th) (th))) - (else - (expand-tex-macro - (tdef.optarg y) - (tdef.argpat y) - (tdef.expansion y)))))) - ((section-ctl-seq? z) => (lambda (n) (do-heading n))) - (*math-mode?* (do-math-ctl-seq z)) - (else (trace-if (> (get-count "\\tracingcommands") 0) "Ignoring " z))))) - -(define do-char (lambda () (emit-html-char (get-tex-char-spec)))) - -(define do-tex-char - (lambda (c) - (cond - ((and *comment-char* (char=? c *comment-char*)) (do-comment)) - ((inside-false-world?) #t) - ((char=? c #\{) (bgroup)) - ((char=? c #\}) (egroup)) - ((char=? c #\$) (do-math)) - ((char=? c #\-) (do-hyphen)) - ((char=? c #\`) (do-lsquo)) - ((char=? c #\') (do-rsquo)) - ((char=? c #\~) (emit-nbsp 1)) - ((char=? c #\!) (do-excl)) - ((char=? c #\?) (do-quest)) - ((or (char=? c #\<) (char=? c #\>) (char=? c #\")) (emit-html-char c)) - ((char=? c #\&) - (cond - ((not (null? *tabular-stack*)) - (do-end-para) - (case (car *tabular-stack*) - ((pmatrix eqalign displaylines) (emit "")) - ((eqnarray eqnarray*) - (set! *equation-position* (+ *equation-position* 1)) - (emit "")) - ((tabular) (do-tabular-colsep)) - ((ruled-table) (do-ruledtable-colsep)))) - (else (emit-html-char c)))) - ((char=? c #\|) - (if (and (not (null? *tabular-stack*)) - (eqv? (car *tabular-stack*) 'ruled-table)) - (do-ruledtable-colsep) - (emit c))) - ((char=? c #\newline) (do-newline)) - ((char=? c #\space) (do-space)) - ((char=? c *tab*) (do-tab)) - (else - (cond - (*math-mode?* - (case c - ((#\^) (do-sup)) - ((#\_) (do-sub)) - ((#\+ #\=) - (unless *math-script-mode?* (emit #\space)) - (emit c) - (unless *math-script-mode?* (emit #\space))) - (else - (if (and (char-alphabetic? c) (not *math-roman-mode?*)) - (begin (emit "") (emit c) (emit "")) - (emit c))))) - ((and *in-small-caps?* (char-lower-case? c)) - (emit "") - (emit (char-upcase c)) - (emit "")) - (else (emit c))))))) - -(define do-tex-ctl-seq-completely - (lambda (x) - (cond - ((resolve-defs x) => tex2page-string) - ((do-tex-prim (find-corresp-prim x)) - => - (lambda (y) (if (eqv? y ':encountered-undefined-command) (emit x))))))) - -(define inside-false-world? - (lambda () (or (memv #f *tex-if-stack*) (memv '? *tex-if-stack*)))) - -(define do-tex-ctl-seq - (lambda (z) - (trace-if (> (get-count "\\tracingcommands") 0) z) - (cond - ((resolve-defs z) - => - (lambda (s) - (trace-if (> (get-count "\\tracingmacros") 0) " --> " s) - (toss-back-char *invisible-space*) - (toss-back-string s))) - ((and (inside-false-world?) (not (if-aware-ctl-seq? z))) #f) - ((string=? z "\\enddocument") (probably-latex) ':encountered-bye) - ((or (string=? z "\\bye") (string=? z "\\TIIPbye")) ':encountered-bye) - ((string=? z "\\endinput") - (let ((next-token (get-token))) - (when (and (not (eof-object? next-token)) (string=? next-token "\\fi")) - (do-fi))) - ':encountered-endinput) - ((find-count z) (do-count= z #f)) - ((find-toks z) (do-toks= z #f)) - ((find-dimen z) (do-dimen= z #f)) - (else (do-tex-prim z))))) - -(define generate-html - (lambda () - (let loop () - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) #t) - ((resolve-chardefs c) - => - (lambda (s) - (toss-back-char *invisible-space*) - (toss-back-string s) - (loop))) - ((char=? c *esc-char*) - (let ((r (do-tex-ctl-seq (get-ctl-seq)))) - (case r - ((:encountered-endinput) #t) - ((:encountered-bye) ':encountered-bye) - (else (loop))))) - (else (get-actual-char) (do-tex-char c) (loop))))))) - -(define do-iffileexists - (lambda () - (let* ((file (actual-tex-filename (get-filename-possibly-braced) #f)) - (thene (ungroup (get-group))) - (elsee (ungroup (get-group)))) - (tex2page-string (if file thene elsee))))) - -(define check-input-file-timestamp? - (lambda (f) - (cond - ((let ((e (file-extension f))) - (and e (member/string-ci=? e '(".t2p" ".bbl" ".ind")))) - #f) - (*inputting-boilerplate?* #f) - (*ignore-timestamp?* #f) - ((> *html-only* 0) #f) - ((and (>= (string-length f) 3) - (char=? (string-ref f 0) #\.) - (char=? (string-ref f 1) #\/)) - #f) - ((member f *verb-written-files*) #f) - (else #t)))) - -(define do-inputiffileexists - (lambda () - (let* ((f (actual-tex-filename (get-filename-possibly-braced) #f)) - (then-txt (ungroup (get-group))) - (else-txt (ungroup (get-group)))) - (cond - (f (tex2page-string then-txt) (tex2page-file f)) - (else (tex2page-string else-txt)))))) - -(define tex2page-file - (lambda (f) - (write-log #\() - (write-log f) - (write-log 'separation-space) - (set! f (tex2page-massage-file f)) - (trace-if (> (get-count "\\tracingcommands") 0) "Inputting file " f) - (let ((r (call-with-input-file/buffered f generate-html))) - (write-log #\)) - (write-log 'separation-space) - r))) - -(define tex2page-file-if-exists - (lambda (f) (when (file-exists? f) (tex2page-file f)))) - -(define do-input - (lambda () - (ignorespaces) - (let ((f (get-filename-possibly-braced))) - (let ((boilerplate-index *inputting-boilerplate?*)) - (when (eqv? *inputting-boilerplate?* 0) - (set! *inputting-boilerplate?* #f)) - (fluid-let - ((*inputting-boilerplate?* - (and boilerplate-index (+ boilerplate-index 1)))) - (cond - ((or (latex-style-file? f) - (member/string-ci=? - f - '("btxmac" - "btxmac.tex" - "eplain" - "eplain.tex" - "epsf" - "epsf.tex" - "eval4tex" - "eval4tex.tex" - "supp-pdf" - "supp-pdf.tex" - "tex2page" - "tex2page.tex"))) - #f) - ((member/string-ci=? f '("miniltx" "miniltx.tex")) - (set-catcode #\@ 11) - #f) - ((ormap (lambda (z) (string=? f z)) '("texinfo" "texinfo.tex")) - (let ((txi2p (actual-tex-filename "texi2p" #f))) - (if txi2p - (begin - (tex2page-file txi2p) - (tex2page-file *current-source-file*) - ':encountered-endinput) - (terror 'do-input "File texi2p.tex not found")))) - ((actual-tex-filename f (check-input-file-timestamp? f)) - => - tex2page-file) - (else - (write-log #\() - (write-log f) - (write-log 'separation-space) - (write-log "not found)") - (write-log 'separation-space)))))))) - -(define do-includeonly - (lambda () - (ignorespaces) - (when (eq? *includeonly-list* #t) (set! *includeonly-list* '())) - (let ((c (get-actual-char))) - (when (or (eof-object? c) (not (char=? c #\{))) - (terror 'do-includeonly))) - (fluid-let - ((*filename-delims* (cons #\} (cons #\, *filename-delims*)))) - (let loop () - (ignorespaces) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) (terror 'do-includeonly)) - ((and *comment-char* (char=? c *comment-char*)) - (eat-till-eol) - (ignorespaces) - (loop)) - ((char=? c #\,) (get-actual-char) (loop)) - ((char=? c #\}) (get-actual-char)) - ((ormap (lambda (d) (char=? c d)) *filename-delims*) - (terror 'do-includeonly)) - (else - (set! *includeonly-list* - (cons (get-plain-filename) *includeonly-list*)) - (loop)))))))) - -(define do-include - (lambda () - (let ((f (ungroup (get-group)))) - (when (or - (eq? *includeonly-list* #t) - (ormap (lambda (i) (string=? f i)) *includeonly-list*)) - (fluid-let - ((*subjobname* (file-stem-name f)) - (*img-file-count* 0) - (*imgdef-file-count* 0)) - (tex2page-file - (actual-tex-filename f (check-input-file-timestamp? f)))))))) - -(define do-eval-string - (lambda (s) - (call-with-input-string - s - (lambda (i) - (let loop () - (let ((x (read i))) (unless (eof-object? x) (eval-expr x) (loop)))))))) - -(define with-output-to-port - (lambda (o th) (parameterize ((current-output-port o)) (th)))) - -(define do-eval - (lambda (fmts) - (let ((s - (ungroup - (fluid-let - ((*esc-char* *esc-char-verb*) (*expand-escape?* #t)) - (get-group))))) - (unless (inside-false-world?) - (when (> *html-only* 0) (set! fmts 'html)) - (case fmts - ((html) - (let ((o (open-output-string))) - (with-output-to-port o (lambda () (do-eval-string s))) - (tex2page-string (get-output-string o)))) - ((quiet) (do-eval-string s)) - (else - (set! *eval-file-count* (+ *eval-file-count* 1)) - (let ((eval4tex-file - (string-append - *jobname* - *eval-file-suffix* - (number->string *eval-file-count*) - ".tex"))) - (ensure-file-deleted eval4tex-file) - (with-output-to-file - eval4tex-file - (lambda () (do-eval-string s) (display "\\relax"))) - (fluid-let - ((*ignore-timestamp?* #t)) - (tex2page-file eval4tex-file))))))))) - -(define eval-for-tex-only - (lambda () - (set! *eval-for-tex-only?* #t) - (do-end-page) - (ensure-file-deleted *html-page*) - (set! *main-tex-file* #f) - (set! *html-page* ".eval4texignore") - (ensure-file-deleted *html-page*) - (set! *html* (open-output-file *html-page*)))) - -(define expand-ctl-seq-into-string - (lambda (cs) - (let ((tmp-port (open-output-string))) - (fluid-let ((*html* tmp-port)) (do-tex-ctl-seq cs)) - (get-output-string tmp-port)))) - -(define tex-string->html-string - (lambda (ts) - (let ((tmp-port (open-output-string))) - (fluid-let ((*html* tmp-port)) (tex2page-string ts)) - (get-output-string tmp-port)))) - -(define call-with-html-output-going-to - (lambda (p th) (fluid-let ((*html* p)) (th)))) - -(define call-external-programs-if-necessary - (lambda () - (let ((run-bibtex? - (cond - ((not *using-bibliography?*) #f) - ((not - (file-exists? - (string-append - *aux-dir/* - *jobname* - *bib-aux-file-suffix* - ".aux"))) - #f) - ((memv 'bibliography *missing-pieces*) #t) - (*source-changed-since-last-run?* - (flag-missing-piece 'fresh-bibliography) - #t) - (else #f))) - (run-makeindex? - (cond - ((not *using-index?*) #f) - ((not - (file-exists? - (string-append - *aux-dir/* - *jobname* - *index-file-suffix* - ".idx"))) - #f) - ((memv 'index *missing-pieces*) #t) - (*source-changed-since-last-run?* - (flag-missing-piece 'fresh-index) - #t) - (else #f)))) - (when run-bibtex? - (write-log 'separation-newline) - (write-log "Running: bibtex ") - (write-log *aux-dir/*) - (write-log *jobname*) - (write-log *bib-aux-file-suffix*) - (write-log #\space) - (system - (string-append "bibtex " *aux-dir/* *jobname* *bib-aux-file-suffix*)) - (unless (file-exists? - (string-append *jobname* *bib-aux-file-suffix* ".bbl")) - (write-log " ... failed; try manually")) - (write-log 'separation-newline)) - (when run-makeindex? - (write-log 'separation-newline) - (write-log "Running: makeindex ") - (write-log *aux-dir/*) - (write-log *jobname*) - (write-log *index-file-suffix*) - (write-log #\space) - (system - (string-append - "makeindex " - *aux-dir/* - *jobname* - *index-file-suffix*)) - (unless (file-exists? - (string-append - *aux-dir/* - *jobname* - *index-file-suffix* - ".ind")) - (write-log " ... failed; try manually")) - (write-log 'separation-newline)) - (for-each - (lambda (f) - (when (file-exists? f) - (write-log 'separation-newline) - (write-log "Running: metapost ") - (write-log f) - (write-log 'separation-newline) - (system (string-append *metapost* " " f)))) - *mp-files*) - (for-each - (lambda (eps-file+img-file-stem) - (retry-lazy-image - (car eps-file+img-file-stem) - (cdr eps-file+img-file-stem))) - *missing-eps-files*)))) - -(define first-file-that-exists - (lambda ff (ormap (lambda (f) (and f (file-exists? f) f)) ff))) - -(define file-in-home - (lambda (f) - (let ((home (getenv "HOME"))) - (and home - (let ((slash-already? - (let ((n (string-length home))) - (and (>= n 0) - (let ((c (string-ref home (- n 1)))) - (or (char=? c #\/) (char=? c #\\))))))) - (string-append home (if slash-already? "" "/") f)))))) - -(define make-target-dir - (lambda () - (let ((hdir-file - (first-file-that-exists - (string-append *jobname* ".hdir") - ".tex2page.hdir" - (file-in-home ".tex2page.hdir")))) - (when hdir-file - (let ((hdir - (call-with-input-file/buffered - hdir-file - (lambda () (get-filename-possibly-braced))))) - (unless (= (string-length hdir) 0) - (case *operating-system* - ((cygwin unix) - (system (string-append "mkdir -p " hdir)) - (system (string-append "touch " hdir "/probe"))) - ((windows) - (system (string-append "mkdir " hdir)) - (system (string-append "echo probe > " hdir "\\probe")))) - (let ((probe (string-append hdir "/probe"))) - (when (file-exists? probe) - (ensure-file-deleted probe) - (set! *aux-dir* hdir) - (set! *aux-dir/* (string-append *aux-dir* "/")))))))))) - -(define move-aux-files-to-aux-dir - (lambda (f) - (when (and - *aux-dir* - (or (file-exists? (string-append f ".tex")) - (file-exists? (string-append f ".scm")) - (file-exists? (string-append f (find-img-file-extn))))) - (case *operating-system* - ((cygwin unix) (system (string-append "mv " f ".* " *aux-dir*))) - ((windows) - (system (string-append "copy " f ".* " *aux-dir*)) - (when (or - (file-exists? (string-append f ".tex")) - (file-exists? (string-append f ".scm"))) - (system (string-append "del " f ".*")))))))) - -(define start-css-file - (lambda () - (let ((css-file (string-append *aux-dir/* *jobname* *css-file-suffix*))) - (ensure-file-deleted css-file) - (set! *css-port* (open-output-file css-file)) - (display - "\n body {\n color: black;\n /* background-color: #e5e5e5;*/\n background-color: #ffffff;\n /*background-color: beige;*/\n margin-top: 2em;\n margin-bottom: 2em;\n /* margin-left: 8%;\n margin-right: 8%; */\n }\n\n @media screen {\n body {\n margin-left: 8%;\n margin-right: 8%;\n }\n }\n\n @media print {\n body {\n text-align: justify;\n }\n }\n\n @media print {\n a:link, a:visited {\n text-decoration: none;\n color: black;\n }\n }\n\n @media print {\n p {\n text-indent: 2em;\n margin-top: 1ex;\n margin-bottom: 0;\n }\n\n }\n\n h1,h2,h3,h4,h5,h6 {\n margin-top: .8em;\n margin-bottom: .2em; /* ?? */\n }\n \n\n .title {\n font-size: 200%;\n font-weight: normal;\n margin-top: 2.8em;\n text-align: center;\n }\n\n .partheading {\n font-size: 100%;\n }\n\n .chapterheading {\n font-size: 100%;\n }\n\n .beginsection {\n margin-top: 1.8em;\n font-size: 100%;\n }\n\n .tiny {\n font-size: 40%;\n }\n\n .scriptsize {\n font-size: 60%;\n }\n\n .footnotesize {\n font-size: 75%;\n }\n\n .small {\n font-size: 90%;\n }\n\n .normalsize {\n font-size: 100%;\n }\n\n .large {\n font-size: 120%;\n }\n\n .largecap {\n font-size: 150%;\n }\n\n .largeup {\n font-size: 200%;\n }\n\n .huge {\n font-size: 300%;\n }\n\n .hugecap {\n font-size: 350%;\n }\n\n p.noindent {\n text-indent: 0;\n }\n\n pre {\n margin-left: 2em;\n }\n\n blockquote {\n margin-left: 2em;\n }\n\n .smallskip {\n margin-top: 2pt;\n margin-bottom: 2pt;\n min-height: 4pt;\n }\n\n .medskip {\n margin-top: 3pt;\n margin-bottom: 3pt;\n min-height: 7pt; \n /*margin-top: 1.6em; \n margin-bottom: 2.4em; \n margin-top: 1em;\n margin-bottom: 1.5em; */\n /* top and bottom have to be different so successive \\...skips cause more spacing? */\n }\n\n .bigskip {\n margin-top: 4pt;\n margin-bottom: 4pt;\n min-height: 13pt;\n /*margin-top: 2.8em; \n margin-bottom: 3.4em; \n margin-top: 2.4em;\n margin-bottom: 1.6em; */\n }\n\n\n ol {\n list-style-type: decimal;\n }\n\n ol ol {\n list-style-type: lower-alpha;\n }\n\n ol ol ol {\n list-style-type: lower-roman;\n }\n\n ol ol ol ol {\n list-style-type: upper-alpha;\n }\n\n tt i {\n font-family: serif;\n }\n\n .verbatim em {\n font-family: serif;\n }\n\n /*\n .verbatim {\n color: #4d0000;\n }\n */\n\n .scheme em {\n color: black;\n font-family: serif;\n }\n\n .scheme {color: #993333} /* background punctuation */\n .scheme .selfeval {color: #006600}\n .scheme .keyword {color: #660000; font-weight: bold}\n .scheme .builtin {color: #660000}\n .scheme .global {color: #660066}\n .scheme .variable {color: #000066}\n .scheme .comment {color: #006666; font-style: oblique}\n\n .schemeresponse {\n color: #006600;\n }\n\n .navigation {\n color: #993300;\n text-align: right;\n font-size: medium;\n font-style: italic;\n }\n\n @media print {\n .navigation {\n display: none;\n }\n }\n\n .disable {\n /* color: #e5e5e5; */\n color: gray;\n }\n\n .smallcaps {\n font-size: 75%;\n }\n\n .smallprint {\n color: gray;\n font-size: 75%;\n text-align: right;\n }\n\n /*\n .smallprint hr {\n text-align: left;\n width: 40%;\n }\n */\n\n .footnoterule {\n text-align: left;\n width: 40%;\n }\n\n @media print {\n .footnoterule {\n margin-top: 2em;\n }\n }\n\n .colophon {\n color: gray;\n font-size: 80%;\n font-style: italic;\n text-align: right;\n margin-top: 1em;\n }\n\n @media print {\n .colophon .advertisement {\n display: none;\n }\n }\n\n .colophon a {\n color: gray;\n }\n " - *css-port*)))) - -(define load-aux-file - (lambda () - (set-start-time) - (let ((label-file - (string-append *aux-dir/* *jobname* *label-file-suffix* ".scm"))) - (when (file-exists? label-file) - (load-tex2page-data-file label-file) - (delete-file label-file))) - (unless (string=? *jobname* "texput") - (let ((jobname-aux (string-append "texput" *aux-file-suffix* ".scm"))) - (when (file-exists? jobname-aux) (delete-file jobname-aux)))) - (let ((aux-file - (string-append *aux-dir/* *jobname* *aux-file-suffix* ".scm"))) - (when (file-exists? aux-file) - (load-tex2page-data-file aux-file) - (delete-file aux-file)) - (set! *aux-port* (open-output-file aux-file))) - (start-css-file) - (unless (null? *toc-list*) (set! *toc-list* (reverse! *toc-list*))) - (unless (null? *stylesheets*) - (set! *stylesheets* (reverse! *stylesheets*))) - (unless (null? *html-head*) (set! *html-head* (reverse! *html-head*))))) - -(define update-last-modification-time - (lambda (f) - (let ((s (file-or-directory-modify-seconds f))) - (when (and - s - (or (not *last-modification-time*) - (> s *last-modification-time*))) - (set! *source-changed-since-last-run?* #t) - (!last-modification-time s) - (when (and - (tex2page-flag-boolean "\\TZPcolophontimestamp") - (not (tex2page-flag-boolean "\\TZPcolophonlastpage")) - (> *html-page-count* 1)) - (flag-missing-piece 'last-modification-time)))))) - -(define probably-latex - (lambda () - (when (null? *tex-env*) - (set! *latex-probability* (+ *latex-probability* 1)) - (if (>= *latex-probability* 2) (definitely-latex))))) - -(define definitely-latex - (let ((already-noted? #f)) - (lambda () - (unless already-noted? - (set! already-noted? #t) - (!definitely-latex) - (write-aux `(!definitely-latex)))))) - -(define !tex-like-layout (lambda () (set! *tex-like-layout?* #t))) - -(define !head-line (lambda (e) (tex-def-toks "\\headline" e #t))) - -(define !foot-line (lambda (e) (tex-def-toks "\\footline" e #t))) - -(define !toc-page (lambda (p) (set! *toc-page* p))) - -(define !index-page (lambda (p) (set! *index-page* p))) - -(define !toc-entry - (lambda (level number page label header) - (set! *toc-list* - (cons - (make-tocentry - 'level - level - 'number - number - 'page - page - 'label - label - 'header - header) - *toc-list*)))) - -(define !label - (lambda (label html-page name value) - (hash-table-put! - *label-table* - label - (make-label - 'src - *label-source* - 'page - html-page - 'name - name - 'value - value)))) - -(define !index - (lambda (index-number html-page-number) - (hash-table-put! *index-table* index-number html-page-number))) - -(define !last-modification-time (lambda (s) (set! *last-modification-time* s))) - -(define !last-page-number (lambda (n) (set! *last-page-number* n))) - -(define !using-chapters (lambda () (set! *using-chapters?* #t))) - -(define !definitely-latex - (lambda () - (set! *tex-format* 'latex) - (when (< (get-gcount "\\secnumdepth") -1) - (set-gcount! "\\secnumdepth" 3)))) - -(define !using-external-program (lambda (x) #f)) - -(define !external-labels (lambda (f) #f)) - -(define !doctype (lambda (d) (set! *doctype* d))) - -(define !colophon - (lambda (x) - (case x - ((last-page) (tex-def-0arg "\\TZPcolophonlastpage" "1")) - ((no-timestamp) (tex-def-0arg "\\TZPcolophontimestamp" "0")) - ((dont-credit-tex2page ingrate) (tex-def-0arg "\\TZPcolophoncredit" "0")) - ((dont-link-to-tex2page-website) - (tex-def-0arg "\\TZPcolophonweblink" "0"))))) - -(define fully-qualified-url? - (lambda (u) (or (substring? "//" u) (char=? (string-ref u 0) #\/)))) - -(define fully-qualified-pathname? - (lambda (f) - (let ((n (string-length f))) - (if (= n 0) - #t - (let ((c0 (string-ref f 0))) - (cond - ((char=? c0 #\/) #t) - ((= n 1) #f) - ((and (char-alphabetic? c0) (char=? (string-ref f 1) #\:)) #t) - (else #f))))))) - -(define ensure-url-reachable - (lambda (f) - (if (and *aux-dir* (not (fully-qualified-url? f)) (not (substring? "/" f))) - (let ((real-f (string-append *aux-dir/* f))) - (when (and (file-exists? f) (not (file-exists? real-f))) - (case *operating-system* - ((cygwin unix) (system (string-append "cp -p " f " " real-f))) - ((windows) (system (string-append "copy/b " f " " *aux-dir*))))) - real-f) - f))) - -(define !stylesheet - (lambda (css) - (if (file-exists? (ensure-url-reachable css)) - (set! *stylesheets* (cons css *stylesheets*)) - (begin - (write-log "! Can't find stylesheet ") - (write-log css) - (write-log 'separation-newline))))) - -(define !html-head (lambda (s) (set! *html-head* (cons s *html-head*)))) - -(define !default-title (lambda (title) (unless *title* (set! *title* title)))) - -(define !preferred-title (lambda (title) (set! *title* title))) - -(define !infructuous-calls-to-tex2page - (lambda (n) (set! *infructuous-calls-to-tex2page* n))) - -(define load-tex2page-data-file - (lambda (f) - (when (file-exists? f) - (fluid-let - ((*current-source-file* f) (*input-line-no* 0)) - (call-with-input-file - f - (lambda (i) - (let loop () - (let ((e (read i))) - (unless (eof-object? e) - (set! *input-line-no* (+ *input-line-no* 1)) - (let ((x (car e))) - (apply - (case x - ((!colophon) !colophon) - ((!default-title) !default-title) - ((!definitely-latex) !definitely-latex) - ((!doctype) !doctype) - ((!external-labels) !external-labels) - ((!foot-line) !foot-line) - ((!header) !html-head) - ((!head-line) !head-line) - ((!html-head) !html-head) - ((!index) !index) - ((!index-page) !index-page) - ((!infructuous-calls-to-tex2page) - !infructuous-calls-to-tex2page) - ((!label) !label) - ((!last-modification-time) !last-modification-time) - ((!last-page-number) !last-page-number) - ((!preferred-title) !preferred-title) - ((!stylesheet) !stylesheet) - ((!tex-like-layout) !tex-like-layout) - ((!toc-entry) !toc-entry) - ((!toc-page) !toc-page) - ((!using-chapters) !using-chapters) - ((!using-external-program) !using-external-program) - (else - (terror - 'load-tex2page-data-file - "Unrecognized aux file directive " - x))) - (cdr e)) - (loop))))))))))) - -(define tex2page-massage-file (lambda (f) f)) - -(define tex2page-help - (lambda (not-a-file) - (write-aux - `(!infructuous-calls-to-tex2page ,(+ *infructuous-calls-to-tex2page* 1))) - (unless (or - (string=? not-a-file "--help") - (string=? not-a-file "--missing-arg") - (string=? not-a-file "--version")) - (write-log "! I can't find file `") - (write-log not-a-file) - (write-log "'.") - (write-log 'separation-newline)) - (cond - ((string=? not-a-file "--version") - (write-log "Copyright (c) 1997-") - (write-log (substring *tex2page-version* 0 4)) - (write-log - ", Dorai Sitaram.\n\nPermission to distribute and use this work for any\npurpose is hereby granted provided this copyright\nnotice is included in the copy. This work is provided\nas is, with no warranty of any kind.\n\nFor more information on TeX2page, please see") - (write-log #\newline) - (write-log *tex2page-website*) - (write-log #\.) - (write-log #\newline) - (write-log #\newline)) - ((string=? not-a-file "--help") - (write-log - "\nThe command tex2page converts a (La)TeX document into\nWeb pages. Call tex2page with the relative or full\npathname of the main (La)TeX file. The file extension\nis optional if it is .tex.\n\nThe relative pathnames of the main and any subsidiary\n(La)TeX files are resolved against the current working\ndirectory and the list of directories in the\nenvironment variable TIIPINPUTS, or if that does not\nexist, TEXINPUTS. \n\nThe output Web files are generated in the current\ndirectory by default. An alternate location can be\nspecified in .hdir, tex2page.hdir, or\n~/tex2page.hdir, where is the basename of the\nmain (La)TeX file. \n\nFor more information on tex2page, please see") - (write-log #\newline) - (write-log *tex2page-website*) - (write-log #\.) - (write-log #\newline) - (write-log #\newline)) - (else - (when (string=? not-a-file "--missing-arg") - (write-log "! Missing command-line argument.") - (write-log 'separation-newline)) - (when (> *infructuous-calls-to-tex2page* 0) - (write-log "You have called TeX2page") - (write-log #\space) - (write-log (+ *infructuous-calls-to-tex2page* 1)) - (write-log #\space) - (write-log "times without a valid input document.") - (write-log 'separation-newline)) - (cond - ((>= *infructuous-calls-to-tex2page* 4) - (write-log "I can't go on meeting you like this.") - (write-log 'separation-newline) - (write-log "Good bye!") - (write-log 'separation-newline)) - (else - (write-log - "Do you need help using TeX2page?\nTry the commands\n tex2page --help\n tex2page --version") - (write-log 'separation-newline))))) - (close-all-open-ports))) - -(define non-fatal-error - (lambda ss - (emit-link-start (string-append *jobname* ".hlog")) - (emit "[") - (for-each emit-html-string ss) - (emit "]") - (emit-link-stop))) - -(define do-math-ctl-seq - (lambda (s) - (cond - ((find-math-def s) => (lambda (x) ((tdef.thunk x)))) - (else - (unless *math-needs-image?* (set! *math-needs-image?* #t)) - (emit (substring s 1 (string-length s))))))) - -(define tex-def-math-prim - (lambda (cs thunk) - (tex-def cs '() #f #f thunk cs #f *math-primitive-texframe*))) - -(define make-reusable-math-image-as-needed - (lambda (cs . expn) - (let ((expn (if (null? expn) cs (car expn)))) - (tex-def-math-prim - cs - (lambda () - (tex2page-string - (string-append "\\global\\imgdef" cs "{$" expn "$}")) - (tex2page-string cs)))))) - -(tex-def-math-prim "\\alpha" (lambda () (emit "α"))) - -(tex-def-math-prim "\\beta" (lambda () (emit "β"))) - -(tex-def-math-prim "\\gamma" (lambda () (emit "γ"))) - -(tex-def-math-prim "\\delta" (lambda () (emit "δ"))) - -(tex-def-math-prim "\\epsilon" (lambda () (emit "ε"))) - -(tex-def-math-prim "\\varepsilon" (lambda () (emit "ε"))) - -(tex-def-math-prim "\\zeta" (lambda () (emit "ζ"))) - -(tex-def-math-prim "\\eta" (lambda () (emit "η"))) - -(tex-def-math-prim "\\theta" (lambda () (emit "θ"))) - -(tex-def-math-prim "\\vartheta" (lambda () (emit "ϑ"))) - -(tex-def-math-prim "\\iota" (lambda () (emit "ι"))) - -(tex-def-math-prim "\\kappa" (lambda () (emit "κ"))) - -(tex-def-math-prim "\\lambda" (lambda () (emit "λ"))) - -(tex-def-math-prim "\\mu" (lambda () (emit "μ"))) - -(tex-def-math-prim "\\nu" (lambda () (emit "ν"))) - -(tex-def-math-prim "\\xi" (lambda () (emit "ξ"))) - -(tex-def-math-prim "\\omicron" (lambda () (emit "ο"))) - -(tex-def-math-prim "\\pi" (lambda () (emit "π"))) - -(tex-def-math-prim "\\varpi" (lambda () (emit "ϖ"))) - -(tex-def-math-prim "\\rho" (lambda () (emit "ρ"))) - -(tex-def-math-prim "\\varrho" (lambda () (emit "ρ"))) - -(tex-def-math-prim "\\sigma" (lambda () (emit "σ"))) - -(tex-def-math-prim "\\varsigma" (lambda () (emit "ς"))) - -(tex-def-math-prim "\\tau" (lambda () (emit "τ"))) - -(tex-def-math-prim "\\upsilon" (lambda () (emit "υ"))) - -(tex-def-math-prim "\\phi" (lambda () (emit "φ"))) - -(tex-def-math-prim "\\varphi" (lambda () (emit "φ"))) - -(tex-def-math-prim "\\chi" (lambda () (emit "χ"))) - -(tex-def-math-prim "\\psi" (lambda () (emit "ψ"))) - -(tex-def-math-prim "\\omega" (lambda () (emit "ω"))) - -(tex-def-math-prim "\\Gamma" (lambda () (emit "Γ"))) - -(tex-def-math-prim "\\Delta" (lambda () (emit "Δ"))) - -(tex-def-math-prim "\\Theta" (lambda () (emit "Θ"))) - -(tex-def-math-prim "\\Lambda" (lambda () (emit "Λ"))) - -(tex-def-math-prim "\\Xi" (lambda () (emit "Ξ"))) - -(tex-def-math-prim "\\Pi" (lambda () (emit "Π"))) - -(tex-def-math-prim "\\Sigma" (lambda () (emit "Σ"))) - -(tex-def-math-prim "\\Upsilon" (lambda () (emit "Υ"))) - -(tex-def-math-prim "\\Phi" (lambda () (emit "Φ"))) - -(tex-def-math-prim "\\Psi" (lambda () (emit "Ψ"))) - -(tex-def-math-prim "\\Omega" (lambda () (emit "Ω"))) - -(tex-def-math-prim "\\aleph" (lambda () (emit "ℵ"))) - -(tex-def-math-prim "\\ell" (lambda () (emit "l"))) - -(tex-def-math-prim "\\wp" (lambda () (emit "℘"))) - -(tex-def-math-prim "\\Re" (lambda () (emit "ℜ"))) - -(tex-def-math-prim "\\Im" (lambda () (emit "ℑ"))) - -(tex-def-math-prim "\\partial" (lambda () (emit "∂"))) - -(tex-def-math-prim "\\infty" (lambda () (emit "∞"))) - -(tex-def-math-prim "\\prime" (lambda () (emit "⁄"))) - -(tex-def-math-prim "\\emptyset" (lambda () (emit "∅"))) - -(tex-def-math-prim "\\nabla" (lambda () (emit "∇"))) - -(tex-def-math-prim "\\surd" (lambda () (emit "√"))) - -(tex-def-math-prim "\\|" (lambda () (emit "||"))) - -(tex-def-math-prim "\\angle" (lambda () (emit "∠"))) - -(tex-def-math-prim "\\triangle" (lambda () (emit "Δ"))) - -(tex-def-math-prim "\\backslash" (lambda () (emit "\\"))) - -(tex-def-math-prim "\\forall" (lambda () (emit "∀"))) - -(tex-def-math-prim "\\exists" (lambda () (emit "∃"))) - -(tex-def-math-prim "\\neg" (lambda () (emit "¬"))) - -(tex-def-math-prim "\\sharp" (lambda () (emit "#"))) - -(tex-def-math-prim "\\clubsuit" (lambda () (emit "♣"))) - -(tex-def-math-prim "\\diamondsuit" (lambda () (emit "♦"))) - -(tex-def-math-prim "\\heartsuit" (lambda () (emit "♥"))) - -(tex-def-math-prim "\\spadesuit" (lambda () (emit "♠"))) - -(tex-def-math-prim "\\sum" (lambda () (emit "∑"))) - -(tex-def-math-prim "\\prod" (lambda () (emit "∏"))) - -(tex-def-math-prim "\\int" (lambda () (emit "∫"))) - -(tex-def-math-prim "\\pm" (lambda () (emit "±"))) - -(tex-def-math-prim "\\setminus" (lambda () (emit "\\"))) - -(tex-def-math-prim "\\cdot" (lambda () (emit " · "))) - -(tex-def-math-prim "\\times" (lambda () (emit "×"))) - -(tex-def-math-prim "\\ast" (lambda () (emit "∗"))) - -(tex-def-math-prim "\\star" (lambda () (emit "∗"))) - -(tex-def-math-prim "\\circ" (lambda () (emit "o"))) - -(tex-def-math-prim "\\bullet" (lambda () (emit "•"))) - -(tex-def-math-prim "\\div" (lambda () (emit "÷"))) - -(tex-def-math-prim "\\cap" (lambda () (emit "∩"))) - -(tex-def-math-prim "\\cup" (lambda () (emit "∪"))) - -(tex-def-math-prim "\\vee" (lambda () (emit "∨"))) - -(tex-def-math-prim "\\wedge" (lambda () (emit "∧"))) - -(tex-def-math-prim "\\oplus" (lambda () (emit "⊕"))) - -(tex-def-math-prim "\\otimes" (lambda () (emit "⊗"))) - -(tex-def-math-prim "\\dagger" (lambda () (emit "†"))) - -(tex-def-math-prim "\\ddagger" (lambda () (emit "‡"))) - -(tex-def-math-prim "\\leq" (lambda () (emit "≤"))) - -(tex-def-math-prim "\\ll" (lambda () (emit "<<"))) - -(tex-def-math-prim "\\subset" (lambda () (emit "⊂"))) - -(tex-def-math-prim "\\subseteq" (lambda () (emit "⊆"))) - -(tex-def-math-prim "\\in" (lambda () (emit "∈"))) - -(tex-def-math-prim "\\geq" (lambda () (emit "≥"))) - -(tex-def-math-prim "\\gg" (lambda () (emit ">>"))) - -(tex-def-math-prim "\\supset" (lambda () (emit "⊃"))) - -(tex-def-math-prim "\\supseteq" (lambda () (emit "⊇"))) - -(tex-def-math-prim "\\ni" (lambda () (emit "∋"))) - -(tex-def-math-prim "\\mid" (lambda () (emit "|"))) - -(tex-def-math-prim "\\parallel" (lambda () (emit "||"))) - -(tex-def-math-prim "\\equiv" (lambda () (emit "≡"))) - -(tex-def-math-prim "\\sim" (lambda () (emit "∼"))) - -(tex-def-math-prim "\\simeq" (lambda () (emit "~"))) - -(tex-def-math-prim "\\approx" (lambda () (emit "≈"))) - -(tex-def-math-prim "\\cong" (lambda () (emit "≅"))) - -(tex-def-math-prim "\\propto" (lambda () (emit "∝"))) - -(tex-def-math-prim "\\perp" (lambda () (emit "⊥"))) - -(tex-def-math-prim "\\not" (lambda () (emit #\!))) - -(tex-def-math-prim "\\notin" (lambda () (emit "∉"))) - -(tex-def-math-prim "\\leftarrow" (lambda () (emit "←"))) - -(tex-def-math-prim "\\Leftarrow" (lambda () (emit "⇐"))) - -(tex-def-math-prim "\\rightarrow" (lambda () (emit "→"))) - -(tex-def-math-prim "\\Rightarrow" (lambda () (emit "⇒"))) - -(tex-def-math-prim "\\leftrightarrow" (lambda () (emit "↔"))) - -(tex-def-math-prim "\\Leftrightarrow" (lambda () (emit "⇔"))) - -(tex-def-math-prim "\\longleftarrow" (lambda () (emit "←---"))) - -(tex-def-math-prim "\\Longleftarrow" (lambda () (emit "⇐==="))) - -(tex-def-math-prim "\\longrightarrow" (lambda () (emit "---→"))) - -(tex-def-math-prim "\\Longrightarrow" (lambda () (emit "===⇒"))) - -(tex-def-math-prim "\\longleftrightarrow" (lambda () (emit "←---→"))) - -(tex-def-math-prim "\\Longleftrightarrow" (lambda () (emit "⇐===⇒"))) - -(tex-def-math-prim "\\uparrow" (lambda () (emit "↑"))) - -(tex-def-math-prim "\\Uparrow" (lambda () (emit "⇑"))) - -(tex-def-math-prim "\\downarrow" (lambda () (emit "↓"))) - -(tex-def-math-prim "\\Downarrow" (lambda () (emit "⇓"))) - -(tex-def-math-prim "\\lbrack" (lambda () (emit "["))) - -(tex-def-math-prim "\\lbrace" (lambda () (emit "{"))) - -(tex-def-math-prim "\\lfloor" (lambda () (emit "⌊"))) - -(tex-def-math-prim "\\langle" (lambda () (emit "⟨"))) - -(tex-def-math-prim "\\lceil" (lambda () (emit "⌈"))) - -(tex-def-math-prim "\\rbrack" (lambda () (emit "]"))) - -(tex-def-math-prim "\\rbrace" (lambda () (emit "}"))) - -(tex-def-math-prim "\\rfloor" (lambda () (emit "⌋"))) - -(tex-def-math-prim "\\rangle" (lambda () (emit "⟩"))) - -(tex-def-math-prim "\\rceil" (lambda () (emit "⌉"))) - -(tex-def-math-prim "\\colon" (lambda () (emit #\:))) - -(tex-def-math-prim "\\ldotp" (lambda () (emit #\.))) - -(tex-let-prim "\\cdotp" "\\cdot") - -(tex-def-math-prim "\\ne" (lambda () (emit "≠"))) - -(tex-let-prim "\\neq" "\\ne") - -(tex-let-prim "\\le" "\\leq") - -(tex-let-prim "\\ge" "\\geq") - -(tex-let-prim "\\{" "\\lbrace") - -(tex-let-prim "\\}" "\\rbrace") - -(tex-let-prim "\\to" "\\rightarrow") - -(tex-let-prim "\\gets" "\\leftarrow") - -(tex-let-prim "\\land" "\\wedge") - -(tex-let-prim "\\lor" "\\vee") - -(tex-let-prim "\\lnot" "\\neg") - -(tex-let-prim "\\vert" "\\mid") - -(tex-let-prim "\\Vert" "\\parallel") - -(tex-let-prim "\\iff" "\\Longleftrightarrow") - -(tex-def-prim "\\S" (lambda () (emit "§"))) - -(tex-def-prim "\\P" (lambda () (emit "¶"))) - -(tex-def-prim "\\dag" (lambda () (emit "†"))) - -(tex-def-prim "\\ddag" (lambda () (emit "‡"))) - -(tex-def-math-prim "\\eqalign" (lambda () (do-eqalign 'eqalign))) - -(tex-def-math-prim "\\eqalignno" (lambda () (do-eqalign 'eqalignno))) - -(tex-def-math-prim "\\displaylines" (lambda () (do-eqalign 'displaylines))) - -(tex-let-prim "\\leqalignno" "\\eqalignno") - -(tex-def-math-prim "\\noalign" do-noalign) - -(tex-def-math-prim "\\frac" do-frac) - -(tex-def-math-prim "\\pmatrix" do-pmatrix) - -(tex-def-math-prim "\\eqno" do-eqno) - -(tex-let-prim "\\leqno" "\\eqno") - -(tex-def-math-prim "\\," do-space) - -(tex-def-math-prim "\\;" do-space) - -(tex-def-math-prim "\\!" do-relax) - -(tex-def-math-prim "\\mathbf" do-relax) - -(tex-def-math-prim "\\mathrm" do-relax) - -(tex-def-math-prim "\\over" (lambda () (emit "/"))) - -(tex-def-math-prim - "\\sqrt" - (lambda () (emit "√(") (tex2page-string (get-token)) (emit ")"))) - -(tex-def-math-prim "\\left" do-relax) - -(tex-def-math-prim "\\right" do-relax) - -(tex-def-prim "\\AA" (lambda () (emit "Å"))) - -(tex-def-prim "\\aa" (lambda () (emit "å"))) - -(tex-def-prim - "\\abstract" - (lambda () - (tex2page-string "\\quote") - (tex2page-string "\\centerline{\\bf\\abstractname}\\par"))) - -(tex-def-prim "\\addcontentsline" do-addcontentsline) - -(tex-def-prim "\\addtocounter" (lambda () (set-latex-counter #t))) - -(tex-def-prim "\\advance" (lambda () (do-advance (global?)))) - -(tex-def-prim "\\advancetally" (lambda () (do-advancetally (global?)))) - -(tex-def-prim "\\AE" (lambda () (emit "Æ"))) - -(tex-def-prim "\\ae" (lambda () (emit "æ"))) - -(tex-def-prim "\\afterassignment" do-afterassignment) - -(tex-def-prim "\\aftergroup" do-aftergroup) - -(tex-def-prim "\\alltt" do-alltt) - -(tex-def-prim "\\appendix" do-appendix) - -(tex-def-prim "\\appendixname" (lambda () (emit "Appendix "))) - -(tex-def-prim "\\author" do-author) - -(tex-def-prim "\\b" (lambda () (do-diacritic 'a))) - -(tex-def-prim "\\begin" do-begin) - -(tex-def-prim-0arg "\\bgroup" "{") - -(tex-def-prim "\\beginsection" do-beginsection) - -(tex-def-prim "\\bf" (lambda () (do-switch 'bf))) - -(tex-def-prim "\\bgcolor" (lambda () (do-switch 'bgcolor))) - -(tex-def-prim "\\bibitem" do-bibitem) - -(tex-def-prim "\\bibliography" do-bibliography) - -(tex-def-prim "\\bibliographystyle" do-bibliographystyle) - -(tex-def-prim "\\bigbreak" (lambda () (do-bigskip 'bigskip))) - -(tex-def-prim "\\bigskip" (lambda () (do-bigskip 'bigskip))) - -(tex-def-prim "\\break" (lambda () (emit "
    "))) - -(tex-def-prim "\\bull" (lambda () (emit "•"))) - -(tex-def-prim "\\c" (lambda () (do-diacritic 'cedilla))) - -(tex-def-prim "\\caption" do-caption) - -(tex-def-prim "\\catcode" do-catcode) - -(tex-def-math-prim - "\\cdots" - (lambda () (emit "···"))) - -(tex-def-prim "\\center" (lambda () (do-block 'center))) - -(tex-def-prim "\\centerline" (lambda () (do-function "\\centerline"))) - -(tex-def-prim - "\\chapter" - (lambda () - (!using-chapters) - (write-aux `(!using-chapters)) - (when (and (eqv? *tex-format* 'latex) (< (get-gcount "\\secnumdepth") -1)) - (set-gcount! "\\secnumdepth" 2)) - (do-heading 0))) - -(tex-def-prim "\\chaptername" (lambda () (emit "Chapter "))) - -(tex-def-prim "\\char" do-char) - -(tex-def-prim "\\cite" do-cite) - -(tex-def-prim "\\closegraphsfile" do-mfpic-closegraphsfile) - -(tex-def-prim "\\closein" (lambda () (do-close-stream 'in))) - -(tex-def-prim "\\closeout" (lambda () (do-close-stream 'out))) - -(tex-def-prim "\\color" do-color) - -(tex-def-prim "\\convertMPtoPDF" do-convertmptopdf) - -(tex-def-prim "\\copyright" (lambda () (emit "©"))) - -(tex-def-prim "\\countdef" (lambda () (do-newcount #t) (eat-integer))) - -(tex-def-prim "\\CR" (lambda () (do-cr "\\CR"))) - -(tex-def-prim "\\cr" (lambda () (do-cr "\\cr"))) - -(tex-def-prim "\\csname" do-csname) - -(tex-def-prim "\\cssblock" do-cssblock) - -(tex-def-prim "\\dag" (lambda () (emit "†"))) - -(tex-def-prim "\\date" do-date) - -(tex-def-prim "\\ddag" (lambda () (emit "‡"))) - -(tex-def-prim "\\def" (lambda () (do-def (global?) #f))) - -(tex-def-prim "\\defcsactive" (lambda () (do-defcsactive (global?)))) - -(tex-def-prim "\\definecolor" do-definecolor) - -(tex-def-prim "\\DefineNamedColor" (lambda () (get-token) (do-definecolor))) - -(tex-def-prim "\\definexref" do-definexref) - -(tex-def-prim "\\definitelylatex" definitely-latex) - -(tex-def-prim "\\defschememathescape" (lambda () (scm-set-mathescape #t))) - -(tex-def-prim - "\\description" - (lambda () - (do-end-para) - (set! *tabular-stack* (cons 'description *tabular-stack*)) - (emit "
    "))) - -(tex-def-prim "\\DH" (lambda () (emit "Ð"))) - -(tex-def-prim "\\dh" (lambda () (emit "ð"))) - -(tex-def-prim "\\discretionary" do-discretionary) - -(tex-def-prim - "\\displaymath" - (lambda () (do-latex-env-as-image "displaymath" 'display))) - -(tex-def-prim "\\divide" (lambda () (do-divide (global?)))) - -(tex-def-prim "\\document" probably-latex) - -(tex-def-prim "\\documentclass" do-documentclass) - -(tex-def-prim - "\\dontuseimgforhtmlmath" - (lambda () (tex-def-0arg "\\TZPmathimage" "0"))) - -(tex-def-prim - "\\dontuseimgforhtmlmathdisplay" - (lambda () (tex-def-0arg "\\TZPmathimage" "0"))) - -(tex-def-prim "\\dontuseimgforhtmlmathintext" (lambda () #t)) - -(tex-def-prim "\\dots" (lambda () (emit "..."))) - -(tex-def-prim "\\edef" (lambda () (do-def (global?) #t))) - -(tex-def-prim-0arg "\\egroup" "}") - -(tex-def-prim "\\eject" do-eject) - -(tex-def-prim "\\else" (lambda () (do-else))) - -(tex-def-prim "\\em" (lambda () (do-switch 'em))) - -(tex-def-prim "\\emph" (lambda () (do-function "\\emph"))) - -(tex-def-prim-0arg "\\empty" "") - -(tex-def-prim "\\end" do-end) - -(tex-def-prim "\\endalltt" do-end-alltt) - -(tex-def-prim "\\endcenter" do-end-block) - -(tex-def-prim - "\\enddescription" - (lambda () - (pop-tabular-stack 'description) - (do-end-para) - (emit "
    ") - (do-para))) - -(tex-def-prim "\\endeqnarray" do-end-equation) - -(tex-def-prim "\\endequation" do-end-equation) - -(tex-def-prim - "\\endenumerate" - (lambda () - (pop-tabular-stack 'enumerate) - (do-end-para) - (emit "") - (do-para))) - -(tex-def-prim "\\endfigure" (lambda () (do-end-table/figure 'figure))) - -(tex-def-prim "\\endflushleft" do-end-block) - -(tex-def-prim "\\endflushright" do-end-block) - -(tex-def-prim "\\endgraf" do-para) - -(tex-def-prim - "\\endhtmlimg" - (lambda () (terror 'tex-def-prim "Unmatched \\endhtmlimg"))) - -(tex-def-prim "\\endhtmlonly" (lambda () (set! *html-only* (- *html-only* 1)))) - -(tex-def-prim - "\\enditemize" - (lambda () - (pop-tabular-stack 'itemize) - (do-end-para) - (emit "") - (do-para))) - -(tex-def-prim "\\endminipage" do-endminipage) - -(tex-def-prim "\\endruledtable" do-endruledtable) - -(tex-def-prim "\\endtabbing" do-end-tabbing) - -(tex-def-prim "\\endtable" (lambda () (do-end-table/figure 'table))) - -(tex-def-prim "\\endtableplain" do-end-table-plain) - -(tex-def-prim "\\endtabular" do-end-tabular) - -(tex-def-prim - "\\endthebibliography" - (lambda () (emit "
    ") - (emit-newline)))) - -(define eat-till-eol - (lambda () - (let loop () - (let ((c (get-actual-char))) - (unless (or (eof-object? c) (char=? c #\newline)) (loop)))))) - -(define do-comment - (lambda () - (eat-till-eol) - (if (munched-a-newline?) - (begin (toss-back-char #\newline) (toss-back-char #\newline))))) - -(define latex-style-file? - (lambda (f) (let ((e (file-extension f))) (and e (string-ci=? e ".sty"))))) - -(define path-to-list - (lambda (p) - (if (not p) - '() - (let loop ((p p) (r '())) - (let ((i (string-index p *path-separator*))) - (if i - (loop - (substring p (+ i 1) (string-length p)) - (cons (substring p 0 i) r)) - (reverse! (cons p r)))))))) - -(define kpsewhich - (lambda (f) - (let ((tmpf (string-append *aux-dir/* *jobname* "-Z-Z.temp"))) - (ensure-file-deleted tmpf) - (system (string-append "kpsewhich " f " > " tmpf)) - (let ((f - (and (file-exists? tmpf) - (call-with-input-file tmpf (lambda (i) (read-line i)))))) - (ensure-file-deleted tmpf) - (if (or (not f) (eof-object? f)) - #f - (let ((f (string-trim-blanks f))) - (when (eq? *operating-system* 'cygwin) - (cond - ((eqv? (substring? "/cygdrive/" f) 0) - (set! f (substring f 11 (string-length f)))) - ((eqv? (substring? "/usr/" f) 0) - (set! f (string-append "/cygwin" f))))) - (cond - ((= (string-length f) 0) #f) - ((eq? *operating-system* 'cygwin) f) - ((file-exists? f) f) - (else #f)))))))) - -(define find-tex-file - (lambda (file) - (let ((files (list (string-append file ".tex") file))) - (or (ormap (lambda (file) (and (file-exists? file) file)) files) - (if (not (null? *tex2page-inputs*)) - (ormap - (lambda (dir) - (ormap - (lambda (file) - (let ((qfile (string-append dir *directory-separator* file))) - (and (file-exists? qfile) qfile))) - files)) - *tex2page-inputs*) - (kpsewhich file)))))) - -(define actual-tex-filename - (lambda (f check-timestamp?) - (let ((doing-main-file? (not *main-tex-file*)) (f2 (find-tex-file f))) - (when doing-main-file? - (when f2 - (set! *jobname* (file-stem-name f2)) - (make-target-dir) - (let ((zeroth-html-page - (string-append *aux-dir/* *jobname* *output-extension*))) - (when (string=? zeroth-html-page f2) - (let ((f2-save (string-append f2 "_save"))) - (write-log 'separation-newline) - (write-log "Copying weirdly named TeX source file ") - (write-log f2) - (write-log " to ") - (write-log f2-save) - (write-log 'separation-newline) - (case *operating-system* - ((cygwin unix) - (system (string-append "cp -pf " f2 " " f2-save))) - ((windows) - (system (string-append "copy/y " f2 " " f2-save)))) - (set! f2 f2-save)))) - (initialize-global-texframe)) - (load-aux-file)) - (when (and - f2 - check-timestamp? - (ormap (lambda (vwf) (string=? f2 vwf)) *verb-written-files*)) - (set! check-timestamp? #f)) - (when (and f2 check-timestamp?) (update-last-modification-time f2)) - f2))) - -(define add-dot-tex-if-no-extension-provided - (lambda (f) - (let ((e (file-extension f))) (if e f (string-append f ".tex"))))) - -(define ignore-tex-specific-text - (lambda (env) - (let ((endenv (string-append "\\end" env))) - (let loop () - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) - (terror 'ignore-tex-specific-text "Missing \\end" env)) - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (cond - ((string=? x endenv) #t) - ((string=? x "\\end") - (let ((g (get-grouped-environment-name-if-any))) - (unless (and g (string=? g env)) (loop)))) - (else (loop))))) - (else (get-actual-char) (loop)))))))) - -(define do-rawhtml - (lambda () - (let loop () - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) (terror 'do-rawhtml "Missing \\endrawhtml")) - ((char=? c *esc-char*) - (let* ((x (get-ctl-seq)) (y (find-corresp-prim x))) - (cond - ((string=? y "\\endrawhtml") 'done) - ((and (string=? x "\\end") (get-grouped-environment-name-if-any)) - => - (lambda (g) - (let ((y (find-corresp-prim (string-append x g)))) - (if (string=? y "\\endrawhtml") - 'done - (begin (emit "\\end{") (emit g) (emit "}") (loop)))))) - ((string=? x "\\\\") (emit c) (toss-back-char c) (loop)) - (else (emit x) (loop))))) - (else (get-actual-char) (emit c) (loop))))))) - -(define do-htmlheadonly - (lambda () - (when (null? *html-head*) (flag-missing-piece 'html-head)) - (let loop ((s '())) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) - (write-aux `(!html-head ,(list->string (reverse! s))))) - ((char=? c *esc-char*) - (write-aux `(!html-head ,(list->string (reverse! s)))) - (let ((x (get-ctl-seq))) - (cond - ((string=? x "\\endhtmlheadonly") 'done) - ((string=? x "\\input") - (let ((f (get-filename-possibly-braced))) - (call-with-input-file/buffered f do-htmlheadonly) - (loop '()))) - (else (write-aux `(!html-head ,x)) (loop '()))))) - (else (get-actual-char) (loop (cons c s)))))))) - -(define resolve-chardefs - (lambda (c) - (cond - ((find-chardef c) - => - (lambda (y) - (get-actual-char) - (expand-tex-macro (cdef.optarg y) (cdef.argpat y) (cdef.expansion y)))) - (else #f)))) - -(define resolve-defs - (lambda (x) - (cond - ((find-def x) - => - (lambda (y) - (cond - ((tdef.defer y) => (lambda (z) z)) - ((tdef.thunk y) #f) - (else - (cond - ((and (inside-false-world?) - (not (if-aware-ctl-seq? x)) - (> (length (tdef.argpat y)) 0)) - #f) - (else - (expand-tex-macro - (tdef.optarg y) - (tdef.argpat y) - (tdef.expansion y)))))))) - (else #f)))) - -(define do-expandafter - (lambda () - (let* ((first (get-raw-token/is)) (second (get-raw-token/is))) - (toss-back-char *invisible-space*) - (cond - ((ctl-seq? second) - (toss-back-string (expand-ctl-seq-into-string second))) - (else (toss-back-string second))) - (toss-back-char *invisible-space*) - (toss-back-string first)))) - -(define resolve-expandafters - (lambda () - (let ((c (snoop-actual-char))) - (if (char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (if (string=? x "\\expandafter") - (do-expandafter) - (begin - (toss-back-char *invisible-space*) - (toss-back-string x)))))))) - -(define do-futurelet - (lambda () - (let* ((first (get-raw-token/is)) - (second (get-raw-token/is)) - (third (get-raw-token))) - (do-futurelet-aux first second third)))) - -(define do-futurenonspacelet - (lambda () - (let* ((first (get-raw-token/is)) - (second (get-raw-token/is)) - (third (get-raw-token/is))) - (do-futurelet-aux first second third)))) - -(define do-futurelet-aux - (lambda (first second third) - (tex-let first third #f) - (toss-back-char *invisible-space*) - (toss-back-string third) - (toss-back-char *invisible-space*) - (toss-back-string second))) - -(define set-start-time - (lambda () - (let* ((secs (current-seconds)) (ht (and secs (seconds->date secs)))) - (when ht - (tex-def-count "\\time" (+ (* 60 (date-hour ht)) (date-minute ht)) #t) - (tex-def-count "\\day" (date-day ht) #t) - (tex-def-count "\\month" (+ (date-month ht) (- 1) 1) #t) - (tex-def-count "\\year" (+ 0 (date-year ht)) #t))))) - -(define initialize-global-texframe - (lambda () - (tex-def-count "\\language" 256 #t) - (tex-def-count "\\secnumdepth" -2 #t) - (tex-def-count "\\tocdepth" -2 #t) - (tex-def-count "\\footnotenumber" 0 #t) - (tex-def-count "\\TIIPtabularborder" 1 #t) - (tex-def-count "\\TIIPnestedtabularborder" 0 #t) - (tex-def-count "\\TIIPobeyspacestrictly" 0 #t) - (tex-def-count "\\TIIPobeylinestrictly" 0 #t) - (tex-def-count "\\errorcontextlines" 5 #t) - (tex-def-count "\\doublehyphendemerits" 10000 #t) - (tex-def-count "\\finalhyphendemerits" 5000 #t) - (tex-def-count "\\hyphenpenalty" 50 #t) - (tex-def-count "\\exhyphenpenalty" 50 #t) - (tex-def-count "\\pretolerance" 100 #t) - (tex-def-count "\\tolerance" 200 #t) - (tex-def-count "\\hbadness" 1000 #t) - (tex-def-count "\\widowpenalty" 150 #t) - (tex-def-count "\\showboxdepth" 3 #t) - (tex-def-count "\\outputpenalty" 0 #t) - (tex-def-count "\\globaldefs" 0 #t) - (tex-def-count "\\mag" 1000 #t) - (tex-def-count "\\tracingcommands" 0 #t) - (tex-def-count "\\tracingmacros" 0 #t) - (tex-def-count "\\tracingonline" 0 #t) - (tex-def-count "\\time" 0 #t) - (tex-def-count "\\day" 0 #t) - (tex-def-count "\\month" 0 #t) - (tex-def-count "\\year" 0 #t) - (tex-def-dimen "\\hsize" (tex-length 6.5 'in) #t) - (tex-def-dimen "\\vsize" (tex-length 8.9 'in) #t) - (tex-def-dimen "\\maxdepth" (tex-length 4 'pt) #t) - (tex-def-dimen "\\delimitershortfall" (tex-length 5 'pt) #t) - (tex-def-dimen "\\nulldelimiterspace" (tex-length 1.2 'pt) #t) - (tex-def-dimen "\\scriptspace" (tex-length 0.5 'pt) #t) - (tex-def-dimen "\\hoffset" 0 #t) - (tex-def-dimen "\\voffset" 0 #t) - (tex-def-dimen "\\epsfxsize" 0 #t) - (tex-def-dimen "\\epsfysize" 0 #t) - (tex-def-dimen "\\emergencystretch" 0 #t) - (tex-def-dimen "\\hfuzz" (tex-length 0.1 'pt) #t) - (tex-def-dimen "\\vfuzz" (tex-length 0.1 'pt) #t) - (tex-def-dimen "\\textwidth" (tex-length 6.5 'in) #t) - (tex-def-dimen "\\baselineskip" (tex-length 12 'pt) #t) - (tex-def-dimen "\\overfullrule" (tex-length 5 'pt) #t) - (tex-def-dimen "\\parindent" (tex-length 20 'pt) #t) - (tex-def-dimen "\\leftskip" 0 #t) - (tex-def-dimen "\\parfillskip" 0 #t) - (tex-def-dimen "\\parskip" 0 #t) - (tex-def-dimen "\\abovedisplayskip" (tex-length 12 'pt) #t) - (tex-def-dimen "\\belowdisplayskip" (tex-length 12 'pt) #t) - (tex-def-toks "\\everypar" "" #t) - (tex-def-toks "\\headline" "" #t) - (tex-def-toks "\\footline" "\\folio" #t) - (tex-def-dotted-count "figure" #f) - (tex-def-dotted-count "table" #f) - (tex-def-dotted-count "equation" #f) - (tex-gdef-0arg "\\TIIPcurrentnodename" "no value yet") - (tex-gdef-0arg "\\@currentlabel" "no value yet") - (tex-gdef-0arg "\\TZPcolophonlastpage" "0") - (tex-gdef-0arg "\\TZPcolophontimestamp" "1") - (tex-gdef-0arg "\\TZPcolophoncredit" "1") - (tex-gdef-0arg "\\TZPcolophonweblink" "1") - (tex-gdef-0arg "\\TZPmathimage" "1") - (tex-gdef-0arg "\\TZPimageformat" "GIF") - (tex-gdef-0arg "\\TZPimageconverter" "NetPBM") - (tex-gdef-0arg "\\TZPslatexcomments" "0") - (tex-gdef-0arg "\\TZPtexlayout" "0") - (tex-gdef-0arg "\\TZPraggedright" "1"))) - -(define find-def - (lambda (ctlseq) - (let ((c - (or (ormap - (lambda (fr) - (lassoc ctlseq (texframe.definitions fr) string=?)) - *tex-env*) - (and *global-texframe* - (lassoc - ctlseq - (texframe.definitions *global-texframe*) - string=?)) - (lassoc - ctlseq - (texframe.definitions *primitive-texframe*) - string=?)))) - (and c (cdr c))))) - -(define find-math-def - (lambda (ctlseq) - (let ((c - (lassoc - ctlseq - (texframe.definitions *math-primitive-texframe*) - string=?))) - (and c (cdr c))))) - -(define find-count - (lambda (ctlseq) - (or (ormap - (lambda (fr) (lassoc ctlseq (texframe.counts fr) string=?)) - *tex-env*) - (lassoc ctlseq (texframe.counts *global-texframe*) string=?) - (lassoc ctlseq (texframe.counts *primitive-texframe*) string=?)))) - -(define find-toks - (lambda (ctlseq) - (or (ormap - (lambda (fr) (lassoc ctlseq (texframe.toks fr) string=?)) - *tex-env*) - (lassoc ctlseq (texframe.toks *global-texframe*) string=?) - (lassoc ctlseq (texframe.toks *primitive-texframe*) string=?)))) - -(define find-dimen - (lambda (ctlseq) - (or (ormap - (lambda (fr) (lassoc ctlseq (texframe.dimens fr) string=?)) - *tex-env*) - (lassoc ctlseq (texframe.dimens *global-texframe*) string=?) - (lassoc ctlseq (texframe.dimens *primitive-texframe*) string=?)))) - -(define get-toks - (lambda (ctlseq) - (cond ((find-toks ctlseq) => cadr) (else (terror 'get-toks))))) - -(define get-dimen - (lambda (ctlseq) - (cond ((find-dimen ctlseq) => cadr) (else (tex-length 6.5 'in))))) - -(define the-count - (lambda (ctlseq) - (let ((dracula (find-count ctlseq))) - (unless dracula (terror 'the-count)) - (cadr dracula)))) - -(define do-count= - (lambda (z g?) (get-equal-sign) (tex-def-count z (get-number) g?))) - -(define do-toks= - (lambda (z g?) (get-equal-sign) (tex-def-toks z (get-group) g?))) - -(define do-dimen= - (lambda (z g?) - (get-equal-sign) - (tex-def-dimen z (get-scaled-points) g?) - (ignorespaces))) - -(define get-gcount - (lambda (ctlseq) - (cadr (lassoc ctlseq (texframe.counts *global-texframe*) string=?)))) - -(define get-count (lambda (cs) (cadr (find-count cs)))) - -(define set-gcount! (lambda (ctlseq v) (tex-def-count ctlseq v #t))) - -(define do-number (lambda () (emit (get-number)))) - -(define do-magnification (lambda () (tex-def-count "\\mag" (get-number) #f))) - -(define do-magstep - (lambda () - (case (string->number (get-token-or-peeled-group)) - ((1) "1000") - ((2) "1200") - ((3) "1440") - ((4) "1728") - ((5) "2074") - ((6) "2488") - (else "")))) - -(define scaled-point-to-tex-point - (lambda (sp) (string-append (number->string (/ sp 65536.0)) "pt"))) - -(define expand-the - (lambda () - (let ((ctlseq (get-ctl-seq))) - (cond - ((find-dimen ctlseq) - => - (lambda (x) (scaled-point-to-tex-point (cadr x)))) - ((get-number-corresp-to-ctl-seq ctlseq) => (lambda (x) x)) - ((find-toks ctlseq) => cadr) - (else (trace-if #f "expand-the failed")))))) - -(define do-the - (lambda () - (let ((ctlseq (get-ctl-seq))) - (cond - ((find-dimen ctlseq) - => - (lambda (x) (emit (scaled-point-to-tex-point (cadr x))))) - ((get-number-corresp-to-ctl-seq ctlseq) => emit) - ((find-toks ctlseq) => (lambda (x) (tex2page-string (cadr x)))) - (else (trace-if #f "do-the failed")))))) - -(define find-corresp-prim - (lambda (ctlseq) - (let ((y (find-def ctlseq))) (or (and y (tdef.defer y)) ctlseq)))) - -(define find-corresp-prim-thunk - (lambda (ctlseq) - (let ((y (find-def ctlseq))) - (if (and y (tdef.thunk y)) (tdef.prim y) ctlseq)))) - -(define global? (lambda () (> (get-gcount "\\globaldefs") 0))) - -(define do-let - (lambda (g?) - (unless (inside-false-world?) - (ignorespaces) - (let* ((lhs (get-ctl-seq)) - (rhs (begin (get-equal-sign) (get-raw-token/is))) - (frame (and g? *global-texframe*))) - (if (ctl-seq? rhs) - (tex-let lhs rhs frame) - (tex-def lhs '() rhs #f #f #f #f frame)))))) - -(define do-def - (lambda (g? e?) - (unless (inside-false-world?) - (let ((lhs (get-raw-token/is))) - (when (and (ctl-seq? lhs) (string=? lhs "\\TIIPcsname")) - (set! lhs (get-peeled-group))) - (let* ((argpat (get-def-arguments lhs)) - (rhs (ungroup (get-group))) - (frame (and g? *global-texframe*))) - (when e? (set! rhs (expand-edef-macro rhs))) - (cond - ((ctl-seq? lhs) (tex-def lhs argpat rhs #f #f #f #f frame)) - (else (tex-def-char (string-ref lhs 0) argpat rhs frame)))))))) - -(define do-newcount (lambda (g?) (tex-def-count (get-ctl-seq) 0 g?))) - -(define do-newtoks (lambda (g?) (tex-def-toks (get-ctl-seq) "" g?))) - -(define do-newdimen (lambda (g?) (tex-def-dimen (get-ctl-seq) 0 g?))) - -(define do-advance - (lambda (g?) - (let* ((ctlseq (get-ctl-seq)) (count (find-count ctlseq))) - (get-by) - (if count - (tex-def-count ctlseq (+ (cadr count) (get-number)) g?) - (eat-dimen))))) - -(define do-multiply - (lambda (g?) - (let* ((ctlseq (get-ctl-seq)) (curr-val (cadr (find-count ctlseq)))) - (get-by) - (tex-def-count ctlseq (* curr-val (get-number)) g?)))) - -(define do-divide - (lambda (g?) - (let* ((ctlseq (get-ctl-seq)) (curr-val (cadr (find-count ctlseq)))) - (get-by) - (tex-def-count ctlseq (quotient curr-val (get-number)) g?)))) - -(define do-newcommand - (lambda (renew?) - (ignorespaces) - (let* ((lhs (string-trim-blanks (ungroup (get-token)))) - (optarg #f) - (argc - (cond - ((get-bracketed-text-if-any) - => - (lambda (s) - (cond - ((get-bracketed-text-if-any) => (lambda (s) (set! optarg s)))) - (string->number (string-trim-blanks s)))) - (else 0))) - (rhs (ungroup (get-token))) - (ok-to-def? (or renew? (not (find-def lhs))))) - (tex-def lhs (latex-arg-num->plain-argpat argc) rhs optarg #f #f #f #f) - (unless ok-to-def? - (trace-if - (> (get-count "\\tracingcommands") 0) - lhs - " already defined"))))) - -(define do-advancetally - (lambda (g?) - (let* ((ctlseq (get-ctl-seq)) - (increment - (string->number (string-trim-blanks (ungroup (get-token)))))) - (tex-def - ctlseq - '() - (number->string - (+ (string->number (or (resolve-defs ctlseq) ctlseq)) increment)) - #f - #f - #f - #f - g?)))) - -(define do-newenvironment - (lambda (renew?) - (ignorespaces) - (let* ((envname (string-trim-blanks (ungroup (get-token)))) - (bs-envname (string-append "\\" envname)) - (optarg #f) - (argc - (cond - ((get-bracketed-text-if-any) - => - (lambda (s) - (cond - ((get-bracketed-text-if-any) => (lambda (s) (set! optarg s)))) - (string->number (string-trim-blanks s)))) - (else 0))) - (beginning (string-append "\\begingroup " (ungroup (get-token)))) - (ending (string-append (ungroup (get-token)) "\\endgroup")) - (ok-to-def? (or renew? (not (find-def bs-envname))))) - (tex-def - bs-envname - (latex-arg-num->plain-argpat argc) - beginning - optarg - #f - #f - #f - #f) - (tex-def (string-append "\\end" envname) '() ending #f #f #f #f #f) - (unless ok-to-def? (trace-if #t "{" envname "} already defined"))))) - -(define tex-def-dotted-count - (lambda (counter-name sec-num) - (when sec-num - (hash-table-put! - *section-counter-dependencies* - sec-num - (cons - counter-name - (table-get *section-counter-dependencies* sec-num '())))) - (hash-table-put! - *dotted-counters* - counter-name - (make-counter 'within sec-num)))) - -(define do-newtheorem - (lambda () - (let* ((env (ungroup (get-group))) - (numbered-like (get-bracketed-text-if-any)) - (counter-name (or numbered-like env)) - (caption (ungroup (get-group))) - (within (if numbered-like #f (get-bracketed-text-if-any))) - (sec-num - (and within (section-ctl-seq? (string-append "\\" within))))) - (unless numbered-like (tex-def-dotted-count counter-name sec-num)) - (tex-def - (string-append "\\" env) - '() - (string-append - "\\par\\begingroup\\TIIPtheorem{" - counter-name - "}{" - caption - "}") - #f - #f - #f - #f - *global-texframe*) - (tex-def - (string-append "\\end" env) - '() - "\\endgroup\\par" - #f - #f - #f - #f - *global-texframe*)))) - -(define do-theorem - (lambda () - (let* ((counter-name (ungroup (get-group))) - (counter (table-get *dotted-counters* counter-name)) - (caption (ungroup (get-group)))) - (unless counter (terror 'do-theorem)) - (let ((new-counter-value (+ 1 (counter.value counter)))) - (set!counter.value counter new-counter-value) - (let* ((thm-num - (let ((sec-num (counter.within counter))) - (if sec-num - (string-append - (section-counter-value sec-num) - "." - (number->string new-counter-value)) - (number->string new-counter-value)))) - (lbl (string-append *html-node-prefix* "thm_" thm-num))) - (tex-def-0arg "\\TIIPcurrentnodename" lbl) - (tex-def-0arg "\\@currentlabel" thm-num) - (emit-anchor lbl) - (emit-newline) - (emit "") - (emit caption) - (emit " ") - (emit thm-num) - (emit ".") - (emit-nbsp 2)))))) - -(define do-begin - (lambda () - (cond - ((get-grouped-environment-name-if-any) - => - (lambda (env) - (toss-back-char *invisible-space*) - (toss-back-string (string-append "\\" env)) - (unless (ormap - (lambda (y) (string=? env y)) - '("htmlonly" - "cssblock" - "document" - "latexonly" - "rawhtml" - "texonly" - "verbatim" - "verbatim*")) - (toss-back-string "\\begingroup") - (do-end-para)))) - (else (terror 'do-begin "\\begin not followed by environment name"))))) - -(define do-end - (lambda () - (cond - ((get-grouped-environment-name-if-any) - => - (lambda (env) - (toss-back-char *invisible-space*) - (unless (ormap (lambda (y) (string=? env y)) '("htmlonly" "document")) - (do-end-para) - (toss-back-string "\\endgroup")) - (toss-back-string (string-append "\\end" env)))) - (else - (toss-back-char *invisible-space*) - (toss-back-string "\\TIIPbye"))))) - -(define latex-arg-num->plain-argpat - (lambda (n) - (let loop ((n n) (s '())) - (if (<= n 0) - s - (loop - (- n 1) - (cons #\# (cons (integer->char (+ *int-corresp-to-0* n)) s))))))) - -(define make-reusable-img - (lambda (g?) - (set! *imgdef-file-count* (+ *imgdef-file-count* 1)) - (ignorespaces) - (let ((lhs (get-ctl-seq)) - (imgdef-file-stem - (string-append - *subjobname* - *img-file-suffix* - *imgdef-file-suffix* - (number->string *imgdef-file-count*)))) - (dump-imgdef imgdef-file-stem) - (tex-to-img imgdef-file-stem) - (tex-def - lhs - '() - (string-append "\\TIIPreuseimage{" imgdef-file-stem "}") - #f - #f - #f - #f - (and g? *global-texframe*))))) - -(define valid-img-file? - (lambda (f) - (and (file-exists? f) - (or (call-with-input-file - f - (lambda (i) (not (eof-object? (read-char i))))) - (begin (delete-file f) #f))))) - -(define source-img-file - (lambda (img-file-stem . alt) - (let* ((alt (if (null? alt) #f (car alt))) - (img-file (string-append img-file-stem (find-img-file-extn))) - (f (string-append *aux-dir/* img-file))) - (write-log #\() - (write-log f) - (write-log 'separation-space) - (valid-img-file? f) - (emit "\"")") - (write-log #\)) - (write-log 'separation-space) - #t))) - -(define reuse-img (lambda () (source-img-file (ungroup (get-group))))) - -(define get-def-arguments - (lambda (lhs) - (let aux () - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) - (terror - 'get-def-arguments - "EOF found while scanning definition of " - lhs)) - ((char=? c *esc-char*) - (let ((x (get-ctl-seq))) - (if (string=? x "\\par") - (cons #\newline (cons #\newline (aux))) - (append (string->list x) (aux))))) - ((char=? c #\{) '()) - (else - (cond - ((char=? c #\newline) (get-actual-char) (ignorespaces)) - ((char-whitespace? c) (ignorespaces) (set! c #\space)) - (else (get-actual-char))) - (cons c (aux)))))))) - -(define get-till-char - (lambda (c0) - (list->string - (reverse! - (let loop ((s '()) (nesting 0) (escape? #f)) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) (terror 'get-till-char "File ended too soon")) - (escape? (loop (cons (get-actual-char) s) nesting #f)) - ((char=? c c0) s) - ((char=? c *esc-char*) - (loop (cons (get-actual-char) s) nesting #t)) - ((char=? c #\{) - (loop (cons (get-actual-char) s) (+ nesting 1) #f)) - ((char=? c #\}) - (loop (cons (get-actual-char) s) (- nesting 1) #f)) - ((> nesting 0) (loop (cons (get-actual-char) s) nesting #f)) - ((and (char-whitespace? c) - (not (char=? c0 #\newline)) - (char-whitespace? c0)) - s) - (else (loop (cons (get-actual-char) s) nesting #f))))))))) - -(define digit->int (lambda (d) (- (char->integer d) *int-corresp-to-0*))) - -(define do-halign - (lambda () - (do-end-para) - (ignorespaces) - (let ((c (get-actual-char))) - (if (eof-object? c) (terror 'do-halign "Missing {")) - (unless (char=? c #\{) (terror 'do-halign "Missing {"))) - (fluid-let - ((*tabular-stack* (cons 'halign *tabular-stack*))) - (bgroup) - (emit "") - (let ((tmplt (get-halign-template))) - (let loop () - (ignorespaces) - (let ((c (snoop-actual-char))) - (cond - ((eof-object? c) (terror 'do-halign "Eof inside \\halign")) - ((char=? c #\}) - (get-actual-char) - (emit "
    ") - (egroup) - (do-para)) - (else (expand-halign-line tmplt) (loop))))))))) - -(define get-halign-template - (lambda () - (let loop ((s '())) - (let ((x (get-raw-token))) - (cond - ((eof-object? x) (terror 'get-halign-template "Eof in \\halign")) - ((string=? x "\\cr") (reverse! (cons #f s))) - ((string=? x "#") (loop (cons #t s))) - ((string=? x "&") (loop (cons #f s))) - (else (loop (cons x s)))))))) - -(define expand-halign-line - (lambda (tmplt) - (emit "
    ") - (tex2page-string (string-append r "}")) - (when (and (string=? x "\\cr") (string=? ins " ")) - (emit-nbsp 1)) - (emit "
    "))) - (munched-a-newline?) - (bgroup) - (emit "
    ")
-      (fluid-let
-        ((*ligatures?* #f) (*verb-display?* #t) (*not-processing?* #t))
-        (let loop ()
-          (let ((c (snoop-actual-char)))
-            (cond
-             ((eof-object? c) (terror 'do-scm-slatex-lines "Eof inside " env))
-             ((char=? c #\newline)
-              (get-actual-char)
-              (scm-emit-html-char c)
-              (cond
-               ((not (tex2page-flag-boolean "\\TZPslatexcomments")) #f)
-               ((char=? (snoop-actual-char) #\;)
-                (get-actual-char)
-                (if (char=? (snoop-actual-char) #\;)
-                  (toss-back-char #\;)
-                  (scm-output-slatex-comment))))
-              (loop))
-             ((char=? c *esc-char*)
-              (let ((x (get-ctl-seq)))
-                (cond
-                 ((string=? x endenv) #t)
-                 ((string=? x "\\end")
-                  (let ((g (get-grouped-environment-name-if-any)))
-                    (if (and g (string=? g env))
-                      (egroup)
-                      (begin
-                        (scm-output-token x)
-                        (when g
-                          (scm-output-token "{")
-                          (scm-output-token g)
-                          (scm-output-token "}"))
-                        (loop)))))
-                 (else (scm-output-token x) (loop)))))
-             (else (scm-output-next-chunk) (loop))))))
-      (emit "
    ") - (egroup) - (cond (display? (do-para)) (in-table? (emit "    		")))))) - -(define string-is-all-dots? - (lambda (s) - (let ((n (string-length s))) - (let loop ((i 0)) - (cond - ((>= i n) #t) - ((char=? (string-ref s i) #\.) (loop (+ i 1))) - (else #f)))))) - -(define string-is-flanked-by-stars? - (lambda (s) - (let ((n (string-length s))) - (and (>= n 3) - (char=? (string-ref s 0) #\*) - (char=? (string-ref s (- n 1)) #\*))))) - -(define string-starts-with-hash? (lambda (s) (char=? (string-ref s 0) #\#))) - -(define scm-get-type - (lambda (s) - (cond - ((table-get *scm-special-symbols* s) 'special-symbol) - ((member/string-ci=? s *scm-keywords*) 'keyword) - ((member/string-ci=? s *scm-builtins*) 'builtin) - ((member/string-ci=? s *scm-variables*) 'variable) - ((string-is-flanked-by-stars? s) 'global) - (else - (let ((colon (string-index s #\:))) - (cond - (colon (if (= colon 0) 'selfeval 'variable)) - ((string-is-all-dots? s) 'background) - ((string-starts-with-hash? s) 'selfeval) - ((string->number s) 'selfeval) - (else 'variable))))))) - -(define eat-star - (lambda () - (let ((c (snoop-actual-char))) - (if (and (not (eof-object? c)) (char=? c #\*)) (get-actual-char) #f)))) - -(define do-cr - (lambda (z) - (ignorespaces) - (let ((top-tabular - (if (not (null? *tabular-stack*)) (car *tabular-stack*) 'nothing))) - (case top-tabular - ((tabular) - (get-bracketed-text-if-any) - (egroup) - (emit "
    ")) - ((eqnarray) - (emit "(") - (emit *equation-number*) - (bump-dotted-counter "equation") - (emit ")
    ")) - ((ruled-table) (emit "
    ")) - ((minipage tabbing) - (get-bracketed-text-if-any) - (emit "
    ") - (emit-newline)) - ((eqalign eqalignno displaylines pmatrix) - (unless (char=? (snoop-actual-char) #\}) - (emit "
    ") - (set! *equation-position* 0) - (emit-newline))) - ((header) (emit #\space)) - (else - (when (and (eqv? *tex-format* 'latex) (string=? z "\\\\")) - (get-bracketed-text-if-any) - (let ((c (snoop-actual-char))) - (when (and (not (eof-object? c)) (char=? c #\*)) - (get-actual-char))) - (emit "
    ") - (emit-newline))))))) - -(define do-ruledtable - (lambda () - (set! *tabular-stack* (cons 'ruled-table *tabular-stack*)) - (emit "
    ") - (emit-newline))) - -(define do-endruledtable - (lambda () - (emit-newline) - (emit "
    ") - (emit-newline) - (pop-tabular-stack 'ruled-table))) - -(define do-tabular - (lambda () - (do-end-para) - (get-bracketed-text-if-any) - (bgroup) - (add-postlude-to-top-frame - (let ((old-math-mode? *math-mode?*) - (old-in-display-math? *in-display-math?*)) - (set! *math-mode?* #f) - (set! *in-display-math?* #f) - (lambda () - (set! *math-mode?* old-math-mode?) - (set! *in-display-math?* old-in-display-math?)))) - (let ((border-width (if (string-index (get-group) #\|) 1 0))) - (set! *tabular-stack* (cons 'tabular *tabular-stack*)) - (emit "
    ") - (pop-tabular-stack 'tabular) - (egroup))) - -(define do-tabular-colsep - (lambda () (egroup) (emit "    		") - (bgroup))) - -(define do-ruledtable-colsep - (lambda () - (emit-newline) - (emit "")) - ((eqalignno) - (set! *equation-position* (+ *equation-position* 1)) - (emit "
    ") (egroup) (do-para))) - -(tex-def-prim "\\endverbatim" do-endverbatim-eplain) - -(tex-def-prim "\\enspace" (lambda () (emit-nbsp 2))) - -(tex-def-prim - "\\enumerate" - (lambda () - (do-end-para) - (set! *tabular-stack* (cons 'enumerate *tabular-stack*)) - (emit "
      "))) - -(tex-def-prim "\\epsfbox" do-epsfbox) - -(tex-def-prim "\\epsfig" do-epsfig) - -(tex-def-prim "\\eqnarray" (lambda () (do-equation 'eqnarray))) - -(tex-def-prim "\\equation" (lambda () (do-equation 'equation))) - -(tex-def-prim "\\errmessage" do-errmessage) - -(tex-def-prim "\\eval" (lambda () (do-eval 'both))) - -(tex-def-prim "\\evalh" (lambda () (do-eval 'html))) - -(tex-def-prim "\\evalq" (lambda () (do-eval 'quiet))) - -(tex-def-prim "\\expandafter" do-expandafter) - -(tex-def-prim "\\expandhtmlindex" expand-html-index) - -(tex-def-prim "\\externaltitle" do-externaltitle) - -(tex-def-prim "\\fi" (lambda () (do-fi))) - -(tex-def-prim "\\figure" (lambda () (do-table/figure 'figure))) - -(tex-def-prim "\\fiverm" (lambda () (do-switch 'fiverm))) - -(tex-def-prim "\\flushleft" (lambda () (do-block 'flushleft))) - -(tex-def-prim "\\flushright" (lambda () (do-block 'flushright))) - -(tex-def-prim "\\fmtname" (lambda () (emit "TeX2page"))) - -(tex-def-prim "\\fmtversion" (lambda () (emit *tex2page-version*))) - -(tex-def-prim "\\folio" (lambda () (emit *html-page-count*))) - -(tex-def-prim "\\font" do-font) - -(tex-def-prim "\\footnote" do-footnote) - -(tex-def-prim "\\footnotesize" (lambda () (do-switch 'footnotesize))) - -(tex-def-prim "\\futurelet" do-futurelet) - -(tex-def-prim "\\futurenonspacelet" do-futurenonspacelet) - -(tex-def-prim "\\gdef" (lambda () (do-def #t #f))) - -(tex-def-prim "\\global" do-global) - -(tex-def-prim "\\globaladvancetally" (lambda () (do-advancetally #t))) - -(tex-def-prim "\\gobblegroup" get-group) - -(tex-def-prim "\\\"" (lambda () (do-diacritic 'umlaut))) - -(tex-def-prim "\\halign" do-halign) - -(tex-def-prim "\\hbox" do-box) - -(tex-def-prim "\\hfill" (lambda () (emit-nbsp 5))) - -(tex-def-prim "\\hlstart" do-hlstart) - -(tex-def-prim "\\href" do-urlh) - -(tex-def-prim - "\\hrule" - (lambda () (do-end-para) (emit "
      ") (emit-newline) (do-para))) - -(tex-def-prim "\\hskip" do-hskip) - -(tex-def-prim "\\hspace" do-hspace) - -(tex-def-prim "\\htmladdimg" do-htmladdimg) - -(tex-def-prim "\\htmlcolophon" do-htmlcolophon) - -(tex-def-prim "\\htmldoctype" do-htmldoctype) - -(tex-def-prim "\\htmlgif" (lambda () (do-htmlimg "htmlgif"))) - -(tex-def-prim "\\htmlheadonly" do-htmlheadonly) - -(tex-def-prim "\\htmlimageconversionprogram" do-htmlimageconversionprogram) - -(tex-def-prim "\\htmlimageformat" do-htmlimageformat) - -(tex-def-prim "\\htmlimg" (lambda () (do-htmlimg "htmlimg"))) - -(tex-def-prim "\\htmlimgmagnification" do-htmlimgmagnification) - -(tex-def-prim "\\htmlmathstyle" do-htmlmathstyle) - -(tex-def-prim "\\htmlonly" (lambda () (set! *html-only* (+ *html-only* 1)))) - -(tex-def-prim "\\htmlpagelabel" do-htmlpagelabel) - -(tex-def-prim "\\htmlpageref" do-htmlpageref) - -(tex-def-prim "\\htmlref" do-htmlref) - -(tex-def-prim "\\htmlrefexternal" do-htmlrefexternal) - -(tex-def-prim "\\htmlspan" (lambda () (do-switch 'span))) - -(tex-def-prim "\\htmldiv" (lambda () (do-switch 'div))) - -(tex-def-prim "\\huge" (lambda () (do-switch 'huge))) - -(tex-def-prim "\\Huge" (lambda () (do-switch 'huge-cap))) - -(tex-def-prim "\\hyperref" do-hyperref) - -(tex-def-prim "\\hyperlink" do-hyperlink) - -(tex-def-prim "\\hypertarget" do-hypertarget) - -(tex-def-prim "\\if" do-if) - -(tex-def-prim "\\ifcase" do-ifcase) - -(tex-def-prim "\\ifdefined" do-ifdefined) - -(tex-def-prim "\\ifeof" do-ifeof) - -(tex-def-prim "\\ifdim" do-iffalse) - -(tex-def-prim "\\iffalse" do-iffalse) - -(tex-def-prim "\\IfFileExists" do-iffileexists) - -(tex-def-prim "\\ifmmode" do-ifmmode) - -(tex-def-prim "\\ifnum" (lambda () (do-ifnum))) - -(tex-def-prim "\\iftrue" do-iftrue) - -(tex-def-prim "\\ifx" do-ifx) - -(tex-def-prim "\\ifodd" do-ifodd) - -(tex-def-prim - "\\ignorenextinputtimestamp" - (lambda () - (unless *inputting-boilerplate?* (set! *inputting-boilerplate?* 0)))) - -(tex-def-prim "\\ignorespaces" ignorespaces) - -(tex-def-prim "\\imgdef" (lambda () (make-reusable-img (global?)))) - -(tex-def-prim "\\imgpreamble" do-img-preamble) - -(tex-def-prim - "\\IMGtabbing" - (lambda () (do-latex-env-as-image "tabbing" 'display))) - -(tex-def-prim - "\\IMGtabular" - (lambda () (do-latex-env-as-image "tabular" 'display))) - -(tex-def-prim "\\include" do-include) - -(tex-def-prim "\\includeexternallabels" do-includeexternallabels) - -(tex-def-prim "\\includeonly" do-includeonly) - -(tex-def-prim "\\includegraphics" do-includegraphics) - -(tex-def-prim "\\index" do-index) - -(tex-def-prim "\\indexitem" (lambda () (do-indexitem 0))) - -(tex-def-prim "\\indexsubitem" (lambda () (do-indexitem 1))) - -(tex-def-prim "\\indexsubsubitem" (lambda () (do-indexitem 2))) - -(tex-def-prim "\\input" do-input) - -(tex-def-prim "\\inputcss" do-inputcss) - -(tex-def-prim "\\inputexternallabels" do-inputexternallabels) - -(tex-def-prim "\\InputIfFileExists" do-inputiffileexists) - -(tex-def-prim "\\inputindex" (lambda () (do-inputindex #f))) - -(tex-def-prim "\\it" (lambda () (do-switch 'it))) - -(tex-def-prim "\\item" do-item) - -(tex-def-prim "\\itemitem" (lambda () (do-plain-item 2))) - -(tex-def-prim - "\\itemize" - (lambda () - (do-end-para) - (set! *tabular-stack* (cons 'itemize *tabular-stack*)) - (emit "
        "))) - -(tex-def-prim "\\itshape" (lambda () (do-switch 'itshape))) - -(tex-def-prim "\\jobname" (lambda () (tex2page-string *jobname*))) - -(tex-def-prim "\\label" do-label) - -(tex-def-prim "\\large" (lambda () (do-switch 'large))) - -(tex-def-prim "\\Large" (lambda () (do-switch 'large-cap))) - -(tex-def-prim "\\LARGE" (lambda () (do-switch 'large-up))) - -(tex-def-prim "\\LaTeX" do-latex-logo) - -(tex-def-prim - "\\LaTeXe" - (lambda () (do-latex-logo) (emit "2E"))) - -(tex-def-prim "\\latexonly" (lambda () (ignore-tex-specific-text "latexonly"))) - -(tex-def-prim - "\\leftdisplays" - (lambda () (set! *display-justification* 'left))) - -(tex-def-prim "\\leftline" (lambda () (do-function "\\leftline"))) - -(tex-def-prim "\\let" (lambda () (do-let (global?)))) - -(tex-def-prim - "\\linebreak" - (lambda () (get-bracketed-text-if-any) (emit "
        "))) - -(tex-def-prim "\\listing" do-verbatiminput) - -(tex-def-prim "\\magnification" do-magnification) - -(tex-def-prim "\\magstep" do-magstep) - -(tex-def-prim-0arg "\\magstephalf" "1095") - -(tex-def-prim "\\mailto" do-mailto) - -(tex-def-prim "\\makeatletter" (lambda () (set-catcode #\@ 11))) - -(tex-def-prim "\\makeatother" (lambda () (set-catcode #\@ 12))) - -(tex-def-prim "\\makehtmlimage" do-makehtmlimage) - -(tex-def-prim "\\maketitle" do-maketitle) - -(tex-def-prim "\\marginpar" do-marginpar) - -(tex-def-prim "\\mathg" do-mathg) - -(tex-def-prim "\\mathdg" do-mathdg) - -(tex-def-prim "\\mathp" do-mathp) - -(tex-def-prim "\\medbreak" (lambda () (do-bigskip 'medskip))) - -(tex-def-prim "\\medskip" (lambda () (do-bigskip 'medskip))) - -(tex-def-prim "\\message" do-message) - -(tex-def-prim "\\mfpic" do-mfpic) - -(tex-def-prim "\\minipage" do-minipage) - -(tex-def-prim "\\multiply" (lambda () (do-multiply (global?)))) - -(tex-def-prim "\\narrower" (lambda () (do-switch 'narrower))) - -(tex-def-prim "\\newcommand" (lambda () (do-newcommand #f))) - -(tex-def-prim "\\newcount" (lambda () (do-newcount (global?)))) - -(tex-def-prim "\\newdimen" (lambda () (do-newdimen (global?)))) - -(tex-def-prim "\\newenvironment" (lambda () (do-newenvironment #f))) - -(tex-def-prim "\\newif" do-newif) - -(tex-def-prim "\\newread" (lambda () (do-new-stream 'in))) - -(tex-def-prim "\\newtheorem" do-newtheorem) - -(tex-def-prim "\\newtoks" (lambda () (do-newtoks (global?)))) - -(tex-def-prim "\\newwrite" (lambda () (do-new-stream 'out))) - -(tex-def-prim "\\noad" (lambda () (tex-def-0arg "\\TZPcolophoncredit" "0"))) - -(tex-def-prim "\\nocite" do-nocite) - -(tex-def-prim "\\node" do-node) - -(tex-def-prim "\\noindent" do-noindent) - -(tex-def-prim "\\nonumber" do-nonumber) - -(tex-def-prim - "\\noslatexlikecomments" - (lambda () (tex-def-0arg "\\TZPslatexcomments" "0"))) - -(tex-def-prim - "\\notimestamp" - (lambda () (tex-def-0arg "\\TZPcolophontimestamp" "0"))) - -(tex-def-prim "\\nr" (lambda () (do-cr "\\nr"))) - -(tex-def-prim "\\number" do-number) - -(tex-def-prim "\\numberedfootnote" do-numbered-footnote) - -(tex-def-prim "\\@ldc@l@r" do-color) - -(tex-def-prim "\\O" (lambda () (emit "Ø"))) - -(tex-def-prim "\\o" (lambda () (emit "ø"))) - -(tex-def-prim "\\obeylines" do-obeylines) - -(tex-def-prim "\\obeyspaces" do-obeyspaces) - -(tex-def-prim "\\obeywhitespace" do-obeywhitespace) - -(tex-def-prim "\\OE" (lambda () (emit "Œ"))) - -(tex-def-prim "\\oe" (lambda () (emit "œ"))) - -(tex-def-prim "\\opengraphsfile" do-mfpic-opengraphsfile) - -(tex-def-prim "\\openin" (lambda () (do-open-stream 'in))) - -(tex-def-prim "\\openout" (lambda () (do-open-stream 'out))) - -(tex-def-prim "\\pagebreak" (lambda () (get-bracketed-text-if-any) (do-eject))) - -(tex-def-prim "\\pageno" (lambda () (emit *html-page-count*))) - -(tex-def-prim "\\pageref" do-pageref) - -(tex-def-prim "\\part" (lambda () (do-heading -1))) - -(tex-def-prim "\\pdfximage" do-pdfximage) - -(tex-def-prim - "\\picture" - (lambda () (do-latex-env-as-image "picture" 'inline))) - -(tex-def-prim "\\plainfootnote" do-plain-footnote) - -(tex-def-prim "\\pounds" (lambda () (emit "£"))) - -(tex-def-prim "\\printindex" (lambda () (do-inputindex #t))) - -(tex-def-prim "\\quad" (lambda () (emit-nbsp 4))) - -(tex-def-prim "\\qquad" (lambda () (emit-nbsp 8))) - -(tex-def-prim - "\\quote" - (lambda () (do-end-para) (emit "
        ") (bgroup))) - -(tex-def-prim - "\\endquote" - (lambda () (do-end-para) (egroup) (emit "
        "))) - -(tex-def-prim "\\r" (lambda () (do-diacritic 'ring))) - -(tex-def-prim "\\raggedleft" (lambda () (do-switch 'raggedleft))) - -(tex-def-prim "\\rawhtml" do-rawhtml) - -(tex-def-prim "\\read" (lambda () (do-read (global?)))) - -(tex-def-prim "\\readtocfile" do-toc) - -(tex-def-prim "\\ref" do-ref) - -(tex-def-prim "\\refexternal" do-refexternal) - -(tex-def-prim "\\refn" do-ref) - -(tex-def-prim "\\relax" do-relax) - -(tex-def-prim "\\renewcommand" (lambda () (do-newcommand #t))) - -(tex-def-prim "\\renewenvironment" (lambda () (do-newenvironment #t))) - -(tex-def-prim "\\resetatcatcode" (lambda () (set-catcode #\@ 12))) - -(tex-def-prim "\\resizebox" do-resizebox) - -(tex-def-prim "\\rightline" (lambda () (do-function "\\rightline"))) - -(tex-def-prim "\\rm" (lambda () (if *math-mode?* (do-switch 'rm)))) - -(tex-def-prim "\\romannumeral" (lambda () (do-romannumeral #f))) - -(tex-def-prim "\\Romannumeral" (lambda () (do-romannumeral #t))) - -(tex-def-prim "\\ruledtable" do-ruledtable) - -(tex-def-prim "\\sc" (lambda () (do-switch 'sc))) - -(tex-def-prim - "\\schemedisplay" - (lambda () (do-scm-slatex-lines "schemedisplay" #t #f))) - -(tex-def-prim - "\\schemebox" - (lambda () (do-scm-slatex-lines "schemebox" #f #f))) - -(tex-def-prim - "\\schemeresponse" - (lambda () (do-scm-slatex-lines "schemeresponse" #t 'result))) - -(tex-def-prim - "\\schemeresponsebox" - (lambda () (do-scm-slatex-lines "schemeresponsebox" #f 'result))) - -(tex-def-prim "\\schemeresult" (lambda () (do-scm 'result))) - -(tex-def-prim "\\scm" (lambda () (do-scm #f))) - -(tex-def-prim "\\scmbuiltin" do-scm-set-builtins) - -(tex-def-prim "\\scmdribble" do-scmdribble) - -(tex-def-prim "\\scminput" do-scminput) - -(tex-def-prim "\\scmkeyword" do-scm-set-keywords) - -(tex-def-prim "\\scmspecialsymbol" do-scm-set-specialsymbol) - -(tex-def-prim "\\scmvariable" do-scm-set-variables) - -(tex-def-prim "\\scriptsize" (lambda () (do-switch 'scriptsize))) - -(tex-def-prim "\\section" (lambda () (do-heading 1))) - -(tex-def-prim "\\seealso" do-see-also) - -(tex-def-prim "\\setcounter" (lambda () (set-latex-counter #f))) - -(tex-def-prim "\\sevenrm" (lambda () (do-switch 'sevenrm))) - -(tex-def-prim "\\sf" (lambda () (do-switch 'sf))) - -(tex-def-prim "\\sidx" do-index) - -(tex-def-prim "\\sl" (lambda () (do-switch 'sl))) - -(tex-def-prim "\\slatexdisable" get-group) - -(tex-def-prim - "\\slatexlikecomments" - (lambda () (tex-def-0arg "\\TZPslatexcomments" "1"))) - -(tex-def-prim "\\small" (lambda () (do-switch 'small))) - -(tex-def-prim "\\smallbreak" (lambda () (do-bigskip 'smallskip))) - -(tex-def-prim "\\smallskip" (lambda () (do-bigskip 'smallskip))) - -(tex-def-prim "\\ss" (lambda () (emit "ß"))) - -(tex-def-prim "\\strike" (lambda () (do-switch 'strike))) - -(tex-def-prim "\\string" do-string) - -(tex-def-prim "\\subject" do-subject) - -(tex-def-prim - "\\subsection" - (lambda () (get-bracketed-text-if-any) (do-heading 2))) - -(tex-def-prim "\\subsubsection" (lambda () (do-heading 3))) - -(tex-def-prim "\\symfootnote" do-symfootnote) - -(tex-def-prim "\\tabbing" do-tabbing) - -(tex-def-prim "\\table" (lambda () (do-table/figure 'table))) - -(tex-def-prim "\\tableplain" do-table-plain) - -(tex-def-prim "\\tableofcontents" do-toc) - -(tex-def-prim "\\tabular" do-tabular) - -(tex-def-prim "\\tag" do-tag) - -(tex-def-prim "\\TeX" do-tex-logo) - -(tex-def-prim "\\texonly" (lambda () (ignore-tex-specific-text "texonly"))) - -(tex-def-prim "\\textasciicircum" (lambda () (emit "^"))) - -(tex-def-prim "\\textbar" (lambda () (emit "|"))) - -(tex-def-prim "\\textbackslash" (lambda () (emit "\\"))) - -(tex-def-prim "\\textbf" (lambda () (do-function "\\textbf"))) - -(tex-def-prim "\\textbullet" (lambda () (emit "•"))) - -(tex-def-prim "\\textdegree" (lambda () (ignorespaces) (emit "°"))) - -(tex-def-prim "\\textemdash" (lambda () (emit *html-mdash*))) - -(tex-def-prim "\\textendash" (lambda () (emit *html-ndash*))) - -(tex-def-prim "\\textexclamdown" (lambda () (emit "¡"))) - -(tex-def-prim "\\textgreater" (lambda () (emit ">"))) - -(tex-def-prim "\\textit" (lambda () (do-function "\\textit"))) - -(tex-def-prim "\\textless" (lambda () (emit "<"))) - -(tex-def-prim "\\textperiodcentered" (lambda () (emit "·"))) - -(tex-def-prim "\\textquestiondown" (lambda () (emit "¿"))) - -(tex-def-prim "\\textquotedblleft" (lambda () (emit *html-ldquo*))) - -(tex-def-prim "\\textquotedblright" (lambda () (emit *html-rdquo*))) - -(tex-def-prim "\\textquoteleft" (lambda () (emit *html-lsquo*))) - -(tex-def-prim "\\textquoteright" (lambda () (emit *html-rsquo*))) - -(tex-def-prim "\\textregistered" (lambda () (emit "®"))) - -(tex-def-prim "\\textrm" (lambda () (do-function "\\textrm"))) - -(tex-def-prim - "\\textsc" - (lambda () - (fluid-let ((*in-small-caps?* #t)) (tex2page-string (get-group))))) - -(tex-def-prim "\\textsl" (lambda () (do-function "\\textsl"))) - -(tex-def-prim "\\textasciitilde" (lambda () (emit "~"))) - -(tex-def-prim "\\texttt" (lambda () (do-function "\\texttt"))) - -(tex-def-prim "\\textvisiblespace" emit-visible-space) - -(tex-def-prim "\\TH" (lambda () (emit "Þ"))) - -(tex-def-prim "\\th" (lambda () (emit "þ"))) - -(tex-def-prim "\\the" do-the) - -(tex-def-prim "\\thebibliography" do-thebibliography) - -(tex-def-prim "\\theindex" do-theindex) - -(tex-def-prim "\\TIIPanchor" do-anchor-for-potential-label) - -(tex-def-prim "\\TIIPbackslash" (lambda () (emit "\\"))) - -(tex-def-prim "\\TIIPbr" do-br) - -(tex-def-prim "\\TIIPcmyk" (lambda () (do-switch 'cmyk))) - -(tex-def-prim "\\TIIPcsname" do-saved-csname) - -(tex-def-prim "\\TIIPcomment" eat-till-eol) - -(tex-def-prim "\\TIIPeatstar" eat-star) - -(tex-def-prim "\\TIIPendgraf" do-end-para) - -(tex-def-prim "\\TIIPfolio" point-to-adjacent-pages) - -(tex-def-prim "\\TIIPgobblegroup" get-group) - -(tex-def-prim "\\TIIPgray" (lambda () (do-switch 'gray))) - -(tex-def-prim "\\TIIPhlend" do-hlend) - -(tex-def-prim "\\TIIPlatexenvasimage" do-following-latex-env-as-image) - -(tex-def-prim "\\TIIPnbsp" (lambda () (emit-nbsp 1))) - -(tex-def-prim "\\TIIPnewline" do-newline) - -(tex-def-prim "\\TIIPnull" get-actual-char) - -(tex-def-prim "\\TIIPreuseimage" reuse-img) - -(tex-def-prim "\\TIIPrgb" (lambda () (do-switch 'rgb))) - -(tex-def-prim "\\TIIPRGB" (lambda () (do-switch 'rgb255))) - -(tex-def-prim "\\TIIPtheorem" do-theorem) - -(tex-def-prim "\\TIIPrelax" do-relax) - -(tex-def-prim "\\tiny" (lambda () (do-switch 'tiny))) - -(tex-def-prim "\\title" do-title) - -(tex-def-prim "\\today" do-today) - -(tex-def-prim "\\trademark" (lambda () (emit "™"))) - -(tex-let-prim "\\texttrademark" "\\trademark") - -(tex-def-prim "\\tracingall" do-tracingall) - -(tex-def-prim "\\tt" (lambda () (do-switch 'tt))) - -(tex-def-prim "\\typein" do-typein) - -(tex-def-prim "\\undefcsactive" do-undefcsactive) - -(tex-def-prim "\\undefschememathescape" (lambda () (scm-set-mathescape #f))) - -(tex-def-prim "\\underline" (lambda () (do-function "\\underline"))) - -(tex-def-prim "\\unscmspecialsymbol" do-scm-unset-specialsymbol) - -(tex-def-prim "\\uppercase" do-uppercase) - -(tex-def-prim "\\url" do-url) - -(tex-def-prim "\\urlh" do-urlh) - -(tex-def-prim "\\urlhd" do-urlhd) - -(tex-def-prim "\\urlp" do-urlp) - -(tex-def-prim "\\v" (lambda () (do-diacritic 'hacek))) - -(tex-def-prim - "\\vdots" - (lambda () - (emit "") - (emit "") - (emit "
        .
        .
        .
        "))) - -(tex-def-prim "\\verb" do-verb) - -(tex-def-prim "\\verbatim" do-verbatim) - -(tex-def-prim "\\verbatiminput" do-verbatiminput) - -(tex-def-prim "\\verbc" do-verbc) - -(tex-def-prim "\\verbatimescapechar" do-verbatimescapechar) - -(tex-def-prim "\\verbwrite" do-verbwrite) - -(tex-def-prim "\\verbwritefile" do-verbwritefile) - -(tex-def-prim "\\vfootnote" do-vfootnote) - -(tex-def-prim "\\vskip" do-vskip) - -(tex-def-prim "\\vspace" do-vspace) - -(tex-def-prim "\\write" do-write) - -(tex-def-prim "\\writenumberedcontentsline" do-writenumberedcontentsline) - -(tex-def-prim "\\writenumberedtocline" do-writenumberedtocline) - -(tex-let-prim "\\writetotoc" "\\writenumberedtocline") - -(tex-def-prim "\\xdef" (lambda () (do-def #t #t))) - -(tex-def-prim "\\xrdef" do-xrdef) - -(tex-def-prim "\\xrefn" do-ref) - -(tex-def-prim "\\xrtag" do-tag) - -(tex-def-prim "\\xspace" do-xspace) - -(tex-def-prim "\\yen" (lambda () (emit "¥"))) - -(tex-def-prim "\\contentsname" (lambda () (emit "Contents"))) - -(tex-def-prim "\\listfigurename" (lambda () (emit "List of Figures"))) - -(tex-def-prim "\\listtablename" (lambda () (emit "List of Tables"))) - -(tex-def-prim "\\refname" (lambda () (emit "References"))) - -(tex-def-prim "\\indexname" (lambda () (emit "Index"))) - -(tex-def-prim "\\figurename" (lambda () (emit "Figure"))) - -(tex-def-prim "\\tablename" (lambda () (emit "Table"))) - -(tex-def-prim "\\partname" (lambda () (emit "Part"))) - -(tex-def-prim "\\appendixname" (lambda () (emit "Appendix"))) - -(tex-def-prim "\\abstractname" (lambda () (emit "Abstract"))) - -(tex-def-prim "\\bibname" (lambda () (emit "Bibliography"))) - -(tex-def-prim "\\chaptername" (lambda () (emit "Chapter"))) - -(tex-def-prim "\\\\" (lambda () (do-cr "\\\\"))) - -(tex-def-prim "\\`" (lambda () (do-diacritic 'grave))) - -(tex-def-prim "\\(" do-latex-intext-math) - -(tex-def-prim "\\[" do-latex-display-math) - -(tex-def-prim "\\)" egroup) - -(tex-def-prim "\\]" egroup) - -(tex-def-prim "\\{" (lambda () (emit "{"))) - -(tex-def-prim "\\}" (lambda () (emit "}"))) - -(tex-let-prim "\\-" "\\TIIPrelax") - -(tex-def-prim "\\'" (lambda () (do-diacritic 'acute))) - -(tex-def-prim - "\\=" - (lambda () - (unless (and - (not (null? *tabular-stack*)) - (eqv? (car *tabular-stack*) 'tabbing)) - (do-diacritic 'circumflex)))) - -(tex-def-prim - "\\>" - (lambda () - (if (and (not (null? *tabular-stack*)) - (eqv? (car *tabular-stack*) 'tabbing)) - (emit-nbsp 3)))) - -(tex-def-prim "\\^" (lambda () (do-diacritic 'circumflex))) - -(tex-def-prim "\\~" (lambda () (do-diacritic 'tilde))) - -(tex-def-prim "\\#" (lambda () (emit "#"))) - -(tex-def-prim "\\ " (lambda () (emit #\space))) - -(tex-def-prim "\\%" (lambda () (emit "%"))) - -(tex-def-prim "\\&" (lambda () (emit "&"))) - -(tex-def-prim "\\@" (lambda () (emit "@"))) - -(tex-def-prim "\\_" (lambda () (emit "_"))) - -(tex-def-prim "\\$" (lambda () (emit "$"))) - -(tex-def-prim (string #\\ #\newline) emit-newline) - -(tex-let-prim "\\htmladvancedentities" "\\TIIPrelax") - -(tex-let-prim "\\displaystyle" "\\TIIPrelax") - -(tex-let-prim "\\textstyle" "\\TIIPrelax") - -(tex-let-prim "\\endsloppypar" "\\TIIPrelax") - -(tex-let-prim "\\frenchspacing" "\\TIIPrelax") - -(tex-let-prim "\\oldstyle" "\\TIIPrelax") - -(tex-let-prim "\\protect" "\\TIIPrelax") - -(tex-let-prim "\\raggedbottom" "\\TIIPrelax") - -(tex-let-prim "\\raggedright" "\\TIIPrelax") - -(tex-let-prim "\\sloppy" "\\TIIPrelax") - -(tex-let-prim "\\sloppypar" "\\TIIPrelax") - -(tex-let-prim "\\beginpackages" "\\TIIPrelax") - -(tex-let-prim "\\endpackages" "\\TIIPrelax") - -(tex-let-prim "\\normalfont" "\\TIIPrelax") - -(tex-let-prim "\\textnormal" "\\TIIPrelax") - -(tex-let-prim "\\unskip" "\\TIIPrelax") - -(tex-def-prim "\\cline" get-group) - -(tex-def-prim "\\externalref" get-group) - -(tex-def-prim "\\GOBBLEARG" get-group) - -(tex-def-prim "\\hyphenation" get-group) - -(tex-def-prim "\\newcounter" get-group) - -(tex-def-prim "\\newlength" get-group) - -(tex-def-prim "\\hphantom" get-group) - -(tex-def-prim "\\vphantom" get-group) - -(tex-def-prim "\\phantom" get-group) - -(tex-def-prim "\\pagenumbering" get-group) - -(tex-def-prim "\\pagestyle" get-group) - -(tex-def-prim "\\raisebox" get-group) - -(tex-def-prim "\\thispagestyle" get-group) - -(tex-def-prim "\\manpagesection" get-group) - -(tex-def-prim "\\manpagedescription" get-group) - -(tex-def-prim "\\externallabels" (lambda () (get-group) (get-group))) - -(tex-let-prim "\\markboth" "\\externallabels") - -(tex-def-prim "\\columnsep" eat-dimen) - -(tex-def-prim "\\columnseprule" eat-dimen) - -(tex-def-prim "\\evensidemargin" eat-dimen) - -(tex-def-prim "\\fboxsep" eat-dimen) - -(tex-def-prim "\\headsep" eat-dimen) - -(tex-def-prim "\\itemsep" eat-dimen) - -(tex-def-prim "\\kern" eat-dimen) - -(tex-def-prim "\\leftcodeskip" eat-dimen) - -(tex-def-prim "\\lower" eat-dimen) - -(tex-def-prim "\\oddsidemargin" eat-dimen) - -(tex-def-prim "\\parsep" eat-dimen) - -(tex-def-prim "\\parskip" eat-dimen) - -(tex-def-prim "\\raise" eat-dimen) - -(tex-def-prim "\\rightcodeskip" eat-dimen) - -(tex-def-prim "\\sidemargin" eat-dimen) - -(tex-def-prim "\\textheight" eat-dimen) - -(tex-def-prim "\\topmargin" eat-dimen) - -(tex-def-prim "\\topsep" eat-dimen) - -(tex-def-prim "\\vertmargin" eat-dimen) - -(tex-def-prim "\\magstep" get-token) - -(tex-def-prim "\\textfont" get-token) - -(tex-def-prim "\\scriptfont" get-token) - -(tex-def-prim "\\scriptscriptfont" get-token) - -(tex-def-prim "\\addtolength" (lambda () (get-token) (get-token))) - -(tex-let-prim "\\addvspace" "\\vspace") - -(tex-let-prim "\\setlength" "\\addtolength") - -(tex-let-prim "\\settowidth" "\\addtolength") - -(tex-let-prim "\\hookaction" "\\addtolength") - -(tex-def-prim "\\enlargethispage" (lambda () (eat-star) (get-group))) - -(tex-def-prim "\\parbox" (lambda () (get-bracketed-text-if-any) (get-group))) - -(tex-def-prim - "\\ProvidesFile" - (lambda () (get-group) (get-bracketed-text-if-any))) - -(tex-def-prim - "\\DeclareGraphicsRule" - (lambda () (get-group) (get-group) (get-group) (get-group))) - -(tex-def-prim - "\\makebox" - (lambda () (get-bracketed-text-if-any) (get-bracketed-text-if-any))) - -(tex-let-prim "\\framebox" "\\makebox") - -(tex-def-prim - "\\rule" - (lambda () (get-bracketed-text-if-any) (get-group) (get-group))) - -(tex-def-prim "\\GOBBLEOPTARG" get-bracketed-text-if-any) - -(tex-def-prim "\\nolinebreak" get-bracketed-text-if-any) - -(tex-def-prim "\\nopagebreak" get-bracketed-text-if-any) - -(tex-def-prim "\\hyphenchar" (lambda () (get-token) (eat-integer))) - -(tex-def-prim "\\skewchar" (lambda () (get-token) (eat-integer))) - -(tex-def-prim - "\\usepackage" - (lambda () (get-bracketed-text-if-any) (get-group) (probably-latex))) - -(tex-def-prim "\\readindexfile" (lambda () (get-token) (do-inputindex #f))) - -(tex-let-prim "\\enskip" "\\enspace") - -(tex-let-prim "\\colophon" "\\htmlcolophon") - -(tex-let-prim "\\path" "\\verb") - -(tex-let-prim "\\par" "\\endgraf") - -(tex-let-prim "\\u" "\\`") - -(tex-let-prim "\\vbox" "\\hbox") - -(tex-let-prim "\\endabstract" "\\endquote") - -(tex-let-prim "\\mbox" "\\hbox") - -(tex-let-prim "\\supereject" "\\eject") - -(tex-let-prim "\\dosupereject" "\\eject") - -(tex-let-prim "\\endgroup" "\\egroup") - -(tex-let-prim "\\begingroup" "\\bgroup") - -(tex-let-prim "\\d" "\\b") - -(tex-let-prim "\\." "\\b") - -(tex-let-prim "\\k" "\\c") - -(tex-let-prim "\\ldots" "\\dots") - -(tex-let-prim "\\documentstyle" "\\documentclass") - -(tex-let-prim "\\H" "\\\"") - -(tex-let-prim "\\/" "\\TIIPrelax") - -(tex-let-prim "\\leavevmode" "\\TIIPrelax") - -(tex-let-prim "\\space" "\\ ") - -(tex-let-prim "\\quotation" "\\quote") - -(tex-let-prim "\\endquotation" "\\endquote") - -(tex-let-prim "\\TIIPdate" "\\today") - -(tex-let-prim "\\schemeinput" "\\scminput") - -(tex-let-prim "\\obeywhitespaces" "\\obeywhitespace") - -(tex-let-prim "\\ensuremath" "\\mathg") - -(tex-let-prim "\\epsffile" "\\epsfbox") - -(tex-let-prim "\\htmlimgformat" "\\htmlimageformat") - -(tex-let-prim "\\p" "\\verb") - -(tex-let-prim "\\ttraggedright" "\\tt") - -(tex-let-prim "\\ttfamily" "\\tt") - -(tex-let-prim "\\htmladdnormallink" "\\urlp") - -(tex-let-prim "\\htmladdnormallinkfoot" "\\urlp") - -(tex-let-prim "\\pagehtmlref" "\\htmlref") - -(tex-let-prim "\\circledR" "\\textregistered") - -(tex-let-prim "\\registered" "\\textregistered") - -(tex-let-prim "\\scmconstant" "\\scmbuiltin") - -(tex-let-prim "\\setbuiltin" "\\scmbuiltin") - -(tex-let-prim "\\setconstant" "\\scmconstant") - -(tex-let-prim "\\setkeyword" "\\scmkeyword") - -(tex-let-prim "\\setvariable" "\\scmvariable") - -(tex-let-prim "\\unssetspecialsymbol" "\\unscmspecialsymbol") - -(tex-let-prim "\\setspecialsymbol" "\\scmspecialsymbol") - -(tex-let-prim "\\scmp" "\\scm") - -(tex-let-prim "\\q" "\\scm") - -(tex-let-prim "\\scheme" "\\scm") - -(tex-let-prim "\\tagref" "\\ref") - -(tex-let-prim "\\numfootnote" "\\numberedfootnote") - -(tex-let-prim "\\f" "\\numberedfootnote") - -(tex-let-prim "\\newpage" "\\eject") - -(tex-let-prim "\\clearpage" "\\eject") - -(tex-let-prim "\\cleardoublepage" "\\eject") - -(tex-let-prim "\\htmlpagebreak" "\\eject") - -(tex-let-prim "\\typeout" "\\message") - -(tex-let-prim "\\unorderedlist" "\\itemize") - -(tex-let-prim "\\li" "\\item") - -(tex-let-prim "\\htmlstylesheet" "\\inputcss") - -(tex-let-prim "\\hr" "\\hrule") - -(tex-let-prim "\\htmlrule" "\\hrule") - -(tex-let-prim "\\numberedlist" "\\enumerate") - -(tex-let-prim "\\orderedlist" "\\enumerate") - -(tex-let-prim "\\endunorderedlist" "\\enditemize") - -(tex-let-prim "\\endnumberedlist" "\\endenumerate") - -(tex-let-prim "\\endorderedlist" "\\endenumerate") - -(tex-let-prim "\\newline" "\\break") - -(tex-let-prim "\\gifdef" "\\imgdef") - -(tex-let-prim "\\schemeeval" "\\eval") - -(tex-let-prim "\\gifpreamble" "\\imgpreamble") - -(tex-let-prim "\\mathpreamble" "\\imgpreamble") - -(tex-let-prim "\\scmverbatim" "\\scm") - -(tex-let-prim "\\scmfilename" "\\verbwritefile") - -(tex-let-prim "\\scmwritefile" "\\verbwritefile") - -(tex-let-prim "\\verbfilename" "\\verbwritefile") - -(tex-let-prim "\\scmfileonly" "\\verbwrite") - -(tex-let-prim "\\scmverbatimfile" "\\scminput") - -(tex-let-prim "\\scmverbatiminput" "\\scminput") - -(tex-let-prim "\\scmwrite" "\\verbwrite") - -(tex-let-prim "\\scmfile" "\\scmdribble") - -(tex-let-prim "\\scmverb" "\\scm") - -(tex-let-prim "\\verbinput" "\\verbatiminput") - -(tex-let-prim "\\verbatimfile" "\\verbatiminput") - -(tex-let-prim "\\verbescapechar" "\\verbatimescapechar") - -(tex-let-prim "\\setverbatimescapechar" "\\verbescapechar") - -(tex-let-prim "\\nohtmlmathimg" "\\dontuseimgforhtmlmath") - -(tex-let-prim "\\nohtmlmathintextimg" "\\dontuseimgforhtmlmathintext") - -(tex-let-prim "\\nohtmlmathdisplayimg" "\\dontuseimgforhtmlmathdisplay") - -(define tex2page - (lambda (tex-file) - (unless (= *write-log-index* 0) (newline)) - (fluid-let - ((*afterassignment* #f) - (*afterpar* '()) - (*afterbye* '()) - (*aux-dir* #f) - (*aux-dir/* "") - (*aux-port* #f) - (*bib-aux-port* #f) - (*bibitem-num* 0) - (*color-names* '()) - (*comment-char* #\%) - (*css-port* #f) - (*current-tex2page-input* #f) - (*current-source-file* #f) - (*display-justification* 'center) - (*doctype* *doctype*) - (*dotted-counters* (make-table 'equ string=?)) - (*dumping-nontex?* #f) - (*equation-number* #f) - (*equation-numbered?* #t) - (*equation-position* 0) - (*esc-char* #\\) - (*esc-char-std* #\\) - (*esc-char-verb* #\|) - (*eval-file-count* 0) - (*eval-for-tex-only?* #f) - (*external-label-tables* (make-table 'equ string=?)) - (*footnote-list* '()) - (*footnote-sym* 0) - (*global-texframe* (make-texframe)) - (*graphics-file-extensions* '(".eps")) - (*html* #f) - (*html-head* '()) - (*html-only* 0) - (*html-page* #f) - (*html-page-count* 0) - (*img-file-count* 0) - (*img-file-tally* 0) - (*imgdef-file-count* 0) - (*imgpreamble* "") - (*imgpreamble-inferred* '()) - (*in-alltt?* #f) - (*in-display-math?* #f) - (*in-para?* #f) - (*in-small-caps?* #f) - (*includeonly-list* #t) - (*index-table* (make-table)) - (*index-count* 0) - (*index-page* #f) - (*index-port* #f) - (*infructuous-calls-to-tex2page* 0) - (*input-line-no* 0) - (*input-streams* '()) - (*inputting-boilerplate?* #f) - (*inside-appendix?* #f) - (*jobname* "texput") - (*label-port* #f) - (*label-source* #f) - (*label-table* (make-table 'equ string=?)) - (*last-modification-time* #f) - (*last-page-number* -1) - (*latex-probability* 0) - (*ligatures?* #t) - (*loading-external-labels?* #f) - (*log-file* #f) - (*log-port* #f) - (*main-tex-file* #f) - (*math-mode?* #f) - (*mfpic-file-num* #f) - (*mfpic-file-stem* #f) - (*mfpic-port* #f) - (*missing-eps-files* '()) - (*missing-pieces* '()) - (*mp-files* '()) - (*not-processing?* #f) - (*output-streams* '()) - (*outputting-external-title?* #f) - (*outputting-to-non-html?* #f) - (*reading-control-sequence?* #f) - (*recent-node-name* #f) - (*scm-dribbling?* #f) - (*section-counter-dependencies* (make-table)) - (*section-counters* (make-table)) - (*slatex-math-escape* #f) - (*source-changed-since-last-run?* #f) - (*stylesheets* '()) - (*subjobname* #f) - (*tabular-stack* '()) - (*temp-string-count* 0) - (*temporarily-use-ascii-for-math?* #f) - (*tex2page-inputs* (path-to-list (getenv "TIIPINPUTS"))) - (*tex-env* '()) - (*tex-format* 'plain) - (*tex-if-stack* '()) - (*tex-like-layout?* *tex-like-layout?*) - (*title* #f) - (*toc-list* '()) - (*toc-page* #f) - (*unresolved-xrefs* '()) - (*using-bibliography?* #f) - (*using-chapters?* #f) - (*using-index?* #f) - (*verb-display?* #f) - (*verb-port* #f) - (*verb-visible-space?* #f) - (*verb-written-files* '()) - (*write-log-index* 0) - (*write-log-possible-break?* #f)) - (set! *main-tex-file* - (actual-tex-filename tex-file (check-input-file-timestamp? tex-file))) - (write-log "This is TeX2page, Version ") - (write-log *tex2page-version*) - (write-log #\space) - (write-log #\() - (write-log *scheme-version*) - (write-log #\,) - (write-log #\space) - (write-log *operating-system*) - (write-log #\)) - (write-log 'separation-newline) - (cond - (*main-tex-file* - (set! *subjobname* *jobname*) - (set! *html-page* - (string-append *aux-dir/* *jobname* *output-extension*)) - (ensure-file-deleted *html-page*) - (set! *html* (open-output-file *html-page*)) - (do-start) - (fluid-let - ((*html-only* (+ *html-only* 1))) - (tex2page-file-if-exists (file-in-home ".tex2page.t2p")) - (tex2page-file-if-exists ".tex2page.t2p") - (cond - ((actual-tex-filename (string-append *jobname* ".t2p") #f) - => - tex2page-file))) - (unless (eqv? (tex2page-file *main-tex-file*) ':encountered-bye) - (insert-missing-end)) - (do-bye)) - (else (tex2page-help tex-file))) - (output-stats)))) - - -) diff --git a/collects/tex2page/tex2page.rkt b/collects/tex2page/tex2page.rkt deleted file mode 100644 index 3a98209af1..0000000000 --- a/collects/tex2page/tex2page.rkt +++ /dev/null @@ -1,12 +0,0 @@ -(module tex2page mzscheme - (require mzlib/etc) - (provide tex2page) - (define - tex2page - (lambda (f) - (parameterize - ((current-namespace (make-namespace))) - (namespace-require - `(file ,(path->string (build-path (this-expression-source-directory) - "tex2page-aux.rkt")))) - ((namespace-variable-value 'tex2page) f))))) diff --git a/collects/tex2page/tex2page.sty b/collects/tex2page/tex2page.sty deleted file mode 100644 index 28bd5bbbb0..0000000000 --- a/collects/tex2page/tex2page.sty +++ /dev/null @@ -1,9 +0,0 @@ -% tex2page.sty -% Dorai Sitaram - -% Loading this file in a LaTeX document -% gives it all the macros of tex2page.tex, -% but via a more LaTeX-convenient filename. - -\input{tex2page} - diff --git a/collects/tex2page/tex2page.tex b/collects/tex2page/tex2page.tex deleted file mode 100644 index 0d49803775..0000000000 --- a/collects/tex2page/tex2page.tex +++ /dev/null @@ -1,1238 +0,0 @@ -% tex2page.tex -% Dorai Sitaram - -% TeX files using these macros -% can be converted by the program -% tex2page into HTML - -\ifx\shipout\UnDeFiNeD\endinput\fi - -\message{version 2008-03-02} % last change - -\let\texonly\relax -\let\endtexonly\relax - -\let\htmlonly\iffalse -\let\endhtmlonly\fi - -\edef\atcatcodebeforetexzpage{% - \noexpand\catcode`\noexpand\@=\the\catcode`\@} -\catcode`\@11 - -% - -\def\verbwritefile{% - \ifx\verbwritefileQport\UnDeFiNeD - \expandafter\csname newwrite\endcsname\verbwritefileQport - \else\immediate\closeout\verbwritefileQport - \fi - \futurelet\verbwritefileQnext\verbwritefileQcheckchar} - -\def\verbwritefileQcheckchar{% - \ifx\verbwritefileQnext\bgroup - \let\verbwritefileQnext\verbwritefileQbracedfile - \else - \let\verbwritefileQnext\verbwritefileQspacedfile - \fi\verbwritefileQnext} - -\def\verbwritefileQspacedfile#1 {% - \immediate\openout\verbwritefileQport #1 -} - -\def\verbwritefileQbracedfile#1{% - \verbwritefileQspacedfile #1 -} - -\def\verbwrite{% - \ifx\verbwritefileQport\UnDeFiNeD - \verbwritefile \jobname.txt \fi - \begingroup - \def\do##1{\catcode`##1=12 }\dospecials - \catcode`\{=1 \catcode`\}=2 - \catcode`\^^M=12 \newlinechar=`\^^M% - \futurelet\verbwriteQopeningchar\verbwriteQii} - -\def\verbwriteQii{\ifx\verbwriteQopeningchar\bgroup - \let\verbwriteQiii\verbwriteQbrace\else - \let\verbwriteQiii\verbwriteQnonbrace\fi - \verbwriteQiii} - -\def\verbwriteQbrace#1{\immediate - \write\verbwritefileQport{#1}\endgroup} - -\def\verbwriteQnonbrace#1{% - \catcode`\{12 \catcode`\}12 - \def\verbwriteQnonbraceQii##1#1{% - \immediate\write\verbwritefileQport{##1}\endgroup}% - \verbwriteQnonbraceQii} - -\ifx\slatexignorecurrentfile\UnDeFiNeD\relax\fi - -% - -\def\defcsactive#1{\defnumactive{`#1}} - -\def\defnumactive#1{\catcode#1\active - \begingroup\lccode`\~#1% - \lowercase{\endgroup\def~}} - -% gobblegobblegobble - -\def\gobblegroup{\bgroup - \def\do##1{\catcode`##1=9 }\dospecials - \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 - \gobblegroupQii} - -\def\gobblegroupQii#1{\egroup} - -% \verb -% Usage: \verb{...lines...} or \verb|...lines...| -% In the former case, | can be used as escape char within -% the verbatim text - -\let\verbhook\relax - -\def\verbfont{\tt} -%\hyphenchar\tentt-1 - -\def\verbsetup{\frenchspacing - \def\do##1{\catcode`##1=12 }\dospecials - \catcode`\|=12 % needed? - \verbfont - \edef\verbQoldhyphenchar{\the\hyphenchar\font}% - \hyphenchar\font-1 - \def\verbQendgroup{\hyphenchar\font\verbQoldhyphenchar\endgroup}% -} - -\def\verbavoidligs{% avoid ligatures - \defcsactive\`{\relax\lq}% - \defcsactive\ {\leavevmode\ }% - \defcsactive\^^I{\leavevmode\ \ \ \ \ \ \ \ }% - \defcsactive\^^M{\leavevmode\endgraf}% - \ifx\noncmttQspecific\UnDeFiNeD\else\noncmttQspecific\fi} - -\def\verbinsertskip{% - \let\firstpar y% - \defcsactive\^^M{\ifx\firstpar y% - \let\firstpar n% - \verbdisplayskip - \parskip 0pt - \aftergroup\verbdisplayskip - \else\leavevmode\fi\endgraf}% - \verbhook} - -%\def\verb{\begingroup -% \verbsetup\verbQii} - -\ifx\verb\UnDeFiNeD\else % save away LaTeX's \verb - \let\LaTeXverb\verb -\fi - -\def\verb{\begingroup - \verbsetup\verbavoidligs\verbQcheckstar}% - -\def\verbQcheckstar{% - \futurelet\verbQcheckstarQnext\verbQcheckstarQii} - -\def\verbQcheckstarQii{% - \if\verbQcheckstarQnext*% - \let\verbQcheckstarQnext\verbQcheckstarQiii - \else - \let\verbQcheckstarQnext\verbQii - \fi - \verbQcheckstarQnext} - -\def\verbQcheckstarQiii#1{% - \defcsactive\ {\relax\char`\ }% - \verbQii} - -\newcount\verbbracebalancecount - -\def\verblbrace{\char`\{} -\def\verbrbrace{\char`\}} - -\ifx\verbatimescapechar\UnDeFiNeD -% don't clobber Eplain's \verbatimescapechar -\def\verbatimescapechar#1{% - \def\@makeverbatimescapechar{\catcode`#1=0 }}% -\fi -\let\verbescapechar\verbatimescapechar - -\verbatimescapechar\| - -{\catcode`\[1 \catcode`\]2 -\catcode`\{12 \catcode`\}12 -\gdef\verbQii#1[%\verbavoidligs - \verbinsertskip\verbhook - %\edef\verbQoldhyphenchar{\the\hyphenchar\tentt}% - %\hyphenchar\tentt=-1 - %\def\verbQendgroup{\hyphenchar\tentt\verbQoldhyphenchar\endgroup}% - %\let\verbQendgroup\endgroup% - \if#1{\@makeverbatimescapechar - \def\{[\char`\{]% - \def\}[\char`\}]% - \def\|[\char`\|]% - \verbbracebalancecount0 - \defcsactive\{[\advance\verbbracebalancecount by 1 - \verblbrace]% - \defcsactive\}[\ifnum\verbbracebalancecount=0 - \let\verbrbracenext\verbQendgroup\else - \advance\verbbracebalancecount by -1 - \let\verbrbracenext\verbrbrace\fi - \verbrbracenext]\else - \defcsactive#1[\verbQendgroup]\fi - \verbQiii -]] - -\def\verbQiii{\futurelet\verbQiiinext\verbQiv} - -{\catcode`\^^M\active% -\gdef\verbQiv{\ifx\verbQiiinext^^M\else% - \defcsactive\^^M{\leavevmode\ }\fi}} - -\let\verbdisplayskip\medbreak - -% \verbatiminput FILENAME -% displays contents of file FILENAME verbatim. - -%\def\verbatiminput#1 {{\verbsetup\verbavoidligs\verbhook -% \input #1 }} - -% ^ original \verbatiminput - -\ifx\verbatiminput\UnDeFiNeD -% LaTeX's (optional) verbatim package defines a \verbatiminput -- -% don't clobber it -\def\verbatiminput{% - \futurelet\verbatiminputQnext\verbatiminputQcheckchar}% -\fi - -\def\verbatiminputQcheckchar{% - \ifx\verbatiminputQnext\bgroup - \let\verbatiminputQnext\verbatiminputQbracedfile - \else - \let\verbatiminputQnext\verbatiminputQspacedfile - \fi\verbatiminputQnext} - -\def\verbatiminputQbracedfile#1{\verbatiminputQdoit{#1}} - -\def\verbatiminputQspacedfile#1 {\verbatiminputQdoit{#1}} - -\def\verbatiminputQdoit#1{{\verbsetup - \verbavoidligs\verbhook - \input #1 }} - -% \url{URL} becomes -% URL in HTML, and -% URL in DVI. - -% A-VERY-VERY-LONG-URL in a .bib file -% could be split by BibTeX -% across a linebreak, with % before the newline. -% To accommodate this, %-followed-by-newline will -% be ignored in the URL argument of \url and related -% macros. - -\ifx\url\UnDeFiNeD -\def\url{\bgroup\urlsetup\let\dummy=}% -\fi - -\def\urlsetup{\verbsetup\urlfont\verbavoidligs - \catcode`\{1 \catcode`\}2 - \defcsactive\%{\urlQpacifybibtex}% - \defcsactive\ {\relax}% - \defcsactive\^^M{\relax}% - \defcsactive\.{\discretionary{}{\char`\.}{\char`\.}}% - \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% - \defcsactive\`{\relax\lq}} - -\let\urlfont\relax - -\def\urlQpacifybibtex{\futurelet\urlQpacifybibtexQnext\urlQpacifybibtexQii} - -\def\urlQpacifybibtexQii{\ifx\urlQpacifybibtexQnext^^M% - \else\%\fi} - - -% \urlh{URL}{TEXT} becomes -% TEXT in HTML, and -% TEXT in DVI. - -% If TEXT contains \\, the part after \\ appears in -% the DVI only. If, further, this part contains \1, -% the latter is replaced by a fixed-width representation -% of URL. - -\def\urlh{\bgroup\urlsetup - \afterassignment\urlhQii - \gdef\urlhQurlarg} - -\def\urlhQii{\egroup - \bgroup - \let\\\relax - \def\1{{\urlsetup\urlhQurlarg}}% - \let\dummy=} - -\def\urlp#1{{#1} \bgroup\urlsetup - \afterassignment\urlpQwrapparens - \gdef\urlpQurlarg} - -\def\urlpQwrapparens{\egroup - {\rm(}{\urlsetup\urlpQurlarg}{\rm)}} - -% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes -% HTML-TEXT in HTML, and -% DVI-TEXT in DVI - -\def\urlhd{\bgroup - \def\do##1{\catcode`##1=12 }\dospecials - \catcode`\{1 \catcode`\}2 - \urlhdQeaturlhtmlargs} - -\def\urlhdQeaturlhtmlargs#1#2{\egroup} - -\ifx\href\UnDeFiNeD -\let\href\urlh -\fi - -% Scheme - -\let\scm\verb -\let\scminput\verbatiminput -\let\scmdribble\scm - - -% Images - -\let\imgdef\def - -\let\makehtmlimage\relax - -\def\mathg{$\bgroup\aftergroup\closemathg\let\dummy=} -\def\closemathg{$} - -\let\mathp\mathg - -\def\mathdg{$$\bgroup\aftergroup\closemathdg\let\dummy=} -\def\closemathdg{$$} - -% - -\ifx\label\UnDeFiNeD -\else -\def\xrtag#1#2{\@bsphack - \protected@write\@auxout{}% - {\string\newlabel{#1}{{#2}{\thepage}}}% -\@esphack}% -%\let\tagref\ref -\fi - -\ifx\definexref\UnDeFiNeD -\else -\def\xrtag#1#2{\definexref{#1}{#2}{}}% -\fi - -\ifx\IfFileExists\UnDeFiNeD -\def\IfFileExists#1#2#3{% - \openin0 #1 % - \ifeof0 % - #3% - \else - #2\fi - \closein0 }% -\fi - -\ifx\futurenonspacelet\UnDeFiNeD -\ifx\@futurenonspacelet\UnDeFiNeD -% -\def\futurenonspaceletQpickupspace/{% - \global\let\futurenonspaceletQspacetoken= }% -\futurenonspaceletQpickupspace/ % -% -\def\futurenonspacelet#1{\def\futurenonspaceletQargQi{#1}% - \afterassignment\futurenonspaceletQstepQone - \let\futurenonspaceletQargQii=}% -% -\def\futurenonspaceletQstepQone{% - \expandafter\futurelet\futurenonspaceletQargQi - \futurenonspaceletQstepQtwo}% -% -\def\futurenonspaceletQstepQtwo{% - \expandafter\ifx\futurenonspaceletQargQi\futurenonspaceletQspacetoken - \let\futurenonspaceletQnext=\futurenonspaceletQstepQthree - \else\let\futurenonspaceletQnext=\futurenonspaceletQargQii - \fi\futurenonspaceletQnext}% -% -\def\futurenonspaceletQstepQthree{% - \afterassignment\futurenonspaceletQstepQone - \let\futurenonspaceletQnext= }% -% -\else\let\futurenonspacelet\@futurenonspacelet -\fi -\fi - -\ifx\slatexversion\UnDeFiNeD -% SLaTeX compat -\let\scmkeyword\gobblegroup -\let\scmbuiltin\gobblegroup -\let\scmconstant\scmbuiltin -\let\scmvariable\scmbuiltin -\let\setbuiltin\scmbuiltin -\let\setconstant\scmbuiltin -\let\setkeyword\scmkeyword -\let\setvariable\scmvariable -\def\schemedisplay{\begingroup - \verbsetup\verbavoidligs - \verbinsertskip - \schemedisplayI}% -\def\schemeresponse{\begingroup - \verbsetup\verbavoidligs - \verbinsertskip - \schemeresponseI}% -{\catcode`\|0 |catcode`|\12 - |long|gdef|schemedisplayI#1\endschemedisplay{% - #1|endgroup}% - |long|gdef|schemeresponseI#1\endschemeresponse{% - #1|endgroup}}% -\fi - - -% STOP LOADING HERE FOR LATEX - -\ifx\section\UnDeFiNeD -\let\maybeloadfollowing\relax -\else -\atcatcodebeforetexzpage -\let\maybeloadfollowing\endinput -\fi\maybeloadfollowing - -\newwrite\sectionQscratchfileport - -% Title - -\def\subject{% - \immediate\openout\sectionQscratchfileport Z-sec-temp - \begingroup - \def\do##1{\catcode`##1=11 }\dospecials - \catcode`\{=1 \catcode`\}=2 - \subjectI} - -\def\subjectI#1{\endgroup - \immediate\write\sectionQscratchfileport {#1}% - \immediate\closeout\sectionQscratchfileport - $$\vbox{\bf \def\\{\cr}% - \halign{\hfil##\hfil\cr - \input Z-sec-temp - \cr}}$$% - \medskip} - -\let\title\subject - -% toc - -\let\tocactive0 - -\newcount\tocdepth - -%\tocdepth=10 -\tocdepth=3 - -\def\tocoutensure{\ifx\tocout\UnDeFiNeD - \csname newwrite\endcsname\tocout\fi} - -\def\tocactivate{\ifx\tocactive0% - \tocoutensure - \tocsave - \openout\tocout \jobname.toc - \global\let\tocactive1\fi} - -\def\tocspecials{\def\do##1{\catcode`##1=12 }\dospecials} - -\def\tocsave{\openin0=\jobname.toc - \ifeof0 \closein0 \else - \openout\tocout Z-T-\jobname.tex - \let\tocsaved 0% - \loop - \ifeof0 \closeout\tocout - \let\tocsaved1% - \else{\tocspecials - \read0 to \tocsaveline - \edef\temp{\write\tocout{\tocsaveline}}\temp}% - \fi - \ifx\tocsaved0% - \repeat - \fi - \closein0 } - -\def\tocentry#1#2{% - %#1=depth #2=secnum - \def\tocentryQsecnum{#2}% - \ifnum#1=1 - \ifnum\tocdepth>2 - \medbreak\begingroup\bf - \else\begingroup\fi - \else\begingroup\fi - \vtop\bgroup\raggedright - \noindent\hskip #1 em - \ifx\tocentryQsecnum\empty - \else\qquad\llap{\tocentryQsecnum}\enspace\fi - \bgroup - \aftergroup\tocentryQii - %read section title - \let\dummy=} - -\def\tocentryQii#1{% - %#1=page nr - , #1\strut\egroup - \endgroup\par -} - - -% allow {thebibliography} to be used directly -% in (plain-TeX) source document without -% generating it via BibTeX - -\ifx\thebibliography\UnDeFiNeD -\def\thebibliography#1{\vskip-\lastskip - \begingroup - \def\endthebibliography{\endgroup\endgroup}% - \def\input##1 ##2{\relax}% - \setbox0=\hbox{\biblabelcontents{#1}}% - \biblabelwidth=\wd0 - \@readbblfile}% -\fi - - -% - -\def\italiccorrection{\futurelet\italiccorrectionI - \italiccorrectionII} - -\def\italiccorrectionII{% - \if\noexpand\italiccorrectionI,\else - \if\noexpand\italiccorrectionI.\else - \/\fi\fi} - -\def\em{\it\ifmmode\else\aftergroup\italiccorrection\fi} - -\def\emph{\bgroup\it - \ifmmode\else\aftergroup\italiccorrection\fi - \let\dummy=} - - -\def\begin#1{\begingroup - \def\end##1{\csname end#1\endcsname\endgroup}% - \csname #1\endcsname} - - -\def\textdegree{\ifmmode^\circ\else$^\circ$\fi} - - -% STOP LOADING HERE FOR EPLAIN - -\ifx\eplain\UnDeFiNeD -\let\maybeloadfollowing\relax -\else -\atcatcodebeforetexzpage -\let\maybeloadfollowing\endinput -\fi\maybeloadfollowing -% - -% Index generation -% -% Your TeX source contains \index{NAME} to -% signal that NAME should be included in the index. -% Check the makeindex documentation to see the various -% ways NAME can be specified, eg, for subitems, for -% explicitly specifying the alphabetization for a name -% involving TeX control sequences, etc. -% -% The first run of TeX will create \jobname.idx. -% makeindex on \jobname[.idx] will create the sorted -% index \jobname.ind. -% -% Use \inputindex (without arguments) to include this -% sorted index, typically somewhere to the end of your -% document. This will produce the items and subitems. -% It won't produce a section heading however -- you -% will have to typeset one yourself. - -%\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% -% \dospecials -% \catcode`\{=1 \catcode`\}=2 \catcode`\ =10 } - -\def\sanitizeidxletters{\def\do##1{\catcode`##1=11 }% - \do\\\do\$\do\&\do\#\do\^\do\_\do\%\do\~% - \do\@\do\"\do\!\do\|\do\-\do\ \do\'} - -\def\index{%\unskip - \ifx\indexout\UnDeFiNeD - \csname newwrite\endcsname\indexout - \openout\indexout \jobname.idx\fi - \begingroup - \sanitizeidxletters - \indexQii} - -\def\indexQii#1{\endgroup - \write\indexout{\string\indexentry{#1}{\folio}}% - \ignorespaces} - -% The following index style indents subitems on a -% separate lines - -\def\theindex{\begingroup - \parskip0pt \parindent0pt - \def\indexitem##1{\par\hangindent30pt \hangafter1 - \hskip ##1 }% - \def\item{\indexitem{0em}}% - \def\subitem{\indexitem{2em}}% - \def\subsubitem{\indexitem{4em}}% - \def\see{{\it see} \bgroup\aftergroup\gobblegroup\let\dummy=}% - \let\indexspace\medskip} - -\def\endtheindex{\endgroup} - -\def\inputindex{% - \openin0 \jobname.ind - \ifeof0 \closein0 - \message{\jobname.ind missing.}% - \else\closein0 - \begingroup - \def\begin##1{\csname##1\endcsname}% - \def\end##1{\csname end##1\endcsname}% - \input\jobname.ind - \endgroup\fi} - -% Cross-references - -% \openxrefout loads all the TAG-VALUE associations in -% \jobname.xrf and then opens \jobname.xrf as an -% output channel that \xrtag can use - -\def\openxrefout{% - \openin0=\jobname.xrf - \ifeof0 \closein0 - \else \closein0 {\catcode`\\0 \input \jobname.xrf }% - \fi - \expandafter\csname newwrite\endcsname\xrefout - \openout\xrefout=\jobname.xrf -} - -% I'd like to call \openxrefout lazily, but -% unfortunately it produces a bug in MiKTeX. -% So let's call it up front. - -\openxrefout - -% \xrtag{TAG}{VALUE} associates TAG with VALUE. -% Hereafter, \ref{TAG} will output VALUE. -% \xrtag stores its associations in \xrefout. -% \xrtag calls \openxrefout if \jobname.xrf hasn't -% already been opened - -\def\xrtag#1#2{\ifx\xrefout\UnDeFiNeD\openxrefout\fi - {\let\folio0% - \edef\temp{% - \write\xrefout{\string\expandafter\string\gdef - \string\csname\space XREF#1\string\endcsname - {#2}\string\relax}}% - \temp}\ignorespaces} - - -% \ref{TAG} outputs VALUE, assuming \xrtag put such -% an association into \xrefout. \ref calls -% \openxrefout if \jobname.xrf hasn't already -% been opened - -\def\ref#1{\ifx\xrefout\UnDeFiNeD\openxrefout\fi - \expandafter\ifx\csname XREF#1\endcsname\relax - %\message or \write16 ? - \message{\the\inputlineno: Unresolved label `#1'.}?\else - \csname XREF#1\endcsname\fi} - - -% - -\def\writenumberedtocline#1#2#3{% - %#1=depth - %#2=secnum - %#3=title - \tocactivate - \edef\@currentlabel{#2}% - {\let\folio0% - \edef\writetotocQtemp{\write\tocout - {\string\tocentry{#1}{#2}{#3}{\folio}}}% - \writetotocQtemp}} - -\def\tableofcontents{% - \ifx\tocactive0% - \openin0 \jobname.toc - \edef\QatcatcodebeforeToC{% - \noexpand\catcode`\noexpand\@=\the\catcode`\@}% - \catcode`\@=11 - \ifeof0 \closein0 \else - \closein0 \input \jobname.toc - \fi - \QatcatcodebeforeToC - \tocoutensure - \openout\tocout \jobname.toc - \global\let\tocactive1% - \else - \input Z-T-\jobname.tex - \fi} - -% - -\ifx\TZPplain\UnDeFiNeD -\let\maybeloadfollowing\relax -\else -\atcatcodebeforetexzpage -\let\maybeloadfollowing\endinput -\fi\maybeloadfollowing - -% Tally control sequences are cheap count -% registers: they doesn't use up TeX's limited number of -% real count registers. - -% A tally is a macro that expands to the -% number kept track of. Thus \edef\kount{0} defines a -% tally \kount that currently contains 0. - -% \advancetally\kount n increments \kount by n. -% \globaladvancetally increments the global \kount. -% If \kount is not defined, the \[global]advancetally -% macros define it to be 0 before proceeding with the -% incrementation. - -\def\newtally#1{\edef#1{0}} - -\def\advancetallyhelper#1#2#3{% - \ifx#2\UnDeFiNeD - #1\edef#2{0}\fi - \edef\setcountCCLV{\count255=#2 }% - \setcountCCLV - \advance\count255 by #3 - #1\edef#2{\the\count255 }} - -\def\advancetally{\advancetallyhelper\relax} -\def\globaladvancetally{\advancetallyhelper\global} - -% Sections - -\def\tracksectionchangeatlevel#1{% - \expandafter\let\expandafter\thiscount\csname - sectionnumber#1\endcsname - \ifx\thiscount\relax - \expandafter\edef\csname sectionnumber#1\endcsname{0}% - \fi - \expandafter\advancetally - \csname sectionnumber#1\endcsname 1% - \ifx\doingappendix0% - \edef\@currentlabel{\csname sectionnumber1\endcsname}% - \else - %\count255=\expandafter\csname sectionnumber1\endcsname - \edef\@currentlabel{\char\csname sectionnumber1\endcsname}% - \fi - \count255=0 - \loop - \advance\count255 by 1 - \ifnum\count255=1 - \else\edef\@currentlabel{\@currentlabel.\csname - sectionnumber\the\count255\endcsname}\fi - \ifnum\count255<#1% - \repeat - \loop - \advance\count255 by 1 - \expandafter\let\expandafter\nextcount\csname - sectionnumber\the\count255\endcsname - \ifx\nextcount\relax - \let\continue0% - \else - \expandafter\edef\csname - sectionnumber\the\count255\endcsname{0}% - \let\continue1\fi - \ifx\continue1% - \repeat} -\newcount\secnumdepth - -\secnumdepth=3 - -\def\sectiond#1{\count255=#1% - \ifx\usingchapters1\advance\count255 by 1 \fi - \edef\sectiondlvl{\the\count255 }% - \futurelet\sectionnextchar\sectiondispatch} - -\def\sectiondispatch{\ifx\sectionnextchar*% - \def\sectioncontinue{\sectionstar{\sectiondlvl}}\else - \ifnum\sectiondlvl>\secnumdepth - \def\sectioncontinue{\sectionhelp{\sectiondlvl}{}}\else - \tracksectionchangeatlevel{\sectiondlvl}% - \def\sectioncontinue{\sectionhelp{\sectiondlvl}% - {\@currentlabel}}\fi\fi - \sectioncontinue} - -\def\sectionstar#1*{\sectionhelp{#1}{}} - -\def\sectionhelp#1#2{% - \edef\sectiondepth{#1}% - \def\sectionnr{#2}% - \immediate\openout\sectionQscratchfileport Z-sec-temp - \begingroup - \def\do##1{\catcode`##1=11 }\dospecials - \catcode`\{=1 \catcode`\}= 2 - \sectionheader} - -% Vanilla section-header look -- change this macro for new look - -\def\sectionheader#1{\endgroup - \immediate\write\sectionQscratchfileport {#1}% - \immediate\closeout\sectionQscratchfileport - \vskip -\lastskip - \ifnum\sectiondepth>\tocdepth\else - \writenumberedtocline{\sectiondepth}{\sectionnr}{#1}% - \fi - \vskip1.5\bigskipamount - \goodbreak %??? - \noindent - \hbox{\vtop{\pretolerance 10000 - \raggedright - \noindent\bf - \ifx\sectionnr\empty\else - \sectionnr\enspace\fi - \input Z-sec-temp }}% - \nobreak - \smallskip - %\noindent - } - -% \edef\temp{\write\tocout{\string\hskip#1\space em\string\relax\space #2% -% \string\vtop{\string\hsize=.7\string\hsize -% \string\noindent\string\raggedright\space #3}\string\par}}\temp - - - -\def\section{\sectiond1} -\def\subsection{\sectiond2} -\def\subsubsection{\sectiond3} -\def\paragraph{\sectiond4} -\def\subparagraph{\sectiond5} - -\let\usingchapters0 - -\def\chapter{\global\let\usingchapters1% -\global\footnotenumber=0 -\futurelet\chapternextchar\chapterdispatch} - -\def\chapterdispatch{\ifx\chapternextchar*% - \let\chaptercontinue\chapterstar\else - \tracksectionchangeatlevel{1}% - \def\chaptercontinue{\chapterhelp{\@currentlabel}}\fi - \chaptercontinue} - -\def\chapterstar*{\chapterhelp{}} - -\def\chapterhelp#1{% - % #1=number #2=heading-text - \def\chapternr{#1}% - \immediate\openout\sectionQscratchfileport Z-sec-temp - \begingroup - \def\do##1{\catcode`##1=11 }\dospecials - \catcode`\{=1 \catcode`\}=2 - \chapterheader} - -\def\chapterheader#1{\endgroup - \immediate\write\sectionQscratchfileport {#1}% - \immediate\closeout\sectionQscratchfileport - \writenumberedtocline{1}{\chapternr}{#1}% - \vfill\eject - \null\vskip3em - \noindent - \ifx\chapternr\empty\hbox{~}\else - \ifx\doingappendix0% - \hbox{\bf Chapter \chapternr}\else - \hbox{\bf Appendix \chapternr}\fi\fi - \vskip 1em - \noindent - \hbox{\bf\vtop{%\hsize=.7\hsize - \pretolerance 10000 - \noindent\raggedright\input Z-sec-temp }}% - \nobreak\vskip3em - %\noindent - } - -\let\doingappendix=0 - -\def\appendix{\let\doingappendix=1% - \count255=`\A% - \advance\count255 by -1 - \expandafter\edef\csname - sectionnumber1\endcsname{\the\count255 }} - -% Numbered footnotes - -\ifx\plainfootnote\UnDeFiNeD - \let\plainfootnote\footnote -\fi - -\newcount\footnotenumber - -\def\numberedfootnote{\global\advance\footnotenumber 1 - \bgroup\csname footnotehook\endcsname - \plainfootnote{$^{\the\footnotenumber}$}\bgroup - \edef\@currentlabel{\the\footnotenumber}% - \aftergroup\egroup - \let\dummy=} - - -\let\@currentlabel\relax - -% \label, as in LaTeX - -% The sectioning commands -% define \@currentlabel so a subsequent call to \label will pick up the -% right label. - -\def\label#1{\xrtag{#1}{\@currentlabel}% - \xrtag{PAGE#1}{\folio}} - -% \pageref, as in LaTeX - -\def\pageref#1{\ref{PAGE#1}} - - -% - -\def\itemize{\par\begingroup - \advance\leftskip\parindent - \smallbreak - \def\item{\smallbreak\noindent - \llap{$\bullet$\enspace}\ignorespaces}} - -\def\enditemize{\smallbreak\smallbreak\endgroup\par} - -\newtally\enumeratelevel - -\def\enumerate{\par\begingroup - \advancetally\enumeratelevel1% - \newtally\enumeratenumber - \advance\leftskip\parindent - \smallbreak - \def\item{\smallbreak\noindent - \advancetally\enumeratenumber1% - \ifnum\enumeratelevel=1 - \edef\enumeratemark{\enumeratenumber}\else - \ifnum\enumeratelevel=2 - \count255=\enumeratenumber - \advance\count255 by -1 \advance\count255 by `a - \edef\enumeratemark{\noexpand\char\the\count255 }\else - \ifnum\enumeratelevel=3 - \edef\enumeratemark{\Romannumeral\enumeratenumber}\else - \ifnum\enumeratelevel=4 - \count255=\enumeratenumber - \advance\count255 by -1 \advance\count255 by `A - \edef\enumeratemark{\noexpand\char\the\count255 }\else - \edef\enumeratemark{\enumeratenumber}\fi\fi\fi\fi - \edef\@currentlabel{\enumeratemark}% needed? - \llap{\enumeratemark.\enspace}\ignorespaces}} - -\def\endenumerate{\smallbreak\smallbreak\endgroup\par} - -% \path is like \verb except that its argument -% can break across lines at `.' and `/'. - -\ifx\path\UnDeFiNeD -\def\path{\begingroup\verbsetup - \pathfont - \defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}% - \defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}% - \verbQii}% -\fi - -\let\pathfont\relax -% - -% plain's \{left,center,right}line can't handle catcode change -% within their argument - -\def\leftline{\line\bgroup\bgroup - \aftergroup\leftlinefinish - \let\dummy=} - -\def\leftlinefinish{\hss\egroup} - -\def\centerline{\line\bgroup\bgroup - \aftergroup\leftlinefinish - \hss\let\dummy=} - -\def\rightline{\line\bgroup\hss\let\dummy=} - -% -% definitions (useful in reference manuals) - -\def\defun#1{\def\defuntype{#1}% -\medbreak -\line\bgroup - \hbox\bgroup - \aftergroup\enddefun - \vrule width .5ex \thinspace - \vrule \enspace - \vbox\bgroup\setbox0=\hbox{\defuntype}% - \advance\hsize-\wd0 - \advance\hsize-1em - \obeylines - \parindent=0pt - \aftergroup\egroup - \strut - \let\dummy=} - -\def\enddefun{\hfil\defuntype\egroup\smallskip} - -% - -%\def\hr{\smallskip\line{\leaders\hbox{~.~}\hfill}\smallskip} - -% - -\def\sidemargin{\afterassignment\sidemarginQadjustoffset - \hoffset} - -\def\sidemarginQadjustoffset{% - \advance\hoffset -1true in - \advance\hsize -2\hoffset} - -% don't let caps disable end-of-sentence spacing -- assumes we won't use -% dots after caps for abbrevs - -\def\nocapdot{% -\count255=`\A -\loop -\sfcode\the\count255=1000 -\ifnum\count255<`\Z -\advance\count255 by 1 -\repeat -} - -% " --> `` or '' - -\def\smartdoublequotes{% - \defcsactive\"{\futurelet\smartdoublequotesI - \smartdoublequotesII}% - \def\smartdoublequotesII{% - \ifcat\noexpand\smartdoublequotesI a``\else - \if\noexpand\smartdoublequotesI 0``\else - \if\noexpand\smartdoublequotesI 1``\else - \if\noexpand\smartdoublequotesI 2``\else - \if\noexpand\smartdoublequotesI 3``\else - \if\noexpand\smartdoublequotesI 4``\else - \if\noexpand\smartdoublequotesI 5``\else - \if\noexpand\smartdoublequotesI 6``\else - \if\noexpand\smartdoublequotesI 7``\else - \if\noexpand\smartdoublequotesI 8``\else - \if\noexpand\smartdoublequotesI 9``\else - ''\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi\fi}% -} - -% - -\def\emailliketext{\nocapdot\smartdoublequotes} - -% - -\def\gobbleencl{\bgroup - \def\do##1{\catcode`##1=12 }\dospecials - \catcode`\{1 \catcode`\}2 \catcode`\^^M=9 - \futurelet\gobbleenclQnext\gobbleenclQii} - -\def\gobbleenclQii{\ifx\gobbleenclQnext\bgroup - \let\gobbleenclQnext\gobblegroupQii - \else\let\gobbleenclQnext\gobbleenclQiii\fi - \gobbleenclQnext} - -\def\gobbleenclQiii#1{% - \def\gobbleenclQiv##1#1{\egroup}% - \gobbleenclQiv} - -% - -\let\strike\fiverm % can be much better! -% - -\ifx\InputIfFileExists\UnDeFiNeD -\def\InputIfFileExists#1#2#3{% - \IfFileExists{#1}{#2\input #1 }{#3}}% -\fi - -% \packindex declares that subitems be bundled into one -% semicolon-separated paragraph - -\def\packindex{% - \def\theindex{\begingroup - \parskip0pt \parindent0pt - \def\item{\par\hangindent20pt \hangafter1 }% - \def\subitem{\unskip; }% - \def\subsubitem{\unskip; }% - \def\see{\bgroup\it see \aftergroup\gobblegroup\let\dummy=}% - \let\indexspace\medskip}} - -% Use \printindex instead of \inputindex if you want -% the section heading ``Index'' automatically generated. - -\def\printindex{\csname beginsection\endcsname Index\par - \inputindex} - -\def\inputepsf{% -\ifx\pdfoutput\UnDeFiNeD - \input epsf -\else - \input supp-pdf - \def\epsfbox##1{\convertMPtoPDF{##1}{1}{1}}% -\fi -} - -\def\r#1{{\accent23 #1}} - -\def\verbc{\begingroup - \verbsetup\afterassignment\verbcI - \let\verbcII=} - -\def\verbcI{{\verbfont\verbcII}\endgroup} - -\let\E\verbc - -% The current font is cmtt iff fontdimen3 = 0 _and_ -% fontdimen7 != 0 - -\def\noncmttQspecific{\let\noncmttQspecificQdoit y% - \ifdim\the\fontdimen3\the\font=0.0pt - \ifdim\the\fontdimen7\the\font=0.0pt - \let\noncmttQspecificQdoit n\fi\fi - \ifx\noncmttQspecificQdoit y% - \defcsactive\<{\relax\char`\<}% - \defcsactive\>{\relax\char`\>}% - \defcsactive\-{\variablelengthhyphen}% - \fi} - -% In a nonmonospaced font, - followed by a letter -% is a regular hyphen. Followed by anything else, it is a -% typewriter hyphen. - -\def\variablelengthhyphen{\futurelet\variablelengthhyphenI - \variablelengthhyphenII} - -\def\variablelengthhyphenII{\ifcat\noexpand\variablelengthhyphenI - a-\else{\tt\char`\-}\fi} - -% uppercase version of \romannumeral - -\def\Romannumeral{\afterassignment\RomannumeralI\count255=} - -\def\RomannumeralI{\uppercase\expandafter{\romannumeral\the\count255 }} - -% \xrdef, as in Eplain - -\def\xrdef#1{\xrtag{#1}{\folio}} - -% - -\def\quote{\bgroup\narrower\smallbreak} -\def\endquote{\smallbreak\egroup} - - -\ifx\frac\UnDeFiNeD -\def\frac#1/#2{{#1\over#2}}% -\fi - -\ifx\bull\UnDeFiNeD -\def\bull{$\bullet$}% -\fi - -% \mailto{ADDRESS} becomes -% ADDRESS in HTML, and -% ADDRESS in DVI. - -\let\mailto\url - -\def\raggedleft{% - \leftskip 0pt plus 1fil - \parfillskip 0pt -} - -%\def\rawhtml{\errmessage{Can't occur outside -% \string\htmlonly}} -%\def\endrawhtml{\errmessage{Can't occur outside -% \string\htmlonly}} - -\let\rawhtml\iffalse -\let\endrawhtml\fi - -\let\htmlheadonly\iffalse -\let\endhtmlheadonly\fi - -\let\cssblock\iffalse -\let\endcssblock\fi - -\def\inputcss#1 {\relax} -\let\htmladdimg\gobblegroup - -\def\htmlref{\bgroup\aftergroup\gobblegroup\let\dummy=} - -% - -\let\htmlcolophon\gobblegroup -\let\htmldoctype\gobblegroup -\let\htmlmathstyle\gobblegroup - -\let\slatexlikecomments\relax -\let\noslatexlikecomments\relax - -\let\imgpreamble\iffalse -\let\endimgpreamble\fi - -\def\inputexternallabels#1 {\relax} -\def\includeexternallabels#1 {\relax} - -\ifx\eval\UnDeFiNeD -\IfFileExists{eval4tex.tex}{\input eval4tex }{}\fi - -\let\evalh\gobblegroup -\let\evalq\gobblegroup - -\let\htmlpagebreak\relax - -\let\htmlpagelabel\gobblegroup - -\def\htmlpageref{\errmessage{Can't occur except inside - \string\htmlonly}} - -% Miscellaneous stuff - -%\def\hr{$$\hbox{---}$$} -\def\hr{\medbreak\centerline{---}\medbreak} -%\def\hr{\par\centerline{$*$}\par} - - -\let\htmlimageformat\gobblegroup -\let\htmlimageconversionprogram\gobblegroup - -\let\externaltitle\gobblegroup -\let\ignorenextinputtimestamp\relax - -% - -\let\htmladvancedentities\relax -\let\n\noindent -\let\p\verb -\let\q\scm -\let\f\numberedfootnote -\let\scmp\scm -\let\numfootnote\numberedfootnote -\let\writetotoc\writenumberedtocline -\let\tag\xrtag -\let\scmfilename\verbwritefile -\let\scmwrite\verbwrite - -% - -\atcatcodebeforetexzpage - -% end of file diff --git a/man/man1/tex2page.1 b/man/man1/tex2page.1 deleted file mode 100644 index cb289eeb2a..0000000000 --- a/man/man1/tex2page.1 +++ /dev/null @@ -1,174 +0,0 @@ -.TH TEX2PAGE 1 "2007-02-21" \"last change -.SH NAME - -tex2page \- makes Web pages from LaTeX and plain-TeX documents - -.SH SYNOPSIS - - tex2page --help - tex2page --version - tex2page - -.SH DESCRIPTION - -The command - - tex2page - -converts the TeX source file to the HTML file -.html, where is the basename of . -Some auxiliary HTML files and some image files may also be -created. - -The argument can be a full or relative pathname. If -the latter, it is reckoned relative to the current directory. -The extension may be omitted if it is .tex. - -In order to resolve cross-references, it may be necessary to -invoke tex2page a couple of times. The log displayed on the -console will inform you if such is the case. This log is also -saved in the file .hlog. - -If tex2page is called with the option `--help', it prints a help -message and exits. - -If tex2page is called with the option `--version', it prints -version information and exits. - -If tex2page is called without an argument, or if the argument is -neither a valid option nor an existing file, then tex2page prints -a brief help message and exits. If you repeatedly (i.e., five or -more times) call it faultily despite its helpful advice, tex2page -will visibly lose its patience. - -The complete documentation for tex2page is included in the -tex2page distribution, and may also be viewed on the Web at - - http://www.ccs.neu.edu/~dorai/tex2page/tex2page-doc.html - -.SH SEARCH PATH FOR TeX FILES - -tex2page uses the same search path as TeX to search for -\einput and \eopenin files. The default search path is -implementation-dependent but can be changed by setting the -environment variable TEXINPUTS to a list of colon-separated -directories. (If you wish to merely prepend your list to the -default list, end your list with a colon.) - -Add two trailing forward slashes to any directory in TEXINPUTS -that you want to recursively search all subdirectories of. - -If the environment variable TIIPINPUTS is set, tex2page will -use the TIIPINPUTS value as its search path instead of -TEXINPUTS. TIIPINPUTS does not support the double-slash -mechanism of TEXINPUTS. - -.SH EDITING ON ERROR - -If tex2page encounters a fatal error in the document, it -displays the prompt - - Type e to edit file at point of error; x to quit - ? - -If you type x, tex2page immediately exits. - -If however you type e, a text editor is fired up, showing the -offending file -- which may or may not be the main input file -- -at the line containing the error. The particular editor chosen -and the arguments with which it is called depends on the -environment variables TEXEDIT or EDITOR. - -If the environment variable TEXEDIT is set, tex2page uses its -string value as the editor call to use. A possible value for -TEXEDIT is "vim +%d %s". This calls the editor vim with %s -replaced by the offending file's name, and %d replaced by the -number of the offending line. - -If TEXEDIT is not set, the value of the environment variable -EDITOR is chosen as the editor. Unlike TEXEDIT -which contains the editor call as a template, EDITOR contains -simply the editor's name. If EDITOR is also not set, vi is -chosen as the editor. - -The editor specified in EDITOR is called with the arguments -" + ", where is the offending file's name and is the -offending line number. It is not possible to alter the way the -file and line arguments are supplied, but fortunately this style -is accepted by vi, emacs, and all their clones. If you use an -editor that requires a different argument style, use TEXEDIT. - -.SH DIRECTORY FOR HTML PAGES - -By default, tex2page generates its output HTML files in the -current directory. You can specify a different directory by -naming it in one of the following files: - - .hdir in the current directory, or - .tex2page.hdir in the current directory, or - .tex2page.hdir in your home directory; - -where is the basename of the input document. The -first of these three files that exists overrides the rest. - -The name in the .hdir file can be, or contain, the TeX -control-sequence \ejobname, which expands to , the -basename of the input document. - -.SH DOCUMENT-SPECIFIC MACROS - -Before processing a TeX source file whose basename is -, tex2page will automatically load the file -.t2p, if it exists. .t2p is a good place -to put macros that are specific to the HTML version of the -document. - -.SH GENERAL MACROS - -tex2page recognizes some commands that are not supplied in -the LaTeX or plain-TeX formats -- typically these are -commands that add value to the HTML output. In order to keep -an input document that uses these extra commands processable -by TeX, working TeX definitions are provided in the TeX macro -file tex2page.tex and the LaTeX macro package file -tex2page.sty. Copy these macro files from the tex2page -distribution to a directory in your TEXINPUTS. - -Plain-TeX documents can use - - \einput tex2page - -while LaTeX documents can use - - \eusepackage{tex2page} - -.SH SYSTEM REQUIREMENTS - -tex2page runs on Scheme or Common Lisp. It may also make use -of the following programs: BibTeX, MakeIndex, Ghostscript, -Dvips, MetaPost, and the NetPBM library. - -Out of the box, tex2page runs in Racket, but the distribution -includes configuration information to allow tex2page to run on -a variety of Scheme and Common Lisp implementations. See file -INSTALL. - -.SH BUGS - -Email to dorai @ ccs.neu.edu. - -.SH SEE ALSO - -tex(1), latex(1), mzscheme(1), bibtex(1), makeindex(1L), -mpost(1). - -.SH COPYRIGHT - -Copyright 1997-2012 by Dorai Sitaram. - -Permission to distribute and use this work for any purpose is -hereby granted provided this copyright notice is included in -the copy. This work is provided as is, with no warranty of any -kind. - -.nx