suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: aaaea309862ae344cc0fd8ad10d8e504b158771f
This commit is contained in:
Robby Findler 2000-06-19 18:06:06 +00:00
parent cc5712aab2
commit c1467860ae
1025 changed files with 11 additions and 399848 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/help/help.ss
View File

@ -23,6 +23,17 @@
(begin-elaboration-time (begin-elaboration-time
(require-library "invoke.ss")) (require-library "invoke.ss"))
(define-values/invoke-unit/sig
help:get-info^
(unit/sig help:get-info^
(import)
(define (get-language-level)
'unknown)
(define (get-teachpack-names)
'unknown))
drscheme:export:help-info)
(define frame-mixin values) (define frame-mixin values)
(define (user-defined-doc-position x) #f) (define (user-defined-doc-position x) #f)

8
collects/net/base64.ss
View File

@ -1,8 +0,0 @@
(require-relative-library "base64s.ss")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:base64^
(require-relative-library "base64r.ss"))

68
collects/net/base64r.ss
View File

@ -1,68 +0,0 @@
(unit/sig mzlib:base64^
(import)
(define (base64-encode src)
; Always includes a terminator
(let* ([len (string-length src)]
[new-len (let ([l (add1 (ceiling (* len 8/6)))])
; Break l into 72-character lines.
; Insert CR/LF between each line.
(+ l (* (quotient l 72) 2)))]
[dest (make-string new-len #\0)]
[char-map (list->vector
(let ([each-char (lambda (s e)
(let loop ([l null][i (char->integer e)])
(if (= i (char->integer s))
(cons s l)
(loop (cons (integer->char i)
l)
(sub1 i)))))])
(append
(each-char #\A #\Z)
(each-char #\a #\z)
(each-char #\0 #\9)
(list #\+ #\/))))])
(let loop ([bits 0][v 0][col 0][srcp 0][destp 0])
(cond
[(= col 72)
; Insert CRLF
(string-set! dest destp #\return)
(string-set! dest (add1 destp) #\linefeed)
(loop bits
v
0
srcp
(+ destp 2))]
[(and (= srcp len)
(<= bits 6))
; That's all, folks.
; Write the last few bits.
(begin
(string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits))))
(add1 destp))
(if (= col 71)
; Have to write CRLF before terminator
(begin
(string-set! dest (+ destp 1) #\return)
(string-set! dest (+ destp 2) #\linefeed)
(string-set! dest (+ destp 3) #\=))
(string-set! dest (add1 destp) #\=))
dest]
[(< bits 6)
; Need more bits.
(loop (+ bits 8)
(bitwise-ior (arithmetic-shift v 8)
(char->integer (string-ref src srcp)))
col
(add1 srcp)
destp)]
[else
; Write a char.
(string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits))))
(loop (- bits 6)
(bitwise-and v (sub1 (arithmetic-shift 1 (- bits 6))))
(add1 col)
srcp
(add1 destp))])))))

3
collects/net/base64s.ss
View File

@ -1,3 +0,0 @@
(define-signature mzlib:base64^
(base64-encode))

8
collects/net/cgi.ss
View File

@ -1,8 +0,0 @@
(require-library "cgiu.ss" "net")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:cgi^
mzlib:cgi@)

313
collects/net/cgir.ss
View File

@ -1,313 +0,0 @@
(unit/sig mzlib:cgi^
(import)
;; type bindings = list ((symbol . string))
;; --------------------------------------------------------------------
;; Exceptions:
(define-struct cgi-error ())
;; chars : list (char)
;; -- gives the suffix which is invalid, not including the `%'
(define-struct (incomplete-%-suffix struct:cgi-error) (chars))
;; char : char
;; -- an invalid character in a hex string
(define-struct (invalid-%-suffix struct:cgi-error) (char))
;; --------------------------------------------------------------------
;; query-chars->string :
;; list (char) -> string
;; -- The input is the characters post-processed as per Web specs, which
;; is as follows:
;; spaces are turned into "+"es and lots of things are turned into %XX,
;; where XX are hex digits, eg, %E7 for ~. The output is a regular
;; Scheme string with all the characters converted back.
(define query-chars->string
(lambda (chars)
(list->string
(let loop ((chars chars))
(if (null? chars) null
(let ((first (car chars))
(rest (cdr chars)))
(let-values (((this rest)
(cond
((char=? first #\+)
(values #\space rest))
((char=? first #\%)
(if (and (pair? rest)
(pair? (cdr rest)))
(values
(integer->char
(or (string->number
(string
(car rest) (cadr rest))
16)
(raise (make-invalid-%-suffix
(if (string->number
(string (car rest))
16)
(cadr rest)
(car rest))))))
(cddr rest))
(raise
(make-incomplete-%-suffix rest))))
(else
(values first rest)))))
(cons this (loop rest)))))))))
;; string->html :
;; string -> string
;; -- the input is raw text, the output is HTML appropriately quoted
(define string->html
(lambda (s)
(apply string-append
(map (lambda (c)
(case c
((#\<) "&lt;")
((#\>) "&gt;")
((#\&) "&amp;")
(else (string c))))
(string->list s)))))
(define default-text-color "#000000")
(define default-bg-color "#ffffff")
(define default-link-color "#cc2200")
(define default-vlink-color "#882200")
(define default-alink-color "#444444")
;; generate-html-output :
;; html-string x list (html-string) x ... -> ()
(define generate-html-output
(opt-lambda (title body-lines
(text-color default-text-color)
(bg-color default-bg-color)
(link-color default-link-color)
(vlink-color default-vlink-color)
(alink-color default-alink-color))
(let ((sa string-append))
(for-each
(lambda (l)
(display l) (newline))
`("Content-type: text/html"
""
"<html>"
"<!-- The form was processed, and this document was generated,"
" using the CGI utilities for MzScheme. For more information"
" on MzScheme, see"
" http://www.cs.rice.edu/CS/PLT/packages/mzscheme/"
" and for the CGI utilities, contact Shriram Krishnamurthi"
" (shriram@cs.rice.edu). -->"
"<head>"
,(sa "<title>" title "</title>")
"</head>"
""
,(sa "<body bgcolor=\"" bg-color "\" text=\"" text-color "\"")
,(sa " link=\"" link-color "\"")
,(sa " vlink=\"" vlink-color "\" alink=\"" alink-color "\">")
""
,@body-lines
""
"</body>"
"</html>")))))
;; read-until-char :
;; iport x char -> list (char) x bool
;; -- operates on the default input port; the second value indicates
;; whether reading stopped because an EOF was hit (as opposed to the
;; delimiter being seen); the delimiter is not part of the result
(define read-until-char
(lambda (ip delimiter)
(let loop ((chars '()))
(let ((c (read-char ip)))
(cond
((eof-object? c)
(values (reverse chars) #t))
((char=? c delimiter)
(values (reverse chars) #f))
(else
(loop (cons c chars))))))))
;; read-name+value :
;; iport -> (symbol + bool) x (string + bool) x bool
;; -- If the first value is false, so is the second, and the third is
;; true, indicating EOF was reached without any input seen. Otherwise,
;; the first and second values contain strings and the third is either
;; true or false depending on whether the EOF has been reached. The
;; strings are processed to remove the CGI spec "escape"s.
;; This code is _slightly_ lax: it allows an input to end in `&'. It's
;; not clear this is legal by the CGI spec, which suggests that the last
;; value binding must end in an EOF. It doesn't look like this matters.
;; It would also introduce needless modality and reduce flexibility.
(define read-name+value
(lambda (ip)
(let-values
(((name eof?)
(read-until-char ip #\=)))
(cond
((and eof? (null? name))
(values #f #f #t))
(eof?
(generate-error-output
(list "Server generated malformed input for POST method:"
(string-append
"No binding for `" (list->string name) "' field."))))
(else
(let-values (((value eof?)
(read-until-char ip #\&)))
(values (string->symbol (query-chars->string name))
(query-chars->string value)
eof?)))))))
;; get-bindings/post :
;; () -> bindings
(define get-bindings/post
(lambda ()
(let-values (((name value eof?)
(read-name+value
(current-input-port))))
(cond
((and eof? (not name))
null)
((and eof? name)
(list (cons name value)))
(else
(cons (cons name value)
(get-bindings/post)))))))
;; get-bindings/get :
;; () -> bindings
(define get-bindings/get
(lambda ()
(let ((p (open-input-string
(getenv "QUERY_STRING"))))
(let loop ()
(let-values (((name value eof?)
(read-name+value p)))
(cond
((and eof? (not name))
null)
((and eof? name)
(list (cons name value)))
(else
(cons (cons name value)
(loop)))))))))
;; get-bindings :
;; () -> bindings
(define get-bindings
(lambda ()
(if (string=? (get-cgi-method) "POST")
(get-bindings/post)
(get-bindings/get))))
;; generate-error-output :
;; list (html-string) -> <exit>
(define generate-error-output
(lambda (error-message-lines)
(generate-html-output "Internal Error"
error-message-lines)
(exit)))
;; bindings-as-html :
;; bindings -> list (html-string)
;; -- formats name-value bindings as HTML appropriate for displaying
(define bindings-as-html
(lambda (bindings)
`("<code>"
,@(map
(lambda (bind)
(string-append
(symbol->string (car bind))
"&nbsp;--&gt;&nbsp;"
(cdr bind)
"<br>"))
bindings)
"</code>")))
;; extract-bindings :
;; (string + symbol) x bindings -> list (string)
;; -- Extracts the bindings associated with a given name. The semantics
;; of forms states that a CHECKBOX may use the same NAME field multiple
;; times. Hence, a list of strings is returned. Note that the result
;; may be the empty list.
(define extract-bindings
(lambda (field-name bindings)
(let ((field-name (if (symbol? field-name) field-name
(string->symbol field-name))))
(let loop ((found null) (bindings bindings))
(if (null? bindings)
found
(if (equal? field-name (caar bindings))
(loop (cons (cdar bindings) found) (cdr bindings))
(loop found (cdr bindings))))))))
;; extract-binding/single :
;; (string + symbol) x bindings -> string
;; -- used in cases where only one binding is supposed to occur
(define extract-binding/single
(lambda (field-name bindings)
(let ((field-name (if (symbol? field-name) field-name
(string->symbol field-name))))
(let ((result (extract-bindings field-name bindings)))
(cond
((null? result)
(generate-error-output
`(,(string-append "No binding for field `"
(if (symbol? field-name)
(symbol->string field-name)
field-name)
"' in <p>")
,@(bindings-as-html bindings))))
((null? (cdr result))
(car result))
(else
(generate-error-output
`(,(string-append "Multiple bindings for field `"
(if (symbol? field-name)
(symbol->string field-name)
field-name)
"' where only one was expected in <p>")
,@(bindings-as-html bindings)))))))))
;; get-cgi-method :
;; () -> string
;; -- string is either GET or POST (though future extension is possible)
(define get-cgi-method
(lambda ()
(getenv "REQUEST_METHOD")))
;; generate-link-text :
;; string x html-string -> html-string
(define generate-link-text
(lambda (url anchor-text)
(string-append "<a href=\"" url "\">" anchor-text "</a>")))
;; ====================================================================
)

24
collects/net/cgis.ss
View File

@ -1,24 +0,0 @@
(require-library "macro.ss")
(define-signature mzlib:cgi^
(
;; -- exceptions raised --
(struct cgi-error ())
(struct incomplete-%-suffix (chars))
(struct invalid-%-suffix (char))
;; -- cgi methods --
get-bindings
get-bindings/post
get-bindings/get
generate-html-output
generate-error-output
bindings-as-html
extract-bindings
extract-binding/single
get-cgi-method
;; -- general HTML utilities --
string->html
generate-link-text
))

4
collects/net/cgiu.ss
View File

@ -1,4 +0,0 @@
(require-library "refer.ss")
(require-library "cgis.ss" "net")
(define mzlib:cgi@ (require-library-unit/sig "cgir.ss" "net"))

8
collects/net/dns.ss
View File

@ -1,8 +0,0 @@
(require-relative-library "dnss.ss")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:dns^
(require-relative-library "dnsr.ss"))

293
collects/net/dnsr.ss
View File

@ -1,293 +0,0 @@
(unit/sig mzlib:dns^
(import)
(define types
'((a 1)
(ns 2)
(md 3)
(mf 4)
(cname 5)
(soa 6)
(mb 7)
(mg 8)
(mr 9)
(null 10)
(wks 11)
(ptr 12)
(hinfo 13)
(minfo 14)
(mx 15)
(txt 16)))
(define classes
'((in 1)
(cs 2)
(ch 3)
(hs 4)))
(define (cossa i l)
(cond
[(null? l) #f]
[(equal? (cadar l) i)
(car l)]
[else (cossa i (cdr l))]))
(define (number->octet-pair n)
(list (integer->char (arithmetic-shift n -8))
(integer->char (modulo n 256))))
(define (octet-pair->number a b)
(+ (arithmetic-shift (char->integer a) 8)
(char->integer b)))
(define (octet-quad->number a b c d)
(+ (arithmetic-shift (char->integer a) 24)
(arithmetic-shift (char->integer b) 16)
(arithmetic-shift (char->integer c) 8)
(char->integer d)))
(define (name->octets s)
(let ([do-one (lambda (s)
(cons
(integer->char (string-length s))
(string->list s)))])
(let loop ([s s])
(let ([m (regexp-match "^([^.]*)[.](.*)" s)])
(if m
(append
(do-one (cadr m))
(loop (caddr m)))
(append
(do-one s)
(list #\nul)))))))
(define (make-std-query-header id question-count)
(append
(number->octet-pair id)
(list #\001 #\nul) ; Opcode & flags (recusive flag set)
(number->octet-pair question-count)
(number->octet-pair 0)
(number->octet-pair 0)
(number->octet-pair 0)))
(define (make-query id name type class)
(append
(make-std-query-header id 1)
(name->octets name)
(number->octet-pair (cadr (assoc type types)))
(number->octet-pair (cadr (assoc class classes)))))
(define (add-size-tag m)
(append (number->octet-pair (length m)) m))
(define (rr-data rr)
(cadddr (cdr rr)))
(define (rr-type rr)
(cadr rr))
(define (rr-name rr)
(car rr))
(define (parse-name start reply)
(let ([v (char->integer (car start))])
(cond
[(zero? v)
; End of name
(values #f (cdr start))]
[(zero? (bitwise-and #xc0 v))
; Normal label
(let loop ([len v][start (cdr start)][accum null])
(cond
[(zero? len)
(let-values ([(s start) (parse-name start reply)])
(let ([s0 (list->string (reverse! accum))])
(values (if s
(string-append s0 "." s)
s0)
start)))]
[else (loop (sub1 len) (cdr start) (cons (car start) accum))]))]
[else
; Compression offset
(let ([offset (+ (arithmetic-shift (bitwise-and #x3f v) 8)
(char->integer (cadr start)))])
(let-values ([(s ignore-start) (parse-name (list-tail reply offset) reply)])
(values s (cddr start))))])))
(define (parse-rr start reply)
(let-values ([(name start) (parse-name start reply)])
(let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
[start (cddr start)])
(let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
[start (cddr start)])
(let ([ttl (octet-quad->number (car start) (cadr start)
(caddr start) (cadddr start))]
[start (cddddr start)])
(let ([len (octet-pair->number (car start) (cadr start))]
[start (cddr start)])
; Extract next len bytes for data:
(let loop ([len len][start start][accum null])
(if (zero? len)
(values (list name type class ttl (reverse! accum))
start)
(loop (sub1 len) (cdr start) (cons (car start) accum))))))))))
(define (parse-ques start reply)
(let-values ([(name start) (parse-name start reply)])
(let ([type (car (cossa (octet-pair->number (car start) (cadr start)) types))]
[start (cddr start)])
(let ([class (car (cossa (octet-pair->number (car start) (cadr start)) classes))]
[start (cddr start)])
(values (list name type class) start)))))
(define (parse-n parse start reply n)
(let loop ([n n][start start][accum null])
(if (zero? n)
(values (reverse! accum) start)
(let-values ([(rr start) (parse start reply)])
(loop (sub1 n) start (cons rr accum))))))
(define (dns-query nameserver addr type class)
(unless (assoc type types)
(raise-type-error 'dns-query "DNS query type" type))
(unless (assoc class classes)
(raise-type-error 'dns-query "DNS query class" class))
(let* ([query (make-query (random 256) addr type class)]
[reply
(let-values ([(r w) (tcp-connect nameserver 53)])
(dynamic-wind
void
(lambda ()
(display (list->string (add-size-tag query)) w)
(flush-output w)
(let ([a (read-char r)]
[b (read-char r)])
(let ([len (octet-pair->number a b)])
(let ([s (read-string len r)])
(unless (= len (string-length s))
(error 'dns-query "unexpected EOF from server"))
(string->list s)))))
(lambda ()
(close-input-port r)
(close-output-port w))))])
; First two bytes must match sent message id:
(unless (and (char=? (car reply) (car query))
(char=? (cadr reply) (cadr query)))
(error 'dns-query "bad reply id from server"))
(let ([v0 (caddr reply)]
[v1 (cadddr reply)])
; Check for error code:
(let ([rcode (bitwise-and #xf (char->integer v1))])
(unless (zero? rcode)
(error 'dns-query "error from server: ~a"
(case rcode
[(1) "format error"]
[(2) "server failure"]
[(3) "name error"]
[(4) "not implemented"]
[(5) "refused"]))))
(let ([qd-count (octet-pair->number (list-ref reply 4) (list-ref reply 5))]
[an-count (octet-pair->number (list-ref reply 6) (list-ref reply 7))]
[ns-count (octet-pair->number (list-ref reply 8) (list-ref reply 9))]
[ar-count (octet-pair->number (list-ref reply 10) (list-ref reply 11))])
(let ([start (list-tail reply 12)])
(let*-values ([(qds start) (parse-n parse-ques start reply qd-count)]
[(ans start) (parse-n parse-rr start reply an-count)]
[(nss start) (parse-n parse-rr start reply ns-count)]
[(ars start) (parse-n parse-rr start reply ar-count)])
(unless (null? start)
(error 'dns-query "error parsing server reply"))
(values (positive? (bitwise-and #x4 (char->integer v0)))
qds ans nss ars reply)))))))
(define cache (make-hash-table))
(define (dns-query/cache nameserver addr type class)
(let ([key (string->symbol (format "~a;~a;~a;~a" nameserver addr type class))])
(let ([v (hash-table-get cache key (lambda () #f))])
(if v
(apply values v)
(let-values ([(auth? qds ans nss ars reply) (dns-query nameserver addr type class)])
(hash-table-put! cache key (list auth? qds ans nss ars reply))
(values auth? qds ans nss ars reply))))))
(define (ip->string s)
(format "~a.~a.~a.~a"
(char->integer (list-ref s 0))
(char->integer (list-ref s 1))
(char->integer (list-ref s 2))
(char->integer (list-ref s 3))))
(define (try-forwarding k nameserver)
(let loop ([nameserver nameserver][tried (list nameserver)])
; Normally the recusion is done for us, but it's technically optional
(let-values ([(v ars auth?) (k nameserver)])
(or v
(and (not auth?)
(let* ([ns (ormap
(lambda (ar)
(and (eq? (rr-type ar) 'a)
(ip->string (rr-data ar))))
ars)])
(and ns
(not (member ns tried))
(loop ns (cons ns tried)))))))))
(define (dns-get-address nameserver addr)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'a 'in)])
(values (and (positive? (length ans))
(let ([s (rr-data (car ans))])
(ip->string s)))
ars auth?)))
nameserver)
(error 'dns-get-address "bad address")))
(define (dns-get-mail-exchanger nameserver addr)
(or (try-forwarding
(lambda (nameserver)
(let-values ([(auth? qds ans nss ars reply) (dns-query/cache nameserver addr 'mx 'in)])
(values (let loop ([ans ans][best-pref +inf.0][exchanger #f])
(cond
[(null? ans) (or exchanger
;; Does 'soa mean that the input address is fine?
(and (ormap
(lambda (ns) (eq? (rr-type ns) 'soa))
nss)
addr))]
[else
(let ([d (rr-data (car ans))])
(let ([pref (octet-pair->number (car d) (cadr d))])
(if (< pref best-pref)
(let-values ([(name start) (parse-name (cddr d) reply)])
(loop (cdr ans) pref name))
(loop (cdr ans) best-pref exchanger))))]))
ars auth?)))
nameserver)
(error 'dns-get-mail-exchanger "bad address")))
(define (dns-find-nameserver)
(case (system-type)
[(unix) (with-handlers ([void (lambda (x) #f)])
(with-input-from-file "/etc/resolv.conf"
(lambda ()
(let loop ()
(let ([l (read-line)])
(or (and (string? l)
(let ([m (regexp-match
(format "nameserver[ ~a]+([0-9]+[.][0-9]+[.][0-9]+[.][0-9]+)" #\tab)
l)])
(and m (cadr m))))
(and (not (eof-object? l))
(loop))))))))]
[else #f])))

5
collects/net/dnss.ss
View File

@ -1,5 +0,0 @@
(define-signature mzlib:dns^
(dns-get-address
dns-get-mail-exchanger
dns-find-nameserver))

999
collects/net/doc.txt
View File

@ -1,999 +0,0 @@
Time-stamp: <99/10/22 12:42:59 shriram>
The `net' collection contains libraries that provide access to the
following _Internet_ (quasi-)protocols:
URL parsing
CGI backends
sendmail
SMTP
NNTP
POP-3
IMAP
Mail header reading and writing
DNS
Shriram Krishnamurthi
shriram@cs.rice.edu
Matthew Flatt
mflatt@cs.utah.edu
==========================================================================
_URL_ posting, _web clients_, _WWW_
==========================================================================
Collection: net
Files: _url.ss_, _urlr.ss_, _urls.ss_, _urlu.ss_
ABSTRACT -------------------------------------------------------------
The url package manages features of URLs.
TYPES ----------------------------------------------------------------
> url
struct url (scheme host port path params query fragment)
scheme : string or #f
host : string or #f
port : number or #f
path : string
params : string or #f
query : string or #f
fragment : string or #f
The basic structure for all URLs.
http://www.cs.rice.edu:80/cgi-bin/finger;xyz?name=shriram&host=nw#top
1 2 3 4 5 6 7
1 = scheme, 2 = host, 3 = port, 4 = path,
5 = params, 6 = query, 7 = fragment
> pure-port
A pure port is one from which the MIME headers have been removed, so
that what remains is purely the first content fragment.
> mime-header
struct mime-header (name value)
name : string
value : string
MIME header.
PROCEDURES -----------------------------------------------------------
> (unixpath->path string) -> path-string
Given a path from a URL structure, turns it into a path that
conforms to the local OS path specifications. Useful for file
accesses on the local disk system.
> (get-pure-port url [list-of-strings]) -> input-port
Takes a URL and returns a pure port corresponding to it. Writes the
optional strings to the server.
> (get-impure-port url [list-of-strings]) -> input-port
Takes a URL and returns an impure port corresponding to it. Writes
the optional strings to the server.
> (display-pure-port input-port) -> void
Writes the output of a pure port. For debugging purposes.
> (purify-port input-port) -> list-of-mime-headers
Purifies a port, returning the MIME headers.
> (string->url string) -> url
Turns a string into a URL.
> (netscape/string->url string) -> url
Turns a string into a URL, applying (what appear to be) Netscape's
conventions on automatically specifying the scheme: a string
starting with a slash gets the scheme "file", while all others get
the scheme "http".
> (url->string url) -> string
Generates a string corresponding to the contents of the url struct.
> (call/input-url url url->port-proc port->void-proc [list-of-strings]) -> void
First argument is the URL to open. Second is a procedure that takes
a URL and turns it into a (pure or impure) port. The third takes
the (pure or impure) port and handles its contents. The optional
fourth argument is a set of strings to send to the server.
> (combine-url/relative url string) -> url
Given a base URL and a relative path, combines the two and returns a
new URL.
EXAMPLE --------------------------------------------------------------
(require-library "url.ss" "net")
(define url:cs (string->url "http://www.cs.rice.edu/"))
(define url:me (string->url "http://www.cs.rice.edu/~shriram/"))
(define comb combine-url/relative)
(define (test url)
(call/input-url url get-pure-port display-pure-port))
(test url:cs)
==========================================================================
_CGI_ backends, _WWW_
==========================================================================
Collection: net
Libraries: _cgi.ss_, _cgic.ss_, _cgir.ss_, _cgis.ss_, _cgiu.ss_
ABSTRACT -------------------------------------------------------------
The cgi package helps programmers write scripts that follow the Common
Gateway Interface (CGI) protocol of the World-Wide Web.
TYPES ----------------------------------------------------------------
binding:
A binding is an association of a form item with its value. Some form
items (such as checkboxes) may correspond to multiple bindings. A
binding is a tag-string pair, where a tag is a symbol or a string.
bindings:
A list of `binding's.
html-string:
A text string that has been escaped according to HTML conventions.
EXCEPTIONS -----------------------------------------------------------
> cgi-error
struct cgi-error ()
cgi-error is a super-structure for all exceptions thrown by this
library.
> incomplete-%-suffix
struct (incomplete-%-suffix cgi-error) (chars)
chars : list of chars
Used when a % in a query is followed by an incomplete suffix. The
characters of the suffix -- excluding the "%" -- are provided by the
exception.
> invalid-%-suffix
struct (invalid-%-suffix cgi-error) (char)
char : char
Used when the character immediately following a % in a query is
invalid.
PROCEDURES -----------------------------------------------------------
> (get-bindings) -> bindings
> (get-bindings/post) -> bindings
> (get-bindings/get) -> bindings
Returns the bindings that corresponding to the options specified by
the user. The /post and /get forms work only when POST and GET
forms are used, respectively, while get-bindings determines the kind
of form that was used and invokes the appropriate function.
> (extract-bindings symbol-or-string bindings) -> list of strings
Given a key and a set of bindings, extract-bindings determines which
ones correspond to a given key. There may be zero, one, or many
associations for a given key.
> (extract-binding/single symbol-or-string bindings) -> string
Given a key and a set of bindings, extract-binding/single ensures
that the key has exactly one association, and returns it.
> (generate-html-output html-string list-of-html-strings [color color color color color]) -> void
The first argument is the title. The second is a list of strings
that consist of the body. The last five arguments are each strings
representing a HTML color; in order, they represent the color of the
text, the background, un-visited links, visited links, and a link
being selected.
> (string->html string) -> html-string
Converts a string into an html-string by applying the appropriate
HTML quoting conventions.
> (generate-link-text string html-string) -> html-string
Takes a string representing a URL, a html-string for the anchor
text, and generates HTML corresponding to an achor.
> (generate-error-output list-of-html-strings) -> <exit>
The procedure takes a series of strings representing the body,
prints them with the subject line "Internal error", and forces the
script to exit.
> (get-cgi-method) -> string
Returns either "GET" or "POST". Always returns a string when
invoked inside a CGI script. Unpredictable otherwise.
> (bindings-as-html bindings) -> list of html-strings
Converts a set of bindings into a list of html-string's. Useful for
debugging.
==========================================================================
_sending mail_, _sendmail_
==========================================================================
Collection: net
Files: _mail.ss_, _mailr.ss_, _mails.ss_, _mailu.ss_
ABSTRACT -------------------------------------------------------------
The mail package helps programmers write programs that need to send
electronic mail messages. The package assumes the existence of a
conformant sendmail program on the local system; see also the SMTP
package, below.
TYPES ----------------------------------------------------------------
All strings used in mail messages are assumed to conform to their
corresponding SMTP specifications, except as noted otherwise.
EXCEPTIONS -----------------------------------------------------------
> no-mail-recipients
struct (no-mail-recipients exn) ()
Raised when no mail recipients were specified.
PROCEDURES -----------------------------------------------------------
> (send-mail-message/port from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string) -> output-port
The first argument is the header for the sender, the second is the
subject line, the third a list of To: recipients, the fourth a list
of CC: recipients, and the fifth a list of BCC: recipients. The
optional sixth argument is used for other mail headers, which must
be specified completely formatted.
The return value is an output port into which the client must write
the message. Clients are urged to use close-output-port on the
return value as soon as the necessary text has been written, so that
the sendmail process can complete.
The sender can hold any value, though of course spoofing should be
used with care.
> (send-mail-message from-string subject-string to-list-of-strings cc-list-of-strings bcc-list-of-string body-list-of-strings [extra-headers-list-of-strings]) -> void
The arguments are the same as that for send-mail-message/port except
that there is one extra input, the list of strings corresponding to
the mail message (followed by the optional additional headers, if
present). There is no interesting return value.
Lines that contain a single period do not need to be quoted.
==========================================================================
_sending mail_, _SMTP_
==========================================================================
Collection: net
Files: _smtp.ss_, _smtpr.ss_, _smtps.ss_
ABSTRACT -------------------------------------------------------------
The SMTP package helps programmers write programs that need to send
electronic mail messages using SMTP. The client must provide the
address of an SMTP server; in contrast, the mail package (see above)
uses a pre-configured sendmail on the local system.
TYPES ----------------------------------------------------------------
The head package defines the format of a `header' string, which is
used by `send-smtp-message'. The head package also provides
utilities to verify the formatting of a mail address. The procedures
of the SMTP package assume that the given string arguments are
well-formed.
EXCEPTIONS -----------------------------------------------------------
Communication errors are signalled via exn:user structure instances.
PROCEDURES -----------------------------------------------------------
> (smtp-send-message server-string from-string to-list-of-strings header message-list-of-strings [port]) -> void
The first argument is the IP address of the SMTP server. The
`from-string' argument specifies the mail address of the sender, and
`to-listof-strings' is a list of recipient addresses (including
"To", "CC", and "BCC" recipients). The `header' argument is the
complete message header, which should already include "From", "To",
and "CC" fields consistent with the given sender and recipients.
the `message-list-of-strings' argument is the body of the message,
where each string in the list corresponds to a single line of
message text; no string in `message-list-of-strings' should contain
a carriage return or newline characters. The optional `port'
argument specifies the IP port to use in contacting the SMTP server;
the default is 25.
See the head package for utilities that construct a message headers
and validate mail address strings.
> (smtp-sending-end-of-message [proc])
Parameter that detemines a send-done procedure to be called after
`smtp-send-message' has completely sent the message. Before the
send-done procedure is called, breaking the thread that is executing
`smtp-send-message' cancels the send. After the send-done procedure
is called, breaking may or may not cancel the send (and probably
won't).
==========================================================================
_NNTP_, _newsgroups_
==========================================================================
Collection: net
Files: _nntp.ss_, _nntpr.ss_, _nntps.ss_, _nntpu.ss_
ABSTRACT -------------------------------------------------------------
The nntp package helps programmers access Usenet groups via the NNTP
protocols.
TYPES ----------------------------------------------------------------
> communicator
struct communicator (sender receiver server port)
sender : oport
receiver : iport
server : string
port : number
Once a connection to a Usenet server has been established, its state
is stored in a communicator, and other procedures take communicators
as an argument.
> desired
A regular expression that matches against a Usenet header.
EXCEPTIONS -----------------------------------------------------------
> nntp
struct (nntp exn) ()
The super-struct of all subsequent exceptions.
> unexpected-response
struct (unexpected-response nntp) (code text)
code : number
text : string
Thrown whenever an unexpected response code is received. The text
holds the response text sent by the server.
> bad-status-line
struct (bad-status-line nntp) (line)
line : string
Mal-formed status lines.
> premature-close
struct (premature-close nntp) (communicator)
communicator : communicator
Thrown when a remote server closes its connection unexpectedly.
> bad-newsgroup-line
struct (bad-newsgroup-line nntp) (line)
line : string
When the newsgroup line is improperly formatted.
> non-existent-group
struct (non-existent-group nntp) (group)
group : string
When the server does not recognize the name of the requested group.
> article-not-in-group
struct (article-not-in-group nntp) (article)
article : number
When an article is outside the server's range for that group.
> no-group-selected
struct (no-group-selected nntp) ()
When an article operation is used before a group has been selected.
> article-not-found
struct (article-not-found nntp) (article)
article : number
When the server is unable to locate the article.
PROCEDURES -----------------------------------------------------------
> (connect-to-server server-string [port-number]) -> communicator
Connects to the name server. The second argument, if provided, must
be a port number; otherwise the default NNTP port is used.
> (disconnect-from-server communicator) -> void
Disconnects a communicator.
> (open-news-group communicator newsgroup-string) -> three values: number number number
The second argument is the name of a newsgroup. The returned values
are the total number of articles in that group, the first available
article, and the last available article.
> (head-of-message communicator message-number) -> list of strings
Given a message number, returns its headers.
> (body-of-message communicator message-number) -> list of strings
Given a message number, returns the body of the message.
> (make-desired-header tag-string) -> desired
Takes the header's tag and returns a desired regexp for that header.
> (extract-desired-headers list-of-header-strings list-of-desireds) -> list of strings
Given a list of headers and of desired's, returns the header lines
that match any of the desired's.
==========================================================================
_POP-3_, _reading mail_
==========================================================================
Collection: net
Files: _pop3.ss_, _pop3r.ss_, _pop3s.ss_, _pop3u.ss_
Note: The pop3.ss invoke-opens the pop3r.ss unit with a "pop3:" prefix.
ABSTRACT -------------------------------------------------------------
Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose.
http://www.cis.ohio-state.edu/htbin/rfc/rfc1939.html
TYPES ----------------------------------------------------------------
> communicator
struct communicator (sender receiver server port state)
sender : oport
receiver : iport
server : string
port : number
state : symbol = (disconnected, authorization, transaction)
Once a connection to a POP-3 server has been established, its state
is stored in a communicator, and other procedures take communicators
as an argument.
> desired
A regular expression that matches against a mail header.
EXCEPTIONS -----------------------------------------------------------
> pop3
struct (pop3 exn) ()
The super-struct used for all other package exceptions.
> cannot-connect
struct (cannot-connect pop3) ()
When a connection to a server cannot be established.
> username-rejected
struct (username-rejected pop3) ()
If the username is rejected.
> password-rejected
struct (password-rejected pop3) ()
If the password is rejected.
> not-ready-for-transaction
struct (not-ready-for-transaction pop3) (communicator)
communicator : communicator
When the communicator is not in transaction mode.
> not-given-headers
struct (not-given-headers pop3) (communicator message)
communicator : communicator
message : number
When the server does not respond with headers for a message as
requested.
> illegal-message-number
struct (illegal-message-number pop3) (communicator message)
communicator : communicator
message : number
When the user specifies an illegal message number.
> cannot-delete-message
struct (cannot-delete-message exn) (communicator message)
communicator : communicator
message : number
When the server is unable to delete a message.
> disconnect-not-quiet
struct (disconnect-not-quiet pop3) (communicator)
communicator : communicator
When the server does not gracefully disconnect.
> malformed-server-response
struct (malformed-server-response pop3) (communicator)
communicator : communicator
When the server produces a mal-formed response.
PROCEDURES -----------------------------------------------------------
> (connect-to-server server-string [port-number]) -> communicator
Connects to a server. Uses the default port number if none is
provided.
> (disconnect-from-server communicator) -> void
Disconnects from as server. Sets the communicator state to
disconnected.
> (authenticate/plain-text user-string passwd-string communicator) -> void
Takes a username and password string and, if successful, changes the
communicator's state to transaction.
> (get-mailbox-status communicator) -> two values: count-number octet-number
Returns the number of messages and the number of octets.
> (get-message/complete communicator message-number) -> two lists of strings
Given a message number, returns a list of headers and list of
strings for the body.
> (get-message/headers communicator message-number) -> list of strings
Given a message number, returns the list of headers.
> (get-message/body communicator message-number) -> list of strings
Given a message number, returns the list of strings for the body.
> (delete-message communicator message-number) -> void
Deletes the specified message.
> (get-unique-id/single communicator message-number) -> string
Gets the server's unique id for a particular message.
> (get-unique-id/all communicator) -> list of (cons message-number id-string)
Gets a list of unique id's from the server for all the messages in
the mailbox.
> (make-desired-header tag-string) -> desired
Takes the header's tag and returns a desired regexp for that header.
> (extract-desired-headers list-of-strings list-of-desireds) -> list of strings
Given a list of headers and of desired's, returns the header lines
that match any of the desired's.
EXAMPLE --------------------------------------------------------------
> (require-library "pop3.ss" "net")
> (define c (pop3:connect-to-server "cs.rice.edu"))
> (pop3:authenticate/plain-text "scheme" "********" c)
> (pop3:get-mailbox-status c)
196
816400
> (pop3:get-message/headers c 100)
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
...
"Status: RO")
> (pop3:get-message/complete c 100)
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
...
"Status: RO")
("some body" "text" "goes" "." "here" "." "")
> (pop3:get-unique-id/single c 205)
no message numbered 205 available for unique id
> (list-tail (pop3:get-unique-id/all c) 194)
((195 . "e24d13c7ef050000") (196 . "3ad2767070050000"))
> (pop3:get-unique-id/single c 196)
"3ad2767070050000"
> (pop3:disconnect-from-server c)
==========================================================================
_IMAP_, _reading mail_
==========================================================================
Collection: net
Files: _imap.ss_, _imapr.ss_, _imaps.ss_
ABSTRACT -------------------------------------------------------------
Implements portions of client-side RFC 2060, Internet Message Access
Protocol - Version 4rev1, Crispin, http://www.isi.edu/in-notes/rfc2060.txt
TYPES ----------------------------------------------------------------
> imap
An opaque record reprsenting an IMAP connection.
> imap-flag
A symbol, but generally not a convenient one to use within a Scheme
program. The `imap-flag->symbol' and `symbol->imap-flag' procedures
convert IMAP flags to convenient symbols and vice-versa.
EXCEPTIONS -----------------------------------------------------------
Communication errors are signalled via exn:user structure instances.
PROCEDURES -----------------------------------------------------------
> (imap-connect server-string username-string password-string mailbox-string)
-> three values: imap, message count, recent message count
Establishes an IMAP connection to the given server using the given
username and password, and selects the specified mailbox. The second
and third return values indicate the total number of message in the
mailbox and the number of recent messages (i.e., messages received
since the mailbox was last selected), respectively.
See also `imap-port-number', below.
A user's primary mailbox is always called "INBOX".
> (imap-disconnect imap) -> void
Closes an IMAP connection. The close may fail due to a communication
error.
> (imap-force-disconnect imap) -> void
Closes an IMAP connection forcefully (i.e., without send a close
message to the server). A forced disconnect never fails.
> (imap-reselect imap mailbox-string)
-> two values: message count and recent message count
De-selects the mailbox currently selected by the connection and
selects the specified mailbox, returning the total and recent
message counts for the new mailbox.
This procedure is useful for polling a mailbox to see whether there
are any new messages (by providing the currently selected mailbox as
the new mailbox), but use imap-status with the 'uidnext flag to
determine whether a mailbox has changed at all (e.g., via a copy
instead of a move).
> (imap-status imap mailbox-string status-symbol-list)
-> list of status values
Requests information about a mailbox from the server. The
status-symbol-list specifies the request, and the return value
includes one value for each symbol in status-symbol-list. The
allowed status symbols are:
'messages - number of messages
'recent - number of recent messages
'unseen - number of unseen messages
'uidnext - uid for next received message
'uidvalidity - id that changes when all uids are changed
> (imap-get-messages imap msg-num-list field-list)
-> list of field-value lists
Downloads information for a set of messages. The `msg-num-list'
argument specifies a set of messages by their message positions (not
their uids). The `field-list' argument specifies the type of
information to download for each message. The avilable fields are:
* 'uid - value is an integer
* 'header - value is a header (string; see the head package)
* 'body - value is a string (with CRLF-separated lines)
* 'flags - value is a list of imap flags
The return value is a list of entry items in parallel to
`msg-num-list'. Each entry is itself a list containing value items
in parallel to `field-list'.
Example:
(imap-get-message imap '(1 3 5) '(uid header))
; => ((107 "From: larry@stooges.com ...")
(110 "From: moe@stooges.com ...")
(112 "From: curly@stooges.com ..."))
> (imap-flag->symbol imap-flag) -> symbol
> (symbol->imap-flag symbol) -> imap-flag
An imap flag is a symbol, but it is generally not a convenient one
to use within a Scheme program, because it usually starts with a
backslash and flag comparisions are case-insensitive. The
`imap-flag->symbol' and `symbol->imap-flag' procedures convert IMAP
flags to convenient symbols and vice-versa:
symbol imap flag
------ ----------
'seen '|\Seen| \
'answered '|\Answered| |
'flagged '|\Flagged| > message flags
'deleted '|\Deleted| |
'draft '|\Draft| |
'recent '|\Recent| /
'noinferiors '|\Noinferiors| \
'noselect '|\Noselect| > mailbox flags
'marked '|\Marked| |
'unmarked '|\Unmarked| /
`imap-flag->symbol' and `symbol->imap-flag' act like the identity
function when any other symbol/flag is provided.
> (imap-store imap mode msg-num-list imap-flags) -> void
Sets flags for a set of messages. The mode argument specifies how
flags are set:
* '+ - add the given flags to each message
* '- - remove the given flags from each emssage
* '! - set each message's flags to the given set
The `msg-num-list' argument specifies a set of messages by their
message positions (not their uids). The `flags' argument specifies
the imap flags to add/remove/install.
Example:
(imap-store imap '+ '(1 2 3) (list (symbol->imap-flag 'deleted)))
; marks the first three messages to be deleted
(imap-expunge imap)
; permanently removes the first three messages (and possibly others)
; from the currently-selected mailbox
> (imap-expunge imap) -> void
Purges every message currently marked with the '|\Deleted| flag from
the mailbox.
> (imap-copy imap msg-num-list dest-mailbox-string) -> void
Copies the specified messages from the currently selected mailbox to
the specified mailbox.
> (imap-mailbox-exists? imap mailbox-string) -> bool
Returns #t if the specified mailbox exists, #f otherwise.
> (imap-create-mailbox imap mailbox-string) -> void
Creates the specified mailbox. (It must not exist already.)
> (imap-list-child-mailboxes imap mailbox-string [delimiter-string])
-> list of mailbox-info lists
Returns information about sub-mailboxes of the given mailbox. If
mailbox-string is #f, information about all top-level mailboxes is
returned. The optional `delimiter-string' is determined
automatically (via `imap-get-hierarchy-delimiter') if it is not
provided.
The return value is a list of mailbox-information lists. Each
mailbox-information list contains two items:
* a list of imap flags for the mailbox
* the mailbox's name
> (imap-get-hierarchy-delimiter imap) -> string
Returns the server-specific string that is used as a separator in
mailbox path names.
> (imap-port-number [k])
A parameter that determines the server port number. The initial
value is 143.
==========================================================================
_mail headers_
==========================================================================
Collection: net
Files: _head.ss_, _headr.ss_, _heads.ss_
ABSTRACT -------------------------------------------------------------
Implements utlities for RFC 822 headers and mail addresses.
TYPES ----------------------------------------------------------------
> header
A string that is an RFC-882-compliant header. A header string
contains a series of CRLF-delimitted fields, and ends with two CRLFs
(the first one terminates the last field, and the second terminates
the header).
PROCEDURES -----------------------------------------------------------
> empty-header
A string correcponding to the empty header, useful for building up
headers with `insert-field' and `append-headers'.
> (validate-header candidate-header-string) -> void
If the format of `candidate-header-string' matches RFC 822, void is
returned, otherwise an exception is raised.
> (extract-field field-string header) -> string or #f
Returns the header content for the specified field, or #f if the
field is not in the header. `field-string' should not end with ":",
and it is used case-insensitively. The returned string will not
contain the field name, color separator, of CRLF terminator for the
field; however, if the field spans multiple lines, the CRLFs
separating the lines will be intact.
Example:
(extract-field "TO" (insert-field "to" "me@localhost" empty-header))
; => "me@localhost"
> (remove-field field-string header) -> header
Creates a new header by removing the specified field from `header'
(or the first instance of the field, if it occurs multiple
times). If the field is not in `header', then the return value is
`header'.
> (insert-field field-string value-string header) -> header
Creates a new header by prefixing the given header with the given
field-value pair. `value-string' should not contain a terminating
CRLF, but a multi-line value (perhaps created with
`data-lines->data') may contain seperator CRLFs.
> (append-headers a-header another-header) -> header
> (standard-message-header from-string to-list-of-strings cc-list-of-strings bcc-list-of-strings subject-string) -> header
Creates a standard mail header given the sender, various lists of
recipients, and a subject. (The BCC recipients do not acually appear
in the header, but they're accepted anyway to complete the
abstarction.)
> (data-lines->data list-of-strings) -> string
Merges multiple lines for a single field value into one string,
adding CRLF-TAB separators.
> (extract-addresses string kind) -> list of strings or
list of list of strings
Parses `string' as a list of comma-delimited mail addresses, raising
an exception if the list is ill-formed. This procedure can be used
for single-address strings, in which case the returned list should
contain only one address.
The `kind' argument specifies which portion of an address should be
returned:
* 'name - the free-form name in the address, or the address
itself if no name is available:
"John Doe <doe@localhost>" => "Jon Doe"
"doe@localhost (Johnny Doe)" => "Johnny Doe"
"doe@localhost" => "doe@localhost"
* 'address - just the mailing address, without any free-form
names:
"Jon Doe <doe@localhost>" => "doe@localhost"
"doe@localhost (Johnny Doe)" => "doe@localhost"
"doe@localhost" => "doe@localhost"
* 'full - the full address, essentially as it appears in the
input, but normalized:
"Jon Doe < doe@localhost >" => "Jon Doe <doe@localhost>"
" doe@localhost (Johnny Doe)" => "doe@localhost (Johnny Doe)"
"doe@localhost" => "doe@localhost"
* 'all - a list containing each of the three posibilities:
free-form name, address, and full address (in that
order)
Example:
(extract-addresses " \"Doe, John\" <doe@localhost>, john" 'address)
; => ("doe@localhost" "john")
> (assemble-address-field list-of-address-strings) -> string
Creates a header field value from a list of addresses. The addresses
are comma-separated, and possibly broken into multiple lines.
==========================================================================
_DNS_, _domain name service_
==========================================================================
Collection: net
Files: _dns.ss_, _dnsr.ss_, _dnss.ss_
ABSTRACT -------------------------------------------------------------
Implements a DNS client, based on RFC 1035
PROCEDURES -----------------------------------------------------------
> (dns-get-address nameserver-string address-string) -> address-string
Consults the specified nameserver (normally a numerical address like
"128.42.1.30") to obtain a numerical address for the given internet
address.
The query record sent to the DNS server includes the "recursive"
bit, but `dns-get-address' also implements a recursive search itself
in case the server does not provide this optional feature.
> (dns-get-mail-exchanger nameserver-string address-string) -> address-string
Consults the specified nameserver to obtain the address for a mail
exchanger the given mail host address. For example, the mail
exchanger for "ollie.cs.rice.edu" is currently "cs.rice.edu".
> (dns-find-nameserver) -> address-string or #f
Attempts to find the address of a nameserver on the present system.
Under Unix, this procedure parses /etc/resolv.conf to extract the
first nameserver address.
==========================================================================
_Base 64 Encoding_, _base64_
==========================================================================
Collection: net
Files: _base64.ss_, _base64r.ss_, _base64s.ss_
ABSTRACT -------------------------------------------------------------
Implements a Base 64 (mime-standard) encoder. (We'll implement a
decoder eventually.)
PROCEDURES -----------------------------------------------------------
> (base64-encode string) -> string
Consumes a string and returns its base64 encoding as a new string.
The returned string is broken into 72-character lines separated by
CRLF combinations, and it always ends with the "=" base64
terminator.

8
collects/net/head.ss
View File

@ -1,8 +0,0 @@
(require-relative-library "heads.ss")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:head^
(require-relative-library "headr.ss"))

243
collects/net/headr.ss
View File

@ -1,243 +0,0 @@
(unit/sig mzlib:head^
(import)
(define empty-header (string #\return #\newline))
(define (string->ci-regexp s)
(list->string
(apply
append
(map
(lambda (c)
(cond
[(memq c '(#\$ #\| #\\ #\[ #\] #\. #\* #\? #\+ #\( #\) #\^))
(list #\\ c)]
[(char-alphabetic? c)
(list #\[ (char-upcase c) (char-downcase c) #\])]
[else (list c)]))
(string->list s)))))
(define re:field-start (regexp
(format "^[^~a~a~a~a~a:~a-~a]*:"
#\space #\tab #\linefeed #\return #\vtab
(integer->char 1)
(integer->char 26))))
(define re:continue (regexp (format "^[~a~a~a]" #\space #\tab #\vtab)))
(define (validate-header s)
(let ([len (string-length s)])
(let loop ([offset 0])
(cond
[(and (= (+ offset 2) len)
(string=? empty-header (substring s offset len)))
(void)] ; validated
[(= offset len) (error 'validate-header "missing ending CRLF")]
[(or (regexp-match re:field-start s offset)
(regexp-match re:continue s offset))
(let ([m (regexp-match-positions (string #\return #\linefeed) s offset)])
(if m
(loop (cdar m))
(error 'validate-header "missing ending CRLF")))]
[else (error 'validate-header "ill-formed header at ~s"
(substring s offset (string-length s)))]))))
(define (make-field-start-regexp field)
(format "(^|[~a][~a])(~a: *)"
#\return #\linefeed
(string->ci-regexp field)))
(define (extract-field field header)
(let ([m (regexp-match-positions
(make-field-start-regexp field)
header)])
(and m
(let ([s (substring header
(cdaddr m)
(string-length header))])
(let ([m (regexp-match-positions
(format "[~a][~a][^: ~a~a]*:"
#\return #\linefeed
#\return #\linefeed)
s)])
(if m
(substring s 0 (caar m))
; Rest of header is this field, but strip trailing CRLFCRLF:
(regexp-replace (format "~a~a~a~a$" #\return #\linefeed #\return #\linefeed)
s
"")))))))
(define (remove-field field header)
(let ([m (regexp-match-positions
(make-field-start-regexp field)
header)])
(if m
(let ([pre (substring header
0
(caaddr m))]
[s (substring header
(cdaddr m)
(string-length header))])
(let ([m (regexp-match-positions
(format "[~a][~a][^: ~a~a]*:"
#\return #\linefeed
#\return #\linefeed)
s)])
(if m
(string-append pre (substring s (+ 2 (caar m))
(string-length s)))
pre)))
header)))
(define (insert-field field data header)
(let ([field (format "~a: ~a~a~a"
field
data
#\return #\linefeed)])
(string-append field header)))
(define (append-headers a b)
(let ([alen (string-length a)])
(if (> alen 1)
(string-append (substring a 0 (- alen 2)) b)
(error 'append-headers "first argument is not a header: ~a" a))))
(define (standard-message-header from tos ccs bccs subject)
(let ([h (insert-field
"Subject" subject
empty-header)])
; NOTE: bccs don't go into the header; that's why
; they're "blind"
(let ([h (if (null? ccs)
h
(insert-field
"CC" (assemble-address-field ccs)
h))])
(let ([h (if (null? tos)
h
(insert-field
"To" (assemble-address-field tos)
h))])
(insert-field
"From" from
h)))))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply
string-append
(map
(lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (data-lines->data datas)
(splice datas (format "~a~a~a" #\return #\linefeed #\tab)))
;;; Extracting Addresses ;;;
(define blank (format "[~a~a~a~a~a]" #\space #\tab #\newline #\return #\vtab))
(define re:all-blank (regexp (format "^~a*$" blank)))
(define (extract-addresses s form)
(unless (memq form '(name address full all))
(raise-type-error 'extract-addresses
"form: 'name, 'address, 'full, or 'all"
form))
(if (or (not s) (regexp-match re:all-blank s))
null
(let loop ([prefix ""][s s])
; Which comes first - a quote or a comma?
(let ([mq (regexp-match-positions "\"[^\"]*\"" s)]
[mc (regexp-match-positions "," s)])
(if (and mq mc (< (caar mq) (caar mc) (cdar mq)))
; Quote contains a comma
(loop (string-append
prefix
(substring s 0 (cdar mq)))
(substring s (cdar mq) (string-length s)))
; Normal comma parsing:
(let ([m (regexp-match "([^,]*),(.*)" s)])
(if m
(let ([n (extract-one-name (string-append prefix (cadr m)) form)]
[rest (extract-addresses (caddr m) form)])
(cons n rest))
(let ([n (extract-one-name (string-append prefix s) form)])
(list n)))))))))
(define (select-result form name addr full)
(case form
[(name) name]
[(address) addr]
[(full) full]
[(all) (list name addr full)]))
(define (one-result form s)
(select-result form s s s))
(define (extract-one-name s form)
(cond
[(regexp-match (format "^~a*(\"[^\"]*\")(.*)" blank) s)
=> (lambda (m)
(let ([name (cadr m)]
[addr (extract-angle-addr (caddr m))])
(select-result form name addr
(format "~a <~a>" name addr))))]
; ?!?!? Where does the "addr (name)" standard come from ?!?!?
[(regexp-match (format "(.*)[(]([^)]*)[)]~a*$" blank) s)
=> (lambda (m)
(let ([name (caddr m)]
[addr (extract-simple-addr (cadr m))])
(select-result form name addr
(format "~a (~a)" addr name))))]
[(regexp-match (format "^~a*(.*)(<.*>)~a*$" blank blank) s)
=> (lambda (m)
(let ([name (regexp-replace (format "~a*$" blank) (cadr m) "")]
[addr (extract-angle-addr (caddr m))])
(select-result form name addr
(format "~a <~a>" name addr))))]
[(or (regexp-match "<" s) (regexp-match ">" s))
(one-result form (extract-angle-addr s))]
[else
(one-result form (extract-simple-addr s))]))
(define (extract-angle-addr s)
(if (or (regexp-match "<.*<" s) (regexp-match ">.*>" s))
(error 'extract-address "too many angle brackets: ~a" s)
(let ([m (regexp-match (format "~a*<([^>]*)>~a*" blank blank) s)])
(if m
(extract-simple-addr (cadr m))
(error 'extract-address "cannot parse address: ~a" s)))))
(define (extract-simple-addr s)
(cond
[(regexp-match "[,\"()<>]" s)
(error 'extract-address "cannot parse address: ~a" s)]
[else
; final whitespace strip
(regexp-replace
(format "~a*$" blank)
(regexp-replace (format "~a*" blank) s "")
"")]))
(define (assemble-address-field addresses)
(if (null? addresses)
""
(let loop ([addresses (cdr addresses)]
[s (car addresses)]
[len (string-length (car addresses))])
(if (null? addresses)
s
(let* ([addr (car addresses)]
[alen (string-length addr)])
(if (<= 72 (+ len alen))
(loop (cdr addresses)
(format "~a,~a~a~a~a"
s #\return #\linefeed
#\tab addr)
alen)
(loop (cdr addresses)
(format "~a, ~a" s addr)
(+ len alen 2)))))))))

12
collects/net/heads.ss
View File

@ -1,12 +0,0 @@
(define-signature mzlib:head^
(empty-header
validate-header
extract-field
remove-field
insert-field
append-headers
standard-message-header
data-lines->data
extract-addresses
assemble-address-field))

8
collects/net/imap.ss
View File

@ -1,8 +0,0 @@
(require-relative-library "imaps.ss")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:imap^
(require-relative-library "imapr.ss"))

379
collects/net/imapr.ss
View File

@ -1,379 +0,0 @@
(unit/sig mzlib:imap^
(import)
(define debug-via-stdio? #f)
(define eol (if debug-via-stdio?
'linefeed
'return-linefeed))
(define crlf (string #\return #\linefeed))
(define (tag-eq? a b)
(or (eq? a b)
(and (symbol? a)
(symbol? b)
(string-ci=? (symbol->string a)
(symbol->string b)))))
(define field-names
(list
(list 'uid (string->symbol "UID"))
(list 'header (string->symbol "RFC822.HEADER"))
(list 'body (string->symbol "RFC822.TEXT"))
(list 'size (string->symbol "RFC822.SIZE"))
(list 'flags (string->symbol "FLAGS"))))
(define flag-names
(list
(list 'seen (string->symbol "\\Seen"))
(list 'answered (string->symbol "\\Answered"))
(list 'flagged (string->symbol "\\Flagged"))
(list 'deleted (string->symbol "\\Deleted"))
(list 'draft (string->symbol "\\Draft"))
(list 'recent (string->symbol "\\Recent"))
(list 'noinferiors (string->symbol "\\Noinferiors"))
(list 'noselect (string->symbol "\\Noselect"))
(list 'marked (string->symbol "\\Marked"))
(list 'unmarked (string->symbol "\\Unmarked"))))
(define (imap-flag->symbol f)
(or (ormap (lambda (a) (and (tag-eq? f (cadr a)) (car a)))
flag-names)
f))
(define (symbol->imap-flag s)
(let ([a (assoc s flag-names)])
(if a
(cadr a)
s)))
(define (log-warning . args)
; (apply printf args)
(void))
(define log log-warning)
(define make-msg-id
(let ([id 0])
(lambda ()
(begin0
(format "a~a " id)
(set! id (add1 id))))))
(define (starts-with? l n)
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(define (skip s n)
(substring s
(if (number? n) n (string-length n))
(string-length s)))
(define (splice l sep)
(if (null? l)
""
(format "~a~a"
(car l)
(apply
string-append
(map
(lambda (n) (format "~a~a" sep n))
(cdr l))))))
(define (imap-read s r)
(let loop ([s s]
[r r]
[accum null]
[eol-k (lambda (accum) (reverse! accum))]
[eop-k (lambda (s accum) (error 'imap-read "unxpected close parenthesis"))])
(cond
[(string=? "" s) (eol-k accum)]
[(char-whitespace? (string-ref s 0))
(loop (skip s 1) r accum eol-k eop-k)]
[else
(case (string-ref s 0)
[(#\") (let ([m (regexp-match "\"([^\"]*)\"(.*)" s)])
(if m
(loop (caddr m) r (cons (cadr m) accum) eol-k eop-k)
(error 'imap-read "didn't find end of quoted string in: ~a" s)))]
[(#\)) (eop-k (skip s 1) accum)]
[(#\() (letrec ([next-line
(lambda (accum)
(loop (read-line r eol) r
accum
next-line
finish-parens))]
[finish-parens
(lambda (s laccum)
(loop s r
(cons (reverse! laccum) accum)
eol-k eop-k))])
(loop (skip s 1) r null next-line finish-parens))]
[(#\{) (let ([m (regexp-match "{([0-9]+)}(.*)" s)])
(cond
[(not m) (error 'imap-read "couldn't read {} number: ~a" s)]
[(not (string=? (caddr m) "")) (error 'imap-read "{} not at end-of-line: ~a" s)]
[else (loop "" r
(cons (read-string (string->number (cadr m)) r)
accum)
eol-k eop-k)]))]
[else (let ([m (regexp-match "([^ (){}]+)(.*)" s)])
(if m
(loop (caddr m) r
(cons (let ([v (cadr m)])
(if (regexp-match "^[0-9]*$" v)
(string->number v)
(string->symbol (cadr m))))
accum)
eol-k eop-k)
(error 'imap-read "failure reading atom: ~a" s)))])])))
(define (imap-send r w cmd info-handler)
(let ([id (make-msg-id)])
(log "sending ~a~a~n" id cmd)
(fprintf w "~a~a~a" id cmd crlf)
(let loop ()
(let ([l (read-line r eol)])
; (log "raw-reply: ~s~n" l)
(cond
[(starts-with? l id)
(let ([reply (imap-read (skip l id) r)])
(log "response: ~a~n" reply)
reply)]
[(starts-with? l "* ")
(let ([info (imap-read (skip l 2) r)])
(log "info: ~s~n" info)
(info-handler info))
(loop)]
[(starts-with? l "+ ")
(error 'imap-send "unexpected continuation request: ~a" l)]
[else
(log-warning "warning: unexpected response for ~a: ~a" id l)
(loop)])))))
(define (str->arg s)
(if (or (regexp-match " " s)
(string=? s ""))
(format "\"~a\"" s)
s))
(define (check-ok reply)
(unless (and (pair? reply)
(tag-eq? (car reply) 'OK))
(error 'check-ok "server error: ~s" reply)))
(define-struct imap-connection (r w))
(define imap-port-number (make-parameter 143))
(define (imap-connect server username password inbox)
; => imap count-k recent-k
(let-values ([(r w) (if debug-via-stdio?
(begin
(printf "stdin == ~a~n" server)
(values (current-input-port) (current-output-port)))
(tcp-connect server (imap-port-number)))])
(with-handlers ([void
(lambda (x)
(close-input-port r)
(close-output-port w)
(raise x))])
(check-ok (imap-send r w "NOOP" void))
(let ([reply (imap-send r w (format "LOGIN ~a ~a"
(str->arg username)
(str->arg password))
void)])
(if (and (pair? reply) (tag-eq? 'NO (car reply)))
(error "username or password rejected by server")
(check-ok reply)))
(let ([imap (make-imap-connection r w)])
(let-values ([(init-count init-recent)
(imap-reselect imap inbox)])
(values imap
init-count
init-recent))))))
(define (imap-reselect imap inbox)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(let ([init-count 0]
[init-recent 0])
(check-ok (imap-send r w (format "SELECT ~a" (str->arg inbox))
(lambda (i)
(when (and (list? i) (= 2 (length i)))
(cond
[(tag-eq? (cadr i) 'EXISTS)
(set! init-count (car i))]
[(tag-eq? (cadr i) 'RECENT)
(set! init-recent (car i))])))))
(values init-count init-recent))))
(define (imap-status imap inbox flags)
(unless (and (list? flags)
(andmap (lambda (s)
(memq s '(messages recent uidnext uidvalidity unseen)))
flags))
(raise-type-error 'imap-status "list of status flag symbols" flags))
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(let ([results null])
(check-ok (imap-send r w (format "STATUS ~a ~a" (str->arg inbox) flags)
(lambda (i)
(when (and (list? i) (= 3 (length i))
(tag-eq? (car i) 'STATUS))
(set! results (caddr i))))))
(map
(lambda (f)
(let loop ([l results])
(cond
[(or (null? l) (null? (cdr l))) #f]
[(tag-eq? f (car l)) (cadr l)]
[else (loop (cdr l))])))
flags))))
(define (imap-disconnect imap)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(check-ok (imap-send r w "LOGOUT" void))
(close-input-port r)
(close-output-port w)))
(define (imap-force-disconnect imap)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(close-input-port r)
(close-output-port w)))
(define (imap-get-messages imap msgs field-list)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(when (or (not (list? msgs))
(not (andmap integer? msgs)))
(raise-type-error 'imap-get-messages "non-empty message list" msgs))
(when (or (null? field-list)
(not (list? field-list))
(not (andmap (lambda (f) (assoc f field-names)) field-list)))
(raise-type-error 'imap-get-messages "non-empty field list" field-list))
(if (null? msgs)
null
(let ([results null])
(imap-send r w (format "FETCH ~a (~a)"
(splice msgs ",")
(splice (map (lambda (f) (cadr (assoc f field-names))) field-list) " "))
(lambda (i)
(when (and (list? i) (<= 2 (length i))
(tag-eq? (cadr i) 'FETCH))
(set! results (cons i results)))))
(map
(lambda (msg)
(let ([m (assoc msg results)])
(unless m
(error 'imap-get-messages "no result for message ~a" msg))
(let ([d (caddr m)])
(map
(lambda (f)
(let ([fld (cadr (assoc f field-names))])
(let loop ([d d])
(cond
[(null? d) #f]
[(null? (cdr d)) #f]
[(tag-eq? (car d) fld) (cadr d)]
[else (loop (cddr d))]))))
field-list))))
msgs)))))
(define (imap-store imap mode msgs flags)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(check-ok
(imap-send r w
(format "STORE ~a ~a ~a"
(splice msgs ",")
(case mode
[(+) "+FLAGS.SILENT"]
[(-) "-FLAGS.SILENT"]
[(!) "FLAGS.SILENT"]
[else (raise-type-error
'imap-store
"mode: '!, '+, or '-")])
flags)
void))))
(define (imap-copy imap msgs dest-mailbox)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(check-ok
(imap-send r w
(format "COPY ~a ~a"
(splice msgs ",")
(str->arg dest-mailbox))
void))))
(define (imap-expunge imap)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(check-ok (imap-send r w "EXPUNGE" void))))
(define (imap-mailbox-exists? imap mailbox)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)]
[exists? #f])
(check-ok (imap-send r w
(format "LIST \"\" ~s" (str->arg mailbox))
(lambda (i)
(when (and (pair? i)
(tag-eq? (car i) 'LIST))
(set! exists? #t)))))
exists?))
(define (imap-create-mailbox imap mailbox)
(let ([r (imap-connection-r imap)]
[w (imap-connection-w imap)])
(check-ok
(imap-send r w
(format "CREATE ~a" (str->arg mailbox))
void))))
(define (imap-get-hierarchy-delimiter imap)
(let* ([r (imap-connection-r imap)]
[w (imap-connection-w imap)]
[result #f])
(check-ok
(imap-send r w "LIST \"\" \"\""
(lambda (x)
(set! result (caddr x)))))
result))
(define imap-list-child-mailboxes
(case-lambda
[(imap mailbox)
(imap-list-child-mailboxes imap mailbox (imap-get-hierarchy-delimiter imap))]
[(imap mailbox delimiter)
(let* ([r (imap-connection-r imap)]
[w (imap-connection-w imap)]
[mailbox-name (and mailbox (format "~a~a" mailbox delimiter))]
[pattern (if mailbox
(format "~a%" mailbox-name)
"%")]
[sub-folders null])
(check-ok
(imap-send r w (format "LIST \"\" ~a" (str->arg pattern))
(lambda (x)
(let ([flags (cadr x)]
[name (let ([s (cadddr x)])
(if (symbol? s)
(symbol->string s)
s))])
(unless (and mailbox-name
(string=? name mailbox-name))
(set! sub-folders
(cons
(list flags name)
sub-folders)))))))
(reverse sub-folders))])))

20
collects/net/imaps.ss
View File

@ -1,20 +0,0 @@
(define-signature mzlib:imap^
(imap-port-number
imap-connect
imap-disconnect
imap-force-disconnect
imap-reselect
imap-status
imap-get-messages
imap-copy
imap-store imap-flag->symbol symbol->imap-flag
imap-expunge
imap-mailbox-exists?
imap-create-mailbox
imap-list-child-mailboxes
imap-get-hierarchy-delimiter))

9
collects/net/info.ss
View File

@ -1,9 +0,0 @@
(lambda (sym fail)
(let ([elab (list "cgis.ss" "mails.ss" "nntps.ss" "pop3s.ss" "urls.ss"
"smtps.ss" "heads.ss" "imaps.ss" "dnss.ss" "base64s.ss")])
(case sym
[(name) "Net"]
[(compile-prefix) `(begin ,@(map (lambda (x) `(require-library ,x "net")) elab))]
[(compile-omit-files) elab]
[(compile-elaboration-zos) elab]
[else (fail)])))

8
collects/net/mail.ss
View File

@ -1,8 +0,0 @@
(require-library "mails.ss" "net")
(require-library "mailu.ss" "net")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:sendmail^
mzlib:sendmail@)

105
collects/net/mailr.ss
View File

@ -1,105 +0,0 @@
(unit/sig mzlib:sendmail^
(import)
(define-struct (no-mail-recipients struct:exn) ())
(define sendmail-search-path
'("/usr/lib" "/usr/sbin"))
(define sendmail-program-file
(if (eq? (system-type) 'unix)
(let loop ((paths sendmail-search-path))
(if (null? paths)
(raise (make-exn:misc:unsupported
"unable to find sendmail on this Unix variant"
(current-continuation-marks)))
(let ((p (build-path (car paths) "sendmail")))
(if (and (file-exists? p)
(memq 'execute (file-or-directory-permissions p)))
p
(loop (cdr paths))))))
(raise (make-exn:misc:unsupported
"sendmail only available under Unix"
(current-continuation-marks)))))
;; send-mail-message/port :
;; string x string x list (string) x list (string) x list (string)
;; [x list (string)] -> oport
;; -- sender can be anything, though spoofing is not recommended.
;; The recipients must all be pure email addresses. Note that
;; everything is expected to follow RFC conventions. If any other
;; headers are specified, they are expected to be completely
;; formatted already. Clients are urged to use close-output-port on
;; the port returned by this procedure as soon as the necessary text
;; has been written, so that the sendmail process can complete.
(define send-mail-message/port
(lambda (sender subject to-recipients cc-recipients bcc-recipients
. other-headers)
(when (and (null? to-recipients) (null? cc-recipients)
(null? bcc-recipients))
(raise (make-no-mail-recipients
"no mail recipients were specified"
(current-continuation-marks))))
(let ((return (apply process* sendmail-program-file "-i"
(append to-recipients cc-recipients bcc-recipients))))
(let ((reader (car return))
(writer (cadr return))
(pid (caddr return))
(error-reader (cadddr return)))
(close-input-port reader)
(close-input-port error-reader)
(fprintf writer "From: ~a~n" sender)
(letrec ((write-recipient-header
(lambda (header-string recipients)
(let ((header-space
(+ (string-length header-string) 2)))
(fprintf writer "~a: " header-string)
(let loop ((to recipients) (indent header-space))
(if (null? to)
(newline writer)
(let ((first (car to)))
(let ((len (string-length first)))
(if (>= (+ len indent) 80)
(begin
(fprintf writer "~n ~a, " first)
(loop (cdr to) (+ len header-space 2)))
(begin
(fprintf writer "~a, " first)
(loop (cdr to)
(+ len indent 2))))))))))))
(write-recipient-header "To" to-recipients)
(write-recipient-header "CC" cc-recipients))
(fprintf writer "Subject: ~a~n" subject)
(fprintf writer "X-Mailer: MzScheme: see www.cs.rice.edu/CS/PLT/~n")
(for-each (lambda (s)
(display s writer)
(newline writer))
other-headers)
(newline writer)
writer))))
;; send-mail-message :
;; string x string x list (string) x list (string) x list (string) x
;; list (string) [x list (string)] -> ()
;; -- sender can be anything, though spoofing is not recommended. The
;; recipients must all be pure email addresses. The text is expected
;; to be pre-formatted. Note that everything is expected to follow
;; RFC conventions. If any other headers are specified, they are
;; expected to be completely formatted already.
(define send-mail-message
(lambda (sender subject to-recipients cc-recipients bcc-recipients text
. other-headers)
(let ((writer (apply send-mail-message/port sender subject
to-recipients cc-recipients bcc-recipients
other-headers)))
(for-each (lambda (s)
(display s writer) ; We use -i, so "." is not a problem
(newline writer))
text)
(close-output-port writer))))
)

4
collects/net/mails.ss
View File

@ -1,4 +0,0 @@
(define-signature mzlib:sendmail^
(send-mail-message/port
send-mail-message
(struct no-mail-recipients ())))

4
collects/net/mailu.ss
View File

@ -1,4 +0,0 @@
(require-library "mails.ss" "net")
(define mzlib:sendmail@
(require-library-unit/sig "mailr.ss" "net"))

128
collects/net/nntp.sd
View File

@ -1,128 +0,0 @@
(define nntp-doc
(mk-document {nntp}
{The PLT NNTP Toolkit}
{[(paragraph {The NNTP toolkit implements routines which form the
basis for a client that can converse with an NNTP (Usenet
News) server. The toolkit defines both procedures to
interface with the server, and exceptions which indicate
erroneous behavior.})]
[(paragraph
{The toolkit is parameterized over [(italic
{communicator})]s, which are structures representing a
connection to a particular server. Several communicators can
be open at any given time. A communicator has four fields:
[(mk-itemize
(list
{[(italic {sender})], an output port which sends
commands to the the server;
}
{[(italic {receiver})], an input port for receiving
responses from the server;
}
{[(italic {server})], a string containing the name of
the server, which is useful for error messages and
identification; and,
}
{[(italic {port})], a number denoting the port number
on the server to which this connection was
established.
}))]})]
[(paragraph {The following procedures are defined:})]
[(mk-itemize
(list
{[(bold {connect-to-server})] accepts a string, the server's
name, and optionally the port number. If no port number
is provided, the default NNTP port (119) is used. A
communicator is returned.}
{[(bold {disconnect-from-server})] takes a communicator and
closes its connections.}
{[(bold {open-news-group})] accepts a communicator and a
string, representing the group's name, and makes it the
current group. Three values are returned: the number of
articles the server has for the group, the first
available article number, and the last article number.}
{[(bold {head-of-message})] takes a communicator and a
message number, and returns the message's headers as a
list of strings.}
{[(bold {body-of-message})] takes a communicator and a
message number, and returns the message's body as a list
of strings.}
{[(bold {make-desired-header})] takes a string representing a
header, and returns a regular expression which can be
matched against header lines. The string should be given
sans a trailing colon; regular expressions may be used
within the string.}
{[(bold {extract-desired-headers})] accepts a list of strings
representing the header and a list of regular expressions
representing desired headers, and returns a list of
strings denoting the desired headers.}))]
[(paragraph {This library only interfaces using the NNTP
protocol; it does not attempt to improve it by providing an
alternative, perhaps more functional, formulation. Hence, it
generates the same errors as those returned by NNTP servers.
These errors are expressed as Scheme exceptions. They are
all sub-types of the exception [(bold {nntp})] (which has
no fields).})]
[(itemize
{[(bold {unexpected-response})] has two fields: [(italic
{code})], a number and [(italic {text})], a string containing
the error message returned by the server. This is raised
when the return code is not recognized by the toolkit.}
{[(bold {premature-close})] is raised when the server
generates an end-of-file in the midst of a multi-line
response (such as the message header or body). The exception
has a [(italic {communicator})] field.}
{[(bold {non-existent-group})] is raised when the group being
opened is not recognized by the server. Note that not all
servers carry all groups.}
{[(bold {article-not-in-group})] is raised when an attempt is
made to get the header or body of a group outside the range
for the group or which has expired or been cancelled. The
[(italic {article})] field holds the article number.}
{[(bold {article-not-found})] is raised in other situations
when an article cannot be found. The article number is given
in the [(italic {article})] field.}
{[(bold {no-group-selected})] is raised when an attempt is
made to get the header or body of an article before any group
has been selected.}
{[(bold {bad-newsgroup-line})] is raised when the server is
not following the RFC specification acknowledging that a
newsgroup has been set. It holds the line in the [(italic
{line})] field.}
{[(bold {bad-status-line})] has one field: [(italic {line})],
a string. This is only flagged when the server does not
follow the RFC specification.})]
[(paragraph {There are at least two routes to take when
improving the library's design. One possibility is to
provide a construct, similar to Scheme's i/o functions, in
whose dynamic range groups are selected, and inside which all
article reading is done. Another approach is to require all
article accesses to also specify a group. The current group
state would be maintained by the implementation, which can
optimize away the need to make the current group setting for
each article read. It can also anticipate certain errors.
The state would be cached with each communicator.})]
[(paragraph {This implementation currently provides no posting
conveniences, though since the output port to the server is
available, the user could implement this. However, that same
argument can be made for the rest of the toolkit as well.})]
}))
(render-html nntp-doc)

8
collects/net/nntp.ss
View File

@ -1,8 +0,0 @@
(require-library "nntpu.ss" "net")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:nntp^
mzlib:nntp@
nntp)

281
collects/net/nntpr.ss
View File

@ -1,281 +0,0 @@
; Time-stamp: <98/07/14 14:41:20 shriram>
; Time-stamp: <97/03/05 15:34:09 shriram>
(unit/sig mzlib:nntp^
(import)
; sender : oport
; receiver : iport
; server : string
; port : number
(define-struct communicator (sender receiver server port))
; code : number
; text : string
; line : string
; communicator : communicator
; group : string
; article : number
(define-struct (nntp struct:exn) ())
(define-struct (unexpected-response struct:nntp) (code text))
(define-struct (bad-status-line struct:nntp) (line))
(define-struct (premature-close struct:nntp) (communicator))
(define-struct (bad-newsgroup-line struct:nntp) (line))
(define-struct (non-existent-group struct:nntp) (group))
(define-struct (article-not-in-group struct:nntp) (article))
(define-struct (no-group-selected struct:nntp) ())
(define-struct (article-not-found struct:nntp) (article))
; signal-error :
; (exn-args ... -> exn) x format-string x values ... ->
; exn-args -> ()
; - throws an exception
(define signal-error
(lambda (constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(apply format format-string args)
(current-continuation-marks)
exn-args)))))
; default-nntpd-port-number :
; number
(define default-nntpd-port-number 119)
; connect-to-server :
; string [x number] -> commnicator
(define connect-to-server
(opt-lambda (server-name (port-number default-nntpd-port-number))
(let-values (((receiver sender)
(tcp-connect server-name port-number)))
(let ((communicator
(make-communicator sender receiver server-name port-number)))
(let-values (((code response)
(get-single-line-response communicator)))
(case code
((200)
communicator)
(else
((signal-error make-unexpected-response
"unexpected connection response: ~s ~s"
code response)
code response))))))))
; close-communicator :
; communicator -> ()
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
; disconnect-from-server :
; communicator -> ()
(define disconnect-from-server
(lambda (communicator)
(send-to-server communicator "QUIT")
(let-values (((code response)
(get-single-line-response communicator)))
(case code
((205)
(close-communicator communicator))
(else
((signal-error make-unexpected-response
"unexpected dis-connect response: ~s ~s"
code response)
code response))))))
; send-to-server :
; communicator x format-string x list (values) -> ()
(define send-to-server
(lambda (communicator message-template . rest)
(apply fprintf (communicator-sender communicator)
(string-append message-template "~n")
rest)))
; parse-status-line :
; string -> number x string
(define parse-status-line
(let ((pattern (regexp "([0-9]+) (.*)")))
(lambda (line)
(let ((match (cdr (or (regexp-match pattern line)
((signal-error make-bad-status-line
"malformed status line: ~s" line)
line)))))
(values (string->number (car match))
(cadr match))))))
; get-one-line-from-server :
; iport -> string
(define get-one-line-from-server
(lambda (server->client-port)
(read-line server->client-port 'return-linefeed)))
; get-single-line-response :
; communicator -> number x string
(define get-single-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ((status-line (get-one-line-from-server receiver)))
(parse-status-line status-line)))))
; get-rest-of-multi-line-response :
; communicator -> list (string)
(define get-rest-of-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let loop ()
(let ((l (get-one-line-from-server receiver)))
(cond
((eof-object? l)
((signal-error make-premature-close
"port prematurely closed during multi-line response")
communicator))
((string=? l ".")
'())
((string=? l "..")
(cons "." (loop)))
(else
(cons l (loop)))))))))
; get-multi-line-response :
; communicator -> number x string x list (string)
; -- The returned values are the status code, the rest of the status
; response line, and the remaining lines.
(define get-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ((status-line (get-one-line-from-server receiver)))
(let-values (((code rest-of-line)
(parse-status-line status-line)))
(values code rest-of-line (get-rest-of-multi-line-response)))))))
; open-news-group :
; communicator x string -> number x number x number
; -- The returned values are the number of articles, the first
; article number, and the last article number for that group.
(define open-news-group
(let ((pattern (regexp "([0-9]+) ([0-9]+) ([0-9]+)")))
(lambda (communicator group-name)
(send-to-server communicator "GROUP ~a" group-name)
(let-values (((code rest-of-line)
(get-single-line-response communicator)))
(case code
((211)
(let ((match (map string->number
(cdr
(or (regexp-match pattern rest-of-line)
((signal-error make-bad-newsgroup-line
"malformed newsgroup open response: ~s"
rest-of-line)
rest-of-line))))))
(let ((number-of-articles (car match))
(first-article-number (cadr match))
(last-article-number (caddr match)))
(values number-of-articles
first-article-number
last-article-number))))
((411)
((signal-error make-non-existent-group
"group ~s does not exist on server ~s"
group-name (communicator-server communicator))
group-name))
(else
((signal-error make-unexpected-response
"unexpected group opening response: ~s" code)
code rest-of-line)))))))
; head/body-of-message :
; string x number -> communicator x number -> list (string)
(define head/body-of-message
(lambda (command ok-code)
(lambda (communicator message-number)
(send-to-server communicator (string-append command " ~a")
(number->string message-number))
(let-values (((code response)
(get-single-line-response communicator)))
(if (= code ok-code)
(get-rest-of-multi-line-response communicator)
(case code
((423)
((signal-error make-article-not-in-group
"article number ~s not in group" message-number)
message-number))
((412)
((signal-error make-no-group-selected
"no group selected")))
((430)
((signal-error make-article-not-found
"no article number ~s found" message-number)
message-number))
(else
((signal-error make-unexpected-response
"unexpected message access response: ~s" code)
code response))))))))
; head-of-message :
; communicator x number -> list (string)
(define head-of-message
(head/body-of-message "HEAD" 221))
; body-of-message :
; communicator x number -> list (string)
(define body-of-message
(head/body-of-message "BODY" 222))
; make-desired-header :
; string -> desired
(define make-desired-header
(lambda (raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
((char-lower-case? c)
(list #\[ (char-upcase c) c #\]))
((char-upper-case? c)
(list #\[ c (char-downcase c) #\]))
(else
(list c))))
(string->list raw-header))))
":"))))
; extract-desired-headers :
; list (string) x list (desired) -> list (string)
(define extract-desired-headers
(lambda (headers desireds)
(let loop ((headers headers))
(if (null? headers) null
(let ((first (car headers))
(rest (cdr headers)))
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest)))))))
)

19
collects/net/nntps.ss
View File

@ -1,19 +0,0 @@
(require-library "macro.ss")
(define-signature mzlib:nntp^
((struct communicator (sender receiver server port))
connect-to-server disconnect-from-server
open-news-group
head-of-message body-of-message
make-desired-header extract-desired-headers
(struct nntp ())
(struct unexpected-response (code text))
(struct bad-status-line (line))
(struct premature-close (communicator))
(struct bad-newsgroup-line (line))
(struct non-existent-group (group))
(struct article-not-in-group (article))
(struct no-group-selected ())
(struct article-not-found (article))))

5
collects/net/nntpu.ss
View File

@ -1,5 +0,0 @@
(require-library "macro.ss")
(require-library "nntps.ss" "net")
(define mzlib:nntp@ (require-library-unit/sig "nntpr.ss" "net"))

32
collects/net/pop3.ss
View File

@ -1,32 +0,0 @@
(require-library "pop3u.ss" "net")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:pop3^
mzlib:pop3@ pop3)
#|
> (require-library "pop3.ss" "net")
> (define c (pop3:connect-to-server "cs.rice.edu"))
> (pop3:authenticate/plain-text "scheme" "********" c)
> (pop3:get-mailbox-status c)
100
177824
> (pop3:get-message/headers c 100)
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
...
"Status: RO")
> (pop3:get-message/complete c 100)
("Date: Thu, 6 Nov 1997 12:34:18 -0600 (CST)"
"Message-Id: <199711061834.MAA11961@new-world.cs.rice.edu>"
"From: Shriram Krishnamurthi <shriram@cs.rice.edu>"
...
"Status: RO")
("some body" "text" "goes" "." "here" "." "")
> (pop3:disconnect-from-server c)
|#

403
collects/net/pop3r.ss
View File

@ -1,403 +0,0 @@
; Time-stamp: <98/10/09 19:19:06 shriram>
(unit/sig mzlib:pop3^
(import)
;; Implements RFC 1939, Post Office Protocol - Version 3, Myers & Rose
;; sender : oport
;; receiver : iport
;; server : string
;; port : number
;; state : symbol = (disconnected, authorization, transaction)
(define-struct communicator (sender receiver server port state))
(define-struct (pop3 struct:exn) ())
(define-struct (cannot-connect struct:pop3) ())
(define-struct (username-rejected struct:pop3) ())
(define-struct (password-rejected struct:pop3) ())
(define-struct (not-ready-for-transaction struct:pop3) (communicator))
(define-struct (not-given-headers struct:pop3) (communicator message))
(define-struct (illegal-message-number struct:pop3) (communicator message))
(define-struct (cannot-delete-message struct:exn) (communicator message))
(define-struct (disconnect-not-quiet struct:pop3) (communicator))
(define-struct (malformed-server-response struct:pop3) (communicator))
;; signal-error :
;; (exn-args ... -> exn) x format-string x values ... ->
;; exn-args -> ()
(define signal-error
(lambda (constructor format-string . args)
(lambda exn-args
(raise (apply constructor
(apply format format-string args)
(current-continuation-marks)
exn-args)))))
;; signal-malformed-response-error :
;; exn-args -> ()
;; -- in practice, it takes only one argument: a communicator.
(define signal-malformed-response-error
(signal-error make-malformed-server-response
"malformed response from server"))
;; confirm-transaction-mode :
;; communicator x string -> ()
;; -- signals an error otherwise.
(define confirm-transaction-mode
(lambda (communicator error-message)
(unless (eq? (communicator-state communicator) 'transaction)
((signal-error make-not-ready-for-transaction error-message)
communicator))))
;; default-pop-port-number :
;; number
(define default-pop-port-number 110)
(define-struct server-responses ())
(define-struct (+ok struct:server-responses) ())
(define-struct (-err struct:server-responses) ())
(define +ok (make-+ok))
(define -err (make--err))
;; connect-to-server :
;; string [x number] -> communicator
(define connect-to-server
(opt-lambda (server-name (port-number default-pop-port-number))
(let-values (((receiver sender)
(tcp-connect server-name port-number)))
(let ((communicator
(make-communicator sender receiver server-name port-number
'authorization)))
(let ((response (get-status-response/basic communicator)))
(cond
((+ok? response) communicator)
((-err? response)
((signal-error make-cannot-connect
"cannot connect to ~a on port ~a"
server-name port-number)))))))))
;; authenticate/plain-text :
;; string x string x communicator -> ()
;; -- if authentication succeeds, sets the communicator's state to
;; transaction.
(define authenticate/plain-text
(lambda (username password communicator)
(let ((sender (communicator-sender communicator)))
(send-to-server communicator "USER ~a" username)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(send-to-server communicator "PASS ~a" password)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(set-communicator-state! communicator 'transaction))
((-err? status)
((signal-error make-password-rejected
"password was rejected"))))))
((-err? status)
((signal-error make-username-rejected
"username was rejected"))))))))
;; get-mailbox-status :
;; communicator -> number x number
;; -- returns number of messages and number of octets.
(define get-mailbox-status
(let ((stat-regexp (regexp "([0-9]+) ([0-9]+)")))
(lambda (communicator)
(confirm-transaction-mode communicator
"cannot get mailbox status unless in transaction mode")
(send-to-server communicator "STAT")
(apply values
(map string->number
(let-values (((status result)
(get-status-response/match communicator
stat-regexp #f)))
result))))))
;; get-message/complete :
;; communicator x number -> list (string) x list (string)
(define get-message/complete
(lambda (communicator message)
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "RETR ~a" message)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(split-header/body (get-multi-line-response communicator)))
((-err? status)
((signal-error make-illegal-message-number
"not given message ~a" message)
communicator message))))))
;; get-message/headers :
;; communicator x number -> list (string)
(define get-message/headers
(lambda (communicator message)
(confirm-transaction-mode communicator
"cannot get message headers unless in transaction state")
(send-to-server communicator "TOP ~a 0" message)
(let ((status (get-status-response/basic communicator)))
(cond
((+ok? status)
(let-values (((headers body)
(split-header/body
(get-multi-line-response communicator))))
headers))
((-err? status)
((signal-error make-not-given-headers
"not given headers to message ~a" message)
communicator message))))))
;; get-message/body :
;; communicator x number -> list (string)
(define get-message/body
(lambda (communicator message)
(let-values (((headers body)
(get-message/complete communicator message)))
body)))
;; split-header/body :
;; list (string) -> list (string) x list (string)
;; -- returns list of headers and list of body lines.
(define split-header/body
(lambda (lines)
(let loop ((lines lines) (header null))
(if (null? lines)
(values (reverse header) null)
(let ((first (car lines))
(rest (cdr lines)))
(if (string=? first "")
(values (reverse header) rest)
(loop rest (cons first header))))))))
;; delete-message :
;; communicator x number -> ()
(define delete-message
(lambda (communicator message)
(confirm-transaction-mode communicator
"cannot delete message unless in transaction state")
(send-to-server communicator "DELE ~a" message)
(let ((status (get-status-response/basic communicator)))
(cond
((-err? status)
((signal-error make-cannot-delete-message
"no message numbered ~a available to be deleted" message)
communicator message))
((+ok? status)
'deleted)))))
;; regexp for UIDL responses
(define uidl-regexp (regexp "([0-9]+) (.*)"))
;; get-unique-id/single :
;; communicator x number -> string
(define (get-unique-id/single communicator message)
(confirm-transaction-mode communicator
"cannot get unique message id unless in transaction state")
(send-to-server communicator "UIDL ~a" message)
(let-values (((status result)
(get-status-response/match communicator
uidl-regexp
".*")))
;; The server response is of the form
;; +OK 2 QhdPYR:00WBw1Ph7x7
(cond
((-err? status)
((signal-error make-illegal-message-number
"no message numbered ~a available for unique id" message)
communicator message))
((+ok? status)
(cadr result)))))
;; get-unique-id/all :
;; communicator -> list(number x string)
(define (get-unique-id/all communicator)
(confirm-transaction-mode communicator
"cannot get unique message ids unless in transaction state")
(send-to-server communicator "UIDL")
(let ((status (get-status-response/basic communicator)))
;; The server response is of the form
;; +OK
;; 1 whqtswO00WBw418f9t5JxYwZ
;; 2 QhdPYR:00WBw1Ph7x7
;; .
(map (lambda (l)
(let ((m (regexp-match uidl-regexp l)))
(cons (string->number (cadr m)) (caddr m))))
(get-multi-line-response communicator))))
;; close-communicator :
;; communicator -> ()
(define close-communicator
(lambda (communicator)
(close-input-port (communicator-receiver communicator))
(close-output-port (communicator-sender communicator))))
;; disconnect-from-server :
;; communicator -> ()
(define disconnect-from-server
(lambda (communicator)
(send-to-server communicator "QUIT")
(set-communicator-state! communicator 'disconnected)
(let ((response (get-status-response/basic communicator)))
(close-communicator communicator)
(cond
((+ok? response) (void))
((-err? response)
((signal-error make-disconnect-not-quiet
"got error status upon disconnect")
communicator))))))
;; send-to-server :
;; communicator x format-string x list (values) -> ()
(define send-to-server
(lambda (communicator message-template . rest)
(apply fprintf (communicator-sender communicator)
(string-append message-template "~n")
rest)))
;; get-one-line-from-server :
;; iport -> string
(define get-one-line-from-server
(lambda (server->client-port)
(read-line server->client-port 'return-linefeed)))
;; get-server-status-response :
;; communicator -> server-responses x string
;; -- provides the low-level functionality of checking for +OK
;; and -ERR, returning an appropriate structure, and returning the
;; rest of the status response as a string to be used for further
;; parsing, if necessary.
(define get-server-status-response
(let ((+ok-regexp (regexp "^\\+OK (.*)"))
(-err-regexp (regexp "^\\-ERR (.*)")))
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let ((status-line (get-one-line-from-server receiver)))
(let ((r (regexp-match +ok-regexp status-line)))
(if r
(values +ok (cadr r))
(let ((r (regexp-match -err-regexp status-line)))
(if r
(values -err (cadr r))
(signal-malformed-response-error communicator))))))))))
;; get-status-response/basic :
;; communicator -> server-responses
;; -- when the only thing to determine is whether the response
;; was +OK or -ERR.
(define get-status-response/basic
(lambda (communicator)
(let-values (((response rest)
(get-server-status-response communicator)))
response)))
;; get-status-response/match :
;; communicator x regexp x regexp -> (status x list (string))
;; -- when further parsing of the status response is necessary.
;; Strips off the car of response from regexp-match.
(define get-status-response/match
(lambda (communicator +regexp -regexp)
(let-values (((response rest)
(get-server-status-response communicator)))
(if (and +regexp (+ok? response))
(let ((r (regexp-match +regexp rest)))
(if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(if (and -regexp (-err? response))
(let ((r (regexp-match -regexp rest)))
(if r (values response (cdr r))
(signal-malformed-response-error communicator)))
(signal-malformed-response-error communicator))))))
;; get-multi-line-response :
;; communicator -> list (string)
(define get-multi-line-response
(lambda (communicator)
(let ((receiver (communicator-receiver communicator)))
(let loop ()
(let ((l (get-one-line-from-server receiver)))
(cond
((eof-object? l)
(signal-malformed-response-error communicator))
((string=? l ".")
'())
((and (> (string-length l) 1)
(char=? (string-ref l 0) #\.))
(cons (substring l 1 (string-length l)) (loop)))
(else
(cons l (loop)))))))))
;; make-desired-header :
;; string -> desired
(define make-desired-header
(lambda (raw-header)
(regexp
(string-append
"^"
(list->string
(apply append
(map (lambda (c)
(cond
((char-lower-case? c)
(list #\[ (char-upcase c) c #\]))
((char-upper-case? c)
(list #\[ c (char-downcase c) #\]))
(else
(list c))))
(string->list raw-header))))
":"))))
;; extract-desired-headers :
;; list (string) x list (desired) -> list (string)
(define extract-desired-headers
(lambda (headers desireds)
(let loop ((headers headers))
(if (null? headers) null
(let ((first (car headers))
(rest (cdr headers)))
(if (ormap (lambda (matcher)
(regexp-match matcher first))
desireds)
(cons first (loop rest))
(loop rest)))))))
)

26
collects/net/pop3s.ss
View File

@ -1,26 +0,0 @@
(require-library "macro.ss")
(define-signature mzlib:pop3^
((struct communicator (sender receiver server port state))
connect-to-server disconnect-from-server
authenticate/plain-text
get-mailbox-status
get-message/complete get-message/headers get-message/body
delete-message
get-unique-id/single get-unique-id/all
make-desired-header extract-desired-headers
(struct pop3 ())
(struct cannot-connect ())
(struct username-rejected ())
(struct password-rejected ())
(struct not-ready-for-transaction (communicator))
(struct not-given-headers (communicator message))
(struct illegal-message-number (communicator message))
(struct cannot-delete-message (communicator message))
(struct disconnect-not-quiet (communicator))
(struct malformed-server-response (communicator))
)
)

5
collects/net/pop3u.ss
View File

@ -1,5 +0,0 @@
(require-library "macro.ss")
(require-library "pop3s.ss" "net")
(define mzlib:pop3@ (require-library-unit/sig "pop3r.ss" "net"))

8
collects/net/smtp.ss
View File

@ -1,8 +0,0 @@
(require-relative-library "smtps.ss")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:smtp^
(require-relative-library "smtpr.ss"))

101
collects/net/smtpr.ss
View File

@ -1,101 +0,0 @@
(unit/sig mzlib:smtp^
(import)
(define ID "localhost")
(define debug-via-stdio? #f)
(define crlf (string #\return #\linefeed))
(define (log . args)
; (apply printf args)
(void))
(define (starts-with? l n)
(and (>= (string-length l) (string-length n))
(string=? n (substring l 0 (string-length n)))))
(define (check-reply r v)
(let ([l (read-line r (if debug-via-stdio?
'linefeed
'return-linefeed))])
(log "server: ~a~n" l)
(if (eof-object? l)
(error 'check-reply "got EOF")
(let ([n (number->string v)])
(unless (starts-with? l n)
(error 'check-reply "expected reply ~a; got: ~a" v l))
(let ([n- (string-append n "-")])
(when (starts-with? l n-)
; Multi-line reply. Go again.
(check-reply r v)))))))
(define (protect-line l)
; If begins with a dot, add one more
(if (or (string=? "" l) (not (char=? #\. (string-ref l 0))))
l
(string-append "." l)))
(define smtp-sending-end-of-message
(make-parameter void
(lambda (f)
(unless (and (procedure? f)
(procedure-arity-includes? f 0))
(raise-type-error 'smtp-sending-end-of-message "thunk" f))
f)))
(define smtp-send-message
(case-lambda
[(server sender recipients header message-lines)
(smtp-send-message server sender recipients header message-lines 25)]
[(server sender recipients header message-lines pos)
(when (null? recipients)
(error 'send-smtp-message "no recievers"))
(let-values ([(r w) (if debug-via-stdio?
(values (current-input-port) (current-output-port))
(tcp-connect server pos))])
(with-handlers ([void (lambda (x)
(close-input-port r)
(close-output-port w)
(raise x))])
(check-reply r 220)
(log "hello~n")
(fprintf w "EHLO ~a~a" ID crlf)
(check-reply r 250)
(log "from~n")
(fprintf w "MAIL FROM:<~a>~a" sender crlf)
(check-reply r 250)
(log "to~n")
(for-each
(lambda (dest)
(fprintf w "RCPT TO:<~a>~a" dest crlf)
(check-reply r 250))
recipients)
(log "header~n")
(fprintf w "DATA~a" crlf)
(check-reply r 354)
(fprintf w "~a" header)
(for-each
(lambda (l)
(log "body: ~a~n" l)
(fprintf w "~a~a" (protect-line l) crlf))
message-lines)
;; After we send the ".", then only break in an emergency
((smtp-sending-end-of-message))
(log "dot~n")
(fprintf w ".~a" crlf)
(flush-output w)
(check-reply r 250)
(log "quit~n")
(fprintf w "QUIT~a" crlf)
(check-reply r 221)
(close-output-port w)
(close-input-port r)))])))

4
collects/net/smtps.ss
View File

@ -1,4 +0,0 @@
(define-signature mzlib:smtp^
(smtp-send-message
smtp-sending-end-of-message))

20
collects/net/url.ss
View File

@ -1,20 +0,0 @@
(require-library "macro.ss")
(require-library "match.ss")
(require-library "file.ss")
(require-library "urlu.ss" "net")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:url^
(compound-unit/sig
(import
(FILE : mzlib:file^))
(link
(URL : mzlib:url^
(mzlib:url@ FILE)))
(export
(open URL)))
#f
mzlib:file^)

525
collects/net/urlr.ss
View File

@ -1,525 +0,0 @@
;; To do:
;; Handle HTTP/file errors.
;; Not throw away MIME headers.
;; Determine file type.
;; ----------------------------------------------------------------------
;; Input ports have two statuses:
;; "impure" = they have text waiting
;; "pure" = the MIME headers have been read
(unit/sig mzlib:url^
(import [file : mzlib:file^])
(define-struct (url-exception struct:exn) ())
;; This is commented out; it's here for debugging.
;; It used to be outside the unit.
(quote
(begin
(invoke-open-unit/sig mzlib:url@ #f)
(define url:cs (string->url "http://www.cs.rice.edu/"))
(define url:me (string->url "http://www.cs.rice.edu/~shriram/"))
(define comb combine-url/relative)
(define (test url)
(call/input-url url
get-pure-port
display-pure-port))))
(define url-error
(lambda (fmt . args)
(let ((s (apply format fmt (map (lambda (arg)
(if (url? arg)
(url->string arg)
arg))
args))))
(raise (make-url-exception s (current-continuation-marks))))))
;; if the path is absolute, it just arbitrarily picks the first
;; filesystem root.
(define unixpath->path
(letrec ([r (regexp "([^/]*)/(.*)")]
[translate-dir
(lambda (s)
(cond
[(string=? s "") 'same] ;; handle double slashes
[(string=? s "..") 'up]
[(string=? s ".") 'same]
[else s]))]
[build-relative-path
(lambda (s)
(let ([m (regexp-match r s)])
(cond
[(string=? s "") 'same]
[(not m) s]
[else
(build-path (translate-dir (cadr m))
(build-relative-path (caddr m)))])))])
(lambda (s)
(cond
[(string=? s "") ""]
[(string=? s "/") (car (filesystem-root-list))]
[(char=? #\/ (string-ref s 0))
(build-path (car (filesystem-root-list))
(build-relative-path
(substring s 1 (string-length s))))]
[else (build-relative-path s)]))))
;; scheme : str + #f
;; host : str + #f
;; port : num + #f
;; path : str
;; params : str + #f
;; query : str + #f
;; fragment : str + #f
(define-struct url (scheme host port path params query fragment))
;; name : str (all lowercase; not including the colon)
;; value : str (doesn't have the eol delimiter)
(define-struct mime-header (name value))
(define url->string
(lambda (url)
(let ((scheme (url-scheme url))
(host (url-host url))
(port (url-port url))
(path (url-path url))
(params (url-params url))
(query (url-query url))
(fragment (url-fragment url)))
(cond
((and scheme (string=? scheme "file"))
(string-append "file:" path))
(else
(let ((sa string-append))
(sa (if scheme (sa scheme "://") "")
(if host host "")
(if port (sa ":" (number->string port)) "")
; There used to be a "/" here, but that causes an
; extra leading slash -- wonder why it ever worked!
path
(if params (sa ";" params) "")
(if query (sa "?" query) "")
(if fragment (sa "#" fragment) ""))))))))
;; url->default-port : url -> num
(define url->default-port
(lambda (url)
(let ((scheme (url-scheme url)))
(cond
((not scheme) 80)
((string=? scheme "http") 80)
(else
(url-error "Scheme ~a not supported" (url-scheme url)))))))
;; make-ports : url -> in-port x out-port
(define make-ports
(lambda (url)
(let ((port-number (or (url-port url)
(url->default-port url))))
(tcp-connect (url-host url) port-number))))
;; http://get-impure-port : url [x list (str)] -> in-port
(define http://get-impure-port
(opt-lambda (url (strings '()))
(let-values (((server->client client->server)
(make-ports url)))
(let ((access-string
(url->string
(make-url #f #f #f
(url-path url) (url-params url)
(url-query url) (url-fragment url)))))
(for-each (lambda (s)
(display s client->server)
(newline client->server))
(cons (format "GET ~a HTTP/1.0" access-string)
(cons (format "Host: ~a" (url-host url))
strings))))
(newline client->server)
(close-output-port client->server)
server->client)))
;; file://get-pure-port : url -> in-port
(define file://get-pure-port
(lambda (url)
(let ((host (url-host url)))
(if (or (not host)
(string=? host "")
(string=? host "localhost"))
(open-input-file
(unixpath->path (url-path url)))
(url-error "Cannot get files from remote hosts")))))
;; get-impure-port : url [x list (str)] -> in-port
(define get-impure-port
(opt-lambda (url (strings '()))
(let ((scheme (url-scheme url)))
(cond
((not scheme)
(url-error "Scheme unspecified in ~a" url))
((string=? scheme "http")
(http://get-impure-port url strings))
((string=? scheme "file")
(url-error "There are no impure file:// ports"))
(else
(url-error "Scheme ~a unsupported" scheme))))))
;; get-pure-port : url [x list (str)] -> in-port
(define get-pure-port
(opt-lambda (url (strings '()))
(let ((scheme (url-scheme url)))
(cond
((not scheme)
(url-error "Scheme unspecified in ~a" url))
((string=? scheme "http")
(let ((port (http://get-impure-port url strings)))
(purify-port port)
port))
((string=? scheme "file")
(file://get-pure-port url))
(else
(url-error "Scheme ~a unsupported" scheme))))))
;; display-pure-port : in-port -> ()
(define display-pure-port
(lambda (server->client)
(let loop ()
(let ((c (read-char server->client)))
(unless (eof-object? c)
(display c)
(loop))))
(close-input-port server->client)))
(define empty-url?
(lambda (url)
(and (not (url-scheme url)) (not (url-params url))
(not (url-query url)) (not (url-fragment url))
(andmap (lambda (c) (char=? c #\space))
(string->list (url-path url))))))
;; combine-url/relative : url x str -> url
(define combine-url/relative
(lambda (base string)
(let ((relative (string->url string)))
(cond
((empty-url? base) ; Step 1
relative)
((empty-url? relative) ; Step 2a
base)
((url-scheme relative) ; Step 2b
relative)
(else ; Step 2c
(set-url-scheme! relative (url-scheme base))
(cond
((url-host relative) ; Step 3
relative)
(else
(set-url-host! relative (url-host base))
(set-url-port! relative (url-port base)) ; Unspecified!
(let ((rel-path (url-path relative)))
(cond
((and rel-path ; Step 4
(not (string=? "" rel-path))
(char=? #\/ (string-ref rel-path 0)))
relative)
((or (not rel-path) ; Step 5
(string=? rel-path ""))
(set-url-path! relative (url-path base))
(or (url-params relative)
(set-url-params! relative (url-params base)))
(or (url-query relative)
(set-url-query! relative (url-query base)))
relative)
(else ; Step 6
(if (and (url-scheme base)
(string=? (url-scheme base) "file"))
;; Important that:
;; 1. You set-url-path! the new path into
;; `relative'.
;; 2. You return `relative' as the value
;; from here without invoking
;; `merge-and-normalize'.
;; The variable `rel-path' contains the
;; path portion of the relative URL.
(let+ ([val base-path (url-path base)]
[val (values base name must-be-dir?)
(split-path base-path)]
[val base-dir (if must-be-dir? base-path base)]
[val ind-rel-path (unixpath->path rel-path)]
[val merged (build-path base-dir
ind-rel-path)])
(set-url-path! relative merged)
relative)
(merge-and-normalize
(url-path base) relative))))))))))))
(define merge-and-normalize
(lambda (base-path relative-url)
(let ((rel-path (url-path relative-url)))
(let ((base-list (string->list base-path))
(rel-list (string->list rel-path)))
(let*
((joined-list
(let loop ((base (reverse base-list)))
(if (null? base)
rel-list
(if (char=? #\/ (car base))
(append (reverse base) rel-list)
(loop (cdr base))))))
(grouped
(let loop ((joined joined-list) (current '()))
(if (null? joined)
(list (list->string (reverse current)))
(if (char=? #\/ (car joined))
(cons (list->string
(reverse (cons #\/ current)))
(loop (cdr joined) '()))
(loop (cdr joined)
(cons (car joined) current))))))
(grouped
(let loop ((grouped grouped))
(if (null? grouped) '()
(if (string=? "./" (car grouped))
(loop (cdr grouped))
(cons (car grouped) (loop (cdr grouped)))))))
(grouped
(let loop ((grouped grouped))
(if (null? grouped) '()
(if (null? (cdr grouped))
(if (string=? "." (car grouped)) '()
grouped)
(cons (car grouped) (loop (cdr grouped)))))))
(grouped
(let remove-loop ((grouped grouped))
(let walk-loop ((r-pre '()) (post grouped))
(if (null? post)
(reverse r-pre)
(let ((first (car post))
(rest (cdr post)))
(if (null? rest)
(walk-loop (cons first r-pre) rest)
(let ((second (car rest)))
(if (and (not (string=? first "../"))
(string=? second "../"))
(remove-loop
(append (reverse r-pre) (cddr post)))
(walk-loop (cons first r-pre) rest)))))))))
(grouped
(let loop ((grouped grouped))
(if (null? grouped) '()
(if (null? (cdr grouped)) grouped
(if (and (null? (cddr grouped))
(not (string=? (car grouped) "../"))
(string=? (cadr grouped) ".."))
'()
(cons (car grouped) (loop (cdr grouped)))))))))
(set-url-path! relative-url
(apply string-append grouped))
relative-url)))))
;; call/input-url : url x (url -> in-port) x (in-port -> T)
;; [x list (str)] -> T
(define call/input-url
(let ((handle-port (lambda (server->client handler)
(dynamic-wind (lambda () 'do-nothing)
(lambda () (handler server->client))
(lambda () (close-input-port server->client))))))
(case-lambda
((url getter handler)
(handle-port (getter url) handler))
((url getter handler params)
(handle-port (getter url params) handler)))))
(define empty-line?
(lambda (chars)
(or (null? chars)
(and (memv (car chars) '(#\return #\linefeed #\tab #\space))
(empty-line? (cdr chars))))))
(define extract-mime-headers-as-char-lists
(lambda (port)
(let headers-loop ((headers '()))
(let char-loop ((header '()))
(let ((c (read-char port)))
(if (eof-object? c)
(reverse headers) ; CHECK: INCOMPLETE MIME: SERVER BUG
(if (char=? c #\newline)
(if (empty-line? header)
(reverse headers)
(begin
(headers-loop (cons (reverse header) headers))))
(char-loop (cons c header)))))))))
;; purify-port : in-port -> list (mime-header)
(define purify-port
(lambda (port)
(let ((headers-as-chars (extract-mime-headers-as-char-lists port)))
(let header-loop ((headers headers-as-chars))
(if (null? headers)
'()
(let ((header (car headers)))
(let char-loop ((pre '()) (post header))
(if (null? post)
(header-loop (cdr headers))
(if (char=? #\: (car post))
(cons (make-mime-header
(list->string (reverse pre))
(list->string post))
(header-loop (cdr headers)))
(char-loop (cons (char-downcase (car post)) pre)
(cdr post)))))))))))
(define character-set-size 256)
(define marker-list
'(#\: #\; #\? #\#))
(define ascii-marker-list
(map char->integer marker-list))
(define marker-locations
(make-vector character-set-size))
(define first-position-of-marker
(lambda (c)
(vector-ref marker-locations (char->integer c))))
;; netscape/string->url : str -> url
(define netscape/string->url
(lambda (string)
(let ((url (string->url string)))
(if (url-scheme url)
url
(if (string=? string "")
(url-error "Can't resolve empty string as URL")
(begin
(set-url-scheme! url
(if (char=? (string-ref string 0) #\/)
"file"
"http"))
url))))))
;; string->url : str -> url
(define string->url
(lambda (string)
(let loop ((markers ascii-marker-list))
(unless (null? markers)
(vector-set! marker-locations (car markers) #f)
(loop (cdr markers))))
(let loop ((chars (string->list string)) (index 0))
(unless (null? chars)
(let ((first (car chars)))
(when (memq first marker-list)
(let ((posn (char->integer first)))
(unless (vector-ref marker-locations posn)
(vector-set! marker-locations posn index)))))
(loop (cdr chars) (add1 index))))
(let
((first-colon (first-position-of-marker #\:))
(first-semicolon (first-position-of-marker #\;))
(first-question (first-position-of-marker #\?))
(first-hash (first-position-of-marker #\#)))
(let
((scheme-start (and first-colon 0))
(path-start (if first-colon (add1 first-colon) 0))
(params-start (and first-semicolon (add1 first-semicolon)))
(query-start (and first-question (add1 first-question)))
(fragment-start (and first-hash (add1 first-hash))))
(let ((total-length (string-length string)))
(let*
((scheme-finish (and scheme-start first-colon))
(path-finish (if first-semicolon first-semicolon
(if first-question first-question
(if first-hash first-hash
total-length))))
(fragment-finish (and fragment-start total-length))
(query-finish (and query-start
(if first-hash first-hash
total-length)))
(params-finish (and params-start
(if first-question first-question
(if first-hash first-hash
total-length)))))
(let ((scheme (and scheme-start
(substring string
scheme-start scheme-finish))))
(if (and scheme
(string=? scheme "file"))
(make-url
scheme
#f ; host
#f ; port
(build-path (substring string path-start total-length))
#f ; params
#f ; query
#f) ; fragment
(let-values (((host port path)
(parse-host/port/path
string path-start path-finish)))
(make-url
scheme
host
port
path
(and params-start
(substring string params-start params-finish))
(and query-start
(substring string query-start query-finish))
(and fragment-start
(substring string fragment-start
fragment-finish))))))))))))
;; parse-host/port/path : str x num x num -> (str + #f) + (num + #f) + str
(define parse-host/port/path
(lambda (path begin-point end-point)
(let ((has-host? (and (>= (- end-point begin-point) 2)
(char=? (string-ref path begin-point) #\/)
(char=? (string-ref path (add1 begin-point))
#\/))))
(let ((begin-point (if has-host?
(+ begin-point 2)
begin-point)))
(let loop ((index begin-point)
(first-colon #f)
(first-slash #f))
(cond
((>= index end-point)
;; We come here only if the string has not had a /
;; yet. This can happen in two cases:
;; 1. The input is a relative URL, and the hostname
;; will not be specified. In such cases, has-host?
;; will be false.
;; 2. The input is an absolute URL with a hostname,
;; and the intended path is "/", but the URL is missing
;; a "/" at the end. has-host? must be true.
(let ((host/path (substring path begin-point end-point)))
(if has-host?
(values host/path #f "/")
(values #f #f host/path))))
((char=? #\: (string-ref path index))
(loop (add1 index) (or first-colon index) first-slash))
((char=? #\/ (string-ref path index))
(if first-colon
(values
(substring path begin-point first-colon)
(string->number (substring path (add1 first-colon)
index))
(substring path index end-point))
(if has-host?
(values
(substring path begin-point index)
#f
(substring path index end-point))
(values
#f
#f
(substring path begin-point end-point)))))
(else
(loop (add1 index) first-colon first-slash))))))))
)

18
collects/net/urls.ss
View File

@ -1,18 +0,0 @@
(require-library "macro.ss")
(require-library "files.ss")
(define-signature mzlib:url^
((struct url (scheme host port path params query fragment))
(struct mime-header (name value))
unixpath->path
get-pure-port ; url [x list (str)] -> in-port
get-impure-port ; url [x list (str)] -> in-port
display-pure-port ; in-port -> ()
purify-port ; in-port -> list (mime-header)
netscape/string->url ; (string -> url)
string->url ; str -> url
url->string
call/input-url ; url x (url -> in-port) x
; (in-port -> T)
; [x list (str)] -> T
combine-url/relative)) ; url x str -> url

5
collects/net/urlu.ss
View File

@ -1,5 +0,0 @@
(require-library "refer.ss")
(require-library "urls.ss" "net")
(define mzlib:url@
(require-library-unit/sig "urlr.ss" "net"))

230
collects/quasiquote/qq-client.ss
View File

@ -1,230 +0,0 @@
; Time-stamp: <98/05/08 22:29:05 shriram>
; * Need to make write-holdings-to-file set permissions appropriately.
; * add-{stock,fund} should check if the entry already exists.
; * Allow update of holdings.
; * Print numbers in columns.
; * Improve output quality and media.
; * Enable queries on individual holdings.
;; Format of RC file:
;; current-seconds (when file was last written)
;; ((entity quantity price) ...)
;; <eof>
;; where entity = (stock "...") or (fund "...")
(require-library "match.ss")
(require-library "date.ss")
(require-library "qq.ss" "quasiquote")
(define rc-file "~/.qqrc")
;; entity : entity
;; quantity : num
;; price : num
(define-struct holding (entity quantity price))
;; raw-holding->holding :
;; raw-holding -> holding
(define raw-holding->holding
(lambda (rh)
(match rh
((('stock name) quantity price)
(make-holding (stock name) quantity price))
((('fund name) quantity price)
(make-holding (fund name) quantity price))
(else (error 'qq-client "~s is an invalid entry in the database" rh)))))
;; holding->raw-holding :
;; holding -> raw-holding
(define holding->raw-holding
(lambda (h)
(list
(let ((entity (holding-entity h)))
(cond
((stock? entity) `(stock ,(entity-name entity)))
((fund? entity) `(fund ,(entity-name entity)))
(else
(error 'qq-client "~s is not a valid entity" entity))))
(holding-quantity h)
(holding-price h))))
;; write-holdings-to-file :
;; list (holding) -> ()
(define write-holdings-to-file
(lambda (holdings)
(let ((p (open-output-file rc-file 'replace)))
(display "; -*- Scheme -*-" p)
(newline p) (newline p)
(display "; Do not edit directly: please use QuasiQuote clients!" p)
(newline p) (newline p)
(write (current-seconds) p)
(newline p) (newline p)
(write (map holding->raw-holding holdings) p)
(newline p)
(close-output-port p))))
;; read-holdings-from-file :
;; () -> (seconds + #f) x list (holding)
(define read-holdings-from-file
(lambda ()
(with-handlers ((exn:i/o:filesystem? (lambda (exn)
(values #f null))))
(let ((p (open-input-file rc-file)))
(values (read p)
(map raw-holding->holding
(read p)))))))
;; update-holdings :
;; list (holding) -> list (holding)
(define update-holdings
(lambda (holdings)
(map (lambda (h)
(let ((entity (holding-entity h)))
(let ((new-value (get-quote entity)))
(make-holding entity (holding-quantity h) new-value))))
holdings)))
;; changed-positions :
;; list (holding) x list (holding) ->
;; list (holding . num) x list (holding . num) x list (holding)
(define changed-positions
(lambda (old-in new-in)
(let loop ((old old-in) (new new-in)
(increases null) (decreases null) (stays null))
(if (and (null? old) (null? new))
(values increases decreases stays)
(if (or (null? old) (null? new))
(error 'qq-client "~s and ~s cannot be compared for changes"
old-in new-in)
(let ((first-old (car old)) (first-new (car new)))
(if (string=? (entity-name (holding-entity first-old))
(entity-name (holding-entity first-new)))
(let* ((price-old (holding-price first-old))
(price-new (holding-price first-new))
(difference (- price-new price-old)))
(cond
((= price-old price-new)
(loop (cdr old) (cdr new)
increases
decreases
(cons first-new stays)))
((< price-old price-new)
(loop (cdr old) (cdr new)
(cons (cons first-new difference) increases)
decreases
stays))
(else
(loop (cdr old) (cdr new)
increases
(cons (cons first-new difference) decreases)
stays))))
(error 'qq-client "~s and ~s are in the same position"
first-old first-new))))))))
;; total-value :
;; list (holding) -> num
(define total-value
(lambda (holdings)
(apply +
(map (lambda (h)
(* (holding-quantity h) (holding-price h)))
holdings))))
;; print-position-changes :
;; list (holding . num) x list (holding . num) x list (holding) -> ()
(define print-position-changes
(lambda (increases decreases stays)
(define print-entry/change
(lambda (holding change)
(printf "~a ~a ~a~a~n"
(entity-name (holding-entity holding))
(holding-price holding)
(if (> change 0) "+" "-")
(abs change))))
(define print-change
(lambda (banner changes)
(unless (null? changes)
(printf "~a:~n" banner))
(for-each (lambda (h+delta)
(print-entry/change (car h+delta) (cdr h+delta)))
changes)
(newline)))
(print-change "Increases" increases)
(print-change "Decreases" decreases)))
;; print-statement :
;; () -> ()
(define print-statement
(lambda ()
(let-values (((old-time old-holdings)
(read-holdings-from-file)))
(let ((new-holdings (update-holdings old-holdings)))
(when old-time
(printf "Changes are since ~a~n~n"
(date->string (seconds->date old-time))))
(let-values (((increases decreases stays)
(changed-positions old-holdings new-holdings)))
(print-position-changes increases decreases stays))
(let ((old-total (total-value old-holdings))
(new-total (total-value new-holdings)))
(printf "Total change: ~a~nTotal value: ~a~n"
(- new-total old-total) new-total))
(write-holdings-to-file new-holdings)))))
;; create-holding :
;; (str -> entity) -> str x num -> holding
(define create-holding
(lambda (maker)
(lambda (name quantity)
(let ((entity (maker name)))
(let ((price (get-quote entity)))
(make-holding entity quantity price))))))
;; create-holding/stock :
;; str x num -> holding
(define create-holding/stock
(create-holding stock))
;; create-holding/fund :
;; str x num -> holding
(define create-holding/fund
(create-holding fund))
;; add-holding :
;; (str x num -> holding) -> x str x num -> ()
(define add-holding
(lambda (maker)
(lambda (name quantity)
(let-values (((old-time old-holdings)
(read-holdings-from-file)))
(write-holdings-to-file
(cons (maker name quantity)
old-holdings))))))
;; add-stock :
;; str x num -> ()
(define add-stock
(add-holding create-holding/stock))
;; add-fund :
;; str x num -> ()
(define add-fund
(add-holding create-holding/fund))

22
collects/quasiquote/qq.ss
View File

@ -1,22 +0,0 @@
(require-library "urls.ss" "net")
(require-library "refer.ss")
(require-library "coreu.ss")
(require-library "qqu.ss" "quasiquote")
(define quasiquote:program@
(compound-unit/sig
(import)
(link
(MZLIB-CORE : mzlib:core^
(mzlib:core@))
(URL : mzlib:url^
((require-library-unit/sig "urlr.ss" "net")
(MZLIB-CORE file)))
(INTERFACE : quasiquote:graphical-interface^
(quasiquote:graphical-interface@))
(QUOTESTER : quasiquote:quotester^
(quasiquote:quotester@ INTERFACE URL)))
(export
(open QUOTESTER))))
(define-values/invoke-unit/sig quasiquote:quotester^ quasiquote:program@)

21
collects/quasiquote/qqguir.ss
View File

@ -1,21 +0,0 @@
(unit/sig quasiquote:graphical-interface^
(import)
(define display-image-stream
(lambda (input-port stock-name)
(let ((tmp-file-name
(build-path (current-directory)
(string-append stock-name "."
(number->string (current-seconds))
".gif"))))
(let ((p (open-output-file tmp-file-name)))
(let loop ()
(let ((c (read-char input-port)))
(unless (eof-object? c)
(display c p)
(loop))))
(close-output-port p)
(close-input-port input-port)
(process (string-append "xv " tmp-file-name))))))
)

98
collects/quasiquote/qqr.ss
View File

@ -1,98 +0,0 @@
(unit/sig quasiquote:quotester^
(import
quasiquote:graphical-interface^
(url : mzlib:url^))
(define-struct entity (name))
(define-struct (stock struct:entity) ())
(define-struct (fund struct:entity) ())
(define get-chart
(lambda (entity)
(define base-directory-for-stocks "/sm/pg/")
;; Rule: append <capital initial of entity>/<entity>.gif
(define base-directory-for-funds "/sm/trmfg/")
;; Rule: append <capital initial of entity>/<entity>.gif
(define handle-processing
(lambda (base-dir)
(let ((s (entity-name entity)))
(display-image-stream
(url:get-pure-port
(url:make-url "http" "www.stockmaster.com" #f
(string-append base-dir "/"
(string (string-ref s 0))
"/" s ".gif")
#f #f #f))
s))))
(cond
((stock? entity)
(handle-processing base-directory-for-stocks))
((fund? entity)
(handle-processing base-directory-for-funds))
(else
(error 'get-chart
"~s is not a stock or fund" entity)))))
;; http://www.stocksmart.com/ows-bin/owa/sq.returnPrice?symbol=<SYMBOL>
;; (regexp "<TD ALIGN=\"RIGHT\">\\$(.+)</TD>")
;; no longer works -- advantage is it provided ratios instead of decimals
;; http://quote.yahoo.com/q?s=<SYMBOL>&d=v1
;; provides some quotes as ratios -- hence the second regexp
(define extract-quote-amount
(let ((quote-pattern (regexp "<td nowrap><b>(.+)</b></td>"))
(ratio-pattern (regexp "<sup>([0-9]+)</sup>/<sub>([0-9]+)</sub>")))
(lambda (port symbol)
(let loop ()
(let ((line (read-line port)))
(if (eof-object? line)
(error 'get-quote
"No quote found for ~s" (entity-name symbol))
(let ((matched (regexp-match quote-pattern line)))
(if matched
(let ((value
(let (($string (cadr matched)))
(let ((p (open-input-string $string)))
(let loop ((sum 0))
(let ((r (read p)))
(if (eof-object? r)
sum
(loop (+ (if (number? r)
r
(let ((ratio-matched
(regexp-match
ratio-pattern
(symbol->string r))))
(if ratio-matched
(/ (string->number
(cadr ratio-matched))
(string->number
(caddr ratio-matched)))
(error 'get-quote
"Unrecognized quote ~s"
r))))
sum)))))))))
;; out of courtesy to the server, we'll read it all
(let finish-loop ()
(let ((line (read-line port)))
(unless (eof-object? line)
(finish-loop))))
value)
(loop)))))))))
(define get-quote
(lambda (symbol)
(extract-quote-amount
(url:get-pure-port
(url:make-url "http" "quote.yahoo.com" #f
"/q" ;; leading slash essential
#f
(string-append "s=" (entity-name symbol) "&d=v1")
#f))
symbol)))
(define stock make-stock)
(define fund make-fund)
)

11
collects/quasiquote/qqs.ss
View File

@ -1,11 +0,0 @@
(define-signature quasiquote:graphical-interface^
(display-image-stream))
(define-signature quasiquote:quotester^
(get-chart
get-quote
(struct entity (name))
(struct stock ())
(struct fund ())
stock
fund))

8
collects/quasiquote/qqu.ss
View File

@ -1,8 +0,0 @@
(require-library "refer.ss")
(require-library "qqs.ss" "quasiquote")
(define quasiquote:quotester@
(require-library-unit/sig "qqr.ss" "quasiquote"))
(define quasiquote:graphical-interface@
(require-library-unit/sig "qqguir.ss" "quasiquote"))

54
collects/readline/doc.txt
View File

@ -1,54 +0,0 @@
The _readline_ collection (not to be confused with MzScheme's
`read-line' procedure) provides glue for using GNU's readline library
with the MzScheme read-eval-print-loop. It has been tested under Linux
(various flavors), FreeBSD, and Solaris.
To use readline, you must be able to compile the "mzrl.c" file to
produce a MzScheme extension, which requires a C compiler. The
"mzmake.ss" program in the "readline" library attempts to compile it
for you, and the collection installer runs "mzmake.ss". Thus, if the
installation succeeds, you can use the readline library right
away. Otherwise, you may have to modified "mzmake.ss" to get it to
work.
Normal use of readline
----------------------
The _rep.ss_ library installs a readline-based function for the
prompt-and-read part of MzScheme's read-eval-print loop.
I put the following in my ~/.mzschemerc so that MzScheme always starts
with readline support:
(require-library "rep.ss" "readline")
The readline history is stored across invocations in ~/.mzrl.history,
assuming MzScheme exits normally.
Direct bindings for readline hackers
------------------------------------
The _readline.ss_ library provides two functions:
> (readline prompt-string) - prints the given prompt string and reads
an S-expression.
> (add-history s) - adds the given string to the readline history,
which is accessible to the user via the up-arrow key
Known Bugs
----------
Hitting ctl-C more than once tends to make either readline or MzScheme
crash (I'm not sure which one).
mflatt@cs.utah.edu
Note to self: pack with
(pack "readline.plt" "readline" '("collects/readline") '(("readline")))

10
collects/readline/info.ss
View File

@ -1,10 +0,0 @@
(lambda (request failure-thunk)
(case request
[(name) "readline"]
[(install-collection)
(lambda (path)
(parameterize ([current-namespace (make-namespace)]
[current-directory (build-path path "collects" "readline")])
(global-defined-value 'argv #())
(load "mzmake.ss")))]
[else (failure-thunk)]))

116
collects/readline/mzmake.ss
View File

@ -1,116 +0,0 @@
#!/bin/sh -f
string=? ; if [ "$PLTHOME" = "" ] ; then
string=? ; echo Please define PLTHOME
string=? ; exit -1
string=? ; fi
string=? ; exec ${PLTHOME}/bin/mzscheme -qr $0 "$@"
;;; This program attempts to compile and link mzrl.c.
;;; See doc.txt for more information.
(define mach-id (string->symbol (system-library-subpath)))
;; Is the readline library in /usr/local/gnu ?
;; We look for the readline library and includes in the
;; following places:
(define search-path
(list "/usr"
"/usr/local/gnu"
;; Hack for the author's convenience:
(format "/home/mflatt/proj/readline-2.1/~a" mach-id)))
(define rl-path
(ormap (lambda (x)
(and (directory-exists? (build-path x "include" "readline"))
(or (file-exists? (build-path x "lib" "libreadline.a"))
(file-exists? (build-path x "lib" "libreadline.so")))
x))
search-path))
(unless rl-path
(error 'readline-installer
"can't find readline include files and/or library; try editing `search-path' in mzmake.ss"))
(require-library "make.ss" "make")
(require-library "link.ss" "dynext")
(require-library "compile.ss" "dynext")
(require-library "file.ss" "dynext")
(require-library "file.ss")
(require-library "functio.ss")
(make-print-checking #f)
;; Used as make dependencies:
(define header (build-path (collection-path "mzscheme" "include") "scheme.h"))
(define version-header (build-path (collection-path "mzscheme" "include") "schvers.h"))
(define dir (build-path "compiled" "native" (system-library-subpath)))
(define mzrl.so (build-path dir (append-extension-suffix "mzrl")))
(define mzrl.o (build-path dir (append-object-suffix "mzrl")))
;; Function used to add a command-line flag:
(define (add-flags fp flags)
(fp (append (fp) flags)))
;; Add -I to compiler command-line
(add-flags current-extension-compiler-flags
(list (format "-I~a/include" rl-path)))
;; More platform-specific compiler flags.
(case mach-id
[(rs6k-aix)
(add-flags current-extension-compiler-flags
(list "-DNEEDS_SELECT_H"))]
[else (void)])
;; If we don't have a .so file, we need to make the linker
;; use the whole archive:
(when (not (file-exists? (build-path rl-path "lib" "libreadline.so")))
(case mach-id
[(sparc-solaris i386-solaris)
(add-flags current-extension-linker-flags
(list "-u" "rl_readline_name"))]
[(i386-linux i386-freebsd)
(add-flags current-extension-linker-flags
(list "--whole-archive"))]
[else (fpritnf (current-error-port)
"mzmake.ss Warning: trying to use .a library, but don't know how to force inclusion;~
~n result may have undefined references~n")]))
;; Add -L and -l for readline:
(add-flags current-extension-linker-flags
(list (format "-L~a/lib" rl-path)
"-lreadline"))
; More platform-specific linker flags.
(case mach-id
[(sparc-solaris i386-solaris)
(add-flags current-extension-linker-flags
(list "-ltermcap"))]
[(rs6k-aix)
(add-flags current-extension-linker-flags
(list "-lc"))]
[else (void)])
;; Add the -lcurses flag:
(add-flags current-extension-linker-flags (list "-lcurses"))
(define (delete/continue x)
(with-handlers ([(lambda (x) #t) void])
(delete-file x)))
(make
((mzrl.so (mzrl.o dir)
(link-extension #f (list mzrl.o) mzrl.so))
(mzrl.o ("mzrl.c" header version-header dir)
(compile-extension #f "mzrl.c" mzrl.o ()))
("clean" () (begin (delete/continue mzrl.o) (delete/continue mzrl.so)))
(dir ()
(make-directory* dir)))
argv)

94
collects/readline/mzrl.c
View File

@ -1,94 +0,0 @@
#include "escheme.h"
#include <sys/types.h>
#include <sys/time.h>
#include <unistd.h>
#ifdef NEEDS_SELECT_H
# include <sys/select.h>
#endif
#include <readline/readline.h>
/* For pre-102 compatibility: */
#ifndef MZ_DECL_VAR_REG
# define MZ_DECL_VAR_REG(x) /* empty */
# define MZ_VAR_REG(p, x) /* empty */
# define MZ_CWVR(x) x
#endif
extern Function *rl_event_hook;
Scheme_Object *do_readline(int argc, Scheme_Object **argv)
{
char *s;
Scheme_Object *o;
if (!SCHEME_STRINGP(argv[0]))
scheme_wrong_type("readline", "string", 0, argc, argv);
s = readline(SCHEME_STR_VAL(argv[0]));
if (!s)
return scheme_eof;
o = scheme_make_string(s);
free(s);
return o;
}
Scheme_Object *do_add_history(int argc, Scheme_Object **argv)
{
char *s;
Scheme_Object *o;
if (!SCHEME_STRINGP(argv[0]))
scheme_wrong_type("add-history", "string", 0, argc, argv);
add_history(SCHEME_STR_VAL(argv[0]));
return scheme_void;
}
static int check(Scheme_Object *x)
{
fd_set fd;
struct timeval time = {0, 0};
FD_ZERO(&fd);
FD_SET(0, &fd);
return select(1, &fd, NULL, NULL, &time);
}
static void set_fd_wait(Scheme_Object *x, void *fd)
{
MZ_FD_SET(0, (fd_set *)fd);
}
static int block(void)
{
scheme_block_until(check, set_fd_wait, scheme_void, 0.0);
return 0;
}
Scheme_Object *scheme_reload(Scheme_Env *env)
{
Scheme_Object *a[2];
MZ_DECL_VAR_REG(2);
MZ_VAR_REG(0, a[0]);
MZ_VAR_REG(1, a[1]);
a[0] = MZ_CWVR(scheme_make_prim_w_arity(do_readline, "readline", 1, 1));
a[1] = MZ_CWVR(scheme_make_prim_w_arity(do_add_history, "add-history", 1, 1));
return MZ_CWVR(scheme_values(2, a));
}
Scheme_Object *scheme_initialize(Scheme_Env *env)
{
rl_readline_name = "mzscheme";
rl_event_hook = block;
return scheme_reload(env);
}

61
collects/readline/pread.ss
View File

@ -1,61 +0,0 @@
(let*-values ([(.history) "~/.mzrl.history"]
[(MAX-HISTORY) 100]
[(readline add-history) (require-library "readline.ss" "readline")]
[(leftovers) null]
[(local-history)
(with-handlers ([void (lambda (exn) null)])
(with-input-from-file .history
(lambda () (read))))]
[(do-readline)
(lambda (p)
(let ([s (readline p)])
(when (string? s)
(add-history s)
(if (= (length local-history) MAX-HISTORY)
(set! local-history (cdr local-history)))
(set! local-history (append local-history (list s))))
s))]
[(save-history)
(lambda ()
(with-handlers ([void void])
(with-output-to-file .history
(lambda () (write local-history))
'truncate)))])
(exit-handler (let ([old (exit-handler)])
(lambda (v)
(save-history)
(old v))))
(for-each add-history local-history)
(let ([prompt-read-using-readline
(lambda (get-prompt)
(if (pair? leftovers)
(begin0
(car leftovers)
(set! leftovers (cdr leftovers)))
(let big-loop ()
(let loop ([s (do-readline (get-prompt 0))][next-pos 1])
(if (eof-object? s)
(begin
(save-history)
s)
(with-handlers ([exn:read:eof?
(lambda (exn)
(loop (string-append
s
(string #\newline)
(do-readline (get-prompt next-pos)))
(add1 next-pos)))])
(let* ([p (open-input-string s)]
[rs (let loop ()
(let ([r (read p)])
(if (eof-object? r)
null
(cons r (loop)))))])
(if (null? rs)
(big-loop)
(begin0
(car rs)
(set! leftovers (cdr rs)))))))))))])
prompt-read-using-readline))

2
collects/readline/readline.ss
View File

@ -1,2 +0,0 @@
(load-relative-extension (build-path "compiled" "native" (system-library-subpath) "mzrl.so"))

10
collects/readline/rep.ss
View File

@ -1,10 +0,0 @@
(current-prompt-read
(let ([read (require-library "pread.ss" "readline")]
[orig-read (current-prompt-read)]
[orig-input (current-input-port)])
(lambda ()
(if (eq? (current-input-port) orig-input)
(read (lambda (n) (if (zero? n) "> " " ")))
(orig-read)))))

289
collects/setup/doc.txt
View File

@ -1,289 +0,0 @@
_Setup PLT_ or _setup-plt_: Collection Setup and Unpacking
==========================================================
The Setup PLT executable (bin/setup-plt for Unix) performs two
services:
* Compiling and setting up all collections: When Setup PLT is run
without any arguments, it finds all of the current collections
(using the PLTHOME and PLTCOLLECTS environment variable)
and compiles all collections with an info.ss library that
indicates how the collection is compiled (see the
--collection-zos flag for mzc).
The --clean (or -c) flag to Setup PLT causes it to delete
all existing .zo and extension files, thus ensuring a clean
build from the source files. (Exactly which files are deleted
is controlled by the info.ss file. See below for more info.)
The -l flag takes one or more collection names and restricts
Setup PLT's action to those collections.
In addition to compilation, a collection's info.ss library
can specify executables to be installed in the plt directory
(plt/bin under Unix) or other installation actions.
* Unpacking _.plt_ files: A .plt file is a platform-indepedent
distribution archive for MzScheme- and MrEd-based software.
When one or more file names are provided as the command line
arguments to Setup PLT, the files contained in the .plt
archive are unpacked (according to specifications embedded in
the .plt file; see below) and only the collections specified
by the plt file are compiled and setup (they are setup as if
the "-c" or "--clean" flag had been passed to setup plt)
Compiling and Setting Up Collections
------------------------------------
Setup PLT attempts to compile and set up any collection that:
* has an info.ss library;
* is a top-level collection (not a sub-collection; top-level
collections can specify subcollections to be compiled and
set up with the `compile-subcollections' info.ss field);
and
* has the 'name info.ss field.
Collections meeting this criteria are compiled using the
`compile-collection-zos' procedure described above. If the -e or
--extension flag is specified, then the collections are also compiled
using the `compile-collection-extension' procedure described above.
Additional info.ss fields trigger additional setup actions:
> 'mzscheme-launcher-names - a list of executable names to be
installed in plt (or plt/bin) to run MzScheme programs implemented
by the collection. A parallel list of library names must be
provided by `mzscheme-launcher-libraries'. For each name, a
launching executable is set up using the launcher collection's
`install-mzscheme-program-launcher'. If the executable already
exists, no action is taken.
> 'mzscheme-launcher-libraries - a list of library names in
parallel to `mzscheme-launcher-names'.
> 'mred-launcher-names - a list of executable names to be installed
in plt (or plt/bin) to run MrEd programs implemented by the
collection. A parallel list of library names must be provided by
`mred-launcher-libraries'. For each name, a launching executable is
set up using the launcher collection's
`install-mred-program-launcher'. If the executable already exists,
no action is taken.
> 'mred-launcher-libraries - a list of library names in
parallel to `mred-launcher-names'.
> 'install-collection - a procedure that accepts a directory path
argument (the path to the collection) and performs
collection-specific installation work. This procedure should avoid
unnecessary work in the case that it is called multiple times for
the same installation.
> 'clean - a list of pathnames to be deleted when the --clean or
-c flag is passed to setup-plt. The pathnames must be relative to
the collection. If the any path names a directory, each of the
files in the directory are deleted but none of the subdirectories of that
directory are checked. If the path names a file,
the file is deleted. The default, if this flag is not specified, is
to delete all files in the compiled subdirectory.
and all of the files in the architecture-specific subdirectory of
the compiled directory, for the architecture that setup-plt
is running under.
Unpacking .plt Distribution Archives
------------------------------------
The extension ".plt" is not required for a distribution archive; this
convention merely helps users identify the purpose of a distribution
file.
The raw format of a distribution file is described below. This format
is uncompressed and sensitive to communication modes (text
vs. binary), so the distribution format is derived from the raw format
by first compressing the file using gzip, then encoding the gzipped
file with the MIME base64 standard (which relies only the characters
A-Z, a-z, 0-9, +, /, and =; all other characters are ignored when
a base64-encoded file is decoded).
The raw format is
* "PLT" are the first three characters.
* An info.ss-like procedure that takes a symbol and a failure thunk
and returns information about archive for recognized symbols. The
two required info fields are:
+ 'name - a human-readable string describing the archive's
contents. This name is used only for printing messages to the
user during unpacking.
+ 'unpacker - a symbol indicating the expected unpacking
environment. Currently, the only allowed value is 'mzscheme.
The procedure is extracted from the archive using MzScheme's
`read' and `eval' procedures.
* An unsigned unit that drives the unpacking process. The unit accepts two
imports: a path string for the plt directory and an `unmztar'
procedure. The remainder of the unpacking process consists of invoking
ths unit. It is expected that the unit will call `unmztar' procedure to
unpack directories and files that are defined in the input archive afer
this unit. The result of invoking the unit must be a list of collection
paths (where each collection path is a list of strings); once the
archive is unpacked, Setup PLT will compile and setup the specified
collections, as if it was invoked with the "-c" option, so the
"compiled" directories will be deleted.
The `unmztar' procedure takes one argument: a filter
procedure. The filter procedure is called for each directory and
file to be unpacked. It is called with three arguments:
+ 'dir, 'file, 'file-replace - indicates whether the item to be
unpacked is a directory, a file, or a file to be replaced;
+ a relative path string - the pathname of the directory or file
to be unpacked, relative to the plt directory; and
+ a path string for the plt directory.
If the filter procedure returns #f for a directory or file, the
directory or file is not unpacked. If the filter procedure returns
#t and the directory or file for 'dir or 'file already exists, it
is not created. (The file for 'file-replace need not exist
already.)
When a directory is unpacked, intermediate directies are created
as necessary to create the specified directory. When a file is
unpacked, the directory must already exist.
The unit is extracted from the archive using MzScheme's `read'
and `eval' procedures.
Assuming that the unpacking unit calls the `unmztar' procedure, the
archive should continue with unpackables. Unpackables are extracted
until the end-of-file is found (as indicated by an `=' in the
base64-encoded input archive).
An unpackable is one of the following:
* The symbol 'dir followed by a list. The `build-path' procedure
will be applied to the list to obtain a relative path for the
directory (and the relatie path is combined with the plt directory
path to ge a complete path).
The 'dir symbol and list are extracted from the archive using
MzScheme's `read' (and the result is *not* `eval'uated).
* The symbol 'file, a list, a number, an asterisk, and the file
data. The list specifies the file's relative path, just as for
directories. The number indicates the size of the file to be
unpacked in bytes. The asterisk indicates the start of the file
data; the next n bytes are written to the file, where n is the
specified size of the file.
The symbol, list, and number are all extracted from the archive
using MzScheme's `read' (and the result is *not* `eval'uated).
After the number is read, input characters are discarded until
an asterisk is found. The file data must follow this asterisk
immediately.
* The symbol 'file-replace is treated like 'file, but if the file
exists on disk already, the file in the archive replaces the file
on disk.
Making .plt archives
--------------------
The setup collection's pack.ss library provides functions to help
make .plt archives, especially under Unix:
> (pack dest name paths collections [filter encode? file-mode]) -
Creates the .plt file specified by the pathname `dest', using the
string `name' as the name reported to Setup PLT as the archive's
description, and `collections' as the list of colection paths
returned by the unpacking unit. The `paths argument must be a list
of relative paths for directories and files; the contents of these
files and directories will be packed into the archive.
The `filter' procedure is called with the relative path of each
candidate for packing. If it returns #f for some path, then that
file or directory is omitted from the archive. If it returns 'file
or 'file-replace for a file, the file is packed with that mode,
rather than the default mode. The default `filter' is `std-filter'
(defined below).
If `encode?' is #f, then the output archive is in raw form, and
still must be gzipped and mime-encoded. If `encode?' is #t, then
gzip and mmencode must be in the shell's path for executables.
the default value is #t.
The `file-mode' argument must be 'file or 'file-replace, indicating
the default mode for a file in the archive. The default value is
'file.
> (std-filter p) - returns #t unless `p' matches one of the following
regular expressions: "CVS$", "compiled$", "~$", or "^#.*#$".
> (mztar path output filter file-mode) - called by `pack' to write one
directory/file `path' to the output port `output' using the filter
procedure `filter' (see `pack' for a description of `filter'). The
`file-mode' argument specifies the default mode for packing a file,
either 'file or 'file-replace.
Setup PLT as a Unit
-------------------
The _setupr.ss_ library in the setup collection contains a signed
unit that imports
setup-option^ - described below
mzlib:file^
compiler^ - from sig.ss in the compiler collection
compiler:option^ - from sig.ss in the compiler collection
launcher-maker^ - from launchers.ss in the `launcher' collection
Invoking this unit starts the setup process. The _setupsig.ss_ library
defines the
> setup-option^
signature, which is implemented by the unit in _setup-optionr.ss_. It
defines the following parameters that control the setup process:
> verbose - #t => prints message from `make' to stderr [default: #f]
> make-verbose - #t => verbose `make' [default: #f]
> compiler-verbose - #t => verbose `compiler' [default: #f]
> clean - #t => delete .zo and .so/.dll files in the specified collections
[default: #f]
> make-zo - #t => compile .zo files [default #t]
> make-so - #t => compile .so/.dll files [default: #f]
> make-launchers - #t => make collection info.ss-specified launchers
[default: #t]
> call-install - #t => call collection info.ss-specified setup code
[default: #t]
> specific-collections - a list of collections to set up; the empty
list means set-up all collections if the archives
list is also empty [default: null]
> archives - a list of .plt archives to unpack; any collections specified
by the archives are set-up in addition to the collections
listed in specific-collections [default: null]
Thus, to unpack a single .plt archive "x.plt", set the `archives'
parameter to (list "x.plt") and leave `specific-collections' as null.
Link the options and setup units so that your option-setting code is
initialized between them, e.g.:
(compound-unit/sig
...
(link ...
[OPTIONS : setup-option^
((require-library "setup-optionr.ss" "setup"))]
[MY-CODE : ()
((require-library "init-options.ss") OPTIONS)]
[SETUP : ()
((require-library "setupr.ss" "setup")
OPTIONS ...)])
...)

12
collects/setup/info.ss
View File

@ -1,12 +0,0 @@
(lambda (request failure)
(case request
[(name) "Setup PLT"]
[(compile-prefix) `(begin
(require-library "refer.ss")
(require-library "setupsig.ss" "setup"))]
[(compile-omit-files) (list "setup.ss" "setupsig.ss")]
[(compile-elaboration-zos) (list "setupsig.ss")]
[(mzscheme-launcher-libraries) (list "setup.ss")]
[(mzscheme-launcher-names) (list "Setup PLT")]
[else (failure)]))

100
collects/setup/pack.ss
View File

@ -1,100 +0,0 @@
;; Utilities for creating a .plt package, relies on gzip and mmencode
(define pack
(case-lambda
[(dest name paths collections)
(pack dest name paths collections std-filter #t 'file)]
[(dest name paths collections filter)
(pack dest name paths collections filter #t 'file)]
[(dest name paths collections filter encode?)
(pack dest name paths collections filter encode? 'file)]
[(dest name paths collections filter encode? file-mode)
(let* ([p (if encode?
(process (format "gzip -c | mmencode > ~s" dest))
#f)]
[stdin (if p
(cadr p)
(open-output-file dest 'truncate/replace))]
[echo (lambda (p)
(thread
(lambda ()
(let loop ()
(let ([l (read-line p 'any)])
(unless (eof-object? l)
(printf "~a~n" l)
(loop)))))))]
[t1 (and p (echo (car p)))]
[t2 (and p (echo (list-ref p 3)))])
(fprintf stdin "PLT~n")
(write
`(lambda (request failure)
(case request
[(name) ,name]
[(unpacker) 'mzscheme]))
stdin)
(newline stdin)
(write
`(unit
(import plthome mzuntar)
(export)
(mzuntar void)
(quote ,collections))
stdin)
(newline stdin)
(for-each
(lambda (path)
(mztar path stdin filter file-mode))
paths)
(close-output-port stdin)
(when p
(thread-wait t1)
(thread-wait t2)))]))
(define (mztar path output filter file-mode)
(define (path->list p)
(let-values ([(base name dir?) (split-path p)])
(if (string? base)
(append (path->list base) (list name))
(list name))))
(define-values (init-dir init-files)
(if (file-exists? path)
(let-values ([(base name dir?) (split-path path)])
(values base (list name)))
(values path #f)))
(let loop ([dir init-dir][dpath (path->list init-dir)][files init-files])
(printf "MzTarring ~a~a...~n" dir
(if files (car files) ""))
(fprintf output "~s~n~s~n" 'dir dpath)
(for-each
(lambda (f)
(let* ([p (build-path dir f)]
[filter-val (filter p)])
(when filter-val
(if (directory-exists? p)
(loop p (append dpath (list f)) #f)
(let ([len (file-size p)])
; (printf "MzTarring ~a~n" p)
(fprintf output "~s~n~s~n~s~n*"
(case filter-val
[(file) 'file]
[(file-replace) 'file-replace]
[else file-mode])
(append dpath (list f))
len)
(with-input-from-file p
(lambda ()
(let loop ()
(let ([c (read-char)])
(unless (eof-object? c)
(write-char c output)
(loop)))))))))))
(or files (directory-list dir)))))
(define (std-filter path)
(not (or (regexp-match "CVS$" path)
(regexp-match "compiled$" path)
(regexp-match "~$" path)
(regexp-match "^#.*#$" path))))

19
collects/setup/setup-optionr.ss
View File

@ -1,19 +0,0 @@
(unit/sig setup-option^
(import)
(define verbose (make-parameter #f))
(define make-verbose (make-parameter #f))
(define compiler-verbose (make-parameter #f))
(define clean (make-parameter #f))
(define make-zo (make-parameter #t))
(define make-so (make-parameter #f))
(define make-launchers (make-parameter #t))
(define call-install (make-parameter #t))
(define pause-on-errors (make-parameter #f))
(define specific-collections (make-parameter null))
(define archives (make-parameter null)))

91
collects/setup/setup.ss
View File

@ -1,91 +0,0 @@
(parameterize ([use-compiled-file-kinds 'none])
(require-library "compile.ss" "compiler"))
(parameterize ([use-compiled-file-kinds 'none])
(require-library "cmdline.ss")
(require-relative-library "setupsig.ss")
(require-library "invoke.ss"))
(define-values/invoke-unit/sig setup-option^
(parameterize ([use-compiled-file-kinds 'none])
(require-relative-library "setup-optionr.ss")))
(define-values (x-specific-collections x-archives)
(command-line
"setup-plt"
argv
(once-each
[("-c" "--clean") "Delete existing compiled files"
(clean #t)]
[("-n" "--no-zo") "Do not produce .zo files"
(make-zo #f)]
[("-x" "--no-launcher") "Do not produce launcher programs"
(make-launchers #f)]
[("-i" "--no-install") "Do not call collection-specific installers"
(call-install #f)]
[("-e" "--extension") "Produce native code extensions"
(make-so #t)]
[("-v" "--verbose") "See names of compiled files and info printfs"
(verbose #t)]
[("-m" "--make-verbose") "See make and compiler usual messages"
(make-verbose #t)]
[("-r" "--compile-verbose") "See make and compiler verbose messages"
(make-verbose #t)
(compiler-verbose #t)]
[("-p" "--pause") "Pause at the end if there are any errors"
(pause-on-errors #t)]
[("-l") =>
(lambda (flag . collections)
(map list collections))
'("Setup specific <collection>s only" "collection")])
(=>
(lambda (collections . archives)
(values (if (null? collections)
null
(car collections))
archives))
'("archive")
(lambda (s)
(display s)
(printf "If no <archive> or -l <collection> is specified, all collections are setup~n")
(exit 0)))))
(specific-collections x-specific-collections)
(archives x-archives)
(parameterize ([use-compiled-file-kinds (if (clean) 'none (use-compiled-file-kinds))])
(require-library "sig.ss" "compiler"))
(parameterize ([use-compiled-file-kinds (if (clean) 'none (use-compiled-file-kinds))])
(invoke-unit/sig
(compound-unit/sig
(import (SOPTION : setup-option^))
(link [STRING : mzlib:string^ ((require-library "stringr.ss"))]
[FILE : mzlib:file^ ((require-library "filer.ss") STRING FUNCTION)]
[FUNCTION : mzlib:function^ ((require-library "functior.ss"))]
[COMPILE : mzlib:compile^ ((require-library "compiler.ss"))]
[PRETTY-PRINT : mzlib:pretty-print^ ((require-library "prettyr.ss"))]
[LAUNCHER : launcher-maker^ ((require-library "launcherr.ss" "launcher") FILE)]
[DCOMPILE : dynext:compile^ ((require-library "compiler.ss" "dynext"))]
[DLINK : dynext:link^ ((require-library "linkr.ss" "dynext"))]
[DFILE : dynext:file^ ((require-library "filer.ss" "dynext"))]
[OPTION : compiler:option^ ((require-library "optionr.ss" "compiler"))]
[COMPILER : compiler^ ((require-library "compiler.ss" "compiler")
OPTION
FUNCTION
PRETTY-PRINT
FILE
STRING
COMPILE
DCOMPILE
DLINK
DFILE)]
[SETUP : () ((require-relative-library "setupr.ss")
SOPTION
FILE
COMPILER
OPTION
LAUNCHER)])
(export))
setup-option^))

587
collects/setup/setupr.ss
View File

@ -1,587 +0,0 @@
; Expects parameters to be set before invocation.
; Calls `exit' when done.
(unit/sig ()
(import setup-option^
mzlib:file^
compiler^
(compiler:option : compiler:option^)
launcher-maker^)
(define plthome
(or (getenv "PLTHOME")
(let ([dir (collection-path "mzlib")])
(and dir
(let-values ([(base name dir?) (split-path dir)])
(and (string? base)
(let-values ([(base name dir?) (split-path base)])
(and (string? base)
(complete-path? base)
base))))))))
(define setup-fprintf
(lambda (p s . args)
(apply fprintf p (string-append "setup-plt: " s "~n") args)))
(define setup-printf
(lambda (s . args)
(apply setup-fprintf (current-output-port) s args)))
(setup-printf "Setup version is ~a" (version))
(setup-printf "PLT home directory is ~a" plthome)
(setup-printf "Collection Paths are: ~a" (current-library-collection-paths))
(exit-handler
(let ([oh (exit-handler)])
(lambda (num)
(let ([error-log (build-path (collection-path "setup") "errors")])
(if (zero? num)
(when (file-exists? error-log)
(delete-file error-log))
(call-with-output-file error-log
(lambda (port)
(show-errors port))
'truncate))
(oh num)))))
(define (warning s x)
(setup-printf s
(if (exn? x)
(exn-message x)
x)))
(define (pretty-name f)
(with-handlers ([void (lambda (x) f)])
(let-values ([(base name dir?) (split-path f)])
(format "~a in ~a" name base))))
(define (call-info info flag default test)
(with-handlers ([void (lambda (x)
(warning
(format "Warning: error getting ~a info: ~~a"
flag)
x)
default)])
(let ([v (info flag (lambda () default))])
(test v)
v)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Archive Unpacking ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (port64->port p)
(let* ([waiting 0]
[waiting-bits 0]
[at-eof? #f]
[push
(lambda (v)
(set! waiting (+ (arithmetic-shift waiting 6) v))
(set! waiting-bits (+ waiting-bits 6)))])
(make-input-port
(lambda ()
(let loop ()
(if at-eof?
eof
(if (>= waiting-bits 8)
(begin0
(integer->char (arithmetic-shift waiting (- 8 waiting-bits)))
(set! waiting-bits (- waiting-bits 8))
(set! waiting (bitwise-and waiting (sub1 (arithmetic-shift 1 waiting-bits)))))
(let* ([c (read-char p)]
[n (if (eof-object? c)
(#%char->integer #\=)
(char->integer c))])
(cond
[(<= (#%char->integer #\A) n (#%char->integer #\Z)) (push (- n (#%char->integer #\A)))]
[(<= (#%char->integer #\a) n (#%char->integer #\z)) (push (+ 26 (- n (#%char->integer #\a))))]
[(<= (#%char->integer #\0) n (#%char->integer #\9)) (push (+ 52 (- n (#%char->integer #\0))))]
[(= (#%char->integer #\+) n) (push 62)]
[(= (#%char->integer #\/) n) (push 63)]
[(= (#%char->integer #\=) n) (set! at-eof? #t)])
(loop))))))
(lambda ()
(or at-eof? (char-ready? p)))
void)))
(define (port64gz->port p64gz)
(let ([gunzip-through-ports
(invoke-unit/sig
(compound-unit/sig
(import)
(link [I : (gunzip-through-ports) ((require-library "inflater.ss"))]
[X : () ((unit/sig () (import (gunzip-through-ports)) gunzip-through-ports) I)])
(export)))])
; Inflate in a thread so the whole input isn't read at once
(let*-values ([(pgz) (port64->port p64gz)]
[(waiting?) #f]
[(ready) (make-semaphore)]
[(read-pipe write-pipe) (make-pipe)]
[(out) (make-output-port
(lambda (s)
(set! waiting? #t)
(semaphore-wait ready)
(set! waiting? #f)
(display s write-pipe))
(lambda ()
(close-output-port write-pipe)))]
[(get) (make-input-port
(lambda ()
(if (char-ready? read-pipe)
(read-char read-pipe)
(begin
(semaphore-post ready)
(read-char read-pipe))))
(lambda ()
(or (char-ready? read-pipe) waiting?))
(lambda ()
(close-input-port read-pipe)))])
(thread (lambda ()
(with-handlers ([void (lambda (x)
(warning "Warning: unpacking error: ~a" x))])
(gunzip-through-ports pgz out))
(close-output-port out)))
get)))
(define (unmztar p filter)
(let loop ()
(let ([kind (read p)])
(unless (eof-object? kind)
(case kind
[(dir) (let ([s (apply build-path (read p))])
(unless (relative-path? s)
(error "expected a directory name relative path string, got" s))
(when (filter 'dir s plthome)
(let ([d (build-path plthome s)])
(unless (directory-exists? d)
(when (verbose)
(setup-printf " making directory ~a" (pretty-name d)))
(make-directory* d)))))]
[(file file-replace)
(let ([s (apply build-path (read p))])
(unless (relative-path? s)
(error "expected a file name relative path string, got" s))
(let ([len (read p)])
(unless (and (number? len) (integer? len))
(error "expected a file name size, got" len))
(let* ([write? (filter kind s plthome)]
[path (build-path plthome s)])
(let ([out (and write?
(if (file-exists? path)
(if (eq? kind 'file)
#f
(open-output-file path 'truncate))
(open-output-file path)))])
(when (and write? (not out))
(setup-printf " skipping ~a; already exists" (pretty-name path)))
(when (and out (or #t (verbose)))
(setup-printf " unpacking ~a" (pretty-name path)))
; Find starting *
(let loop ()
(let ([c (read-char p)])
(cond
[(char=? c #\*) (void)] ; found it
[(char-whitespace? c) (loop)]
[(eof-object? c) (void)] ; signal the error below
[else (error
(format
"unexpected character setting up ~a, looking for #\*"
path)
c)])))
; Copy file data
(let loop ([n len])
(unless (zero? n)
(let ([c (read-char p)])
(when (eof-object? c)
(error (format
"unexpected end-of-file while ~a ~a (at ~a of ~a)"
(if out "unpacking" "skipping")
path
(- len n -1) len)))
(when out
(write-char c out)))
(loop (sub1 n))))
(when out
(close-output-port out))))))]
[else (error "unknown file tag" kind)])
(loop)))))
(define (unpack-archive archive)
(with-handlers ([void
(lambda (x)
(warning (format "Warning: error unpacking ~a: ~~a"
archive)
x)
null)])
(call-with-input-file archive
(lambda (p64)
(let* ([p (port64gz->port p64)])
(unless (and (eq? #\P (read-char p))
(eq? #\L (read-char p))
(eq? #\T (read-char p)))
(error "not an unpackable distribution archive"))
(let* ([n (make-namespace)]
[info (eval (read p) n)])
(unless (and (procedure? info)
(procedure-arity-includes? info 2))
(error "expected a procedure of arity 2, got" info))
(let ([name (call-info info 'name #f
(lambda (n)
(unless (string? n)
(if n
(error "couldn't find the package name")
(error "expected a string")))))]
[unpacker (call-info info 'unpacker #f
(lambda (n)
(unless (eq? n 'mzscheme)
(error "unpacker isn't mzscheme:" n))))])
(unless (and name unpacker)
(error "bad name or unpacker"))
(setup-printf "Unpacking ~a from ~a" name archive)
(let ([u (eval (read p) n)])
(unless (unit? u)
(error "expected a unit, got" u))
(let ([plthome plthome]
[unmztar (lambda (filter)
(unmztar p filter))])
(invoke-unit u plthome unmztar))))))))))
(define x-specific-collections
(apply
append
(specific-collections)
(map unpack-archive (archives))))
(define (done)
(setup-printf "Done setting up"))
(unless (null? (archives))
(when (null? x-specific-collections)
(done)
(exit 0))) ; done
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Collection Compilation ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct cc (collection path name info))
(define collection->cc
(lambda (collection-p)
(with-handlers ([void (lambda (x) #f)])
(let ([dir (apply collection-path collection-p)])
(with-handlers ([(lambda (x)
(and (exn:i/o:filesystem? x)
(string=? (exn:i/o:filesystem-pathname x)
(build-path dir "info.ss"))))
(lambda (x) #f)]
[void
(lambda (x)
(warning "Warning: error loading info.ss: ~a" x)
#f)])
(let* ([info (parameterize ([use-compiled-file-kinds 'none])
(apply require-library/proc "info.ss" collection-p))]
[name (call-info info 'name #f
(lambda (x)
(unless (string? x)
(error "result is not a string:" x))))])
(and
name
;(call-info info 'compile-prefix #f #t)
(make-cc
collection-p
(apply collection-path collection-p)
name
info))))))))
(define (cannot-compile c)
(error 'setup-plt "don't know how to compile collection: ~a"
(if (= (length c) 1)
(car c)
c)))
(define collections-to-compile
(if (null? x-specific-collections)
(let ([ht (make-hash-table)])
(let loop ([collection-paths (current-library-collection-paths)])
(cond
[(null? collection-paths)
(hash-table-map ht (lambda (k v) v))]
[else (let ([cp (car collection-paths)])
(let loop ([collections (if (directory-exists? cp)
(directory-list cp)
null)])
(cond
[(null? collections) (void)]
[else (let* ([collection (car collections)]
[coll-sym (string->symbol collection)])
(hash-table-get
ht
coll-sym
(lambda ()
(let ([cc (collection->cc (list collection))])
(when cc
(hash-table-put!
ht
coll-sym
cc))))))
(loop (cdr collections))])))
(loop (cdr collection-paths))])))
(map
(lambda (c)
(or (collection->cc c)
(cannot-compile c)))
x-specific-collections)))
(define control-io-apply
(lambda (print-doing f args)
(if (make-verbose)
(begin
(apply f args)
#t)
(let* ([oop (current-output-port)]
[printed? #f]
[on? #f]
[op (make-output-port
(lambda (s)
(let loop ([s s])
(if on?
(let ([m (regexp-match-positions (string #\newline) s)])
(if m
(begin
(set! on? #f)
(when (verbose)
(display (substring s 0 (add1 (caar m))) oop)
(flush-output oop))
(loop (substring s (add1 (caar m)) (string-length s))))
(when (verbose)
(display s oop)
(flush-output oop))))
(let ([m (or (regexp-match-positions "making" s)
(regexp-match-positions "compiling" s))])
(when m
(unless printed?
(set! printed? #t)
(print-doing oop))
(set! on? #t)
(when (verbose)
(display " " oop)) ; indentation
(loop (substring s (caar m) (string-length s))))))))
void)])
(parameterize ([current-output-port op])
(apply f args)
printed?)))))
; Close over sub-collections
(set! collections-to-compile
(let loop ([l collections-to-compile])
(if (null? l)
null
(let* ([cc (car l)]
[info (cc-info cc)])
(append
(list cc)
(map
(lambda (subcol)
(or
(collection->cc subcol)
(cannot-compile subcol)))
(call-info info 'compile-subcollections null
(lambda (x)
(unless (and (list? x)
(andmap
(lambda (x)
(list? x)
(andmap
(lambda (x)
(and (string? x)
(relative-path? x)))
x))
x))
(error "result is not a list of relative path string lists:" x)))))
(loop (cdr l)))))))
(define (delete-files-in-directory path printout)
(for-each
(lambda (end-path)
(let ([path (build-path path end-path)])
(cond
[(directory-exists? path)
(void)]
[(file-exists? path)
(printout)
(unless (delete-file path)
(error 'delete-files-in-directory
"unable to delete file: ~a" path))]
[else (error 'delete-files-in-directory
"encountered ~a, neither a file nor a directory"
path)])))
(directory-list path)))
(define (is-subcollection? collection sub-coll)
(cond
[(null? collection) #t]
[(null? sub-coll) #f]
[else (and (string=? (car collection) (car sub-coll))
(is-subcollection? (cdr collection) (cdr sub-coll)))]))
(define (clean-collection cc)
(let* ([info (cc-info cc)]
[default (box 'default)]
[paths (call-info
info
'clean
(list "compiled" (build-path "compiled" "native" (system-library-subpath)))
(lambda (x)
(unless (or (eq? x default)
(and (list? x)
(andmap string? x)))
(error 'setup-plt "expected a list of strings for 'clean, got: ~s"
x))))]
[printed? #f]
[print-message
(lambda ()
(unless printed?
(set! printed? #t)
(setup-printf "Deleting files for ~a." (cc-name cc))))])
(for-each (lambda (path)
(let ([full-path (build-path (cc-path cc) path)])
(cond
[(directory-exists? full-path)
(delete-files-in-directory
full-path
print-message)]
[(file-exists? full-path)
(delete-file full-path)
(print-message)]
[else (void)])))
paths)))
(when (clean)
(for-each clean-collection collections-to-compile))
(when (or (make-zo) (make-so))
(compiler:option:verbose (compiler-verbose))
(compiler:option:compile-subcollections #f))
(define errors null)
(define (record-error cc desc go)
(with-handlers ([(lambda (x) (not (exn:misc:user-break? x)))
(lambda (x)
(if (exn? x)
(begin
(fprintf (current-error-port) "~a~n" (exn-message x))
(when (defined? 'print-error-trace)
((global-defined-value 'print-error-trace)
(current-error-port)
x)))
(fprintf (current-error-port) "~s~n" x))
(set! errors (cons (list cc desc x) errors)))])
(go)))
(define (show-errors port)
(for-each
(lambda (e)
(let ([cc (car e)]
[desc (cadr e)]
[x (caddr e)])
(setup-fprintf port
" Error during ~a for ~a (~a)"
desc (cc-name cc) (cc-path cc))
(if (exn? x)
(setup-fprintf port " ~a" (exn-message x))
(setup-fprintf port " ~s" x))))
errors))
(define (make-it desc compile-collection)
(for-each (lambda (cc)
(record-error
cc
(format "Making ~a" desc)
(lambda ()
(unless (let ([b (box 1)]) (eq? b ((cc-info cc) 'compile-prefix (lambda () b))))
(unless (control-io-apply
(lambda (p) (setup-fprintf p "Making ~a for ~a at ~a" desc (cc-name cc) (cc-path cc)))
compile-collection
(cc-collection cc))
(setup-printf "No need to make ~a for ~a at ~a" desc (cc-name cc) (cc-path cc)))))))
collections-to-compile))
(when (make-zo) (make-it ".zos" compile-collection-zos))
(when (make-so) (make-it "extension" compile-collection-extension))
(when (make-launchers)
(let ([name-list
(lambda (l)
(unless (and (list? l)
(andmap (lambda (x)
(and (string? x)
(relative-path? x)))
l))
(error "result is not a list of relative path strings:" l)))])
(for-each (lambda (cc)
(record-error
cc
"Launcher Setup"
(lambda ()
(when (= 1 (length (cc-collection cc)))
(let ([info (cc-info cc)])
(map
(lambda (kind
mzscheme-launcher-libraries
mzscheme-launcher-names
mzscheme-program-launcher-path
install-mzscheme-program-launcher)
(let ([mzlls (call-info info mzscheme-launcher-libraries null
name-list)]
[mzlns (call-info info mzscheme-launcher-names null
name-list)])
(if (= (length mzlls) (length mzlns))
(map
(lambda (mzll mzln)
(let ([p (mzscheme-program-launcher-path mzln)])
(unless (file-exists? p)
(setup-printf "Installing ~a launcher ~a" kind p)
(install-mzscheme-program-launcher
mzll
(car (cc-collection cc))
mzln))))
mzlls mzlns)
(setup-printf "Warning: ~a launcher library list ~s doesn't match name list ~s"
kind mzlls mzlns))))
'("MzScheme" "MrEd")
'(mzscheme-launcher-libraries mred-launcher-libraries)
'(mzscheme-launcher-names mred-launcher-names)
(list mzscheme-program-launcher-path mred-program-launcher-path)
(list install-mzscheme-program-launcher install-mred-program-launcher)))))))
collections-to-compile)))
(when (call-install)
(for-each (lambda (cc)
(let/ec k
(record-error
cc
"General Install"
(lambda ()
(let ([t ((cc-info cc) 'install-collection (lambda () (k #f)))])
(unless (and (procedure? t)
(procedure-arity-includes? t 1))
(error 'setup-plt
"install-collection: result is not a procedure of arity 1 for ~a"
(cc-name cc)))
(setup-printf "Installing ~a" (cc-name cc))
(t plthome))))))
collections-to-compile))
(done)
(unless (null? errors)
(setup-printf "")
(show-errors (current-error-port))
(when (pause-on-errors)
(fprintf (current-error-port)
"INSTALLATION FAILED.~nPress Enter to continue...~n")
(read-line))
(exit 1))
(exit 0))

20
collects/setup/setupsig.ss
View File

@ -1,20 +0,0 @@
(begin-elaboration-time
(require-library "launchers.ss" "launcher")
(require-library "dynexts.ss" "dynext")
(require-library "functios.ss")
(require-library "files.ss")
(require-library "sig.ss" "compiler"))
(define-signature setup-option^
(verbose
make-verbose
compiler-verbose
clean
make-zo
make-so
make-launchers
call-install
pause-on-errors
specific-collections
archives))

38
collects/slatex/doc.txt
View File

@ -1,38 +0,0 @@
_SLaTeX_
========
The use SLaTeX as a standalone program, either drag your .tex file onto
SLaTeX (on the macintosh or windows), or type "slatex file" at the command
prompt (under windows or X).
Under the macintosh, SLaTeX will attempt to run OzTeX. If you do not have
OzTeX installed, or use another version of LaTeX, this will fail and you
can run your own version manually.
To use SLaTeX in a program, require _slatex.ss_:
(require-library "slatex.ss" "slatex")
The file slatex.ss defines three procedures:
> (slatex filename)
This procedure accepts a string naming a file and runs slatex and latex on
the file. It calls `filename->latex-filename' on `filename'.
> (slatex/no-latex filename)
This procedure slatex's the file named by filename, without calling
latex. That is, it only processes the .tex file to produce the .Z files.
It calls filename->latex-filename on `filename'.
> (latex filename)
This procedure `latex's the file named by filename. It calls
filename->latex-filename on `filename'.
> (filename->latex-filename filename)
This procedure accepts a filename and, if that file exists, it returns
it. If the filename appended with the suffix `.tex' exists, that filename
is returned. Otherwise, error is called.

23
collects/slatex/info.ss
View File

@ -1,23 +0,0 @@
(lambda (request fail)
(case request
((name) "SLaTeX")
((install-collection)
(lambda (plt-home)
(unless (file-exists? (build-path (collection-path "slatex") "compiled" "slatexsrc.zo"))
(let ([slatex-code-directory (build-path (collection-path "slatex") "slatex-code")]
[compiled-directory (build-path (collection-path "slatex") "compiled")])
(parameterize ([current-namespace (make-namespace)]
[current-output-port (make-output-port void void)]
[current-directory slatex-code-directory])
(require-library "slaconfg.scm" "slatex" "slatex-code"))
(unless (directory-exists? compiled-directory)
(make-directory compiled-directory))
(copy-file (build-path slatex-code-directory "slatex.scm") ; this file is actually a .zo file
(build-path compiled-directory "slatexsrc.zo"))))
(require-library "launcher.ss" "launcher")
(make-mzscheme-launcher
(list "-qge"
"(require-library \"slatex-launcher.scm\"
\"slatex\")")
(mzscheme-program-launcher-path "SLaTeX"))))
(else (fail))))

54
collects/slatex/slatex-code/2col.tex
View File

@ -1,54 +0,0 @@
% from the TeXbook, p. 257
\newdimen\fullhsize
\fullhsize\hsize
\def\fullline{\hbox to\fullhsize}
\ifx\plainmakeheadline\undefined
% ensure that we do this only once!
\let\plainmakeheadline\makeheadline
\let\plainmakefootline\makefootline
\fi
% the text width spans both columns, as far as
% head- and footlines are concerned
\def\textwideline{\hbox to\fullhsize}
\def\makeheadline{{\let\line\textwideline\plainmakeheadline}}
\def\makefootline{{\let\line\textwideline\plainmakefootline}}
% space between the two columns -- can be changed
% immediately after loading 2col
\def\gutter#1{\hsize\fullhsize
\advance\hsize-#1
\hsize.5\hsize
}
\gutter{1.5pc}
\let\lr=L
\newbox\leftcolumn
\output={\if L\lr
\global\setbox\leftcolumn=\columnbox
\global\let\lr=R\else
\doubleformat
\global\let\lr L\fi
\ifnum\outputpenalty>-20000 \else
\dosupereject\fi}
\def\doubleformat{\shipout\vbox{\makeheadline
\fullline{\box\leftcolumn\hfil\columnbox}%
\makefootline}\advancepageno}
\def\columnbox{\leftline{\pagebody}}
% \bye cleans up.
\outer\def\bye{\vfill\supereject
\if R\lr\null\vfill\eject\fi
\end}

49
collects/slatex/slatex-code/8pt.tex
View File

@ -1,49 +0,0 @@
\ifdim\the\fontdimen2\tenrm=3.33333pt
% almost definitely using CM fonts
\font\eightrm cmr8
\font\eighti cmmi8
\font\eightsy cmsy8
\font\eightit cmti8
\font\eightbf cmbx8
\font\eighttt cmtt8
\else\ifx\ljmagnification\undefined
\def\fontstem#1{\expandafter\fontstemII\fontname#1 \end}%
\def\fontstemII#1 #2\end{#1 }%
\font\eightrm \fontstem\tenrm at 8pt
\font\eighti cmmi8
\font\eightsy cmsy8
\font\eightit \fontstem\tenit at 8pt
\font\eightbf \fontstem\tenbf at 8pt
\font\eighttt \fontstem\tentt at 8pt
\else
\setcountCCLVtoljmag
\font\eighti cmmi8 scaled \count255
\font\eightsy cmsy8 scaled \count255
\multiply\count255 by 4
\divide\count255 by 5
\font\eightrm \fontstem\tenrm scaled \count255
\font\eightit \fontstem\tenit scaled \count255
\font\eightbf \fontstem\tenbf scaled \count255
\font\eighttt \fontstem\tentt scaled \count255
\fi\fi
\skewchar\eighti'177
\skewchar\eightsy'60
\def\eightpoint{%
\textfont0\eightrm
\textfont1\eighti
\textfont2\eightsy
\textfont\itfam\eightit
\textfont\bffam\eightbf
\textfont\ttfam\eighttt
\def\rm{\fam0\eightrm}%
\def\oldstyle{\fam1\eighti}%
\def\it{\fam\itfam\eightit}%
\def\bf{\fam\bffam\eightbf}%
\def\tt{\fam\ttfam\eighttt}%
\rm
\setbox\strutbox\hbox{\vrule height .85em depth .35em width
0pt }%
\normalbaselineskip 1.2em
\normalbaselines}

114
collects/slatex/slatex-code/README
View File

@ -1,114 +0,0 @@
README
SLaTeX Version 2.4
(c) Dorai Sitaram
dorai@cs.rice.edu
Read me first
...
1. A brief description of SLaTeX
SLaTeX is a Scheme program that allows you to write program
code (or code fragments) "as is" in your LaTeX or TeX
source. SLaTeX is particularly geared to the programming
languages Scheme (R5RS) and other Lisps, e.g., Common Lisp.
The formatting of the code includes assigning appropriate
fonts to the various tokens in the code (keywords,
variables, constants, data), at the same time retaining the
proper indentation when going to the non-monospace
(non-typewriter) fonts provided by TeX. SLaTeX comes with
two databases that recognize the identifier conventions of
Scheme and CL respectively.
While it is certainly possible to get by with a minimal
knowledge of SLaTeX commands, the package comes with a
variety of features for manipulating output positioning,
modifying/enhancing the database, changing the fonting
defaults, adding special symbols, and selective disabling of
SLaTeX. For a detailed documentation of SLaTeX, run slatex
on the file slatxdoc.tex in the SLaTeX distribution after
finishing the installation process.
...
2. Obtaining SLaTeX
SLaTeX is available at the URL
http://www.cs.rice.edu/CS/PLT/packages/slatex/slatex.tar.gz.
Ungzipping and untarring produces a directory slatex,
containing the SLaTeX files. (The file "manifest" lists the
files in the distribution -- make sure nothing is missing.)
...
3. Requisites for installing SLaTeX
SLaTeX is implemented in R5RS-compliant Scheme -- macros are
not needed. The code uses the non-standard procedures
delete-file, file-exists? and flush-output, but a Scheme
without these procedures can also run SLaTeX. The
configuration defines the corresponding variables to be
dummy procedures, since they are not crucial. The
distribution comes with code to allow SLaTeX to run also on
Common Lisp. The dialects that SLaTeX has run successfully
on are: Bigloo, Chez Scheme, CLISP, Elk, Gnu Common Lisp,
Gambit, Guile, Ibuki Common Lisp, MIT C Scheme, MzScheme,
Scheme-to-C, SCM, UMB Scheme, and VSCM on Unix; MzScheme on
Windows 95; CLISP and SCM on OS/2; Austin Kyoto Common Lisp,
CLISP, MIT C Scheme, and SCM on MSDOS; and Macintosh Common
Lisp on Mac OS.
...
4. Installing SLaTeX
Refer to the file "install" for configuring SLaTeX to your
dialect and ways of invoking it on your (La)TeX files.
...
5. Using SLaTeX
The file slatxdoc.tex is a manual describing "How to Use
SLaTeX". A version of the corresponding .dvi file,
slatxdoc.dvi, is included in the distribution, but you could
create your own (and thereby check that SLaTeX works on your
system). Save the provided slatxdoc.dvi file in case your
setup doesn't work, and type
slatex slatxdoc
You may create a file slatxdoc.ind that arranges the index
information from the file slatxdoc.idx generated by LaTeX.
Run LaTeX on slatxdoc another time to sort out the index and
the citations.
If you have run Scheme (or CL) on config.scm (Sec. 1 of
install) but haven't been able to decide how to set up the
paths or the shell/bat script or the most suitable invoking
method (Sec. 2 and 3 of install), perform the following
actions (in the directory where you unpacked the
distribution) to get slatxdoc.dvi:
1) Start up Scheme (or CL).
2) Type (load "slatex.scm").
3) Type (SLaTeX.process-main-tex-file "slatxdoc").
4) Exit Scheme (or CL).
5) Call latex on slatxdoc.tex. (Use makeindex to generate
slatxdoc.ind, if possible. Call latex a second time to get
the citations right and to generate an index if available.)
...
6. Bugs, etc.
Bug reports, flames, criticisms and suggestions are
most welcome -- send to
Dorai Sitaram
dorai@cs.rice.edu

125
collects/slatex/slatex-code/aliases.scm
View File

@ -1,125 +0,0 @@
(make-slatex-alias
'(
global-adjoin adjoin
global-assoc assoc
global-delete delete
global-error error
global-make-string make-string
global-member member
global-peek-char peek-char
global-read read
global-read-char read-char
global-string string
))
(case dialect
((bigloo) 'skip
)
((chez)
(make-slatex-alias
'(
force-output flush-output
some ormap
)))
((cl)
(make-slatex-alias
`(
adjoin slatex::%adjoin
append! nconc
assoc slatex::%assoc
begin progn
char? characterp
char=? char=
char-alphabetic? alpha-char-p
delete slatex::%delete
display princ
else t
eq? eq
equal? equal
eqv? eql
file-exists? probe-file
fluid-let let
for-each mapc
integer->char code-char
lambda slatex::%lambda
let slatex::%let
list-tail subseq
make-string slatex::%make-string
map mapcar
member slatex::%member
memq member
memv member
newline terpri
null? null
pair? consp
peek-char slatex::%peek-char
position-char position
read slatex::%read
read-char slatex::%read-char
*return* ,(read-from-string "#\\return")
reverse! nreverse
set! setq
set-car! rplaca
set-cdr! rplacd
string slatex::%string
string=? string=
string-ci=? string-equal
string-length length
string-ref char
sublist subseq
substring subseq
*tab* ,(read-from-string "#\\tab")
void values
)))
((cscheme)
(make-slatex-alias
`(
mapcan append-map!
*return* ,(with-input-from-string "#\\return" read)
*tab* ,(with-input-from-string "#\\tab" read)
)))
((elk)
(make-slatex-alias
'(
force-output flush-output-port
)))
((gambit)
(make-slatex-alias
'(
force-output flush-output
)))
((guile)
(make-slatex-alias
`(
*return* ,(call-with-input-string "#\\return" read)
*tab* ,(call-with-input-string "#\\tab" read)
)))
((mzscheme)
(make-slatex-alias
`(
force-output flush-output
some ormap
*return* ,(let ((i (open-input-string "#\\return")))
(begin0 (read i) (close-input-port i)))
*tab* ,(let ((i (open-input-string "#\\tab")))
(begin0 (read i) (close-input-port i)))
)))
((pcsge) 'skip
)
((scm)
(make-slatex-alias
`(
*return* ,(call-with-input-string "#\\return" read)
*tab* ,(call-with-input-string "#\\tab" read)
)))
((stk)
(make-slatex-alias
`(
force-output flush
)))
((vscm)
(make-slatex-alias
'(
delete-file remove-file
force-output flush
))))

197
collects/slatex/slatex-code/batconfg.lsp
View File

@ -1,197 +0,0 @@
;batconfg.lsp
;Configures SLaTeX batfile/shellscript (CL version)
;(c) Dorai Sitaram, Rice U., 1991, 1994
#+gcl
(or (find-package :slatex) (make-package :slatex))
#-gcl
(defpackage slatex (:use cl))
(set-dispatch-macro-character #\# #\t
#'(lambda (p ig ig2)
(declare (ignore ig ig2))
t))
(set-dispatch-macro-character #\# #\f
#'(lambda (p ig ig2)
(declare (ignore ig ig2))
nil))
(format t "~&Beginning configuring command script -- wait...")
(defvar *slatex-directory* (directory-namestring *load-pathname*))
(defvar *op-sys*)
(defvar cl-pathname)
(defvar slatex-pathname)
(defvar texinputs)
(defvar texinputs-list)
(defvar accepts-echo)
(defvar accepts-cmdline-file)
(defvar accepts-initfile)
(defvar system-procedure nil)
#+clisp
(setf system-procedure 'run-shell-command)
(with-open-file (inp (concatenate 'string *slatex-directory*
"config.dat")
:direction :input)
(read inp) ;we already know dialect
(setf *op-sys* (read inp)
cl-pathname (read inp)
slatex-pathname (read inp)
texinputs (read inp)
texinputs-list (read inp)
accepts-echo (read inp)
accepts-cmdline-file (read inp)
accepts-initfile (read inp)) )
(defvar bat-file)
(setf bat-file
(concatenate 'string *slatex-directory*
(case *op-sys*
((os2 os2fat) "slatex.cmd")
((windows dos) "slatex.bat")
(unix "slatex"))))
(unless (eq *op-sys* 'mac-os)
(if (probe-file bat-file) (delete-file bat-file)))
(defun princn (x o)
(princ x o)
(terpri o))
(defun n (o)
(terpri o))
(with-open-file
(o bat-file :direction :output)
(case *op-sys*
((unix)
(cond (accepts-echo
(princn "echo '" o)
(princ "(load " o)
(prin1 slatex-pathname o)
(princn ")" o)
(princ "(setq slatex::*texinputs* " o)
(prin1 texinputs o)
(princn ")" o)
(princ "(setq slatex::*texinputs-list* `" o)
(prin1 texinputs-list o)
(princn ")" o)
(princ "(slatex::process-main-tex-file \"'$1'\")' | " o)
(princn cl-pathname o))
(accepts-cmdline-file
(princ "echo '(load " o)
(prin1 slatex-pathname o)
(princn ")' > Zslatex.jnk" o)
(princ "echo '(setq slatex::*texinputs* " o)
(prin1 texinputs o)
(princn ")' >> Zslatex.jnk" o)
(princ "echo '(setq slatex::*texinputs-list* `" o)
(prin1 texinputs-list o)
(princn ")' >> Zslatex.jnk" o)
(princn "echo '(slatex::process-main-tex-file \"'$1'\")' >> Zslatex.jnk" o)
(princn "echo '(slatex::exit-scheme)' >> Zslatex.jnk" o)
(princ cl-pathname o)
(princ " " o)
(princ accepts-cmdline-file o)
(princn " Zslatex.jnk" o)
(princn "rm -f Zslatex.jnk" o))
(accepts-initfile
(princ "echo '(load " o)
(prin1 slatex-pathname o)
(princ ")' > " o)
(princn accepts-initfile o)
(princ "echo '(setq slatex::*texinputs* " o)
(prin1 texinputs o)
(princ ")' >> " o)
(princn accepts-initfile o)
(princ "echo '(setq slatex::*texinputs-list* (quote " o)
(prin1 texinputs-list o)
(princ ")' >> " o)
(princn accepts-initfile o)
(princ "echo '(slatex::process-main-tex-file \"'$1'\")' >> " o)
(princn accepts-initfile o)
(princn cl-pathname o)
(princ "rm -f " o)
(princn accepts-initfile o)))
(princn "if test -f pltexchk.jnk" o)
(princn "then tex $1; rm pltexchk.jnk" o)
(princn "else latex $1" o)
(princn "fi" o))
((windows dos os2fat os2)
(princn "@echo off" o)
(cond (accepts-echo
(princ "echo (load " o)
(prin1 slatex-pathname o)
(princn ") > Zslatex.jnk" o)
(princ "echo (setq slatex::*texinputs* " o)
(prin1 texinputs o)
(princn ") >> Zslatex.jnk" o)
(princ "echo (setq slatex::*texinputs-list* '" o)
(prin1 texinputs-list o)
(princn ") >> Zslatex.jnk" o)
(princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o)
(princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o)
(princ "echo (load \"Zslatex.jnk\") | " o)
(princn cl-pathname o)
(princn "del Zslatex.jnk" o))
(accepts-cmdline-file
(princ "echo (load " o)
(prin1 slatex-pathname o)
(princn ") > Zslatex.jnk" o)
(princ "echo (setq slatex::*texinputs* " o)
(prin1 texinputs o)
(princn ") >> Zslatex.jnk" o)
(princ "echo (setq slatex::*texinputs-list* '" o)
(prin1 texinputs-list o)
(princn ") >> Zslatex.jnk" o)
(princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o)
(princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o)
(princ cl-pathname o)
(princ " " o)
(princ accepts-cmdline-file o)
(princn " Zslatex.jnk" o)
(princn "del Zslatex.jnk" o))
(accepts-initfile
(princ "echo (load " o)
(prin1 slatex-pathname o)
(princ ") > " o)
(princn accepts-initfile o)
(princ "echo (setq slatex::*texinputs* " o)
(prin1 texinputs o)
(princ ") >> " o)
(princn accepts-initfile o)
(princ "echo (setq slatex::*texinputs-list* '" o)
(prin1 texinputs-list o)
(princ ") >> " o)
(princn accepts-initfile o)
(princ "echo (slatex::process-main-tex-file \"%1\") >> " o)
(princn accepts-initfile o)
(princ "echo (slatex::exit-scheme) >> " o)
(princn accepts-initfile o)
(princn cl-pathname o)
(princ "del " o)
(princn accepts-initfile o)))
(princn "if exist pltexchk.jnk goto one" o)
(princn "goto two" o)
(princn ":one" o)
(princn "call tex %1" o)
(princn "del pltexchk.jnk" o)
(princn "goto end" o)
(princn ":two" o)
(princn "call latex %1" o)
(princn ":end" o))))
(format t "~&Finished configuring command script.~%")
(when (eq *op-sys* 'unix)
#+(or allegro clisp)
(run-shell-command "chmod +x slatex")
#+gcl
(system "chmod +x slatex")
#-(or gcl clisp)
(format t "~&Type (chmod +x slatex) on Unix command line~%"))

206
collects/slatex/slatex-code/batconfg.scm
View File

@ -1,206 +0,0 @@
;batconfg.scm;-*-scheme-*-
;Configures SLaTeX batfile/shellscript (Scheme version)
;(c) Dorai Sitaram, Rice U., 1991, 1994
(display "Beginning configuring command script -- wait...")
(newline)
(define dialect 'forward)
(define *op-sys* 'forward)
(define scheme-pathname 'forward)
(define slatex-pathname 'forward)
(define texinputs 'forward)
(define texinputs-list 'forward)
(define accepts-echo 'forward)
(define accepts-cmdline-file 'forward)
(define accepts-initfile 'forward)
(define system-procedure #f)
(call-with-input-file "config.dat"
(lambda (ip)
(set! dialect (read ip))
(set! *op-sys* (read ip))
(set! scheme-pathname (read ip))
(set! slatex-pathname (read ip))
(set! texinputs (read ip))
(set! texinputs-list (read ip))
(set! accepts-echo (read ip))
(set! accepts-cmdline-file (read ip))
(set! accepts-initfile (read ip))
(cond ((or (eof-object? dialect)
(eof-object? *op-sys*)
(eof-object? scheme-pathname)
(eof-object? slatex-pathname)
(eof-object? texinputs)
(eof-object? texinputs-list)
(eof-object? accepts-echo)
(eof-object? accepts-cmdline-file)
(eof-object? accepts-initfile))
(error "config.dat has too few answers"))
((eof-object? (read ip)) #t)
(else (error "config.dat has too many answers")))))
(case dialect
((bigloo chez cscheme guile mzscheme scm stk)
(set! system-procedure 'system)))
(define bat-file 'forward)
(case *op-sys*
((os2 os2bat)
(set! bat-file "slatex.cmd"))
((windows dos)
(set! bat-file "slatex.bat"))
((unix)
(set! bat-file "slatex")))
;(if (memq *op-sys* '(unix windows dos os2fat os2)) ;why here?
(if (memq dialect '(bigloo chez cscheme guile mzscheme pcsge scm))
(if (file-exists? bat-file)
(delete-file bat-file)))
(define modified-newline newline)
(cond ((and (eq? dialect 'mzscheme)
(memq *op-sys* '(windows dos)))
(set! modified-newline
(let ((cr (integer->char 13))
(lf (integer->char 10)))
(lambda (o)
(display cr o)
(display lf o))))))
(define princn
(lambda (x o)
(display x o)
(modified-newline o)))
(call-with-output-file bat-file
(lambda (o)
(case *op-sys*
((unix)
(cond (accepts-echo
(princn "echo '" o)
(display "(load " o)
(write slatex-pathname o)
(princn ")" o)
(display "(set! slatex::*texinputs* " o)
(write texinputs o)
(princn ")" o)
(display "(set! slatex::*texinputs-list* `" o)
(write texinputs-list o)
(princn ")" o)
(display "(slatex::process-main-tex-file \"'$1'\")' | " o)
(princn scheme-pathname o))
(accepts-cmdline-file
(display "echo '(load " o)
(write slatex-pathname o)
(princn ")' > Zslatex.jnk" o)
(display "echo '(set! slatex::*texinputs* " o)
(write texinputs o)
(princn ")' >> Zslatex.jnk" o)
(display "echo '(set! slatex::*texinputs-list* `" o)
(write texinputs-list o)
(princn ")' >> Zslatex.jnk" o)
(princn "echo '(slatex::process-main-tex-file \"'$1'\")' >> Zslatex.jnk" o)
(princn "echo '(slatex::exit-scheme)' >> Zslatex.jnk" o)
(display scheme-pathname o)
(display " " o)
(display accepts-cmdline-file o)
(princn " Zslatex.jnk" o)
(princn "rm -f Zslatex.jnk" o))
(accepts-initfile
(display "echo '(load " o)
(write slatex-pathname o)
(display ")' > " o)
(princn accepts-initfile o)
(display "echo '(set! slatex::*texinputs* " o)
(write texinputs o)
(display ")' >> " o)
(princn accepts-initfile o)
(display "echo '(set! slatex::*texinputs-list* (quote " o)
(write texinputs-list o)
(display ")' >> " o)
(princn accepts-initfile o)
(display "echo '(slatex::process-main-tex-file \"'$1'\")' >> " o)
(princn accepts-initfile o)
(princn scheme-pathname o)
(display "rm -f " o)
(princn accepts-initfile o)))
(princn "if test -f pltexchk.jnk" o)
(princn "then tex $1; rm pltexchk.jnk" o)
(princn "else latex $1" o)
(princn "fi" o))
((windows dos os2fat os2)
(princn "@echo off" o)
(cond (accepts-echo
(display "echo (load " o)
(write slatex-pathname o)
(princn ") > Zslatex.jnk" o)
(display "echo (set! slatex::*texinputs* " o)
(write texinputs o)
(princn ") >> Zslatex.jnk" o)
(display "echo (set! slatex::*texinputs-list* '" o)
(write texinputs-list o)
(princn ") >> Zslatex.jnk" o)
(princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o)
(princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o)
(display "echo (load \"Zslatex.jnk\") | " o)
(princn scheme-pathname o)
(princn "del Zslatex.jnk" o))
(accepts-cmdline-file
(display "echo (load " o)
(write slatex-pathname o)
(princn ") > Zslatex.jnk" o)
(display "echo (set! slatex::*texinputs* " o)
(write texinputs o)
(princn ") >> Zslatex.jnk" o)
(display "echo (set! slatex::*texinputs-list* '" o)
(write texinputs-list o)
(princn ") >> Zslatex.jnk" o)
(princn "echo (slatex::process-main-tex-file \"%1\") >> Zslatex.jnk" o)
(princn "echo (slatex::exit-scheme) >> Zslatex.jnk" o)
(display scheme-pathname o)
(display " " o)
(display accepts-cmdline-file o)
(display " Zslatex.jnk" o)
(princn "del Zslatex.jnk" o))
(accepts-initfile
(display "echo (load " o)
(write slatex-pathname o)
(display ") > " o)
(princn accepts-initfile o)
(display "echo (set! slatex::*texinputs* " o)
(write texinputs o)
(display ") >> " o)
(princn accepts-initfile o)
(display "echo (set! slatex::*texinputs-list* '" o)
(write texinputs-list o)
(display ") >> " o)
(princn accepts-initfile o)
(display "echo (slatex::process-main-tex-file \"%1\") >> " o)
(princn accepts-initfile o)
(display "echo (slatex::exit-scheme) >> " o)
(princn accepts-initfile o)
(princn scheme-pathname o)
(display "del " o)
(princn accepts-initfile o)))
(princn "if exist pltexchk.jnk goto one" o)
(princn "goto two" o)
(princn ":one" o)
(princn "call tex %1" o)
(princn "del pltexchk.jnk" o)
(princn "goto end" o)
(princn ":two" o)
(princn "call latex %1" o)
(princn ":end" o)))))
(display "Finished configuring batfile/shellscript")
(newline)
(if (eq? *op-sys* 'unix)
(case system-procedure
((system) (system "chmod +x slatex"))
(else
(display "Type (chmod +x slatex) on Unix command line")
(newline))))

7
collects/slatex/slatex-code/cfg4lsp.lsp
View File

@ -1,7 +0,0 @@
(load "slaconfg.lsp")
(load "batconfg.lsp")
(cond ((fboundp 'bye) (bye))
((fboundp 'exit) (exit))
((fboundp 'quit) (quit))
(t (format t "~&You may exit CL now!~%")))

10
collects/slatex/slatex-code/cfg4scm.scm
View File

@ -1,10 +0,0 @@
(load "slaconfg.scm")
(load "batconfg.scm")
(case dialect
((scm) (quit))
((cscheme) (%exit))
((bigloo) (exit 0))
(else (exit)
(display "You may exit Scheme now!")
(newline)))

57
collects/slatex/slatex-code/cltl.sty
View File

@ -1,57 +0,0 @@
%cltl.sty
%SLaTeX Version 1.99
%Style file to be used in (La)TeX when using SLaTeX for Common Lisp
%(c) Dorai Sitaram, December 1991, Rice University
\input slatex.sty
% The database in this file was generated from CL as follows:
% (defun canonical-special-form-p (x)
% (and (special-form-p x) (not (macro-function x))))
% (defun gather (pred)
% (sort (let ((x '()))
% (do-all-symbols (y)
% (if (funcall pred y) (setq x (cons y x))))
% x)
% #'string< :key #'symbol-name))
% A rather old (1987) version of Ibuki CL was used. So you may want
% to regenerate the keywords using the above functions in _your_ CL.
% CL sp. forms, i.e., (gather #'canonical-special-form-p)
\setkeyword{block catch compiler-let declare eval-when flet function
go if labels let let* macrolet multiple-value-call
multiple-value-prog1 progn progv quote return-from setq tagbody the
throw unwind-protect}
% CL macros, i.e., (gather #'macro-function)
\setkeyword{and assert compiler::base-used case ccase check-type
compiler::ck-spec compiler::ck-vl clines compiler::cmpck
system::coerce-to-package conditions::conc-name cond ctypecase decf
debugger::def-command defcfun defconstant defentry
system:define-compiler-macro conditions:define-condition
system:define-inline-function define-modify-macro define-setf-method
define-user-stream-type defla defmacro defparameter defsetf defstruct
deftype defun debugger::defun-property defvar do do* do-all-symbols
do-external-symbols do-symbols system::docdoc system::docfun
system::doctype system::docvar dolist compiler::dolist*
compiler::dolist** dotimes compiler::dotimes* compiler::dotimes**
ecase etypecase compiler::get-output-pathname conditions:handler-bind
conditions:handler-case system::if-error conditions:ignore-errors incf
system::inspect-print system::inspect-recursively locally loop
conditions::make-function multiple-value-bind multiple-value-list
multiple-value-setq compiler::next-cfun compiler::next-cmacro
compiler::next-cvar compiler::next-label compiler::next-label* or
conditions::parent-type pop prog prog* prog1 prog2 psetf psetq push
pushnew remf conditions::report-function conditions::resolve-function
conditions:restart-bind conditions:restart-case return rotatef
compiler::safe-compile setf shiftf conditions::slots step time trace
typecase unless untrace when debugger::with-debugger-environment
with-input-from-string conditions::with-keyword-pairs with-open-file
with-open-stream with-output-to-string conditions:with-simple-restart
compiler::wt compiler::wt-go compiler::wt-h compiler::wt-label
compiler::wt-nl compiler::wt-nl1}

259
collects/slatex/slatex-code/codeset.scm
View File

@ -1,259 +0,0 @@
;codeset.scm
;SLaTeX Version 2.4
;Displays the typeset code made by SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1999
(eval-within slatex
(define slatex::display-tex-line
(lambda (line)
(cond;((and (flush-comment-line? line)
; (char=? (of line =char / 1) #\%))
; (display "\\ZZZZschemecodebreak" *out*)
; (newline *out*))
(else
(let loop ((i (if (flush-comment-line? line) 1 0)))
(let ((c (of line =char / i)))
(if (char=? c #\newline)
(if (not (eq? (of line =tab / i) &void-tab))
(newline *out*))
(begin (write-char c *out*) (loop (+ i 1))))))))))
(define slatex::display-scm-line
(lambda (line)
(let loop ((i 0))
(let ((c (of line =char / i)))
(cond ((char=? c #\newline)
(let ((tab (of line =tab / i)))
(cond ((eq? tab &tabbed-crg-ret)
(display "\\\\%" *out*)
(newline *out*))
((eq? tab &plain-crg-ret) (newline *out*))
((eq? tab &void-tab)
(write-char #\% *out*)
(newline *out*)))))
((eq? (of line =notab / i) &begin-comment)
(display-tab (of line =tab / i) *out*)
(write-char c *out*)
(loop (+ i 1)))
((eq? (of line =notab / i) &mid-comment)
(write-char c *out*)
(loop (+ i 1)))
((eq? (of line =notab / i) &begin-string)
(display-tab (of line =tab / i) *out*)
(display "\\dt{" *out*)
(if (char=? c #\space)
(display-space (of line =space / i) *out*)
(display-tex-char c *out*))
(loop (+ i 1)))
((eq? (of line =notab / i) &mid-string)
(if (char=? c #\space)
(display-space (of line =space / i) *out*)
(display-tex-char c *out*))
(loop (+ i 1)))
((eq? (of line =notab / i) &end-string)
(if (char=? c #\space)
(display-space (of line =space / i) *out*)
(display-tex-char c *out*))
(write-char #\} *out*)
(if *in-qtd-tkn* (set! *in-qtd-tkn* #f)
(if *in-mac-tkn* (set! *in-mac-tkn* #f)))
(loop (+ i 1)))
((eq? (of line =notab / i) &begin-math)
(display-tab (of line =tab / i) *out*)
(write-char c *out*)
(loop (+ i 1)))
((eq? (of line =notab / i) &mid-math)
(write-char c *out*)
(loop (+ i 1)))
((eq? (of line =notab / i) &end-math)
(write-char c *out*)
(if *in-qtd-tkn* (set! *in-qtd-tkn* #f)
(if *in-mac-tkn* (set! *in-mac-tkn* #f)))
(loop (+ i 1)))
; ((memq (of line =notab / i) (list &mid-math &end-math))
; (write-char c *out*)
; (loop (+ i 1)))
((char=? c #\space)
(display-tab (of line =tab / i) *out*)
(display-space (of line =space / i) *out*)
(loop (+ i 1)))
((char=? c #\')
(display-tab (of line =tab / i) *out*)
(write-char c *out*)
(if (or *in-qtd-tkn*
(> *in-bktd-qtd-exp* 0)
(and (pair? *bq-stack*)
(not (of (car *bq-stack*) =in-comma))))
#f
(set! *in-qtd-tkn* #t))
(loop (+ i 1)))
((char=? c #\`)
(display-tab (of line =tab / i) *out*)
(write-char c *out*)
(if (or (null? *bq-stack*)
(of (car *bq-stack*) =in-comma))
(set! *bq-stack*
(cons (let ((f (make-bq-frame)))
(setf (of f =in-comma) #f)
(setf (of f =in-bq-tkn) #t)
(setf (of f =in-bktd-bq-exp) 0)
f)
*bq-stack*)))
(loop (+ i 1)))
((char=? c #\,)
(display-tab (of line =tab / i) *out*)
(write-char c *out*)
(if (not (or (null? *bq-stack*)
(of (car *bq-stack*) =in-comma)))
(set! *bq-stack*
(cons (let ((f (make-bq-frame)))
(setf (of f =in-comma) #t)
(setf (of f =in-bq-tkn) #t)
(setf (of f =in-bktd-bq-exp) 0)
f)
*bq-stack*)))
(if (char=? (of line =char / (+ i 1)) #\@)
(begin (display-tex-char #\@ *out*) (loop (+ 2 i)))
(loop (+ i 1))))
((memv c '(#\( #\[))
(display-tab (of line =tab / i) *out*)
(write-char c *out*)
(cond (*in-qtd-tkn* (set! *in-qtd-tkn* #f)
(set! *in-bktd-qtd-exp* 1))
((> *in-bktd-qtd-exp* 0)
(set! *in-bktd-qtd-exp* (+ *in-bktd-qtd-exp* 1))))
(cond (*in-mac-tkn* (set! *in-mac-tkn* #f)
(set! *in-bktd-mac-exp* 1))
((> *in-bktd-mac-exp* 0) ;is this possible?
(set! *in-bktd-mac-exp* (+ *in-bktd-mac-exp* 1))))
(if (not (null? *bq-stack*))
(let ((top (car *bq-stack*)))
(cond ((of top =in-bq-tkn)
(setf (of top =in-bq-tkn) #f)
(setf (of top =in-bktd-bq-exp) 1))
((> (of top =in-bktd-bq-exp) 0)
(setf (of top =in-bktd-bq-exp)
(+ (of top =in-bktd-bq-exp) 1))))))
(if (not (null? *case-stack*))
(let ((top (car *case-stack*)))
(cond ((of top =in-ctag-tkn)
(setf (of top =in-ctag-tkn) #f)
(setf (of top =in-bktd-ctag-exp) 1))
((> (of top =in-bktd-ctag-exp) 0)
(setf (of top =in-bktd-ctag-exp)
(+ (of top =in-bktd-ctag-exp) 1)))
((> (of top =in-case-exp) 0)
(setf (of top =in-case-exp)
(+ (of top =in-case-exp) 1))
(if (= (of top =in-case-exp) 2)
(set! *in-qtd-tkn* #t))))))
(loop (+ i 1)))
((memv c '(#\) #\]))
(display-tab (of line =tab / i) *out*)
(write-char c *out*)
(if (> *in-bktd-qtd-exp* 0)
(set! *in-bktd-qtd-exp* (- *in-bktd-qtd-exp* 1)))
(if (> *in-bktd-mac-exp* 0)
(set! *in-bktd-mac-exp* (- *in-bktd-mac-exp* 1)))
(if (not (null? *bq-stack*))
(let ((top (car *bq-stack*)))
(if (> (of top =in-bktd-bq-exp) 0)
(begin
(setf (of top =in-bktd-bq-exp)
(- (of top =in-bktd-bq-exp) 1))
(if (= (of top =in-bktd-bq-exp) 0)
(set! *bq-stack* (cdr *bq-stack*)))))))
(let loop ()
(if (not (null? *case-stack*))
(let ((top (car *case-stack*)))
(cond ((> (of top =in-bktd-ctag-exp) 0)
(setf (of top =in-bktd-ctag-exp)
(- (of top =in-bktd-ctag-exp) 1))
(if (= (of top =in-bktd-ctag-exp) 0)
(setf (of top =in-case-exp) 1)))
((> (of top =in-case-exp) 0)
(setf (of top =in-case-exp)
(- (of top =in-case-exp) 1))
(if (= (of top =in-case-exp) 0)
(begin
(set! *case-stack* (cdr *case-stack*))
(loop))))))))
(loop (+ i 1)))
(else (display-tab (of line =tab / i) *out*)
(loop (slatex::do-token line i))))))))
(define slatex::do-token
(let ((token-delims (list #\( #\) #\[ #\] #\space *return*
#\" #\' #\`
#\newline #\, #\;)))
(lambda (line i)
(let loop ((buf '()) (i i))
(let ((c (of line =char / i)))
(cond ((char=? c #\\ )
(loop (cons (of line =char / (+ i 1)) (cons c buf))
(+ i 2)))
((or (memv c token-delims)
(memv c *math-triggerers*))
(slatex::output-token (list->string (reverse! buf)))
i)
((char? c) (loop (cons (of line =char / i) buf) (+ i 1)))
(else (error "do-token: token contains non-char ~s?"
c))))))))
(define slatex::output-token
(lambda (token)
(if (not (null? *case-stack*))
(let ((top (car *case-stack*)))
(if (of top =in-ctag-tkn)
(begin
(setf (of top =in-ctag-tkn) #f)
(setf (of top =in-case-exp) 1)))))
(if (lassoc token special-symbols (function token=?))
(begin
(if *in-qtd-tkn* (set! *in-qtd-tkn* #f)
(if *in-mac-tkn* (set! *in-mac-tkn* #f)))
(display (cdr (lassoc token special-symbols (function token=?)))
*out*))
(display-token
token
(cond (*in-qtd-tkn*
(set! *in-qtd-tkn* #f)
(cond ((equal? token "else") 'syntax)
((lmember token data-tokens (function token=?)) 'data)
((lmember token constant-tokens (function token=?))
'constant)
((lmember token variable-tokens (function token=?))
'constant)
((lmember token keyword-tokens (function token=?))
'constant)
((prim-data-token? token) 'data)
(else 'constant)))
((> *in-bktd-qtd-exp* 0) 'constant)
((and (not (null? *bq-stack*))
(not (of (car *bq-stack*) =in-comma))) 'constant)
(*in-mac-tkn* (set! *in-mac-tkn* #f)
(set-keyword token) 'syntax)
((> *in-bktd-mac-exp* 0) (set-keyword token) 'syntax)
((lmember token data-tokens (function token=?)) 'data)
((lmember token constant-tokens (function token=?)) 'constant)
((lmember token variable-tokens (function token=?)) 'variable)
((lmember token keyword-tokens (function token=?))
(cond ((token=? token "quote") (set! *in-qtd-tkn* #t))
((lmember token macro-definers (function token=?))
(set! *in-mac-tkn* #t))
((lmember token case-and-ilk (function token=?))
(set! *case-stack*
(cons (let ((f (make-case-frame)))
(setf (of f =in-ctag-tkn) #t)
(setf (of f =in-bktd-ctag-exp) 0)
(setf (of f =in-case-exp) 0)
f)
*case-stack*))))
'syntax)
((prim-data-token? token) 'data)
(else 'variable))
*out*))
(if (and (not (null? *bq-stack*)) (of (car *bq-stack*) =in-bq-tkn))
(set! *bq-stack* (cdr *bq-stack*)))))
)

12
collects/slatex/slatex-code/config.dat
View File

@ -1,12 +0,0 @@
;mzschemeunix.cfg
;sample config.dat for MzScheme on Unix
mzscheme
unix
"mzscheme"
"/home/dorai/tex/slatex/slatex.scm"
"/home/dorai/tex/0tex"
()
#t
"-f"
#f

7
collects/slatex/slatex-code/config.scm
View File

@ -1,7 +0,0 @@
;config.scm
;Configures SLaTeX for your system
;(c) Dorai Sitaram, 1991-8
; 'nil is a symbol in Scheme, but nil in CL
(load (if 'nil "cfg4scm.scm" "cfg4lsp.lsp"))

25
collects/slatex/slatex-code/copying
View File

@ -1,25 +0,0 @@
copying
SLaTeX Version 2.4
Dorai Sitaram, 1991, 1998
ds26@gte.com
SLaTeX is provided free of charge.
You are free to use, copy and distribute verbatim
copies of SLaTeX provided this License Agreement is
included, provided you don't change the authorship
notice that heralds each file, and provided you give
the recipient(s) the same permissions that this
agreement allows you.
You are free to use, modify and distribute modified
copies of SLaTeX provided you follow the conditions
described above, with the further condition that you
prominently state the changes you made.
Neither Rice University, nor GTE Labs Inc., nor Dorai
Sitaram assume any responsibility for any damages arising
out of using SLaTeX.
Dorai Sitaram
ds26@gte.com

139
collects/slatex/slatex-code/defaults.scm
View File

@ -1,139 +0,0 @@
;defaults.scm
;SLaTeX v. 2.3
;Default database for SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-if (cl)
(eval-within slatex
(defvar slatex::*slatex-case-sensitive?* #f)))
(eval-unless (cl)
(eval-within slatex
(defvar slatex::*slatex-case-sensitive?* #t)))
(eval-within slatex
(defvar slatex::keyword-tokens
'(
;RnRS (plus some additional Scheme) keywords
"=>"
"%"
"abort"
"and"
"begin"
"begin0"
"case"
"case-lambda"
"cond"
"define"
"define!"
"define-macro!"
"define-syntax"
"defmacro"
"defrec!"
"delay"
"do"
"else"
"extend-syntax"
"fluid-let"
"if"
"lambda"
"let"
"let*"
"letrec"
"let-syntax"
"letrec-syntax"
"or"
"quasiquote"
"quote"
"rec"
"record-case"
"record-evcase"
"recur"
"set!"
"sigma"
"struct"
"syntax"
"syntax-rules"
"trace"
"trace-lambda"
"trace-let"
"trace-recur"
"unless"
"unquote"
"unquote-splicing"
"untrace"
"when"
"with"
))
(defvar slatex::variable-tokens '())
(defvar slatex::constant-tokens '())
(defvar slatex::data-tokens '())
(defvar slatex::special-symbols
'(
("." . ".")
("..." . "{\\dots}")
("-" . "$-$")
("1-" . "\\va{1$-$}")
("-1+" . "\\va{$-$1$+$}")
))
(defvar slatex::macro-definers
'("define-syntax" "syntax-rules" "defmacro"
"extend-syntax" "define-macro!"))
(defvar slatex::case-and-ilk
'("case" "record-case"))
(define slatex::tex-analog
(lambda (c)
;find a TeX string that corresponds to the character c
(case c
((#\$ #\& #\% #\# #\_) (string #\\ c))
;((#\#) "{\\sf\\#}")
;((#\\) "{\\ttbackslash}")
((#\{ #\}) (string #\$ #\\ c #\$))
((#\\) "$\\backslash$")
((#\+) "$+$")
((#\*) "$\\ast$")
((#\=) "$=$")
((#\<) "$\\lt$")
((#\>) "$\\gt$")
((#\^) "\\^{}")
((#\|) "$\\vert$")
;((#\~) "\\verb-~-")
((#\~) "\\~{}")
((#\@) "{\\atsign}")
((#\") "{\\tt\\dq}")
(else (string c)))))
(define slatex::token=?
(lambda (t1 t2)
;tests if t1 and t2 are identical tokens
(funcall (if *slatex-case-sensitive?* (function string=?)
(function string-ci=?))
t1 t2)))
(defvar slatex::*slatex-enabled?* #t)
(defvar slatex::*slatex-reenabler* "UNDEFINED")
(defvar slatex::*intext-triggerers* (list "scheme"))
(defvar slatex::*resultintext-triggerers* (list "schemeresult"))
(defvar slatex::*display-triggerers* (list "schemedisplay"))
(defvar slatex::*response-triggerers* (list "schemeresponse"))
(defvar slatex::*respbox-triggerers* (list "schemeresponsebox"))
(defvar slatex::*box-triggerers* (list "schemebox"))
(defvar slatex::*top-box-triggerers* (list "schemetopbox"))
(defvar slatex::*input-triggerers* (list "schemeinput"))
(defvar slatex::*region-triggerers* (list "schemeregion"))
(defvar slatex::*math-triggerers* '())
(defvar slatex::*slatex-in-protected-region?* #f)
(defvar slatex::*protected-files* '())
(defvar slatex::*include-onlys* 'all)
(defvar slatex::*latex?* #t)
(defvar slatex::*slatex-separate-includes?* #f)
(defvar slatex::*tex-calling-directory* "")
)

24
collects/slatex/slatex-code/defun.tex
View File

@ -1,24 +0,0 @@
\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\defprocedure{\defun{procedure}}
%\def\defessentialprocedure{\defun{\hbox{%
% \vbox{\hbox{essential}\hbox{procedure}}}}}

59
collects/slatex/slatex-code/fileproc.scm
View File

@ -1,59 +0,0 @@
;fileproc.scm
;SLaTeX Version 2.3
;File-manipulation routines used by SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994
;file-exists?
(eval-if (vscm)
(eval-within slatex
(define slatex::file-exists?
(if (eq? *op-sys* 'unix)
(lambda (f)
(system (string-append "test -f " f)))
(lambda (f) 'assume-file-exists)))))
(eval-unless (bigloo chez cl cscheme elk gambit guile mzscheme pcsge scm stk
vscm)
(eval-within slatex
(define slatex::file-exists?
(lambda (f) #t))));assume file exists
;delete-file
(eval-if (schemetoc stk umbscheme)
(eval-within slatex
(define slatex::delete-file
(lambda (f)
(call-with-output-file f
(lambda (p) 'file-deleted))))))
(eval-unless (bigloo chez cl cscheme guile mzscheme pcsge
schemetoc scm stk umbscheme vscm)
(eval-within slatex
(define slatex::delete-file
(lambda (f) 'assume-file-deleted))))
;force-output
;the DOS version of C Scheme has flush-output, the Unix version doesn't
(eval-if (cscheme)
(eval-within slatex
(define slatex::force-output
(if (environment-bound? user-initial-environment 'flush-output)
flush-output
(lambda z 'assume-output-forced)))))
(eval-if (bigloo)
(eval-within slatex
(define slatex::force-output
(lambda z
(if (null? z)
(flush-output-port (current-output-port))
(flush-output-port (car z)))))))
(eval-unless (bigloo chez cl cscheme elk guile mzscheme scm vscm)
(eval-within slatex
(define slatex::force-output
(lambda z 'assume-output-forced))))

197
collects/slatex/slatex-code/helpers.scm
View File

@ -1,197 +0,0 @@
;helpers.scm
;SLaTeX v. 2.4
;Helpers for SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-unless (cl)
(eval-within slatex
(define slatex::prim-data-token?
(lambda (token)
;token cannot be empty string!
(or (char=? (string-ref token 0) #\#)
(string->number token))))))
(eval-if (cl)
(eval-within slatex
(defun prim-data-token? (token)
(declare (global-string token))
(let ((c (char token 0)))
(or (char= c #\#)
(char= c #\:)
(numberp (read-from-string token)))))))
(eval-within slatex
(define slatex::set-keyword
(lambda (x)
;add token x to the keyword database
(if (not (lmember x keyword-tokens (function token=?)))
(begin
(set! constant-tokens
(delete x constant-tokens (function token=?)))
(set! variable-tokens
(delete x variable-tokens (function token=?)))
(set! data-tokens (delete x data-tokens (function token=?)))
(set! keyword-tokens (cons x keyword-tokens))))))
(define slatex::set-constant
(lambda (x)
;add token x to the constant database
(if (not (lmember x constant-tokens (function token=?)))
(begin
(set! keyword-tokens
(delete x keyword-tokens (function token=?)))
(set! variable-tokens
(delete x variable-tokens (function token=?)))
(set! data-tokens (delete x data-tokens (function token=?)))
(set! constant-tokens (cons x constant-tokens))))))
(define slatex::set-variable
(lambda (x)
;add token x to the variable database
(if (not (lmember x variable-tokens (function token=?)))
(begin
(set! keyword-tokens (delete x keyword-tokens (function token=?)))
(set! constant-tokens
(delete x constant-tokens (function token=?)))
(set! data-tokens (delete x data-tokens (function token=?)))
(set! variable-tokens (cons x variable-tokens))))))
(define slatex::set-data
(lambda (x)
;add token x to the "data" database
(if (not (lmember x data-tokens (function token=?)))
(begin
(set! keyword-tokens
(delete x keyword-tokens (function token=?)))
(set! constant-tokens
(delete x constant-tokens (function token=?)))
(set! variable-tokens
(delete x variable-tokens (function token=?)))
(set! data-tokens (cons x data-tokens))))))
(define slatex::set-special-symbol
(lambda (x transl)
;add token x to the special-symbol database with
;the translation transl
(let ((c (lassoc x special-symbols (function token=?))))
(if c (set-cdr! c transl)
(set! special-symbols
(cons (cons x transl) special-symbols))))))
(define slatex::unset-special-symbol
(lambda (x)
;disable token x's special-symbol-hood
(set! special-symbols
(delete-if
(lambda (c)
(token=? (car c) x)) special-symbols))))
(define slatex::texify
(lambda (s)
;create a tex-suitable string out of token s
(list->string (slatex::texify-aux s))))
(define slatex::texify-data
(lambda (s)
;create a tex-suitable string out of the data token s
(let loop ((l (texify-aux s)) (r '()))
(if (null? l) (list->string (reverse! r))
(let ((c (car l)))
(loop (cdr l)
(if (char=? c #\-) (append! (list #\$ c #\$) r)
(cons c r))))))))
(define slatex::texify-aux
(let* ((arrow (string->list "-$>$"))
(em-dash (string->list "---"))
(en-dash (string->list "--"))
(arrow2 (string->list "$\\to$"))
(em-dash-2 (string->list "${-}{-}{-}$"))
(en-dash-2 (string->list "${-}{-}$")))
(lambda (s)
;return the list of tex characters corresponding to token s.
;perhaps some extra context-sensitive prettifying
;could go in the making of texified-sl below
(let ((texified-sl (mapcan
(lambda (c) (string->list (tex-analog c)))
(string->list s))))
(let loop ((d texified-sl))
;cdr down texified-sl
;to transform any character combinations
;as desired
(cond ((null? d) #f)
((list-prefix? arrow d) ; $->$
(let ((d2 (list-tail d 4)))
(set-car! d (car arrow2))
(set-cdr! d (append (cdr arrow2) d2))
(loop d2)))
((list-prefix? em-dash d) ; ---
(let ((d2 (list-tail d 3)))
(set-car! d (car em-dash-2))
(set-cdr! d (append (cdr em-dash-2) d2))
(loop d2)))
((list-prefix? en-dash d) ; --
(let ((d2 (list-tail d 2)))
(set-car! d (car en-dash-2))
(set-cdr! d (append (cdr en-dash-2) d2))
(loop d2)))
(else (loop (cdr d)))))
texified-sl))))
(define slatex::display-begin-sequence
(lambda (out)
(if (or *intext?* (not *latex?*))
(begin
(display "\\" out)
(display *code-env-spec* out)
(newline out))
(begin
(display "\\begin{" out)
(display *code-env-spec* out)
(display "}%" out)
(newline out)))))
(define slatex::display-end-sequence
(lambda (out)
(cond (*intext?* ;(or *intext?* (not *latex?*))
(display "\\end" out)
(display *code-env-spec* out)
;(display "{}" out)
(newline out))
(*latex?*
(display "\\end{" out)
(display *code-env-spec* out)
(display "}" out)
(newline out))
(else
(display "\\end" out)
(display *code-env-spec* out)
(newline out)))))
(define slatex::display-tex-char
(lambda (c p)
(display (if (char? c) (tex-analog c) c) p)))
(define slatex::display-token
(lambda (s typ p)
(cond ((eq? typ 'syntax)
(display "\\sy{" p)
(display (texify s) p)
(display "}" p))
((eq? typ 'variable)
(display "\\va{" p)
(display (texify s) p)
(display "}" p))
((eq? typ 'constant)
(display "\\cn{" p)
(display (texify s) p)
(display "}" p))
((eq? typ 'data)
(display "\\dt{" p)
(display (texify-data s) p)
(display "}" p))
(else (error "display-token: ~
Unknown token type ~s." typ)))))
)

180
collects/slatex/slatex-code/history
View File

@ -1,180 +0,0 @@
2.4w
9 Oct 1999
Read cr before lf when reading files on Windows (Shriram report)
Token delimitation strengthened (John Clements bug
report).
CL set-dispatch-macro-character arg should be uppercase
character because CLISP doesn't automatically upcase
it as standard suggests
2.4v
8 Mar 1999
Comma'd forms inside backquote should get the right font
assignment even if preceded by quote. (Shriram bug report)
2.4u
15 Jan 1999
Use require-library instead of reference-library.
pathproc.scm: *path-separator*, *directory-mark*,
*file-hider* have approp values for OS = Windows.
MzScheme/Win95 slatex.bat should contain Windows-style
line termination.
Config file for CLISP on Win 95.
Jun 8, 1998
2.4t
distribution mishap fix
May 1, 1998
2.4s
Port to STk
Apr 21, 1998
2.4r
Port to Allegro Common Lisp for Linux. Minor config
bugs nixed.
Apr 1998
2.4q
Ports to Windows 95, Gambit, MIT Scheme.
Apr 1997
2.4 p
{schemeregion} should not collapse lines with TeX comments
into one (nor should it eat the comment character).
v. 2.4o
Fixed indentation bug caused by implicit space after \\
in tab environment.
Feb 1997
v. 2.4n
Fixed bug that caused \begin{schemebox} to produce space at
paragraph begin (Matthias).
Ported to Bigloo, thanks to Christian Queinnec.
* typesets as \ast. (* "as is" is too high.)
Ported to Guile.
May 1996
v 2.4m
Ported to MzScheme.
Check that config.dat has right number of answers.
Eliminates common typos while setting up config.dat
(Shriram's sugg.).
Accommodate Schemes that allow loading of files mentioned on
the command-line, but using an option such as -load or -f
(Shriram's sugg).
Changed names in preproc.scm to avoid collision with
existing Scheme procs, if any. (Shriram Krishnamurthi's
idea.)
Ported to GCL (Linux).
Changes to package system -- uses CL's package sys in CL.
dump-display made more efficient.
Cleaned up bat config.
Feb 1996
v 2.4l
Ported to Macintosh Common Lisp.
Version number reported on invocation and whilst loading
slatex.sty (to enable trenchant bug reporting).
No longer requires "system" procedure spec from user via
config.dat. Other config info should be sufficient to
deduce this. One less confusion.
v 2.4k
-- and --- in Scheme tokens are treated as minuses rather
than en- and em-dash. Mike Ernst's idea.
v 2.4j
Now recognizes :keywords as data in CL.
Left margin error in indented {schemedisplay}s corrected
Package system made more robust
Apr 1995
v 2.4
Support for OS/2, both FAT and HPFS.
Included sample Rexx script (for OS/2 + emTeX + scm)
that has robust TEXINPUT recognition.
Fixed paragraph indentation bug after {schemedisplay}
within {schemeregion}.
Recognizes LaTeX2e files in addition to LaTeX2.09.
Sentence-ending space doesn't follow null?, set!, etc.
Documentation converted to plain TeX.
Added {schemeresponse}, {schemeresponsebox}, and their
corresponding \defscheme*token and \undefscheme*token.
Fixed bug related to quoted special symbols;
quoted math escapes; and quoted strings.
Added \setdata in analogy with \setkeyword,
\setvariable, and \setconstant.
\schemeresult, etc., distinguish between constant and
data -- data items are set in \datafont; everything
else in \constantfont.
Removed bogus \ignorespaces from \slatexdisable.
Typeset code is now frenchspaced (instead of using
\null's) to avoid sentence-ending spaces after ! and ?.
Mark Krentel's idea.
Added config code for Matthias Blume's VSCM.
Jan 1994
v 2.3
The Dark Years
Several bug fixes
Dec 1991
First major update
Mar 1991
First public release
1990
First Rice PLT release

233
collects/slatex/slatex-code/index.tex
View File

@ -1,233 +0,0 @@
\input tex2html
\htmlonly
\htmlstylesheet{tex2html.css}
\gifpreamble
\magnification\magstep1
\endgifpreamble
\let\byline\leftline
\endhtmlonly
\let\n\noindent
%%%
\subject{SLaTeX}
\byline{\urlh{slatex.tar.gz}{[Download version \input version ]}}
\smallskip
\byline{\urlh{http://www.cs.rice.edu/~dorai}{Dorai Sitaram}}
\byline{\urlh{mailto:ds26@gte.com}{ds26@gte.com}}
\bigskip
\section{Introduction}
SLaTeX is a Scheme program that allows you to write
program code (or code fragments) ``as is'' in your
LaTeX or plain TeX source. SLaTeX will typeset the
code with appropriate fonts for the various token
categories --- e.g., {\bf boldface} for keywords and
{\em italics} for variables ---, at the same time
retaining the proper indentations and vertical
alignments in TeX's non-monospace fonts.
\subsection{SLaTeX for LaTeX users}
For example, consider a LaTeX file \p{example.tex}
with the following contents:
\verb+
\documentclass{article}
\usepackage{slatex}
\begin{document}
In Scheme, the expression
\scheme|(set! x 42)| returns
an unspecified value, rather
than \scheme'42'. However,
one could get a \scheme{set!}
of the latter style with:
\begin{schemedisplay}
(define-syntax setq
(syntax-rules ()
[(setq var val)
(begin (set! var val)
var)]))
\end{schemedisplay}
\end{document}
+
When run through SLaTeX, the resulting \p{example.dvi} file
looks as follows:
---
\htmlgif
\input slatex.sty
\input margins
\sidemargin 1.75 true in
In Scheme, the expression
\scheme|(set! x 42)| returns
an unspecified value, rather
than \scheme'42'. However,
one could get a \scheme{set!}
of the latter style with:
\schemedisplay
(define-syntax setq
(syntax-rules ()
[(setq var val)
(begin (set! var val)
var)]))
\endschemedisplay
\endhtmlgif
---
As the example shows, {\em in-text} code is introduced by
the control sequence \p{\scheme} and is flanked by either
identical characters or by matching braces. Code meant for
{\em display} is presented between
\p{\begin{schemedisplay}} and
\p{\end{schemedisplay}}. Note that you write the code
as you would when writing a program --- no special
annotation is needed to get the typeset version.
\subsection{SLaTeX for plain TeX users}
SLaTeX works much the same way with plain TeX as with
LaTeX, but for only two exceptions. First, since plain
TeX doesn't have \p{\documentstyle}, the file
\p{slatex.sty} must be introduced via an \p{\input}
statement before its commands can be used in the plain
TeX source.
Second, since plain TeX does not have LaTeX's
\p|\begin{|{\em env}\p|} ... \end{|{\em env}\p|}|
style of environments, any
environment commands in SLaTeX are invoked with the
opening \p{\}{\em env} and the closing
\p{\end}{\it env}.
The plain TeX version of \p{quick.tex} looks like:
---
\verb+
% quick.tex
\input slatex.sty
In Scheme, the expression
\scheme|(set! x 42)| returns
an unspecified value, rather
than \scheme'42'. However,
one could get a \scheme{set!}
of the latter style with:
\schemedisplay
(define-syntax setq
(syntax-rules ()
[(setq x a)
(begin (set! x a)
x)]))
\endschemedisplay
\bye
+
---
The file is now SLaTeX'd by invoking \p{slatex} as
before --- SLaTeX is clever enough to figure out
whether the file it operates on should later be sent to
LaTeX or plain TeX.
\section{Automatic token recognition}
By default, SLaTeX recognizes the tokens of Scheme.
This default can be changed with the commands
\p{\setkeyword}, \p{\setvariable},
\p{\setconstant}, and \p{\setdata}. The arguments of
these commands is a space-separated list enclosed in
braces. E.g.,
\p{
\setconstant{infinity -infinity}
}
\n tells SLaTeX that \scheme{infinity} and
\scheme{-infinity} are to be typeset as constants.
The file \p{cltl.sty} uses these commands to modify
SLaTeX's default so that it recognizes the tokens of
Common Lisp rather than Scheme. You may fashion your
own \p{.sty} files on the model of
\p{cltl.sty}.
The user need not use \p{\setkeyword} to specify such
new keywords as are introduced by Scheme's (or Common
Lisp's) macro definition facilities. SLaTeX will
automatically recognize new macros and auxiliary
keywords, as in the example above, where \p{setq} is
recognized as a keyword because of the context in which
it occurs, although it is not normally a keyword in
Scheme. No special treatment is needed to ensure that
it will continue to be treated as a keyword in any
subsequent Scheme code in the document.
In addition, quoted material is recognized as
``constant'', and strings, numbers, booleans and
characters are recognized as ``data'' without the need
to identify them with \p{\setconstant} and \p{\setdata}
respectively.
\subsection{Tokens as arbitrary symbols}
Although your program code is naturally restricted to
using ascii identifiers that follow some convention,
the corresponding typeset code could be more mnemonic
and utilize the full suite of mathematical and other
symbols provided by TeX. This of course should not
require you to interfere with your code itself, which
should run in its ascii representation. It is only the
typeset version that has the new look. For instance,
if you want all occurrences of the ascii token
\p{lambda} to be typeset as the Greek letter $\lambda$,
you could say
\p{
\setspecialsymbol{lambda}{$\lambda$}
}
You can use \p{\unsetspecialsymbol} on a token to have
it revert to its default behavior.
In effect, \p{\setspecialsymbol} generalizes the act of
``fonting'' a token to converting it into any arbitrary
symbol.
\section{Additional documentation}
More comprehensive documentation of all that
is possible with SLaTeX is provided in the
distribution.
Although SLaTeX is written in Scheme, a configuration
option is provided to make it run on Common Lisp.
SLaTeX has tested successfully on many different Scheme
and Common Lisp dialects, viz., Allegro Common Lisp,
Austin Kyoto Common Lisp, Bigloo, Chez Scheme, CLISP,
Elk, Gambit, Gnu Common Lisp, Guile, Ibuki Common Lisp,
Macintosh Common Lisp, MIT Scheme, MzScheme,
Scheme{\tt->}C, SCM, UMB Scheme, and VSCM.
\bye

173
collects/slatex/slatex-code/install
View File

@ -1,173 +0,0 @@
INSTALL
SLaTeX Version 2.4
(c) Dorai Sitaram
Installation instructions for SLaTeX
...
1. Configuring SLaTeX for your system
1) Go to the directory slatex.
2) Edit the file config.dat as suggested in the
comments there. Some sample config.dat's are provided in
the configs/ subdirectory.
3) Invoke your Scheme interpreter. (If you're using
Common Lisp, invoke the Common Lisp interpreter.) Load
the file config.scm into Scheme (or Common Lisp). This
is done by typing
(load "config.scm")
at the Scheme (or Common Lisp) prompt.
This will configure SLaTeX for your Scheme dialect and
operating system, creating an appropriate slatex.scm file.
(For Chez and MzScheme, slatex.scm is a compiled version.) A
script file (called slatex.bat on DOS, slatex.cmd on OS/2,
and just slatex on Unix) is also created for convenient
invocation on your operating system command line. A
Scheme/Common Lisp file callsla.scm is also created to
provide access to SLaTeX from Scheme/Common Lisp.
4) Exit Scheme (or Common Lisp).
(Note: In many Schemes and Common Lisps on Unix, you can
combine steps 3 and 4 with a command such as
echo '(load "config.scm")' | scheme
)
...
2. Setting paths and modifying script file
(If your dialect is Bigloo, you may ignore this section.)
1) Copy or move or link slatex.scm into a suitable
place, e.g., your bin or lib, or the system bin or
lib.
2) Copy or move or link slatex.sty into a suitable
place, e.g., somewhere in your TEXINPUT(S) path. For
installing on system, place in directory containing
the LaTeX style files (on mine this is
/usr/local/lib/tex/macros).
3) (If your platform is a Mac, ignore this.) Copy or move
or link the shellscript slatex or batfile slatex.bat to a
suitable place in your PATH, e.g., your bin or the system
bin. Note that slatex(.bat) sets SLaTeX.*texinputs*. If
you're making the same shellscript/batfile available to
multiple users, you should change the line
(set! slatex::*texinputs* "...")
to
(set! slatex::*texinputs* <dialect-dependent-way
of obtaining TEXINPUT(S)>)
(But see scripts/readme.)
4) Run slatex on slatxdoc.tex for documentation.
(This also checks that slatex does indeed work on your
machine.) Refer to slatxdoc.dvi when befuddled.
...
3. Other ways of invoking SLaTeX
The configuration process creates shellscript/batfile
slatex(.bat) for a standard invoking mechanism for
SLaTeX. The shellscript/batfile is created to exploit
the way your Scheme is called, e.g., matters like
whether it accepts echo'd s-expressions (e.g., Chez),
whether it loads command line files (e.g., SCM), and
whether it always checks for an "init" file (e.g., MIT
C Scheme).
1) If your Scheme doesn't fall into either of these
categories, you may have to write your own
shellscript/batfile or devise some other mechanism.
2) The shellscript/batfile invokes Scheme. If,
however, you are already in Scheme and spend most of
the time continuously at the Scheme prompt rather than
the operating system prompt, you may want to avoid some
of the delays inherent in the shellscript/batfile.
3) If your platform is a Macintosh, no shellscript/batfile
is created. The idea mentioned below is your only choice.
However, it is so easy to use that it may soon become your
preferred way of invoking SLaTeX, even on Unix or OS/2.
The file callsla.scm, which contains just one small
procedure named call-slatex, and which is created by
the configuration process, provides a simple calling
mechanism from Scheme/Common Lisp, as opposed to the
operating system command line. You may use it as an
alternative to the slatex shellscript/batfile. The
usage is as follows: load callsla.scm into
Scheme/Common Lisp
(load "callsla.scm")
and type
(call-slatex <tex-file>)
when you need to call SLaTeX on the (La)TeX file
<tex-file>. This invokes the SLaTeX preprocessor on
<tex-file>. If your Scheme has a "system" procedure
that can call the operating system command line,
call-slatex will also send your file to TeX or LaTeX.
If your Scheme does not have such a procedure,
call-slatex will simply prod you to call TeX or LaTeX
yourself.
The outline of the shellscript/batfile or callsla.scm
or of any strategy you devise for using SLaTeX should
include the following actions:
1) Load the file slatex.scm (created by the
configuration process) into Scheme.
2) Set the variable slatex::*texinputs-list* to the
list of directories in which TeX looks for \input
files. If you have a a "regular" TEXINPUTS, you could
set slatex::*texinputs-list* to
(slatex::path-to-list <the value of TEXINPUTS>)
(In shell scripts, <the value of TEXINPUTS> can be
obtained with some for unquoting. In Schemes with
getenv, you could use (getenv "TEXINPUTS").)
3) Call the procedure slatex::process-main-tex-file on the
.tex file to be processed.
4) Call either latex or tex on the .tex file.
You may devise your own way of calling
process-main-tex-file, provided your method makes sure
that slatex.scm has been loaded, slatex::.*texinputs* set
appropriately _before_ the call and latex/tex is called
_after_ the call.
Note that if you prefer to stay in Scheme most of the
time, it is a good idea to pre-load the procedure
call-slatex, perhaps through an init file. Call-slatex
is just a "one-liner" "call-by-need" hook to SLaTeX and
does not take up much resources. (Global name clashes
between your own code and SLaTeX code won't occur
unless you use variable names starting with 'slatex::')
If you made no calls to call-slatex, the bigger file
slatex.scm is not loaded at all. If you make several
calls to call-slatex, slatex.scm is loaded only once,
at the time of the first call.
;end of file

131
collects/slatex/slatex-code/lerror.scm
View File

@ -1,131 +0,0 @@
;lerror.scm
;SLaTeX v. 2.3
;Display and error routines
;(c) Dorai Sitaram, Rice U., 1991, 1994
;#\newline and #\space are r5rs
;#\return and #\tab aren't
(eval-unless (cl scm)
(eval-within slatex
(defvar slatex::*return* (integer->char 13))
(defvar slatex::*tab* (integer->char 9))))
(eval-if (guile scm)
(eval-within slatex
(define slatex::error
(lambda vv
(let ((ep (current-error-port)))
(display "Error: " ep)
(for-each
(lambda (v)
(display v ep)
(newline ep))
vv)
(abort))))))
(eval-if (chez elk schemetoc)
(eval-within slatex
(define slatex::error
(lambda vv
(display "Error: ")
(for-each
(lambda (v)
(display v) (newline))
vv)
(global-error #f "")))))
(eval-if (stk)
(eval-within slatex
(define slatex::error
(lambda vv
(display "Error: ")
(for-each
(lambda (v) (display v) (newline))
vv)
(global-error "Error")))))
(eval-if (bigloo)
(eval-within slatex
(define slatex::error
(lambda vv
(display "Error: ")
(for-each
(lambda (v)
(display v) (newline))
vv)
(global-error 'SLaTeX "error" #f)))))
(eval-unless (bigloo chez cl elk guile schemetoc scm)
(eval-within slatex
(define slatex::error
(lambda vv
(display "Error: ")
(for-each
(lambda (v)
(display v) (newline))
vv)
(global-error "")))))
(eval-if (vscm)
(eval-within slatex
(define void
;(void) is a no-op expression that's useful in some places
;where use of a dummy value would make VSCM "warn" about
;unused values
(let ((x 0))
(lambda ()
(set! x 0))))))
(eval-unless (vscm cl chez gambit mzscheme)
(eval-within slatex
(define slatex::void
(lambda ()
(if #f #f)))))
(eval-if (cl)
(eval-within slatex
(defun slatex::function-available (s)
(let ((x (find-symbol s
(if (member 'gcl *features*) :lisp :cl))))
(if (and x (fboundp x)) x nil)))
(defun slatex::exit-scheme ()
(let ((quitter
(or (function-available "BYE")
(function-available "EXIT")
(function-available "QUIT"))))
(if quitter (funcall quitter)
(progn
(format t "You may exit CL now!~%")
(funcall 'barf)))))))
(eval-if (chez elk mzscheme pcsge schemetoc stk umbscheme vscm)
(eval-within slatex
(define slatex::exit-scheme
(lambda () ;in case it's a macro
(exit)))))
(eval-if (cscheme)
(eval-within slatex
(define slatex::exit-scheme
(lambda ()
(%exit)))))
(eval-if (guile scm)
(eval-within slatex
(define slatex::exit-scheme quit)))
(eval-if (bigloo)
(eval-within slatex
(define slatex::exit-scheme
(lambda () (exit 0)))))
(eval-unless (bigloo chez cl cscheme elk guile mzscheme pcsge
schemetoc scm umbscheme vscm)
(eval-within slatex
(define slatex::exit-scheme
(lambda ()
(display "Exit Scheme!")
(newline)
(barf)))))

81
collects/slatex/slatex-code/manifest
View File

@ -1,81 +0,0 @@
;manifest
;SLaTeX Version 2.4
;List of files provided in the SLaTeX distribution
;(c) Dorai Sitaram
;ds26@gte.com
README
install
history
manifest
version
copying
config.dat
;documentation
slatxdoc.tex
slatxdoc.bbl
slatxdoc.dvi
index.tex
tex2html.css
margins.tex
;misc TeX macros
8pt.tex
2col.tex
defun.tex
tex2html.tex
;style files
slatex.sty
cltl.sty
config.scm
cfg4scm.scm
cfg4lsp.lsp
slaconfg.lsp
preproc.lsp
batconfg.lsp
slaconfg.scm
preproc.scm
batconfg.scm
aliases.scm
s4.scm
seqprocs.scm
fileproc.scm
defaults.scm
lerror.scm
structs.scm
helpers.scm
peephole.scm
codeset.scm
pathproc.scm
texread.scm
proctex.scm
proctex2.scm
;alternative ways to invoke SLaTeX
scripts/readme
scripts/slatex.cmd
;sample config.dats
configs/template.cfg
configs/rice.cfg
configs/scmunix.cfg
configs/gclunix.cfg
configs/clispunix.cfg
configs/clispw95.cfg
configs/mzschemeunix.cfg
configs/mzschemew95.cfg
configs/mcl.cfg
configs/guileunix.cfg
configs/bigloounix.cfg
configs/mitschemeunix.cfg
configs/gambitunix.cfg
configs/acllinux.cfg
configs/stkunix.cfg
;eof

11
collects/slatex/slatex-code/margins.tex
View File

@ -1,11 +0,0 @@
\def\sidemargin{\afterassignment\sidemarginII\hoffset}
\def\sidemarginII{\advance\hoffset -1true in
\advance\hsize -2\hoffset}
\def\vertmargin{\afterassignment\vertmarginII\voffset}
\def\vertmarginII{\advance\voffset -1true in
\advance\vsize -2\voffset}

158
collects/slatex/slatex-code/pathproc.scm
View File

@ -1,158 +0,0 @@
;pathproc.scm
;SLaTeX Version 1.99
;File-manipulation routines used by SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-unless (cl)
(eval-within slatex
(define slatex::directory-namestring
(lambda (f)
(let ((p (string-position-right slatex::*directory-mark* f)))
(if p
(substring f 0 (+ p 1)) ""))))
(define slatex::basename
(lambda (f)
(let ((p (string-position-right *directory-mark* f)))
(if p
(set! f (substring f (+ p 1) (string-length f))))
(let ((p (string-position-right #\. f)))
(if p
(substring f 0 p)
f)))))
))
(eval-if (cl)
(eval-within slatex
(defun basename (f)
(let ((f (file-namestring (merge-pathnames
(make-pathname :type "x") f))))
(subseq f 0 (- (length f) 2))))))
(eval-within slatex
(defvar slatex::*texinputs* "")
(defvar slatex::*texinputs-list* #f)
(defvar slatex::*path-separator*
(cond ((eq? *op-sys* 'unix) #\:)
((eq? *op-sys* 'mac-os) (integer->char 0))
((memq *op-sys* '(windows os2 dos os2fat)) #\;)
(else (error "Couldn't determine path separator character."))))
(defvar slatex::*directory-mark*
(cond ((eq? *op-sys* 'unix) #\/)
((eq? *op-sys* 'mac-os) #\:)
((memq *op-sys* '(windows os2 dos os2fat)) #\\)
(else (error "Couldn't determine directory mark."))))
(defvar slatex::*directory-mark-string*
(list->string (list *directory-mark*)))
(defvar slatex::*file-hider*
(cond ((memq *op-sys* '(windows os2 unix mac-os)) ".")
((memq *op-sys* '(dos os2fat)) "x") ;no such luck for dos & os2fat
(else "."))) ;use any old character
(define slatex::path-to-list
(lambda (p)
;convert a unix or dos representation of a path to a list of
;directory names (strings)
(let loop ((p (string->list p)) (r (list "")))
(let ((separator-pos (position-char *path-separator* p)))
(if separator-pos
(loop (list-tail p (+ separator-pos 1))
(cons (list->string (sublist p 0 separator-pos))
r))
(reverse! (cons (list->string p) r)))))))
(define slatex::find-some-file
(lambda (path . files)
;look through each directory in path till one of files is found
(let loop ((path path))
(if (null? path) #f
(let ((dir (car path)))
(let loop1 ((files
(if (or (string=? dir "") (string=? dir "."))
files
(map (lambda (file)
(string-append dir
*directory-mark-string*
file)) files))))
(if (null? files) (loop (cdr path))
(let ((file (car files)))
(if (file-exists? file) file
(loop1 (cdr files)))))))))))
(define slatex::file-extension
(lambda (filename)
;find extension of filename
(let ((i (string-position-right #\. filename)))
(if i (substring filename i (string-length filename))
#f))))
(define slatex::full-texfile-name
(lambda (filename)
;find the full pathname of the .tex/.sty file filename
(let ((extn (file-extension filename)))
(if (and extn (or (string=? extn ".sty") (string=? extn ".tex")))
(find-some-file *texinputs-list* filename)
(find-some-file *texinputs-list*
(string-append filename ".tex") filename)))))
(define slatex::full-styfile-name
(lambda (filename)
;find the full pathname of the .sty file filename
(find-some-file *texinputs-list*
(string-append filename ".sty"))))
(define slatex::full-clsfile-name
(lambda (filename)
;find the full pathname of the .cls file filename
(find-some-file *texinputs-list*
(string-append filename ".cls"))))
(define slatex::full-scmfile-name
(lambda (filename)
;find the full pathname of the scheme file filename;
;acceptable extensions are .scm .ss .s
(apply (function find-some-file) *texinputs-list*
filename
(map (lambda (extn) (string-append filename extn))
'(".scm" ".ss" ".s")))))
(defvar slatex::subjobname 'fwd)
(defvar slatex::primary-aux-file-count -1)
(define slatex::new-primary-aux-file
(lambda e
;used by new-aux-file unless in protected region;
;this is the default
(set! primary-aux-file-count
(+ primary-aux-file-count 1))
(apply (function string-append) *tex-calling-directory*
*file-hider* "Z"
(number->string primary-aux-file-count)
subjobname e)))
(define slatex::new-secondary-aux-file
(let ((n -1))
(lambda e
;used by new-aux-file when in protected region
(set! n (+ n 1))
(apply (function string-append) *tex-calling-directory*
*file-hider*
"ZZ" (number->string n) subjobname e))))
(define slatex::new-aux-file
(lambda e
;create a new auxiliary file with provided extension if any
(apply (if *slatex-in-protected-region?*
(function new-secondary-aux-file)
(function new-primary-aux-file))
e)))
)

397
collects/slatex/slatex-code/peephole.scm
View File

@ -1,397 +0,0 @@
;peephole.scm
;SLaTeX Version 2.3
;Peephole adjuster used by the SLaTeX typesetter
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-within slatex
(define slatex::get-line
(let ((curr-notab &void-notab))
(lambda (line)
;read the current tex line into "line";
;returns false on eof
(let ((graphic-char-seen? #f))
(let loop ((i 0))
(let ((c (read-char *in*)))
(cond (graphic-char-seen? (void))
((or (eof-object? c)
(char=? c *return*)
(char=? c #\newline)
(char=? c #\space) (char=? c *tab*))
(void))
(else (set! graphic-char-seen? #t)))
(cond
((eof-object? c)
(cond ((eq? curr-notab &mid-string)
(if (> i 0)
(setf (of line =notab / (- i 1)) &end-string)))
((eq? curr-notab &mid-comment)
(set! curr-notab &void-notab))
((eq? curr-notab &mid-math)
(error "get-line: Found eof inside math.")))
(setf (of line =char / i) #\newline)
(setf (of line =space / i) &void-space)
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &void-notab)
(setf (of line =rtedge) i)
(if (eq? (of line =notab / 0) &mid-string)
(setf (of line =notab / 0) &begin-string))
(if (= i 0) #f #t))
((or (char=? c *return*) (char=? c #\newline))
(if (and (memv slatex::*op-sys* '(dos windows os2 os2fat))
(char=? c *return*))
(if (char=? (peek-char *in*) #\newline)
(read-char *in*)))
(cond ((eq? curr-notab &mid-string)
(if (> i 0)
(setf (of line =notab / (- i 1)) &end-string)))
((eq? curr-notab &mid-comment)
(set! curr-notab &void-notab))
((eq? curr-notab &mid-math)
(error "get-line: Sorry, you can't split ~
math formulas across lines in Scheme code.")))
(setf (of line =char / i) #\newline)
(setf (of line =space / i) &void-space)
(setf (of line =tab / i)
(cond ((eof-object? (peek-char *in*)) &plain-crg-ret)
(*intext?* &plain-crg-ret)
(else &tabbed-crg-ret)))
(setf (of line =notab / i) &void-notab)
(setf (of line =rtedge) i)
(if (eq? (of line =notab / 0) &mid-string)
(setf (of line =notab / 0) &begin-string))
#t)
((eq? curr-notab &mid-comment)
(setf (of line =char / i) c)
(setf (of line =space / i)
(cond ((char=? c #\space) &plain-space)
((char=? c *tab*) &plain-space)
(else &void-space)))
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &mid-comment)
(loop (+ i 1)))
((char=? c #\\)
(setf (of line =char / i) c)
(setf (of line =space / i) &void-space)
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) curr-notab)
(let ((i+1 (+ i 1)) (c+1 (read-char *in*)))
(if (char=? c+1 *tab*) (set! c+1 #\space))
(setf (of line =char / i+1) c+1)
(setf (of line =space / i+1)
(if (char=? c+1 #\space) &plain-space
&void-space))
(setf (of line =tab / i+1) &void-tab)
(setf (of line =notab / i+1) curr-notab)
(loop (+ i+1 1))))
((eq? curr-notab &mid-math)
(if (char=? c *tab*) (set! c #\space))
(setf (of line =space / i)
(if (char=? c #\space) &plain-space
&void-space))
(setf (of line =tab / i) &void-tab)
(cond ((memv c *math-triggerers*)
(setf (of line =char / i) #\$)
(setf (of line =notab / i) &end-math)
(setf curr-notab &void-notab))
(else (setf (of line =char / i) c)
(setf (of line =notab / i) &mid-math)))
(loop (+ i 1)))
((eq? curr-notab &mid-string)
(if (char=? c *tab*) (set! c #\space))
;or should tab and space be treated differently?
(setf (of line =char / i) c)
(setf (of line =space / i)
(if (char=? c #\space) &inner-space &void-space))
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i)
(cond ((char=? c #\")
(set! curr-notab &void-notab)
&end-string)
(else &mid-string)))
(loop (+ i 1)))
;henceforth curr-notab is &void-notab
((char=? c #\space)
(setf (of line =char / i) c)
(setf (of line =space / i)
(cond (*intext?* &plain-space)
(graphic-char-seen? &inner-space)
(else &init-space)))
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &void-notab)
(loop (+ i 1)))
((char=? c *tab*)
(let loop1 ((i i) (j 0))
(if (< j 8)
(begin
(setf (of line =char / i) #\space)
(setf (of line =space / i)
(cond (*intext?* &plain-space)
(graphic-char-seen? &inner-space)
(else &init-space)))
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &void-notab)
(loop1 (+ i 1) (+ j 1)))))
(loop (+ i 8)))
((char=? c #\")
(setf (of line =char / i) c)
(setf (of line =space / i) &void-space)
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &begin-string)
(set! curr-notab &mid-string)
(loop (+ i 1)))
((char=? c #\;)
(setf (of line =char / i) c)
(setf (of line =space / i) &void-space)
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &begin-comment)
(set! curr-notab &mid-comment)
(loop (+ i 1)))
((memv c *math-triggerers*)
(setf (of line =char / i) #\$)
(setf (of line =space / i) &void-space)
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &begin-math)
(set! curr-notab &mid-math)
(loop (+ i 1)))
(else (setf (of line =char / i) c)
(setf (of line =space / i) &void-space)
(setf (of line =tab / i) &void-tab)
(setf (of line =notab / i) &void-notab)
(loop (+ i 1))))))))))
(define slatex::peephole-adjust
(lambda (curr prev)
;adjust the tabbing information on the current line curr and
;its previous line prev relative to each other
(if (or (slatex::blank-line? curr)
(slatex::flush-comment-line? curr))
(if (not *latex-paragraph-mode?*)
(begin
(set! *latex-paragraph-mode?* #t)
(if (not *intext?*)
(begin
(slatex::remove-some-tabs prev 0)
(let ((prev-rtedge (of prev =rtedge)))
(if (eq? (of prev =tab / prev-rtedge) &tabbed-crg-ret)
(setf (of prev =tab / (of prev =rtedge))
&plain-crg-ret)))))))
(begin
(if *latex-paragraph-mode?*
(set! *latex-paragraph-mode?* #f)
(if (not *intext?*)
(let ((remove-tabs-from #f))
(let loop ((i 0))
(cond
((char=? (of curr =char / i) #\newline)
(set! remove-tabs-from i))
((char=? (of prev =char / i) #\newline)
(set! remove-tabs-from #f))
((eq? (of curr =space / i) &init-space)
;eating initial space of curr
(if (eq? (of prev =notab / i) &void-notab)
(begin
(cond
((or (char=? (of prev =char / i) #\()
(eq? (of prev =space / i) &paren-space))
(setf (of curr =space / i) &paren-space))
((or (char=? (of prev =char / i) #\[)
(eq? (of prev =space / i) &bracket-space))
(setf (of curr =space / i) &bracket-space))
((or (memv (of prev =char / i) '(#\' #\` #\,))
(eq? (of prev =space / i) &quote-space))
(setf (of curr =space / i) &quote-space)))
(if (memq (of prev =tab / i)
(list &set-tab &move-tab))
(setf (of curr =tab / i) &move-tab))))
(loop (+ i 1)))
;finished tackling &init-spaces of curr
((= i 0) ;curr starts left-flush
(set! remove-tabs-from 0))
;at this stage, curr[notab,i]
;is either #f or a &begin-comment/string
((not (eq? (of prev =tab / i) &void-tab))
;curr starts with nice alignment with prev
(set! remove-tabs-from (+ i 1))
(if (memq (of prev =tab / i)
(list &set-tab &move-tab))
(setf (of curr =tab / i) &move-tab)))
((memq (of prev =space / i)
(list &init-space &init-plain-space
&paren-space &bracket-space
&quote-space))
;curr starts while prev is still empty
(set! remove-tabs-from (+ i 1)))
((and (char=? (of prev =char / (- i 1)) #\space)
(eq? (of prev =notab / (- i 1)) &void-notab))
;curr can induce new alignment straightaway
(set! remove-tabs-from (+ i 1))
(setf (of prev =tab / i) &set-tab)
(setf (of curr =tab / i) &move-tab))
(else ;curr stakes its &move-tab (modulo parens/bkts)
;and induces prev to have corresp &set-tab
(set! remove-tabs-from (+ i 1))
(let loop1 ((j (- i 1)))
(cond ((<= j 0) 'exit-loop1)
((not (eq? (of curr =tab / j) &void-tab))
'exit-loop1)
((memq (of curr =space / j)
(list &paren-space &bracket-space
&quote-space))
(loop1 (- j 1)))
((or (not (eq? (of prev =notab / j)
&void-notab))
(char=? (of prev =char / j) #\space))
(let ((k (+ j 1)))
(if (not (memq (of prev =notab / k)
(list &mid-comment
&mid-math &end-math
&mid-string
&end-string)))
(begin
(if (eq? (of prev =tab / k)
&void-tab)
(setf (of prev =tab / k)
&set-tab))
(setf (of curr =tab / k)
&move-tab)))))
(else 'anything-else?)
)))))
(remove-some-tabs prev remove-tabs-from))))
(if (not *intext?*) (slatex::add-some-tabs curr))
(slatex::clean-init-spaces curr)
(slatex::clean-inner-spaces curr)))))
(define slatex::add-some-tabs
(lambda (line)
;add some tabs in the body of line "line" so the next line
;can exploit them
(let loop ((i 1) (succ-parens? #f))
(let ((c (of line =char / i)))
(cond ((char=? c #\newline) 'exit-loop)
((not (eq? (of line =notab / i) &void-notab))
(loop (+ i 1) #f))
((char=? c #\[)
(if (eq? (of line =tab / i) &void-tab)
(setf (of line =tab / i) &set-tab))
(loop (+ i 1) #f))
((char=? c #\()
(if (eq? (of line =tab / i) &void-tab)
(if (not succ-parens?)
(setf (of line =tab / i) &set-tab)))
(loop (+ i 1) #t))
(else (loop (+ i 1) #f)))))))
(define slatex::remove-some-tabs
(lambda (line i)
;remove useless tabs on line "line" after index i
(if i
(let loop ((i i))
(cond ((char=? (of line =char / i) #\newline) 'exit)
((eq? (of line =tab / i) &set-tab)
(setf (of line =tab / i) &void-tab)
(loop (+ i 1)))
(else (loop (+ i 1))))))))
(define slatex::clean-init-spaces
(lambda (line)
;remove init-spaces on line "line" because
;tabs make them defunct
(let loop ((i (of line =rtedge)))
(cond ((< i 0) 'exit-loop)
((eq? (of line =tab / i) &move-tab)
(let loop1 ((i (- i 1)))
(cond ((< i 0) 'exit-loop1)
((memq (of line =space / i)
(list &init-space &paren-space &bracket-space
&quote-space))
(setf (of line =space / i) &init-plain-space)
(loop1 (- i 1)))
(else (loop1 (- i 1))))))
(else (loop (- i 1)))))))
(define slatex::clean-inner-spaces
(lambda (line)
;remove single inner spaces in line "line" since
;paragraph mode takes care of them
(let loop ((i 0) (succ-inner-spaces? #f))
(cond ((char=? (of line =char / i) #\newline) 'exit-loop)
((eq? (of line =space / i) &inner-space)
(if (not succ-inner-spaces?)
(setf (of line =space / i) &plain-space))
(loop (+ i 1) #t))
(else (loop (+ i 1) #f))))))
(define slatex::blank-line?
(lambda (line)
;check if line "line" is blank
(let loop ((i 0))
(let ((c (of line =char / i)))
(cond ((char=? c #\space)
(if (eq? (of line =notab / i) &void-notab)
(loop (+ i 1)) #f))
((char=? c #\newline)
(let loop1 ((j (- i 1)))
(if (not (<= j 0))
(begin
(setf (of line =space / i) &void-space)
(loop1 (- j 1)))))
#t)
(else #f))))))
(define slatex::flush-comment-line?
(lambda (line)
;check if line "line" is one with ; in the leftmost column
(and (char=? (of line =char / 0) #\;)
(eq? (of line =notab / 0) &begin-comment)
(not (char=? (of line =char / 1) #\;)))))
(define slatex::do-all-lines
(lambda ()
;process all lines, adjusting each adjacent pair
(let loop ((line1 *line1*) (line2 *line2*))
(let* ((line2-paragraph? *latex-paragraph-mode?*)
(more? (get-line line1)))
;
(peephole-adjust line1 line2)
;
(funcall (if line2-paragraph?
(function slatex::display-tex-line)
(function slatex::display-scm-line)) line2)
;
(if (not (eq? line2-paragraph? *latex-paragraph-mode?*))
(funcall (if *latex-paragraph-mode?*
(function display-end-sequence)
(function display-begin-sequence)) *out*))
;
(if more? (loop line2 line1))))))
;scheme2tex is the "interface" procedure supplied by this file --
;it takes Scheme code from inport and produces LaTeX source for same
;in outport
(define slatex::scheme2tex
(lambda (inport outport)
;create a typeset version of scheme code from inport
;in outport;
;local setting of keywords, etc.?
(set! *in* inport)
(set! *out* outport)
(set! *latex-paragraph-mode?* #t)
(set! *in-qtd-tkn* #f)
(set! *in-bktd-qtd-exp* 0)
(set! *in-mac-tkn* #f)
(set! *in-bktd-mac-exp* 0)
(set! *case-stack* '())
(set! *bq-stack* '())
(let ((flush-line ;needed anywhere else?
(lambda (line)
(setf (of line =rtedge) 0)
(setf (of line =char / 0) #\newline)
(setf (of line =space / 0) &void-space)
(setf (of line =tab / 0) &void-tab)
(setf (of line =notab / 0) &void-notab))))
(funcall flush-line *line1*)
(funcall flush-line *line2*))
(do-all-lines)))
)

157
collects/slatex/slatex-code/preproc.lsp
View File

@ -1,157 +0,0 @@
;preproc.lsp
;Preprocessor to allow CL interpret the brand of Scheme
;used in SLaTeX.
;(c) Dorai Sitaram, Nov. 1992
#+gcl
(make-package :slatex)
#-gcl
(defpackage slatex
(:use cl))
;print lower-case
(setq *print-case* :downcase)
;defmacro-slatex
(defmacro defmacro-slatex (m vv &rest ee)
`(progn
(setf (get nil ',m) ',m)
(setf (get ',m 'defmacro-slatex)
#'(lambda ,vv ,@ee))))
(defun slatex-macro-p (s)
(and (symbolp s) (get s 'defmacro-slatex)))
(defun expand-macrocalls (e)
(if (not (consp e)) e
(let* ((a (car e)) (xfmr (slatex-macro-p a)))
(if xfmr
(expand-macrocalls (apply xfmr (cdr e)))
(case a
((quote) e)
((lambda)
`(lambda ,(cadr e)
,@(mapcar #'expand-macrocalls (cddr e))))
((case)
`(case ,(expand-macrocalls (cadr e))
,@(mapcar #'(lambda (clause)
`(,(car clause)
,@(mapcar #'expand-macrocalls (cdr clause))))
(cddr e))))
(t (mapcar #'expand-macrocalls e)))))))
;some macros
;package
(defvar *alias-alist* '())
(defun make-slatex-alias (zz)
(loop
(when (null zz) (return))
(push (cons (car zz) (cadr zz)) *alias-alist*)
(setq zz (cddr zz))))
(load "aliases.scm")
(defmacro-slatex eval-within (p &rest ee)
(let ((ee (nsublis *alias-alist* ee)))
(case (length ee)
((0) nil)
((1) (car ee))
(t (cons 'progn ee)))))
(defmacro-slatex slatex::%lambda (parms &rest body)
`(function
(lambda ,(dot-to-and-rest parms) ; cl::lambda
,@body)))
(defun dot-to-and-rest (vv)
;Change the . z format of Scheme lambdalists to
;CL's &rest z format
(cond ((null vv) nil)
((symbolp vv) `(&rest ,vv))
(t (let* ((last-vv (last vv))
(cdr-last-vv (cdr last-vv)))
(if cdr-last-vv
(progn
(setf (cdr last-vv) `(&rest ,cdr-last-vv))
vv)
vv)))))
(defmacro-slatex define (x e)
(unless (and x (symbolp x) (consp e))
(error "define ~s ~s" x e))
(let ((a (car e)))
(case a
((slatex::%let let*)
`(,a ,(cadr e)
(define ,x ,(caddr e))))
((slatex::%lambda)
`(defun ,x ,(dot-to-and-rest (cadr e))
,@(cddr e)))
(t (error "define ~s ~s" x e)))))
(defmacro-slatex slatex::%let (n &rest ee)
;Named let with name containing the string "loop"
;is considered to be iterative and is transformed
;into CL loop.
(if (and n (symbolp n))
(let ((tail-recursive-p
(search "LOOP" (symbol-name n))))
(if (and tail-recursive-p (eq n 'loop))
(setf n '%%%loop%%%
ee (nsublis `((loop . ,n)) ee)))
`(,(if tail-recursive-p 'named-let-tail-recursive
'named-let-non-tail-recursive) ,n ,@ee))
`(let ,n ,@ee))) ; cl::let?
(defmacro-slatex named-let-non-tail-recursive (n xvxv &rest ee)
`(labels ((,n ,(mapcar 'car xvxv) ,@ee))
(,n ,@(mapcar 'cadr xvxv))))
(defmacro-slatex named-let-tail-recursive (n xvxv &rest ee)
(let ((xx (mapcar 'car xvxv)))
`(let ,xvxv
(flet ((,n ,xx
(throw ',n (values ,@xx))))
(loop
(multiple-value-setq ,xx
(let ,(mapcar #'(lambda (x) `(,x ,x)) xx)
(catch ',n
(return ,(if (= (length ee) 1) (car ee)
(cons 'progn ee)))))))))))
(defmacro-slatex defenum (&rest z)
(do ((z z (cdr z))
(n 0 (1+ n))
(r '() (cons `(defvar ,(car z) (code-char ,n)) r)))
((null z) `(progn ,@r))))
(defmacro-slatex defrecord (name &rest fields)
(do ((fields fields (cdr fields))
(i 0 (1+ i))
(r '() (cons `(defvar ,(car fields) ,i) r)))
((null fields)
`(progn
(defun ,name () (make-array ,i))
,@r))))
(defmacro-slatex of (r i &rest z)
(cond ((null z) `(elt ,r ,i))
((and (eq i '/) (= (length z) 1))
`(char ,r ,(car z)))
(t `(of (elt ,r ,i) ,@z))))
(defmacro-slatex eval-if (dialects &rest body)
(if (member 'cl dialects)
(if (= (length body) 1) (car body)
`(progn ,@body))))
(defmacro-slatex eval-unless (dialects &rest body)
(if (not (member 'cl dialects))
(if (= (length body) 1) (car body)
`(progn ,@body))))

247
collects/slatex/slatex-code/preproc.scm
View File

@ -1,247 +0,0 @@
;preproc.scm
;Macro preprocessor for SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994
;property lists
(define preproc:*properties* '())
(define preproc:get
(lambda (sym prop . default)
(let ((sym-props (assoc sym preproc:*properties*)))
(cond (sym-props
(let ((prop-val (assoc prop (cdr sym-props))))
(cond (prop-val (cdr prop-val))
((pair? default) (car default))
(else #f))))
((pair? default) (car default))
(else #f)))))
(define preproc:put
(lambda (sym prop val)
(let ((sym-props (assoc sym preproc:*properties*)))
(if sym-props
(let* ((props (cdr sym-props))
(prop-val (assoc prop props)))
(if prop-val
(set-cdr! prop-val val)
(set-cdr! sym-props
(cons (cons prop val) props))))
(set! preproc:*properties*
(cons (cons sym (list (cons prop val)))
preproc:*properties*))))))
;define-macro
(define defmacro-preproc
(lambda (kw xfmr)
(preproc:put #f kw kw)
(preproc:put kw 'defmacro-preproc xfmr)))
(define preproc:macro?
(lambda (s)
(and (symbol? s)
(preproc:get s 'defmacro-preproc))))
(define expand-macrocalls
(lambda (e)
(if (not (pair? e)) e
(let* ((a (car e)) (xfmr (preproc:macro? a)))
(if xfmr
(expand-macrocalls (apply xfmr (cdr e)))
(case a
;;something that looks like a macro call
;;within quote shouldn't be expanded
((quote) e)
;;lambda-arg can contain dotted list -- so
;;we avoid letting else-clause map across it
((lambda)
`(lambda ,(cadr e)
,@(map expand-macrocalls (cddr e))))
;;case-tags can look like macro calls -- these
;;shouldn't be expanded
((case)
`(case ,(expand-macrocalls (cadr e))
,@(map (lambda (clause)
`(,(car clause)
,@(map expand-macrocalls (cdr clause))))
(cddr e))))
;;expand-macrocalls can be mapped across the rest --
;;it isn't likely that we can have an expression
;;that looks like a macro call but isn't
(else (map expand-macrocalls e))))))))
;some macros
;package
(define make-slatex-alias
(lambda (zz)
(if (not (null? zz))
(begin
(preproc:put 'slatex (car zz) (cadr zz))
(make-slatex-alias (cddr zz))))))
(load "aliases.scm")
(define preproc: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))))))))
(defmacro-preproc 'in-package
(lambda (p) #f))
(defmacro-preproc 'shadow
(lambda (xx) #f))
(define *current-package* #f)
(defmacro-preproc 'eval-within
(lambda (p . ee)
(let ((ee
(let insert-qualifieds ((e ee))
(cond ((pair? e)
(set-car! e (insert-qualifieds (car e)))
(set-cdr! e (insert-qualifieds (cdr e)))
e)
((symbol? e)
(%eval-within-get-qualified-symbol p e))
(else e)))))
(case (length ee)
((0) #f)
((1) (car ee))
(else (cons 'begin ee))))))
(define %eval-within-get-qualified-symbol
(lambda (curr-p px)
(let* ((px-s (symbol->string px))
(i (%eval-within-dblcolon-index px-s)))
(cond (i (let ((p (string->symbol (substring px-s 0 i)))
(x (string->symbol (substring px-s (+ i 2)
(string-length px-s)))))
(if (eq? p curr-p) (preproc:put p x px))
px))
(else (cond ((preproc:get curr-p px))
((preproc:get #f px))
(else px)))))))
(define %eval-within-dblcolon-index
(lambda (s)
(let ((i (preproc:string-index s #\:)))
(if (or (not i)
(= i (- (string-length s) 1))) #f
(let ((i+1 (+ i 1)))
(if (char=? (string-ref s i+1) #\:)
i #f))))))
;defvar
(defmacro-preproc 'defvar
(lambda (x e)
`(define ,x ,e)))
;fluid-let
(define gentemp
(let ((n -1))
(lambda ()
;;generates an allegedly new symbol. This is a
;;gross hack since there is no standardized way
;;of getting uninterned symbols
(set! n (+ n 1))
(string->symbol (string-append "%:g" (number->string n) "%")))))
(defmacro-preproc 'fluid-let
(lambda (let-pairs . body)
(let ((x-s (map car let-pairs))
(i-s (map cadr let-pairs))
(old-x-s (map (lambda (p) (gentemp)) let-pairs)))
`(let ,(map (lambda (old-x x) `(,old-x ,x)) old-x-s x-s)
,@(map (lambda (x i) `(set! ,x ,i)) x-s i-s)
(let ((%temp% (begin ,@body)))
,@(map (lambda (x old-x) `(set! ,x ,old-x)) x-s old-x-s)
%temp%)))))
;defenum
(defmacro-preproc 'defenum
(lambda z
(let loop ((z z) (n 0) (r '()))
(if (null? z) `(begin ,@r)
(loop (cdr z) (+ n 1)
(cons `(define ,(car z) (integer->char ,n)) r))))))
;defrecord
(defmacro-preproc 'defrecord
(lambda (name . fields)
(let loop ((fields fields) (i 0) (r '()))
(if (null? fields)
`(begin (define ,name (lambda () (make-vector ,i)))
,@r)
(loop (cdr fields) (+ i 1)
(cons `(define ,(car fields) ,i) r))))))
;of
(defmacro-preproc 'of
(lambda (r i . z)
(cond ((null? z) `(vector-ref ,r ,i))
((and (eq? i '/) (= (length z) 1))
`(string-ref ,r ,(car z)))
(else `(of (vector-ref ,r ,i) ,@z)))))
;setf
(defmacro-preproc 'setf
(lambda (l r)
(if (symbol? l) `(set! ,l ,r)
(let ((a (car l)))
(if (eq? a 'list-ref)
`(set-car! (list-tail ,@(cdr l)) ,r)
`(,(cond ((eq? a 'list-ref) 'list-set!)
((eq? a 'string-ref) 'string-set!)
((eq? a 'vector-ref) 'vector-set!)
((eq? a 'of) 'the-setter-for-of)
(else
(error "(setf ~s ~s) is ill-formed." l r)))
,@(cdr l) ,r))))))
;the-setter-for-of
(defmacro-preproc 'the-setter-for-of
(lambda (r i j . z)
(cond ((null? z) `(vector-set! ,r ,i ,j))
((and (eq? i '/) (= (length z) 1))
`(string-set! ,r ,j ,(car z)))
(else `(the-setter-for-of (vector-ref ,r ,i) ,j ,@z)))))
;eval-{if,unless}
(defmacro-preproc 'eval-if
(lambda (dialects . body)
(if (memq dialect dialects)
(if (= (length body) 1) (car body)
`(begin ,@body))
`#f)))
(defmacro-preproc 'eval-unless
(lambda (dialects . body)
(if (not (memq dialect dialects))
(if (= (length body) 1) (car body)
`(begin ,@body))
`#f)))
;func{tion, all}
(defmacro-preproc 'function
(lambda (x)
`,x))
(defmacro-preproc 'funcall
(lambda (f . args)
`(,f ,@args)))

245
collects/slatex/slatex-code/proctex.scm
View File

@ -1,245 +0,0 @@
;proctex.scm
;SLaTeX v. 2.4
;Implements SLaTeX's piggyback to LaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1999
(eval-if (cl)
(eval-within slatex
(defun ignore2 (i ii)
(declare (ignore i ii))
(values))))
(eval-unless (cl)
(eval-within slatex
(define slatex::ignore2
(lambda (i ii)
;ignores its two arguments
'void))))
(eval-within slatex
(defvar slatex::version-number "2.4w")
(define slatex::disable-slatex-temply
(lambda (in)
;tell slatex that it should not process slatex commands till
;the enabling control sequence is called
(set! *slatex-enabled?* #f)
(set! *slatex-reenabler* (read-grouped-latexexp in))))
(define slatex::enable-slatex-again
(lambda ()
;tell slatex to resume processing slatex commands
(set! *slatex-enabled?* #t)
(set! *slatex-reenabler* "UNDEFINED")))
(define slatex::add-to-slatex-db
(lambda (in categ)
;some scheme identifiers to be added to the token category categ
(if (memq categ '(keyword constant variable))
(slatex::add-to-slatex-db-basic in categ)
(slatex::add-to-slatex-db-special in categ))))
(define slatex::add-to-slatex-db-basic
(lambda (in categ)
;read the following scheme identifiers and add them to the
;token category categ
(let ((setter (cond ((eq? categ 'keyword) (function set-keyword))
((eq? categ 'constant) (function set-constant))
((eq? categ 'variable) (function set-variable))
(else (error "add-to-slatex-db-basic: ~
Unknown category ~s." categ))))
(ids (read-grouped-schemeids in)))
(for-each setter ids))))
(define slatex::add-to-slatex-db-special
(lambda (in what)
;read the following scheme identifier(s) and either
;enable/disable its special-symbol status
(let ((ids (read-grouped-schemeids in)))
(cond ((eq? what 'unsetspecialsymbol)
(for-each (function unset-special-symbol) ids))
((eq? what 'setspecialsymbol)
(if (not (= (length ids) 1))
(error "add-to-slatex-db-special: ~
\\setspecialsymbol takes one arg exactly."))
(let ((transl (read-grouped-latexexp in)))
(set-special-symbol (car ids) transl)))
(else (error "add-to-slatex-db-special: ~
Unknown command ~s." what))))))
(define slatex::process-slatex-alias
(lambda (in what which)
;add/remove a slatex control sequence name
(let ((triggerer (read-grouped-latexexp in)))
(case which
((intext)
(set! *intext-triggerers*
(funcall what triggerer *intext-triggerers*
(function string=?))))
((resultintext)
(set! *resultintext-triggerers*
(funcall what triggerer *resultintext-triggerers*
(function string=?))))
((display)
(set! *display-triggerers*
(funcall what triggerer *display-triggerers*
(function string=?))))
((response)
(set! *response-triggerers*
(funcall what triggerer *response-triggerers*
(function string=?))))
((respbox)
(set! *respbox-triggerers*
(funcall what triggerer *respbox-triggerers*
(function string=?))))
((box)
(set! *box-triggerers*
(funcall what triggerer *box-triggerers*
(function string=?))))
((input)
(set! *input-triggerers*
(funcall what triggerer *input-triggerers*
(function string=?))))
((region)
(set! *region-triggerers*
(funcall what triggerer *region-triggerers*
(function string=?))))
((mathescape)
(if (not (= (string-length triggerer) 1))
(error "process-slatex-alias: ~
Math escape should be character."))
(set! *math-triggerers*
(funcall what (string-ref triggerer 0)
*math-triggerers* (function char=?))))
(else (error "process-slatex-alias:
Unknown command ~s." which))))))
(define slatex::decide-latex-or-tex
(lambda (latex?)
;create a junk file if the file is in plain tex rather
;than latex; this is used afterward to call the right
;command, i.e., latex or tex
(set! *latex?* latex?)
(let ((pltexchk.jnk "pltexchk.jnk"))
(if (file-exists? pltexchk.jnk) (delete-file pltexchk.jnk))
(if (not *latex?*)
(call-with-output-file pltexchk.jnk
(lambda (outp)
(display 'junk outp)
(newline outp)))))))
(define slatex::process-include-only
(lambda (in)
;remember the files mentioned by \includeonly
(set! *include-onlys* '())
(for-each
(lambda (filename)
(let ((filename (full-texfile-name filename)))
(if filename
(set! *include-onlys*
(adjoin filename *include-onlys*
(function string=?))))))
(read-grouped-commaed-filenames in))))
(define slatex::process-documentstyle
(lambda (in)
;process the .sty files corresponding to the documentstyle options
(eat-tex-whitespace in)
(if (char=? (peek-char in) #\[)
(for-each
(lambda (filename)
(fluid-let ((*slatex-in-protected-region?* #f))
(slatex::process-tex-file
(string-append filename ".sty"))))
(read-bktd-commaed-filenames in)))))
(define slatex::process-documentclass
(lambda (in)
(eat-bktd-text in)
(eat-grouped-text in)))
(define slatex::process-case-info
(lambda (in)
;find out and tell slatex if the scheme tokens that differ
;only by case should be treated identical or not
(let ((bool (read-grouped-latexexp in)))
(set! *slatex-case-sensitive?*
(cond ((string-ci=? bool "true") #t)
((string-ci=? bool "false") #f)
(else (error "process-case-info: ~
\\schemecasesensitive's arg should be true or false.")))))))
(defvar slatex::seen-first-command? #f)
(define slatex::process-main-tex-file
(lambda (filename)
;kick off slatex on the main .tex file filename
(display "SLaTeX v. ")
(display version-number)
(newline)
(set! primary-aux-file-count -1)
(set! *slatex-separate-includes?* #f)
(if (or (not *texinputs-list*) (null? *texinputs-list*))
(set! *texinputs-list*
(if *texinputs* (path-to-list *texinputs*)
'(""))))
(let ((file-hide-file "xZfilhid.tex"))
(if (file-exists? file-hide-file) (delete-file file-hide-file))
(if (memq *op-sys* '(dos os2fat))
(call-with-output-file file-hide-file
(lambda (out)
(display "\\def\\filehider{x}" out)
(newline out))
'text)))
(display "typesetting code")
(set! *tex-calling-directory* (directory-namestring filename))
(set! subjobname (basename filename))
(set! seen-first-command? #f)
(process-tex-file filename)
(display "done")
(newline)))
(define slatex::dump-intext
(lambda (in out)
(let* ((write-char (if out (function write-char) (function ignore2)))
(delim-char (begin (eat-whitespace in) (read-char in)))
(delim-char
(cond ((char=? delim-char #\{) #\})
(else delim-char))))
(if (eof-object? delim-char)
(error "dump-intext: Expected delimiting character ~
but found eof."))
(let loop ()
(let ((c (read-char in)))
(if (eof-object? c)
(error "dump-intext: Found eof inside Scheme code."))
(if (char=? c delim-char) 'done
(begin (funcall write-char c out) (loop))))))))
(define slatex::dump-display
(lambda (in out ender)
(eat-tabspace in)
(let ((write-char (if out (function write-char) (function ignore2)))
(ender-lh (string-length ender)) (c (peek-char in)))
(if (eof-object? c)
(error "dump-display: Found eof inside displayed code."))
(if (char=? c #\newline) (read-char in))
(let loop ((i 0))
(if (= i ender-lh) 'done
(let ((c (read-char in)))
(if (eof-object? c)
(error "dump-display: Found eof inside displayed code."))
(if (char=? c (string-ref ender i))
(loop (+ i 1))
(let loop2 ((j 0))
(if (< j i)
(begin
(funcall write-char (string-ref ender j) out)
(loop2 (+ j 1)))
(begin
(funcall write-char c out)
(loop 0)))))))))))
;continued on proctex2.scm
)

451
collects/slatex/slatex-code/proctex2.scm
View File

@ -1,451 +0,0 @@
;proctex2.scm
;SLaTeX v. 2.4
;Implements SLaTeX's piggyback to LaTeX
;...continued from proctex.scm
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-within slatex
(defvar slatex::debug? #f)
(define slatex::process-tex-file
(lambda (raw-filename)
;call slatex on the .tex file raw-filename
(if debug?
(begin (display "begin ")
(display raw-filename)
(newline)))
(let ((filename (full-texfile-name raw-filename)))
(if (not filename) ;didn't find it
(begin (display "[")
(display raw-filename)
(display "]") (force-output))
(call-with-input-file filename
(lambda (in)
(let ((done? #f))
(let loop ()
(if done? 'exit-loop
(begin
(let ((c (read-char in)))
(cond
((eof-object? c) (set! done? #t))
((char=? c #\%) (eat-till-newline in))
((char=? c #\\)
(let ((cs (read-ctrl-seq in)))
(if (not seen-first-command?)
(begin
(set! seen-first-command? #t)
(decide-latex-or-tex
(or
(string=? cs "documentstyle")
(string=? cs "documentclass")
(string=? cs "NeedsTeXFormat")
))))
(cond
((not *slatex-enabled?*)
(if (string=? cs *slatex-reenabler*)
(enable-slatex-again)))
((string=? cs "slatexignorecurrentfile")
(set! done? #t))
((string=? cs "slatexseparateincludes")
(if *latex?*
(set! *slatex-separate-includes?* #t)))
((string=? cs "slatexdisable")
(disable-slatex-temply in))
((string=? cs "begin")
(eat-tex-whitespace in)
(if (eqv? (peek-char in) #\{)
(let ((cs (read-grouped-latexexp in)))
(cond
((member cs *display-triggerers*)
(slatex::trigger-scheme2tex
'envdisplay in cs))
((member cs *response-triggerers*)
(trigger-scheme2tex 'envresponse
in cs))
((member cs *respbox-triggerers*)
(trigger-scheme2tex 'envrespbox
in cs))
((member cs *box-triggerers*)
(trigger-scheme2tex 'envbox
in cs))
((member cs *top-box-triggerers*)
(trigger-scheme2tex 'envtopbox
in cs))
((member cs *region-triggerers*)
(slatex::trigger-region
'envregion in cs))))))
((member cs *intext-triggerers*)
(trigger-scheme2tex 'intext in #f))
((member cs *resultintext-triggerers*)
(trigger-scheme2tex 'resultintext in #f))
((member cs *display-triggerers*)
(trigger-scheme2tex 'plaindisplay
in cs))
((member cs *response-triggerers*)
(trigger-scheme2tex 'plainresponse
in cs))
((member cs *respbox-triggerers*)
(trigger-scheme2tex 'plainrespbox
in cs))
((member cs *box-triggerers*)
(trigger-scheme2tex 'plainbox
in cs))
((member cs *region-triggerers*)
(trigger-region 'plainregion
in cs))
((member cs *input-triggerers*)
(slatex::process-scheme-file
(read-filename in)))
((string=? cs "input")
(let ((f (read-filename in)))
(if (not (string=? f ""))
(fluid-let
((*slatex-in-protected-region?*
#f))
(process-tex-file f)))))
((string=? cs "usepackage")
(fluid-let ((*slatex-in-protected-region?*
#f))
(process-tex-file
(string-append (read-filename in)
".sty"))))
((string=? cs "include")
(if *latex?*
(let ((f (full-texfile-name
(read-filename in))))
(if (and f
(or (eq? *include-onlys* 'all)
(member f
*include-onlys*)))
(fluid-let
((*slatex-in-protected-region?*
#f))
(if *slatex-separate-includes?*
(fluid-let
((subjobname
(basename f))
(primary-aux-file-count
-1))
(process-tex-file f))
(process-tex-file f)))))))
((string=? cs "includeonly")
(if *latex?* (process-include-only in)))
((string=? cs "documentstyle")
(if *latex?* (process-documentstyle in)))
((string=? cs "documentclass")
(if *latex?* (process-documentclass in)))
((string=? cs "schemecasesensitive")
(process-case-info in))
((string=? cs "defschemetoken")
(process-slatex-alias
in (function adjoin)
'intext))
((string=? cs "undefschemetoken")
(process-slatex-alias
in (function delete)
'intext))
((string=? cs "defschemeresulttoken")
(process-slatex-alias
in (function adjoin)
'resultintext))
((string=? cs "undefschemeresulttoken")
(process-slatex-alias
in (function delete)
'resultintext))
((string=? cs "defschemeresponsetoken")
(process-slatex-alias
in (function adjoin)
'response))
((string=? cs "undefschemeresponsetoken")
(process-slatex-alias
in (function delete)
'response))
((string=? cs "defschemeresponseboxtoken")
(process-slatex-alias
in (function adjoin)
'respbox))
((string=? cs "undefschemeresponseboxtoken")
(process-slatex-alias
in (function delete)
'respbox))
((string=? cs "defschemedisplaytoken")
(process-slatex-alias
in (function adjoin)
'display))
((string=? cs "undefschemedisplaytoken")
(process-slatex-alias
in (function delete)
'display))
((string=? cs "defschemeboxtoken")
(process-slatex-alias
in (function adjoin)
'box))
((string=? cs "undefschemeboxtoken")
(process-slatex-alias
in (function delete)
'box))
((string=? cs "defschemeinputtoken")
(process-slatex-alias
in (function adjoin)
'input))
((string=? cs "undefschemeinputtoken")
(process-slatex-alias
in (function delete)
'input))
((string=? cs "defschemeregiontoken")
(process-slatex-alias
in (function adjoin)
'region))
((string=? cs "undefschemeregiontoken")
(process-slatex-alias in
(function delete)
'region))
((string=? cs "defschememathescape")
(process-slatex-alias in
(function adjoin)
'mathescape))
((string=? cs "undefschememathescape")
(process-slatex-alias in
(function delete)
'mathescape))
((string=? cs "setkeyword")
(add-to-slatex-db in 'keyword))
((string=? cs "setconstant")
(add-to-slatex-db in 'constant))
((string=? cs "setvariable")
(add-to-slatex-db in 'variable))
((string=? cs "setspecialsymbol")
(add-to-slatex-db in 'setspecialsymbol))
((string=? cs "unsetspecialsymbol")
(add-to-slatex-db in 'unsetspecialsymbol))
)))))
(loop))))))
'text)))
(if debug?
(begin (display "end ")
(display raw-filename)
(newline)))
))
(define slatex::process-scheme-file
(lambda (raw-filename)
;typeset the scheme file raw-filename so that it can
;be input as a .tex file
(let ((filename (full-scmfile-name raw-filename)))
(if (not filename)
(begin (display "process-scheme-file: ")
(display raw-filename)
(display " doesn't exist")
(newline))
(let ((aux.tex (new-aux-file ".tex")))
(display ".") (force-output)
(if (file-exists? aux.tex) (delete-file aux.tex))
(call-with-input-file filename
(lambda (in)
(call-with-output-file aux.tex
(lambda (out)
(fluid-let ((*intext?* #f)
(*code-env-spec* "ZZZZschemedisplay"))
(scheme2tex in out)))
'text))
'text)
(if *slatex-in-protected-region?*
(set! *protected-files* (cons aux.tex *protected-files*)))
(process-tex-file filename))))))
(define slatex::trigger-scheme2tex
(lambda (typ in env)
;process the slatex command identified by typ;
;env is the name of the environment
(let* ((aux (new-aux-file)) (aux.scm (string-append aux ".scm"))
(aux.tex (string-append aux ".tex")))
(if (file-exists? aux.scm) (delete-file aux.scm))
(if (file-exists? aux.tex) (delete-file aux.tex))
(display ".") (force-output)
(call-with-output-file aux.scm
(lambda (out)
(cond ((memq typ '(intext resultintext)) (dump-intext in out))
((memq typ '(envdisplay envresponse envrespbox envbox envtopbox))
(dump-display in out (string-append "\\end{" env "}")))
((memq typ '(plaindisplay plainresponse
plainrespbox plainbox))
(dump-display in out (string-append "\\end" env)))
(else (error "trigger-scheme2tex: ~
Unknown triggerer ~s." typ))))
'text)
(call-with-input-file aux.scm
(lambda (in)
(call-with-output-file aux.tex
(lambda (out)
(fluid-let
((*intext?* (memq typ '(intext resultintext)))
(*code-env-spec*
(cond ((eq? typ 'intext) "ZZZZschemecodeintext")
((eq? typ 'resultintext)
"ZZZZschemeresultintext")
((memq typ '(envdisplay plaindisplay))
"ZZZZschemedisplay")
((memq typ '(envresponse plainresponse))
"ZZZZschemeresponse")
((memq typ '(envrespbox plainrespbox))
"ZZZZschemeresponsebox")
((memq typ '(envbox plainbox))
"ZZZZschemebox")
((memq typ '(envtopbox))
"ZZZZschemetopbox")
(else (error "trigger-scheme2tex: ~
Unknown triggerer ~s." typ)))))
(scheme2tex in out)))
'text))
'text)
(if *slatex-in-protected-region?*
(set! *protected-files* (cons aux.tex *protected-files*)))
(if (memq typ '(envdisplay plaindisplay envbox plainbox envtopbox))
(process-tex-file aux.tex))
(delete-file aux.scm)
)))
(define slatex::trigger-region
(lambda (typ in env)
;process a scheme region to create a in-lined file with
;slatex output
(let ((aux.tex (new-primary-aux-file ".tex"))
(aux2.tex (new-secondary-aux-file ".tex")))
(if (file-exists? aux2.tex) (delete-file aux2.tex))
(if (file-exists? aux.tex) (delete-file aux.tex))
(display ".") (force-output)
(fluid-let ((*slatex-in-protected-region?* #t)
(*protected-files* '()))
(call-with-output-file aux2.tex
(lambda (out)
(cond ((eq? typ 'envregion)
(dump-display in out (string-append "\\end{" env "}")))
((eq? typ 'plainregion)
(dump-display in out (string-append "\\end" env)))
(else (error "trigger-region: ~
Unknown triggerer ~s." typ))))
'text)
(process-tex-file aux2.tex)
(set! *protected-files* (reverse! *protected-files*))
(call-with-input-file aux2.tex
(lambda (in)
(call-with-output-file aux.tex
(lambda (out)
(slatex::inline-protected-files in out))
'text))
'text)
(delete-file aux2.tex)
))))
(define slatex::inline-protected-files
(lambda (in out)
;inline all the protected files in port in into port out
(let ((done? #f))
(let loop ()
(if done? 'exit-loop
(begin
(let ((c (read-char in)))
(cond ((eof-object? c)
;(display "{}" out)
(set! done? #t))
((or (char=? c *return*) (char=? c #\newline))
(let ((c2 (peek-char in)))
(if (not (eof-object? c2))
(write-char c out))))
((char=? c #\%)
(write-char c out) (newline out)
(eat-till-newline in))
((char=? c #\\)
(let ((cs (read-ctrl-seq in)))
(cond
((string=? cs "begin")
(let ((cs (read-grouped-latexexp in)))
(cond ((member cs *display-triggerers*)
(slatex::inline-protected
'envdisplay in out cs))
((member cs *response-triggerers*)
(inline-protected
'envresponse in out cs))
((member cs *respbox-triggerers*)
(inline-protected
'envrespbox in out cs))
((member cs *box-triggerers*)
(inline-protected 'envbox in out cs))
((member cs *top-box-triggerers*)
(inline-protected 'envtopbox in out cs))
((member cs *region-triggerers*)
(inline-protected
'envregion in out cs))
(else
(display "\\begin{" out)
(display cs out)
(display "}" out)))))
((member cs *intext-triggerers*)
(inline-protected 'intext in out #f))
((member cs *resultintext-triggerers*)
(inline-protected 'resultintext in out #f))
((member cs *display-triggerers*)
(inline-protected 'plaindisplay in out cs))
((member cs *response-triggerers*)
(inline-protected 'plainresponse in out cs))
((member cs *respbox-triggerers*)
(inline-protected 'plainrespbox in out cs))
((member cs *box-triggerers*)
(inline-protected 'plainbox in out cs))
((member cs *region-triggerers*)
(inline-protected 'plainregion in out cs))
((member cs *input-triggerers*)
(inline-protected 'input in out cs))
(else
(display "\\" out)
(display cs out)))))
(else (write-char c out))))
(loop)))))))
(define slatex::inline-protected
(lambda (typ in out env)
(cond ((eq? typ 'envregion)
(display "\\begin{" out)
(display env out)
(display "}" out)
(dump-display in out (string-append "\\end{" env "}"))
(display "\\end{" out)
(display env out)
(display "}" out))
((eq? typ 'plainregion)
(display "\\" out)
(display env out)
(dump-display in out (string-append "\\end" env))
(display "\\end" out)
(display env out))
(else (let ((f (car *protected-files*)))
(set! *protected-files* (cdr *protected-files*))
(call-with-input-file f
(lambda (in)
(inline-protected-files in out))
'text)
(delete-file f)
)
(cond ((memq typ '(intext resultintext))
(display "{}" out)
(dump-intext in #f))
((memq typ '(envrespbox envbox envtopbox))
(if (not *latex?*)
(display "{}" out))
(dump-display in #f
(string-append "\\end{" env "}")))
((memq typ '(plainrespbox plainbox))
(display "{}" out)
(dump-display in #f
(string-append "\\end" env)))
((memq typ '(envdisplay envresponse))
(dump-display in #f
(string-append "\\end{" env "}")))
((memq typ '(plaindisplay plainresponse))
(dump-display in #f (string-append "\\end" env)))
((eq? typ 'input)
(read-filename in)) ;and throw it away
(else (error "inline-protected: ~
Unknown triggerer ~s." typ)))))))
)

102
collects/slatex/slatex-code/s4.scm
View File

@ -1,102 +0,0 @@
;s4.scm
;SLaTeX v. 2.3
;Making dialect meet R5RS spec
;(includes optimizing for Chez 4.0a+)
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-if (chez)
(eval-when (compile load eval)
(if (not (bound? 'optimize-level)) ;do only for old Chezs
(let ((cwif call-with-input-file)
(cwof call-with-output-file))
(set! call-with-input-file
(lambda (f p)
(cwif f (lambda (pt)
(p pt)
(close-input-port pt)))))
(set! call-with-output-file
(lambda (f p)
(cwof f (lambda (pt)
(p pt)
(close-output-port pt)))))))))
(eval-if (chez)
(if (bound? 'optimize-level) (optimize-level 3)))
(eval-if (cl)
(eval-within slatex
(defun member (x s)
(declare (list s))
(global-member x s :test (function equal)))
(defun assoc (x s)
(declare (list s))
(global-assoc x s :test (function equal)))
(defun number->string (n &optional (b 10))
(declare (number n))
(write-to-string n :base b))
(defun string->number (s &optional (b 10))
(declare (global-string s))
(let ((*read-base* b))
(let ((n (read-from-string s)))
(if (numberp n) n nil))))
(defun char-whitespace? (c)
(declare (character c))
(or (char= c #\space) (char= c #\tab)
(not (graphic-char-p c))))
(defun make-string (n &optional (c #\space))
(declare (number n))
(global-make-string n :initial-element c))
(defun string (&rest z)
(concatenate 'global-string z))
(defun string-append (&rest z)
(apply (function concatenate) 'global-string z))
(defun string->list (s)
(declare (global-string s))
(concatenate 'list s))
(defun list->string (l)
(declare (list l))
(concatenate 'global-string l))
(defun make-vector (n &optional x)
(declare (number n))
(make-array (list n) :initial-element x))
(defun vector->list (v)
(declare (vector v))
(concatenate 'vector v))
(defun list->vector (l)
(declare (list l))
(concatenate 'vector l))
(defun call-with-input-file (f p)
(with-open-file (i f :direction :input)
(funcall p i)))
(defun call-with-output-file (f p)
(with-open-file (o f :direction :output)
(funcall p o)))
(defun read (&optional p)
(global-read p nil :eof-object))
(defun read-char (&optional p)
(global-read-char p nil :eof-object))
(defun peek-char (&optional p)
(global-peek-char nil p nil :eof-object))
(defun eof-object? (v)
(eq v :eof-object))
))

193
collects/slatex/slatex-code/seqprocs.scm
View File

@ -1,193 +0,0 @@
;seqprocs.scm
;SLaTeX v. 2.3
;Sequence routines
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-if (cscheme)
(eval-within slatex
(define slatex::some
(lambda (f l) (there-exists? l f)))))
(eval-unless (chez cl cscheme mzscheme)
(eval-within slatex
(define slatex::some
(lambda (f l)
;returns nonfalse iff f is true of at least one element in l;
;this nonfalse value is that given by the first such element in l;
;only one argument list supported
(let loop ((l l))
(if (null? l) #f
(or (f (car l)) (loop (cdr l)))))))))
(eval-within slatex
(define slatex::ormapcdr
(lambda (f l)
;apply f to successive cdrs of l, returning
;immediately when an application is true.
;only one argument list supported
(let loop ((l l))
(if (null? l) #f
(or (funcall f l) (loop (cdr l)))))))
(define slatex::list-prefix?
(lambda (pfx l)
;tests if list pfx is a prefix of list l
(cond ((null? pfx) #t)
((null? l) #f)
((eqv? (car pfx) (car l)) (list-prefix? (cdr pfx) (cdr l)))
(else #f))))
(define slatex::string-suffix?
(lambda (sfx s)
;tests if string sfx is a suffix of string s
(let ((sfx-len (string-length sfx)) (s-len (string-length s)))
(if (> sfx-len s-len) #f
(let loop ((i (- sfx-len 1)) (j (- s-len 1)))
(if (< i 0) #t
(and (char=? (string-ref sfx i) (string-ref s j))
(loop (- i 1) (- j 1)))))))))
)
(eval-unless (bigloo chez cl cscheme elk guile mzscheme pcsge stk scm)
(eval-within slatex
(define slatex::append!
(lambda (l1 l2)
;destructively appends lists l1 and l2;
;only two argument lists supported
(cond ((null? l1) l2)
((null? l2) l1)
(else (let loop ((l1 l1))
(if (null? (cdr l1))
(set-cdr! l1 l2)
(loop (cdr l1))))
l1))))))
(eval-unless (cl cscheme)
(eval-within slatex
(define slatex::mapcan
(lambda (f l)
;maps f on l but splices (destructively) the results;
;only one argument list supported
(let loop ((l l))
(if (null? l) '()
(append! (f (car l)) (loop (cdr l)))))))))
(eval-unless (bigloo chez cl cscheme elk mzscheme pcsge)
(eval-within slatex
(define slatex::reverse!
(lambda (s)
;reverses list s inplace (i.e., destructively)
(let loop ((s s) (r '()))
(if (null? s) r
(let ((d (cdr s)))
(set-cdr! s r)
(loop d s))))))))
(eval-unless (cl)
(eval-within slatex
(define slatex::lassoc
(lambda (x al eq)
(let loop ((al al))
(if (null? al) #f
(let ((c (car al)))
(if (eq (car c) x) c
(loop (cdr al))))))))
(define slatex::lmember
(lambda (x l eq)
(let loop ((l l))
(if (null? l) #f
(if (eq (car l) x) l
(loop (cdr l)))))))
(define slatex::delete
(lambda (x l eq)
(let loop ((l l))
(cond ((null? l) l)
((eq (car l) x) (loop (cdr l)))
(else (set-cdr! l (loop (cdr l)))
l)))))
(define slatex::adjoin
(lambda (x l eq)
(if (lmember x l eq) l
(cons x l))))
(define slatex::delete-if
(lambda (p s)
(let loop ((s s))
(cond ((null? s) s)
((p (car s)) (loop (cdr s)))
(else (set-cdr! s (loop (cdr s)))
s)))))
(define slatex::string-prefix?
(lambda (s1 s2 i)
;Tests if s1 and s2 have the same first i chars.
;Both s1 and s2 must be at least i long.
(let loop ((j 0))
(if (= j i) #t
(and (char=? (string-ref s1 j) (string-ref s2 j))
(loop (+ j 1)))))))
(define slatex::sublist
(lambda (l i f)
;finds the sublist of l from index i inclusive to index f exclusive
(let loop ((l (list-tail l i)) (k i) (r '()))
(cond ((>= k f) (reverse! r))
((null? l)
(slatex::error "sublist: List too small."))
(else (loop (cdr l) (+ k 1) (cons (car l) r)))))))
(define slatex::position-char
(lambda (c l)
;finds the leftmost index of character-list l where character c occurs
(let loop ((l l) (i 0))
(cond ((null? l) #f)
((char=? (car l) c) i)
(else (loop (cdr l) (+ i 1)))))))
(define slatex::string-position-right
(lambda (c s)
;finds the rightmost index of string s where character c occurs
(let ((n (string-length s)))
(let loop ((i (- n 1)))
(cond ((< i 0) #f)
((char=? (string-ref s i) c) i)
(else (loop (- i 1))))))))
))
(eval-if (cl)
(eval-within slatex
(defun lassoc (x l eq)
(declare (list l))
(global-assoc x l :test eq))
(defun lmember (x l eq)
(declare (list l))
(global-member x l :test eq))
(defun delete (x l eq)
(declare (list l))
(global-delete x l :test eq))
(defun adjoin (x l eq)
(declare (list l))
(global-adjoin x l :test eq))
(defun string-prefix? (s1 s2 i)
(declare (global-string s1 s2) (integer i))
(string= s1 s2 :end1 i :end2 i))
(defun string-position-right (c s)
(declare (character c) (global-string s))
(position c s :test (function char=) :from-end t))
))

103
collects/slatex/slatex-code/slaconfg.lsp
View File

@ -1,103 +0,0 @@
;slaconfg.lsp
;Configures SLaTeX for Common Lisp on your system
;(c) Dorai Sitaram, Rice U., 1991, 1994
(set-dispatch-macro-character #\# #\T
#'(lambda (p ig ig2)
(declare (ignore ig ig2))
t))
(set-dispatch-macro-character #\# #\F
#'(lambda (p ig ig2)
(declare (ignore ig ig2))
nil))
(defvar *slatex-directory* (directory-namestring *load-pathname*))
(defvar dialect 'cl)
(defvar *op-sys*)
(with-open-file (inp (concatenate 'string
*slatex-directory*
"config.dat")
:direction :input)
(read inp) ;ignore dialect info
(setq *op-sys* (read inp)))
(if (not (member *op-sys* '(windows os2 unix dos os2fat mac-os)))
(setq *op-sys* 'other))
(load (merge-pathnames "preproc.lsp" *slatex-directory*))
(defvar list-of-slatex-files
(mapcar
#'(lambda (f)
(concatenate 'string *slatex-directory* f))
(list
"s4.scm"
"seqprocs.scm"
"fileproc.scm"
"lerror.scm"
"defaults.scm"
"structs.scm"
"helpers.scm"
"peephole.scm"
"codeset.scm"
"pathproc.scm"
"texread.scm"
"proctex.scm"
"proctex2.scm")))
(format t "~&Beginning configuring SLaTeX for Common Lisp on ~a -- ~
wait..." *op-sys*)
(defvar outfile (concatenate 'string *slatex-directory*
#+(or mcl clisp) "slatexsrc.scm"
#-(or mcl clisp) "slatex.scm"))
(if (probe-file outfile) (delete-file outfile))
(with-open-file (o outfile :direction :output)
(format o
";slatex.scm file generated for Common Lisp, ~a~%~
;(c) Dorai Sitaram, Rice U., 1991, 1994~%"
*op-sys*)
#-gcl
(print `(defpackage slatex (:use cl)) o)
(print `(in-package :slatex) o)
(print `(defvar *op-sys* ',*op-sys*) o)
(dolist (f list-of-slatex-files)
(format t "~&~a...~%" f)
(format o "~%~%;~a~%" f)
(with-open-file (i f :direction :input)
(loop
(let ((x (read i nil :eof)))
(if (eq x :eof) (return))
(let ((xm (expand-macrocalls x)))
(cond ((not xm) nil)
((and (consp xm) (eq (car xm) 'progn))
(dolist (y (cdr xm))
(if y (pprint y o))))
(t (pprint xm o)))))))))
#+(or mcl clisp)
(progn
(format t "~&Getting compiled version...~%")
(compile-file outfile :output-file
(concatenate 'string *slatex-directory*
"slatex.scm"))
(format t "~&Finished compilation~%"))
(format t
"~&Finished configuring SLaTeX for your machine.
Read install for details on
1. which paths to place the SLaTeX files in;
2. how to modify the given batch file or shell script
that invokes SLaTeX.~%~%")

155
collects/slatex/slatex-code/slaconfg.scm
View File

@ -1,155 +0,0 @@
;slaconfg.scm
;Configures SLaTeX for your Scheme
;(c) Dorai Sitaram, Rice U., 1991, 1994
(define dialect 'forward)
(define *op-sys* 'forward)
(call-with-input-file "config.dat"
(lambda (p)
(set! dialect (read p))
(set! *op-sys* (read p))))
(if (not (memq dialect
'(bigloo chez cscheme elk guile mzscheme pcsge schemetoc scm
stk umbscheme vscm other)))
(set! dialect 'other))
(if (not (memq *op-sys* '(windows os2 unix dos os2fat mac-os)))
(set! *op-sys* 'other))
(load "preproc.scm")
(define list-of-slatex-files
(list
"s4.scm"
"seqprocs.scm"
"fileproc.scm"
"lerror.scm"
"defaults.scm"
"structs.scm"
"helpers.scm"
"peephole.scm"
"codeset.scm"
"pathproc.scm"
"texread.scm"
"proctex.scm"
"proctex2.scm"))
(display "Beginning configuring SLaTeX for ")
(display dialect)
(display " on ")
(display *op-sys*)
(display " -- wait...")
(newline)
(define outfile
(if (memq dialect '(bigloo chez mzscheme)) "slatexsrc.scm" "slatex.scm"))
(cond ((memq dialect '(bigloo chez cscheme guile mzscheme pcsge scm))
(if (file-exists? outfile)
(delete-file outfile)))
(else
(newline)
(display "If configuring fails following this sentence, ")
(newline)
(display "you most likely already have a slatex.scm in the ")
(display "current directory.")
(newline)
(display "Delete it and retry.")
(newline)))
(define prettyp
;pretty-printer -- not really needed, so use write for dialects
;that don't have it
(case dialect
((bigloo) pp)
((chez) pretty-print)
; ((scm) (if (defined? pretty-print) pretty-print write))
(else write)))
(call-with-output-file outfile
(lambda (o)
;;begin banner
(display ";slatex.scm file generated for " o)
(display dialect o)
(display ", " o)
(display *op-sys* o)
(newline o)
(display ";(c) Dorai Sitaram, Rice U., 1991, 1994" o)
(newline o) (newline o)
;;end banner
;(if (eq? dialect 'bigloo)
;(write `(module slatex (main slatex::process-main-tex-file)) o))
(write `(define slatex::*op-sys* ',*op-sys*) o)
(newline o)
(for-each
(lambda (f)
(newline)
(display f) (display "...")
(newline o)
(display ";" o)
(display f o)
(newline o)
(newline o)
(call-with-input-file f
(lambda (i)
(let loop ()
(let ((x (read i)))
(if (not (eof-object? x))
(let ((xm (expand-macrocalls x)))
(cond ((not xm))
((and (pair? xm) (eq? (car xm) 'begin))
(for-each
(lambda (y)
(if y (begin (prettyp y o)
(newline o))))
(cdr xm)))
(else (prettyp xm o) (newline o)))
(loop))))))))
list-of-slatex-files)))
(if (eq? dialect 'mzscheme)
(require-library "compile.ss"))
(case dialect
((bigloo)
(newline)
;can't get bigloo to compile
;(display "Getting compiled version for Bigloo...")
(display "Couldn't get Bigloo to compile SLaTeX. Using source for now.")
(system "cp -p slatexsrc.scm slatex.scm")
(newline)
;(system "bigloo -O -v -o SLaTeX slatex.scm")
;(system "rm slatex.o")
;(display "Finished compilation (executable is named SLaTeX)")
;(newline)
)
((chez mzscheme)
(newline)
(display "Getting compiled version...")
(newline)
(compile-file "slatexsrc.scm" "slatex.scm")
;;(delete-file "slatexsrc.scm")
(display "Finished compilation")))
(newline)
(newline)
(display "Finished configuring the SLaTeX Scheme file for your machine")
(newline)
(display "Read \"install\" for details on")
(newline)
(newline)
(display "1. which paths to place the SLaTeX files in")
(newline)
(newline)
(display "2. how to use the batch file, shell script, or Scheme script")
(newline)
(display "that invokes SLaTeX")
(newline)
(newline)

569
collects/slatex/slatex-code/slatex.sty
View File

@ -1,569 +0,0 @@
% slatex.sty
% SLaTeX v. 2.4
% style file to be used in (La)TeX when using SLaTeX
% (c) Dorai Sitaram, Rice U., 1991, 1999
\def\slatexversion{2.4w}
% This file (or a soft link to it) should be in some
% directory in your TEXINPUTS path (i.e., the one
% (La)TeX scours for \input or \documentstyle option
% files).
% Do not attempt to debug this file, since the results
% are not transparent just to (La)TeX. The Scheme part
% of SLaTeX depends on information laid out here -- so
% (La)TeX-minded debugging of this file will almost
% inevitably sabotage SLaTeX.
% It's possible you don't find the default style set
% out here appealing: e.g., you may want to change the
% positioning of displayed code; change the fonts for
% keywords, constants, and variables; add new keywords,
% constants, and variables; use your names instead of
% the provided \scheme, [\begin|\end]{schemedisplay},
% [\begin|\end]{schemebox}, (or \[end]schemedisplay,
% \[end]schemebox for TeX), which might be seem too
% long or unmnemonic, and many other things. The clean
% way to do these things is outlined in the
% accompanying manual, slatxdoc.tex. This way is both
% easier than messing with this .sty file, and safer
% since you will not unwittingly break SLaTeX.
%%%
% to prevent loading slatex.sty more than once
\ifx\slatexignorecurrentfile\UNDEFINED
\else\endinput\fi
% use \slatexignorecurrentfile to disable slatex for
% the current file. (Unstrangely, the very definition
% disables slatex for the rest of _this_ file, slatex.sty.)
\def\slatexignorecurrentfile{}
% checking whether we're using LaTeX or TeX?
\newif\ifusinglatex
\ifx\newenvironment\UNDEFINED\usinglatexfalse\else\usinglatextrue\fi
% make @ a letter for TeX
\ifusinglatex\relax\else
\edef\atcatcodebeforeslatex{\the\catcode`\@ }
\catcode`\@11
\fi
% identification of TeX/LaTeX style for schemedisplay.
% Do \defslatexenvstyle{tex} to get TeX environment
% style in LaTeX
\def\defslatexenvstyle#1{\gdef\slatexenvstyle{#1}}
\ifusinglatex\defslatexenvstyle{latex}\else\defslatexenvstyle{tex}\fi
% TeX doesn't have sans-serif; use roman instead
\ifx\sf\UNDEFINED\let\sf\rm\fi
% tabbing from plain TeX
%
\newif\ifus@ \newif\if@cr
\newbox\tabs \newbox\tabsyet \newbox\tabsdone
%
\def\cleartabs{\global\setbox\tabsyet\null \setbox\tabs\null}
\def\settabs{\setbox\tabs\null \futurelet\next\sett@b}
\let\+=\relax % in case this file is being read in twice
\def\sett@b{\ifx\next\+\let\next\relax
\def\next{\afterassignment\s@tt@b\let\next}%
\else\let\next\s@tcols\fi\next}
\def\s@tt@b{\let\next\relax\us@false\m@ketabbox}
\def\tabalign{\us@true\m@ketabbox} % non-\outer version of \+
\outer\def\+{\tabalign}
\def\s@tcols#1\columns{\count@#1 \dimen@\hsize
\loop\ifnum\count@>\z@ \@nother \repeat}
\def\@nother{\dimen@ii\dimen@ \divide\dimen@ii\count@
\setbox\tabs\hbox{\hbox to\dimen@ii{}\unhbox\tabs}%
\advance\dimen@-\dimen@ii \advance\count@\m@ne}
%
\def\m@ketabbox{\begingroup
\global\setbox\tabsyet\copy\tabs
\global\setbox\tabsdone\null
\def\cr{\@crtrue\crcr\egroup\egroup
\ifus@\unvbox\z@\lastbox\fi\endgroup
\setbox\tabs\hbox{\unhbox\tabsyet\unhbox\tabsdone}}%
\setbox\z@\vbox\bgroup\@crfalse
\ialign\bgroup&\t@bbox##\t@bb@x\crcr}
%
\def\t@bbox{\setbox\z@\hbox\bgroup}
\def\t@bb@x{\if@cr\egroup % now \box\z@ holds the column
\else\hss\egroup \global\setbox\tabsyet\hbox{\unhbox\tabsyet
\global\setbox\@ne\lastbox}% now \box\@ne holds its size
\ifvoid\@ne\global\setbox\@ne\hbox to\wd\z@{}%
\else\setbox\z@\hbox to\wd\@ne{\unhbox\z@}\fi
\global\setbox\tabsdone\hbox{\box\@ne\unhbox\tabsdone}\fi
\box\z@}
% finished (re)defining TeX's tabbing macros
% above from plain.tex; was disabled in lplain.tex. Do
% not modify above unless you really know what you're
% up to. Make all changes you want to following code.
% The new env is preferable to LaTeX's tabbing env
% since latter accepts only a small number of tabs
% following retrieves something like LaTeX's tabbing
% env without the above problem (it also creates a box
% for easy manipulation!)
\def\lat@xtabbing{\begingroup
\def\={\cleartabs&} \def\>{&}%
\def\\{\cr\tabalign\lat@xtabbingleftmost}%
\tabalign\lat@xtabbingleftmost}
\def\endlat@xtabbing{\cr\endgroup}
\let\lat@xtabbingleftmost\relax
% stuff for formating Scheme code
\newskip\par@nlen \newskip\brack@tlen \newskip\quot@len
\newskip\h@lflambda
\newbox\garb@ge
\def\s@ttowidth#1#2{\setbox\garb@ge\hbox{#2}#1\wd\garb@ge\relax}
\s@ttowidth\par@nlen{$($} % size of paren
\s@ttowidth\brack@tlen{$[$} % size of bracket
\s@ttowidth\quot@len{'} % size of quote indentation
\s@ttowidth\h@lflambda{ii} % size of half of lambda indentation
\def\PRN{\hskip\par@nlen} % these are used by SLaTeX's codesetter
\def\BKT{\hskip\brack@tlen}
\def\QUO{\hskip\quot@len}
\def\HL{\hskip\h@lflambda}
\newskip\abovecodeskip \newskip\belowcodeskip
\newskip\leftcodeskip \newskip\rightcodeskip
% the following default assignments give a flushleft
% display
\abovecodeskip=\medskipamount \belowcodeskip=\medskipamount
\leftcodeskip=0pt \rightcodeskip=0pt
% adjust above,below,left,right codeskip's to personal
% taste
% for centered displays
%
% \leftcodeskip=0pt plus 1fil
% \rightcodeskip=0pt plus 1fil
%
% if \rightcodeskip != 0pt, pagebreaks within Scheme
% blocks in {schemedisplay} are disabled
\let\checkforfollpar1
\def\noindentifnofollpar{\ifx\checkforfollpar0\let\next\relax
\else\ifusinglatex\let\next\@endparenv
\else\let\next\noindentifnofollparI\fi\fi\next}
\def\noindentifnofollparI{\futurelet\next\noindentifnofollparII}
\def\noindentifnofollparII{\ifx\next\par\else\noindent\ignorespaces\fi}
% the following are the default font assignments for
% words in code. Change them to suit personal taste
\def\keywordfont#1{{\bf #1}}
\def\variablefont#1{{\it #1\/}}
\def\constantfont#1{{\sf #1}}
\def\datafont#1{\constantfont{#1}}
\let\schemecodehook\relax
\let\ZZZZschemecodehook\relax
%program listings that allow page breaks but
%can't be centered
\def\ZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
\edef\@tempa{\the\rightcodeskip}%
\ifx\@tempa\thez@skip\let\next\ZZZZschemeprogram
\else\let\next\ZZZZschemeprogramII\fi\next}
\def\endZZZZschemedisplay{\edef\thez@skip{\the\z@skip}%
\edef\@tempa{\the\rightcodeskip}%
\ifx\@tempa\thez@skip\let\next\endZZZZschemeprogram
\else\let\next\endZZZZschemeprogramII\fi\next}
\def\ZZZZschemeprogram{\vskip\abovecodeskip
\begingroup
\schemecodehook\ZZZZschemecodehook
\frenchspacing
\let\sy=\keywordfont \let\cn=\constantfont
\let\va=\variablefont \let\dt=\datafont
\def\lat@xtabbingleftmost{\hskip\leftskip\hskip\leftcodeskip\relax}%
\lat@xtabbing}
\def\endZZZZschemeprogram{\endlat@xtabbing
\endgroup
\vskip\belowcodeskip
\noindentifnofollpar}
\def\ZZZZschemeprogramII{\vskip\abovecodeskip
\begingroup
\noindent
%\ZZZZschemecodehook\schemecodehook %\ZZZZschemebox already has it
\hskip\leftcodeskip
\ZZZZschemebox}
\def\endZZZZschemeprogramII{\endZZZZschemebox
\hskip\rightcodeskip
\endgroup
\vskip\belowcodeskip
\noindentifnofollpar}
\def\ZZZZschemeresponse{\ZZZZschemecodehookforresult
\ZZZZschemedisplay}
\let\endZZZZschemeresponse\endZZZZschemedisplay
%
\def\ZZZZschemebox{%
\leavevmode\hbox\bgroup\vbox\bgroup
\schemecodehook\ZZZZschemecodehook
\frenchspacing
\let\sy=\keywordfont \let\cn=\constantfont
\let\va=\variablefont \let\dt=\datafont
\lat@xtabbing}
\def\endZZZZschemebox{\endlat@xtabbing
\egroup\egroup\ignorespaces}
\def\ZZZZschemeresponsebox{\ZZZZschemecodehookforresult
\ZZZZschemebox}
\let\endZZZZschemeresponsebox\endZZZZschemebox
% schemetopbox : added by robby/jbc 2000
\def\ZZZZschemetopbox{%
\leavevmode\hbox\bgroup\vtop\bgroup
\schemecodehook\ZZZZschemecodehook
\frenchspacing
\let\sy=\keywordfont \let\cn=\constantfont
\let\va=\variablefont \let\dt=\datafont
\lat@xtabbing}
\def\endZZZZschemetopbox{\endlat@xtabbing
\egroup\egroup\ignorespaces}
%in-text
\def\ZZZZschemecodeintext{\begingroup
\schemecodehook\ZZZZschemecodehook
\frenchspacing
\let\sy\keywordfont \let\cn\constantfont
\let\va\variablefont \let\dt\datafont}
\def\endZZZZschemecodeintext{\endgroup\ignorespaces}
\def\ZZZZschemeresultintext{\ZZZZschemecodehookforresult
\ZZZZschemecodeintext}
\let\endZZZZschemeresultintext\endZZZZschemecodeintext
%
\def\ZZZZschemecodehookforresult{%
\gdef\ZZZZschemecodehook{\let\keywordfont\constantfont
\let\variablefont\constantfont
\global\let\ZZZZschemecodehook\relax}}
% \comm@nt<some-char>...text...<same-char> comments out
% TeX source analogous to
% \verb<some-char>...text...<same-char>. Sp. case:
% \comm@nt{...text...} == \comm@nt}...text...}
\def\@makeother#1{\catcode`#112\relax}
\def\comm@nt{%
\begingroup
\let\do\@makeother \dospecials
\@comm}
\begingroup\catcode`\<1 \catcode`\>2
\catcode`\{12 \catcode`\}12
\long\gdef\@comm#1<%
\if#1{\long\def\@tempa ##1}<\endgroup>\else
\long\def\@tempa ##1#1<\endgroup>\fi
\@tempa>
\endgroup
% like LaTeX2e's \InputIfFileExists
\ifx\InputIfFileExists\UNDEFINED
\def\InputIfFileExists#1#2#3{%
\immediate\openin0=#1\relax
\ifeof0\relax\immediate\closein0\relax#3%
\else\immediate\closein0\relax#2\input#1\relax\fi}%
\fi
\def\ZZZZinput#1{\input#1\relax}
% you may replace the above by
%
% \def\ZZZZinput#1{\InputIfFileExists{#1}{}{}}
%
% if you just want to call (La)TeX on your text
% ignoring the portions that need to be SLaTeX'ed
%use \subjobname rather than \jobname to generate
%slatex's temp files --- this allows us to change
%\subjobname for more control, if necessary.
\let\subjobname\jobname
% counter for generating temp file names
\newcount\sch@mefilenamecount
\sch@mefilenamecount=-1
% To produce displayed Scheme code:
% in LaTeX:
% \begin{schemedisplay}
% ... indented program (with sev'l lines) ...
% \end{schemedisplay}
%
% in TeX:
% \schemedisplay
% ... indented program (with sev'l lines) ...
% \endschemedisplay
\begingroup\catcode`\|=0 \catcode`\[=1 \catcode`\]=2
\catcode`\{=12 \catcode`\}=12 \catcode`\\=12
|gdef|defschemedisplaytoken#1[%
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|begingroup
|let|do|@makeother |dospecials
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|endgroup|end[#1]]%
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|endgroup|csname end#1|endcsname]%
|long|expandafter|gdef|csname #1|endcsname[%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[%
|global|advance|sch@mefilenamecount by 1
|let|checkforfollpar0%
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|let|checkforfollpar1%
|noindentifnofollpar]]%
|endgroup
\def\undefschemedisplaytoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% like {schemedisplay}, but displays output from a
% Scheme evaluation. I.e., keywords and variables
% appear in the data font
\let\defschemeresponsetoken\defschemedisplaytoken
\let\undefschemeresponsetoken\undefschemedisplaytoken
% \scheme|...program fragment...| produces Scheme code
% in-text. Sp. case: \scheme{...} == \scheme}...}
\def\defschemetoken#1{%
\long\expandafter\def\csname#1\endcsname{%
\global\advance\sch@mefilenamecount by 1
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}%
\comm@nt}}
\let\undefschemetoken\undefschemedisplaytoken
% \schemeresult|...program fragment...| produces a
% Scheme code result in-text: i.e. keyword or variable
% fonts are replaced by the data font. Sp. case:
% \schemeresult{...} == \schemeresult}...}
\let\defschemeresulttoken\defschemetoken
\let\undefschemeresulttoken\undefschemetoken
% To produce a box of Scheme code:
% in LaTeX:
% \begin{schemebox}
% ... indented program (with sev'l lines) ...
% \end{schemebox}
%
% in TeX:
% \schemebox
% ... indented program (with sev'l lines) ...
% \endschemebox
\begingroup\catcode`\|=0 \catcode`\[=1 \catcode`\]=2
\catcode`\{=12 \catcode`\}=12 \catcode`\\=12
|gdef|defschemeboxtoken#1[%
|long|expandafter|gdef|csname ZZZZcomment#1|endcsname[%
|begingroup
|let|do|@makeother |dospecials
|csname ZZZZcomment|slatexenvstyle II#1|endcsname]%
|long|expandafter|gdef|csname ZZZZcommentlatexII#1|endcsname##1\end{#1}[%
|endgroup|end[#1]]%
|long|expandafter|gdef|csname ZZZZcommenttexII#1|endcsname##1\end#1[%
|endgroup|csname end#1|endcsname]%
|long|expandafter|gdef|csname #1|endcsname[%
|global|advance|sch@mefilenamecount by 1
|ZZZZinput[|filehider Z|number|sch@mefilenamecount|subjobname.tex]%
|csname ZZZZcomment#1|endcsname]%
|long|expandafter|gdef|csname end#1|endcsname[]]%
|endgroup
\let\undefschemeboxtoken\undefschemedisplaytoken
% like {schemeresponse}, but in a box
\let\defschemeresponseboxtoken\defschemeboxtoken
\let\undefschemeresponseboxtoken\undefschemeboxtoken
% for wholesale dumping of all-Scheme files into TeX (converting
% .scm files to .tex),
% use
% \schemeinput{<filename>}
% .scm, .ss, .s extensions optional
\def\defschemeinputtoken#1{%
\long\expandafter\gdef\csname#1\endcsname##1{%
\global\advance\sch@mefilenamecount by 1
\ZZZZinput{\filehider Z\number\sch@mefilenamecount\subjobname.tex}}}
\def\undefschemeinputtoken#1{%
\expandafter\gdef\csname#1\endcsname{\UNDEFINED}}
% delineating a region that features typeset code
% not usually needed, except when using \scheme and schemedisplay
% inside macro-args and macro-definition-bodies
% in LaTeX:
% \begin{schemeregion}
% ...
% \end{schemeregion}
%
% in TeX:
% \schemeregion
% ...
% \endschemeregion
\let\defschemeregiontoken\defschemeboxtoken
\let\undefschemeregiontoken\undefschemeboxtoken
% the SLaTeX tokens
\defschemedisplaytoken{schemedisplay}
\defschemetoken{scheme}
\defschemeboxtoken{schemebox}
\defschemeresulttoken{schemeresult}
\defschemeresponsetoken{schemeresponse}
\defschemeresponseboxtoken{schemeresponsebox}
\defschemeinputtoken{schemeinput}
\defschemeregiontoken{schemeregion}
% introducing new code-tokens to the keyword, variable and constant
% categories
\def\comm@ntII{%
\begingroup
\let\do\@makeother \dospecials
\@commII}
\begingroup\catcode`\[1 \catcode`\]2
\catcode`\{12 \catcode`\}12
\long\gdef\@commII{[%
\long\def\@tempa ##1}[\endgroup]\@tempa]%
\endgroup
\let\setkeyword\comm@ntII
\let\setvariable\comm@ntII
\let\setconstant\comm@ntII
\let\setdata\comm@ntII
% \defschememathescape makes the succeeding grouped character an
% escape into latex math from within Scheme code;
% this character can't be }
\let\defschememathescape\comm@ntII
\let\undefschememathescape\comm@ntII
% telling SLaTeX that a certain Scheme identifier is to
% be replaced by the specified LaTeX expression.
% Useful for generating ``mathematical''-looking
% typeset code even though the corresponding Scheme
% code is ascii as usual and doesn't violate
% identifier-naming rules
\def\setspecialsymbol{%
\begingroup
\let\do\@makeother \dospecials
\@commIII}
\begingroup\catcode`\[1 \catcode`\]2
\catcode`\{12 \catcode`\}12
\long\gdef\@commIII{[%
\long\def\@tempa ##1}[\endgroup\@gobbleI]\@tempa]%
\endgroup
\def\@gobbleI#1{}
% \unsetspecialsymbol strips Scheme identifier(s) of
% any ``mathematical'' look lent by the above
\let\unsetspecialsymbol\comm@ntII
% enabling/disabling slatex
\def\slatexdisable#1{\expandafter\gdef\csname#1\endcsname{}}
% \schemecasesensitive takes either true or false as
% argument
\def\schemecasesensitive#1{}
%for latex only: use \slatexseparateincludes before the
%occurrence of any Scheme code in your file, if you
%want the various \include'd files to have their own
%pool of temporary slatex files. This lets you juggle
%your \include's in successive runs of LaTeX without
%having to worry that the temp. files may interfere.
%By default, only a single pool of temp files is used.
%Warning: On DOS, if your \include'd files have fairly
%similar names, avoid \slatexseparateincludes since the
%short filenames on DOS will likely confuse the temp
%file pools of different \include files.
\def\slatexseparateincludes{%
\gdef\include##1{{\def\subjobname{##1}%
\sch@mefilenamecount=-1
\@include##1 }}}
% convenient abbreviations for characters
\begingroup
\catcode`\|=0
|catcode`|\=12
|gdef|ttbackslash{{|tt|catcode`|\=12 \}}
|endgroup
\mathchardef\lt="313C
\mathchardef\gt="313E
\begingroup
\catcode`\@12
\global\let\atsign@%
\endgroup
\chardef\dq=`\"
% leading character of slatex filenames: . for unix to
% keep them out of the way
\def\filehider{.}
% since the above doesn't work of dos, slatex on dos
% will use a different character, and make the
% redefinition available through the following
\InputIfFileExists{xZfilhid.tex}{}{}
% @ is no longer a letter for TeX
\ifusinglatex\relax\else
\catcode`\@\atcatcodebeforeslatex
\fi
\message{*** Check: Are you sure you called SLaTeX \slatexversion? ***}

BIN
collects/slatex/slatex-code/slatxdoc.dvi
View File

Binary file not shown.

1777
collects/slatex/slatex-code/slatxdoc.tex
View File

File diff suppressed because it is too large Load Diff

107
collects/slatex/slatex-code/structs.scm
View File

@ -1,107 +0,0 @@
;structs.scm
;SLaTeX v. 2.3
;Structures used by SLaTeX
;(c) Dorai Sitaram, Rice U., 1991, 1994
(eval-within slatex
(defvar slatex::*max-line-length* 200)
(defenum
;possible values of =space
slatex::&void-space
slatex::&plain-space
slatex::&init-space
slatex::&init-plain-space
slatex::&paren-space
slatex::&bracket-space
slatex::&quote-space
slatex::&inner-space)
(defenum
;possible values of =tab
slatex::&void-tab
slatex::&set-tab
slatex::&move-tab
slatex::&tabbed-crg-ret
slatex::&plain-crg-ret)
(defenum
;possible values of =notab
slatex::&void-notab
slatex::&begin-comment
slatex::&mid-comment
slatex::&begin-string
slatex::&mid-string
slatex::&end-string
slatex::&begin-math
slatex::&mid-math
slatex::&end-math)
(defrecord slatex::make-raw-line
slatex::=rtedge
slatex::=char
slatex::=space
slatex::=tab
slatex::=notab)
(define slatex::make-line
(lambda ()
;makes a "line" record
(let ((l (make-raw-line)))
(setf (of l =rtedge) 0)
(setf (of l =char) (make-string *max-line-length* #\space))
(setf (of l =space) (make-string *max-line-length* &void-space))
(setf (of l =tab) (make-string *max-line-length* &void-tab))
(setf (of l =notab) (make-string *max-line-length* &void-notab))
l)))
(defvar slatex::*line1* (make-line))
(defvar slatex::*line2* (make-line))
(defrecord slatex::make-case-frame
slatex::=in-ctag-tkn
slatex::=in-bktd-ctag-exp
slatex::=in-case-exp)
(defrecord slatex::make-bq-frame
slatex::=in-comma slatex::=in-bq-tkn slatex::=in-bktd-bq-exp)
(defvar slatex::*latex-paragraph-mode?* 'fwd1)
(defvar slatex::*intext?* 'fwd2)
(defvar slatex::*code-env-spec* "UNDEFINED")
(defvar slatex::*in* 'fwd3)
(defvar slatex::*out* 'fwd4)
(defvar slatex::*in-qtd-tkn* 'fwd5)
(defvar slatex::*in-bktd-qtd-exp* 'fwd6)
(defvar slatex::*in-mac-tkn* 'fwd7)
(defvar slatex::*in-bktd-mac-exp* 'fwd8)
(defvar slatex::*case-stack* 'fwd9)
(defvar slatex::*bq-stack* 'fwd10)
(define slatex::display-space
(lambda (s p)
(cond ((eq? s &plain-space) (display #\space p))
((eq? s &init-plain-space) (display #\space p))
((eq? s &init-space) (display "\\HL " p))
((eq? s &paren-space) (display "\\PRN " p))
((eq? s &bracket-space) (display "\\BKT " p))
((eq? s &quote-space) (display "\\QUO " p))
((eq? s &inner-space) (display "\\ " p)))))
(define slatex::display-tab
(lambda (tab p)
(cond ((eq? tab &set-tab) (display "\\=" p))
((eq? tab &move-tab) (display "\\>" p)))))
(define slatex::display-notab
(lambda (notab p)
(cond ((eq? notab &begin-string) (display "\\dt{" p))
((eq? notab &end-string) (display "}" p)))))
)

68
collects/slatex/slatex-code/tex2html.css
View File

@ -1,68 +0,0 @@
body {
color: black;
background-color: white;
margin-top: 2em;
margin-left: 8%;
}
.chapterheading {
/*color: #cc0000;*/
color: purple;
/*font-family: verdana, serif;*/
font-size: 70%}
.subject {
/*margin-left: 0%;*/
color: #cc0000;
/*font-family: verdana, serif;*/
/*color: purple;*/
/* text-align: center;*/
}
h1,h2,h3,h4,h5,h6 {
color: navy;
/* font-family: verdana, serif;*/
margin-left: -4%;
margin-top: .5em
}
.bibitem {color: purple}
.verbatim {color: darkgreen}
/*code {
font-weight: bold
}*/
.scheme .punctuation {color: brown}
/*.scheme .punctuation code {color: brown;
font-weight: normal}*/
.scheme .keyword {color: #cc0000;
font-weight: bold;
}
.scheme .variable {color: navy;
/* font-style: italic; */
}
.scheme .global {color: purple}
.scheme .selfeval {color: green}
.scheme .comment {
/*font-family: serif;*/
color: teal}
.takenotice {color: red}
.smallprint {
color: gray;
font-size: 50%;
}
.smallprint hr {
text-align: left;
width: 40%;
}
.footnote {font-weight: bold}

810
collects/slatex/slatex-code/tex2html.tex
View File

@ -1,810 +0,0 @@
% tex2html.tex
% Dorai Sitaram, Apr 1997
\message{version 3p}
% TeX files using these macros
% can be converted by the program
% tex2html into HTML
\let\texonly\relax
\let\endtexonly\relax
\texonly
\ifx\slatexignorecurrentfile\UNDEFINED\relax\fi
\def\defcsactive#1{\defnumactive{`#1}}
\def\defnumactive#1#2{\catcode#1\active
\begingroup\lccode`\~#1%
\lowercase{\endgroup\def~{#2}}}
% gobblegobblegobble
\def\gobblegroup{\bgroup
\def\do##1{\catcode`##1=9 }\dospecials
\catcode`\{1 \catcode`\}2 \catcode`\^^M=9
\gobblegroupI}
\def\gobblegroupI#1{\egroup}
\def\gobbleencl{\bgroup
\def\do##1{\catcode`##1=12 }\dospecials
\catcode`\{1 \catcode`\}2 \catcode`\^^M=9
\futurelet\gobbleenclnext\gobbleenclI}
\def\gobbleenclI{\ifx\gobbleenclnext\bgroup
\let\gobbleenclnext\gobblegroupI
\else\let\gobbleenclnext\gobbleenclII\fi
\gobbleenclnext}
\def\gobbleenclII#1{%
\def\gobbleenclIII##1#1{\egroup}%
\gobbleenclIII}
% \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}
% The current font is cmtt iff fontdimen3 = 0 _and_
% fontdimen7 != 0
\def\checkifusingcmtt{\let\usingcmtt n%
\ifdim\the\fontdimen3\the\font=0.0pt
\ifdim\the\fontdimen7\the\font=0.0pt
\else\let\usingcmtt y\fi\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}
\def\verbavoidligs{% avoid ligatures
\defcsactive\`{\relax\lq}%
\defcsactive\ {\leavevmode\ }%
\defcsactive\^^I{\leavevmode\ \ \ \ \ \ \ \ }%
\defcsactive\^^M{\leavevmode\endgraf}%
\checkifusingcmtt
\ifx\usingcmtt n%
\defcsactive\<{\relax\char`\<}%
\defcsactive\>{\relax\char`\>}%
\defcsactive\-{\variablelengthhyphen}%
\fi}
\def\verbinsertskip{%
\let\firstpar y%
\defcsactive\^^M{\ifx\firstpar y%
\let\firstpar n%
\verbdisplayskip
\aftergroup\verbdisplayskip
\else\leavevmode\fi\endgraf}%
\verbhook}
\def\verb{\begingroup
\verbsetup\verbI}
\newcount\verbbracebalancecount
\def\verblbrace{\char`\{}
\def\verbrbrace{\char`\}}
\def\verbescapechar#1{%
\def\escapifyverbescapechar{\catcode`#1=0 }}
\verbescapechar\|
{\catcode`\[1 \catcode`\]2
\catcode`\{12 \catcode`\}12
\gdef\verbI#1[\verbavoidligs
\verbinsertskip\verbhook
\if#1{\escapifyverbescapechar
\def\{[\char`\{]%
\def\}[\char`\}]%
\def\|[\char`\|]%
\verbbracebalancecount0
\defcsactive\{[\advance\verbbracebalancecount by 1
\verblbrace]%
\defcsactive\}[\ifnum\verbbracebalancecount=0
\let\verbrbracenext\endgroup\else
\advance\verbbracebalancecount by -1
\let\verbrbracenext\verbrbrace\fi
\verbrbracenext]\else
\defcsactive#1[\endgroup]\fi
\verbII
]]
\def\verbII{\futurelet\verbIInext\verbIII}
{\catcode`\^^M\active%
\gdef\verbIII{\ifx\verbIInext^^M\else%
\defcsactive\^^M{\leavevmode\ }\fi}}
\let\verbdisplayskip\medbreak
% \verbinput FILENAME
% displays contents of file FILENAME verbatim.
\def\verbinput#1 {{\verbsetup\verbavoidligs\verbhook
\input #1 }}
\def\verbfilename#1 {\relax}
\let\verbwrite\gobbleencl
% \path is like \verb except that its argument
% can break across lines at `.' and `/'.
\def\path{\begingroup\verbsetup
\pathfont
\defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}%
\defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}%
\verbI}
\let\pathfont\relax
% \url{URL} becomes
% <a href="URL">URL</a> 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.
\def\url{\bgroup\urlsetup\let\dummy=}
\def\urlsetup{\verbsetup\urlfont\verbavoidligs
\catcode`\{1 \catcode`\}2
\defcsactive\%{\urlpacifybibtex}%
\defcsactive\ {\relax}%
\defcsactive\^^M{\relax}%
\defcsactive\.{\discretionary{\char`\.}{}{\char`\.}}%
\defcsactive\/{\discretionary{\char`\/}{}{\char`\/}}%
\defcsactive\`{\relax\lq}}
\let\urlfont\relax
\def\urlpacifybibtex{\futurelet\urlpacifybibtexnext\urlpacifybibtexI}
\def\urlpacifybibtexI{\ifx\urlpacifybibtexnext^^M%
\else\%\fi}
% \mailto{ADDRESS} becomes
% <a href="mailto:ADDRESS">ADDRESS</a> in HTML, and
% ADDRESS in DVI.
\let\mailto\url
% \urlh{URL}{TEXT} becomes
% <a href="URL">TEXT</a> 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\urlhI
\gdef\urlII}
\def\urlhI{\egroup
\bgroup
\let\\\relax
\def\1{{\urlsetup\urlII}}%
\let\dummy=}
% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes
% <a href="URL">HTML-TEXT</a> in HTML, and
% DVI-TEXT in DVI
\def\urlhd{\bgroup
\def\do##1{\catcode`##1=12 }\dospecials
\catcode`\{1 \catcode`\}2
\urlhdI}
\def\urlhdI#1#2{\egroup}
%
\let\ignorenextinputtimestamp\relax
%
\let\htmlonly\iffalse
\let\endhtmlonly\fi
\def\rawhtml{\errmessage{Can't occur except inside
\string\htmlonly}}
\def\endrawhtml{\errmessage{Can't occur except inside
\string\htmlonly}}
\let\htmlheadonly\iffalse
\let\endhtmlheadonly\fi
\let\htmlstylesheet\gobblegroup
% color (deprecated)
\let\rgb\gobblegroup
\let\color\gobblegroup
% Scheme
\let\scm\verb
\let\scminput\verbatiminput
\def\scmfilename#1 {\relax}
\let\scmdribble\scm
\let\scmwrite\gobbleencl
\let\scmkeyword\gobblegroup
\let\setkeyword\gobblegroup % SLaTeX compat
\ifx\slatexversion\UNDEFINED
\def\schemedisplay{\begingroup
\verbsetup\verbavoidligs
\verbinsertskip
\schemedisplayI}%
\fi
{\catcode`\|0 |catcode`|\12
|long|gdef|schemedisplayI#1\endschemedisplay{%
#1|endgroup}}
% GIFs
\let\gifdef\def
\def\gifpreamble{\let\magnificationoutsidegifpreamble\magnification
\def\magnification{\count255=}}
\def\endgifpreamble{\let\magnification\magnificationoutsidegifpreamble}
\let\htmlgif\relax
\let\endhtmlgif\relax
% Cheap count registers: doesn't use up TeX's limited
% number of real count registers.
% A cheap count register is simply a macro that expands to the
% contents of the count register. Thus \def\kount{0} defines a
% count register \kount that currently contains 0.
% \advancecheapcount\kount num increments \kount by n.
% \globaladvancecheapcount increments the global \kount.
% If \kount is not defined, the \[global]advancecheapcount
% macros define it to be 0 before proceeding with the
% incrementation.
\def\newcheapcount#1{\edef#1{0}}
\def\advancecheapcounthelper#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\advancecheapcount{\advancecheapcounthelper\relax}
\def\globaladvancecheapcount{\advancecheapcounthelper\global}
% title
\let\title\gobblegroup
\def\subject#1{\centerline{\bf#1}\medskip}
% plain's \beginsection splits pages too easily
%\def\beginsection#1\par{\sectionwithnumber{1}{}{#1}}
\def\beginsection{\vskip-\lastskip
\bigbreak\noindent
\bgroup\bf
\let\par\sectionafterskip}
\def\beginsectionstar*{\beginsection}
% 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=}
%
\let\strike\fiverm % can be much better!
%
\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}
%\def\hr{\smallskip\line{\leaders\hbox{~.~}\hfill}\smallskip}
%Commonplace math that doesn't require GIF. (Avoiding $
%here because $ triggers GIF generation.)
\def\mathg{$\bgroup\aftergroup\closemathg\let\dummy=}
\def\closemathg{$}
\def\mathdg{$$\bgroup\aftergroup\closemathdg\let\dummy=}
\def\closemathdg{$$}
\def\frac#1/#2{{#1\over#2}}
%
% Backward compatible stuff
\let\p\verb
\let\verbatim\verb
\let\verbatimfile\verbinput
\let\setverbatimescapechar\verbescapechar
\let\scmp\scm
\let\scmverbatim\scm
\let\scmverbatimfile\scminput
\let\scmfile\scmdribble
\let\scmfileonly\scmwrite
\let\href\urlhd
\endtexonly
\ifx\newenvironment\UNDEFINED\else
% we're in LaTeX and so won't load rest of file
\endinput\fi
\texonly
\input btxmac
% Sections
\def\tracksectionchangeatlevel#1{%
\expandafter\let\expandafter\thiscount\csname
sectionnumber#1\endcsname
\ifx\thiscount\relax
\expandafter\edef\csname sectionnumber#1\endcsname{0}%
\fi
\expandafter\advancecheapcount
\csname sectionnumber#1\endcsname 1%
\ifx\doingappendix0%
\edef\recentlabel{\csname sectionnumber1\endcsname}%
\else
%\count255=\expandafter\csname sectionnumber1\endcsname
\edef\recentlabel{\char\csname sectionnumber1\endcsname}%
\fi
\count255=0
\loop
\advance\count255 by 1
\ifnum\count255=1
\else\edef\recentlabel{\recentlabel.\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}
% Vanilla section-header look -- change this macro for new look
\def\sectionstar#1*#2{\vskip-\lastskip
% #1=depth #2=heading-text
\tocactivate
{\let\folio0%
\edef\temp{\write\tocout{\string\tocentry{#1}{}{#2}{\folio}}}%
\temp}%
\goodbreak
\vskip1.5\bigskipamount
\noindent
\hbox{\bf\vtop{\hsize=.7\hsize
\pretolerance 10000
\noindent\raggedright#2}}%
\bgroup\let\par\sectionafterskip}
\def\sectionwithnumber#1#2#3{\vskip-\lastskip
% #1=depth #2=dotted-number #3=heading-text
\tocactivate
{\let\folio0%
\edef\temp{\write\tocout{\string\tocentry{#1}{#2}{#3}{\folio}}}%
\temp}
\goodbreak
\vskip1.5\bigskipamount
\noindent
\hbox{\bf#2\vtop{\hsize=.7\hsize
\pretolerance 10000
\noindent\raggedright#3}}%
\bgroup\let\par\sectionafterskip}
% \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\sectionafterskip{\egroup\nobreak\medskip\noindent}
\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
\tracksectionchangeatlevel{\sectiondlvl}
\def\sectioncontinue{\sectionwithnumber{\sectiondlvl}%
{\recentlabel\enspace}}\fi
\sectioncontinue}
\def\section{\sectiond1}
\def\subsection{\sectiond2}
\def\subsubsection{\sectiond3}
\def\paragraph{\sectiond4}
\def\subparagraph{\sectiond5}
\let\usingchapters0
\def\chapter{\global\let\usingchapters1%
\futurelet\chapternextchar\chapterdispatch}
\def\chapterdispatch{\ifx\chapternextchar*%
\let\chaptercontinue\chapterstar\else
\tracksectionchangeatlevel{1}%
\def\chaptercontinue{\chapterhelp{\recentlabel}}\fi
\chaptercontinue}
\def\chapterstar*#1{%
% #1=heading-text
\tocactivate
{\let\folio0%
\edef\temp{\write\tocout{\string\tocentry{1}{}{#1}{\folio}}}%
\temp}%
\vfill\eject
\null\vskip3em
\noindent
\hbox{\bf\vtop{\hsize=.7\hsize
\pretolerance 10000
\noindent\raggedright#1}}%
\bgroup\let\par\chapterafterskip}
\def\chapterhelp#1#2{%
% #1=number #2=heading-text
\tocactivate
{\let\folio0%
\edef\temp{\write\tocout{\string\tocentry{1}{#1\enspace}{#2}{\folio}}}%
\temp}%
\vfill\eject
\null\vskip3em
\noindent
\ifx\doingappendix0%
\hbox{\bf Chapter #1}\else
\hbox{\bf Appendix #1}\fi
\vskip 1em
\noindent
\hbox{\bf\vtop{\hsize=.7\hsize
\pretolerance 10000
\noindent\raggedright#2}}%
\bgroup\let\par\chapterafterskip}
\def\chapterafterskip{\egroup\nobreak\vskip3em \noindent}
\let\doingappendix=0
\def\appendix{\let\doingappendix=1%
\count255=`\A%
\advance\count255 by -1
\expandafter\edef\csname
sectionnumber1\endcsname{\the\count255 }}
% toc
\let\tocactive0
\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#3#4{%
%#1=depth #2=secnum #3=sectitle #4=secpage
\ifnum#1=1\medbreak\begingroup\bf
\else\begingroup\fi
\noindent\hskip #1 em
#2%
\vtop{\hsize=.7\hsize
\raggedright
\noindent {#3},
#4\strut}\endgroup\par}
\def\tableofcontents{%
\ifx\tocactive0%
\openin0 \jobname.toc
\ifeof0 \closein0 \else
\closein0 \input \jobname.toc
\fi
\tocoutensure
\openout\tocout \jobname.toc
\global\let\tocactive1%
\else
\input Z-T-\jobname.tex
\fi}
% Cross-references
% \openxrefout loads all the TAG-VALUE associations in
% \jobname.xrf and then opens \jobname.xrf as an
% output channel that \tag can use
\def\openxrefout{\openin0=\jobname.xrf
\ifeof0 \closein0 \else
{\catcode`\\0 \input \jobname.xrf }\fi
\csname newwrite\endcsname\xrefout
\openout\xrefout=\jobname.xrf }
% \tag{TAG}{VALUE} associates TAG with VALUE.
% Hereafter, \ref{TAG} will output VALUE.
% \tag stores its associations in \xrefout.
% \tag calls \openxrefout if \jobname.xrf hasn't
% already been opened
\def\tag#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}}
% \ref{TAG} outputs VALUE, assuming \tag 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}
% \label, as in LaTeX
\let\recentlabel\relax
% The sectioning commands
% define \recentlabel so a subsequent call to \label will pick up the
% right label.
\def\label#1{\tag{#1}{\recentlabel}%
\tag{PAGE#1}{\folio}}
% \pageref, as in LaTeX
\def\pageref#1{\ref{PAGE#1}}
% Numbered footnotes
\newcheapcount\footnotenumber
\ifx\plainfootnote\UNDEFINED
\let\plainfootnote\footnote
\fi
\def\numfootnote{\globaladvancecheapcount\footnotenumber 1%
\bgroup\csname footnotehook\endcsname
\plainfootnote{$^{\footnotenumber}$}\bgroup
\edef\recentlabel{\footnotenumber}%
\aftergroup\egroup
\let\dummy=}
%
\def\iffileexists#1#2#3{%
\openin0 #1
\ifeof0 \closein0
#3%
\else \closein0
#2\fi}
% \ifx\bibitem\UNDEFINED
% \newcheapcount\bibitemnumber
% \def\bibitem{\par\globaladvancecheapcount\bibitemnumber 1%
% \edef\recentlabel{\bibitemnumber}%
% [\bibitemnumber]\label}
% \fi
%
% \def\begin#1{\begingroup
% \def\end##1{\csname end#1\endcsname\endgroup}%
% \def\envname{#1}%
% \def\envnameI{thebibliography}%
% \csname #1\endcsname
% \ifx\envname\envnameI\let\next\gobblegroup
% \else\let\next\relax\fi\next}
% \def\begin#1{\begingroup
% \let\end\endbegin
% \csname #1\endcsname}
% \def\endbegin#1{\csname end#1\endcsname\endgroup}
% 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, e.g., 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.
%
% Use \printindex instead of \inputindex if you want
% the section heading ``Index'' automatically generated.
\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
\indexI}
\def\indexI#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}}%
\let\indexspace\medskip}
\def\endtheindex{\endgroup}
% \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; }%
\let\indexspace\medskip}}
\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}
\def\printindex{\csname beginsection\endcsname Index\par
\inputindex}
%
\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\itemize{\par\begingroup
\advance\leftskip 1.5em
\smallbreak
\def\item{\smallbreak$\bullet$\enspace\ignorespaces}}
\def\enditemize{\smallbreak\smallbreak\endgroup\par}
\def\enumerate{\par\begingroup
\newcheapcount\enumeratenumber
\advance\leftskip 1.5em
\smallbreak
\def\item{\smallbreak
\advancecheapcount\enumeratenumber1%
{\bf \enumeratenumber.}\enspace\ignorespaces}}
\def\endenumerate{\smallbreak\smallbreak\endgroup\par}
\endtexonly
% end of file

Some files were not shown because too many files have changed in this diff Show More