diff --git a/collects/help/help.ss b/collects/help/help.ss index 62feef91..a50a81ce 100644 --- a/collects/help/help.ss +++ b/collects/help/help.ss @@ -23,6 +23,17 @@ (begin-elaboration-time (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 (user-defined-doc-position x) #f) diff --git a/collects/net/base64.ss b/collects/net/base64.ss deleted file mode 100644 index f3e2bca3..00000000 --- a/collects/net/base64.ss +++ /dev/null @@ -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")) diff --git a/collects/net/base64r.ss b/collects/net/base64r.ss deleted file mode 100644 index e5452b84..00000000 --- a/collects/net/base64r.ss +++ /dev/null @@ -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))]))))) - diff --git a/collects/net/base64s.ss b/collects/net/base64s.ss deleted file mode 100644 index 452525f5..00000000 --- a/collects/net/base64s.ss +++ /dev/null @@ -1,3 +0,0 @@ - -(define-signature mzlib:base64^ - (base64-encode)) diff --git a/collects/net/cgi.ss b/collects/net/cgi.ss deleted file mode 100644 index db770679..00000000 --- a/collects/net/cgi.ss +++ /dev/null @@ -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@) diff --git a/collects/net/cgir.ss b/collects/net/cgir.ss deleted file mode 100644 index 040c2610..00000000 --- a/collects/net/cgir.ss +++ /dev/null @@ -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 - ((#\<) "<") - ((#\>) ">") - ((#\&) "&") - (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" - "" - "" - "" - - "" - ,(sa "" title "") - "" - "" - ,(sa "") - "" - ,@body-lines - "" - "" - ""))))) - - ;; 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) -> - - (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) - `("" - ,@(map - (lambda (bind) - (string-append - (symbol->string (car bind)) - " --> " - (cdr bind) - "
")) - bindings) - ""))) - - ;; 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

") - ,@(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

") - ,@(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 "" anchor-text ""))) - - ;; ==================================================================== - - - ) diff --git a/collects/net/cgis.ss b/collects/net/cgis.ss deleted file mode 100644 index c51585cf..00000000 --- a/collects/net/cgis.ss +++ /dev/null @@ -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 - )) diff --git a/collects/net/cgiu.ss b/collects/net/cgiu.ss deleted file mode 100644 index 1b13e28f..00000000 --- a/collects/net/cgiu.ss +++ /dev/null @@ -1,4 +0,0 @@ -(require-library "refer.ss") -(require-library "cgis.ss" "net") - -(define mzlib:cgi@ (require-library-unit/sig "cgir.ss" "net")) diff --git a/collects/net/dns.ss b/collects/net/dns.ss deleted file mode 100644 index b569eb68..00000000 --- a/collects/net/dns.ss +++ /dev/null @@ -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")) diff --git a/collects/net/dnsr.ss b/collects/net/dnsr.ss deleted file mode 100644 index 804d4254..00000000 --- a/collects/net/dnsr.ss +++ /dev/null @@ -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]))) diff --git a/collects/net/dnss.ss b/collects/net/dnss.ss deleted file mode 100644 index 8083f659..00000000 --- a/collects/net/dnss.ss +++ /dev/null @@ -1,5 +0,0 @@ - -(define-signature mzlib:dns^ - (dns-get-address - dns-get-mail-exchanger - dns-find-nameserver)) diff --git a/collects/net/doc.txt b/collects/net/doc.txt deleted file mode 100644 index e3fabe04..00000000 --- a/collects/net/doc.txt +++ /dev/null @@ -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) -> - - 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 " - ... - "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 " - ... - "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 " => "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 (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 (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\" , 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. diff --git a/collects/net/head.ss b/collects/net/head.ss deleted file mode 100644 index e9c8b16e..00000000 --- a/collects/net/head.ss +++ /dev/null @@ -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")) diff --git a/collects/net/headr.ss b/collects/net/headr.ss deleted file mode 100644 index 37ad57de..00000000 --- a/collects/net/headr.ss +++ /dev/null @@ -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))))))))) diff --git a/collects/net/heads.ss b/collects/net/heads.ss deleted file mode 100644 index c6c9a2f1..00000000 --- a/collects/net/heads.ss +++ /dev/null @@ -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)) diff --git a/collects/net/imap.ss b/collects/net/imap.ss deleted file mode 100644 index 844c4842..00000000 --- a/collects/net/imap.ss +++ /dev/null @@ -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")) diff --git a/collects/net/imapr.ss b/collects/net/imapr.ss deleted file mode 100644 index f6f0ba64..00000000 --- a/collects/net/imapr.ss +++ /dev/null @@ -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))]))) diff --git a/collects/net/imaps.ss b/collects/net/imaps.ss deleted file mode 100644 index 0a802eb4..00000000 --- a/collects/net/imaps.ss +++ /dev/null @@ -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)) diff --git a/collects/net/info.ss b/collects/net/info.ss deleted file mode 100644 index a70d15c9..00000000 --- a/collects/net/info.ss +++ /dev/null @@ -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)]))) \ No newline at end of file diff --git a/collects/net/mail.ss b/collects/net/mail.ss deleted file mode 100644 index 3e231e73..00000000 --- a/collects/net/mail.ss +++ /dev/null @@ -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@) diff --git a/collects/net/mailr.ss b/collects/net/mailr.ss deleted file mode 100644 index 5be07bad..00000000 --- a/collects/net/mailr.ss +++ /dev/null @@ -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)))) - - ) diff --git a/collects/net/mails.ss b/collects/net/mails.ss deleted file mode 100644 index 56c18572..00000000 --- a/collects/net/mails.ss +++ /dev/null @@ -1,4 +0,0 @@ -(define-signature mzlib:sendmail^ - (send-mail-message/port - send-mail-message - (struct no-mail-recipients ()))) diff --git a/collects/net/mailu.ss b/collects/net/mailu.ss deleted file mode 100644 index 0b010537..00000000 --- a/collects/net/mailu.ss +++ /dev/null @@ -1,4 +0,0 @@ -(require-library "mails.ss" "net") - -(define mzlib:sendmail@ - (require-library-unit/sig "mailr.ss" "net")) diff --git a/collects/net/nntp.sd b/collects/net/nntp.sd deleted file mode 100644 index d00a462b..00000000 --- a/collects/net/nntp.sd +++ /dev/null @@ -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) diff --git a/collects/net/nntp.ss b/collects/net/nntp.ss deleted file mode 100644 index 0050f26a..00000000 --- a/collects/net/nntp.ss +++ /dev/null @@ -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) diff --git a/collects/net/nntpr.ss b/collects/net/nntpr.ss deleted file mode 100644 index 5787d75f..00000000 --- a/collects/net/nntpr.ss +++ /dev/null @@ -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))))))) - - ) diff --git a/collects/net/nntps.ss b/collects/net/nntps.ss deleted file mode 100644 index 0d8dca9d..00000000 --- a/collects/net/nntps.ss +++ /dev/null @@ -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)))) - diff --git a/collects/net/nntpu.ss b/collects/net/nntpu.ss deleted file mode 100644 index 1551b592..00000000 --- a/collects/net/nntpu.ss +++ /dev/null @@ -1,5 +0,0 @@ -(require-library "macro.ss") - -(require-library "nntps.ss" "net") - -(define mzlib:nntp@ (require-library-unit/sig "nntpr.ss" "net")) diff --git a/collects/net/pop3.ss b/collects/net/pop3.ss deleted file mode 100644 index b91822c8..00000000 --- a/collects/net/pop3.ss +++ /dev/null @@ -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 " - ... - "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 " - ... - "Status: RO") -("some body" "text" "goes" "." "here" "." "") -> (pop3:disconnect-from-server c) - -|# diff --git a/collects/net/pop3r.ss b/collects/net/pop3r.ss deleted file mode 100644 index 381598c2..00000000 --- a/collects/net/pop3r.ss +++ /dev/null @@ -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))))))) - - ) diff --git a/collects/net/pop3s.ss b/collects/net/pop3s.ss deleted file mode 100644 index 143d6768..00000000 --- a/collects/net/pop3s.ss +++ /dev/null @@ -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)) - - ) - ) diff --git a/collects/net/pop3u.ss b/collects/net/pop3u.ss deleted file mode 100644 index 5169fd00..00000000 --- a/collects/net/pop3u.ss +++ /dev/null @@ -1,5 +0,0 @@ -(require-library "macro.ss") - -(require-library "pop3s.ss" "net") - -(define mzlib:pop3@ (require-library-unit/sig "pop3r.ss" "net")) diff --git a/collects/net/smtp.ss b/collects/net/smtp.ss deleted file mode 100644 index 28da5346..00000000 --- a/collects/net/smtp.ss +++ /dev/null @@ -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")) diff --git a/collects/net/smtpr.ss b/collects/net/smtpr.ss deleted file mode 100644 index 62c2696f..00000000 --- a/collects/net/smtpr.ss +++ /dev/null @@ -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)))]))) diff --git a/collects/net/smtps.ss b/collects/net/smtps.ss deleted file mode 100644 index aaf743af..00000000 --- a/collects/net/smtps.ss +++ /dev/null @@ -1,4 +0,0 @@ - -(define-signature mzlib:smtp^ - (smtp-send-message - smtp-sending-end-of-message)) diff --git a/collects/net/url.ss b/collects/net/url.ss deleted file mode 100644 index 701befd8..00000000 --- a/collects/net/url.ss +++ /dev/null @@ -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^) diff --git a/collects/net/urlr.ss b/collects/net/urlr.ss deleted file mode 100644 index a37d45ea..00000000 --- a/collects/net/urlr.ss +++ /dev/null @@ -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)))))))) - - ) - diff --git a/collects/net/urls.ss b/collects/net/urls.ss deleted file mode 100644 index c3c02a4c..00000000 --- a/collects/net/urls.ss +++ /dev/null @@ -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 diff --git a/collects/net/urlu.ss b/collects/net/urlu.ss deleted file mode 100644 index e897a344..00000000 --- a/collects/net/urlu.ss +++ /dev/null @@ -1,5 +0,0 @@ -(require-library "refer.ss") -(require-library "urls.ss" "net") - -(define mzlib:url@ - (require-library-unit/sig "urlr.ss" "net")) diff --git a/collects/quasiquote/qq-client.ss b/collects/quasiquote/qq-client.ss deleted file mode 100644 index 374c2ee7..00000000 --- a/collects/quasiquote/qq-client.ss +++ /dev/null @@ -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) ...) -;; -;; 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)) diff --git a/collects/quasiquote/qq.ss b/collects/quasiquote/qq.ss deleted file mode 100644 index 522e8edb..00000000 --- a/collects/quasiquote/qq.ss +++ /dev/null @@ -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@) diff --git a/collects/quasiquote/qqguir.ss b/collects/quasiquote/qqguir.ss deleted file mode 100644 index 1cc1cc64..00000000 --- a/collects/quasiquote/qqguir.ss +++ /dev/null @@ -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)))))) - - ) diff --git a/collects/quasiquote/qqr.ss b/collects/quasiquote/qqr.ss deleted file mode 100644 index 0a92e0f6..00000000 --- a/collects/quasiquote/qqr.ss +++ /dev/null @@ -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 /.gif - (define base-directory-for-funds "/sm/trmfg/") - ;; Rule: append /.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= - ;; (regexp "\\$(.+)") - ;; no longer works -- advantage is it provided ratios instead of decimals - - ;; http://quote.yahoo.com/q?s=&d=v1 - ;; provides some quotes as ratios -- hence the second regexp - - (define extract-quote-amount - (let ((quote-pattern (regexp "(.+)")) - (ratio-pattern (regexp "([0-9]+)/([0-9]+)"))) - (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) - - ) diff --git a/collects/quasiquote/qqs.ss b/collects/quasiquote/qqs.ss deleted file mode 100644 index e632436f..00000000 --- a/collects/quasiquote/qqs.ss +++ /dev/null @@ -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)) diff --git a/collects/quasiquote/qqu.ss b/collects/quasiquote/qqu.ss deleted file mode 100644 index 7ee89513..00000000 --- a/collects/quasiquote/qqu.ss +++ /dev/null @@ -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")) diff --git a/collects/readline/doc.txt b/collects/readline/doc.txt deleted file mode 100644 index d7ed302b..00000000 --- a/collects/readline/doc.txt +++ /dev/null @@ -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"))) diff --git a/collects/readline/info.ss b/collects/readline/info.ss deleted file mode 100644 index 5d3093a2..00000000 --- a/collects/readline/info.ss +++ /dev/null @@ -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)])) diff --git a/collects/readline/mzmake.ss b/collects/readline/mzmake.ss deleted file mode 100755 index 4475a3a3..00000000 --- a/collects/readline/mzmake.ss +++ /dev/null @@ -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) diff --git a/collects/readline/mzrl.c b/collects/readline/mzrl.c deleted file mode 100644 index c93ecffc..00000000 --- a/collects/readline/mzrl.c +++ /dev/null @@ -1,94 +0,0 @@ - -#include "escheme.h" -#include -#include -#include -#ifdef NEEDS_SELECT_H -# include -#endif -#include - -/* 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); -} diff --git a/collects/readline/pread.ss b/collects/readline/pread.ss deleted file mode 100644 index 1ca6d115..00000000 --- a/collects/readline/pread.ss +++ /dev/null @@ -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)) - diff --git a/collects/readline/readline.ss b/collects/readline/readline.ss deleted file mode 100644 index f0362ae1..00000000 --- a/collects/readline/readline.ss +++ /dev/null @@ -1,2 +0,0 @@ - -(load-relative-extension (build-path "compiled" "native" (system-library-subpath) "mzrl.so")) diff --git a/collects/readline/rep.ss b/collects/readline/rep.ss deleted file mode 100644 index 20c67727..00000000 --- a/collects/readline/rep.ss +++ /dev/null @@ -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))))) - diff --git a/collects/setup/doc.txt b/collects/setup/doc.txt deleted file mode 100644 index 142ac759..00000000 --- a/collects/setup/doc.txt +++ /dev/null @@ -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 ...)]) - ...) diff --git a/collects/setup/info.ss b/collects/setup/info.ss deleted file mode 100644 index 480347a5..00000000 --- a/collects/setup/info.ss +++ /dev/null @@ -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)])) diff --git a/collects/setup/pack.ss b/collects/setup/pack.ss deleted file mode 100644 index abb3f454..00000000 --- a/collects/setup/pack.ss +++ /dev/null @@ -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)))) - diff --git a/collects/setup/setup-optionr.ss b/collects/setup/setup-optionr.ss deleted file mode 100644 index 9684dc3c..00000000 --- a/collects/setup/setup-optionr.ss +++ /dev/null @@ -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))) - - - diff --git a/collects/setup/setup.ss b/collects/setup/setup.ss deleted file mode 100644 index 875d492b..00000000 --- a/collects/setup/setup.ss +++ /dev/null @@ -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 s only" "collection")]) - (=> - (lambda (collections . archives) - (values (if (null? collections) - null - (car collections)) - archives)) - '("archive") - (lambda (s) - (display s) - (printf "If no or -l 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^)) diff --git a/collects/setup/setupr.ss b/collects/setup/setupr.ss deleted file mode 100644 index d5a67472..00000000 --- a/collects/setup/setupr.ss +++ /dev/null @@ -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)) diff --git a/collects/setup/setupsig.ss b/collects/setup/setupsig.ss deleted file mode 100644 index 72b59fca..00000000 --- a/collects/setup/setupsig.ss +++ /dev/null @@ -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)) diff --git a/collects/slatex/doc.txt b/collects/slatex/doc.txt deleted file mode 100644 index 8606177a..00000000 --- a/collects/slatex/doc.txt +++ /dev/null @@ -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. diff --git a/collects/slatex/info.ss b/collects/slatex/info.ss deleted file mode 100644 index dabb83da..00000000 --- a/collects/slatex/info.ss +++ /dev/null @@ -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)))) diff --git a/collects/slatex/slatex-code/2col.tex b/collects/slatex/slatex-code/2col.tex deleted file mode 100644 index b843f07d..00000000 --- a/collects/slatex/slatex-code/2col.tex +++ /dev/null @@ -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} diff --git a/collects/slatex/slatex-code/8pt.tex b/collects/slatex/slatex-code/8pt.tex deleted file mode 100644 index 2de4a4f2..00000000 --- a/collects/slatex/slatex-code/8pt.tex +++ /dev/null @@ -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} diff --git a/collects/slatex/slatex-code/README b/collects/slatex/slatex-code/README deleted file mode 100644 index 2ae6bd88..00000000 --- a/collects/slatex/slatex-code/README +++ /dev/null @@ -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 diff --git a/collects/slatex/slatex-code/aliases.scm b/collects/slatex/slatex-code/aliases.scm deleted file mode 100644 index 550f62e2..00000000 --- a/collects/slatex/slatex-code/aliases.scm +++ /dev/null @@ -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 - )))) diff --git a/collects/slatex/slatex-code/batconfg.lsp b/collects/slatex/slatex-code/batconfg.lsp deleted file mode 100644 index ada53d7d..00000000 --- a/collects/slatex/slatex-code/batconfg.lsp +++ /dev/null @@ -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~%")) diff --git a/collects/slatex/slatex-code/batconfg.scm b/collects/slatex/slatex-code/batconfg.scm deleted file mode 100644 index 30992722..00000000 --- a/collects/slatex/slatex-code/batconfg.scm +++ /dev/null @@ -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)))) diff --git a/collects/slatex/slatex-code/cfg4lsp.lsp b/collects/slatex/slatex-code/cfg4lsp.lsp deleted file mode 100644 index e2228f5b..00000000 --- a/collects/slatex/slatex-code/cfg4lsp.lsp +++ /dev/null @@ -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!~%"))) diff --git a/collects/slatex/slatex-code/cfg4scm.scm b/collects/slatex/slatex-code/cfg4scm.scm deleted file mode 100644 index b6885005..00000000 --- a/collects/slatex/slatex-code/cfg4scm.scm +++ /dev/null @@ -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))) \ No newline at end of file diff --git a/collects/slatex/slatex-code/cltl.sty b/collects/slatex/slatex-code/cltl.sty deleted file mode 100644 index 745d830c..00000000 --- a/collects/slatex/slatex-code/cltl.sty +++ /dev/null @@ -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} diff --git a/collects/slatex/slatex-code/codeset.scm b/collects/slatex/slatex-code/codeset.scm deleted file mode 100644 index 56a81074..00000000 --- a/collects/slatex/slatex-code/codeset.scm +++ /dev/null @@ -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*))))) - ) diff --git a/collects/slatex/slatex-code/config.dat b/collects/slatex/slatex-code/config.dat deleted file mode 100644 index 63697a3f..00000000 --- a/collects/slatex/slatex-code/config.dat +++ /dev/null @@ -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 diff --git a/collects/slatex/slatex-code/config.scm b/collects/slatex/slatex-code/config.scm deleted file mode 100644 index 01863cca..00000000 --- a/collects/slatex/slatex-code/config.scm +++ /dev/null @@ -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")) diff --git a/collects/slatex/slatex-code/copying b/collects/slatex/slatex-code/copying deleted file mode 100644 index 43785311..00000000 --- a/collects/slatex/slatex-code/copying +++ /dev/null @@ -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 diff --git a/collects/slatex/slatex-code/defaults.scm b/collects/slatex/slatex-code/defaults.scm deleted file mode 100644 index 87908664..00000000 --- a/collects/slatex/slatex-code/defaults.scm +++ /dev/null @@ -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* "") - ) diff --git a/collects/slatex/slatex-code/defun.tex b/collects/slatex/slatex-code/defun.tex deleted file mode 100644 index 6eb02b40..00000000 --- a/collects/slatex/slatex-code/defun.tex +++ /dev/null @@ -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}}}}} - diff --git a/collects/slatex/slatex-code/fileproc.scm b/collects/slatex/slatex-code/fileproc.scm deleted file mode 100644 index 64a4d418..00000000 --- a/collects/slatex/slatex-code/fileproc.scm +++ /dev/null @@ -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)))) diff --git a/collects/slatex/slatex-code/helpers.scm b/collects/slatex/slatex-code/helpers.scm deleted file mode 100644 index 05961f55..00000000 --- a/collects/slatex/slatex-code/helpers.scm +++ /dev/null @@ -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))))) - - ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/history b/collects/slatex/slatex-code/history deleted file mode 100644 index 4b193be2..00000000 --- a/collects/slatex/slatex-code/history +++ /dev/null @@ -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 diff --git a/collects/slatex/slatex-code/index.tex b/collects/slatex/slatex-code/index.tex deleted file mode 100644 index 98a752ed..00000000 --- a/collects/slatex/slatex-code/index.tex +++ /dev/null @@ -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 diff --git a/collects/slatex/slatex-code/install b/collects/slatex/slatex-code/install deleted file mode 100644 index e26c06f0..00000000 --- a/collects/slatex/slatex-code/install +++ /dev/null @@ -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* ) - -(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 ) - -when you need to call SLaTeX on the (La)TeX file -. This invokes the SLaTeX preprocessor on -. 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 ) - -(In shell scripts, 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 \ No newline at end of file diff --git a/collects/slatex/slatex-code/lerror.scm b/collects/slatex/slatex-code/lerror.scm deleted file mode 100644 index 4cc2b67a..00000000 --- a/collects/slatex/slatex-code/lerror.scm +++ /dev/null @@ -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))))) diff --git a/collects/slatex/slatex-code/manifest b/collects/slatex/slatex-code/manifest deleted file mode 100644 index 1fd1322c..00000000 --- a/collects/slatex/slatex-code/manifest +++ /dev/null @@ -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 diff --git a/collects/slatex/slatex-code/margins.tex b/collects/slatex/slatex-code/margins.tex deleted file mode 100644 index f793025a..00000000 --- a/collects/slatex/slatex-code/margins.tex +++ /dev/null @@ -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} - - diff --git a/collects/slatex/slatex-code/pathproc.scm b/collects/slatex/slatex-code/pathproc.scm deleted file mode 100644 index fb720672..00000000 --- a/collects/slatex/slatex-code/pathproc.scm +++ /dev/null @@ -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))) - - ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/peephole.scm b/collects/slatex/slatex-code/peephole.scm deleted file mode 100644 index 92afb6a5..00000000 --- a/collects/slatex/slatex-code/peephole.scm +++ /dev/null @@ -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) "e-space)) - (setf (of curr =space / i) "e-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 - "e-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 - "e-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 - "e-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))) - ) diff --git a/collects/slatex/slatex-code/preproc.lsp b/collects/slatex/slatex-code/preproc.lsp deleted file mode 100644 index 27137b68..00000000 --- a/collects/slatex/slatex-code/preproc.lsp +++ /dev/null @@ -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)))) diff --git a/collects/slatex/slatex-code/preproc.scm b/collects/slatex/slatex-code/preproc.scm deleted file mode 100644 index 2a65d57c..00000000 --- a/collects/slatex/slatex-code/preproc.scm +++ /dev/null @@ -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))) diff --git a/collects/slatex/slatex-code/proctex.scm b/collects/slatex/slatex-code/proctex.scm deleted file mode 100644 index 692bec75..00000000 --- a/collects/slatex/slatex-code/proctex.scm +++ /dev/null @@ -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 - ) diff --git a/collects/slatex/slatex-code/proctex2.scm b/collects/slatex/slatex-code/proctex2.scm deleted file mode 100644 index c80f7338..00000000 --- a/collects/slatex/slatex-code/proctex2.scm +++ /dev/null @@ -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))))))) - ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/s4.scm b/collects/slatex/slatex-code/s4.scm deleted file mode 100644 index b93e62ff..00000000 --- a/collects/slatex/slatex-code/s4.scm +++ /dev/null @@ -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)) - - )) diff --git a/collects/slatex/slatex-code/seqprocs.scm b/collects/slatex/slatex-code/seqprocs.scm deleted file mode 100644 index 5336fa68..00000000 --- a/collects/slatex/slatex-code/seqprocs.scm +++ /dev/null @@ -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)) - - )) diff --git a/collects/slatex/slatex-code/slaconfg.lsp b/collects/slatex/slatex-code/slaconfg.lsp deleted file mode 100644 index aaf86417..00000000 --- a/collects/slatex/slatex-code/slaconfg.lsp +++ /dev/null @@ -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.~%~%") diff --git a/collects/slatex/slatex-code/slaconfg.scm b/collects/slatex/slatex-code/slaconfg.scm deleted file mode 100644 index 81ea0879..00000000 --- a/collects/slatex/slatex-code/slaconfg.scm +++ /dev/null @@ -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) diff --git a/collects/slatex/slatex-code/slatex.sty b/collects/slatex/slatex-code/slatex.sty deleted file mode 100644 index 522640c9..00000000 --- a/collects/slatex/slatex-code/slatex.sty +++ /dev/null @@ -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...text... comments out -% TeX source analogous to -% \verb...text.... 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{} -% .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? ***} diff --git a/collects/slatex/slatex-code/slatxdoc.dvi b/collects/slatex/slatex-code/slatxdoc.dvi deleted file mode 100644 index 24f06604..00000000 Binary files a/collects/slatex/slatex-code/slatxdoc.dvi and /dev/null differ diff --git a/collects/slatex/slatex-code/slatxdoc.tex b/collects/slatex/slatex-code/slatxdoc.tex deleted file mode 100644 index 927f93e0..00000000 --- a/collects/slatex/slatex-code/slatxdoc.tex +++ /dev/null @@ -1,1777 +0,0 @@ -%slatxdoc.tex -%SLaTeX Version 2.4 -%Documentation for SLaTeX -%(c) Dorai Sitaram -%dorai@cs.rice.edu - -\input slatex.sty - -\slatexdisable{enableslatex} -\input tex2html -\magnification\magstephalf - -%\advance\hoffset -.1true in -%\advance\voffset -.1 true in -%\advance\hsize .2 true in -%\advance\vsize .2 true in - -\input 8pt -\input 2col -\input defun - -%%%% other definitions - -%\frenchspacing - -% color, if possible - -\InputIfFileExists{colordvi}{}{\let\Red\relax -\let\Blue\relax -\let\Green\relax} - -%\def\section{\bigbreak\begingroup\noindent\bf -%\def\par{\endgroup\nobreak\smallskip}} - -\def\bs{{\tt\char`\\}} -\def\{{\ifmmode\lbrace\else$\lbrace$\fi} -\def\}{\ifmmode\rbrace\else$\rbrace$\fi} - -% sans-serif - -\font\sf cmss10 - -% \newcheapcount\bibitemnumber - -% \def\bibitem{\par\globaladvancecheapcount\bibitemnumber 1% -% \edef\recentlabel{\bibitemnumber}% -% [\bibitemnumber]\label} - -% -\overfullrule 0pt - -%\parindent1.5em -\pretolerance0 -\tolerance4000 - -%\raggedbottom - -\hyphenation{def-sla-tex-env-style dorai env-name -kyo-to left-code-skip right-code-skip -scheme-case-sen-si-tive scheme-dis-play scheme-in-put -scheme-re-gion scheme-re-sponse-box scheme-re-sult SLaTeX} - -% glossary items - -\def\re{\defun{}} - -\def\wideline{\par\centerline{\hrulefill}\par} - -\let\footnotehook\eightpoint -\hyphenchar\eighttt=-1 - -% abbrevs - -\let\n\noindent -\let\f\numfootnote - -%\packindex - -\leftcodeskip\parindent - -\enableslatex - -\centerline{How to Use SLaTeX} - -\bigskip - -\centerline{Dorai Sitaram} -\centerline{{\tt dorai@cs.rice.edu}} -\centerline{Department of Computer Science} -\centerline{Rice University} -\centerline{Houston, TX 77251-1892} - -\bigskip - -SLaTeX \index{introduction} is a Scheme program that allows -you to write programs or program fragments ``as is'' in your -TeX or LaTeX source. It is particularly geared to the -programming languages Scheme and other Lisps, e.g., Common -Lisp. The formatting of the code includes assigning -appropriate fonts and colors 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 Common Lisp -respectively. These can be modified by the user with easy -TeX commands. In addition, the user can tell SLaTeX to -typeset certain identifiers as specially suited TeX -expressions (i.e., beyond just fonting them). All this is -done without interfering with the identifier conventions of -the language of the programming code. In sum, no change -need be made to your (presumably running) program code in -order to get a typeset version with a desired look: You can -get a spectrum of styles ranging from {\it no\/} fonting -through basic default fonting to various -``math\-e\-mat\-i\-cal''-looking output for pedagogic or -other reasons. - -Popular packages for typesetting Scheme code, e.g., -Queinnec's LiSP2TeX~\cite{lisp2tex} -and Ramsdell's SchemeWeb~\cite{schemeweb}, use -a {\tt verbatim}-like environment -where all the characters are in a {\tt monospace typewriter} -font. While the {\tt monospace} ensures that the indentation -is not affected, it fails to distinguish between the various -tokens used in the code. On the other hand, SLaTeX can -font- or even color-code\f{To get color, you need a dvi -driver such as Rokicki's {\tt dvips} and a color printer. If -you don't have a color printer, you can still view your -color-coded document on screen, but will have to settle for -grayscaling on your paper output.} the tokens, e.g., {\bf -boldface} and/or red for keywords like \scheme{define} and -\scheme{lambda}, {\sf sans-serif} and/or green for -constants like \scheme{#t} and \scheme{42}, and {\it italics\/} -and/or blue for variables such as -\scheme{x} and \scheme{y} in \scheme{(lambda (x y) -(cons x (cons y '())))}. SLaTeX provides a -convenient way of capturing the indentation -information as well as assigning distinguishing fonts -to code tokens without requiring the user to worry -about fonting and spacing. It uses temporary files -to store its typeset version of the user's code -fragments and then calls TeX or LaTeX on the user's -TeX files as well as these temporaries. - -\slatexdisable{enableslatex} - -The rest of this manual has the following outline: -section~\ref{intro-example} introduces a small example -that covers the SLaTeX control sequences you will need -the most. Both LaTeX~\cite{latex} and plain -TeX~\cite{tex} versions are -shown. Section~\ref{slatex-sty-files} describes the -SLaTeX style files {\tt slatex.sty} and {\tt cltl.sty}. -Section~\ref{glossary} provides a complete description -of all the SLaTeX control sequences. These include -commands for manipulating output positioning, enhancing -the database, changing the fonting defaults, adding -special symbols, and selective disabling of -SLaTeX. Section~\ref{preamble} offers guidelines for -setting up a preamble that reflects your typesetting -taste. Section~\ref{ftp} contains information on -obtaining and installing SLaTeX. - -\section{Introductory example} -\label{intro-example} - -\index{quick introduction} -We now present a short text that illustrates the -most basic features of SLaTeX. Luckily, these -cover the commands you will need and use the most. -There are a couple of minor differences between the -ways SLaTeX is used in LaTeX and in plain TeX (but -see the entry in section~\ref{glossary} for \p{\defslatexenvstyle} if -you wish to use the plain-TeX style with the LaTeX -format, or the LaTeX style with the plain format). - -\subsection{SLaTeX for LaTeX users} - -\index{LaTeX} -\index{scheme@{\tt\bs scheme}} -\index{schemedisplay@{\tt\{schemedisplay\}}!in LaTeX} -\index{in-text Scheme code} -\index{displayed Scheme code} -\index{slatex.sty@{\tt slatex.sty}} -\index{slatex.sty@{\tt slatex.sty}!as document style} -Consider the following LaTeX ({\it and\/} -SLaTeX) file -{\tt quick.tex}: - -\goodbreak - ---- - -\verbatim+ -% quick.tex -\documentclass{article} -\usepackage{slatex} -% -%That was LaTeX2e. If you use -%LaTeX2.09, or LaTeX2e in -%2.09 compatibility mode, use -% -%\documentstyle[slatex]{article} -% -%or -% -%\documentstyle{article} -%\input slatex.sty -\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 x a) - (begin (set! x a) - x)])) -\end{schemedisplay} - -\end{document} -+ - ---- - -First, the SLaTeX definitions in the style file -{\tt slatex.sty} are loaded into your LaTeX file. This may -be done either via \p{\usepackage} or -\p{\input} --- or, if you use LaTeX 2.09, as a -\p{\documentstyle} option. - -\index{scheme@{\tt\bs scheme}!using grouped argument} - -In-text code is introduced by the SLaTeX control -sequence \p{\scheme} and is flanked by a pair of -identical characters that are not alphabetic letters -or ``\p|{|''. As a special convenient case, -SLaTeX also allows the form \p{\scheme{...}}. - -The SLaTeX control sequences for -displayed code are the opening - -\verbatim{ -\begin{schemedisplay} -} - -\n and the closing - -\verbatim{ -\end{schemedisplay} -} - -The file is now SLaTeX'd by running the command {\tt slatex} -on it from the Unix or DOS or OS/2 command -line: - -\verbatim{ -slatex quick -} - -\n or - -\verbatim{ -slatex quick.tex -} - -\n Alternatively, you can load the file {\tt callsla.scm} into -your Scheme or Common Lisp, and then call - -\verbatim{ -(call-slatex "quick") -} - -\n This calls a Scheme program {\tt slatex.scm} that -typesets the Scheme code fragments from {\tt quick.tex} into -temporary files. Thereafter, {\tt quick.tex} along with the -temporary files are passed -to LaTeX. (For information on judiciously -reusing temporary files, see -\p{\separateincludes}.) -The resulting -{\tt quick.dvi} file, when viewed or printed, looks like: - -\enableslatex - ---- - -\n -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 - ---- - -\index{recognizing new syntactic keywords automatically} - -Note that \scheme{setq}, although not normally a -syntactic keyword in Scheme, is nevertheless -automatically recognized as such because of the context -in which it occurs. No special treatment is needed to -ensure that it will continue be treated as such in any -subsequent Scheme code in the document. -\slatexdisable{enableslatex} - -\subsection{SLaTeX for plain TeX users} - -\index{plain TeX} -\index{scheme@{\tt\bs scheme}} -\index{schemedisplay@{\tt\{schemedisplay\}}!in plain TeX} -\index{in-text Scheme code} -\index{displayed Scheme code} -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 -{\tt slatex.sty} must be introduced via an \p{\input} -statement before its commands can be used in the plain -TeX source. - -\index{environments} - -Second, since plain TeX does not have LaTeX's -\p|\begin{|{\it env\/}\p|} ... \end{|{\it env\/}\p|}| -style of environments, any -environment commands in SLaTeX are invoked with the -opening \p{\}{\it env\/} and the closing -\p{\end}{\it env}. - -The plain TeX version of {\tt quick.tex} looks like: - ---- - -\verbatim+ -% 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 {\tt 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{The SLaTeX style files} -\label{slatex-sty-files} - -\index{slatex.sty@{\tt slatex.sty}} -The LaTeX (or TeX) file that is given to SLaTeX -undergoes some code-setting preprocessing and is then -handed over to LaTeX (or TeX). The style file -{\tt slatex.sty} defines the appropriate commands so that -LaTeX (or TeX) can recognize the SLaTeX-specific -directives and deal with them appropriately. As -mentioned above, you may -either \p{\input} the file {\tt slatex.sty}, -or use it as the \p{\documentstyle} option -{\tt slatex}. - -\index{cltl.sty@{\tt cltl.sty}} -\index{SLaTeX database!for Scheme} -\index{SLaTeX database!for Common Lisp} -\index{SLaTeX database!modifying} - -The default database of SLaTeX recognizes the keywords -and constants of Scheme. The database can be modified -with the commands \p{\setkeyword}, -\p{\setconstant}, \p{\setvariable}, -\p{\setdata}, -\p{\setspecialsymbol} and \p{\unsetspecialsymbol} -(q.v.). If you're using Common Lisp rather than -Scheme, use {\tt cltl.sty} instead of {\tt slatex.sty}. -{\tt cltl.sty} loads {\tt slatex.sty} and modifies the -database to reflect Common Lisp. You may also fashion your -own {\tt .sty} files on the model of {\tt cltl.sty}. - -\section{SLaTeX's control sequences} -\label{glossary} - -\index{SLaTeX control sequences} -You've already seen the SLaTeX control sequence -\p{\scheme} and the environment -\p{{schemedisplay}}.\f{The notation -\p|{|{\it envname\/}\p|}| -is used to denote an environment -named {\it envname}. Usually, in plain TeX, this is the pair -\p{\}{\it envname\/} and \p{\end}{\it envname}, while in -LaTeX, it is the environment formed with -\p|\begin{|{\it envname\/}\p|}| and -\p|\end{|{\it envname\/}\p|}|. -But see -\p{\defslatexenvstyle}.} These suffice for quite a -few instances of handling code. However, you will -occasionally require more control on the typesetting -process. To help you in such situations, here is a -complete\f{At least that's what you're supposed to -think~\dots} list of SLaTeX control sequences with -examples. - -\re{\p{{schemedisplay}}} -\index{schemedisplay@{\tt\{schemedisplay\}}} -\index{displayed Scheme code} - -Typesets the enclosed code, which is typically several -lines of code indented as is common in Scheme files. E.g., - -\verbatim{ -\begin{schemedisplay} -(define compose - ;this is also known as $B$ - (lambda (f g) - (lambda (x) - (apply f (g x))))) -\end{schemedisplay} -is the ``compose'' function. -} - -\n produces - -\enableslatex -\schemedisplay -(define compose - ;this is also known as $B$ - (lambda (f g) - (lambda (x) - (apply f (g x))))) -\endschemedisplay -is the ``compose'' function. -\slatexdisable{enableslatex} - -As with all LaTeX environment enders, if the line -after \p{\end{schemedisplay}} contains -non-whitespace text, the paragraph continues. -Otherwise --- i.e., when \p{\end{schemedisplay}} -is followed by at least one blank line --- a fresh -paragraph is started. Similarly, in plain TeX, a -fresh paragraph is started after a -\p{{schemedisplay}} only if -\p{\endschemedisplay} is followed by at least one -blank line. - -\index{Scheme comments} - -Comments in Scheme are usually introduced by ``{\tt ;}'' -(semicolon). The rest of the line after a ``{\tt ;}'' -is set in paragraph mode. - -\index{TeX paragraphs amidst Scheme code} - -Separate {\it blocks\/} of code can either be -introduced in different \p{{schemedisplay}} -environments or put in a single -\p{{schemedisplay}} and separated by a line with a -``{\tt ;}'' in the first column. This ``{\tt ;}'' is -not typeset and anything following it on the line is -set in paragraph mode. Consecutive lines with ``{\tt ;}'' in -the first column are treated as input for a -TeX paragraph, with words possibly moved around from -line to line to ensure justification. When in -paragraph mode, the first line that has {\it no\/} -leading ``{\tt ;}'' signals a fresh block of Scheme -code within the \p{{schemedisplay}}. (The -\p{{schemedisplay}} may end, or commence, on -either a paragraph or a Scheme code block.) - -E.g., - -\verbatim{ -\begin{schemedisplay} -(define even? - ;testing evenness - (lambda (n) - (if (= n 0) #t - (not (odd? (- n 1)))) - )) -; The procedures {\it even?\/} -; above and {\it odd?\/} below -; are mutually recursive. -(define odd? - ;testing oddness - (lambda (n) - (if (= n 0) #f - (not (even? (- n 1)))) - )) -\end{schemedisplay} -} - -\n produces - -\enableslatex -\schemedisplay -(define even? - ;testing evenness - (lambda (n) - (if (= n 0) #t - (not (odd? (- n 1)))) - )) -; The procedures {\it even?\/} -; above and {\it odd?\/} below -; are mutually recursive. -(define odd? - ;testing oddness - (lambda (n) - (if (= n 0) #f - (not (even? (- n 1)))) - )) -\endschemedisplay - -\slatexdisable{enableslatex} -SLaTeX can recognize that blocks of code are separate -if you have at least one empty line separating them. -I.e., there is no need for empty ``{\tt ;}'' lines. -This convenience is to accommodate Scheme files where -definitions are usually separated by one or more -blank lines. - -\index{schemedisplay@{\tt\{schemedisplay\}}!allowing page -breaks in} - -Intervening paragraphs, either with lines with a -leading ``{\tt ;}'', or with blank lines, are ideal -spots for \p{{schemedisplay}} to allow pagebreaks. -In fact, the default setting for -\p{{schemedisplay}} also allows pagebreaks {\it within\/} a -Scheme block, but it is easy to disable -this (see entry for -\p{\rightcodeskip}). - -{\tolerance100000 The space surrounding displayed -Scheme code can be modified by setting the {\it skips\/} -\p{\abovecodeskip}, \p{\belowcodeskip}, \p{\leftcodeskip}, -and \p{\rightcodeskip} (q.v.).\par} - -Note: see \p{{schemeregion}}. - -\re{\p{{schemeresponse}}} -\index{schemeresponse@{\tt\{schemeresponse\}}} -\index{displayed Scheme result} - -This is like \p{{schemedisplay}}, except that the -code is displayed as the output of a Scheme -evaluation, i.e., as data. In other words, keyword -and variable fonts are disabled. - -Note: see \p{\schemeresult} and -\p{{schemeresponsebox}}. - -\re{\p{\scheme}} -\index{scheme@{\tt\bs scheme}} -\index{in-text Scheme code} - -{\tolerance100000 Typesets its argument, which is -enclosed in arbitrary but identical non-alphabetic and -non-\p|{| characters, as in-text code. Special case: -\p{\scheme{...}} is a convenience (provided the `\p{...}'\ -doesn't contain a `\p|}|'). E.g., \p+\scheme|(call/cc+ -\p+(lambda (x) x))|+ and \p+\scheme{(call/cc+ \p+(lambda (x) -x))}+ both produce -\enableslatex -\scheme{(call/cc (lambda (x) x))}. -\slatexdisable{enableslatex} -\index{scheme@{\tt\bs scheme}!using grouped argument} -\par} - -\index{nesting SLaTeX control sequences} -It {\it is\/} permitted to intermix calls to -\p{{schemedisplay}} and -\p{\scheme}. Thus, - -\verbatim{ -\begin{schemedisplay} -(define factorial - (lambda (n) - (if (= n 0) - ;\scheme{(zero? n)} - ;also possible - 1 (* n (factorial - (- n 1)))))) - ;or \scheme{... (sub1 1)} -\end{schemedisplay} -} - -\n produces - -\enableslatex -\schemedisplay -(define factorial - (lambda (n) - (if (= n 0) - ;\scheme{(zero? n)} - ;also possible - 1 (* n (factorial - (- n 1)))))) - ;or \scheme{... (sub1 1)} -\endschemedisplay - -\slatexdisable{enableslatex} -Note: see \p{{schemeregion}}. - -\re{\p{\schemeresult}} -\index{schemeresult@{\tt\bs schemeresult}} - -Typesets its argument, which is enclosed in arbitrary -but identical non-alphabetic and non-\p|{| -characters, as in-text Scheme ``result'' or data: -i.e., keyword and variable fonts are disabled. -Special convenient case (as for \p{\scheme}): -\p{\schemeresult{...}}. E.g., -\index{schemeresult@{\tt\bs schemeresult}!using grouped argument} - -\verbatim+ -\scheme|((lambda () (cons 'lambda -'cons)))| yields -\schemeresult|(lambda . cons)|. -+ - -\n produces - -\enableslatex -\scheme|((lambda () (cons 'lambda -'cons)))| yields -\schemeresult|(lambda . cons)|. -\slatexdisable{enableslatex} - -\re{\p{{schemebox}}} -\index{schemebox@{\tt\{schemebox\}}} -\index{boxed Scheme code} - -The \p{{schemebox}} environment is similar to -\p{{schemedisplay}} except that the code is -provided as a ``box'' (i.e., it is not ``displayed'' -in the standard way). Indeed, when the appropriate -skip parameters are set, \p{{schemedisplay}} -itself {\it may\/}\f{Yes, {\it may\/}: Not all -\p{{schemedisplay}}s invoke \p{{schemebox}}, -and if you're curious why, see entry for -\p{\rightcodeskip}. It is a matter of whether -pagebreaks within Scheme code are allowed or not.} -use a \p{{schemebox}} to create a box of code that -is set off with all-round space as a display. - -Saving a \p{{schemebox}} in an explicit box allows you -to move your typeset code arbitrarily. - -Note: see \p{{schemeregion}}. - -\re{\p{{schemeresponsebox}}} -\index{schemeresponsebox@{\tt\{schemeresponsebox\}}} - -This is like \p{{schemebox}}, except that the -contents are displayed as Scheme data. See also -\p{\schemeresult} and \p{{schemeresponse}}. - -\re{\p{\schemeinput}} -\index{schemeinput@{\tt\bs schemeinput}} -\index{inputting Scheme files as is} - -This can be used to input Scheme files as typeset code. -(Unlike (La)TeX's \p{\input}, \p{\schemeinput}'s -argument must always be grouped.) The Scheme file can -be specified either by its full name, or without its -extension, if the latter is \p{.scm}, \p{.ss} or -\p{.s}. E.g., - -\verbatim{ -\schemeinput{evenodd.scm} -% the .scm is optional! -} - -\n {\tolerance100000 (where \p{evenodd.scm} is the -name of a Scheme file containing the code for -\enableslatex -\scheme{even?} and \scheme{odd?} above) produces the same -effect as the -\slatexdisable{enableslatex} -\p{{schemedisplay}} version.\par} - -Note: see \p{{schemeregion}}. - -\re{\p{{schemeregion}}} -\index{schemeregion@{\tt\{schemeregion\}}} -\index{nesting SLaTeX control sequences} - -{\tolerance100000 -Calls to \p{\scheme}, \p{\schemeresult}, -\p{{schemedisplay}}, \p{{schemebox}} or -\p{\schemeinput} can be nested in (a Scheme comment) -of other calls. In (La)TeX source, they can occur in -bodies of environments or be otherwise grouped. -However, they cannot normally be passed as arguments to -macros or included in bodies of macro definitions (even -though these are complete calls and not parameterized -with respect to macro arguments). To be able to do -these things, you should first cordon off such a text with -the -\p{{schemeregion}} environment. SLaTeX is fairly -generous about where exactly you throw the cordon.\par} - -E.g., you cannot have - -\verbatim{ -... -The code fragment $\underline -{\hbox{\scheme{(call/cc I)}}}$ is ... -... -} - -\n but you {\it can\/} have - -\verbatim{ -\begin{schemeregion} -... -The code fragment $\underline -{\hbox{\scheme{(call/cc I)}}}$ is ... -... -\end{schemeregion} -} - -\n and this will produce - -\enableslatex -\schemeregion -\dots - -The code fragment $\underline -{\hbox{\scheme{(call/cc I)}}}$ is \dots - -\dots -\endschemeregion -\slatexdisable{enableslatex} - -Thus, the \p{{schemeregion}} environment makes it -possible to put SLaTeX-specific commands inside macro -arguments or macro definitions without causing -rupture. Normally, this can't be done since once -SLaTeX is done preprocessing your text, all -SLaTeX-specific commands correspond to \p{comment}-like -regions --- the actual typeset code is -in an external, temporary file. These \p{comment} -regions share the characteristic of LaTeX's {\tt verbatim} -regions, which also can't appear in macro -arguments or definitions. - -To solve this, you enclose the offending text in a -\p{{schemeregion}} environment. This ``inlines'' -all the the enclosed calls to SLaTeX as actual -typeset code instead of treating such calls as \p{comment} -regions --- thus escaping the fate described -above. A \p{{schemeregion}} is a perfect no-op as -far as the enclosed {\it non\/}-SLaTeX commands are -concerned. - -However, while a \p{{schemeregion}} allows its -enclosed SLaTeX commands to be included in macro -arguments and bodies, it itself cannot be so -included. This is because \p{{schemeregion}} is -now a super-\p{comment}. The solution is simple: -just pull the \p{{schemeregion}} cordon as outward -as possible so that all the SLaTeX calls that you -need treated specially are enclosed. A safe approach -is to call \p{{schemeregion}} at the ``top -level'', i.e., outside any nesting of groups --- it -does not hurt that the cordon is too wide. Indeed, -you may even wrap each of your TeX files in one huge -\p{{schemeregion}} if you so wish. This will cover -any obscure ``non-robust''\f{The term ``robust'' is not -necessarily used in the same sense as in the LaTeX manual -(Lamport).} use of the SLaTeX primitives --- the only -downside is that SLaTeX may run slower. - -Note: TeX files that are loaded using \p{\input} -from within a \p{{schemeregion}} will not -automatically inherit the robust lifestyle. A SLaTeX -command is made robust only by an enclosing -\p{{schemeregion}} {\it in the same file as -itself}. In other words, region markers have textual -or ``lexical'' scope, not ``dynamic'' scope. - -\re{\p{\setkeyword} -\p{\setconstant} -\p{\setvariable} -\p{\setdata}} -\index{setkeyword@{\tt\bs setkeyword}} -\index{setconstant@{\tt\bs setconstant}} -\index{setvariable@{\tt\bs setvariable}} -\index{setdata@{\tt\bs setdata}} -\index{SLaTeX database!modifying} - -SLaTeX has a database containing information about -which code tokens are to be treated as {\bf keywords}, -which as {\sf constants}, which as {\it variables}, and -which as {\sf data}. However, it is very likely that -you will want to add your own tokens to these -categories. The control sequences that enable you to -do this are \p{\setkeyword}, -\p{\setconstant}, -\p{\setvariable}, and \p{\setdata}. Their arguments are entered -as a (space-separated) list enclosed in braces -(\p{{}}): SLaTeX learns that these are henceforth to -be typeset in the appropriate category. E.g., - -\enableslatex -\verbatim{ -\setconstant{infinity -infinity} -} - -\n tells SLaTeX that \scheme{infinity} and -\scheme{-infinity} are to be typeset as constants. -\slatexdisable{enableslatex} - -\index{recognizing new syntactic keywords automatically} - -The user need not use \p{\setkeyword} to specify such -new keywords as are introduced by Scheme's and Common -Lisp's syntactic definition facilities -\enableslatex -(\scheme{define-syntax}/\scheme{syntax-rules}, -\scheme{defmacro}, \scheme{extend-syntax}, -\scheme{define-macro!}.) SLaTeX automatically recognizes -new macros and auxiliary keywords defined using these -facilities. -\slatexdisable{enableslatex} - -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. - -\re{\p{\setspecialsymbol} -\p{\unsetspecialsymbol}} -\index{setspecialsymbol@{\tt\bs setspecialsymbol}} -\index{unsetspecialsymbol@{\tt\bs unsetspecialsymbol}} -\index{SLaTeX database!modifying} -\index{recognizing special symbols} - -These commands are useful to generate -``math\-e\-mat\-i\-cal''-looking typeset versions of -your code, over and beyond the fonting capabilities -provided by default. 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, you -might want all occurrences of \p{lambda}, \p{and}, -\p{equiv?}, \p{below?}, \p{above?}, \p{a1} and \p{a2} in -your code to be typeset as -$\lambda$, $\land$, $\equiv$, $\subseteq$, -$\supseteq$, $a_1$ and $a_2$ respectively. To do -this, you should \p{\setspecialsymbol} the -concerned identifier to the desired TeX expansion, -viz., - -\enableslatex -\verbatim{ -\setspecialsymbol{lambda}{$\lambda$} -\setspecialsymbol{and}{$\land$} -\setspecialsymbol{equiv?}{$\equiv$} -\setspecialsymbol{below?}{$\subseteq$} -\setspecialsymbol{above?}{$\supseteq$} -\setspecialsymbol{a1}{$a_1$} -\setspecialsymbol{a2}{$a_2$} -} - -\n Now, typing\slatexdisable{enableslatex} - -\verbatim{ -\begin{schemedisplay} -(define equiv? - (lambda (a1 a2) - (and (below? a1 a2) - (above? a1 a2)))) -\end{schemedisplay} -} - -\n produces - -\enableslatex -\schemedisplay -(define equiv? - (lambda (a1 a2) - (and (below? a1 a2) - (above? a1 a2)))) -\endschemedisplay -Note\slatexdisable{enableslatex} that with the above -settings, \p{lambda} and \p{and} have lost their -default keyword status, i.e., they will not be typed -{\bf boldface}. To retrieve the original status of -special symbols, you should use -\p{\unsetspecialsymbol}, e.g., - -\enableslatex -\verbatim{ -\unsetspecialsymbol{lambda and} -} - -\n Typing the same program after unsetting the -special symbols as above produces, as expected: - -\schemedisplay -(define equiv? - (lambda (a1 a2) - (and (below? a1 a2) (above? a1 a2)))) -\endschemedisplay - -In effect, \slatexdisable{enableslatex} -\p{\setspecialsymbol} extends the -basic ``fonting'' capability to arbitrarily special -typeset versions. - -\re{\p{\schemecasesensitive}} -\index{schemecasesensitive@{\tt\bs schemecasesensitive}} -\index{case sensitivity} - -SLaTeX always typesets output that is of the same case -as your input, regardless of the setting of the -\p{\schemecasesensitive} command. However, this command -can be used to signal to SLaTeX that all case variations of -an identifier are to be treated identically. E.g., typing -\p{\schemecasesensitive{false}} ensures -that \p{lambda}, \p{lambda} and \p{lambda} will -all be treated as keywords, just as \p{lambda}. -\p{\schemecasesensitive{true}} reverts to the -default mode where case is significant in determining -the class of a token. - -Note that the status \p{\schemecasesensitive} also -affects the ``special symbols'' of the previous item. -Thus, in the default case-{\it sensitive\/} setting, only the -case-significant symbol as mentioned in the call to -\p{\setspecialsymbol} will be replaced by the -corresponding TeX expansion. In a case-{\it in\/}sensitive -setting, all case variations of the special symbol will -be replaced. - -\re{\p{\abovecodeskip} -\p{\belowcodeskip} -\p{\leftcodeskip} -\p{\rightcodeskip}} -\index{abovecodeskip@{\tt\bs abovecodeskip}} -\index{belowcodeskip@{\tt\bs belowcodeskip}} -\index{leftcodeskip@{\tt\bs leftcodeskip}} -\index{rightcodeskip@{\tt\bs rightcodeskip}} -\index{schemedisplay@{\tt\{schemedisplay\}}!adjusting display parameters} - -These are the parameters used by \p{{schemedisplay}} for -positioning displayed code. The default values are - -\verbatim{ -\abovecodeskip \medskipamount -\belowcodeskip \medskipamount -\leftcodeskip 0pt -\rightcodeskip 0pt -} - -\n This produces a flushleft display. The defaults can be -changed to get new display styles. E.g., this manual -sets - -\verbatim{ -\leftcodeskip\parindent -} - -\n which shifts the display from the left by the same -amount as a paragraph indentation. - -\index{schemedisplay@{\tt\{schemedisplay\}}!allowing page -breaks in} -\index{schemedisplay@{\tt\{schemedisplay\}}!disallowing -pagebreaks in} - -In both the above cases, the \p{{schemedisplay}} -environment will be broken naturally across page -boundaries at the right spot if the code is too long to -fit a single page. In fact, automatic pagebreaks -within the Scheme code are allowed if and only if -\p{\rightcodeskip} is 0pt (its default value). For -all other values of \p{\rightcodeskip}, each Scheme -code block in a \p{{schemedisplay}} is guaranteed -to be on the same page. If you have decided on a left -indentation, and you're not sure what value to give to -\p{\rightcodeskip}, but nevertheless don't want -Scheme code broken across pages, you could set - -\verbatim{ -\rightcodeskip=0.01pt %or -\rightcodeskip=0pt plus 1fil -} - -\n To understand why this would disable pagebreaks -within the Scheme block, suppose instead you'd set - -\verbatim{ -\leftcodeskip=0pt plus 1fil -\rightcodeskip=0pt plus 1fil -} - -\n This will get you a {\it centered\/} display style. -This is of course because the skip on each side of the -code produces a ``spring''\f{Springs, or rather -``glue'', are discussed in detail in {\em The -TeXbook}~\cite[pp.\ 70ff.]{tex}.} that -pushes the code to the center. But for this spring -action to work nicely, the code must have been -collected into an unbreakable box --- which is -precisely what -\p{{schemedisplay}} does for each of its code blocks -whenever it notices that the prevailing value of -\p{\rightcodeskip} is not the default -zero.\f{0pt plus 1fil $\ne$ 0pt} Clearly, such -unbreakable boxes cannot tolerate pagebreaks. - -Thus, the behind-the-scenes selective boxing dictates -whether a \p{{schemedisplay}} block can or cannot be -broken across a page boundary. And the value of -\p{\rightcodeskip} is used to govern this selection -in a ``reasonable'' manner. - -\re{\p{\keywordfont} -\p{\constantfont} -\p{\variablefont} -\p{\datafont}} -\index{keywordfont@{\tt\bs keywordfont}} -\index{constantfont@{\tt\bs constantfont}} -\index{variablefont@{\tt\bs variablefont}} -\index{datafont@{\tt\bs datafont}} -\index{specifying SLaTeX's fonts} - -These decide the typefaces used for keywords, -constants, variables, and data. The default -definitions are:\f{\p{\sf} in LaTeX is the -sans-serif font. Since plain TeX does not define -\p{\sf}, you may define one before -\p{\input}ing \p{slatex.sty}. If no \p{\sf} -is found, \p{slatex.sty} has \p{\let\sf=\rm}. You -may redefine it before or after to an appropriate -font of your choice. This manual set -\p{\font\sf=cmss10}. Of course, you could -redefine \p{\constantfont} itself to not rely on -(the name) \p{\sf}.} - -\verbatim{ -\def\keywordfont#1{{\bf#1}} -\def\constantfont#1{{\sf#1}} -\def\variablefont#1{{\it#1\/}} -\let\datafont\constantfont -} - -\n This is close to the {\em Little -Schemer}~\cite{tls,tss} style. -Redefine these control -sequences for font changes. As an extreme case, defining -all of them to -\p|{{\tt#1}}| typesets everything in monospace -typewriter font, as, for instance, in SICP~\cite{sicp}. - -Note that ``constants'' and ``data'' {\it can\/} be -distinguished, although by default SLaTeX does not do -so. Typically, primitive data such as booleans, -numbers, characters and strings are set as ``data''; -whereas quoted material is set as ``constant''. - -The control sequences \p{\keywordfont}, \&c., can be -defined to be anything at all, not just font switches. -For instance, if you use Rokicki's dvips, you can -use these SLaTeX sequences to color-code your programs! -Simply use: - -\begingroup -\def\keywordfont#1{\Red{#1}} -\def\variablefont#1{\Blue{#1}} -\def\constantfont#1{\Green{#1}} - -\verbatim{ -\input colordvi -\def\keywordfont#1{\Red{#1}} -\def\variablefont#1{\Blue{#1}} -\def\constantfont#1{\Green{#1}} -} - -\n The following example will appear in color if -you've processed this document with dvips and have a -color-capable viewer or printer: - -\enableslatex -\schemedisplay -(define factorial - (lambda (n) - (if (= n 0) 1 - (* n (+ n 1))))) -\endschemedisplay - -\endgroup\slatexdisable{enableslatex} - -\re{\p{\defschemedisplaytoken} -\p{\defschemetoken} -\p{\defschemeboxtoken} -\p{\defschemeresulttoken} -\p{\defschemeresponsetoken} -\p{\defschemeresponseboxtoken} -\p{\defschemeinputtoken} -\p{\defschemeregiontoken}} -\index{defschemedisplaytoken@{\tt\bs defschemedisplaytoken}} -\index{defschemetoken@{\tt\bs defschemetoken}} -\index{defschemeboxtoken@{\tt\bs defschemeboxtoken}} -\index{defschemeresulttoken@{\tt\bs defschemeresulttoken}} -\index{defschemeresponsetoken@{\tt\bs defschemeresponsetoken}} -\index{defschemeresponseboxtoken@{\tt\bs defschemeresponseboxtoken}} -\index{defschemeinputtoken@{\tt\bs defschemeinputtoken}} -\index{defschemeregiontoken@{\tt\bs defschemeregiontoken}} -\index{defining SLaTeX control sequences} - -These define the tokens used by SLaTeX to trigger -typesetting of in-text code, displayed code, boxed -code, Scheme program files and robust regions. The -default tokens are, as already described, -\p{{schemedisplay}}, \p{\scheme}, -\p{{schemebox}}, \p{\schemeresult}, -\p{{schemeresponse}}, \p{{schemeresponsebox}}, -\p{\schemeinput} and \p{{schemeregion}} -respectively. You can use the \p{\defscheme*token} -control sequences to get alternate tokens, e.g., -shorter or more mnemonic ones. Thus, -if you want \p{\code} to be -your new control sequence for in-text code, use -\p|\defschemetoken{code}|. All instances of -\p{\code+...+} after this definition produce -in-text code, unless overridden by an -\p{\undefschemetoken} command. - -One can have at any time any number of tokens for the -same activity. One consequence of this is that one can -have nested \p{{schemeregion}}s, provided one has -different names for the nested call. Otherwise, the -\p{\end} of an inner region will prematurely -terminate an outer region. - -\re{\p{\undefschemedisplaytoken} -\p{\undefschemetoken} -\p{\undefschemeboxtoken} -\p{\undefschemeresulttoken} -\p{\undefschemeresponsetoken} -\p{\undefschemeresponseboxtoken} -\p{\undefschemeinputtoken} -\p{\undefschemeregiontoken}} -\index{undefschemedisplaytoken@{\tt\bs undefschemedisplaytoken}} -\index{undefschemetoken@{\tt\bs undefschemetoken}} -\index{undefschemeboxtoken@{\tt\bs undefschemeboxtoken}} -\index{undefschemeresulttoken@{\tt\bs undefschemeresulttoken}} -\index{undefschemeresponsetoken@{\tt\bs undefschemeresponsetoken}} -\index{undefschemeresponseboxtoken@{\tt\bs undefschemeresponseboxtoken}} -\index{undefschemeinputtoken@{\tt\bs undefschemeinputtoken}} -\index{undefschemeregiontoken@{\tt\bs undefschemeregiontoken}} -\index{undefining SLaTeX control sequences} - -These {\it un\/}define the tokens used for triggering -the typesetting of in-text code, displayed code, boxed -code, Scheme program files, and robust regions. -Typically, tokens are undefined so you can use the -names for other purposes without tripping up the SLaTeX -system. - -\re{\p{\defschememathescape} -\p{\undefschememathescape}} -\index{defschememathescape@{\tt\bs defschememathescape}} -\index{undefschememathescape@{\tt\bs undefschememathescape}} -\index{TeX mathmode in SLaTeX} -\index{escape character for mathmode within Scheme} - -{\tolerance100000 -\p|\defschememathescape{$}| defines the character -\p{$} as a mathematical escape character to be used -within Scheme code. (Any character other than -\p|}| and whitespace may be chosen instead of -\p{$}.) This allows one to use TeX -mathematical subformulas within Scheme code, e.g.,\par} - -\verbatim{ -\defschememathescape{$} - -\begin{schemedisplay} -(define $\equiv$ - (lambda (a$_1$ a$_2$) - ($\land$ - ($\subseteq$ a$_1$ a$_2$) - ($\supseteq$ a$_1$ a$_2$)))) -\end{schemedisplay} -} - -\n produces - -\enableslatex -\defschememathescape{$} - -\schemedisplay -(define $\equiv$ - (lambda (a$_1$ a$_2$) - ($\land$ - ($\subseteq$ a$_1$ a$_2$) - ($\supseteq$ a$_1$ a$_2$)))) -\endschemedisplay -\undefschememathescape{$} -\slatexdisable{enableslatex} -\p|\undefschememathescape{$}| disables the -math-escape nature, if any, of \p{$}. - -\re{\p{\slatexdisable}} -\index{slatexdisable@{\tt\bs slatexdisable}} -\index{disabling SLaTeX} - -The tokens for typesetting code, as also the token -\p{\input} (which is sensitive to SLaTeX, since -the latter uses it to recursively process files within -files), can only be used as calls. If they occur in -the bodies of macro definitions, or their names are -used for defining other control sequences, SLaTeX could -misprocess them. Sometimes, one wants TeX to -\p{\input} a file, without wanting SLaTeX to process -the inputted file. Or the name -\p{\scheme} can occur in a verbatim environment, -and we don't want such an occurrence to cause SLaTeX to -look for and ``find'' Scheme code that is not really -there. - -Avoiding such uses altogether can be unduly -restrictive.\f{Especially when one is writing -a ``How to \dots'' manual like this where one both uses -{\it and\/} mentions the control sequences!} One way -out is to judiciously employ the -\p{\undefscheme*token} commands to temporarily -remove the SLaTeX-specificity of these names. Even -this can be painful. SLaTeX therefore provides the -command \p{\slatexdisable}. This takes one -argument word and makes the corresponding control -sequence out of it. Further, from this point in the -text, SLaTeX is disabled {\it until\/} the -manufactured control sequence shows up. This -mechanism makes it possible to restrict SLaTeX to only -appropriate portions of the text. Note that the token -\p{\slatexdisable} itself can appear in the text -succeeding its call. The only token that can restore -SLaTeX-sensitivity is the one created during the call -to \p{\slatexdisable}. - -The following is a typical example of the -\p{\slatexdisable} approach. You want the names -\p{\scheme} and -\p|\begin{schemedisplay}| in a {\tt verbatim} -environment: - -\verbatim{ -\slatexdisable{slatexenable} -\begin{verbatim} -SLaTeX provides the command \scheme -and the pair \begin{schemedisplay} -and \end{schemedisplay} to typeset -in-text and displayed Scheme code -respectively. -\end{verbatim} -\slatexenable -} - -\n produces the required - -\verbatim{ -SLaTeX provides the command \scheme -and the pair \begin{schemedisplay} -and \end{schemedisplay} to typeset -in-text and displayed Scheme code -respectively. -} - -\re{\p{\slatexignorecurrentfile}} -\index{slatexignorecurrentfile@{\tt\bs slatexignorecurrentfile}} -\index{disabling SLaTeX} - -This is a SLaTeX pragma included to improve efficiency. -If you're sure that the remaining portion of a certain -(La)TeX file (including the files that would be -\p{\input}ed by it) don't contain any SLaTeX -commands, then you may place this control sequence in -it at this point to signal SLaTeX that no preprocessing -is necessary for the rest of the file. - -\re{\p{\defslatexenvstyle}} -\index{defslatexenvstyle@{\tt\bs defslatexenvstyle}} -\index{plain TeX} -\index{LaTeX} -\index{environments} - -As shown previously, the differences in SLaTeX usage -between plain TeX and LaTeX is simply a matter of the -difference in the ``environment'' styles of the two -formats. It is easy get the behavior of the one format -with the other. - -1. If you wish to use the plain-TeX style in LaTeX, -type - -\verbatim{ -\defslatexenvstyle{tex} -} - -\n before first such use. - -2. Similarly, if you wish to use the LaTeX -\p{\begin}/\p{\end} style in plain TeX, use - -\verbatim{ -\defslatexenvstyle{latex} -} - -\n {\it provided you have already defined \p{\begin} and -\p{\end} appropriately!\/} One way to accomplish -this is: - -\verbatim{ -\def\begin#1{\begingroup - \csname#1\endcsname - \let\end\endenvironment} -\def\endenvironment#1{% - \csname end#1\endcsname - \endgroup} -} - -\n Here, \p{\end} is defined within a group because -TeX already has an \p{\end} command whose global -definition is used by commands such as \p{\bye} and -therefore should not be changed lightly. - -{\tolerance100000 -In either case, you can revert to the default style with -\p|\defslatexenvstyle{latex}| and -\p|\defslatexenvstyle{tex}| -respectively.\par} - -\re{\p{\slatexseparateincludes}} -\index{slatexseparateincludes@{\tt\bs slatexseparateincludes}} -\index{reusing SLaTeX's temporary files} - -By default, the temporary files of SLaTeX use the name -of the topmost TeX file, i.e., the name stored under -\p{\jobname}. In large LaTeX documents using -\p{\include}, this may be unduly restrictive. - -To recapitulate, the \p{slatex} command creates -temporary files to store typeset code and then passes -the baton on to TeX or LaTeX. If no significant change -has been made to the Scheme code (either in content or -in relative positioning) in the document, then -successive calls to (La)TeX could be made directly -using the old temporary files. This could be a time-saver, -since it avoids calling up the Scheme typesetter. - -However, in a large LaTeX document with -\p{\include}s, these successive calls to LaTeX often -entail juggling the \p{\include}s that are chosen. -In this case, even though the relative position of the -Scheme code is preserved within each \p{\include}d -file, the sequence perceived by the main file changes. -This spoils the invariance we needed if we'd wanted to -avoid calling SLaTeX unnecessarily. - -\index{reusing SLaTeX's temporary files!exploiting -LaTeX's {\tt\bs include}} - -To solve this, the SLaTeX command sequence -\p{\slatexseparateincludes} --- which must be called -before the first occurrence of Scheme code in your -document --- guarantees that each -\p{\include}d file will generate its own pool of -temp files. Thus, if the SLaTeX -files are created once for each \p{\include}, they -will be correctly loaded no matter what sequence of -\p{\include}s is taken. - -\re{\p{\schemecodehook}} -\index{schemecodehook@{\tt\bs schemecodehook}} -\index{hook for {\tt\bs schemedisplay} and -{\tt\bs schemebox}} - -The user can define \p{\schemecodehook} to be -anything. The hook will be evaluated inside each -subsequent call to \p{{schemedisplay}} and -\p{{schemebox}}. E.g., if you have \p{\tiny} -defined (as in LaTeX) to reduce font size, then - -\verbatim{ -\let\schemecodehook\tiny -} - -\n converts your Scheme displays and boxes into {\fiverm -small print}. - -The default value of the hook is \p{\relax}, a -no-op. - -\section{Resetting SLaTeX's defaults} -\label{preamble} - -\index{writing personal preamble} -\index{SLaTeX database!modifying} -{\tolerance100000 A sample style modification file for -SLaTeX would include redefinition of the names of the -codesetting control sequences; adjustment of the -display parameters; modification of the font -assignments for keywords, constants, variables, and -special symbols; and addition of new keywords, -constants, variables, and special symbols to SLaTeX's -database.\par} - -Let's assume you want - -1. a centered display style with no vertical skips; - -{\tolerance100000 2. the names \p{\code}, -\p|{schemefrag}|, -\p|{scmbox}|, \p{\sinput} instead of -\p{\scheme}, \p{{schemedisplay}}, -\p{{schemebox}} and -\p{\schemeinput};\par} - -3. tokens to disregard case; - -4. the keywords to come out in \p{typewriter}, the -constants in roman, and the variables in {\bf bold}; - -5. \p{und} and \p{oder} as keywords, -\p{true} and \p{false} as constants, -\p{define} as a variable (overriding default as -keyword!), \p{F} as a constant (\p{f} will also -be a constant, due to case-insensitivity!); - -6. \p{top} and \p{bottom} to print as -$\top$ and $\bot$ respectively. - -This could be set up as - -\verbatim{ -\abovecodeskip 0pt -\belowcodeskip 0pt -\leftcodeskip 0pt plus 1fil -\rightcodeskip 0pt plus 1fil - -\undefschemetoken{scheme} -\undefschemeboxtoken{schemebox} -\undefschemedisplaytoken{schemedisplay} -\undefschemeinputtoken{schemeinput} - -\defschemetoken{code} -\defschemeboxtoken{scmbox} -\defschemedisplaytoken{schemefrag} -\defschemeinputtoken{sinput} - -\schemecasesensitive{false} - -\def\keywordfont#1{{\tt#1}} -\def\constantfont#1{{\rm#1}} -\def\variablefont#1{{\bf#1\/}} - -\setkeyword{und oder} -\setconstant{true false} -\setvariable{define} -\setconstant{F} - -\setspecialsymbol{top}{$\top$} -\setspecialsymbol{bottom}{$\bottom$} -} - -\n This file can then be \p{\input} in the preamble of -your (La)TeX document. - -\section{Obtaining and installing SLaTeX} -\label{ftp} - -\index{obtaining and installing SLaTeX} -{\tolerance100000 -SLaTeX is available from the Rice University PLT website at -the URL \path{http://www.cs.rice.edu/CS/PLT/packages/slatex/slatex.tar.gz}. -Un\p{gzip}ping and -un\p{tar}ring produces a directory \p{slatex}, -containing the SLaTeX files. (The file \p{manifest} -lists the files in the distribution --- make sure that -nothing is missing.)\par} - -To install SLaTeX on your system: - -1. First change directory (\p{cd}) to \p{slatex}, -the directory housing the SLaTeX files.\f{The SLaTeX -files use Unix-style newlines. If you're using OS/2 or -DOS, you may want to use an appropriate newline -modifier to make the files comply -with your operating system's newline format.} - -2. Edit the file \p{config.dat} as suggested by the -comments in the file itself. - -3. Invoke your Scheme or Common Lisp interpreter. -Load the file \p{config.scm}, i.e., type - -\enableslatex -\schemedisplay -(load "config.scm") -\endschemedisplay -at \slatexdisable{enableslatex} the Scheme (or Common -Lisp) prompt. This will configure SLaTeX for your -Scheme dialect and operating system, creating a Scheme -file called \p{slatex.scm}. (If you informed \p{config.dat} -that your Scheme dialect is Chez, the file -\p{slatex.scm} is a compiled version rather than -Scheme source.) The configuration process also creates -a shell script (\p{slatex} on Unix, \p{slatex.cmd} -on OS/2, and \p{slatex.bat} on DOS) to let you invoke -SLaTeX from your operating system command line. A -Scheme/Common Lisp file \p{callsla.scm} is also -created --- this lets you call SLaTeX from the -Scheme/Common Lisp prompt. This is a convenient alternative -to using a shell script from the operating-system -commandline. It is also the only alternative for those -using SLaTeX on a Macintosh. - -4. Exit Scheme/Common Lisp. - -To set up paths and modify shell script: - -1. Copy (or move, or link) \p{slatex.scm} into a -suitable place, e.g., your \p{bin} or \p{lib} -directory, or the system \p{bin} or \p{lib}. - -2. Copy (or move, or link) \p{slatex.sty} into a -suitable place, i.e., somewhere in your -\p{TEXINPUTS} path. For installing on a multiuser -system, place in the directory containing the LaTeX -files (on mine this is {\tt -/usr/local/lib/tex/macros}). - -3. \enableslatex -Copy (or move, or link) the shell script -\p{slatex} to a -suitable place in your \p{PATH}, e.g., your {bin} or -the system {bin} directory. Note that -\p{slatex} sets -\scheme{slatex::*texinputs*}. If you're making the same -shell script available to multiple users, you should -change the line - -\schemedisplay -(set! slatex::*texinputs* "...") -\endschemedisplay -to -\schemedisplay -(set! slatex::*texinputs* - (getenv "TEXINPUTS")) -\endschemedisplay -or some other dialect-dependent way of obtaining the -\p{TEXINPUTS} environment variable. -\slatexdisable{enableslatex} - -4. Run \p{slatex} on \p{slatxdoc.tex} (this -file!) for documentation. (This also serves as a check -that SLaTeX does indeed work on your machine.) Refer -to \p{slatxdoc.dvi} when befuddled. - -If your dialect did not allow a nice enough shell script, or -if your platform is a Macintosh, the following provides an -alternate route to unlocking SLaTeX. - -\subsection{Other ways of invoking SLaTeX} - -The configuration process creates a shell script for a -standard invoking mechanism for SLaTeX. The -script exploits the way your Scheme is called, e.g., -matters like whether it accepts \p{echo}'d -s-expressions (e.g., Chez), whether it loads its first -command line argument (e.g., SCM), and whether it -always checks for an ``init'' file (e.g., MIT -Scheme). - -1. If your Scheme doesn't fall into either of these -categories, you may have to write your own -shell script or devise some other mechanism. - -2. The shell script invokes -Scheme/\allowbreak Common Lisp. If, however, you are -already in Scheme/\allowbreak Common Lisp and spend most of the -time continuously at the Scheme/\allowbreak Common Lisp prompt -rather than the operating system prompt, you may avoid -some of the delays inherent in the shell script. - -3. If your platform is a Macintosh, no shell script 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. - -\enableslatex -The file \p{callsla.scm}, which contains just one -small procedure named \scheme{call-slatex}, and which -is created by the configuration process, provides a -simple calling mechanism from Scheme/Common Lisp, in -contrast to the operating system command line. You may -use it as an alternative to the -\p{slatex} shell script. -The usage is as follows: load -\p{callsla.scm} into Scheme/Common Lisp - -\schemedisplay -(load "callsla.scm") -\endschemedisplay -and type - -\setspecialsymbol{}{\va{$\langle$tex-file$\rangle$}} -\schemedisplay -(call-slatex ) -\endschemedisplay -when you need to call SLaTeX on the (La)TeX file -\scheme{}. This invokes the SLaTeX preprocessor on -\scheme{}. If your Scheme has a -\scheme{system} procedure -that can call the operating system command line, -\scheme{call-slatex} will also send your file to TeX or -LaTeX. If your Scheme does not have such a procedure, -\scheme{call-slatex} will simply prod you to call TeX -or LaTeX yourself. -\slatexdisable{enableslatex} - -The outline of the shell script or -\p{callsla.scm} or of any strategy you devise for -using SLaTeX should include the following actions: - -1. Load the file \p{slatex.scm} (created by the -configuration process) into Scheme/Common Lisp. - -2. \enableslatex -Set the variable \scheme{slatex::*texinputs*} to the -path \p{TEXINPUTS} or \p{TEXINPUT} used by -TeX\f{There is some variation on the name of -this environment variable. Unix TeXs prefer -\p{TEXINPUTS} with an \p{S}, while OS/2 and DOS (e.g., -Eberhard Mattes's emTeX) favor the 8-letter \p{TEXINPUT} --- -no \p{S}.} -to look for -\slatexdisable{enableslatex} -\p{\input} -files. - -3. \enableslatex -Call the procedure -\scheme{slatex::process-main-tex-file} on the \p{.tex} -file to be processed. -\slatexdisable{enableslatex} - -4. Call either \p{latex} or \p{tex} on the \p{.tex} file. - -\enableslatex -You may devise your own way of calling -\scheme{slatex::process-main-tex-file}, provided your -method makes sure that \p{slatex.scm} has been -loaded, \scheme{slatex::*texinputs*} set appropriately -{\it before\/} the call and \p{latex}/\p{tex} is called -{\it after\/} the call. - -Note that if you prefer to stay in Scheme/\allowbreak -Common Lisp most of the time, it is a good idea to -pre-load the procedure \scheme{call-slatex}, perhaps -through an ``init'' file. \scheme{call-slatex} is just -a small ``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 -``\scheme{slatex::}'') If you made no calls to -\scheme{call-slatex}, the bigger file \p{slatex.scm} -is not loaded at all. If you make several calls to -\scheme{call-slatex}, -\p{slatex.scm} is loaded only once, at the time of -the first call. -\slatexdisable{enableslatex} - -\subsection{Dialects SLaTeX runs on} - -\index{dialects SLaTeX runs on} -SLaTeX is implemented -\enableslatex -in R5RS-compliant~\cite{r5rs} Scheme (macros are not -needed). The code uses the non-standard procedures -\scheme{delete-file}, -\scheme{file-exists?} and \scheme{force-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 files \p{readme} and -\p{install} contain all the information -necessary to configure SLaTeX for your system. -\slatexdisable{enableslatex} - -SLaTeX has been tested successfully in the following -dialects: - -1. On Unix: Allegro Common Lisp; Bigloo; Chez Scheme; -CLISP; Elk; Gambit; -Gnu Common -Lisp; Guile; -Ibuki Common Lisp (1987); MIT C Scheme; Scheme-to-C; SCM; -STk; UMB Scheme; VSCM. - -2. On Windows 95: MzScheme. - -3. On OS/2: CLISP; SCM. - -4. On MS-DOS: Austin Kyoto Common Lisp; CLISP; MIT C -Scheme; SCM. -%PCScheme/Geneva - -5. On Mac OS: Macintosh Common Lisp 3.0. - -If your Scheme is not mentioned here but {\it is\/} -R5RS-compliant, please send a note to the author at -\p{dorai@cs.rice.edu} describing your Scheme's -procedures for deleting files, testing file existence, -and forcing output, if any, and the configuration file -will be enhanced to accommodate the new dialect. - -Bug reports are most welcome --- send to -\p{dorai@cs.rice.edu}. -\index{bug reports} - -\section{References} - -\bibliographystyle{plain} - -\iffileexists{slatxdoc.bib} -{\bibliography{slatxdoc}} -{\bibliography{bigbib}} - -\section{Index} - -%\begincolumns2 -\inputindex -%\endcolumns - -\bye diff --git a/collects/slatex/slatex-code/structs.scm b/collects/slatex/slatex-code/structs.scm deleted file mode 100644 index d947a69c..00000000 --- a/collects/slatex/slatex-code/structs.scm +++ /dev/null @@ -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::"e-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 "e-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))))) - ) diff --git a/collects/slatex/slatex-code/tex2html.css b/collects/slatex/slatex-code/tex2html.css deleted file mode 100644 index c78da2ae..00000000 --- a/collects/slatex/slatex-code/tex2html.css +++ /dev/null @@ -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} diff --git a/collects/slatex/slatex-code/tex2html.tex b/collects/slatex/slatex-code/tex2html.tex deleted file mode 100644 index 56471fe0..00000000 --- a/collects/slatex/slatex-code/tex2html.tex +++ /dev/null @@ -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 -% URL in HTML, and -% URL in DVI. - -% A-VERY-VERY-LONG-URL in a .bib file -% could be split by BibTeX -% across a linebreak, with % before the newline. -% To accommodate this, %-followed-by-newline will -% be ignored in the URL argument of \url and related -% macros. - -\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 -% ADDRESS in HTML, and -% ADDRESS in DVI. - -\let\mailto\url - -% \urlh{URL}{TEXT} becomes -% TEXT in HTML, and -% TEXT in DVI. - -% If TEXT contains \\, the part after \\ appears in -% the DVI only. If, further, this part contains \1, -% the latter is replaced by a fixed-width representation -% of URL. - -\def\urlh{\bgroup\urlsetup - \afterassignment\urlhI - \gdef\urlII} - -\def\urlhI{\egroup - \bgroup - \let\\\relax - \def\1{{\urlsetup\urlII}}% - \let\dummy=} - -% \urlhd{URL}{HTML-TEXT}{DVI-TEXT} becomes -% HTML-TEXT in HTML, and -% DVI-TEXT in DVI - -\def\urlhd{\bgroup - \def\do##1{\catcode`##1=12 }\dospecials - \catcode`\{1 \catcode`\}2 - \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 diff --git a/collects/slatex/slatex-code/texread.scm b/collects/slatex/slatex-code/texread.scm deleted file mode 100644 index c46d3fcb..00000000 --- a/collects/slatex/slatex-code/texread.scm +++ /dev/null @@ -1,229 +0,0 @@ -;texread.scm -;SLaTeX v. 2.3 -;Various token-readers used on TeX files by SLaTeX -;(c) Dorai Sitaram, Rice U., 1991, 1994 - -(eval-within slatex - - (define slatex::eat-till-newline - (lambda (in) - ;skip all characters from port in till newline inclusive or eof - (let loop () - (let ((c (read-char in))) - (cond ((eof-object? c) 'done) - ((char=? c #\newline) 'done) - (else (loop))))))) - - (define slatex::read-ctrl-seq - (lambda (in) - ;assuming we've just read a backslash, read the remaining - ;part of a latex control sequence from port in - (let ((c (read-char in))) - (if (eof-object? c) - (error "read-ctrl-exp: \\ followed by eof.")) - (if (char-alphabetic? c) - (list->string - (reverse! - (let loop ((s (list c))) - (let ((c (peek-char in))) - (cond ((eof-object? c) s) - ((char-alphabetic? c) (read-char in) - (loop (cons c s))) - ((char=? c #\%) (eat-till-newline in) - (loop s)) - (else s)))))) - (string c))))) - - (define slatex::eat-tabspace - (lambda (in) - ;skip to the next non-space and non-tab character from port in - (let loop () - (let ((c (peek-char in))) - (cond ((eof-object? c) 'done) - ((or (char=? c #\space) (char=? c *tab*)) - (read-char in) (loop)) - (else 'done)))))) - - (define slatex::eat-whitespace - (lambda (in) - ;skip to the next whitespace character from port in - (let loop () - (let ((c (peek-char in))) - (cond ((eof-object? c) 'done) - ((char-whitespace? c) - (read-char in) (loop)) - (else 'done)))))) - - (define slatex::eat-tex-whitespace - (lambda (in) - ;skip to the next whitespace character from port in; - ;skips past latex comments too - (let loop () - (let ((c (peek-char in))) - (cond ((eof-object? c) 'done) - ((char-whitespace? c) (read-char in) (loop)) - ((char=? c #\%) (eat-till-newline in)) - (else 'done)))))) - - (define slatex::chop-off-whitespace - (lambda (l) - ;removes leading whitespace from character-list l - (ormapcdr (lambda (d) (if (char-whitespace? (car d)) #f d)) l))) - - (define slatex::read-grouped-latexexp - (lambda (in) - ;reads a latex grouped expression from port in - ;(removes the groups) - (eat-tex-whitespace in) - (let ((c (read-char in))) - (if (eof-object? c) (error "read-grouped-latexexp: ~ -Expected { but found eof.")) - (if (not (char=? c #\{)) - (error "read-grouped-latexexp: ~ -Expected { but found ~a." c)) - (eat-tex-whitespace in) - (list->string - (reverse! - (chop-off-whitespace - (let loop ((s '()) (nesting 0) (escape? #f)) - (let ((c (read-char in))) - (if (eof-object? c) (error "read-groupted-latexexp: ~ -Found eof inside {...}.")) - (cond (escape? (loop (cons c s) nesting #f)) - ((char=? c #\\) - (loop (cons c s) nesting #t)) - ((char=? c #\%) (eat-till-newline in) - (loop s nesting #f)) - ((char=? c #\{) - (loop (cons c s) (+ nesting 1) #f)) - ((char=? c #\}) - (if (= nesting 0) s - (loop (cons c s) (- nesting 1) #f))) - (else - (loop (cons c s) nesting #f))))))))))) - - (define slatex::read-filename - (let ((filename-delims (list #\{ #\} #\[ #\] #\( #\) #\# #\% #\\ #\, - #\space *return* #\newline *tab* #\\))) - (lambda (in) - ;reads a filename as allowed in latex syntax from port in - (eat-tex-whitespace in) - (let ((c (peek-char in))) - (if (eof-object? c) (error "read-filename: ~ -Expected filename but found eof.")) - (if (char=? c #\{) (read-grouped-latexexp in) - (list->string - (reverse! - (let loop ((s '()) (escape? #f)) - (let ((c (peek-char in))) - (cond ((eof-object? c) - (if escape? (error "read-filename: ~ -\\ followed by eof.") - s)) - (escape? (read-char in) - (loop (cons c s) #f)) - ((char=? c #\\) (read-char in) - (loop (cons c s) #t)) - ((memv c filename-delims) s) - (else (read-char in) - (loop (cons c s) #f)))))))))))) - - (define slatex::read-schemeid - (let ((schemeid-delims (list #\{ #\} #\[ #\] #\( #\) - #\space *return* #\newline *tab*))) - (lambda (in) - ;reads a scheme identifier from port in - (eat-whitespace in) - (list->string - (reverse! - (let loop ((s '()) (escape? #f)) - (let ((c (peek-char in))) - (cond ((eof-object? c) s) - (escape? (read-char in) (loop (cons c s) #f)) - ((char=? c #\\) (read-char in) - (loop (cons c s) #t)) - ((memv c schemeid-delims) s) - (else (read-char in) (loop (cons c s) #f)))))))))) - - (define slatex::read-delimed-commaed-filenames - (lambda (in lft-delim rt-delim) - ;reads a filename from port in, assuming it's delimited by - ;lft- and rt-delims - (eat-tex-whitespace in) - (let ((c (read-char in))) - (if (eof-object? c) (error "read-delimed-commaed-filenames: ~ -Expected filename(s) but found eof.")) - (if (not (char=? c lft-delim)) - (error "read-delimed-commaed-filenames: ~ -Left delimiter ~a not found." lft-delim)) - (let loop ((s '())) - (eat-tex-whitespace in) - (let ((c (peek-char in))) - (if (eof-object? c) (error "read-delimed-commaed-filenames: ~ -Found eof inside filename(s).")) - (if (char=? c rt-delim) - (begin (read-char in) (reverse! s)) - (let ((s (cons (read-filename in) s))) - (eat-tex-whitespace in) - (let ((c (peek-char in))) - (if (eof-object? c) - (error "read-delimed-commaed-filenames: ~ -Found eof inside filename(s).")) - (cond - ((char=? c #\,) (read-char in)) - ((char=? c rt-delim) (void)) - (else (error "read-delimed-commaed-filenames: ~ -Bad filename(s) syntax."))) - (loop s))))))))) - - (define slatex::read-grouped-commaed-filenames - (lambda (in) - ;read a filename from port in, assuming it's grouped - (read-delimed-commaed-filenames in #\{ #\}))) - - (define slatex::read-bktd-commaed-filenames - (lambda (in) - ;read a filename from port in, assuming it's bracketed - (read-delimed-commaed-filenames in #\[ #\]))) - - (define slatex::read-grouped-schemeids - (lambda (in) - ;read a list of scheme identifiers from port in, - ;assuming they're all grouped - (eat-tex-whitespace in) - (let ((c (read-char in))) - (if (eof-object? c) (error "read-grouped-schemeids: ~ -Expected Scheme identifiers but found eof.")) - (if (not (char=? c #\{)) (error "read-grouped-schemeids: ~ -Expected { but found ~a." c)) - (let loop ((s '())) - (eat-whitespace in) - (let ((c (peek-char in))) - (if (eof-object? c) (error "read-grouped-schemeids: -Found eof inside Scheme identifiers.")) - (if (char=? c #\}) - (begin (read-char in) (reverse! s)) - (loop (cons (read-schemeid in) s)))))))) - - (define slatex::eat-delimed-text - (lambda (in lft-delim rt-delim) - (eat-tex-whitespace in) - (let ((c (peek-char in))) - (if (eof-object? c) 'exit - (if (char=? c lft-delim) - (let loop () - (let ((c (read-char in))) - (if (eof-object? c) 'exit - (if (char=? c rt-delim) 'exit - (loop)))))))))) - - (define slatex::eat-bktd-text - (lambda (in) - (eat-delimed-text in #\[ #\]))) - - (define slatex::eat-grouped-text - (lambda (in) - (eat-delimed-text in #\{ #\}))) - - ;(trace read-filename) - ) \ No newline at end of file diff --git a/collects/slatex/slatex-code/version b/collects/slatex/slatex-code/version deleted file mode 100644 index a403bb62..00000000 --- a/collects/slatex/slatex-code/version +++ /dev/null @@ -1 +0,0 @@ -2.4w \ No newline at end of file diff --git a/collects/slatex/slatex-launcher.scm b/collects/slatex/slatex-launcher.scm deleted file mode 100644 index c8433d16..00000000 --- a/collects/slatex/slatex-launcher.scm +++ /dev/null @@ -1,15 +0,0 @@ -(require-library "slatex.ss" "slatex") - -(case (system-type) - [(macos) - - ;; set up drag and drop - (current-load slatex) - - (for-each slatex (vector->list argv))] - [(windows unix) - (when (eq? (vector) argv) - (error 'slatex "expected a file on the command line~n")) - (parameterize ([error-escape-handler exit]) - (slatex (vector-ref argv 0))) - (exit)]) diff --git a/collects/slatex/slatex.ss b/collects/slatex/slatex.ss deleted file mode 100644 index b89a387b..00000000 --- a/collects/slatex/slatex.ss +++ /dev/null @@ -1,51 +0,0 @@ -(require-library "file.ss") - -(define (filename->latex-filename input-file) - (cond - [(file-exists? input-file) input-file] - [(file-exists? (string-append input-file ".tex")) - (string-append input-file ".tex")] - [else - (error 'filename->latex-filename "~e does not exist" input-file)])) - -(define (latex input-file) - (let ([file (filename->latex-filename (normalize-path input-file))]) - (case (system-type) - [(macos) - (system "OTEX") - - ;; boy, wouldn't it be great if the "actv" appleevent worked for OTEX? - ;(send-event "OTEX" "misc" "acvt") - (let ([oztex-location (build-path (car (filesystem-root-list)) - "Applications" - "OzTeX" - "OzTeX")]) - (when (file-exists? oztex-location) - (with-handlers ([void void]) ;; mzscheme cannot handle result - (send-event "MACS" "aevt" "odoc" (vector 'file oztex-location))))) - (send-event "OTEX" "aevt" "odoc" (vector 'file file))] - [(windows unix) ;; is this also okay for beos? - (system (format "latex ~a" file))] - [else - (error 'latex "do not know how to run latex on ~s" (system-type))]))) - -(define (slatex filename) - (slatex/no-latex filename) - (latex filename)) - -(define slatex/no-latex - (let ([ns (make-namespace)]) - (parameterize ([current-namespace ns]) - (require-library "slatexsrc.ss" "slatex") - (global-defined-value 'slatex::*texinputs* #f) - (global-defined-value 'slatex::*texinputs-list* #f)) - (lambda (input-file) - (let* ([fixed-file (filename->latex-filename input-file)] - [file (normalize-path fixed-file)]) - (let-values ([(base name dir?) (split-path file)]) - (parameterize ([current-namespace ns] - [current-directory - (if (string? base) - base - (current-directory))]) - (eval `(slatex::process-main-tex-file ,name)))))))) diff --git a/collects/slatex/slatexsrc.ss b/collects/slatex/slatexsrc.ss deleted file mode 100644 index f85d662b..00000000 --- a/collects/slatex/slatexsrc.ss +++ /dev/null @@ -1 +0,0 @@ -(error 'slatexsrc.ss "should only load the compiled version of this file. Run `setup-plt -cl slatex' to generate slatexsrc.zo") diff --git a/collects/slibinit/doc.txt b/collects/slibinit/doc.txt deleted file mode 100644 index a65b39c5..00000000 --- a/collects/slibinit/doc.txt +++ /dev/null @@ -1,23 +0,0 @@ - -_Slib_ Initialization File --------------------------- - -The "init.ss" file in the _slibinit_ collection is an slib2c5 -initialization file. To configure MzScheme for slib, load: - - (require-library "init.ss" "slibinit") - -That's enough if the SCHEME_LIBRARY_PATH environment variable is -defined. Otherwise, the initialization file assumes that slib is -installed as an "slib" collection (i.e., in an "slib" directory in the -same location as the "mzlib" directory). - - -The initialization file contains one system-dependent setting: -`most-positive-fixnum' is bound to a value that is precisely correct -for 32-bit architectures. The precise value for a 64-bit architcture -is in the file, but commented out. The only danger in using the 32-bit -value for a 64-bit architecture is a decrease in performance. - -No other changes should be necessary. Send patches to -scheme@cs.rice.edu. diff --git a/collects/slibinit/init.ss b/collects/slibinit/init.ss deleted file mode 100644 index c86bb658..00000000 --- a/collects/slibinit/init.ss +++ /dev/null @@ -1,315 +0,0 @@ -; Derived from: -*-scheme-*- -; "Template.scm" configuration template of *features* for Scheme -; Copyright (C) 1991, 1992, 1993 Aubrey Jaffer. - -; Compatibility file for MzScheme -- -; http://www.cs.rice.edu/CS/PLT/packages/mzscheme/ -; -- and DrScheme -- -; http://www.cs.rice.edu/CS/PLT/packages/drscheme/ -; -- produced by Shriram Krishnamurthi , -; Mon Feb 10 12:03:53 CST 1997 - -(require-library "pretty.ss") -(unless (memq (system-type) '(unix beos)) - (require-library "date.ss")) - -;;; (software-type) should be set to the generic operating system type. -;;; UNIX, VMS, MACOS, AMIGA and MS-DOS are supported. - -(define (software-type) - (case (system-type) - [(unix beos) 'UNIX] - [(windows) 'MS-DOS] - [(macos) 'MACOS] - [else (system-type)])) - -;;; (scheme-implementation-type) should return the name of the scheme -;;; implementation loading this file. - -(define (scheme-implementation-type) '|MzScheme|) - -;;; (scheme-implementation-version) should return a string describing -;;; the version the scheme implementation loading this file. - -(define scheme-implementation-version version) - -;;; (implementation-vicinity) should be defined to be the pathname of -;;; the directory where any auxillary files to your Scheme -;;; implementation reside. - -(define implementation-vicinity - (let ([path - (or (getenv "PLTHOME") - (with-handlers ([void (lambda (x) #f)]) - (let ([p (collection-path "mzlib")]) - (let*-values ([(base name dir?) (split-path p)] - [(base name dir?) (split-path base)]) - (and (string? base) base)))) - (case (system-type) - ((unix) "/usr/local/lib/plt") - ((windows) "C:\\Program Files\\PLT") - ((macos) "My Disk:plt:")))]) - (lambda () path))) - -;;; (library-vicinity) should be defined to be the pathname of the -;;; directory where files of Scheme library functions reside. - -(define library-vicinity - (let ((library-path - (or - ;; Use this getenv if your implementation supports it. - (getenv "SCHEME_LIBRARY_PATH") - ;; Use this path if your scheme does not support GETENV - (with-handlers ([void - (lambda (x) - (error 'slib-init - "can't find SCHEME_LIBRARY_PATH environment variable or \"slib\" collection"))]) - (collection-path "slib"))))) - (lambda () library-path))) - -;;; (home-vicinity) should return the vicinity of the user's HOME -;;; directory, the directory which typically contains files which -;;; customize a computer environment for a user. - -(define (home-vicinity) - (find-system-path 'home-dir)) - -;;; *FEATURES* should be set to a list of symbols describing features -;;; of this implementation. Suggestions for features are: - -(define *features* - '( - source ;can load scheme source files - ;(slib:load-source "filename") - compiled ;can load compiled files - ;(slib:load-compiled "filename") - rev4-report ;conforms to -; rev3-report ;conforms to -; ieee-p1178 ;conforms to -; sicp ;runs code from Structure and - ;Interpretation of Computer - ;Programs by Abelson and Sussman. - rev4-optional-procedures ;LIST-TAIL, STRING->LIST, - ;LIST->STRING, STRING-COPY, - ;STRING-FILL!, LIST->VECTOR, - ;VECTOR->LIST, and VECTOR-FILL! -; rev2-procedures ;SUBSTRING-MOVE-LEFT!, - ;SUBSTRING-MOVE-RIGHT!, - ;SUBSTRING-FILL!, - ;STRING-NULL?, APPEND!, 1+, - ;-1+, ?, >=? - multiarg/and- ;/ and - can take more than 2 args. - multiarg-apply ;APPLY can take more than 2 args. - rationalize - delay ;has DELAY and FORCE - with-file ;has WITH-INPUT-FROM-FILE and - ;WITH-OUTPUT-FROM-FILE - string-port ;has CALL-WITH-INPUT-STRING and - ;CALL-WITH-OUTPUT-STRING -; transcript ;TRANSCRIPT-ON and TRANSCRIPT-OFF - char-ready? -; macro ;has R4RS high level macros - defmacro ;has Common Lisp DEFMACRO - eval ;SLIB:EVAL is single argument eval -; record ;has user defined data structures - values ;proposed multiple values - dynamic-wind ;proposed dynamic-wind - ieee-floating-point ;conforms to - full-continuation ;can return multiple times -; object-hash ;has OBJECT-HASH - -; sort -; queue ;queues - pretty-print -; object->string -; format -; trace ;has macros: TRACE and UNTRACE -; compiler ;has (COMPILER) -; ed ;(ED) is editor - system ;posix (system ) - getenv ;posix (getenv ) - program-arguments ;returns list of strings (argv) -; Xwindows ;X support -; curses ;screen management package -; termcap ;terminal description package -; terminfo ;sysV terminal description - current-time ;returns time in seconds since 1/1/1970 - )) - -;;; Compatibility code added by Shriram. - -(define-macro defmacro - (lambda (name params . body) - `(define-macro ,name - (lambda ,params - ,@body)))) - -(define program-arguments - (lambda () - (vector->list argv))) - -(define current-time - ;; Gives time since 1/1/1970 ... - ;; ... GMT for Unix, Windows, and BeOS. - ;; ... local time for MacOS. - (if (memq (system-type) '(unix beos windows)) - current-seconds - (let ([zero (find-seconds 0 0 0 1 1 1970)]) - (lambda () - (- (current-seconds) zero))))) - -;;; Remainder is modifications of existing code in Template.scm. - -;;; (OUTPUT-PORT-WIDTH ) -(define (output-port-width . arg) 79) - -;;; (OUTPUT-PORT-HEIGHT ) -(define (output-port-height . arg) 24) - -;;; (CURRENT-ERROR-PORT) -;; Already in MzScheme - -;;; (TMPNAM) makes a temporary file name. -(define tmpnam (let ((cntr 100)) - (lambda () (set! cntr (+ 1 cntr)) - (string-append "slib_" (number->string cntr))))) - -;;; (FILE-EXISTS? ) -;; Already in MzScheme - -;;; (DELETE-FILE ) -;; Already in MzScheme - -;;; FORCE-OUTPUT flushes any pending output on optional arg output port -;;; use this definition if your system doesn't have such a procedure. -(define force-output flush-output) - -;;; CALL-WITH-INPUT-STRING and CALL-WITH-OUTPUT-STRING are the string -;;; port versions of CALL-WITH-*PUT-FILE. - -(define call-with-input-string - (lambda (string thunk) - (parameterize ((current-input-port (open-input-string string))) - (thunk)))) - -(define call-with-output-string - (lambda (receiver) - (let ((sp (open-output-string))) - (receiver sp) - (get-output-string sp)))) - -;;; CHAR-CODE-LIMIT is one greater than the largest integer which can -;;; be returned by CHAR->INTEGER. -(define char-code-limit 256) - -;;; MOST-POSITIVE-FIXNUM is used in modular.scm -(define most-positive-fixnum #x3FFFFFFF) ; 30 bits on 32-bit machines -; (define most-positive-fixnum #x3FFFFFFFFFFFFFFF) ; 62 bits on 64-bit machines - -;;; Return argument -(define (identity x) x) - -;;; If your implementation provides eval SLIB:EVAL is single argument -;;; eval using the top-level (user) environment. -(define slib:eval eval) - -;;; If your implementation provides R4RS macros: -;(define macro:eval slib:eval) -;(define macro:load load) - -(define gentemp - (let ((*gensym-counter* -1)) - (lambda () - (set! *gensym-counter* (+ *gensym-counter* 1)) - (string->symbol - (string-append "slib:G" (number->string *gensym-counter*)))))) - -(define defmacro? macro?) - -(define (macroexpand-1 x) - ;; Slib expects macroexpand-1 to return an `eq?' value if there's nothing - ;; to expand. MzScheme returns an `equal?' value, instead. - ;; Of course, using will equal? is bad if the input contains cycles. - ;; We assume that slib-based code won't try to use MzScheme's graph input - ;; syntax, since it isn't standard. - (let ([xx (expand-defmacro-once x)]) - (if (equal? xx x) - x - xx))) - -(define macroexpand expand-defmacro) - -(define base:eval slib:eval) -(define (defmacro:expand* x) (macroexpand x)) -(define (defmacro:eval x) (base:eval (defmacro:expand* x))) - -(define (defmacro:load ) - (slib:eval-load defmacro:eval)) - -(define (slib:eval-load evl) - (if (not (file-exists? )) - (set! (string-append (scheme-file-suffix)))) - (call-with-input-file - (lambda (port) - (let ((old-load-pathname *load-pathname*)) - (set! *load-pathname* ) - (do ((o (read port) (read port))) - ((eof-object? o)) - (evl o)) - (set! *load-pathname* old-load-pathname))))) - -;;; define an error procedure for the library -(define slib:error error) - -;;; define these as appropriate for your system. -(define slib:tab (integer->char 9)) -(define slib:form-feed (integer->char 12)) - -;;; Support for older versions of Scheme. Not enough code for its own file. -(define (last-pair l) (if (pair? (cdr l)) (last-pair (cdr l)) l)) -(define t #t) -(define nil #f) - -;;; Define these if your implementation's syntax can support it and if -;;; they are not already defined. - -(define 1+ add1) -(define -1+ sub1) -(define 1- -1+) - -(define in-vicinity - (lambda args - (let loop ([args args]) - (cond - [(null? (cdr args)) (car args)] - [(string=? "" (car args)) (loop (cdr args))] - [else (let ([v (loop (cdr args))]) - (build-path (car args) v))])))) - -;;; Define SLIB:EXIT to be the implementation procedure to exit or -;;; return if exitting not supported. -(define slib:exit exit) - -;;; Here for backward compatability -(define scheme-file-suffix - (let ((suffix (case (software-type) - ((NOSVE) "_scm") - (else ".scm")))) - (lambda () suffix))) - -;;; (SLIB:LOAD-SOURCE "foo") should load "foo.scm" or with whatever -;;; suffix all the module files in SLIB have. See feature 'SOURCE. - -(define (slib:load-source f) (load (string-append f ".scm"))) - -;;; (SLIB:LOAD-COMPILED "foo") should load the file that was produced -;;; by compiling "foo.scm" if this implementation can compile files. -;;; See feature 'COMPILED. - -(define (slib:load-compiled f) (load (string-append f ".zo"))) - -;;; At this point SLIB:LOAD must be able to load SLIB files. - -(define slib:load slib:load-source) - -(slib:load (in-vicinity (library-vicinity) "require")) diff --git a/collects/srpersist/doc.txt b/collects/srpersist/doc.txt deleted file mode 100644 index 50ebeda9..00000000 --- a/collects/srpersist/doc.txt +++ /dev/null @@ -1,2507 +0,0 @@ - _SrPersist_ - =========== - - _ODBC_ - ====== - - SrPersist is an ODBC library for MzScheme and DrScheme. - Any database management system with an ODBC driver should - be usable with SrPersist. - - SrPersist provides a one-to-one mapping of ODBC procedures to - Scheme procedures, with some additional utility procedures in Scheme. - Procedures from ODBC versions 1.0 through 3.51 are supported. - Where ODBC expects symbolic constants created through C #define's, - SrPersist uses Scheme constants, which are checked for validity. - In many cases, redundant arguments are eliminated. In many cases, - the SrPersist version of an ODBC procedure returns a handle, allowing - procedures to be composed. - - ODBC procedure names are mapped to Scheme names straightforwardly. - The initial "SQL" in the name is removed, the characters - are made all lowercase, and hyphens are inserted before the location - of formerly uppercase letters, other than the first following "SQL". - For example, the hypothetical ODBC name SQLProcedureName would be - mapped to the Scheme name procedure-name. The exception is SQLError, - which is mapped to sql-error, to avoid confusion with the MzScheme - procedure error. - - The documentation here may be sufficient to get started with - SrPersist, but you will certainly want to consult an ODBC reference for - more information. The file tutorial.txt in the SrPersist collection - provides some simple examples of how to use SrPersist. - - SrPersist is not - ---------------- - - SrPersist makes the ODBC API available in Scheme, but does not - support any abstractions beyond it. Some useful error-checking is - performed that is not done when using the C version of the API. - Serious run-time errors are still possible, such as when a too-small - buffer is bound to a column. - - We are considering ways in which to build a higher-level layer - on top of SrPersist, to avoid some of the low-level details - of ODBC. We would welcome ideas and contributions from users - of SrPersist in this area. Please contact us via email at - scheme@cs.rice.edu. - - Loading - ------- - - Before actually loading SrPersist, you need to define the global variable - odbc-version. For example: - - (define odbc-version 3.5) - - Valid values of odbc-version are 1.0, 2.0, 3.0, 3.5, and 3.51. - The version here should be less than or equal to the ODBC version - used when compiling the SrPersist files. See README in - the SrPersist source directory for more details on compilation. - For the precompiled Windows binary, use 3.51 for odbc-version. - - For Windows, if you get errors when loading, your Windows installation - may be missing certain ODBC libraries. Look for ODBC Data Sources - in Windows Control Panel. If that application is missing, download - and install the Microsoft Data Access Components from - http://www.microsoft.com/data/. The download is about 6.5 Mb. - - There are two ways to load SrPersist. The first is to treat - it as a library: - - (require-library "srpersist.ss" "srpersist") - - makes available the procedures listed here. The other way - to load SrPersist uses a signed unit: - - (require-library "srpersistu.ss" "srpersist") - - binds `srpersist@' to the unit, with signature `srpersist^', - which is defined in the file `sigs.ss' in the srpersist collection. - The contents of that signature depend on the value of - odbc-version. This unit can be invoked or imported into other - units as needed. - - Overview of ODBC - ---------------- - - ODBC is a standard for allowing application programs to retrieve from - and send data to relational databases. The application program - communicates with a Driver Manager using ODBC procedures. Database - queries use SQL (Structured Query Language). The Driver Manager - communicates with databases using drivers specific to them. Therefore, - ODBC is a "middleware" standard. - - How to use this documentation - ----------------------------- - - Because ODBC is very complex, this documentation cannot hope to - cover all its aspects. Instead, this documentation describes - a Scheme interface to ODBC. Each ODBC API procedure has a Scheme - counterpart. In this documentation, we describe the parameters - and return values for each procedure, as well as give some indication - of the purpose of the procedure. To use ODBC effectively, you will - need access to an ODBC reference, such as that provided with the - Microsoft ODBC SDK. - - Overview of ODBC procedures - --------------------------- - - In the documentation below, we group SrPersist ODBC procedures - by topics. The topics are Exceptions, Handles, Connections, Environments, - Statements and Parameters, Descriptors, Cursors, Columns and Data - Retrieval, Metadata, and Errors and Diagnostics. SrPersist also has - its own utility procedures, listed under the heading Utilities below. - - For each procedure, we indicate the ODBC version in which it was - introduced. Therefore, some SrPersist procedures may not be available - to your program. If the variable odbc-version is greater than or - equal to the ODBC version in which a procedure was introduced, the - procedure will be available; otherwise, the procedure will not be - available. - - Exceptions - ---------- - - Any SrPersist ODBC procedure may raise an exception. - SrPersist exceptions correspond to the ODBC SQLRESULT codes, - as follows: - - exn-invalid-handle SQL_INVALID_HANDLE - exn-error SQL_ERROR - exn-still-executing SQL_STILL_EXECUTING - exn-need-data SQL_NEED_DATA - exn-with-info SQL_SUCCESS_WITH_INFO - exn-no-data SQL_NO_DATA_FOUND (before ODBC 3.0) - exn-no-data SQL_NO_DATA (ODBC 3.0 or greater) - - Each of these exceptions is an ordinary Scheme structure - derived from `struct:exn'. Only `exn-need-data` and `exn-with-info' - contain an extra field, `val' in both cases. The names of the - exception indicate the nature of the problem that has occurred. - Each of these exceptions, other than `exn-with-info', indicate an error. - The exception `exn-error' is a catchall, indicating an unspecified error. - The exception `exn-with-info' does not indicate an error, rather it - indicates that additional information is available about the procedure - that generated the exception. The `val' field of `exn-need-data` or - `exn-with-info' instances contains the value returned by the procedure - that generated the exception. In the case of `exn-need-data', depending - on the ODBC procedure, the contained value may not be meaningful. - - `with-handlers' can be used to handle SrPersist exceptions: - - (with-handlers ([(lambda (exn) - (exn-with-info? exn)) - (lambda (exn) - (printf "Got exn-with-info exception~n") - (printf "Value: ~a~n" (exn-with-info-val exn)))]) - ...) - - Applications can call sql-error, get-diag-rec, or get-diag-field - to obtain additional information about an exception that - has occurred (see the heading "Diagnostics", below). No additional - information is available when the exception is `exn-invalid-handle'. - - Besides these SrPersist-particular exceptions, other kinds of errors - may raise exceptions. For example, passing a value of the - wrong type to a SrPersist procedure will raise an exception. - - Handles - ------- - - ODBC and SrPersist support four kinds of handles. - In ODBC itself, all handles are represented as integers, - making it possible for handle types to be confused. - In SrPersist, each handle type has a distinct Scheme - type. An "environment handle" has type `sql-henv'; a - "connection handle" has type `sql-hdbc'; a "statement handle" has - type `sql-hstmt'; a "descriptor handle" has type `sql-hdesc'. - - Further, descriptor handles have an attribute which divides - them into subtypes, though this does not show up in their - Scheme type. Ordinarily, a descriptor handle is either an - Application Parameter Descriptor (attribute APD), an Application - Row Descriptor (ARD), an Implementation Parameter Descriptor (IPD), - or an Implementation Row Descriptor (IRD). Most descriptor - handles are created by an ODBC driver. When a descriptor - handle is explicitly allocated, it receives the attribute - EXPLICIT, rather than one of the four attribute values just - mentioned. - - There are several procedures to allocate fresh handles. - -> (alloc-env) - - ODBC 1.0. - - Returns a fresh environment handle. - -> (alloc-connect henv) - - ODBC 1.0, deprecated in favor of `alloc-handle'. - - Returns a fresh connection handle, given `henv', an - environment handle. - -> (alloc-stmt hdbc) - - ODBC 1.0, deprecated in favor of `alloc-handle'. - - Returns a fresh statement handle, given `hdbc', a - connection handle - -> (alloc-handle htype [handle]) - - ODBC 3.0. - - Returns a fresh handle whose type depends on `htype', - a Scheme symbol. If `htype' is 'sql-handle-env, - then `handle' must be omitted, and a fresh `environment - handle' is returned. If `htype' is 'sql-handle-dbc, - then `handle' must be an environment handle, and a fresh - `connection handle' is returned. If `htype' is 'sql-handle-stmt, - then `handle' must be a connection handle, and a fresh - `statement handle' is returned. If `htype' is 'sql-handle-desc, - then `handle' must be a connection handle, and a fresh - `descriptor handle' with attribute EXPLICIT is returned. - Any other value of `htype' causes an error. - -> (free-connect hdbc) - - ODBC 1.0, deprecated in favor of free-handle. - - Frees a connection handle `hdbc', whose value is returned by the - procedure. - -> (free-env henv) - - ODBC 1.0, deprecated in favor of free-handle. - - Frees an environment handle `henv', whose value is returned by the - procedure. - -> (free-handle handle) - - ODBC 3.0. - - Frees `handle', which may be an environment, connection, statment, - or descriptor handle. Returns the value of `handle'. - -> (free-stmt hstmt option) - - ODBC 1.0. - - Frees or releases resources for the statement handle `hstmt'. - The `option' argument may be any of the following symbols, with - the indicated effects: - - 'sql-close closes the statement cursors, discards pending results - (does not actually free `hstmt') - 'sql-drop deprecated, effectively (free-handle hstmt) - 'sql-unbind releases all column buffers for the statement - 'sql-reset-parms releases all parameter buffers for the statement - - free-stmt returns the value of `hstmt'. - - Environments - ------------ - -> (data-sources henv direction) - - OCBC 1.0. - - For the environment handle `henv', returns a pair of strings - indicating a data source name and its description. The - symbol `direction' is either 'sql-fetch-first, 'sql-fetch-next, - 'sql-fetch-first-user, or 'sql-fetch-first-system. User data - sources are visible only to a particular user, while system - data sources are visible to all users. - -> (drivers henv fetch) - - ODBC 2.0. - - For the environment handle `henv', returns a two-element list - of strings describing an available driver. The first string - identifies the driver and the second string describes attributes - of the driver. `fetch' is either 'sql-fetch-first or - 'sql-fetch-next. By using repeated calls to drivers with - 'sql-fetch-next, a program can obtain information about all - available drivers. Providing 'sql-fetch-next on the first - call to drivers has the same effect as 'sql-fetch-first. - - Please consult an ODBC reference for an information about the - keyword/value pairs that appear in the attributes string. - -> (get-env-attr henv attr) - - Given an environment handle `henv', returns the value of the - attribute `attr'. The possible values for `attr' and the - resulting return values are: - - attr returns - ---- ------- - 'sql-attr-connection-pooling 'sql-cp-off, or - 'sql-cp-one-per-driver, or - 'sql-cp-one-per-henv - - 'sql-attr-cp-match 'sql-cp-strict-match, or - 'sql-cp-relaxed-match - - 'sql-attr-odbc-version 'sql-ov-odbc3, or - 'sql-ov-odbc2 - - 'sql-attr-output-nts boolean - - Please see an ODBC reference for more information about the - significance of these attributes. - -> (set-env-attr henv attr val) - - Given an environment handle `henv', sets the value of its associated - attribute `attr' to the value `val'. See `get-env-attr' for the - available attributes and their valid values. Returns the value of - `henv'. - - Connections - ----------- - - Before an ODBC database may be used, a `connection' between - the ODBC driver and database management system needs to be - established. Here are the procedures for establishing and - managing connections. - -> (connect hdbc dbms name password) - - ODBC 1.0. - - Establishes a connection, given a connection handle `hdbc', and - strings for a database server `dbms', a `name' and `password'. - Returns the value of `hdbc'. - -> (browse-connect hdbc connect-string) - - Connects to a data source, given a connection handle `hdbc' - and connection string `connect-string'. The connection string - consists of keyword and value pairs. See `driver-connect' - for the format of such pairs. The first time `browse-connect' - is called, the connection string must contain either the - DSN or DRIVER keywords. `browse-connect' returns a connection string - with a sequence of keywords and value pairs. Those pairs not - preceded by an asterisk are mandatory in the next call to - browse-connect. If the supplied connection string does not - contain all needed attributes to make a connection, a `exn-need-data' - exception is raised, which contains a connection string indicating - which attributes are missing. - -> (driver-connect hdbc connect-string prompt) - - Connects to an ODBC driver, given a connection handle `hdbc', - the string `connect-string', and the symbol `prompt'. - The connect-string is a possibly-empty sequence of - keyword, attribute pairs: - - keyword=attribute;... - - where `keyword' is any of - - DSN data source - UID user id - PWD password - FILEDSN name of a .dsn file containing a connection string - DRIVER driver description - SAVEFILE a .dsn file for saving the connection attributes - - or a driver-specific keyword. DSN and DRIVER are mutually-exclusive. - DRIVER is ODBC 2.0, while FILEDSN and SAVEFILE are ODBC 3.0. - For DRIVER only, the attribute may be surrounded by - curly braces {}, useful if the attribute contains a semicolon. - `prompt' is one of the symbols - - 'sql-driver-prompt prompt for required information - 'sql-driver-complete prompt if DSN not in connect-string - 'sql-driver-complete-required prompt if DSN not in connect-string - 'sql-driver-noprompt do not prompt for information - - driver-connect returns a connection string indicating all the - keywords and values that were passed to the data source. - -> (disconnect hdbc) - - ODBC 1.0. - - Closes the data source connection associated with the connection - handle `hdbc'. Frees any statement and descriptor handles associated - with the connection handle. Returns the value of `hdbc'. - -> (get-info hdbc infotype [handle]) - - ODBC 1.0. - - Returns information about the data source associated with the - connection handle `hdbc'. The type of the return value depends - on the symbol `infotype', which indicates the information requested. - The optional argument `handle' is either a statement handle - or a descript handle, and may be used only with certain - values of `infotype', as described below. - - The significance of the values returned by get-info is beyond the - scope of this documentation. Please consult an ODBC reference - for further information. - - The permissible values of `infotype' vary by ODBC version. - Valid values of `infotype' and their return types are: - - infotype returns - -------- ------- - - [ODBC 1.0 or greater] - 'sql-accessible-procedures boolean - 'sql-accessible-tables boolean - 'sql-active-connections unsigned integer - 'sql-active-statements unsigned integer - 'sql-alter-table a list with elements chosen from - '(sql-at-add-column-collation - sql-at-add-column-default - sql-at-add-column-single - sql-at-add-constraint - sql-at-add-table-constraint - sql-at-constraint-name-definition - sql-at-drop-column-cascade - sql-at-drop-column-default - sql-at-drop-column-restrict - sql-at-drop-table-constraint-cascade - sql-at-drop-table-constraint-restrict - sql-at-set-column-default - sql-at-constraint-initially-deferred - sql-at-constraint-initially-immediate - sql-at-constraint-deferrable - sql-at-constraint-non-deferrable) - 'sql-correlation-name 'sql-cn-none, or - 'sql-cn-different, or - 'sql-cn-any - 'sql-convert-functions a list with elements chosen from - '(sql-fn-cvt-cast sql-fn-cvt-convert) - 'sql-column-alias boolean - 'sql-concat-null-behavior 'sql-cb-null or - sql-cb-non-null - 'sql-convert-bigint a list with elements chosen from - '(sql-cvt-bigint - sql-cvt-binary - sql-cvt-bit - sql-cvt-char - sql-cvt-date - sql-cvt-decimal - sql-cvt-double - sql-cvt-float - sql-cvt-integer - sql-cvt-interval-year-month - sql-cvt-interval-day-time - sql-cvt-longvarbinary - sql-cvt-longvarchar - sql-cvt-numeric - sql-cvt-real - sql-cvt-smallint - sql-cvt-time - sql-cvt-timestamp - sql-cvt-tinyint - sql-cvt-varbinary - sql-cvt-varchar) - 'sql-convert-binary same as for 'sql-convert-bigint - 'sql-convert-bit same as for 'sql-convert-bigint - 'sql-convert-char same as for 'sql-convert-bigint - 'sql-convert-date same as for 'sql-convert-bigint - 'sql-convert-decimal same as for 'sql-convert-bigint - 'sql-convert-double same as for 'sql-convert-bigint - 'sql-convert-float same as for 'sql-convert-bigint - 'sql-convert-integer same as for 'sql-convert-bigint - 'sql-convert-longvarbinary same as for 'sql-convert-bigint - 'sql-convert-longvarchar same as for 'sql-convert-bigint - 'sql-convert-real same as for 'sql-convert-bigint - 'sql-convert-numeric same as for 'sql-convert-bigint - 'sql-convert-smallint same as for 'sql-convert-bigint - 'sql-convert-time same as for 'sql-convert-bigint - 'sql-convert-timestamp same as for 'sql-convert-bigint - 'sql-convert-tinyint same as for 'sql-convert-bigint - 'sql-convert-varbinary same as for 'sql-convert-bigint - 'sql-convert-varchar same as for 'sql-convert-bigint - 'sql-cursor-commit-behavior 'sql-cb-delete, or - 'sql-cb-close, or - 'sql-cb-preserve - 'sql-cursor-rollback-behavior same as for 'sql-cursor-commit-behavior - 'sql-data-source-name string - 'sql-data-source-read-only boolean - 'sql-database-name string - 'sql-dbms-name string - 'sql-dbms-ver string - 'sql-default-txn-isolation 'sql-txn-read-uncommitted, or - 'sql-txn-read-committed, or - 'sql-txn-repeatable-read, or - 'sql-txn-serializable - 'sql-driver-hdbc connection handle - 'sql-driver-henv environment handle - 'sql-driver-hlib unsigned integer - 'sql-driver-hstmt statement handle; `handle' argument - also a statement handle - 'sql-driver-name string - 'sql-driver-odbc-ver string - 'sql-driver-ver string - 'sql-expressions-in-orderby boolean - 'sql-fetch-direction a list with elements chosen from - '(sql-fd-fetch-next - sql-fd-fetch-first - sql-fd-fetch-last - sql-fd-fetch-prior - sql-fd-fetch-absolute - sql-fd-fetch-relative - sql-fd-fetch-bookmark) - 'sql-file-usage 'sql-file-not-supported, or - 'sql-file-table, or - 'sql-file-catalog - 'sql-getdata-extensions a list with elements chosen from - '(sql-gd-any-column - sql-gd-any-order - sql-gd-block - sql-gd-bound) - 'sql-group-by 'sql-gb-collate (ODBC 3.0 or greater), or - 'sql-gb-not-supported, or - 'sql-gb-group-by-equals-select, or - 'sql-gb-group-by-contains-select, or - 'sql-gb-no-relation - 'sql-identifier-case 'sql-ic-upper, or - 'sql-ic-lower, or - 'sql-ic-sensitive, or - 'sql-ic-mixed - 'sql-identifier-quote-char string - 'sql-integrity boolean - 'sql-keywords string - 'sql-like-escape-clause boolean - 'sql-lock-types a list with elements chosen from - '(sql-lck-no-change - sql-lck-exclusive - sql-lck-unlock) - 'sql-max-binary-literal-len unsigned integer - 'sql-max-catalog-name-len unsigned integer - 'sql-max-char-literal-len unsigned integer - 'sql-max-column-name-len unsigned integer - 'sql-max-columns-in-group-by unsigned integer - 'sql-max-columns-in-index unsigned integer - 'sql-max-columns-in-order-by unsigned integer - 'sql-max-columns-in-select unsigned integer - 'sql-max-columns-in-table unsigned integer - 'sql-max-cursor-name-len unsigned integer - 'sql-max-index-size unsigned integer - 'sql-max-owner-name-len unsigned integer - 'sql-max-procedure-name-len unsigned integer - 'sql-max-qualifier-name-len unsigned integer - 'sql-max-row-size unsigned integer - 'sql-max-row-size-includes-long boolean - 'sql-max-schema-name-len unsigned integer - 'sql-max-statement-len unsigned integer - 'sql-max-table-name-len unsigned integer - 'sql-max-tables-in-select unsigned integer - 'sql-max-user-name-len unsigned integer - 'sql-mult-result-sets boolean - 'sql-multiple-active-txn boolean - 'sql-need-long-data-len boolean - 'sql-non-nullable-columns 'sql-nnc-null or - 'sql-nnc-non-null - 'sql-null-collation 'sql-nc-end, or - 'sql-nc-high, or - 'sql-nc-low, or - 'sql-nc-start - 'sql-numeric-functions a list with elements chosen from - '(sql-fn-num-abs - sql-fn-num-acos - sql-fn-num-asin - sql-fn-num-atan - sql-fn-num-atan2 - sql-fn-num-ceiling - sql-fn-num-cos - sql-fn-num-cot - sql-fn-num-degrees - sql-fn-num-exp - sql-fn-num-floor - sql-fn-num-log - sql-fn-num-log10 - sql-fn-num-mod - sql-fn-num-pi - sql-fn-num-power - sql-fn-num-radians - sql-fn-num-rand - sql-fn-num-round - sql-fn-num-sign - sql-fn-num-sin - sql-fn-num-sqrt - sql-fn-num-tan - sql-fn-num-truncate) - 'sql-odbc-api-conformance 'sql-oac-none, or - 'sql-oac-level1, or - 'sql-oac-level2 - 'sql-odbc-sql-conformance 'sql-osc-minimum, or - 'sql-osc-core, or - 'sql-osc-extended - 'sql-odbc-sql-opt-ief boolean - 'sql-odbc-ver string - 'sql-order-by-columns-in-select boolean - 'sql-outer-joins boolean - 'sql-owner-term string - 'sql-owner-usage a list with elements chosen from - '(sql-ou-dml-statements - sql-ou-procedure-invocation - sql-ou-table-definition - sql-ou-index-definition - sql-ou-privilege-definition) - 'sql-pos-operations a list with elements chosen from - '(sql-pos-position - sql-pos-refresh - sql-pos-update - sql-pos-delete - sql-pos-add) - 'sql-positioned-statements a list with elements chosen from - '(sql-ps-positioned-delete - sql-ps-positioned-update - sql-ps-select-for-update) - 'sql-procedure-term string - 'sql-procedures boolean - 'sql-qualifier-location 'sql-ql-start or 'sql-ql-end - 'sql-qualifier-name-separator string - 'sql-qualifier-term string - 'sql-qualifier-usage a list with elements chosen from - '(sql-qu-dml-statements - sql-qu-procedure-invocation - sql-qu-table-definition - sql-qu-index-definition - sql-qu-privilege-definition) - 'sql-quoted-identifier-case 'sql-ic-upper, or - 'sql-ic-lower, or - 'sql-ic-sensitive, or - 'sql-ic-mixed - 'sql-row-updates boolean - 'sql-scroll-concurrency a list with elements chosen from - '(sql-scco-read-only - sql-scco-lock - sql-scco-opt-rowver - sql-scco-opt-values) - 'sql-scroll-options a list with elements chosen from - '(sql-so-forward-only - sql-so-static - sql-so-keyset-driven - sql-so-dynamic - sql-so-mixed) - 'sql-search-pattern-escape string - 'sql-server-name string - 'sql-special-characters string - 'sql-static-sensitivity a list with elements chosen from - '(sql-ss-additions - sql-ss-deletions - sql-ss-updates) - 'sql-string-functions a list with elements chosen from - '(sql-fn-str-ascii - sql-fn-str-bit-length - sql-fn-str-char - sql-fn-str-char-length - sql-fn-str-character-length - sql-fn-str-concat - sql-fn-str-difference - sql-fn-str-insert - sql-fn-str-lcase - sql-fn-str-left - sql-fn-str-length - sql-fn-str-locate - sql-fn-str-ltrim - sql-fn-str-octet-length - sql-fn-str-position - sql-fn-str-repeat - sql-fn-str-replace - sql-fn-str-right - sql-fn-str-rtrim - sql-fn-str-soundex - sql-fn-str-space - sql-fn-str-substring - sql-fn-str-ucase) - 'sql-subqueries a list with elements chosen from - '(sql-sq-correlated-subqueries - sql-sq-comparison - sql-sq-exists - sql-sq-in - sql-sq-quantified) - 'sql-system-functions a list with elements chosen from - '(sql-fn-sys-dbname - sql-fn-sys-ifnull - sql-fn-sys-username) - 'sql-table-term string - 'sql-timedate-add-intervals a list with elements chosen from - '(sql-fn-tsi-frac-second - sql-fn-tsi-second - sql-fn-tsi-minute - sql-fn-tsi-hour - sql-fn-tsi-day - sql-fn-tsi-week - sql-fn-tsi-month - sql-fn-tsi-quarter - sql-fn-tsi-year) - 'sql-timedate-diff-intervals a list with elements chosen from - '(sql-fn-tsi-frac-second - sql-fn-tsi-second - sql-fn-tsi-minute - sql-fn-tsi-hour - sql-fn-tsi-day - sql-fn-tsi-week - sql-fn-tsi-month - sql-fn-tsi-quarter - sql-fn-tsi-year) - 'sql-timedate-functions a list with elements chosen from - '(sql-fn-td-current-date - sql-fn-td-current-time - sql-fn-td-current-timestamp - sql-fn-td-curdate - sql-fn-td-curtime - sql-fn-td-dayname - sql-fn-td-dayofmonth - sql-fn-td-dayofweek - sql-fn-td-dayofyear - sql-fn-td-extract - sql-fn-td-hour - sql-fn-td-minute - sql-fn-td-month - sql-fn-td-monthname - sql-fn-td-now - sql-fn-td-quarter - sql-fn-td-second - sql-fn-td-timestampadd - sql-fn-td-timestampdiff - sql-fn-td-week - sql-fn-td-year) - 'sql-txn-capable 'sql-tc-none, or - 'sql-tc-dml, or - 'sql-tc-ddl-commit, or - 'sql-tc-ddl-ignore, or - 'sql-tc-all - 'sql-txn-isolation-option same as for 'sql-default-txn-isolation - 'sql-union a list with elements chosen from - '(sql-u-union sql-u-union-all) - 'sql-user-name string - - [ODBC 2.0 or greater]: - 'sql-bookmark-persistence a list with elements chosen from - '(sql-bp-close sql-bp-delete - sql-bp-drop sql-bp-transaction - sql-bp-update sql-bp-other-hstmt) - - [ODBC 2.01 or greater]: - 'sql-oj-capabilities a list with elements chosen from - '(sql-oj-left - sql-oj-right - sql-oj-full - sql-oj-nested - sql-oj-not-ordered - sql-oj-inner - sql-oj-all-comparison-ops) - - [ODBC 3.0 or greater]: - 'sql-active-environments unsigned integer - 'sql-aggregate-functions a list with elements chosen from - '(sql-af-all - sql-af-avg - sql-af-count - sql-af-distinct - sql-af-max - sql-af-min - sql-af-sum) - 'sql-alter-domain a list with elements chosen from - '(sql-ad-add-domain-constraint - sql-ad-add-domain-default - sql-ad-constraint-name-definition - sql-ad-drop-domain-constraint - sql-ad-drop-domain-default - sql-ad-add-constraint-deferrable - sql-ad-add-constraint-non-deferrable - sql-ad-add-constraint-inititally-deferred - sql-ad-add-constraint-initially-immediate) - 'sql-async-mode 'sql-am-connection, or - 'sql-am-statement, or - 'sql-am-none - 'sql-batch-row-count a list with elements chosen from - '(sql-brc-rolled-up - sql-brc-procedures - sql-brc-explicit) - 'sql-batch-support a list with elements chosen from - '(sql-bs-select-explicit - sql-bs-row-count-explicit - sql-bs-select-proc - sql-bs-row-count-proc) - 'sql-catalog-location 'sql-cl-start or 'sql-cl-end - 'sql-catalog-name boolean - 'sql-catalog-name-separator string - 'sql-catalog-term string - 'sql-catalog-usage a list with elements chosen from - '(sql-cu-dml-statements - sql-cu-procedure-invocation - sql-cu-table-definition - sql-cu-index-definition - sql-cu-privilege-definition) - 'sql-collation-seq string - 'sql-convert-interval-year-month same as for 'sql-convert-bigint - 'sql-convert-interval-day-time same as for 'sql-convert-bigint - 'sql-convert-interval-year-month same as for 'sql-convert-bigint - 'sql-create-assertion a list with elements chosen from - '(sql-ca-create-assertion - sql-ca-constraint-initially-deferred - sql-ca-constraint-initially-immediate - sql-ca-constraint-deferrable - sql-ca-constraint-non-deferrable) - 'sql-create-character-set a list with elements chosen from - '(sql-ccs-create-character-set - sql-ccs-collate-clause - sql-ccs-limited-collation) - 'sql-create-collation a list with elements chosen from - '(sql-ccol-create-collation) - 'sql-create-domain a list with elements chosen from - '(sql-cdo-create-domain - sql-cdo-constraint-name-definition - sql-cdo-default - sql-cdo-constraint - sql-cdo-collation - sql-cdo-constraint-initially-deferred - sql-cdo-constraint-initially-immediate - sql-cdo-constraint-deferrable - sql-cdo-constraint-non-deferrable) - 'sql-create-schema a list with elements chosen from - '(sql-cs-create-schema - sql-cs-authorization - sql-cs-default-character-set) - 'sql-create-table a list with elements chosen from - '(sql-ct-create-table - sql-ct-table-constraint - sql-ct-constraint-name-definition - sql-ct-commit-preserve - sql-ct-commit-delete - sql-ct-global-temporary - sql-ct-local-temporary - sql-ct-column-constraint - sql-ct-column-default - sql-ct-column-collation - sql-ct-constraint-initially-deferred - sql-ct-constraint-initially-immediate - sql-ct-constraint-deferrable - sql-ct-constraint-non-deferrable) - 'sql-create-translation a list with elements chosen from - '(sql-ctr-create-translation) - 'sql-create-view a list with elements chosen from - '(sql-cv-create-view - sql-cv-check-option - sql-cv-cascaded - sql-cv-local) - 'sql-datetime-literals a list with elements chosen from - '(sql-dl-sql92-date - sql-dl-sql92-time - sql-dl-sql92-timestamp - sql-dl-sql92-interval-year - sql-dl-sql92-interval-month - sql-dl-sql92-interval-day - sql-dl-sql92-interval-hour - sql-dl-sql92-interval-minute - sql-dl-sql92-interval-second - sql-dl-sql92-interval-year-to-month - sql-dl-sql92-interval-day-to-hour - sql-dl-sql92-interval-day-to-minute - sql-dl-sql92-interval-day-to-second - sql-dl-sql92-interval-hour-to-minute - sql-dl-sql92-interval-hour-to-second - sql-dl-sql92-interval-minute-to-second) - 'sql-ddl-index 'sql-di-create-index or - 'sql-di-drop-index - 'sql-describe-parameter boolean - 'sql-dm-ver string - 'sql-driver-hdesc descriptor handle; `handle' argument - also a descriptor handle - 'sql-drop-assertion a list with elements chosen from - '(sql-da-drop-assertion) - 'sql-drop-character-set a list with elements chosen from - '(sql-dcs-drop-character-set) - 'sql-drop-collation a list with elements chosen from - '(sql-dc-drop-collation) - 'sql-drop-domain a list with elements chosen from - '(sql-dd-drop-domain - sql-dd-cascade - sql-dd-restrict) - 'sql-drop-schema a list with elements chosen from - '(sql-ds-drop-schema - sql-ds-cascade - sql-ds-restrict) - 'sql-drop-table a list with elements chosen from - '(sql-dt-drop-table - sql-dt-cascade - sql-dt-restrict) - 'sql-drop-translation a list with elements chosen from - '(sql-dtr-drop-translation) - 'sql-drop-view a list with elements chosen from - '(sql-dv-drop-view - sql-dv-cascade - sql-dv-restrict) - 'sql-cursor-sensitivity 'sql-insensitive, or - 'sql-unspecified, or - 'sql-sensitive - 'sql-dynamic-cursor-attributes1 a list with elements chosen from - '(sql-ca1-next sql-ca1-absolute - sql-ca1-relative sql-ca1-bookmark - sql-ca1-lock-exclusive - sql-ca1-lock-no-change - sql-ca1-lock-unlock sql-ca1-pos-position - sql-ca1-pos-update sql-ca1-pos-delete - sql-ca1-pos-refresh - sql-ca1-positioned-update - sql-ca1-positioned-delete - sql-ca1-select-for-update - sql-ca1-bulk-add - sql-ca1-bulk-update-by-bookmark - sql-ca1-bulk-delete-by-bookmark - sql-ca1-bulk-fetch-by-bookmark) - 'sql-dynamic-cursor-attributes2 a list with elements chosen from - '(sql_ca2_read_only_concurrency - sql_ca2_lock_concurrency - sql_ca2_opt_rowver_concurrency - sql_ca2_opt_values_concurrency - sql_ca2_sensitivity_additions - sql_ca2_sensitivity_deletions - sql_ca2_sensitivity_updates - sql_ca2_max_rows_select - sql_ca2_max_rows_insert - sql_ca2_max_rows_delete - sql_ca2_max_rows_update - sql_ca2_max_rows_catalog - sql_ca2_max_rows_affects_all - sql_ca2_crc_exact - sql_ca2_crc_approximate - sql_ca2_simulate_non_unique - sql_ca2_simulate_try_unique - sql_ca2_simulate_unique) - 'sql-forward-only-cursor-attributes1 - same as for 'sql-keyset-cursor-attributes1 - 'sql-forward-only-cursor-attributes2 - same as for 'sql-keyset-cursor-attributes2 - 'sql-index-keywords a list with elements chosen from - '(sql-ik-asc sql-ik-desc) - 'sql-info-schema-views a list with elements chosen from - '(sql-isv-assertions - sql-isv-character-sets - sql-isv-check-constraints - sql-isv-collations - sql-isv-column-domain-usage - sql-isv-column-privileges - sql-isv-columns - sql-isv-constraint-column-usage - sql-isv-constraint-table-usage - sql-isv-domain-constraints - sql-isv-domains - sql-isv-key-column-usage - sql-isv-referential-constraints - sql-isv-schemata - sql-isv-sql-languages - sql-isv-table-constraints - sql-isv-table-privileges - sql-isv-tables sql-isv-translations - sql-isv-usage-privileges - sql-isv-view-column-usage - sql-isv-view-table-usage) - 'sql-insert-statement a list with elements chosen from - '(sql-is-insert-literals - sql-is-insert-searched - sql-is-select-into) - 'sql-keyset-cursor-attributes1 same as for 'sql-dynamic-cursor-attributes1 - 'sql-keyset-cursor-attributes2 same as for 'sql-dynamic-cursor-attributes2 - 'sql-max-async-concurrent-statements unsigned integer - 'sql-max-concurrent-activities unsigned integer - 'sql-max-driver-connections unsigned integer - 'sql-max-identifier-len unsigned integer - 'sql-odbc-interface-conformance 'sql-oic-core, or - 'sql-oic-level1, or - 'sql-oic-level2 - 'sql-param-array-row-counts 'sql-parc-batch or 'sql-parc-no-batch - 'sql-param-array-selects 'sql-pas-batch, or 'sql-pas-no-batch, or - 'sql-pas-no-select - 'sql-schema-term string - 'sql-schema-usage a list with elements chosen from - '(sql-su-dml-statements - sql-su-procedure-invocation - sql-su-table-definition - sql-su-index-definition - sql-su-privilege-definition) - 'sql-sql-conformance 'sql-sc-sql92-entry, or - 'sql-sc-fips127-2-transitional, or - 'sql-sc-sql92-full, or - 'sql-sc-sql92-intermediate, or - 'sql-sql92-datetime-functions a list with elements chosen from - '(sql-sdf-current-date - sql-sdf-current-time - sql-sdf-current-timestamp) - 'sql-sql92-foreign-key-delete-rule - a list with elements chosen from - '(sql-sfkd-cascade - sql-sfkd-no-action - sql-sfkd-set-default - sql-sfkd-set-null) - 'sql-sql92-foreign-key-update-rule - a list with elements chosen from - '(sql-sfku-cascade - sql-sfku-no-action - sql-sfku-set-default - sql-sfku-set-null) - 'sql-sql92-grant a list with elements chosen from - '(sql-sg-delete-table - sql-sg-insert-column - sql-sg-insert-table - sql-sg-references-table - sql-sg-references-column - sql-sg-select-table - sql-sg-update-column - sql-sg-update-table - sql-sg-usage-on-domain - sql-sg-usage-on-character-set - sql-sg-usage-on-collation - sql-sg-usage-on-translation - sql-sg-with-grant-option) - 'sql-sql92-numeric-value-functions - a list with elements chosen from - '(sql-snvf-bit-length - sql-snvf-char-length - sql-snvf-character-length - sql-snvf-extract - sql-snvf-octet-length - sql-snvf-position) - 'sql-sql92-predicates a list with elements chosen from - '(sql-sp-between - sql-sp-comparison - sql-sp-exists - sql-sp-in - sql-sp-isnotnull - sql-sp-isnull - sql-sp-like - sql-sp-match-full - sql-sp-match-partial - sql-sp-match-unique-full - sql-sp-match-unique-partial - sql-sp-overlaps - sql-sp-quantified-comparison - sql-sp-unique) - 'sql-sql92-relational-join-operations - a list with elements chosen from - '(sql-srjo-corresponding-clause - sql-srjo-cross-join - sql-srjo-except-join - sql-srjo-full-outer-join - sql-srjo-inner-join - sql-srjo-intersect-join - sql-srjo-left-outer-join - sql-srjo-natural-join - sql-srjo-right-outer-join - sql-srjo-union-join) - 'sql-sql92-revoke a list with elements chosen from - '(sql-sr-cascade - sql-sr-delete-table - sql-sr-grant-option-for - sql-sr-insert-column - sql-sr-insert-table - sql-sr-references-column - sql-sr-references-table - sql-sr-restrict - sql-sr-select-table - sql-sr-update-column - sql-sr-update-table - sql-sr-usage-on-domain - sql-sr-usage-on-character-set - sql-sr-usage-on-collation - sql-sr-usage-on-translation) - 'sql-sql92-row-value-constructor a list with elements chosen from - '(sql-srvc-value-expression - sql-srvc-null - sql-srvc-default - sql-srvc-row-subquery) - 'sql-sql92-string-functions a list with elements chosen from - '(sql-ssf-convert - sql-ssf-lower - sql-ssf-upper - sql-ssf-substring - sql-ssf-translate - sql-ssf-trim-both - sql-ssf-trim-leading - sql-ssf-trim-trailing) - 'sql-sql92-value-expressions a list with elements chosen from - '(sql-sve-case - sql-sve-cast - sql-sve-coalesce - sql-sve-nullif) - 'sql-standard-cli-conformance a list with elements chosen from - '(sql-scc-xopen-cli-version1 - sql-scc-iso92-cli) - 'sql-static-cursor-attributes1 same as for 'sql-dynamic-cursor-attributes1 - 'sql-static-cursor-attributes2 same as for 'sql-dynamic-cursor-attributes2 - 'sql-xopen-cli-year string - -> (get-functions hdbc fn) - - ODBC 1.0. - - For the driver that supports the connection indicated by the connection - handle `hdbc', get-functions indicates whether the function or set - of functions denoted by the symbol `fn' is supported by the driver. - - For ODBC 2.0 or later, `fn' may be 'sql-api-all-functions. - In that case, get-functions returns a list of two-element lists in which - the first element is a symbol indicating a function name, and - the second element is #t if the driver supports the function, - otherwise #f. The function names in the list are those below indicated - as ODBC 2.0 or earlier. - - For ODBC 3.0 or greater, `fn' may be 'sql-api-odbc3-all-functions. - In that case, get-functions returns a list of two-element lists in which - the first element is a symbol indicating a function name, and - the second element is #t if the driver supports the function, - otherwise #f. The function names in the list include those from ODBC 3.0, - and those from ODBC 2.0 and earlier. - - `fn' may also be one of the symbols in the following list of functions. - In this case, get-functions returns #t if the function is supported, - #f otherwise. - - [ODBC 2.0 and earlier] - 'sql-api-sqlbindcol - 'sql-api-sqlcancel - 'sql-api-sqlconnect - 'sql-api-sqlgetfunctions - 'sql-api-sqlgetinfo - 'sql-api-sqldatasources - 'sql-api-sqldescribecol - 'sql-api-sqlgettypeinfo - 'sql-api-sqldisconnect - 'sql-api-sqlnumresultcols - 'sql-api-sqldrivers - 'sql-api-sqlparamdata - 'sql-api-sqlprepare - 'sql-api-sqlexecdirect - 'sql-api-sqlputdata - 'sql-api-sqlexecute - 'sql-api-sqlrowcount - 'sql-api-sqlfetch - 'sql-api-sqlsetcursorname - 'sql-api-sqlfreestmt - 'sql-api-sqlgetcursorname - 'sql-api-sqlgetdata - 'sql-api-sqlcolumns - 'sql-api-sqlstatistics - 'sql-api-sqlspecialcolumns - 'sql-api-sqltables - 'sql-api-sqlbindparameter - 'sql-api-sqlnativesql - 'sql-api-sqlbrowseconnect - 'sql-api-sqlnumparams - 'sql-api-sqlprimarykeys - 'sql-api-sqlcolumnprivileges - 'sql-api-sqlprocedurecolumns - 'sql-api-sqldescribeparam - 'sql-api-sqlprocedures - 'sql-api-sqldriverconnect - 'sql-api-sqlsetpos - 'sql-api-sqlforeignkeys - 'sql-api-sqltableprivileges - 'sql-api-sqlmoreresults - - [ODBC 3.0] - 'sql-api-sqlallochandle - 'sql-api-sqlgetdescfield - 'sql-api-sqlgetdescrec - 'sql-api-sqlgetdiagfield - 'sql-api-sqlclosecursor - 'sql-api-sqlgetdiagrec - 'sql-api-sqlcolattribute - 'sql-api-sqlgetenvattr - 'sql-api-sqlcopydesc - 'sql-api-sqlgetstmtattr - 'sql-api-sqlendtran - 'sql-api-sqlsetconnectattr - 'sql-api-sqlfetchscroll - 'sql-api-sqlfreehandle - 'sql-api-sqlgetconnectattr - 'sql-api-sqlsetdescfield - 'sql-api-sqlsetdescrec - 'sql-api-sqlsetenvattr - 'sql-api-sqlsetstmtattr - 'sql-api-sqlbulkoperations - -> (get-connect-attr hdbc attr) - - ODBC 3.0. - - For the connection handle `hdbc', returns the value of an attribute - given by the symbol `attr'. The permissible values of `attr' and - the corresponding ranges of return values are: - - 'sql-attr-access-mode 'sql-mode-read-only, 'sql-mode-read-write - 'sql-attr-async-enable 'sql-async-enable-off, 'sql-async-enable-on - 'sql-attr-autocommit 'sql-autocommit-off, 'sql-autocommit-on - 'sql-attr-auto-ipd boolean - 'sql-attr-connection-dead 'sql-cd-true, 'sql-cd-false - 'sql-attr-connection-timeout exact integer - 'sql-attr-current-catalog string - 'sql-attr-login-timeout exact integer - 'sql-attr-metadata-id boolean - 'sql-attr-odbc-cursors 'sql-cur-use-if-needed, - 'sql-cur-use-odbc, - 'sql-cur-use-driver - 'sql-attr-packet-size exact integer - 'sql-attr-quiet-mode exact integer - 'sql-attr-trace exact integer - 'sql-attr-tracefile string - 'sql-attr-translate-lib string - 'sql-attr-translate-option exact intger - 'sql-attr-txn-isolation 'sql-txn-read-uncommitted, - 'sql-txn-read-committed, - 'sql-txn-repeatable-read, - 'sql-txn-serializable - - See an ODBC reference for the significance of these connection attributes. - Driver-specific attributes are not supported. - -> (get-connect-option hdbc option) - - ODBC 1.0, deprecated in favor of get-connect-attr. - - For a connection handle `hdbc', returns the value of the - connection option specified by the symbol `option'. - The permisible values of `option' are the same as for `attr' in - `get-connect-attr'. See `get-connect-attr' for more information. - -> (set-connect-attr hdbc attr val) - - For a connection handle `hdbc', sets the attribute indicated by the - symbol `attr' to be `val'. The type of `val' depends on `attr', - as follows: - - 'sql-attr-access-mode 'sql-mode-read-only, 'sql-mode-read-write - 'sql-attr-async-enable 'sql-async-enable-off, 'sql-async-enable-on - 'sql-attr-autocommit 'sql-autocommit-off, 'sql-autocommit-on - 'sql-attr-connection-timeout exact integer - 'sql-attr-current-catalog string - 'sql-attr-login-timeout exact integer - 'sql-attr-metadata-id boolean - 'sql-attr-odbc-cursors 'sql-cur-use-if-needed, - 'sql-cur-use-odbc, - 'sql-cur-use-driver - 'sql-attr-packet-size exact integer - 'sql-attr-quiet-mode exact integer - 'sql-attr-trace exact integer - 'sql-attr-tracefile string - 'sql-attr-translate-lib string - 'sql-attr-translate-option exact intger - 'sql-attr-txn-isolation 'sql-txn-read-uncommitted, - 'sql-txn-read-committed, - 'sql-txn-repeatable-read, - 'sql-txn-serializable - - Returns the value of `hdbc'. - - Note that some connection attributes listed in the documentation - for `get-connect-attr' are not settable. The type boolean - above indicates that any Scheme value other than #f is - interpreted as true. - - See an ODBC reference for the significance of these connection attributes. - Driver-specific attributes are not supported. - -> (set-connect-option hdbc option val) - - ODBC 1.0, deprecated in favor of set-connect-attr. - - For a connection handle `hdbc', sets the option indicated by the - symbol `option' to be `val'. The type of `val' depends on `attr'. - The permisible values of `option' are the same as for `attr' in - `set-connect-attr'. See `set-connect-attr' for more information. - Returns the value of `hdbc'. - - Statements and Parameters - ------------------------- - -> (prepare hstmt sql) - - ODBC 1.0. - - Compiles the SQL statement given by the string `sql' for the - statement handle `hstmt'. Returns the value of `hstmt'. Once - an SQL statement has been compiled for a statement handle, - `sql-execute' can be called as many times as desired using that handle. - -> (execute hstmt) - - ODBC 1.0. - - Executes the SQL statement associated with the statement handle - `hstmt'. The SQL statement must have been compiled using - `sql-prepare'. When a statement executes, its parameters, - indicated by ?'s in the SQL text, are replaced by the values - bound to those parameters. See `bind-parameter' and `bind-param'. - The value of `hstmt' is returned. - -> (exec-direct hstmt sql) - - ODBC 1.0. - - Compiles and executes the SQL statement `sql', a string, and - associates that statement with the statement handle `hstmt'. - When a statement executes, its parameters, indicated by ?'s in - the SQL text, are replaced by the values bound to those parameters. - See `bind-parameter' and `bind-param'. The value of `hstmt' is - returned. - -> (native-sql hdbc sql) - - ODBC 1.0. - - Given a connection handle `hdbc' and an SQL statement `sql', returns - a string indicating the SQL that would be passed to the - data source associated with the handle. - -> (param-data hstmt) - - ODBC 1.0. - - Returns the sql-buffer that is bound to the statement handle - `hstmt'. If no such buffer exists, an error occurs. - -> (put-data hstmt buff) - - ODBC 1.0. - - Given the statement handle `hstmt' and an sql-buffer `buff', - sends the buffer data to either 1) the parameter associated - with the statement, or 2) the column associated with the - statement, for use with bulk-operations or set-pos. Returns the - value of `hstmt'. - -> (cancel hstmt) - - ODBC 1.0. - - Terminates processing of the statement given by the statement handle - `hstmt'. Returns the value of `hstmt'. - -> (end-tran handle action) - - ODBC 3.0. - - Requests a commit or rollback for all transactions associated with - `handle', which may be either an environment handle or a - connection handle. `action' is one of the symbols - 'sql-commit or 'sql-rollback. Returns the value of `handle'. - -> (transact henv hdbc action) - - ODBC 1.0, deprecated in favor of end-tran. - - Requests a commit or rollback for all transactions associated with - either the environment handle `henv' or the connection handle `hdbc'. - `action' is one of the symbols 'sql-commit or 'sql-rollback. - If `hdbc' is the symbol 'sql-null-hdbc, the action is performed - for the environment handle; otherwise, it is performed for the - connection handle. Returns void. - -> (num-params hstmt) - - ODBC 1.0. - - Returns the number of parameters (placeholders indicated by a ?) - in the SQL associated with the statement handle `hstmt'. - The `prepare' procedure must be called before calling this - procedure. - -> (bind-parameter hstmt num param-type sql-type col-size buff ind [digits]) - - ODBC 2.0. - - Associates the sql-buffer `buff' with the parameter (a placeholder - indicated by ? in an SQL statement) denoted by the statement - handle `hstmt' and positive integer `num'. The param-type is - one of the symbols 'sql-param-input, 'sql-param-output, or - 'sql-param-input-output. `sql-type' is an SQL data type. - `col-size' is the number of bytes to be sent from the buffer - to the parameter, or, if `sql-data-type' is any of 'sql-decimal, - 'sql-numeric, 'sql-float, 'sql-real, or 'sql-double, the number of - digits of precision used. `ind' is an sql-indicator. The optional - argument `digits' indicates the number of digits to the right of the - decimal point, and is used if `sql-data-type' is 'sql-decimal, - 'sql-numeric, 'sql-time, 'sql-timestamp, 'sql-type-time, - 'sql-type-timestamp, 'sql-interval-second, 'sql-interval-day-to-second, - 'sql-interval-hour-to-second, or 'sql-interval-minute-to-second. - Returns the value of `hstmt'. - - The `prepare' procedure must be called before calling `bind-parameter'. - -> (param-options hstmt numrows) - - ODBC 1.0, deprecated in favor of set-stmt-attr. - - For the statement handle `hstmt', indicates to the ODBC driver the - number of rows associated with each parameter. `numrows' is - an exact positive integer. Returns the current row number. - -> (describe-param hstmt pos) - - ODBC 1.0. - - For the statement handle `hstmt', returns information about the - parameter at position `pos', a positive exact integer. The - returned information is a list consisting of - - - a symbol indicating an SQL data type, - - an exact integer that denotes, depending on the data type, - either the number of bytes expected by a data source for - the parameter, or the precision associated with the data type - - an exact integer denoting the number of trailing decimal digits - expected in the column or expression associated with the parameter - - a symbol indicating the parameter may be associated with - NULLs, either 'sql-no-nulls, 'sql-nullable, or - 'sql-nullable-unknown. - -> (bind-param hstmt num sql-type col-size buff ind [digits]) - - ODBC 3.0, deprecated in favor of bind-parameter. - - Associates the sql-buffer `buff' with the parameter (a placeholder - indicated by ? in an SQL statement) denoted by the statement - handle `hstmt' and positive integer `num'. The arguments are as - for the same-named arguments of procedure `bind-parameter'; some arguments - are omitted for `bind-param'. Note that `bind-param' always - assumes an input parameter, unlike `bind-parameter', which takes - an argument to indicate the parameter type. Returns the value - of `hstmt'. - -> (set-param hstmt num sql-type buff ind) - - ODBC 1.0, deprecated in favor of bind-parameter. - - Associates the sql-buffer `buff' with the parameter (a placeholder - indicated by ? in an SQL statement) denoted by the statement - handle `hstmt' and positive integer `num'. `sql-type' is an SQL - data type. `ind' is an sql-indicator. Returns the value of - `hstmt'. - -> (get-stmt-attr hstmt attr) - - ODBC 3.0. - - For the statement handle `hstmt', returns the value of its - associated attribute `attr'. The statement handle attributes - and their possible values are: - - attr returns - ---- ------- - 'sql-attr-app-param-desc an APD descriptor handle - 'sql-attr-app-row-desc an ARD descriptor handle - 'sql-attr-async-enable 'sql-async-enable-off, or - 'sql-async-enable-on - 'sql-attr-concurrency 'sql-concur-read-only, or - 'sql-concur-lock, or - 'sql-concur-rowver, or - 'sql-concur-values - 'sql-attr-cursor-scrollable 'sql-nonscrollable, or - 'sql-scrollable - 'sql-attr-cursor-sensitivity 'sql-insensitive, or - 'sql-sensitive, or - 'sql-unspecified - 'sql-attr-cursor-type 'sql-cursor-forward-only, or - 'sql-cursor-static, or - 'sql-cursor-keyset-driven, or - 'sql-cursor-dynamic - 'sql-attr-enable-auto-ipd boolean - 'sql-attr-fetch-bookmark-ptr unsigned integer - 'sql-attr-imp-param-desc an IPD descriptor handle - 'sql-attr-imp-row-desc an IRD descriptor handle - 'sql-attr-keyset-size unsigned integer - 'sql-attr-max-length unsigned integer - 'sql-attr-max-rows unsigned integer - 'sql-attr-metadata-id boolean - 'sql-attr-noscan 'sql-noscan-off, or - 'sql-noscan-on - 'sql-attr-param-bind-offset-ptr sql-boxed-uint - (see read-boxed-uint, below) - 'sql-attr-param-bind-type 'sql-param-bind-by-column, or - unsigned integer - 'sql-attr-param-operation-ptr sql-op-parms (see read-op-parms, below) - 'sql-attr-param-status-ptr row-status (see below) - 'sql-attr-params-processed-ptr sql-boxed-uint - (see read-boxed-uint, below) - 'sql-attr-paramset-size unsigned integer - 'sql-attr-query-timeout unsigned integer - 'sql-attr-retrieve-data 'sql-rd-on, or - 'sql-rd-off - 'sql-attr-row-array-size unsigned integer - 'sql-attr-row-bind-offset-ptr sql-boxed-uint - (see read-boxed-uint, below) - 'sql-attr-row-bind-type 'sql-bind-by-column, or - unsigned integer - 'sql-attr-row-number unsigned integer - 'sql-attr-row-operation-ptr op-parms (see read-op-parms, below) - 'sql-attr-row-status-ptr row-status (see read-row-status, below) - 'sql-attr-rows-fetched-ptr sql-boxed-uint - (see read-boxed-uint, below) - 'sql-attr-simulate-cursor 'sql-sc-non-unique, or - 'sql-sc-try-unique, or - 'sql-sc-unique - 'sql-attr-use-bookmarks 'sql-ub-off, or - 'sql-ub-variable, or - 'sql-ub-on - - See an ODBC reference for information about the significance of - these attributes. The type `sql-boxed-uint' is a Scheme representation - of a pointer value. See `read-boxed-uint', below. - An instance of the type `sql-op-parms' is a value that encapsulates an - array whose elements are either 'sql-param-proceed or - 'sql-param-ignore. See `read-op-parms', below. An instance - of the type `sql-row-status' encapsulates an array, one element for - each parameter in the statement, each with one of the values: - - 'sql-param-success - 'sql-param-success-with-info - 'sql-param-error - 'sql-param-unused - 'sql-param-diag-unavilable - -> (get-stmt-option hstmt option) - - ODBC 1.0, deprecated in favor of get-stmt-attr. - - For the statement handle `hstmt', returns the value of its - associated `option'. The statement handle options - and their return values are: - - option returns - ------ ------- - 'sql-async-enable 'sql-async-enable-off, or - 'sql-async-enable-on - 'sql-bind-type 'sql-param-bind-by-column, or - unsigned integer - 'sql-concurrency 'sql-concur-read-only, or - 'sql-concur-lock, or - 'sql-concur-rowver, or - 'sql-concur-values - 'sql-cursor-type 'sql-cursor-forward-only, or - 'sql-cursor-static, or - 'sql-cursor-keyset-driven, or - 'sql-cursor-dynamic - 'sql-keyset-size unsigned integer - 'sql-max-length unsigned integer - 'sql-max-rows unsigned integer - 'sql-noscan 'sql-noscan-off, or - 'sql-noscan-on - 'sql-query-timeout unsigned integer - 'sql-retrieve-data 'sql-rd-on, or - 'sql-rd-off - 'sql-rowset-size unsigned integer - 'sql-simulate-cursor 'sql-sc-non-unique, or - 'sql-sc-try-unique, or - 'sql-sc-unique - 'sql-use-bookmarks 'sql-ub-off, or - 'sql-ub-variable, or - 'sql-ub-on - - See an ODBC reference for the significance of these options. - -> (set-stmt-attr hstmt attr val) - - ODBC 3.0. - - For the statement handle `hstmt', sets its associated attribute `attr' - to the value `val'. See `get-stmt-attr' for attributes and - their possible values. Returns the value of `hstmt'. - -> (set-stmt-option hstmt attr val) - - ODBC 1.0, deprecated in favor of set-stmt-attr. - - For the statement handle `hstmt', sets its associated `option' - to the value `val'. See `get-stmt-option' for options and - their possible values. Returns the value of `hstmt'. - - Descriptors - ----------- - -> (copy-desc hdesc-src hdesc-target) - - ODBC 3.0. - - Copies information from descriptor handle `hdesc-src' to - descriptor handle `hdesc-target'. Returns the value of - `hdesc-src'. - -> (get-desc-rec hdesc recnum) - - ODBC 3.0. - - Given a descriptor handle `hdesc' and record number - `recnum', a positive exact integer, returns a list - of values pertaining to the descriptor record. The first - element of that list is a string, the name of the parameter or column - associated with the descriptor record; the second element - is a symbol indicating a concise SQL data type (see SQL data - types, below); the third element is a symbol that indicates an - interval subtype for the types 'sql-datetime or 'sql-interval, - otherwise 'no-subtype; the fourth element is an exact integer - indicating the byte length of the parameter or column; the fifth - element is an exact integer indicating the number of digits of - precision for the parameter or column (only relevant for numeric data - types); the sixth element is an exact integer indicating the number of - digits to the right of the decimal point used for data in the - column or parameter; while the seventh element is one of - 'sql-no-nulls, 'sql-nullable, or 'sql-nullable-unknown, indicating - whether the parameter or column may have NULL values. - -> (set-desc-rec hdesc recnum type subtype length precision scale buff len ind) - - ODBC 3.0. - - For the descriptor record denoted by the descriptor handle `hdesc' and - positive exact integer `recnum', sets its associated information. - `type' is a symbol indicating a concise SQL or C data type (see SQL data - types, below); `subtype' is a symbol indicating a subtype for the types - 'sql-datetime or 'sql-interval, or it may be 'no-subtype; - `len' is an sql-length (see make-length and read-length, below), which - should be initialized to the desired length of the column or parameter - associated with the descriptor record; `ind' is an sql-indicator - (see Indicators, below). Returns the value of `hdesc'. - -> (get-desc-field hdesc recnum field) - - ODBC 3.0. - - For the descriptor handle `hdesc', returns the value of a field - in the descriptor record with index `recnum', an integer. `field' is a - symbol indicating the field within that record. - - Valid values of `field' and their return types are listed below. - Please consult an ODBC reference for the significance of these - fields. - - field returns - ----- ------- - 'sql-desc-alloc-type integer - 'sql-desc-array-size unsigned integer - 'sql-desc-array-status-ptr array status indicator - 'sql-desc-bind-offset-ptr binding offset - 'sql-desc-bind-type integer - 'sql-desc-count integer - 'sql-desc-rows-processed-ptr rows-processed - 'sql-desc-auto-unique-value integer - 'sql-desc-base-column-name string - 'sql-desc-case-sensitive boolean - 'sql-desc-concise-type SQL data type - 'sql-desc-base-table-name string - 'sql-desc-catalog-name string - 'sql-desc-data-ptr sql-buffer - 'sql-desc-datetime-interval-code 'sql-code-date, or - 'sql-code-time, or - 'sql-code-timestamp, or - 'sql-code-day, or - 'sql-code-day-to-hour, or - 'sql-code-day-to-minute, or - 'sql-code-day-to-second, or - 'sql-code-hour, or - 'sql-code-hour-to-minute, or - 'sql-code-hour-to-second, or - 'sql-code-minute, or - 'sql-code-minute-to-second, or - 'sql-code-month, or - 'sql-code-second, or - 'sql-code-year, or - 'sql-code-year-to-month - 'sql-desc-datetime-interval-precision integer - 'sql-desc-display-size integer - 'sql-desc-fixed-prec-scale boolean - 'sql-desc-indicator-ptr sql-indicator - 'sql-desc-label string - 'sql-desc-length unsigned length - 'sql-desc-literal-prefix string - 'sql-desc-literal-suffix string - 'sql-desc-local-type-name string - 'sql-desc-name string - 'sql-desc-nullable 'sql-nullable, or - 'sql-no-nulls, or - 'sql-nullable-unknown - 'sql-desc-num-prec-radix integer - 'sql-desc-octet-length integer - 'sql-desc-octet-length-ptr octet-length - 'sql-desc-parameter-type 'sql-param-input, or - 'sql-param-output, or - 'sql-param-input-output - 'sql-desc-precision integer - 'sql-desc-rowver boolean - 'sql-desc-scale integer - 'sql-desc-schema-name string - 'sql-desc-searchable for ODBC 3.0 or greater: - 'sql-pred-char, or - 'sql-pred-basic, or - 'sql-pred-none, or - 'sql-pred-searchable - for earlier versions: - 'sql-all-except-like, or - 'sql-like-only, or - 'sql-searchable, or - 'sql-unsearchable - 'sql-desc-table-name string - 'sql-desc-type SQL data type (except intervals) - 'sql-desc-type-name string - 'sql-desc-unnamed 'sql-named or 'sql-unnamed - 'sql-desc-unsigned boolean - 'sql-desc-updatable 'sql-attr-readonly, or - 'sql-attr-write, or - 'sql-attr-readwrite-unknown - -> (set-desc-field hdesc recnum field val) - - ODBC 3.0. - - For the descriptor handle `hdesc', sets the field indicated - by the symbol `field' in the record with index `recnum', an integer, - to the value `val'. See get-desc-field for valid values of - `field' and corresponding types for `val'. Returns the value of - `hdesc'. - - Cursors - ------- - -> (get-cursor-name hstmt) - - ODBC 1.0. - - Returns a string naming the cursor associated with the statement - handle `hstmt'. - -> (set-cursor-name hstmt name) - - ODBC 1.0. - - Assigns the string `name' as the name of the cursor associated with - the statement handle `hstmt'. Returns the value of `hstmt'. - -> (close-cursor hstmt) - - ODBC 3.0. - - Closes the cursor associated with the statement handle `hstmt', - discarding any pending results. Returns the value of `hstmt'. - - Columns and data retrieval - ------------------------------- - - Data in a relational database is organized into tables consisting - of rows and columns. A column corresponds to a field in the - database. A row is an individual data record. - -> (num-result-cols hstmt) - - ODBC 1.0. - - Returns the number of data columns in the data set associated with - the statement handle `hstmt'. - -> (describe-col hstmt colnum) - - ODBC 1.0. - - Given the statement handle `hstmt' and the exact integer `colnum', - indicating a column number, returns a list of information describing - a column in a data set. The first element in the list is a - string giving the name of the column; the second element is a - symbol indicating its SQL data type (see SQL data types, below); - the third element is the maximum byte length of data for the - column; the fourth element is either the number of digits to the right - of the decimal point, for relevant data types (see SQL data types), - otherwise 0; the fifth element is a symbol indicating whether the column - accepts NULL entries, either 'sql-no-nulls, 'sql-nullable, or - 'sql-nullable-unknown. - -> (col-attribute hstmt colnum attr) - - ODBC 3.0. - - Given the statement handle `hstmt', an exact integer `colnum', - indicating a column number, and the symbol `attr', indicating a - column attribute, returns the value of the column attribute. - Columns are numbered starting at 1. The attributes and their - associated types are - - attr returns - ---- ------- - 'sql-desc-count integer - 'sql-desc-auto-unique-value boolean - 'sql-desc-base-column-name string - 'sql-desc-base-table-name string - 'sql-desc-case-sensitive boolean - 'sql-desc-catalog-name string - 'sql-desc-concise-type SQL data type - 'sql-desc-data-ptr sql-buffer - 'sql-desc-display-size integer - 'sql-desc-fixed-prec-scale boolean - 'sql-desc-label string - 'sql-desc-length integer - 'sql-desc-literal-prefix string - 'sql-desc-literal-suffix string - 'sql-desc-local-type-name string - 'sql-desc-name string - 'sql-desc-nullable 'sql-nullable, or - 'sql-no-nulls, or - 'sql-nullable-unknown - 'sql-desc-num-prec-radix integer - 'sql-desc-octet-length integer - 'sql-desc-precision integer - 'sql-desc-scale integer - 'sql-desc-schema-name string - 'sql-desc-searchable ODBC 3.0 or greater: - 'sql-pred-char, or - 'sql-pred-basic, or - 'sql-pred-none, or - 'sql-pred-searchable - earlier versions of ODBC: - 'sql-like-only, or - 'sql-all-except-like, or - 'sql-searchable, or - 'sql-unsearchable - 'sql-desc-table-name string - 'sql-desc-type concise SQL data type - 'sql-desc-type-name string - 'sql-desc-unnamed 'sql-named, or - 'sql-unnamed - 'sql-desc-unsigned boolean - 'sql-desc-updatable 'sql-attr-readonly, or - 'sql-attr-write, or - 'sql-attr-readwrite-unknown - -> (col-attributes hstmt colnum attr) - - ODBC 1.0, deprecated in favor of col-attribute. - - Given the statement handle `hstmt', an exact integer `colnum', - indicating a column number, and the symbol `attr', indicating a - column attribute, returns the value of the column attribute. - Columns are numbered starting at 1. The attributes and their - associated types are - - attr returns - ---- ------- - 'sql-column-count integer - 'sql-column-name string - 'sql-column-type SQL data type - 'sql-column-length integer - 'sql-column-precision integer - 'sql-column-scale integer - 'sql-column-display-size integer - 'sql-column-nullable 'sql-no-nulls, or - 'sql-nullable - 'sql-column-unsigned boolean - 'sql-column-money boolean - 'sql-column-updatable 'sql-attr-readonly, or - 'sql-attr-write, or - 'sql-attr-readwrite-unknown - 'sql-column-auto-increment boolean - 'sql-column-case-sensitive boolean - 'sql-column-searchable 'sql-searchable, or - 'sql-like-only, or - 'sql-all-except-like, or - 'sql-unsearchable - 'sql-column-type-name string - 'sql-column-table-name string - 'sql-column-owner-name string - 'sql-column-qualifier-name string - 'sql-column-label string - -> (bind-col hstmt colnum buff ind) - - ODBC 1.0. - - Associates the sql-buffer `buff' and sql-indicator `ind' - with a column of data denoted by the statement handle `hstmt' - and column numer `colnum', an integer. Returns the value - of `hstmt'. - -> (fetch hstmt) - - ODBC 1.0. - - Retrieves data in the current row of the data set for - the statement handle `hstmt' into the sql-buffers - bound to the data set's columns, and sets the columns' - associated sql-indicator's. Returns the value of `hstmt'. - For columns without bound sql-buffers, `get-data' can be used - to retrieve data following a `fetch'. - -> (get-data hstmt colnum buff ind) - - Retrieves data in the current row of the data set for - the column denoted by the statement handle `hstmt' - and column number `colnum', an integer, into the sql-buffer - `buff' and sets the sql-indicator `ind'. Returns the value of - `hstmt'. `get-data' allows column data to be retrieved without - binding columns to buffers. - -> (fetch-scroll hstmt orient [rownum]) - - ODBC 3.0. - - Fetches multiple rows of data in a data set associated with - the statement handle `hstmt'. `orient' indicates which rows - to fetch, and may be one of the symbols - - 'sql-fetch-first first rowset - 'sql-fetch-next next rowset - 'sql-fetch-prior previous rowset - 'sql-fetch-last last rowset - 'sql-fetch-absolute rowset starting at `rownum' - 'sql-fetch-relative rowset relative to current, - using `rownum' (may be negative) - 'sql-fetch-bookmark rowset relative to - 'sql-attr-fetch-bookmark-ptr - statement attribute - - fetch-scroll returns the value of `hstmt'. The size of rowsets is - specified by the 'sql-attr-rowset-size statement attribute (see - `get-stmt-attr' and `set-stmt-attr'). See an ODBC reference for more - information on using rowsets. - -> (set-scroll-options hstmt concurrency keyset size) - - ODBC 1.0, deprecated in favor of get-info and set-stmt-attr. - - Sets cursor scrolling options for the statement handle - `hstmt'. `concurrency' is one of - - 'sql-concur-read-only updates and deletes not permitted - 'sql-concur-lock updates and deletes permitted - 'sql-concur-rowver compares row versions for concurrency - control - 'sql-concur-values compares values for concurrency control - - `keyset' is one of - - 'sql-scroll-forward-only only forward scrolling - 'sql-scroll-static no scrolling - 'sql-scroll-keyset-driven cursor uses keys for scrolling - 'sql-scroll-dynamic use `size' parameter for keyset size - - `size', a nonnegative exact integer, gives the size of - rowsets when using `extended-fetch'. Returns the value of `hstmt'. - -> (extended-fetch hstmt orientation [rownum]) - - ODBC 1.0, deprecated in favor of fetch-scroll. - - Retrieves a rowset from a result data set for the statement handle - `hstmt' and returns a row-status value (see Row Status, below). - `orientation' indicates which rowset is to be retrieved, one of - - 'sql-fetch-first first rowset in the data set - 'sql-fetch-next next rowset in the data set - 'sql-fetch-prior prior rowset in the data set - 'sql-fetch-last last rowset in the data set - 'sql-fetch-absolute fetches the rowset starting at the row - given by `rownum' - 'sql-fetch-relative fetches the rowset `rownum' rows from - the start row of the current rowset - 'sql-fetch-bookmark fetches the rowset, interpreting - `rownum' as a bookmark - - The `rownum' argument is an integer, which may be negative. - It must be provided if `orientation' is in 'sql-fetch-absolute, - 'sql-fetch-relative, or 'sql-fetch-bookmark, and must be omitted - otherwise. - -> (more-results hstmt) - - ODBC 1.0. - - Retrieves the next data set for the statement handle `hstmt', whose - value is returned by the procedure. `more-results', which moves between - data sets, is distinguished from procedures such as `fetch', which return - results within data sets. - -> (set-pos hstmt rownum operation lock) - - ODBC 1.0. - - Sets a cursor position for the statement handle `hstmt' - and updates the data source. `rownum', a nonnegative exact - integer, specifies the ordinal position of the row within the - current rowset where `operation' is to occur. A value of 0 - indicates that the operation is to occur on every row in the - rowset. - -`operation' is one of - - 'sql-position positions the cursor at the indicated row - 'sql-refresh refreshes data in buffers associated with - the rowset indicated by `rownum' - 'sql-add a new row is added to the data source (but see below) - 'sql-update data in buffers is used to update the rowset - 'sql-delete deletes the indicated row from the data source - - `set-pos' with 'sql-add is deprecated in favor of `bulk-operations' - with 'sql-add. - - `lock' indicates the lock status for the row or rows after the - operation is performed, one of - - 'sql-lock-no-change use lock status before operation performed - 'sql-lock-exclusive no other application or connection can - access - 'sql-lock-unlock no lock restrictions on access - - set-pos returns the value of `hstmt'. - -> (bulk-operations hstmt operation) - - ODBC 3.0. - - Performs bulk inserts and bulk bookmark operations on the data source - associated with the statement handle `hstmt'. `operation' may - be one of - - 'sql-add adds new rows - 'sql-update-by-bookmark updates rows identified by a bookmark - 'sql-delete-by-bookmark deletes rows identified by a bookmark - 'sql-fetch-by-bookmark retrieves rows identified by a bookmark - - Returns the value of `hstmt'. - - The details of using bulk-operations are beyond the scope of this - documentation. Consult an ODBC reference for more information. - -> (row-count hstmt) - - ODBC 1.0. - - For the data source associated with the statement handle `hstmt', - returns the number of rows affected by the most recent INSERT, - UPDATE, or DELETE operation. - - Metadata - -------- - -> (column-privileges hstmt catalog schema table column) - - Creates a result data set describing column privileges in the current - data source. There are at least eight columns in the resulting data set; a - driver may add columns. The contents of those columns are beyond the scope - of this documentation; consult an ODBC reference for details. - - `hstmt' is a statement handle, and its value is returned by the - procedure. `catalog', `schema', `table', and `column' are strings. - `column' may contain an underscore "_" indicating a single-character - wildcard, or a percent sign "%", which matches zero or more characters. - -> (columns hstmt catalog schema table column) - - Creates a result data set describing columns in the current data source. - There are at least eighteen columns in the resulting data set; a - driver may add columns. The contents of those columns are beyond the scope - of this documentation; consult an ODBC reference for details. - - `hstmt' is a statement handle, whose value is returned by the procedure. - `catalog', `schema', `table', and `column' are strings. `table' and - `column' may contain an underscore "_" indicating a single-character - wildcard, or a percent sign "%", which matches zero or more characters. - -> (foreign-keys hstmt catalog schema table fk-catalog fk-schema fk-table) - - ODBC 1.0. - - Creates a result data set containing foreign key information for the - specified table. There are fourteen ODBC-defined columns in the resulting - data set; a driver may add columns. The contents of those columns are beyond - the scope of this documentation; consult an ODBC reference for details. - - `hstmt' is a statement handle; its value is returned by the procedure. - `catalog', `schema', `table', `fk-catalog', `fk-schema', and `fk-table' - are all strings. `catalog', `schema', and `table' specify a table - containing a primary key, while `fk-catalog', `fk-schema', and `fk-table' - specify a table containing a foreign key. - -> (get-type-info hstmt type) - - ODBC 1.0. - - Given a statement handle `hstmt' and a symbol `type' indicating an - SQL data type (see SQL data types, below), creates a result data set - describing support for that data type in the current data source. - Returns the value of `hstmt'. There are at least nineteen columns in - the resulting data set; a driver may add columns. The contents of - those columns are beyond the scope of this documentation; consult an - ODBC reference for details. - -> (primary-keys hstmt catalog schema table) - - ODBC 1.0. - - Creates a result data set containing the column names that make up the - primary key for a table. There are up to six ODBC-defined columns in - the resulting data set; a driver may add columns. The contents of those - columns are beyond the scope of this documentation; consult an ODBC - reference for details. - - `hstmt' is a statement handle; its value is returned by the procedure. - `catalog', `schema', and `table' are strings. - -> (procedure-columns hstmt catalog schema name column) - - ODBC 1.0. - - Creates a result data set containing the input and output parameters and - columns associated with registered procedures in the current data source. - There are nineteen ODBC-defined columns in the resulting data set; a - driver may add columns. The contents of those columns are beyond the - scope of this documentation; consult an ODBC reference for details. - - `hstmt' is a statement handle; its value is returned by the procedure. - `catalog', `schema', `name', and `column' are strings. `name' indicates - a procedure name, while `column' is a column name. `schema', `name', and - `column' may contain an underscore "_" indicating a single-character - wildcard, or a percent sign "%", which matches zero or more characters. - -> (procedures hstmt catalog schema name) - - ODBC 1.0. - - Creates a result data set containing the registered procedure names in the - current data source. There are eight ODBC-defined columns in the - resulting data set; a driver may add columns. The contents of those - columns are beyond the scope of this documentation; consult an ODBC - reference for details. - - `hstmt' is a statement handle; its value is returned by the procedure. - `catalog', `schema', and `name' are strings. `name' indicates a procedure - name. Both `schema' and `name' may contain an underscore "_" indicating - a single-character wildcard, or a percent sign "%", which matches zero or - more characters. - -> (table-privileges hstmt catalog schema table) - - ODBC 1.0. - - Creates a result data set describing tables in the system catalog. - Such a data set consists of at least seven string columns, consisting of - a catalog name, a schema name, a table name, the grantor of - table privileges, the grantee, the name of the privilege, and - a string indicating whether the grantee may transfer the privilege. - Valid privilege names are "SELECT", "INSERT", "UPDATE", and "DELETE". - The seventh column is either "YES", "NO", or a NULL. Drivers may - add additional columns. - - `hstmt' is a statement handle; its value is returned by the procedure. - - `catalog', `schema', and `table' are strings to be matched when - searching the system catalog. An underscore "_" indicates a - single-character wildcard; a percent sign "%" matches zero or more - characters. - -> (tables hstmt catalog schema table table-type) - - ODBC 1.0. - - Creates a result data set giving information about the tables - in the database system catalog. Such a data set may be - processed as ordinary data. The result data set has at least five - string columns, consisting of the catalog name, schema name, table - name, table type, and descriptive remarks. Drivers may add additional - columns. - - `hstmt' is a statement handle, and its value is returned by the - procedure. - - `catalog', `schema', `table', and `table-type' are strings - to be matched when searching the system catalog. `catalog' and - `schema' may be empty strings for unnamed catalogs and schemas. - In `catalog', `schema', and `table', an underscore "_" may be used - as a single-character wildcard, while a percent sign "%" may be - used to match zero or more arbitrary characters. - - The following remarks apply only to ODBC 3.0 or greater: - - `catalog' may also be the symbol 'sql-all-catalogs. In that case, - if `schema' and `table' are empty strings, the result data set consists - of valid catalog names (the other columns are NULL's). - - `schema' may also be the symbol 'sql-all-schemas. In that case, if - `catalog' and `table' are empty strings, the result data set - consists of valid schema names (the other columns are NULL's). - - `table-type' may also be the symbol 'sql-all-table-types. In that case, - if `catalog', `schema, and `table' are empty strings, the result data set - consists of valid table type names (the other columns are NULL's). - - End of ODBC 3.0-or-greater-specific remarks. - - Other factors may affect the result data set. Please consult an - ODBC reference for more details. - -> (special-columns hstmt rowid catalog schema table scope nullable) - - ODBC 1.0. - - Creates a result data set describing primary key information in a - given table. There may be up to eight ODBC-defined columns in the - resulting data set; a driver may add columns. The contents of those - columns are beyond the scope of this documentation; consult an ODBC - reference for details. - - `hstmt' is a statement handle, and its value is returned by the - procedure. `rowid' is either 'sql-best-rowid, indicating that the - result data set contains a column or columns that uniquely identify - a row in a table; or 'sql-rowver, indicating that the result data set - contains those columns that are automatically updated when a row value - is updated by a transaction. `catalog', `schema', and `table' are - strings. `scope' is either 'sql-scope-currow, indicating that the primary - key sought is for the current row, or 'sql-scope-transaction, indicating - that the primary key applies to the current transaction. `nullable' is - either 'sql-no-nulls, which excludes columns in the result data set that - may contain NULL, or 'sql-nullable, which allows such columns. - -> (statistics hstmt catalog schema table index-type accuracy) - - ODBC 1.0. - - Creates a result data set describing statistics about a table and its - indexes. There are thirteen ODBC-defined columns in the resulting data - set; a driver may add columns. The contents of those columns are beyond - the scope of this documentation; consult an ODBC reference for details. - - `hstmt' is a statement handle, and its value is returned by the - procedure. `catalog', `schema', and `table' are strings. - `index-type' is either 'sql-index-unique, indicating that only unique - indexes are to be considered, or 'sql-index-all, indicating that all - indexes are to be considered. `accuracy' is either 'sql-quick, indicating - that readily-available but perhaps stale data may be used when generating - the data set, or 'sql-ensure, indicating that only up-to-date data is used. - - Errors and Diagnostics - ---------------------- - -> (get-diag-field handle recnum field) - - ODBC 3.0. - - Returns the value of an individual field of a diagnostic header - record or status record. The type of the value depends on the field. - - `handle' may be an environment handle, connection handle, statement - handle, or descriptor handle. `recnum' is a positive integer indicating - which record contains the field. `field' is a symbol, as listed below. - - Please consult an ODBC reference for information on the significance - of individual fields. The valid values for `field' and their corresponding - return types are: - - field returns - ----- ------- - 'sql-diag-dynamic-function string - 'sql-diag-connection-name string - 'sql-diag-class-origin string - 'sql-diag-message-text string - 'sql-diag-server-name string - 'sql-diag-sqlstate string - 'sql-diag-subclass-origin string - 'sql-diag-cursor-row-count integer - 'sql-diag-dynamic-function-code integer - 'sql-diag-number integer - 'sql-diag-row-count integer - 'sql-diag-column-number 'sql-no-column-number, or - 'sql-column-number-unknown, or - integer - 'sql-diag-native integer - 'sql-diag-row-number 'sql-no-row-number, or - 'sql-row-number-unknown, or - integer - 'sql-diag-returncode 'sql-success, or - 'sql-no-data, or - 'sql-invalid-handle, or - 'sql-error, or - 'sql-need-data, or - 'sql-success-with-info - -> (get-diag-rec handle recnum) - - ODBC 3.0. - - Returns a three-element list that describes the last ODBC error, - as indicated by the exn-error, exn-with-info, or exn-no-data - exceptions. - - The first element of the list is a five-character string indicating - an SQL state. The second element of the list is an integer - indicating an error code specific to the data source. The third - element is a string describing the error. See an ODBC reference - for more information on SQL states. - - `handle' may be an environment handle, connection handle, statement - handle, or descriptor handle. `recnum' is a positive integer - indicating a status record index. - -> (sql-error henv hdbc hstmt) - - ODBC 1.0, deprecated in favor of get-diag-rec. - - Returns a three-element list that describes the last ODBC error, - as indicated by the exn-error, exn-with-info, or exn-no-data - exceptions. - - The first element of the list is a five-character string indicating - an SQL state. The second element of the list is an integer - indicating an error code specific to the data source. The third - element is a string describing the error. See an ODBC reference - for more information on SQL states. - - `henv' is an environment handle. `hdbc' is ordinarily a connection - handle, and `hstmt' is ordinarily a statement handle. For information - about `henv', pass the symbol 'sql-null-hdbc for `hdbc' and the - symbol 'sql-null-hstmt for `hstmt'. For information about `hdbc', - when it is a connection handle, pass 'sql-null-hstmt for `hstmt'. - - Utilities - --------- - -> (make-indicator) - - Creates an sql-indicator. - -> (read-indicator an-sql-indicator) - - Given an sql-indicator, returns its stored value, which is - one of 'sql-no-total, 'sql-null-data, 'sql-nts, 'sql-column-ignore, - 'sql-data-at-exec, a pair consisting of 'sql-len-data-at-exec - and an integer, or an integer. - - Please consult an ODBC reference for the significance of these - values. - -> (make-length [n]) - - Creates an sql-length. `n' is an exact integer, which defaults to 0. - -> (read-length an-sql-length) - - Given an sql-length, returns its stored value, which is - an integer. - -> (make-buffer c-type num-elts) - - Creates an sql-buffer. `c-type' is a symbol denoting a C data type - (see "C data types", below) indicating the size of buffer elements. - `num-elts' is a nonnegative exact integer indicating the number - of buffer elements. - - It is the responsibility of the programmer to make sure that - buffers bound to columns have the correct type and adequate - size for the column. If a column has the incorrect type or - is too small, unpredictable effects may occur. - -> (read-buffer sql-buffer) - - Returns the contents of an sql-buffer. For a buffer of type - 'sql-c-char or 'sql-c-wchar, a string is returned. For all other - types, a list of values of appropriate type is returned. In the - case of 'sql-c-wchar, an error occurs if the buffer contains - a character not representable as an ordinary character. - - SrPersist provides no guarantees that a buffer contains valid data. - -> (write-buffer sql-buffer vals) - - Updates the contents of an sql-buffer. The type of `vals' - depends on the C type used to create the buffer. Also, if - `vals' is a list, its length should depend on the size of - `sql-buffer'. For a type of 'sql-c-char or 'sql-c-wchar, `vals' - should be a string. For all other types, `vals' should be a a list - of values of appropriate Scheme type. If the type of `vals' is - incorrect, an error occurs. If `vals' is a string that is longer - than the number of elements in `sql-buffer', or `vals' is a list - longer than the number of elements in `sql-buffer', an error - occurs. - -> (read-row-status an-sql-row-status) - - Given an sql-row-status value, returns a list, each element of which - is one of 'sql-row-deleted, 'sql-row-error, 'sql-row-success, or - 'sql-row-updated. - -> (read-op-parms an-sql-op-parms) - - Available when compiled for ODBC 3.0 or greater. - - Given an sql-op-parms value, returns a list, each element of which - is either 'sql-param-proceed or 'sql-param-ignore. - -> (read-boxed-uint an-sql-boxed-uint) - - Given an sql-boxed-uint, returns an unsigned integer value. - - SQL data types - -------------- - - Data stored in data source have SQL data types. In contrast, - data in sql-buffer's have C data types. - - The significance of most of these types should be clear. Consult - an ODBC reference for more details. - - 'sql-char - 'sql-varchar - 'sql-longvarchar - 'sql-wchar - 'sql-wvarchar - 'sql-wlongvarchar - 'sql-date - 'sql-time - 'sql-timestamp - 'sql-decimal - 'sql-numeric - 'sql-smallint - 'sql-integer - 'sql-real - 'sql-float - 'sql-double - 'sql-bit - 'sql-tinyint - 'sql-bigint - 'sql-binary - 'sql-varbinary - 'sql-longvarbinary - 'sql-interval-year - 'sql-interval-year-to-month - 'sql-interval-hour - 'sql-interval-minute - 'sql-interval-day-to-hour - 'sql-interval-day-to-minute - 'sql-interval-day-to-second - 'sql-interval-hour-to-minute - 'sql-interval-hour-to-second - 'sql-interval-minute-to-second - - [ODBC 3.0 and greater] - 'sql-type-date - 'sql-type-time - 'sql-type-timestamp - - [ODBC 3.5 and greater] - 'sql-guid - - C data types - ------------ - - Data in sql-buffer's have C data types. In contrast, data stored in - data sources have SQL data types. - - The significance of most of these types should be clear. Consult - an ODBC reference for more details. - - 'sql-c-char - 'sql-c-wchar - 'sql-c-long - 'sql-c-short - 'sql-c-float - 'sql-c-double - 'sql-c-date - 'sql-c-time - 'sql-c-timestamp - 'sql-c-binary - 'sql-c-bit - 'sql-c-tinyint - 'sql-c-slong - 'sql-c-sshort - 'sql-c-stinyint - 'sql-c-ulong - 'sql-c-ushort - 'sql-c-utinyint - 'sql-c-bookmark - - [ODBC 3.0 or greater] - 'sql-c-numeric - 'sql-c-timestamp - 'sql-c-type-timestamp - 'sql-c-type-date - 'sql-c-type-time - 'sql-c-interval-year - 'sql-c-interval-month - 'sql-c-interval-day - 'sql-c-interval-hour - 'sql-c-interval-minute - 'sql-c-interval-second - 'sql-c-interval-year-to-month - 'sql-c-interval-day-to-hour - 'sql-c-interval-day-to-minute - 'sql-c-interval-day-to-second - 'sql-c-interval-hour-to-minute - 'sql-c-interval-hour-to-second - 'sql-c-interval-minute-to-second - 'sql-c-sbigint - 'sql-c-ubigint - 'sql-c-varbookmark - - [ODBC 3.5 or greater] - 'sql-c-guid - diff --git a/collects/srpersist/info.ss b/collects/srpersist/info.ss deleted file mode 100644 index 675a9f96..00000000 --- a/collects/srpersist/info.ss +++ /dev/null @@ -1,19 +0,0 @@ -;; info.ss for srpersist collection - -;; no .zo compilation necessary, since all the -;; real code is in C++ - -(lambda (request failure-thunk) - (case request - [(name) "SrPersist"] - [(compile-prefix) void] - [(compile-omit-files) - '("info.ss" - "sigs.ss" - "invoke-1.0.ss" - "invoke-2.0.ss" - "invoke-3.0.ss" - "invoke-3.5.ss" - "srpersist.ss" - "srpersistu.ss")] - [else (failure-thunk)])) diff --git a/collects/srpersist/invoke-1.0.ss b/collects/srpersist/invoke-1.0.ss deleted file mode 100644 index 9e5e0c7c..00000000 --- a/collects/srpersist/invoke-1.0.ss +++ /dev/null @@ -1,3 +0,0 @@ -(define-values/invoke-unit/sig - srpersist:odbc-1.0^ - srpersist@) diff --git a/collects/srpersist/invoke-2.0.ss b/collects/srpersist/invoke-2.0.ss deleted file mode 100644 index ebb9ce67..00000000 --- a/collects/srpersist/invoke-2.0.ss +++ /dev/null @@ -1,3 +0,0 @@ -(define-values/invoke-unit/sig - srpersist:odbc-2.0^ - srpersist@) \ No newline at end of file diff --git a/collects/srpersist/invoke-3.0.ss b/collects/srpersist/invoke-3.0.ss deleted file mode 100644 index 5dd02686..00000000 --- a/collects/srpersist/invoke-3.0.ss +++ /dev/null @@ -1,3 +0,0 @@ -(define-values/invoke-unit/sig - srpersist:odbc-3.0^ - srpersist@) diff --git a/collects/srpersist/invoke-3.5.ss b/collects/srpersist/invoke-3.5.ss deleted file mode 100644 index b60c92d4..00000000 --- a/collects/srpersist/invoke-3.5.ss +++ /dev/null @@ -1,4 +0,0 @@ -(define-values/invoke-unit/sig - srpersist:odbc-3.5^ - srpersist@) - diff --git a/collects/srpersist/sigs.ss b/collects/srpersist/sigs.ss deleted file mode 100644 index 96b4210f..00000000 --- a/collects/srpersist/sigs.ss +++ /dev/null @@ -1,327 +0,0 @@ -;; sigs.ss for srpersist collection - -(define-signature srpersist:odbc-1.0^ - - ; utility - - (make-length - read-length - make-indicator - read-indicator - set-indicator - read-row-status - make-buffer - read-buffer - write-buffer - - ; ODBC procedures - - alloc-connect - alloc-env - alloc-stmt - bind-col - cancel - columns - connect - data-sources - describe-col - disconnect - sql-error - exec-direct - execute - fetch - free-connect - free-env - free-stmt - get-connect-option - get-cursor-name - get-data - get-functions - get-info - get-stmt-option - get-type-info - num-result-cols - param-data - prepare - put-data - row-count - set-connect-option - set-cursor-name - set-param - set-stmt-option - special-columns - statistics - tables - transact - driver-connect - browse-connect - col-attributes - column-privileges - describe-param - extended-fetch - foreign-keys - more-results - native-sql - num-params - param-options - primary-keys - procedure-columns - procedures - set-pos - table-privileges - set-scroll-options - - ; implementation of ODBC macro - - len-binary-attr - - ; structures - - struct:sql-date - make-sql-date - sql-date? - sql-date-year - set-sql-date-year! - sql-date-month - set-sql-date-month! - sql-date-day - set-sql-date-day! - struct:sql-time - make-sql-time - sql-time? - sql-time-hour - set-sql-time-hour! - sql-time-minute - set-sql-time-minute! - sql-time-second - set-sql-time-second! - struct:sql-timestamp - make-sql-timestamp - sql-timestamp? - sql-timestamp-year - set-sql-timestamp-year! - sql-timestamp-month - set-sql-timestamp-month! - sql-timestamp-day - set-sql-timestamp-day! - sql-timestamp-hour - set-sql-timestamp-hour! - sql-timestamp-minute - set-sql-timestamp-minute! - sql-timestamp-second - set-sql-timestamp-second! - sql-timestamp-fraction - set-sql-timestamp-fraction! - - ; exceptions - - struct:exn-with-info - make-exn-with-info - exn-with-info? - exn-with-info-val - set-exn-with-info-val! - struct:exn-invalid-handle - make-exn-invalid-handle - exn-invalid-handle? - struct:exn-error - make-exn-error - exn-error? - struct:exn-need-data - make-exn-need-data - exn-need-data? - exn-need-data-val - set-exn-need-data-val! - struct:exn-still-executing - make-exn-still-executing - exn-still-executing?)) - -(define-signature srpersist:odbc-2.0^ - - ;; ODBC procedures - - ((open srpersist:odbc-1.0^) - bind-parameter - drivers)) - - -(define-signature srpersist:odbc-3.0^ - - ((open srpersist:odbc-2.0^) - - ;; utility - - read-op-parms - - ;; ODBC procedures - - alloc-handle - bind-param - bulk-operations - close-cursor - col-attribute - copy-desc - end-tran - fetch-scroll - free-handle - get-connect-attr - get-desc-field - get-desc-rec - get-diag-field - get-diag-rec - get-env-attr - get-stmt-attr - set-connect-attr - set-desc-field - set-desc-rec - set-env-attr - set-stmt-attr - - ;; structures - - struct:sql-numeric - make-sql-numeric - sql-numeric? - sql-numeric-precision - set-sql-numeric-precision! - sql-numeric-scale - set-sql-numeric-scale! - sql-numeric-sign - set-sql-numeric-sign! - sql-numeric-val - set-sql-numeric-val! - struct:sql-year-interval - make-sql-year-interval - sql-year-interval? - sql-year-interval-sign - set-sql-year-interval-sign! - sql-year-interval-year - set-sql-year-interval-year! - struct:sql-month-interval - make-sql-month-interval - sql-month-interval? - sql-month-interval-sign - set-sql-month-interval-sign! - sql-month-interval-month - set-sql-month-interval-month! - struct:sql-day-interval - make-sql-day-interval - sql-day-interval? - sql-day-interval-sign - set-sql-day-interval-sign! - sql-day-interval-day - set-sql-day-interval-day! - struct:sql-hour-interval - make-sql-hour-interval - sql-hour-interval? - sql-hour-interval-sign - set-sql-hour-interval-sign! - sql-hour-interval-hour - set-sql-hour-interval-hour! - struct:sql-minute-interval - make-sql-minute-interval - sql-minute-interval? - sql-minute-interval-sign - set-sql-minute-interval-sign! - sql-minute-interval-minute - set-sql-minute-interval-minute! - struct:sql-second-interval - make-sql-second-interval - sql-second-interval? - sql-second-interval-sign - set-sql-second-interval-sign! - sql-second-interval-second - set-sql-second-interval-second! - struct:sql-year-to-month-interval - make-sql-year-to-month-interval - sql-year-to-month-interval? - sql-year-to-month-interval-sign - set-sql-year-to-month-interval-sign! - sql-year-to-month-interval-year - set-sql-year-to-month-interval-year! - sql-year-to-month-interval-month - set-sql-year-to-month-interval-month! - struct:sql-day-to-hour-interval - make-sql-day-to-hour-interval - sql-day-to-hour-interval? - sql-day-to-hour-interval-sign - set-sql-day-to-hour-interval-sign! - sql-day-to-hour-interval-day - set-sql-day-to-hour-interval-day! - sql-day-to-hour-interval-hour - set-sql-day-to-hour-interval-hour! - struct:sql-day-to-minute-interval - make-sql-day-to-minute-interval - sql-day-to-minute-interval? - sql-day-to-minute-interval-sign - set-sql-day-to-minute-interval-sign! - sql-day-to-minute-interval-day - set-sql-day-to-minute-interval-day! - sql-day-to-minute-interval-hour - set-sql-day-to-minute-interval-hour! - sql-day-to-minute-interval-minute - set-sql-day-to-minute-interval-minute! - struct:sql-day-to-second-interval - make-sql-day-to-second-interval - sql-day-to-second-interval? - sql-day-to-second-interval-sign - set-sql-day-to-second-interval-sign! - sql-day-to-second-interval-day - set-sql-day-to-second-interval-day! - sql-day-to-second-interval-hour - set-sql-day-to-second-interval-hour! - sql-day-to-second-interval-minute - set-sql-day-to-second-interval-minute! - sql-day-to-second-interval-second - set-sql-day-to-second-interval-second! - struct:sql-hour-to-minute-interval - make-sql-hour-to-minute-interval - sql-hour-to-minute-interval? - sql-hour-to-minute-interval-sign - set-sql-hour-to-minute-interval-sign! - sql-hour-to-minute-interval-hour - set-sql-hour-to-minute-interval-hour! - sql-hour-to-minute-interval-minute - set-sql-hour-to-minute-interval-minute! - struct:sql-hour-to-second-interval - make-sql-hour-to-second-interval - sql-hour-to-second-interval? - sql-hour-to-second-interval-sign - set-sql-hour-to-second-interval-sign! - sql-hour-to-second-interval-hour - set-sql-hour-to-second-interval-hour! - sql-hour-to-second-interval-minute - set-sql-hour-to-second-interval-minute! - sql-hour-to-second-interval-second - set-sql-hour-to-second-interval-second! - struct:sql-minute-to-second-interval - make-sql-minute-to-second-interval - sql-minute-to-second-interval? - sql-minute-to-second-interval-sign - set-sql-minute-to-second-interval-sign! - sql-minute-to-second-interval-minute - set-sql-minute-to-second-interval-minute! - sql-minute-to-second-interval-second - set-sql-minute-to-second-interval-second! - - ;; exceptions - - struct:exn-no-data - make-exn-no-data - exn-no-data?)) - -(define-signature srpersist:odbc-3.5^ - - ((open srpersist:odbc-3.0^) - - struct:sql-guid - make-sql-guid - sql-guid? - sql-guid-data1 - set-sql-guid-data1! - sql-guid-data2 - set-sql-guid-data2! - sql-guid-data3 - set-sql-guid-data3! - sql-guid-data4 - set-sql-guid-data4!)) - diff --git a/collects/srpersist/srpersist.ss b/collects/srpersist/srpersist.ss deleted file mode 100644 index e0988fa6..00000000 --- a/collects/srpersist/srpersist.ss +++ /dev/null @@ -1,22 +0,0 @@ -;; srpersist.ss - -(unless (defined? 'odbc-version) - (error "odbc-version not defined: should be inexact number greater than or equal to 1.0")) - -(require-library "macro.ss") -(require-library "cores.ss") -(require-library "srpersistu.ss" "srpersist") - -(cond - - [(>= odbc-version 3.5) - (require-library "invoke-3.5.ss" "srpersist")] - - [(>= odbc-version 3.0) - (require-library "invoke-3.0.ss" "srpersist")] - - [(>= odbc-version 2.0) - (require-library "invoke-2.0.ss" "srpersist")] - - [(>= odbc-version 1.0) - (require-library "invoke-1.0.ss" "srpersist")]) diff --git a/collects/srpersist/srpersistu.ss b/collects/srpersist/srpersistu.ss deleted file mode 100644 index 2612243e..00000000 --- a/collects/srpersist/srpersistu.ss +++ /dev/null @@ -1,67 +0,0 @@ -(require-relative-library "sigs.ss") - -(define srpersist@ - - (if (defined? 'odbc-version) - - (let ([the-unit - (load-relative-extension - (string-append - (build-path - "lib" - (system-library-subpath) - (case (system-type) - [(unix) "srpmain.so"] - [(windows) "srpmain.dll"] - [(macos) "srpmain.so"] - [else (error "Unknown platform")]))))]) - - (cond - - [(>= odbc-version 3.5) - (compound-unit/sig - (import) - (link [srpersist : srpersist:odbc-3.5^ - ((unit->unit/sig - the-unit - () - srpersist:odbc-3.5^))]) - (export - (open srpersist)))] - - [(>= odbc-version 3.0) - (compound-unit/sig - (import) - (link [srpersist : srpersist:odbc-3.0^ - ((unit->unit/sig - the-unit - () - srpersist:odbc-3.0^))]) - (export - (open srpersist)))] - - [(>= odbc-version 2.0) - (compound-unit/sig - (import) - (link [srpersist : srpersist:odbc-2.0^ - ((unit->unit/sig - the-unit - () - srpersist:odbc-2.0^))]) - (export - (open srpersist)))] - - [(>= odbc-version 1.0) - (compound-unit/sig - (import) - (link [srpersist : srpersist:odbc-1.0^ - ((unit->unit/sig - the-unit - () - srpersist:odbc-1.0^))]) - (export - (open srpersist)))])) - - ; no ODBC version defined - - (error "odbc-version not defined"))) diff --git a/collects/srpersist/tutorial.txt b/collects/srpersist/tutorial.txt deleted file mode 100644 index 5a92799c..00000000 --- a/collects/srpersist/tutorial.txt +++ /dev/null @@ -1,185 +0,0 @@ -SrPersist Tutorial -================== - -If you look at the doc.txt file in the SrPersist collection, -you soon realize that the ODBC standard is quite complex. -It is not necessary to master the standard before using it. -Performing simple data retrievals and insertions is not very -difficult. This tutorial provides some simple examples that -you can start with when writing your own code. - -This tutorial does not address issues of compiling and -installing SrPersist. See the README file in the -SrPersist source directory for such information. - -Allocating handles ------------------- - -Before you can connect to a database, you need to allocate -an environment handle, and a connection handle: - - (define henv (alloc-env) - (define hdbc (alloc-connect henv)) - -We bind these identifiers to the handle values, so that -we can refer to the handles at later points in the program. - -Getting a connection --------------------- - -SrPersist provides three procedures to connect to a database, -two of which we mention here. - -When getting started, you can use - - (driver-connect hdbc "" 'sql-driver-prompt) - -where `hdbc' is the connection handle just allocated. -This procedure displays a dialog box, or series of them. -From the dialog boxes, you should be able to choose -the database system and a particular database to -connect to. This procedure returns a string, which -you can use in place of the empty string the next -time you need to call this procedure. The string -contains information about the database system and -database you chose through the dialogs. Using that -returned string, this procedure will not show a -dialog box. - -Alternatively, you can use - - (connect hdbc dbms name password) - -where again `hdbc' is the connection handle you've -allocated. `dbms', `name', and `password' are strings -indicating a database system (a "data source" in ODBC -parlance), a login name, and login password. Unlike -driver-connect, you have to know the name of the -database system, which may not be obvious. To find out -this information, you can call - - (data-sources henv 'sql-fetch-first) - -to get a data source name and its description. Calling -data-sources with 'sql-fetch-next gets the next data source; -you can continue making such calls until you've enumerated -all possible data sources. - -Making a statement ------------------- - -Once your program is connected to a database system, -you'll want to submit queries in the form of SQL. -Be patient, for it takes several steps to submit such -a query. - -First you'll need to allocate a statement handle -using the existing connection handle: - - (define hstmt (alloc-stmt hdbc)) - -We'll see that we can reuse this statement handle -for several SQL queries. - -When you connected to the database system, you -chose some particular database. The database system -may contain several databases. SQL has the USE statement -to choose among them. In SrPersist, we write: - - (prepare hstmt "USE test_db") - (execute hstmt) - -Note that some database systems, such as Microsoft Access, -do not allow you to switch databases in this way. You can -think of prepare as performing a compilation step; execute -runs the resulting code. - -Now suppose the database test_db contains a table -"people" that has columns for name, a string, and -age, an integer. - -We can make a query to get the desired data from the -database. - - (prepare hstmt "SELECT name,age FROM people") - (execute hstmt) - -Conceptually, the statement above creates a new table, -consisting of rows of data. We need some location -in our program to store the data. ODBC uses buffers -for data storage. SrPersist associates an ODBC C type -with each buffer. - -Assume that the name column consists of strings -no longer than 50 characters. We create a -buffer to hold results: - - (define name-buffer (make-buffer 'sql-c-char 50)) - -For the age column: - - (define age-buffer (make-buffer 'sql-c-slong 1)) - -There are ways to find out the types associated with columns, -but unfortunately, it's a complicated business. There are -actually distinct types (SQL types) for the columns themselves, -and separate C types for buffers that receive their data. -But 'sql-c-char is probably what you want for string buffers, -and 'sql-c-slong for integer buffers. - -We'll need another kind of buffer, an "indicator": - - (define name-indicator (make-indicator)) - (define age-indicator (make-indicator)) - -These indicators do not hold data, just status information. -We can safely ignore their role for the remainder of this -tutorial. - -Next, we wish to associate the buffers we've created with -the database columns: - - (bind-col hstmt 1 name-buffer name-indicator) - (bind-col hstmt 2 age-buffer age-indicator) - -Columns are numbered from 1. Although the people table -may have had the name and age at any position, our -query above created the name column as column 1, -and the age column as column 2. - -Now we can retrieve the data and print it out: - - (with-handlers - ([(lambda (exn) (exn-no-data? exn)) - (lambda (exn) (printf "** End of data **~n"))]) - (let loop () - (fetch hstmt) - (printf "Name: ~a Age: ~a~n" - (read-buffer name-buffer) - (read-buffer age-buffer)) - (loop)) - -The code loops through each row and prints the -values stored in the buffers. When all the -data has been read, the call to fetch raises -the exn-no-data exception. - -Suppose we want to insert a new record into the table people. -Assume that the table consists of the columns name, address, -and age. To perform the insertion, we simply write the -appropriate SQL, and run it: - - (prepare hstmt - (string-append "INSERT INTO people SET " - "name=\"Joe Bloggs\"," - "address=\"123 Main Street\"," - "age=42")) - (execute hstmt) - -If you now perform the SELECT query above, and run the -given loop over the results, you should see the effect -of the insertion. - -While there's much more in the ODBC standard, this example -code should give you the flavor of how it works. - diff --git a/collects/stepper/annotater.ss b/collects/stepper/annotater.ss deleted file mode 100644 index aaa2b3d8..00000000 --- a/collects/stepper/annotater.ss +++ /dev/null @@ -1,862 +0,0 @@ -(unit/sig stepper:annotate^ - (import [z : zodiac:system^] - mzlib:function^ - [e : zodiac:interface^] - [utils : stepper:cogen-utils^] - stepper:marks^ - [s : stepper:model^] - stepper:shared^ - stepper:client-procs^) - - ; ANNOTATE SOURCE CODE - - ; gensyms for annotation: - - ; the mutator-gensym is used in building the mutators that go into certain marks. - ; (define mutator-gensym (gensym "mutator-")) - - ; the `closure-temp' symbol is used for the let which wraps created closures, so - ; that we can stuff them into the hash table. - - ; closure-temp: uninterned-symbol - - (define closure-temp (gensym "closure-temp-")) - - ; dual-map : (('a -> (values 'b 'c)) ('a list)) -> (values ('b list) ('c list)) - - (define (dual-map f . lsts) - (if (null? (car lsts)) - (values null null) - (let+ ([val (values a b) (apply f (map car lsts))] - [val (values a-rest b-rest) (apply dual-map f (map cdr lsts))]) - (values (cons a a-rest) (cons b b-rest))))) - - ; binding-set-union takes some lists of bindings where no element appears twice in one list, and - ; forms a new list which is the union of the sets. - - (define (binding-set-pair-union a-set b-set) - (cond [(or (eq? a-set 'all) (eq? b-set 'all)) 'all] - [else (append a-set (remq* a-set b-set))])) - - (define binding-set-union - (lambda args - (foldl binding-set-pair-union - null - args))) - - (define (binding-set-intersect a-set b-set) - (remq* (remq* a-set b-set) b-set)) - - (define never-undefined? never-undefined-getter) - (define (mark-never-undefined parsed) (never-undefined-setter parsed #t)) - - (define (interlace a b) - (foldr (lambda (a b built) - (cons a (cons b built))) - null - a - b)) - - (define (closure-key-maker closure) - closure) - - ; paroptarglist-> ilist and arglist->ilist are used to recreate - ; mzscheme sexp syntax from the parsed zodiac form, so that the - ; resulting expression can be fed to mzscheme. - - - - ; debug-key: this key will be used as a key for the continuation marks. - - (define debug-key (gensym "debug-key-")) - - ; translate-varref : returns the name the varref will get in the final output - - (define (translate-varref expr) - (if (z:top-level-varref? expr) ; top level varrefs - (z:varref-var expr) - (get-binding-name (z:bound-varref-binding expr)))) - - ; make-debug-info builds the thunk which will be the mark at runtime. It contains - ; a source expression (in the parsed zodiac format) and a set of z:binding/value pairs. - ;((z:parsed (union (list-of z:binding) 'all) (list-of z:binding) symbol) -> - ; debug-info) - - (define (make-debug-info source tail-bound free-bindings label) - (let* ([kept-bindings (if (eq? tail-bound 'all) - free-bindings - (binding-set-intersect tail-bound - free-bindings))] - [var-clauses (map (lambda (x) - (let ([var (get-binding-name x)]) - (list var x))) - kept-bindings)]) - (make-full-mark source label var-clauses))) - - ; cheap-wrap for non-debugging annotation - - (define cheap-wrap - (lambda (zodiac body) - (let ([start (z:zodiac-start zodiac)] - [finish (z:zodiac-finish zodiac)]) - `(#%with-continuation-mark (#%quote ,debug-key) - ,(make-cheap-mark (z:make-zodiac #f start finish)) - ,body)))) - - ; wrap-struct-form - - (define (wrap-struct-form names annotated) - (let* ([arg-temps (build-list (length names) get-arg-binding)] - [arg-temp-syms (map z:binding-var arg-temps)] - [struct-proc-names (cdr names)] - [closure-records (map (lambda (proc-name) `(,make-closure-record - (#%quote ,proc-name) - (#%lambda () #f) - ,(eq? proc-name (car struct-proc-names)))) - struct-proc-names)] - [proc-arg-temp-syms (cdr arg-temp-syms)] - [setters (map (lambda (arg-temp-sym closure-record) - `(,closure-table-put! ,arg-temp-sym ,closure-record)) - proc-arg-temp-syms - closure-records)] - [full-body (append setters (list `(values ,@arg-temp-syms)))]) - `(#%let-values ((,arg-temp-syms ,annotated)) ,@full-body))) - - ; update-closure-record-name : adds a name to an existing closure table record, - ; if there is one for that value. - - (define (update-closure-record-name value name) - (let* ([closure-record (closure-table-lookup value)] - [old-name (closure-record-name closure-record)]) - (if old-name - (e:internal-error "closure-record already has a name: ~a" old-name) - (set-closure-record-name! closure-record name)))) - - - (define initial-env-package null) - - ; annotate takes - ; a) a list of zodiac:read expressions, - ; b) a list of zodiac:parsed expressions, - ; c) a list of previously-defined variables, - ; d) a break routine to be called at breakpoints, and - ; e) a boolean which indicates whether the expression is to be annotated "cheaply". - ; - ; actually, I'm not sure that annotate works for more than one expression, even though - ; it's supposed to take a whole list. I wouldn't count on it. Also, both the red-exprs - ; and break arguments may be #f, the first during a zodiac:elaboration-evaluator call, - ; the second during any non-stepper use. - - (define (annotate red-exprs parsed-exprs input-struct-proc-names break cheap-wrap?) - (local - ( - (define (make-break kind) - `(#%lambda returned-value-list - (,break (continuation-mark-set->list - (current-continuation-marks) - (#%quote ,debug-key)) - (#%quote ,kind) - returned-value-list))) - - ; wrap creates the w-c-m expression. - - (define (simple-wcm-wrap debug-info expr) - `(#%with-continuation-mark (#%quote ,debug-key) ,debug-info ,expr)) - - (define (wcm-pre-break-wrap debug-info expr) - (if break - (simple-wcm-wrap debug-info `(#%begin (,(make-break 'result-break)) ,expr)) - (simple-wcm-wrap debug-info expr))) - - (define (break-wrap expr) - (if break - `(#%begin (,(make-break 'normal-break)) ,expr) - expr)) - - (define (double-break-wrap expr) - (if break - `(#%begin (,(make-break 'double-break)) ,expr) - expr)) - - (define (simple-wcm-break-wrap debug-info expr) - (simple-wcm-wrap debug-info (break-wrap expr))) - - (define (return-value-wrap expr) - (if break - `(#%let* ([result ,expr]) - (,(make-break 'result-break) result) - result) - expr)) - -; For Multiple Values: -; `(#%call-with-values -; (#%lambda () -; expr) -; (#%lambda result-values -; (,(make-break 'result-break) result-values) -; (#%apply #%values result-values)))) - - (define (find-read-expr expr) - (let ([offset (z:location-offset (z:zodiac-start expr))]) - (let search-exprs ([exprs red-exprs]) - (let* ([later-exprs (filter - (lambda (expr) - (<= offset (z:location-offset (z:zodiac-finish expr)))) - exprs)] - [expr - (car later-exprs)]) - (if (= offset (z:location-offset (z:zodiac-start expr))) - expr - (cond - ((z:scalar? expr) (e:static-error "starting offset inside scalar:" offset)) - ((z:sequence? expr) - (let ([object (z:read-object expr)]) - (cond - ((z:list? expr) (search-exprs object)) - ((z:vector? expr) - (search-exprs (vector->list object))) ; can source exprs be here? - ((z:improper-list? expr) - (search-exprs (search-exprs object))) ; can source exprs be here? (is this a bug?) - (else (e:static-error "unknown expression type in sequence" expr))))) - (else (e:static-error "unknown read type" expr)))))))) - - (define (struct-procs-defined expr) - (if (and (z:define-values-form? expr) - (z:struct-form? (z:define-values-form-val expr))) - (map z:varref-var (z:define-values-form-vars expr)) - null)) - - (define struct-proc-names (apply append input-struct-proc-names - (map struct-procs-defined parsed-exprs))) - - (define (non-annotated-proc? varref) - (let ([name (z:varref-var varref)]) - (or (s:check-pre-defined-var name) - (memq name struct-proc-names)))) - - ; annotate/inner takes - ; a) a zodiac expression to annotate - ; b) a list of all findins which this expression is tail w.r.t. - ; or 'all to indicate that this expression is tail w.r.t. _all_ bindings. - ; c) a list of varrefs of 'floating' variables; i.e. lexical bindings NO: TAKEN OUT - ; whose value must be captured in order to reconstruct outer expressions. - ; Necessitated by 'unit', useful for 'letrec*-values'. - ; d) a boolean indicating whether this expression will be the r.h.s. of a reduction - ; (and therefore should be broken before) - ; e) a boolean indicating whether this expression is top-level (and therefore should - ; not be wrapped, if a begin). - ; f) a boolean indicating whether this expression should receive the "cheap wrap" (aka - ; old-style aries annotation) or not. #t => cheap wrap. NOTE: THIS HAS BEEN - ; (TEMPORARILY?) TAKEN OUT/MOVED TO THE TOP LEVEL. - ; - ; it returns - ; a) an annotated s-expression - ; b) a list of varrefs for the variables which occur free in the expression - ; - ;(z:parsed (union (list-of z:varref) 'all) (list-of z:varref) bool bool -> - ; sexp (list-of z:varref)) - - (define (annotate/inner expr tail-bound pre-break? top-level?) - - (let* ([tail-recur (lambda (expr) (annotate/inner expr tail-bound #t #f))] - [define-values-recur (lambda (expr) (annotate/inner expr tail-bound #f #f))] - [non-tail-recur (lambda (expr) (annotate/inner expr null #f #f))] - [lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))] - ; note: no pre-break for the body of a let; it's handled by the break for the - ; let itself. - [let-body-recur (lambda (expr bindings) (annotate/inner expr (binding-set-union tail-bound bindings) #f #f))] - [cheap-wrap-recur (lambda (expr) (let-values ([(ann _) (non-tail-recur expr)]) ann))] - [make-debug-info-normal (lambda (free-bindings) - (make-debug-info expr tail-bound free-bindings 'none))] - [make-debug-info-app (lambda (tail-bound free-bindings label) - (make-debug-info expr tail-bound free-bindings label))] - [wcm-wrap (if pre-break? - wcm-pre-break-wrap - simple-wcm-wrap)] - [wcm-break-wrap (lambda (debug-info expr) - (wcm-wrap debug-info (break-wrap expr)))] - [expr-cheap-wrap (lambda (annotated) (cheap-wrap expr annotated))]) - - ; find the source expression and associate it with the parsed expression - - (when (and red-exprs (not cheap-wrap?)) - (set-expr-read! expr (find-read-expr expr))) - - (cond - - ; the variable forms - - [(z:varref? expr) - (let* ([v (translate-varref expr)] - [real-v (if (z:top-level-varref? expr) - v - (z:binding-orig-name - (z:bound-varref-binding expr)))] - [maybe-undef? (or (and (z:bound-varref? expr) - (not (never-undefined? (z:bound-varref-binding expr)))) - (utils:is-unit-bound? expr))] - [truly-top-level? (and (z:top-level-varref? expr) (not (utils:is-unit-bound? expr)))] - [_ (when truly-top-level? - (utils:check-for-syntax-or-macro-keyword expr))] - [free-bindings (if (z:bound-varref? expr) - (list (z:bound-varref-binding expr)) - null)] - [debug-info (make-debug-info-normal free-bindings)] - [annotated (if (and maybe-undef? (utils:signal-undefined)) - `(#%if (#%eq? ,v ,utils:the-undefined-value) - (#%raise (,utils:make-undefined - ,(format utils:undefined-error-format real-v) - (#%current-continuation-marks) - (#%quote ,v))) - ,v) - v)]) - (values (if cheap-wrap? - (if (or (and maybe-undef? (utils:signal-undefined)) truly-top-level?) - (expr-cheap-wrap annotated) - annotated) - (wcm-break-wrap debug-info (return-value-wrap annotated))) free-bindings))] - - [(z:app? expr) - (let*-values - ([(sub-exprs) (cons (z:app-fun expr) (z:app-args expr))] - [(annotated-sub-exprs free-bindings-sub-exprs) - (dual-map non-tail-recur sub-exprs)] - [(free-bindings) (apply binding-set-union free-bindings-sub-exprs)]) - (if cheap-wrap? - (values (expr-cheap-wrap annotated-sub-exprs) free-bindings) - (let* ([arg-temps (build-list (length sub-exprs) get-arg-binding)] - [arg-temp-syms (map z:binding-var arg-temps)] - [let-clauses `((,arg-temp-syms - (#%values ,@(map (lambda (x) `(#%quote ,*unevaluated*)) arg-temps))))] - [set!-list (map (lambda (arg-symbol annotated-sub-expr) - `(#%set! ,arg-symbol ,annotated-sub-expr)) - arg-temp-syms annotated-sub-exprs)] - [new-tail-bound (binding-set-union tail-bound arg-temps)] - [app-debug-info (make-debug-info-app new-tail-bound arg-temps 'called)] - [annotate-app? (let ([fun-exp (z:app-fun expr)]) - (and (z:top-level-varref? fun-exp) - (non-annotated-proc? fun-exp)))] - [final-app (break-wrap (simple-wcm-wrap app-debug-info - (if annotate-app? - (return-value-wrap arg-temp-syms) - arg-temp-syms)))] - [debug-info (make-debug-info-app new-tail-bound - (binding-set-union free-bindings arg-temps) - 'not-yet-called)] - [let-body (wcm-wrap debug-info `(#%begin ,@set!-list ,final-app))] - [let-exp `(#%let-values ,let-clauses ,let-body)]) - (values let-exp free-bindings))))] - - [(z:struct-form? expr) - (let ([super-expr (z:struct-form-super expr)] - [raw-type (utils:read->raw (z:struct-form-type expr))] - [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) - (if super-expr - (let*-values - ([(annotated-super-expr free-bindings-super-expr) - (non-tail-recur super-expr)] - [(annotated) - `(#%struct - ,(list raw-type annotated-super-expr) - ,raw-fields)] - [(debug-info) (make-debug-info-normal free-bindings-super-expr)]) - (values (if cheap-wrap? - (expr-cheap-wrap annotated) - (wcm-wrap debug-info annotated)) - free-bindings-super-expr)) - (let ([annotated `(#%struct ,raw-type ,raw-fields)]) - (values (if cheap-wrap? - (expr-cheap-wrap annotated) - (wcm-wrap (make-debug-info-normal null) annotated)) - null))))] - - [(z:if-form? expr) - (let*-values - ([(annotated-test free-bindings-test) - (non-tail-recur (z:if-form-test expr))] - [(annotated-then free-bindings-then) - (tail-recur (z:if-form-then expr))] - [(annotated-else free-bindings-else) - (tail-recur (z:if-form-else expr))] - [(free-bindings) (binding-set-union free-bindings-test - free-bindings-then - free-bindings-else)] - [(if-temp-sym) (z:binding-var if-temp)] - [(inner-annotated) `(#%if ,if-temp-sym - ,annotated-then - ,annotated-else)] - [(annotated-2) (if (utils:signal-not-boolean) - `(#%if (#%boolean? ,if-temp-sym) - ,inner-annotated - (#%raise (,utils:make-not-boolean - (#%format ,utils:not-boolean-error-format - ,if-temp-sym) - (#%current-continuation-marks) - ,if-temp-sym))) - inner-annotated)]) - (if cheap-wrap? - (values - (expr-cheap-wrap (if (utils:signal-not-boolean) - `(#%let ((,if-temp-sym ,annotated-test)) ,annotated-2) - `(#%if ,annotated-test ,annotated-then ,annotated-else))) - free-bindings) - (let* ([annotated `(#%begin - (#%set! ,if-temp-sym ,annotated-test) - ,(break-wrap annotated-2))] - [debug-info (make-debug-info-app (binding-set-union tail-bound (list if-temp)) - (binding-set-union free-bindings (list if-temp)) - 'none)] - [wcm-wrapped (wcm-wrap debug-info annotated)] - [outer-annotated `(#%let ((,if-temp-sym (#%quote ,*unevaluated*))) ,wcm-wrapped)]) - (values outer-annotated free-bindings))))] - - [(z:quote-form? expr) - (let ([annotated `(#%quote ,(utils:read->raw (z:quote-form-expr expr)))]) - (values (if cheap-wrap? - annotated - (wcm-wrap (make-debug-info-normal null) annotated)) - null))] - - [(z:begin-form? expr) - (if top-level? - (let*-values - ([(bodies) (z:begin-form-bodies expr)] - [(annotated-bodies free-bindings) - (dual-map (lambda (expr) - (annotate/inner expr 'all #f #t)) - bodies)]) - (values `(#%begin ,@annotated-bodies) - (apply binding-set-union free-bindings))) - (let*-values - ([(bodies) (z:begin-form-bodies expr)] - [(all-but-last-body last-body-list) - (list-partition bodies (- (length bodies) 1))] - [(last-body) (car last-body-list)] - [(annotated-a free-bindings-a) - (dual-map non-tail-recur all-but-last-body)] - [(annotated-final free-bindings-final) - (tail-recur last-body)] - [(free-bindings) (apply binding-set-union free-bindings-final free-bindings-a)] - [(debug-info) (make-debug-info-normal free-bindings)] - [(annotated) `(#%begin ,@(append annotated-a (list annotated-final)))]) - (values (if cheap-wrap? - (expr-cheap-wrap annotated) - (wcm-wrap debug-info annotated)) - free-bindings)))] - - [(z:begin0-form? expr) - (let*-values - ([(bodies) (z:begin0-form-bodies expr)] - [(annotated-bodies free-bindings-lists) - (dual-map non-tail-recur bodies)] - [(free-bindings) (apply binding-set-union free-bindings-lists)] - [(debug-info) (make-debug-info-normal free-bindings)] - [(annotated) `(#%begin0 ,@annotated-bodies)]) - (values (if cheap-wrap? - (expr-cheap-wrap annotated) - (wcm-wrap debug-info annotated)) - free-bindings))] - - ; gott in himmel! this transformation is complicated. Just for the record, - ; here's a sample transformation: - ;(let-values ([(a b c) e1] [(d e) e2]) e3) - ; - ;turns into - ; - ;(let-values ([(dummy1 dummy2 dummy3 dummy4 dummy5) - ; (values *unevaluated* *unevaluated* *unevaluated* *unevaluated* *unevaluated*)]) - ; (with-continuation-mark - ; key huge-value - ; (begin - ; (set!-values (dummy1 dummy2 dummy3) e1) - ; (set!-values (dummy4 dummy5) e2) - ; (let-values ([(a b c d e) (values dummy1 dummy2 dummy3 dummy4 dummy5)]) - ; e3)))) - ; - ; let me know if you can do it in less. - - ; another irritating point: the mark and the break that must go immediately - ; around the body. Irritating because they will be instantly replaced by - ; the mark and the break produced by the annotated body itself. However, - ; they're necessary, because the body may not contain free references to - ; all of the variables defined in the let, and thus their values are not - ; known otherwise. - ; whoops! hold the phone. I think I can get away with a break before, and - ; a mark after, so only one of each. groovy, eh? - - [(z:let-values-form? expr) - (let*-values - ([(binding-sets) (z:let-values-form-vars expr)] - [(binding-set-list) (apply append binding-sets)] - [(vals) (z:let-values-form-vals expr)] - [(_1) (for-each utils:check-for-keyword binding-set-list)] - [(_2) (for-each mark-never-undefined binding-set-list)] - [(annotated-vals free-bindings-vals) - (dual-map non-tail-recur vals)] - [(annotated-body free-bindings-body) - (let-body-recur (z:let-values-form-body expr) binding-set-list)] - [(free-bindings) (apply binding-set-union (remq* binding-set-list free-bindings-body) - free-bindings-vals)]) - (if cheap-wrap? - (let ([bindings - (map (lambda (bindings val) - `(,(map get-binding-name bindings) ,val)) - binding-sets - annotated-vals)]) - (values (expr-cheap-wrap `(#%let-values ,bindings ,annotated-body)) free-bindings)) - (let* ([dummy-binding-sets - (let ([counter 0]) - (map (lambda (binding-set) - (map (lambda (binding) - (begin0 - (get-arg-binding counter) - (set! counter (+ counter 1)))) - binding-set)) - binding-sets))] - [dummy-binding-list (apply append dummy-binding-sets)] - [outer-dummy-initialization - `([,(map z:binding-var dummy-binding-list) - (#%values ,@(build-list (length dummy-binding-list) - (lambda (_) `(#%quote ,*unevaluated*))))])] - [set!-clauses - (map (lambda (dummy-binding-set val) - `(#%set!-values ,(map z:binding-var dummy-binding-set) ,val)) - dummy-binding-sets - annotated-vals)] - [inner-transference - `([,(map get-binding-name binding-set-list) - (values ,@(map z:binding-var dummy-binding-list))])] - ; time to work from the inside out again - [inner-let-values - `(#%let-values ,inner-transference ,annotated-body)] - [middle-begin - `(#%begin ,@set!-clauses ,(double-break-wrap inner-let-values))] - [wrapped-begin - (wcm-wrap (make-debug-info-app (binding-set-union tail-bound dummy-binding-list) - (binding-set-union free-bindings dummy-binding-list) - 'let-body) - middle-begin)] - [whole-thing - `(#%let-values ,outer-dummy-initialization ,wrapped-begin)]) - (values whole-thing free-bindings))))] - - [(z:letrec-values-form? expr) - (let*-values - ([(binding-sets) (z:letrec-values-form-vars expr)] - [(binding-list) (apply append binding-sets)] - [(binding-names) (map get-binding-name binding-list)] - [(vals) (z:letrec-values-form-vals expr)] - [(_1) (when (andmap z:case-lambda-form? vals) - (for-each mark-never-undefined binding-list))] ; we could be more aggressive about this. - [(_2) (for-each utils:check-for-keyword binding-list)] - [(annotated-vals free-bindings-vals) - (dual-map non-tail-recur vals)] - [(annotated-body free-bindings-body) - (let-body-recur (z:letrec-values-form-body expr) - binding-list)] - [(free-bindings-inner) (apply binding-set-union free-bindings-body free-bindings-vals)] - [(free-bindings-outer) (remq* binding-list free-bindings-inner)]) - (if cheap-wrap? - (let ([bindings - (map (lambda (bindings val) - `(,(map get-binding-name bindings) - ,val)) - binding-sets - annotated-vals)]) - (values (expr-cheap-wrap `(#%letrec-values ,bindings ,annotated-body)) - free-bindings-outer)) - (let* ([outer-initialization - `((,binding-names (#%values ,@binding-names)))] - [set!-clauses - (map (lambda (binding-set val) - `(#%set!-values ,(map get-binding-name binding-set) ,val)) - binding-sets - annotated-vals)] - [middle-begin - `(#%begin ,@set!-clauses ,(double-break-wrap annotated-body))] - [wrapped-begin - (wcm-wrap (make-debug-info-app (binding-set-union tail-bound binding-list) - (binding-set-union free-bindings-inner binding-list) - 'let-body) - middle-begin)] - [whole-thing - `(#%letrec-values ,outer-initialization ,wrapped-begin)]) - (values whole-thing free-bindings-outer))))] - - [(z:define-values-form? expr) - (let*-values - ([(vars) (z:define-values-form-vars expr)] - [(_1) (map utils:check-for-keyword vars)] - [(binding-names) (map z:varref-var vars)] - - ; NB: this next recurrence is NOT really tail, but we cannot - ; mark define-values itself, so we mark the sub-expr as - ; if it was in tail posn (i.e., we must hold on to - ; bindings). - - [(val) (z:define-values-form-val expr)] - [(annotated-val free-bindings-val) - (define-values-recur val)]) - (cond [(and (z:case-lambda-form? val) (not cheap-wrap?)) - (values `(#%define-values ,binding-names - (#%let ((,closure-temp ,annotated-val)) - (,update-closure-record-name ,closure-temp (#%quote ,(car binding-names))) - ,closure-temp)) - free-bindings-val)] - [(z:struct-form? val) - (values `(#%define-values ,binding-names - ,(wrap-struct-form binding-names annotated-val)) - free-bindings-val)] - [else - (values `(#%define-values ,binding-names - ,annotated-val) - free-bindings-val)]))] - - [(z:set!-form? expr) - (utils:check-for-keyword (z:set!-form-var expr)) - (let*-values - ([(var) (z:set!-form-var expr)] - [(v) (translate-varref var)] - [(annotated-body rhs-free-bindings) - (non-tail-recur (z:set!-form-val expr))] - [(free-bindings) (binding-set-union (if (z:top-level-varref? var) - null - (list (z:bound-varref-binding var))) - rhs-free-bindings)] - [(debug-info) (make-debug-info-normal free-bindings)] - [(annotated) `(#%set! ,v ,annotated-body)]) - (values (if cheap-wrap? - (expr-cheap-wrap annotated) - (wcm-wrap (make-debug-info-normal free-bindings) annotated)) - free-bindings))] - - [(z:case-lambda-form? expr) - (let*-values - ([(annotated-cases free-bindings-cases) - (dual-map - (lambda (arglist body) - (let ([binding-list (z:arglist-vars arglist)] - [args (utils:arglist->ilist arglist)]) - (utils:improper-foreach utils:check-for-keyword args) - (utils:improper-foreach mark-never-undefined args) - (let*-values - ([(annotated free-bindings) - (lambda-body-recur body)] - [(new-free-bindings) (remq* binding-list free-bindings)] - [(new-annotated) (list (utils:improper-map get-binding-name args) - annotated)]) - (values new-annotated new-free-bindings)))) - (z:case-lambda-form-args expr) - (z:case-lambda-form-bodies expr))] - [(annotated-case-lambda) (cons '#%case-lambda annotated-cases)] - [(new-free-bindings) (apply binding-set-union free-bindings-cases)] - [(closure-info) (make-debug-info-app 'all new-free-bindings 'none)] - [(wrapped-annotated) (wcm-wrap (make-debug-info-normal null) - annotated-case-lambda)] - [(hash-wrapped) `(#%let ([,closure-temp ,wrapped-annotated]) - (,closure-table-put! (,closure-key-maker ,closure-temp) - (,make-closure-record - #f - ,closure-info - #f)) - ,closure-temp)]) - (values (if cheap-wrap? - annotated-case-lambda - hash-wrapped) - new-free-bindings))] - - ; the annotation for w-c-m is insufficient for - ; debugging: there must be an intermediate let & set!s to - ; allow the user to see the computed values for the key and the - ; value. - - [(z:with-continuation-mark-form? expr) - (let*-values - ([(annotated-key free-bindings-key) - (non-tail-recur (z:with-continuation-mark-form-key expr))] - [(annotated-val free-bindings-val) - (non-tail-recur (z:with-continuation-mark-form-val expr))] - [(annotated-body free-bindings-body) - (non-tail-recur (z:with-continuation-mark-form-body expr))] - [(free-bindings) (binding-set-union free-bindings-key free-bindings-val free-bindings-body)] - [(debug-info) (make-debug-info-normal free-bindings)] - [(annotated) `(#%with-continuation-mark - ,annotated-key - ,annotated-val - ,annotated-body)]) - (values (if cheap-wrap? - (expr-cheap-wrap annotated) - (wcm-wrap debug-info annotated)) - free-bindings))] - - [(not cheap-wrap?) - (e:static-error "cannot annotate units or classes except in cheap-wrap mode")] - - [(z:unit-form? expr) - (let* ([imports (z:unit-form-imports expr)] - [exports (map (lambda (export) - (list (translate-varref (car export)) - (z:read-object (cdr export)))) - (z:unit-form-exports expr))] - [clauses (map annotate/top-level (z:unit-form-clauses expr))]) - (for-each utils:check-for-keyword imports) - (values - `(#%unit - (import ,@(map get-binding-name imports)) - (export ,@exports) - ,@clauses) - null))] - - [(z:compound-unit-form? expr) - (let ((imports (map get-binding-name - (z:compound-unit-form-imports expr))) - (links (z:compound-unit-form-links expr)) - (exports (z:compound-unit-form-exports expr))) - (let - ((links - (map - (lambda (link-clause) - (let* ([tag (utils:read->raw (car link-clause))] - [sub-unit (cheap-wrap-recur (cadr link-clause))] - [imports - (map (lambda (import) - (if (z:lexical-varref? import) - (translate-varref import) - `(,(utils:read->raw (car import)) - ,(utils:read->raw (cdr import))))) - (cddr link-clause))]) - `(,tag (,sub-unit ,@imports)))) - links)) - (exports - (map - (lambda (export-clause) - `(,(utils:read->raw (car export-clause)) - (,(utils:read->raw (cadr export-clause)) - ,(utils:read->raw (cddr export-clause))))) - exports))) - (let ((e `(#%compound-unit - (import ,@imports) - (link ,@links) - (export ,@exports)))) - (values (expr-cheap-wrap e) null))))] - - [(z:invoke-unit-form? expr) - (values - (expr-cheap-wrap `(#%invoke-unit ,(cheap-wrap-recur (z:invoke-unit-form-unit expr)) - ,@(map translate-varref - (z:invoke-unit-form-variables expr)))) - null)] - - [(z:interface-form? expr) - (let ([vars (z:interface-form-variables expr)]) - (for-each utils:check-for-keyword vars) - (values - (expr-cheap-wrap - `(#%interface ,(map cheap-wrap-recur - (z:interface-form-super-exprs expr)) - ,@(map utils:read->raw vars))) - null))] - - [(z:class*/names-form? expr) - (let* ([process-arg - (lambda (element) - (if (pair? element) - (and (utils:check-for-keyword (car element)) - (list (get-binding-name (car element)) - (cheap-wrap-recur (cdr element)))) - (and (utils:check-for-keyword element) - (get-binding-name element))))] - [paroptarglist->ilist - (lambda (paroptarglist) - (cond - ((z:sym-paroptarglist? paroptarglist) - (process-arg (car (z:paroptarglist-vars paroptarglist)))) - ((z:list-paroptarglist? paroptarglist) - (map process-arg (z:paroptarglist-vars paroptarglist))) - ((z:ilist-paroptarglist? paroptarglist) - (let loop ((vars (map process-arg - (z:paroptarglist-vars paroptarglist)))) - (if (null? (cddr vars)) - (cons (car vars) (cadr vars)) - (cons (car vars) (loop (cdr vars)))))) - (else - (e:internal-error paroptarglist - "Given to paroptarglist->ilist"))))]) - (values - (expr-cheap-wrap - `(#%class*/names - (,(get-binding-name (z:class*/names-form-this expr)) - ,(get-binding-name (z:class*/names-form-super-init expr))) - ,(cheap-wrap-recur (z:class*/names-form-super-expr expr)) - ,(map cheap-wrap-recur (z:class*/names-form-interfaces expr)) - ,(paroptarglist->ilist (z:class*/names-form-init-vars expr)) - ,@(map - (lambda (clause) - (cond - ((z:public-clause? clause) - `(public - ,@(map (lambda (internal export expr) - `((,(get-binding-name internal) - ,(utils:read->raw export)) - ,(cheap-wrap-recur expr))) - (z:public-clause-internals clause) - (z:public-clause-exports clause) - (z:public-clause-exprs clause)))) - ((z:override-clause? clause) - `(override - ,@(map (lambda (internal export expr) - `((,(get-binding-name internal) - ,(utils:read->raw export)) - ,(cheap-wrap-recur expr))) - (z:override-clause-internals clause) - (z:override-clause-exports clause) - (z:override-clause-exprs clause)))) - ((z:private-clause? clause) - `(private - ,@(map (lambda (internal expr) - `(,(get-binding-name internal) - ,(cheap-wrap-recur expr))) - (z:private-clause-internals clause) - (z:private-clause-exprs clause)))) - ((z:inherit-clause? clause) - `(inherit - ,@(map (lambda (internal inherited) - `(,(get-binding-name internal) - ,(utils:read->raw inherited))) - (z:inherit-clause-internals clause) - (z:inherit-clause-imports clause)))) - ((z:rename-clause? clause) - `(rename - ,@(map (lambda (internal import) - `(,(get-binding-name internal) - ,(utils:read->raw import))) - (z:rename-clause-internals clause) - (z:rename-clause-imports clause)))) - ((z:sequence-clause? clause) - `(sequence - ,@(map cheap-wrap-recur - (z:sequence-clause-exprs clause)))))) - (z:class*/names-form-inst-clauses expr)))) - null))] - - [else - (e:internal-error - expr - "stepper:annotate/inner: unknown object to annotate, ~a~n" - expr)]))) - - (define (annotate/top-level expr) - (let-values ([(annotated dont-care) - (annotate/inner expr 'all #f #t)]) - annotated))) - - ; body of local - - (let* ([annotated-exprs (map (lambda (expr) - (annotate/top-level expr)) - parsed-exprs)]) - (values annotated-exprs - struct-proc-names)))) - -) - diff --git a/collects/stepper/break.ss b/collects/stepper/break.ss deleted file mode 100644 index c8dd6cdf..00000000 --- a/collects/stepper/break.ss +++ /dev/null @@ -1,26 +0,0 @@ -(unit/sig (break) - (import [mred : mred^] - [marks : stepper:marks^] - [annotate : stepper:annotate^]) - - (define drscheme-eventspace (mred:current-eventspace)) - (define break-semaphore (make-semaphore)) - (define break-resume-value #f) - - (define (break) - (let ([break-info (continuation-mark-set->list (current-continuation-marks) - annotate:debug-key)]) - (parameterize - ([mred:current-eventspace drscheme-eventspace]) - (mred:queue-callback - (lambda () - (current-namespace (make-namespace)) - (global-defined-value 'break-info break-info) - (global-defined-value 'break-resume (lambda (val) - (set! break-resume-value val) - (semaphore-post break-semaphore))) - (global-defined-value 'expose-mark marks:expose-mark) - (global-defined-value 'display-mark marks:display-mark) - (mred:graphical-read-eval-print-loop))) - (semaphore-wait break-semaphore) - break-resume-value)))) \ No newline at end of file diff --git a/collects/stepper/client-procs.ss b/collects/stepper/client-procs.ss deleted file mode 100644 index 85d73fa4..00000000 --- a/collects/stepper/client-procs.ss +++ /dev/null @@ -1,14 +0,0 @@ -(unit/sig stepper:client-procs^ - (import [z : zodiac:system^]) - - (define (make-client-pair name) - (let-values ([(getter setter) (z:register-client name (lambda () #f))]) - (values - (lambda (parsed) (getter (z:parsed-back parsed))) - (lambda (parsed n) (setter (z:parsed-back parsed) n))))) - - (define-values (never-undefined-getter never-undefined-setter) - (make-client-pair 'maybe-undefined)) - - (define-values (read-getter read-setter) - (make-client-pair 'read))) \ No newline at end of file diff --git a/collects/stepper/debug-wrapper.ss b/collects/stepper/debug-wrapper.ss deleted file mode 100644 index 73d9634f..00000000 --- a/collects/stepper/debug-wrapper.ss +++ /dev/null @@ -1,40 +0,0 @@ -(unit/sig plt:aries-no-break^ - (import [zodiac : zodiac:system^] - [utils : stepper:cogen-utils^] - [marks : stepper:marks^] - [annotate : stepper:annotate^]) - - (define w-c-m-key annotate:debug-key) - - (define current-environments #f) - - (define (annotate sexp zodiac-read) - (let-values - ([(annotateds new-envs) - (annotate:annotate (and zodiac-read (list zodiac-read)) - (list sexp) - current-environments - #f - #t)]) - (set! current-environments new-envs) - (car annotateds))) - - (define (extract-zodiac-location mark-set) - (let ([mark-list (continuation-mark-set->list mark-set annotate:debug-key)]) - (if (null? mark-list) - #f - (marks:mark-source (car mark-list))))) - - (define (make-zodiac-mark location) - (marks:make-cheap-mark location)) - - (define signal-not-boolean utils:signal-not-boolean) - (define signal-undefined utils:signal-undefined) - - ; initialization --- should be called once per execute - ; (except that (2000-02-20) it doesn't matter anyway because - ; these environments are totally irrelevant to non-stepper - ; use of the annotater. - (set! current-environments annotate:initial-env-package)) - - \ No newline at end of file diff --git a/collects/stepper/doc.txt b/collects/stepper/doc.txt deleted file mode 100644 index caaabc93..00000000 --- a/collects/stepper/doc.txt +++ /dev/null @@ -1,36 +0,0 @@ -What is the _Stepper_? - -DrScheme includes an "algebraic stepper," a tool which proceeds through the -evaluation of a set of definitions and expressions, one step at a time. -This evaluation shows the user how DrScheme evaluates expressions and -definitions, and can help in debugging programs. Currently, the Stepper is -available in the "Beginner" and "Intermediate" language levels. - -How do I use the Stepper? - -The Stepper operates on the contents of the frontmost DrScheme window. A click -on the "Step" button brings up the stepper window. The stepper window has -three boxes; each one is separated by a blue horizontal line. - -The first box shows definitions and expressions whose evaluation is -complete. This box is changed only when another completed evaluation's -result is added to it. - -The second box shows the current expression. The region highlighted in -green is known as the "redex". You may pronounce this word in any way you -want. It is short for "reducible expression," and it is the expression -which is the next to be simplified. - -The third box shows the result of the reduction. The region highlighted -in purple is the new expression which is substituted for the green one as -a result of the reduction. - -For more information on how DrScheme selects a "redex" and how the -expressions are reduced, please see The Beginner Language Semantics -which formally specify the set of rules governing the language's evaluation. - -There are three buttons at the top of the stepper window. The "Home" -button returns to the initial state of the evaluation: id est, no -expressions have yet been evaluated. The "Previous" button returns to the -prior step of the evaluation. The "Next" step shows the next step in the -evaluation. diff --git a/collects/stepper/fake-model.ss b/collects/stepper/fake-model.ss deleted file mode 100644 index 2d0d9697..00000000 --- a/collects/stepper/fake-model.ss +++ /dev/null @@ -1,19 +0,0 @@ -; this is an icky hack: the annotater wants to know whether procedures are primitives; -; if they are, it wraps their applications with return-value breaks. For the purposes -; of the debugger, it doesn't matter, since no breaks are really inserted anyway. -; So this unit is a complete farce. - -(unit/sig stepper:model^ - (import) - - (define check-pre-defined-var - (lambda (ignored) #f)) - - (define check-global-defined 'fake) - (define global-lookup 'fake) - (define constructor-style-printing? 'fake) - (define abbreviate-cons-as-list? 'fake) - (define user-cons? 'fake) - (define user-vector? 'fake) - (define image? 'fake) - (define print-convert 'fake)) \ No newline at end of file diff --git a/collects/stepper/info.ss b/collects/stepper/info.ss deleted file mode 100644 index dcbbde1e..00000000 --- a/collects/stepper/info.ss +++ /dev/null @@ -1,7 +0,0 @@ -(lambda (request failure) - (case request - [(name) "stepper"] - [(compile-prefix) '(begin (require-library "sig.ss" "stepper") - (require-library "drsig.ss" "drscheme"))] - [(compile-omit-files) '("test.ss" "testr.ss" "sig.ss")] - [else (failure)])) \ No newline at end of file diff --git a/collects/stepper/instance.ss b/collects/stepper/instance.ss deleted file mode 100644 index 191cd60d..00000000 --- a/collects/stepper/instance.ss +++ /dev/null @@ -1,46 +0,0 @@ -; stepper-instance - -(compound-unit/sig - (import (model-input : stepper:model-input^) - (core : mzlib:core^) - (error : zodiac:interface^) - (print-convert : mzlib:print-convert^) - (drscheme : drscheme:export^) - (zodiac : zodiac:system^) - (zcp : stepper:client-procs^) - (shared : stepper:shared^) - (mred : mred^) - (utils : stepper:cogen-utils^) - (marks : stepper:marks^)) - (link [stepper-annotate : stepper:annotate^ - ((require-library-unit/sig "annotater.ss" "stepper") - zodiac - (core function) - error - utils - marks - stepper - shared - zcp)] - [reconstruct : stepper:reconstruct^ - ((require-library-unit/sig "reconstructr.ss" "stepper") - zodiac - (core function) - error - utils - (drscheme basis) - marks - stepper - shared)] - [stepper : stepper:model^ - ((require-library-unit/sig "model.ss" "stepper") - model-input - mred - zodiac - drscheme - print-convert - error - stepper-annotate - reconstruct - shared)]) - (export)) diff --git a/collects/stepper/link-jr.ss b/collects/stepper/link-jr.ss deleted file mode 100644 index 112fa737..00000000 --- a/collects/stepper/link-jr.ss +++ /dev/null @@ -1,42 +0,0 @@ -(compound-unit/sig - (import (core : mzlib:core^) - (zodiac : zodiac:system^) - (error : zodiac:interface^)) - (link [pretty : mzlib:pretty-print^ ((require-library-unit/sig "prettyr.ss"))] - [client-procs : stepper:client-procs^ - ((require-library-unit/sig "client-procs.ss" "stepper") - zodiac)] - [marks : stepper:marks^ - ((require-library-unit/sig "marks.ss" "stepper") - zodiac - client-procs - (core function))] - [utils : stepper:cogen-utils^ - ((require-library-unit/sig "utils.ss" "stepper") - zodiac - error)] - [shared : stepper:shared^ ((require-library-unit/sig "sharedr.ss" "stepper") - zodiac - error - client-procs)] - [fake-stepper : stepper:model^ - ((require-library-unit/sig "fake-model.ss" "stepper"))] - [annotate : stepper:annotate^ - ((require-library-unit/sig "annotater.ss" "stepper") - zodiac - (core function) - error - utils - marks - fake-stepper - shared - client-procs)] - [debug-wrapper : plt:aries-no-break^ - ((require-library-unit/sig "debug-wrapper.ss" "stepper") - zodiac - utils - marks - annotate)] - [break : (break) - ((unit/sig (break) (import) (define break (lambda () #f))))]) - (export (open debug-wrapper) (open break))) \ No newline at end of file diff --git a/collects/stepper/link.ss b/collects/stepper/link.ss deleted file mode 100644 index 652740e0..00000000 --- a/collects/stepper/link.ss +++ /dev/null @@ -1,72 +0,0 @@ -; link.ss - -(compound-unit/sig - (import (core : mzlib:core^) - (framework : framework^) - (print-convert : mzlib:print-convert^) - (mred : mred^) - (drscheme : drscheme:export^) - (zodiac : zodiac:system^) - (error : zodiac:interface^)) - (link [pretty : mzlib:pretty-print^ ((require-library-unit/sig "prettyr.ss"))] - [client-procs : stepper:client-procs^ - ((require-library-unit/sig "client-procs.ss" "stepper") - zodiac)] - [marks : stepper:marks^ - ((require-library-unit/sig "marks.ss" "stepper") - zodiac - client-procs - (core function))] - [utils : stepper:cogen-utils^ - ((require-library-unit/sig "utils.ss" "stepper") - zodiac - error)] - [shared : stepper:shared^ ((require-library-unit/sig "sharedr.ss" "stepper") - zodiac - error - client-procs)] - [fake-stepper : stepper:model^ - ((require-library-unit/sig "fake-model.ss" "stepper"))] - [annotate : stepper:annotate^ - ((require-library-unit/sig "annotater.ss" "stepper") - zodiac - (core function) - error - utils - marks - fake-stepper - shared - client-procs)] - [debug-wrapper : plt:aries-no-break^ - ((require-library-unit/sig "debug-wrapper.ss" "stepper") - zodiac - utils - marks - annotate)] - [break : (break) - ((require-library-unit/sig "break.ss" "stepper") - mred - marks - annotate)] - [stepper-view-controller : (stepper-go) - ((require-library-unit/sig "view-controller.ss" "stepper") - core - error - zodiac - client-procs - pretty - mred - drscheme - print-convert - framework - shared - utils - marks)] - [stepper-startup : () - ((require-library-unit/sig "startup.ss" "stepper") - core - mred - framework - drscheme - stepper-view-controller)]) - (export (open debug-wrapper) (open break))) diff --git a/collects/stepper/marks.ss b/collects/stepper/marks.ss deleted file mode 100644 index d13b801c..00000000 --- a/collects/stepper/marks.ss +++ /dev/null @@ -1,74 +0,0 @@ -(unit/sig stepper:marks^ - (import [z : zodiac:system^] - [cp : stepper:client-procs^] - mzlib:function^) - - (define (make-full-mark location label bindings) - `(#%lambda () (#%list ,location (#%quote ,label) ,@(apply append bindings)))) - - (define (make-cheap-mark location) - location) - - (define (cheap-mark? mark) - (z:zodiac? mark)) - - (define (cheap-mark-source mark) - mark) - - (define (mark-source mark) - (if (cheap-mark? mark) - (cheap-mark-source mark) - (car (mark)))) - - (define (mark-bindings mark) - (letrec ([pair-off - (lambda (lst) - (cond [(null? lst) null] - [(null? (cdr lst)) (error 'mark-bindings "uneven number of vars and bindings")] - [else (cons (list (car lst) (cadr lst)) (pair-off (cddr lst)))]))]) - (pair-off (cddr (mark))))) - - (define (mark-label mark) - (cadr (mark))) - - (define (mark-binding-value mark-binding) - (car mark-binding)) - - (define (mark-binding-binding mark-binding) - (cadr mark-binding)) - - (define (expose-mark mark) - (let ([source (mark-source mark)] - [label (mark-label mark)] - [bindings (mark-bindings mark)]) - (list source - label - (map (lambda (binding) - (list (z:binding-orig-name (mark-binding-binding binding)) - (mark-binding-value binding))) - bindings)))) - - (define (display-mark mark) - (let ([exposed (expose-mark mark)]) - (printf "source: ~a~n" (let ([read (cp:read-getter (car exposed))]) - (and read - (z:sexp->raw read)))) - (printf "label: ~a~n" (cadr exposed)) - (printf "bindings:~n") - (for-each (lambda (binding-pair) - (printf " ~a : ~a~n" (car binding-pair) (cadr binding-pair))) - (caddr exposed)))) - - (define (lookup-binding mark-list binding) - (if (null? mark-list) - (error 'lookup-binding "variable not found in environment: ~a" binding) - (let* ([bindings (mark-bindings (car mark-list))] - [matches (filter (lambda (b) - (eq? binding (mark-binding-binding b))) - bindings)]) - (cond [(null? matches) - (lookup-binding (cdr mark-list) binding)] - [(> (length matches) 1) - (error 'lookup-binding "more than one variable binding found for binding: ~a" binding)] - [else ; (length matches) = 1 - (car matches)]))))) diff --git a/collects/stepper/model.ss b/collects/stepper/model.ss deleted file mode 100644 index 452ba7e5..00000000 --- a/collects/stepper/model.ss +++ /dev/null @@ -1,286 +0,0 @@ -(unit/sig stepper:model^ - (import [i : stepper:model-input^] - mred^ - [z : zodiac:system^] - [d : drscheme:export^] - [p : mzlib:print-convert^] - [e : zodiac:interface^] - [a : stepper:annotate^] - [r : stepper:reconstruct^] - stepper:shared^) - - (define image? i:image?) - - (define (send-to-other-eventspace eventspace thunk) - (parameterize ([current-eventspace eventspace]) - (queue-callback thunk))) - - (define drscheme-eventspace (current-eventspace)) - - (define (send-to-drscheme-eventspace thunk) - (send-to-other-eventspace drscheme-eventspace thunk)) - - (define par-constructor-style-printing #f) - (define (constructor-style-printing?) - par-constructor-style-printing) - - (define par-abbreviate-cons-as-list #f) - (define (abbreviate-cons-as-list?) - par-abbreviate-cons-as-list) - - (define par-cons #f) - (define (user-cons? val) - (eq? val par-cons)) - - (define par-vector #f) - (define (user-vector? val) - (eq? val par-vector)) - - (define user-pre-defined-vars #f) - - (define (check-pre-defined-var identifier) - (memq identifier user-pre-defined-vars)) - - (define user-namespace #f) - - (define (check-global-defined identifier) - (with-handlers - ([exn:variable? (lambda args #f)]) - (global-lookup identifier) - #t)) - - (define (global-lookup identifier) - (parameterize ([current-namespace user-namespace]) - (global-defined-value identifier))) - - (define finished-exprs null) - - (define current-expr #f) - (define packaged-envs a:initial-env-package) - - (define user-eventspace (make-eventspace)) - - ;; user eventspace management - - ; here's how this stuff works. To prevent the processing of any old events - ; on the user's eventspace queue, suspend-user-computation basically sits - ; on the thread. The only way to get anything done on this thread is to - ; release the stepper-semaphore, either with a command of 'step, which - ; allows the user-eventspace thread to return to whatever it was doing - ; when it was suspended, or with a thunk command, in which case the - ; user eventspace thread goes and executes that thunk before resuming - ; waiting. The stepper-command-waiting semaphore is used to prevent - ; stacked requests from demolishing each other. It might be better to - ; use a queue for this. - - (define stepper-semaphore (make-semaphore)) - (define stepper-command-waiting-semaphore (make-semaphore)) - (semaphore-post stepper-command-waiting-semaphore) - (define stepper-return-val-semaphore (make-semaphore)) - (define stepper-awaken-arg #f) - (define eval-depth 0) - - (define (suspend-user-computation) - (semaphore-wait stepper-semaphore) - (let ([local-awaken-arg stepper-awaken-arg]) - (semaphore-post stepper-command-waiting-semaphore) - (cond - [(eq? local-awaken-arg 'step) - (void)] - [(procedure? local-awaken-arg) - (set! eval-depth (+ eval-depth 1)) - (local-awaken-arg) - (set! eval-depth (- eval-depth 1)) - (suspend-user-computation)] - [else (e:internal-error "unknown value in stepper-awaken-arg.")]))) - - (define (continue-user-computation) - (semaphore-wait stepper-command-waiting-semaphore) - (set! stepper-awaken-arg 'step) - (semaphore-post stepper-semaphore)) - - (define (send-to-user-eventspace thunk) - (semaphore-wait stepper-command-waiting-semaphore) - (set! stepper-awaken-arg thunk) - (semaphore-post stepper-semaphore)) - - ;; start user thread going - (send-to-other-eventspace - user-eventspace - suspend-user-computation) - - (define user-primitive-eval #f) - (define user-vocabulary #f) - - (define reader - (z:read i:text-stream - (z:make-location 1 1 0 "stepper-text"))) - - (send-to-user-eventspace - (lambda () - (set! user-primitive-eval (current-eval)) - (d:basis:initialize-parameters (make-custodian) i:settings) - (set! user-namespace (current-namespace)) - (set! user-pre-defined-vars (map car (make-global-value-list))) - (set! user-vocabulary (d:basis:current-vocabulary)) - (set! par-constructor-style-printing (p:constructor-style-printing)) - (set! par-abbreviate-cons-as-list (p:abbreviate-cons-as-list)) - (set! par-cons (global-defined-value 'cons)) - (set! par-vector (global-defined-value 'vector)) - (semaphore-post stepper-return-val-semaphore))) - (semaphore-wait stepper-return-val-semaphore) - - (define print-convert - (let ([print-convert-result 'not-a-real-value]) - (lambda (val) - (send-to-user-eventspace - (lambda () - (set! print-convert-result - (parameterize ([p:current-print-convert-hook - (lambda (v basic-convert sub-convert) - (if (image? v) - v - (basic-convert v)))]) - (p:print-convert val))) - (semaphore-post stepper-return-val-semaphore))) - (semaphore-wait stepper-return-val-semaphore) - print-convert-result))) - - (define (read-next-expr) - (send-to-user-eventspace - (lambda () - (let/ec k - (let ([exception-handler (make-exception-handler k)]) - (d:interface:set-zodiac-phase 'reader) - (let* ([new-expr (with-handlers - ((exn:read? exception-handler)) - (reader))]) - (if (z:eof? new-expr) - (begin - (send-to-drscheme-eventspace - (lambda () - (i:receive-result (make-finished-result finished-exprs)))) - 'finished) - (let* ([new-parsed (if (z:eof? new-expr) - #f - (begin - (d:interface:set-zodiac-phase 'expander) - (with-handlers - ((exn:syntax? exception-handler)) - (z:scheme-expand new-expr 'previous user-vocabulary))))]) - (let*-values ([(annotated-list envs) (a:annotate (list new-expr) (list new-parsed) packaged-envs break #f)] - [(annotated) (car annotated-list)]) - (set! packaged-envs envs) - (set! current-expr new-parsed) - (check-for-repeated-names new-parsed exception-handler) - (let ([expression-result - (parameterize ([current-exception-handler exception-handler]) - (user-primitive-eval annotated))]) - (send-to-drscheme-eventspace - (lambda () - (add-finished-expr expression-result) - (read-next-expr))))))))))))) - - (define (check-for-repeated-names expr exn-handler) - (with-handlers - ([exn:user? exn-handler] - [exn:syntax? exn-handler]) - (when (z:define-values-form? expr) - (for-each (lambda (name) - (when (check-global-defined name) - (e:static-error expr - "name is already bound: ~s" name))) - (map z:varref-var (z:define-values-form-vars expr)))))) - - (define (add-finished-expr expression-result) - (let ([reconstructed (r:reconstruct-completed current-expr expression-result)]) - (set! finished-exprs (append finished-exprs (list reconstructed))))) - - (define held-expr no-sexp) - (define held-redex no-sexp) - - (define (break mark-list break-kind returned-value-list) - (let ([reconstruct-helper - (lambda (finish-thunk) - (send-to-drscheme-eventspace - (lambda () - (let* ([reconstruct-pair - (r:reconstruct-current current-expr mark-list break-kind returned-value-list)] - [reconstructed (car reconstruct-pair)] - [redex (cadr reconstruct-pair)]) - (finish-thunk reconstructed redex)))))]) - (case break-kind - [(normal-break) - (when (not (r:skip-redex-step? mark-list)) - (reconstruct-helper - (lambda (reconstructed redex) - (set! held-expr reconstructed) - (set! held-redex redex) - (continue-user-computation))) - (suspend-user-computation))] - [(result-break) - (when (not (or (r:skip-redex-step? mark-list) - (and (null? returned-value-list) - (eq? held-expr no-sexp)))) - (reconstruct-helper - (lambda (reconstructed reduct) -; ; this invariant (contexts should be the same) -; ; fails in the presence of unannotated code. For instance, -; ; currently (map my-proc (cons 3 empty)) goes to -; ; (... ...), where the context of the first one is -; ; empty and the context of the second one is (... ...). -; ; so, I'll just disable this invariant test. -; (when (not (equal? reconstructed held-expr)) -; (e:internal-error 'reconstruct-helper -; "pre- and post- redex/uct wrappers do not agree:~nbefore: ~a~nafter~a" -; held-expr reconstructed)) - (let ([result (make-before-after-result finished-exprs - held-expr - held-redex - reconstructed - reduct)]) - (set! held-expr no-sexp) - (set! held-redex no-sexp) - (i:receive-result result)))) - (suspend-user-computation))] - [(double-break) - ; a double-break occurs at the beginning of a let's body. - (send-to-drscheme-eventspace - (lambda () - (let* ([reconstruct-quintuple - (r:reconstruct-current current-expr mark-list break-kind returned-value-list)]) - (set! finished-exprs (append finished-exprs (car reconstruct-quintuple))) - (when (not (eq? held-expr no-sexp)) - (e:internal-error 'break-reconstruction - "held-expr not empty when a double-break occurred")) - (i:receive-result (apply make-before-after-result - finished-exprs - (cdr reconstruct-quintuple)))))) - (suspend-user-computation)] - [else (e:internal-error 'break "unknown label on break")]))) - - (define (handle-exception exn) - (if (not (eq? held-expr no-sexp)) - (begin - (printf "held-expr: ~a~n" held-expr) - (i:receive-result (make-before-error-result finished-exprs held-expr held-redex (exn-message exn)))) - (begin - (printf "no held sexp~n") - (i:receive-result (make-error-result finished-exprs (exn-message exn)))))) - - (define (make-exception-handler k) - (lambda (exn) - (send-to-drscheme-eventspace - (lambda () - (handle-exception exn))) - (k))) - - ; start the ball rolling with a "fake" user computation - (send-to-user-eventspace - (lambda () - (suspend-user-computation) - (send-to-drscheme-eventspace - read-next-expr))) - - ; result of invoking stepper-instance : (->) - continue-user-computation) \ No newline at end of file diff --git a/collects/stepper/reconstructr.ss b/collects/stepper/reconstructr.ss deleted file mode 100644 index 627837c7..00000000 --- a/collects/stepper/reconstructr.ss +++ /dev/null @@ -1,623 +0,0 @@ -(unit/sig stepper:reconstruct^ - (import [z : zodiac:system^] - mzlib:function^ - [e : zodiac:interface^] - [utils : stepper:cogen-utils^] - [b : plt:basis^] - stepper:marks^ - [s : stepper:model^] - stepper:shared^) - - (define the-undefined-value (letrec ([x x]) x)) - - (define nothing-so-far (gensym "nothing-so-far-")) - - (define memoized-read->raw - (let ([table (make-hash-table-weak)]) - (lambda (read) - (or (hash-table-get table read (lambda () #f)) - (let ([raw (z:sexp->raw read)]) - (hash-table-put! table read raw) - raw))))) - - (define (make-apply-pred-to-raw pred) - (lambda (expr) - (pred (memoized-read->raw (expr-read expr))))) - - (define (make-check-raw-first-symbol symbol) - (make-apply-pred-to-raw - (lambda (raw) - (and (pair? raw) - (eq? (car raw) symbol))))) - - (define comes-from-define? - (make-check-raw-first-symbol 'define)) - - (define comes-from-define-procedure? - (make-apply-pred-to-raw - (lambda (raw) (and (pair? raw) - (eq? (car raw) 'define) - (pair? (cadr raw)))))) - - (define comes-from-lambda-defined-procedure? - (make-apply-pred-to-raw - (lambda (raw) (and (pair? raw) - (eq? (car raw) 'define) - (pair? (caddr raw)) - (eq? (caaddr raw) 'lambda))))) - - (define comes-from-define-struct? - (make-check-raw-first-symbol 'define-struct)) - - (define comes-from-cond? - (make-check-raw-first-symbol 'cond)) - - (define comes-from-lambda? - (make-check-raw-first-symbol 'lambda)) - - (define comes-from-case-lambda? - (make-check-raw-first-symbol 'case-lambda)) - - (define comes-from-and? - (make-check-raw-first-symbol 'and)) - - (define comes-from-or? - (make-check-raw-first-symbol 'or)) - - ; the lifted-names table maps bindings to numbers. the number, - ; essentially, is how we avoid clashes. So, if a binding with - ; the original name "foo" is associated with the number "2", - ; the lifted name will be "~foo~2". Note that you _need_ - ; that second tilde; otherwise there could be an overlap, - ; e.g. (foo 12) => ~foo12, (foo1 2) => ~foo12. - - (define lifted-names-table (make-hash-table-weak)) - - (define (insert-lifted-name binding) - (let* ([binding-name (z:binding-orig-name binding)] - [matching (filter - (lambda (key&val) (eq? (car key&val) binding-name)) - (hash-table-map lifted-names-table (lambda (key val) (list (z:binding-orig-name key) val))))] - [matching-nums (map cadr matching)] - [free-num (let loop ([try-index 0]) - (if (memq try-index matching-nums) - (loop (+ try-index 1)) - try-index))]) - (hash-table-put! lifted-names-table binding free-num) - (string->symbol (string-append "~" (symbol->string binding-name) "~" (number->string free-num))))) - - (define (lookup-lifted-name binding) - (cond [(hash-table-get lifted-names-table binding (lambda () #f)) => - (lambda (binding-number) - (string->symbol (string-append "~" (symbol->string (z:binding-orig-name binding)) "~" - (number->string binding-number))))] - [else ; the user is about to get the undefined value in a letrec... - (z:binding-orig-name binding)])) - - (define (rectify-value val) - (let ([closure-record (closure-table-lookup val (lambda () #f))]) - (cond - [closure-record - (or (closure-record-name closure-record) - (let ([mark (closure-record-mark closure-record)]) - (o-form-case-lambda->lambda - (rectify-source-expr (mark-source mark) (list mark) null))))] - [else - (s:print-convert val)]))) - - (define (o-form-case-lambda->lambda o-form) - (cond [(eq? (car o-form) 'lambda) - o-form] - [else ; o-form = case-lambda - (let ([args (caadr o-form)] - [body-exps (cdr (cadr o-form))]) - `(lambda ,args ,@body-exps))])) - - (define (o-form-lambda->define o-form name) - (let ([args (cadr o-form)] - [body-exps (cddr o-form)]) - `(define (,name ,@args) ,@body-exps))) - - (define (final-mark-list? mark-list) - (and (not (null? mark-list)) (eq? (mark-label (car mark-list)) 'final))) - - (define continuation? - (let ([r (regexp "#")]) - (lambda (k) - (let ([p (open-output-string)]) - (display k p) - (not (not (regexp-match r (get-output-string p)))))))) - - (define (skip-result-step? mark-list) - (in-inserted-else-clause mark-list)) - - (define (skip-redex-step? mark-list) - (and (pair? mark-list) - (let ([expr (mark-source (car mark-list))]) - (or (and (z:varref? expr) - (or (z:lambda-varref? expr) - (let ([var (z:varref-var expr)]) - (with-handlers - ([exn:variable? (lambda args #f)]) - (or (and (s:check-pre-defined-var var) - (or (procedure? (s:global-lookup var)) - (eq? var 'empty))) - (let ([val (if (z:top-level-varref? expr) - (s:global-lookup var) - (lookup-binding mark-list (z:bound-varref-binding expr)))]) - (and (procedure? val) - (not (continuation? val)) - (eq? var - (closure-record-name - (closure-table-lookup val (lambda () #f))))))))))) - (and (z:app? expr) - (let ([fun-val (mark-binding-value - (lookup-binding mark-list (get-arg-binding 0)))]) - (and (procedure? fun-val) - (procedure-arity-includes? - fun-val - (length (z:app-args expr))) - (or (and (s:constructor-style-printing?) - (if (s:abbreviate-cons-as-list?) - (eq? fun-val list) ; that needs exporting too. - (and (s:user-cons? fun-val) - (second-arg-is-list? mark-list)))) - (s:user-vector? fun-val) - (and (eq? fun-val void) - (eq? (z:app-args expr) null)) - (struct-constructor-procedure? fun-val) - ; this next clause may be obviated by the previous one. - (let ([closure-record (closure-table-lookup fun-val (lambda () #f))]) - (and closure-record - (closure-record-constructor? closure-record))))))) - (in-inserted-else-clause mark-list))))) - - (define (second-arg-is-list? mark-list) - (let ([arg-val (mark-binding-value (lookup-binding mark-list (get-arg-binding 2)))]) - (list? arg-val))) - - (define (in-inserted-else-clause mark-list) - (and (not (null? mark-list)) - (let ([expr (mark-source (car mark-list))]) - (or (and (z:zodiac? expr) - (not (z:if-form? expr)) - (comes-from-cond? expr)) - (in-inserted-else-clause (cdr mark-list)))))) - - ; rectify-source-expr (z:parsed (ListOf Mark) (ListOf z:binding) -> sexp) - - (define (rectify-source-expr expr mark-list lexically-bound-bindings) - (let ([recur (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))] - [let-recur (lambda (expr bindings) (rectify-source-expr expr mark-list (append bindings lexically-bound-bindings)))]) - (cond [(z:varref? expr) - (cond [(z:bound-varref? expr) - (let ([binding (z:bound-varref-binding expr)]) - (if (memq binding lexically-bound-bindings) - (z:binding-orig-name binding) - (if (z:lambda-binding? binding) - (rectify-value (mark-binding-value (lookup-binding mark-list (z:bound-varref-binding expr)))) - (lookup-lifted-name binding))))] - [(z:top-level-varref? expr) - (z:varref-var expr)])] - - [(z:app? expr) - (map recur (cons (z:app-fun expr) (z:app-args expr)))] - - [(z:struct-form? expr) - (if (comes-from-define-struct? expr) - (e:internal-error expr "this expression should have been skipped during reconstruction") - (let ([super-expr (z:struct-form-super expr)] - [raw-type (utils:read->raw (z:struct-form-type expr))] - [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) - (if super-expr - `(struct (,raw-type ,(recur super-expr)) - ,raw-fields) - `(struct ,raw-type ,raw-fields))))] - - [(z:if-form? expr) - (cond - [(comes-from-cond? expr) - `(cond ,@(rectify-cond-clauses (z:zodiac-start expr) expr mark-list lexically-bound-bindings))] - [(comes-from-and? expr) - `(and ,@(rectify-and-clauses (z:zodiac-start expr) expr mark-list lexically-bound-bindings))] - [(comes-from-or? expr) - `(or ,@(rectify-or-clauses (z:zodiac-start expr) expr mark-list lexically-bound-bindings))] - [else - `(if ,(recur (z:if-form-test expr)) - ,(recur (z:if-form-then expr)) - ,(recur (z:if-form-else expr)))])] - - [(z:quote-form? expr) - (let ([raw (utils:read->raw (z:quote-form-expr expr))]) - (rectify-value raw) -; (cond [(or (string? raw) -; (number? raw) -; (boolean? raw) -; (s:image? raw)) -; raw] -; [else -; `(quote ,raw)]) - )] - - [(z:let-values-form? expr) - (let* ([bindings (z:let-values-form-vars expr)] - [binding-names (map (lambda (b-list) (map z:binding-orig-name b-list)) bindings)] - [right-sides (map recur (z:let-values-form-vals expr))] - [must-be-values? (ormap (lambda (n-list) (not (= (length n-list) 1))) binding-names)] - [rectified-body (let-recur (z:let-values-form-body expr) bindings)]) - (if must-be-values? - `(let-values ,(map list binding-names right-sides) ,rectified-body) - `(let ,(map list (map car binding-names) right-sides) ,rectified-body)))] - - [(z:letrec-values-form? expr) - (let* ([bindings (z:letrec-values-form-vars expr)] - [binding-names (map (lambda (b-list) (map z:binding-orig-name b-list)) bindings)] - [right-sides (map (lambda (expr) (let-recur expr bindings)) - (z:letrec-values-form-vals expr))] - [must-be-values? (ormap (lambda (n-list) (not (= (length n-list) 1))) binding-names)] - [rectified-body (let-recur (z:letrec-values-form-body expr) bindings)]) - (if must-be-values? - `(letrec-values ,(map list binding-names right-sides) ,rectified-body) - `(letrec ,(map list (map car binding-names) right-sides) ,rectified-body)))] - - [(z:case-lambda-form? expr) - (let* ([arglists (z:case-lambda-form-args expr)] - [bodies (z:case-lambda-form-bodies expr)] - [o-form-arglists - (map (lambda (arglist) - (utils:improper-map z:binding-orig-name - (utils:arglist->ilist arglist))) - arglists)] - [binding-form-arglists (map z:arglist-vars arglists)] - [o-form-bodies - (map (lambda (body binding-form-arglist) (let-recur body binding-form-arglist)) - bodies - binding-form-arglists)]) - (cond [(or (comes-from-lambda? expr) (comes-from-define? expr)) - `(lambda ,(car o-form-arglists) ,(car o-form-bodies))] - [(comes-from-case-lambda? expr) - `(case-lambda ,@(map list o-form-arglists o-form-bodies))] - [else - (e:internal-error expr "unknown source for case-lambda")]))] - - ; we won't call rectify-source-expr on define-values expressions - - [else - (print-struct #t) - (e:internal-error - expr - (format "stepper:rectify-source: unknown object to rectify, ~a~n" expr))]))) - - ; these macro unwinders (and, or) are specific to beginner level - - (define (rectify-and-clauses and-source expr mark-list lexically-bound-bindings) - (let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))]) - (if (and (z:if-form? expr) (equal? and-source (z:zodiac-start expr))) - (cons (rectify-source (z:if-form-test expr)) - (rectify-and-clauses and-source (z:if-form-then expr) mark-list lexically-bound-bindings)) - null))) - - (define (rectify-or-clauses or-source expr mark-list lexically-bound-bindings) - (let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))]) - (if (and (z:if-form? expr) (equal? or-source (z:zodiac-start expr))) - (cons (rectify-source (z:if-form-test expr)) - (rectify-or-clauses or-source (z:if-form-else expr) mark-list lexically-bound-bindings)) - null))) - - (define (rectify-cond-clauses cond-source expr mark-list lexically-bound-bindings) - (let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))]) - (if (equal? cond-source (z:zodiac-start expr)) - (if (z:if-form? expr) - (cons (list (rectify-source (z:if-form-test expr)) - (rectify-source (z:if-form-then expr))) - (rectify-cond-clauses cond-source (z:if-form-else expr) mark-list lexically-bound-bindings)) - null) - `((else ,(rectify-source expr)))))) - - ; reconstruct-completed : reconstructs a completed expression or definition. This now - ; relies upon the s:global-lookup procedure to find values in the user-namespace. - ; I'm not yet sure whether or not 'vars' must be supplied or whether they can be derived - ; from the expression itself. - - (define (reconstruct-completed expr value) - (cond [(z:define-values-form? expr) - (if (comes-from-define-struct? expr) - (utils:read->raw (expr-read expr)) - (let* ([vars (map z:varref-var (z:define-values-form-vars expr))] - [values (map s:global-lookup vars)] - [rectified-vars (map rectify-value values)]) - (cond [(comes-from-define-procedure? expr) - (let* ([mark (closure-record-mark (closure-table-lookup (car values)))] - [rectified (rectify-source-expr (mark-source mark) (list mark) null)]) - (o-form-lambda->define (o-form-case-lambda->lambda rectified) - (car vars)))] - [(comes-from-lambda-defined-procedure? expr) - (let* ([mark (closure-record-mark (closure-table-lookup (car values)))] - [rectified (rectify-source-expr (mark-source mark) (list mark) null)]) - `(define ,(car vars) ,(o-form-case-lambda->lambda rectified)))] - [(comes-from-define? expr) - `(define ,(car vars) ,(car rectified-vars))] - [else - `(define-values ,vars - ,(if (= (length values) 1) - (car rectified-vars) - `(values ,@rectified-vars)))])))] - [(z:begin-form? expr) ; hack for xml stuff - (utils:read->raw (expr-read expr))] - [else - (rectify-value value)])) - - ; reconstruct-current : takes a parsed expression, a list of marks, the kind of break, and - ; any values that may have been returned at the break point. It produces a list containing the - ; reconstructed sexp, and the (contained) sexp which is the redex. If the redex is a heap value - ; (and can thus be distinguished from syntactically identical occurrences of that value using - ; eq?), it is embedded directly in the sexp. Otherwise, its place in the sexp is taken by the - ; highlight-placeholder, which is replaced by the highlighted redex in the construction of the - ; text% - - ; z:parsed (list-of mark) symbol (list-of value) -> - ; (list sexp sexp) - - (define (reconstruct-current expr mark-list break-kind returned-value-list) - - (local - ((define (rectify-source-top-marks expr) - (rectify-source-expr expr mark-list null)) - - (define (rectify-top-level expr so-far) - (if (z:define-values-form? expr) - (let ([vars (z:define-values-form-vars expr)] - [val (z:define-values-form-val expr)]) - (cond [(comes-from-define-struct? expr) - (let* ([struct-expr val] - [super-expr (z:struct-form-super struct-expr)] - [raw-type (utils:read->raw (z:struct-form-type struct-expr))] - [raw-fields (map utils:read->raw (z:struct-form-fields struct-expr))]) - `(define-struct - ,(if super-expr - (list raw-type so-far) - raw-type) - ,raw-fields))] - [(or (comes-from-define-procedure? expr) - (and (comes-from-define? expr) - (pair? so-far) - (eq? (car so-far) 'lambda))) - (let* ([proc-name (z:varref-var - (car (z:define-values-form-vars expr)))] - [o-form-proc so-far]) - (o-form-lambda->define o-form-proc proc-name))] - - [(comes-from-define? expr) - `(define - ,(z:varref-var (car vars)) - ,so-far)] - - [else - `(define-values - ,(map utils:read->raw vars) - ,(rectify-source-top-marks val))])) - so-far)) - - (define (rectify-inner mark-list so-far) - (let* ([rectify-source-current-marks - (lambda (expr) - (rectify-source-expr expr mark-list null))] - [rectify-let - (lambda (letrec? binding-sets vals body) - (let+ ([val binding-list (apply append binding-sets)] - [val binding-names (map (lambda (set) (map z:binding-orig-name set)) binding-sets)] - [val must-be-values? (ormap (lambda (n-list) (not (= (length n-list) 1))) binding-sets)] - [val dummy-var-list (if letrec? - binding-list - (build-list (length binding-list) get-arg-binding))] - [val rhs-vals (map (lambda (arg-binding) - (mark-binding-value (lookup-binding mark-list arg-binding))) - dummy-var-list)] - [val rhs-list - (let loop ([binding-sets binding-sets] [rhs-vals rhs-vals] [rhs-sources vals]) - (cond [(null? binding-sets) null] - [(eq? (car rhs-vals) (if letrec? - the-undefined-value - *unevaluated*)) - (cons so-far - (map (lambda (expr) - (rectify-source-expr expr mark-list (if letrec? - binding-sets - null))) - (cdr rhs-sources)))] - [else - (let*-values ([(first-set) (car binding-sets)] - [(set-vals remaining) (list-partition rhs-vals (length first-set))]) - (cons - (case (length first-set) - ((0) `(values)) - ((1) (car set-vals)) - (else `(values ,@set-vals))) - (loop (cdr binding-sets) remaining (cdr rhs-sources))))]))] - [val rectified-body (rectify-source-expr body mark-list binding-list)]) - (if must-be-values? - `(,(if letrec? 'letrec-values 'let-values) - ,(map list binding-names rhs-list) ,rectified-body) - `(,(if letrec? 'letrec 'let) - ,(map list (map car binding-names) rhs-list) ,rectified-body))))] - [top-mark (car mark-list)] - [expr (mark-source top-mark)]) - (cond - ; variable references - [(z:varref? expr) - (if (eq? so-far nothing-so-far) - (rectify-source-current-marks expr) - (e:internal-error expr - "variable reference given as context"))] - - ; applications - - [(z:app? expr) - (let* ([sub-exprs (cons (z:app-fun expr) (z:app-args expr))] - [arg-temps (build-list (length sub-exprs) get-arg-binding)] - [arg-vals (map (lambda (arg-temp) - (mark-binding-value (lookup-binding mark-list arg-temp))) - arg-temps)]) - (case (mark-label (car mark-list)) - ((not-yet-called) - (letrec - ([split-lists - (lambda (exprs vals) - (if (or (null? vals) - (eq? (car vals) *unevaluated*)) - (values null exprs) - (let-values ([(small-vals small-exprs) - (split-lists (cdr exprs) (cdr vals))]) - (values (cons (car vals) small-vals) small-exprs))))]) - (let-values ([(evaluated unevaluated) (split-lists sub-exprs arg-vals)]) - (let* ([rectified-evaluated (map rectify-value evaluated)]) - (if (null? unevaluated) - rectified-evaluated - (append rectified-evaluated - (cons so-far - (map rectify-source-current-marks (cdr unevaluated))))))))) - ((called) - (if (eq? so-far nothing-so-far) - `(...) ; in unannotated code - `(... ,so-far ...))) - (else - (e:static-error "bad label in application mark: ~s" expr))))] - - ; define-struct - - [(z:struct-form? expr) - (if (comes-from-define-struct? expr) - so-far - (let ([super-expr (z:struct-form-super expr)] - [raw-type (utils:read->raw (z:struct-form-type expr))] - [raw-fields (map utils:read->raw (z:struct-form-fields expr))]) - (if super-expr - `(struct (,raw-type ,so-far) - ,raw-fields) - `(struct ,raw-type ,raw-fields))))] - - ; if - - [(z:if-form? expr) - (let ([test-exp (if (eq? so-far nothing-so-far) - (rectify-value (mark-binding-value (lookup-binding mark-list if-temp))) - so-far)]) - (cond [(comes-from-cond? expr) - (let* ([clause (list test-exp (rectify-source-current-marks (z:if-form-then expr)))] - [cond-source (z:zodiac-start expr)] - [rest-clauses (rectify-cond-clauses cond-source (z:if-form-else expr) mark-list null)]) - `(cond ,clause ,@rest-clauses))] - [(comes-from-and? expr) - `(and ,test-exp ,@(rectify-and-clauses (z:zodiac-start expr) - (z:if-form-then expr) - mark-list - null))] - [(comes-from-or? expr) - `(or ,test-exp ,@(rectify-or-clauses (z:zodiac-start expr) - (z:if-form-else expr) - mark-list - null))] - [else - `(if ,test-exp - ,(rectify-source-current-marks (z:if-form-then expr)) - ,(rectify-source-current-marks (z:if-form-else expr)))]))] - - ; quote : there is no mark or break on a quote. - - ; begin, begin0 : may not occur directly (or indirectly?) except in advanced - - ; let-values - - [(z:let-values-form? expr) - (rectify-let #f - (z:let-values-form-vars expr) - (z:let-values-form-vals expr) - (z:let-values-form-body expr))] - - [(z:letrec-values-form? expr) - (rectify-let #t - (z:letrec-values-form-vars expr) - (z:letrec-values-form-vals expr) - (z:letrec-values-form-body expr))] - - ; define-values : define's don't get marks, so they can't occur here - - ; lambda : there is no mark or break on a quote - - [else - (print-struct #t) - (e:internal-error - expr - (format "stepper:reconstruct: unknown object to reconstruct, ~a~n" expr))]))) - - - (define redex #f) - - (define (current-def-rectifier so-far mark-list first) - (if (null? mark-list) - (rectify-top-level expr so-far) - (let ([reconstructed (rectify-inner mark-list so-far)]) - (current-def-rectifier - (if first - (begin - (set! redex reconstructed) - highlight-placeholder) - reconstructed) - (cdr mark-list) - #f)))) - - (define (let-style-abstraction letrec? binding-sets body) - (let* ([redex (rectify-inner mark-list #f)] - [binding-list (apply append binding-sets)] - [new-names (map insert-lifted-name binding-list)] - [dummy-var-list (if letrec? - binding-list - (build-list (length binding-list) get-arg-binding))] - [rhs-vals (map (lambda (arg-temp) - (mark-binding-value (lookup-binding mark-list arg-temp))) - dummy-var-list)] - [before-step (current-def-rectifier highlight-placeholder (cdr mark-list) #f)] - [reduct (rectify-source-expr body mark-list null)] - [after-step (current-def-rectifier highlight-placeholder (cdr mark-list) #f)] - [new-defines (map (lambda (name val) `(define ,name ,val)) new-names rhs-vals)]) - (list new-defines before-step redex after-step reduct))) - - - (define (rectify-let-values-step) - (let* ([source-expr (mark-source (car mark-list))]) - (apply let-style-abstraction - (z:letrec-values-form? source-expr) - (map (lambda (accessor) (accessor source-expr)) - (cond [(z:let-values-form? source-expr) - (list z:let-values-form-vars - z:let-values-form-body)] - [(z:letrec-values-form? source-expr) - (list z:letrec-values-form-vars - z:letrec-values-form-body)]))))) - - - ; (define (confusable-value? val) - ; (not (or (number? val) - ; (boolean? val) - ; (string? val) - ; (symbol? val)))) - - (define answer - (case break-kind - ((result-break) - (let* ([innermost (if (null? returned-value-list) - (rectify-source-expr (mark-source (car mark-list)) mark-list null) - (rectify-value (car returned-value-list)))] - [current-def (current-def-rectifier highlight-placeholder (cdr mark-list) #f)]) - (list current-def innermost))) - ((normal-break) - (let ([current-def (current-def-rectifier nothing-so-far mark-list #t)]) - (list current-def redex))) - ((double-break) - (rectify-let-values-step)) - (else - (e:internal-error 'reconstruct-current-def "unknown break kind: " break-kind)))) - - ) - - answer))) diff --git a/collects/stepper/sharedr.ss b/collects/stepper/sharedr.ss deleted file mode 100644 index a18cce0d..00000000 --- a/collects/stepper/sharedr.ss +++ /dev/null @@ -1,145 +0,0 @@ -(unit/sig stepper:shared^ - (import [z : zodiac:system^] - [e : zodiac:interface^] - stepper:client-procs^) - - ; A step-result is either: - ; (make-before-after-result finished-exprs exp redex reduct) - ; or (make-before-error-result finished-exprs exp redex err-msg) - ; or (make-error-result finished-exprs err-msg) - ; or (make-finished-result finished-exprs) - (define-struct before-after-result (finished-exprs exp redex post-exp reduct)) - (define-struct before-error-result (finished-exprs exp redex err-msg)) - (define-struct error-result (finished-exprs err-msg)) - (define-struct finished-result (finished-exprs)) - - (define (read-exprs text) - (let ([reader (z:read (open-input-string text) - (z:make-location 1 1 0 "stepper-string"))]) - (let read-loop ([new-expr (reader)]) - (if (z:eof? new-expr) - () - (cons new-expr (read-loop (reader))))))) - - ; the closure record is placed in the closure table - - (define-struct closure-record (name mark constructor?)) - - ; bogus-binding is used so that we can create legal zodiac bindings for temporary variables - - (define (create-bogus-binding name) - (let* ([gensymed-name (gensym name)] - [binding (z:make-lexical-binding #f #f #f (z:make-empty-back-box) - gensymed-name name)]) - (set-new-binding-name! binding gensymed-name) - binding)) - - ; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings - ; not eq? to any other bindings, but a client can always get the same binding by - ; invoking the resulting procedure with the same key (numbers work well). make-binding-source - ; also takes a string which will be part of the printed representation of the binding's - ; name; this makes debugging easier. - ; make-gensym-source : (string -> (key -> binding)) - - (define (make-binding-source id-string) - (let ([assoc-table (make-hash-table-weak)]) - (lambda (key) - (let ([maybe-fetch (hash-table-get assoc-table key (lambda () #f))]) - (or maybe-fetch - (begin - (let* ([new-binding (create-bogus-binding - (string-append id-string (format "~a" key) "-"))]) - (hash-table-put! assoc-table key new-binding) - new-binding))))))) - - ; get-binding-name extracts the S-expression name for a binding. Zodiac - ; creates a unique, gensym'd symbol for each binding, but the name is - ; unreadable. Here, we create a new gensym, but the name of the generated - ; symbol prints in the same way as the original symbol. - - (define (get-binding-name binding) - (let ([name (lookup-new-binding-name binding)]) - (or name - (let* ([orig-name (z:binding-orig-name binding)] - [name (string->uninterned-symbol (symbol->string orig-name))]) - (set-new-binding-name! binding name) - name)))) - - (define-values (lookup-new-binding-name set-new-binding-name!) - (let-values ([(getter setter) (z:register-client 'new-name (lambda () #f))]) - (values - (lambda (parsed) (getter (z:parsed-back parsed))) - (lambda (parsed n) (setter (z:parsed-back parsed) n))))) - - ; get-arg-binding maintains a list of bindings associated with the non-negative - ; integers. These symbols are used in the elaboration of applications; the nth - ; in the application is evaluated and stored in a variable whose name is the nth - ; gensym supplied by get-arg-symbol. - - (define get-arg-binding - (make-binding-source "arg")) - - ; test cases: (returns #t on success) - #| (let ([arg3 (get-arg-symbol 3)] - [arg2 (get-arg-symbol 2)] - [arg1 (get-arg-symbol 1)] - [arg2p (get-arg-symbol 2)]) - (and (not (eq? arg3 arg2)) - (not (eq? arg3 arg1)) - (not (eq? arg3 arg2p)) - (not (eq? arg2 arg1)) - (eq? arg2 arg2p) - (not (eq? arg1 arg2p)))) - |# - - ; gensyms needed by many modules: - - ; no-sexp is used to indicate no sexpression for display. - ; e.g., on an error message, there's no sexp. - (define no-sexp (gensym "no-sexp-")) - - ; *unevaluated* is the value assigned to temps before they are evaluated. - (define *unevaluated* (gensym "unevaluated-")) - - ; if-temp : uninterned-symbol - (define if-temp (create-bogus-binding "if-temp-")) - - ; struct-flag : uninterned symbol - (define struct-flag (gensym "struct-flag-")) - - ; highlight-placeholder : uninterned symbol - (define highlight-placeholder (gensym "highlight-placeholder")) - - ; list-partition takes a list and a number, and returns two lists; the first one contains the - ; first n elements of the list, and the second contains the remainder. If n is greater than - ; the length of the list, the exn:application:mismatch exception is raised. - - (define (list-partition lst n) - (if (= n 0) - (values null lst) - (if (null? lst) - (list-ref lst 0) ; cheap way to generate exception - (let-values ([(first rest) (list-partition (cdr lst) (- n 1))]) - (values (cons (car lst) first) rest))))) - - ; to perform source correlation, we use the 'register-client' ability of zodiac to - ; add fields to parsed structures at runtime. - - (define expr-read read-getter) - (define set-expr-read! read-setter) - - (define (list-take n a-list) - (if (= n 0) - null - (cons (car a-list) (list-take (- n 1) (cdr a-list))))) - - (define (flatten-take n a-list) - (apply append (list-take n a-list))) - - (define-values (closure-table-put! closure-table-lookup) - (let ([closure-table (make-hash-table-weak)]) - (values - (lambda (key value) - (hash-table-put! closure-table key value)) - (lambda args ; key or key & failure-thunk - (apply hash-table-get closure-table args)))))) \ No newline at end of file diff --git a/collects/stepper/sig.ss b/collects/stepper/sig.ss deleted file mode 100644 index cde14866..00000000 --- a/collects/stepper/sig.ss +++ /dev/null @@ -1,103 +0,0 @@ -(define-signature stepper:cogen-utils^ - (check-for-keyword - check-for-syntax-or-macro-keyword - - the-undefined-value - (struct undefined (id)) - signal-undefined - undefined-error-format - - (struct not-boolean (val)) - signal-not-boolean - not-boolean-error-format - - is-unit-bound? - read->raw - arglist->ilist - - improper-map - improper-foreach)) - -(define-signature plt:aries-no-break^ - (annotate - extract-zodiac-location - w-c-m-key - make-zodiac-mark - signal-not-boolean - signal-undefined)) - -(define-signature plt:aries^ - ((open plt:aries-no-break^) - break)) - -(define-signature stepper:marks^ - (cheap-mark? - make-cheap-mark - cheap-mark-source - make-full-mark - mark-source - mark-bindings - mark-label - mark-binding-value - mark-binding-binding - expose-mark - display-mark - lookup-binding)) - -(define-signature stepper:client-procs^ - (read-getter - read-setter - never-undefined-getter - never-undefined-setter)) - -(define-signature stepper:model-input^ - (text-stream settings image? receive-result)) - -(define-signature stepper:model^ - (check-pre-defined-var - check-global-defined - global-lookup - constructor-style-printing? - abbreviate-cons-as-list? - user-cons? - user-vector? - image? - print-convert)) - -(define-signature stepper:shared^ - ((struct before-after-result (finished-exprs exp redex post-exp reduct)) - (struct before-error-result (finished-exprs exp redex err-msg)) - (struct error-result (finished-exprs err-msg)) - (struct finished-result (finished-exprs)) - get-binding-name - ;lookup-new-binding-name - ;set-new-binding-name! - list-take - list-partition - (struct closure-record (name mark constructor?)) - ;create-bogus-binding - *unevaluated* - no-sexp - if-temp - struct-flag - highlight-placeholder - get-arg-binding - expr-read - set-expr-read! - flatten-take - closure-table-put! - closure-table-lookup)) - -(define-signature stepper:annotate^ - (initial-env-package - annotate - debug-key)) - -(define-signature stepper:reconstruct^ - (reconstruct-completed - reconstruct-current - final-mark-list? - skip-result-step? - skip-redex-step?)) - - \ No newline at end of file diff --git a/collects/stepper/startup.ss b/collects/stepper/startup.ss deleted file mode 100644 index 3ebadbad..00000000 --- a/collects/stepper/startup.ss +++ /dev/null @@ -1,52 +0,0 @@ -(unit/sig (invoke-stepper) - (import mzlib:core^ - [mred : mred^] - [fw : framework^] - [drscheme : drscheme:export^] - (stepper-go)) - - (define (invoke-stepper frame) - (let ([existing-stepper (send frame stepper-frame)]) - (if existing-stepper - (send existing-stepper show #t) - (fw:gui-utils:show-busy-cursor - (lambda () - (stepper-go frame)))))) - - (define stepper-bitmap - (drscheme:unit:make-bitmap - "Step" - (build-path (collection-path "icons") "foot.bmp"))) - - (drscheme:get/extend:extend-unit-frame - (lambda (super%) - (class super% args - (inherit button-panel) - (sequence (apply super-init args)) - (rename [super-disable-evaluation disable-evaluation] - [super-enable-evaluation enable-evaluation]) - (override - [enable-evaluation - (lambda () - (send stepper-button enable #t) - (super-enable-evaluation))] - [disable-evaluation - (lambda () - (send stepper-button enable #f) - (super-disable-evaluation))]) - (public - [stepper-frame - (let ([frame #f]) - (case-lambda - (() frame) - ((new-val) (set! frame new-val))))] - - [stepper-button (make-object mred:button% - (stepper-bitmap this) - button-panel - (lambda (button evt) - (invoke-stepper this)))]) - (sequence - (send button-panel change-children - (lambda (l) - (cons stepper-button (function:remq stepper-button l))))))))) diff --git a/collects/stepper/tests/main.ss b/collects/stepper/tests/main.ss deleted file mode 100644 index de7924d8..00000000 --- a/collects/stepper/tests/main.ss +++ /dev/null @@ -1,22 +0,0 @@ - -(define (send-string str) - (for-each fw:test:keystroke (string->list str))) - -(define top-window - (let loop ([window (get-top-level-focus-window)]) - (if (is-a? window frame%) - window - (begin - (printf "Got this value: ~s~n" window) - (printf "waiting...~n") - (sleep 3) - (loop (get-top-level-focus-window)))))) - -(printf "got a frame.~n") - -(send (ivar top-window definitions-canvas) focus) - -(send-string "(+ 1 2)") - -(fw:test:button-push (ivar top-window stepper-button)) - diff --git a/collects/stepper/utils.ss b/collects/stepper/utils.ss deleted file mode 100644 index 3b6e094f..00000000 --- a/collects/stepper/utils.ss +++ /dev/null @@ -1,115 +0,0 @@ -(unit/sig stepper:cogen-utils^ - (import [z : zodiac:system^] - [e : zodiac:interface^]) - - - ; check whether the supplied id is a keyword. if the id is a syntax or - ; macro keyword, issue an error. If disallow-procedures? is true, then - ; we issue an error for _any_ use of a keyword. These procedures are used - ; to prevent the program from redefining keywords. - - (define check-for-keyword/both - (lambda (disallow-procedures?) - (lambda (id) - (let ([real-id - (cond - [(z:binding? id) (z:binding-orig-name id)] - [(z:top-level-varref? id) (z:varref-var id)] - [(z:bound-varref? id) - (z:binding-orig-name (z:bound-varref-binding id))] - [(z:symbol? id) - (z:read-object id)] - [else - (e:internal-error id "Given in check-for-keyword")])]) - (when (and (keyword-name? real-id) - (or disallow-procedures? - (let ([gdv (global-defined-value real-id)]) - (or (syntax? gdv) - (macro? gdv))))) - (e:static-error "keyword" 'term:keyword-out-of-context - id "invalid use of keyword ~s" real-id)))))) - - (define check-for-keyword (check-for-keyword/both #t)) - (define check-for-syntax-or-macro-keyword (check-for-keyword/both #f)) - - (define the-undefined-value (letrec ((x x)) x)) - - (define-struct (undefined struct:exn) (id)) - (define signal-undefined (make-parameter #t)) - (define undefined-error-format - "Variable ~s referenced before definition or initialization") - - (define-struct (not-boolean struct:exn) (val)) - (define signal-not-boolean (make-parameter #f)) - (define not-boolean-error-format "Condition value is neither true nor false: ~e") - - ; there is a problem with Zodiac. The problem is that Zodiac has not been - ; distinguishing between top-level variables and those bound by unit clauses. - ; this is an important distinction to make, because the variables bound by - ; unit clauses may take on the `undefined' value, whereas those bound as - ; top-level variables will never require this check. (If used before defined, - ; these values are simply considered unbound. To this end, Matthew has modified - ; Zodiac to add a bit of information which aries can use to distinguish these - ; fields. Currently, this information is stored in the `unit?' field of a - ; `top-level-varref/bind/unit' structure. There are cleaner solutions, but - ; this one fits well into the current state of the world. This may change at - ; some point in the future. For the moment, here is the function which - ; distinguishes between these two types of binding: - - (define (is-unit-bound? varref) - (and (z:top-level-varref/bind/unit? varref) - (z:top-level-varref/bind/unit-unit? varref))) - - ; Objects that are passed to eval get quoted by M3. These objects - ; do not belong in the `read' structure framework. Hence, if they - ; are passed to z:sexp->raw, they will error. Thus, we first check - ; before sending things there. - - ; jbc additional comments, including elucidation from shriram: - ; there are three `levels' of parsed stuff: - ; raw: simple, unannotated scheme values - ; sexp: simple scheme values with attached zodiac information - ; parsed: fully parsed into zodiac structures - - (define read->raw - (lambda (read) - (if (z:zodiac? read) - (z:sexp->raw read) - read))) - - ; divined notes about the structure of an arglist. Evidently, an arglist can - ; take one of three forms: - ; list-arglist : this arglist represents a simple list of arguments - ; ilist-arglist : this arglist represents a list of arguments which uses - ; `dot-notation' to separate the last element of the list - ; sym-arglist : this arglist represents the `single argument with no - ; parens' style of argument list. - - (define arglist->ilist - (lambda (arglist) - (cond - ((z:list-arglist? arglist) - (z:arglist-vars arglist)) - ((z:ilist-arglist? arglist) - (let loop ((vars (z:arglist-vars arglist))) - (if (null? (cddr vars)) - (cons (car vars) (cadr vars)) - (cons (car vars) (loop (cdr vars)))))) - ((z:sym-arglist? arglist) - (car (z:arglist-vars arglist))) - (else - (e:internal-error arglist - "Given to arglist->ilist"))))) - - (define make-improper - (lambda (combine) - (rec improper ;; `rec' is for the name in error messages - (lambda (f list) - (let improper-loop ([list list]) - (cond - ((null? list) list) - ((pair? list) (combine (f (car list)) - (improper-loop (cdr list)))) - (else (f list)))))))) - (define improper-map (make-improper cons)) - (define improper-foreach (make-improper (lambda (x y) y)))) \ No newline at end of file diff --git a/collects/stepper/view-controller.ss b/collects/stepper/view-controller.ss deleted file mode 100644 index 698c0040..00000000 --- a/collects/stepper/view-controller.ss +++ /dev/null @@ -1,394 +0,0 @@ -(unit/sig (stepper-go) - (import [c : mzlib:core^] - [e : zodiac:interface^] - [z : zodiac:system^] - [cp : stepper:client-procs^] - mzlib:pretty-print^ - mred^ - [d : drscheme:export^] - [p : mzlib:print-convert^] - [f : framework^] - stepper:shared^ - [utils : stepper:cogen-utils^] - [marks : stepper:marks^]) - - ;;;;;; copied from /plt/collects/drscheme/snip.ss : - - (define separator-snipclass - (make-object - (class-asi snip-class% - (override - [read (lambda (s) - (let ([size-box (box 0)]) - (send s get size-box) - (make-object separator-snip%)))])))) - - (send* separator-snipclass - (set-version 1) - (set-classname "drscheme:separator-snip%")) - - (send (get-the-snip-class-list) add separator-snipclass) - - ;; the two numbers 1 and 2 which appear here are to line up this snip - ;; with the embedded snips around it in the drscheme rep. - ;; I have no idea where the extra pixels are going. - (define separator-snip% - (class snip% () - (inherit get-style set-snipclass set-flags get-flags get-admin) - (private [width 500] - [height 1] - [white-around 2]) - (override - [write (lambda (s) - (send s put (char->integer #\r)))] - [copy (lambda () - (let ([s (make-object separator-snip%)]) - (send s set-style (get-style)) - s))] - [get-extent - (lambda (dc x y w-box h-box descent-box space-box lspace-box rspace-box) - (for-each (lambda (box) (unless (not box) (set-box! box 0))) - (list descent-box space-box lspace-box rspace-box)) - (let* ([admin (get-admin)] - [reporting-media (send admin get-editor)] - [reporting-admin (send reporting-media get-admin)] - [widthb (box 0)] - [space 2]) - (send reporting-admin get-view #f #f widthb #f) - (set! width (- (unbox widthb) - space - 2))) - (set! height 1) - (unless (not w-box) - (set-box! w-box width)) - (unless (not h-box) - (set-box! h-box (+ (* 2 white-around) height))))] - [draw - (let* ([body-pen (send the-pen-list find-or-create-pen - "BLUE" 0 'solid)] - [body-brush (send the-brush-list find-or-create-brush - "BLUE" 'solid)]) - (lambda (dc x y left top right bottom dx dy draw-caret) - (let ([orig-pen (send dc get-pen)] - [orig-brush (send dc get-brush)]) - (send dc set-pen body-pen) - (send dc set-brush body-brush) - - (send dc draw-rectangle (+ x 1) - (+ white-around y) width height) - - (send dc set-pen orig-pen) - (send dc set-brush orig-brush))))]) - (sequence - (super-init) - (set-flags (cons 'hard-newline (get-flags))) - (set-snipclass separator-snipclass)))) - - ;;;; end of copied region - - (define stepper-frame% - (class (d:frame:basics-mixin (f:frame:standard-menus-mixin f:frame:basic%)) (drscheme-frame) - (rename [super-on-close on-close]) - (override - [on-close - (lambda () - (send drscheme-frame stepper-frame #f) - (super-on-close))]) - (sequence (super-init "The Foot")))) - - (define stepper-canvas% - (class editor-canvas% (parent (editor #f) (style null) (scrolls-per-page 100)) - (rename (super-on-size on-size)) - (inherit get-editor) - (override - [on-size - (lambda (width height) - (super-on-size width height) - (let ([editor (get-editor)]) - (when editor - (send editor reset-pretty-print-width this))))]) - (sequence (super-init parent editor style scrolls-per-page)))) - - (define (image? val) - (is-a? val snip%)) - - (define (confusable-value? val) - (or (number? val) - (boolean? val) - (string? val) - (symbol? val))) - - ; insert-highlighted-value : sexp sexp -> sexp - ; replaces highlight-placeholder in the first sexp with the second sexp - - (define (insert-highlighted-value exp inserted) - (let ([recur (lambda (exp) (insert-highlighted-value exp inserted))]) - (cond [(list? exp) - (map recur exp)] - [(vector? exp) - (list->vector (map recur (vector->list exp)))] - [(eq? exp highlight-placeholder) - inserted] - [else exp]))) - - (define stepper-text% - (class f:text:basic% (finished-exprs exp redex post-exp reduct error-msg (line-spacing 1.0) (tabstops null)) - (inherit find-snip insert change-style highlight-range last-position lock erase auto-wrap - begin-edit-sequence end-edit-sequence get-start-position get-style-list set-style-list) - (public (pretty-printed-width -1) - (char-width 0) - (clear-highlight-thunks null) - [reset-style - (lambda () - (change-style (send (get-style-list) find-named-style "Standard")))] - (reset-pretty-print-width - (lambda (canvas) - (begin-edit-sequence) - (let* ([style (send (get-style-list) find-named-style "Standard")] - [_ (set! char-width (send style get-text-width (send canvas get-dc)))] - [canvas-width (let-values ([(client-width client-height) - (send canvas get-client-size)]) - (- client-width 18))] ; 12 border pixels + 6 for wrap char - [min-columns 30] - [new-columns (max min-columns - (floor (/ canvas-width char-width)))]) - (pretty-print-columns new-columns) - (reformat-sexp) - (end-edit-sequence)))) - (reformat-sexp - (lambda () - (when (not (= pretty-printed-width (pretty-print-columns))) - (set! pretty-printed-width (pretty-print-columns)) - (format-whole-step)))) - [format-sexp - (lambda (sexp redex highlight-color) - (let ([real-print-hook (pretty-print-print-hook)] - [redex-begin #f] - [redex-end #f] - [placeholder-present? #f]) - (parameterize ([pretty-print-size-hook - (lambda (value display? port) - (if (eq? value highlight-placeholder) - (begin - (set! placeholder-present? #t) - (string-length (format "~s" redex))) - (if (image? value) - 1 ; if there was a good way to calculate a image widths ... - #f)))] - [pretty-print-print-hook - (lambda (value display? port) - (if (eq? value highlight-placeholder) - (insert (format "~s" redex)) - ; next occurs if value is an image: - (insert (send value copy))))] - [pretty-print-display-string-handler - (lambda (string port) - (insert string))] - [pretty-print-print-line - (lambda (number port old-length dest-columns) - (when (not (eq? number 0)) - (insert #\newline)) - 0)] - [pretty-print-pre-print-hook - (lambda (value p) - (when (or (and (not placeholder-present?) - (eq? value redex)) - (eq? value highlight-placeholder)) - (set! redex-begin (get-start-position))))] - [pretty-print-post-print-hook - (lambda (value p) - (when (or (and (not placeholder-present?) - (eq? value redex)) - (eq? value highlight-placeholder)) - (set! redex-end (get-start-position))))]) - (pretty-print sexp) - (if redex-begin - (set! clear-highlight-thunks - (cons (highlight-range redex-begin redex-end highlight-color #f #f) - clear-highlight-thunks))))))] - - [un-hacked-format-sexp - (lambda (exp region color) - (if (confusable-value? region) - (format-sexp exp region color) - (format-sexp (insert-highlighted-value exp region) region color)))] - - [format-whole-step - (lambda () - (lock #f) - (begin-edit-sequence) - (for-each (lambda (fun) (fun)) clear-highlight-thunks) - (set! clear-highlight-thunks null) - (erase) - (for-each - (lambda (expr) - (un-hacked-format-sexp expr no-sexp #f) - (insert #\newline)) - finished-exprs) - (insert (make-object separator-snip%)) - (when (not (eq? redex no-sexp)) - (insert #\newline) - (reset-style) - (un-hacked-format-sexp exp redex redex-highlight-color) - (insert #\newline) - (insert (make-object separator-snip%)) - (insert #\newline)) - (cond [(not (eq? reduct no-sexp)) - (reset-style) - (un-hacked-format-sexp post-exp reduct result-highlight-color)] - [error-msg - (let ([before-error-msg (last-position)]) - (reset-style) - (auto-wrap #t) - (insert error-msg) - (change-style error-delta before-error-msg (last-position)))]) - (end-edit-sequence) - (lock #t))]) - (sequence (super-init line-spacing tabstops) - (set-style-list (f:scheme:get-style-list))))) - - (define error-delta (make-object style-delta% 'change-style 'italic)) - (send error-delta set-delta-foreground "RED") - - (define test-dc (make-object bitmap-dc% (make-object bitmap% 1 1))) - (define result-highlight-color (make-object color% 255 255 255)) - (define redex-highlight-color (make-object color% 255 255 255)) - (send test-dc try-color (make-object color% 212 159 245) result-highlight-color) - (send test-dc try-color (make-object color% 193 251 181) redex-highlight-color) - - (define (stepper-wrapper drscheme-frame settings) - - (local ((define view-history null) - (define view-currently-updating #f) - (define final-view #f) - (define view 0) - - ; build gui object: - - (define (home) - (update-view 0)) - - (define (next) - (send next-button enable #f) - (send previous-button enable #f) - (send home-button enable #f) - (if (= view (- (length view-history) 1)) - (update-view/next-step (+ view 1)) - (update-view (+ view 1)))) - - (define (previous) - (update-view (- view 1))) - - (define s-frame (make-object stepper-frame% drscheme-frame)) - - (define button-panel (make-object horizontal-panel% (send s-frame get-area-container))) - (define home-button (make-object button% "Home" button-panel - (lambda (_1 _2) (home)))) - (define previous-button (make-object button% "<< Previous" button-panel - (lambda (_1 _2) (previous)))) - (define next-button (make-object button% "Next >>" button-panel (lambda - (_1 _2) (next)))) - - (define canvas (make-object stepper-canvas% (send s-frame get-area-container))) - - (define (update-view/next-step new-view) - (set! view-currently-updating new-view) - (step)) - - (define (update-view new-view) - (set! view new-view) - (let ([e (list-ref view-history view)]) - (send e reset-pretty-print-width canvas) - (send canvas lazy-refresh #t) - (send canvas set-editor e) - (send e set-position (send e last-position)) - (send canvas lazy-refresh #f)) - (send previous-button enable (not (zero? view))) - (send home-button enable (not (zero? view))) - (send next-button enable (not (eq? final-view view)))) - - (define (receive-result result) - (let ([step-text - (cond [(before-after-result? result) - (make-object stepper-text% - (before-after-result-finished-exprs result) - (before-after-result-exp result) - (before-after-result-redex result) - (before-after-result-post-exp result) - (before-after-result-reduct result) - #f)] - [(before-error-result? result) - (set! final-view view-currently-updating) - (make-object stepper-text% - (before-error-result-finished-exprs result) - (before-error-result-exp result) - (before-error-result-redex result) - no-sexp - no-sexp - (before-error-result-err-msg result))] - [(error-result? result) - (set! final-view view-currently-updating) - (make-object stepper-text% - (error-result-finished-exprs result) - no-sexp - no-sexp - no-sexp - no-sexp - (error-result-err-msg result))] - [(finished-result? result) - (set! final-view view-currently-updating) - (make-object stepper-text% - (finished-result-finished-exprs result) - no-sexp - no-sexp - no-sexp - no-sexp - #f)])]) - (set! view-history (append view-history (list step-text))) - (update-view view-currently-updating))) - - (define text-stream - (f:gui-utils:read-snips/chars-from-text (ivar drscheme-frame definitions-text))) - - (define step - (invoke-unit/sig (require-library-unit/sig "instance.ss" "stepper") - stepper:model-input^ - (c : mzlib:core^) - (e : zodiac:interface^) - (p : mzlib:print-convert^) - (d : drscheme:export^) - (z : zodiac:system^) - (cp : stepper:client-procs^) - stepper:shared^ - mred^ - (utils : stepper:cogen-utils^) - (marks : stepper:marks^)))) - - (send drscheme-frame stepper-frame s-frame) - (set! view-currently-updating 0) - (send button-panel stretchable-width #f) - (send button-panel stretchable-height #f) - (send canvas stretchable-height #t) - (send canvas min-width 400) - (send canvas min-height 100) - (send previous-button enable #f) - (send home-button enable #f) - (send next-button enable #f) - (send (send s-frame edit-menu:get-undo-item) enable #f) - (send (send s-frame edit-menu:get-redo-item) enable #f) - (step) - (send s-frame show #t))) - - (define beginner-level-name "Beginning Student") - - (define (stepper-go frame) - (let ([settings (f:preferences:get d:language:settings-preferences-symbol)]) - (if #f ; (not (string=? (d:basis:setting-name settings) beginner-level-name)) - (message-box "Stepper" - (format (string-append "Language level is set to \"~a\".~n" - "The Foot only works for the \"~a\" language level.~n") - (d:basis:setting-name settings) - beginner-level-name) - #f - '(ok)) - (stepper-wrapper frame settings))))) diff --git a/collects/tests/addrhack.c b/collects/tests/addrhack.c deleted file mode 100644 index fc942d00..00000000 --- a/collects/tests/addrhack.c +++ /dev/null @@ -1,53 +0,0 @@ -/* -Matthew writes: - -This file, when loaded, defines: - - object->address : value -> exact integer in [0,2^32-1] - address->object : exact integer in [0,2^32-1] -> value - -Obviously, address->object is not safe. - -To Compile: - - mzc --cc addrhack.c - mzc --ld addrhack.so addrhack.o - -*/ -#include "escheme.h" - -Scheme_Object *object_to_address(int c, Scheme_Object **a) -{ - return scheme_make_integer_value_from_unsigned((unsigned long)a[0]); -} - -Scheme_Object *address_to_object(int c, Scheme_Object **a) -{ - unsigned long v; - - if (!scheme_get_unsigned_int_val(a[0], &v)) - scheme_signal_error("bad address"); - - return (Scheme_Object *)v; -} - -Scheme_Object *scheme_reload(Scheme_Env *env) -{ - scheme_add_global("object->address", - scheme_make_prim_w_arity(object_to_address, - "object->address", - 1, 1), - env); - scheme_add_global("address->object", - scheme_make_prim_w_arity(address_to_object, - "address->object", - 1, 1), - env); - - return scheme_void; -} - -Scheme_Object *scheme_initialize(Scheme_Env *env) -{ - return scheme_reload(env); -} diff --git a/collects/tests/drscheme/README b/collects/tests/drscheme/README deleted file mode 100644 index 723b0aa0..00000000 --- a/collects/tests/drscheme/README +++ /dev/null @@ -1,85 +0,0 @@ -`(#| - -This directory contains code for testing DrScheme. To run the tests, -load run-test.ss. It will return a function that accepts the names of -tests. Those names must be listed here. If no arguments are passed to -the function, all tests will be run. - - -|# mem.ss #| - - runs some memory tests - -|# sample-solutions.ss #| - - This tests the sample solutions in HtDP - -|# io.ss #| - - This tests the drscheme's io implementation. - -|# repl-test.ss #| - - This tests various interactions between parameters in the - implementation of drscheme. - -|# language-test.ss #| - - This tests that all of the individual settings in the language dialog - take effect in the repl. - - -|# graphics.ss #| - - This tests the various graphic elements that can appear - in programs. - -|# launcher.ss #| - - This tests the launcher feature of drscheme. - ----------------------------------- --------- MANUAL TESTS ---------- ----------------------------------- - - sixlib.ss - ----------------------------------- ----------- OLD TESTS ----------- ----------------------------------- - - menu-test.ss - -PR-based tests: - - pr-144.ss - pr-17.ss - pr-246.ss - pr-39.ss - pr-46.ss - pr-48.ss - pr-51.ss - pr-58.ss - pr-80.ss - pr-99.ss - -Ideally, each test should be run with a fresh invocation -of DrScheme. Since that's time-consuming, you can -run all tests by executing "drscheme-test.ss". - -A small amount of manual intervention is needed during -the tests. By intervention, we mean pushing buttons -in dialogs that popup during the tests. - -The progress and results of the tests are reported to -standard output. You should examine this output to determine -whether if the tests were successful. - -The code is maintained by Paul Steckler. The original code -was by Robby Findler. - -There are some other files in this directory, which appear -to be unused, such as tmp.ss, and line-art.ss. The directory -syncheck/ appears to be unused. - -|#) \ No newline at end of file diff --git a/collects/tests/drscheme/check-syntax-test.ss b/collects/tests/drscheme/check-syntax-test.ss deleted file mode 100644 index e3399a94..00000000 --- a/collects/tests/drscheme/check-syntax-test.ss +++ /dev/null @@ -1,52 +0,0 @@ -;;; check-syntax.ss - -;;; Author: Paul Steckler, modifying code by Robby Findler - -(load-relative "drscheme-test-util.ss") - -(let* ([drs-frame (wait-for-drscheme-frame)] - [interactions-edit (ivar drs-frame interactions-edit)] - [get-int-pos (lambda () (get-text-pos interactions-edit))] - [check-check-syntax ; type in term, call check-syntax - (lambda (str expected) - (clear-definitions drs-frame) - (type-in-definitions drs-frame str) - (let ([answer-begin (get-int-pos)]) - (mred:test:button-push (ivar drs-frame check-syntax-button)) - (let ([answer-end (- (get-int-pos) 1)]) - (let ([actual (send interactions-edit get-text - answer-begin answer-end)]) - (unless (string=? actual expected) - (printf "Expected: ~a~n Actual: ~a~n~n" - expected actual))) - (let ([frame (mred:test:get-active-frame)]) - (unless (eq? frame drs-frame) - (error 'check-syntax "Unexpected window ~a" frame))))))] - - ; question: should we test for errors at different syntax levels? - - [terms-and-msgs ; terms and expected error message, if any - - ; why are some of these messages init-capped, others not? - - '(("x" "") - ("." "can't use `.' outside list") - ("(" "missing close paren") - ("begin" "Invalid use of keyword begin") - ("(begin)" "Malformed begin") - ("1" "") - ("add1" "") - ("(lambda (x) x)" ""))]) - - (set-language-level! "R4RS+" drs-frame) - - (printf "Starting check-syntax tests~n") - - (for-each - (lambda (p) (check-check-syntax (car p) (cadr p))) - terms-and-msgs)) - - (printf "Finished check-syntax tests~n") - - - \ No newline at end of file diff --git a/collects/tests/drscheme/config-lang-test.ss b/collects/tests/drscheme/config-lang-test.ss deleted file mode 100644 index d8ed9b73..00000000 --- a/collects/tests/drscheme/config-lang-test.ss +++ /dev/null @@ -1,76 +0,0 @@ -;;; config-lang-test.ss - -;;; tests the toggle options in the dialog started from the -;;; Language | Configure Language... menu item - -;;; Author: Paul Steckler - -(load-relative "drscheme-test-util.ss") - -(letrec* ([_ (wait-for-drscheme-frame)] - [drscheme-frame (mred:test:get-active-frame)] - [eq-frame? (lambda () (eq? (mred:test:get-active-frame) drscheme-frame))] - [interactions-edit (ivar drscheme-frame interactions-edit)] - [interactions-canvas (ivar drscheme-frame interactions-canvas)] - [definitions-edit (ivar drscheme-frame definitions-edit)] - [definitions-canvas (ivar drscheme-frame definitions-canvas)] - [execute-button (ivar drscheme-frame execute-button)] - [get-int-pos (lambda () (get-start-of-last-line interactions-edit))] - [wait-for-events - (lambda (nevents) - (let loop () - (unless (= nevents (mred:test:number-pending-actions)) - (sleep 1/2) - (loop))))] - [run-test - (lambda (cb state code expected) - - ; click on menu item - - (mred:test:menu-select "Language" "Configure Language...") - (mred:test:new-window (wx:find-window-by-name "Language" null)) - - ; open sub-dialog - - (with-handlers ([(lambda (_) #t) (lambda (x) (printf "~a~n" (exn-message x)))]) - (mred:test:button-push "Show Details") - (wait-for-events 1) - (mred:test:reraise-error)) - - (mred:test:set-check-box! cb state) - - ; close dialog - - (mred:test:button-push "OK") - - ; enter code in definitions window - - (wait-for-drscheme-frame) - (mred:test:new-window definitions-canvas) - (clear-definitions drscheme-frame) - (mred:test:button-push execute-button) - - (let ([answer-begin (send interactions-edit last-position)]) - - (type-in-definitions drscheme-frame code) - (mred:test:keystroke #\return) - - ; compare actual answer to expected - - (push-button-and-wait execute-button) - - (let* ([answer-end (- (send interactions-edit last-position) 3)] - [actual (send interactions-edit get-text - answer-begin answer-end)]) - (unless (string=? actual expected) - (printf "Expected: ~a~n Actual: ~a~n~n" - expected actual)))))]) - - ; now toggle items and test - - (mred:test:run-interval 500) - - (run-test "Case sensitive" #f - "(eq? 'foo 'FOO)" - "#t")) - diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss deleted file mode 100644 index b024cc74..00000000 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ /dev/null @@ -1,337 +0,0 @@ -;;; util.ss - -;;; utility functions for DrScheme GUI testing - -;;; Authors: Robby Findler, Paul Steckler - -(unit/sig drscheme:test-util^ - - (import mred^ - [fw : framework^] - test-utils:gui^) - - ;; save-drscheme-window-as : string -> void - ;; use the "save as" dialog in drscheme to save the definitions - ;; window to a file. - (define (save-drscheme-window-as filename) - (use-get/put-dialog - (lambda () - (fw:test:menu-select "File" "Save Definitions As...")) - filename)) - - ;; use-get/put-dialog : (-> void) string -> void - ;; open-dialog is a thunk that should open the dialog - ;; filename is a string naming a file that should be typed into the dialog - (define (use-get/put-dialog open-dialog filename) - (unless (procedure? open-dialog) - (error 'use-open/close-dialog "expected procedure as first argument, got: ~e, other arg: ~e" - open-dialog filename)) - (unless (string? filename) - (error 'use-open/close-dialog "expected string as second argument, got: ~e, other arg: ~e" - filename open-dialog)) - (let ([drs (wait-for-drscheme-frame)] - [old-pref (fw:preferences:get 'framework:file-dialogs)]) - (with-handlers ([(lambda (x) #t) - (lambda (x) - (fw:preferences:set 'framework:file-dialogs old-pref) - (raise x))]) - (fw:preferences:set 'framework:file-dialogs 'common) - (open-dialog) - (let ([dlg (wait-for-new-frame drs)]) - (send (find-labelled-window "Full pathname") focus) - (fw:test:keystroke #\a (list (case (system-type) - [(windows) 'control] - [(macos) 'command] - [(unix) 'meta]))) - (for-each fw:test:keystroke (string->list filename)) - (fw:test:button-push "OK") - (wait-for-new-frame dlg)) - (fw:preferences:set 'framework-file-dialogs old-pref)))) - - ;; -> eventspace - ;; returns the eventspace used by the program in the current drscheme window - (define (get-user-eventspace) - (ivar (wait-for-drscheme-frame) user-eventspace)) - - (define (test-util-error fmt . args) - (raise (make-exn (apply fmt args) (current-continuation-marks)))) - - (define poll-until - (case-lambda - [(pred) (poll-until pred 10)] - [(pred secs) - (let ([step 1/20]) - (let loop ([counter secs]) - (if (<= counter 0) - (error 'poll-until "timeout after ~e secs, ~e never returned a true value" secs pred) - (let ([result (pred)]) - (or result - (begin - (sleep step) - (loop (- counter step))))))))])) - - (define (drscheme-frame? frame) - (ivar-in-interface? 'execute-button (object-interface frame))) - - (define (wait-for-drscheme-frame) - (let ([wait-for-drscheme-frame-pred - (lambda () - (yield) - (let ([active (get-top-level-focus-window)]) - (if (and active - (drscheme-frame? active)) - active - #f)))]) - (or (wait-for-drscheme-frame-pred) - (begin - (printf "Select DrScheme frame~n") - (poll-until wait-for-drscheme-frame-pred))))) - - (define (wait-for-new-frame old-frame) - (let ([wait-for-new-frame-pred - (lambda () - (let ([active (get-top-level-focus-window)]) - (if (and active - (not (eq? active old-frame))) - active - #f)))]) - (poll-until wait-for-new-frame-pred))) - - (define (wait-for-computation frame) - (verify-drscheme-frame-frontmost 'wait-for-computation frame) - (let* ([button (ivar frame execute-button)] - [wait-for-computation-pred - (lambda () - (fw:test:reraise-error) - (send button is-enabled?))]) - (poll-until - wait-for-computation-pred - 60))) - - (define do-execute - (case-lambda - [(frame) - (do-execute frame #t)] - [(frame wait-for-finish?) - (verify-drscheme-frame-frontmost 'do-execute frame) - (let ([button (ivar frame execute-button)]) - (fw:test:button-push button) - (when wait-for-finish? - (wait-for-computation frame)))])) - - (define (verify-drscheme-frame-frontmost function-name frame) - (unless (and (eq? frame (get-top-level-focus-window)) - (drscheme-frame? frame)) - (error function-name "drscheme frame not frontmost: ~e" frame))) - - (define (clear-definitions frame) - (verify-drscheme-frame-frontmost 'clear-definitions frame) - (fw:test:new-window (ivar frame definitions-canvas)) - (let ([window (send frame get-focus-window)]) - (let-values ([(cw ch) (send window get-client-size)] - [(w h) (send window get-size)]) - (fw:test:mouse-click 'left - (+ cw (floor (/ (- w cw) 2))) - (+ ch (floor (/ (- h ch) 2)))))) - (fw:test:menu-select "Edit" "Select All") - (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) - "Clear" - "Delete"))) - - - (define (type-in-definitions frame str) - (type-in-definitions/interactions 'definitions-canvas frame str)) - (define (type-in-interactions frame str) - (type-in-definitions/interactions 'interactions-canvas frame str)) - - (define (type-in-definitions/interactions canvas-ivar frame str/sexp) - (let ([str (if (string? str/sexp) - str/sexp - (let ([port (open-output-string)]) - (parameterize ([current-output-port port]) - (write str/sexp port)) - (get-output-string port)))]) - (verify-drscheme-frame-frontmost 'type-in-definitions/interactions frame) - (let ([len (string-length str)] - [canvas (ivar/proc frame canvas-ivar)]) - (fw:test:new-window canvas) - (send (send canvas get-editor) set-caret-owner #f) - (let loop ([i 0]) - (unless (>= i len) - (let ([c (string-ref str i)]) - (fw:test:keystroke - (if (char=? c #\newline) - #\return - c))) - (loop (+ i 1))))))) - - (define wait - (case-lambda - [(test desc-string) (wait test desc-string 5)] - [(test desc-string time) - (let ([int 1/2]) - (let loop ([sofar 0]) - (cond - [(> sofar time) (error 'wait desc-string)] - [(test) (void)] - [else (sleep int) - (loop (+ sofar int))])))])) - - (define (wait-pending) - (wait (lambda () (= 0 (fw:test:number-pending-actions))) - "Pending actions didn't terminate") - (fw:test:reraise-error)) - - -;;; get-sub-panel takes -;;; a list of integers describing the path from a frame to the desired panel -;;; the frame -;;; based on code by Mark Krentel - -;;; Examples: -;;; (get-sub-panel '() frame) gets the top-panel in frame -;;; (get-sub-panel '(2) frame) gets the 2nd child of the top-panel -;;; (get-sub-panel '(2 0) frame) gets the 0th child of the 2nd child of the top-panel - - (define (get-sub-panel path frame) - (letrec ([loop - (lambda (path panel) - (if (null? path) - (if (is-a? panel panel%) - panel - (test-util-error "not a panel")) - (loop - (cdr path) - (list-ref (send panel get-children) (car path)))))]) - (loop path frame))) - -;;; get-text-pos returns the offset in an text buffer of the beginning -;;; of the last line - - (define (get-text-pos text) - (let* ([last-pos (send text last-position)] - [last-line (send text position-line last-pos)]) - (send text line-start-position last-line))) - - ; poll for enabled button - - (define (wait-for-button button) - (poll-until - (let ([wait-for-button-pred - (lambda () - (send button is-enabled?))]) - wait-for-button-pred))) - - (define (push-button-and-wait button) - (fw:test:button-push button) - (poll-until - (let ([button-push-and-wait-pred - (lambda () - (fw:test:reraise-error) - (= 0 (fw:test:number-pending-actions)))]) - button-push-and-wait-pred)) - (wait-for-button button)) - - ; set language level in the frontmost DrScheme frame - (define set-language-level! - (case-lambda - [(level) - (set-language-level! level #t)] - [(level close-dialog?) - (let ([frame (get-top-level-focus-window)]) - (fw:test:menu-select "Language" "Choose Language...") - - (wait-for-new-frame frame) - (let ([language-choice (find-labelled-window "Language" choice%)]) - (cond - [(member level (let loop ([n (send language-choice get-number)]) - (cond - [(zero? n) null] - [else (cons (send language-choice get-string (- n 1)) - (loop (- n 1)))]))) - (fw:test:set-choice! language-choice level)] - [else - (fw:test:set-choice! language-choice "Full Scheme") - (fw:test:set-radio-box! - (find-labelled-window #f radio-box% (send language-choice get-parent)) - level)])) - - (when close-dialog? - (let ([language-dialog (get-top-level-focus-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame language-dialog))))])) - - (define (repl-in-edit-sequence?) - (send (ivar (wait-for-drscheme-frame) interactions-text) refresh-delayed?)) - - (define (has-error? frame) - (verify-drscheme-frame-frontmost 'had-error? frame) - (let* ([interactions-text (ivar frame interactions-text)] - [last-para (send interactions-text last-paragraph)]) - (unless (>= last-para 2) - (error 'has-error? "expected at least 2 paragraphs in interactions window, found ~a" - (+ last-para 1))) - (let ([start (send interactions-text paragraph-start-position 2)] - [end (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1))]) - (send interactions-text split-snip start) - (send interactions-text split-snip end) - (let loop ([pos start]) - (cond - [(<= end pos) #f] - [else - (let ([snip (send interactions-text find-snip pos 'after-or-none)]) - (cond - [(not snip) #f] - [else - (let ([color (send (send snip get-style) get-foreground)]) - (if (and (= 255 (send color red)) - (= 0 (send color blue) (send color green))) - #t - (loop (+ pos (send snip get-count)))))]))]))))) - - (define fetch-output - (case-lambda - [(frame) - (verify-drscheme-frame-frontmost 'fetch-output frame) - (let* ([interactions-text (ivar frame interactions-text)] - [last-para (send interactions-text last-paragraph)]) - (unless (>= last-para 2) - (error 'fetch-output "expected at least 2 paragraphs in interactions window, found ~a" - (+ last-para 1))) - (fetch-output frame - (send interactions-text paragraph-start-position 2) - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1))))] - [(frame start end) - (verify-drscheme-frame-frontmost 'fetch-output frame) - (let ([interactions-text (ivar frame interactions-text)]) - (send interactions-text split-snip start) - (send interactions-text split-snip end) - (let loop ([snip (send interactions-text find-snip end 'before)] - [strings null]) - (cond - [(< (send interactions-text get-snip-position snip) start) - (apply string-append strings)] - [else - (cond - [(is-a? snip string-snip%) - (loop (send snip previous) - (cons (send snip get-text 0 (send snip get-count)) strings))] - [(is-a? snip editor-snip%) - (let ([editor (send snip get-editor)]) - (cond - [(is-a? editor pasteboard%) - (loop (send snip previous) - (cons "" strings))] - [(is-a? editor text%) - (loop (send snip previous) - (list* "[" - (send editor get-text) - "]" - strings))]))] - [(is-a? snip image-snip%) - (loop (send snip previous) - (cons "" - strings))] - [else (error 'find-output "unknown snip: ~e~n" snip)])])))]))) \ No newline at end of file diff --git a/collects/tests/drscheme/drscheme-test.ss b/collects/tests/drscheme/drscheme-test.ss deleted file mode 100644 index 8061f488..00000000 --- a/collects/tests/drscheme/drscheme-test.ss +++ /dev/null @@ -1,47 +0,0 @@ -;;; drscheme-test.ss - -;;; files for testing of DrScheme - -;;; Author: Paul Steckler - -(load-relative "drscheme-test-util.ss") - -(define test-files - (list - "menu-test.ss" ; opens some dialogs and closes them - "repl-test.ss" ; executes and loads some terms in the REPL - "check-syntax-test.ss" ; calls syntax checker on some terms - )) - -(define pr-files - (list - "pr-17.ss" - "pr-39.ss" - "pr-39.ss" - "pr-46.ss" - "pr-48.ss" - "pr-51.ss" - "pr-58.ss" - "pr-80.ss" - "pr-99.ss" - "pr-144.ss" - "pr-246.ss" - )) - -(define (run-it s) - (clear-definitions (wait-for-drscheme-frame)) - (printf "Running tests in file ~a...~n" s) - (load-relative s) - (printf "Done with file ~a.~n" s)) - -(printf "Running DrScheme tests...~n") - -(for-each run-it test-files) - -(printf "Done with DrScheme tests.~n") - -(printf "Running tests designed from GNATS pr's...~n") - -(for-each run-it pr-files) - -(printf "Done with GNATS pr tests.~n") diff --git a/collects/tests/drscheme/event-efficency.ss b/collects/tests/drscheme/event-efficency.ss deleted file mode 100644 index 0119a04a..00000000 --- a/collects/tests/drscheme/event-efficency.ss +++ /dev/null @@ -1,63 +0,0 @@ -(define semaphore (make-semaphore 0)) -(define loop-size 3000) -(define events/loop 10) - -(define frame (make-object frame% "frame" #f 100 100)) -(define counter 0) -(define canvas - (make-object - (class canvas% () - (inherit refresh) - (override - [on-paint - (lambda () - (cond - [(equal? 0 counter) - (void)] - [else - (set! counter (- counter 1)) - (refresh)]))]) - (sequence (super-init frame))))) - -(send frame show #t) -;(event-dispatch-handler (let ([orig (event-dispatch-handler)]) (lambda (eventspace) (orig eventspace)))) - -(define (test name body-expression after-expression) - (let ([start-time (current-milliseconds)]) - (eval - `(let loop ([n loop-size]) - (unless (zero? n) - ,body-expression - (loop (- n 1))))) - (let* ([end-time (current-milliseconds)] - [total-time (- end-time start-time)]) - - (eval after-expression) - - (printf "~a: time per event ~a msec~n~a: total time ~a msec~n" - name - (exact->inexact - (/ (floor (* (/ total-time loop-size events/loop) 1000)) 1000)) - name - total-time)))) - - -(test - "canvas" - `(begin - ,@(let loop ([n events/loop]) - (cond - [(zero? n) `()] - [else `((queue-callback void) - . - ,(loop (- n 1)))]))) - '(void)) - - -(test - "queue" - '(begin (set! counter events/loop) - (send canvas refresh)) - '(begin (queue-callback (lambda () (semaphore-post semaphore))) - (yield semaphore))) - diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss deleted file mode 100644 index 2338e2d4..00000000 --- a/collects/tests/drscheme/io.ss +++ /dev/null @@ -1,35 +0,0 @@ -(set-language-level! "Textual (MzScheme)") - -(define frame (wait-for-drscheme-frame)) - -(define (check-output expression expected) - (begin - (clear-definitions frame) - (type-in-definitions frame expression) - (do-execute frame) - (let ([got (fetch-output frame)]) - (unless (equal? expected got) - (error 'io.ss "expected ~s, got ~s for ~s" expected got expression))))) - -(check-output "(display 1)" "[1]") -(check-output "(display 1 (current-output-port))" "[1]") -(check-output "(display 1 (current-error-port))" "1") -(check-output "(display 1) (display 1 (current-error-port))" (format "[1]~n1")) -(check-output "(display 1 (current-error-port)) (display 1)" (format "1~n[1]")) -(check-output "(display 1) (display 1 (current-error-port)) (display 1)" (format "[1]~n1~n[1]")) -(check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))" (format "1~n[1]~n1")) -(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))" "[1]") -(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))" "[1]") -(check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))" "1") - - -;; long io / execute test -(clear-definitions frame) -(type-in-definitions - frame - "(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))") -(do-execute frame) -(clear-definitions frame) -(do-execute frame) -(unless (equal? "" (fetch-output frame)) - (error 'io.ss "failed long io / execute test")) diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss deleted file mode 100644 index 9533f434..00000000 --- a/collects/tests/drscheme/language-test.ss +++ /dev/null @@ -1,576 +0,0 @@ -(define language (make-parameter "<>")) - -(define (set-language close-dialog?) - (set-language-level! (language) close-dialog?) - (unless close-dialog? - (with-handlers ([exn:user? (lambda (x) (void))]) - (fw:test:button-push "Show Details")))) - -(define (test-setting setting-name value expression result) - (fw:test:set-check-box! setting-name value) - (let ([f (get-top-level-focus-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame f)) - (let* ([drs (get-top-level-focus-window)] - [interactions (ivar drs interactions-text)]) - (clear-definitions drs) - (type-in-definitions drs expression) - (do-execute drs) - (let* ([got (fetch-output drs)]) - (unless (string=? result got) - (printf "FAILED: ~a ~a test~n expected: ~a~n got: ~a~n" (language) expression result got))) - '(dump-memory-stats))) - -(define (test-hash-bang) - (let* ([expression (format "#!~n1")] - [result "1"] - [drs (get-top-level-focus-window)] - [interactions (ivar drs interactions-text)]) - (clear-definitions drs) - (type-in-definitions drs expression) - (do-execute drs) - (let* ([got (fetch-output drs)]) - (unless (string=? "1" got) - (printf "FAILED: ~a ~a test~n expected: ~a~n got: ~a~n" - (language) expression result got))))) - -(define (mred) - (parameterize ([language "Graphical without Debugging (MrEd)"]) - (generic-settings #f) - (generic-output #t #t #f) - (set-language #f) - (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "cond or case: no matching clause") - - (test-hash-bang) - - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (do-execute drs)) - - (test-expression "(error 'a \"~a\" 1)" "a: 1") - (test-expression "(error \"a\" \"a\")" "a \"a\"") - - (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) - - (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") - (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") - (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") - - (test-expression "true" "reference to undefined identifier: true") - (test-expression "mred^" "compile: illegal use of an expansion-time value name in: mred^") - (test-expression "(eq? 'a 'A)" "#t") - (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" "define-values: illegal use (not at top-level) in: (#%define-values (x) x)") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "3/2" "3/2") - (test-expression "1/3" "1/3") - (test-expression "(list 1)" "(1)") - (test-expression "argv" "#0()"))) - -(define (mzscheme) - (parameterize ([language "Textual without Debugging (MzScheme)"]) - (generic-settings #f) - (generic-output #t #t #f) - (set-language #f) - (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "cond or case: no matching clause") - - (test-hash-bang) - - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (do-execute drs)) - - (test-expression "(error 'a \"~a\" 1)" "a: 1") - (test-expression "(error \"a\" \"a\")" "a \"a\"") - - (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) - - (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") - (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") - (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") - - (test-expression "true" "reference to undefined identifier: true") - (test-expression "mred^" "reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "#t") - (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" "define-values: illegal use (not at top-level) in: (#%define-values (x) x)") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "3/2" "3/2") - (test-expression "1/3" "1/3") - (test-expression "(list 1)" "(1)") - (test-expression "argv" "#0()"))) - -(define (mred-debug) - (parameterize ([language "Graphical (MrEd)"]) - (generic-settings #f) - (generic-output #t #t #t) - (set-language #f) - (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "no matching cond clause") - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #t "(letrec ([x x]) 1)" - "Variable x referenced before definition or initialization") - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #f "(letrec ([x x]) 1)" "1") - - (test-hash-bang) - - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (do-execute drs)) - - (test-expression "(error 'a \"~a\" 1)" "a: 1") - (test-expression "(error \"a\" \"a\")" "a \"a\"") - - (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) - - (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") - (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") - (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") - - (test-expression "true" "reference to undefined identifier: true") - (test-expression "mred^" "signature: invalid use of signature name mred^") - (test-expression "(eq? 'a 'A)" "#t") - (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" - "definition: invalid position for internal definition") - (test-expression "(letrec ([x x]) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "3/2" "3/2") - (test-expression "1/3" "1/3") - (test-expression "(list 1)" "(1)") - (test-expression "argv" "#0()"))) - -(define (mzscheme-debug) - (parameterize ([language "Textual (MzScheme)"]) - (generic-settings #f) - (generic-output #t #t #t) - (set-language #f) - (test-setting "Unmatched cond/case is an error" #t "(cond [#f 1])" "no matching cond clause") - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #t "(letrec ([x x]) 1)" - "Variable x referenced before definition or initialization") - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #f "(letrec ([x x]) 1)" "1") - - (test-hash-bang) - - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (do-execute drs)) - - (test-expression "(error 'a \"~a\" 1)" "a: 1") - (test-expression "(error \"a\" \"a\")" "a \"a\"") - - (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) - - (test-expression "(list make-posn posn-x posn-y posn?)" "reference to undefined identifier: make-posn") - (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") - (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") - - (test-expression "true" "reference to undefined identifier: true") - (test-expression "mred^" "reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "#t") - (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") - (test-expression "(cond [(= 1 2) 3])" "") - (test-expression "(cons 1 2)" "(1 . 2)") - (test-expression "'(1)" "(1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(#&1 #&1)") - (test-expression "(local ((define x x)) 1)" - "definition: invalid position for internal definition") - (test-expression "(letrec ([x x]) 1)" "1") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "1") - (test-expression "1.0" "1.0") - (test-expression "#i1.0" "1.0") - (test-expression "3/2" "3/2") - (test-expression "1/3" "1/3") - (test-expression "(list 1)" "(1)") - (test-expression "argv" "#0()"))) - -(define (zodiac-beginner) - (parameterize ([language "Beginning Student"]) - (zodiac) - (generic-output #f #f #t) - - (test-hash-bang) - - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (do-execute drs)) - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" "reference to undefined identifier: time") - - (test-expression "(list make-posn posn-x posn-y posn?)" "(cons make-posn (cons posn-x (cons posn-y (cons posn? empty))))") - (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") - (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") - - (test-expression "true" "true") - (test-expression "mred^" "reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" "reference to undefined identifier: set!") - (test-expression "(cond [(= 1 2) 3])" "no matching cond clause") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "'(1)" "quote: misused: '(1) is not a symbol") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(cons (box 1) (cons (box 1) empty))") - (test-expression "(local ((define x x)) 1)" - "definition: must be at the top level") - (test-expression "(letrec ([x x]) 1)" - "illegal application: first term in application must be a function name") - (test-expression "(if 1 1 1)" "Condition value is neither true nor false: 1") - (test-expression "(+ 1)" "+: expects at least 2 arguments, given 1: 1") - (test-expression "1.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "3/2" "1.5") - (test-expression "1/3" "1/3") - (test-expression "(list 1)" "(cons 1 empty)") - (test-expression "argv" "reference to undefined identifier: argv"))) - -(define (zodiac-intermediate) - (parameterize ([language "Intermediate Student"]) - (zodiac) - (generic-output #t #f #t) - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #t "(local ((define x x)) 1)" - "Variable x referenced before definition or initialization") - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #f "(local ((define x x)) 1)" "1") - - (test-hash-bang) - - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (do-execute drs)) - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) - - (test-expression "(list make-posn posn-x posn-y posn?)" "(list make-posn posn-x posn-y posn?)") - (test-expression "set-posn-x!" "reference to undefined identifier: set-posn-x!") - (test-expression "set-posn-y!" "reference to undefined identifier: set-posn-y!") - - (test-expression "true" "true") - (test-expression "mred^" "reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" "reference to undefined identifier: set!") - (test-expression "(cond [(= 1 2) 3])" "no matching cond clause") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "'(1)" "(list 1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(list (box 1) (box 1))") - (test-expression "(local ((define x x)) 1)" "Variable x referenced before definition or initialization") - (test-expression "(letrec ([x x]) 1)" "Variable x referenced before definition or initialization") - (test-expression "(if 1 1 1)" "Condition value is neither true nor false: 1") - (test-expression "(+ 1)" "+: expects at least 2 arguments, given 1: 1") - (test-expression "1.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "3/2" "1.5") - (test-expression "1/3" "1/3") - (test-expression "(list 1)" "(list 1)") - (test-expression "argv" "reference to undefined identifier: argv"))) - -(define (zodiac-advanced) - (parameterize ([language "Advanced Student"]) - (zodiac) - (generic-output #t #t #t) - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #t "(local ((define x x)) 1)" - "Variable x referenced before definition or initialization") - (set-language #f) - (test-setting "Signal undefined variables when first referenced" #f "(local ((define x x)) 1)" "1") - - (test-hash-bang) - - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (set-language #t) - (do-execute drs)) - - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") - - (test-expression "(time 1)" (format "[cpu time: 0 real time: 0 gc time: 0]~n1")) - - (test-expression "(list make-posn posn-x posn-y posn?)" "(list make-posn posn-x posn-y posn?)") - (test-expression "set-posn-x!" "set-posn-x!") - (test-expression "set-posn-y!" "set-posn-y!") - - (test-expression "true" "true") - (test-expression "mred^" "reference to undefined identifier: mred^") - (test-expression "(eq? 'a 'A)" "false") - (test-expression "(set! x 1)" "set!: cannot set undefined identifier: x") - (test-expression "(cond [(= 1 2) 3])" "no matching cond clause") - (test-expression "(cons 1 2)" "cons: second argument must be of type , given 1 and 2") - (test-expression "'(1)" "(list 1)") - (test-expression "(define shrd (box 1)) (list shrd shrd)" - "(shared ((-1- (box 1))) (list -1- -1-))") - (test-expression "(local ((define x x)) 1)" "Variable x referenced before definition or initialization") - (test-expression "(letrec ([x x]) 1)" "Variable x referenced before definition or initialization") - (test-expression "(if 1 1 1)" "1") - (test-expression "(+ 1)" "+: expects at least 2 arguments, given 1: 1") - (test-expression "1.0" "1") - (test-expression "#i1.0" "#i1.0") - (test-expression "3/2" "1.5") - (test-expression "1/3" "1/3") - (test-expression "(list 1)" "(list 1)") - (test-expression "argv" "reference to undefined identifier: argv"))) - -(define (zodiac) - (generic-settings #t) - - (set-language #f) - (test-setting "Print booleans as true and false" #t "#t #f" (format "true~nfalse")) - (set-language #f) - (test-setting "Print booleans as true and false" #f "#t #f" (format "#t~n#f")) - - (set-language #f) - (test-setting "Unmatched cond/case is an error" #t "(cond [false 1])" "no matching cond clause")) - -(define (generic-settings false/true?) - (set-language #f) - (test-setting "Case sensitive" #t "(eq? 'a 'A)" (if false/true? "false" "#f")) - (set-language #f) - (test-setting "Case sensitive" #f "(eq? 'a 'A)" (if false/true? "true" "#t")) - (set-language #f) - (test-setting "Unmatched cond/case is an error" #f - (format "(cond [~a 1])" (if false/true? "false" "#f")) - "")) - -(define (generic-output list? quasi-quote? zodiac?) - (let* ([drs (wait-for-drscheme-frame)] - [expression (format "(define x (box 4/3))~n(list x x)")] - [set-output-choice - (lambda (option show-sharing rationals pretty?) - (set-language #f) - (fw:test:set-radio-box! "Output Style" option) - (when show-sharing - (fw:test:set-check-box! - "Show sharing in values" - (if (eq? show-sharing 'on) #t #f))) - (when rationals - (fw:test:set-check-box! - "Print rationals in whole/part notation" - (if (eq? rationals 'on) #t #f))) - (fw:test:set-check-box! - "Use pretty printer to format values" - pretty?) - (let ([f (get-top-level-focus-window)]) - (fw:test:button-push "OK") - (wait-for-new-frame f)))] - [test - ;; answer must either be a string, or a procedure that accepts both zero and 1 - ;; argument. When the procedure accepts 1 arg, the argument is `got' and - ;; the result must be a boolean indicating if the result was satisfactory. - ;; if the procedure receives no arguments, it must return a descriptive string - ;; for the error message - (lambda (option show-sharing rationals pretty? answer) - (set-output-choice option show-sharing rationals pretty?) - (do-execute drs) - (let ([got (fetch-output drs)]) - (unless (if (procedure? answer) - (answer got) - (whitespace-string=? answer got)) - (printf "FAILED ~a ~a, sharing ~a, rationals ~a, got ~s expected ~s~n" - (language) option show-sharing rationals got - (answer)))))]) - - (clear-definitions drs) - (type-in-definitions drs expression) - - (test "write" 'off #f #t "(#&4/3 #&4/3)") - (test "write" 'on #f #t "(#0=#&4/3 #0#)") - (when quasi-quote? - (test "Quasiquote" 'off 'off #t "`(,(box 4/3) ,(box 4/3))") - (test "Quasiquote" 'off 'on #t "`(,(box (+ 1 1/3)) ,(box (+ 1 1/3)))") - (test "Quasiquote" 'on 'off #t "(shared ((-1- (box 4/3))) `(,-1- ,-1-))") - (test "Quasiquote" 'on 'on #t "(shared ((-1- (box (+ 1 1/3)))) `(,-1- ,-1-))")) - (test "Constructor" 'off 'off #t - (if list? - "(list (box 4/3) (box 4/3))" - "(cons (box 4/3) (cons (box 4/3) empty))")) - (test "Constructor" 'off 'on #t - (if list? - "(list (box (+ 1 1/3)) (box (+ 1 1/3)))" - "(cons (box (+ 1 1/3)) (cons (box (+ 1 1/3)) empty))")) - (test "Constructor" 'on 'off #t - (if list? - "(shared ((-1- (box 4/3))) (list -1- -1-))" - (format "(shared ((-1- (box 4/3))) (cons -1- (cons -1- empty)))"))) - (test "Constructor" 'on 'on #t - (if list? - "(shared ((-1- (box (+ 1 1/3)))) (list -1- -1-))" - (format "(shared ((-1- (box (+ 1 1/3)))) (cons -1- (cons -1- empty)))"))) - - - ;; setup comment box - (clear-definitions drs) - (fw:test:menu-select "Edit" "Insert Text Box") - (fw:test:keystroke #\a) - (fw:test:keystroke #\b) - (fw:test:keystroke #\c) - - ;; test comment box in print-convert and print-convert-less settings - (test "Constructor" 'on 'on #t (if zodiac? "[abc]" "'non-string-snip")) - (test "write" 'on #f #t (if zodiac? "[abc]" "non-string-snip")) - - ;; setup write / pretty-print difference - (clear-definitions drs) - (for-each fw:test:keystroke - (string->list - "(define(f n)(cond((zero? n)null)[else(cons n(f(- n 1)))]))(f 40)")) - (test "Constructor" 'on 'on #f - (case-lambda - [(x) (not (member #\newline (string->list x)))] - [() "no newlines in result"])) - (test "Constructor" 'on 'on #t - (case-lambda - [(x) (member #\newline (string->list x))] - [() "newlines in result (may need to make the window smaller)"])) - (test "write" #f #f #f - (case-lambda - [(x) (not (member #\newline (string->list x)))] - [() "no newlines in result"])) - (test "write" #f #f #t - (case-lambda - [(x) (member #\newline (string->list x))] - [() "newlines in result (may need to make the window smaller)"])))) - -(define (whitespace-string=? string1 string2) - (let loop ([i 0] - [j 0] - [in-whitespace? #t]) - (cond - [(= i (string-length string1)) (only-whitespace? string2 j)] - [(= j (string-length string2)) (only-whitespace? string1 i)] - [else (let ([c1 (string-ref string1 i)] - [c2 (string-ref string2 j)]) - (cond - [in-whitespace? - (cond - [(whitespace? c1) - (loop (+ i 1) - j - #t)] - [(whitespace? c2) - (loop i - (+ j 1) - #t)] - [else (loop i j #f)])] - [(and (whitespace? c1) - (whitespace? c2)) - (loop (+ i 1) - (+ j 1) - #t)] - [(char=? c1 c2) - (loop (+ i 1) - (+ j 1) - #f)] - [else #f]))]))) - -(define (whitespace? c) - (or (char=? c #\newline) - (char=? c #\space) - (char=? c #\tab) - (char=? c #\return))) - -(define (only-whitespace? str i) - (let loop ([n i]) - (cond - [(= n (string-length str)) - #t] - [(whitespace? (string-ref str n)) - (loop (+ n 1))] - [else #f]))) - -;; whitespace-string=? tests -'(map (lambda (x) (apply equal? x)) - (list (list #t (whitespace-string=? "a" "a")) - (list #f (whitespace-string=? "a" "A")) - (list #f (whitespace-string=? "a" " ")) - (list #f (whitespace-string=? " " "A")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? " " " ")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? "a a" "a a")) - (list #t (whitespace-string=? " a" "a")) - (list #t (whitespace-string=? "a" " a")) - (list #t (whitespace-string=? "a " "a")) - (list #t (whitespace-string=? "a" "a ")))) - -(define (test-expression expression expected) - (let* ([drs (wait-for-drscheme-frame)] - [interactions-text (ivar drs interactions-text)] - [last-para (send interactions-text last-paragraph)]) - (send interactions-text set-position - (send interactions-text last-position) - (send interactions-text last-position)) - (type-in-interactions drs expression) - (type-in-interactions drs (string #\newline)) - (wait-for-computation drs) - (let ([got - (fetch-output - drs - (send interactions-text paragraph-start-position (+ last-para 1)) - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1)))]) - (unless (whitespace-string=? got expected) - (printf "FAILED: ~a expected ~s to produce ~s, got ~s instead~n" - (language) expression expected got))))) - - -;; clear teachpack -(let ([drs (wait-for-drscheme-frame)]) - (fw:test:menu-select "Language" "Clear All Teachpacks")) - -(zodiac-beginner) -(zodiac-intermediate) -(zodiac-advanced) -(mzscheme-debug) -(mred-debug) -(mzscheme) -(mred) diff --git a/collects/tests/drscheme/launcher.ss b/collects/tests/drscheme/launcher.ss deleted file mode 100644 index ea7a9189..00000000 --- a/collects/tests/drscheme/launcher.ss +++ /dev/null @@ -1,96 +0,0 @@ -(define tmp-filename - (build-path (collection-path "tests" "drscheme") - "launcher-test-tmp.ss")) -(define tmp-launcher - (build-path (collection-path "tests" "drscheme") - (case (system-type) - [(unix) "launcher-test-tmp"] - [(windows) "launcher-test-tmp.exe"] - [else (error 'launcher.ss "cannot run this test under ~s" (system-type))]))) -(define tmp-teachpack - (build-path (collection-path "tests" "drscheme") - "launcher-test-teachpack.ss")) - -(define (get-port) - (let loop ([n 100]) - (unless (zero? n) - (with-handlers ([(lambda (x) #t) - (lambda (x) - (loop (- n 1)))]) - (let ([tcp-port (+ 51700 n)]) - (values tcp-port - (tcp-listen tcp-port))))))) - -(define (run-launcher/no-teachpack listener test expected) - (when (file-exists? tmp-launcher) - (delete-file tmp-launcher)) - (use-get/put-dialog - (lambda () - (fw:test:menu-select "Scheme" "Create Launcher...")) - tmp-launcher) - (let-values ([(l-in l-out l-pid l-err l-proc) (apply values (process* tmp-launcher))] - [(in out) (tcp-accept listener)]) - (let ([got (read in)]) - (unless (equal? expected got) - (error test "expected ~s, got ~s" expected got))))) - -(define (teachpackless-test) - (define-values (port-num listener) (get-port)) - (define drs (wait-for-drscheme-frame)) - (clear-definitions drs) - (type-in-definitions - drs - `(let-values ([(in out) (tcp-connect "localhost" ,port-num)]) - (write 'the-correct-answer out) - (newline out))) - (when (file-exists? tmp-filename) - (delete-file tmp-filename)) - (save-drscheme-window-as tmp-filename) - (set-language-level! "Graphical without Debugging (MrEd)") - (run-launcher/no-teachpack listener 'no-teachpack 'the-correct-answer)) - -(define (teachpack-test language insert-junk) - (define-values (port-num listener) (get-port)) - (define drs (wait-for-drscheme-frame)) - (set-language-level! language) - (call-with-output-file tmp-teachpack - (lambda (port) - (write - `(unit/sig (send-back) - (import plt:userspace^) - (define (send-back sexp) - (let-values ([(in out) (tcp-connect "localhost" ,port-num)]) - (write sexp out) - (newline out) - (close-output-port out) - (close-input-port in)))) - port)) - 'truncate) - (clear-definitions drs) - (insert-junk) - (type-in-definitions drs `(send-back 'the-correct-answer)) - (fw:test:menu-select "File" "Save Definitions") - (fw:test:menu-select "Language" "Clear All Teachpacks") - (use-get/put-dialog - (lambda () - (fw:test:menu-select "Language" "Add Teachpack...")) - tmp-teachpack) - (run-launcher/no-teachpack listener 'teachpack-beginner 'the-correct-answer)) - -(teachpackless-test) - -;(teachpack-test "Graphical (MrEd)" void) -;(teachpack-test "Textual (MzScheme)" void) -;(teachpack-test "Textual without Debugging (MzScheme)" void) -;(teachpack-test "Graphical without Debugging (MrEd)" void) -;(teachpack-test "Beginning Student" void) -;(teachpack-test "Intermediate Student" void) -;(teachpack-test "Advanced Student" void) - -(teachpack-test "Beginning Student" - (lambda () - (let ([drs (wait-for-drscheme-frame)]) - (fw:test:menu-select "Edit" "Insert Text Box") - (fw:test:keystroke #\a) - (fw:test:keystroke #\b) - (fw:test:keystroke #\c)))) \ No newline at end of file diff --git a/collects/tests/drscheme/line-art.ss b/collects/tests/drscheme/line-art.ss deleted file mode 100644 index 7c1d918b..00000000 --- a/collects/tests/drscheme/line-art.ss +++ /dev/null @@ -1,27 +0,0 @@ -(lambda (a b c d e f g h i j k l m n o p q r ss t u v w x y z) - (list z - y - x - w - v - u - t - ss - r - q - p - o - n - m - l - k - j - i - h - g - f - e - d - c - b - a)) \ No newline at end of file diff --git a/collects/tests/drscheme/menu-test.ss b/collects/tests/drscheme/menu-test.ss deleted file mode 100644 index d23b1566..00000000 --- a/collects/tests/drscheme/menu-test.ss +++ /dev/null @@ -1,82 +0,0 @@ -;;; menu-test.ss - -;;; tests the various menu items in the DrScheme menubar - -;;; Author: Paul Steckler, based on earlier code by Robby Findler - -(load "drscheme-test-util.ss") - -;; Under X, the validity of these tests requires that the window -;; with the mouse cursor is active. That's not necessarily the case. - -(let* ([frame (wait-for-drscheme-frame)] - - [eq-frame? (lambda () (eq? (mred:test:get-active-frame) frame))] - - [dialog-test - (lambda (menu) - (lambda (item) - (mred:test:menu-select menu item) - (wait (lambda () (not (eq-frame?))) - (string-append - "Didn't get a new frame after selecting " - menu "|" item)) - (mred:test:button-push "Cancel") - (wait-pending) - (wait eq-frame? - (string-append - "Original DrScheme frame not active after cancelling File|" - item))))] - - [file-dialog-test (dialog-test "File")] - [edit-dialog-test (dialog-test "Edit")] - [language-dialog-test (dialog-test "Language")] - - [file-dialog-items - '("Open..." - "Open URL..." - "Save Definitions As..." - "Save Definitions As Text..." - "Save Interactions" - "Save Interactions As..." - "Save Interactions As Text..." - - ; we omit the print dialogs, because the test primitives - ; only work with MrEd-derived classes - - "Close" ; do this 3 times, per Robby - "Close" - "Close" - - ; the Quit dialog also seems not to work with the test primitives - - )] - - [edit-dialog-items - '("Preferences...")] - - [language-dialog-items - '("Configure Language..." - "Set Library To...")]) - - ; this makes sure REPL is loaded - - (type-in-definitions frame "a") - - (for-each file-dialog-test file-dialog-items) - (printf "File menu tests complete~n") - - (for-each edit-dialog-test edit-dialog-items) - (printf "Edit menu tests complete~n") - - (for-each language-dialog-test language-dialog-items) - (printf "Language menu tests complete~n") - - (printf "All menu tests complete~n")) - -; in old autosave+prompt-save.ss, we had: - -; ((load-relative (build-path 'up "mred" "gui-main.ss")) -; "New Unit" -; "Save Definitions" -; wx:frame%) diff --git a/collects/tests/drscheme/pr-144.ss b/collects/tests/drscheme/pr-144.ss deleted file mode 100644 index 5e0bd1c3..00000000 --- a/collects/tests/drscheme/pr-144.ss +++ /dev/null @@ -1,106 +0,0 @@ -;;; pr-144.ss - -;;; Open the preferences dialog, go to the check syntax section. -;;; Wait for the autosave delay and make sure no autosaves appear. - -(require-library "function.ss") - -(load-relative "drscheme-test-util.ss") - -(let* ([drs-frame (wait-for-drscheme-frame)] - [seconds 5] - [autosave-prefix "#mredauto#"] - [autosave-prefix-len (string-length autosave-prefix)] - [definitions-edit (ivar drs-frame definitions-edit)] - [autosave-save (mred:get-preference 'mred:autosaving-on?)] - [autosave-delay-save (mred:get-preference 'mred:autosave-delay)] - [get-font-cbs - (lambda (lst) - (let ([get-cb-with-label - (lambda (label) - (car (memf (lambda (elt) - (and (is-a? elt mred:check-box%) - (string=? (send elt get-label) label))) - lst)))]) - (map get-cb-with-label '("Slant" "Bold" "Underline"))))] - [autosave-file? - (lambda (filename) - (and (> (string-length filename) autosave-prefix-len) - (string=? (substring filename 0 autosave-prefix-len) - autosave-prefix)))] - [open-preferences - (lambda () - (mred:test:menu-select "Edit" "Preferences...") - (let* ([frame - (letrec ([loop - (lambda () - (let ([active (mred:test:get-active-frame)]) - (if (or (eq? active #f) - (eq? active drs-frame)) - (begin - (sleep 1/2) - (loop)) - active)))]) - (loop))] - [panel (send frame get-top-panel)] - [children (ivar panel children)] - [choice-box (car children)] - [choice-box-event - (let ([event-obj - (make-object wx:command-event% - wx:const-event-type-choice-command)]) - (send event-obj set-event-object choice-box) - event-obj)]) - (send choice-box-event set-command-int - (send choice-box find-string "Check Syntax")) - (send choice-box command choice-box-event) - - (let* ([upper-panel (cadr children)] - [check-syntax-panel (send upper-panel active-child)] - [check-box-panels (ivar check-syntax-panel children)] - - [syntax-panel (car check-box-panels)] - [syntax-check-boxes (get-font-cbs (ivar syntax-panel children))] - [curr-states (map (lambda (cb) (send cb get-value)) - syntax-check-boxes)]) - - ; toggle current states of syntax checkboxes - ; we're going to hit Cancel, so nothing should take effect - - (map (lambda (cb state) - (mred:test:set-check-box! cb (not state))) - syntax-check-boxes - curr-states))))]) - - ; delete any existing autosave files - - (for-each - (lambda (filename) - (when (autosave-file? filename) - (delete-file filename))) - (directory-list)) - - (mred:set-preference 'mred:autosaving-on? #t) - (mred:set-preference 'mred:autosave-delay seconds) - - (open-preferences) - - (sleep (+ seconds 5)) - - ; now see if there are any autosave files - - (if (ormap autosave-file? (directory-list)) - (printf "Autosave test failed~n") - (printf "Autosave test succeeded~n")) - - (mred:test:button-push "Cancel") - - (mred:set-preference 'mred:autosaving-on? autosave-save) - (mred:set-preference 'mred:autosave-delay autosave-delay-save)) - - - - - - - diff --git a/collects/tests/drscheme/pr-17.ss b/collects/tests/drscheme/pr-17.ss deleted file mode 100644 index 3e79d70d..00000000 --- a/collects/tests/drscheme/pr-17.ss +++ /dev/null @@ -1,69 +0,0 @@ -;;; pr-17.ss - -;;; Create new frame, check that all buttons and menus exist - -;;; Author: Paul Steckler - -(load-relative "drscheme-test-util.ss") - -(define-macro check-for-button - (lambda (button s) - `(unless (ivar drscheme-frame-new ,button) - (printf "Missing ~a button" ,s)))) - -(let* ([drscheme-frame (wait-for-drscheme-frame)] - [drscheme-frame-new 'dummy] - [menubar (send drscheme-frame get-menu-bar)] - [menubar-new 'dummy] - [menus-expected - (if (eq? wx:platform 'windows) - '("&File" "&Edit" "&Windows" "&View" "S&cheme" "&Language" "&Help") - '("File" "Edit" "Windows" "View" "Scheme" "Language" "Help"))] - [buttons-expected '(check-syntax analyze execute break)] - [check-menus - (lambda () - (letrec ([loop - (lambda (lst n) - (if (null? lst) - #t - (let ([expected-item (car lst)] - [actual-item (send menubar-new get-label-top n)]) - (if (string=? expected-item actual-item) - (loop (cdr lst) (add1 n)) - (printf "Expected menu ~a but found ~a~n" - expected-item - actual-item)))))]) - (loop menus-expected 0)))] - [button-error - (lambda (s) - (printf "Can't find ~a button~n" s))]) - - ; open new unit window - - (mred:test:menu-select "File" "New") - - ; get data structures for new window - - (set! drscheme-frame-new (wait-for-new-drscheme-frame drscheme-frame)) - (set! menubar-new (send drscheme-frame-new get-menu-bar)) - - ; compare old and new - - (printf "Checking menus ... ") - - (check-menus) - - (printf "checking buttons ... ") - - (check-for-button check-syntax-button "check syntax") - (check-for-button analyze-button "analyze") - (check-for-button execute-button "execute") - (check-for-button stop-execute-button "break") - - (printf "done~n") - - (mred:test:menu-select "File" "Close")) - - - - diff --git a/collects/tests/drscheme/pr-246.ss b/collects/tests/drscheme/pr-246.ss deleted file mode 100644 index e1b6f17f..00000000 --- a/collects/tests/drscheme/pr-246.ss +++ /dev/null @@ -1,47 +0,0 @@ -;;; pr-246.ss - -;;; make sure (cons 1 2) is an error in beginner-level Scheme - -;;; pr-58.ss - -;;; tests check-syntax when given bogus improper list -;;; tested at each language level - -;;; Author: Paul Steckler - -(load-relative "drscheme-test-util.ss") - -(let* ([drs-frame (wait-for-drscheme-frame)] - [interactions-edit (ivar drs-frame interactions-edit)] - [execute-button (ivar drs-frame execute-button)] - [get-int-pos (lambda () (get-text-pos interactions-edit))] - [check-execute ; type in term, call execute - (lambda (str expected) - (clear-definitions drs-frame) - (push-button-and-wait execute-button) ; clears out any text in interactions-edit - (type-in-definitions drs-frame str) - (let ([answer-begin (get-int-pos)]) - (push-button-and-wait execute-button) - (let* ([answer-end (- (get-int-pos) 1)] - [actual (send interactions-edit get-text - answer-begin answer-end)]) - (unless (string=? actual expected) - (printf "Expected: ~a~n Actual: ~a~n~n" - expected actual)) - (let ([frame (mred:test:get-active-frame)]) - (unless (eq? frame drs-frame) - (error 'check-syntax "Unexpected window ~a" frame))))))]) - - (printf "Starting test~n") - - (set-language-level! "Beginner" drs-frame) - - (check-execute "(cons 1 2)" - "cons: second argument must be of type , given 1 and 2") - - ; end pr-246 - - (printf "Finished test~n")) - - - diff --git a/collects/tests/drscheme/pr-39.ss b/collects/tests/drscheme/pr-39.ss deleted file mode 100644 index a4bcb22e..00000000 --- a/collects/tests/drscheme/pr-39.ss +++ /dev/null @@ -1,8 +0,0 @@ -;;; pr-39.ss - -;;; this generated error before - -(require-library "referf.ss") - - - \ No newline at end of file diff --git a/collects/tests/drscheme/pr-46.ss b/collects/tests/drscheme/pr-46.ss deleted file mode 100644 index a9c12924..00000000 --- a/collects/tests/drscheme/pr-46.ss +++ /dev/null @@ -1,35 +0,0 @@ -;;; pr-46.ss - -;;; tests register-will in the interactions window - -(load-relative "drscheme-test-util.ss") - -(let* ([drs-frame (wait-for-drscheme-frame)] - [interactions-edit (ivar drs-frame interactions-edit)] - [execute-button (ivar drs-frame execute-button)] - [get-int-pos (lambda () (get-text-pos interactions-edit))] - [check-execute ; type in term, hit execute - (lambda (str expected) - (clear-definitions drs-frame) - (type-in-definitions drs-frame str) - (let ([answer-begin (+ (get-int-pos) 3)]) - (push-button-and-wait execute-button) - (let ([answer-end (- (get-int-pos) 1)]) - (let ([actual (send interactions-edit get-text - answer-begin answer-end)]) - (unless (string=? actual expected) - (printf "Expected: ~a~n Actual: ~a~n~n" - expected actual))) - (let ([frame (mred:test:get-active-frame)]) - (unless (eq? frame drs-frame) - (error 'check-syntax "Unexpected window ~a" frame))))))] - [terms-and-msgs - '(("(register-will (list 1 2 3) display)" "") - ("(collect-garbage)" ""))]) - - (for-each - (lambda (p) (check-execute (car p) (cadr p))) - terms-and-msgs)) - - - \ No newline at end of file diff --git a/collects/tests/drscheme/pr-48.ss b/collects/tests/drscheme/pr-48.ss deleted file mode 100644 index 32a30a34..00000000 --- a/collects/tests/drscheme/pr-48.ss +++ /dev/null @@ -1,383 +0,0 @@ -;;; pr-48.ss - -;;; tests font style changes to text after syntax check - -;;; Author: Paul Steckler - -(require-library "function.ss") - -(load-relative "drscheme-test-util.ss") - -; a font description is a list - -(define make-font-desc - (lambda (slant weight uline) - (list slant weight uline))) - -(define slant car) -(define weight cadr) -(define uline caddr) - -; the descriptions for the 5 different syntax items should be -; distinct from one another - -(define normal-font-desc - (make-font-desc wx:const-normal wx:const-normal #f)) - -(define syn-font-desc - (make-font-desc wx:const-normal wx:const-bold #t)) - -(define prim-font-desc - (make-font-desc wx:const-slant wx:const-normal #f)) - -(define const-font-desc - (make-font-desc wx:const-normal wx:const-bold #f)) - -(define bound-var-font-desc - (make-font-desc wx:const-slant wx:const-bold #t)) - -(define free-var-font-desc - (make-font-desc wx:const-normal wx:const-normal #t)) - -; a problem is a syntax string and a list of font descriptions -; for each character in the string - -(define problem - (lambda (str descs) - (list str descs))) - -(let* ([drs-frame (wait-for-drscheme-frame)] - [definitions-edit (ivar drs-frame definitions-edit)] - [get-font-cbs - (lambda (lst) - (let ([get-cb-with-label - (lambda (label) - (car (memf (lambda (elt) - (and (is-a? elt mred:check-box%) - (string=? (send elt get-label) label))) - lst)))]) - (map get-cb-with-label '("Slant" "Bold" "Underline"))))] - [set-check-boxes! - (lambda (cbs desc) - (mred:test:set-check-box! (slant cbs) - (if (eq? (slant desc) wx:const-normal) - #f - #t)) - (mred:test:set-check-box! (weight cbs) - (if (eq? (weight desc) wx:const-normal) - #f - #t)) - (mred:test:set-check-box! (uline cbs) (uline desc)))] - [set-syn-check-preferences! - (lambda () - (mred:test:menu-select "Edit" "Preferences...") - (let* ([frame - (letrec ([loop - (lambda () - (let ([active (mred:test:get-active-frame)]) - (if (or (eq? active #f) - (eq? active drs-frame)) - (begin - (sleep 1/2) - (loop)) - active)))]) - (loop))] - [panel (send frame get-top-panel)] - [children (ivar panel children)] - [choice-box (car children)] - [choice-box-event - (let ([event-obj - (make-object wx:command-event% - wx:const-event-type-choice-command)]) - (send event-obj set-event-object choice-box) - event-obj)]) - (send choice-box-event set-command-int - (send choice-box find-string "Check Syntax")) - (send choice-box command choice-box-event) - - (let* ([upper-panel (cadr children)] - [check-syntax-panel (send upper-panel active-child)] - [check-box-panels (ivar check-syntax-panel children)] - - [syntax-panel (car check-box-panels)] - [syntax-check-boxes (get-font-cbs (ivar syntax-panel children))] - - [primitive-panel (cadr check-box-panels)] - [primitive-check-boxes (get-font-cbs (ivar primitive-panel children))] - - [constant-panel (caddr check-box-panels)] - [constant-check-boxes (get-font-cbs (ivar constant-panel children))] - - [bound-var-panel (cadddr check-box-panels)] - [bound-var-check-boxes (get-font-cbs (ivar bound-var-panel children))] - - [free-var-panel (car (cddddr check-box-panels))] - [free-var-check-boxes (get-font-cbs (ivar free-var-panel children))]) - - (for-each - - (lambda (p) - (set-check-boxes! (car p) (cadr p))) - - (list - (list syntax-check-boxes syn-font-desc) - (list primitive-check-boxes prim-font-desc) - (list constant-check-boxes const-font-desc) - (list bound-var-check-boxes bound-var-font-desc) - (list free-var-check-boxes free-var-font-desc))) - - (mred:test:button-push "OK"))))] - [print-desc - (lambda (d) - (let ([slant - (let ([slant-res (slant d)]) - (cond - [(eq? slant-res wx:const-normal) - 'normal-slant] - [(eq? slant-res wx:const-slant) - 'slant] - [(eq? slant-res wx:const-italic) - 'italic] - [else - 'unknown]))] - [weight - (let ([weight-res (weight d)]) - (cond - [(eq? weight-res wx:const-normal) - 'normal-weight] - [(eq? weight-res wx:const-light) - 'light] - [(eq? weight-res wx:const-bold) - 'bold] - [else - 'unknown]))] - [uline (case (uline d) - [(#t) 'underline] - [(#f) 'no-underline] - [else (number->string (uline d))])]) - (printf "~a/~a/~a~n" slant weight uline)))] - [check-check-syntax-fonts - (lambda (problem) - (letrec* - ([str (car problem)] - [font-descs (cadr problem)] - [loop - (lambda (n descs) - (if (null? descs) - '() - (let* ([the-snip (send definitions-edit - find-snip n wx:const-snip-after)] - [the-style (send the-snip get-style)] - [the-font (send the-style get-font)] - [exp-desc (car descs)] - [actual-desc - (list (send the-font get-style) - (send the-font get-weight) - (send the-font get-underlined))]) - (if (equal? exp-desc actual-desc) - (loop (add1 n) (cdr descs)) - (begin - (printf "*** Failed on input ~a ***~n" str) - (printf "At position ~a:~nExpected style: " n) - (print-desc exp-desc) - (printf "Actual style: ") - (print-desc actual-desc))))))]) - (clear-definitions drs-frame) - (type-in-definitions drs-frame str) - (mred:test:button-push (ivar drs-frame check-syntax-button)) - (loop 0 font-descs)))]) - - ; set syntax-check font preferences in dialog - - (set-syn-check-preferences!) - - ; now run problems - - (wait-for-drscheme-frame) - - ; a problem is a pair: - ; the first element is a piece of syntax to check - ; the second element is a list of font descriptions, - ; one for each character in the syntax - - (for-each check-check-syntax-fonts - - (list - - (problem - - "(or 1 2 3)" - - (list - normal-font-desc ; ( - syn-font-desc ; o - syn-font-desc ; r - normal-font-desc ; _ - const-font-desc ; 1 - normal-font-desc ; _ - const-font-desc ; 2 - normal-font-desc ; _ - const-font-desc ; 3 - normal-font-desc ; ) - )) - - (problem - - "(and 1 2 3)" - - (list - normal-font-desc ; ( - syn-font-desc ; a - syn-font-desc ; n - syn-font-desc ; d - normal-font-desc ; _ - const-font-desc ; 1 - normal-font-desc ; _ - const-font-desc ; 2 - normal-font-desc ; _ - const-font-desc ; 3 - normal-font-desc ; ) - )) - - (problem - - "'(a b c)" - - (list - const-font-desc ; ' - const-font-desc ; ( - const-font-desc ; a - const-font-desc ; _ - const-font-desc ; b - const-font-desc ; _ - const-font-desc ; c - const-font-desc ; ) - - )) - - (problem - - "(quote x)" - - (list - const-font-desc ; ( - const-font-desc ; q - const-font-desc ; u - const-font-desc ; o - const-font-desc ; t - const-font-desc ; e - const-font-desc ; _ - const-font-desc ; x - const-font-desc ; ) - )) - - (problem - - "(quasiquote x)" - - (list - const-font-desc ; ( - const-font-desc ; q - const-font-desc ; u - const-font-desc ; a - const-font-desc ; s - const-font-desc ; i - const-font-desc ; q - const-font-desc ; u - const-font-desc ; o - const-font-desc ; t - const-font-desc ; e - const-font-desc ; _ - const-font-desc ; x - const-font-desc ; ) - )) - - (problem - - "#&a" - - (list - - const-font-desc ; # - const-font-desc ; & - const-font-desc ; a - )) - - (problem - - "#&\"hi\"" - - (list - - const-font-desc ; # - const-font-desc ; & - const-font-desc ; " - const-font-desc ; h - const-font-desc ; i - const-font-desc ; " - )) - - (problem - - "#&2" - - (list - - const-font-desc ; # - const-font-desc ; & - const-font-desc ; 2 - )) - - (problem - - "(define x 3)" - - (list - - normal-font-desc ; ( - syn-font-desc ; d - syn-font-desc ; e - syn-font-desc ; f - syn-font-desc ; i - syn-font-desc ; n - syn-font-desc ; e - normal-font-desc ; _ - bound-var-font-desc ; x - normal-font-desc ; _ - const-font-desc ; 3 - normal-font-desc ; ) - )) - - (problem - - "(local ([define x 3]) x)" - - (list - - normal-font-desc ; ( - syn-font-desc ; l - syn-font-desc ; o - syn-font-desc ; c - syn-font-desc ; a - syn-font-desc ; l - normal-font-desc ; - normal-font-desc ; ( - normal-font-desc ; [ - syn-font-desc ; d - syn-font-desc ; e - syn-font-desc ; f - syn-font-desc ; i - syn-font-desc ; n - syn-font-desc ; e - normal-font-desc ; - bound-var-font-desc ; x - normal-font-desc ; - const-font-desc ; 3 - normal-font-desc ; ] - normal-font-desc ; ) - const-font-desc ; - bound-var-font-desc ; x - normal-font-desc ; ) - )) - - ))) diff --git a/collects/tests/drscheme/pr-51.dir/1.ss b/collects/tests/drscheme/pr-51.dir/1.ss deleted file mode 100644 index 466ca277..00000000 --- a/collects/tests/drscheme/pr-51.dir/1.ss +++ /dev/null @@ -1,3 +0,0 @@ -;;; 1.ss -- needed for pr-51.ss - -(load-relative "2.ss") diff --git a/collects/tests/drscheme/pr-51.dir/2.ss b/collects/tests/drscheme/pr-51.dir/2.ss deleted file mode 100644 index d573477e..00000000 --- a/collects/tests/drscheme/pr-51.dir/2.ss +++ /dev/null @@ -1,3 +0,0 @@ -;;; 2.ss -- needed for pr-51.ss - -(printf "This string should print!~n") diff --git a/collects/tests/drscheme/pr-51.ss b/collects/tests/drscheme/pr-51.ss deleted file mode 100644 index 87e159f8..00000000 --- a/collects/tests/drscheme/pr-51.ss +++ /dev/null @@ -1,5 +0,0 @@ -;;; pr-51.ss - -;;; tests printing while loading files in a subdirectory - -(require (build-path "pr-51.dir" "1.ss")) diff --git a/collects/tests/drscheme/pr-58.ss b/collects/tests/drscheme/pr-58.ss deleted file mode 100644 index f7a314c4..00000000 --- a/collects/tests/drscheme/pr-58.ss +++ /dev/null @@ -1,54 +0,0 @@ -;;; pr-58.ss - -;;; tests check-syntax when given bogus improper list -;;; tested at each language level - -;;; Author: Paul Steckler - -(load-relative "drscheme-test-util.ss") - -(let* ([drs-frame (wait-for-drscheme-frame)] - [interactions-edit (ivar drs-frame interactions-edit)] - [execute-button (ivar drs-frame execute-button)] - [get-int-pos (lambda () (get-text-pos interactions-edit))] - [check-check-syntax ; type in term, call check-syntax - (lambda (str expected) - (clear-definitions drs-frame) - (type-in-definitions drs-frame str) - (push-button-and-wait execute-button) - (let ([answer-begin (+ (get-int-pos) 3)]) - (mred:test:button-push (ivar drs-frame check-syntax-button)) - (let* ([answer-end (- (get-int-pos) 1)] - [actual (send interactions-edit get-text - answer-begin answer-end)]) - (unless (string=? actual expected) - (printf "Expected: ~a~n Actual: ~a~n~n" - expected actual)) - (let ([frame (mred:test:get-active-frame)]) - (unless (eq? frame drs-frame) - (error 'check-syntax "Unexpected window ~a" frame))))))]) - - (printf "Starting tests~n") - - (set-language-level! "Beginner" drs-frame) - - (check-check-syntax "'(a . b)" "improper lists are not allowed") - - ; from pr-246 - ; execute says "cons: second argument must be of type , given 1 and 2") - - (check-check-syntax "(cons 1 2)" "") - - ; end pr-246 - - (set-language-level! "Intermediate" drs-frame) - (check-check-syntax "'(a . b)" "improper lists are not allowed") - - (set-language-level! "Advanced" drs-frame) - (check-check-syntax "'(a . b)" "improper lists are not allowed") - - (set-language-level! "R4RS+" drs-frame) - (check-check-syntax "'(a . b)" "") - - (printf "Finished tests~n")) - diff --git a/collects/tests/drscheme/pr-80.ss b/collects/tests/drscheme/pr-80.ss deleted file mode 100644 index 444ee040..00000000 --- a/collects/tests/drscheme/pr-80.ss +++ /dev/null @@ -1,29 +0,0 @@ -;;; pr-80.ss - -;;; Create a frame with buggy callback in the definitions window. -;;; After invoking the callback, make sure the source text is properly highlighted. - -(load-relative "drscheme-test-util.ss") - -(letrec* ([_ (wait-for-drscheme-frame)] - [drscheme-frame (mred:test:get-active-frame)] - [eq-frame? (lambda () (eq? (mred:test:get-active-frame) drscheme-frame))] - [interactions-edit (ivar drscheme-frame interactions-edit)] - [interactions-canvas (ivar drscheme-frame interactions-canvas)] - [definitions-edit (ivar drscheme-frame definitions-edit)] - [definitions-canvas (ivar drscheme-frame definitions-canvas)] - [execute-button (ivar drscheme-frame execute-button)] - [code "(let* ([frame (make-object mred:frame% null \"MyFrame\" 100 100 200 300)] - [panel (make-object mred:vertical-panel% frame)] - [button (make-object mred:button% panel - (lambda (self event) - (send frame show #f) (car 4)) - \"Push me\")]) - (send frame show #t))"]) - - (type-in-definitions drscheme-frame code) - (push-button-and-wait execute-button) - - (printf "Code in callback should be highlighted~n")) - - diff --git a/collects/tests/drscheme/pr-99.ss b/collects/tests/drscheme/pr-99.ss deleted file mode 100644 index 8637193a..00000000 --- a/collects/tests/drscheme/pr-99.ss +++ /dev/null @@ -1,11 +0,0 @@ -;;; pr-99.ss - -(define x 5) - -(thread-wait (thread (lambda () (set! x (current-parameterization))))) - -(if (eq? x (current-parameterization)) - (printf "Test is *not* successful~n") - (printf "Test is successful~n")) - - \ No newline at end of file diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss deleted file mode 100644 index b03aa665..00000000 --- a/collects/tests/drscheme/repl-test.ss +++ /dev/null @@ -1,510 +0,0 @@ -(define-struct test (program - r4rs-load-answer prepend-filename? r4rs-execute-answer r4rs-execute-location - mred-execute-answer mred-load-answer mred-read-test? breaking-test?)) - -(define test-data - (list - - ;; basic tests - (make-test "(" - "1.1-1.2: syntax error: missing close paren" - #t - "syntax error: missing close paren" - (vector 0 1) - "read: expected a ')'; started at position 1 in " - "read: expected a ')'; started at position 1 in " - #t - #f) - (make-test "." - "1.1-1.2: syntax error: can't use `.' outside list" - #t - "syntax error: can't use `.' outside list" - (vector 0 1) - "read: illegal use of \".\" at position 1 in " - "read: illegal use of \".\" at position 1 in " - #t - #f) - (make-test "(lambda ())" - "1.1-1.12: lambda: malformed expression" - #t - "lambda: malformed expression" - (vector 0 11) - "lambda: bad syntax in: (lambda ())" - "lambda: bad syntax in: (lambda ())" - #f - #f) - (make-test "x" - "1.1-1.2: reference to undefined identifier: x" - #t - "reference to undefined identifier: x" - (vector 0 1) - "reference to undefined identifier: x" - "reference to undefined identifier: x" - #f - #f) - (make-test "(raise 1)" - "uncaught exception: 1" - #f - "uncaught exception: 1" - #f - "uncaught exception: 1" - "uncaught exception: 1" - #f - #f) - (make-test "(raise #f)" - "uncaught exception: #f" - #f - "uncaught exception: #f" - #f - "uncaught exception: #f" - "uncaught exception: #f" - #f - #f) - (make-test "(values 1 2)" - (format "1~n2") - #f - (format "1~n2") - #f - (format "1~n2") - (format "1~n2") - #f - #f) - (make-test "(list 1 2)" - "(1 2)" - #f - "(1 2)" - #f - "(1 2)" - "(1 2)" - #f - #f) - - ;; eval tests - (make-test " (eval '(values 1 2))" - (format "1~n2") - #f - (format "1~n2") - #f - (format "1~n2") - (format "1~n2") - #f - #f) - (make-test " (eval '(list 1 2))" - "(1 2)" - #f - "(1 2)" - #f - "(1 2)" - "(1 2)" - #f - #f) - (make-test " (eval '(lambda ()))" - "1.5-1.24: lambda: malformed expression" - #t - "lambda: malformed expression" - (vector 4 23) - "lambda: bad syntax in: (lambda ())" - "lambda: bad syntax in: (lambda ())" - #f - #f) - (make-test " (eval 'x)" - "1.5-1.14: reference to undefined identifier: x" - #t - "reference to undefined identifier: x" - (vector 4 13) - "reference to undefined identifier: x" - "reference to undefined identifier: x" - #f - #f) - - ;; printer setup test - (make-test "(car (void))" - "1.1-1.13: car: expects argument of type ; given #" - #t - "car: expects argument of type ; given #" - (vector 0 12) - "car: expects argument of type ; given #" - "car: expects argument of type ; given #" - #f - #f) - - - ;; error in the middle - (make-test "1 2 ( 3 4" - "1.5-1.6: syntax error: missing close paren" - #t - (format "1~n2~nsyntax error: missing close paren") - (vector 4 5) - (format "1~n2~nread: expected a ')'; started at position 5 in ") - (format "read: expected a ')'; started at position 5 in ") - #t - #f) - (make-test "1 2 . 3 4" - "1.5-1.6: syntax error: can't use `.' outside list" - #t - (format "1~n2~nsyntax error: can't use `.' outside list") - (vector 4 5) - (format "1~n2~nread: illegal use of \".\" at position 5 in ") - (format "read: illegal use of \".\" at position 5 in ") - #t - #f) - (make-test "1 2 x 3 4" - "1.5-1.6: reference to undefined identifier: x" - #t - (format "1~n2~nreference to undefined identifier: x") - (vector 4 5) - (format "1~n2~nreference to undefined identifier: x") - (format "reference to undefined identifier: x") - #f - #f) - (make-test "1 2 (raise 1) 3 4" - "uncaught exception: 1" - #f - (format "1~n2~nuncaught exception: 1") - 'unlocated-error - (format "1~n2~nuncaught exception: 1") - (format "uncaught exception: 1") - #f - #f) - (make-test "1 2 (raise #f) 3 4" - "uncaught exception: #f" - #f - (format "1~n2~nuncaught exception: #f") - 'unlocated-error - (format "1~n2~nuncaught exception: #f") - "uncaught exception: #f" - #f - #f) - - ;; new namespace test - (make-test (format "(current-namespace (make-namespace))~nif") - "compile: illegal use of a syntactic form name in: if" - #f - "compile: illegal use of a syntactic form name in: if" - 'unlocated-error - - "compile: illegal use of a syntactic form name in: if" - "compile: illegal use of a syntactic form name in: if" - #f - #f) - - ;; error escape handler test - (make-test (format "(let ([old (error-escape-handler)])~n(+ (let/ec k~n(dynamic-wind~n(lambda () (error-escape-handler (lambda () (k 5))))~n(lambda () (car))~n(lambda () (error-escape-handler old))))~n10))") - (format "5.12-5.17: car: expects 1 argument, given 0~n15") - #t - (format "car: expects 1 argument, given 0~n15") - 'definitions - - (format "car: expects 1 argument, given 0~n15") - (format "car: expects 1 argument, given 0~n15") - #f - #f) - - - ;; macro tests - (make-test "(define-macro m (lambda (x) (+ x 1))) (m 2)" - "3" - #f - "3" - #f - "3" - "3" - #f - #f) - (make-test "(define-macro m (lambda (x) `(+ ,x 1))) (m (+ 1 2))" - "4" - #f - "4" - #f - "4" - "4" - #f - #f) - (make-test "(define-macro m (car))" - "1.17-1.22: car: expects 1 argument, given 0" - #t - "car: expects 1 argument, given 0" - (vector 16 21) - "car: expects 1 argument, given 0" - "car: expects 1 argument, given 0" - #f - #f) - (make-test - (format "(define-macro m (lambda () (car)))~n(m)") - "1.28-1.33: car: expects 1 argument, given 0" - #t - "car: expects 1 argument, given 0" - (vector 27 32) - "car: expects 1 argument, given 0" - "car: expects 1 argument, given 0" - #f - #f) - (make-test - (format "(define-macro m (lambda (x) `(+ ,x 1)))~n(m #t)") - "2.1-2.7: +: expects type as 1st argument, given: #t; other arguments were: 1" - #t - "+: expects type as 1st argument, given: #t; other arguments were: 1" - (vector 40 46) - "+: expects type as 1st argument, given: #t; other arguments were: 1" - "+: expects type as 1st argument, given: #t; other arguments were: 1" - #f - #f) - (make-test - "(define-macro m 1)" - "1.1-1.19: define-macro: expander is not a procedure" - #t - "define-macro: expander is not a procedure" - (vector 0 18) - "define-macro: not a procedure" - "define-macro: not a procedure" - #f - #f) - (make-test - "(define-macro m (values (let ([x (lambda (x) x)]) x) (let ([y (lambda (x) x)]) y)))" - "context expected 1 value, received 2 values: # #" - #f - "context expected 1 value, received 2 values: # #" - #f - "context expected 1 value, received 2 values: # #" - "context expected 1 value, received 2 values: # #" - #f - #f) - - (make-test - (format "(define-macro m (lambda (x) (values x x)))~n(m 1)") - "context expected 1 value, received 2 values: 1 1" - #f - "context expected 1 value, received 2 values: 1 1" - #f - "context expected 1 value, received 2 values: 1 1" - "context expected 1 value, received 2 values: 1 1" - #f - #f) - - (make-test - (format "(define s (make-semaphore 0))~n(queue-callback~n(lambda ()~n(dynamic-wind~nvoid~n(lambda () (car))~n(lambda () (semaphore-post s)))))~n(yield s)") - "6.12-6.17: car: expects 1 argument, given 0" - #t - "car: expects 1 argument, given 0" - (vector 99 104) - "car: expects 1 argument, given 0" - "car: expects 1 argument, given 0" - #f - #f) - - ;; breaking tests - (make-test "(semaphore-wait (make-semaphore 0))" - "1.1-1.36: user break" - #t - "user break" - (vector 0 35) - - "user break" - "user break" - #f - #t) - - (make-test "(let l()(l))" - "1.9-1.12: user break" - #t - "user break" - (vector 8 11) - - "user break" - "user break" - #f - #t) - - ;; continuation tests - (make-test (format "(define k (call/cc (lambda (x) x)))~n(k 17)~nk") - "17" #f "17" #f - "17" "17" #f #f) - (make-test (format "(define v (vector (call/cc (lambda (x) x))))~n((vector-ref v 0) 2)~nv") - "#1(2)" #f "#1(2)" #f - "#1(2)" "#1(2)" #f #f) - (make-test (format "(define v (vector (eval '(call/cc (lambda (x) x)))))~n((vector-ref v 0) 2)~nv") - "#1(2)" #f "#1(2)" #f - "#1(2)" "#1(2)" #f #f) - - )) - -(define drscheme-frame (wait-for-drscheme-frame)) - -(define interactions-text (ivar drscheme-frame interactions-text)) -(define interactions-canvas (ivar drscheme-frame interactions-canvas)) -(define definitions-text (ivar drscheme-frame definitions-text)) -(define definitions-canvas (ivar drscheme-frame definitions-canvas)) -(define execute-button (ivar drscheme-frame execute-button)) -(define insert-string - (lambda (string) - (let loop ([n 0]) - (unless (= n (string-length string)) - (let ([c (string-ref string n)]) - (if (char=? c #\newline) - (fw:test:keystroke #\return) - (fw:test:keystroke c))) - (loop (+ n 1)))))) - -(define wait-for-execute (lambda () (wait-for-button execute-button))) -(define get-int-pos (lambda () (get-text-pos interactions-text))) - - -(define tmp-load-filename - (normalize-path (build-path (current-load-relative-directory) "repl-test-tmp.ss"))) - -;; given a filename "foo", we perform two operations on the contents -;; of the file "foo.ss". First, we insert its contents into the REPL -;; directly, and second, we use the load command. We compare the -;; the results of these operations against expected results. - -(define run-test - (lambda (execute-text-start escape mred?) - (lambda (in-vector) - (let* ([program (test-program in-vector)] - [pre-answer-load (test-r4rs-load-answer in-vector)] - [prepend-filename? (test-prepend-filename? in-vector)] - [answer-load (if prepend-filename? - (string-append "." tmp-load-filename ": " pre-answer-load) - pre-answer-load)] - [answer-execute (test-r4rs-execute-answer in-vector)] - [execute-location (test-r4rs-execute-location in-vector)] - [mred-execute-answer (test-mred-execute-answer in-vector)] - [mred-load-answer (test-mred-load-answer in-vector)] - [mred-read-test? (test-mred-read-test? in-vector)] - [breaking-test? (test-breaking-test? in-vector)]) - - (clear-definitions drscheme-frame) - ; load contents of test-file into the REPL, recording - ; the start and end positions of the text - - (insert-string program) - (do-execute drscheme-frame (not breaking-test?)) - (when breaking-test? - (fw:test:button-push (ivar drscheme-frame stop-execute-button)) - (wait-for-execute)) - - (let* ([execute-text-end (- (get-int-pos) 1)] ;; subtract one to skip last newline - [received-execute - (send interactions-text get-text - execute-text-start execute-text-end)]) - - ; check focus and selection for execute test - (unless mred? - (cond - [(eq? execute-location 'definitions) - (unless (send definitions-canvas has-focus?) - (printf "FAILED execute test for ~s~n expected definitions to have the focus~n" - program))] - [(eq? execute-location 'unlocated-error) - (unless (send interactions-canvas has-focus?) - (printf "FAILED execute test for ~s~n expected interactions to have the focus~n" - program))] - [(and execute-location (send definitions-canvas has-focus?)) - (let ([error-range (send interactions-text get-error-range)]) - (unless (and error-range - (= (car error-range) (vector-ref execute-location 0)) - (= (cdr error-range) (vector-ref execute-location 1))) - (printf "FAILED execute test for ~s~n error-range is ~s~n expected ~a ~a~n" - program - error-range - (vector-ref execute-location 0) - (vector-ref execute-location 1))))] - [execute-location - (printf "FAILED execute test for ~s~n expected definitions canvas to have the focus~n" - program)] - [(not (send interactions-canvas has-focus?)) - (printf "FAILED execute test for ~s~n expected interactions to have the focus~n" - program)] - [else (void)])) - - ; check text for execute test - (let ([expected - (if mred? - (if mred-read-test? - (string-append mred-execute-answer "USERPORT") - mred-execute-answer) - answer-execute)]) - (unless (string=? received-execute expected) - (printf "FAILED execute test for ~s~n expected: ~s~n got: ~s~n" - program expected received-execute))) - - (fw:test:new-window interactions-canvas) - - ; construct the load file - - (call-with-output-file tmp-load-filename - (lambda (port) (display program port)) - 'truncate) - - ; stuff the load command into the REPL - - (for-each fw:test:keystroke - (string->list (format "(load ~s)" tmp-load-filename))) - - ; record current text position, then stuff a CR into the REPL - - (let ([load-text-start (+ 1 (send interactions-text last-position))]) - - (fw:test:keystroke #\return) - - (when breaking-test? - (fw:test:button-push (ivar drscheme-frame stop-execute-button))) - (wait-for-execute) - - (let* ([load-text-end (- (get-int-pos) 1)] ;; subtract one to eliminate newline - [received-load - (send interactions-text get-text - load-text-start load-text-end)]) - - ; check load text - (let ([expected - (if mred? - (if mred-read-test? - (string-append mred-load-answer - tmp-load-filename) - mred-load-answer) - answer-load)]) - (unless (string=? received-load expected) - (printf "FAILED load test for ~s~n expected: ~s~n got: ~s~n" - program expected received-load))) - - ; check for edit-sequence - (when (repl-in-edit-sequence?) - (printf "FAILED: repl in edit-sequence") - (escape))))))))) - -(define (run-test-in-language-level raw?) - (let ([level (if raw? "Graphical without Debugging (MrEd)" "Graphical (MrEd)")] - [drs (wait-for-drscheme-frame)]) - (printf "running ~a tests~n" level) - (set-language-level! level) - (fw:test:new-window definitions-canvas) - (clear-definitions drscheme-frame) - (do-execute drscheme-frame) - (let/ec escape (for-each (run-test (get-int-pos) escape raw?) test-data)))) - -(define (kill-tests) - (let ([drs (wait-for-drscheme-frame)]) - (clear-definitions drs) - (do-execute drs) - - (fw:test:menu-select "Scheme" "Kill") - - (let ([win (wait-for-new-frame drs)]) - (fw:test:button-push "Ok") - (let ([drs2 (wait-for-new-frame win)]) - (unless (eq? drs2 drs) - (error 'kill-tests "expected original drscheme frame to come back to the front")))) - - (type-in-definitions drs "(kill-thread (current-thread))") - (do-execute drs #f) - - (let ([win (wait-for-new-frame drs)]) - (fw:test:button-push "Ok") - (let ([drs2 (wait-for-new-frame win)]) - (unless (eq? drs2 drs) - (error 'kill-tests "expected original drscheme frame to come back to the front")))))) - -(run-test-in-language-level #t) -(run-test-in-language-level #f) -(kill-tests) diff --git a/collects/tests/drscheme/sample-solutions.ss b/collects/tests/drscheme/sample-solutions.ss deleted file mode 100644 index 3cab6ac7..00000000 --- a/collects/tests/drscheme/sample-solutions.ss +++ /dev/null @@ -1,131 +0,0 @@ -;; memory debugging -(global-defined-value 'top-level-frames null) - -(define sample-solutions-dir - (build-path (collection-path "mzlib") - 'up - 'up - 'up - "robby" - "collects" - "solutions")) -(unless (directory-exists? sample-solutions-dir) - (error 'sample-solutions.ss "expected directory ~s to exist" sample-solutions-dir)) - -(set! sample-solutions-dir (normalize-path sample-solutions-dir)) - -;; add the full pathname to the toc entries. -(define toc - (map (lambda (x) (cons (build-path sample-solutions-dir (car x)) (cdr x))) - (call-with-input-file (build-path sample-solutions-dir "toc.ss") read))) - -;; close out the first frame to avoid complications -(let ([orig-drs (wait-for-drscheme-frame)]) - (fw:test:menu-select "File" "New") - (wait-for-new-frame orig-drs) - (send orig-drs close)) - -(define frame-to-close (wait-for-drscheme-frame)) - -(define (test-single-file toc-entry) - (let ([filename (car toc-entry)] - [language (cadr toc-entry)] - [errors-ok? (caddr toc-entry)] - [teachpacks (cadddr toc-entry)] - [old-pref (fw:preferences:get 'framework:file-dialogs)]) - (fw:preferences:set 'framework:file-dialogs 'common) - - - (let* ([drs-frame (wait-for-drscheme-frame)] - [wait-for-execute - (lambda () - (wait-for-button (ivar drs-frame execute-button)))]) - (fw:test:menu-select "File" "Open...") - (wait-for-new-frame drs-frame) - (let ([pathname (find-labelled-window "Full pathname")] - [dialog (get-top-level-focus-window)]) - (send pathname focus) - (fw:test:keystroke #\a (case (system-type) - [(windows) (list 'control)] - [(macos) (list 'meta)] - [(unix) (list 'meta)])) - (let loop ([i 0]) - (when (< i (string-length filename)) - (fw:test:keystroke (string-ref filename i)) - (loop (+ i 1)))) - (fw:test:keystroke #\return) - (wait-for-new-frame dialog)) - (wait-for-new-frame drs-frame)) - - (let* ([drs-frame (wait-for-drscheme-frame)] - [wait-for-execute - (lambda () - (wait-for-button (ivar drs-frame execute-button)))]) - - (when frame-to-close (send frame-to-close close)) - (set! frame-to-close drs-frame) - - ;; memory debugging - (global-defined-value 'top-level-frames - (cons - (make-weak-box drs-frame) - (global-defined-value 'top-level-frames))) - (collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage)(collect-garbage) - (send drs-frame update-memory-text) - ;(dump-memory-stats) - - (set-language-level! language) - (fw:test:menu-select "Language" "Clear All Teachpacks") - (for-each (lambda (teachpack) - (let ([filename (normalize-path (apply - build-path - (collection-path "mzlib") - 'up - 'up - "teachpack" - teachpack))]) - (fw:test:menu-select "Language" "Add Teachpack...") - (let ([dialog (wait-for-new-frame drs-frame)]) - (send (find-labelled-window "Full pathname") focus) - (fw:test:keystroke #\a (case (system-type) - [(windows) (list 'control)] - [(macos) (list 'meta)] - [(unix) (list 'meta)])) - (let loop ([i 0]) - (when (< i (string-length filename)) - (fw:test:keystroke (string-ref filename i)) - (loop (+ i 1)))) - (fw:test:keystroke #\return) - (wait-for-new-frame dialog)))) - teachpacks) - - (do-execute drs-frame) - (wait-for-execute) - - (when (and (not errors-ok?) - (has-error? drs-frame)) - (error 'sample-solutions.ss "should be no errors for ~s" filename)) - - - (let ([lines - (let ([port (open-input-string (fetch-output drs-frame))]) - (let loop () - (let ([line (read-line port)]) - (if (eof-object? line) - null - (cons line (loop))))))]) - (unless (< (length lines) 3) - (let loop ([before (car lines)] - [during (cadr lines)] - [after (caddr lines)] - [rest (cdddr lines)]) - (when (string=? during "=") - (unless (string=? before after) - (printf "FAILED ~s; expected ~s and ~s to be the same~n" - filename before after))) - (unless (null? rest) - (loop during after (car rest) (cdr rest)))))) - - (fw:preferences:set 'framework:file-dialogs old-pref)))) - -(for-each test-single-file toc) \ No newline at end of file diff --git a/collects/tests/drscheme/sig.ss b/collects/tests/drscheme/sig.ss deleted file mode 100644 index 0887ff22..00000000 --- a/collects/tests/drscheme/sig.ss +++ /dev/null @@ -1,26 +0,0 @@ -(require-library "function.ss") -(require-library "file.ss") -(require-library "guis.ss" "tests" "utils") - -(define-signature drscheme:test-util^ - (save-drscheme-window-as - use-get/put-dialog - do-execute - test-util-error - poll-until - wait-for-computation - wait-for-drscheme-frame - wait-for-new-frame - clear-definitions - type-in-definitions - type-in-interactions - wait - wait-pending - get-sub-panel - get-text-pos - wait-for-button - push-button-and-wait - set-language-level! - repl-in-edit-sequence? - fetch-output - has-error?)) diff --git a/collects/tests/drscheme/sixlib.ss b/collects/tests/drscheme/sixlib.ss deleted file mode 100644 index c93554a7..00000000 --- a/collects/tests/drscheme/sixlib.ss +++ /dev/null @@ -1,250 +0,0 @@ -;; make sure these load -(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "graphicss.ss" "graphics") - (require-library "graphicr.ss" "graphics") - (require-library "graphicspr.ss" "graphics")) - -;; load the graphics -(require-library "graphics.ss" "graphics") -(require-library "macro.ss") -(open-graphics) - -(define (struct-test) - ;; test rgb selectors - (let* ([fraction 1/5] - [test - (list - (rgb-red (make-rgb fraction 0 0)) - (rgb-green (make-rgb 0 fraction 0)) - (rgb-blue (make-rgb 0 0 fraction)))]) - (unless (equal? (list fraction fraction fraction) test) - (error 'rgb "wrong: ~s" test))) - - ;; test posn selectors - (let* ([test - (list - (posn-x (make-posn 1 0)) - (posn-y (make-posn 0 1)))]) - (unless (equal? (list 1 1) test) - (error 'posn "wrong: ~s" test)))) - -;; test basic operations -(define (basic-test) - (let ([v (open-viewport "Tester" 200 200)]) - ((draw-string v) (make-posn 0 20) "Reversed X; click to continue") - ((draw-string v) (make-posn 0 40) "(busy-waiting right now!)") - ((draw-line v) (make-posn 0 0) (make-posn 100 100)) - ((draw-line v) (make-posn 100 0) (make-posn 0 100)) - ((flip-viewport v)) - (let loop () - (unless (ready-mouse-click v) - (loop))) - - ((clear-viewport v)) - ((draw-string v) (make-posn 0 20) "Cleared; click") - (get-mouse-click v) - - (let ([rect-draw - (lambda (f) - (f (make-posn 20 20) 60 60))] - [poly-draw - (lambda (f) - (f (list (make-posn 0 0) (make-posn 40 0) (make-posn 20 40)) (make-posn 20 20)))] - [string-draw - (lambda (f) - (f (make-posn 10 20) "XXXXX"))] - [shape - (lambda (do-draw draw clear flip name) - ((clear-viewport v)) - ((draw-string v) (make-posn 0 20) (format "Centered ~s" name)) - (do-draw (draw v)) - (get-mouse-click v) - - ((draw-string v) (make-posn 0 40) (format "Erased ~s" name)) - (do-draw (clear v)) - (get-mouse-click v) - - ((clear-viewport v)) - ((draw-string v) (make-posn 0 20) (format "Centered ~s" name)) - (do-draw (draw v)) - (get-mouse-click v) - - ((draw-string v) (make-posn 0 40) (format "Flipped ~s" name)) - (do-draw (flip v)) - (get-mouse-click v) - - ((draw-string v) (make-posn 0 40) (format "Flipped ~s back" name)) - (do-draw (flip v)) - (get-mouse-click v))]) - (shape rect-draw draw-rectangle clear-rectangle flip-rectangle "box") - (shape rect-draw draw-solid-rectangle clear-solid-rectangle flip-solid-rectangle "solid box") - (shape rect-draw draw-ellipse clear-ellipse flip-ellipse "circle") - (shape rect-draw draw-solid-ellipse clear-solid-ellipse flip-solid-ellipse "solid circle") - (shape poly-draw draw-polygon clear-polygon flip-polygon "polygon") - (shape poly-draw draw-solid-polygon clear-solid-polygon flip-solid-polygon "solid polygon") - (shape string-draw - draw-string - clear-string - flip-string - "string")) - - ((clear-viewport v)) - ((draw-string v) (make-posn 0 20) "Done; click") - (get-mouse-click v) - - (close-viewport v))) - -;; test get-pixel -(define (pixel-test) - (let ([v (open-viewport "test get-pixel" 8 8)] - [f (lambda (x y) - (if (= (modulo (+ x y) 2) 0) - (make-rgb 1 1 1) - (make-rgb (/ (modulo (+ x y) 3) 2) - (/ (modulo (+ x y 1) 3) 2) - (/ (modulo (+ x y 2) 3) 2))))] - - [unmarshall-color - (lambda (c) - (if (is-a? c color%) - (list (send c red) - (send c green) - (send c blue)) - c))] - - [for-each-point - (lambda (f) - (let loop ([i 8]) - (unless (= i 0) - (let loop ([j 8]) - (unless (= j 0) - (f (- i 1) (- j 1)) - (loop (- j 1)))) - (loop (- i 1)))))]) - (for-each-point - (lambda (i j) - ;(printf "(~a, ~a) -> ~a~n" i j (unmarshall-color (f i j))) - ((draw-pixel v) (make-posn i j) (f i j)))) - ;(get-mouse-click v) - (for-each-point - (lambda (i j) - (let* ([cmp - (lambda (rgb1 rgb2) - (and (= (rgb-red rgb1) (rgb-red rgb2)) - (= (rgb-blue rgb1) (rgb-blue rgb2)) - (= (rgb-green rgb1) (rgb-green rgb2))))] - [color-expected ((test-pixel v) (f i j))] - [bw-expected (if (cmp (make-rgb 1 1 1) color-expected) 0 1)] - [color-got ((get-color-pixel v) (make-posn i j))] - [bw-got ((get-pixel v) (make-posn i j))]) - (unless (= bw-got bw-expected) - (error 'test-get-pixel "wrong answer for (~a,~a); got ~a expectd ~a" - i j bw-got bw-expected)) - (unless (cmp color-expected color-got) - (error 'test-get-color-pixel "wrong answer for (~a,~a); got ~a expected ~a" - i j - (unmarshall-color color-got) - (unmarshall-color color-expected)))))) - (close-viewport v))) - -(define (snip-test) - ;; test snips - (let ([vp (open-pixmap "snip test" 100 100)]) - ((draw-string vp) (make-posn 20 30) "flipped rect") - ((flip-solid-rectangle vp) (make-posn 10 10) 80 80) - (display (viewport->snip vp)))) - -(define (color-test) - (let ([v (open-viewport "Color Tester" 100 200)]) - ((draw-solid-rectangle v) (make-posn 10 10) 80 80 (make-rgb 1 0 0)) - ((draw-solid-ellipse v) (make-posn 10 10) 80 80 (make-rgb 0 1 0)) - ((draw-line v) (make-posn 10 10) (make-posn 90 90) (make-rgb 0 0 1)) - ((draw-string v) (make-posn 10 100) "red rectangle") - ((draw-string v) (make-posn 10 120) "green ellipse") - ((draw-string v) (make-posn 10 140) "blue line") - (get-mouse-click v) - - ((draw-viewport v) (make-rgb 1 0 0)) - ((draw-string v) (make-posn 10 100) "solid red") - (get-mouse-click v) - - ((draw-viewport v)) - ((clear-string v) (make-posn 10 100) "solid black") - (get-mouse-click v) - - (close-viewport v))) - -(define (pixmap-test) - (local [(define width 500) - (define height 500) - (define pixmap-filename (build-path (collection-path "icons") "plt.gif")) - (define view-port (open-viewport "pixmap tests" width height)) - (define (line) - ((draw-line view-port) (make-posn 50 50) (make-posn 450 450))) - (define (next desc) - ((draw-string view-port) (make-posn 0 (- height 50)) desc) - ((draw-string view-port) (make-posn 0 (- height 30)) "click to continue") - (get-mouse-click view-port) - ((clear-viewport view-port)))] - - (line) - (((draw-pixmap-posn pixmap-filename) view-port) (make-posn 0 0)) - (next "draw line then draw-pixmap-posn") - - (line) - ((draw-pixmap view-port) pixmap-filename (make-posn 0 0)) - (next "pixmap-functions: draw line then draw-pixmap") - - (close-viewport view-port))) - -(define (copy-viewport-test) - (let* ([width 100] - [height 100] - [vs (open-viewport "viewport source" width height)] - [vd (open-viewport "viewport dest" width height)]) - - ((draw-ellipse vs) (make-posn 10 10) 80 80) - ((draw-string vs) (make-posn 10 30) "Click") - (get-mouse-click vs) - (copy-viewport vs vd) - ((clear-viewport vs)) - ((draw-string vs) (make-posn 10 30) "Cleared") - (get-mouse-click vd) - (void))) - -(define (keyboard-test) - (let ([v (open-viewport "keyboard" 300 200)] - [RED (make-rgb 1 0 0)] - [BLACK (make-rgb 0 0 0)]) - ((draw-string v) (make-posn 5 15) "Type, end with return (red is from key-ready):") - (let loop ([x 5]) - (let* ([kv (or (begin - ((draw-rectangle v) (make-posn 290 0) 10 10 RED) - (ready-key-press v)) - (begin - ((draw-rectangle v) (make-posn 290 0) 10 10 BLACK) - (cons 'slow (get-key-press v))))] - [k (key-value (if (pair? kv) (cdr kv) kv))]) - ((clear-rectangle v) (make-posn 0 290) 10 10) - (cond - [(eq? k #\return) 'done] - [(char? k) (let ([s (string k)]) - ((draw-string v) (make-posn x 50) s - (if (pair? kv) - BLACK - RED)) - (sleep 0.05) ; slow down so key-ready takes effect - (loop (+ x (car ((get-string-size v) s)))))] - [else (loop x)]))) - (close-viewport v))) - -(struct-test) -(basic-test) -(pixel-test) -(color-test) -(snip-test) -(pixmap-test) -(copy-viewport-test) -(keyboard-test) - -(close-graphics) diff --git a/collects/tests/drscheme/syncheck/basic.ss b/collects/tests/drscheme/syncheck/basic.ss deleted file mode 100644 index 5f49a206..00000000 --- a/collects/tests/drscheme/syncheck/basic.ss +++ /dev/null @@ -1,25 +0,0 @@ - -(define-struct x (a b c)) - -make-x -x? -x-b -set-x-c! - -rumplestilskin - -(1 2) -(letrec () 'constant) -(letrec-values ([(x y) 'constant]) 'constant) -(let () 'constant) -(let-values ([(x y) 'constant]) 'constant) -(let ([x 1]) x) -(lambda (x) 'constant) -(case-lambda [(x . y) x] [(x) x] [y x]) -`(,x) ;; this one won't show the unbound x :( -(if 1 2 3) -(set! y 1) -(define x 2) -(set! x 1) -(begin 123 x y) -(begin0 123 x y) diff --git a/collects/tests/drscheme/syncheck/circle.ss b/collects/tests/drscheme/syncheck/circle.ss deleted file mode 100644 index 74ac0aa5..00000000 --- a/collects/tests/drscheme/syncheck/circle.ss +++ /dev/null @@ -1,14 +0,0 @@ -(lambda (f) - - f f) - -(define g 1) - - g g g - -(define g 1) -g g - - - -g g g \ No newline at end of file diff --git a/collects/tests/drscheme/syncheck/generate.ss b/collects/tests/drscheme/syncheck/generate.ss deleted file mode 100644 index 5c287e06..00000000 --- a/collects/tests/drscheme/syncheck/generate.ss +++ /dev/null @@ -1,34 +0,0 @@ -#!/bin/sh - -string=? ; exec /home/mflatt/plt/bin/mzscheme -qr $0 - -;; run this to output lots of scheme code to stdout -;; that code should all pass thru the syntax checker - -(require-library "pretty.ss") - -(let ([orig-eval (current-eval)] - [orig-output (current-output-port)] - [dir (current-directory)]) - (parameterize ([current-eval - (lambda (x) - (begin0 (orig-eval x) - (pretty-print x orig-output)))] - [current-output-port (make-output-port void void)] - [current-error-port (make-output-port void void)] - [error-display-handler void]) - (current-directory "/home/mflatt/proj/mred/mzscheme/tests") - (load "testing.ss") - - (load "basic.ss") - (load "read.ss") - (load "syntax.ss") - (load "file.ss") - (load "path.ss") - (load "number.ss") - (load "object.ss") - (load "struct.ss") - (load "unit.ss") - (load "thread.ss") - (load "param.ss") - (current-directory dir))) diff --git a/collects/tests/drscheme/syncheck/lots.ss b/collects/tests/drscheme/syncheck/lots.ss deleted file mode 100644 index 891c20fa..00000000 --- a/collects/tests/drscheme/syncheck/lots.ss +++ /dev/null @@ -1,14 +0,0 @@ -(define x 1) - -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x -x x x x x x x x x x x x x x x x x x x x diff --git a/collects/tests/drscheme/tool.ss b/collects/tests/drscheme/tool.ss deleted file mode 100644 index b338fc72..00000000 --- a/collects/tests/drscheme/tool.ss +++ /dev/null @@ -1,206 +0,0 @@ -;; load this file as a tool to run the test suites - -(unit/sig () - (import [mred : mred^] - [core : mzlib:core^] - [fw : framework^] - [pc : mzlib:print-convert^] - (drscheme : drscheme:export^) - [zodiac : zodiac:system^]) - - (define test-thread - (let ([kill-old void]) - (lambda (test thunk) - (kill-old) - (let ([thread-desc (thread - (lambda () - (printf "t>> ~a started~n" test) - (thunk) - (printf "t>> ~a finished~n" test)))]) - (set! kill-old - (lambda () - (when (thread-running? thread-desc) - (kill-thread thread-desc) - (printf "t>> killed ~a~n" test)))))))) - - (define all-tests (map symbol->string (require-library "README" "tests" "drscheme"))) - - (define (make-repl) - (test-thread - "REPL" - (lambda () - (let ([startup "~/.mzschemerc"]) - (when (file-exists? startup) - (load startup))) - (read-eval-print-loop)))) - - (define (run-test-suite filename) - (test-thread - filename - (lambda () - (invoke-unit/sig - (compound-unit/sig (import [fw : framework^] - [mred : mred^]) - (link - [utils : test-utils:gui^ ((require-library "guir.ss" "tests" "utils") mred)] - [drs-utils : drscheme:test-util^ ((require-library "drscheme-test-util.ss" "tests" "drscheme") mred fw utils)] - [main : () - ((unit/sig () - (import [drs-utils : drscheme:test-util^] - [utils : test-utils:gui^]) - - (invoke-unit/sig - (eval - `(unit/sig () - (import [fw : framework^] - mzlib:function^ - mzlib:file^ - drscheme:test-util^ - test-utils:gui^ - mred^ - [drscheme : drscheme:export^] - [zodiac : zodiac:system^]) - - (include ,(build-path (collection-path "tests" "drscheme") filename)))) - (fw : framework^) - (core:function : mzlib:function^) - (core:file : mzlib:file^) - (drs-utils : drscheme:test-util^) - (utils : test-utils:gui^) - (mred : mred^) - (drscheme : drscheme:export^) - (zodiac : zodiac:system^))) - - drs-utils utils)]) - (export)) - (fw : framework^) - (mred : mred^))))) - - (fw:preferences:set-default 'drscheme:test-suite:file-name "repl-tests.ss" string?) - (fw:preferences:set-default 'drscheme:test-suite:run-interval 10 number?) - - (fw:preferences:set-default 'drscheme:test-suite:frame-width #f (lambda (x) (or (not x) (number? x)))) - (fw:preferences:set-default 'drscheme:test-suite:frame-height 300 (lambda (x) (or (not x) (number? x)))) - - (define current-test-suite-frame #f) - - (define (ask-test-suite) - (if current-test-suite-frame - (send current-test-suite-frame show #t) - (let* ([frame% (class mred:frame% () - (override - [on-size - (lambda (w h) - (fw:preferences:set 'drscheme:test-suite:frame-width w) - (fw:preferences:set 'drscheme:test-suite:frame-height h))] - [on-close - (lambda () - (set! current-test-suite-frame #f))]) - (sequence - (super-init "Test Suites" - #f - (fw:preferences:get 'drscheme:test-suite:frame-width) - (fw:preferences:get 'drscheme:test-suite:frame-height))))] - [drscheme-test-dir (collection-path "tests" "drscheme")] - [frame (make-object frame%)] - [panel (make-object mred:vertical-panel% frame)] - [top-panel (make-object mred:vertical-panel% panel)] - [bottom-panel (make-object mred:horizontal-panel% panel)]) - (send top-panel stretchable-height #f) - (send (make-object mred:button% - "REPL" - bottom-panel - (lambda (_1 _2) - (send frame show #f) - (make-repl))) - focus) - - (when drscheme-test-dir - (send top-panel stretchable-height #t) - (send bottom-panel stretchable-height #f) - (letrec ([lb (make-object mred:list-box% - #f - all-tests - top-panel - (lambda (b e) - (when (eq? (send e get-event-type) 'list-box-dclick) - (run-test-suite-callback))))] - [run-test-suite-callback - (lambda () - (let ([selection (send lb get-selection)]) - (when selection - (send frame show #f) - (let ([test (list-ref all-tests selection)]) - (fw:preferences:set - 'drscheme:test-suite:file-name - test) - (run-test-suite - test)))))]) - - ;; set values from preferences - (let* ([test-suite (fw:preferences:get 'drscheme:test-suite:file-name)] - [num (send lb find-string test-suite)]) - (when num - (send lb set-string-selection test-suite) - (send lb set-first-visible-item num) - (fw:test:run-interval (fw:preferences:get 'drscheme:test-suite:run-interval)))) - - (send - (make-object mred:button% - "Run Test Suite" - bottom-panel - (lambda (_1 _2) - (run-test-suite-callback))) - focus)) - - (let* ([pre-times (list 0 10 50 100 500)] - [times (if (member (fw:test:run-interval) pre-times) - pre-times - (append pre-times (list (fw:test:run-interval))))] - [choice - (make-object mred:choice% - "Run Interval" - (map number->string times) - top-panel - (lambda (choice event) - (let ([time (list-ref times (send choice get-selection))]) - (fw:preferences:set 'drscheme:test-suite:run-interval time) - (fw:test:run-interval time))))]) - (send choice set-selection - (let loop ([l times] - [n 0]) - (if (= (car l) (fw:test:run-interval)) - n - (loop (cdr l) - (+ n 1))))))) - (make-object mred:button% - "Cancel" - bottom-panel - (lambda (_1 _2) - (send frame show #f))) - (send frame show #t) - (set! current-test-suite-frame frame)))) - - (drscheme:get/extend:extend-unit-frame - (lambda (super%) - (class super% args - (inherit button-panel) - (sequence (apply super-init args)) - (private - [bitmap (make-object mred:bitmap% - (if (<= (mred:get-display-depth) 1) - (build-path (collection-path "icons") "bb-sm-bw.bmp") - (build-path (collection-path "icons") "bb-small.bmp")) - 'bmp)] - [button (make-object - mred:button% - (if (send bitmap ok?) - bitmap - "Console") - button-panel - (lambda (button evt) - (ask-test-suite)))]) - (sequence - (send button-panel change-children - (lambda (l) - (cons button (core:function:remq button l))))))))) diff --git a/collects/tests/framework/README b/collects/tests/framework/README deleted file mode 100644 index 076179fa..00000000 --- a/collects/tests/framework/README +++ /dev/null @@ -1,116 +0,0 @@ -`(#| - Framework Test Suite Overview - -Each tests will rely on the sucessfully completion of all of the ones -before it. In addition, all test suites rely on the sucessful -completion of the engine test suites and the mzscheme test suites. - -All of these tests reside in PLTHOME/tests/framework/ - -There will be a main mzscheme process which will start up a new mred -as necessary for the test suites. Since some tests actually require -mred to exit in order to pass, this governor is required. - -To run a test use: - - framework-test ... - -where or is the name of one of the tests -below. Alternatively, pass no command-line arguments to run the same -test as last time, or `all' to run all of the tests. - -- load: |# load.ss #| - - | This tests that the advertised ways of loading the framework at - | it's components all work. - -- exit: |# exit.ss #| - - | This tests that exit:exit really exits and that the exit callbacks - | are actually run. - -- preferences: |# prefs.ss #| - - | This tests that preferences are saved and restored correctly, both - | immediately and across reboots of mred. - -- individual object tests: - - | These tests are simple object creation and basic operations. - | Each test assumes that the others pass; this may yield strange - | error messages when one fails. - - - frames: |# frame.ss #| - - canvases: |# canvas.ss #| - - texts: |# text.ss #| - - pasteboards: |# pasteboard.ss #| - -- basic connections between classes - - | These tests will create objects in various configurations and - | trigger situations to test their functionality. - - - edits to canvases: |# edit-canvas.ss #| - - canvases to frames: |# canvas-frame.ss #| - - edits to frames: |# edit-frame.ss #| - - handler |# handler-test.ss #| - -- keybindings: |# keys.ss #| - - | This tests all of the misc (non-scheme) keybindings - -- searching: |# search.ss #| - - | This tests the seaching frame. - -- info: |# info-frame.ss #| - - | This tests the info frame. (ie that toolbar on the bottom of the - screen) - -- group tests: |# group-test.ss #| - - | make sure that mred:the-frame-group records frames correctly. - | fake user input expected. - -- parenthesis toolkit: |# paren-test.ss #| - - | Test to be sure that parenthesis matching engine works - | No fake user input expected. - -- scheme mode |# scheme.ss #| - - | Make sure that Scheme things work in scheme mode. - -- saving tests: - - | These tests will make sure that the usual checks against a user - | losing their work are in place. - - - autosaving: |# autosave.ss #| - - closing: |# close.ss #| - - quitting: |# quit.ss #| - -- docs: - - | these tests perform santiy checks to ensure that the docs are up to - | date with the code and the mred web browser isn't horribly broken - - - inheritance: inheritance.ss - - | make sure that the super-class relationships in the docs match - | the code. - -- interactive tests - - | these tests require intervention by people. Clicking and whatnot - - - panel:single |# panel.ss #| - - - garbage collection: |# mem.ss #| - - | These tests will create objects in various configurations and - | make sure that they are garbage collected - - -|#) \ No newline at end of file diff --git a/collects/tests/framework/canvas.ss b/collects/tests/framework/canvas.ss deleted file mode 100644 index ec167c95..00000000 --- a/collects/tests/framework/canvas.ss +++ /dev/null @@ -1,23 +0,0 @@ -(define (test-creation class name) - (test - name - (lambda (x) #t) - (lambda () - (send-sexp-to-mred - `(let* ([f (make-object frame:basic% "test canvas" #f 300 300)] - [c (make-object ,class (send f get-area-container))]) - (send c set-editor (make-object text:basic%)) - (send f show #t))) - (wait-for-frame "test canvas") - (send-sexp-to-mred - `(send (get-top-level-focus-window) show #f))))) - -(test-creation '(canvas:basic-mixin editor-canvas%) - 'canvas:basic-mixin-creation) -(test-creation 'canvas:basic% - 'canvas:basic%-creation) - -(test-creation '(canvas:wide-snip-mixin canvas:basic%) - 'canvas:wide-snip-mixin-creation) -(test-creation 'canvas:wide-snip% - 'canvas:wide-snip%-creation) diff --git a/collects/tests/framework/exit.ss b/collects/tests/framework/exit.ss deleted file mode 100644 index 870a5831..00000000 --- a/collects/tests/framework/exit.ss +++ /dev/null @@ -1,93 +0,0 @@ -(test 'exit/no-prompt - (lambda (x) - (and (eq? x 'passed) - (not (mred-running?)))) - (lambda () - (with-handlers ([eof-result? (lambda (x) 'passed)]) - (send-sexp-to-mred '(preferences:set 'framework:verify-exit #f)) - (send-sexp-to-mred '(begin (exit:exit) (sleep/yield 1))) - 'failed))) - -(test 'exit/prompt - (lambda (x) (and (eq? x 'passed) - (not (mred-running?)))) - (lambda () - (with-handlers ([eof-result? (lambda (x) 'passed)]) - (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t) - (test:run-one (lambda () (exit:exit))))) - (wait-for-frame "Warning") - (wait-for-new-frame '(test:button-push "Quit")) - 'failed))) - -(test 'exit/prompt/no-twice - (lambda (x) (and (eq? x 'passed) - (not (mred-running?)))) - (let ([exit/push-button - (lambda (button) - (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t) - (test:run-one (lambda () (exit:exit))))) - (wait-for-frame "Warning") - (wait-for-new-frame `(test:button-push ,button)))]) - (lambda () - (exit/push-button "Cancel") - (exit/push-button "Cancel") - (with-handlers ([eof-result? (lambda (x) 'passed)]) - (exit/push-button "Quit") - 'failed)))) - -(test 'exit/esc-cancel - (lambda (x) (and (eq? x 'passed) - (not (mred-running?)))) - (let ([exit/wait-for-warning - (lambda () - (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #t) - (test:run-one (lambda () (exit:exit))))) - (wait-for-frame "Warning"))]) - (lambda () - (exit/wait-for-warning) - (wait-for-new-frame `(test:close-top-level-window (get-top-level-focus-window))) - (exit/wait-for-warning) - (with-handlers ([eof-result? (lambda (x) 'passed)]) - (wait-for-new-frame '(test:button-push "Quit")) - 'failed)))) - -(define tmp-file (build-path (find-system-path 'temp-dir) "framework-exit-test-suite")) -;; need to test "on" callbacks -(test 'exit-callback-called - (lambda (x) - (begin0 (and (file-exists? tmp-file) (not (mred-running?))) - (when (file-exists? tmp-file) (delete-file tmp-file)))) - - (lambda () - (when (file-exists? tmp-file) (delete-file tmp-file)) - (with-handlers ([eof-result? (lambda (x) 'passed)]) - (send-sexp-to-mred - `(begin - (preferences:set 'framework:verify-exit #f) - (exit:insert-can?-callback (lambda () (call-with-output-file ,tmp-file void) #t)) - (begin (exit:exit) (sleep/yield 1))))))) - -(test 'exit-callback-removed - (lambda (x) (and (eq? x 'passed) (not (mred-running?)))) - (lambda () - (with-handlers ([eof-result? (lambda (x) 'passed)]) - (send-sexp-to-mred - `(begin - (preferences:set 'framework:verify-exit #f) - ((exit:insert-can?-callback (lambda () (error 'called-exit-callback)))) - (begin (exit:exit) (sleep/yield 1))))))) - -(test 'exit-callback-stops-exit - (lambda (x) (eq? x 'passed)) - (lambda () - (begin0 - (send-sexp-to-mred - `(begin - (preferences:set 'framework:verify-exit #f) - (let ([rm-callback (exit:insert-can?-callback (lambda () #f))]) - (exit:exit) - (rm-callback) - 'passed))) - (with-handlers ([eof-result? (lambda (x) 'passed)]) - (send-sexp-to-mred - `(exit:exit)))))) diff --git a/collects/tests/framework/frame.ss b/collects/tests/framework/frame.ss deleted file mode 100644 index cfb4de7f..00000000 --- a/collects/tests/framework/frame.ss +++ /dev/null @@ -1,137 +0,0 @@ -(define (test-creation name class-expression) - (test - name - (lambda (x) x) - (lambda () - (send-sexp-to-mred - `(begin (preferences:set 'framework:exit-when-no-frames #f) - (send (make-object ,class-expression "test") show #t))) - (wait-for-frame "test") - (queue-sexp-to-mred - '(send (get-top-level-focus-window) close)) - #t))) - -(test-creation - 'basic%-creation - 'frame:basic%) -(test-creation - 'basic-mixin-creation - '(frame:basic-mixin frame%)) - -(test-creation - 'info-mixin-creation - '(frame:info-mixin frame:basic%)) -(test-creation - 'info%-creation - 'frame:info%) - -(test-creation - 'text-info-mixin-creation - '(frame:text-info-mixin frame:info%)) -(test-creation - 'text-info%-creation - 'frame:text-info%) - -(test-creation - 'pasteboard-info-mixin-creation - '(frame:pasteboard-info-mixin frame:info%)) -(test-creation - 'pasteboard-info%-creation - 'frame:pasteboard-info%) - -(test-creation - 'standard-menus%-creation - 'frame:standard-menus%) -(test-creation - 'standard-menus-mixin - '(frame:standard-menus-mixin frame:basic%)) - -(test-creation - 'text%-creation - 'frame:text%) -(test-creation - 'text-mixin-creation - '(frame:text-mixin frame:editor%)) -(test-creation - 'text-mixin-creation - '(frame:text-mixin frame:editor%)) - -(test-creation - 'searchable%-creation - 'frame:searchable%) -(test-creation - 'searchable-mixin - '(frame:searchable-mixin frame:text%)) - -(test-creation - 'text-info-file%-creation - 'frame:text-info-file%) -(test-creation - 'text-info-file-mixin-creation - '(frame:file-mixin frame:text%)) - -(test-creation - 'pasteboard-mixin-creation - '(frame:pasteboard-mixin frame:editor%)) -(test-creation - 'pasteboard-mixin-creation - '(frame:pasteboard-mixin (frame:editor-mixin frame:standard-menus%))) -(test-creation - 'pasteboard%-creation - 'frame:pasteboard%) - -(test-creation - 'pasteboard-info-file-mixin-creation - '(frame:file-mixin frame:pasteboard%)) -(test-creation - 'pasteboard-info-file%-creation - 'frame:pasteboard-info-file%) - -(define (test-open name class-expression) - (let* ([test-file-contents "test"] - [tmp-file-name "framework-tmp"] - [tmp-file (build-path (collection-path "tests" "framework") - tmp-file-name)]) - (test - name - (lambda (x) - (delete-file tmp-file) - (equal? x test-file-contents)) - (lambda () - (send-sexp-to-mred - `(begin - (preferences:set 'framework:exit-when-no-frames #f) - (preferences:set 'framework:file-dialogs 'common) - (send (make-object ,class-expression "test open") show #t))) - (wait-for-frame "test open") - (send-sexp-to-mred - `(test:menu-select "File" "Open...")) - (wait-for-frame "Get file") - (call-with-output-file tmp-file - (lambda (port) - (display test-file-contents port)) - 'truncate) - (send-sexp-to-mred - `(begin (send (find-labelled-window "Full pathname") focus) - ,(case (system-type) - [(macos) `(test:keystroke #\a '(meta))] - [(unix) `(test:keystroke #\a '(meta))] - [(windows) `(test:keystroke #\a '(control))] - [else (error "unknown system type: ~a" (system-type))]) - (for-each test:keystroke - (string->list ,tmp-file)) - (test:keystroke #\return))) - (wait-for-frame tmp-file-name) - (begin0 - (send-sexp-to-mred - `(let* ([w (get-top-level-focus-window)] - [t (send (send w get-editor) get-text)]) - (test:close-top-level-window w) - t)) - (wait-for-frame "test open") - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close))))))) - -(test-open "frame:editor open" 'frame:text%) -(test-open "frame:searchable open" 'frame:searchable%) -(test-open "frame:text-info open" 'frame:text-info-file%) diff --git a/collects/tests/framework/framework-test-engine.ss b/collects/tests/framework/framework-test-engine.ss deleted file mode 100644 index 83fdd80f..00000000 --- a/collects/tests/framework/framework-test-engine.ss +++ /dev/null @@ -1,59 +0,0 @@ -(require-library "errortrace.ss" "errortrace") (error-print-width 80) (error-context-display-depth 3) - -(let* ([errs null] - [sema (make-semaphore 1)] - [protect - (lambda (f) - (semaphore-wait sema) - (begin0 (f) - (semaphore-post sema)))]) - (thread - (let* ([print-convert - (parameterize ([current-namespace (make-namespace)]) - (require-library "pconvert.ss") - (global-defined-value 'print-convert))] - [exception->string - (lambda (x) - (if (exn? x) - (if (defined? 'print-error-trace) - (let ([p (open-output-string)]) - (print-error-trace p x) - (string-append (exn-message x) (string #\newline) (get-output-string p))) - (exn-message x)) - (format "~s" x)))]) - (lambda () - (let*-values ([(in out) (tcp-connect "localhost" (load-relative "receive-sexps-port.ss"))] - [(continue) (make-semaphore 0)]) - (let loop () - (let ([sexp (read in)]) - (if (eof-object? sexp) - (begin - (close-input-port in) - (close-output-port out) - (exit)) - (begin - (write - (let ([these-errs (protect (lambda () (begin0 errs (set! errs null))))]) - (if (null? these-errs) - (with-handlers ([(lambda (x) #t) - (lambda (x) (list 'error (exception->string x)))]) - (list 'normal (print-convert (eval sexp)))) - (list 'error - (apply string-append - (map (lambda (x) (string-append (exception->string x) (string #\newline))) - these-errs))))) - out) - (loop))))))))) - - (let ([od (event-dispatch-handler)] - [port (current-output-port)]) - (event-dispatch-handler - (lambda (evt) - (parameterize ([current-exception-handler - (let ([oe (current-exception-handler)]) - (lambda (exn) - (protect - (lambda () - (set! errs (cons exn errs)))) - (oe exn)))]) - (od evt)))))) diff --git a/collects/tests/framework/group-test.ss b/collects/tests/framework/group-test.ss deleted file mode 100644 index 914f67a8..00000000 --- a/collects/tests/framework/group-test.ss +++ /dev/null @@ -1,142 +0,0 @@ -(test - 'exit-off - (lambda (x) (not (equal? x "test"))) - (lambda () - (send-sexp-to-mred - '(begin (send (make-object frame:basic% "test") show #t) - (preferences:set 'framework:verify-exit #f) - (preferences:set 'framework:exit-when-no-frames #f))) - (wait-for-frame "test") - (send-sexp-to-mred - `(begin (send (get-top-level-focus-window) close) - (let ([f (get-top-level-focus-window)]) - (if f - (send f get-label) - #f)))))) -(test - 'exit-on - (lambda (x) (not (equal? x "test"))) - (lambda () - (send-sexp-to-mred - '(begin (send (make-object frame:basic% "test") show #t) - (preferences:set 'framework:verify-exit #t) - (preferences:set 'framework:exit-when-no-frames #t))) - (wait-for-frame "test") - (send-sexp-to-mred - `(queue-callback (lambda () (send (get-top-level-focus-window) close)))) - (wait-for-frame "Warning") - (send-sexp-to-mred - `(test:button-push "Cancel")) - (wait-for-frame "test") - (queue-sexp-to-mred - `(begin (preferences:set 'framework:exit-when-no-frames #f) - (send (get-top-level-focus-window) close) - (let ([f (get-top-level-focus-window)]) - (if f - (send f get-label) - #f)))))) - -(test - 'one-frame-registered - (lambda (x) (equal? x (list "test"))) - (lambda () - (send-sexp-to-mred - `(send (make-object frame:basic% "test") show #t)) - (wait-for-frame "test") - (send-sexp-to-mred - `(begin0 - (map (lambda (x) (send x get-label)) (send (group:get-the-frame-group) get-frames)) - (send (get-top-level-focus-window) close))))) - -(test - 'two-frames-registered - (lambda (x) (equal? x (list "test2" "test1"))) - (lambda () - (send-sexp-to-mred - '(send (make-object frame:basic% "test1") show #t)) - (wait-for-frame "test1") - (send-sexp-to-mred - '(send (make-object frame:basic% "test2") show #t)) - (wait-for-frame "test2") - (send-sexp-to-mred - `(begin0 - (let ([frames (send (group:get-the-frame-group) get-frames)]) - (for-each (lambda (x) (send x close)) frames) - (map (lambda (x) (send x get-label)) frames)))))) - -(test - 'one-frame-unregistered - (lambda (x) (equal? x (list "test1"))) - (lambda () - (send-sexp-to-mred - '(send (make-object frame:basic% "test1") show #t)) - (wait-for-frame "test1") - (send-sexp-to-mred - '(send (make-object frame:basic% "test2") show #t)) - (wait-for-frame "test2") - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close)) - (send-sexp-to-mred - `(let ([frames (send (group:get-the-frame-group) get-frames)]) - (for-each (lambda (x) (send x close)) frames) - (map (lambda (x) (send x get-label)) frames))))) - -(test - 'windows-menu - (lambda (x) - (equal? x (list "test"))) - (lambda () - (send-sexp-to-mred - '(let ([frame (make-object frame:basic% "test")]) - (send frame show #t))) - (wait-for-frame "test") - (send-sexp-to-mred - '(begin0 - (map - (lambda (x) (send x get-label)) - (send (car (send (send (get-top-level-focus-window) get-menu-bar) get-items)) get-items)) - (send (get-top-level-focus-window) close))))) - -(test - 'windows-menu-sorted1 - (lambda (x) - (equal? x (list "aaa" "bbb"))) - (lambda () - (send-sexp-to-mred - '(let ([frame (make-object frame:basic% "aaa")]) - (send frame show #t))) - (wait-for-frame "aaa") - (send-sexp-to-mred - '(let ([frame (make-object frame:basic% "bbb")]) - (send frame show #t))) - (wait-for-frame "bbb") - (send-sexp-to-mred - `(let ([frames (send (group:get-the-frame-group) get-frames)]) - (begin0 - (map - (lambda (x) (send x get-label)) - (send (car (send (send (car frames) get-menu-bar) get-items)) get-items)) - (for-each (lambda (x) (send x close)) frames)))))) - -(test - 'windows-menu-sorted2 - (lambda (x) - (equal? x (list "aaa" "bbb"))) - (lambda () - (send-sexp-to-mred - '(let ([frame (make-object frame:basic% "bbb")]) - (send frame show #t))) - (wait-for-frame "bbb") - (send-sexp-to-mred - '(let ([frame (make-object frame:basic% "aaa")]) - (send frame show #t))) - (wait-for-frame "aaa") - (send-sexp-to-mred - `(let ([frames (send (group:get-the-frame-group) get-frames)]) - (begin0 - (map - (lambda (x) (send x get-label)) - (send (car (send (send (car frames) get-menu-bar) get-items)) get-items)) - (for-each (lambda (x) (send x close)) frames)))))) - - diff --git a/collects/tests/framework/handler-test.ss b/collects/tests/framework/handler-test.ss deleted file mode 100644 index f5b5b534..00000000 --- a/collects/tests/framework/handler-test.ss +++ /dev/null @@ -1,42 +0,0 @@ -(let* ([filename "framework-group-test.ss"] - [tmp-filename (build-path (find-system-path 'temp-dir) filename)]) - - (test - 'file-opened - (lambda (x) (equal? (list filename "MrEd REPL") x)) - (lambda () - (send-sexp-to-mred - `(begin (handler:edit-file ,tmp-filename) - (void))) - (wait-for-frame filename) - (send-sexp-to-mred - `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows)) - (send (car (get-top-level-windows)) close))))) - - (test - 'files-opened-twice - (lambda (x) (equal? (list filename "MrEd REPL") x)) - (lambda () - (send-sexp-to-mred - `(begin (handler:edit-file ,tmp-filename) - (void))) - (wait-for-frame filename) - (send-sexp-to-mred - `(begin (handler:edit-file ,tmp-filename) - (void))) - (wait-for-frame filename) - (send-sexp-to-mred - `(begin0 (map (lambda (x) (send x get-label)) (get-top-level-windows)) - (send (car (get-top-level-windows)) close))))) - - (test - 'file-opened-in-editor - (lambda (x) (equal? filename x)) - (lambda () - (send-sexp-to-mred - `(begin (handler:edit-file ,tmp-filename) - (void))) - (wait-for-frame filename) - (send-sexp-to-mred - `(let ([f (car (get-top-level-windows))]) - (send (send f get-editor) get-filename)))))) \ No newline at end of file diff --git a/collects/tests/framework/info.ss b/collects/tests/framework/info.ss deleted file mode 100644 index aa2a0f41..00000000 --- a/collects/tests/framework/info.ss +++ /dev/null @@ -1,14 +0,0 @@ -(lambda (request response) - (case request - [(name) "Framework"] - [(install-collection) - (lambda (_) - (require-library "launcher.ss" "launcher") - (make-mred-launcher - (list "-qe-" - "(require-library \"framework-test-engine.ss\" \"tests\" \"framework\")") - (mred-program-launcher-path "Framework Test Engine")) - (make-mzscheme-launcher - (list "-mqve-" "(require-library \"main.ss\" \"tests\" \"framework\")") - (mred-program-launcher-path - "Framework Test")))])) \ No newline at end of file diff --git a/collects/tests/framework/key-specs.ss b/collects/tests/framework/key-specs.ss deleted file mode 100644 index ab643fd5..00000000 --- a/collects/tests/framework/key-specs.ss +++ /dev/null @@ -1,29 +0,0 @@ -(define-struct key-spec (before after macos unix windows)) -(define-struct buff-spec (string start end)) - -(define global-specs - (list - (make-key-spec (make-buff-spec "abc" 1 1) - (make-buff-spec "abc" 2 2) - (list '(#\f control) '(right)) - (list '(#\f control) '(right)) - (list '(#\f control) '(right))))) - -(define scheme-specs - (list - (make-key-spec (make-buff-spec "(abc (def))" 4 4) - (make-buff-spec "(abc (def))" 10 10) - (list ;'(#\f alt control) - '(right alt)) - (list ;'(#\f alt control) - '(right alt)) - (list ;'(#\f alt control) - '(right alt))) - (make-key-spec (make-buff-spec "'(abc (def))" 1 1) - (make-buff-spec "'(abc (def))" 12 12) - (list ;'(#\f alt control) - '(right alt)) - (list ;'(#\f alt control) - '(right alt)) - (list ;'(#\f alt control) - '(right alt))))) diff --git a/collects/tests/framework/keys.ss b/collects/tests/framework/keys.ss deleted file mode 100644 index e207d7d0..00000000 --- a/collects/tests/framework/keys.ss +++ /dev/null @@ -1,123 +0,0 @@ -(test - 'keymap:aug-keymap%/get-table - (lambda (x) - (equal? '((c:k "abc")) x)) - (lambda () - (send-sexp-to-mred - '(let ([k (make-object keymap:aug-keymap%)]) - (send k add-function "abc" void) - (send k map-function "c:k" "abc") - (hash-table-map (send k get-map-function-table) list))))) - -(test - 'keymap:aug-keymap%/get-table/ht - (lambda (x) - (equal? x '((c:k "def")))) - (lambda () - (send-sexp-to-mred - '(let ([k (make-object keymap:aug-keymap%)] - [ht (make-hash-table)]) - (send k add-function "abc" void) - (send k map-function "c:k" "abc") - (hash-table-put! ht 'c:k "def") - (hash-table-map (send k get-map-function-table/ht ht) list))))) - -(test - 'keymap:aug-keymap%/get-table/chain1 - (lambda (x) - (equal? x '((c:k "abc-k2")))) - (lambda () - (send-sexp-to-mred - '(let ([k (make-object keymap:aug-keymap%)] - [k1 (make-object keymap:aug-keymap%)] - [k2 (make-object keymap:aug-keymap%)]) - (send k1 add-function "abc-k1" void) - (send k1 map-function "c:k" "abc-k1") - (send k2 add-function "abc-k2" void) - (send k2 map-function "c:k" "abc-k2") - (send k chain-to-keymap k1 #t) - (send k chain-to-keymap k2 #t) - (hash-table-map (send k get-map-function-table) list))))) - -(test - 'keymap:aug-keymap%/get-table/chain/2 - (lambda (x) - (equal? x '((c:k "abc-k")))) - (lambda () - (send-sexp-to-mred - '(let ([k (make-object keymap:aug-keymap%)] - [k1 (make-object keymap:aug-keymap%)]) - (send k1 add-function "abc-k1" void) - (send k1 map-function "c:k" "abc-k1") - (send k add-function "abc-k" void) - (send k map-function "c:k" "abc-k") - (send k chain-to-keymap k1 #t) - (hash-table-map (send k get-map-function-table) list))))) - -(define (test-canonicalize name str1 str2) - (test - (string->symbol (format "keymap:canonicalize-keybinding-string/~a" name)) - (lambda (x) - (string=? x str2)) - (lambda () - (send-sexp-to-mred - `(keymap:canonicalize-keybinding-string ,str2))))) - -(test-canonicalize 1 "c:a" "c:a") -(test-canonicalize 2 "d:a" "d:a") -(test-canonicalize 3 "m:a" "m:a") -(test-canonicalize 4 "a:a" "a:a") -(test-canonicalize 5 "s:a" "s:a") -(test-canonicalize 6 "c:a" "c:a") -(test-canonicalize 7 "s:m:d:c:a:a" "a:c:d:m:s:a") -(test-canonicalize 8 "~s:~m:~d:~c:~a:a" "~a:~c:~d:~m:~s:a") -(test-canonicalize 9 ":a" "~a:~c:~d:~m:~s:a") -(test-canonicalize 10 ":d:a" "~a:~c:d:~m:~s:a") -(test-canonicalize 11 "esc;s:a" "esc;s:a") -(test-canonicalize 12 "s:a;esc" "s:a;esc") - -(include "key-specs.ss") - -(send-sexp-to-mred `(send (make-object frame:basic% "dummy to trick frame group") show #t)) -(wait-for-frame "dummy to trick frame group") - -(define (test-key key-spec) - (let* ([keys ((case (system-type) - [(macos) key-spec-macos] - [(unix) key-spec-unix] - [(windows) key-spec-windows]) - key-spec)] - [before (key-spec-before key-spec)] - [after (key-spec-after key-spec)] - [process-key - (lambda (key) - (let ([text-expect (buff-spec-string after)] - [start-expect (buff-spec-start after)] - [end-expect (buff-spec-end after)]) - (test key - (lambda (x) (equal? x (vector text-expect start-expect end-expect))) - `(let* ([text (send (get-top-level-focus-window) get-editor)]) - (send text erase) - (send text insert ,(buff-spec-string before)) - (send text set-position ,(buff-spec-start before) ,(buff-spec-end before)) - (test:keystroke ',(car key) ',(cdr key)) - (vector (send text get-text) - (send text get-start-position) - (send text get-end-position))))))]) - (for-each process-key keys))) - -(define (test-specs frame-name frame-class specs) - (send-sexp-to-mred `(send (make-object ,frame-class ,frame-name) show #t)) - (wait-for-frame frame-name) - (for-each test-key specs) - (send-sexp-to-mred `(send (get-top-level-focus-window) close))) - -(test-specs "global keybingings test" 'frame:text% global-specs) -(test-specs "scheme mode keybindings test" - '(class frame:editor% (name) - (override - [get-editor% - (lambda () - (scheme:text-mixin text:basic%))]) - (sequence (super-init name))) - scheme-specs) diff --git a/collects/tests/framework/load.ss b/collects/tests/framework/load.ss deleted file mode 100644 index 57fff0b3..00000000 --- a/collects/tests/framework/load.ss +++ /dev/null @@ -1,142 +0,0 @@ -(let ([pred (lambda (x) (void? x))] - [old-load-framework-automatically? (load-framework-automatically)]) - - (load-framework-automatically #f) - - (test - 'guiutilss.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "guiutilss.ss" "framework") - (global-defined-value 'framework:gui-utils^) - (void))) - - (test - 'guiutils.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "guiutils.ss" "framework") - (global-defined-value 'gui-utils:read-snips/chars-from-text) - (void))) - - (test - 'guiutilsr.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "guiutilss.ss" "framework") - (eval - '(invoke-unit/sig - (compound-unit/sig - (import) - (link [m : mred^ (mred@)] - [g : framework:gui-utils^ ((require-library "guiutilsr.ss" "framework") m)]) - (export)))) - (void))) - - - (test - 'macro.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "macro.ss" "framework") - (global-defined-value 'mixin) - (void))) - (test - 'tests.ss - (lambda (x) x) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "tests.ss" "framework") - (unit/sig? (require-library "keys.ss" "framework")))) - (test - 'testr.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "tests.ss" "framework") - (eval - '(define-values/invoke-unit/sig - ((unit test : framework:test^)) - (compound-unit/sig - (import) - (link [mred : mred^ (mred@)] - [keys : framework:keys^ ((require-library "keys.ss" "framework"))] - [test : framework:test^ ((require-library "testr.ss" "framework") mred keys)]) - (export (unit test))))) - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (void))) - (test - 'test.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "test.ss" "framework") - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (void))) - - (test - 'frameworkp.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "frameworks.ss" "framework") - (require-library "file.ss") - (eval - '(define-values/invoke-unit/sig - framework^ - (compound-unit/sig - (import) - (link [mred : mred^ (mred@)] - [core : mzlib:core^ ((require-library "corer.ss"))] - [pf : framework:prefs-file^ - ((let ([tf (make-temporary-file)]) - (unit/sig framework:prefs-file^ (import) - (define preferences-filename tf))))] - [framework : framework^ ((require-library "frameworkp.ss" "framework") - core mred pf)]) - (export (open framework))))) - (global-defined-value 'preferences:get) - (void))) - - (test - 'frameworkr.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "frameworks.ss" "framework") - (eval - '(define-values/invoke-unit/sig - framework^ - (compound-unit/sig - (import) - (link [mred : mred^ (mred@)] - [core : mzlib:core^ ((require-library "corer.ss"))] - [framework : framework^ ((require-library "frameworkr.ss" "framework") core mred)]) - (export (open framework))))) - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (global-defined-value 'frame:basic-mixin) - (global-defined-value 'editor:basic-mixin) - (global-defined-value 'exit:exit) - (void))) - (test - 'framework.ss - pred - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "framework.ss" "framework") - (global-defined-value 'test:run-one) - (global-defined-value 'test:button-push) - (global-defined-value 'frame:basic-mixin) - (global-defined-value 'editor:basic-mixin) - (global-defined-value 'exit:exit) - (void))) - (test - 'framework.ss/gen - (lambda (x) x) - '(parameterize ([current-namespace (make-namespace 'mred)]) - (require-library "pretty.ss") - (let* ([op ((global-defined-value 'pretty-print-print-line))] - [np (lambda x (apply op x))]) - ((global-defined-value 'pretty-print-print-line) np) - (require-library "framework.ss" "framework") - (eq? np ((global-defined-value 'pretty-print-print-line)))))) - - (load-framework-automatically old-load-framework-automatically?)) - diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss deleted file mode 100644 index a50e3c6d..00000000 --- a/collects/tests/framework/main.ss +++ /dev/null @@ -1,370 +0,0 @@ -(require-library "launchers.ss" "launcher") -(require-library "cores.ss") -(require-library "cmdlines.ss") -(require-library "macro.ss") -(require-library "function.ss") - -(unless (file-exists? (build-path (current-load-relative-directory) "receive-sexps-port.ss")) - (call-with-output-file (build-path (current-load-relative-directory) "receive-sexps-port.ss") - (lambda (port) - (write 6012 port)))) - -(define-signature TestSuite^ - ((struct eof-result ()) - load-framework-automatically - shutdown-listener shutdown-mred mred-running? - send-sexp-to-mred queue-sexp-to-mred - test - wait-for-frame - - ;; sexp -> void - ;; grabs the frontmost window, executes the sexp and waits for a new frontmost window - wait-for-new-frame - - wait-for)) - -(define-signature internal-TestSuite^ - ((open TestSuite^) - test-name - failed-tests)) - -(define-signature Engine^ - (only-these-tests - section-name - section-jump)) - -(require-library "guis.ss" "tests" "utils") - -(define TestSuite - (unit/sig internal-TestSuite^ - (import (program) - Engine^ - launcher-maker^ - mzlib:pretty-print^ - mzlib:function^) - - (define test-name "<>") - (define failed-tests null) - - (define-struct eof-result ()) - - (define load-framework-automatically? #t) - - (define listener - (let loop () - (let ([port (load-relative "receive-sexps-port.ss")]) - (with-handlers ([(lambda (x) #t) - (lambda (x) - (let ([next (+ port 1)]) - (call-with-output-file (build-path (current-load-relative-directory) - "receive-sexps-port.ss") - (lambda (p) - (write next p)) - 'truncate) - (printf " tcp-listen failed for port ~a, attempting ~a~n" - port next) - (loop)))]) - (tcp-listen port))))) - - (define in-port #f) - (define out-port #f) - - (define restart-mred - (lambda () - (shutdown-mred) - (let-values ([(base _1 _2) (split-path program)]) - ((case (system-type) - [(macos) system*] - [else (lambda (x) (thread (lambda () (system* x))))]) - (mred-program-launcher-path "Framework Test Engine"))) - (let-values ([(in out) (tcp-accept listener)]) - (set! in-port in) - (set! out-port out)) - (when load-framework-automatically? - (queue-sexp-to-mred - `(begin - (require-library "framework.ss" "framework") - (require-library "gui.ss" "tests" "utils") - (test:run-interval 0)))))) - - (define load-framework-automatically - (case-lambda - [(new-load-framework-automatically?) - (unless (eq? (not (not new-load-framework-automatically?)) - load-framework-automatically?) - (set! load-framework-automatically? (not (not new-load-framework-automatically?))) - (shutdown-mred))] - [() load-framework-automatically?])) - - (define shutdown-listener - (lambda () - (shutdown-mred) - (tcp-close listener))) - - (define shutdown-mred - (lambda () - (when (and in-port - out-port) - (close-output-port out-port) - (close-input-port in-port) - (set! in-port #f) - (set! in-port #f)))) - - (define mred-running? - (lambda () - (if (char-ready? in-port) - (not (eof-object? (peek-char in-port))) - #t))) - - (define queue-sexp-to-mred - (lambda (sexp) - (send-sexp-to-mred - `(let ([thunk (lambda () ,sexp)] - [sema (make-semaphore 0)]) - (queue-callback (lambda () - (thunk) - (semaphore-post sema))) - (semaphore-wait sema))))) - - (define send-sexp-to-mred - (lambda (sexp) - (let ([show-text - (lambda (sexp) - - (parameterize ([pretty-print-print-line - (let ([prompt " "] - [old-liner (pretty-print-print-line)]) - (lambda (ln port ol cols) - (let ([ov (old-liner ln port ol cols)]) - (if ln - (begin (display prompt port) - (+ (string-length prompt) ov)) - ov))))]) - (pretty-print sexp) - (newline)))]) - (unless (and in-port - out-port - (or (not (char-ready? in-port)) - (not (eof-object? (peek-char in-port))))) - (restart-mred)) - (printf " ~a // ~a: sending to mred:~n" section-name test-name) - (show-text sexp) - (write sexp out-port) - (newline out-port) - (let ([answer - (with-handlers ([(lambda (x) #t) - (lambda (x) - (list 'cant-read - (string-append - (exn-message x) - "; rest of string: " - (format - "~s" - (apply - string - (let loop () - (if (char-ready? in-port) - (let ([char (read-char in-port)]) - (if (eof-object? char) - null - (cons char (loop)))) - null)))))))]) - (read in-port))]) - (unless (or (eof-object? answer) - (and (list? answer) - (= 2 (length answer)))) - (error 'send-sexp-to-mred "unpected result from mred: ~s~n" answer)) - - (if (eof-object? answer) - (raise (make-eof-result)) - (case (car answer) - [(error) - (error 'send-sexp-to-mred "mred raised \"~a\"" (second answer))] - [(cant-read) (error 'mred/cant-parse (second answer))] - [(normal) - (printf " ~a // ~a: received from mred:~n" section-name test-name) - (show-text (second answer)) - (eval (second answer))])))))) - - - (define test - (case-lambda - [(in-test-name passed? sexp/proc) (test in-test-name passed? sexp/proc 'section)] - [(in-test-name passed? sexp/proc jump) - (fluid-let ([test-name in-test-name]) - (when (or (not only-these-tests) - (memq test-name only-these-tests)) - (let ([failed - (with-handlers ([(lambda (x) #t) - (lambda (x) - (if (exn? x) - (exn-message x) - x))]) - (let ([result - (if (procedure? sexp/proc) - (sexp/proc) - (begin0 (send-sexp-to-mred sexp/proc) - (send-sexp-to-mred ''check-for-errors)))]) - (not (passed? result))))]) - (when failed - (printf "FAILED ~a: ~a~n" failed test-name) - (set! failed-tests (cons (cons section-name test-name) failed-tests)) - (case jump - [(section) (section-jump)] - [(continue) (void)] - [else (jump)])))))])) - - (define (wait-for/wrapper wrapper sexp) - (let ([timeout 10] - [pause-time 1/2]) - (send-sexp-to-mred - (wrapper - `(let ([test (lambda () ,sexp)]) - (let loop ([n ,(/ timeout pause-time)]) - (if (zero? n) - (error 'wait-for - ,(format "after ~a seconds, ~s didn't come true" timeout sexp)) - (unless (test) - (sleep ,pause-time) - (loop (- n 1)))))))))) - - (define (wait-for sexp) (wait-for/wrapper (lambda (x) x) sexp)) - - (define (wait-for-new-frame sexp) - (wait-for/wrapper - (lambda (w) - `(let ([frame (get-top-level-focus-window)]) - ,sexp - ,w)) - `(not (eq? frame (get-top-level-focus-window))))) - - (define (wait-for-frame name) - (wait-for `(let ([win (get-top-level-focus-window)]) - (and win - (string=? (send win get-label) ,name))))))) - -(define Engine - (unit/sig Engine^ - (import (argv) - internal-TestSuite^ - mzlib:command-line^ - mzlib:function^ - mzlib:file^ - mzlib:string^ - mzlib:pretty-print^) - - (define section-jump void) - (define section-name "<>") - (define only-these-tests #f) - - (define preferences-file (build-path (find-system-path 'pref-dir) - (case (system-type) - [(macos) "MrEd Preferences"] - [(windows) "mred.pre"] - [(unix) ".mred.prefs"]))) - (define old-preferences-file (let-values ([(base name _2) (split-path preferences-file)]) - (build-path base (string-append name ".save")))) - - - (with-handlers ([(lambda (x) #f) - (lambda (x) (display (exn-message x)) (newline))]) - (let* ([all-files (map symbol->string (load-relative "README"))] - [all? #f] - [files-to-process null] - [command-line-flags - `((once-each - [("-a" "--all") - ,(lambda (flag) - (set! all? #t)) - ("Run all of the tests")]) - (multi - [("-o" "--only") - ,(lambda (flag _only-these-tests) - (set! only-these-tests (cons (string->symbol _only-these-tests) - (or only-these-tests null)))) - ("Only run test named " "test-name")]))]) - - (let* ([saved-command-line-file (build-path (collection-path "tests" "framework") "saved-command-line.ss")] - [parsed-argv (if (equal? argv (vector)) - (if (file-exists? saved-command-line-file) - (begin - (let ([result (call-with-input-file saved-command-line-file read)]) - (printf "reusing command-line arguments: ~s~n" result) - result)) - (vector)) - argv)]) - (parse-command-line "framework-test" parsed-argv command-line-flags - (lambda (collected . files) - (set! files-to-process (if (or all? (null? files)) all-files files))) - `("Names of the tests; defaults to all tests")) - (call-with-output-file saved-command-line-file - (lambda (port) - (write parsed-argv port)) - 'truncate)) - - - (when (file-exists? preferences-file) - (printf " saving preferences file ~s to ~s~n" preferences-file old-preferences-file) - (if (file-exists? old-preferences-file) - (printf " backup preferences file exists, using that one~n") - (begin (copy-file preferences-file old-preferences-file) - (printf " saved preferences file~n")))) - - (for-each (lambda (x) - (when (member x all-files) - (shutdown-mred) - (let/ec k - (fluid-let ([section-name x] - [section-jump k]) - (with-handlers ([(lambda (x) #t) - (lambda (exn) - (printf "~a~n" (if (exn? exn) (exn-message exn) exn)))]) - (printf "beginning ~a test suite~n" x) - - (invoke-unit/sig - (eval - `(unit/sig () - (import TestSuite^ - mzlib:function^ - mzlib:file^ - mzlib:string^ - mzlib:pretty-print^) - (include ,x))) - TestSuite^ - mzlib:function^ - mzlib:file^ - mzlib:string^ - mzlib:pretty-print^) - (printf "PASSED ~a test suite~n" x)))))) - files-to-process))) - - (printf " restoring preferences file ~s to ~s~n" old-preferences-file preferences-file) - (when (file-exists? preferences-file) - (unless (file-exists? old-preferences-file) - (error 'framework-test "lost preferences file backup!")) - (delete-file preferences-file) - (copy-file old-preferences-file preferences-file) - (delete-file old-preferences-file)) - (printf " restored preferences file~n") - - (shutdown-listener) - - (unless (null? failed-tests) - (printf "FAILED tests:~n") - (for-each (lambda (failed-test) - (printf " ~a // ~a~n" (car failed-test) (cdr failed-test))) - failed-tests)))) - -(invoke-unit/sig - (compound-unit/sig - (import (P : (program)) - (A : (argv))) - (link - [core : mzlib:core^ ((require-library "corer.ss"))] - [launcher : launcher-maker^ ((require-library "launcherr.ss" "launcher") (core file))] - [M : mzlib:command-line^ ((require-library "cmdliner.ss"))] - [T : internal-TestSuite^ (TestSuite P E launcher (core pretty-print) (core function))] - [E : Engine^ (Engine A T M (core function) (core file) (core string) (core pretty-print))]) - (export)) - (program) - (argv)) diff --git a/collects/tests/framework/mem.ss b/collects/tests/framework/mem.ss deleted file mode 100644 index a2fa9cb7..00000000 --- a/collects/tests/framework/mem.ss +++ /dev/null @@ -1,108 +0,0 @@ -;; (list-of (list string (list-of (weak-box TST)))) -(send-sexp-to-mred '(define mem-boxes null)) - -(define mem-count 10) - -(define (test-allocate tag open close) - (send-sexp-to-mred - `(let ([new-boxes - (let loop ([n ,mem-count]) - (cond - [(zero? n) null] - [else - (let* ([o (,open)] - [b (make-weak-box o)]) - (,close o) - (cons b (loop (- n 1))))]))]) - (collect-garbage) - (set! mem-boxes (cons (list ,tag new-boxes) mem-boxes))))) - -(define (done) - (send-sexp-to-mred - `(begin - (collect-garbage) - (collect-garbage) - (collect-garbage) - (collect-garbage) - (let ([f (make-object dialog% "Results")] - [anything? #f]) - (for-each - (lambda (boxl) - (let* ([tag (first boxl)] - [boxes (second boxl)] - [calc-results - (lambda () - (foldl (lambda (b n) (if (weak-box-value b) (+ n 1) n)) - 0 - boxes))]) - (when (> (calc-results) 0) - (collect-garbage) - (collect-garbage) - (collect-garbage) - (collect-garbage) - (collect-garbage) - (collect-garbage)) - (let ([res (calc-results)]) - (when (> res 0) - (set! anything? #t) - (make-object message% (format "~a: ~a of ~a~n" tag res ,mem-count) f))))) - (reverse mem-boxes)) - (cond - [anything? (make-object button% "Close" f (lambda x (send f show #f)))] - [else (make-object button% "NOTHING!" f (lambda x (send f show #f)))]) - (send f show #t))))) - -(define (test-frame-allocate name %) - (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #f)) - (test-allocate name - `(lambda () (let ([f (make-object ,% ,name)]) - (send f show #t) - f)) - `(lambda (f) (send f close))) - (send-sexp-to-mred '(preferences:set 'framework:exit-when-no-frames #t))) - -(test-allocate "frame%" - '(lambda () (let ([f (make-object frame% "test frame")]) - (send f show #t) - f)) - '(lambda (f) (send f show #f))) - - -(define (test-editor-allocate object-name) - (test-allocate (symbol->string object-name) - `(lambda () (make-object ,object-name)) - '(lambda (e) (send e on-close)))) - -(test-editor-allocate 'text:basic%) -(test-editor-allocate 'text:keymap%) -(test-editor-allocate 'text:autowrap%) -(test-editor-allocate 'text:file%) -(test-editor-allocate 'text:clever-file-format%) -(test-editor-allocate 'text:backup-autosave%) -(test-editor-allocate 'text:searching%) -(test-editor-allocate 'text:info%) - -(test-editor-allocate 'pasteboard:basic%) -(test-editor-allocate 'pasteboard:keymap%) -(test-editor-allocate 'pasteboard:file%) -(test-editor-allocate 'pasteboard:backup-autosave%) -(test-editor-allocate 'pasteboard:info%) - -(test-editor-allocate 'scheme:text%) - -(test-allocate "text:return%" - '(lambda () (make-object text:return% void)) - '(lambda (t) (void))) - - -(test-frame-allocate "frame:basic%" 'frame:basic%) -(test-frame-allocate "frame:standard-menus%" 'frame:standard-menus%) -(test-frame-allocate "frame:text%" 'frame:text%) -(test-frame-allocate "frame:searchable%" 'frame:searchable%) -(test-frame-allocate "frame:text-info%" 'frame:text-info%) -(test-frame-allocate "frame:text-info-file%" 'frame:text-info-file%) -(test-frame-allocate "frame:pasteboard%" 'frame:pasteboard%) -(test-frame-allocate "frame:pasteboard-info%" 'frame:pasteboard-info%) -(test-frame-allocate "frame:pasteboard-info-file%" 'frame:pasteboard-info-file%) -(done) - diff --git a/collects/tests/framework/panel.ss b/collects/tests/framework/panel.ss deleted file mode 100644 index 3079a341..00000000 --- a/collects/tests/framework/panel.ss +++ /dev/null @@ -1,130 +0,0 @@ -(test - 'single-panel - (lambda (x) (eq? x 'passed)) - `(let* ([semaphore (make-semaphore 0)] - [semaphore-frame% - (class frame% args - (override - [on-close (lambda () (semaphore-post semaphore))]) - (sequence - (apply super-init args)))] - [f (make-object semaphore-frame% "Single Panel Test")] - [blue-brush (send the-brush-list find-or-create-brush "BLUE" 'solid)] - [green-brush (send the-brush-list find-or-create-brush "FOREST GREEN" 'solid)] - [black-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)] - [grid-canvas% - (class canvas% (lines parent label stretchable-width? stretchable-height?) - (inherit get-dc get-client-size) - (override - [on-paint - (lambda () - (let-values ([(width height) (get-client-size)]) - (let ([dc (get-dc)] - [single-width (/ width lines)] - [single-height (/ height lines)]) - (send dc set-pen black-pen) - (let loop ([i lines]) - (cond - [(zero? i) (void)] - [else - (let loop ([j lines]) - (cond - [(zero? j) (void)] - [else - (send dc set-brush - (if (= 0 (modulo (+ i j) 2)) - blue-brush green-brush)) - (send dc draw-rectangle - (* single-width (- i 1)) - (* single-height (- j 1)) - single-width - single-height) - (loop (- j 1))])) - (loop (- i 1))])))))]) - (inherit set-label min-width min-height stretchable-height stretchable-width) - (sequence - (super-init parent) - (stretchable-width stretchable-width?) - (stretchable-height stretchable-height?) - (min-width 50) - (min-height 50) - (set-label label)))] - - [border-panel (make-object horizontal-panel% f '(border))] - [single-panel (make-object panel:single% border-panel)] - [children (list (make-object grid-canvas% 3 single-panel "Small" #f #f) - (make-object grid-canvas% 3 single-panel "Wide" #f #t) - (make-object grid-canvas% 3 single-panel "Tall" #t #f) - (make-object grid-canvas% 3 single-panel "Wide and Tall" #t #t))] - [active-child (car children)] - [radios (make-object horizontal-panel% f)] - [make-radio - (lambda (label choices callback) - (let* ([panel (make-object vertical-panel% radios '(border))] - [message (make-object message% label panel)] - [radio (make-object radio-box% #f choices panel (lambda (radio _) (callback radio)))] - [button (make-object button% - "Cycle" panel - (lambda (_1 _2) - (let ([before (send radio get-selection)] - [tot (send radio get-number)]) - (let loop ([n tot]) - (unless (zero? n) - (send radio set-selection (- tot n)) - (callback radio) - (sleep/yield 1) - (loop (- n 1)))) - (send radio set-selection before) - (callback radio))))]) - radio))] - [radio - (make-radio - "Active Child" - (map (lambda (x) (send x get-label)) children) - (lambda (radio) - (let loop ([n (length children)] - [cs children]) - (cond - [(null? cs) (void)] - [else (let ([c (car cs)]) - (if (string=? (send radio get-item-label (send radio get-selection)) - (send c get-label)) - (begin (set! active-child c) - (send single-panel active-child active-child)) - (loop (- n 1) - (cdr cs))))]))))] - [vertical-alignment 'center] - [horizontal-alignment 'center] - [update-alignment (lambda () - (send single-panel set-alignment horizontal-alignment vertical-alignment))] - [horiz - (make-radio - "Horizontal Alignment" - (list "left" "center" "right") - (lambda (radio) - (set! horizontal-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) - (update-alignment)))] - [vert - (make-radio - "Vertical Alignment" - (list "top" "center" "bottom") - (lambda (radio) - (set! vertical-alignment (string->symbol (send radio get-item-label (send radio get-selection)))) - (update-alignment)))] - [buttons (make-object horizontal-panel% f)] - [result 'failed] - [failed (make-object button% "Failed" buttons (lambda (_1 _2) (semaphore-post semaphore)))] - [passed (make-object button% "Passed" buttons (lambda (_1 _2) - (set! result 'passed) - (semaphore-post semaphore)))]) - (send border-panel min-width 100) - (send border-panel min-height 100) - (send vert set-selection 1) - (send horiz set-selection 1) - (send buttons stretchable-height #f) - (send buttons set-alignment 'right 'center) - (send radios stretchable-height #f) - (send f show #t) - (yield semaphore) - (send f show #f) - result)) diff --git a/collects/tests/framework/paren-test.ss b/collects/tests/framework/paren-test.ss deleted file mode 100644 index 62c4b91e..00000000 --- a/collects/tests/framework/paren-test.ss +++ /dev/null @@ -1,139 +0,0 @@ -(define balanced-tests - `(("()" 0 2) - ("(a)" 0 3) - ("(a a)" 0 5) - ("(())" 0 4) - ("(())" 1 3) - ("([])" 1 3) - ("([])" 0 4) - ("{[]}" 1 3) - ("{[]}" 0 4) - ("abc" 0 3) - ("(abc (abc))" 0 11) - ("(abc (abc))" 5 10))) - -(define unbalanced-tests - `(("()" #t (1) (1)) - ("(()" #f (0 2) (1 2)) - ("(a()" #f (0) (1 3)) - (")" #f (0 1) (0 1)) - ("())" #f (1 2) (1 3)) - ("() a)" #f (1 4) (1 5)))) - -(define (run-unbalanced-test test-data) - (let ([expression (first test-data)] - [balanced? (second test-data)] - [forward-starts (third test-data)] - [backward-starts (fourth test-data)]) - (test - (string->symbol (format "unbalanced-paren-~a" expression)) - (lambda (x) (not (ormap (lambda (x) x) x))) - `(let ([t (make-object text%)]) - (send t insert ,expression) - (append - (list (not (eq? ,balanced? (scheme-paren:balanced? t 0 (send t last-position))))) - (map (lambda (n) (scheme-paren:forward-match t n (send t last-position))) ',forward-starts) - (map (lambda (n) (scheme-paren:backward-match t n 0)) ',backward-starts)))))) - -(define (run-balanced-test test-data) - (let ([expression (first test-data)] - [start (second test-data)] - [end (third test-data)]) - (test - (string->symbol (format "balanced-paren-~a/~a/~a" expression start end)) - (lambda (x) (equal? x (list start end #t))) - `(let ([t (make-object text%)]) - (send t insert ,expression) - (list (scheme-paren:backward-match t ,end 0) - (scheme-paren:forward-match t ,start (send t last-position)) - (scheme-paren:balanced? t 0 (send t last-position))))))) - -(define (run-scheme-unbalanced-test test-data) - (let ([expression (first test-data)] - [balanced? (second test-data)] - [forward-starts (third test-data)] - [backward-starts (fourth test-data)]) - (test - (string->symbol (format "scheme-unbalanced-paren-~a" expression)) - (lambda (x) (not (ormap (lambda (x) x) x))) - `(let* ([t (make-object scheme:text%)] - [setup-text - (lambda () - (send t erase) - (send t insert ,(string-append " " expression)))] - [insert-first - (lambda () - (send t insert " " 0 0))] - [delete-first - (lambda () - (send t delete 0 1))]) - (append - (map - (lambda (n) - (setup-text) - (send t get-backward-sexp (+ n 1)) - (delete-first) - (send t get-backward-sexp n)) - ',backward-starts) - (map - (lambda (n) - (setup-text) - (send t get-backward-sexp (+ n 1)) - (insert-first) - (send t get-backward-sexp (+ n 2))) - ',backward-starts) - (map - (lambda (n) - (setup-text) - (send t get-forward-sexp (+ n 1)) - (delete-first) - (send t get-forward-sexp n)) - ',forward-starts) - (map - (lambda (n) - (setup-text) - (send t get-forward-sexp (+ n 1)) - (insert-first) - (send t get-forward-sexp (+ n 2))) - ',forward-starts)))))) - -(define (run-scheme-balanced-test test-data) - (let* ([expression (first test-data)] - [start (second test-data)] - [end (third test-data)] - [answers (list start (+ start 2) end (+ end 2))]) - (test - (string->symbol (format "balanced-paren-~a/~a" expression answers)) - (lambda (x) (equal? x answers)) - `(let* ([t (make-object scheme:text%)] - [setup-text - (lambda () - (send t erase) - (send t insert ,(string-append " " expression)))] - [insert-first - (lambda () - (send t insert " " 0 0))] - [delete-first - (lambda () - (send t delete 0 1))]) - (list (begin (setup-text) - (send t get-backward-sexp ,(+ end 1)) - (delete-first) - (send t get-backward-sexp ,end)) - (begin (setup-text) - (send t get-backward-sexp ,(+ end 1)) - (insert-first) - (send t get-backward-sexp ,(+ end 2))) - (begin (setup-text) - (send t get-forward-sexp ,(+ start 1)) - (delete-first) - (send t get-forward-sexp ,start)) - (begin (setup-text) - (send t get-forward-sexp ,(+ start 1)) - (insert-first) - (send t get-forward-sexp ,(+ start 2)))))))) - -(for-each run-unbalanced-test unbalanced-tests) -(for-each run-scheme-unbalanced-test unbalanced-tests) -(for-each run-balanced-test balanced-tests) -(for-each run-scheme-balanced-test balanced-tests) diff --git a/collects/tests/framework/pasteboard.ss b/collects/tests/framework/pasteboard.ss deleted file mode 100644 index 2aceee62..00000000 --- a/collects/tests/framework/pasteboard.ss +++ /dev/null @@ -1,45 +0,0 @@ -(define (test-creation frame class name) - (test - name - (lambda (x) #t) - (lambda () - (send-sexp-to-mred - `(let* ([% (class-asi ,frame - (override - [get-editor% - (lambda () - ,class)]))] - [f (make-object % "test pasteboard")]) - (preferences:set 'framework:exit-when-no-frames #f) - (send f show #t))) - (wait-for-frame "test pasteboard") - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close))))) - -(test-creation 'frame:editor% - '(editor:basic-mixin pasteboard%) - 'editor:basic-mixin-creation) -(test-creation 'frame:editor% - 'pasteboard:basic% - 'pasteboard:basic-creation) - -(test-creation 'frame:editor% - '(editor:file-mixin pasteboard:keymap%) - 'editor:file-mixin-creation) -(test-creation 'frame:editor% - 'pasteboard:file% - 'pasteboard:file-creation) - -(test-creation 'frame:editor% - '(editor:backup-autosave-mixin pasteboard:file%) - 'editor:backup-autosave-mixin-creation) -(test-creation 'frame:editor% - 'pasteboard:backup-autosave% - 'pasteboard:backup-autosave-creation) - -(test-creation 'frame:pasteboard-info% - '(editor:info-mixin pasteboard:backup-autosave%) - 'editor:info-mixin-creation) -(test-creation 'frame:pasteboard-info% - 'pasteboard:info% - 'pasteboard:info-creation) diff --git a/collects/tests/framework/prefs.ss b/collects/tests/framework/prefs.ss deleted file mode 100644 index cb780807..00000000 --- a/collects/tests/framework/prefs.ss +++ /dev/null @@ -1,55 +0,0 @@ -(local [(define pref-file (build-path (find-system-path 'pref-dir) - (case (system-type) - [(macos) "MrEd Preferences"] - [(windows) "mred.pre"] - [(unix) ".mred.prefs"] - [else (error 'prefs.ss "unknown os: ~a~n" (system-type))]))) - (define old-prefs (if (file-exists? pref-file) - (call-with-input-file pref-file read) - null)) - (define (check-eq? s) (lambda (t) (eq? s t))) - (define pref-sym 'framework:test-suite)] - - (call-with-output-file pref-file - (lambda (port) (write (filter (lambda (x) (not (eq? (car x) pref-sym))) - old-prefs) - port)) - 'truncate) - (shutdown-mred) - - (test - 'preference-unbound - (check-eq? 'passed) - `(with-handlers ([exn:unknown-preference? - (lambda (x) - 'passed)]) - (preferences:get ',pref-sym))) - (test 'preference-set-default/get - (check-eq? 'passed) - `(begin (preferences:set-default ',pref-sym 'passed symbol?) - (preferences:get ',pref-sym))) - (test 'preference-set/get - (check-eq? 'new-pref) - `(begin (preferences:set ',pref-sym 'new-pref) - (preferences:get ',pref-sym))) - (with-handlers ([eof-result? (lambda (x) (void))]) - (send-sexp-to-mred '(begin (preferences:set 'framework:verify-exit #f) (exit:exit)))) - - (test 'preference-get-after-restart - (check-eq? 'new-pref) - `(begin (preferences:set-default ',pref-sym 'passed symbol?) - (preferences:get ',pref-sym)))) - - -(test 'dialog-appears - (lambda (x) (eq? 'passed x)) - (lambda () - (send-sexp-to-mred '(preferences:show-dialog)) - (wait-for-frame "Preferences") - (send-sexp-to-mred '(begin (preferences:hide-dialog) - (let ([f (get-top-level-focus-window)]) - (if f - (if (string=? "Preferences" (send f get-label)) - 'failed - 'passed) - 'passed)))))) diff --git a/collects/tests/framework/scheme.ss b/collects/tests/framework/scheme.ss deleted file mode 100644 index e69de29b..00000000 diff --git a/collects/tests/framework/send-sexp.ss b/collects/tests/framework/send-sexp.ss deleted file mode 100644 index ec88275f..00000000 --- a/collects/tests/framework/send-sexp.ss +++ /dev/null @@ -1,11 +0,0 @@ -(define send-sexp - (lambda (sexp) - (let-values ([(in out) (tcp-connect "localhost" (require-library "receive-sexps-port.ss" "tests" "framework"))]) - (write sexp out) - (newline out) - (let ([result (read in)]) - (close-input-port in) - (close-output-port out) - (case (car result) - [(error) (error 'send-sexp (cadr result))] - [(normal) (cadr result)]))))) diff --git a/collects/tests/framework/text.ss b/collects/tests/framework/text.ss deleted file mode 100644 index 2936213d..00000000 --- a/collects/tests/framework/text.ss +++ /dev/null @@ -1,70 +0,0 @@ -(define (test-creation frame% class name) - (test - name - (lambda (x) #t) - (lambda () - (send-sexp-to-mred - `(let* ([% (class-asi ,frame% - (override - [get-editor% (lambda () ,class)]))] - [f (make-object % "test text")]) - (preferences:set 'framework:exit-when-no-frames #f) - (send f show #t))) - (wait-for-frame "test text") - (send-sexp-to-mred `(test:keystroke #\a)) - (wait-for `(string=? "a" (send (send (get-top-level-focus-window) get-editor) get-text))) - (send-sexp-to-mred - `(begin (send (send (get-top-level-focus-window) get-editor) lock #t) - (send (send (get-top-level-focus-window) get-editor) lock #f))) - (queue-sexp-to-mred - `(send (get-top-level-focus-window) close))))) - - -(test-creation 'frame:text% - '(text:basic-mixin (editor:basic-mixin text%)) - 'text:basic-mixin-creation) -(test-creation 'frame:text% - 'text:basic% - 'text:basic-creation) - -(define (return-args class) - `(class ,class () - (sequence - (super-init void)))) -(test-creation 'frame:text% - (return-args '(text:return-mixin text:basic%)) - 'text:return-mixin-creation) -(test-creation 'frame:text% - (return-args 'text:return%) - 'text:return-creation) - -(test-creation 'frame:text% - '(editor:file-mixin text:keymap%) - 'editor:file-mixin-creation) -(test-creation 'frame:text% - 'text:file% - 'text:file-creation) -(test-creation 'frame:text% - '(text:clever-file-format-mixin text:file%) - 'text:clever-file-format-mixin-creation) -(test-creation 'frame:text% - 'text:clever-file-format% - 'text:clever-file-format-creation) -(test-creation 'frame:text% - '(editor:backup-autosave-mixin text:clever-file-format%) - 'editor:backup-autosave-mixin-creation) -(test-creation 'frame:text% - 'text:backup-autosave% - 'text:backup-autosave-creation) -(test-creation 'frame:text% - '(text:searching-mixin text:backup-autosave%) - 'text:searching-mixin-creation) -(test-creation 'frame:text% - 'text:searching% - 'text:searching-creation) -(test-creation '(frame:searchable-mixin frame:text%) - '(text:info-mixin (editor:info-mixin text:searching%)) - 'text:info-mixin-creation) -(test-creation '(frame:searchable-mixin frame:text%) - 'text:info% - 'text:info-creation) \ No newline at end of file diff --git a/collects/tests/framework/utils.ss b/collects/tests/framework/utils.ss deleted file mode 100644 index 3776c311..00000000 --- a/collects/tests/framework/utils.ss +++ /dev/null @@ -1,13 +0,0 @@ -(define (wait-for-frame name) - (let ([timeout 10] - [pause-time 1/2]) - (send-sexp-to-mred - `(let loop ([n ,(/ timeout pause-time)]) - (if (zero? n) - (error 'wait-for-mred-frame - ,(format "after ~a seconds, frame labelled ~s didn't appear" timeout name)) - (let ([win (get-top-level-focus-window)]) - (printf "win: ~a label ~a~n" win (and win (string=? (send win get-label) ,name))) - (unless (and win (string=? (send win get-label) ,name)) - (sleep ,pause-time) - (loop (- n 1))))))))) diff --git a/collects/tests/info.ss b/collects/tests/info.ss deleted file mode 100644 index 717693fe..00000000 --- a/collects/tests/info.ss +++ /dev/null @@ -1,13 +0,0 @@ -(let ([sub-collections (list "framework")]) - (lambda (request result) - (case request - [(name) "Test Suites"] - [(install-collection) - (lambda (arg) - (error-print-width 500) - (for-each (lambda (sub-collection) - (let ([sub-info (build-path (collection-path "tests" sub-collection) "info.ss")]) - (when (file-exists? sub-info) - (((load-relative sub-info) 'install-collection void) arg)))) - sub-collections))] - [else (result)]))) diff --git a/collects/tests/mred/README b/collects/tests/mred/README deleted file mode 100644 index 6ce7f292..00000000 --- a/collects/tests/mred/README +++ /dev/null @@ -1,87 +0,0 @@ - -The "item.ss" test (use load/cd) creates a frame to select among -several types of control-testing frames. Click the `Get Instructions' -button in the top-left for more information. - ---------------------------------------------------------------------------- - -The "draw.ss" test (use load/cd) tests drawing commands. Click the -"What Should I See?" button for further details. - ---------------------------------------------------------------------------- - -The "mem.ss" test is loaded at startup: - mred -r mem.ss -Creates a lot of frames and instance of other objects, reporting -memory information along the way. At the end, before the last memory -dump, objects that are still allocated are displayed like this: - (frame (1 . 5)) -This means that the frame allocated by thread #1 at cycle 5 -(counting down from some number) hasn't been garbage-collected. -If there's a few of these lines (around 10), that's ok. -A large number of lines (say, 50) indicates a GC problem. - ---------------------------------------------------------------------------- - -[Out of date:] -The "random.ss" test is a randomized test of the MrEd classes that tests -MrEd's stability. Load "random.ss", and then run - (init) -This attempts to create instances of classes using random -intialization arguments. (init) can be run any number of times. -(2 is a good number) Then run - (call-all-random) -This calls every method of every class (skipping some "dangerous" ones -that modify the file system) with a random instance and with random -arguments. - -To avoid testing much of the wxMedia toolbox, which is likely to be -platform-independent, (define skip-media? #t) before loading -"random.ss". - - -================================================== -Old Stuff -================================================== - ---------------------------------------------------------------------------- - -The "imred.ss" test is used to check for memory leaks in a loop -invoking the mred system. Call the `go' procedure with a list -of symbol flags: - 'force not included: - Use the current eventspaces; expects mred:run-exit-callbacks - to terminate everything properly - 'force included: - Use a new eventspace; don't run mred:run-exit-callbacks and - call wx:kill-eventspace instead. - 'console included: - Open a MrEd console - 'thread included: - Spawn a sleeping-and-looping thread during each invocation. - Also tests semaphore-callback (because it has to) - 'eventspace included: - Create a new sub-eventspace during each invocation with - a wx:frame% shown - ---------------------------------------------------------------------------- - -"startup" tests the startup flags of mred. run "run.ss" from that directory. - ---------------------------------------------------------------------------- - -"frame-edit.ss" checks that various frames match with various -edits. Under construction. - ---------------------------------------------------------------------------- - -"gui.ss" tests: - - save prompting (before closing unsaved files) and - - autosaving - -evaluate `(load "gui.ss")' in the console to run. - -It also overwrites the file "tmp.ss" in the testing directory. - ---------------------------------------------------------------------------- - diff --git a/collects/tests/mred/auto.ss b/collects/tests/mred/auto.ss deleted file mode 100644 index 993e13bf..00000000 --- a/collects/tests/mred/auto.ss +++ /dev/null @@ -1,4 +0,0 @@ - -(load-relative "editor.ss") -(load-relative "paramz.ss") -(load-relative "windowing.ss") diff --git a/collects/tests/mred/button-steps.txt b/collects/tests/mred/button-steps.txt deleted file mode 100644 index e2e233ac..00000000 --- a/collects/tests/mred/button-steps.txt +++ /dev/null @@ -1,11 +0,0 @@ -Click the "Hit Me" button. "Callback Ok" should appear in the console. - -Click "Check". "All Ok" should appear in the console. - -Repeat the above two steps. - -Click "Disable Test" and quickly click "Hit Me". The button should - become disabled for a second, then become re-enabled, but the - click on "Hit Me" should not invoke the callback. - -Repeat the first two steps above. diff --git a/collects/tests/mred/canvas-steps.txt b/collects/tests/mred/canvas-steps.txt deleted file mode 100644 index d22562ff..00000000 --- a/collects/tests/mred/canvas-steps.txt +++ /dev/null @@ -1,175 +0,0 @@ - -Overview --------- - -This canvas test frame is for checking the behvaiour of the -scrollbars. Canvas scrollbars work in one of two modes: - 1) Managing: the scrollbar determines the size and offset of - the canvas's drawing area. - 2) Non-managing: the scrollbars are simply placed next to the - canvas; the canvas's size and offset are not affected by - the scrollbar values. -In the test frame, the top canvas is initially unmanaged, and the -bottom is managed. - -An HVCanvas has both horizontal and vertical scrollbars, but the -scrollbars are initially disabled. Clikcing the "Enable Vertical" -checkbox enables the vertical scroll. A VCanvas has only a vertical -scrollbar; clicking "ENable Horizontal" in this case has no effect. -When a canvas is managed by its scrollbars and a scrollbar is missing -in a particular direction, it should act the same as an unmanaged -canvas in that direction. - -On each canvas, the following are painted at 0,0: - * The name of the canvas - * Three values per scroll bar, for UNMANAGED canvases: - - The current value of the scroll - - The maximum value of the scroll - - The page step of the scroll - These should all be 0 for MANAGED canvases and for - disabled directions - * Two size measurements: - - The client size of the canvas - - The drawing area of the canvas - These should be the same for UNMANAGED canvases/directions - * Two lines showing what each `virtual boundary' of the canvas would - be if it is managed and the scrollbar is enabled. (Initially, the - bottom canvas's boundaries are probably beyond the visible region.) - When the canvas is managed with a vertical scrollbar, the bottom - boundary line might not be visible, i.e., it might be clipped - but - it must be clipped eactly in that case. - -As the scroll is changed for the managed canvas, the information will -move, because the scrolls automatically adjust the offset of the -canvas. For the unmanaged canvas, the information is always visible in -the same place; it is just updated. - -The top's scrollbars have a range of 10 and a page step of 3. The -bottom's scrollbars have a range of 20 and a page step of 3 (although -the page step is sometimes ignored for a managed canvas). In managed -mode: - - * In the bottom canvas, one vertical scroll step is mapped to 10 - pixels and one horizontal step to 25 pixels, making the virtual - area 200 pixels high and 500 pixels wide. - - When the "Small" checkbox is checked, the range is changed to 2 - instead of 20, making the virtual size 20 high by 50 wide. - - * In the bottom canvas, one vertical or horizontal scroll step is - mapped to 1 pixel, making the virtual area 10x10. - -Initially, the top canvas is unmanaged and the bottom is managed. -Checking the "swap" checkbox makes the top canvas unmanaged and the -bottom canvas managed. - -The steps below assume an HVCanvas. Don't resize the window before -starting the steps. - -HVCanvas Steps --------------- - -Enable vertical scroll. The scroll should be at position 1 for both - canvases. The bottom canvas should be scrolled up 10 pixels. The - displayed info should change: - ------------------------------------------- - | Unmanaged Scroll | - | V: p: 1 r: 10 g: 3 H: 0 0 0 | - | Client: x Virtual: x | ; for some and - ------------------------------------------- - | Automanaged Scroll | ; <- actually, scrolled up - | V: p: 0 r: 0 g: 0 H: 0 0 0 | ; all zero for managed - | Client: x Virtual: x 200 | ; within 1 of - ------------------------------------------- - (You might not be able to read 200 in the lower right.) - Make the window slightly wider. Make sure the gets bigger to - reflect the new width of the canvases. - -Set the bottom canvas's vertical scroll to 0. The "Automanaged Scroll" - should scroll back down into the original location. - -Scroll the bottom canvas's vertical scroll to its maximum value (which - is less than 10) You may see the bottom border close to the bottom - edge of the canvas. - -Adjust the top canvas's scroll, and watch the `p' value change each - time. The maximum value is 10. Use the `page up/down' areas and make - sure the `p' value changes by 3. - -Turn off the vertical scroll. The bottom canvas's image should snap - back to its original place. All the `V:' values in the top should - return to zeros. - -Perform the above steps for horizontal scrolling. - -Turn on both vertical and horizontal scrolling. You should see the - obvious combined effect. In particular, the bottom canvas's text - should be scrolled both up and to the left. - -Move all scrolls to 1 step beyond the smallest setting. - -Make the frame larger. The top canvas's scrolls should still have 10 - steps, but the bottom canvas's scrolls will have fewer steps, - reflecting the fact that less scrolling is needed to see the same - virtual area. - -Test the bottom canvas's scrolls to ensure that the maximum values of - the scrolls show the edges of the canvas's virtual area. - -Make the frame large enough to see the whole bottom canvas's virtual - area. The scrollbars should become disabled in both directions. - -Make the frame smaller again. The bottom canvas's scrolls should - adjust correctly. Make the frame small enough that all scrollbars are - active. - -Move all scrolls to 1 step beyond the smallest setting. - -Check "swap". Now, the top canvas is managed and the bottom canvas is - unmanaged. But the top canvas's area is so small that its scrollbars - are always disabled. (It may also be clipped to the tiny 10x10 box.) - The bottom canvas's scrollbars should now act the the top ones used - to: there are 20 steps in each direction and the `V:' and `H:' values - change as the scrolls are moved. - -Uncheck "swap". The scrollbars should all go back to the 1 position. - The bottom canvas should be scrolled in the usual way. - -Check "small". The top canvas should be unaffected. The bottom canvas - should scroll back to 0,0, the scrollbars should be disabled, and a - 50x20 box should be drawn in the upper left (or the entire canvas is - clipped to that box). - -Check "swap". The bottom canvas should not be clipped. - -Check "swap". The bottom canvas might be clipped again. - -Uncheck "small". The bottom canvas should not be clipped. - -Check "small" and disable vertical scrolls. The bottom canvas should - be clipped horizontally or the boundary drawn at a small offset from - the left. - -Enable vertical and disable horizontal. The bottom canvas will be - narrowly clipped of have a short boundary from the top. - -HCanvas Steps --------------- - -A vertical scrollbar should not be visible at all. - -Check both "Enable Vertical" and "Enable Horizontal". Verify that the - canvases act exactly like an HVCanvas with vertical scrolls disabled. - -VCanvas Steps --------------- - -Transpose the approve appropriately - -Canvas Steps ------------- - -No scrollbars, checking the enabler boxes has no effect. - -Click "small" and make sure the bottom canvas is not clipped. - diff --git a/collects/tests/mred/checkbox-steps.txt b/collects/tests/mred/checkbox-steps.txt deleted file mode 100644 index 0ee77b23..00000000 --- a/collects/tests/mred/checkbox-steps.txt +++ /dev/null @@ -1,21 +0,0 @@ -Check the "On" checkbox. "Callback Ok" should appear in the console. - -Uncheck the "On" checkbox. "Callback Ok" should appear in the console. - -Click "Check". "All Ok" should appear in the console. - -Repeat the above three steps. - -Click "Toggle". The checkbox should become checked. - -Click "Toggle". The checkbox should become unchecked. - -Check the "On" checkbox. "Callback Ok" should appear in the console. - -Click "Toggle". The checkbox should become unchecked. - -Repeat the above four steps with "Simulation Toggle" instead of "Toggle". - However, with "Simulation Toggle", "Callback Ok" should be printed - each time "Simulation Toggle" is hit. - -Click "Check". "All Ok" should appear in the console. diff --git a/collects/tests/mred/choice-list-steps.txt b/collects/tests/mred/choice-list-steps.txt deleted file mode 100644 index 3d3856b0..00000000 --- a/collects/tests/mred/choice-list-steps.txt +++ /dev/null @@ -1,236 +0,0 @@ -Set Up, Callbacks, Appending ----------------------------- - -The choice/list should contain "Alpha" "Beta" and "Gamma" for - starters, unless and empty choice/list was created. In a choice, - "Alpha" should be initially selected. - -If there are no items: - - * Click on the choice box. Make sure that nothing prints to the - console as a result. - - * Click "Append"; "Extra 1" should appear in the list of tiems. - For a choice, it should be immediately selected. - - * Click "Append" again. The selection should not change. - - * Start over with a fresh frame. Click the "Clear" button and - nothing should happen. - - * If its an empty list, start over with a fresh frame. Click the - "Reset" button and make sure "Alpha" "Beta" and "Gamma" are - added. - - * Start over with a fresh frame again; jump down to the `Clearing' - section (but don't click "Clear"). - -For a multi-selection list, jump down to "Multiple Selections". - -If there are items, select each once in order (single-click for - lists). After each solection, "Changed N" should appear in the - console (where N is the position of the item, counting from 0) for a - choice item, "Change (N)" for a list box; in either case, the - "Changed" line is followed by "Callback Ok". This should be printed - even if the selection is technically unchanged. Select the last one a - second time to make sure. - -For a choice, click to pop-up the menu, but don't select anything. for - a list, click in an area without items and in the scroll bar(s). In - both cases, the selection should not change and nothing should print - in the console. - -Click the "Append" button. The seletion should not change, but a new - item "Extra 1" should appear. - -Click the "Append" button again. - -Select the first newly added item. - -Click on the "check" button. In the console, "content: " whould be - printed along with a list of strings. That list should match the - items in the choice/list. - -Selections ----------- - -Click "Select First". The selection should change to "Alpha", but - nothing should appear in the console. - -Click "Select Middle". The selection should change to "Gamma", but - nothing should appear in the console. - -Click "Select Last". The selection should change to "Extra 2"", but - nothing should appear in the console. - -Click "Select Bad -1" and Select Bad X". In both cases, nothing should - happen, and nothing should appear in the console. - -Repeat the above four steps for the "by name" buttons. (There's - nothing equivalent to -1 for the "by name" buttons.) - -Repeat the four steps for the "by Simulate" buttons; in addition to - having the selections change, the "Changed N" and "Callback Ok" - messages should print in the console. For the -1 and X cases, "event - selection value mismatch" should print in the console, and the - selection should not change. - -Click on the "check" button and check the content list. - -Clearing --------- - -Choose clear. All items should disappear. - -Choose clear again. Nothing should happen. - -Click on all parts of the control. The callback should never be - invoked. - -Click on all the "Select" buttons. For the top buttons and "by - Simulate" buttons (but not the "bad" ones), an exception should be - reported. Nothing should happend for the "by Name" buttons. - -Click on "Check". The empty item list should be reported in the - console. - -Click on "Append". For a choice, "Extra 3" should be immediately - selected. For a list box, nothing should be selected. - -Click "Append" again. The selection should not change. - -Select the second item, "Extra 4". Note the callback message in - the console for item 1. - -Click "Check" and see the list in the console: ("Extra 3" "Extra 4") - -Append one more, "Extra 5", and try all the selecting buttons again. - -Append 5 more items. The last one is very long, but it should look ok: - "This is a Really Long Named Item That Would Have Used the Short - Name, Yes This is a Really Long Named Item That Would Have Used the - Short Name Extra 10" - -Select the long-name item. - -Click "Check". The long name should be printed ok in the console. - ->> No More Tests for Choice Frames << - -Visible Range >> Lists Only << -------------- - -Scroll to the top and select the first item. Click "Visible - Indices". In the console, the top should be 0, and the visible count - equal to the number of items that are completely visible in the - item. If an item is only partly visible, it should not be counted. - -Scroll down exactly one item's height without changing the - selection. Click "Visible Incices" again. The top should change to 1 - but the count should be the same. - -On some platforms, you can scroll to partially show the first item. - Try it and hit "Visible Indices"; the partially shown item should - count as unshown. The visible count should not change. - -Make the window taller to show at least one more item. Try "Visible - Indices" again and make sure it changed. - -Click "Select Last". The list should scroll to the end. Try "Visible - Indices" again. - -Make the list box taller than all its items. (It may be necssary to - delete some items by selecting them and hitting the "Delete" button.) - Click "Visible Indices" and make sure that the visible count is still - more than the number of items. - -Deleting >> Lists Only << --------- - -Select an item in the middle of the list. - -Hit "Delete". The item should disappear, and nothing shold be - selected. - -Append a new item. - -Select the third item in the list. Hit "Delete Above"; the second item - should disappear, and the selection should stick with its item as it - moves into 2nd place. Hit "Delete Above" again and the first item - should disappear, and the new first item should still be selected. - Click "Delete Above" one more time, and nothing should happen. - -Append two new items. - -Select the third to last item in the list. Test "Delete Below" by - clicking it three times, just like to "Delete Above". - -Append two new items. - -Click "Check" and inspect the item list in the console. - -Select the first item. Click the "Reset" button. The list should - contain "Alpha" "Beta" and "Gamma" with no selection. - -Click "Check" and inspect the item list in the console. - -Double-Click >> Lists Only << ------------- - -Double-click on "Alpha". The console should report the first click - in the normal way, and then report "Changed -1" followed by - "Double-click", then "Callback Ok". - -Double-click on "Gamma". Same as above, except that the initial - click is reported for position 2 instead of 0. - -Click "Check" and inspect the item list in the console. - ->> No More Tests for Single-Selection List Frames << - -Multiple Selections >> Multiple-Selection Lists Only << -------------------- - -Click on each of the three items and make sure that "Changed" - and "Callback Ok" are printed in the console: - - * For regular MultiLists, each click should unhilite the - old selection as it hilites the new one - - * For MultiExtendLists, each click should extend the - selection. - -Click on a selected item to make sure "Changed" is printed again. - -Click "Check" and verify the item list *and* the selection list. - (Remember that the items are numbered from 0). - -Clear the selection except for one item, somehow. (You may need to use - the Ctl key) - -Use the shift key to select a second item. The console should show - "Changed" and "Callback Ok" as usual. - -Click "Check" and verify that the selection list now has the right - two items. - -Shift-click on a selected item. The console should show "Changed" - and "Callback Ok" as usual. - -Shift-click to select the remaining item. The console should show - "Changed" and "Callback Ok" as usual. - -Control-click on a selected item. It should become unselected (and the - other two selected items should remain so). The console should report - "Changed" and "Callback Ok". - -Click "Check" and verify the selection list. - -Try the "Select N" buttons. They should always extend the selection. - -Try the "by Simulate" buttons; they should should act like clicking, - either extending the selection or restarting it. - -Try dragging (and shift-dragging and ctl-dragging) and make sure the - console reports are appropriate. - diff --git a/collects/tests/mred/classhack.c b/collects/tests/mred/classhack.c deleted file mode 100644 index 85c6f2cf..00000000 --- a/collects/tests/mred/classhack.c +++ /dev/null @@ -1,149 +0,0 @@ - -#include "escheme.h" - - -/**************** Copied from plt/src/mzscheme/src/object.c **************/ -typedef long ClassVariable; - -typedef struct Scheme_Class { - Scheme_Type type; - - ClassVariable *ivars; /* Order determines order of evaluation */ - - union { - Scheme_Closed_Prim *initf; - struct { - Scheme_Instance_Init_Proc *f; - void *data; - } insti; - } piu; - short priminit; - - short pos; - struct Scheme_Class **heritage; - struct Scheme_Class *superclass; /* Redundant, but useful. */ - Scheme_Object *super_init_name; - struct Scheme_Interface *equiv_intf; /* interface implied by this class */ - - short num_args, num_required_args, num_arg_vars; - short num_ivar, num_private, num_ref; - short num_public, num_slots; /* num_vslots == num_public */ - Scheme_Object **public_names; - /* ... */ -} Scheme_Class; - -typedef struct Scheme_Interface { - Scheme_Type type; - short num_names, num_supers; - short for_class; /* 1 => impl iff subclass, 0 => normal interface */ - Scheme_Object **names; - short *name_map; /* position in names => interface slot position */ - struct Scheme_Interface **supers; /* all superinterfaces (flattened hierarchy) */ - struct Scheme_Class *supclass; - short *super_offsets; /* superinterface => super's slot position offset */ - Scheme_Object *defname; -} Scheme_Interface; - -/*************************************************************************/ - -Scheme_Object *array_to_list(int c, Scheme_Object **names) -{ - Scheme_Object *p = scheme_null; - - while (c--) - p = scheme_make_pair(names[c], p); - - return p; -} - -Scheme_Object *arrays_to_list(int c1, Scheme_Object **ns1, - int c2, Scheme_Object **ns2) - /* Merge arrays. Exploit the fact that they're both - sorted. */ -{ - Scheme_Object **ns; - int c, i1, i2; - - ns = (Scheme_Object **)scheme_malloc(sizeof(Scheme_Object*) * (c1 + c2)); - c = i1 = i2 = 0; - while ((i1 < c1) || (i2 < c2)) { - if (i1 >= c1) { - ns[c++] = ns2[i2++]; - } else if (i2 >= c2) { - ns[c++] = ns1[i1++]; - } else { - Scheme_Object *n1 = ns1[i1]; - Scheme_Object *n2 = ns2[i2]; - - if (n1 == n2) { - ns[c++] = n1; - i1++; - i2++; - } else if ((unsigned long)n1 < (unsigned long)n2) { - ns[c++] = ns1[i1++]; - } else { - ns[c++] = ns2[i2++]; - } - } - } - - return array_to_list(c, ns); -} - -Scheme_Object *class_to_names(int argc, Scheme_Object **argv) -{ - Scheme_Class *class = (Scheme_Class *)argv[0]; - - if (!SCHEME_CLASSP(argv[0])) - scheme_wrong_type("class->names", "class", 0, argc, argv); - - return array_to_list(class->num_public, class->public_names); -} - -Scheme_Object *interface_to_names(int argc, Scheme_Object **argv) -{ - Scheme_Interface *interface = (Scheme_Interface *)argv[0]; - - if (!SCHEME_INTERFACEP(argv[0])) - scheme_wrong_type("interface->names", "interface", 0, argc, argv); - - return arrays_to_list(interface->num_names, interface->names, - interface->supclass->num_public, interface->supclass->public_names); -} - -Scheme_Object *interface_to_super_interfaces(int argc, Scheme_Object **argv) -{ - Scheme_Interface *interface = (Scheme_Interface *)argv[0]; - - if (!SCHEME_INTERFACEP(argv[0])) - scheme_wrong_type("interface->super-interfaces", "interface", 0, argc, argv); - - return array_to_list(interface->num_supers, (Scheme_Object**)interface->supers); -} - - -Scheme_Object *scheme_initialize(Scheme_Env *env) -{ - return scheme_reload(env); -} - -Scheme_Object *scheme_reload(Scheme_Env *env) -{ - scheme_add_global("class->names", - scheme_make_prim_w_arity(class_to_names, - "class->names", - 1, 1), - env); - scheme_add_global("interface->names", - scheme_make_prim_w_arity(interface_to_names, - "interface->names", - 1, 1), - env); - scheme_add_global("interface->super-interfaces", - scheme_make_prim_w_arity(interface_to_super_interfaces, - "interface->super-interfaces", - 1, 1), - env); - - return scheme_void; -} diff --git a/collects/tests/mred/draw-info.txt b/collects/tests/mred/draw-info.txt deleted file mode 100644 index 3b2f03af..00000000 --- a/collects/tests/mred/draw-info.txt +++ /dev/null @@ -1,221 +0,0 @@ -The drawing area should have the following features: - - At the top-left, when the window is opened for the first time, you - shoudl see a hollow box with a line sticking out to the bottom - left. Repainting the canvas should produce instead a solid box and - no line. Repainting with Pixmap or Bitmap should always produce - the hollow box and line. - - At the top, "Pen 0 x 0" in a consistent font (i.e., re-painting - should not change the font; clicking *2 should make it twice - a big, and unclicking should restore it) - "Pen 1 x 1" in a possibly different font - "Pen 2 x 2" in a bold red font (bold version of 1x1 font) on yellow - - A line should appear across each of "Pen 0 x 0" and "Pen 1 x 1" - (if the line is missing, it was probably erased when the text - was repainted, and that is bad) - A little bit of a black line should appear before "Pen 2 x 2", but - the yellow background should have covered up the rest of the line - - To the right of the Pen text, a black and red pair of splines should - form a squashed "S", twice as wide as high. The "S" is formed by - two splines. - - Under the splines should be two blue polygons, the top with a square - hole (odd-even fill) and the bottom all solid (winding fill). The - black lines forming the polygon should be the same in each shape - (strictly on borders for the top polygon, drawn over blue in the - bottom polygon). - - To the far right should be three columns of boxes. All boxes should - have a red border and lines on a background that matches the - normal background (i.e., either white or cyan). The lines should - be black for the left colum, and green for the remaining two - columns. - - Under the three columns of boxes, a black box should be filled with - an 25% black B&W bitmap, and a red box frame should be draw with a - 50% red stipple. - - The drawings under "0 x 0" and "1 x 1" should look nearly the same: - - TopLeft: h-line should be left-aligned with box below it, but - extend 1 extra pixel. v-line similarly should be - top-aligned and 1 pixel longer. The lines should not - touch the box - there should be 2 pixels of space. - - Top: Lines for the rotated L's should join in a sharp corner - - Second from Top: like top-left, but lines should touch the box (so - only the vertical overhang is visible) - - Second from top, right: For 0x0, the X should never be more than 1 - pixel wide; this is a case where 1x1 may - be different (i.e., it may have areas - two-pixels wide) - - Four shape rows: First (solid brush, solid pen) and second (solid - brush, solid pen) columns should be the same shape, with - the first hollow and the second filled. Third (solid - brush, no pen) column should look like the second column. - The fourth column should be the xor of the first and - third columns. The precise results are ill-defined for - the "2 x 2 Pen" shapes. - - Octagons: two hollow octagons exactly the same shape. - - Dot (after octagons): a single pixel (uses draw-point) - - Another Dot (below the first one): a single pixel (created as a - 0-length line from draw-line) - - Line: actually two lines, but they should form a single - unbroken line - - Arcs: The leftmost should be the top half of an ellipse (it's - formed via two arcs); the rightmost should be a filled wedge - from 90 degrees to 180 degress. The arcs are part of an - ellipse 40 tall and 30 wide (i.e., stretched slightly in the - vertical direction from a circle). - - Big octagon: The octagon defines the region for octagin clipping. - Also, it's drawn in xor mode, so it should flip black to - white wherever the octagon line runs over the shapes of the - middle section. The bitmaps of the bottom region are drawn - afterwards, and wil therefore hide parts of the octagon - line, although the MrEd logo is also drawn in XOR mode so it - shouldn't obscure the octagon line. - - Bottom section: - - Images: MrEd logo (b & w), drawn in XOR mode, so the octagin line - should be toggled where the black part of the MrEd logo - intersects with the line. - BB logo (color) - Top subrow: - Down-left arrow (with a thin horizontal line), black on - background - Down-left arrow, red on background - Down-left arrow, red on background - Bottom subrow, on blue field in black-bordered roundrect: - Down-left arrow (with a thin horizontal line), black on - blue - Down-left arrow, red on blue - Down-left arrow, red on background (cyan or white) - BB logo, same as before - Down-left arrow - red on black - - Stippled boxes, in a blue box w/black border, four black-outlined - shapes: - Sqaure - green down-arrows on blue field - Cirle - green down-arrows on background (cyan or white) field - Square - bb logo - Square - green cross-hatch on blue - - Dashed lines: each half green and half black with the background - color (white or cyan) between the dots/dashes, two of each: - Solid line - Dot line - Long Dash line - Short Dash line - Dot Dash line - - Long line: On the screen, the line should be 1 pixel wide, except - that the last 1/9th should be two pixels wide. In postscript, - the line should consist of 9 segments, growing in width from - 0.0 to 2.0 (inclusive) in 0.25 increments. When the image - is scaled by a factor of 2, the first 1/9th on the screen - should still be 1 pixel, the next 7/9ths should be 2 pixels, - and the last 1/9 should be 4 pixels wide. - - The drawings under 2x2 should be reasonable extensions of the - 0x0 and 1x1 pictures for a double-wide pen. - -The image should look the same regardless of the top radio button -setting --- Canvas, Pixmap, or Bitmap --- except that the Bitmap -setting must produce a black-and-white image. When you go from Pixmap -+ *2 ("*2" is described next) back to Pixmap, there may be junk from -the *2 drawing left around the right and bottom. That's ok. Same for -going from Canvas + Cyan ("Cyan" is described later) to Pixmap + Cyan. - -Clicking on the "*2" checkbox should double the size of everything, -including the pen widths, but not the bitmaps. The 0x0 pen should be -the same width as before (1 pixel). - -Clicking on "+10" should shift everything 10 pixels down and across. -(Even when "*2" is checked, it should be a 10 pixel offset). - -Clicking on "Cyan" should change the background to cyan instead of -white. When Pixmap or Bitmap is used, the background will be set in -the Pixmap/Bitmap, not the canvas, so a white background should frame -the cyan area to the right and bottom (if you make the window big -enough). - -Clipping should slip the drawing to a particular shape: - - rectangle - a 10-pixel strip 100 pixels from the left - - octagon - the content of the big outlined octagon; some - part of the octagone outline is clipped - - circle - a circle inscribed in the octagon's bounding - box - - round rectangle - a rounded rect inscrobed in the the blue box for - testing stipples - - unions, intersects, subtracts - hopefully obvious - - polka - purple field with holes showing the normal drawing - -When "*2" is also clicked, the clipping region should scale -accordingly. "+10" should move the clipping region. (In either the -"*2" or "+10" case, the content of the clipped region should be the -same.) - -The "Clock" button tests a range of wedges. Each wedge has a 1-pixel - black background and orange filling. A sequence of wedges is - produced. Imagine the following: - The two hands of a clock start at 0 radians (i.e., 3:15). For each - step, the minute hand is moved back (counter-clockwise) pi/4 - radians, while the hour hand moves back pi/8 radians, and - everything between the minute hand moving counter-clockwise to the - hour hand is filled in. So after drawing the full circle on the 0th - step, the wedge includes everything except a small slice on the 1st - step. The empty slice grows ever larger while shifting - counter-clockwise. By the time the minute hand wraps to 0 radians - (at which point the hour hand is a pi radians), the wedge covers - only the top half of the clock. It keeps going until the wedge - nearly disappears (but instead of disappearing, the whole circle is - filled in again). The same pattern is then repeated, but reversing - the wedge part and empty part (so the wedge starts small and grows - larger this time around). - The orange wedge is drawn just before the bitmaps, so they appear on - top of the orange wedge, but the wegde paints over other things. If - the "Pixmap" box is checked and the "Polka" clipping region is - selected, the result is an animtation where you can only see the - wedge grow and move through the polka-dot holes in the purple field. - -The "Clip Clock" button is similar to "Clock", except that all drawing - is clipped to the area to be painted orange. "Clip Clock" clipping - overrides any other clipping setting. - -Clicking on "PostScript" should produce the image described above in a -PostScript file. - -The "icons" and "stipple" boxes enable those parts of the -drawing. These checkboxes are provided because PostScript drawing of -icons and stipples can be slow. - ----------- - -Finally, print these instructions by hitting the "Print" button at the -top of the "What Should I See?" window. The following lines are for -the printing test; they should wrap aroundneatly on the printed -page. (Don't add any newlines.) Check to make sure no lines are -skipped or duplicated across page breaks. Try different page -orientations. - -0 1 2 3 4 5 6 7 8 9 X O T T F -012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789 diff --git a/collects/tests/mred/draw.ss b/collects/tests/mred/draw.ss deleted file mode 100644 index 57203b25..00000000 --- a/collects/tests/mred/draw.ss +++ /dev/null @@ -1,780 +0,0 @@ - -(define sys-path - (lambda (f) - (build-path (collection-path "icons") f))) - -(define local-path - (let ([d (current-load-relative-directory)]) - (lambda (f) - (build-path d f)))) - -(define (get-icon) - (make-object bitmap% (sys-path "mred.xbm") 'xbm)) - -(define (show-instructions file) - (letrec ([f (make-object frame% file #f 400 400)] - [print (make-object button% "Print" f - (lambda (b ev) - (send e print)))] - [c (make-object editor-canvas% f)] - [e (make-object text%)]) - (send e load-file file) - (send e lock #t) - (send c set-editor e) - (send f show #t))) - -(define pi (atan 0 -1)) - -(define octagon - (list (make-object point% 60 60) - (make-object point% 120 60) - (make-object point% 180 120) - (make-object point% 180 180) - (make-object point% 120 240) - (make-object point% 60 240) - (make-object point% 0 180) - (make-object point% 0 120) - (make-object point% 60 60))) - -(define (get-b&w-light-stipple) - (make-object bitmap% - (list->string (map integer->char '(#x88 0 #x22 0 #x88 0 #x22 0))) - 8 8)) - -(define (get-b&w-half-stipple) - (make-object bitmap% - (list->string (map integer->char '(#xcc #x33 #xcc #x33 #xcc #x33 #xcc #x33))) - 8 8)) - -(let* ([f (make-object frame% "Graphics Test" #f 300 450)] - [vp (make-object vertical-panel% f)] - [hp0 (make-object horizontal-panel% vp)] - [hp (make-object horizontal-panel% vp)] - [hp2 hp] - [hp3 (make-object horizontal-pane% vp)] - [bb (make-object bitmap% (sys-path "bb.gif") 'gif)] - [return (let* ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)] - [dc (make-object bitmap-dc% bm)]) - (send dc draw-line 0 3 20 3) - (send dc set-bitmap #f) - bm)] - [clock-start #f] - [clock-end #f] - [clock-clip? #f] - [use-bitmap? #f] - [use-bad? #f] - [depth-one? #f] - [cyan? #f] - [clip 'none]) - (send hp0 stretchable-height #f) - (send hp stretchable-height #f) - (send hp3 stretchable-height #f) - (make-object button% "What Should I See?" hp0 - (lambda (b e) - (show-instructions (local-path "draw-info.txt")))) - (let ([canvas - (make-object - (class canvas% args - (inherit get-dc) - (public - [no-bitmaps? #f] - [set-bitmaps (lambda (on?) (set! no-bitmaps? (not on?)) (on-paint))] - [no-stipples? #f] - [set-stipples (lambda (on?) (set! no-stipples? (not on?)) (on-paint))] - [pixel-copy? #f] - [set-pixel-copy (lambda (on?) (set! pixel-copy? on?) (on-paint))] - [scale 1] - [set-scale (lambda (s) (set! scale s) (on-paint))] - [offset 0] - [set-offset (lambda (o) (set! offset o) (on-paint))]) - (override - [on-paint - (case-lambda - [() (on-paint #f)] - [(ps?) - (let* ([can-dc (get-dc)] - [pen0s (make-object pen% "BLACK" 0 'solid)] - [pen1s (make-object pen% "BLACK" 1 'solid)] - [pen2s (make-object pen% "BLACK" 2 'solid)] - [pen0t (make-object pen% "BLACK" 0 'transparent)] - [pen1t (make-object pen% "BLACK" 1 'transparent)] - [pen2t (make-object pen% "BLACK" 2 'transparent)] - [pen0x (make-object pen% "BLACK" 0 'xor)] - [pen1x (make-object pen% "BLACK" 1 'xor)] - [pen2x (make-object pen% "BLACK" 2 'xor)] - [brushs (make-object brush% "BLACK" 'solid)] - [brusht (make-object brush% "BLACK" 'transparent)] - [brushb (make-object brush% "BLUE" 'solid)] - [mem-dc (if use-bitmap? - (make-object bitmap-dc%) - #f)] - [bm (if use-bitmap? - (if use-bad? - (make-object bitmap% "no such file") - (make-object bitmap% (* scale 350) (* scale 300) depth-one?)) - #f)] - [draw-series - (lambda (dc pens pent penx size x y flevel last?) - (let* ([ofont (send dc get-font)] - [otfg (send dc get-text-foreground)] - [otbg (send dc get-text-background)] - [obm (send dc get-text-mode)]) - (if (positive? flevel) - (send dc set-font - (make-object font% - 10 'decorative - 'normal - (if (> flevel 1) - 'bold - 'normal) - #t))) - (send dc set-pen pens) - (send dc set-brush brusht) - - ; Text should overlay this line (except for 2x2) - (send dc draw-line - (+ x 3) (+ y 12) - (+ x 40) (+ y 12)) - - (send dc set-text-background (make-object color% "YELLOW")) - (when (= flevel 2) - (send dc set-text-foreground (make-object color% "RED")) - (send dc set-text-mode 'solid)) - - (send dc draw-text (string-append size " Pen") - (+ x 5) (+ y 8)) - (send dc set-font ofont) - - (when (= flevel 2) - (send dc set-text-foreground otfg) - (send dc set-text-mode obm)) - (send dc set-text-background otbg) - - (send dc draw-line - (+ x 5) (+ y 27) (+ x 10) (+ 27 y)) - (send dc draw-rectangle - (+ x 5) (+ y 30) 5 5) - (send dc draw-line - (+ x 12) (+ y 30) (+ x 12) (+ y 35)) - - (send dc draw-line - (+ x 5) (+ y 40) (+ x 10) (+ 40 y)) - (send dc draw-rectangle - (+ x 5) (+ y 41) 5 5) - (send dc draw-line - (+ x 10) (+ y 41) (+ x 10) (+ 46 y)) - - (send dc draw-line - (+ x 15) (+ y 25) (+ x 20) (+ 25 y)) - (send dc draw-line - (+ x 20) (+ y 30) (+ x 20) (+ 25 y)) - - (send dc draw-line - (+ x 30) (+ y 25) (+ x 25) (+ 25 y)) - (send dc draw-line - (+ x 25) (+ y 30) (+ x 25) (+ 25 y)) - - (send dc draw-line - (+ x 35) (+ y 30) (+ x 40) (+ 30 y)) - (send dc draw-line - (+ x 40) (+ y 25) (+ x 40) (+ 30 y)) - - (send dc draw-line - (+ x 50) (+ y 30) (+ x 45) (+ 30 y)) - (send dc draw-line - (+ x 45) (+ y 25) (+ x 45) (+ 30 y)) - - ; Check line thickness with "X" - (send dc draw-line - (+ x 20) (+ y 45) (+ x 40) (+ 39 y)) - (send dc draw-line - (+ x 20) (+ y 39) (+ x 40) (+ 45 y)) - - (send dc draw-rectangle - (+ x 5) (+ y 50) 10 10) - (send dc draw-rounded-rectangle - (+ x 5) (+ y 65) 10 10 3) - (send dc draw-ellipse - (+ x 5) (+ y 80) 10 10) - - (send dc set-brush brushs) - (send dc draw-rectangle - (+ x 17) (+ y 50) 10 10) - (send dc draw-rounded-rectangle - (+ x 17) (+ y 65) 10 10 3) - (send dc draw-ellipse - (+ x 17) (+ y 80) 10 10) - - (send dc set-pen pent) - (send dc draw-rectangle - (+ x 29) (+ y 50) 10 10) - (send dc draw-rounded-rectangle - (+ x 29) (+ y 65) 10 10 3) - (send dc draw-ellipse - (+ x 29) (+ y 80) 10 10) - - (send dc set-pen penx) - (send dc draw-rectangle - (+ x 41) (+ y 50) 10 10) - (send dc draw-rounded-rectangle - (+ x 41) (+ y 65) 10 10 3) - (send dc draw-ellipse - (+ x 41) (+ y 80) 10 10) - - (send dc set-pen pens) - (send dc draw-rectangle - (+ x 17) (+ y 95) 10 10) - ; (send dc set-logical-function 'clear) - (send dc draw-rectangle - (+ x 18) (+ y 96) 8 8) - ; (send dc set-logical-function 'copy) - - (send dc draw-rectangle - (+ x 29) (+ y 95) 10 10) - ; (send dc set-logical-function 'clear) - (send dc set-pen pent) - (send dc draw-rectangle - (+ x 30) (+ y 96) 8 8) - - (send dc set-pen pens) - (send dc draw-rectangle - (+ x 5) (+ y 95) 10 10) - ; (send dc set-logical-function 'xor) - (send dc draw-rectangle - (+ x 5) (+ y 95) 10 10) - ; (send dc set-logical-function 'copy) - - (send dc draw-line - (+ x 5) (+ y 110) (+ x 8) (+ y 110)) - (send dc draw-line - (+ x 8) (+ y 110) (+ x 11) (+ y 113)) - (send dc draw-line - (+ x 11) (+ y 113) (+ x 11) (+ y 116)) - (send dc draw-line - (+ x 11) (+ y 116) (+ x 8) (+ y 119)) - (send dc draw-line - (+ x 8) (+ y 119) (+ x 5) (+ y 119)) - (send dc draw-line - (+ x 5) (+ y 119) (+ x 2) (+ y 116)) - (send dc draw-line - (+ x 2) (+ y 116) (+ x 2) (+ y 113)) - (send dc draw-line - (+ x 2) (+ y 113) (+ x 5) (+ y 110)) - - (send dc draw-lines - (list - (make-object point% 5 95) - (make-object point% 8 95) - (make-object point% 11 98) - (make-object point% 11 101) - (make-object point% 8 104) - (make-object point% 5 104) - (make-object point% 2 101) - (make-object point% 2 98) - (make-object point% 5 95)) - (+ x 12) (+ y 15)) - - (send dc draw-point (+ x 35) (+ y 115)) - (send dc draw-line (+ x 35) (+ y 120) (+ x 35) (+ y 120)) - - (send dc draw-line - (+ x 5) (+ y 125) (+ x 10) (+ y 125)) - (send dc draw-line - (+ x 11) (+ y 125) (+ x 16) (+ y 125)) - - (send dc set-brush brusht) - (send dc draw-arc - (+ x 5) (+ y 135) - 30 40 - 0 (/ pi 2)) - (send dc draw-arc - (+ x 5) (+ y 135) - 30 40 - (/ pi 2) pi) - (send dc set-brush brushs) - (send dc draw-arc - (+ x 45) (+ y 135) - 30 40 - (/ pi 2) pi) - (send dc set-brush brusht) - - - (when last? - (let ([p (send dc get-pen)]) - (send dc set-pen (make-object pen% "BLACK" 1 'xor)) - (send dc draw-polygon octagon) - (send dc set-pen p)) - - (when clock-start - (let ([b (send dc get-brush)]) - (send dc set-brush (make-object brush% "ORANGE" 'solid)) - (send dc draw-arc 0. 60. 180. 180. clock-start clock-end) - (send dc set-brush b)))) - - (when last? - (let ([op (send dc get-pen)]) - - ; Splines - (define (draw-ess dx dy) - (send dc draw-spline - (+ dx 200) (+ dy 10) - (+ dx 218) (+ dy 12) - (+ dx 220) (+ dy 20)) - (send dc draw-spline - (+ dx 220) (+ dy 20) - (+ dx 222) (+ dy 28) - (+ dx 240) (+ dy 30))) - (send dc set-pen pen0s) - (draw-ess 0 0) - (send dc set-pen (make-object pen% "RED" 0 'solid)) - (draw-ess -2 2) - - ; Polygons: odd-even vs. winding - (let ([polygon - (list (make-object point% 12 0) - (make-object point% 40 0) - (make-object point% 40 28) - (make-object point% 0 28) - (make-object point% 0 12) - (make-object point% 28 12) - (make-object point% 28 40) - (make-object point% 12 40) - (make-object point% 12 0))] - [ob (send dc get-brush)] - [op (send dc get-pen)]) - (send dc set-pen pen1s) - (send dc set-brush (make-object brush% "BLUE" 'solid)) - (send dc draw-polygon polygon 200 40 'odd-even) - (send dc draw-polygon polygon 200 90 'winding) - (send dc set-pen op) - (send dc set-brush ob)) - - - ; Brush patterns: - (let ([pat-list (list 'bdiagonal-hatch - 'crossdiag-hatch - 'fdiagonal-hatch - 'cross-hatch - 'horizontal-hatch - 'vertical-hatch)] - [b (make-object brush% "BLACK" 'solid)] - [ob (send dc get-brush)] - [obg (send dc get-background)] - [blue (make-object color% "BLUE")]) - (let loop ([x 245][y 10][l pat-list]) - (unless (null? l) - (send b set-color "BLACK") - (send b set-style (car l)) - (send dc set-brush b) - (send dc draw-rectangle x y 20 20) - (send dc set-brush ob) - (send b set-color "GREEN") - (send dc set-brush b) - (send dc draw-rectangle (+ x 25) y 20 20) - (send dc set-background blue) - (send dc draw-rectangle (+ x 50) y 20 20) - (send dc set-background obg) - (send dc set-brush ob) - (loop x (+ y 25) (cdr l))))) - - (send dc set-pen op)) - - ; B&W 8x8 stipple: - (unless no-bitmaps? - (let ([bml (get-b&w-light-stipple)] - [bmh (get-b&w-half-stipple)] - [orig-b (send dc get-brush)] - [orig-pen (send dc get-pen)]) - (send dc set-brush brusht) - (send dc set-pen pen1s) - (send dc draw-rectangle 244 164 18 18) - (send dc draw-bitmap bml 245 165) - (send dc draw-bitmap bml 245 173) - (send dc draw-bitmap bml 253 165) - (send dc draw-bitmap bml 253 173) - - (let ([p (make-object pen% "RED" 1 'solid)]) - (send p set-stipple bmh) - (send dc set-pen p) - (send dc draw-rectangle 270 164 18 18)) - - (send dc set-brush orig-b) - (send dc set-pen orig-pen)))) - - (when last? - ; Test get-text-extent - (let ([save-pen (send dc get-pen)] - [save-fnt (send dc get-font)]) - (send dc set-pen (make-object pen% "YELLOW" 1 'xor)) - (let loop ([fam '(default default modern modern decorative roman)] - [stl '(normal slant slant italic normal normal)] - [wgt '(normal bold normal normal bold normal)] - [sze '(12 12 12 12 12 32)] - [x 244] - [y 210]) - (unless (null? fam) - (let ([fnt (make-object font% (car sze) (car fam) (car stl) (car wgt))] - [s "AgMh"]) - (send dc set-font fnt) - (send dc draw-text s x y) - (send dc set-font save-fnt) - (let-values ([(w h d a) (send dc get-text-extent s fnt)]) - (send dc draw-rectangle x y w h) - (send dc draw-line x (+ y (- h d)) (+ x w) (+ y (- h d))) - (loop (cdr fam) (cdr stl) (cdr wgt) (cdr sze) x (+ y h)))))) - (send dc set-pen save-pen))) - - ; Bitmap copying: - (when (and (not no-bitmaps?) last?) - (let ([x 5] [y 165]) - (send dc draw-bitmap (get-icon) x y 'xor) - (set! x (+ x (send (get-icon) get-width))) - (let ([black (send the-color-database find-color "BLACK")] - [red (send the-color-database find-color "RED")] - [do-one - (lambda (bm mode color) - (if (send bm ok?) - (begin - (let ([h (send bm get-height)] - [w (send bm get-width)]) - (send dc draw-bitmap-section - bm x y - 0 0 w h - mode color) - (set! x (+ x w 10)))) - (printf "bad bitmap~n")))]) - ;; BB icon - (do-one bb 'solid black) - (let ([start x]) - ;; First three return icons: - (do-one return 'solid black) - (do-one return 'solid red) - (do-one return 'opaque red) - ;; Next three, on a bluew background - (let ([end x] - [b (send dc get-brush)]) - (send dc set-brush (make-object brush% "BLUE" 'solid)) - (send dc draw-rounded-rectangle (- start 5) (+ y 15) (- end start) 15 -0.2) - (send dc set-brush b) - (set! x start) - (set! y (+ y 18)) - (do-one return 'solid black) - (do-one return 'solid red) - (do-one return 'opaque red) - (set! y (- y 18)))) - ;; Another BB icon, make sure color has no effect - (do-one bb 'solid red) - ;; Another return, blacnk on red - (let ([bg (send dc get-background)]) - (send dc set-background (send the-color-database find-color "BLACK")) - (do-one return 'opaque red) - (send dc set-background bg)) - ;; Return by drawing into color, copying color to monochrome, then - ;; monochrome back oonto canvas: - (let* ([w (send return get-width)] - [h (send return get-height)] - [color (make-object bitmap% w h)] - [mono (make-object bitmap% w h #t)] - [cdc (make-object bitmap-dc% color)] - [mdc (make-object bitmap-dc% mono)]) - (send cdc clear) - (send cdc draw-bitmap return 0 0) - (send mdc clear) - (send mdc draw-bitmap color 0 0) - (send dc draw-bitmap mono - (- x w 10) (+ y 18))) - (send dc set-pen pens)))) - - (when (and (not no-stipples?) last?) - ; Blue box as background: - (send dc set-brush brushb) - (send dc draw-rectangle 80 200 125 40) - (when (send return ok?) - (let ([b (make-object brush% "GREEN" 'solid)]) - (send b set-stipple return) - (send dc set-brush b) - ; First stipple (transparent background) - (send dc draw-rectangle 85 205 30 30) - (send dc set-brush brushs) - (send b set-style 'opaque) - (send dc set-brush b) - ; Second stipple (opaque) - (send dc draw-ellipse 120 205 30 30) - (send dc set-brush brushs) - (send b set-stipple bb) - (send dc set-brush b) - ; Third stipple (BB logo) - (send dc draw-rectangle 155 205 20 30) - (send dc set-brush brushs) - (send b set-stipple #f) - (send b set-style 'cross-hatch) - (send dc set-brush b) - ; Green cross hatch (white BG) on blue field - (send dc draw-rectangle 180 205 20 20) - (send dc set-brush brushs)))) - - (when (and pixel-copy? last? (not (or ps? (eq? dc can-dc)))) - (let* ([x 100] - [y 170] - [x2 245] [y2 188] - [w 40] [h 20] - [c (make-object color%)] - [bm (make-object bitmap% w h depth-one?)] - [mdc (make-object bitmap-dc%)]) - (send mdc set-bitmap bm) - (let iloop ([i 0]) - (unless (= i w) - (let jloop ([j 0]) - (if (= j h) - (iloop (add1 i)) - (begin - (send dc get-pixel (+ i x) (+ j y) c) - (send mdc set-pixel i j c) - (jloop (add1 j))))))) - (send dc draw-bitmap bm x2 y2) - (let ([p (send dc get-pen)] - [b (send dc get-brush)]) - (send dc set-pen (make-object pen% "BLACK" 0 'xor-dot)) - (send dc set-brush brusht) - (send dc draw-rectangle x y w h) - (send dc set-pen p) - (send dc set-brush b)))) - - (let ([styles (list 'solid - 'dot - 'long-dash - 'short-dash - 'dot-dash)] - [obg (send dc get-background)] - [red (make-object color% "RED")]) - (let loop ([s styles][y 250]) - (unless (null? s) - (let ([p (make-object pen% "GREEN" flevel (car s))]) - (send dc set-pen p) - (send dc draw-line (+ x 5) y (+ x 30) y) - (send dc set-background red) - (send dc draw-line (+ x 5) (+ 4 y) (+ x 30) (+ y 4)) - (send dc set-background obg) - (send pens set-style (car s)) - (send dc set-pen pens) - (send dc draw-line (+ x 30) y (+ x 55) y) - (send dc set-background red) - (send dc draw-line (+ x 30) (+ y 4) (+ x 55) (+ y 4)) - (send dc set-background obg) - (send dc set-pen pent) - (send pens set-style 'solid) - (loop (cdr s) (+ y 8)))))) - - (when (= flevel 2) - (let ([lens '(0 0.25 0.5 0.75 1.0 1.25 1.5 1.75 2.0)]) - (let loop ([l lens][x 10]) - (unless (null? l) - (let ([p (make-object pen% "BLACK" (car l) 'solid)]) - (send dc set-pen p) - (send dc draw-line x 300 (+ x 19) 300) - (send dc set-pen pent) - (loop (cdr l) (+ x 20))))))) - - (when (and last? (not (or ps? (eq? dc can-dc))) - (send mem-dc get-bitmap)) - (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque))) - - 'done)]) - - (send (get-dc) set-scale 1 1) - (send (get-dc) set-origin 0 0) - - (let ([dc (if ps? - (let ([dc (if (eq? ps? 'print) - (make-object printer-dc%) - (make-object post-script-dc%))]) - (and (send dc ok?) dc)) - (if (and use-bitmap?) - (begin - (send mem-dc set-bitmap bm) - mem-dc) - (get-dc)))]) - (when dc - (send dc start-doc "Draw Test") - (send dc start-page) - - (send dc set-scale scale scale) - (send dc set-origin offset offset) - - (send dc set-background - (if cyan? - (send the-color-database find-color "CYAN") - (send the-color-database find-color "WHITE"))) - - (send dc set-clipping-region #f) - (send dc clear) - - (if clock-clip? - (let ([r (make-object region% dc)]) - (send r set-arc 0. 60. 180. 180. clock-start clock-end) - (send dc set-clipping-region r)) - (let ([mk-poly (lambda () - (let ([r (make-object region% dc)]) - (send r set-polygon octagon) r))] - [mk-circle (lambda () - (let ([r (make-object region% dc)]) - (send r set-ellipse 0. 60. 180. 180.) r))] - [mk-rect (lambda () - (let ([r (make-object region% dc)]) - (send r set-rectangle 100 -25 10 400) r))]) - (case clip - [(none) (void)] - [(rect) (send dc set-clipping-rect 100 -25 10 400)] - [(poly) (send dc set-clipping-region (mk-poly))] - [(circle) (send dc set-clipping-region (mk-circle))] - [(rect+poly) (let ([r (mk-poly)]) - (send r union (mk-rect)) - (send dc set-clipping-region r))] - [(rect+circle) (let ([r (mk-circle)]) - (send r union (mk-rect)) - (send dc set-clipping-region r))] - [(poly-rect) (let ([r (mk-poly)]) - (send r subtract (mk-rect)) - (send dc set-clipping-region r))] - [(poly&rect) (let ([r (mk-poly)]) - (send r intersect (mk-rect)) - (send dc set-clipping-region r))] - [(roundrect) (let ([r (make-object region% dc)]) - (send r set-rounded-rectangle 80 200 125 40 -0.25) - (send dc set-clipping-region r))] - [(polka) - (let ([c (send dc get-background)]) - (send dc set-background (send the-color-database find-color "PURPLE")) - (send dc clear) - (send dc set-background c)) - (let ([r (make-object region% dc)] - [w 30] - [s 10]) - (let xloop ([x 0]) - (if (> x 300) - (send dc set-clipping-region r) - (let yloop ([y 0]) - (if (> y 500) - (xloop (+ x w s)) - (let ([r2 (make-object region% dc)]) - (send r2 set-ellipse x y w w) - (send r union r2) - (yloop (+ y w s)))))))) - (send dc clear)]))) - - ; check default pen/brush: - (send dc draw-rectangle 0 0 5 5) - (send dc draw-line 0 0 20 6) - - (draw-series dc pen0s pen0t pen0x "0 x 0" 5 0 0 #f) - - (draw-series dc pen1s pen1t pen1x "1 x 1" 70 0 1 #f) - - (draw-series dc pen2s pen2t pen2x "2 x 2" 135 0 2 #t) - - (unless clock-clip? - (let ([r (send dc get-clipping-region)]) - (if (eq? clip 'none) - (when r - (error 'draw-test "shouldn't have been a clipping region")) - (let*-values ([(x y w h) (send r get-bounding-box)] - [(l) (list x y w h)]) - (unless (andmap = l - (case clip - [(rect) '(100. -25. 10. 400.)] - [(poly circle poly-rect) '(0. 60. 180. 180.)] - [(rect+poly rect+circle) '(0. -25. 180. 400.)] - [(poly&rect) '(100. 60. 10. 180.)] - [(roundrect) '(80. 200. 125. 40.)] - [(polka) '(0. 0. 310. 510.)])) - (error 'draw-test "clipping region changed badly: ~a" l)))))) - - (let-values ([(w h) (send dc get-size)]) - (unless (cond - [ps? #t] - [use-bad? #t] - [use-bitmap? (and (= w (* scale 350)) (= h (* scale 300)))] - [else (= w (send this get-width)) (= h (send this get-height))]) - (error 'x "wrong size reported by get-size: ~a ~a; w & h is ~a ~a" - w h (send this get-width) (send this get-height)))) - - (send dc set-clipping-region #f) - - (send dc end-page) - (send dc end-doc))) - - 'done)])]) - (sequence (apply super-init args))) - vp)]) - (make-object radio-box% #f '("Canvas" "Pixmap" "Bitmap" "Bad") hp0 - (lambda (self event) - (set! use-bitmap? (< 0 (send self get-selection))) - (set! depth-one? (< 1 (send self get-selection))) - (set! use-bad? (< 2 (send self get-selection))) - (send canvas on-paint)) - '(horizontal)) - (make-object button% "PS" hp - (lambda (self event) - (send canvas on-paint #t))) - (make-object button% "Print" hp - (lambda (self event) - (send canvas on-paint 'print))) - (make-object check-box% "*2" hp - (lambda (self event) - (send canvas set-scale (if (send self get-value) 2 1)))) - (make-object check-box% "+10" hp - (lambda (self event) - (send canvas set-offset (if (send self get-value) 10 0)))) - (make-object check-box% "Cyan" hp - (lambda (self event) - (set! cyan? (send self get-value)) - (send canvas on-paint))) - (send (make-object check-box% "Icons" hp2 - (lambda (self event) - (send canvas set-bitmaps (send self get-value)))) - set-value #t) - (send (make-object check-box% "Stipples" hp2 - (lambda (self event) - (send canvas set-stipples (send self get-value)))) - set-value #t) - (make-object check-box% "Pixset" hp2 - (lambda (self event) - (send canvas set-pixel-copy (send self get-value)))) - (make-object choice% "Clip" - '("None" "Rectangle" "Octagon" "Circle" "Round Rectangle" - "Rectangle + Octagon" "Rectangle + Circle" - "Octagon - Rectangle" "Rectangle & Octagon" "Polka") - hp3 - (lambda (self event) - (set! clip (list-ref - '(none rect poly circle roundrect rect+poly rect+circle poly-rect poly&rect polka) - (send self get-selection))) - (send canvas on-paint))) - (let ([clock (lambda (clip?) - (thread (lambda () - (set! clock-clip? clip?) - (let loop ([c 0][swapped? #f][start 0.][end 0.]) - (if (= c 32) - (if swapped? - (void) - (loop 0 #t 0. 0.)) - (begin - (set! clock-start (if swapped? end start)) - (set! clock-end (if swapped? start end)) - (send canvas on-paint) - (sleep 0.25) - (loop (add1 c) swapped? (+ start (/ pi 8)) (+ end (/ pi 16)))))) - (set! clock-clip? #f) - (set! clock-start #f) - (set! clock-end #f) - (send canvas on-paint))))]) - (make-object button% "Clock" hp3 (lambda (b e) (clock #f))) - (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))))) - - (send f show #t)) - -; Canvas, Pixmaps, and Bitmaps: -; get-pixel -; begin-set-pixel -; end-set-pixel -; set-pixel diff --git a/collects/tests/mred/editor.ss b/collects/tests/mred/editor.ss deleted file mode 100644 index a1794d08..00000000 --- a/collects/tests/mred/editor.ss +++ /dev/null @@ -1,66 +0,0 @@ - -(when (not (defined? 'test)) - (load-relative "testing.ss")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Editor Tests ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;;;;; Undo tests - -(define e (make-object text%)) - -(stv e insert "Hello") -(st #t e is-modified?) -(stv e undo) -(st #f e is-modified?) -(stv e redo) -(st #t e is-modified?) -(stv e set-modified #f) -(st #f e is-modified?) -(stv e undo) -(st #t e is-modified?) -(stv e redo) -(st #f e is-modified?) -(stv e undo) -(st #t e is-modified?) -(stv e redo) -(st #f e is-modified?) -(stv e undo) -(stv e set-modified #f) -(st #f e is-modified?) -(stv e redo) -(st #t e is-modified?) -(st "Hello" e get-text) -(define undone? #f) -(stv e add-undo (letrec ([f (lambda () - (set! undone? #t) - (send e add-undo f) ; reinstall self! - #f)]) - f)) -(stv e undo) -(st "Hello" e get-text) -(test #t 'undone? undone?) -(stv e undo) -(st "" e get-text) -(set! undone? #f) -(stv e redo) -(st "Hello" e get-text) -(test #f 'undone? undone?) -(stv e redo) -(st "Hello" e get-text) -(test #t 'undone? undone?) -(set! undone? #f) -(stv e redo) -(st "Hello" e get-text) -(test #f 'undone? undone?) -(stv e insert "x") -(st "Hellox" e get-text) -(stv e add-undo (lambda () - (set! undone? #t) - #t)) ; do next one, too -(stv e undo) -(test #t 'undone? undone?) -(st "Hello" e get-text) - -(report-errs) diff --git a/collects/tests/mred/frame-edit.ss b/collects/tests/mred/frame-edit.ss deleted file mode 100644 index 5add33dd..00000000 --- a/collects/tests/mred/frame-edit.ss +++ /dev/null @@ -1,73 +0,0 @@ -;; this file tests frames with various edits in them - -(define testing-frame #f) - -(define test-frame/edit - (lambda (frame% edit% title) - (let* ([frame (make-object - (class frame% args - (public [get-edit% (lambda () edit%)]) - (inherit show) - (sequence (apply super-init args))))] - [edit (send frame get-edit)] - [string-good "test insert"] - [string-bad "SHOULD NOT SEE THIS"] - [get-insertion - (lambda (string) - (if (is-a? edit wx:media-edit%) - string - (let ([snip (make-object wx:media-snip%)] - [snip-e (make-object mred:media-edit%)]) - (send snip set-media snip-e) - (send snip-e insert string) - snip)))]) - (set! testing-frame frame) - (send frame set-title-prefix title) - (send frame show #t) - (send edit insert (get-insertion string-good)) - (send edit lock #t) - (send edit insert (get-insertion string-bad)) - (send edit lock #f)))) - -(define continue? #t) - -(define close-down - (lambda () - (let ([answer (mred:get-choice "Continue the test suite?" - "Yes" "No" - "connections test suite")]) - (when (send testing-frame on-close) - (send testing-frame show #f)) - (unless answer - (error 'close-down))))) - -(define-macro frame/edit - (lambda (frame% edit%) - `(when continue? - (printf "testing frame: ~a edit: ~a~n" ',frame% ',edit%) - (test-frame/edit ,frame% ,edit% (format "~a ~a" ',frame% ',edit%))))) - -(define searching-frame% (mred:make-searchable-frame% mred:simple-menu-frame%)) -(define searching-info-frame% (mred:make-searchable-frame% mred:info-frame%)) - -(frame/edit mred:pasteboard-frame% mred:pasteboard%) (close-down) -(frame/edit mred:simple-menu-frame% mred:media-edit%) (close-down) -(frame/edit searching-frame% mred:media-edit%) (close-down) - -(frame/edit mred:info-frame% mred:info-edit%) (close-down) - -(frame/edit searching-info-frame% mred:searching-edit%) -(mred:find-string (send testing-frame get-canvas) - null - 0 0 (list 'ignore-case)) -(close-down) - -(frame/edit mred:info-frame% mred:clever-file-format-edit%) (close-down) -(frame/edit mred:info-frame% mred:file-edit%) (close-down) -(frame/edit mred:info-frame% mred:backup-autosave-edit%) (close-down) -(frame/edit mred:info-frame% mred:scheme-mode-edit%) (close-down) - -(frame/edit searching-info-frame% mred:clever-file-format-edit%) (close-down) -(frame/edit searching-info-frame% mred:file-edit%) (close-down) -(frame/edit searching-info-frame% mred:backup-autosave-edit%) (close-down) -(frame/edit searching-info-frame% mred:scheme-mode-edit%) (close-down) diff --git a/collects/tests/mred/frame-steps.txt b/collects/tests/mred/frame-steps.txt deleted file mode 100644 index ec3051fd..00000000 --- a/collects/tests/mred/frame-steps.txt +++ /dev/null @@ -1,277 +0,0 @@ - -These instructions go with the "item.ss" MrEd test file. You probably -got them by clicking on the "Get Instructions" button. - -This file mostly contains instructions for running the "Make Big -Frame" and "Make Medium Frame" tests. "Big" and "Medium" are silly -names; they're essentially the same set of tests, but for different -sets of controls. There are just too many kinds of controls to fit in -one frame. - -The clock in the upper right of the "Test Selector" frame should -increment every second. - -The buttons at the bottom of the Selector frame open little frames for -testing individual control types in detail. Those frames come with -their own instructions. - -Make XXX Frame --------------- - -Big Frame should contain the following on the left: - - Message (a message) (a message) - Hello (a button) - (a button) - List (a list box) - Apple - Banana - Coconut & Donut - Check (a check box) - (a check box) - Radio (a radio box) - First - Second - Third - Image Radio (a check box) - - - Choice (a choice item) - Alpha - Beta - Gamma - Delta & Rest - Text (a text field) - initial & starting - -Medium Frame should contain: - - H Slider (a horizontal slider) - V Slider (a vertical slider) - H Gauge (a horizontal slider) - V Gauge (a vertical slider) - Text (a multi-line text field) - initial & starting - -The names on labels must match the above exactly (except that <> -indicates an image). Watch out for letters that are dropped or -&s that are dropped. - -Make sure all the controls with moving parts work. - -Tabbing and arrow keys should work correctly. The canvas in the bottom -middle area does not receive the focus via tabs in Big Frame, but it -does in Medium Frame. When it receives the focus via a tab, "Tab in" -is drawn in the canvas; when the focus leaves the canvas for any reason -(tab out, mouse click somewhere else, etc.), "Tab in" is erased. - -Window Resizing ---------------- - -Stretch the window vertically. Stretch it horizontally. Unless the -frame was created with "all stechy" on, then messages, buttons, check -boxes, and radio boxes should not stretch. Choice and text items -should only strech horizontally. Sliders and gauges should only -resize in the major direction. - -If "all stretchy" was on, then everything in the left column should -stretch both directions. - -Show and Hide -------------- - -The second column in the window starts with "Hide and Show". Click it -and see that the frame disappears and reappears. The remaining -checkboxes can be un-checked to hide items. The first two hide -everything in the left column. The remained hide the corresponding -item on the left. - -Click on the canvas at the bottom of the second column. A popup menu -should accurately report the local visibility of each control. (If a -control is shown but the panel is hidden, the menu should still say -SHOWN.) - - - * hide/show all the controls through each panel - checkbox; the menu should say SHOWN for all - items - - * click each checkbox to hide an item, then click - again to show it before moving to the next item; - check the popup menu for accuracy before and after - re-showing - - * hide all of the controls, then hide and unhide the - whole panel (one of the top checkboxes); unhiding - should not show the hidden controls; unhide one - or two to convince yourself that the panel is - unhid - - * hide the panel and unhide all of the controls; - you should not see any of them; then unhide the - panel; they should all appear - - * hide the panel; hide all the controls; unhide the - panel (the controls should not appear); unhide - all the controls - - * repeat the three steps above with the other panel checkbox - -Enable and Disable ------------------- - -The third column contains checkboxes for enabling things. Note that -each radio button has its own enabler, as well as the whole radio -box. Try each one, clicking on the item to make sure it's really -disabled. - - * enable/disable all the controls through each panel - checkbox - - * click each checkbox to disble an item; click on the - item to make sure it's disabled; recheck the checkbox; - make sure the item is re-enebaled - - * disable all the controls; disable and re-enable the - whole panel; make sure the controls are still disabled - - * disable the panel; re-enable the individual controls; - make sure the controls are still not enabled; re-enable - the panel and check that the controls are enabled - - * disbale the panel; diable all the controls; enable the - panel and make sure the controls are still disabled; - enable all the controls - - * repeat the three steps above with the other panel checkbox - - * repeat the three steps for radioboxes and radio items, - sintead of panels and controls - -Relabeling ----------- - -The buttons in the fourth column toggle the labels on items. The -control should not resize itself for the new label. - -For text labels, the new label is XXXXXXXXX. For icon labels, -it depends: - - - message: - - button: - - checbox: - -Note that radio items can't be relabelled. - -Be sure to click each button twice, to make sure that the original -label is restored. - -Cursors -------- - -Checking "Control Bullseye Cursors" should change the cursor over -every control in the left column, plus the canvas in the second -column. The cursor should only apply to the "client area" of a -control, not the label if it is outside the control. The cursor should -be normal everywhere else. - -Checking "Frame Cross Cursor" should change the cursor in the -frame to a cross. It sets the cursor for the controls only when -"Controls Bullseye Cursors" is not set. - -Checking "Busy Cursor" should change the cursor to a watch everywhere -in the frame's eventspace. It overrides all other cursor settings. - -Combinations to try: - - * Bull only - just controls changed - * Cross only - all of frame changed - * Bull + Cross - controls are bullseye, cross everywhere else - - Uncheck Cross and make sure Bull still works - - Recheck Cross, uncheck Bull and make sure Cross works on - controls - * Busy only - everywhere changed - * Busy + Cross - everywhere changed - - Uncheck Busy and make sure Cross still works - - Recheck Busy, uncheck cross and make sure Busy still works - - Uncheck Busy and make sure Cross is still off - * Busy + Bull - everywhere changed - (same as above, but for Bull) - * Busy + Bull + Cross - everywhere changed - - Uncheck Busy and verify Bull + Cross - (that's enough) - -Also, while the busy cursor is on, try creating a new Big/Medium Frame -and make sure that the busy cursor is active in the new frame and over -all controls in the new frame. - -Popup Menus (Big Frame) ------------ - -Hide something. Left-click on the canvas to see the SHOW state. -Unhide that something. RIGHT-click on the canvas to get the old - SHOW state. Then left-click to see the new SHOW state. -Left-click and pick some item; verify that the canvas shows the - select index (counting from 1) -Right-click and pick some item; verify that the canvas shows the - selected index (counting from 1) - -Focus Info ----------- - -Under "Enable Text", the current focus is show as: - label value - Sometimes label is () for null (no label) - Sometimes value is just # (no known class) -but usually you can tell what it means. - -Click on various controls. Watch how the focus changes (some controls -on some platforms never get the focus). Verify that the focus -indicator is always right. (There's about a 1 second delay.) - -Event Info ----------- - -Under the focus indicator, the last event is reported. If the label of -the destination is non-null, the label is shown, otherwise the value -is shown. - -As the mouse is moved over a control's client area, the event -indicator should report the control under the mouse and `mouse' for -mouse event. This is independent of the location of the focus. - -Press a key. Instead of `mouse', the event indicator should say `key', -and report the item that currently has the focus. (Unfortunately, -under windows, the key info is immediately replaced with mouse info.) - -Event Filtering ---------------- - -When "Drop Mouse Events" is checked at the bottom of the thrid column, -all other controls (except "Drop Mouse Events" and "Drop Key Events") -shold cease to respond to mouse events. The event indicator will still -work. Keyboard events should not be affected (though it may be hard to -get the focus somewhere interesting). - -Try every control with mouse events dropped. - -"Drop Key Events" does the obvious thing. Try every keybord-responding -control with events dropped. Try dialog navigation keys on other -controls, such as TAB or left-arrow. - -Different Configuations ------------------------ - -Each Frame can be created in several different configurations (32 or -64 of them!). - -Step through the first 16 configurations, create a frame each time, -and make sure the resulting controls look right. Resize each frame and -check stretchiness before closing it. - -Go back to the default configuration and try the 3 other combinations -of label and button fonts. The big label font should apply to external -control labels, and to message items. The button font should apply to -the content of controls (names within a button, checkbox, listbox, -choice, or text control). - diff --git a/collects/tests/mred/gauge-steps.txt b/collects/tests/mred/gauge-steps.txt deleted file mode 100644 index 7f5610b3..00000000 --- a/collects/tests/mred/gauge-steps.txt +++ /dev/null @@ -1,35 +0,0 @@ - -The gauge should be initially empty (i.e., set to 0), and have a - maximum value of 10 (although there's no indication of the maximum). - -Click "+". The gauge should go up by one. - -Click "-". It should go back down to zero. - -Click "+" five times. The gauge should be at the halfway point. - -Click "-" ten times. (Five type errors.) Click "+" once. The gauge - should be at one. - -Click "+" twelve times. (Three mismatch errors.) Click "-" once. The - gauge should be at nine. - -Click "-" four times. The gauge should be at the halfway point. - -Click "Bigger". The range is now 11 instead of 10, so the gauge - should be below halfway. - -Click "Smaller". The range is back to 10, so the gauge should be at - the halfway point. - -Click "Smaller" five times. The range is now 5, so the gauge should - be full. - -Click "Smaller" once more. The range is now 4, so the gauge value - should be 4 also. - -Click "Bigger" and the gauge should be 80% full. - -Click "Smaller" six times. (Two type errors.) The minimum gauge range - is 1, so click "Bigger" once and the gauge should be at halfway. - diff --git a/collects/tests/mred/gui-main.ss b/collects/tests/mred/gui-main.ss deleted file mode 100644 index 588b125d..00000000 --- a/collects/tests/mred/gui-main.ss +++ /dev/null @@ -1,89 +0,0 @@ -(lambda (new-name save-name console%) - (let* ([dir (current-load-relative-directory)] - [console - (let loop ([printout? #f]) - (let ([f (mred:test:get-active-frame)]) - (if (and f - (is-a? f console%)) - f - (begin - (unless printout? - (printf "please select the console~n")) - (sleep 1/2) - (loop #t)))))] - [wait - (opt-lambda (test desc-string [time 5]) - (let ([int 1/2]) - (let loop ([sofar 0]) - (cond - [(> sofar time) (error 'wait desc-string)] - [(test) (void)] - [else (sleep int) - (loop (+ sofar int))]))))] - [wait-pending - (lambda () - (wait (lambda () (= 0 (mred:test:number-pending-actions))) - "pending action sdidn't terminate") - (mred:test:reraise-error))] - [_ (mred:test:menu-select "File" new-name)] - [_ (wait-pending)] - [_ (wait (lambda () (not (eq? (mred:test:get-active-frame) console))) - "focus didn't change from the console after File|New")] - [frame (mred:test:get-active-frame)] - [_ (mred:test:keystroke #\a)] - - [_ (mred:test:menu-select "File" "Close")] - [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame)))) - "active frame remained original frame after File|Close")] - [_ (mred:test:button-push "Cancel")] - [_ (wait-pending)] - - [_ (mred:test:menu-select "File" "Close")] - [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame)))) - "active frame remained original frame after File|Close")] - [_ (mred:test:button-push "Cancel")] - [_ (wait-pending)] - - [_ (wait (lambda () (eq? frame (mred:test:get-active-frame))) - "active frame did not return to editor frame")] - [_ (mred:test:menu-select "File" "Close")] - [_ (wait (lambda () (not (eq? frame (mred:test:get-active-frame)))) - "active frame remained original frame after File|Close")] - [_ (mred:test:button-push "Close Anyway")] - [_ (wait-pending)] - - [_ (unless (mred:get-preference 'mred:autosaving-on?) - (error 'autosave "autosaving preference turned off. Turn back on (with preferences dialog)"))] - [tmp-file (build-path dir "tmp.ss")] - [backup-file (build-path dir "#tmp.ss#1#")] - [_ (call-with-output-file tmp-file - (lambda (port) (display "12" port)) - 'truncate)] - [_ (when (file-exists? backup-file) - (delete-file backup-file))] - [_ (mred:edit-file tmp-file)] - [_ (wait (lambda () (not (eq? console (mred:test:get-active-frame)))) - "after mred:edit-file, the console remained active")] - [frame (mred:test:get-active-frame)] - [_ (mred:test:keystroke #\3)] - [autosave-time (+ 10 (mred:get-preference 'mred:autosave-delay))] - [_ (printf "waiting for autosave timeout (~a secs)~n" autosave-time)] - [_ (sleep autosave-time)] - [_ (printf "finished waiting for autosave timeout~n")] - [_ (unless (file-exists? backup-file) - (error 'autosave "autosave file (~a) not created" backup-file))] - [_ (mred:test:menu-select "File" save-name)] - [_ (wait-pending)] - [_ (when (file-exists? backup-file) - (error 'autosave "autosave file (~a) not deleted after original file saved"))] - [_ (mred:test:menu-select "File" "Close")] - [_ (wait-pending)] - [_ (wait (lambda () (eq? (mred:test:get-active-frame) console)) - "focus didn't return to the console after closing autosave test frame")]) - (printf "test finished~n"))) - -; -; when rewriting, apply this function to: -; "New Unit" -; "Save Definitions" -; wx:frame% diff --git a/collects/tests/mred/gui.ss b/collects/tests/mred/gui.ss deleted file mode 100644 index 1125a133..00000000 --- a/collects/tests/mred/gui.ss +++ /dev/null @@ -1,5 +0,0 @@ -(let ([f (load-relative "gui-main.ss")]) - (thread - (lambda () - (f "New" "Save" mred:console-frame%)))) - diff --git a/collects/tests/mred/imred.ss b/collects/tests/mred/imred.ss deleted file mode 100644 index f7bda4ae..00000000 --- a/collects/tests/mred/imred.ss +++ /dev/null @@ -1,70 +0,0 @@ -(define make-invokable-unit - (lambda (application) - (compound-unit/sig (import) - (link [wx : wx^ (wx@)] - [core : mzlib:core^ (mzlib:core@)] - [mred : mred^ ((require-library "linkwx.ss" "mred") core wx)] - [application : () (application mred core wx)]) - (export (unit mred mred2))))) - -(define (go flags) - (define die? #f) - (define my-app - (unit/sig () - (import mred^ - mzlib:core^ - [wx : wx^]) - - (define app-name "Tester") - (define console (if (memq 'console flags) - (make-object console-frame%) - #f)) - (define eval-string pretty-print@:pretty-print) - (when (memq 'thread flags) - (let ([s (make-semaphore 1)] - [s2 (make-semaphore 0)] - [done (make-semaphore 0)]) - ; Use of semaphore-callback insures that thread is a child - ; of the eventspace - (semaphore-callback s - (lambda () - (semaphore-post done) - (thread (lambda () - (let loop () - (sleep 1) - (loop)))) - (when (begin0 - die? - (set! die? (not die?))) - (kill-thread (current-thread))))) ; kills handler thread - ; Add another callback that we know will not get triggered - (semaphore-callback s2 void) - (wx:yield done))) - (when (memq 'eventspace flags) - (let ([e (wx:make-eventspace)]) - (parameterize ([wx:current-eventspace e]) - (send (make-object wx:frame% null "Testing" -1 -1 100 100) - show #t)))) - (unless (memq 'force flags) - (run-exit-callbacks)))) - - (let loop () - (collect-garbage) - (collect-garbage) - (wx:yield) (sleep) (wx:yield) (sleep) - (wx:yield) (sleep) (wx:yield) (sleep) - (wx:yield) (sleep) (wx:yield) (sleep) - (wx:yield) (sleep) (wx:yield) (sleep) - (wx:yield) (sleep) (wx:yield) (sleep) - (dump-memory-stats) - (let ([custodian (make-custodian)]) - (parameterize ([current-custodian custodian] - [wx:current-eventspace - (if (memq 'force flags) - (wx:make-eventspace) - (wx:current-eventspace))]) - (invoke-unit/sig - (make-invokable-unit my-app))) - (when (memq 'force flags) - (custodian-shutdown-all custodian))) - (loop))) diff --git a/collects/tests/mred/item.ss b/collects/tests/mred/item.ss deleted file mode 100644 index c2187c7f..00000000 --- a/collects/tests/mred/item.ss +++ /dev/null @@ -1,1794 +0,0 @@ - -(require-library "core.ss") - -(define my-txt #f) -(define my-lb #f) -(define noisy? #f) - -(define mdi-frame #f) -(define (mdi) - (set! mdi-frame (make-object frame% "Item Test" #f - #f #f #f #f - '(mdi-parent))) - (send mdi-frame maximize #t) - (send mdi-frame show #t)) - -(define default-parent-frame #f) -(define (parent-frame) - (set! default-parent-frame (make-object frame% "Item Test Parent" #f - 100 100)) - (send default-parent-frame show #t)) - -(when (defined? 'mdi?) - (when mdi? - (mdi))) - -(define make-frame - (opt-lambda (% name [parent #f] [x #f] [y #f] [w #f] [h #f] [style '()]) - (make-object % name - (or parent mdi-frame default-parent-frame) - x y w h - (if mdi-frame - (cons 'mdi-child style) - style)))) - -(define special-font (send the-font-list find-or-create-font - 20 'decorative - 'normal 'bold - #f)) - -(define (make-h&s cp f) - (make-object button% "Hide and Show" cp - (lambda (b e) (send f show #f) (send f show #t)))) - -(define (add-hide name w cp) - (let ([c (make-object check-box% (format "Show ~a" name) cp - (lambda (c e) (send w show (send c get-value))))]) - (send c set-value #t))) - -(define (add-disable name w ep) - (let ([c (make-object check-box% (format "Enable ~a" name) ep - (lambda (c e) (send w enable (send c get-value))))]) - (send c set-value #t))) - -(define (add-disable-radio name w i ep) - (let ([c (make-object check-box% (format "Enable ~a" name) ep - (lambda (c e) (send w enable i (send c get-value))))]) - (send c set-value #t))) - -(define (add-change-label name w lp orig other) - (make-object button% (format "Relabel ~a" name) lp - (let ([orig-name (if orig orig (send w get-label))] - [changed? #f]) - (lambda (b e) - (if changed? - (unless (null? orig-name) - (send w set-label orig-name)) - (send w set-label other)) - (set! changed? (not changed?)))))) - -(define (add-focus-note frame panel) - (define m (make-object message% "focus: ??????????????????????????????" panel)) - (send - (make-object - (class-asi timer% - (inherit start) - (override - [notify - (lambda () - (when (send frame is-shown?) - (send m set-label - (let* ([w (with-handlers ([void (lambda (x) #f)]) - (let ([f (get-top-level-focus-window)]) - (and f (send f get-focus-window))))] - [l (and w (send w get-label))]) - (format "focus: ~a ~a" (or l "") w))) - (start 1000 #t)))]))) - start 1000 #t)) - -(define (add-pre-note frame panel) - (define m (make-object message% "pre: ??????????????????????????????" panel)) - (define cm (make-object check-box% "Drop Mouse Events" panel void)) - (define ck (make-object check-box% "Drop Key Events" panel void)) - (lambda (win e) - (let ([m? (is-a? e mouse-event%)]) - (send m set-label - (format "pre: ~a ~a" - (if m? "mouse" "key") - (let ([l (send win get-label)]) - (if (not l) - win - l)))) - (and (not (or (eq? win cm) (eq? win ck))) - (or (and m? (send cm get-value)) - (and (not m?) (send ck get-value))))))) - -(define (add-enter/leave-note frame panel) - (define m (make-object message% "enter: ??????????????????????????????" panel)) - (lambda (win e) - (when (memq (send e get-event-type) '(enter leave)) - (let ([s (format "~a: ~a" - (send e get-event-type) - (let ([l (send win get-label)]) - (if (not l) - win - l)))]) - (when noisy? (printf "~a~n" s)) - (send m set-label s))))) - -(define (add-cursors frame panel ctls) - (let ([old #f] - [f-old #f] - [bc (make-object cursor% 'bullseye)] - [cc (make-object cursor% 'cross)]) - (make-object check-box% "Control Bullseye Cursors" panel - (lambda (c e) - (if (send c get-value) - (set! old - (map (lambda (b) - (begin0 - (send b get-cursor) - (send b set-cursor bc))) - ctls)) - (map (lambda (b c) (send b set-cursor c)) - ctls old)))) - (make-object check-box% "Frame Cross Cursor" panel - (lambda (c e) - (if (send c get-value) - (begin - (set! f-old (send frame get-cursor)) - (send frame set-cursor cc)) - (send frame set-cursor f-old)))) - (make-object check-box% "Busy Cursor" panel - (lambda (c e) - (if (send c get-value) - (begin-busy-cursor) - (end-busy-cursor)))))) - -(define OTHER-LABEL "XXXXXXXXXXXXXXXXXXXXXX") - -(define-values (icons-path local-path) - (let ([d (current-load-relative-directory)]) - (values - (lambda (n) - (build-path (collection-path "icons") n)) - (lambda (n) - (build-path d n))))) - -(define on-demand-menu-item% - (class menu-item% (name . args) - (override - [on-demand - (lambda () - (printf "Menu item ~a demanded~n" name))]) - (sequence - (apply super-init name args)))) - -(define popup-test-canvas% - (class canvas% (objects names . args) - (inherit popup-menu get-dc refresh) - (public - [tab-in? #f] - [last-m null] - [last-choice #f]) - (override - [on-paint - (lambda () - (let ([dc (get-dc)]) - (send dc clear) - (send dc draw-text "Left: popup hide state" 0 0) - (send dc draw-text "Right: popup previous" 0 20) - (send dc draw-text (format "Last pick: ~s" last-choice) 0 40) - (when tab-in? - (send dc draw-text "Tab in" 0 60))))] - [on-event - (lambda (e) - (if (send e button-down?) - (let ([x (send e get-x)] - [y (send e get-y)] - [m (if (or (null? last-m) - (send e button-down? 'left)) - (let ([m (make-object popup-menu% "T&itle" - (lambda (m e) - (unless (is-a? m popup-menu%) - (error "bad menu object")) - (unless (and (is-a? e control-event%) - (memq (send e get-event-type) - '(menu-popdown menu-popdown-none))) - (error "bad event object")) - (printf "popdown ok~n")))] - [make-callback - (let ([id 0]) - (lambda () - (set! id (add1 id)) - (let ([id id]) - (lambda (m e) - (set! last-choice id) - (on-paint)))))]) - (for-each - (lambda (obj name) - (make-object menu-item% - (string-append - name ": " - (if (send obj is-shown?) - "SHOWN" - "")) - m - (make-callback))) - objects names) - (make-object on-demand-menu-item% - "[on-demand hook]" - m - void) - m) - last-m)]) - (set! last-m m) - (popup-menu m (inexact->exact x) (inexact->exact y)))))] - [on-tab-in (lambda () (set! tab-in? #t) (refresh))] - [on-focus (lambda (on?) - (when (and tab-in? (not on?)) - (set! tab-in? #f) - (refresh)))]) - (sequence - (apply super-init args)))) - -(define prev-frame #f) - -(define bitmap% - (class bitmap% args - (inherit ok?) - (sequence - (apply super-init args) - (unless (ok?) - (printf "bitmap failure: ~s~n" args))))) - -(define active-frame% - (class-asi frame% - (private - [pre-on void] - [el void]) - (rename [super-on-subwindow-event on-subwindow-event] - [super-on-subwindow-char on-subwindow-char]) - (override [on-subwindow-event (lambda args - (apply el args) - (or (apply pre-on args) - (apply super-on-subwindow-event args)))] - [on-subwindow-char (lambda args - (or (apply pre-on args) - (apply super-on-subwindow-char args)))] - [on-activate (lambda (on?) (printf "active: ~a~n" on?))] - [on-move (lambda (x y) (printf "moved: ~a ~a~n" x y))] - [on-size (lambda (x y) (printf "sized: ~a ~a~n" x y))]) - (public [set-info - (lambda (ep) - (set! pre-on (add-pre-note this ep)) - (set! el (add-enter/leave-note this ep)))]))) - -(define (trace-mixin c%) - (class c% (name . args) - (override - [on-superwindow-show - (lambda (on?) - (printf "~a ~a~n" name (if on? "show" "hide")))] - [on-superwindow-enable - (lambda (on?) - (printf "~a ~a~n" name (if on? "on" "off")))]) - (sequence - (apply super-init name args)))) - -(define (make-ctls ip cp lp add-testers ep radio-h? label-h? null-label? stretchy?) - - (define return-bmp - (make-object bitmap% (icons-path "return.xbm") 'xbm)) - (define bb-bmp - (make-object bitmap% (icons-path "bb.gif") 'gif)) - (define mred-bmp - (make-object bitmap% (icons-path "mred.xbm") 'xbm)) - (define nruter-bmp - (make-object bitmap% (local-path "nruter.xbm") 'xbm)) - - (define :::dummy::: - (when (not label-h?) - (send ip set-label-position 'vertical))) - - (define-values (l il) - (let ([p (make-object horizontal-panel% ip)]) - (send p stretchable-width stretchy?) - (send p stretchable-height stretchy?) - - (let () - (define l (make-object (trace-mixin message%) "Me&ssage" p)) - (define il (make-object (trace-mixin message%) return-bmp p)) - - (add-testers "Message" l) - (add-change-label "Message" l lp #f OTHER-LABEL) - - (add-testers "Image Message" il) - (add-change-label "Image Message" il lp return-bmp nruter-bmp) - - (values l il)))) - - (define b (make-object (trace-mixin button%) - "He&llo" ip - (lambda (b e) - (send b enable #f) - (sleep/yield 5) - (send b enable #t)))) - - (define ib (make-object (trace-mixin button%) bb-bmp ip void)) - - ; (define ib2 (make-object button% return-bmp ip void)) - - (define lb (make-object (trace-mixin list-box%) - (if null-label? #f "L&ist") - '("Apple" "Banana" "Coconut & Donuts" "Eclair" "French Fries" "Gatorade" "Huevos Rancheros") - ip void)) - - (define cb (make-object (trace-mixin check-box%) "C&heck" ip void)) - - (define icb (make-object (trace-mixin check-box%) mred-bmp ip void)) - - (define rb (make-object (trace-mixin radio-box%) - (if null-label? #f "R&adio") - '("First" "Dos" "T&rio") - ip void - (if radio-h? - '(horizontal) - '(vertical)))) - - (define irb (make-object (trace-mixin radio-box%) - (if null-label? #f "Image Ra&dio") - (list return-bmp nruter-bmp) - ip void - (if radio-h? - '(horizontal) - '(vertical)))) - - (define ch (make-object (trace-mixin choice%) - (if null-label? #f "Ch&oice") - '("Alpha" "Beta" "Gamma" "Delta & Rest") - ip void)) - - (define txt (make-object (trace-mixin text-field%) - (if null-label? #f "T&ext") - ip void - "initial & starting")) - - (set! my-txt txt) - (set! my-lb lb) - - (add-testers "Button" b) - (add-change-label "Button" b lp #f OTHER-LABEL) - - (add-testers "Image Button" ib) - (add-change-label "Image Button" ib lp bb-bmp return-bmp) - - (add-testers "List" lb) - (add-change-label "List" lb lp #f OTHER-LABEL) - - (add-testers "Checkbox" cb) - (add-change-label "Checkbox" cb lp #f OTHER-LABEL) - - (add-testers "Image Checkbox" icb) - (add-change-label "Image Checkbox" icb lp mred-bmp bb-bmp) - - (add-testers "Radiobox" rb) - (add-disable-radio "Radio Item `First'" rb 0 ep) - (add-disable-radio "Radio Item `Dos'" rb 1 ep) - (add-disable-radio "Radio Item `Trio'" rb 2 ep) - (add-change-label "Radiobox" rb lp #f OTHER-LABEL) - - (add-testers "Image Radiobox" irb) - (add-disable-radio "Radio Image Item 1" irb 0 ep) - (add-disable-radio "Radio Image Item 2" irb 1 ep) - (add-change-label "Image Radiobox" irb lp #f OTHER-LABEL) - - (add-testers "Choice" ch) - (add-change-label "Choice" ch lp #f OTHER-LABEL) - - (add-testers "Text" txt) - (add-change-label "Text" txt lp #f OTHER-LABEL) - - (let ([items (list l il - b ib - lb - cb icb - rb irb - ch - txt)] - [names (list "label" "image label" - "button" "image button" - "list box" - "checkbox" "image checkbox" - "radio box" "image radiobox" - "choice" - "text")]) - (make-object choice% - "Set Focus" - (cons "..." names) - lp - (lambda (c e) - (let ([v (send c get-selection)]) - (when (positive? v) - (send (list-ref items (sub1 v)) focus) - (send c set-selection 0))))) - (cons (make-object popup-test-canvas% - items - names - cp) - items))) - -(define (big-frame h-radio? v-label? null-label? stretchy? special-label-font? special-button-font?) - (define f (make-frame active-frame% "Tester")) - - (define hp (make-object horizontal-panel% f)) - - (define ip (make-object vertical-panel% hp)) - (define cp (make-object vertical-panel% hp)) - (define ep (make-object vertical-panel% hp)) - (define lp (make-object vertical-panel% hp)) - - (define (basic-add-testers name w) - (add-hide name w cp) - (add-disable name w ep)) - - (define add-testers - (if stretchy? - (lambda (name control) - (send control stretchable-width #t) - (send control stretchable-height #t) - (basic-add-testers name control)) - basic-add-testers)) - - (define fp (make-object vertical-panel% ip)) - - (define tp (make-object vertical-panel% fp)) - - (make-h&s cp f) - - (add-testers "Sub-panel" fp) - - (send tp set-label "Sub-sub panel") - (add-testers "Sub-sub-panel" tp) - - (when special-label-font? - (send tp set-label-font special-font)) - (when special-button-font? - (send tp set-control-font special-font)) - - (let ([ctls (make-ctls tp cp lp add-testers ep h-radio? v-label? null-label? stretchy?)]) - (add-focus-note f ep) - (send f set-info ep) - - (add-cursors f lp ctls)) - - (send f show #t) - (set! prev-frame f) - f) - -(define (med-frame plain-slider? label-h? null-label? stretchy? special-label-font? special-button-font?) - (define f2 (make-frame active-frame% "Tester2")) - - (define hp2 (make-object horizontal-panel% f2)) - - (define ip2-0 (make-object vertical-panel% hp2)) - (define cp2 (make-object vertical-panel% hp2)) - (define ep2 (make-object vertical-panel% hp2)) - (define lp2 (make-object vertical-panel% hp2)) - - (define (basic-add-testers2 name w) - (add-hide name w cp2) - (add-disable name w ep2)) - - (define add-testers2 - (if stretchy? - (lambda (name control) - (send control stretchable-width #t) - (send control stretchable-height #t) - (basic-add-testers2 name control)) - basic-add-testers2)) - - (define fp2 (make-object vertical-panel% ip2-0)) - (define ip2 (make-object vertical-panel% fp2)) - - (make-h&s cp2 f2) - - (add-testers2 "Sub-panel" fp2) - (send ip2 set-label "Sub-sub panel") - (add-testers2 "Sub-sub-panel" ip2) - - (when prev-frame - (add-disable "Previous Tester Frame" prev-frame ep2)) - - (when (not label-h?) - (send ip2 set-label-position 'vertical)) - - (when special-label-font? - (send ip2 set-label-font special-font)) - (when special-button-font? - (send ip2 set-control-font special-font)) - - (let () - (define sh (make-object slider% - (if null-label? #f "H S&lider") 0 10 ip2 - (lambda (s e) - (send gh set-value (* 10 (send sh get-value)))) - 5 - (if plain-slider? '(horizontal plain) '(horizontal)))) - - (define sv (make-object slider% - (if null-label? #f "V Sl&ider") 0 10 ip2 - (lambda (s e) - (send gv set-value (* 10 (send sv get-value)))) - 5 - (if plain-slider? '(vertical plain) '(vertical)))) - - (define gh (make-object gauge% - (if null-label? #f "H G&auge") 100 ip2 - '(horizontal))) - - (define gv (make-object gauge% - (if null-label? #f "V Ga&uge") 100 ip2 - '(vertical))) - - (define txt (make-object text-field% - (if null-label? #f "T&ext") ip2 void - "initial & starting" - '(multiple))) - - (add-testers2 "Horiz Slider" sh) - (add-testers2 "Vert Slider" sv) - (add-testers2 "Horiz Gauge" gh) - (add-testers2 "Vert Gauge" gv) - ; (add-testers2 "Text Message" cmt) - ; (add-testers2 "Image Message" cmi) - (add-testers2 "Text" txt) - - (add-change-label "Horiz Slider" sh lp2 #f OTHER-LABEL) - (add-change-label "Vert Slider" sv lp2 #f OTHER-LABEL) - (add-change-label "Horiz Gauge" gh lp2 #f OTHER-LABEL) - (add-change-label "Vert Gauge" gv lp2 #f OTHER-LABEL) - (add-change-label "Text" txt lp2 #f OTHER-LABEL) - - - (let* ([items (list sh sv - gh gv - ; cmt cmi - txt)] - [canvas (make-object popup-test-canvas% - items - (list "h slider" "v slider" - "v gauge" "v gauge" - ; "text msg" "image msg" - "text") - cp2 '(hscroll vscroll))]) - (send canvas accept-tab-focus #t) - (send canvas init-auto-scrollbars 300 300 0.0 0.0) - (add-disable "Canvas" canvas ep2) - - (add-focus-note f2 ep2) - (send f2 set-info ep2) - - (add-cursors f2 lp2 (cons canvas items))) - - (send f2 create-status-line) - (send f2 set-status-text "This is the status line") - (send f2 show #t) - (set! prev-frame f2) - f2)) - -; Need: check, check-test, and enable via menubar -; All operations on Submenus -(define f% - (class frame% args - (private - ADD-APPLE - ADD-BANANA - ADD-COCONUT - DELETE-APPLE - DELETE-EXTRA-BANANA - DELETE-BANANA - DELETE-COCONUT-0 - DELETE-COCONUT - DELETE-COCONUT-2 - COCONUT-ID - DELETE-ONCE - APPLE-CHECK-ID) - (private - menu-bar - main-menu - apple-menu - banana-menu - coconut-menu - baseball-ids - hockey-ids - enable-item) - (sequence (apply super-init args)) - (public - [make-menu-bar - (lambda () - (let* ([mb (make-object menu-bar% this)] - [menu (make-object menu% "&Tester" mb)] - [new (case-lambda - [(l help parent) (make-object menu-item% l parent callback #f help)] - [(l help) (make-object menu-item% l menu callback #f help)] - [(l) (make-object menu-item% l menu callback)])] - [sep (lambda () (make-object separator-menu-item% menu))]) - (set! menu-bar mb) - (set! main-menu menu) - - (set! ADD-APPLE (new "Add Apple" "Adds the Apple menu")) - (set! ADD-BANANA (new "Add Banana")) - (set! ADD-COCONUT (new "Add Coconut")) - - (make-object on-demand-menu-item% "Append Donut" menu - (lambda (m e) - (make-object menu-item% "Donut" apple-menu void))) - (sep) - (set! DELETE-COCONUT-0 (new "Delete Coconut")) - (make-object menu-item% "Delete Apple" menu - (lambda (m e) - (send apple-menu delete) - (set! apple-installed? #f))) - - (sep) - (set! enable-item - (make-object checkable-menu-item% "Apple Once Disabled" menu - (lambda (m e) - (send DELETE-ONCE enable - (not (send enable-item is-checked?)))))) - - (let ([mk-enable (lambda (on?) - (lambda (m e) - (let ([l (send menu-bar get-items)]) - (unless (null? (cdr l)) - (send (cadr l) enable on?)))))]) - (make-object menu-item% "Disable Second" menu (mk-enable #f)) - (make-object menu-item% "Enable Second" menu (mk-enable #t))) - - (let ([make-menu - (opt-lambda (title parent help-string) - (let ([m (make-object menu% title parent help-string)]) - (send m delete) - m))]) - (set! apple-menu (make-menu "Apple" mb #f)) - (set! banana-menu (make-menu "Banana" mb #f)) - (set! coconut-menu (make-menu "Coconut" apple-menu "Submenu"))) - - (set! COCONUT-ID coconut-menu) - - (set! DELETE-ONCE (new "Delete Once" #f apple-menu)) - (set! DELETE-APPLE (new "Delete Apple" "Deletes the Apple menu" apple-menu)) - (set! APPLE-CHECK-ID (make-object checkable-menu-item% "Checkable" apple-menu void)) - - (set! DELETE-BANANA (new "Delete Banana" #f banana-menu)) - (set! DELETE-EXTRA-BANANA (new "Delete First Banana Item" #f banana-menu)) - - (set! DELETE-COCONUT (new "Delete Coconut" #f coconut-menu)) - (set! DELETE-COCONUT-2 (new "Delete Coconut By Position" #f coconut-menu))))] - - [callback - (lambda (op ev) - (cond - [(eq? op ADD-APPLE) - (send apple-menu restore) - (set! apple-installed? #t)] - [(eq? op ADD-BANANA) - (send banana-menu restore)] - [(eq? op ADD-COCONUT) - (send coconut-menu restore)] - [(eq? op DELETE-ONCE) - (send DELETE-ONCE delete)] - [(eq? op DELETE-APPLE) - (send apple-menu delete) - (set! apple-installed? #f)] - [(eq? op DELETE-BANANA) - (send banana-menu delete)] - [(eq? op DELETE-EXTRA-BANANA) - (send (car (send banana-menu get-items)) delete)] - [(or (eq? op DELETE-COCONUT) (eq? op DELETE-COCONUT-0)) - (send COCONUT-ID delete)] - [(eq? op DELETE-COCONUT-2) - (send (list-ref (send apple-menu get-items) 3) delete)]))]) - (public - [mfp (make-object vertical-panel% this)] - [mc (make-object editor-canvas% mfp)] - [restp (make-object vertical-panel% mfp)] - [sbp (make-object horizontal-panel% restp)] - [mfbp (make-object horizontal-panel% restp)] - [lblp (make-object horizontal-panel% restp)] - [badp (make-object horizontal-panel% restp)] - [e (make-object text%)]) - (sequence - (send restp stretchable-height #f) - (send mc min-height 250) - (send mc set-editor e) - (send e load-file (local-path "menu-steps.txt"))) - (public - [make-test-button - (lambda (name pnl menu id) - (make-object button% - (format "Test ~a" name) pnl - (lambda (b e) - (message-box - "Checked?" - (if (send id is-checked?) - "yes" - "no")))))] - [compare - (lambda (expect v kind) - (unless (or (and (string? expect) (string? v) - (string=? expect v)) - (eq? expect v)) - (error 'test-compare "~a mismatch: ~s != ~s" kind expect v)))] - [check-parent - (lambda (menu id) - (unless use-menubar? - (unless (eq? (send id get-parent) menu) - (error 'check-parent "parent mismatch: for ~a, ~a != ~a" - (send id get-label) - (send menu get-label) - (send (send (send id get-parent) get-item) get-label)))))] - [label-test - (lambda (menu id expect) - (check-parent menu id) - (let ([v (send id get-label)]) - (compare expect v "label")))] - [top-label-test - (lambda (pos expect) - (let ([i (send menu-bar get-items)]) - (and (> (length i) pos) - (let ([v (send (list-ref i pos) get-label)]) - (compare expect v "top label")))))] - [help-string-test - (lambda (menu id expect) - (check-parent menu id) - (let ([v (send id get-help-string)]) - (compare expect v "help string")))] - [find-test - (lambda (menu title expect string) - (letrec ([find - (lambda (menu str) - (let ([items (send menu get-items)]) - (ormap (lambda (i) - (and (is-a? i labelled-menu-item<%>) - (equal? (send i get-plain-label) str) - i)) - items)))] - [find-item - (lambda (menu str) - (or (find menu str) - (let ([items (send menu get-items)]) - (ormap (lambda (i) - (and (is-a? i menu%) - (find-item i str))) - items))))] - [v (if use-menubar? - (let ([item (find menu-bar title)]) - (if item - (find-item item string) - -1)) - (find-item menu string))]) - (compare expect v (format "label search: ~a" string))))] - [tell-ok - (lambda () - (printf "ok~n"))] - [temp-labels? #f] - [use-menubar? #f] - [apple-installed? #f] - [via (lambda (menu) (if use-menubar? menu-bar menu))] - [tmp-pick (lambda (a b) (if temp-labels? a b))] - [apple-pick (lambda (x a b) (if (and use-menubar? (not apple-installed?)) - x - (tmp-pick a b)))]) - (sequence - (make-menu-bar) - - (send apple-menu restore) - - (make-object button% - "Delete Tester" sbp - (lambda args - (send main-menu delete))) - (make-object button% - "Delete First Menu" sbp - (lambda args - (send (car (send menu-bar get-items)) delete))) - (make-object button% - "Add Tester" sbp - (lambda args - (send main-menu restore))) - (make-object button% - "Add Delete Banana" sbp - (lambda args - (send DELETE-BANANA restore))) - (make-object button% - "Counts" sbp - (lambda args - (message-box - "Counts" - (format "MB: ~a; T: ~a; A: ~a; B: ~a" - (length (send menu-bar get-items)) - (length (send main-menu get-items)) - (length (send apple-menu get-items)) - (length (send banana-menu get-items)))))) - - (make-test-button "Apple Item" mfbp apple-menu APPLE-CHECK-ID) - (make-object button% - "Check in Apple" mfbp - (lambda args - (send APPLE-CHECK-ID check #t))) - (make-object button% - "Toggle Menubar Enable" mfbp - (lambda args - (send menu-bar enable (not (send menu-bar is-enabled?))))) - (make-object button% - "Toggle Apple Enable" mfbp - (lambda args - (send apple-menu enable (not (send apple-menu is-enabled?))))) - - (make-object button% - "Test Labels" lblp - (lambda args - (label-test (via main-menu) ADD-APPLE (tmp-pick "Apple Adder" "Add Apple")) - (help-string-test (via main-menu) ADD-APPLE (tmp-pick "ADDER" "Adds the Apple menu")) - (label-test (via apple-menu) DELETE-APPLE (apple-pick #f "Apple Deleter" "Delete Apple")) - (help-string-test (via apple-menu) DELETE-APPLE (apple-pick #f "DELETER" - "Deletes the Apple menu")) - (label-test (via apple-menu) COCONUT-ID (apple-pick #f "Coconut!" "Coconut")) - (help-string-test (via apple-menu) COCONUT-ID (apple-pick #f "SUBMENU" "Submenu")) - (label-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "Coconut Deleter" "Delete Coconut")) ; submenu test - (help-string-test (via coconut-menu) DELETE-COCONUT (apple-pick #f "CDELETER" #f)) - (top-label-test 0 (if temp-labels? "Hi" "&Tester")) - (top-label-test 1 (if apple-installed? "Apple" #f)) - (tell-ok))) - (make-object button% - "Find Labels" lblp - (lambda args - (find-test main-menu (tmp-pick "Hi" "&Tester") - ADD-APPLE (tmp-pick "Apple Adder" "Add Apple")) - (find-test apple-menu "Apple" (apple-pick -1 DELETE-APPLE DELETE-APPLE) - (tmp-pick "Apple Deleter" "Delete Apple")) - (find-test apple-menu "Apple" (apple-pick -1 COCONUT-ID COCONUT-ID) - (tmp-pick "Coconut!" "Coconut")) - (find-test apple-menu "Apple" (apple-pick -1 DELETE-COCONUT DELETE-COCONUT) - (tmp-pick "Coconut Deleter" "Delete Coconut")) - (tell-ok))) - (make-object button% - "Toggle Labels" lblp - (lambda args - (set! temp-labels? (not temp-labels?)) - (let ([menu (via main-menu)]) - (send ADD-APPLE set-label (tmp-pick "Apple Adder" "Add Apple")) - (send DELETE-APPLE set-label (tmp-pick "Apple Deleter" "Delete Apple")) - (send COCONUT-ID set-label (tmp-pick "Coconut!" "Coconut")) - (send DELETE-COCONUT set-label (tmp-pick "Coconut Deleter" "Delete Coconut")) - (send ADD-APPLE set-help-string (tmp-pick "ADDER" "Adds the Apple menu")) - (send DELETE-APPLE set-help-string (tmp-pick "DELETER" "Deletes the Apple menu")) - (send COCONUT-ID set-help-string (tmp-pick "SUBMENU" "Submenu")) - (send DELETE-COCONUT set-help-string (tmp-pick "CDELETER" #f)) - (send main-menu set-label (if temp-labels? "Hi" "&Tester"))))) - (letrec ([by-bar (make-object check-box% - "Via Menubar" lblp - (lambda args - (set! use-menubar? (send by-bar get-value))))]) - by-bar) - - #f))) - -(define (menu-frame) - (define mf (make-frame f% "Menu Test")) - (set! prev-frame mf) - (send mf show #t) - mf) - -(define (panel-frame) - (define make-p% - (lambda (panel%) - (class panel% (parent) - (override - [container-size - (lambda (l) - (values (apply + (map car l)) - (apply + (map cadr l))))] - [place-children - (lambda (l w h) - (let-values ([(mw mh) (container-size l)]) - (let* ([num-x-stretch (apply + (map (lambda (x) (if (caddr x) 1 0)) l))] - [num-y-stretch (apply + (map (lambda (x) (if (cadddr x) 1 0)) l))] - [dx (floor (/ (- w mw) num-x-stretch))] - [dy (floor (/ (- h mh) num-y-stretch))]) - (let loop ([l l][r null][x 0][y 0]) - (if (null? l) - (reverse r) - (let ([w (+ (caar l) (if (caddr (car l)) dx 0))] - [h (+ (cadar l) (if (cadddr (car l)) dy 0))]) - (loop (cdr l) - (cons (list x y w h) r) - (+ x w) (+ y h))))))))]) - (sequence (super-init parent))))) - (define f (make-frame frame% "Panel Tests")) - (define h (make-object horizontal-panel% f)) - (define kind (begin - (send h set-label-position 'vertical) - (send h set-alignment 'center 'top) - (make-object radio-box% - "Kind" - '("Panel" "Pane") - h - void))) - (define direction (make-object radio-box% - "Direction" - '("Horionztal" "Vertical" "Diagonal" "None") - h - void)) - (define h-align (make-object radio-box% - "H Alignment" - '("Left" "Center" "Right") - h - void)) - (define v-align (make-object radio-box% - "V Alignment" - '("Top" "Center" "Bottom") - h - void)) - (make-object button% "Make Container" f - (lambda (b e) (do-panel-frame - (let ([kind (send kind get-selection)] - [direction (send direction get-selection)]) - (case kind - [(0) (case direction - [(0) horizontal-panel%] - [(1) vertical-panel%] - [(2) (make-p% panel%)] - [else panel%])] - [(1) (case direction - [(0) horizontal-pane%] - [(1) vertical-pane%] - [(2) (make-p% pane%)] - [else pane%])])) - (case (send h-align get-selection) - [(0) 'left] - [(1) 'center] - [(2) 'right]) - (case (send v-align get-selection) - [(0) 'top] - [(1) 'center] - [(2) 'bottom])))) - (send f show #t)) - -(define (do-panel-frame p% va ha) - (define f (make-frame frame% "Container Test")) - (define p (make-object p% f)) - (define b (make-object button% "Add List or Bad" p - (lambda (b e) - (send p add-child - (if (send c get-value) - m1 - l))))) - (define c (make-object check-box% "Remove List" p - (lambda (c e) - (if (send c get-value) - (send p delete-child l) - (send p add-child l))))) - (define l (make-object list-box% "List Box" '("A" "B" "C") p - (lambda (l e) - (if (eq? (send e get-event-type) 'list-box) - (send p get-children) - (send p change-children reverse))))) - (define p2 (make-object vertical-panel% p '(border))) - (define m1 (make-object message% "1" p2)) - (define m2 (make-object message% "2" p2)) - (send p set-alignment va ha) - (send f show #t)) - -(define (check-callback-event orig got e types silent?) - (unless (eq? orig got) - (error "object not the same")) - (unless (is-a? e control-event%) - (error "bad event object")) - (let ([type (send e get-event-type)]) - (unless (memq type types) - (error (format "bad event type: ~a" type)))) - (unless silent? - (printf "Callback Ok~n"))) - -(define (instructions v-panel file) - (define c (make-object editor-canvas% v-panel)) - (define m (make-object text%)) - (send c set-editor m) - (send m load-file (local-path file)) - (send m lock #t) - (send c min-width 520) - (send c min-height 200)) - -(define (open-file file) - (define f (make-object frame% file #f 300 300)) - (instructions f file) - (send f show #t)) - -(define (button-frame frame% style) - (define f (make-frame frame% "Button Test")) - (define p (make-object vertical-panel% f)) - (define old-list null) - (define commands (list 'button)) - (define hit? #f) - (define b (make-object button% - "Hit Me" p - (lambda (bx e) - (set! hit? #t) - (set! old-list (cons e old-list)) - (check-callback-event b bx e commands #f)) - style)) - (define c (make-object button% - "Check" p - (lambda (c e) - (for-each - (lambda (e) - (check-callback-event b b e commands #t)) - old-list) - (printf "All Ok~n")))) - (define e (make-object button% - "Disable Test" p - (lambda (c e) - (sleep 1) - (set! hit? #f) - (let ([sema (make-semaphore)]) - (send b enable #f) - (thread (lambda () (sleep 0.5) (semaphore-post sema))) - (yield sema) - (when hit? - (printf "un-oh~n")) - (send b enable #t))))) - (instructions p "button-steps.txt") - (send f show #t)) - -(define (checkbox-frame) - (define f (make-frame frame% "Checkbox Test")) - (define p f) - (define old-list null) - (define commands (list 'check-box)) - (define cb (make-object check-box% - "On" p - (lambda (cx e) - (set! old-list (cons e old-list)) - (check-callback-event cb cx e commands #f)))) - (define t (make-object button% - "Toggle" p - (lambda (t e) - (let ([on? (send cb get-value)]) - (send cb set-value (not on?)))))) - (define t2 (make-object button% - "Simulation Toggle" p - (lambda (t e) - (let ([on? (send cb get-value)] - [e (make-object control-event% 'check-box)]) - (send cb set-value (not on?)) - (send cb command e))))) - (define c (make-object button% - "Check" p - (lambda (c e) - (for-each - (lambda (e) - (check-callback-event cb cb e commands #t)) - old-list) - (printf "All Ok~n")))) - (instructions p "checkbox-steps.txt") - (send f show #t)) - -(define (radiobox-frame) - (define f (make-frame frame% "Radiobox Test")) - (define p f) - (define old-list null) - (define commands (list 'radio-box)) - (define hp (make-object horizontal-panel% p)) - (define _ (send hp stretchable-height #f)) - (define callback (lambda (rb e) - (set! old-list (cons (cons rb e) old-list)) - (check-callback-event rb rb e commands #f))) - (define rb1-l (list "Singleton")) - (define rb1 (make-object radio-box% "&Left" rb1-l hp callback)) - (define rb2-l (list "First" "Last")) - (define rb2 (make-object radio-box% "&Center" rb2-l hp callback)) - (define rb3-l (list "Top" "Middle" "Bottom")) - (define rb3 (make-object radio-box% "&Right" rb3-l hp callback)) - - (define rbs (list rb1 rb2 rb3)) - (define rbls (list rb1-l rb2-l rb3-l)) - (define normal-sel (lambda (rb p) (send rb set-selection p))) - (define simulate-sel (lambda (rb p) - (let ([e (make-object control-event% 'radio-box)]) - (send rb set-selection p) - (send rb command e)))) - (define (mk-err exn?) - (lambda (f) - (lambda (rb p) - (with-handlers ([exn? void]) - (f rb p) - (error "no exn raisd"))))) - (define type-err (mk-err exn:application:type?)) - (define mismatch-err (mk-err exn:application:mismatch?)) - - (define do-sel (lambda (sel n) (for-each (lambda (rb) (sel rb (n rb))) rbs))) - (define sel-minus (lambda (sel) (do-sel (type-err sel) (lambda (rb) -1)))) - (define sel-first (lambda (sel) (do-sel sel (lambda (rb) 0)))) - (define sel-middle (lambda (sel) (do-sel sel (lambda (rb) (floor (/ (send rb get-number) 2)))))) - (define sel-last (lambda (sel) (do-sel sel (lambda (rb) (sub1 (send rb get-number)))))) - (define sel-N (lambda (sel) (do-sel (mismatch-err sel) (lambda (rb) (send rb get-number))))) - (define (make-selectors title sel) - (define hp2 (make-object horizontal-panel% p)) - (send hp2 stretchable-height #f) - (make-object button% (format "Select -1~a" title) hp2 (lambda (b e) (sel-minus sel))) - (make-object button% (format "Select First~a" title) hp2 (lambda (b e) (sel-first sel))) - (make-object button% (format "Select Middle ~a" title) hp2 (lambda (b e) (sel-middle sel))) - (make-object button% (format "Select Last~a" title) hp2 (lambda (b e) (sel-last sel))) - (make-object button% (format "Select N~a" title) hp2 (lambda (b e) (sel-N sel)))) - (make-selectors "" normal-sel) - (make-selectors " by Simulate" simulate-sel) - (make-object button% "Check" p - (lambda (c e) - (for-each - (lambda (rb l) - (let loop ([n 0][l l]) - (unless (null? l) - (let ([a (car l)] - [b (send rb get-item-label n)]) - (unless (string=? a b) - (error "item name mismatch: ~s != ~s" a b))) - (loop (add1 n) (cdr l))))) - rbs rbls) - (for-each - (lambda (rbe) - (check-callback-event (car rbe) (car rbe) (cdr rbe) commands #t)) - old-list) - (printf "All Ok~n"))) - (instructions p "radiobox-steps.txt") - (send f show #t)) - -(define (choice-or-list-frame list? list-style empty?) - (define f (make-frame frame% (if list? "List Test" "Choice Test"))) - (define p f) - (define-values (actual-content actual-user-data) - (if empty? - (values null null) - (values '("Alpha" "Beta" "Gamma") - (list #f #f #f)))) - (define commands - (if list? - (list 'list-box 'list-box-dclick) - (list 'choice))) - (define old-list null) - (define multi? (or (memq 'multiple list-style) - (memq 'extended list-style))) - (define callback - (lambda (cx e) - (when (zero? (send c get-number)) - (error "Callback for empty choice/list")) - (set! old-list (cons e old-list)) - (cond - [(eq? (send e get-event-type) 'list-box-dclick) - ; double-click - (printf "Double-click~n") - (unless (send cx get-selection) - (error "no selection for dclick"))] - [else - ; misc multi-selection - (printf "Changed: ~a~n" (if list? - (send cx get-selections) - (send cx get-selection)))]) - (check-callback-event c cx e commands #f))) - (define c (if list? - (make-object list-box% "Tester" actual-content p callback list-style) - (make-object choice% "Tester" actual-content p callback))) - (define counter 0) - (define append-with-user-data? #f) - (define ab (make-object button% - "Append" p - (lambda (b e) - (set! counter (add1 counter)) - (let ([naya (format "~aExtra ~a" - (if (= counter 10) - (string-append - "This is a Really Long Named Item That Would Have Used the Short Name, Yes " - "This is a Really Long Named Item That Would Have Used the Short Name ") - "") - counter)] - [naya-data (box 0)]) - (set! actual-content (append actual-content (list naya))) - (set! actual-user-data (append actual-user-data (list naya-data))) - (if (and list? append-with-user-data?) - (send c append naya naya-data) - (begin - (send c append naya) - (when list? - (send c set-data - (sub1 (send c get-number)) - naya-data)))) - (set! append-with-user-data? - (not append-with-user-data?)))))) - (define cs (when list? - (make-object button% - "Visible Indices" p - (lambda (b e) - (printf "top: ~a~nvisible count: ~a~n" - (send c get-first-visible-item) - (send c number-of-visible-items)))))) - (define cdp (make-object horizontal-panel% p)) - (define rb (make-object button% "Clear" cdp - (lambda (b e) - (set! actual-content null) - (set! actual-user-data null) - (send c clear)))) - (define (delete p) - (send c delete p) - (when (<= 0 p (sub1 (length actual-content))) - (if (zero? p) - (begin - (set! actual-content (cdr actual-content)) - (set! actual-user-data (cdr actual-user-data))) - (begin - (set-cdr! (list-tail actual-content (sub1 p)) - (list-tail actual-content (add1 p))) - (set-cdr! (list-tail actual-user-data (sub1 p)) - (list-tail actual-user-data (add1 p))))))) - (define db (if list? - (make-object button% - "Delete" cdp - (lambda (b e) - (let ([p (send c get-selection)]) - (delete p)))) - null)) - (define dab (if list? - (make-object button% - "Delete Above" cdp - (lambda (b e) - (let ([p (send c get-selection)]) - (delete (sub1 p))))) - null)) - (define dbb (if list? - (make-object button% - "Delete Below" cdp - (lambda (b e) - (let ([p (send c get-selection)]) - (delete (add1 p))))) - null)) - (define setb (if list? - (make-object button% - "Reset" cdp - (lambda (b e) - (send c set '("Alpha" "Beta" "Gamma")) - (set! actual-content '("Alpha" "Beta" "Gamma")) - (set! actual-user-data (list #f #f #f)))) - null)) - (define sel (if list? - (make-object button% - "Add Select First" cdp - (lambda (b e) - (send c select 0 #t))) - null)) - (define unsel (if list? - (make-object button% - "Unselect" cdp - (lambda (b e) - (send c select (send c get-selection) #f))) - null)) - (define (make-selectors method mname numerical?) - (define p2 (make-object horizontal-panel% p)) - (send p2 stretchable-height #f) - (when numerical? - (make-object button% - (string-append "Select Bad -1" mname) p2 - (lambda (b e) - (with-handlers ([exn:application:type? void]) - (method -1) - (error "expected a type exception"))))) - (make-object button% - (string-append "Select First" mname) p2 - (lambda (b e) - (method 0))) - (make-object button% - (string-append "Select Middle" mname) p2 - (lambda (b e) - (method (floor (/ (send c get-number) 2))))) - (make-object button% - (string-append "Select Last" mname) p2 - (lambda (b e) - (method (sub1 (send c get-number))))) - (make-object button% - (string-append "Select Bad X" mname) p2 - (lambda (b e) - (with-handlers ([exn:application:mismatch? void]) - (method (if numerical? - (send c get-number) - #f)) - (error "expected a mismatch exception")))) - #f) - (define dummy-1 (make-selectors (ivar c set-selection) "" #t)) - (define dummy-2 (make-selectors (lambda (p) - (if p - (when (positive? (length actual-content)) - (send c set-string-selection - (list-ref actual-content p))) - (send c set-string-selection "nada"))) - " by Name" - #f)) - (define dummy-3 (make-selectors (lambda (p) - (let ([e (make-object control-event% (if list? 'list-box 'choice))]) - (send c set-selection p) - (when list? (send c set-first-visible-item p)) - (send c command e))) - " by Simulate" #t)) - (define tb (make-object button% - "Check" p - (lambda (b e) - (let ([c (send c get-number)]) - (unless (= c (length actual-content)) - (error "bad number response"))) - (let loop ([n 0][l actual-content][lud actual-user-data]) - (unless (null? l) - (let ([s (car l)] - [sud (car lud)] - [sv (send c get-string n)] - [sudv (if list? - (send c get-data n) - #f)]) - (unless (string=? s sv) - (error "get-string mismatch")) - (unless (or (not list?) (eq? sud sudv)) - (error 'get-data "mismatch at ~a: ~s != ~s" - n sud sudv)) - (unless (= n (send c find-string s)) - (error "bad find-string result"))) - (loop (add1 n) (cdr l) (cdr lud)))) - (let ([bad (lambda (exn? i) - (with-handlers ([exn? void]) - (send c get-string i) - (error "out-of-bounds: no exn")))]) - (bad exn:application:type? -1) - (bad exn:application:mismatch? (send c get-number))) - (unless (not (send c find-string "nada")) - (error "find-string of nada wasn't #f")) - (for-each - (lambda (e) - (check-callback-event c c e commands #t)) - old-list) - (printf "content: ~s~n" actual-content) - (when multi? - (printf "selections: ~s~n" (send c get-selections)))))) - (send c stretchable-width #t) - (instructions p "choice-list-steps.txt") - (send f show #t)) - -(define (slider-frame) - (define f (make-frame frame% "Slider Test")) - (define p (make-object vertical-panel% f)) - (define old-list null) - (define commands (list 'slider)) - (define s (make-object slider% "Slide Me" -1 11 p - (lambda (sl e) - (check-callback-event s sl e commands #f) - (printf "slid: ~a~n" (send s get-value))) - 3)) - (define c (make-object button% "Check" p - (lambda (c e) - (for-each - (lambda (e) - (check-callback-event s s e commands #t)) - old-list) - (printf "All Ok~n")))) - (define (simulate v) - (let ([e (make-object control-event% 'slider)]) - (send s set-value v) - (send s command e))) - (define p2 (make-object horizontal-panel% p)) - (define p3 (make-object horizontal-panel% p)) - (send p3 stretchable-height #f) - (make-object button% - "Up" p2 - (lambda (c e) - (send s set-value (add1 (send s get-value))))) - (make-object button% - "Down" p2 - (lambda (c e) - (send s set-value (sub1 (send s get-value))))) - (make-object button% - "Simulate Up" p2 - (lambda (c e) - (simulate (add1 (send s get-value))))) - (make-object button% - "Simulate Down" p2 - (lambda (c e) - (simulate (sub1 (send s get-value))))) - (instructions p "slider-steps.txt") - (send f show #t)) - -(define (gauge-frame) - (define f (make-frame frame% "Gauge Test")) - (define p (make-object vertical-panel% f)) - (define g (make-object gauge% "Tester" 10 p)) - (define (move d name) - (make-object button% - name p - (lambda (c e) - (send g set-value (+ d (send g get-value)))))) - (define (size d name) - (make-object button% - name p - (lambda (c e) - (send g set-range (+ d (send g get-range)))))) - (move 1 "+") - (move -1 "-") - (size 1 "Bigger") - (size -1 "Smaller") - (instructions p "gauge-steps.txt") - (send f show #t)) - -(define (text-frame style) - (define (handler get-this) - (lambda (c e) - (unless (eq? c (get-this)) - (printf "callback: bad item: ~a~n" c)) - (let ([t (send e get-event-type)]) - (cond - [(eq? t 'text-field) - (printf "Changed: ~a~n" (send c get-value))] - [(eq? t 'text-field-enter) - (printf "Return: ~a~n" (send c get-value))])))) - - (define f (make-frame frame% "Text Test")) - (define p (make-object vertical-panel% f)) - (define t1 (make-object text-field% #f p (handler (lambda () t1)) "This should just fit!" style)) - (define t2 (make-object text-field% "Another" p (handler (lambda () t2)) "This too!" style)) - (define junk (send p set-label-position 'vertical)) - (define t3 (make-object text-field% "Catch Returns" p (handler (lambda () t3)) "And, yes, this!" - (cons 'hscroll style))) - (send t1 stretchable-width #f) - (send t2 stretchable-width #f) - (send t3 stretchable-width #f) - (send f show #t)) - -(define (canvas-frame flags) - (define f (make-frame frame% "Canvas Test" #f #f 250)) - (define p (make-object vertical-panel% f)) - (define c% (class canvas% (name swapped-name p) - (inherit get-dc get-scroll-pos get-scroll-range get-scroll-page - get-client-size get-virtual-size get-view-start) - (rename [super-init-manual-scrollbars init-manual-scrollbars] - [super-init-auto-scrollbars init-auto-scrollbars]) - (public - [auto? #f] - [incremental? #f] - [inc-mode (lambda (x) (set! incremental? x))] - [vw 10] - [vh 10] - [set-vsize (lambda (w h) (set! vw w) (set! vh h))]) - (override - [on-paint - (lambda () - (let ([s (format "V: p: ~s r: ~s g: ~s H: ~s ~s ~s" - (get-scroll-pos 'vertical) - (get-scroll-range 'vertical) - (get-scroll-page 'vertical) - (get-scroll-pos 'horizontal) - (get-scroll-range 'horizontal) - (get-scroll-page 'horizontal))] - [dc (get-dc)]) - (let-values ([(w h) (get-client-size)] - [(w2 h2) (get-virtual-size)] - [(x y) (get-view-start)]) - ; (send dc set-clipping-region 0 0 w2 h2) - (unless incremental? (send dc clear)) - (send dc draw-text (if (send ck-w get-value) swapped-name name) 3 3) - ; (draw-line 3 12 40 12) - (send dc draw-text s 3 15) - (send dc draw-text (format "client: ~s x ~s virtual: ~s x ~s view: ~s x ~s" - w h - w2 h2 - x y) - 3 27) - (send dc draw-line 0 vh vw vh) - (send dc draw-line vw 0 vw vh))))] - [on-scroll - (lambda (e) - (when auto? (printf "Hey - on-scroll called for auto scrollbars~n")) - (unless incremental? (on-paint)))] - [init-auto-scrollbars (lambda x - (set! auto? #t) - (apply super-init-auto-scrollbars x))] - [init-manual-scrollbars (lambda x - (set! auto? #f) - (apply super-init-manual-scrollbars x))]) - (sequence - (super-init p flags)))) - (define un-name "Unmanaged scroll") - (define m-name "Automanaged scroll") - (define c1 (make-object c% un-name m-name p)) - (define c2 (make-object c% m-name un-name p)) - (define (reset-scrolls for-small?) - (let* ([h? (send ck-h get-value)] - [v? (send ck-v get-value)] - [small? (send ck-s get-value)] - [swap? (send ck-w get-value)]) - (send c1 set-vsize 10 10) - (if swap? - (send c1 init-auto-scrollbars (and h? 10) (and v? 10) .1 .1) - (send c1 init-manual-scrollbars (and h? 10) (and v? 10) 3 3 1 1)) - ; (send c1 set-scrollbars (and h? 1) (and v? 1) 10 10 3 3 1 1 swap?) - (send c2 set-vsize (if small? 50 500) (if small? 20 200)) - (if swap? - (send c2 init-manual-scrollbars (if small? 2 20) (if small? 2 20) 3 3 1 1) - (send c2 init-auto-scrollbars (and h? (if small? 50 500)) (and v? (if small? 20 200)) .2 .2)) - ; (send c2 set-scrollbars (and h? 25) (and v? 10) (if small? 2 20) (if small? 2 20) 3 3 1 1 (not swap?)) - (if for-small? - ; Specifically refresh the bottom canvas - (send c2 refresh) - ; Otherwise, we have to specifically refresh the unmanaged canvas - (send (if swap? c2 c1) refresh)))) - (define p2 (make-object horizontal-panel% p)) - (define junk (send p2 stretchable-height #f)) - (define ck-v (make-object check-box% "Vertical Scroll" p2 (lambda (b e) (reset-scrolls #f)))) - (define ck-h (make-object check-box% "Horizontal Scroll" p2 (lambda (b e) (reset-scrolls #f)))) - (define ck-s (make-object check-box% "Small" p2 (lambda (b e) (reset-scrolls #t)))) - (define ck-w (make-object check-box% "Swap" p2 (lambda (b e) (reset-scrolls #f)))) - (define ip (make-object horizontal-panel% p)) - (send ip stretchable-height #f) - (make-object button% - "Get Instructions" ip - (lambda (b e) (open-file "canvas-steps.txt"))) - (make-object button% - "&1/5 Scroll" ip - (lambda (b e) (send c2 scroll 0.2 0.2))) - (make-object button% - "&4/5 Scroll" ip - (lambda (b e) (send c2 scroll 0.8 0.8))) - (make-object check-box% - "Inc" ip - (lambda (c e) - (send c1 inc-mode (send c get-value)) - (send c2 inc-mode (send c get-value)))) - (send c1 set-vsize 10 10) - (send c2 set-vsize 500 200) - (send f show #t)) - -(define (editor-canvas-oneline-frame) - (define f (make-frame frame% "x" #f 200 #f)) - - (define (try flags) - (define c (make-object editor-canvas% f #f flags)) - - (define e (make-object text%)) - - (send e insert "Xy!") - - (send c set-line-count 1) - - (send c set-editor e) - (send c stretchable-height #f)) - - (send f show #t) - - (try '(no-hscroll no-vscroll)) - (try '(no-vscroll)) - (try '(no-hscroll)) - (try '())) - -(define (minsize-frame) - (define f (make-frame frame% "x")) - - (define bp (make-object horizontal-panel% f)) - (define tb (make-object button% "Toggle Stretch" bp - (lambda (b e) - (for-each - (lambda (p) - (send p stretchable-width (not (send p stretchable-width))) - (send p stretchable-height (not (send p stretchable-height)))) - containers)))) - (define ps (make-object button% "Print Sizes" bp - (lambda (b e) - (newline) - (for-each - (lambda (p) - (let ([c (car (send p get-children))]) - (let-values ([(w h) (send c get-size)] - [(cw ch) (send c get-client-size)]) - (printf "~a: (~a x ~a) client[~a x ~a] diff<~a x ~a> min{~a x ~a}~n" - c w h cw ch - (- w cw) (- h ch) - (send c min-width) (send c min-height))))) - (reverse containers)) - (newline)))) - - (define containers null) - - (define (make-container p) - (let ([p (make-object vertical-panel% p '())]) - (send p stretchable-width #f) - (send p stretchable-height #f) - (set! containers (cons p containers)) - p)) - - (define hp0 (make-object horizontal-panel% f)) - - (define p (make-object panel% (make-container hp0))) - (define pb (make-object panel% (make-container hp0) '(border))) - - (define hp1 (make-object horizontal-panel% f)) - - (define c (make-object canvas% (make-container hp1))) - (define cb (make-object canvas% (make-container hp1) '(border))) - (define ch (make-object canvas% (make-container hp1) '(hscroll))) - (define cv (make-object canvas% (make-container hp1) '(vscroll))) - (define chv (make-object canvas% (make-container hp1) '(hscroll vscroll))) - (define cbhv (make-object canvas% (make-container hp1) '(border hscroll vscroll))) - - (define hp2 (make-object horizontal-panel% f)) - - (define ec (make-object editor-canvas% (make-container hp2) #f '(no-hscroll no-vscroll))) - (define ech (make-object editor-canvas% (make-container hp2) #f '(no-vscroll))) - (define ecv (make-object editor-canvas% (make-container hp2) #f '(no-hscroll))) - (define echv (make-object editor-canvas% (make-container hp2) #f '())) - - (send f show #t)) - -;---------------------------------------------------------------------- - -(define selector (make-frame frame% "Test Selector")) -(define ap (make-object vertical-panel% selector)) - -; Test timers while we're at it. And create the "Instructions" button. -(let ([clockp (make-object horizontal-panel% ap)] - [selector selector]) - (make-object button% "Get Instructions" clockp - (lambda (b e) - (open-file "frame-steps.txt"))) - (make-object vertical-panel% clockp) ; filler - (let ([time (make-object message% "XX:XX:XX" clockp)]) - (make-object - (class timer% () - (inherit start) - (override - [notify - (lambda () - (let* ([now (seconds->date (current-seconds))] - [pad (lambda (pc d) - (let ([s (number->string d)]) - (if (= 1 (string-length s)) - (string-append pc s) - s)))] - [s (format "~a:~a:~a" - (pad " " (let ([h (modulo (date-hour now) 12)]) - (if (zero? h) - 12 - h))) - (pad "0" (date-minute now)) - (pad "0" (date-second now)))]) - (send time set-label s) - (when (send selector is-shown?) - (start 1000 #t))))]) - (sequence - (super-init) - (start 1000 #t)))))) - -(define bp (make-object vertical-panel% ap '(border))) -(define bp1 (make-object horizontal-panel% bp)) -(define bp2 (make-object horizontal-pane% bp)) -(define mp (make-object vertical-panel% ap '(border))) -(define mp1 (make-object horizontal-panel% mp)) -(define mp2 (make-object horizontal-pane% mp)) - -(send bp1 set-label-position 'vertical) -(send mp1 set-label-position 'vertical) - -(define pp (make-object horizontal-pane% ap)) -(send bp stretchable-height #f) -(make-object button% "Make Menus Frame" pp (lambda (b e) (menu-frame))) -(make-object horizontal-pane% pp) -(make-object button% "Make Panel Frame" pp (lambda (b e) (panel-frame))) -(make-object horizontal-pane% pp) -(make-object button% "Editor Canvas One-liners" pp (lambda (b e) (editor-canvas-oneline-frame))) -(make-object horizontal-pane% pp) -(make-object button% "Minsize Windows" pp (lambda (b e) (minsize-frame))) -(define bp (make-object horizontal-pane% ap)) -(send bp stretchable-width #f) -(make-object button% "Make Button Frame" bp (lambda (b e) (button-frame frame% null))) -(make-object button% "Make Default Button Frame" bp (lambda (b e) (button-frame frame% '(border)))) -(make-object button% "Make Button Dialog" bp (lambda (b e) (button-frame dialog% null))) -(define crp (make-object horizontal-pane% ap)) -(send crp stretchable-height #f) -(make-object button% "Make Checkbox Frame" crp (lambda (b e) (checkbox-frame))) -(make-object vertical-pane% crp) ; filler -(make-object button% "Make Radiobox Frame" crp (lambda (b e) (radiobox-frame))) -(define cp (make-object horizontal-pane% ap)) -(send cp stretchable-width #f) -(make-object button% "Make Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #f))) -(make-object button% "Make Empty Choice Frame" cp (lambda (b e) (choice-or-list-frame #f null #t))) -(define lp (make-object horizontal-pane% ap)) -(send lp stretchable-width #f) -(make-object button% "Make List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #f))) -(make-object button% "Make Empty List Frame" lp (lambda (b e) (choice-or-list-frame #t '(single) #t))) -(make-object button% "Make MultiList Frame" lp (lambda (b e) (choice-or-list-frame #t '(multiple) #f))) -(make-object button% "Make MultiExtendList Frame" lp (lambda (b e) (choice-or-list-frame #t '(extended) #f))) -(define gsp (make-object horizontal-pane% ap)) -(send gsp stretchable-height #f) -(make-object button% "Make Gauge Frame" gsp (lambda (b e) (gauge-frame))) -(make-object vertical-pane% gsp) ; filler -(make-object button% "Make Slider Frame" gsp (lambda (b e) (slider-frame))) -(define tp (make-object horizontal-pane% ap)) -(send tp stretchable-width #f) -(make-object button% "Make Text Frame" tp (lambda (b e) (text-frame '(single)))) -(make-object button% "Make Multitext Frame" tp (lambda (b e) (text-frame '(multiple)))) - -(define cnp (make-object horizontal-pane% ap)) -(send cnp stretchable-width #t) -(send cnp set-alignment 'right 'center) -(let ([mkf (lambda (flags name) - (make-object button% - (format "Make ~aCanvas Frame" name) cnp - (lambda (b e) (canvas-frame flags))))]) - (mkf '(hscroll vscroll) "HV") - (mkf '(hscroll) "H") - (mkf '(vscroll) "V") - (mkf null "") - (make-object grow-box-spacer-pane% cnp)) - -(define (choose-next radios) - (let loop ([l radios]) - (let* ([c (car l)] - [rest (cdr l)] - [n (send c number)] - [v (send c get-selection)]) - (if (< v (sub1 n)) - (send c set-selection (add1 v)) - (if (null? rest) - (map (lambda (c) (send c set-selection 0)) radios) - (begin - (send c set-selection 0) - (loop rest))))))) - -(define make-next-button - (lambda (p l) - (make-object button% - "Next Configuration" p - (lambda (b e) (choose-next l))))) - -(define make-selector-and-runner - (lambda (p1 p2 radios? size maker) - (define radio-h-radio - (make-object radio-box% - (if radios? "Radio Box Orientation" "Slider Style") - (if radios? '("Vertical" "Horizontal") '("Numbers" "Plain")) - p1 void)) - (define label-h-radio - (make-object radio-box% "Label Orientation" '("Vertical" "Horizontal") - p1 void)) - (define label-null-radio - (make-object radio-box% "Optional Labels" '("Use Label" "No Label") - p1 void)) - (define stretchy-radio - (make-object radio-box% "Stretchiness" '("Normal" "All Stretchy") - p1 void)) - (define label-font-radio - (make-object radio-box% "Label Font" '("Normal" "Big") - p1 void)) - (define button-font-radio - (make-object radio-box% "Control Font" '("Normal" "Big") - p1 void)) - (define next-button - (make-next-button p2 (list radio-h-radio label-h-radio label-null-radio - stretchy-radio label-font-radio button-font-radio))) - (define go-button - (make-object button% (format "Make ~a Frame" size) p2 - (lambda (b e) - (maker - (positive? (send radio-h-radio get-selection)) - (positive? (send label-h-radio get-selection)) - (positive? (send label-null-radio get-selection)) - (positive? (send stretchy-radio get-selection)) - (positive? (send label-font-radio get-selection)) - (positive? (send button-font-radio get-selection)))))) - #t)) - -(make-selector-and-runner bp1 bp2 #t "Big" big-frame) -(make-selector-and-runner mp1 mp2 #f "Medium" med-frame) - -(send selector show #t) diff --git a/collects/tests/mred/media.mre b/collects/tests/mred/media.mre deleted file mode 100644 index 00a6badb..00000000 Binary files a/collects/tests/mred/media.mre and /dev/null differ diff --git a/collects/tests/mred/mediastream.example b/collects/tests/mred/mediastream.example deleted file mode 100644 index 2cfe56f5..00000000 Binary files a/collects/tests/mred/mediastream.example and /dev/null differ diff --git a/collects/tests/mred/mediastream.ss b/collects/tests/mred/mediastream.ss deleted file mode 100644 index a4c8a261..00000000 --- a/collects/tests/mred/mediastream.ss +++ /dev/null @@ -1,60 +0,0 @@ - -(define out-base (make-object wx:media-stream-out-string-base%)) -(define out (make-object wx:media-stream-out% out-base)) - -(define items (list 10 3.5 100 0 -1 -100 -3.5 "howdy")) - -(define (write-all) - (for-each - (lambda (i) - (send out put i)) - items)) - -(write-all) - -(let ([start (send out tell)]) - (send out put-fixed 100) - (write-all) - (let ([end (send out tell)]) - (send out jump-to start) - (send out put-fixed 99) - (send out jump-to end) - (send out put "End Second"))) - -(define file (send out-base get-string)) - -(define in-base (make-object wx:media-stream-in-string-base% file)) -(define in (make-object wx:media-stream-in% in-base)) - -(define (test expected got) - (unless (equal? expected got) - (error 'media-stream-test "expected ~s, got ~s~n" expected got))) - -(define (read-all) - (for-each - (lambda (i) - (test i - (cond - [(string? i) (send in get-string)] - [(inexact? i) (send in get-inexact)] - [else (send in get-exact)]))) - items)) -(read-all) -(test 99 (let ([b (box 0)]) - (send in get-fixed b) - (unbox b))) -(read-all) -(test "End Second" (send in get-string)) - -(define example-file-name (build-path (current-load-relative-directory) "mediastream.example")) -(define expect (if (file-exists? example-file-name) - (with-input-from-file example-file-name - (lambda () - (read-string (+ (string-length file) 10)))) - (begin - (fprintf (current-error-port) "Warning: ~a does not exist; creating it.~n" example-file-name) - (with-output-to-file example-file-name - (lambda () (display file))) - file))) -(unless (string=? file expect) - (error "generated file does not match expected file")) diff --git a/collects/tests/mred/mem.ss b/collects/tests/mred/mem.ss deleted file mode 100644 index 10a43808..00000000 --- a/collects/tests/mred/mem.ss +++ /dev/null @@ -1,281 +0,0 @@ - -; run with mred -u -- -f mem.ss - -(define source-dir (current-load-relative-directory)) - -(define num-times 8) -(define num-threads 3) - -(define dump-stats? #f) - -(define edit? #t) -(define insert? #t) -(define load-file? #f) ; adds a lot of messy objects - -(define menus? #t) -(define atomic? #t) -(define offscreen? #t) -(define frame? #t) - -(define subwindows? #t) - -(define allocated '()) -(define (remember tag v) - (set! allocated - (cons (cons tag (make-weak-box v)) - allocated)) - v) - -(when subwindows? - (global-defined-value - 'sub-collect-frame - (make-object frame% "sub-collect")) - (global-defined-value - 'sub-collect-panel - (make-object panel% sub-collect-frame))) - -(define permanent-ready? #f) -(define mb-lock (make-semaphore 1)) - -(define htw (make-hash-table-weak)) - -(send sub-collect-frame show #t) - -(define (get-panel% n) - (case (modulo n 3) - [(0) panel%] - [(1) vertical-panel%] - [(2) horizontal-panel%])) - -(define (get-pane% n) - (case (modulo n 6) - [(0) pane%] - [(1) vertical-pane%] - [(2) horizontal-pane%] - [else (get-panel% n)])) - -(define (get-image n) - (build-path (collection-path "icons") - (case (modulo n 4) - [(0) "mini-plt.xpm"] - [(1) "lock.gif"] - [(2) "help.bmp"] - [(3) "return.xbm"]))) - -(define (maker id n) - (sleep) - (collect-garbage) - (collect-garbage) - (printf "Thread: ~s Cycle: ~s~n" id n) - ; (dump-object-stats) - ; (if (and dump-stats? (= id 1)) - ; (dump-memory-stats)) - (unless (zero? n) - (let ([tag (cons id n)]) - (let* ([edit (remember tag (make-object text%))] - [ef (let ([f (make-object frame% "Editor Frame")]) - (send (make-object editor-canvas% f) set-editor edit) - (remember tag f))] - [c (make-custodian)] - [es (parameterize ([current-custodian c]) - (make-eventspace))]) - - (when edit? - (send ef show #t) - (sleep 0.1)) - - (parameterize ([current-eventspace es]) - (send (remember - tag - (make-object - (class timer% args - (override [notify void]) - (sequence (apply super-init args))))) - start 100)) - - (if frame? - (let* ([f (remember tag - (make-object (if (even? n) - frame% - dialog%) - "Tester" #f 200 200))] - [cb (lambda (x y) f)] - [p (remember tag (make-object (get-pane% n) f))]) - (remember tag (make-object canvas% f)) - (when (zero? (modulo n 3)) - (thread (lambda () (send f show #t))) - (let loop () (sleep) (unless (send f is-shown?) (loop)))) - (remember tag (make-object button% "one" p cb)) - (let ([class check-box%]) - (let loop ([m 10]) - (unless (zero? m) - (remember (cons tag m) - (make-object class "another" p cb)) - (loop (sub1 m))))) - (remember tag (make-object check-box% "check" p cb)) - (remember tag (make-object choice% "choice" '("a" "b" "c") p cb)) - (remember tag (make-object list-box% "list" '("apple" "banana" "coconut") - p cb)) - (remember tag (make-object button% "two" p cb)) - (send f show #f))) - - (if subwindows? - (let ([p (make-object (get-panel% n) sub-collect-frame)] - [cv (make-object canvas% sub-collect-frame)] - [add-objects - (lambda (p tag hide?) - (let ([b (let* ([x #f] - [bcb (lambda (a b) x)]) - (set! x (make-object button% "one" p bcb)) - x)] - [c (make-object check-box% "check" p void)] - [co (make-object choice% "choice" '("a" "b" "c") p void)] - [cv (make-object canvas% p)] - [lb (make-object list-box% "list" '("apple" "banana" "coconut") p void)]) - (when hide? - (send p delete-child b) - (send p delete-child c) - (send p delete-child cv) - (send p delete-child co) - (send p delete-child lb)) - (remember tag b) - (remember tag c) - (remember tag cv) - (remember tag co) - (remember tag lb)))]) - (add-objects sub-collect-panel (cons 'sc1 tag) #t) - (add-objects p (cons 'sc2 tag) #f) - (remember (cons 'sc0 tag) p) - (remember (cons 'sc0 tag) cv) - (send sub-collect-frame delete-child p) - (send sub-collect-frame delete-child cv))) - - (if (and edit? insert?) - (let ([e edit]) - (when load-file? - (send e load-file (build-path source-dir "mem.ss"))) - (let loop ([i 20]) - (send e insert (number->string i)) - (unless (zero? i) - (loop (sub1 i)))) - (let ([s (make-object editor-snip%)]) - (send (send s get-editor) insert "Hello!") - (send e insert s)) - (send e insert #\newline) - (send e insert "done") - (send e set-modified #f))) - - (when menus? - (let ([f (remember tag (make-object frame% "MB Frame 0"))]) - (remember tag (make-object menu% "TM1" (remember (cons 'q tag) (make-object menu-bar% f))))) - (let* ([mb (remember tag (make-object menu-bar% ef))] - [m (remember tag (make-object menu% "Ok" mb))]) - (remember tag (make-object menu-item% "Hi" m void)) - (remember tag - (make-object checkable-menu-item% - "Checkable" - (remember tag (make-object menu% "Hello" m)) - void)) - (let ([i (remember tag (make-object menu-item% "Delete Me" m void))]) - (send i delete))) - - (when subwindows? - (unless permanent-ready? - (semaphore-wait mb-lock) - (unless (send sub-collect-frame get-menu-bar) - (let ([mb (make-object menu-bar% sub-collect-frame)]) - (make-object menu% "Permanent" mb))) - (set! permanent-ready? #t) - (semaphore-post mb-lock)) - (let* ([mb (send sub-collect-frame get-menu-bar)] - [mm (car (send mb get-items))]) - (send (remember (cons 'm tag) (make-object menu-item% "Delete Me" mm void)) delete) - (let ([m (remember tag (make-object menu% "Temporary" mb))]) - (remember (cons 't tag) (make-object menu-item% "Temp Hi" m void)) - (send m delete))))) - - (when atomic? - (let loop ([m 8]) - (unless (zero? m) - (remember (cons tag m) (make-object point% n m)) - (let ([br (make-object brush%)]) - (remember (cons tag m) br) - (hash-table-put! htw br 'ok)) - (remember (cons tag m) (make-object pen%)) - (loop (sub1 m))))) - - (when offscreen? - (let ([m (remember tag (make-object bitmap-dc%))] - [b0 (remember (cons tag 'f) (make-object bitmap% (get-image n)))] - [b (remember (cons tag 'u) (make-object bitmap% 100 100))] - [b2 (remember (cons tag 'x) (make-object bitmap% 100 100))]) - (unless (send b0 ok?) - (error "bitmap load error")) - (send m set-bitmap b))) - - (when edit? - (send ef show #f)) - - (custodian-shutdown-all c) - - (collect-garbage) - - (maker id (sub1 n)))))) - -(define (still) - (map (lambda (x) - (let ([v (weak-box-value (cdr x))]) - (if v - (printf "~s ~s~n" (car x) v)))) - allocated) - (void)) - -(define (xthread f) - (f)) - -(define (stw t n) - '(thread-weight t (floor (/ (thread-weight t) n)))) - -(define (breakable t) - (if #f - (thread (lambda () - (read) - (printf "breaking~n") - (break-thread t) - (thread-wait t) - (printf "done~n"))) - (void))) - -(define (do-test) - (let ([sema (make-semaphore)]) - (let loop ([n num-threads]) - (unless (zero? n) - (breakable - (thread (lambda () - (stw (current-thread) n) - (dynamic-wind - void - (lambda () (maker n num-times)) - (lambda () (semaphore-post sema)))))) - (loop (sub1 n)))) - (let loop ([n num-threads]) - (unless (zero? n) - (yield sema) - (loop (sub1 n))))) - - (collect-garbage) - (collect-garbage) - (let loop ([n 100]) - (if (zero? n) 0 (sub1 (loop (sub1 n))))) - (collect-garbage) - (collect-garbage) - (still) - (when subwindows? - (set! sub-collect-frame #f) - (set! sub-collect-panel #f)) - (when dump-stats? - (dump-memory-stats) - (still))) - -(do-test) - diff --git a/collects/tests/mred/menu-steps.txt b/collects/tests/mred/menu-steps.txt deleted file mode 100644 index 42bee5ee..00000000 --- a/collects/tests/mred/menu-steps.txt +++ /dev/null @@ -1,104 +0,0 @@ -Instructions: - Initial Setup: - - Second menu is enabled "Apple" - Delete Apple - Add Apple - apple menu appears - Delete Tester (button) - Delete First Menu (button) - empty menu bar - Add Tester (button) - Add Apple - Delete Tester - Add Tester - tester now the second menu - Delete Apple - only tester left - - Menu Inserting & Deleting: - Add Apple - apple menu appears - Add Banana - banana menu appears - Delete Apple (from apple menu) - apple menu goes, banana menu still there - Delete Banana - back to starting point - Add Apple - Add Banana - Delete Banana - apple still there - Delete Apple - Add Apple - Add Coconut - coconut submenu appears - Delete Coconut (from sub-menu) - coconut submenu gone - Delete Apple - Add Coconut - Add Apple - apple menu appears with coconut already - Delete Apple - Delete Coconut - Add Apple - apple menu appears without coconut - - Menu Enabling: - Disable Second - apple menu gray & unselectable - Enable Second - back to normal - Disable Second - Delete Apple (from tester menu) - Add Apple - still gray - Enable Second - - Item Enabling: - Disable Apple Once Item -> once item grayed & unselectable - Un-Disable Apple Once Item -> once item normal - Disable Apple Once Item - Delete Apple - Add Apple -> once item still gray - Un-Disable Apple Once Item - Delete Apple - Disable Apple Once Item - Add Apple -> once item gray again - Un-Disable Apple Once Item - - Item Inserting & Deleting: - Append Donut - donut item added - Delete Once - once item disappears - Delete Apple - Add Apple - once item still gone - Append Donut - another donut - Delete Apple - Append Donut - Add Apple - three donuts total - - Emptying a Menu - Add Banana - Delete First Banana Item (in Banana Menu) - one left - Delete First Banana Item - none left - Add Delete Banana - one item again - Add Delete Banana - still one item - Delete Banana - - Checkable Items & Insertions: - Test Apple Item -> "no" - Apple | Checkable - on - Test Apple Item -> "yes" - Delete Apple - Test Apple Item -> "yes" - Add Apple - Apple | Checkable - off - Test Apple Item -> "no" - Delete Apple - Test Apple Item -> "no" - Check in Apple (Button) - Test Apple Item -> "yes" - Add Apple - Apple | Checkable - off - Check in Apple (Button) - check is on - Test Apple Item -> "yes" - Apple | Checkable - off - Delete Apple - - Labels (Apple & Banana currently deleted): - Add Coconut - (coconut item needed for the rest) - Test Labels - "ok" in console - Find Labels - "ok" in console - Toggle Labels - "Tester" -> "Hi", "Add Apple" -> "Apple Adder" - Add Apple - check that "Delete Apple" -> "Apple Deleter" - Delete Apple - Test Labels - "ok" in console - Find Labels - "ok" in console - Toggle Labels - original labels - Add Apple - check for original labels - Toggle Labels - "Delete Apple" -> "Apple Deleter" - Toggle Labels - Delete Apple diff --git a/collects/tests/mred/nruter.xbm b/collects/tests/mred/nruter.xbm deleted file mode 100644 index 9e74923d..00000000 --- a/collects/tests/mred/nruter.xbm +++ /dev/null @@ -1,4 +0,0 @@ -#define nruter_width 6 -#define nruter_height 9 -static char nruter_bits[] = { - 0x1e,0x1f,0x03,0x03,0x27,0x3e,0x3c,0x3c,0x3e}; diff --git a/collects/tests/mred/paramz.ss b/collects/tests/mred/paramz.ss deleted file mode 100644 index 18530ccc..00000000 --- a/collects/tests/mred/paramz.ss +++ /dev/null @@ -1,33 +0,0 @@ - -(when (not (defined? 'test)) - (load-relative "testing.ss")) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Parameterization Tests ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Killing an eventspace -(define c (make-custodian)) -(define e (parameterize ([current-custodian c]) (make-eventspace))) -(parameterize ([current-eventspace e]) (send (make-object frame% "x" #f 50 50) show #t)) -(test #f 'shutdown? (eventspace-shutdown? e)) -(custodian-shutdown-all c) -(test #t 'shutdown? (eventspace-shutdown? e)) -(define (try-use-es t) - (test - 'error - 'shutdown-eventspace - (with-handlers ([(lambda (x) - (and (exn:misc? x) - (regexp-match "shutdown" (exn-message x)))) - (lambda (x) - (printf "got expected error: ~a~n" (exn-message x)) - 'error)]) - (parameterize ([current-eventspace e]) - (t))))) -(try-use-es (lambda () (make-object frame% "x" #f 50 50))) -(try-use-es (lambda () (make-object dialog% "x" #f 50 50))) -(try-use-es (lambda () (make-object timer%))) -(try-use-es (lambda () (queue-callback void))) - -(report-errs) diff --git a/collects/tests/mred/radiobox-steps.txt b/collects/tests/mred/radiobox-steps.txt deleted file mode 100644 index da4304f9..00000000 --- a/collects/tests/mred/radiobox-steps.txt +++ /dev/null @@ -1,31 +0,0 @@ - -You should see three radioboxes: - "Left" with one radio button: "Singleton" - "Center" with two radio button: "First" and "Last" - "Right" with three radio button: "Top", "Middle", and "Bottom" - -Click the "Check" button. "All Ok" should appear in the console. - -Click each radio button once. For each click, "Callback Ok" - should be printed in the console, even if the radio button - is already selected. - -Click the "Check" button. "All Ok" should appear in the console. - -Select the first button in all radio boxes. - -Click "Select First", "Select Middle", "Select Last" then - "Select First" again. The appropriate button should become selected - in all radioboxes each time. (For the two-button box, the - second one counts as `middle'.) - -Click "Select -1" and "Select N". Nothing should happen (because the - appropriate exceptions are caught). Select the last button in each - box and try "Select -1" again. Nothing should happen. Return the - selection to the first item in each box. - -Repeat the two steps for the "Select XXX by Simulate" buttons. In this - case, "Callback Ok" should be printed three times when any button - is hit. The selection should move appropriately. - -Click the "Check" button. diff --git a/collects/tests/mred/random.ss b/collects/tests/mred/random.ss deleted file mode 100644 index 3c535b6f..00000000 --- a/collects/tests/mred/random.ss +++ /dev/null @@ -1,1028 +0,0 @@ - -; (require-library "errortrace.ss" "errortrace") -(require-library "core.ss") - -(define example-list% - (class object% (name-in parents [filter (lambda (x) (not (void? x)))]) - (public - [name name-in] - [items '()] - [num-items 0] - [baddies null] - - [parents-count - (if parents - (map (lambda (parent) - (ivar parent count)) - parents) - '())] - [parents-choose - (if parents - (map (lambda (parent) - (ivar parent choose-example)) - parents) - '())] - [choose-parent-example - (lambda (which) - (let loop ([pos which][counts parents-count][chooses parents-choose]) - (if (null? counts) - (void) - (let ([c ((car counts))]) - (if (< pos c) - ((car chooses) pos) - (loop (- pos c) (cdr counts) (cdr chooses)))))))] - - [count - (lambda () (+ num-items (apply + (map (lambda (x) (x)) parents-count))))] - [set-filter - (lambda (f) - (set! filter f))] - [prepare values] - [set-prepare - (lambda (f) - (set! prepare f))] - [add - (lambda (x) - (if (filter x) - (begin - (set! num-items (add1 num-items)) - (set! items (cons x items))) - (error 'add "rejected: ~a in: ~a" x name)))] - [all-examples - (lambda () - (apply append items (map (lambda (p) (send p all-examples)) parents)))] - [choose-example - (opt-lambda ([which #f]) - (let ([n (if which - which - (let ([c (count)]) - (if (zero? c) - 0 - (random c))))]) - (if (< n num-items) - (prepare (list-ref items n)) - (choose-parent-example (- n num-items)))))] - [add-bad - (lambda (i) - (set! baddies (cons i baddies)))] - [bad-examples - (lambda () baddies)]) - (sequence (super-init)))) - -(define boxed-example-list% - (class object% (parent) - (public - [name `(boxed ,(ivar parent name))] - [all-examples - (lambda () - (let ([l (map box (send parent all-examples))]) - l))] - [choose-example - (opt-lambda ([which #f]) - (let ([ex (send parent choose-example)]) - (if (void? ex) - (void) - (box ex))))] - [bad-examples - (lambda () (cons 5 (map box (send parent bad-examples))))]) - (sequence (super-init)))) - -(define listed-example-list% - (class object% (parent) - (public - [name `(listed ,(ivar parent name))] - [all-examples - (lambda () - (let ([l (map list (send parent all-examples))]) - l))] - [add - (lambda (v) - (unless (list? v) - (error 'add "rejected: ~a in: ~a" v name)) - (for-each - (lambda (i) - (send parent add i)) - v))] - [choose-example - (opt-lambda ([which #f]) - (let ([ex (send parent choose-example)]) - (if (void? ex) - (void) - (list ex))))] - [bad-examples - (lambda () - (cons 5 (map list (send parent bad-examples))))]) - (sequence (super-init)))) - -(define optional-example-list% - (class object% (parent val) - (public - [name `(optional ,(ivar parent name))] - [all-examples - (lambda () - (let ([l (map box (send parent all-examples))]) - (cons val l)))] - [add - (lambda (x) - (and x (send parent add x)))] - [choose-example - (opt-lambda ([which #f]) - (if (zero? (random 2)) - val - (send parent choose-example)))] - [bad-examples - (lambda () (cons #t (send parent bad-examples)))]) - (sequence (super-init)))) - -(define choose-example-list% - (class object% (parents) - (public - [name `(choose ,(map (lambda (p) (ivar p name)) parents))] - [all-examples - (lambda () - (apply append (map (lambda (p) (send p all-examples)) parents)))] - [add void] - [choose-example - (opt-lambda ([which #f]) - (send (list-ref parents (random (length parents))) - choose-example which))] - [bad-examples - (lambda () null)]) - (sequence (super-init)))) - -(define unknown-example-list% - (class object% (who) - (public - [name `(unknown ,who)] - [all-examples (lambda () null)] - [add void] - [choose-example - (opt-lambda ([which #f]) - (format "[dummy for ~a]" name))] - [bad-examples - (lambda () null)]) - (sequence (super-init)))) - -(define discrete-example-list% - (class object% (vals) - (public - [name `(one-of ,@vals)] - [all-examples (lambda () vals)] - [add (lambda (x) (unless (member x vals) - (error '|add in discrete-example-list| - "no good: ~a" x)))] - [choose-example - (opt-lambda ([which #f]) - (list-ref vals (random (length vals))))] - [bad-examples - (lambda () - (if (member 'bad-example-symbol vals) - null - (list 'bad-example-symbol)))]) - (sequence (super-init)))) - -(define number-example-list% - (class object% (parent start end) - (public - [name `(number in ,start ,end)] - [all-examples - (lambda () - (filter ok (send parent all-examples)))] - [ok (lambda (v) (<= start v end))] - [add (lambda (v) - (send parent add v) - (unless (ok v) - (error 'add "rejected (late): ~a in: ~a" v name)))] - [choose-example - (opt-lambda ([which #f]) - (let loop () - (let ([v (send parent choose-example which)]) - (if (ok v) - v - (loop)))))] - [bad-examples - (lambda () - (list* (sub1 start) - (if (= (add1 end) end) - (- start 2) - (add1 end)) - (send parent bad-examples)))]) - (sequence (super-init)))) - -(define-struct (fatal-exn struct:exn) ()) - -(define (fatal-error name str . args) - (raise (make-fatal-exn (apply format (string-append "~a: " str) name args) - ((debug-info-handler))))) - -(define trying-class #f) -(define trying-method #f) - -(define null-results null) - -(define-macro define-main - (lambda list - (let loop ([l list][rest '()]) - (if (null? l) - (cons 'begin rest) - (loop (cdr l) - (let* ([first (car l)] - [name (if (symbol? first) - first - (car first))] - [strname (symbol->string name)] - [bases (if (symbol? first) - () - (cdr first))] - [el-name (lambda (s) - (if s - (string->symbol - (string-append - (symbol->string s) - "-example-list")) - #f))]) - (append - `((define ,(el-name name) - (make-object example-list% - ',name - (list ,@(map el-name bases)) - (lambda (v) (when (null? v) - (set! null-results (cons (list trying-class trying-method ',name) - null-results)) - (error ',name "got null")))))) - (if (or (regexp-match "%$" strname) (regexp-match "<%>$" strname)) - `((send ,(el-name name) set-filter (lambda (x) (is-a? x ,name))) - (send ,(el-name name) add-bad 5)) - null) - rest))))))) - -(define-main - void - (value char real string-list subarea<%>) - char - ubyte - integer - integer-list - symbol - real - real-list - string - string-list - boolean - procedure - eventspace - - (area<%> window<%> subarea<%> area-container<%>) - - (subarea<%> subwindow<%> pane%) - - (window<%> subwindow<%> area-container-window<%>) - - (area-container<%> area-container-window<%> pane%) - - (subwindow<%> control<%> canvas<%> panel%) - - (area-container-window<%> top-level-window<%> panel%) - - (control<%> message% button% check-box% slider% gauge% text-field% radio-box% list-control<%>) - - (list-control<%> choice% list-box%) - - (top-level-window<%> frame% dialog%) - - (pane% horizontal-pane% vertical-pane% grow-box-spacer-pane%) - - (panel% horizontal-panel% vertical-panel%) - - (canvas<%> canvas% editor-canvas%) - - message% - button% - check-box% - slider% - gauge% - text-field% - radio-box% - - choice% - list-box% - - canvas% - editor-canvas% - - horizontal-pane% - vertical-pane% - grow-box-spacer-pane% - - horizontal-panel% - vertical-panel% - - frame% - dialog% - - point% - - ps-setup% - - color% - font% - brush% - pen% - region% - - font-list% - pen-list% - brush-list% - color-database<%> - font-name-directory<%> - - cursor% - bitmap% - - (event% control-event% scroll-event% mouse-event% key-event%) - control-event% - scroll-event% - mouse-event% - key-event% - - (dc<%> bitmap-dc% post-script-dc% printer-dc%) - bitmap-dc% - post-script-dc% - printer-dc% - - (menu-item-container<%> menu% menu-bar% popup-menu%) - - popup-menu% - menu-bar% - - (menu-item<%> separator-menu-item% labelled-menu-item<%>) - (labelled-menu-item<%> selectable-menu-item<%> menu%) - (selectable-menu-item<%> menu-item% checkable-menu-item%) - separator-menu-item% - menu-item% - checkable-menu-item% - - menu% - - timer% - - add-color<%> - mult-color<%> - style-delta% - style<%> - style-list% - - (editor-admin% editor-snip-editor-admin<%>) - editor-snip-editor-admin<%> - snip-admin% - - (editor<%> text% pasteboard%) - text% - pasteboard% - - (snip% string-snip% image-snip% editor-snip%) - (string-snip% tab-snip%) - tab-snip% - image-snip% - editor-snip% - - snip-class% - snip-class-list<%> - - editor-data% - editor-data-class% - editor-data-class-list<%> - - keymap% - editor-wordbreak-map% - - (editor-stream-in-base% editor-stream-in-string-base%) - (editor-stream-out-base% editor-stream-out-string-base%) - - editor-stream-in-string-base% - editor-stream-out-string-base% - - editor-stream-in% - editor-stream-out% - - clipboard<%> - clipboard-client%) - -(send bitmap%-example-list set-filter (lambda (bm) (send bm ok?))) - -; Avoid stuck states in random testing: -(send frame%-example-list set-prepare (lambda (w) (send w enable #t) w)) -(send dialog%-example-list set-prepare (lambda (w) (send w enable #t) w)) - -(send boolean-example-list set-filter boolean?) -(send char-example-list set-filter char?) -(send string-example-list set-filter string?) -(send symbol-example-list set-filter symbol?) -(send real-example-list set-filter real?) -(send integer-example-list set-filter (lambda (x) (and (number? x) (exact? x) (integer? x)))) -(send integer-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (exact? x) (integer? x))) x)))) -(send real-list-example-list set-filter (lambda (x) (and (list? x) (andmap (lambda (x) (and (number? x) (real? x))) x)))) - -(define false-example-list (make-object example-list% 'false '())) -(send false-example-list add #f) -(send false-example-list add-bad #t) - -(send char-example-list add-bad 'not-a-char) -(send string-example-list add-bad 'not-a-string) -(send symbol-example-list add-bad "not a symbol") -(send real-example-list add-bad 4+5i) -(send integer-example-list add-bad 5.0) -(send integer-list-example-list add-bad 7) -(send real-list-example-list add-bad 7.0) - -(define empty-list-example-list (make-object example-list% 'empty-list '())) -(send empty-list-example-list add null) -(send empty-list-example-list add-bad #f) - -(send* boolean-example-list - (add #t) - (add #f)) - -(send* integer-example-list - (add 0) (add 0) (add 0) (add 0) - (add 0) (add 0) (add 0) (add 0) - (add 0) (add 0) (add 0) (add 0) - (add 0) (add 0) (add 0) (add 0) - (add -1) - (add -2) - (add -3) - (add -1000) - (add 1) - (add 2) - (add 3) - (add 4) - (add 5) - (add 6) - (add 7) - (add 8) - (add 9) - (add 10) - (add 16) - (add 32) - (add 64) - (add 128) - (add 256) - (add 255) - (add 1023) - (add 1000)) - -(send* real-example-list - (add 0.0) (add 0.0) - (add -1.0) - (add -2.0) - (add -1000.0) - (add 1.0) - (add 2.0) - (add 256.0) - (add +inf.0) - (add -inf.0) - (add 2/3) - (add -100/9)) - -(define non-negative-integer-example-list (make-object number-example-list% integer-example-list 0 +inf.0)) -(define positive-integer-example-list (make-object number-example-list% integer-example-list 1 +inf.0)) - -(define non-negative-real-example-list (make-object number-example-list% real-example-list 0 +inf.0)) -(define positive-integer-example-list (make-object number-example-list% real-example-list 1e-200 +inf.0)) - -(define (range-integer-example-list s e) - (make-object number-example-list% integer-example-list s e)) - -(define (range-real-example-list s e) - (make-object number-example-list% real-example-list s e)) - -(send* symbol-example-list - (add 'ok) (add 'change-family)) - -(send* string-list-example-list - (add '("apple" "banana" "coconut"))) - -(send* char-example-list - (add #\nul) - (add #\a) - (add #\1) - (add #\newline) - (add #\tab) - (add #\z) - (add #\C)) - -(send* real-example-list - (add 0.) - (add 0.) - (add 0.) - (add -1.) - (add -2.) - (add -3.) - (add -1000.) - (add 1.) - (add 2.) - (add 3.) - (add 1000.) - (add 5)) - -(send* string-example-list - (add "") - (add "hello") - (add "system/mred.xbm") - (add "system/mred.bmp") - (add "mred.gif") - (add "goodbye adious see you later zai jian seeya bye-bye")) - -(send procedure-example-list add void) - -(define classinfo (make-hash-table)) - -(define (add-all-combinations example-list items) - (for-each - (lambda (i) (send example-list add i)) - (let loop ([items items]) - (cond - [(null? (cdr items)) items] - [else (let ([l (loop (cdr items))]) - (append - (map (lambda (x) (bitwise-ior (car items) x)) l) - l))])))) - -(define (optional v l) (make-object optional-example-list% l v)) -(define (boxed l) (make-object boxed-example-list% l)) -(define (unknown s) (make-object unknown-example-list% s)) -(define (choice . l) (make-object choose-example-list% l)) -(define (style-list . l) (make-object listed-example-list% (make-object discrete-example-list% l))) -(define (symbol-in l) (make-object discrete-example-list% l)) - -(load-relative "windowing-classes.ss") -(load-relative "drawing-classes.ss") -(load-relative "editor-classes.ss") - -(define (get-args l) - (let/ec bad - (let loop ([l l]) - (if (null? l) - '() - (let* ([source (car l)] - [value (send source choose-example #f)]) - (if (void? value) - (bad (format "no examples: ~a" (ivar source name))) - (cons value (loop (cdr l))))))))) - -(define (get-all-args l) - (let loop ([l l]) - (if (null? l) - '() - (let* ([source (car l)] - [values (send source all-examples)] - [rest (loop (cdr l))]) - (if (null? (cdr l)) - (list values) - (apply append - (map (lambda (other) - (map (lambda (v) (cons v other)) values)) - rest))))))) - -(define-struct posargs (good bads)) - -(define (get-bad-args l) - (let/ec bad - (let loop ([l l]) - (if (null? l) - '() - (let* ([source (car l)] - [good (send source choose-example #f)] - [bads (send source bad-examples)]) - (if (void? good) - (bad (format "no examples: ~a" (ivar source name))) - (cons (make-posargs good bads) (loop (cdr l))))))))) - -(define thread-output-port current-output-port) - -(define print-only? #f) - -(define (apply-args v dest name k) - (if (list? v) - (begin - (fprintf (thread-output-port) "~a: ~s" name v) - (flush-output (thread-output-port)) - (if print-only? - (newline) - (with-handlers (((lambda (x) (not (fatal-exn? x))) - (lambda (x) - (fprintf (thread-output-port) - ": error: ~a~n" - (exn-message x))))) - (if (eq? dest 'values) - (k v) - (send dest add (k v))) - (flush-display) - (fprintf (thread-output-port) ": success~n")))) - (fprintf (thread-output-port) "~a: failure: ~a~n" name v))) - -(define (try-args arg-types dest name k) - (apply-args (get-args arg-types) dest name k)) - -(define (try-all-args arg-types dest name k) - (let ([vs (get-all-args arg-types)]) - (for-each (lambda (v) - (apply-args v dest name k)) - vs))) - -(define (apply-bad-args v dest name k bad) - (fprintf (thread-output-port) "~a: ~s" name v) - (flush-output (thread-output-port)) - (with-handlers ([exn:application:type? - (lambda (x) - (fprintf (thread-output-port) ": exn: ~a~n" - (exn-message x)) - ;; Check for expected bad value in exn record - (unless (eqv? bad (exn:application-value x)) - (if (or (and (box? bad) (eqv? (unbox bad) (exn:application-value x))) - (and (pair? bad) (null? (cdr bad)) - (eqv? (car bad) (exn:application-value x)))) - (fprintf (thread-output-port) - " BOX/PAIR CONTEXT MISMATCH: ~a~n" bad) - (fprintf (thread-output-port) - " EXN CONTENT MISMATCH: ~a != ~a~n" - (exn:application-value x) bad))) - ;; Check that exn is from the right place: - (let ([class (if (list? name) - (let ([n (car name)]) - (if (symbol? n) - n - '|.|)) - name)] - [method (if (list? name) (cadr name) 'initialization)]) - (when (eq? method 'initialization) - ; init is never inherited, so class name really should be present - (unless (regexp-match (symbol->string class) (exn-message x)) - (fprintf (thread-output-port) - " NO OCCURRENCE of class name ~a in the error message~n" - class))) - (unless (regexp-match (symbol->string method) (exn-message x)) - (fprintf (thread-output-port) - " NO OCCURRENCE of method ~a in the error message~n" - method))))] - [exn:application:arity? - (lambda (x) - (fprintf (thread-output-port) - ": UNEXPECTED ARITY MISMATCH: ~a~n" - (exn-message x)))] - [(lambda (x) (not (fatal-exn? x))) - (lambda (x) - (fprintf (thread-output-port) - ": WRONG EXN TYPE: ~a~n" - (exn-message x)))]) - (k v) - (flush-display) - (fprintf (thread-output-port) ": NO EXN RAISED~n"))) - -(define (try-bad-args arg-types dest name k) - (let ([args (get-bad-args arg-types)]) - (cond - [(not (list? args)) (fprintf (thread-output-port) "~a: failure in bad-testing: ~a~n" name args)] - [else - (let loop ([pres null][posts args]) - (unless (null? posts) - (for-each - (lambda (bad) - (apply-bad-args (append - (map posargs-good pres) - (list bad) - (map posargs-good (cdr posts))) - dest name k bad)) - (posargs-bads (car posts))) - (loop (append pres (list (car posts))) (cdr posts))))]))) - -(define (create-some cls try) - (when (class? cls) - (let* ([v (hash-table-get classinfo cls)] - [dest (car v)] - [name (cadr v)] - [creators (caddr v)]) - (let loop ([l creators]) - (unless (null? l) - (try (car l) dest name - (lambda (v) - (apply make-object cls v))) - (loop (cdr l))))))) - -(define (create-all-random) - (fprintf (thread-output-port) "creating all randomly...~n") - (hash-table-for-each classinfo (lambda (k v) - (create-some k try-args)))) -(define (create-all-exhaust) - (fprintf (thread-output-port) "creating all exhaustively...~n") - (hash-table-for-each classinfo (lambda (k v) - (create-some k try-all-args)))) - -(define (create-all-bad) - (fprintf (thread-output-port) "creating all with bad arguments...~n") - (hash-table-for-each classinfo (lambda (k v) - (create-some k try-bad-args)))) - -(define (try-methods cls try) - (let* ([v (hash-table-get classinfo cls)] - [source (car v)] - [use (if source (send source choose-example) #f)] - [name (cadr v)] - [methods (cdddr v)]) - (if (void? use) - (fprintf (thread-output-port) "~s: no examples~n" name) - (let loop ([l methods]) - (unless (null? l) - (unless (symbol? (car l)) - (let* ([method (car l)] - [iv (car method)] - [resulttype (caddr method)] - [argtypes (cdddr method)]) - (set! trying-class (and source (ivar source name))) - (set! trying-method iv) - (try argtypes resulttype (list name iv use) - (lambda (args) - (if use - (begin - - ;; Avoid showing a disabled dialog - (when (and (is-a? use dialog%) - (eq? iv 'show) - (equal? args '(#t))) - (send use enable #t)) - - ;; Avoid excessive scaling - (when (eq? iv 'set-scale) - (set! args (map (lambda (x) (min x 10)) args))) - - (apply (ivar/proc use iv) args)) - - (apply (global-defined-value iv) args)))))) - (loop (cdr l))))))) - -(define (call-random except) - (fprintf (thread-output-port) "calling all except ~a randomly...~n" except) - (hash-table-for-each classinfo (lambda (k v) - (unless (member k except) - (try-methods k try-args))))) - -(define (call-all-random) - (call-random null)) - -(define (call-all-bad) - (fprintf (thread-output-port) "calling all with bad arguments...~n") - (hash-table-for-each classinfo (lambda (k v) (try-methods k try-bad-args)))) - -(define (call-all-non-editor) - (call-random (list :editor-buffer% :editor-edit% :editor-snip% :editor-pasteboard% 'EditorGlobal))) - -(define (init) - (create-all-random) - (create-all-random) - (create-all-random) - (create-all-random)) - -(with-handlers ([void (lambda (x) - (printf "Warning: couldn't load classhack.so~n"))]) - (load-relative-extension "classhack.so")) - -(printf " Creating Example Instances~n") - -(define f (make-object frame% "Example Frame 1")) -(send frame%-example-list add f) - -(define d (make-object dialog% "Example Dialog 1")) -(send dialog%-example-list add d) - -(define hpl (make-object horizontal-panel% f)) -(send horizontal-panel%-example-list add hpl) -(define vpl (make-object vertical-panel% d)) -(send vertical-panel%-example-list add vpl) -(define hp (make-object horizontal-pane% d)) -(send horizontal-pane%-example-list add hp) -(define vp (make-object vertical-pane% f)) -(send vertical-pane%-example-list add vp) -(define sp (make-object grow-box-spacer-pane% f)) -(send grow-box-spacer-pane%-example-list add sp) - -(send message%-example-list add (make-object message% "Message 1" hpl)) -(send button%-example-list add (make-object button% "Button 1" vpl void)) -(send check-box%-example-list add (make-object check-box% "Check Box 1" hp void)) -(send slider%-example-list add (make-object slider% "Slider 1" -10 10 vp void)) -(send gauge%-example-list add (make-object gauge% "Gauge 1" 100 hpl)) -(send text-field%-example-list add (make-object text-field% "Text Field 1" vpl void)) -(send radio-box%-example-list add (make-object radio-box% "Radio Box 1" '("Radio Button 1.1" "Radio Button 1.2") hp void)) -(send choice%-example-list add (make-object choice% "Choice 1" '("Choice 1.1" "Choice 1.2" "Choice 1.3") vp void)) -(send list-box%-example-list add (make-object list-box% "List Box 1" '("List Box 1.1" "List Box 1.2" "List Box 1.3") hpl void)) - -(send canvas%-example-list add (make-object canvas% f)) -(define c (make-object editor-canvas% d)) -(send editor-canvas%-example-list add c) - -(send point%-example-list add (make-object point% 50 60)) - -(send ps-setup%-example-list add (make-object ps-setup%)) - -(send color%-example-list add (make-object color% "RED")) -(send font%-example-list add (make-object font% 12 'roman 'normal 'normal)) -(send brush%-example-list add (make-object brush% "GREEN" 'solid)) -(send pen%-example-list add (make-object pen% "BLUE" 1 'solid)) -(send region%-example-list add (make-object region% (send c get-dc))) - -(send font-list%-example-list add the-font-list) -(send pen-list%-example-list add the-pen-list) -(send brush-list%-example-list add the-brush-list) -(send color-database<%>-example-list add the-color-database) -(send font-name-directory<%>-example-list add the-font-name-directory) - -(send cursor%-example-list add (make-object cursor% 'watch)) -(send bitmap%-example-list add (make-object bitmap% (build-path (collection-path "icons") "bb.gif"))) - -(send control-event%-example-list add (make-object control-event% 'list-box)) -(send scroll-event%-example-list add (make-object scroll-event%)) -(send mouse-event%-example-list add (make-object mouse-event% 'left-down)) -(send key-event%-example-list add (make-object key-event%)) - -(send bitmap-dc%-example-list add (make-object bitmap-dc%)) -(send post-script-dc%-example-list add (make-object post-script-dc% #f)) - -(with-handlers ([void void]) - (send printer-dc%-example-list add (make-object printer-dc%))) - -(define mb (make-object menu-bar% f)) -(send menu-bar%-example-list add mb) -(define m (make-object menu% "Menu1" mb)) -(send menu%-example-list add m) -(send popup-menu%-example-list add (make-object popup-menu% "Popup Menu 1")) - -(send separator-menu-item%-example-list add (make-object separator-menu-item% m)) -(send menu-item%-example-list add (make-object menu-item% "Menu Item 1" m void)) -(send checkable-menu-item%-example-list add (make-object checkable-menu-item% "Checkable Menu Item 1" m void)) - -(send timer%-example-list add (make-object timer%)) - -(define sd (make-object style-delta%)) -(send add-color<%>-example-list add (send sd get-background-add)) -(send mult-color<%>-example-list add (send sd get-background-mult)) -(send style-delta%-example-list add sd) -(define sl (make-object style-list%)) -(send style-list%-example-list add sl) -(send style<%>-example-list add (send sl basic-style)) - -(define e (make-object text%)) -(send c set-editor e) -(send text%-example-list add e) -(send pasteboard%-example-list add (make-object pasteboard%)) - -(define s (make-object editor-snip%)) -(send e insert s) -(send editor-snip-editor-admin<%>-example-list add (send (send s get-editor) get-admin)) -(send snip-admin%-example-list add (make-object snip-admin%)) - -(send tab-snip%-example-list add (make-object tab-snip%)) -(send image-snip%-example-list add (make-object image-snip%)) -(send editor-snip%-example-list add (make-object editor-snip%)) - -(send snip-class%-example-list add (make-object snip-class%)) -(send snip-class-list<%>-example-list add (get-the-snip-class-list)) - -(send editor-data%-example-list add (make-object editor-data%)) -(send editor-data-class%-example-list add (make-object editor-data-class%)) -(send editor-data-class-list<%>-example-list add (get-the-editor-data-class-list)) - -(send keymap%-example-list add (make-object keymap%)) -(send editor-wordbreak-map%-example-list add the-editor-wordbreak-map) - -(define sib (make-object editor-stream-in-string-base% "Hello")) -(send editor-stream-in-string-base%-example-list add sib) -(define sob (make-object editor-stream-out-string-base%)) -(send editor-stream-out-string-base%-example-list add sob) - -(send editor-stream-in%-example-list add (make-object editor-stream-in% sib)) -(send editor-stream-out%-example-list add (make-object editor-stream-out% sob)) - -(send clipboard<%>-example-list add the-clipboard) -(send clipboard-client%-example-list add (make-object clipboard-client%)) - -(printf " Done Creating Example Instances~n") - -(printf " Checking all methods~n") -(define in-top-level null) -(hash-table-for-each classinfo - (lambda (key v) - (let* ([methods (cdddr v)] - [names (map (lambda (x) (if (pair? x) (car x) x)) methods)]) - (if (string? key) - ;; Check global procs/values - (for-each - (lambda (name method) - (if (void? (with-handlers ([void void]) - (global-defined-value name))) - ;; Not there - (printf "No such procedure/value: ~a~n" name) - - (let ([v (global-defined-value name)]) - (when (procedure? v) - ;; check arity - (unless (equal? (arity v) (cadr method)) - (printf "Arity mismatch for ~a, real: ~a documented: ~a~n" - name (arity v) (cadr method)))))) - - (set! in-top-level (cons name in-top-level))) - names methods) - ;; Check intf/class methods - (begin - (set! in-top-level (cons (cadr v) in-top-level)) - - ; Check printed form: - (let ([p (open-output-string)]) - (display key p) - (let ([sp (get-output-string p)] - [ss (let ([s (symbol->string (cadr v))]) - (format "#<~a:~a>" - (if (interface? key) "interface" "class") - s))]) - (unless (string=? sp ss) - (printf "bad printed form: ~a != ~a~n" sp ss)))) - - ; Check documented methods are right - (let ([ex (send (car v) choose-example)]) - (unless (is-a? ex key) - (printf "Bad example: ~a for ~a~n" ex key)) - (for-each - (lambda (name method) - (if (or (and (interface? key) - (ivar-in-interface? name key)) - (and (class? key) - (ivar-in-interface? name (class->interface key)))) - - ;; Method is there, check arity - (when (is-a? ex key) - (let ([m (ivar/proc ex name)]) - (unless (equal? (arity m) (cadr method)) - (printf "Warning: arity mismatch for ~a in ~a, real: ~a documented: ~a~n" - name key - (arity m) (cadr method))))) - - ;; Not there - (printf "No such method: ~a in ~a~n" name key))) - names methods)) - - ; Check everything is documented - (when (procedure? (with-handlers ([void void]) (global-defined-value 'class->names))) - (for-each - (lambda (n) - (unless (memq n names) - (printf "Undocumented method: ~a in ~a~n" n key))) - (let ([l ((if (interface? key) interface->names class->names) key)] - [l2 (interface->ivar-names (if (interface? key) - key - (class->interface key)))]) - (unless (and (= (length l) - (length l2)) - (andmap (lambda (i) (member i l2)) - l)) - (printf "Ivar list doesn't match expected for ~a~n" key)) - l)))))))) -(printf " Method-checking done~n") - -(let* ([get-all (lambda (n) - (parameterize ([current-namespace n]) - (map car (make-global-value-list))))] - [expect-n (list* 'mred@ 'mred^ (append (get-all (make-namespace)) in-top-level))] - [actual-n (get-all (make-namespace 'mred))]) - (for-each - (lambda (i) - (unless (memq i expect-n) - (printf "Undocumented global: ~a~n" i))) - actual-n)) - -(unless (and (>= (vector-length argv) 1) - (string=? (vector-ref argv 0) "-r")) - (exit 0)) - -;; Remove some things: -(for-each (lambda (p) - (let ([k (ormap (lambda (k) - (and (equal? k (car p)) - k)) - (hash-table-map classinfo (lambda (k v) k)))]) - (hash-table-put! - classinfo k - (let ([l (hash-table-get classinfo k)]) - (let loop ([l l]) - (cond - [(null? l) null] - [(and (pair? (car l)) - (eq? (cadr p) (caar l))) - (cdr l)] - [else (cons (car l) (loop (cdr l)))])))))) - '(("Eventspaces" sleep/yield))) - -(random-seed 179) - -(create-all-bad) -(call-all-bad) - -(create-all-random) -(call-all-random) diff --git a/collects/tests/mred/showkey.ss b/collects/tests/mred/showkey.ss deleted file mode 100644 index 45a633c0..00000000 --- a/collects/tests/mred/showkey.ss +++ /dev/null @@ -1,40 +0,0 @@ - -(require-library "macro.ss") - -(let ([c% - (class-asi canvas% - (override - [on-event - (lambda (ev) - (printf "MOUSE ~a meta: ~a control: ~a alt: ~a shift: ~a buttons: ~a ~a ~a~n" - (send ev get-event-type) - (send ev get-meta-down) - (send ev get-control-down) - (send ev get-alt-down) - (send ev get-shift-down) - (send ev get-left-down) - (send ev get-middle-down) - (send ev get-right-down)))] - [on-char - (lambda (ev) - (printf "KEY code: ~a meta: ~a control: ~a alt: ~a shift: ~a~n" - (let ([v (send ev get-key-code)]) - (if (symbol? v) - v - (format "~a = ASCII ~a" v (char->integer v)))) - (send ev get-meta-down) - (send ev get-control-down) - (send ev get-alt-down) - (send ev get-shift-down)))]))]) - (define f (make-object (class frame% () - (inherit accept-drop-files) - (override - [on-drop-file (lambda (file) - (printf "Dropped: ~a~n" file))]) - (sequence - (super-init "tests" #f 100 100) - (accept-drop-files #t))))) - (define c (make-object c% f)) - (send c focus) - (send f show #t)) - diff --git a/collects/tests/mred/slider-steps.txt b/collects/tests/mred/slider-steps.txt deleted file mode 100644 index 41fb488b..00000000 --- a/collects/tests/mred/slider-steps.txt +++ /dev/null @@ -1,21 +0,0 @@ - -The slider's initial value should be 3. The range is -1 to 11. - -Change the slider value in each way allowed by the control (dragging, - clicking in page-up/page-down, clicking on one-step arrows). For - each change, the console should contain "Callback Ok". When you - drag, one callback may be reported for the whole drag, or - intermediate callbacks may be reported. - -Click "Up" until the slider is at the top; a mismatch exception should - be reported. Click "Down" once aand verify that the slider is at 10. - -Repeat the above step for "Down" (checking for an exception when the - slider is already at its minimum value). - -Repeat the above two steps for "Simulate Up" and "Simulate Down". For - the simulates, the console should report "Callback Ok" for each click. - If you try to go too far up or down, the console should report an - error: "slider value mismatch". - -Click the "Check" button. The console should report "All Ok". diff --git a/collects/tests/mred/testing.ss b/collects/tests/mred/testing.ss deleted file mode 100644 index 410b7f5b..00000000 --- a/collects/tests/mred/testing.ss +++ /dev/null @@ -1,38 +0,0 @@ - -;; MrEd automatic testing basic functions and macros - -(define errs null) -(define test-count 0) - -(define (test expect name got) - (set! test-count (add1 test-count)) - (unless (equal? expect got) - (let ([s (format "~a: expected ~a; got ~a" name expect got)]) - (printf "ERROR: ~a~n" s) - (set! errs (cons s errs))))) - - -(define-macro st - (lambda (val obj method . args) - `(test ,val ',method (send ,obj ,method ,@args)))) - -(define-macro stv - (lambda args - `(st (void) ,@args))) - -(define-macro stvals - (lambda (vals obj method . args) - `(test ,vals ',method (call-with-values (lambda () (send ,obj ,method ,@args)) list)))) - - -(define (report-errs) - (newline) - (if (null? errs) - (printf "Passed all ~a tests~n" test-count) - (begin - (printf "~a Error(s) in ~a tests~n" (length errs) test-count) - (for-each - (lambda (s) - (printf "~a~n" s)) - (reverse errs))))) - diff --git a/collects/tests/mred/windowing.ss b/collects/tests/mred/windowing.ss deleted file mode 100644 index 10b0037b..00000000 --- a/collects/tests/mred/windowing.ss +++ /dev/null @@ -1,992 +0,0 @@ - -(when (not (defined? 'test)) - (load-relative "testing.ss")) - -; These message boxes mustn't survive -(let ([c (make-custodian)]) - (parameterize ([current-custodian c]) - (parameterize ([current-eventspace (make-eventspace)]) - (queue-callback - (lambda () - (queue-callback - (lambda () - (sleep/yield 0.1) - (queue-callback - (lambda () - (custodian-shutdown-all c))) - (message-box "w" "q"))) - (message-box "x" "y")))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Windowing Tests ;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-macro FAILS void) - -(define (pause) - (let ([s (make-semaphore)]) - (flush-display) - (thread (lambda () (sleep 0.01) (semaphore-post s))) - (yield s))) - -(define (enable-tests f) - (printf "Enable ~a~n" f) - (st #t f is-enabled?) - (stv f enable #f) - (st #f f is-enabled?) - (stv f enable #t) - (st #t f is-enabled?)) - -(define (drop-file-tests f) - (printf "Drop File ~a~n" f) - (st #f f accept-drop-files) - (stv f accept-drop-files #t) - (st #t f accept-drop-files) - (stv f accept-drop-files #f) - (st #f f accept-drop-files)) - -(define (client->screen-tests f) - (printf "Client<->Screen ~a~n" f) - (let-values ([(x y) (send f client->screen 0 0)]) - (stvals '(0 0) f screen->client x y)) - (let-values ([(x y) (send f screen->client 0 0)]) - (stvals '(0 0) f client->screen x y)) - (let-values ([(cw ch) (send f get-client-size)] - [(w h) (send f get-size)]) - (test #t `(client-size ,f ,cw ,ch ,w ,h) (and (<= 1 cw w) (<= 1 ch h)))) - (stv f refresh)) - -(define (area-tests f sw? sh? no-stretch?) - (printf "Area ~a~n" f) - (let ([x (send f min-width)] - [y (send f min-height)]) - (st sw? f stretchable-width) - (st sh? f stretchable-height) - (stv (send f get-top-level-window) reflow-container) - (pause) ; to make sure size has taken effect - (let-values ([(w h) (if no-stretch? - (send f get-size) - (values 0 0))]) - (printf "Size ~a x ~a~n" w h) - (when no-stretch? - (stv f min-width w) ; when we turn of stretchability, don't resize - (stv f min-height h)) - (stv f stretchable-width #f) - (stv f stretchable-height #f) - (st #f f stretchable-width) - (st #f f stretchable-height) - (stv f stretchable-width #t) - (stv f stretchable-height #t) - (st #t f stretchable-width) - (st #t f stretchable-height) - (stv f stretchable-width sw?) - (stv f stretchable-height sh?)) - (stv f min-width x) - (stv f min-height y))) - -(define (containee-tests f sw? sh? m) - (area-tests f sw? sh? #f) - (printf "Containee ~a~n" f) - (st m f horiz-margin) - (st m f vert-margin) - (stv f horiz-margin 3) - (st 3 f horiz-margin) - (st m f vert-margin) - (stv f horiz-margin m) - (stv f vert-margin 3) - (st m f horiz-margin) - (st 3 f vert-margin) - (stv f vert-margin m)) - -(define (container-tests f win?) - (printf "Container ~a~n" f) - (let-values ([(x y) (send f get-alignment)]) - (stv f set-alignment 'right 'bottom) - (stvals '(right bottom) f get-alignment) - (stv f set-alignment x y)) - (when win? - (test #t 'get-label-font-kind (is-a? (send f get-label-font) font%)) - (test #t 'get-label-font-kind (is-a? (send f get-control-font) font%)) - (st (send f get-label-font) f get-control-font) - (let ([fnt (send f get-label-font)] - [other-font (make-object font% 20 'decorative 'normal 'bold)]) - (st 'system fnt get-family) - (st 'normal fnt get-style) - (st 'normal fnt get-weight) - (stv f set-label-font other-font) - (st other-font f get-label-font) - (stv f set-label-font fnt) - (stv f set-control-font other-font) - (st other-font f get-control-font) - (stv f set-control-font fnt)) - (st 'horizontal f get-label-position) - (stv f set-label-position 'vertical) - (st 'vertical f get-label-position) - (stv f set-label-position 'horizontal))) - -(define (cursor-tests f) - (printf "Cursor ~a~n" f) - (let ([c (send f get-cursor)]) - (stv f set-cursor c) - (st c f get-cursor) - (begin-busy-cursor) - (end-busy-cursor) - (st c f get-cursor) - (stv f set-cursor #f) - (st #f f get-cursor) - (begin-busy-cursor) - (end-busy-cursor) - (st #f f get-cursor) - (stv f set-cursor c))) - -(define (show-tests f) - (unless (is-a? f dialog%) - (printf "Show ~a~n" f) - (let ([on? (send f is-shown?)]) - (stv f show #f) - (when on? - (stv f show #t))))) - -(define (window-tests f sw? sh? parent top m) - (st parent f get-parent) - (st top f get-top-level-window) - (enable-tests f) - (drop-file-tests f) - (client->screen-tests f) - (cursor-tests f) - (show-tests f)) - -(define (containee-window-tests f sw? sh? parent top m) - (window-tests f sw? sh? parent top m) - (containee-tests f sw? sh? m)) - -(define (test-control-event e types) - (test #t 'event-instance (is-a? e control-event%)) - (test #t 'event-type (pair? (memq (send e get-event-type) types)))) - -(define (label-test b l) - (let ([&-l (format "&~a" l)] - [my-l (format "My ~a" l)] - [&-my-l (format "&My ~a" l)]) - (st &-l b get-label) - (st l b get-plain-label) - (stv b set-label &-my-l) - (st &-my-l b get-label) - (st my-l b get-plain-label) - (stv b set-label &-l))) - -(let ([f (make-object frame% "Yes & No" #f 150 151 20 21)]) - (let ([init-tests - (lambda () - (st "Yes & No" f get-label) - (st "Yes No" f get-plain-label) - (stv f set-label "Yeah & Nay") - (st "Yeah & Nay" f get-label) - (st "Yeah Nay" f get-plain-label) - (stv f set-label "Yes & No") - (st #f f get-parent) - (st f f get-top-level-window) - (st 20 f get-x) - (st 21 f get-y) - (st 150 f get-width) - (st 151 f get-height) - (stvals (list (send f get-width) (send f get-height)) f get-size) - (st #f f has-status-line?) - (st #f f is-iconized?) - (st #f f get-menu-bar))] - [space-tests - (lambda () - (printf "Spacing~n") - (let ([b (send f border)]) - (stv f border 25) - (st 25 f border) - (stv f border b)) - (let ([s (send f spacing)]) - (stv f spacing 7) - (st 7 f spacing) - (stv f spacing s)))] - [enable-tests - (lambda () (enable-tests f))] - [drop-file-tests - (lambda () - (drop-file-tests f))] - [client->screen-tests - (lambda () - (printf "Client<->Screen~n") - (let-values ([(x y) (send f client->screen 0 0)]) - (stvals '(0 0) f screen->client x y)) - (let-values ([(x y) (send f screen->client 0 0)]) - (stvals '(0 0) f client->screen x y)))] - [container-tests - (lambda () - (printf "Container~n") - (area-tests f #t #t #t) - (let-values ([(x y) (send f container-size null)]) - (st x f min-width) - (st y f min-height)) - (container-tests f #t))] - [cursor-tests - (lambda () - (test #t 'get-cursor-kind (is-a? (send f get-cursor) cursor%)) - (cursor-tests f))]) - - (st (current-eventspace) f get-eventspace) - (st #t f can-close?) - (st #t f can-exit?) - (stv f focus) - - (space-tests) - (enable-tests) - (client->screen-tests) - (container-tests) - (cursor-tests) - - (printf "Init~n") - (init-tests) - (stv f show #t) - (pause) - (printf "Show Init~n") - (init-tests) - (stv f show #f) - (pause) - (printf "Hide Init~n") - (init-tests) - (send f show #t) - (pause) - - (space-tests) - (enable-tests) - (client->screen-tests) - (container-tests) - - (stv f change-children values) - - (printf "Iconize~n") - (stv f iconize #t) - (pause) - (pause) - (st #t f is-iconized?) - (stv f show #t) - (pause) - (st #f f is-iconized?) - - (stv f maximize #t) - (pause) - (stv f maximize #f) - (pause) - - (printf "Move~n") - (stv f move 34 37) - (pause) - (FAILS (st 34 f get-x)) - (FAILS (st 37 f get-y)) - (st 150 f get-width) - (st 151 f get-height) - - (printf "Resize~n") - (stv f resize 56 57) - (pause) - (FAILS (st 34 f get-x)) - (FAILS (st 37 f get-y)) - (st 56 f get-width) - (st 57 f get-height) - - (stv f center) - (pause) - (st 56 f get-width) - (st 57 f get-height) - - (client->screen-tests) - - (stv f create-status-line) - (stv f set-status-text "Hello") - - (stv f change-children values) - (st null f get-children) - (stvals '(center top) f get-alignment) - - (stv f focus) - - (cursor-tests) - - (printf "Menu Bar~n") - (let ([mb (make-object menu-bar% f)]) - (st mb f get-menu-bar) - (st f mb get-frame) - (st null f get-children) - - (st #t mb is-enabled?) - (stv mb enable #f) - (st #f mb is-enabled?) - (stv mb enable #t) - (st #t mb is-enabled?) - - (st null mb get-items) - - (printf "Menu 1~n") - (let* ([m (make-object menu% "&File" mb)] - [i m] - [delete-enable-test (lambda (i parent empty) - (printf "Item~n") - (st #f i is-deleted?) - (st #t i is-enabled?) - - (stv i delete) - (st #t i is-deleted?) - (st empty parent get-items) - (stv i restore) - (st #f i is-deleted?) - - (stv i enable #f) - (st #f i is-enabled?) - (stv i enable #t) - (st #t i is-enabled?) - - (stv i delete) - (st #t i is-enabled?) - (stv i enable #f) - (st #f i is-enabled?) - (stv i restore) - (st #f i is-deleted?) - (st #f i is-enabled?) - (stv i enable #t) - - (let ([l (send i get-help-string)]) - (stv i set-help-string "Yikes") - (st "Yikes" i get-help-string) - (stv i set-help-string #f) - (st #f i get-help-string) - (stv i set-help-string l)) - - (let ([l (send i get-label)]) - (stv i set-label "Matthew") - (st "Matthew" i get-label) - (stv i set-label l)))] - [hit #f]) - (st (list i) mb get-items) - (st mb i get-parent) - - (st "&File" i get-label) - (st "File" i get-plain-label) - (st #f i get-help-string) - - (delete-enable-test i mb null) - - (st null m get-items) - - (printf "Menu Items~n") - (let ([i1 (make-object menu-item% "&Plain" m - (lambda (i e) - (test-control-event e '(menu)) - (test hit 'expected-plain-menu i) - (set! hit 'plain) - 'oops) - #f "Help")] - [i2 (make-object separator-menu-item% m)] - [i3 (make-object checkable-menu-item% "Che&ckable" m - (lambda (i e) - (test-control-event e '(menu)) - (test hit 'expected-check-menu i) - (set! hit 'check) - 'oops) - #\C)] - [shortcut-test - (lambda (i empty name) - (delete-enable-test i m empty) - - (printf "Shortcut~n") - (set! hit i) - (stv i command (make-object control-event% 'menu)) - (test name 'hit-command hit) - - (let ([c (send i get-shortcut)]) - (stv i set-shortcut #\M) - (st #\M i get-shortcut) - (stv i set-shortcut #f) - (st #f i get-shortcut) - (stv i set-shortcut c)) - - (st 'meta i get-x-shortcut-prefix) - (let ([p (send i get-x-shortcut-prefix)]) - (stv i set-x-shortcut-prefix 'alt) - (st 'alt i get-x-shortcut-prefix) - (stv i set-x-shortcut-prefix 'ctl) - (st 'ctl i get-x-shortcut-prefix) - (stv i set-x-shortcut-prefix 'ctl-m) - (st 'ctl-m i get-x-shortcut-prefix) - (stv i set-x-shortcut-prefix 'alt)))]) - (st (list i1 i2 i3) m get-items) - - (st "&Plain" i1 get-label) - (st "Plain" i1 get-plain-label) - (st "Help" i1 get-help-string) - (st #f i1 get-shortcut) - - (st "Che&ckable" i3 get-label) - (st "Checkable" i3 get-plain-label) - (st #f i3 get-help-string) - (st #\C i3 get-shortcut) - - (shortcut-test i1 (list i2 i3) 'plain) - (shortcut-test i3 (list i2 i1) 'check) - - (st (list i2 i1 i3) m get-items) - (stv i2 delete) - (st #t i2 is-deleted?) - (st (list i1 i3) m get-items) - (stv i2 restore) - (st #f i2 is-deleted?) - (st (list i1 i3 i2) m get-items) - - 'done) - - (printf "Menu 2~n") - (let* ([m2 (make-object menu% "&Edit" mb "Help Edit")] - [i2 m2]) - (st (list i i2) mb get-items) - (st mb i2 get-parent) - - (st "&Edit" i2 get-label) - (st "Edit" i2 get-plain-label) - (st "Help Edit" i2 get-help-string) - - (delete-enable-test i2 mb (list i)) - - (st null m2 get-items) - - ; Move orig to end - (stv i delete) - (stv i restore) - (st (list i2 i) mb get-items))) - - 'done))) - -(define frame (let ([l (get-top-level-windows)]) - (test 1 'list-size (length l)) - (car l))) -(st "Yes & No" frame get-label) - -(define (test-controls parent frame) - (define side-effect #f) - - (printf "Buttons~n") - (letrec ([b (make-object button% - "&Button" - parent - (lambda (bt e) - (test bt 'same-button b) - (test-control-event e '(button)) - (set! side-effect 'button) - 'oops) - '(border))]) - (label-test b "Button") - (stv b command (make-object control-event% 'button)) - (test 'button 'button-callback side-effect) - - (containee-window-tests b #f #f parent frame 2)) - - (printf "Check Box~n") - (letrec ([c (make-object check-box% - "&Check Box" - parent - (lambda (cb e) - (test cb 'same-check c) - (test-control-event e '(check-box)) - (set! side-effect 'check-box) - 'oops) - null)]) - (label-test c "Check Box") - (stv c command (make-object control-event% 'check-box)) - (test 'check-box 'check-box-callback side-effect) - - (st #f c get-value) - (stv c set-value #t) - (st #t c get-value) - (stv c set-value #f) - (st #f c get-value) - - (containee-window-tests c #f #f parent frame 2)) - - (printf "Radio Box~n") - (letrec ([r (make-object radio-box% - "&Radio Box" - (list "O&ne" "T&wo" "T&hree") - parent - (lambda (rb e) - (test rb 'same-radio r) - (test-control-event e '(radio-box)) - (set! side-effect 'radio-box) - 'oops) - '(vertical))]) - (label-test r "Radio Box") - (stv r command (make-object control-event% 'radio-box)) - (test 'radio-box 'radio-box-callback side-effect) - - ; Try every combination of enable states: - (let ([try-all - (lambda () - (let loop ([n 7]) - (let ([0? (positive? (bitwise-and n 1))] - [1? (positive? (bitwise-and n 2))] - [2? (positive? (bitwise-and n 4))]) - (st 0? r is-enabled? 0) - (st 1? r is-enabled? 1) - (st 2? r is-enabled? 2) - (let ([0? (positive? (bitwise-and (sub1 n) 1))] - [1? (positive? (bitwise-and (sub1 n) 2))] - [2? (positive? (bitwise-and (sub1 n) 4))]) - (stv r enable 0 0?) - (stv r enable 1 1?) - (stv r enable 2 2?) - (unless (zero? n) - (loop (sub1 n)))))) - (st #t r is-enabled? 0) - (st #t r is-enabled? 1) - (st #t r is-enabled? 2))]) - (try-all) - (stv r enable #f) - (try-all) - (stv r enable #t)) - - (st "O&ne" r get-item-label 0) - (st "T&wo" r get-item-label 1) - (st "T&hree" r get-item-label 2) - (st "One" r get-item-plain-label 0) - (st "Two" r get-item-plain-label 1) - (st "Three" r get-item-plain-label 2) - - (st 3 r get-number) - - (st 0 r get-selection) - (stv r set-selection 1) - (st 1 r get-selection) - (stv r set-selection 2) - (st 2 r get-selection) - (stv r set-selection 1) - (st 1 r get-selection) - (stv r set-selection 0) - (st 0 r get-selection) - - (containee-window-tests r #f #f parent frame 2)) - - (printf "Gauge~n") - (letrec ([g (make-object gauge% - "&Gauge" - 10 - parent - '(horizontal))]) - (label-test g "Gauge") - - (st 0 g get-value) - (stv g set-value 8) - (st 8 g get-value) - (stv g set-value 0) - (st 0 g get-value) - (stv g set-value 10) - (st 10 g get-value) - - (st 10 g get-range) - (stv g set-range 11) - (st 11 g get-range) - (st 10 g get-value) - (stv g set-range 8) - (st 8 g get-range) - (st 8 g get-value) - (stv g set-range 1) - (st 1 g get-range) - (st 1 g get-value) - (stv g set-range 10) - (st 10 g get-range) - (st 1 g get-value) - - (containee-window-tests g #t #f parent frame 2)) - - (printf "Slider~n") - (letrec ([s (make-object slider% - "&Slider" - -2 8 - parent - (lambda (sl e) - (test sl 'same-slider s) - (test-control-event e '(slider)) - (set! side-effect 'slider) - 'oops) - 3 - '(horizontal))]) - (label-test s "Slider") - (stv s command (make-object control-event% 'slider)) - (test 'slider 'slider-callback side-effect) - - (st 3 s get-value) - (stv s set-value 4) - (st 4 s get-value) - (stv s set-value -2) - (st -2 s get-value) - (stv s set-value 8) - (st 8 s get-value) - - (containee-window-tests s #t #f parent frame 2)) - - (let ([test-list-control - (lambda (l choice? multi?) - (st 3 l get-number) - - (st "A" l get-string 0) - (st "B" l get-string 1) - (st "C & D" l get-string 2) - - (unless choice? - (st 'a l get-data 0) - (st #f l get-data 1) - (st 'c-&-d l get-data 2)) - - (st 0 l find-string "A") - (st 1 l find-string "B") - (st 2 l find-string "C & D") - (st #f l find-string "C") - - (stv l set-selection 2) - (st 2 l get-selection) - (st "C & D" l get-string-selection) - (stv l set-selection 1) - (st 1 l get-selection) - (st "B" l get-string-selection) - (stv l set-selection 0) - (st 0 l get-selection) - (st "A" l get-string-selection) - - (stv l set-string-selection "C & D") - (st 2 l get-selection) - (st "C & D" l get-string-selection) - (stv l set-string-selection "B") - (st 1 l get-selection) - (st "B" l get-string-selection) - (stv l set-string-selection "A") - (st 0 l get-selection) - (st "A" l get-string-selection) - - (stv l set-selection 2) - - (unless choice? - (st '(2) l get-selections) - (stv l set-selection 1) - (st #t l is-selected? 1) - (st #f l is-selected? 2) - (st '(1) l get-selections) - (stv l set-selection 2) - (st #f l is-selected? 1) - (st #t l is-selected? 2) - - (stv l select 2 #f) - (st '() l get-selections) - (st #f l get-selection) - (stv l select 0 #t) - (st '(0) l get-selections) - - (stv l select 2 #t) - (st (if multi? '(0 2) '(2)) l get-selections) - (stv l select 1 #t) - (st (if multi? '(0 1 2) '(1)) l get-selections) - (stv l select 1 #f) - (st (if multi? '(0 2) '()) l get-selections) - (st (if multi? 0 #f) l get-selection) - (stv l select 2 #t) - (st (if multi? '(0 2) '(2)) l get-selections) - (st (if multi? 0 2) l get-selection) - (st multi? l is-selected? 0) - (st #t l is-selected? 2) - (stv l set-selection 2) - (st '(2) l get-selections)) - - (if choice? - (stv l append "E") - (stv l append "E" 'e)) - (st 4 l get-number) - (st 2 l get-selection) - (unless choice? - (st 'e l get-data 3)) - (stv l append "F & G") - (st 5 l get-number) - (st 2 l get-selection) - (unless choice? - (st #f l get-data 4)) - - (stv l set-selection 4) - (st 4 l get-selection) - (st "F & G" l get-string-selection) - (stv l set-selection 2) - (stv l set-string-selection "F & G") - (st 4 l get-selection) - (st "F & G" l get-string-selection) - - (unless choice? - (stv l delete 1) - (st 4 l get-number) - (st "A" l get-string 0) - (st 'a l get-data 0) - (st "C & D" l get-string 1) - (st 'c-&-d l get-data 1) - - (stv l delete 0) - (st 3 l get-number)) - - (stv l clear) - (st 0 l get-number) - (st #f l get-selection) - (st #f l get-string-selection) - - (stv l append "Z") - (st 1 l get-number) - (when choice? - (st 0 l get-selection) - (st "Z" l get-string-selection)) - - (unless choice? - (st 1 l get-number) - (stv l set '("ONe" "TW&o" "THRee")) - (st 3 l get-number) - (st "ONe" l get-string 0) - (st "TW&o" l get-string 1) - (st "THRee" l get-string 2) - - (stv l set-data 0 'my-example-data) - (stv l set-data 2 'my-other-data) - (st 'my-example-data l get-data 0) - (st #f l get-data 1) - (st 'my-other-data l get-data 2)) - - 'done-list)]) - - (printf "Choice~n") - (letrec ([c (make-object choice% - "&Choice" - '("A" "B" "C & D") - parent - (lambda (ch e) - (test ch 'same-choice c) - (test-control-event e '(choice)) - (set! side-effect 'choice) - 'oops) - null)]) - (label-test c "Choice") - (stv c command (make-object control-event% 'choice)) - (test 'choice 'choice-callback side-effect) - - (st 0 c get-selection) - - (test-list-control c #t #f) - - (containee-window-tests c #f #f parent frame 2)) - - (let ([mk-list - (lambda (style) - (printf "List Box: ~a~n" style) - (letrec ([l (make-object list-box% - "&List Box" - '("A" "B" "C & D") - parent - (lambda (lb e) - (test lb 'same-list-box l) - (test-control-event e '(list-box)) - (set! side-effect 'list-box) - 'oops) - (list style))]) - (label-test l "List Box") - (stv l command (make-object control-event% 'list-box)) - (test 'list-box 'list-box-callback side-effect) - - (stv l set-data 0 'a) - (stv l set-data 2 'c-&-d) - - (test-list-control l #f (and (memq style '(multiple extended)) #t)) - - (containee-window-tests l #t #t parent frame 2) - - (stv parent delete-child l)))]) - - (mk-list 'single) - (mk-list 'multiple) - (mk-list 'extended)) - - 'done-lists) - - (let loop ([styles '((single) (multiple) (multiple hscroll))]) - (unless (null? styles) - (let ([t (make-object text-field% "Label" parent void "Starting Value" (car styles))]) - (st "Starting Value" t get-value) - (stv t set-value "different") - (st "different" t get-value) - - (test #t 'is-editor? (is-a? (send t get-editor) text%)) - - (containee-window-tests t #t - (and (memq 'multiple (car styles)) #t) - parent frame 0) - - (send parent delete-child t) - (loop (cdr styles))))) - - (let ([c (make-object canvas% parent '(hscroll vscroll))]) - - (printf "Tab Focus~n") - (st #f c accept-tab-focus) - (stv c accept-tab-focus #t) - (st #t c accept-tab-focus) - (stv c accept-tab-focus #f) - (st #f c accept-tab-focus) - - (stv c init-auto-scrollbars 500 606 .02 .033) - ; (stv c set-scrollbars 100 101 5 6 2 3 10 20 #t) - (let-values ([(w h) (send c get-virtual-size)] - [(cw ch) (send c get-client-size)]) - (printf "Canvas size: Virtual: ~a x ~a Client: ~a x ~a~n" w h cw ch) - (let ([check-scroll - (lambda (xpos ypos) - (let-values ([(x y) (send c get-view-start)]) - (let ([coerce (lambda (x) (inexact->exact (floor x)))]) - (test (coerce (* xpos (- 500 cw))) `(canvas-view-x ,xpos ,ypos ,x ,cw) x) - (test (coerce (* ypos (- 606 ch))) `(canvas-view-y ,xpos ,ypos ,y ,ch) y))))]) - (test 500 'canvas-virt-w-size w) - (test 606 'canvas-virt-h-size h) - - (check-scroll 0.02 0.033) - - (st 0 c get-scroll-pos 'horizontal) - (st 0 c get-scroll-pos 'vertical) - (st 0 c get-scroll-page 'horizontal) - (st 0 c get-scroll-page 'vertical) - (st 0 c get-scroll-range 'horizontal) - (st 0 c get-scroll-range 'vertical) - - (stv c scroll 0.1 0.1) - (check-scroll 0.1 0.1) - (stv c scroll #f 0.2) - (check-scroll 0.1 0.2) - (stv c scroll 0.0 #f) - (check-scroll 0.0 0.2) - - 'done-sb)) - - (stv c init-manual-scrollbars 5 6 2 3 4 5) - (let-values ([(w h) (send c get-virtual-size)] - [(cw ch) (send c get-client-size)]) - (let ([check-scroll - (lambda (xpos ypos) - (st xpos c get-scroll-pos 'horizontal) - (st ypos c get-scroll-pos 'vertical) - - (test cw 'canvas-virt-w-size w) - (test ch 'canvas-virt-h-size h) - - (let-values ([(x y) (send c get-view-start)]) - (test 0 'canvas-view-x x) - (test 0 'canvas-view-y y)))]) - - (check-scroll 4 5) - - (st 2 c get-scroll-page 'horizontal) - (st 3 c get-scroll-page 'vertical) - (st 5 c get-scroll-range 'horizontal) - (st 6 c get-scroll-range 'vertical) - - (stv c scroll 1 1) - (check-scroll 4 5) - - (stv c set-scroll-pos 'horizontal 1) - (check-scroll 1 5) - (stv c set-scroll-pos 'vertical 0) - (check-scroll 1 0) - - (stv c set-scroll-page 'horizontal 1) - (st 1 c get-scroll-page 'horizontal) - (st 3 c get-scroll-page 'vertical) - (stv c set-scroll-page 'vertical 2) - (st 1 c get-scroll-page 'horizontal) - (st 2 c get-scroll-page 'vertical) - - 'done-sb)) - - (stv c warp-pointer 21 23) - - (containee-window-tests c #t #t parent frame 0)) - - (let* ([e (make-object text%)] - [c (make-object editor-canvas% - parent e - null - 102)]) - (let loop ([n 100]) - (unless (zero? n) - (send e insert (format "line ~a~n" n)) - (loop (sub1 n)))) - - (st #f c allow-scroll-to-last) - (stv c allow-scroll-to-last #t) - (st #t c allow-scroll-to-last) - (stv c allow-scroll-to-last #f) - - (st 'hello c call-as-primary-owner (lambda () 'hello)) - - (st #f c force-display-focus) - (stv c force-display-focus #t) - (st #t c force-display-focus) - (stv c force-display-focus #f) - - (st e c get-editor) - (stv c set-editor #f) - (st #f c get-editor) - (stv c set-editor e) - (st e c get-editor) - - (st #f c lazy-refresh) - (stv c lazy-refresh #t) - (st #t c lazy-refresh) - (stv c lazy-refresh #f) - - (st #f c scroll-with-bottom-base) - (stv c scroll-with-bottom-base #t) - (st #t c scroll-with-bottom-base) - (stv c scroll-with-bottom-base #f) - - (stv c set-line-count 6) - (stv c set-line-count #f) - - (containee-window-tests c #t #t parent frame 0)) - - 'done) - -(test-controls frame frame) - -(define (panel-tests frame% show?) - (define (panel-test % win?) - (let* ([frame (make-object frame% "Panel Test" #f 100 100)] - [panel (if % - (make-object % frame) - frame)]) - (let ([go - (lambda () - (test-controls panel frame) - (if win? - ((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0) - (area-tests panel #t #t #f)) - (container-tests panel win?) - (send frame show #f))]) - (when (eq? show? 'dialog) - (queue-callback go)) - (when show? - (send frame show #t)) - (unless (eq? show? 'dialog) - (go))))) - (panel-test #f #t) - (panel-test vertical-pane% #f) - (panel-test horizontal-pane% #f) - (panel-test vertical-panel% #t) - (panel-test horizontal-panel% #t)) - -(panel-tests dialog% #f) -(panel-tests frame% #t) -(panel-tests frame% #f) -(panel-tests dialog% 'dialog) - - -(report-errs) diff --git a/collects/tests/mysterx/README b/collects/tests/mysterx/README deleted file mode 100644 index e9bf3688..00000000 --- a/collects/tests/mysterx/README +++ /dev/null @@ -1,26 +0,0 @@ -MysterX test control -==================== - -The file mystests.ss in this directory creates a window -with a test ActiveX control, and runs a number of tests on it. -After the internal tests are performed, you can interact -with the test control using a mouse. - -The C++ code in the src subdirectory is supplied uncompiled. -You need Visual C++ 6.0 to compile it. You may need to -change the directory for MZC in testobject.mak if you have -installed PLT software to a nonstandard location. - -To compile, run "nmake". Once you've compiled the test ActiveX -control, load "mystests.ss". - -DHTML test code -=============== - -The file dhtmltests.ss contains a number of tests -for the Dynamic HTML capabilities of MysterX. -Simply load the file into MzScheme or DrScheme to run the -tests. Any errors will be printed in the REPL. -The behavior that appears in the window that is created -may be ignored. - diff --git a/collects/tests/mysterx/dhtmltests.ss b/collects/tests/mysterx/dhtmltests.ss deleted file mode 100644 index a827fb6e..00000000 --- a/collects/tests/mysterx/dhtmltests.ss +++ /dev/null @@ -1,133 +0,0 @@ -;;; dhtmltests.ss -- DHTML tests for MysterX - -(require-library "mysterx.ss" "mysterx") - -(define wb (make-object mx-browser% "DHTML tests" 300 300 - 'default 'default '(maximize))) - -(define doc (send wb current-document)) - -(send doc insert-html "

This is some text

") - -(define txt (send doc find-element "P" "text")) - -(define (test-prop getter setter expected) - (printf "Checking ~a~n" getter) - ((ivar/proc txt setter) expected) - (let ([got ((ivar/proc txt getter))]) - (unless (equal? got expected) - (printf "~a: Expected ~a, got ~a~n" - getter expected got)))) - -(define tests - `((font-family set-font-family! ("monospace" "fantasy")) - (font-size set-font-size! xx-large) - (font-style set-font-style! oblique) - (font-variant set-font-variant! small-caps) - (font-weight set-font-weight! bolder) - (background-attachment set-background-attachment! fixed) - (background-image - set-background-image! - "http://www.cs.rice.edu/CS/PLT/packages/drscheme/logo.gif") - (background-repeat set-background-repeat! no-repeat) - (background-position set-background-position! (right bottom)) - (background-position-x set-background-position-x! - ,(make-css-length 42 'em)) - (background-position-y set-background-position-y! - ,(make-css-percentage 95)) - (letter-spacing set-letter-spacing! normal) - (letter-spacing set-letter-spacing! - ,(make-css-length 20 'pt)) - (vertical-align set-vertical-align! super) - (text-decoration set-text-decoration! (underline line-through)) - (text-decoration-underline set-text-decoration-underline! #t) - (text-decoration-overline set-text-decoration-overline! #t) - (text-decoration-linethrough set-text-decoration-linethrough! #t) - (text-decoration-blink set-text-decoration-blink! #t) - (color set-color! red) - (background-color set-background-color! orange) - (pixel-top set-pixel-top! 27) - (pixel-left set-pixel-left! 99) - (pixel-width set-pixel-width! 99) - (pixel-height set-pixel-height! 199) - (overflow set-overflow! scroll) - (pos-top set-pos-top! 13.0) - (pos-left set-pos-left! 17.0) - (pos-width set-pos-width! 188.0) - (text-transform set-text-transform! uppercase) - (text-align set-text-align! justify) - (text-indent set-text-indent! ,(make-css-length 50 'pt)) - (line-height set-line-height! ,(make-css-percentage 200)) - (margin set-margin! (auto ,(make-css-length 70 'pt) auto auto)) - (margin-top set-margin-top! ,(make-css-length 70 'pt)) - (margin-bottom set-margin-bottom! auto) - (margin-left set-margin-left! auto) - (margin-right set-margin-right! ,(make-css-percentage 200)) - (pagebreak-before set-pagebreak-before! always) - (pagebreak-after set-pagebreak-after! always) - (cursor set-cursor! help) - (padding set-padding! ,(list (make-css-length 70 'pt) (make-css-percentage 300))) - (padding-top set-padding-top! ,(make-css-length 30 'em)) - (padding-bottom set-padding-bottom! ,(make-css-length 3 'cm)) - (padding-left set-padding-left! ,(make-css-length 3 'ex)) - (padding-right set-padding-right! ,(make-css-length 70 'mm)) - (border set-border! (blue ,(make-css-length 6 'pt) solid)) - (border-top set-border-top! (red ,(make-css-length 8 'pt) dashed)) - (border-bottom set-border-bottom! (green ,(make-css-length 4 'pt) dotted)) - (border-left set-border-left! (pink thick dotted)) - (border-right set-border-right! (black thin dashed)) - (border-color set-border-color! orange) - (border-top-color set-border-top-color! cyan) - (border-bottom-color set-border-bottom-color! darkseagreen) - (border-left-color set-border-left-color! goldenrod) - (border-right-color set-border-right-color! purple) - (border-width set-border-width! ,(make-css-length 20 'pt)) - (border-top-width set-border-top-width! ,(make-css-length 15 'pt)) - (border-bottom-width set-border-bottom-width! ,(make-css-length 15 'pt)) - (border-left-width set-border-left-width! ,(make-css-length 15 'pt)) - (border-right-width set-border-right-width! ,(make-css-length 15 'pt)) - (border-bottom-width set-border-bottom-width! ,(make-css-length 30 'pt)) - (border-left-width set-border-left-width! ,(make-css-length 30 'em)) - (border-right-width set-border-right-width! ,(make-css-length 1 'in)) - (border-style set-border-style! solid) - (border-top-style set-border-top-style! none) - (border-bottom-style set-border-bottom-style! dashed) - (border-left-style set-border-left-style! dotted) - (border-right-style set-border-right-style! none) - (style-float set-style-float! left) - (display set-display! list-item) - (list-style-type set-list-style-type! lower-roman) - (list-style-position set-list-style-position! inside) - (visibility set-visibility! hidden) - (clip set-clip! - (,(make-css-length 2 'cm) auto - ,(make-css-length 5 'in) auto)) - (clip set-clip! - (,(make-css-length 2 'cm) auto - ,(make-css-length 5 'in) auto)) - (style-float set-style-float! left) - (clear set-clear! both) - (width set-width! ,(make-css-percentage 50)) - (height set-height! ,(make-css-percentage 50)) - (top set-top! auto) - (left set-left! auto) - (z-index set-z-index! 4))) - -(for-each - (lambda (t) - (apply test-prop t)) - tests) - -; filter test - -(define filter-spec - '(glow (strength 99) (enabled #t) (color "#ff00ff"))) - -(apply (ivar/proc txt 'set-filter!) filter-spec) - -(let ([result (send txt filter)]) - (if (equal? result filter-spec) - (printf "Checking filter~n") - (error (format "filter test: Expected ~a, got ~a~n" - filter-spec result)))) - diff --git a/collects/tests/mysterx/mystests.ss b/collects/tests/mysterx/mystests.ss deleted file mode 100644 index 6502acb2..00000000 --- a/collects/tests/mysterx/mystests.ss +++ /dev/null @@ -1,71 +0,0 @@ -;;; mystests.ss -- test suite for MysterX - -(require-library "mysterx.ss" "mysterx") - -(define wb (make-object mx-browser% "MysTest" 230 250)) -(define doc (send wb current-document)) - -(define ctrl (send doc insert-object "TestControl Class" 95 95 'percent)) - -(define (inv f . args) (apply com-invoke ctrl f args)) - -(define errors? #f) - -(define tests - `(("AddTest" (39 ,(box 420)) ,(+ 39 420)) - ("AddTest" (420 ,(box 39)) ,(+ 420 39)) - ("FloatTest" (4.7 5.2) ,(- 5.2 4.7)) - ("FloatTest" (88.7 33.2) ,(- 33.2 88.7)) - ("FloatTest" (-88.7 33.2) ,(- 33.2 -88.7)) - ("StringTest" ("abc" "def") ,"abcdef") - ("StringTest" ("Supercali" "fragilistic") ,"Supercalifragilistic") - ("ShortTest" (42 17) ,(* 42 17)) - ("ShortTest" (77 -22) ,(* 77 -22)))) - -(for-each - (lambda (t) - (let ([got (apply inv (car t) (cadr t))] - [expected (caddr t)]) - (unless (equal? got expected) - (set! errors? #t) - (printf "Expected: ~a~nGot : ~a~n" - expected got)))) - tests) - -(define caption "SomeCaption") - -(com-set-property! ctrl "Caption" caption) - -(unless (string=? caption (com-get-property ctrl "Caption")) - (set! errors? #t)) - -(when errors? - (printf "There were errors!~n")) - -(define (make-mousefun s) - (let ([t (string-append s ": button = ~a shift = ~a x = ~a y = ~a~n")]) - (lambda (button shift x y) - (printf t button shift x y)))) - -(define (mouse-pair s) - (list s (make-mousefun s))) - -(unless errors? - (for-each - (lambda (sf) - (com-register-event-handler ctrl (car sf) (cadr sf))) - `(("Click" - ,(lambda () (printf "Click~n"))) - ,(mouse-pair "MouseMove") - ,(mouse-pair "MouseDown") - ,(mouse-pair "MouseUp"))) - - (printf "Try clicking and moving the mouse over the object~n") - (printf "You should see Click, MouseMove, MouseDown, and MouseUp events~n")) - - - - - - - diff --git a/collects/tests/mysterx/src/Makefile b/collects/tests/mysterx/src/Makefile deleted file mode 100644 index 75fbf3a1..00000000 --- a/collects/tests/mysterx/src/Makefile +++ /dev/null @@ -1,2 +0,0 @@ -all : - nmake /f testobject.mak diff --git a/collects/tests/mysterx/src/resource.h b/collects/tests/mysterx/src/resource.h deleted file mode 100644 index 862c34d5..00000000 --- a/collects/tests/mysterx/src/resource.h +++ /dev/null @@ -1,18 +0,0 @@ -//{{NO_DEPENDENCIES}} -// Microsoft Developer Studio generated include file. -// Used by testobject.rc -// -#define IDS_PROJNAME 100 -#define IDB_TESTCONTROL 101 -#define IDR_TESTCONTROL 102 - -// Next default values for new objects -// -#ifdef APSTUDIO_INVOKED -#ifndef APSTUDIO_READONLY_SYMBOLS -#define _APS_NEXT_RESOURCE_VALUE 201 -#define _APS_NEXT_COMMAND_VALUE 32768 -#define _APS_NEXT_CONTROL_VALUE 201 -#define _APS_NEXT_SYMED_VALUE 103 -#endif -#endif diff --git a/collects/tests/mysterx/src/stdafx.cxx b/collects/tests/mysterx/src/stdafx.cxx deleted file mode 100644 index a5eea178..00000000 --- a/collects/tests/mysterx/src/stdafx.cxx +++ /dev/null @@ -1,12 +0,0 @@ -// stdafx.cpp : source file that includes just the standard includes -// stdafx.pch will be the pre-compiled header -// stdafx.obj will contain the pre-compiled type information - -#include "stdafx.h" - -#ifdef _ATL_STATIC_REGISTRY -#include -#include -#endif - -#include diff --git a/collects/tests/mysterx/src/stdafx.h b/collects/tests/mysterx/src/stdafx.h deleted file mode 100644 index 79976b0b..00000000 --- a/collects/tests/mysterx/src/stdafx.h +++ /dev/null @@ -1,28 +0,0 @@ -// stdafx.h : include file for standard system include files, -// or project specific include files that are used frequently, -// but are changed infrequently - -#if !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_) -#define AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED_ - -#if _MSC_VER > 1000 -#pragma once -#endif // _MSC_VER > 1000 - -#define STRICT -#ifndef _WIN32_WINNT -#define _WIN32_WINNT 0x0400 -#endif -#define _ATL_APARTMENT_THREADED - -#include -//You may derive a class from CComModule and use it if you want to override -//something, but do not change the name of _Module -extern CComModule _Module; -#include -#include - -//{{AFX_INSERT_LOCATION}} -// Microsoft Visual C++ will insert additional declarations immediately before the previous line. - -#endif // !defined(AFX_STDAFX_H__07B31FF3_19EE_11D3_B5DB_0060089002FE__INCLUDED) diff --git a/collects/tests/mysterx/src/testcont.bmp b/collects/tests/mysterx/src/testcont.bmp deleted file mode 100644 index 12297649..00000000 Binary files a/collects/tests/mysterx/src/testcont.bmp and /dev/null differ diff --git a/collects/tests/mysterx/src/testcontrol.cxx b/collects/tests/mysterx/src/testcontrol.cxx deleted file mode 100644 index 22563ffc..00000000 --- a/collects/tests/mysterx/src/testcontrol.cxx +++ /dev/null @@ -1,51 +0,0 @@ -// TestControl.cpp : Implementation of CTestControl - -#include "stdafx.h" -#include "Testobject.h" -#include "TestControl.h" - -///////////////////////////////////////////////////////////////////////////// -// CTestControl - - - -STDMETHODIMP CTestControl::AddTest(long n1, long *n2, long *n3) -{ - // note side effect - - - *n3 = n1 + *n2; - - *n2 = n1; - - return S_OK; -} - -STDMETHODIMP CTestControl::StringTest(BSTR s1, BSTR s2, BSTR *s3) -{ - int len1,len2; - - len1 = SysStringLen(s1); - len2 = SysStringLen(s2); - - *s3 = SysAllocStringByteLen(NULL,(len1 + len2 + 1)*2); - wcsncpy(*s3,s1,len1); - wcsncpy(*s3 + len1,s2,len2); - *(*s3 + len1 + len2) = L'\0'; - - return S_OK; -} - -STDMETHODIMP CTestControl::ShortTest(short n1, short n2, short *n3) -{ - *n3 = n1 * n2; - - return S_OK; -} - -STDMETHODIMP CTestControl::FloatTest(double n1, double n2, double *n3) -{ - *n3 = n2 - n1; - - return S_OK; -} diff --git a/collects/tests/mysterx/src/testcontrol.h b/collects/tests/mysterx/src/testcontrol.h deleted file mode 100644 index 90787c21..00000000 --- a/collects/tests/mysterx/src/testcontrol.h +++ /dev/null @@ -1,172 +0,0 @@ -// TestControl.h : Declaration of the CTestControl - -#ifndef __TESTCONTROL_H_ -#define __TESTCONTROL_H_ - -#include "resource.h" // main symbols -#include -#include -#include "testobjectCP.h" - - -///////////////////////////////////////////////////////////////////////////// -// CTestControl -class ATL_NO_VTABLE CTestControl : - public CComObjectRootEx, - public CStockPropImpl, - public CComControl, - public IPersistStreamInitImpl, - public IOleControlImpl, - public IOleObjectImpl, - public IOleInPlaceActiveObjectImpl, - public IViewObjectExImpl, - public IOleInPlaceObjectWindowlessImpl, - public IConnectionPointContainerImpl, - public IPersistStorageImpl, - public ISpecifyPropertyPagesImpl, - public IQuickActivateImpl, - public IDataObjectImpl, - public IProvideClassInfo2Impl<&CLSID_TestControl, &DIID__ITestControlEvents, &LIBID_TESTOBJECTLib>, - public IPropertyNotifySinkCP, - public CComCoClass, - public CProxy_ITestControlEvents< CTestControl > -{ -public: - CTestControl() - { - } - -DECLARE_REGISTRY_RESOURCEID(IDR_TESTCONTROL) - -DECLARE_PROTECT_FINAL_CONSTRUCT() - -BEGIN_COM_MAP(CTestControl) - COM_INTERFACE_ENTRY(ITestControl) - COM_INTERFACE_ENTRY(IDispatch) - COM_INTERFACE_ENTRY(IViewObjectEx) - COM_INTERFACE_ENTRY(IViewObject2) - COM_INTERFACE_ENTRY(IViewObject) - COM_INTERFACE_ENTRY(IOleInPlaceObjectWindowless) - COM_INTERFACE_ENTRY(IOleInPlaceObject) - COM_INTERFACE_ENTRY2(IOleWindow, IOleInPlaceObjectWindowless) - COM_INTERFACE_ENTRY(IOleInPlaceActiveObject) - COM_INTERFACE_ENTRY(IOleControl) - COM_INTERFACE_ENTRY(IOleObject) - COM_INTERFACE_ENTRY(IPersistStreamInit) - COM_INTERFACE_ENTRY2(IPersist, IPersistStreamInit) - COM_INTERFACE_ENTRY(IConnectionPointContainer) - COM_INTERFACE_ENTRY(ISpecifyPropertyPages) - COM_INTERFACE_ENTRY(IQuickActivate) - COM_INTERFACE_ENTRY(IPersistStorage) - COM_INTERFACE_ENTRY(IDataObject) - COM_INTERFACE_ENTRY(IProvideClassInfo) - COM_INTERFACE_ENTRY(IProvideClassInfo2) - COM_INTERFACE_ENTRY_IMPL(IConnectionPointContainer) -END_COM_MAP() - -BEGIN_PROP_MAP(CTestControl) - PROP_DATA_ENTRY("_cx", m_sizeExtent.cx, VT_UI4) - PROP_DATA_ENTRY("_cy", m_sizeExtent.cy, VT_UI4) - PROP_ENTRY("Caption", DISPID_CAPTION, CLSID_NULL) - // Example entries - // PROP_ENTRY("Property Description", dispid, clsid) - // PROP_PAGE(CLSID_StockColorPage) -END_PROP_MAP() - -BEGIN_CONNECTION_POINT_MAP(CTestControl) - CONNECTION_POINT_ENTRY(IID_IPropertyNotifySink) - CONNECTION_POINT_ENTRY(DIID__ITestControlEvents) -END_CONNECTION_POINT_MAP() - -BEGIN_MSG_MAP(CTestControl) - CHAIN_MSG_MAP(CComControl) - DEFAULT_REFLECTION_HANDLER() - MESSAGE_HANDLER(WM_LBUTTONDOWN, OnLButtonDown) - MESSAGE_HANDLER(WM_LBUTTONUP, OnLButtonUp) - MESSAGE_HANDLER(WM_MBUTTONDOWN, OnMButtonDown) - MESSAGE_HANDLER(WM_MBUTTONUP, OnMButtonUp) - MESSAGE_HANDLER(WM_RBUTTONDOWN, OnRButtonDown) - MESSAGE_HANDLER(WM_RBUTTONUP, OnRButtonUp) - MESSAGE_HANDLER(WM_MOUSEMOVE, OnMouseMove) -END_MSG_MAP() -// Handler prototypes: -// LRESULT MessageHandler(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled); -// LRESULT CommandHandler(WORD wNotifyCode, WORD wID, HWND hWndCtl, BOOL& bHandled); -// LRESULT NotifyHandler(int idCtrl, LPNMHDR pnmh, BOOL& bHandled); - - - -// IViewObjectEx - DECLARE_VIEW_STATUS(VIEWSTATUS_SOLIDBKGND | VIEWSTATUS_OPAQUE) - -// ITestControl -public: - STDMETHOD(FloatTest)(double n1,double n2,/*[out,retval]*/double *n3); - STDMETHOD(ShortTest)(short int n1,short int n2,/*[out,retval]*/short int *n3); - STDMETHOD(StringTest)(BSTR s1,BSTR s2,/*[out,retval]*/BSTR *s3); - STDMETHOD(AddTest)(long n1,long *n2,/*[out,retval]*/long *n3); - - HRESULT OnDraw(ATL_DRAWINFO& di) - { - RECT& rc = *(RECT*)di.prcBounds; - Rectangle(di.hdcDraw, rc.left, rc.top, rc.right, rc.bottom); - - SetTextAlign(di.hdcDraw, TA_CENTER|TA_BASELINE); - LPCTSTR pszText = _T("MysterX Test Control"); - TextOut(di.hdcDraw, - (rc.left + rc.right) / 2, - (rc.top + rc.bottom) / 2, - pszText, - lstrlen(pszText)); - - return S_OK; - } - CComBSTR m_bstrCaption; - LRESULT OnLButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) - { - Fire_MouseDown(0x1,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); - Fire_Click(); - return DefWindowProc(uMsg,wParam,lParam); - } - LRESULT OnLButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) - { - Fire_MouseUp(0x1,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); - return DefWindowProc(uMsg,wParam,lParam); - } - LRESULT OnMButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) - { - Fire_MouseDown(0x4,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); - Fire_Click(); - return DefWindowProc(uMsg,wParam,lParam); - } - LRESULT OnMButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) - { - Fire_MouseUp(0x4,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); - return DefWindowProc(uMsg,wParam,lParam); - } - LRESULT OnRButtonDown(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) - { - Fire_MouseDown(0x2,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); - Fire_Click(); - return DefWindowProc(uMsg,wParam,lParam); - } - LRESULT OnRButtonUp(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) - { - Fire_MouseUp(0x2,wParam,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); - return DefWindowProc(uMsg,wParam,lParam); - } - LRESULT OnMouseMove(UINT uMsg, WPARAM wParam, LPARAM lParam, BOOL& bHandled) - { - short button; - short shift; - - button = wParam & (MK_LBUTTON | MK_MBUTTON | MK_RBUTTON); - shift = wParam & (MK_CONTROL | MK_SHIFT); - - Fire_MouseMove(button,shift,GET_X_LPARAM(lParam),GET_Y_LPARAM(lParam)); - - return DefWindowProc(uMsg,wParam,lParam); - } -}; - -#endif //__TESTCONTROL_H_ diff --git a/collects/tests/mysterx/src/testcontrol.rgs b/collects/tests/mysterx/src/testcontrol.rgs deleted file mode 100644 index 8c369919..00000000 --- a/collects/tests/mysterx/src/testcontrol.rgs +++ /dev/null @@ -1,34 +0,0 @@ -HKCR -{ - Testobject.TestControl.1 = s 'TestControl Class' - { - CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}' - } - Testobject.TestControl = s 'TestControl Class' - { - CLSID = s '{FED8FE26-19CA-11D3-B5DB-0060089002FE}' - CurVer = s 'Testobject.TestControl.1' - } - NoRemove CLSID - { - ForceRemove {FED8FE26-19CA-11D3-B5DB-0060089002FE} = s 'TestControl Class' - { - ProgID = s 'Testobject.TestControl.1' - VersionIndependentProgID = s 'Testobject.TestControl' - ForceRemove 'Programmable' - InprocServer32 = s '%MODULE%' - { - val ThreadingModel = s 'Apartment' - } - ForceRemove 'Control' - ForceRemove 'Insertable' - ForceRemove 'ToolboxBitmap32' = s '%MODULE%, 101' - 'MiscStatus' = s '0' - { - '1' = s '131473' - } - 'TypeLib' = s '{07B31FF0-19EE-11D3-B5DB-0060089002FE}' - 'Version' = s '1.0' - } - } -} diff --git a/collects/tests/mysterx/src/testobject.cxx b/collects/tests/mysterx/src/testobject.cxx deleted file mode 100644 index 6f5f57a1..00000000 --- a/collects/tests/mysterx/src/testobject.cxx +++ /dev/null @@ -1,72 +0,0 @@ -// testobject.cpp : Implementation of DLL Exports. - - -// Note: Proxy/Stub Information -// To build a separate proxy/stub DLL, -// run nmake -f testobjectps.mk in the project directory. - -#include "stdafx.h" -#include "resource.h" -#include -#include "testobject.h" - -#include "testobject_i.c" -#include "TestControl.h" - - -CComModule _Module; - -BEGIN_OBJECT_MAP(ObjectMap) -OBJECT_ENTRY(CLSID_TestControl, CTestControl) -END_OBJECT_MAP() - -///////////////////////////////////////////////////////////////////////////// -// DLL Entry Point - -extern "C" -BOOL WINAPI DllMain(HINSTANCE hInstance, DWORD dwReason, LPVOID /*lpReserved*/) -{ - if (dwReason == DLL_PROCESS_ATTACH) - { - _Module.Init(ObjectMap, hInstance, &LIBID_TESTOBJECTLib); - DisableThreadLibraryCalls(hInstance); - } - else if (dwReason == DLL_PROCESS_DETACH) - _Module.Term(); - return TRUE; // ok -} - -///////////////////////////////////////////////////////////////////////////// -// Used to determine whether the DLL can be unloaded by OLE - -STDAPI DllCanUnloadNow(void) -{ - return (_Module.GetLockCount()==0) ? S_OK : S_FALSE; -} - -///////////////////////////////////////////////////////////////////////////// -// Returns a class factory to create an object of the requested type - -STDAPI DllGetClassObject(REFCLSID rclsid, REFIID riid, LPVOID* ppv) -{ - return _Module.GetClassObject(rclsid, riid, ppv); -} - -///////////////////////////////////////////////////////////////////////////// -// DllRegisterServer - Adds entries to the system registry - -STDAPI DllRegisterServer(void) -{ - // registers object, typelib and all interfaces in typelib - return _Module.RegisterServer(TRUE); -} - -///////////////////////////////////////////////////////////////////////////// -// DllUnregisterServer - Removes entries from the system registry - -STDAPI DllUnregisterServer(void) -{ - return _Module.UnregisterServer(TRUE); -} - - diff --git a/collects/tests/mysterx/src/testobject.def b/collects/tests/mysterx/src/testobject.def deleted file mode 100644 index 9dd3b921..00000000 --- a/collects/tests/mysterx/src/testobject.def +++ /dev/null @@ -1,9 +0,0 @@ -; testobject.def : Declares the module parameters. - -LIBRARY "testobject.DLL" - -EXPORTS - DllCanUnloadNow @1 PRIVATE - DllGetClassObject @2 PRIVATE - DllRegisterServer @3 PRIVATE - DllUnregisterServer @4 PRIVATE diff --git a/collects/tests/mysterx/src/testobject.idl b/collects/tests/mysterx/src/testobject.idl deleted file mode 100644 index 8176914b..00000000 --- a/collects/tests/mysterx/src/testobject.idl +++ /dev/null @@ -1,66 +0,0 @@ -// testobject.idl : IDL source for testobject.dll -// - -// This file will be processed by the MIDL tool to -// produce the type library (testobject.tlb) and marshalling code. - -import "oaidl.idl"; -import "ocidl.idl"; -#include "olectl.h" - - - [ - object, - uuid(07B31FFC-19EE-11D3-B5DB-0060089002FE), - dual, - helpstring("ITestControl Interface"), - pointer_default(unique) - ] - interface ITestControl : IDispatch - { - [propput, id(DISPID_CAPTION)] - HRESULT Caption([in]BSTR strCaption); - [propget, id(DISPID_CAPTION)] - HRESULT Caption([out,retval]BSTR* pstrCaption); - [id(1), helpstring("method AddTest")] HRESULT AddTest(long n1,long *n2,[out,retval]long *n3); - [id(2), helpstring("method StringTest")] HRESULT StringTest(BSTR s1,BSTR s2,[out,retval]BSTR *s3); - [id(3), helpstring("method ShortTest")] HRESULT ShortTest(short int n1,short int n2,[out,retval]short int *n3); - [id(4), helpstring("method FloatTest")] HRESULT FloatTest(double n1,double n2,[out,retval]double *n3); - }; - -[ - uuid(07B31FF0-19EE-11D3-B5DB-0060089002FE), - version(1.0), - helpstring("testobject 1.0 Type Library") -] -library TESTOBJECTLib -{ - importlib("stdole32.tlb"); - importlib("stdole2.tlb"); - - [ - uuid(07B31FFD-19EE-11D3-B5DB-0060089002FE), - helpstring("_ITestControlEvents Interface") - ] - dispinterface _ITestControlEvents - { - properties: - methods: - [id(DISPID_CLICK), helpstring("method Click")] HRESULT Click(); - [id(DISPID_MOUSEDOWN), helpstring("method MouseDown")] HRESULT MouseDown(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y); - [id(DISPID_MOUSEUP), helpstring("method MouseUp")] HRESULT MouseUp(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y); - [id(1), helpstring("method KeyDown")] HRESULT KeyDown(short *keyCode,short shift); - [id(2), helpstring("method KeyUp")] HRESULT KeyUp(short *keyCode,short shift); - [id(3), helpstring("method MouseMove")] HRESULT MouseMove(short button,short shift,OLE_XPOS_PIXELS x,OLE_YPOS_PIXELS y); - }; - - [ - uuid(FED8FE26-19CA-11D3-B5DB-0060089002FE), - helpstring("TestControl Class") - ] - coclass TestControl - { - [default] interface ITestControl; - [default, source] dispinterface _ITestControlEvents; - }; -}; diff --git a/collects/tests/mysterx/src/testobject.mak b/collects/tests/mysterx/src/testobject.mak deleted file mode 100644 index 3e78fd67..00000000 --- a/collects/tests/mysterx/src/testobject.mak +++ /dev/null @@ -1,48 +0,0 @@ -# mysterx.mak - -all : testobject.dll - -clean : - -@erase testcontrol.obj - -@erase testobject.obj - -@erase testobject.dll - -CPP=cl.exe -CPP_FLAGS=/MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "_ATL_STATIC_REGISTRY" /D "_ATL_MIN_CRT" /c - -MTL=midl.exe -MTL_SWITCHES=/tlb testobject.tlb /h testobject.h /iid testobject_i.c /Oicf -RSC=rc.exe -RSC_PROJ=/l 0x409 /fo"testobject.res" -REGSVR32=regsvr32 - -.cxx.obj:: - $(CPP) $(CPP_FLAGS) $< - -MZC="C:\Program Files\PLT\mzc" - -LINK32=link.exe -LINK32_FLAGS= \ - kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib \ - advapi32.lib ole32.lib oleaut32.lib \ - uuid.lib odbc32.lib odbccp32.lib \ - /nologo /subsystem:windows /dll /incremental:no /machine:I386 \ - /def:testobject.def /out:testobject.dll -DEF_FILE=testobject.def -LINK32_OBJS= \ - testobject.obj testcontrol.obj testobject.res - -testobject.dll : $(DEF_FILE) $(LINK32_OBJS) - $(LINK32) $(LINK32_FLAGS) $(LINK32_OBJS) - $(REGSVR32) /s testobject.dll - -testcontrol.obj : testcontrol.cxx testobject.tlb stdafx.h - -testobject.obj : testobject.cxx stdafx.h - -testobject.tlb : testobject.idl - $(MTL) $(MTL_SWITCHES) testobject.idl - -testcontrol.res : testcontrol.rc testcontrol.tlb - $(RSC) $(RSC_PROJ) testcontrol.rc - diff --git a/collects/tests/mysterx/src/testobject.rc b/collects/tests/mysterx/src/testobject.rc deleted file mode 100644 index 0ae3fa9c..00000000 --- a/collects/tests/mysterx/src/testobject.rc +++ /dev/null @@ -1,132 +0,0 @@ -//Microsoft Developer Studio generated resource script. -// -#include "resource.h" - -#define APSTUDIO_READONLY_SYMBOLS -///////////////////////////////////////////////////////////////////////////// -// -// Generated from the TEXTINCLUDE 2 resource. -// -#include "winres.h" - -///////////////////////////////////////////////////////////////////////////// -#undef APSTUDIO_READONLY_SYMBOLS - -///////////////////////////////////////////////////////////////////////////// -// English (U.S.) resources - -#if !defined(AFX_RESOURCE_DLL) || defined(AFX_TARG_ENU) -#ifdef _WIN32 -LANGUAGE LANG_ENGLISH, SUBLANG_ENGLISH_US -#pragma code_page(1252) -#endif //_WIN32 - -#ifdef APSTUDIO_INVOKED -///////////////////////////////////////////////////////////////////////////// -// -// TEXTINCLUDE -// - -1 TEXTINCLUDE DISCARDABLE -BEGIN - "resource.h\0" -END - -2 TEXTINCLUDE DISCARDABLE -BEGIN - "#include ""winres.h""\r\n" - "\0" -END - -3 TEXTINCLUDE DISCARDABLE -BEGIN - "1 TYPELIB ""testobject.tlb""\r\n" - "\0" -END - -#endif // APSTUDIO_INVOKED - - -#ifndef _MAC -///////////////////////////////////////////////////////////////////////////// -// -// Version -// - -VS_VERSION_INFO VERSIONINFO - FILEVERSION 1,0,0,1 - PRODUCTVERSION 1,0,0,1 - FILEFLAGSMASK 0x3fL -#ifdef _DEBUG - FILEFLAGS 0x1L -#else - FILEFLAGS 0x0L -#endif - FILEOS 0x4L - FILETYPE 0x2L - FILESUBTYPE 0x0L -BEGIN - BLOCK "StringFileInfo" - BEGIN - BLOCK "040904B0" - BEGIN - VALUE "CompanyName", "\0" - VALUE "FileDescription", "testobject Module\0" - VALUE "FileVersion", "1, 0, 0, 1\0" - VALUE "InternalName", "testobject\0" - VALUE "LegalCopyright", "Copyright 1999\0" - VALUE "OriginalFilename", "testobject.DLL\0" - VALUE "ProductName", "testobject Module\0" - VALUE "ProductVersion", "1, 0, 0, 1\0" - VALUE "OLESelfRegister", "\0" - END - END - BLOCK "VarFileInfo" - BEGIN - VALUE "Translation", 0x409, 1200 - END -END - -#endif // !_MAC - - -///////////////////////////////////////////////////////////////////////////// -// -// Bitmap -// - -IDB_TESTCONTROL BITMAP DISCARDABLE "testcont.bmp" - - -///////////////////////////////////////////////////////////////////////////// -// -// REGISTRY -// - -IDR_TESTCONTROL REGISTRY DISCARDABLE "TestControl.rgs" - -///////////////////////////////////////////////////////////////////////////// -// -// String Table -// - -STRINGTABLE DISCARDABLE -BEGIN - IDS_PROJNAME "testobject" -END - -#endif // English (U.S.) resources -///////////////////////////////////////////////////////////////////////////// - - - -#ifndef APSTUDIO_INVOKED -///////////////////////////////////////////////////////////////////////////// -// -// Generated from the TEXTINCLUDE 3 resource. -// -1 TYPELIB "testobject.tlb" - -///////////////////////////////////////////////////////////////////////////// -#endif // not APSTUDIO_INVOKED - diff --git a/collects/tests/mysterx/src/testobjectCP.h b/collects/tests/mysterx/src/testobjectCP.h deleted file mode 100644 index 9f65ed24..00000000 --- a/collects/tests/mysterx/src/testobjectCP.h +++ /dev/null @@ -1,179 +0,0 @@ -#ifndef _TESTOBJECTCP_H_ -#define _TESTOBJECTCP_H_ - - - - - - -template -class CProxy_ITestControlEvents : public IConnectionPointImpl -{ - //Warning this class may be recreated by the wizard. -public: - HRESULT Fire_Click() - { - CComVariant varResult; - T* pT = static_cast(this); - int nConnectionIndex; - int nConnections = m_vec.GetSize(); - - for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) - { - pT->Lock(); - CComPtr sp = m_vec.GetAt(nConnectionIndex); - pT->Unlock(); - IDispatch* pDispatch = reinterpret_cast(sp.p); - if (pDispatch != NULL) - { - VariantClear(&varResult); - DISPPARAMS disp = { NULL, NULL, 0, 0 }; - pDispatch->Invoke(DISPID_CLICK, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); - } - } - return varResult.scode; - - } - HRESULT Fire_MouseDown(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y) - { - CComVariant varResult; - T* pT = static_cast(this); - int nConnectionIndex; - CComVariant* pvars = new CComVariant[4]; - int nConnections = m_vec.GetSize(); - - for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) - { - pT->Lock(); - CComPtr sp = m_vec.GetAt(nConnectionIndex); - pT->Unlock(); - IDispatch* pDispatch = reinterpret_cast(sp.p); - if (pDispatch != NULL) - { - VariantClear(&varResult); - pvars[3] = button; - pvars[2] = shift; - pvars[1] = x; - pvars[0] = y; - DISPPARAMS disp = { pvars, NULL, 4, 0 }; - pDispatch->Invoke(DISPID_MOUSEDOWN, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); - } - } - delete[] pvars; - return varResult.scode; - - } - HRESULT Fire_MouseUp(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y) - { - CComVariant varResult; - T* pT = static_cast(this); - int nConnectionIndex; - CComVariant* pvars = new CComVariant[4]; - int nConnections = m_vec.GetSize(); - - for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) - { - pT->Lock(); - CComPtr sp = m_vec.GetAt(nConnectionIndex); - pT->Unlock(); - IDispatch* pDispatch = reinterpret_cast(sp.p); - if (pDispatch != NULL) - { - VariantClear(&varResult); - pvars[3] = button; - pvars[2] = shift; - pvars[1] = x; - pvars[0] = y; - DISPPARAMS disp = { pvars, NULL, 4, 0 }; - pDispatch->Invoke(DISPID_MOUSEUP, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); - } - } - delete[] pvars; - return varResult.scode; - - } - HRESULT Fire_KeyDown(SHORT * keyCode, SHORT shift) - { - CComVariant varResult; - T* pT = static_cast(this); - int nConnectionIndex; - CComVariant* pvars = new CComVariant[2]; - int nConnections = m_vec.GetSize(); - - for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) - { - pT->Lock(); - CComPtr sp = m_vec.GetAt(nConnectionIndex); - pT->Unlock(); - IDispatch* pDispatch = reinterpret_cast(sp.p); - if (pDispatch != NULL) - { - VariantClear(&varResult); - pvars[1] = keyCode; - pvars[0] = shift; - DISPPARAMS disp = { pvars, NULL, 2, 0 }; - pDispatch->Invoke(0x1, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); - } - } - delete[] pvars; - return varResult.scode; - - } - HRESULT Fire_KeyUp(SHORT *keyCode, SHORT shift) - { - CComVariant varResult; - T* pT = static_cast(this); - int nConnectionIndex; - CComVariant* pvars = new CComVariant[2]; - int nConnections = m_vec.GetSize(); - - for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) - { - pT->Lock(); - CComPtr sp = m_vec.GetAt(nConnectionIndex); - pT->Unlock(); - IDispatch* pDispatch = reinterpret_cast(sp.p); - if (pDispatch != NULL) - { - VariantClear(&varResult); - pvars[1] = keyCode; - pvars[0] = shift; - DISPPARAMS disp = { pvars, NULL, 2, 0 }; - pDispatch->Invoke(0x2, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); - } - } - delete[] pvars; - return varResult.scode; - - } - HRESULT Fire_MouseMove(SHORT button, SHORT shift, OLE_XPOS_PIXELS x, OLE_YPOS_PIXELS y) - { - CComVariant varResult; - T* pT = static_cast(this); - int nConnectionIndex; - CComVariant* pvars = new CComVariant[4]; - int nConnections = m_vec.GetSize(); - - for (nConnectionIndex = 0; nConnectionIndex < nConnections; nConnectionIndex++) - { - pT->Lock(); - CComPtr sp = m_vec.GetAt(nConnectionIndex); - pT->Unlock(); - IDispatch* pDispatch = reinterpret_cast(sp.p); - if (pDispatch != NULL) - { - VariantClear(&varResult); - pvars[3] = button; - pvars[2] = shift; - pvars[1] = x; - pvars[0] = y; - DISPPARAMS disp = { pvars, NULL, 4, 0 }; - pDispatch->Invoke(0x3, IID_NULL, LOCALE_USER_DEFAULT, DISPATCH_METHOD, &disp, &varResult, NULL, NULL); - } - } - delete[] pvars; - return varResult.scode; - - } -}; -#endif \ No newline at end of file diff --git a/collects/tests/mzscheme/README b/collects/tests/mzscheme/README deleted file mode 100644 index 32bca41e..00000000 --- a/collects/tests/mzscheme/README +++ /dev/null @@ -1,44 +0,0 @@ - -To run most of the tests, run: - > (load "PATHTOHERE/all.ss") -where PATHTOHERE is the path to this directory. - -Test failures may cause the test to stop before finishing, but most -test failures will let the test continue, and a summary message at the -end will enummerate the failures that occurred. - -Some files are directories are created (in the current directory) -during the run. The files are named "tmp" where is a number. -The directory is named "deep". If the test suite passes, the directory -should be removed, but some "tmp" files will remain. (The "tmp" -files are automatically replaced if the test suite is run again.) - -Unless your machine clock is always exactly in sync with your disk, -don't worry about failures that look like this: - ((path) (#f #t (#<|primitive:<=|> 11 39 11))) - ((path) (#f #t (#<|primitive:<=|> 11 39 11))) - ((path) (#f #t (#<|primitive:<=|> 11 39 11))) - -Additionally, test expand-defmacro by running: - > (load "PATHTOHERE/expand.ss") - -Test compilation and writing/reading compiled code with: - > (load "PATHTOHERE/compile.ss") - -Test deep non-tail recursion with: - > (load "PATHTOHERE/deep.ss") - -Run the standard tests with no output except for the results with: - > (load "PATHTOHERE/quiet.ss") - -Run 3 copies of the test suite concurrently in separate threads: - > (load "PATHTOHERE/parallel.ss") - -MzLib tests are run with: - > (load "PATHTOHERE/mzlib.ss") - - -Please report bugs using - http://www.cs.rice.edu/CS/PLT/Bugs/ -or (as a last resort) send mail to - plt-bugs@rice.edu diff --git a/collects/tests/mzscheme/all.ss b/collects/tests/mzscheme/all.ss deleted file mode 100644 index 8c2f2925..00000000 --- a/collects/tests/mzscheme/all.ss +++ /dev/null @@ -1,40 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(load-relative "basic.ss") -(load-relative "read.ss") -(unless (defined? 'building-flat-tests) - (load-relative "macro.ss")) -(load-relative "syntax.ss") -(load-relative "number.ss") -(load-relative "object.ss") -(load-relative "struct.ss") -(load-relative "unit.ss") -(load-relative "unitsig.ss") -(load-relative "thread.ss") -(load-relative "contmark.ss") -(load-relative "will.ss") -(load-relative "namespac.ss") -(unless (or (defined? 'building-flat-tests) - (defined? 'read/zodiac) - (defined? 'in-drscheme?)) - (load-relative "param.ss")) -(load-relative "file.ss") -(load-relative "path.ss") -(unless (defined? 'building-flat-tests) - (load-relative "hashper.ss")) -(unless (or (defined? 'building-flat-tests) - (defined? 'read/zodiac) - (defined? 'in-drscheme?)) - (load-relative "optimize.ss")) -(unless (defined? 'building-flat-tests) - (load-relative "name.ss")) -(unless (defined? 'building-flat-tests) - (load-relative "multi-expand.ss")) - -;; Ok, so this isn't really all of them. Here are more: -; thrport.ss -; deep.ss - -; See also README diff --git a/collects/tests/mzscheme/basic.ss b/collects/tests/mzscheme/basic.ss deleted file mode 100644 index 7018a2ed..00000000 --- a/collects/tests/mzscheme/basic.ss +++ /dev/null @@ -1,1494 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(test '() 'null null) -(test '() 'null ()) - -(let ([f (lambda () #&7)]) - (test #t eq? (f) (f))) - -(SECTION 2 1);; test that all symbol characters are supported. -'(+ - ... !.. $.+ %.- &.! *.: /:. :+. <-. =. >. ?. ~. _. ^.) - -(SECTION 3 4) -(define disjoint-type-functions - (list boolean? char? null? number? pair? procedure? string? symbol? vector?)) -(define type-examples - (list - #t #f #\a '() 9739 '(test) record-error "test" "" 'test '#() '#(a b c) )) -(define i 1) -(for-each (lambda (x) (display (make-string i #\ )) - (set! i (+ 3 i)) - (write x) - (newline)) - disjoint-type-functions) -(define type-matrix - (map (lambda (x) - (let ((t (map (lambda (f) (f x)) disjoint-type-functions))) - (write t) - (write x) - (newline) - t)) - type-examples)) - -(SECTION 6 1) -(test #f not #t) -(test #f not 3) -(test #f not (list 3)) -(test #t not #f) -(test #f not '()) -(test #f not (list)) -(test #f not 'nil) -(arity-test not 1 1) - -(test #t boolean? #f) -(test #t boolean? #t) -(test #f boolean? 0) -(test #f boolean? '()) -(arity-test boolean? 1 1) - -(SECTION 6 2) -(test #t eqv? 'a 'a) -(test #f eqv? 'a 'b) -(test #t eqv? 2 2) -(test #f eqv? 2 2.0) -(test #t eqv? '() '()) -(test #t eqv? '10000 '10000) -(test #t eqv? 10000000000000000000 10000000000000000000) -(test #f eqv? 10000000000000000000 10000000000000000001) -(test #f eqv? 10000000000000000000 20000000000000000000) -(test #f eqv? (cons 1 2) (cons 1 2)) -(test #f eqv? (lambda () 1) (lambda () 2)) -(test #f eqv? #f 'nil) -(let ((p (lambda (x) x))) - (test #t eqv? p p)) -(define gen-counter - (lambda () - (let ((n 0)) - (lambda () (set! n (+ n 1)) n)))) -(let ((g (gen-counter))) (test #t eqv? g g)) -(test #f eqv? (gen-counter) (gen-counter)) -(letrec ((f (lambda () (if (eqv? f g) 'f 'both))) - (g (lambda () (if (eqv? f g) 'g 'both)))) - (test #f eqv? f g)) - -(test #t eq? 'a 'a) -(test #f eq? (list 'a) (list 'a)) -(test #t eq? '() '()) -(test #t eq? car car) -(let ((x '(a))) (test #t eq? x x)) -(let ((x '#())) (test #t eq? x x)) -(let ((x (lambda (x) x))) (test #t eq? x x)) - -(test #t equal? 'a 'a) -(test #t equal? '("a") '("a")) -(test #t equal? '(a) '(a)) -(test #t equal? '(a (b) c) '(a (b) c)) -(test #t equal? '("a" ("b") "c") '("a" ("b") "c")) -(test #t equal? "abc" "abc") -(test #t equal? 2 2) -(test #t equal? (make-vector 5 'a) (make-vector 5 'a)) -(test #t equal? (box "a") (box "a")) -(test #f equal? "" (string #\null)) - -(test #f equal? 'a "a") -(test #f equal? 'a 'b) -(test #f equal? '(a) '(b)) -(test #f equal? '(a (b) d) '(a (b) c)) -(test #f equal? '(a (b) c) '(d (b) c)) -(test #f equal? '(a (b) c) '(a (d) c)) -(test #f equal? "abc" "abcd") -(test #f equal? "abcd" "abc") -(test #f equal? 2 3) -(test #f equal? 2.0 2) -(test #f equal? (make-vector 5 'b) (make-vector 5 'a)) -(test #f equal? (box "a") (box "b")) - -(arity-test eq? 2 2) -(arity-test eqv? 2 2) -(arity-test equal? 2 2) - -(SECTION 6 3) -(test '(a b c d e) 'dot '(a . (b . (c . (d . (e . ())))))) -(define x (list 'a 'b 'c)) -(define y x) -(and list? (test #t list? y)) -(set-cdr! x 4) -(test '(a . 4) 'set-cdr! x) -(test #t eqv? x y) -(test '(a b c . d) 'dot '(a . (b . (c . d)))) -(test #f list? y) -(let ((x (list 'a))) (set-cdr! x x) (test #f list? x)) -(arity-test list? 1 1) - -(test #t pair? '(a . b)) -(test #t pair? '(a . 1)) -(test #t pair? '(a b c)) -(test #f pair? '()) -(test #f pair? '#(a b)) -(arity-test pair? 1 1) - -(test '(a) cons 'a '()) -(test '((a) b c d) cons '(a) '(b c d)) -(test '("a" b c) cons "a" '(b c)) -(test '(a . 3) cons 'a 3) -(test '((a b) . c) cons '(a b) 'c) -(arity-test cons 2 2) - -(test 'a car '(a b c)) -(test '(a) car '((a) b c d)) -(test 1 car '(1 . 2)) -(arity-test car 1 1) -(error-test '(car 1)) - -(test '(b c d) cdr '((a) b c d)) -(test 2 cdr '(1 . 2)) -(arity-test cdr 1 1) -(error-test '(cdr 1)) - -(test '(a 7 c) list 'a (+ 3 4) 'c) -(test '() list) - -(test 3 length '(a b c)) -(test 3 length '(a (b) (c d e))) -(test 0 length '()) -(arity-test length 1 1) -(error-test '(length 1)) -(error-test '(length '(1 . 2))) -(error-test '(length "a")) -; (error-test '(length (quote #0=(1 . #0#)))) -(error-test '(let ([p (cons 1 1)]) (set-cdr! p p) (length p))) -(define x (cons 4 0)) -(set-cdr! x x) -(error-test '(length x)) - -(define l '(1 2 3)) -(set-cdr! l 5) -(test '(1 . 5) 'set-cdr! l) -(set-car! l 0) -(test '(0 . 5) 'set-car! l) -(arity-test set-car! 2 2) -(arity-test set-cdr! 2 2) -(error-test '(set-car! 4 4)) -(error-test '(set-cdr! 4 4)) - -(define (box-tests box unbox box? set-box! set-box!-name unbox-name) - (define b (box 5)) - (test 5 unbox b) - (when set-box! - (set-box! b 6) - (test 6 unbox b)) - (test #t box? b) - (test #f box? 5) - (arity-test box 1 1) - (arity-test unbox 1 1) - (arity-test box? 1 1) - (when set-box! - (arity-test set-box! 2 2)) - (error-test `(,unbox-name 8)) - (when set-box! - (error-test `(,set-box!-name 8 8)))) -(box-tests box unbox box? set-box! 'set-box! 'unbox) -(box-tests make-weak-box weak-box-value weak-box? #f #f 'weak-box-value) - -(test '(x y) append '(x) '(y)) -(test '(a b c d) append '(a) '(b c d)) -(test '(a (b) (c)) append '(a (b)) '((c))) -(test '() append) -(test '(a b c . d) append '(a b) '(c . d)) -(test 'a append '() 'a) -(test 1 append 1) -(test '(1 . 2) append '(1) 2) -(test '(1 . 2) append '(1) 2) -(error-test '(append '(1 2 . 3) 1)) -(error-test '(append '(1 2 3) 1 '(4 5 6))) -(test '(x y) append! '(x) '(y)) -(test '(a b c d) append! '(a) '(b c d)) -(test '(a (b) (c)) append! '(a (b)) '((c))) -(test '() append!) -(test '(a b c . d) append! '(a b) '(c . d)) -(test 'a append! '() 'a) -(test 1 append! 1) -(error-test '(append! '(1 2 . 3) 1)) -(error-test '(append! '(1 2 3) 1 '(4 5 6))) - -(define l '(1 2)) -(define l2 '(3 4 . 7)) -(define l3 (append l l2)) -(test '(1 2 3 4 . 7) 'append l3) -(set-car! l2 5) -(test '(1 2 5 4 . 7) 'append l3) -(set-car! l3 0) -(test '(0 2 5 4 . 7) 'append l3) -(test '(1 2) 'append l) - -(let* ([l '(1 2)] - [l2 '(3 4 . 7)] - [l3 (append! l l2)]) - (test '(1 2 3 4 . 7) 'append! l3) - (set-car! l2 5) - (test '(1 2 5 4 . 7) 'append! l3) - (set-car! l3 0) - (test '(0 2 5 4 . 7) 'append! l3) - (test '(0 2 5 4 . 7) 'append! l)) - -(test '(c b a) reverse '(a b c)) -(test '((e (f)) d (b c) a) reverse '(a (b c) d (e (f)))) -(arity-test reverse 1 1) -(error-test '(reverse 1)) -(error-test '(reverse '(1 . 1))) - -(define l '(a b c)) -(test '(c b a) reverse! l) -(test '(a) 'reverse! l) -(test '((e (f)) d (b c) a) reverse! '(a (b c) d (e (f)))) -(arity-test reverse! 1 1) -(error-test '(reverse! 1)) -(error-test '(reverse! '(1 . 1))) - -(test 'c list-ref '(a b c d) 2) -(test 'c list-ref '(a b c . d) 2) -(arity-test list-ref 2 2) -(error-test '(list-ref 1 1) exn:application:mismatch?) -(error-test '(list-ref '(a b . c) 2) exn:application:mismatch?) -(error-test '(list-ref '(1 2 3) 2.0)) -(error-test '(list-ref '(1) '(1))) -(error-test '(list-ref '(1) 1) exn:application:mismatch?) -(error-test '(list-ref '() 0) exn:application:mismatch?) -(error-test '(list-ref '() 0) exn:application:mismatch?) -(error-test '(list-ref '(1) -1)) - -(test '(c d) list-tail '(a b c d) 2) -(test '(a b c d) list-tail '(a b c d) 0) -(test '(b c . d) list-tail '(a b c . d) 1) -(test 1 list-tail 1 0) -(arity-test list-tail 2 2) -(error-test '(list-tail 1 1) exn:application:mismatch?) -(error-test '(list-tail '(1 2 3) 2.0)) -(error-test '(list-tail '(1) '(1))) -(error-test '(list-tail '(1) -1)) -(error-test '(list-tail '(1) 2) exn:application:mismatch?) -(error-test '(list-tail '(1 2 . 3) 3) exn:application:mismatch?) - -(define (test-mem memq memq-name) - (test '(a b c) memq 'a '(a b c)) - (test '(b c) memq 'b '(a b c)) - (test '(b . c) memq 'b '(a b . c)) - (test '#f memq 'a '(b c d)) - - (arity-test memq 2 2) - (error-test `(,memq-name 'a 1) exn:application:mismatch?) - (error-test `(,memq-name 'a '(1 . 2)) exn:application:mismatch?)) - -(test-mem memq 'memq) -(test-mem memv 'memv) -(test-mem member 'member) - -(test #f memq "apple" '("apple")) -(test #f memv "apple" '("apple")) -(test '("apple") member "apple" '("apple")) - -; (test #f memq 1/2 '(1/2)) ; rationals are immutable and we may want to optimize -(test '(1/2) memv 1/2 '(1/2)) -(test '(1/2) member 1/2 '(1/2)) - -(test '((1 2)) member '(1 2) '(1 2 (1 2))) - -(define (test-ass assq assq-name) - (define e '((a 1) (b 2) (c 3))) - (test '(a 1) assq 'a e) - (test '(b 2) assq 'b e) - (test #f assq 'd e) - (test '(a 1) assq 'a '((x 0) (a 1) b 2)) - (test '(a 1) assq 'a '((x 0) (a 1) . 0)) - (arity-test assq 2 2) - - (error-test `(,assq-name 1 1) exn:application:mismatch?) - (error-test `(,assq-name 1 '(1 2)) exn:application:mismatch?) - (error-test `(,assq-name 1 '((0) . 2)) exn:application:mismatch?)) - -(test-ass assq 'assq) -(test-ass assv 'assv) -(test-ass assoc 'assoc) - -(test #f assq '(a) '(((a)) ((b)) ((c)))) -(test #f assv '(a) '(((a)) ((b)) ((c)))) -(test '((b) 1) assoc '(b) '(((a)) ((b) 1) ((c)))) - -; (test #f assq '1/2 '(((a)) (1/2) ((c)))) ; rationals are immutable and we may want to optimize -(test '(1/2) assv '1/2 '(((a)) (1/2) ((c)))) -(test '(1/2) assoc '1/2 '(((a)) (1/2) ((c)))) - -(SECTION 6 4) -(test #t symbol? 'foo) -(test #t symbol? (car '(a b))) -(test #f symbol? "bar") -(test #t symbol? 'nil) -(test #f symbol? '()) -(test #f symbol? #f) -;;; But first, what case are symbols in? Determine the standard case: -(define char-standard-case char-upcase) -(if (string=? (symbol->string 'A) "a") - (set! char-standard-case char-downcase)) -(test #t 'standard-case - (string=? (symbol->string 'a) (symbol->string 'A))) -(test #t 'standard-case - (or (string=? (symbol->string 'a) "A") - (string=? (symbol->string 'A) "a"))) -(define (str-copy s) - (let ((v (make-string (string-length s)))) - (do ((i (- (string-length v) 1) (- i 1))) - ((< i 0) v) - (string-set! v i (string-ref s i))))) -(define (string-standard-case s) - (set! s (str-copy s)) - (do ((i 0 (+ 1 i)) - (sl (string-length s))) - ((>= i sl) s) - (string-set! s i (char-standard-case (string-ref s i))))) -(test (string-standard-case "flying-fish") symbol->string 'flying-fish) -(test (string-standard-case "martin") symbol->string 'Martin) -(test "Malvina" symbol->string (string->symbol "Malvina")) -(test #t 'standard-case (eq? 'a 'A)) - -(define x (string #\a #\b)) -(define y (string->symbol x)) -(string-set! x 0 #\c) -(test "cb" 'string-set! x) -(test "ab" symbol->string y) -(test y string->symbol "ab") - -(test #t eq? 'mISSISSIppi 'mississippi) -(test #f 'string->symbol (eq? 'bitBlt (string->symbol "bitBlt"))) -(test 'JollyWog string->symbol (symbol->string 'JollyWog)) - -(arity-test symbol? 1 1) - -(SECTION 6 6) -(test #t eqv? '#\ #\Space) -(test #t eqv? #\space '#\Space) -(test #t char? #\a) -(test #t char? #\() -(test #t char? #\ ) -(test #t char? '#\newline) -(arity-test char? 1 1) - -(test #t char=? #\A) -(test #f char=? #\A #\B) -(test #f char=? #\A #\A #\B) -(test #f char=? #\A #\B #\A) -(test #f char=? #\a #\b) -(test #f char=? #\9 #\0) -(test #t char=? #\A #\A) -(test #t char=? #\A #\A #\A) -(test #t char=? #\370 #\370) -(test #f char=? #\371 #\370) -(test #f char=? #\370 #\371) -(arity-test char=? 1 -1) -(error-test '(char=? #\a 1)) -(error-test '(char=? #\a #\b 1)) -(error-test '(char=? 1 #\a)) - -(test #t char? #\A) -(test #f char>? #\A #\B) -(test #t char>? #\B #\A) -(test #f char>? #\A #\B #\C) -(test #f char>? #\B #\A #\C) -(test #t char>? #\C #\B #\A) -(test #f char>? #\a #\b) -(test #t char>? #\9 #\0) -(test #f char>? #\A #\A) -(test #f char>? #\370 #\370) -(test #t char>? #\371 #\370) -(test #f char>? #\370 #\371) -(arity-test char>? 1 -1) -(error-test '(char>? #\a 1)) -(error-test '(char>? #\a #\a 1)) -(error-test '(char>? 1 #\a)) - -(test #t char<=? #\A) -(test #t char<=? #\A #\B) -(test #t char<=? #\A #\B #\C) -(test #t char<=? #\A #\A #\C) -(test #f char<=? #\A #\B #\A) -(test #f char<=? #\B #\A #\C) -(test #t char<=? #\a #\b) -(test #f char<=? #\9 #\0) -(test #t char<=? #\A #\A) -(test #t char<=? #\370 #\370) -(test #f char<=? #\371 #\370) -(test #t char<=? #\370 #\371) -(arity-test char<=? 1 -1) -(error-test '(char<=? #\a 1)) -(error-test '(char<=? #\b #\a 1)) -(error-test '(char<=? 1 #\a)) - -(test #t char>=? #\A) -(test #f char>=? #\A #\B) -(test #f char>=? #\a #\b) -(test #t char>=? #\9 #\0) -(test #t char>=? #\A #\A) -(test #t char>=? #\370 #\370) -(test #t char>=? #\371 #\370) -(test #f char>=? #\370 #\371) -(arity-test char>=? 1 -1) -(error-test '(char>=? #\a 1)) -(error-test '(char>=? #\a #\b 1)) -(error-test '(char>=? 1 #\a)) - -(test #t char-ci=? #\A) -(test #f char-ci=? #\A #\B) -(test #f char-ci=? #\A #\A #\B) -(test #f char-ci=? #\a #\B) -(test #f char-ci=? #\A #\b) -(test #f char-ci=? #\a #\b) -(test #f char-ci=? #\9 #\0) -(test #t char-ci=? #\A #\A) -(test #t char-ci=? #\A #\a) -(test #t char-ci=? #\A #\a #\A) -(test #t char-ci=? #\370 #\370) -(test #f char-ci=? #\371 #\370) -(test #f char-ci=? #\370 #\371) -(arity-test char-ci=? 1 -1) -(error-test '(char-ci=? #\a 1)) -(error-test '(char-ci=? #\a #\b 1)) -(error-test '(char-ci=? 1 #\a)) - -(test #t char-ci? #\A) -(test #f char-ci>? #\A #\B) -(test #f char-ci>? #\B #\A #\C) -(test #t char-ci>? #\C #\B #\A) -(test #f char-ci>? #\a #\B) -(test #f char-ci>? #\A #\b) -(test #f char-ci>? #\a #\b) -(test #t char-ci>? #\C #\b #\A) -(test #t char-ci>? #\9 #\0) -(test #f char-ci>? #\A #\A) -(test #f char-ci>? #\A #\a) -(test #f char-ci>? #\370 #\370) -(test #t char-ci>? #\371 #\370) -(test #f char-ci>? #\370 #\371) -(arity-test char-ci>? 1 -1) -(error-test '(char-ci>? #\a 1)) -(error-test '(char-ci>? #\a #\b 1)) -(error-test '(char-ci>? 1 #\a)) - -(test #t char-ci<=? #\A) -(test #t char-ci<=? #\A #\B) -(test #t char-ci<=? #\a #\B) -(test #t char-ci<=? #\a #\B #\C) -(test #f char-ci<=? #\a #\b #\A) -(test #t char-ci<=? #\A #\b) -(test #t char-ci<=? #\a #\b) -(test #f char-ci<=? #\9 #\0) -(test #t char-ci<=? #\A #\A) -(test #t char-ci<=? #\A #\a) -(test #t char-ci<=? #\370 #\370) -(test #f char-ci<=? #\371 #\370) -(test #t char-ci<=? #\370 #\371) -(arity-test char-ci<=? 1 -1) -(error-test '(char-ci<=? #\a 1)) -(error-test '(char-ci<=? #\b #\a 1)) -(error-test '(char-ci<=? 1 #\a)) - -(test #t char-ci>=? #\A) -(test #f char-ci>=? #\A #\B) -(test #f char-ci>=? #\B #\A #\C) -(test #t char-ci>=? #\B #\B #\A) -(test #f char-ci>=? #\a #\B) -(test #f char-ci>=? #\A #\b) -(test #f char-ci>=? #\a #\b) -(test #t char-ci>=? #\9 #\0) -(test #t char-ci>=? #\A #\A) -(test #t char-ci>=? #\A #\a) -(test #t char-ci>=? #\370 #\370) -(test #t char-ci>=? #\371 #\370) -(test #f char-ci>=? #\370 #\371) -(arity-test char-ci>=? 1 -1) -(error-test '(char-ci>=? #\a 1)) -(error-test '(char-ci>=? #\a #\b 1)) -(error-test '(char-ci>=? 1 #\a)) - -(define (ascii-range start end) - (let ([s (or (and (number? start) start) (char->integer start))] - [e (or (and (number? end) end) (char->integer end))]) - (let loop ([n e][l (list (integer->char e))]) - (if (= n s) - l - (let ([n (sub1 n)]) - (loop n (cons (integer->char n) l))))))) - -(define basic-uppers (ascii-range #\A #\Z)) -(define uppers basic-uppers) -(define basic-lowers (ascii-range #\a #\z)) -(define lowers basic-lowers) -(when (eq? (system-type) 'macos) - ; There are more alphabetics: - (set! uppers (append uppers - (ascii-range 128 134) - (ascii-range 174 175) - (ascii-range 203 206) - (ascii-range 217 217) - (ascii-range 229 239) - (ascii-range 241 244))) - (set! lowers (append lowers - (ascii-range 135 159) - (ascii-range 190 191) - (ascii-range 207 207) - (ascii-range 216 216)))) -(define alphas (append uppers lowers)) -(define digits (ascii-range #\0 #\9)) -(define whites (list #\newline #\return #\space #\page #\tab #\vtab)) - -(define (test-all is-a? name members) - (let loop ([n 0]) - (unless (= n 256) - (let ([c (integer->char n)]) - (test (and (memq c members) #t) `(,is-a? (integer->char ,n)) (is-a? c)) - (loop (add1 n))))) - (arity-test char-alphabetic? 1 1) - (error-test `(,name 1))) - -(test-all char-alphabetic? 'char-alphabetic? alphas) -(test-all char-numeric? 'char-numeric? digits) -(test-all char-whitespace? 'char-whitespace? whites) -(test-all char-upper-case? 'char-upper-case? uppers) -(test-all char-lower-case? 'char-lower-case? lowers) - -(let loop ([n 0]) - (unless (= n 256) - (test n 'integer->char (char->integer (integer->char n))) - (loop (add1 n)))) - -(test 0 char->integer #\nul) -(test 10 char->integer #\newline) -(test 13 char->integer #\return) -(test 9 char->integer #\tab) -(test 8 char->integer #\backspace) -(test 12 char->integer #\page) -(test 32 char->integer #\space) -(test 127 char->integer #\rubout) -(test #\null 'null #\nul) -(test #\newline 'linefeed #\linefeed) - -(test #\. integer->char (char->integer #\.)) -(test #\A integer->char (char->integer #\A)) -(test #\a integer->char (char->integer #\a)) -(test #\371 integer->char (char->integer #\371)) -(arity-test integer->char 1 1) -(arity-test char->integer 1 1) -(error-test '(integer->char 5.0)) -(error-test '(integer->char 'a)) -(error-test '(integer->char -1)) -(error-test '(integer->char 256)) -(error-test '(integer->char 10000000000000000)) -(error-test '(char->integer 5)) - -(define (test-up/down case case-name members amembers memassoc) - (let loop ([n 0]) - (unless (= n 256) - (let ([c (integer->char n)]) - (if (memq c members) - (if (memq c amembers) - (test (cdr (assq c memassoc)) case c) - (test (case c) case c)) ; BOGUS! Could tweak Mac testing here - (test n `(char->integer (,case-name (integer->char ,n))) (char->integer (case c))))) - (loop (add1 n)))) - (arity-test case 1 1) - (error-test `(,case-name 2))) - -(test-up/down char-upcase 'char-upcase lowers basic-lowers (map cons basic-lowers basic-uppers)) -(test-up/down char-downcase 'char-downcase uppers basic-uppers (map cons basic-uppers basic-lowers)) - -((load-relative "censor.ss") - (lambda () - (let loop ([n 0]) - (unless (= n 256) - (let ([c (integer->char n)]) - (if (or (char<=? #\a c #\z) - (char<=? #\A c #\Z) - (char<=? #\0 c #\9)) - (begin - (test c latin-1-integer->char n) - (test n char->latin-1-integer c)) - (when (latin-1-integer->char n) - (test n char->latin-1-integer (latin-1-integer->char n))))) - (loop (add1 n)))))) - -(arity-test latin-1-integer->char 1 1) -(arity-test char->latin-1-integer 1 1) -(error-test '(latin-1-integer->char 5.0)) -(error-test '(latin-1-integer->char 'a)) -(error-test '(latin-1-integer->char -1)) -(error-test '(latin-1-integer->char 256)) -(error-test '(latin-1-integer->char 10000000000000000)) -(error-test '(char->latin-1-integer 5)) - -(SECTION 6 7) -(test #t string? "The word \"recursion\\\" has many meanings.") -(test #t string? "") -(arity-test string? 1 1) -(test 3 'make-string (string-length (make-string 3))) -(test "" make-string 0) -(arity-test make-string 1 2) -(error-test '(make-string "hello")) -(error-test '(make-string 5 "hello")) -(error-test '(make-string 5.0 #\b)) -(error-test '(make-string 5.2 #\a)) -(error-test '(make-string -5 #\f)) -(error-test '(make-string 500000000000000 #\f) exn:misc:out-of-memory?) - -(define f (make-string 3 #\*)) -(test "?**" 'string-set! (begin (string-set! f 0 #\?) f)) -(arity-test string-set! 3 3) -(error-test '(string-set! "hello" 0 #\a)) ; immutable string constant -(define hello-string (string-copy "hello")) -(error-test '(string-set! hello-string 'a #\a)) -(error-test '(string-set! 'hello 4 #\a)) -(error-test '(string-set! hello-string 4 'a)) -(error-test '(string-set! hello-string 4.0 'a)) -(error-test '(string-set! hello-string 5 #\a) exn:application:mismatch?) -(error-test '(string-set! hello-string -1 #\a)) -(error-test '(string-set! hello-string (expt 2 100) #\a) exn:application:mismatch?) -(test "abc" string #\a #\b #\c) -(test "" string) -(error-test '(string #\a 1)) -(error-test '(string 1 #\a)) -(error-test '(string 1)) -(test 3 string-length "abc") -(test 0 string-length "") -(arity-test string-length 1 1) -(error-test '(string-length 'apple)) -(test #\a string-ref "abc" 0) -(test #\c string-ref "abc" 2) -(arity-test string-ref 2 2) -(error-test '(string-ref 'apple 4)) -(error-test '(string-ref "apple" 4.0)) -(error-test '(string-ref "apple" '(4))) -(error-test '(string-ref "apple" 5) exn:application:mismatch?) -(error-test '(string-ref "" 0) exn:application:mismatch?) -(error-test '(string-ref "" (expt 2 100)) exn:application:mismatch?) -(error-test '(string-ref "apple" -1)) -(test "" substring "ab" 0 0) -(test "" substring "ab" 1 1) -(test "" substring "ab" 2 2) -(test "a" substring "ab" 0 1) -(test "b" substring "ab" 1 2) -(test "ab" substring "ab" 0 2) -(test (string #\a #\nul #\b) substring (string #\- #\a #\nul #\b #\*) 1 4) -(arity-test substring 3 3) -(error-test '(substring 'hello 2 3)) -(error-test '(substring "hello" "2" 3)) -(error-test '(substring "hello" 2.0 3)) -(error-test '(substring "hello" 2 3.0)) -(error-test '(substring "hello" 2 "3")) -(error-test '(substring "hello" 2 7) exn:application:mismatch?) -(error-test '(substring "hello" -2 3)) -(error-test '(substring "hello" 4 3) exn:application:mismatch?) -(error-test '(substring "hello" (expt 2 100) 3) exn:application:mismatch?) -(error-test '(substring "hello" (expt 2 100) 5) exn:application:mismatch?) -(error-test '(substring "hello" 3 (expt 2 100)) exn:application:mismatch?) -(test "foobar" string-append "foo" "bar") -(test "foo" string-append "foo") -(test "foo" string-append "foo" "") -(test "foogoo" string-append "foo" "" "goo") -(test "foo" string-append "" "foo") -(test "" string-append) -(test (string #\a #\nul #\b #\c #\nul #\d) - string-append (string #\a #\nul #\b) (string #\c #\nul #\d)) -(error-test '(string-append 1)) -(error-test '(string-append "hello" 1)) -(error-test '(string-append "hello" 1 "done")) -(test "" make-string 0) -(define s (string-copy "hello")) -(define s2 (string-copy s)) -(test "hello" 'string-copy s2) -(string-set! s 2 #\x) -(test "hello" 'string-copy s2) -(test (string #\a #\nul #\b) string-copy (string #\a #\nul #\b)) -(string-fill! s #\x) -(test "xxxxx" 'string-fill! s) -(arity-test string-copy 1 1) -(arity-test string-fill! 2 2) -(error-test '(string-copy 'blah)) -(error-test '(string-fill! "oops" 5)) - -(define ax (string #\a #\nul #\370 #\x)) -(define abigx (string #\a #\nul #\370 #\X)) -(define ax2 (string #\a #\nul #\370 #\x)) -(define ay (string #\a #\nul #\371 #\x)) - -(test #t string=? "string") -(test #t string? "string") -(test #t string<=? "string") -(test #t string>=? "string") -(test #t string-ci=? "string") -(test #t string-ci? "string") -(test #t string-ci<=? "string") -(test #t string-ci>=? "string") - -(test #t string=? "" "") -(test #f string? "" "") -(test #t string<=? "" "") -(test #t string>=? "" "") -(test #t string-ci=? "" "") -(test #f string-ci? "" "") -(test #t string-ci<=? "" "") -(test #t string-ci>=? "" "") - -(test #f string=? "A" "B") -(test #f string=? "a" "b") -(test #f string=? "9" "0") -(test #t string=? "A" "A") -(test #f string=? "A" "AB") -(test #t string=? ax ax2) -(test #f string=? ax abigx) -(test #f string=? ax ay) -(test #f string=? ay ax) - -(test #t string? "A" "B") -(test #f string>? "a" "b") -(test #t string>? "9" "0") -(test #f string>? "A" "A") -(test #f string>? "A" "AB") -(test #t string>? "AB" "A") -(test #f string>? ax ax2) -(test #f string>? ax ay) -(test #t string>? ay ax) - -(test #t string<=? "A" "B") -(test #t string<=? "a" "b") -(test #f string<=? "9" "0") -(test #t string<=? "A" "A") -(test #t string<=? "A" "AB") -(test #f string<=? "AB" "A") -(test #t string<=? ax ax2) -(test #t string<=? ax ay) -(test #f string<=? ay ax) - -(test #f string>=? "A" "B") -(test #f string>=? "a" "b") -(test #t string>=? "9" "0") -(test #t string>=? "A" "A") -(test #f string>=? "A" "AB") -(test #t string>=? "AB" "A") -(test #t string>=? ax ax2) -(test #f string>=? ax ay) -(test #t string>=? ay ax) - -(test #f string-ci=? "A" "B") -(test #f string-ci=? "a" "B") -(test #f string-ci=? "A" "b") -(test #f string-ci=? "a" "b") -(test #f string-ci=? "9" "0") -(test #t string-ci=? "A" "A") -(test #t string-ci=? "A" "a") -(test #f string-ci=? "A" "AB") -(test #t string-ci=? ax ax2) -(test #t string-ci=? ax abigx) -(test #f string-ci=? ax ay) -(test #f string-ci=? ay ax) -(test #f string-ci=? abigx ay) -(test #f string-ci=? ay abigx) - -(test #t string-ci? "A" "B") -(test #f string-ci>? "a" "B") -(test #f string-ci>? "A" "b") -(test #f string-ci>? "a" "b") -(test #t string-ci>? "9" "0") -(test #f string-ci>? "A" "A") -(test #f string-ci>? "A" "a") -(test #f string-ci>? "A" "AB") -(test #t string-ci>? "AB" "A") -(test #f string-ci>? ax ax2) -(test #f string-ci>? ax abigx) -(test #f string-ci>? ax ay) -(test #t string-ci>? ay ax) -(test #f string-ci>? abigx ay) -(test #t string-ci>? ay abigx) - -(test #t string-ci<=? "A" "B") -(test #t string-ci<=? "a" "B") -(test #t string-ci<=? "A" "b") -(test #t string-ci<=? "a" "b") -(test #f string-ci<=? "9" "0") -(test #t string-ci<=? "A" "A") -(test #t string-ci<=? "A" "a") -(test #t string-ci<=? "A" "AB") -(test #f string-ci<=? "AB" "A") -(test #t string-ci<=? ax ax2) -(test #t string-ci<=? ax abigx) -(test #t string-ci<=? ax ay) -(test #f string-ci<=? ay ax) -(test #t string-ci<=? abigx ay) -(test #f string-ci<=? ay abigx) - -(test #f string-ci>=? "A" "B") -(test #f string-ci>=? "a" "B") -(test #f string-ci>=? "A" "b") -(test #f string-ci>=? "a" "b") -(test #t string-ci>=? "9" "0") -(test #t string-ci>=? "A" "A") -(test #t string-ci>=? "A" "a") -(test #f string-ci>=? "A" "AB") -(test #t string-ci>=? "AB" "A") -(test #t string-ci>=? ax ax2) -(test #t string-ci>=? ax abigx) -(test #f string-ci>=? ax ay) -(test #t string-ci>=? ay ax) -(test #f string-ci>=? abigx ay) -(test #t string-ci>=? ay abigx) - -(map (lambda (pred) - (arity-test pred 1 -1) - (let ([predname (string->symbol - (primitive-name pred))]) - (error-test `(,predname "a" 1)) - (error-test `(,predname "a" "b" 5)) - (error-test `(,predname 1 "a")))) - (list string=? - string>? - string=? - string<=? - string-ci=? - string-ci>? - string-ci=? - string-ci<=?)) - -(define r (regexp "(-[0-9]*)+")) -(test '("-12--345" "-345") regexp-match r "a-12--345b") -(test '((1 . 9) (5 . 9)) regexp-match-positions r "a-12--345b") -(test '("--345" "-345") regexp-match r "a-12--345b" 2) -(test '("--34" "-34") regexp-match r "a-12--345b" 2 8) -(test '((4 . 9) (5 . 9)) regexp-match-positions r "a-12--345b" 2) -(test '((4 . 8) (5 . 8)) regexp-match-positions r "a-12--345b" 2 8) -(test '("a-b") regexp-match "a[-c]b" "a-b") -(test '("a-b") regexp-match "a[c-]b" "a-b") -(test #f regexp-match "x+" "12345") -(test "su casa" regexp-replace "mi" "mi casa" "su") -(define r2 (regexp "([Mm])i ([a-zA-Z]*)")) -(define insert "\\1y \\2") -(test "My Casa" regexp-replace r2 "Mi Casa" insert) -(test "my cerveza Mi Mi Mi" regexp-replace r2 "mi cerveza Mi Mi Mi" insert) -(test "my cerveza My Mi Mi" regexp-replace* r2 "mi cerveza Mi Mi Mi" insert) -(test "bbb" regexp-replace* "a" "aaa" "b") - -;; Test regexp with null chars: -(let* ([s (string #\a #\b #\nul #\c)] - [3s (string-append s s s)]) - (test #f regexp-match (string #\nul) "no nulls") - (test (list s) regexp-match s s) - (test (list 3s s) regexp-match (format "(~a)*" s) 3s) - (test (list (string #\b #\nul #\c)) regexp-match (string #\[ #\nul #\b #\] #\* #\c) s) - (test (list (string #\a #\b #\nul)) regexp-match (string #\a #\[ #\b #\nul #\] #\+) s) - (test "hihihi" regexp-replace* (string #\nul) (string #\nul #\nul #\nul) "hi")) -(test (string #\- #\nul #\+ #\- #\nul #\+ #\- #\nul #\+) - regexp-replace* "a" "aaa" (string #\- #\nul #\+)) - -;; Check extremely many subexpressions: -(for-each - (lambda (mx) - (let* ([v (make-vector mx null)] - [open (make-vector mx #t)]) - (let loop ([n 0][m 0][s null]) - (cond - [(and (= n mx) (zero? m)) - (let* ([s (list->string (reverse! s))] - [plain (regexp-replace* "[()]" s "")]) - (test (cons plain (map list->string (map reverse! (vector->list v)))) regexp-match s plain))] - [(or (= n mx) (< (random 10) 3)) - (if (and (positive? m) - (< (random 10) 7)) - (begin - (let loop ([p 0][m (sub1 m)]) - (if (vector-ref open p) - (if (zero? m) - (vector-set! open p #f) - (loop (add1 p) (sub1 m))) - (loop (add1 p) m))) - (loop n (sub1 m) (cons #\) s))) - - (let ([c (integer->char (+ (char->integer #\a) (random 26)))]) - (let loop ([p 0]) - (unless (= p n) - (when (vector-ref open p) - (vector-set! v p (cons c (vector-ref v p)))) - (loop (add1 p)))) - (loop n m (cons c s))))] - [else - (loop (add1 n) (add1 m) (cons #\( s))])))) - '(1 10 100 500)) - - -(define (test-bad-re-args who) - (error-test `(,who 'e "hello")) - (error-test `(,who "e" 'hello)) - (error-test `(,who "e" "hello" -1 5)) - (error-test `(,who "e" "hello" 1 +inf.0)) - (error-test `(,who "e" "" 0 1) exn:application:mismatch?) - (error-test `(,who "e" "hello" 3 2) exn:application:mismatch?) - (error-test `(,who "e" "hello" 3 12) exn:application:mismatch?) - (error-test `(,who "e" "hello" (expt 2 100) 5) exn:application:mismatch?)) -(test-bad-re-args 'regexp-match) -(test-bad-re-args 'regexp-match-positions) - -(arity-test regexp 1 1) -(arity-test regexp? 1 1) -(arity-test regexp-match 2 4) -(arity-test regexp-match-positions 2 4) -(arity-test regexp-replace 3 3) -(arity-test regexp-replace* 3 3) - -(SECTION 6 8) -(test #t vector? '#(0 (2 2 2 2) "Anna")) -(test #t vector? '#()) -(arity-test vector? 1 1) -(test '#(a b c) vector 'a 'b 'c) -(test '#() vector) -(test 3 vector-length '#(0 (2 2 2 2) "Anna")) -(test 0 vector-length '#()) -(arity-test vector-length 1 1) -(error-test '(vector-length "apple")) -(test 8 vector-ref '#(1 1 2 3 5 8 13 21) 5) -(arity-test vector-ref 2 2) -(error-test '(vector-ref "apple" 3)) -(error-test '(vector-ref #(4 5 6) 3) exn:application:mismatch?) -(error-test '(vector-ref #() 0) exn:application:mismatch?) -(error-test '(vector-ref #() (expt 2 100)) exn:application:mismatch?) -(error-test '(vector-ref #(4 5 6) -1)) -(error-test '(vector-ref #(4 5 6) 2.0)) -(error-test '(vector-ref #(4 5 6) "2")) -(test '#(0 ("Sue" "Sue") "Anna") 'vector-set - (let ((vec (vector 0 '(2 2 2 2) "Anna"))) - (vector-set! vec 1 '("Sue" "Sue")) - vec)) -(test '#(hi hi) make-vector 2 'hi) -(test '#() make-vector 0) -(test '#() make-vector 0 'a) -(arity-test make-vector 1 2) -(error-test '(make-vector "a" 'a)) -(error-test '(make-vector 1.0 'a)) -(error-test '(make-vector 10.2 'a)) -(error-test '(make-vector -1 'a)) -(error-test '(make-vector 1000000000000000000000 'a) exn:misc:out-of-memory?) -(arity-test vector-set! 3 3) -(error-test '(vector-set! #() 0 'x) exn:application:mismatch?) -(error-test '(vector-set! #(1 2 3) -1 'x)) -(error-test '(vector-set! #(1 2 3) 3 'x) exn:application:mismatch?) -(error-test '(vector-set! #(1 2 3) (expt 2 100) 'x) exn:application:mismatch?) -(error-test '(vector-set! '(1 2 3) 2 'x)) -(error-test '(vector-set! #(1 2 3) "2" 'x)) -(define v (quote #(1 2 3))) -(vector-fill! v 0) -(test (quote #(0 0 0)) 'vector-fill! v) -(arity-test vector-fill! 2 2) -(error-test '(vector-fill! '(1 2 3) 0)) - -(SECTION 6 9) -(test #t procedure? car) -(test #f procedure? 'car) -(test #t procedure? (lambda (x) (* x x))) -(test #f procedure? '(lambda (x) (* x x))) -(test #t call-with-current-continuation procedure?) -(test #t call-with-escape-continuation procedure?) -(test #t procedure? (case-lambda ((x) x) ((x y) (+ x y)))) -(arity-test procedure? 1 1) - -(test 7 apply + (list 3 4)) -(test 7 apply (lambda (a b) (+ a b)) (list 3 4)) -(test 17 apply + 10 (list 3 4)) -(test '() apply list '()) -(define compose (lambda (f g) (lambda args (f (apply g args))))) -(test 30 (compose sqrt *) 12 75) -(error-test '(apply) exn:application:arity?) -(error-test '(apply (lambda x x)) exn:application:arity?) -(error-test '(apply (lambda x x) 1)) -(error-test '(apply (lambda x x) 1 2)) -(error-test '(apply (lambda x x) 1 '(2 . 3))) - -(test '(b e h) map cadr '((a b) (d e) (g h))) -(test '(5 7 9) map + '(1 2 3) '(4 5 6)) -(test '#(0 1 4 9 16) 'for-each - (let ((v (make-vector 5))) - (for-each (lambda (i) (vector-set! v i (* i i))) - '(0 1 2 3 4)) - v)) - -(define (map-tests map) - (let ([size? exn:application:mismatch?] - [non-list? type?]) - (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '1)) - (error-test `(,map (lambda (x y) (+ x y)) '2 '(1 2))) - (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '(1 2 3)) size?) - (error-test `(,map (lambda (x y) (+ x y)) '(1 2 3) '(1 2)) size?) - (error-test `(,map (lambda (x) (+ x)) '(1 2 . 3)) non-list?) - (error-test `(,map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2)) non-list?) - (error-test `(,map (lambda (x y) (+ x y)) '(1 2 . 3) '(1 2 3)) non-list?) - (error-test `(,map (lambda (x y) (+ x y)) '(1 2) '(1 2 . 3)) non-list?) - (error-test `(,map (lambda (x y) (+ x y)) '(1 2 3) '(1 2 . 3)) non-list?) - (error-test `(,map) exn:application:arity?) - (error-test `(,map (lambda (x y) (+ x y))) exn:application:arity?) - (error-test `(,map (lambda () 10) null) exn:application:mismatch?) - (error-test `(,map (case-lambda [() 9] [(x y) 10]) '(1 2 3)) exn:application:mismatch?) - (error-test `(,map (lambda (x) 10) '(1 2) '(3 4)) exn:application:mismatch?))) -(map-tests 'map) -(map-tests 'for-each) -(map-tests 'andmap) -(map-tests 'ormap) - -(test (void) for-each (lambda (x) (values 1 2)) '(1 2)) -(error-test '(map (lambda (x) (values 1 2)) '(1 2)) arity?) - -(test #t andmap add1 null) -(test #f ormap add1 null) -(test #f andmap positive? '(1 -2 3)) -(test #t ormap positive? '(1 -2 3)) -(test #f andmap negative? '(1 -2 3)) -(test #t ormap negative? '(1 -2 3)) -(test 4 andmap add1 '(1 2 3)) -(test 2 ormap add1 '(1 2 3)) - -(error-test '(ormap (lambda (x) (values 1 2)) '(1 2)) arity?) -(error-test '(andmap (lambda (x) (values 1 2)) '(1 2)) arity?) - -(error-test '(ormap (lambda (x) (values 1 2)) '(1)) arity?) -(error-test '(andmap (lambda (x) (values 1 2)) '(1)) arity?) - -(test -3 call-with-current-continuation - (lambda (exit) - (for-each (lambda (x) (if (negative? x) (exit x))) - '(54 0 37 -3 245 19)) - #t)) -(define list-length - (lambda (obj) - (call-with-current-continuation - (lambda (return) - (letrec ((r (lambda (obj) (cond ((null? obj) 0) - ((pair? obj) (+ (r (cdr obj)) 1)) - (else (return #f)))))) - (r obj)))))) -(test 4 list-length '(1 2 3 4)) -(test #f list-length '(a b . c)) -(test '() map cadr '()) - -;;; This tests full conformance of call-with-current-continuation. It -;;; is a separate test because some schemes do not support call/cc -;;; other than escape procedures. I am indebted to -;;; raja@copper.ucs.indiana.edu (Raja Sooriamurthi) for fixing this -;;; code. The function leaf-eq? compares the leaves of 2 arbitrary -;;; trees constructed of conses. -(define (next-leaf-generator obj eot) - (letrec ((return #f) - (cont (lambda (x) - (recurx obj) - (set! cont (lambda (x) (return eot))) - (cont #f))) - (recurx (lambda (obj) - (if (pair? obj) - (for-each recurx obj) - (call-with-current-continuation - (lambda (c) - (set! cont c) - (return obj))))))) - (lambda () (call-with-current-continuation - (lambda (ret) (set! return ret) (cont #f)))))) -(define (leaf-eq? x y) - (let* ((eot (list 'eot)) - (xf (next-leaf-generator x eot)) - (yf (next-leaf-generator y eot))) - (letrec ((loop (lambda (x y) - (cond ((not (eq? x y)) #f) - ((eq? eot x) #t) - (else (loop (xf) (yf))))))) - (loop (xf) (yf))))) -(define (test-cont) - (newline) - (display ";testing continuations; ") - (SECTION 6 9) - (test #t leaf-eq? '(a (b (c))) '((a) b c)) - (test #f leaf-eq? '(a (b (c))) '((a) b c d)) - '(report-errs)) - -(define (test-cc-values test-call/cc) - (test '(a b c) - call-with-values - (lambda () - (test-call/cc - (lambda (k) - (dynamic-wind - void - (lambda () - (k 'a 'b 'c)) - (lambda () - (values 1 2)))))) - list) - - (test 1 dynamic-wind - (lambda () (test-call/cc void)) - (lambda () 1) - (lambda () (test-call/cc void))) - - ; Try devious jumping with pre- and post-thunks: - (test 2 test-call/cc - (lambda (exit) - (dynamic-wind - (lambda () (exit 2)) - void - void))) - (test 3 test-call/cc - (lambda (exit) - (dynamic-wind - void - void - (lambda () (exit 3))))) - - (let ([rv - (lambda (get-v) - (let ([x 0]) - (test-call/cc - (lambda (exit) - (dynamic-wind - void - (lambda () (exit)) - (lambda () (set! x (get-v)))))) - x))] - [r56 - (lambda () - (let ([x 0] - [y 1] - [c1 #f]) - (dynamic-wind - (lambda () (set! x (add1 x))) - (lambda () - (let/cc k (set! c1 k)) - (if (>= x 5) - (set! c1 #f))) - (lambda () (set! y (add1 y)))) - (when c1 (c1)) - (list x y)))] - [rx.y - (lambda (get-x get-y) - (let ([c1 #f] - [x 0] - [y 0]) - (let ([v - (dynamic-wind - (lambda () (set! y x)) - (lambda () (let/cc k (set! c1 k))) - (lambda () - (set! x (get-x)) - (when c1 - ((begin0 - c1 - (set! c1 #f)) - (get-y)))))]) - (cons y v))))] - [rv2 - (lambda (get-v) - (let ([c1 #f] - [give-up #f]) - (test-call/cc - (lambda (exit) - (dynamic-wind - (lambda () (when give-up (give-up (get-v)))) - (lambda () (let/cc k (set! c1 k))) - (lambda () (set! give-up exit) (c1)))))))] - [r10-11-12 - (lambda () - (let ([c2 #f] - [x 10] - [y 11]) - (let ([v (dynamic-wind - (lambda () (set! y (add1 y))) - (lambda () (begin0 x (set! x (add1 x)))) - (lambda () (let/cc k (set! c2 k))))]) - (when c2 ((begin0 - c2 - (set! c2 #f)))) - (list v x y))))] - [r13.14 - (lambda () - (let ([c0 #f] - [x 11] - [y 12]) - (dynamic-wind - (lambda () (let/cc k (set! c0 k))) - (lambda () (set! x (add1 x))) - (lambda () (set! y (add1 y)) - (when c0 ((begin0 - c0 - (set! c0 #f)))))) - (cons x y)))] - [ra-b-a-b - (lambda (get-a get-b) - (let ([l null]) - (let ((k-in (test-call/cc (lambda (k1) - (dynamic-wind - (lambda () (set! l (append l (list (get-a))))) - (lambda () - (call/cc (lambda (k2) (k1 k2)))) - (lambda () (set! l (append l (list (get-b)))))))))) - (k-in (lambda (v) l)))))]) - - (test 4 rv (lambda () 4)) - (test '(5 6) r56) - - (test '(7 . 8) rx.y (lambda () 7) (lambda () 8)) - - (test 9 rv2 (lambda () 9)) - - (test '(10 11 12) r10-11-12) - - (test '(13 . 14) r13.14) - - ; !!! fixed in 50: - (test '(enter exit enter exit) - ra-b-a-b (lambda () 'enter) (lambda () 'exit)) - - (test '((13 . 14) (10 11 12) (13 . 14) (10 11 12)) - ra-b-a-b r13.14 r10-11-12) - (test '((10 11 12) (13 . 14) (10 11 12) (13 . 14)) - ra-b-a-b r10-11-12 r13.14) - - (test '((enter exit enter exit) - (exit enter exit enter) - (enter exit enter exit) - (exit enter exit enter)) - ra-b-a-b - (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit))) - (lambda () (ra-b-a-b (lambda () 'exit) (lambda () 'enter)))) - - (test '(enter exit enter exit) - rv (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))) - (test '(enter exit enter exit) - rv2 (lambda () (ra-b-a-b (lambda () 'enter) (lambda () 'exit)))) - - (test '(10 11 12) rv r10-11-12) - (test '(10 11 12) rv2 r10-11-12) - - (test '(13 . 14) rv r13.14) - (test '(13 . 14) rv2 r13.14) - - (test 12 'dw/ec (test-call/cc - (lambda (k0) - (test-call/cc - (lambda (k1) - (test-call/cc - (lambda (k2) - (dynamic-wind - void - (lambda () (k1 6)) - (lambda () (k2 12)))))))))) - - ;; !!! fixed in 53 (for call/ec) - (test 13 'dw/ec (test-call/cc - (lambda (k0) - (test-call/cc - (lambda (k1) - (test-call/cc - (lambda (k2) - (dynamic-wind - void - (lambda () (k1 6)) - (lambda () (k2 12))))) - (k0 13)))))) - - )) - - -(test-cc-values call/cc) -(test-cc-values call/ec) - -(test 'ok - 'ec-cc-exn-combo - (with-handlers ([void (lambda (x) 'ok)]) - (define f - (let ([k #f]) - (lambda (n) - (case n - [(0) (let/ec r (r (set! k (let/cc k k))))] - [(1) (k)])))) - (f 0) - (f 1))) - -(test '(1 2 3 4 1 2 3 4) 'dyn-wind-pre/post-order - (let ([x null] - [go-back #f]) - (dynamic-wind - (lambda () (set! x (cons 4 x))) - (lambda () (dynamic-wind - (lambda () (set! x (cons 3 x))) - (lambda () (set! go-back (let/cc k k))) - (lambda () (set! x (cons 2 x))))) - (lambda () (set! x (cons 1 x)))) - (if (procedure? go-back) - (go-back 1) - x))) - -(test '(5 . 5) 'suspended-cont-escape - (let ([retry #f]) - (let ([v (let/ec exit - (dynamic-wind - void - (lambda () (exit 5)) - (lambda () - (let/ec inner-escape - (set! retry (let/cc k k)) - (inner-escape 12) - 10))))]) - (if (procedure? retry) - (retry 10) - (cons v v))))) - -(test '(here) 'escape-interrupt-full-jump-up - (let ([b #f] - [v null]) - (define (f g) - (dynamic-wind - void - g - (lambda () - (set! v (cons 'here v)) - (b 10)))) - - (let/ec big - (set! b big) - (let/cc ok - (f (lambda () - (ok #f))))) - - v)) - - -(arity-test call/cc 1 1) -(arity-test call/ec 1 1) -(error-test '(call/cc 4)) -(error-test '(call/cc (lambda () 0))) -(error-test '(call/ec 4)) -(error-test '(call/ec (lambda () 0))) - -(test #t primitive? car) -(test #f primitive? leaf-eq?) -(arity-test primitive? 1 1) - -(test 1 arity arity) -(test 2 arity cons) -(test (make-arity-at-least 1) arity >) -(test (list 0 1) arity current-output-port) -(test (list 1 3 (make-arity-at-least 5)) - arity (case-lambda [(x) 0] [(x y z) 1] [(x y z w u . rest) 2])) -(arity-test arity 1 1) - -(test #t procedure-arity-includes? cons 2) -(test #f procedure-arity-includes? cons 0) -(test #f procedure-arity-includes? cons 3) -(test #t procedure-arity-includes? list 3) -(test #t procedure-arity-includes? list 3000) -(test #t procedure-arity-includes? (lambda () 0) 0) -(test #f procedure-arity-includes? (lambda () 0) 1) -(test #f procedure-arity-includes? cons 10000000000000000000000000000) -(test #t procedure-arity-includes? list 10000000000000000000000000000) -(test #t procedure-arity-includes? (lambda x x) 10000000000000000000000000000) - -(error-test '(procedure-arity-includes? cons -1)) -(error-test '(procedure-arity-includes? cons 1.0)) -(error-test '(procedure-arity-includes? 'cons 1)) - -(arity-test procedure-arity-includes? 2 2) - -(newline) -(display ";testing scheme 4 functions; ") -(SECTION 6 7) -(test '(#\P #\space #\l) string->list "P l") -(test '() string->list "") -(test "1\\\"" list->string '(#\1 #\\ #\")) -(test "" list->string '()) -(arity-test list->string 1 1) -(arity-test string->list 1 1) -(error-test '(string->list 'hello)) -(error-test '(list->string 'hello)) -(error-test '(list->string '(#\h . #\e))) -(SECTION 6 8) -(test '(dah dah didah) vector->list '#(dah dah didah)) -(test '() vector->list '#()) -(test '#(dididit dah) list->vector '(dididit dah)) -(test '#() list->vector '()) -(arity-test list->vector 1 1) -(arity-test vector->list 1 1) -(error-test '(vector->list 'hello)) -(error-test '(list->vector 'hello)) -(error-test '(list->vector '(#\h . #\e))) - -(test-cont) - -(report-errs) - -"last item in file" diff --git a/collects/tests/mzscheme/censor.ss b/collects/tests/mzscheme/censor.ss deleted file mode 100644 index 52ef2628..00000000 --- a/collects/tests/mzscheme/censor.ss +++ /dev/null @@ -1,30 +0,0 @@ - -; run a thunk using a censor that removes dangerous chars from a -; string for printing to a terminal -(lambda (thunk) - (let ([censor (lambda (s) - (list->string - (let loop ([s (string->list s)]) - (if (null? s) - null - (let ([c (car s)]) - (cond - [(and (not (char-whitespace? c)) (or (char<=? c #\space) (char>=? c #\200))) - (append (cons #\{ (string->list - (number->string - (char->integer c)))) - (cons #\} (loop (cdr s))))] - [else - (cons c (loop (cdr s)))]))))))]) - (let* ([oldp (current-output-port)] - [cp (make-output-port - (lambda (s) - (display (censor s) oldp)) - void)]) - (dynamic-wind - (lambda () (current-output-port cp)) - thunk - (lambda () - (current-output-port oldp)))))) - - diff --git a/collects/tests/mzscheme/chkdoc.ss b/collects/tests/mzscheme/chkdoc.ss deleted file mode 100644 index c4249aeb..00000000 --- a/collects/tests/mzscheme/chkdoc.ss +++ /dev/null @@ -1,28 +0,0 @@ - -(require-library "mzlib.ss") - -(define actual-definitions - (filter (lambda (s) - (let ([s (symbol->string s)]) - (not (char=? (string-ref s 0) #\#)))) - (map car (make-global-value-list)))) - -(define doc-path (collection-path "doc")) - -(define r5rs-keywords (with-input-from-file (build-path doc-path "r5rs" "keywords") read)) -(define mzscheme-keywords (with-input-from-file (build-path doc-path "mzscheme" "keywords") read)) - -(define documented - (map string->symbol (map car (append r5rs-keywords mzscheme-keywords)))) - -(for-each - (lambda (doc) - (unless (memq doc actual-definitions) - (printf "Documented but doesn't exist: ~a~n" doc))) - documented) - -(for-each - (lambda (act) - (unless (memq act documented) - (printf "Undocumented: ~a~n" act))) - actual-definitions) diff --git a/collects/tests/mzscheme/classd.ss b/collects/tests/mzscheme/classd.ss deleted file mode 100644 index 7288413a..00000000 --- a/collects/tests/mzscheme/classd.ss +++ /dev/null @@ -1,147 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - - -(SECTION 'class/d) - -(require-library "classd.ss") - -(syntax-test '(class/d object% ((public x)) (define (x) 1))) -(syntax-test '(class/d object% () ((public x)))) -;; Should this be an error? -; (syntax-test '(class/d object% () ((public x x)) (define x 10))) - -(test - 1 - 'test-1 - (send (make-object (class/d object% () ((public y)) (define (y) 1) (super-init))) y)) - -(test - 1 - 'test-2 - (send (make-object (class/d object% () ((public y)) (define (y) 1) (define (z) 1) (super-init))) y)) - -(test - 3 - 'test-3 - (let ([x 1]) - (make-object - (class/d object% () () - (set! x 2) - (set! x 3) - (super-init))) - x)) - -(test - 2 - 'test-4 - (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) - () - ((override x)) - (super-init) - (define (x) 2))) - x)) - - -(test - 2 - 'test-5 - (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) - () - ((inherit x) - (public y)) - (super-init) - (define (y) (+ (x) (x))))) - y)) - -(test - 2 - 'test-6 - (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) - () - ((rename [super-x x]) - (public y)) - (super-init) - (define (y) (+ (super-x) (super-x))))) - y)) - -(test - 2 - 'test-7 - (send (make-object (class/d (class object% () (public [x (lambda () 1)]) (sequence (super-init))) - () - ((rename [super-x x]) - (override x)) - (super-init) - (define (x) (+ (super-x) (super-x))))) - x)) - -(test - 2 - 'test-8 - (send (make-object (class/d object% (xxx) - ((public x)) - (define (x) xxx) - (super-init)) - 2) - x)) - -(test - 1 - 'test-9 - (send (make-object (class/d*/names (local-this local-super-init) - object% - ((interface ())) - () - ((public x)) - (define (x) 1) - (local-super-init))) - x)) - -(test - 1 - 'test-10 - (send (make-object (class/d* object% - ((interface ())) - () - ((public x)) - (define (x) 1) - (super-init))) - x)) - -(test - 77 - 'test-10 - (ivar (make-object (class/d object% () - ((public x)) - (define y 77) - (define x y) - (super-init))) - x)) - -(test - (cons 78 16) - 'test-10 - (ivar (make-object (class/d (class object% () (public [x 16]) (sequence (super-init))) () - ((override x) - (rename [super-x x])) - (super-init) - (define y 78) - (define x (cons y super-x)))) - x)) - -(test - (cons 79 29) - 'test-10 - (ivar (make-object (class (class/d object% () - ((public x z)) - (define y 79) - (define x 19) - (define z (cons y x)) - (super-init)) () - (override - [x 29]) - (sequence - (super-init)))) - z)) diff --git a/collects/tests/mzscheme/cmdline.ss b/collects/tests/mzscheme/cmdline.ss deleted file mode 100644 index 618422db..00000000 --- a/collects/tests/mzscheme/cmdline.ss +++ /dev/null @@ -1,159 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'COMMAND-LINE) - -(require-library "cmdline.ss") - -(define (r-append opt . rest) - (append opt (list (list->vector rest)))) - -(test '("-bye" #()) - parse-command-line - "test" - #("--hi" "-bye") - (list - (list - 'multi - (list (list "--hi") - (lambda (flag v) v) - (list "Hello" "x")))) - r-append - '("arg")) - -(test '("1" "2" #("3")) - parse-command-line - "test" - #("-xi" "1" "2" "3") - (list - (list - 'multi - (list (list "-x" "-i") - (lambda (flag v) v) - (list "x or i" "x")))) - r-append - '("arg")) - -(test '(("-x" "a" "b") ("-i") #()) - parse-command-line - "test" - #("-xi" "a" "b") - (list - (list - 'multi - (list (list "-x" "-i") - list - (list "xi")))) - r-append - '("arg")) - -(test '("--simple" ("-x" . "a") ("-i" . "b") #()) - parse-command-line - "test" - #("--simple" "-xi" "a" "b") - (list - (list - 'multi - (list (list "--simple") (lambda (v) v) (list "S")) - (list (list "-x" "-i") - cons - (list "xi" "v")))) - r-append - '("arg")) - -(test '(("-x" "a" "c") ("-i" . "b") #("d")) - parse-command-line - "test" - #("-xi" "a" "c" "b" "d") - (list - (list - 'multi - (list (list "-x") - (lambda (x y z) (list x y z)) - (list "X" "y" "z")) - (list (list "-i") - cons - (list "i" "v")))) - r-append - '("arg")) - -(define (test-end-flags v include?) - (test (list - (list->vector - (let ([l '("-xi" "--bad" "--")]) - (if include? - (cons v l) - l)))) - parse-command-line - "test" - (vector v "-xi" "--bad" "--") - (list - (list - 'multi - (list (list "-x" "-i") - list - (list "xi")))) - r-append - '("arg"))) - -(test-end-flags "1" #t) -(test-end-flags "+" #t) -(test-end-flags "-" #t) -(test-end-flags "--" #f) -(test-end-flags "-1" #t) -(test-end-flags "+1" #t) -(test-end-flags "-1.4" #t) -(test-end-flags "+1999.0" #t) - -(define (test-bad-flag v name) ; -h and -i defined - (test 'yes-it-worked - (lambda (x-ignored y-ignored) - (with-handlers ([void - (lambda (exn) - (if (regexp-match - (format "unknown flag: ~s" name) - (exn-message exn)) - 'yes-it-worked - exn))]) - (parse-command-line - "test" - (vector name "--") - (list - (list - 'multi - (list (list "-x" "-i") - list - (list "x i")))) - r-append - '("arg")))) - v name)) - -(test-bad-flag "--ok" "--ok") -(test-bad-flag "-xbi" "-b") - -(test (void) parse-command-line "test" #() null void '("arg")) -(test (void) parse-command-line "test" #() (list (list 'once-each (list null void '("")))) void '("arg")) -(test (void) parse-command-line "test" #() (list (list 'once-any (list null void '("")))) void '("arg")) -(test (void) parse-command-line "test" #() (list (list 'multi (list null void '("")))) void '("arg")) -(test (void) parse-command-line "test" #() (list (list 'multi)) void '("arg")) - -(test "2" parse-command-line "test" #("1" "2") null (lambda (a b c) c) '("b" "c")) - -(error-test '(parse-command-line 'test #() null void '("arg"))) -(error-test '(parse-command-line "test" 9 null void '("arg"))) -(error-test '(parse-command-line "test" #() (list 0) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'malti)) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list 0 void '("")))) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list (list 0) void '("")))) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "hi") void '("")))) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "--") void '("")))) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "-xi") void '("")))) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "-x") (lambda () null) '("")))) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "--xi") void ""))) void '("arg"))) -(error-test '(parse-command-line "test" #() (list (list 'multi (list (list "--xi") void '("" a)))) void '("arg"))) -(error-test '(parse-command-line "test" #() null (lambda () null) null)) - -(error-test '(parse-command-line "test" #() null (lambda (x y) null) null) exn:user?) - -(report-errs) diff --git a/collects/tests/mzscheme/compfile.ss b/collects/tests/mzscheme/compfile.ss deleted file mode 100644 index 4cd91819..00000000 --- a/collects/tests/mzscheme/compfile.ss +++ /dev/null @@ -1,11 +0,0 @@ - -(require-library "compat.ss") -(require-library "compat.ss") -(require-library "compat.ss") - -(defmacro test (x y) (string-append x y)) - -(test "a" "b") - -(load x) -(require-library) diff --git a/collects/tests/mzscheme/compile.ss b/collects/tests/mzscheme/compile.ss deleted file mode 100644 index a252c1f8..00000000 --- a/collects/tests/mzscheme/compile.ss +++ /dev/null @@ -1,86 +0,0 @@ - -; Tests compilation and writing/reading compiled code -; by setting the eval handler and running all tests - -(unless (defined? 'compile-load) - (global-defined-value 'compile-load "all.ss")) - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(define file - (if #f - (open-output-file "x" 'replace) - (make-output-port void void))) - -(define try-one - (lambda (e) - (let ([c (compile e)] - [p (open-output-string)]) - (write c p) - (let ([s (get-output-string p)]) - ; (write (string->list s)) (newline) - (let ([e (parameterize ([read-accept-compiled #t]) - (read (open-input-string s)))]) - (eval e)))))) - -(letrec ([orig (current-eval)] - [orig-load (current-load)] - [my-load - (lambda (filename) - (let ([f (open-input-file filename)]) - (dynamic-wind - void - (lambda () - (let loop ([results (list (void))]) - (let ([v (parameterize ([read-accept-compiled #t]) - (read f))]) - (if (eof-object? v) - (apply values results) - (loop (call-with-values - (lambda () (my-eval v orig)) - list)))))) - (lambda () - (close-input-port f)))))] - [my-eval - (case-lambda - [(x next-eval) - (let ([p (open-output-string)] - [c (compile x)]) - (write c p) - (let ([s (get-output-string p)]) - ; (display s file) (newline file) - (let ([e (parameterize ([read-accept-compiled #t]) - (read (open-input-string s)))]) - ; (write e file) (newline file) - (parameterize ([current-eval next-eval]) - (orig e)))))] - [(x) (my-eval x orig)])]) - (dynamic-wind - (lambda () - (set! teval (lambda (x) (my-eval x my-eval))) - ; (read-accept-compiled #t) - (current-eval my-eval) - (current-load my-load)) - (lambda () - (load-relative compile-load)) - (lambda () - (set! teval eval) - (close-output-port file) - ; (read-accept-compiled #f) - (current-eval orig) - (current-load orig-load)))) - -; Check compiled number I/O: -(let ([l (let loop ([n -512][l null]) - (if (= n 513) - l - (loop (add1 n) (cons n l))))] - [p (open-output-string)]) - (write (compile `(quote ,l)) p) - (let ([s (open-input-string (get-output-string p))]) - (let ([l2 (parameterize ([read-accept-compiled #t]) - (eval (read s)))]) - (test #t equal? l l2)))) - -(report-errs) diff --git a/collects/tests/mzscheme/compilex.ss b/collects/tests/mzscheme/compilex.ss deleted file mode 100644 index 5e417fb0..00000000 --- a/collects/tests/mzscheme/compilex.ss +++ /dev/null @@ -1,14 +0,0 @@ - -; Tests simple compilation by setting the eval handler and -; running all tests - -(let ([orig (current-eval)]) - (dynamic-wind - (lambda () - (current-eval - (lambda (x) - (orig (compile x))))) - (lambda () - (load "all.ss")) - (lambda () - (current-eval orig)))) diff --git a/collects/tests/mzscheme/contmark.ss b/collects/tests/mzscheme/contmark.ss deleted file mode 100644 index bdc4ba2e..00000000 --- a/collects/tests/mzscheme/contmark.ss +++ /dev/null @@ -1,214 +0,0 @@ - - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'continuation-marks) - -(define (extract-current-continuation-marks key) - (continuation-mark-set->list (current-continuation-marks) key)) - -(test null extract-current-continuation-marks 'key) - -(test '(10) 'wcm (with-continuation-mark 'key 10 - (extract-current-continuation-marks 'key))) -(test '(11) 'wcm (with-continuation-mark 'key 10 - (with-continuation-mark 'key 11 - (extract-current-continuation-marks 'key)))) -(test '(9) 'wcm (with-continuation-mark 'key 10 - (with-continuation-mark 'key2 9 - (with-continuation-mark 'key 11 - (extract-current-continuation-marks 'key2))))) -(test '() 'wcm (with-continuation-mark 'key 10 - (with-continuation-mark 'key2 9 - (with-continuation-mark 'key 11 - (extract-current-continuation-marks 'key3))))) - -(test '() 'wcm (let ([x (with-continuation-mark 'key 10 (list 100))]) - (extract-current-continuation-marks 'key))) - -(test '(11) 'wcm (with-continuation-mark 'key 11 - (let ([x (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key))]) - (extract-current-continuation-marks 'key)))) - -(test '((11) (10 11) (11)) 'wcm (with-continuation-mark 'key 11 - (list (extract-current-continuation-marks 'key) - (with-continuation-mark 'key 10 (extract-current-continuation-marks 'key)) - (extract-current-continuation-marks 'key)))) - -(test '(11) 'wcm-invoke/tail (with-continuation-mark 'x 10 - (invoke-unit - (unit - (import) - (export) - - (with-continuation-mark 'x 11 - (continuation-mark-set->list - (current-continuation-marks) - 'x)))))) - -(test '(11 10) 'wcm-invoke/nontail (with-continuation-mark 'x 10 - (invoke-unit - (unit - (import) - (export) - - (define l (with-continuation-mark 'x 11 - (continuation-mark-set->list - (current-continuation-marks) - 'x))) - l)))) - -(test '(11 10) 'wcm-begin0 (with-continuation-mark 'x 10 - (begin0 - (with-continuation-mark 'x 11 - (extract-current-continuation-marks 'x)) - (+ 2 3)))) -(test '(11 10) 'wcm-begin0/const (with-continuation-mark 'x 10 - (begin0 - (with-continuation-mark 'x 11 - (extract-current-continuation-marks 'x)) - 'constant))) - -(define (get-marks) - (extract-current-continuation-marks 'key)) - -(define (tail-apply f) - (with-continuation-mark 'key 'tail - (f))) - -(define (non-tail-apply f) - (with-continuation-mark 'key 'non-tail - (car (cons (f) null)))) - -(test '(tail) tail-apply get-marks) -(test '(non-tail) non-tail-apply get-marks) -(test '(tail non-tail) non-tail-apply (lambda () (tail-apply get-marks))) -(test '(non-tail) tail-apply (lambda () (non-tail-apply get-marks))) - -(define (mark-x f) - (lambda () - (with-continuation-mark 'key 'x (f)))) - -(test '(x) tail-apply (mark-x get-marks)) -(test '(x non-tail) non-tail-apply (mark-x get-marks)) - -(test '(x) tail-apply (lambda () (tail-apply (mark-x get-marks)))) -(test '(x non-tail non-tail) non-tail-apply (lambda () (non-tail-apply (mark-x get-marks)))) -(test '(x non-tail) tail-apply (lambda () (non-tail-apply (mark-x get-marks)))) -(test '(x non-tail) non-tail-apply (lambda () (tail-apply (mark-x get-marks)))) - -;; Make sure restoring continuations restores the marks: -(let ([l null]) - (let ([did-once? #f] - [did-twice? #f] - [try-again #f] - [get-marks #f]) - - (with-continuation-mark - 'key (let/cc k (set! try-again k) 1) - (begin - (unless did-once? - (set! get-marks (let/cc k k))) - (set! l (cons (extract-current-continuation-marks 'key) l)))) - - (if did-once? - (unless did-twice? - (set! did-twice? #t) - (get-marks #f)) - (begin - (set! did-once? #t) - (try-again 2)))) - - (test '((1) (2) (1)) 'call/cc-restore-marks l)) - -(define (p-equal? a b) - (let loop ([a a][b b]) - (cond - [(eq? a b) #t] - [(equal? (car a) (car b)) - (loop (cdr a) (cdr b))] - [else - (printf "a: ~s~n" a) - (printf "b: ~s~n" b) - #f]))) - -;; Create a deep stack with a deep mark stack -(test #t - 'deep-stacks - (p-equal? - (let loop ([n 1000][l null]) - (if (zero? n) - l - (loop (sub1 n) (cons n l)))) - (let loop ([n 1000]) - (if (zero? n) - (extract-current-continuation-marks 'x) - (let ([x (with-continuation-mark 'x n (loop (sub1 n)))]) - x))))) - -;; Create a deep mark stack 10 times -(let loop ([n 10]) - (unless (zero? n) - (let* ([max 1000] - [r (add1 (random max))]) - (test (list 0 r) - `(loop ,n) - (with-continuation-mark 'base 0 - (let loop ([n max]) - (if (zero? n) - (append - (extract-current-continuation-marks 'base) - (extract-current-continuation-marks r)) - (with-continuation-mark n n - (loop (sub1 n)))))))) - (loop (sub1 n)))) - -;; Make sure marks are separate in separate threads -(let ([s1 (make-semaphore 0)] - [s2 (make-semaphore 0)] - [result null]) - (thread (lambda () - (with-continuation-mark 'key 'b.1 - (begin - (semaphore-wait s1) - (with-continuation-mark 'key 'b.2 - (begin - (semaphore-post s2) - (semaphore-wait s1) - (with-continuation-mark 'key 'b.4 - (begin - (set! result (extract-current-continuation-marks 'key)) - (semaphore-post s2))) - 'ok)) - 'ok)))) - (thread-wait - (thread (lambda () - (with-continuation-mark 'key 'a.1 - (begin - (semaphore-post s1) - (with-continuation-mark 'key 'a.2 - (begin - (semaphore-wait s2) - (with-continuation-mark 'key 'a.3 - (begin - (semaphore-post s1) - (with-continuation-mark 'key 'a.4 - (begin - (semaphore-wait s2) - (set! result (append (extract-current-continuation-marks 'key) result)))) - 'ok)) - 'ok)) - 'ok))))) - (test '(a.4 a.3 a.2 a.1 b.4 b.2 b.1) 'thread-marks result)) - -(arity-test current-continuation-marks 0 0) -(arity-test continuation-mark-set->list 2 2) -(arity-test continuation-mark-set? 1 1) - -(error-test '(continuation-mark-set->list 5 1)) - -(test #f continuation-mark-set? 5) -(test #t continuation-mark-set? (current-continuation-marks)) - -(report-errs) diff --git a/collects/tests/mzscheme/date.ss b/collects/tests/mzscheme/date.ss deleted file mode 100644 index 10671b78..00000000 --- a/collects/tests/mzscheme/date.ss +++ /dev/null @@ -1,42 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'date) - -(require-library "date.ss") - -(define (test-find s m h d mo y) - (let* ([secs (find-seconds s m h d mo y)] - [date (seconds->date secs)]) - (test #t 'same - (and (= s (date-second date)) - (= m (date-minute date)) - (= h (date-hour date)) - (= d (date-day date)) - (= mo (date-month date)) - (= y (date-year date)))))) - -(test-find 0 0 0 1 4 1975) -(test-find 0 0 0 1 4 2005) - -; Bad dates -(error-test '(find-seconds 0 0 0 0 0 1990) exn:user?) -(error-test '(find-seconds 0 0 0 0 1 1990) exn:user?) -(error-test '(find-seconds 0 0 0 1 0 1990) exn:user?) - -; Early/late -(error-test '(find-seconds 0 0 0 1 1 1490) exn:user?) -(error-test '(find-seconds 0 0 0 1 1 2890) exn:user?) - -; 1990 April 1 was start of daylight savings: -(test-find 0 0 1 1 4 1990) ; ok -(let ([s (find-seconds 1 0 3 1 4 1990)]) ; ok - (when (date-dst? (seconds->date s)) - ; We have daylight savings here; 2:01 AM doesn't exist - (error-test '(find-seconds 0 1 2 1 4 1990) exn:user?) - ; This date is ambiguous; find-seconds should find - ; one of the two possible values, though: - (test-find 0 30 1 27 10 1996))) - -(report-errs) diff --git a/collects/tests/mzscheme/deep.ss b/collects/tests/mzscheme/deep.ss deleted file mode 100644 index 6cf30e78..00000000 --- a/collects/tests/mzscheme/deep.ss +++ /dev/null @@ -1,126 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'deep) - -; Test deep stacks - -(define (nontail-loop n esc) - (let loop ([n n]) - (if (zero? n) - (esc 0) - (sub1 (loop (sub1 n)))))) - -(define (time-it t) - (let ([s (current-process-milliseconds)]) - (t) - (- (current-process-milliseconds) s))) - -(define (find-depth go) - ; Find depth that triggers a stack overflow by looking - ; for an incongruous change in the running time. - (let find-loop ([d 100][t (time-it (lambda () (go 100)))]) - (if (zero? t) - (find-loop (* 2 d) (time-it (lambda () (go (* 2 d))))) - (begin - ; (printf "~a in ~a~n" d t) - (let* ([d2 (* 2 d)] - [t2 (time-it (lambda () (go d2)))]) - (if (> (/ t2 d2) (* 2.2 (/ t d))) - d2 - (find-loop d2 t2))))))) - -(define proc-depth (find-depth (lambda (n) (nontail-loop n (lambda (x) x))))) -(printf "non-tail loop overflows at ~a~n" proc-depth) - -(test (- proc-depth) 'deep-recursion (nontail-loop proc-depth (lambda (x) x))) - -(test 0 'deep-recursion-escape/ec - (let/ec k - (nontail-loop proc-depth k))) - -(test 0 'deep-recursion-escape/cc - (let/cc k - (nontail-loop proc-depth k))) - -(define (read-deep depth) - (define paren-port - (let* ([depth depth] - [closing? #f] - [count depth]) - (make-input-port - (lambda () - (cond - [closing? - (if (= count depth) - eof - (begin - (set! count (add1 count)) - #\) ))] - [else - (set! count (sub1 count)) - (when (zero? count) - (set! closing? #t)) - #\(])) - (lambda () #t) - void))) - (read paren-port)) - -(define read-depth (find-depth read-deep)) -(printf "nested paren read overflows at ~a~n" read-depth) - -(define deep-list (read-deep read-depth)) - -(test #t 'read-deep (pair? deep-list)) - -(define s (open-output-string)) -(display deep-list s) -(test 'ok 'display 'ok) - -(test #t 'equal? (equal? deep-list (read (open-input-string (get-output-string s))))) - -(define going? #t) -(define (equal?-forever l1 l2) - (let ([t (thread (lambda () - (equal? l1 l2) ; runs forever; could run out of memory - (set! going? #f)))]) - (sleep 1) - (kill-thread t) - going?)) - - -(define l1 (cons 0 #f)) -(set-cdr! l1 l1) -(define l2 (cons 0 #f)) -(set-cdr! l2 l2) -(test #t 'equal?-forever (equal?-forever l1 l2)) - -(define l1 (cons 0 #f)) -(set-car! l1 l1) -(define l2 (cons 0 #f)) -(set-car! l2 l2) -(test #t 'equal?-forever/memory (equal?-forever l1 l2)) - -(define l1 (vector 0)) -(vector-set! l1 0 l1) -(define l2 (vector 0)) -(vector-set! l2 0 l2) -(test #t 'equal?-forever/vector (equal?-forever l1 l2)) - -(define-struct a (b c)) -(define l1 (make-a 0 #f)) -(set-a-b! l1 l1) -(define l2 (make-a 0 #f)) -(set-a-b! l2 l2) -(test #t 'equal?-forever/struct (equal?-forever l1 l2)) - -(define l1 (box 0)) -(set-box! l1 l1) -(define l2 (box 0)) -(set-box! l2 l2) -(test #t 'equal?-forever/struct (equal?-forever l1 l2)) - -(test #t 'equal?-forever/struct (call-in-nested-thread (lambda () (equal?-forever l1 l2)))) - -(report-errs) diff --git a/collects/tests/mzscheme/em-imp.ss b/collects/tests/mzscheme/em-imp.ss deleted file mode 100644 index 69a97a09..00000000 --- a/collects/tests/mzscheme/em-imp.ss +++ /dev/null @@ -1,467 +0,0 @@ -;;; -*- scheme -*- -;;; Fortran-style implementation of an EM clustering algorithm. -;;; -;;; Written by Jeffrey Mark Siskind (qobi@cs.toronto.edu) -;;; R4RS-ified by by Lars Thomas Hansen (lth@cs.uoregon.edu) -;;; Random number generator by Ozan Yigit. -;;; -;;; To run: (run-benchmark) -;;; You must provide your own timer function. -;;; -;;; Some benchmark times: -;;; -;;; Chez Scheme 4.1 for SunOS running on Sparc 10/51 (1MB,96MB,50MHz), Solaris: -;;; Optimize-level 2: 112s run (CPU), 2.8s gc, 326 MB allocated, 1181 GCs -;;; Optimize-level 3: 79s run (CPU), 2.8s gc, 326 MB allocated, 1163 GCs - -(define make-model vector) -(define (model-pi model) (vector-ref model 0)) -(define (set-model-pi! model x) (vector-set! model 0 x)) -(define (model-mu model) (vector-ref model 1)) -(define (model-sigma model) (vector-ref model 2)) -(define (model-log-pi model) (vector-ref model 3)) -(define (set-model-log-pi! model x) (vector-set! model 3 x)) -(define (model-sigma-inverse model) (vector-ref model 4)) -(define (model-log-determinant-sigma model) (vector-ref model 5)) -(define (set-model-log-sigma-determinant! model x) (vector-set! model 5 x)) - -;--------------------------------------------------------------------------- -; Minimal Standard Random Number Generator -; Park & Miller, CACM 31(10), Oct 1988, 32 bit integer version. -; better constants, as proposed by Park. -; By Ozan Yigit - -(define *seed* 1) - -(define (srand seed) - (set! *seed* seed) - *seed*) - -(define (rand) - (let ((A 48271) - (M 2147483647) - (Q 44488) - (R 3399)) - (let* ((hi (quotient *seed* Q)) - (lo (modulo *seed* Q)) - (test (- (* A lo) (* R hi)))) - (if (> test 0) - (set! *seed* test) - (set! *seed* (+ test M))))) - *seed*) - -;--------------------------------------------------------------------------- - -(define (panic s) (error 'panic s)) - -(define *rand-max* 2147483648) - -(define log-math-precision 35.0) - -(define minus-infinity (- *rand-max*)) - -(define first car) - -(define second cadr) - -(define rest cdr) - -(define (reduce f l i) - (cond ((null? l) i) - ((null? (rest l)) (first l)) - (else (let loop ((l (rest l)) (c (first l))) - (if (null? l) c (loop (rest l) (f c (first l)))))))) - -(define (every-n p n) - (let loop ((i 0)) (or (>= i n) (and (p i) (loop (+ i 1)))))) - -(define (sum f n) - (let loop ((n (- n 1)) (c 0.0)) - (if (negative? n) c (loop (- n 1) (+ c (f n)))))) - -(define (add-exp e1 e2) - (let* ((e-max (max e1 e2)) - (e-min (min e1 e2)) - (factor (floor e-min))) - (if (= e-max minus-infinity) - minus-infinity - (if (> (- e-max factor) log-math-precision) - e-max - (+ (log (+ (exp (- e-max factor)) (exp (- e-min factor)))) - factor))))) - -(define (map-n f n) - (let loop ((i 0) (c '())) - (if (< i n) (loop (+ i 1) (cons (f i) c)) (reverse c)))) - -(define (map-n-vector f n) - (let ((v (make-vector n))) - (let loop ((i 0)) - (if (< i n) - (begin (vector-set! v i (f i)) - (loop (+ i 1))))) - v)) - -(define (remove-if-not p l) - (let loop ((l l) (c '())) - (cond ((null? l) (reverse c)) - ((p (first l)) (loop (rest l) (cons (first l) c))) - (else (loop (rest l) c))))) - -(define (positionv x l) - (let loop ((l l) (i 0)) - (cond ((null? l) #f) - ((eqv? x (first l)) i) - (else (loop (rest l) (+ i 1)))))) - -(define (make-matrix m n) - (map-n-vector (lambda (i) (make-vector n)) m)) - -(define (make-matrix-initial m n initial) - (map-n-vector (lambda (i) (make-vector n initial)) m)) - -(define (matrix-rows a) (vector-length a)) - -(define (matrix-columns a) (vector-length (vector-ref a 0))) - -(define (matrix-ref a i j) (vector-ref (vector-ref a i) j)) - -(define (matrix-set! a i j x) (vector-set! (vector-ref a i) j x)) - -(define (matrix-row-ref a i) (vector-ref a i)) - -(define (matrix-row-set! a i v) (vector-set! a i v)) - -(define (determinant a) - (if (not (= (matrix-rows a) (matrix-columns a))) - (panic "Can only find determinant of a square matrix")) - (call-with-current-continuation - (lambda (return) - (let* ((n (matrix-rows a)) - (b (make-matrix n n)) - (d 1.0)) - (do ((i 0 (+ i 1))) ((= i n)) - (do ((j 0 (+ j 1))) ((= j n)) (matrix-set! b i j (matrix-ref a i j)))) - (do ((i 0 (+ i 1))) ((= i n)) - ;; partial pivoting reduces rounding errors - (let ((greatest (abs (matrix-ref b i i))) - (index i)) - (do ((j (+ i 1) (+ j 1))) ((= j n)) - (let ((x (abs (matrix-ref b j i)))) - (if (> x greatest) (begin (set! index j) (set! greatest x))))) - (if (= greatest 0.0) (return 0.0)) - (if (not (= index i)) - (let ((v (matrix-row-ref b i))) - (matrix-row-set! b i (matrix-row-ref b index)) - (matrix-row-set! b index v) - (set! d (- d)))) - (let ((c (matrix-ref b i i))) - (set! d (* d c)) - (do ((j i (+ j 1))) ((= j n)) - (matrix-set! b i j (/ (matrix-ref b i j) c))) - (do ((j (+ i 1) (+ j 1))) ((= j n)) - (let ((e (matrix-ref b j i))) - (do ((k (+ i 1) (+ k 1))) ((= k n)) - (matrix-set! - b j k (- (matrix-ref b j k) (* e (matrix-ref b i k)))))))))) - d)))) - -(define (invert-matrix! a b) - (if (not (= (matrix-rows a) (matrix-columns a))) - (panic "Can only invert a square matrix")) - (let* ((n (matrix-rows a)) - (c (make-matrix n n))) - (do ((i 0 (+ i 1))) ((= i n)) - (do ((j 0 (+ j 1))) ((= j n)) - (matrix-set! b i j 0.0) - (matrix-set! c i j (matrix-ref a i j)))) - (do ((i 0 (+ i 1))) ((= i n)) (matrix-set! b i i 1.0)) - (do ((i 0 (+ i 1))) ((= i n)) - (if (zero? (matrix-ref c i i)) - (call-with-current-continuation - (lambda (return) - (do ((j 0 (+ j 1))) ((= j n)) - (if (and (> j i) (not (zero? (matrix-ref c j i)))) - (begin - (let ((e (vector-ref c i))) - (vector-set! c i (vector-ref c j)) - (vector-set! c j e)) - (let ((e (vector-ref b i))) - (vector-set! b i (vector-ref b j)) - (vector-set! b j e)) - (return #f)))) - (panic "Matrix is singular")))) - (let ((d (/ (matrix-ref c i i)))) - (do ((j 0 (+ j 1))) ((= j n)) - (matrix-set! c i j (* d (matrix-ref c i j))) - (matrix-set! b i j (* d (matrix-ref b i j)))) - (do ((k 0 (+ k 1))) ((= k n)) - (let ((d (- (matrix-ref c k i)))) - (if (not (= k i)) - (do ((j 0 (+ j 1))) ((= j n)) - (matrix-set! - c k j (+ (matrix-ref c k j) (* d (matrix-ref c i j)))) - (matrix-set! - b k j (+ (matrix-ref b k j) (* d (matrix-ref b i j)))))))))))) - -(define (jacobi! a) - (if (not (and (= (matrix-rows a) (matrix-columns a)) - (every-n (lambda (i) - (every-n (lambda (j) - (= (matrix-ref a i j) (matrix-ref a j i))) - (matrix-rows a))) - (matrix-rows a)))) - (panic "Can only compute eigenvalues/eigenvectors of a symmetric matrix")) - (let* ((n (matrix-rows a)) - (d (make-vector n)) - (v (make-matrix-initial n n 0.0)) - (b (make-vector n)) - (z (make-vector n 0.0))) - (do ((ip 0 (+ ip 1))) ((= ip n)) - (matrix-set! v ip ip 1.0) - (vector-set! b ip (matrix-ref a ip ip)) - (vector-set! d ip (matrix-ref a ip ip))) - (let loop ((i 0)) - (if (> i 50) (panic "Too many iterations in JACOBI!")) - (let ((sm (sum (lambda (ip) - (sum (lambda (ir) - (let ((iq (+ ip ir 1))) - (abs (matrix-ref a ip iq)))) - (- n ip 1))) - (- n 1)))) - (if (not (zero? sm)) - (begin - (let ((tresh (if (< i 3) (/ (* 0.2 sm) (* n n)) 0.0))) - (do ((ip 0 (+ ip 1))) ((= ip (- n 1))) - (do ((ir 0 (+ ir 1))) ((= ir (- n ip 1))) - (let* ((iq (+ ip ir 1)) - (g (* 100.0 (abs (matrix-ref a ip iq))))) - (cond - ((and (> i 3) - (= (+ (abs (vector-ref d ip)) g) - (abs (vector-ref d ip))) - (= (+ (abs (vector-ref d iq)) g) - (abs (vector-ref d iq)))) - (matrix-set! a ip iq 0.0)) - ((> (abs (matrix-ref a ip iq)) tresh) - (let* ((h (- (vector-ref d iq) (vector-ref d ip))) - (t (if (= (+ (abs h) g) (abs h)) - (/ (matrix-ref a ip iq) h) - (let ((theta (/ (* 0.5 h) - (matrix-ref a ip iq)))) - (if (negative? theta) - (- (/ (+ (abs theta) - (sqrt (+ (* theta theta) 1.0))))) - (/ (+ (abs theta) - (sqrt (+ (* theta theta) 1.0)))))))) - (c (/ (sqrt (+ (* t t) 1.0)))) - (s (* t c)) - (tau (/ s (+ c 1.0))) - (h (* t (matrix-ref a ip iq)))) - (define (rotate a i j k l) - (let ((g (matrix-ref a i j)) - (h (matrix-ref a k l))) - (matrix-set! a i j (- g (* s (+ h (* g tau))))) - (matrix-set! a k l (+ h (* s (- g (* h tau))))))) - (vector-set! z ip (- (vector-ref z ip) h)) - (vector-set! z iq (+ (vector-ref z iq) h)) - (vector-set! d ip (- (vector-ref d ip) h)) - (vector-set! d iq (+ (vector-ref d iq) h)) - (matrix-set! a ip iq 0.0) - (do ((j 0 (+ j 1))) ((= j n)) - (cond ((< j ip) (rotate a j ip j iq)) - ((< ip j iq) (rotate a ip j j iq)) - ((< iq j) (rotate a ip j iq j))) - (rotate v j ip j iq))))))))) - (do ((ip 0 (+ ip 1))) ((= ip n)) - (vector-set! b ip (+ (vector-ref b ip) (vector-ref z ip))) - (vector-set! d ip (vector-ref b ip)) - (vector-set! z ip 0.0)) - (loop (+ i 1)))))) - (do ((i 0 (+ i 1))) ((= i (- n 1))) - (let ((k i) - (p (vector-ref d i))) - (do ((l 0 (+ l 1))) ((= l (- n i 1))) - (let* ((j (+ i l 1))) - (if (>= (vector-ref d j) p) - (begin (set! k j) (set! p (vector-ref d j)))))) - (if (not (= k i)) - (begin (vector-set! d k (vector-ref d i)) - (vector-set! d i p) - (do ((j 0 (+ j 1))) ((= j n)) - (let ((p (matrix-ref v j i))) - (matrix-set! v j i (matrix-ref v j k)) - (matrix-set! v j k p))))))) - (list d v))) - -(define (clip-eigenvalues! a v) - (let* ((j (jacobi! a)) - (l (first j)) - (e (second j))) - (do ((k1 0 (+ k1 1))) ((= k1 (vector-length a))) - (let ((a-k1 (vector-ref a k1)) - (e-k1 (vector-ref e k1))) - (do ((k2 0 (+ k2 1))) ((= k2 (vector-length a-k1))) - (let ((e-k2 (vector-ref e k2)) - (s 0.0)) - (do ((k 0 (+ k 1))) ((= k (vector-length a))) - (set! s (+ s (* (max (vector-ref v k) (vector-ref l k)) - (vector-ref e-k1 k) - (vector-ref e-k2 k))))) - (vector-set! a-k1 k2 s))))))) - -;;; EM - -(define (e-step! x z models) - (do ((i 0 (+ i 1))) ((= i (vector-length x))) - (let ((xi (vector-ref x i)) - (zi (vector-ref z i))) - (do ((j 0 (+ j 1))) ((= j (vector-length models))) - ;; Compute for each model. - (let* ((model (vector-ref models j)) - (log-pi (model-log-pi model)) - (mu (model-mu model)) - (sigma-inverse (model-sigma-inverse model)) - (log-determinant-sigma (model-log-determinant-sigma model)) - (t 0.0)) - ;; Compute likelihoods (note: up to constant for all models). - (set! t 0.0) - (do ((k1 0 (+ k1 1))) ((= k1 (vector-length xi))) - (let ((sigma-inverse-k1 (vector-ref sigma-inverse k1))) - (do ((k2 0 (+ k2 1))) ((= k2 (vector-length xi))) - (set! t (+ t (* (- (vector-ref xi k1) (vector-ref mu k1)) - (vector-ref sigma-inverse-k1 k2) - (- (vector-ref xi k2) (vector-ref mu k2)))))))) - (vector-set! zi j (- log-pi (* 0.5 (+ log-determinant-sigma t)))))))) - (let ((l 0.0)) - (do ((i 0 (+ i 1))) ((= i (vector-length x))) - (let ((s minus-infinity) - (zi (vector-ref z i))) - ;; Normalize ownerships to sum to one. - (do ((j 0 (+ j 1))) ((= j (vector-length models))) - (set! s (add-exp s (vector-ref zi j)))) - (do ((j 0 (+ j 1))) ((= j (vector-length models))) - (vector-set! zi j (exp (- (vector-ref zi j) s)))) - (set! l (+ l s)))) - ;; Return log likelihood. - l)) - -(define (m-step! x models z clip) - (let ((kk (vector-length (vector-ref x 0)))) - ;; For each model, optimize parameters. - (do ((j 0 (+ j 1))) ((= j (vector-length models))) - (let* ((model (vector-ref models j)) - (mu (model-mu model)) - (sigma (model-sigma model)) - (s 0.0)) - ;; Optimize values. - (do ((k 0 (+ k 1))) ((= k kk)) - (do ((i 0 (+ i 1))) ((= i (vector-length x))) - (set! s (+ s (vector-ref (vector-ref z i) j))))) - (do ((k 0 (+ k 1))) ((= k kk)) - (let ((m 0.0)) - (do ((i 0 (+ i 1))) ((= i (vector-length x))) - (set! m (+ m (* (vector-ref (vector-ref z i) j) - (vector-ref (vector-ref x i) k))))) - (vector-set! mu k (/ m s)))) - (do ((k1 0 (+ k1 1))) ((= k1 kk)) - (let ((sigma-k1 (vector-ref sigma k1)) - (mu-k1 (vector-ref mu k1))) - (do ((k2 0 (+ k2 1))) ((= k2 kk)) - (let ((mu-k2 (vector-ref mu k2)) - (m 0.0)) - (do ((i 0 (+ i 1))) ((= i (vector-length x))) - (set! m (+ m (* (vector-ref (vector-ref z i) j) - (- (vector-ref (vector-ref x i) k1) mu-k1) - (- (vector-ref (vector-ref x i) k2) mu-k2))))) - (vector-set! sigma-k1 k2 (/ m s)))))) - (clip-eigenvalues! sigma clip) - (set-model-pi! model (/ s (vector-length x))) - (set-model-log-pi! model (log (/ s (vector-length x)))) - (invert-matrix! sigma (model-sigma-inverse model)) - (set-model-log-sigma-determinant! model (log (determinant sigma))))))) - -(define (em! x z models clip em-kick-off-tolerance em-convergence-tolerance) - (let loop ((old-log-likelihood minus-infinity) (starting? #t)) - (let ((log-likelihood (e-step! x z models))) - (cond - ((or (and starting? (> log-likelihood old-log-likelihood)) - (> log-likelihood (+ old-log-likelihood em-convergence-tolerance))) - (m-step! x models z clip) - (loop log-likelihood - (and starting? - (not (= (vector-length models) 1)) - (or (= old-log-likelihood minus-infinity) - (< log-likelihood - (+ old-log-likelihood em-kick-off-tolerance)))))) - (else old-log-likelihood))))) - -(define (noise epsilon) (- (* 2.0 epsilon (/ (rand) *rand-max*)) epsilon)) - -(define (initial-z ii jj) - (map-n-vector - (lambda (i) - (let ((zi (map-n-vector (lambda (j) (+ (/ jj) (noise (/ jj)))) jj)) - (s 0.0)) - (do ((j 0 (+ j 1))) ((= j jj)) (set! s (+ s (vector-ref zi j)))) - (do ((j 0 (+ j 1))) ((= j jj)) (vector-set! zi j (/ (vector-ref zi j) s))) - zi)) - ii)) - -(define (ems x clip em-kick-off-tolerance em-convergence-tolerance - ems-convergence-tolerance) - (let loop ((jj 1) - (old-z #f) - (old-models #f) - (old-log-likelihood minus-infinity)) - (let* ((kk (vector-length (vector-ref x 0))) - (z (initial-z (vector-length x) jj)) - (models (map-n-vector - (lambda (j) - (make-model 0.0 - (make-vector kk) - (make-matrix kk kk) - 0.0 - (make-matrix kk kk) - 0.0)) - jj))) - (m-step! x models z clip) - (let ((new-log-likelihood - (em! - x z models clip em-kick-off-tolerance em-convergence-tolerance))) - (if (> (- (/ old-log-likelihood new-log-likelihood) 1.0) - ems-convergence-tolerance) - (loop (+ jj 1) z models new-log-likelihood) - (list old-z old-models)))))) - -(define (em-clusterer x clip em-kick-off-tolerance em-convergence-tolerance - ems-convergence-tolerance) - (let* ((z-models (ems x clip em-kick-off-tolerance - em-convergence-tolerance - ems-convergence-tolerance)) - (z (first z-models)) - (models (second z-models))) - (e-step! x z models) - (let ((clusters - (map-n (lambda (i) - (let ((zi (vector->list (vector-ref z i)))) - (list i (positionv (reduce max zi minus-infinity) zi)))) - (vector-length z)))) - (map-n (lambda (j) - (map (lambda (cluster) (vector-ref x (first cluster))) - (remove-if-not (lambda (cluster) (= (second cluster) j)) - clusters))) - (vector-length (vector-ref z 0)))))) - -(define (go) - (em-clusterer - '#(#(1.0) #(2.0) #(3.0) #(11.0) #(12.0) #(13.0)) '#(1.0) 10.0 1.0 0.01)) - -(define (run-benchmark) - (srand 1) - (do ((i 0 (+ i 1))) ((= i 100)) - (write (go)) - (newline))) - -; eof - diff --git a/collects/tests/mzscheme/expand.ss b/collects/tests/mzscheme/expand.ss deleted file mode 100644 index ab184a17..00000000 --- a/collects/tests/mzscheme/expand.ss +++ /dev/null @@ -1,26 +0,0 @@ - -; Tests macro expansion by setting the eval handler and -; running all tests - -(unless (defined? 'expand-load) - (global-defined-value 'expand-load "all.ss")) - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(let ([orig (current-eval)]) - (dynamic-wind - (lambda () - (current-eval - (lambda (x) - (set! mz-test-syntax-errors-allowed? #t) - (let ([x (expand-defmacro - (expand-defmacro - (expand-defmacro-once - (expand-defmacro-once x))))]) - (set! mz-test-syntax-errors-allowed? #f) - (orig x))))) - (lambda () - (load-relative expand-load)) - (lambda () - (current-eval orig)))) diff --git a/collects/tests/mzscheme/fact.ss b/collects/tests/mzscheme/fact.ss deleted file mode 100644 index d991f2fc..00000000 --- a/collects/tests/mzscheme/fact.ss +++ /dev/null @@ -1,6 +0,0 @@ -(define fact - (lambda (n) - (let loop ([n n][res 1]) - (if (zero? n) - res - (loop (sub1 n) (* n res)))))) diff --git a/collects/tests/mzscheme/file.ss b/collects/tests/mzscheme/file.ss deleted file mode 100644 index e345ff86..00000000 --- a/collects/tests/mzscheme/file.ss +++ /dev/null @@ -1,677 +0,0 @@ - - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(define testing.ss (build-path (current-load-relative-directory) "testing.ss")) - -(SECTION 6 10 1) -(test #t input-port? (current-input-port)) -(test #t output-port? (current-output-port)) -(test #t output-port? (current-error-port)) -(test (void) current-input-port (current-input-port)) -(test (void) current-output-port (current-output-port)) -(test (void) current-error-port (current-error-port)) -(test #t call-with-input-file testing.ss input-port?) -(define this-file (open-input-file testing.ss)) -(test #t input-port? this-file) -(close-input-port this-file) -(define this-file (open-input-file testing.ss 'binary)) -(test #t input-port? this-file) -(close-input-port this-file) -(define this-file (open-input-file testing.ss 'text)) -(test #t input-port? this-file) -(arity-test input-port? 1 1) -(arity-test output-port? 1 1) -(arity-test current-input-port 0 1) -(arity-test current-output-port 0 1) -(arity-test current-error-port 0 1) -(error-test '(current-input-port 8)) -(error-test '(current-output-port 8)) -(error-test '(current-error-port 8)) -(error-test '(current-input-port (current-output-port))) -(error-test '(current-output-port (current-input-port))) -(error-test '(current-error-port (current-input-port))) -(SECTION 6 10 2) -(test #\; peek-char this-file) -(arity-test peek-char 0 1) -(test #\; read-char this-file) -(arity-test read-char 0 1) -(test '(define cur-section '()) read this-file) -(arity-test read 0 1) -(test #\( peek-char this-file) -(test '(define errs '()) read this-file) -(close-input-port this-file) -(close-input-port this-file) -(arity-test close-input-port 1 1) -(arity-test close-output-port 1 1) -(error-test '(peek-char 5)) -(error-test '(peek-char (current-output-port))) -(error-test '(read-char 5)) -(error-test '(read-char (current-output-port))) -(error-test '(read 5)) -(error-test '(read (current-output-port))) -(error-test '(close-input-port 5)) -(error-test '(close-output-port 5)) -(error-test '(close-input-port (current-output-port))) -(error-test '(close-output-port (current-input-port))) -(define (check-test-file name) - (define test-file (open-input-file name)) - (test #t 'input-port? - (call-with-input-file - name - (lambda (test-file) - (test load-test-obj read test-file) - (test #t eof-object? (peek-char test-file)) - (test #t eof-object? (read-char test-file)) - (input-port? test-file)))) - (test #\; read-char test-file) - (test display-test-obj read test-file) - (test load-test-obj read test-file) - (close-input-port test-file)) -(SECTION 6 10 3) -(define write-test-obj - '(#t #f #\a () 9739 -3 . #((test) "te \" \" st" "" test #() b c))) -(define display-test-obj - '(#t #f a () 9739 -3 . #((test) te " " st test #() b c))) -(define load-test-obj - (list 'define 'foo (list 'quote write-test-obj))) -(let ([f (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))]) - (test #t call-with-output-file - "tmp1" f 'truncate)) -(check-test-file "tmp1") - -(test (string #\null #\null #\" #\null #\") - 'write-null - (let ([p (open-output-string)]) - (write-char #\null p) - (display (string #\null) p) - (write (string #\null) p) - (let ([s (get-output-string p)]) - s))) - -; Test string ports with file-position: -(let ([s (open-output-string)]) - (test (string) get-output-string s) - (test 0 file-position s) - (display "a" s) - (test (string #\a) get-output-string s) - (test 1 file-position s) - (test (void) file-position s 10) - (test 10 file-position s) - (test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul) get-output-string s) - (display "z" s) - (test (string #\a #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\nul #\z) get-output-string s) - (test 11 file-position s) - (test (void) file-position s 3) - (display "mmm" s) - (test (string #\a #\nul #\nul #\m #\m #\m #\nul #\nul #\nul #\nul #\z) get-output-string s) - (test 6 file-position s) - (display "banana" s) - (test (string #\a #\nul #\nul #\m #\m #\m #\b #\a #\n #\a #\n #\a) get-output-string s) - (test 12 file-position s)) -(let ([s (open-input-string "hello")]) - (test 0 file-position s) - (test #\h read-char s) - (test 1 file-position s) - (test #\e read-char s) - (test (void) file-position s 0) - (test 0 file-position s) - (test #\h read-char s) - (test (void) file-position s 4) - (test 4 file-position s) - (test #\o read-char s) - (test 5 file-position s) - (test eof read-char s) - (test 5 file-position s) - (test (void) file-position s 502) - (test eof read-char s) - (test eof read-char s) - (test 502 file-position s) - (test (void) file-position s 2) - (test #\l read-char s) - (test 3 file-position s)) - -(define s (open-output-string)) -(error-test '(file-position 's 1)) -(error-test '(file-position s 'one)) -(error-test '(file-position s -1)) -(error-test '(file-position s (expt 2 100)) exn:application:mismatch?) -(error-test '(file-position (make-input-port void void void) 100) exn:application:mismatch?) -(error-test '(file-position (make-output-port void void) 100) exn:application:mismatch?) -(arity-test file-position 1 2) - -(define (test-read-line r1 r2 s1 s2 flags sep) - (let ([p (open-input-string (string-append s1 - (apply string sep) - s2))]) - (test r1 apply read-line p flags) - (test r2 apply read-line p flags))) -(define (add-return s t) (string-append s (string #\return) t)) -(define (add-linefeed s t) (string-append s (string #\linefeed) t)) - -(test-read-line "ab" "cd" "ab" "cd" null '(#\linefeed)) -(test-read-line (add-return "ab" "cd") eof "ab" "cd" null '(#\return)) -(test-read-line (add-return "ab" "") "cd" "ab" "cd" null '(#\return #\linefeed)) -(test-read-line "ab" "cd" "ab" "cd" '(return) '(#\return)) -(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return) '(#\linefeed)) -(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return) '(#\return #\linefeed)) -(test-read-line (add-return "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\return)) -(test-read-line (add-linefeed "ab" "cd") eof "ab" "cd" '(return-linefeed) '(#\linefeed)) -(test-read-line "ab" "cd" "ab" "cd" '(return-linefeed) '(#\return #\linefeed)) -(test-read-line (add-return "ab" "") "cd" "ab" "cd" '(return-linefeed) '(#\return #\return #\linefeed)) -(test-read-line "ab" (add-linefeed "" "cd") "ab" "cd" '(return-linefeed) '(#\return #\linefeed #\linefeed)) -(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return)) -(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\linefeed)) -(test-read-line "ab" "cd" "ab" "cd" '(any) '(#\return #\linefeed)) -(test-read-line "ab" "" "ab" "cd" '(any) '(#\linefeed #\return)) -(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\return)) -(test-read-line "ab" "cd" "ab" "cd" '(any-one) '(#\linefeed)) -(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\return #\linefeed)) -(test-read-line "ab" "" "ab" "cd" '(any-one) '(#\linefeed #\return)) - -(arity-test read-line 0 2) -(error-test '(read-line 8)) -(error-test '(read-line 'any)) -(error-test '(read-line (current-input-port) 8)) -(error-test '(read-line (current-input-port) 'anyx)) - -(arity-test open-input-file 1 2) -(error-test '(open-input-file 8)) -(error-test '(open-input-file "x" 8)) -(error-test '(open-input-file "x" 'something-else)) -(error-test '(open-input-file "badfile") exn:i/o:filesystem?) - -(arity-test open-output-file 1 3) -(error-test '(open-output-file 8)) -(error-test '(open-output-file "x" 8)) -(error-test '(open-output-file "x" 'something-else)) -(let ([conflict? exn:application:mismatch?] - [modes '(binary text)] - [replacement '(error replace truncate append truncate/replace update)]) - (for-each - (lambda (ones) - (for-each - (lambda (one) - (error-test `(open-output-file "x" ',one 'bad)) - (error-test `(open-output-file "x" ',one 8)) - (error-test `(open-output-file "x" 'bad ',one)) - (error-test `(open-output-file "x" 8 ',one)) - (error-test `(call-with-output-file "x" void ',one 'bad)) - (error-test `(call-with-output-file "x" void ',one 8)) - (error-test `(call-with-output-file "x" void 'bad ',one)) - (error-test `(call-with-output-file "x" void 8 ',one)) - (error-test `(with-output-to-file "x" void ',one 8)) - (error-test `(with-output-to-file "x" void ',one 'bad)) - (error-test `(with-output-to-file "x" void 8 ',one)) - (error-test `(with-output-to-file "x" void 'bad ',one)) - (for-each - (lambda (two) - (error-test `(open-output-file "x" ',one ',two) conflict?) - (error-test `(call-with-output-file "x" void ',one ',two) conflict?) - (error-test `(with-output-to-file "x" void ',one ',two) conflict?)) - ones)) - ones)) - `(,modes ,replacement))) -(error-test '(open-output-file (build-path (current-directory) "baddir" "x")) - exn:i/o:filesystem?) - -(when (file-exists? "tmp4") - (delete-file "tmp4")) -(close-output-port (open-output-file "tmp4")) -(error-test '(let ([c (make-custodian)]) - (let ([p (parameterize ([current-custodian c]) - (open-output-file "tmp4" 'replace))]) - (custodian-shutdown-all c) - (display 'hi p))) - exn:i/o:port:closed?) -(error-test '(open-output-file "tmp4" 'error) exn:i/o:filesystem?) -(define p (open-output-file "tmp4" 'replace)) -(display 7 p) -(display "" p) -(close-output-port p) -(close-output-port (open-output-file "tmp4" 'truncate)) -(define p (open-input-file "tmp4")) -(test eof read p) -(close-input-port p) -(define p (open-output-file "tmp4" 'replace)) -(display 7 p) -(close-output-port p) -(define p (open-output-file "tmp4" 'append)) -(display 7 p) -(close-output-port p) -(error-test '(display 9 p) exn:i/o:port:closed?) -(error-test '(write 9 p) exn:i/o:port:closed?) -(error-test '(write-char #\a p) exn:i/o:port:closed?) - -(error-test '(let ([c (make-custodian)]) - (let ([p (parameterize ([current-custodian c]) - (open-input-file "tmp4"))]) - (custodian-shutdown-all c) - (read p))) - exn:i/o:port:closed?) -(define p (open-input-file "tmp4")) -(test 77 read p) -(close-input-port p) -(error-test '(read p) exn:i/o:port:closed?) -(error-test '(read-char p) exn:i/o:port:closed?) -(error-test '(char-ready? p) exn:i/o:port:closed?) - -(define p (open-output-file "tmp4" 'update)) -(display 6 p) -(close-output-port p) -(test 2 file-size "tmp4") -(define p (open-input-file "tmp4")) -(test 67 read p) -(test eof read p) -(close-input-port p) - -(define p (open-output-file "tmp4" 'update)) -(file-position p 1) -(display 68 p) -(close-output-port p) -(test 3 file-size "tmp4") -(define p (open-input-file "tmp4")) -(test 0 file-position p) -(test 668 read p) -(test 3 file-position p) -(test eof read p) -(test 3 file-position p) -(file-position p 1) -(test 1 file-position p) -(test #\6 read-char p) -(test #\8 read-char p) -(file-position p 0) -(test 0 file-position p) -(test #\6 read-char p) -(test 1 file-position p) -(file-position p 2) -(test #\8 read-char p) -(test 3 file-position p) -(close-input-port p) - -(close-output-port (open-output-file "tmp4" 'truncate/replace)) -(define p (open-input-file "tmp4")) -(test eof read p) -(close-input-port p) - -(arity-test call-with-input-file 2 3) -(arity-test call-with-output-file 2 4) -(arity-test with-input-from-file 2 3) -(arity-test with-output-to-file 2 4) - -(error-test '(call-with-input-file "x" 8)) -(error-test '(call-with-input-file 8 (lambda (x) x))) -(error-test '(call-with-input-file 8 (lambda () 9))) -(error-test '(call-with-input-file "x" (lambda (x) x) 8)) -(error-test '(call-with-input-file "x" (lambda (x) x) 'bad)) - -(error-test '(call-with-output-file "x" 8)) -(error-test '(call-with-output-file 8 (lambda (x) x))) -(error-test '(call-with-output-file 8 (lambda () 9))) -(error-test '(call-with-output-file "x" (lambda (x) x) 8)) -(error-test '(call-with-output-file "x" (lambda (x) x) 'bad)) - -(error-test '(with-input-from-file "x" 8)) -(error-test '(with-input-from-file 8 (lambda () 9))) -(error-test '(with-input-from-file 8 (lambda (x) x))) -(error-test '(with-input-from-file "x" (lambda () 9) 8)) -(error-test '(with-input-from-file "x" (lambda () 9) 'bad)) - -(error-test '(with-output-to-file "x" 8)) -(error-test '(with-output-to-file 8 (lambda () 9))) -(error-test '(with-output-to-file 8 (lambda (x) x))) -(error-test '(with-output-to-file "x" (lambda () 9) 8)) -(error-test '(with-output-to-file "x" (lambda () 9) 'bad)) - -(define s (open-output-string)) -(test #f input-port? s) -(test #t output-port? s) -(let ([c (current-output-port)]) - (current-output-port s) - (display 8) - (current-output-port c)) -(test "8" get-output-string s) -(let ([c (current-error-port)]) - (current-error-port s) - (display 9 (current-error-port)) - (current-error-port c)) -(test "89" get-output-string s) -(define s (open-input-string (get-output-string s))) -(test #t input-port? s) -(test #f output-port? s) -(test 89 + 0 - (let ([c (current-input-port)]) - (current-input-port s) - (begin0 - (read) - (current-input-port c)))) -(test eof read s) - -(arity-test open-output-string 0 0) -(arity-test open-input-string 1 1) -(arity-test get-output-string 1 1) - -(error-test '(get-output-string 9)) -(error-test '(get-output-string (current-output-port))) - -(define-values (out in) (make-pipe)) -(test #t input-port? out) -(test #t output-port? in) -(let loop ([n 1000]) - (unless (zero? n) - (display n in) - (newline in) - (loop (sub1 n)))) -(let loop ([n 999]) - (unless (zero? n) - (read out) - (loop (sub1 n)))) -(test 1 read out) -(close-output-port in) -(test eof read out) -(close-input-port out) -(arity-test make-pipe 0 0) - -(test #t input-port? (make-input-port void void void)) -(error-test '(read (make-input-port void void void)) - exn:i/o:port:user?) -(arity-test make-input-port 3 4) -(error-test '(make-input-port 8 void void)) -(error-test '(make-input-port void 8 void)) -(error-test '(make-input-port void void 8)) -(error-test '(make-input-port add1 void void)) -(error-test '(make-input-port void add1 void)) -(error-test '(make-input-port void void add1)) - -(test #t output-port? (make-output-port void void)) -(arity-test make-output-port 2 2) -(error-test '(make-output-port 8 void)) -(error-test '(make-output-port void 8)) -(error-test '(make-output-port (lambda () 9) void)) -(error-test '(make-output-port void add1)) - -(let ([p (make-input-port - (lambda () #\a) - (lambda () #t) - void - (lambda () #\b))]) - (test #\a read-char p) - (test #\b peek-char p) - (test #\a read-char p) - (test #\b peek-char p) - (test #\b peek-char p) - (test #\a read-char p) - (test 3 file-position p)) - -(let* ([s (open-input-string "(apple \"banana\" [coconut])")] - [p (make-input-port - (lambda () (read-char s)) - (lambda () #t) - void - (lambda () (peek-char s)))]) - (test '(apple "banana" [coconut]) read p)) - -(define test-file - (open-output-file "tmp2" 'truncate)) -(write-char #\; test-file) -(display write-test-obj test-file) -(newline test-file) -(write load-test-obj test-file) -(test #t output-port? test-file) -(close-output-port test-file) -(check-test-file "tmp2") - -(define ui (make-input-port (lambda () #\") (lambda () #t) void)) -(test "" read ui) -(arity-test (port-read-handler ui) 1 1) -(error-test '((port-read-handler ui) 8)) -(let ([old (port-read-handler ui)]) - (port-read-handler ui (lambda (x) "hello")) - (test "hello" read ui) - (port-read-handler ui old) - (test "" read ui)) -(arity-test port-read-handler 1 2) -(error-test '(port-read-handler 1)) -(error-test '(port-read-handler ui 8)) -(error-test '(port-read-handler (current-output-port) 8)) -(error-test '(port-read-handler ui (lambda () 9))) -(error-test '(port-read-handler ui (lambda (x y) 9))) - -(define sp (open-output-string)) -(test (void) display "hello" sp) -(test "hello" get-output-string sp) -(test (void) write "hello" sp) -(test "hello\"hello\"" get-output-string sp) -(arity-test (port-display-handler sp) 2 2) -(arity-test (port-write-handler sp) 2 2) -(arity-test (port-print-handler sp) 2 2) -(error-test '((port-display-handler sp) 8 8)) -(error-test '((port-write-handler sp) 8 8)) -(error-test '((port-print-handler sp) 8 8)) -(let ([oldd (port-display-handler sp)] - [oldw (port-write-handler sp)] - [oldp (port-print-handler sp)] - [adding (let ([s "hello\"hello\""]) - (lambda (a) - (set! s (string-append s a)) - s))]) - (port-display-handler sp (lambda (v p) (oldd "X" p) (values 1 2))) - (test (void) display "hello" sp) - (test (adding "X") get-output-string sp) - (test (void) write "hello" sp) - (test (adding "\"hello\"") get-output-string sp) - (test (void) print "hello" sp) - (test (adding "\"hello\"") get-output-string sp) - - (port-write-handler sp (lambda (v p) (oldd "Y" p) 5)) - (test (void) display "hello" sp) - (test (adding "X") get-output-string sp) - (test (void) write "hello" sp) - (test (adding "Y") get-output-string sp) - (test (void) print "hello" sp) - (test (adding "\"hello\"") get-output-string sp) - (parameterize ([global-port-print-handler display]) - (test (void) print "hello" sp) - (test (adding "X") get-output-string sp)) - (parameterize ([global-port-print-handler oldd]) - (test (void) print "hello" sp) - (test (adding "hello") get-output-string sp)) - (test (void) print "hello" sp) - (test (adding "\"hello\"") get-output-string sp) - - - (port-print-handler sp (lambda (v p) (oldd "Z" p) 5)) - (test (void) display "hello" sp) - (test (adding "X") get-output-string sp) - (test (void) write "hello" sp) - (test (adding "Y") get-output-string sp) - (test (void) print "hello" sp) - (test (adding "Z") get-output-string sp) - (parameterize ([global-port-print-handler display]) - (test (void) print "hello" sp) - (test (adding "Z") get-output-string sp)) - (test (void) print "hello" sp) - (test (adding "Z") get-output-string sp) - - (port-display-handler sp oldd) - (test (void) display "hello" sp) - (test (adding "hello") get-output-string sp) - (test (void) write "hello" sp) - (test (adding "Y") get-output-string sp) - - (port-write-handler sp oldw) - (test (void) display "hello" sp) - (test (adding "hello") get-output-string sp) - (test (void) write "hello" sp) - (test (adding "\"hello\"") get-output-string sp) - - (port-display-handler sp oldw) - (port-write-handler sp oldd) - (port-print-handler sp oldp) - (test (void) display "hello" sp) - (test (adding "\"hello\"") get-output-string sp) - (test (void) write "hello" sp) - (test (adding "hello") get-output-string sp) - (test (void) print "goodbye" sp) - (test (adding "\"goodbye\"") get-output-string sp) - (port-display-handler sp oldd) - (port-write-handler sp oldw)) -(error-test '(port-display-handler 1)) -(error-test '(port-display-handler sp 8)) -(error-test '(port-display-handler (current-input-port) 8)) -(error-test '(port-display-handler sp (lambda (x) 9))) -(error-test '(port-display-handler sp (lambda (x y z) 9))) -(error-test '(port-write-handler 1)) -(error-test '(port-write-handler sp 8)) -(error-test '(port-write-handler (current-input-port) 8)) -(error-test '(port-write-handler sp (lambda (x) 9))) -(error-test '(port-write-handler sp (lambda (x y z) 9))) - -(SECTION 6 10 4) -(load "tmp1") -(test write-test-obj 'load foo) - -(SECTION 'INEXACT-I/IO) -(define wto write-test-obj) -(define dto display-test-obj) -(define lto load-test-obj) -(define f-3.25 (string->number "-3.25")) -(define f.25 (string->number ".25")) -(set! write-test-obj (list f.25 f-3.25));.25 inexact errors less likely. -(set! display-test-obj (list f.25 f-3.25));.3 often has such errors (~10^-13) -(set! load-test-obj (list 'define 'foo (list 'quote write-test-obj))) -(let ([f (lambda (test-file) - (write-char #\; test-file) - (display write-test-obj test-file) - (newline test-file) - (write load-test-obj test-file) - (output-port? test-file))]) - (test #t call-with-output-file - "tmp3" f 'truncate)) -(check-test-file "tmp3") -(set! write-test-obj wto) -(set! display-test-obj dto) -(set! load-test-obj lto) - -(define badc-range-start 0) -(define badc-range-end 255) - -(SECTION 'PRINTF) -(define (test-format format format-name) - (test "~" format "~~") - (test "hello---~---there" format "~a---~~---~a" "hello" 'there) - (test "\"hello\"---~---there" format "~s---~~---~s" "hello" 'there) - (test "\"hello\"---~---there" format "~v---~~---~v" "hello" 'there) - (test (string #\a #\newline #\b #\newline #\c) format "a~nb~%c") - (let ([try-newline-stuff - (lambda (newlines) - (test "12" format (apply string `(#\1 #\~ #\space ,@newlines #\space #\2))) - (test "12" format (apply string `(#\1 #\~ ,@newlines #\space #\2))) - (test "12" format (apply string `(#\1 #\~ ,@newlines #\2))) - (test (apply string `(#\1 ,@newlines #\2)) - format (apply string `(#\1 #\~ ,@newlines #\space ,@newlines #\2))))]) - (for-each try-newline-stuff '((#\return) (#\newline) (#\return #\newline)))) - (test "twenty=20..." format "twenty=~s..." 20) - (test "twenty=20..." format "twenty=~v..." 20) - (test "twenty=20..." format "twenty=~e..." 20) - (test "twenty=14..." format "twenty=~x..." 20) - (test "twenty=24..." format "twenty=~o..." 20) - (test "twenty=10100..." format "twenty=~b..." 20) - (test "zee=z..." format "zee=~c..." #\z) - - (test #\. - (lambda (s) (string-ref s (sub1 (string-length s)))) - (parameterize ([error-print-width 40]) - (format "~e" (make-string 200 #\v)))) - - (let() - (define bads - (let loop ([i badc-range-end]) - (cond - [(eq? i badc-range-start) (list (integer->char i))] - [else (let ([c (integer->char i)] - [rest (loop (sub1 i))]) - (case c - [(#\~ #\% #\n #\a #\s #\c #\o #\x #\b #\v #\e - #\N #\A #\S #\C #\O #\X #\B #\V #\E) - rest] - [else (if (char-whitespace? c) - rest - (cons c rest))]))]))) - - (define with-censor (load-relative "censor.ss")) - - ; test for all bad tags; the string we generate shouldn't - ; be printed to a terminal directly because it can contain contain - ; control characters; censor it - (unless (defined? 'building-flat-tests) - (with-censor - (lambda () - (for-each (lambda (c) - (error-test `(,@format-name ,(format "a~~~cb" c) 0))) - bads))))) - - (error-test `(,@format-name 9)) - (error-test `(,@format-name "apple~")) - (error-test `(,@format-name "~")) - (error-test `(,@format-name "~~~")) - (error-test `(,@format-name "~o") exn:application:mismatch?) - (error-test `(,@format-name "~o" 1 2) exn:application:mismatch?) - (error-test `(,@format-name "~c" 1) exn:application:mismatch?) - (error-test `(,@format-name "~x" 'a) exn:application:mismatch?) - (error-test `(,@format-name "~x" 4.0) exn:application:mismatch?) - (error-test `(,@format-name "~x" 5+4.0i) exn:application:mismatch?)) - -(test-format format '(format)) -(test-format - (lambda args - (let ([p (open-output-string)]) - (apply fprintf p args) - (get-output-string p))) - '(fprintf (current-output-port))) -(test-format - (lambda args - (let ([p (open-output-string)]) - (parameterize ([current-output-port p]) - (apply printf args)) - (get-output-string p))) - '(printf)) - -(arity-test format 1 -1) -(arity-test printf 1 -1) -(arity-test fprintf 2 -1) - -(define success-1? (putenv "APPLE" "AnApple")) -(define success-2? (putenv "BANANA" "AnotherApple")) -(error-test `(getenv 7)) -(error-test `(getenv (string #\a #\nul #\b))) -(error-test `(putenv 7 "hi")) -(error-test `(putenv "hi" 7)) -(error-test `(putenv (string #\a #\nul #\b) "hi")) -(error-test `(putenv "hi" (string #\a #\nul #\b))) -(collect-garbage) -(unless (eq? (system-type) 'macos) - (test #t 'success-1 success-1?) - (test #t 'success-2 success-2?) - (test "AnApple" getenv "APPLE") - (test "AnotherApple" getenv "BANANA")) -(test #f getenv "AnUndefinedEnvironmentVariable") - -(arity-test getenv 1 1) -(arity-test putenv 2 2) - -(arity-test read-eval-print-loop 0 0) -(test (void) 'r-e-p-l-return - (parameterize ([current-input-port (make-input-port - (lambda () eof) - void - void)]) - (read-eval-print-loop))) - -(report-errs) diff --git a/collects/tests/mzscheme/function.ss b/collects/tests/mzscheme/function.ss deleted file mode 100644 index ca366b27..00000000 --- a/collects/tests/mzscheme/function.ss +++ /dev/null @@ -1,69 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'function) - -(require-library "function.ss") - -(test (list 1 2 3 4) foldl cons '() (list 4 3 2 1)) -(test (list 1 2 3 4) foldr cons '() (list 1 2 3 4)) -(test - (list (list 5 6) (list 3 4) (list 1 2)) - foldl (lambda (x y sofar) (cons (list x y) sofar)) - '() - (list 1 3 5) - (list 2 4 6)) -(test - (list (list 1 2) (list 3 4) (list 5 6)) - foldr (lambda (x y sofar) (cons (list x y) sofar)) - '() - (list 1 3 5) - (list 2 4 6)) - -(arity-test foldl 3 -1) -(arity-test foldr 3 -1) - -(test 0 (compose add1 sub1) 0) -(test 2 (compose add1 (lambda () 1))) -(test 5 (compose (lambda (a b) a) (lambda (x) (values (add1 x) x))) 4) -(test -1 (compose (lambda (a b) (+ a b)) (lambda (x y) (values (- y) x))) 2 3) -(test 'hi (compose (case-lambda [(x) 'bye][(y z) 'hi]) (lambda () (values 1 2)))) -(test 'ok (compose (lambda () 'ok) (lambda () (values)))) -(test 'ok (compose (lambda () 'ok) (lambda (w) (values))) 5) -(test-values '(1 2 3) (lambda () ((compose (lambda (x) (values x (add1 x) (+ x 2))) (lambda (y) y)) 1))) - -(error-test '(compose 5)) -(error-test '(compose add1 sub1 5)) -(error-test '(compose add1 5 sub1)) -(error-test '(compose 5 add1 sub1)) -(error-test '((compose add1 (lambda () (values 1 2)))) exn:application:arity?) -(error-test '((compose add1 sub1)) exn:application:arity?) -(error-test '((compose (lambda () 1) add1) 8) exn:application:arity?) - -(arity-test compose 1 -1) - -(test '(1 2 3) filter number? '(1 a 2 b 3 c d)) -(test '() filter string? '(1 a 2 b 3 c d)) -(error-test '(filter string? '(1 2 3 . 4)) exn:application:mismatch?) -(error-test '(filter 2 '(1 2 3))) -(error-test '(filter cons '(1 2 3))) -(arity-test filter 2 2) - -(test 0 assf add1 '(0 1 2)) -(test 0 assf number? '(a 0 1 2 c)) -(test "ok" assf string? '(a 0 1 "ok" 2 c)) -(error-test '(assf cons '(1 2 3))) -(error-test '(assf string? '(1 2 3 . 4)) exn:application:mismatch?) - -(test '("a" "b" "c" "c" "d" "e" "f") - quicksort - '("d" "f" "e" "c" "a" "c" "b") - string. - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(define bad#%? - (if (defined? 'read/zodiac) - exn? - syntaxe?)) - -; Masking names shouldn't hurt the #% versions.. - -(define car 3) -(test 3 #%car (cons 3 2)) -(define car #%car) - -(let ((lambda 2)) - (test #t equal? 2 ((#%lambda (x) x) lambda))) - -; You can't mask the #% versions. - -(error-test '(define #%lambda 2) bad#%?) -(error-test '(set! #%lambda 2) bad#%?) - -; We allow random #% things to be set!'ed and define'd. - -(test #t equal? (void) (eval '(define #%foo 3))) -(test #t equal? 4 (begin (set! #%foo 4) #%foo)) - -; But you can't bind #% things either. - -(error-test '(let ((#%car 3)) 3) syntaxe?) -(error-test '(let ((#%lambda 3)) 3) syntaxe?) - -; Let's try out all #% syntax to make sure it's immune. (We'll skip -; the macro stuff.) - -(map (lambda (s) - (error-test `(define ,s 3) bad#%?) - (error-test `(set! ,s 3) bad#%?)) - '(#%lambda #%let-values #%letrec-values #%define-values #%quote - #%if #%begin #%set! #%begin0 #%case-lambda #%struct)) - -; And a few primitives, for good measure. - -(map (lambda (s) - (error-test `(define ,s 3) bad#%?) - (error-test `(set! ,s 3) bad#%?)) - '(#%car #%cdr #%cons)) - -(newline) -(newline) - -; (printf "Done with #% test suite!~n~n") - -(report-errs) diff --git a/collects/tests/mzscheme/image.ss b/collects/tests/mzscheme/image.ss deleted file mode 100644 index 41219f06..00000000 --- a/collects/tests/mzscheme/image.ss +++ /dev/null @@ -1,32 +0,0 @@ - -; Tests image saving/loading by dumping an image -; and loading it with every report-errs - -(define dump/restore - (lambda () - (printf "Dumping image...~n") - (let ([result (write-image-to-file "tmp9")]) - (if (vector? result) - (printf "Continuing ~a~n" result) - (read-image-from-file "tmp9" #("after" "restore")))))) - -(define ll null) -(define load-relative - (lambda (f) - (set! ll (append ll (list f))))) - -(#%load-relative "all.ss") - -(define load-relative #%load-relative) - -(define go - (let ([d (current-load-relative-directory)]) - (lambda () - (parameterize ([current-load-relative-directory d]) - (for-each - (lambda (f) - (load-relative f) - (dump/restore)) - ll))))) - -(printf "Run `(go)'~n") diff --git a/collects/tests/mzscheme/ktest.ss b/collects/tests/mzscheme/ktest.ss deleted file mode 100644 index 86d2d0dd..00000000 --- a/collects/tests/mzscheme/ktest.ss +++ /dev/null @@ -1,11 +0,0 @@ -(define k - (call-with-current-continuation - (lambda (exit) - (let loop ((n 60000)) - (if (zero? n) - (let ((v (call-with-current-continuation (lambda (k) k)))) - (if (number? v) - v - (exit v))) - (- (loop (- n 1)) 1)))))) - diff --git a/collects/tests/mzscheme/loadable.ss b/collects/tests/mzscheme/loadable.ss deleted file mode 100644 index eb943a3f..00000000 --- a/collects/tests/mzscheme/loadable.ss +++ /dev/null @@ -1 +0,0 @@ -"This is a simple file used by param.ss" diff --git a/collects/tests/mzscheme/loop.ss b/collects/tests/mzscheme/loop.ss deleted file mode 100644 index 18fde593..00000000 --- a/collects/tests/mzscheme/loop.ss +++ /dev/null @@ -1,29 +0,0 @@ - - -(define five +) - -(define (one v) - (if (equal? v 15) - (apply five (list 1 2 3 4 5)) - 15)) - -(define (dloop x d) - (if (zero? d) - 0 - (if (equal? x 15) - (let ([v (one 10)]) - (let ([c (one v)]) - (add1 (dloop c (sub1 d))))) - (dloop 15 d)))) - -(define (loop) - (let loop ([n 0]) - (let ([v (dloop 0 n)]) - (if (equal? n v) - (begin - (when (zero? (modulo n 100)) - (printf "~a~n" n)) - (loop (add1 n))) - (error 'loop "messed up: ~a != ~a~n" n v))))) - - diff --git a/collects/tests/mzscheme/ltest.ss b/collects/tests/mzscheme/ltest.ss deleted file mode 100644 index 5765a97c..00000000 --- a/collects/tests/mzscheme/ltest.ss +++ /dev/null @@ -1,88 +0,0 @@ -(printf "nested loop~n") -(time - (let loop ([n 10000]) - (unless (zero? n) - (let loop2 ([m 10]) - (if (zero? m) - (loop (sub1 n)) - (loop2 (sub1 m))))))) - -(printf "single loop~n") -(time - (let loop ([n 100000]) - (unless (zero? n) - (loop (sub1 n))))) - -(printf "Y loop~n") -(time - ((lambda (f n) (f f n)) - (lambda (loop n) - (unless (zero? n) - (loop loop (sub1 n)))) - 100000)) - - -(printf "let closure recur~n") -(time - (let ([f (lambda (x) (sub1 x))]) - (let loop ([n 100000]) - (unless (zero? n) - (loop (f n)))))) - -(printf "direct closure recur~n") -(time - (let loop ([n 100000]) - (unless (zero? n) - (loop ((lambda (x) (sub1 x)) n))))) - -(printf "direct closure recur if~n") -(time - (let loop ([n 100000]) - (if (zero? n) - (void) - (loop ((lambda (x) (sub1 x)) n))))) - -(printf "let closure top-level~n") -(define loop - (let ([f (lambda (x) (sub1 x))]) - (lambda (n) - (unless (zero? n) - (loop (f n)))))) -(time (loop 100000)) - -(printf "direct closure top-level~n") -(define loop - (lambda (n) - (unless (zero? n) - (loop ((lambda (x) (sub1 x)) n))))) -(time (loop 100000)) - - -; > (load "ltest.ss") -; cpu time: 1820 real time: 1826 -; cpu time: 1420 real time: 1422 -; cpu time: 1960 real time: 1957 -; cpu time: 2630 real time: 2626 -; > (load "ltest.ss") -; cpu time: 1790 real time: 1803 -; cpu time: 1430 real time: 1468 -; cpu time: 2150 real time: 2159 -; cpu time: 2820 real time: 2824 - -; > (load "ltest.ss") -; nested loop -; cpu time: 1750 real time: 1817 -; single loop -; cpu time: 1430 real time: 1425 -; Y loop -; cpu time: 1500 real time: 1500 -; let closure recur -; cpu time: 1830 real time: 1835 -; direct closure recur -; cpu time: 1790 real time: 1791 -; direct closure recur if -; cpu time: 1800 real time: 1793 -; let closure top-level -; cpu time: 1810 real time: 1804 -; direct closure top-level -; cpu time: 1760 real time: 1758 diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss deleted file mode 100644 index 3b752fff..00000000 --- a/collects/tests/mzscheme/macro.ss +++ /dev/null @@ -1,35 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - - -(SECTION 'MACRO) - -(define-macro mx - (lambda (x) - (list x 1 8))) -(test 9 'macro (mx +)) -(test -7 'macro (mx -)) -(test 18 'macro (let ([mx (lambda (x) (x 1 8 9))]) (mx +))) -(when (defined? 'let-macro) - (teval '(test 13 'let-macro (let-macro mx (lambda (x) (list x 6 7)) (mx +)))) - (teval '(test -7 'let-macro (let-macro mx2 (lambda (x y) (list 'mx y)) (mx2 + -)))) - (teval '(test '(10) 'let-macro ((lambda () (let-macro x (lambda x (cons 'list x)) (x 10)))))) - (teval '(test '(10) 'let-macro (let () (define-macro x (lambda x (cons 'list x))) (x 10)))) - ; (test '(10) eval '((lambda () (define-macro x (lambda x (cons 'list x))) (x 10)))) - ) - -(define a-global-var 1) -(define-macro a-macro (lambda () a-global-var)) -(test 1 'macro (a-macro)) - -(when (defined? 'let-macro) - (teval '(define (defmacro-test) - (define-macro define-alias (lambda (x y) `(define ,x ,y))) - (test 45 'define - (let ((x 5)) - (define-alias foo (lambda (y) (bar x y))) - (define-alias bar (lambda (a b) (+ (* a b) a))) - (foo (+ x 3))))))) - -(report-errs) diff --git a/collects/tests/mzscheme/macrolib.ss b/collects/tests/mzscheme/macrolib.ss deleted file mode 100644 index 1a7803b3..00000000 --- a/collects/tests/mzscheme/macrolib.ss +++ /dev/null @@ -1,195 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load "testing.ss")) - -(SECTION 'macrolib) - -(require-library "macro.ss") - -(let ([u (letrec ([x x]) x)]) - (let ([l1 - (let+ ([rec a a] - [recs [b c] [c b]] - [rec d 1] - [val e 1] - [val x 1] - [val y 2] - [vals (x y) (y x)] - [rec (values f) (values 1)] - [vals [(values g h) (values 2 3)]] - [val i 3] - [_ (set! i 4) - (set! i 5)]) - 'x - (list a b c d e x y f g h i))] - [l2 (list u u u 1 1 2 1 1 2 3 5)]) - (test l1 'let-plus l2))) - -(require-library "shared.ss") - -(test "((car . cdr) #(one two three four five six) #&box (list1 list2 list3 list4) # 3 3)" - 'shared - (let ([s (open-output-string)]) - (display - (shared ((a (cons 'car 'cdr)) - (b (vector 'one 'two 'three 'four 'five 'six)) - (c (box 'box)) - (d (list 'list1 'list2 'list3 'list4)) - (e (make-weak-box 'weak-box)) - (f (+ 1 2)) - (g 3)) - (list a b c d e f g)) - s) - (get-output-string s))) - -(test 'hi 'local (local () 'hi)) -(define x 7) -(test 6 'local (local ((define x 6)) x)) -(test 7 'local x) -(test 6 vector-ref (struct->vector (local ((define x 6) (define-struct a (b))) (make-a x))) 1) -(test #t 'local (local [(define o (lambda (x) (if (zero? x) #f (e (sub1 x))))) - (define e (lambda (x) (if (zero? x) #t (o (sub1 x)))))] - (e 10))) -(test 'second 'local (local ((define x 10) (define u 'second)) (cons x 1) u)) -(test-values '(4 6) (lambda () (local ((define y 6) (define x 4)) (values x y)))) -(test 10 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) (y)))) -(test 5 'local (let ([x 10]) (local ((define y (lambda () x))) (define x 5) x))) -(test 8 'local (let ([lambda 9]) (local [(define lambda 8)] lambda))) -(test 9 'local (let ([lambda 10]) (local [(define lambda 9) (define lambda2 lambda)] lambda2))) -(test 19 'local (local [(define lambda 19) (define lambda2 lambda)] lambda2)) -(test 1 'local (local ((define-values (a b c) (values 1 2 3))) a)) -(test 1 (lambda () (local ((define-values (a b c) (values 1 2 3))) a))) -(test 8 'local (local [(define lambda 8)] lambda)) -(test 12 'local (local [(define (f y) (add1 y))] (f 11))) -(test 120 'local (local [(define (f y) 'ignore-me (add1 y))] (f 119))) -(test 17 'local (local [(define-values (apple b) (values 12 17))] b)) -(test 4 'local (local [(define-struct cons (car cdr))] (cons-car (make-cons 4 5)))) -(test 40 'local (local [(define-struct (cons struct:exn) (car cdr))] (cons-car (make-cons "" (void) 40 50)))) -(syntax-test '(local)) -(syntax-test '(local . 1)) -(syntax-test '(local ())) -(syntax-test '(local () . 1)) -(syntax-test '(local 1 1)) -(syntax-test '(local (1) 1)) -(syntax-test '(local (x) 1)) -(syntax-test '(local ((+ 1 2)) 1)) -(syntax-test '(local ((define x)) 1)) -(syntax-test '(local ((define x 4) (+ 1 2)) 1)) -(syntax-test '(local ((define x 4) (+ 1 2) (define y 10)) 1)) -(syntax-test '(local ((define (x 8) 4)) 1)) -(syntax-test '(local ((define (x . 8) 4)) 1)) -(syntax-test '(local ((define x 8 4)) 1)) -(syntax-test '(local ((define 1 8 4)) 1)) -(syntax-test '(let ([define 10]) (local ((define x 4)) 10))) -(syntax-test '(let ([define-values 10]) (local ((define-values (x) 4)) 10))) -(syntax-test '(let ([define-struct 10]) (local ((define-struct x ())) 10))) - -(for-each syntax-test - (list '(evcase) - '(evcase 1 (a)) - '(evcase 1 (a b) a) - '(evcase 1 (a . b) a) - '(evcase 1 [else 5] [1 10]))) -(define => 17) -(test (void) 'void-evcase (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1))) -(define save-comp (compile-allow-cond-fallthrough)) -(compile-allow-cond-fallthrough #f) -(test #t andmap (lambda (x) (= x 17)) - (list - (evcase 3 [3 17]) - (evcase 3 [(+ 1 2) 17] [3 1]) - (evcase 3 [3 4 5 17]) - (evcase 3 [4 1] [3 4 5 17]) - (evcase 3 [4 1 2 3 4] [3 4 5 17]) - (evcase 3 [4 4] [2 10] [else 17]) - (let ([else 10]) (evcase 3 [4 4] [2 10] [else 15] [3 17])) - (let ([else 3]) (evcase 3 [else 17] [2 14])) - (with-handlers ([(lambda (x) #t) (lambda (x) 17)]) (evcase 1)) - (evcase 3 [3 =>]) - (evcase 3 [3 => 17]) - (let ([=> 12]) (evcase 3 [3 => 17])) - (let ([=> 17]) (evcase 3 [3 =>])))) -(compile-allow-cond-fallthrough save-comp) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(require-library "invoke.ss") - -(define make-z - (lambda (x-val) - (unit - (import z) - (export (x z) y) - - (define x x-val) - (define y (lambda () (- z x)))))) - -(define z1 (make-z 8)) -(define z2 (make-z 7)) - -(define m3 - (compound-unit - (import) - (link [Z1 (z1 (Z2 z))][Z2 (z2 (Z1 z))]) - (export [Z1 (y y1) (z x1)][Z2 (y y2) (z x2)]))) - -(define-values/invoke-unit (y1 x1 y2 x2) m3) -(test '(-1 1 8 7) 'invoke-open-unit (list (y1) (y2) x1 x2)) - -; Linking environments - -(when (defined? 'x) - (undefine 'x)) - -(define (make--eval) - (let ([n (make-namespace)]) - (lambda (e) - (let ([orig (current-namespace)]) - (dynamic-wind - (lambda () (current-namespace n)) - (lambda () - (require-library "invoke.ss") - (eval e)) - (lambda () (current-namespace orig))))))) - -(define u - (unit - (import) - (export x) - (define x 5))) -(define e (make--eval)) -(e (list 'define-values/invoke-unit '(x) u #f)) -(test #f defined? 'x) -(test #t e '(defined? 'x)) - -(define u2 - (let ([u u]) - (unit - (import) - (export) - (global-define-values/invoke-unit (x) u #f)))) -(define e (make--eval)) -(e (list 'define-values/invoke-unit '() u2 #f)) -(test #f defined? 'x) -(test #t e '(defined? 'x)) - - -; Export var from embedded unit: - -(define-signature e ((unit w : (embedded-v)))) -(define-values/invoke-unit/sig (embedded-v) - (compound-unit/sig - (import) - (link [E : e ((compound-unit/sig - (import) - (link [w : (embedded-v) ((unit/sig (embedded-v) - (import) - (define embedded-v 0)))]) - (export (unit w))))]) - (export (var ((E w) embedded-v))))) -(test 0 'embedded-v embedded-v) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(report-errs) - diff --git a/collects/tests/mzscheme/makeflat.ss b/collects/tests/mzscheme/makeflat.ss deleted file mode 100644 index 73ca6755..00000000 --- a/collects/tests/mzscheme/makeflat.ss +++ /dev/null @@ -1,60 +0,0 @@ - -(unless (defined? 'flat-load) - (global-defined-value 'flat-load "all.ss")) -(unless (defined? 'lines-per-file) - (global-defined-value 'lines-per-file +inf.0)) - -(require-library "pretty.ss") - - -(define line-count 0) -(define file-count 0) - -(define flatp (open-output-file "flat.ss" 'replace)) -(define old-eval (current-eval)) -(define old-namespace (current-namespace)) - -(pretty-print '(define error-test void) flatp) -(pretty-print '(define building-flat-tests #t) flatp) -(pretty-print '(define section #f) flatp) - -(define (flat-pp v) - (pretty-print v flatp) - (set! line-count (add1 line-count)) - (when (>= line-count lines-per-file) - (set! line-count 0) - (set! file-count (add1 file-count)) - (close-output-port flatp) - (set! flatp - (open-output-file - (format "flat~a.ss" file-count) - 'replace)))) - -(define error-test - (case-lambda - [(expr) (error-test expr #f)] - [(expr exn?) - (unless (eq? exn? exn:syntax?) - (flat-pp `(thunk-error-test (lambda () ,expr) - (quote ,expr) - ,@(if exn? - (list (string->symbol - (primitive-name - exn?))) - null))))])) - -(define building-flat-tests #t) - -(dynamic-wind - (lambda () - (current-eval - (lambda (e) - (unless (or (and (pair? e) - (memq (car e) '(load load-relative error-test))) - (not (eq? (current-namespace) old-namespace))) - (flat-pp e)) - (old-eval e)))) - (lambda () - (load-relative flat-load)) - (lambda () - (current-eval old-eval))) diff --git a/collects/tests/mzscheme/multi-expand.ss b/collects/tests/mzscheme/multi-expand.ss deleted file mode 100644 index 07393b16..00000000 --- a/collects/tests/mzscheme/multi-expand.ss +++ /dev/null @@ -1,82 +0,0 @@ -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(define counter 0) -(define-macro counterM (lambda () (set! counter (add1 counter)) 88)) - -(let* ([test-counter - (lambda (sexp) - (set! counter 0) - (eval sexp) - counter)]) - (test 1 test-counter '(begin0 1 (begin (counterM)))) - (test 1 test-counter '(begin0 (begin (counterM)))) - (test 1 test-counter '(lambda () - (counterM) - 1)) - (test 2 test-counter '(lambda () - (counterM) - (counterM) - 1)) - (test 2 test-counter '(lambda () - (define x (counterM)) - (define y (counterM)) - 1)) - (test 2 test-counter '(lambda () - (lambda () (counterM)) - (lambda () (counterM)) - 1)) - (test 1 test-counter '(lambda () - (begin (counterM)) - 1)) - (test 2 test-counter '(lambda () - (begin (counterM)) - (begin (counterM)) - 1)) - (test 3 test-counter '(lambda () - (begin (counterM)) - (begin (counterM)) - (begin (counterM)) - 1)) - (test 1 test-counter '(cond [1 (begin (counterM))])) - (test 1 test-counter '(begin (cond [1 (counterM)]))) - (test 1 test-counter '(begin0 (cond [1 (counterM)]) 1)) - (test 1 test-counter '(let () (begin (counterM)))) - (test 1 test-counter '(begin (let () (counterM)))) - (test 1 test-counter '(begin0 (let () (counterM)) 1)) - - (test 1 test-counter '(unit (import) (export) (counterM))) - (test 2 test-counter '(unit (import) (export) (counterM) (counterM))) - (test 1 test-counter '(unit (import) (export) (begin (counterM)))) - (test 2 test-counter '(unit (import) (export) (begin (counterM)) (begin (counterM)))) - (test 1 test-counter '(unit (import) (export) (begin0 (counterM)))) - (test 2 test-counter '(unit (import) (export) (begin0 (counterM)) (begin (counterM)))) - (test 1 test-counter '(unit (import) (export) (unit (import) (export) (counterM)))) - - - (test 1 test-counter '(begin (unit (import) (export) (counterM)))) - (test 2 test-counter '(begin (unit (import) (export) (counterM) (counterM)))) - (test 1 test-counter '(begin (unit (import) (export) (begin (counterM))))) - (test 2 test-counter '(begin (unit (import) (export) (begin (counterM)) (begin (counterM))))) - (test 1 test-counter '(begin (unit (import) (export) (begin0 (counterM))))) - (test 2 test-counter '(begin (unit (import) (export) (begin0 (counterM)) (begin (counterM))))) - (test 1 test-counter '(begin (unit (import) (export) (unit (import) (export) (counterM))))) - - (test 1 test-counter '(begin0 (unit (import) (export) (counterM)))) - (test 2 test-counter '(begin0 (unit (import) (export) (counterM) (counterM)))) - (test 1 test-counter '(begin0 (unit (import) (export) (begin (counterM))))) - (test 2 test-counter '(begin0 (unit (import) (export) (begin (counterM)) (begin (counterM))))) - (test 1 test-counter '(begin0 (unit (import) (export) (begin0 (counterM))))) - (test 2 test-counter '(begin0 (unit (import) (export) (begin0 (counterM)) (begin (counterM))))) - (test 1 test-counter '(begin0 (unit (import) (export) (unit (import) (export) (counterM))))) - - (test 1 test-counter '(begin0 1 (unit (import) (export) (counterM)))) - (test 2 test-counter '(begin0 1 (unit (import) (export) (counterM) (counterM)))) - (test 1 test-counter '(begin0 1 (unit (import) (export) (begin (counterM))))) - (test 2 test-counter '(begin0 1 (unit (import) (export) (begin (counterM)) (begin (counterM))))) - (test 1 test-counter '(begin0 1 (unit (import) (export) (begin0 (counterM))))) - (test 2 test-counter '(begin0 1 (unit (import) (export) (begin0 (counterM)) (begin (counterM))))) - (test 1 test-counter '(begin0 1 (unit (import) (export) (unit (import) (export) (counterM))))) -) - -(report-errs) diff --git a/collects/tests/mzscheme/mzlib.ss b/collects/tests/mzscheme/mzlib.ss deleted file mode 100644 index 184b8503..00000000 --- a/collects/tests/mzscheme/mzlib.ss +++ /dev/null @@ -1,32 +0,0 @@ - -; Test MzLib -; See also pptest.ss and ztest.ss - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(load-relative "function.ss") - -(load-relative "date.ss") - -(load-relative "cmdline.ss") - -(load-relative "pconvert.ss") - -(load-relative "pretty.ss") - -(load-relative "classd.ss") - -; Last - so macros are not present by accident -(load-relative "macrolib.ss") - -(require-library "core.ss") -(test #t 'invoke-core-in-#%-space - (begin - (let ([l (require-library "corer.ss")]) - (parameterize ([current-namespace (make-namespace 'hash-percent-syntax)]) - (invoke-unit/sig l))) - #t)) - - -(report-errs) diff --git a/collects/tests/mzscheme/mzthr.ss b/collects/tests/mzscheme/mzthr.ss deleted file mode 100644 index 18b4f51e..00000000 --- a/collects/tests/mzscheme/mzthr.ss +++ /dev/null @@ -1,75 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'mzlib-threads) - -(require-library "thread.ss") - -(define sema (make-semaphore)) -(define sema2 (make-semaphore)) -(define c-out 0) -(define SLEEP-TIME 0.1) - -;;; consumer-thread ;;; - -(define-values (th g) (consumer-thread (case-lambda - [(f arg) (set! c-out (f arg)) - (semaphore-post sema)] - [(f arg1 arg2) (set! c-out (f arg1 arg2)) - (semaphore-post sema)]))) -(g + 1 2) -(semaphore-wait sema) -(test 3 'consumer-thread c-out) - -; queue 2 -(g car '(4 5)) -(g semaphore-wait sema2) -(semaphore-wait sema) -(test 4 'consumer-thread c-out) -(semaphore-post sema2) -(semaphore-wait sema) -(test (void) 'consumer-thread c-out) - -; queue 3 -(g / 2) -(g semaphore-wait sema2) -(g (lambda (s) (semaphore-wait s) 5) sema2) -(semaphore-wait sema) -(test 1/2 'consumer-thread c-out) -(semaphore-post sema2) -(semaphore-wait sema) -(test (void) 'consumer-thread c-out) -(semaphore-post sema2) -(semaphore-wait sema) -(test 5 'consumer-thread c-out) - -; kill the consumer -(kill-thread th) -(g - 7) -(sleep SLEEP-TIME) -(test 5 'consumer-thread c-out) - -(arity-test consumer-thread 1 2) -(error-test '(consumer-thread 9)) -(arity-test g 2 3) - -;;; semaphore-wait-multiple ;;; - -(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) -(semaphore-post sema) -(test sema semaphore-wait-multiple (list sema sema2)) -(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) -(semaphore-post sema2) -(test sema2 semaphore-wait-multiple (list sema sema2)) -(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) -(semaphore-post sema) -(semaphore-post sema2) -(let ([first (semaphore-wait-multiple (list sema sema2))]) - (test #t semaphore? first) - (test (if (eq? first sema) sema2 sema) semaphore-wait-multiple (list sema sema2))) -(test #f semaphore-wait-multiple (list sema sema2) SLEEP-TIME) - -(arity-test semaphore-wait-multiple 1 3) - -(report-errs) diff --git a/collects/tests/mzscheme/name.ss b/collects/tests/mzscheme/name.ss deleted file mode 100644 index 9f2b34bd..00000000 --- a/collects/tests/mzscheme/name.ss +++ /dev/null @@ -1,105 +0,0 @@ - -; Test MzScheme's name inference - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'NAMES) - -(arity-test inferred-name 1 1) -(test #f inferred-name 0) -(test #f inferred-name 'hello) -(test #f inferred-name "hi") - -; Test ok when no name for proc -(test #f inferred-name (lambda () 0)) -(test #f inferred-name (case-lambda)) -(test #f inferred-name (case-lambda [(x) 9])) -(test #f inferred-name (case-lambda [(x) 9][(y z) 12])) - -; Test constructs that don't provide a name -(test #f inferred-name (let ([x (cons (lambda () 10) 0)]) (car x))) -(test #f inferred-name (let ([x (let ([y (lambda (x) x)]) (y (lambda () 10)))]) x)) - -; Test ok when name for proc -(define f (lambda () 0)) -(define f2 (lambda (a) 0)) -(define f3 (case-lambda)) -(define f4 (case-lambda [(x) 9])) -(define f5 (case-lambda [(x) 9][(y z) 10])) - -(test 'f inferred-name f) -(test 'f2 inferred-name f2) -(test 'f3 inferred-name f3) -(test 'f4 inferred-name f4) -(test 'f5 inferred-name f5) - -; Test constructs that do provide a name -(test 'a inferred-name (let ([a (lambda () 0)]) a)) -(test 'a inferred-name (let ([a (lambda () 0)]) (let ([b a]) b))) -(test 'b inferred-name (let* ([b (lambda () 0)]) b)) -(test 'c inferred-name (letrec ([c (lambda () 0)]) c)) -(test 'loop inferred-name (let loop () loop)) - -(test 'd inferred-name (let ([d (begin (lambda () x))]) d)) -(test 'e inferred-name (let ([e (begin0 (lambda () x))]) e)) - -(test 'd2 inferred-name (let ([d2 (begin 7 (lambda () x))]) d2)) -(test 'e2 inferred-name (let ([e2 (begin0 (lambda () x) 7)]) e2)) - -(test 'd3 inferred-name (let ([d3 (begin (cons 1 2) (lambda () x))]) d3)) -(test 'e3 inferred-name (let ([e3 (begin0 (lambda () x) (cons 1 2))]) e3)) - -(test 'f inferred-name (let ([f (begin0 (begin (cons 1 2) (lambda () x)) (cons 1 2))]) f)) - -(test 'g1 inferred-name (let ([g1 (if (cons 1 2) (lambda () x) #f)]) g1)) -(test 'g2 inferred-name (let ([g2 (if (negative? (car (cons 1 2))) #t (lambda () x))]) g2)) - -(test 'w inferred-name (let ([w (let ([x 5]) (lambda () x))]) w)) -(test 'z inferred-name (let ([z (let ([x 5]) (cons 1 2) (lambda () x))]) z)) - -(set! f (lambda () 10)) -(test 'f inferred-name f) - -; Test class stuff ok when no name -(test #f inferred-name (class object% () (sequence (super-init)))) -(test #f inferred-name (interface ())) - -; Test class stuff ok when name -(test 'c1 inferred-name (let ([c1 (class object% () (sequence (super-init)))]) c1)) -(test 'i1 inferred-name (let ([i1 (interface ())]) i1)) -(test 'm inferred-name - (ivar - (make-object - (class object% () - (public - [m (lambda () 10)]) - (sequence (super-init)))) - m)) - ; Use external name: -(test 'mex inferred-name - (ivar - (make-object - (class object% () - (public - [(m mex) (lambda () 10)]) - (sequence (super-init)))) - mex)) - -; Test unit stuff ok when no name -(test #f inferred-name (unit (import) (export))) -(test #f inferred-name (compound-unit (import) (link) (export))) - -; Test class stuff ok when name -(test 'u1 inferred-name (let ([u1 (unit (import) (export))]) u1)) -(test 'u2 inferred-name (let ([u2 (compound-unit (import) (link) (export))]) u2)) - -(test 'x inferred-name (invoke-unit - (unit (import) (export) (define x (lambda () 0)) x))) -(test 'x2 inferred-name (invoke-unit - (unit (import) (export x2) (define x2 (lambda () 0)) x2))) - ; Use external name: -(test 'x3 inferred-name (invoke-unit - (unit (import) (export (x x3)) (define x (lambda () 0)) x))) - -(report-errs) diff --git a/collects/tests/mzscheme/namespac.ss b/collects/tests/mzscheme/namespac.ss deleted file mode 100644 index 78da0ddb..00000000 --- a/collects/tests/mzscheme/namespac.ss +++ /dev/null @@ -1,104 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'namespaces) - -(define flag-map - (list (list 'keywords - 'no-keywords - '(#%let ([#%lambda 7]) (void)) - exn:syntax? - #f) - (list 'call/cc=call/ec - 'call/cc!=call/ec - '((call/cc (#%lambda (x) x)) void) - exn:application:continuation? - #f) - (list 'hash-percent-syntax - 'all-syntax - '(if #t (void)) - exn:variable? - #f))) - -(define (do-one-by-one more less) - (let loop ([n (length flag-map)]) - (unless (zero? n) - (let ([test-info - (let loop ([l flag-map][p 1]) - (if (null? l) - '() - (let* ([g (car l)] - [g++ (cdddr g)]) - (cons - (cond - [(= p n) (cons (less g) (less g++))] - [else (cons (more g) (more g++))]) - (loop (cdr l) (add1 p))))))]) - (let* ([flags (map car test-info)] - [namespace (apply make-namespace flags)]) - (printf "trying: ~s~n" flags) - (let loop ([tests (map caddr flag-map)] - [results (map cdr test-info)]) - (if (null? results) - '() - (begin - (if (car results) - (error-test - `(with-handlers ([(#%lambda (x) #f) void]) ; outside parameterize re-raises exns after escaping - (parameterize ([current-namespace ,namespace]) - (eval ',(car tests)))) - (car results)) - (with-handlers ([(lambda (x) #f) void]) - (parameterize ([current-namespace namespace]) - (test (void) eval (car tests))))) - (loop (cdr tests) (cdr results))))))) - (loop (sub1 n))))) - -(unless (defined? 'building-flat-tests) - (do-one-by-one car cadr) - (do-one-by-one cadr car)) - -; Test primitive-name -(let ([gvl (parameterize ([current-namespace (make-namespace)]) (make-global-value-list))] - [aliases (list (cons "call/cc" "call-with-current-continuation") - (cons "call/ec" "call-with-escape-continuation") - (cons "interaction-environment" "current-namespace") - (cons "unit/sig?" "unit-with-signature?") - (cons "unit/sig->unit" "unit-with-signature-unit") - (cons "unit-with-signature->unit" "unit-with-signature-unit"))]) - (test #t 'names - (andmap - (lambda (nv-pair) - (let ([name (car nv-pair)] - [value (cdr nv-pair)]) - (or (not (primitive? value)) - (let* ([s (symbol->string name)] - [sr (if (char=? #\# (string-ref s 0)) - (substring s 2 (string-length s)) - s)] - [st (let ([m (assoc sr aliases)]) - (if m - (cdr m) - sr))]) - (or (equal? st (primitive-name value)) - (and (fprintf (current-error-port) - "different: ~a ~a~n" st (primitive-name value)) - #f)))))) - gvl))) - -(define (test-empty . flags) - (let ([e (apply make-namespace flags)]) - (parameterize ([current-namespace e]) - (test null make-global-value-list) - (test 'unbound 'empty-namespace - (with-handlers ([void (lambda (exn) 'unbound)]) - (eval 'car))) - (test 'unbound 'empty-namespace - (with-handlers ([void (lambda (exn) 'unbound)]) - (eval '#%car))) - (global-defined-value 'hello 5) - (test 5 'empty-namespace (eval 'hello)) - (test '((hello . 5)) make-global-value-list)))) -(test-empty 'empty) -(apply test-empty (append '(empty) (map car flag-map) (map cadr flag-map))) diff --git a/collects/tests/mzscheme/nch.ss b/collects/tests/mzscheme/nch.ss deleted file mode 100644 index 45398e6f..00000000 --- a/collects/tests/mzscheme/nch.ss +++ /dev/null @@ -1,30 +0,0 @@ - -(define (fact n) - (if (zero? n) - 1 - (* n (fact (- n 1))))) - -(define f1000 (fact 1000)) - -(define (divall n d) - (if (<= n 1) - d - (divall (/ n d) (+ 1 d)))) - -(define (nch n c) - (/ (fact n) (fact (- n c)) (fact c))) - -(define (snch n) - (letrec ((loop - (lambda (i) - (if (> i n) - 0 - (+ (nch n i) (loop (+ i 1))))))) - (loop 0))) - -(define (fsum n) - (if (zero? n) - 1 - (+ (fact n) (fsum (- n 1))))) - - diff --git a/collects/tests/mzscheme/number.ss b/collects/tests/mzscheme/number.ss deleted file mode 100644 index 9090f806..00000000 --- a/collects/tests/mzscheme/number.ss +++ /dev/null @@ -1,1797 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'numbers) - -(SECTION 6 5 5) -(test #f number? 'a) -(test #f complex? 'a) -(test #f real? 'a) -(test #f rational? 'a) -(test #f integer? 'a) - -(test #t number? 3) -(test #t complex? 3) -(test #t real? 3) -(test #t rational? 3) -(test #t integer? 3) - -(test #t number? 3.0) -(test #t complex? 3.0) -(test #t real? 3.0) -(test #t rational? 3.0) -(test #t integer? 3.0) - -(test #t number? 3.1) -(test #t complex? 3.1) -(test #t real? 3.1) -(test #t rational? 3.1) -(test #f integer? 3.1) - -(test #t number? 3/2) -(test #t complex? 3/2) -(test #t real? 3/2) -(test #t rational? 3/2) -(test #f integer? 3/2) - -(test #t number? 3+i) -(test #t complex? 3+i) -(test #f real? 3+i) -(test #f rational? 3+i) -(test #f integer? 3+i) - -(test #t number? 3.0+0i) -(test #t complex? 3.0+0i) -(test #t real? 3.0+0i) -(test #t rational? 3.0+0i) -(test #t integer? 3.0+0i) - -(test #t number? 3.0+0.0i) -(test #t complex? 3.0+0.0i) -(test #t real? 3.0+0.0i) -(test #t rational? 3.0+0.0i) -(test #t integer? 3.0+0.0i) - -(test #t number? 3.1+0.0i) -(test #t complex? 3.1+0.0i) -(test #t real? 3.1+0.0i) -(test #t rational? 3.1+0.0i) -(test #f integer? 3.1+0.0i) - -(test #t exact? 3) -(test #t exact? 3/4) -(test #f exact? 3.0) -(test #t exact? (expt 2 100)) -(test #t exact? 3+4i) -(test #f exact? 3.0+4i) - -(test #f inexact? 3) -(test #f inexact? 3/4) -(test #t inexact? 3.0) -(test #f inexact? (expt 2 100)) -(test #f inexact? 3+4i) -(test #t inexact? 3.0+4i) -(test #t inexact? 0+4.0i) -(test #t inexact? 4+0.i) - -(test #t complex? -4.242154731064108e-5-6.865001427422244e-5i) -(test #f exact? -4.242154731064108e-5-6.865001427422244e-5i) -(test #t inexact? -4.242154731064108e-5-6.865001427422244e-5i) - -(test #t complex? -4.242154731064108f-5-6.865001427422244f-5i) -(test #f exact? -4.242154731064108f-5-6.865001427422244f-5i) -(test #t inexact? -4.242154731064108f-5-6.865001427422244f-5i) - -(test #t number? +inf.0) -(test #t complex? +inf.0) -(test #t real? +inf.0) -(test #t rational? +inf.0) -(test #t integer? +inf.0) - -(test #t number? -inf.0) -(test #t complex? -inf.0) -(test #t real? -inf.0) -(test #t rational? -inf.0) -(test #t integer? -inf.0) - -(test #t number? +nan.0) -(test #t complex? +nan.0) -(test #t real? +nan.0) -(test #t rational? +nan.0) -(test #f integer? +nan.0) - -(arity-test inexact? 1 1) -(arity-test number? 1 1) -(arity-test complex? 1 1) -(arity-test real? 1 1) -(arity-test rational? 1 1) -(arity-test integer? 1 1) -(arity-test exact? 1 1) -(arity-test inexact? 1 1) - -(error-test '(exact? 'a)) -(error-test '(inexact? 'a)) - -(test "+inf.0" number->string +inf.0) -(test "-inf.0" number->string -inf.0) -(test "+nan.0" number->string +nan.0) -(test "+nan.0" number->string +nan.0) - -(test #t = 0.0 -0.0) -(test #f eqv? 0.0 -0.0) - -(test #t = 0) -(test #t > 0) -(test #t < 0) -(test #t >= 0) -(test #t <= 0) -(test #t = 22 22 22) -(test #t = 22 22) -(test #f = 34 34 35) -(test #f = 34 35) -(test #t > 3 -6246) -(test #f > 9 9 -2424) -(test #t >= 3 -4 -6246) -(test #t >= 9 9) -(test #f >= 8 9) -(test #t < -1 2 3 4 5 6 7 8) -(test #f < -1 2 3 4 4 5 6 7) -(test #t <= -1 2 3 4 5 6 7 8) -(test #t <= -1 2 3 4 4 5 6 7) -(test #f < 1 3 2) -(test #f >= 1 3 2) - -(define (test-compare lo m hi) ; all positive! - (define -lo (- lo)) - (define -m (- m)) - (define -hi (- hi)) - - (define (test-lh l h) - (test #f > l h) - (test #t < l h) - (test #f = l h) - (test #f >= l h) - (test #t <= l h)) - - (define (test-hl h l) - (test #t > h l) - (test #f < h l) - (test #f = h l) - (test #t >= h l) - (test #f <= h l)) - - (define (test-zero z) - (test-hl m z) - (test-lh -m z) - (test-hl z -m) - (test-lh z m)) - - (test-lh m hi) - (test-hl -m -hi) - - (test #f > m m) - (test #f < m m) - (test #t = m m) - (test #t >= m m) - (test #t <= m m) - - (test-hl m -m) - (test-lh -m m) - - (test-hl m lo) - (test-lh -m -lo) - - (test-zero 0) - (test-zero 0.0)) - -(test-compare 0.5 1.2 2.3) -(test-compare 2/5 1/2 2/3) -(test #t = 1/2 2/4) - -(test-compare 0.5 6/5 2.3) -(test-compare 1 11922615739/10210200 3000) -(test-compare 1.0 11922615739/10210200 3000.0) - -(test-compare 0.4+0.i 1/2 2.3+0.i) - -(test #f > 0 (/ 1 (expt 2 400))) - -(test #t < 0.5 2/3) -(test #f < 2/3 0.5) -(test #t = 0.5 1/2) -(test #t = +0.5i +1/2i) -(test #f = +0.5i 1+1/2i) -(test #t = 1 1.0+0i) -(test #t = 1 1.0+0.0i) -(test #f eqv? 1.0 1.0+0.0i) -(test #f eqv? 1.0-0.0i 1.0+0.0i) - -(test #f = 1+2i 2+i) - -(define (test-nan.0 f . args) - (apply test +nan.0 f args)) - -(define (test-i-nan.0 f . args) - (apply test (make-rectangular +nan.0 +nan.0) f args)) - -(define (test-nan c) - (test #f < +nan.0 c) - (test #f > +nan.0 c) - (test #f = +nan.0 c) - (test #f <= +nan.0 c) - (test #f >= +nan.0 c)) -(test-nan 0) -(test-nan 0.0) -(test-nan 0.3) -(test-nan +nan.0) -(test-nan +inf.0) -(test-nan -inf.0) -(test-nan 0.3+0.0i) -(test #f = +nan.0 1+2i) -(test #f = +nan.0 (make-rectangular +inf.0 -inf.0)) - -(test-compare 999999999999 1000000000000 1000000000001) -(define big-num (expt 2 1500)) -(test-compare (sub1 big-num) big-num (add1 big-num)) -(test-compare 1.0 (expt 10 100) 1e200) - -(define (inf-zero-test inf rx negnot) - (let ([inf-test-x - (lambda (r v) - (test r < v inf) - (test (not r) > v inf) - (test r <= v inf) - (test (not r) >= v inf) - - (test (not r) < inf v) - (test r > inf v) - (test (not r) <= inf v) - (test r >= inf v))]) - (inf-test-x rx 5) - (inf-test-x (negnot rx) -5) - (inf-test-x rx big-num) - (inf-test-x (negnot rx) (- big-num)) - (inf-test-x rx (/ big-num 3)) - (inf-test-x (negnot rx) (/ (- big-num) 3)) - (inf-test-x rx (/ 1 big-num)) - (inf-test-x (negnot rx) (/ 1 (- big-num))))) -(inf-zero-test +inf.0 #t (lambda (x) x)) -(inf-zero-test -inf.0 #f (lambda (x) x)) -(inf-zero-test 0.0 #f not) - -(error-test '(= 1 'a)) -(error-test '(= 1 1 'a)) -(error-test '(= 1 2 'a)) -(error-test '(= 'a 1)) -(error-test '(= 'a)) -(error-test '(> 1 'a)) -(error-test '(> 1 0 'a)) -(error-test '(> 1 2 'a)) -(error-test '(> 'a 1)) -(error-test '(> 0.5+0.1i 1)) -(error-test '(> 1 0.5+0.1i)) -(error-test '(< 1 'a)) -(error-test '(< 1 2 'a)) -(error-test '(< 1 0 'a)) -(error-test '(< 'a 1)) -(error-test '(< 0.5+0.1i 1)) -(error-test '(< 1 0.5+0.1i)) -(error-test '(>= 1 'a)) -(error-test '(>= 1 1 'a)) -(error-test '(>= 1 2 'a)) -(error-test '(>= 'a 1)) -(error-test '(>= 0.5+0.1i 1)) -(error-test '(>= 1 0.5+0.1i)) -(error-test '(<= 1 'a)) -(error-test '(<= 1 1 'a)) -(error-test '(<= 1 0 'a)) -(error-test '(<= 'a 1)) -(error-test '(<= 0.5+0.1i 1)) -(error-test '(<= 1 0.5+0.1i)) - -(arity-test = 1 -1) -(arity-test < 1 -1) -(arity-test > 1 -1) -(arity-test <= 1 -1) -(arity-test >= 1 -1) - -(test #t zero? 0) -(test #t zero? 0.0) -(test #t zero? +0.0i) -(test #t zero? -0.0i) -(test #t zero? 0.0+0.0i) -(test #f zero? 1.0+0.0i) -(test #f zero? 1.0+1.0i) -(test #f zero? 0.0+1.0i) -(test #t zero? 0/1) -(test #f zero? 1) -(test #f zero? -1) -(test #f zero? -100) -(test #f zero? 1.0) -(test #f zero? -1.0) -(test #f zero? 1/2) -(test #f zero? -1/2) -(test #f zero? -1/2+2i) -(test #f zero? +inf.0) -(test #f zero? -inf.0) -(test #f zero? +nan.0) -(test #f zero? (expt 2 37)) -(test #f zero? (expt -2 37)) -(test #t positive? 4) -(test #f positive? -4) -(test #f positive? 0) -(test #t positive? 4.0) -(test #f positive? -4.0) -(test #f positive? 0.0) -(test #t positive? 2/4) -(test #f positive? -2/4) -(test #f positive? 0/2) -(test #t positive? +inf.0) -(test #f positive? -inf.0) -(test #f positive? +nan.0) -(test #t positive? 5+0.0i) -(test #f positive? -5+0.0i) -(test #t positive? (expt 2 37)) -(test #f positive? (expt -2 37)) -(test #f negative? 4) -(test #t negative? -4) -(test #f negative? 0) -(test #f negative? 4.0) -(test #t negative? -4.0) -(test #f negative? 0.0) -(test #f negative? 2/4) -(test #t negative? -2/4) -(test #f negative? 0/4) -(test #f negative? (expt 2 37)) -(test #t negative? (expt -2 37)) -(test #f negative? +inf.0) -(test #t negative? -inf.0) -(test #f negative? +nan.0) -(test #f negative? 5+0.0i) -(test #t negative? -5+0.0i) -(test #t odd? 3) -(test #f odd? 2) -(test #f odd? -4) -(test #t odd? -1) -(test #t odd? +inf.0) -(test #t odd? -inf.0) -(test #t odd? 5+0.0i) -(test #f odd? 4+0.0i) -(test #f odd? (expt 2 37)) -(test #f odd? (expt -2 37)) -(test #t odd? (add1 (expt 2 37))) -(test #t odd? (sub1 (expt -2 37))) -(test #f even? 3) -(test #t even? 2) -(test #t even? -4) -(test #f even? -1) -(test #t even? +inf.0) -(test #t even? -inf.0) -(test #t even? 4+0.0i) -(test #f even? 5+0.0i) -(test #t even? (expt 2 37)) -(test #t even? (expt -2 37)) -(test #f even? (add1 (expt 2 37))) -(test #f even? (sub1 (expt -2 37))) - -(arity-test zero? 1 1) -(arity-test positive? 1 1) -(arity-test negative? 1 1) -(arity-test odd? 1 1) -(arity-test even? 1 1) - -(error-test '(positive? 2+i)) -(error-test '(negative? 2+i)) -(error-test '(odd? 4.1)) -(error-test '(odd? 4.1+0.0i)) -(error-test '(odd? 4+1i)) -(error-test '(even? 4.1)) -(error-test '(even? 4.1+0.0i)) -(error-test '(even? 4+1i)) -(error-test '(even? +nan.0)) - -(error-test '(positive? 'i)) -(error-test '(negative? 'i)) -(error-test '(odd? 'a)) -(error-test '(even? 'a)) -(error-test '(odd? 'i)) -(error-test '(even? 'i)) - -(test 5 max 5) -(test 5 min 5) -(test 38 max 34 5 7 38 6) -(test -24 min 3 5 5 330 4 -24) -(test 38.0 max 34 5.0 7 38 6) -(test -24.0 min 3 5 5 330 4 -24.0) -(test 2/3 max 1/2 2/3) -(test 2/3 max 2/3 1/2) -(test 2/3 max 2/3 -4/5) -(test 1/2 min 1/2 2/3) -(test 1/2 min 2/3 1/2) -(test -4/5 min 2/3 -4/5) -(test +inf.0 max +inf.0 0 -inf.0) -(test -inf.0 min +inf.0 0 -inf.0) -(test-nan.0 max +inf.0 +nan.0 0 -inf.0) -(test-nan.0 min +inf.0 0 +nan.0 -inf.0) -(test 9.0 min 9.0+0.0i 100) -(test 8.0 min 9.0+0.0i 8) -(test 9.0 min 100 9.0+0.0i) -(test 8.0 min 8 9.0+0.0i) -(test 100.0 max 9.0+0.0i 100) -(test 9.0 max 9.0+0.0i 8) -(test 100.0 max 100 9.0+0.0i) -(test 9.0 max 8 9.0+0.0i) - -(test (expt 5 27) max 9 (expt 5 27)) -(test (expt 5 29) max (expt 5 29) (expt 5 27)) -(test (expt 5 29) max (expt 5 27) (expt 5 29)) -(test (expt 5 27) max (expt 5 27) 9) -(test (expt 5 27) max (expt 5 27) (- (expt 5 29))) -(test (expt 5 27) max (- (expt 5 29)) (expt 5 27)) -(test (- (expt 5 27)) max (- (expt 5 27)) (- (expt 5 29))) -(test (- (expt 5 27)) max (- (expt 5 29)) (- (expt 5 27))) -(test 9 min 9 (expt 5 27)) -(test (expt 5 27) min (expt 5 29) (expt 5 27)) -(test (expt 5 27) min (expt 5 27) (expt 5 29)) -(test 9 min (expt 5 27) 9) -(test (- (expt 5 29)) min (expt 5 27) (- (expt 5 29))) -(test (- (expt 5 29)) min (- (expt 5 29)) (expt 5 27)) -(test (- (expt 5 29)) min (- (expt 5 27)) (- (expt 5 29))) -(test (- (expt 5 29)) min (- (expt 5 29)) (- (expt 5 27))) - -(error-test '(max 0 'a)) -(error-test '(min 0 'a)) -(error-test '(max 'a 0)) -(error-test '(min 'a 0)) -(error-test '(max 'a)) -(error-test '(min 'a)) -(error-test '(min 2 4+i)) -(error-test '(max 2 4+i)) -(error-test '(min 4+i)) -(error-test '(max 4+i)) - -(arity-test max 1 -1) -(arity-test min 1 -1) - -(test 0 +) -(test 7 + 3 4) -(test 6 + 1 2 3) -(test 7.0 + 3 4.0) -(test 6.0 + 1 2.0 3) -(test 19/12 + 1/4 1/3 1) -(test +i + +i) -(test 3/2+1i + 1 2+2i -i -3/2) -(test 3 + 3) -(test 0 +) -(test 4 * 4) -(test 16.0 * 4 4.0) -(test 1 *) -(test 6/25 * 3/5 1/5 2) -(test #i+6/25 * 3/5 1/5 2.0) -(test +6/25i * 3/5 1/5 2 +i) -(test (make-rectangular 0 #i+6/25) * 3/5 1/5 2.0 +i) -(test 18805208620685182736256260714897 - * (sub1 (expt 2 31)) - 8756857658476587568751) -(test 1073741874 + (- (expt 2 30) 50) 100) ; fixnum -> bignum for 32 bits -(test -1073741874 - (- 50 (expt 2 30)) 100) ; fixnum -> bignum for 32 bits -(test 10.0+0.0i + 9.0+0.0i 1) -(test 10.0+0.0i + 9.0+0.0i 1-0.0i) -(test 9.0+0.0i * 9.0+0.0i 1) -(test 10.0-1.0i + 9.0+0.0i 1-1.0i) -(test 0 * 0 10.0) -(test 0 * 0 +inf.0) -(test 0 * 0 +nan.0) -(test 0 / 0 0.0) -(test 0 / 0 +inf.0) -(test 0 / 0 -inf.0) -(test 0 / 0 +nan.0) -(test -0.0 + 0 -0.0) -(test -0.0 + -0.0 0) -(test -0.0 - -0.0 0) - -(test -0.0 - 0.0) -(test 0.0 - -0.0) -(test -0.0 - 0 0.0) -(test 0.0 - 0 -0.0) - -(arity-test * 0 -1) -(arity-test + 0 -1) -(arity-test - 1 -1) -(arity-test / 1 -1) - -(test 2 add1 1) -(test 0 add1 -1) -(test 2.0 add1 1.0) -(test 0.0 add1 -1.0) -(test 3/2 add1 1/2) -(test 1/2 add1 -1/2) -(test 2.0+i add1 1.0+i) -(test 0.0+i add1 -1.0+i) -(test 0.0+0.0i add1 -1+0.0i) -(test 0.0-0.0i add1 -1-0.0i) -(test 1073741824 add1 #x3FFFFFFF) ; fixnum boundary case - -(error-test '(add1 "a")) -(arity-test add1 1 1) - -(test 1 sub1 2) -(test -2 sub1 -1) -(test 1.0 sub1 2.0) -(test -2.0 sub1 -1.0) -(test -1/2 sub1 1/2) -(test -3/2 sub1 -1/2) -(test 1.0+i sub1 2.0+i) -(test -2.0+i sub1 -1.0+i) -(test -2.0+0.0i sub1 -1+0.0i) -(test -2.0-0.0i sub1 -1-0.0i) -(test -1073741824 sub1 -1073741823) ; fixnum boundary case - -(error-test '(sub1 "a")) -(arity-test sub1 1 1) - -(test 1024 expt 2 10) -(test 1/1024 expt 2 -10) -(arity-test expt 2 2) - -(test 0 apply + (map inexact->exact (list 3.2e+270 -2.4e+270 -8e+269))) -(test 0 apply + (map inexact->exact (list 3.2f+7 -2.4f+7 -8f+6))) - -(test #t positive? (inexact->exact 0.1)) -(test #t negative? (inexact->exact -0.1)) -(test 0 + (inexact->exact -0.1) (inexact->exact 0.1)) -(arity-test inexact->exact 1 1) -(error-test '(inexact->exact 'a)) -(test 1+i inexact->exact 1.0+1.0i) -(test 1 inexact->exact 1.0+0.0i) -(test 1 inexact->exact 1.0-0.0i) - -(test #t positive? (exact->inexact 1/10)) -(test #t negative? (exact->inexact -1/10)) -(test 0.0 + (exact->inexact -1/10) (exact->inexact 1/10)) -(arity-test exact->inexact 1 1) -(error-test '(exact->inexact 'a)) -(test 1.0+1.0i exact->inexact 1+1i) -(test 1.0+0.0i exact->inexact 1+0.0i) -(test (expt 7 30) inexact->exact (expt 7 30)) - -(error-test '(inexact->exact +inf.0)) -(error-test '(inexact->exact -inf.0)) -(error-test '(inexact->exact +nan.0)) - -(error-test '(* 'a 0)) -(error-test '(+ 'a 0)) -(error-test '(/ 'a 0)) -(error-test '(- 'a 0)) -(error-test '(+ 0 'a)) -(error-test '(* 0 'a)) -(error-test '(- 0 'a)) -(error-test '(/ 0 'a)) -(error-test '(+ 'a)) -(error-test '(* 'a)) -(error-test '(- 'a)) -(error-test '(/ 'a)) - -(define (test-inf-plus-times v) - (define (test+ +) - (test +inf.0 + v (+ +inf.0)) - (test -inf.0 + v (+ -inf.0)) - (test +inf.0 + (- v) (+ +inf.0)) - (test -inf.0 + (- v) (+ -inf.0)) - - (test +inf.0 + +inf.0 v) - (test -inf.0 + -inf.0 v) - (test +inf.0 + +inf.0 (- v)) - (test -inf.0 + -inf.0 (- v)) - - (test-nan.0 + +nan.0 v) - (test-nan.0 + v +nan.0)) - - (test+ +) - (test+ -) - - (test +inf.0 * +inf.0 v) - (test -inf.0 * -inf.0 v) - (test -inf.0 * +inf.0 (- v)) - (test +inf.0 * -inf.0 (- v)) - - (test +inf.0 * v +inf.0) - (test -inf.0 * v -inf.0) - (test -inf.0 * (- v) +inf.0) - (test +inf.0 * (- v) -inf.0) - - (test-nan.0 * +nan.0 v) - (test-nan.0 * v +nan.0)) - -(test-inf-plus-times 1) -(test-inf-plus-times 1.0) -(test-inf-plus-times (expt 2 100)) - -(test -inf.0 - +inf.0) -(test +inf.0 - -inf.0) -(test +inf.0 + +inf.0 +inf.0) -(test -inf.0 + -inf.0 -inf.0) -(test-nan.0 + +inf.0 -inf.0) -(test-nan.0 - +inf.0 +inf.0) -(test-nan.0 - -inf.0 -inf.0) -(test +inf.0 * +inf.0 +inf.0) -(test -inf.0 * +inf.0 -inf.0) -(test 0 * +inf.0 0) -(test-nan.0 * +inf.0 0.0) -(test-nan.0 + +nan.0 +nan.0) -(test-nan.0 - +nan.0 +nan.0) -(test-nan.0 * +nan.0 +nan.0) - -(test 1/2 / 1 2) -(test 1/2 / 1/4 1/2) -(test 0.5 / 1 2.0) -(test 0.5 / 1.0 2) -(test 1/2+3/2i / 1+3i 2) -(test 1/5-3/5i / 2 1+3i) -(test 0.5+0.0i / 1+0.0i 2) -(test 0.25-0.0i / 1 4+0.0i) -(test 0.25+0.0i / 1+0.0i 4+0.0i) - -(test +inf.0 / 1.0 0.0) -(test -inf.0 / -1.0 0.0) -(test +inf.0 / -1.0 -0.0) -(test -inf.0 / 1.0 -0.0) - -(define (make-test-inf-zero-div zero -zero inf -inf) - (lambda (v) - (test zero / v +inf.0) - (test -zero / v -inf.0) - (test -zero / (- v) +inf.0) - (test zero / (- v) -inf.0) - - (test inf / +inf.0 v) - (test -inf / -inf.0 v) - (test -inf / +inf.0 (- v)) - (test inf / -inf.0 (- v)) - - (unless (zero? v) - (test zero / 0.0 v) - (test -zero / 0.0 (- v)) - (test -zero / -0.0 v) - (test zero / -0.0 (- v)) - - (test inf / v 0.0) - (test -inf / (- v) 0.0) - (test -inf / v -0.0) - (test inf / (- v) -0.0)) - - (test-nan.0 / +nan.0 v) - (test-nan.0 / v +nan.0))) - -(define test-inf-zero-div (make-test-inf-zero-div 0.0 -0.0 +inf.0 -inf.0)) -(define test-neg-inf-zero-div (make-test-inf-zero-div -0.0 0.0 -inf.0 +inf.0)) - -(test-inf-zero-div big-num) -(test-inf-zero-div (/ big-num 3)) -(test-inf-zero-div 0.0) - -(test-neg-inf-zero-div (- big-num)) -(test-neg-inf-zero-div (- (/ big-num 3))) -(test-neg-inf-zero-div -0.0) - -(test-nan.0 / +inf.0 +inf.0) -(test-nan.0 / +inf.0 -inf.0) -(test-nan.0 / +nan.0 -nan.0) - -(test 1.0 exact->inexact (/ big-num (add1 big-num))) - -(error-test '(/ 0) exn:application:divide-by-zero?) -(error-test '(/ 1 0) exn:application:divide-by-zero?) -(error-test '(/ 1/2 0) exn:application:divide-by-zero?) -(error-test '(/ 1+2i 0) exn:application:divide-by-zero?) -(error-test '(/ 1.0 0) exn:application:divide-by-zero?) - -(test -1 - 3 4) -(test -3 - 3) -(test -1.0 - 3.0 4) -(test -3.0 - 3.0) -(test 7 abs -7) -(test 7.0 abs -7.0) -(test 7 abs 7) -(test 0 abs 0) -(test 1/2 abs 1/2) -(test 1/2 abs -1/2) -(test +inf.0 abs +inf.0) -(test +inf.0 abs -inf.0) -(test-nan.0 abs -nan.0) -(test 4.0 abs -4.0+0.0i) - -(arity-test abs 1 1) -(error-test '(-) exn:application:arity?) -(error-test '(abs 'a)) -(error-test '(abs +5i)) - -(test 5 quotient 35 7) -(test 5.0 quotient 35 7.0) -(test 5.0 quotient 36 7.0) -(test 5.0 quotient 36.0 7) -(test -5 quotient -35 7) -(test -5.0 quotient -35 7.0) -(test -5 quotient 35 -7) -(test -5.0 quotient 35 -7.0) -(test 5 quotient -35 -7) -(test 5.0 quotient -35 -7.0) -(test -5.0 quotient -36 7.0) -(test -5.0 quotient 36.0 -7) -(test -5.0 quotient 36.0 -7+0.0i) -(test -5.0 quotient 36.0+0.0i -7) -(test 1 modulo 13 4) -(test 1 remainder 13 4) -(test 1.0 modulo 13 4.0) -(test 1.0 remainder 13 4.0) -(test 3 modulo -13 4) -(test -1 remainder -13 4) -(test 3.0 modulo -13 4.0) -(test -1.0 remainder -13 4.0) -(test -3 modulo 13 -4) -(test 1 remainder 13 -4) -(test -3.0 modulo 13.0 -4) -(test 1.0 remainder 13.0 -4) -(test -1 modulo -13 -4) -(test -1 remainder -13 -4) -(test -1.0 modulo -13 -4.0) -(test -1.0 remainder -13 -4.0) -(test -1.0 modulo -13 -4.0+0.0i) -(test -1.0 remainder -13 -4.0+0.0i) -(test -1.0 modulo -13+0.0i -4.0) -(test -1.0 remainder -13+0.0i -4.0) -(test -2 remainder -3333333332 -3) -(test -2 modulo -3333333332 -3) -(test 2 remainder 3333333332 -3) -(test -1 modulo 3333333332 -3) -(test 0 modulo 4 2) -(test 0 modulo -4 2) -(test 0 modulo 4 -2) -(test 0 modulo -4 -2) -(test 0.0 modulo 4.0 2) -(test 0.0 modulo -4.0 2) -(test 0.0 modulo 4.0 -2) -(test 0.0 modulo -4.0 -2) -(test 0 remainder 4 2) -(test 0 remainder -4 2) -(test 0 remainder 4 -2) -(test 0 remainder -4 -2) -(test 0.0 remainder 4.0 2) -(test 0.0 remainder -4.0 2) -(test 0.0 remainder 4.0 -2) -(test 0.0 remainder -4.0 -2) -(define (divtest n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2)))) -(test #t divtest 238 9) -(test #t divtest -238 9) -(test #t divtest 238 -9) -(test #t divtest -238 -9) - -(test 13.0 quotient 1324.0 100) - -(error-test '(quotient 6 0) exn:application:divide-by-zero?) -(error-test '(modulo 6 0) exn:application:divide-by-zero?) -(error-test '(remainder 6 0) exn:application:divide-by-zero?) -(error-test '(quotient 6 0.0) exn:application:divide-by-zero?) -(error-test '(modulo 6 0.0) exn:application:divide-by-zero?) -(error-test '(remainder 6 0.0) exn:application:divide-by-zero?) -(error-test '(quotient 6 -0.0) exn:application:divide-by-zero?) -(error-test '(modulo 6 -0.0) exn:application:divide-by-zero?) -(error-test '(remainder 6 -0.0) exn:application:divide-by-zero?) - -(define (test-qrm-inf v) - (define iv (exact->inexact v)) - - (test 0.0 quotient v +inf.0) - (test -0.0 quotient v -inf.0) - (test iv remainder v +inf.0) - (test iv remainder v -inf.0) - (test iv modulo v +inf.0) - (test -inf.0 modulo v -inf.0) - - (test +inf.0 quotient +inf.0 v) - (test -inf.0 quotient -inf.0 v) - (test 0.0 remainder +inf.0 v) - (test 0.0 remainder -inf.0 v) - (test 0.0 modulo +inf.0 v) - (test 0.0 modulo -inf.0 v)) - -(test-qrm-inf 9) -(test-qrm-inf 9.0) -(test-qrm-inf (expt 2 100)) - -;; Check 0.0 combinations -(test -0.0 quotient -0.0 +inf.0) -(test 0.0 quotient -0.0 -inf.0) -(test -0.0 quotient -0.0 2.0) -(test 0.0 quotient -0.0 -2.0) -(test 0.0 quotient 0.0 +inf.0) -(test -0.0 quotient 0.0 -inf.0) -(test 0.0 quotient 0.0 2.0) -(test -0.0 quotient 0.0 -2.0) -(test 0.0 modulo -0.0 +inf.0) -(test 0.0 modulo -0.0 -inf.0) -(test 0.0 modulo -0.0 2.0) -(test 0.0 modulo -0.0 -2.0) -(test 0.0 modulo 0.0 +inf.0) -(test 0.0 modulo 0.0 -inf.0) -(test 0.0 modulo 0.0 2.0) -(test 0.0 modulo 0.0 -2.0) -(test 0.0 remainder -0.0 +inf.0) -(test 0.0 remainder -0.0 -inf.0) -(test 0.0 remainder -0.0 2.0) -(test 0.0 remainder -0.0 -2.0) -(test 0.0 remainder 0.0 +inf.0) -(test 0.0 remainder 0.0 -inf.0) -(test 0.0 remainder 0.0 2.0) -(test 0.0 remainder 0.0 -2.0) - -(arity-test quotient 2 2) -(arity-test modulo 2 2) -(arity-test remainder 2 2) - -(error-test '(quotient 'a 1)) -(error-test '(quotient 1 'a)) -(error-test '(quotient 1 +nan.0)) -(error-test '(quotient +nan.0 1)) -(error-test '(modulo 'a 1)) -(error-test '(modulo 1 'a)) -(error-test '(modulo +nan.0 1)) -(error-test '(modulo 1 +nan.0)) -(error-test '(remainder 'a 1)) -(error-test '(remainder 1 'a)) -(error-test '(remainder +nan.0 1)) -(error-test '(remainder 1 +nan.0)) -(error-test '(quotient 'a 1.0)) -(error-test '(quotient 1.0 'a)) -(error-test '(modulo 'a 1.0)) -(error-test '(modulo 1.0 'a)) -(error-test '(remainder 'a 1.0)) -(error-test '(remainder 1.0 'a)) -(error-test '(quotient 1/2 1)) -(error-test '(remainder 1/2 1)) -(error-test '(modulo 1/2 1)) -(error-test '(quotient 2 1/2)) -(error-test '(remainder 2 1/2)) -(error-test '(modulo 2 1/2)) -(error-test '(quotient 12.3 1)) -(error-test '(remainder 12.3 1)) -(error-test '(modulo 12.3 1)) -(error-test '(quotient 2 12.3)) -(error-test '(remainder 2 12.3)) -(error-test '(modulo 2 12.3)) -(error-test '(quotient 1+2i 1)) -(error-test '(remainder 1+2i 1)) -(error-test '(modulo 1+2i 1)) -(error-test '(quotient 2 1+2i)) -(error-test '(remainder 2 1+2i)) -(error-test '(modulo 2 1+2i)) - -(test 10 bitwise-ior 10) -(test 10 bitwise-and 10) -(test 10 bitwise-xor 10) -(test 7 bitwise-ior 3 4) -(test 0 bitwise-and 3 4) -(test 7 bitwise-xor 3 4) -(test 7 bitwise-ior 3 4 1) -(test 1 bitwise-and 3 5 1) -(test 6 bitwise-xor 3 4 1) - -(test #x1ffff7777 bitwise-ior #x1aaaa5555 #x155553333) -(test #x100001111 bitwise-and #x1aaaa5555 #x155553333) -(test #x0ffff6666 bitwise-xor #x1aaaa5555 #x155553333) - -(test #x3ffff7777 bitwise-ior #x2aaaa5555 #x155553333) -(test #x000001111 bitwise-and #x2aaaa5555 #x155553333) -(test #x3ffff6666 bitwise-xor #x2aaaa5555 #x155553333) - -(test #x3ffff7777 bitwise-ior #x2aaaa5555 #x155553333) -(test #x000001111 bitwise-and #x2aaaa5555 #x155553333) -(test #x3ffff6666 bitwise-xor #x2aaaa5555 #x155553333) - -(test #xfffffffffffffe bitwise-not #x-FFFFFFFFFFFFFF) -(test #x-100000000000000 bitwise-not #xFFFFFFFFFFFFFF) - -(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-15555aaaa)) - bitwise-not (bitwise-ior #x-2aaaa5555 #x-15555aaaa)) -(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-155553333)) - bitwise-not (bitwise-ior #x-2aaaa5555 #x-155553333)) -(test (bitwise-and (bitwise-not #x-2aaaa5555) (bitwise-not #x-15555333)) - bitwise-not (bitwise-ior #x-2aaaa5555 #x-15555333)) - -(test #x-155553333 bitwise-xor #x-2aaaa5555 (bitwise-xor #x-2aaaa5555 #x-155553333)) -(test #x-15555333 bitwise-xor #x-2aaaa5555 (bitwise-xor #x-2aaaa5555 #x-15555333)) - -(arity-test bitwise-ior 1 -1) -(arity-test bitwise-and 1 -1) -(arity-test bitwise-xor 1 -1) -(arity-test bitwise-not 1 1) - -(define error-test-bitwise-procs - (lambda (v) - (error-test `(bitwise-ior ,v)) - (error-test `(bitwise-and ,v)) - (error-test `(bitwise-xor ,v)) - (error-test `(bitwise-not ,v)) - (error-test `(bitwise-ior 1 ,v)) - (error-test `(bitwise-and 1 ,v)) - (error-test `(bitwise-xor 1 ,v)) - (error-test `(bitwise-ior ,v 1)) - (error-test `(bitwise-and ,v 1)) - (error-test `(bitwise-xor ,v 1)))) - -(error-test-bitwise-procs 1.0) -(error-test-bitwise-procs 1/2) -(error-test-bitwise-procs 1+2i) -(error-test-bitwise-procs 1.0+0.0i) -(error-test-bitwise-procs +inf.0) -(error-test-bitwise-procs ''a) - -(test 1 arithmetic-shift 1 0) -(test 1024 arithmetic-shift 1 10) -(test 1 arithmetic-shift 1024 -10) -(test 256 arithmetic-shift 1024 -2) -(test 0 arithmetic-shift 1024 -11) -(test 0 arithmetic-shift 1024 -20) -(test 0 arithmetic-shift 1024 -40) -(test 0 arithmetic-shift 1024 -20000000000000000000) -(test 0 arithmetic-shift 0 100) -(test 0 arithmetic-shift 0 -100) -(test 0 arithmetic-shift 17 -32) - -(test (expt 2 40) arithmetic-shift (expt 2 40) 0) -(test (expt 2 50) arithmetic-shift (expt 2 40) 10) -(test (expt 2 30) arithmetic-shift (expt 2 40) -10) ; somewhere close to here is a boundary... -(test (expt 2 29) arithmetic-shift (expt 2 40) -11) -(test (expt 2 31) arithmetic-shift (expt 2 40) -9) -(test 1 arithmetic-shift (expt 2 40) -40) -(test 0 arithmetic-shift (expt 2 40) -41) -(test 0 arithmetic-shift (expt 2 40) -100) - -(test -1 arithmetic-shift -1 0) -(test -1024 arithmetic-shift -1 10) -(test -1 arithmetic-shift -1024 -10) -(test -256 arithmetic-shift -1024 -2) -(test -1 arithmetic-shift -1024 -11) -(test -1 arithmetic-shift -1024 -20) -(test -1 arithmetic-shift -1024 -20000000000000000000) - -(test (- (expt 2 40)) arithmetic-shift (- (expt 2 40)) 0) -(test (- (expt 2 50)) arithmetic-shift (- (expt 2 40)) 10) -(test (- (expt 2 30)) arithmetic-shift (- (expt 2 40)) -10) ; somewhere close to here is a boundary... -(test (- (expt 2 29)) arithmetic-shift (- (expt 2 40)) -11) -(test (- (expt 2 31)) arithmetic-shift (- (expt 2 40)) -9) -(test -1 arithmetic-shift (- (expt 2 40)) -40) -(test -1 arithmetic-shift (- (expt 2 40)) -41) -(test -1 arithmetic-shift (- (expt 2 40)) -100) - -(test 0 arithmetic-shift (sub1 (expt 2 30)) -32) -(test 0 arithmetic-shift (sub1 (expt 2 31)) -32) -(test 0 arithmetic-shift (sub1 (expt 2 32)) -32) -(test 1 arithmetic-shift (expt 2 32) -32) - -(arity-test arithmetic-shift 2 2) -(error-test '(arithmetic-shift "a" 1)) -(error-test '(arithmetic-shift 1 "a")) -(error-test '(arithmetic-shift 1.0 1)) -(error-test '(arithmetic-shift 1 1.0)) -(error-test '(arithmetic-shift 1 1.0+0.0i)) -(error-test '(arithmetic-shift 1 (expt 2 80)) exn:misc:out-of-memory?) - -(test 4 gcd 0 4) -(test 4 gcd -4 0) -(test 4 gcd 32 -36) -(test 2 gcd 6 10 14) -(test 0 gcd) -(test 5 gcd 5) -(test 5.0 gcd 5.0 10) -(test 5.0 gcd -5.0 10) -(test 5.0 gcd 5.0 -10) -(test 5.0 gcd 5.0+0.0i 10) -(test 5.0 gcd 5.0 10+0.0i) -(test (expt 3 37) gcd (expt 9 35) (expt 6 37)) -(test (expt 3 37) gcd (- (expt 9 35)) (expt 6 37)) -(test (expt 3 37) gcd (expt 9 35) (- (expt 6 37))) -(test 201 gcd (* 67 (expt 3 20)) (* 67 3)) -(test 201 gcd (* 67 3) (* 67 (expt 3 20))) -(test 201.0 gcd (* 67 (expt 3 20)) (* 67. 3)) -(test 201.0 gcd (* 67. 3) (* 67 (expt 3 20))) -(test 9.0 gcd +inf.0 9) -(test 9.0 gcd -inf.0 9) -(test 288 lcm 32 -36) -(test 12 lcm 2 3 4) -(test 1 lcm) -(test 5 lcm 5) -(test 0 lcm 123 0) -(test 30.0 lcm 5 6.0) -(test 30.0 lcm 5 6.0+0.0i) -(test 30.0 lcm 5+0.0i 6.0) -(test 0.0 lcm 123 0.0) -(test 0.0 lcm 123 -0.0) -(test (* (expt 2 37) (expt 9 35)) lcm (expt 9 35) (expt 6 37)) -(test (* (expt 2 37) (expt 9 35)) lcm (- (expt 9 35)) (expt 6 37)) -(test (* (expt 2 37) (expt 9 35)) lcm (expt 9 35) (- (expt 6 37))) - -(error-test '(gcd +nan.0)) -(error-test '(gcd 'a)) -(error-test '(gcd 'a 1)) -(error-test '(gcd 1 'a)) -(error-test '(lcm +nan.0)) -(error-test '(lcm 'a)) -(error-test '(lcm 'a 1)) -(error-test '(lcm 1 'a)) -(error-test '(gcd 1/2)) -(error-test '(gcd 3 1/2)) -(error-test '(gcd 1/2 3)) -(error-test '(lcm 1/2)) -(error-test '(lcm 3 1/2)) -(error-test '(lcm 1/2 3)) -(error-test '(gcd 1+2i)) -(error-test '(lcm 1+2i)) -(error-test '(gcd 1 1+2i)) -(error-test '(lcm 1 1+2i)) -(error-test '(gcd +nan.0 5.0)) -(error-test '(gcd 5.0 +nan.0)) -(error-test '(lcm +nan.0 5.0)) -(error-test '(lcm 5.0 +nan.0)) - -(arity-test gcd 0 -1) -(arity-test lcm 0 -1) - -(test 2 floor 5/2) -(test 3 ceiling 5/2) -(test 2 round 5/2) -(test 2 truncate 5/2) -(test -3 floor -5/2) -(test -2 ceiling -5/2) -(test -2 round -5/2) -(test -2 truncate -5/2) - -(test 1 floor 4/3) -(test 2 ceiling 4/3) -(test 1 round 4/3) -(test 1 truncate 4/3) -(test -2 floor -4/3) -(test -1 ceiling -4/3) -(test -1 round -4/3) -(test -1 truncate -4/3) - -(test 1 floor 5/3) -(test 2 ceiling 5/3) -(test 2 round 5/3) -(test 1 truncate 5/3) -(test -2 floor -5/3) -(test -1 ceiling -5/3) -(test -2 round -5/3) -(test -1 truncate -5/3) - -(test 2 floor 11/4) -(test 3 ceiling 11/4) -(test 3 round 11/4) -(test 2 truncate 11/4) -(test -3 floor -11/4) -(test -2 ceiling -11/4) -(test -3 round -11/4) -(test -2 truncate -11/4) - -(test 2 floor 9/4) -(test 3 ceiling 9/4) -(test 2 round 9/4) -(test 2 truncate 9/4) -(test -3 floor -9/4) -(test -2 ceiling -9/4) -(test -2 round -9/4) -(test -2 truncate -9/4) - -(test 2.0 floor 2.4) -(test 3.0 ceiling 2.4) -(test 2.0 round 2.4) -(test 2.0 truncate 2.4) -(test -3.0 floor -2.4) -(test -2.0 ceiling -2.4) -(test -2.0 round -2.4) -(test -2.0 truncate -2.4) - -(test 2.0 floor 2.6) -(test 3.0 ceiling 2.6) -(test 3.0 round 2.6) -(test 2.0 truncate 2.6) -(test -3.0 floor -2.6) -(test -2.0 ceiling -2.6) -(test -3.0 round -2.6) -(test -2.0 truncate -2.6) - -(test 2.0 round 2.5) -(test -2.0 round -2.5) -(test 4.0 round 3.5) -(test -4.0 round -3.5) - -(test 2.0 floor 2.6+0.0i) -(test 3.0 ceiling 2.6+0.0i) -(test 3.0 round 2.6+0.0i) -(test 2.0 truncate 2.6+0.0i) - -(define (test-fcrt-int v) - (test v floor v) - (test v ceiling v) - (test v round v) - (test v truncate v)) - -(test-fcrt-int 2) -(test-fcrt-int 2.0) -(test-fcrt-int (expt 2 100)) -(test-fcrt-int +inf.0) -(test-fcrt-int -inf.0) - -(test-nan.0 floor +nan.0) -(test-nan.0 ceiling +nan.0) -(test-nan.0 round +nan.0) -(test-nan.0 truncate +nan.0) - -(arity-test round 1 1) -(arity-test floor 1 1) -(arity-test ceiling 1 1) -(arity-test truncate 1 1) - -(error-test '(floor 2+i)) -(error-test '(ceiling 2+i)) -(error-test '(truncate 2+i)) -(error-test '(round 2+i)) - -(error-test '(floor "a")) -(error-test '(ceiling "a")) -(error-test '(truncate "a")) -(error-test '(round "a")) - -(test 5 numerator 5) -(test 5000000000000 numerator 5000000000000) -(test 5.0 numerator 5.0) -(test 5.0 numerator 5.0+0.0i) -(test 1 denominator 5) -(test 1 denominator 5000000000000) -(test 1.0 denominator 5.0) -(test 1.0 denominator 5.0+0.0i) -(test 2 numerator 2/3) -(test 3 denominator 2/3) -(test 1000.0 round (* 10000.0 (/ (numerator 0.1) (denominator 0.1)))) - -(test +inf.0 numerator +inf.0) -(test -inf.0 numerator -inf.0) -(test-nan.0 numerator +nan.0) -(test 1.0 denominator +inf.0) -(test 1.0 denominator -inf.0) -(test-nan.0 denominator +nan.0) - -(error-test '(numerator 'a)) -(error-test '(numerator 1+2i)) -(error-test '(denominator 'a)) -(error-test '(denominator 1+2i)) - -(arity-test numerator 1 1) -(arity-test denominator 1 1) - -(define (test-on-reals f filter) - (test (filter 5) f 5) - (test (filter 5.0) f 5.0) - (test (filter 1/5) f 1/5) - (test (filter (expt 2 100)) f (expt 2 100))) - -(test 1+2i make-rectangular 1 2) -(test 1.0+2.0i make-rectangular 1.0 2) -(test 1.0+2.0i make-rectangular 1.0+0.0i 2) -(test 1.0+2.0i make-rectangular 1.0 2+0.0i) -(test-nan.0 real-part (make-rectangular +nan.0 1)) -(test 1.0 imag-part (make-rectangular +nan.0 1)) -(test-nan.0 imag-part (make-rectangular 1 +nan.0)) -(test 1.0 real-part (make-rectangular 1 +nan.0)) -(test +inf.0 real-part (make-rectangular +inf.0 -inf.0)) -(test -inf.0 imag-part (make-rectangular +inf.0 -inf.0)) - -(test (make-rectangular +inf.0 -inf.0) * 1. (make-rectangular +inf.0 -inf.0)) -(test (make-rectangular +inf.0 +inf.0) * +1.0i (make-rectangular +inf.0 -inf.0)) -(test (make-rectangular -inf.0 +inf.0) * -3. (make-rectangular +inf.0 -inf.0)) -(test (make-rectangular +inf.0 -inf.0) * (make-rectangular +inf.0 -inf.0) 1.) -(test (make-rectangular +inf.0 +inf.0) * (make-rectangular +inf.0 -inf.0) +1.0i) -(test (make-rectangular -inf.0 +inf.0) * (make-rectangular +inf.0 -inf.0) -3.) -(test (make-rectangular +inf.0 -inf.0) / (make-rectangular +inf.0 -inf.0) 1.) -(test (make-rectangular -inf.0 -inf.0) / (make-rectangular +inf.0 -inf.0) +1.0i) -(test (make-rectangular -inf.0 +inf.0) / (make-rectangular +inf.0 -inf.0) -3.) - -(test-i-nan.0 * 1.+0.i (make-rectangular +inf.0 -inf.0)) -(test-i-nan.0 * 0.+1.0i (make-rectangular +inf.0 -inf.0)) -(test-i-nan.0 * -3.+0.i (make-rectangular +inf.0 -inf.0)) -(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) 1.+0.i) -(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) 0.+1.0i) -(test-i-nan.0 * (make-rectangular +inf.0 -inf.0) -3.+0.i) -(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) 1.+0.i) -(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) 0.+1.0i) -(test-i-nan.0 / (make-rectangular +inf.0 -inf.0) -3.+0.i) - -(test 1 magnitude 1) -(test 1 magnitude -1) -(test 1.0 magnitude 1.0) -(test 1.0 magnitude -1.0) -(test big-num magnitude big-num) -(test big-num magnitude (- big-num)) -(test 3/4 magnitude 3/4) -(test 3/4 magnitude -3/4) -(test 10.0 magnitude 10.0+0.0i) -(test 10.0 magnitude -10.0+0.0i) - -(test 0 angle 1) -(test 0 angle 1.0) -(test 0 angle 0.0) -(test 0 angle big-num) -(test 0 angle 3/4) -(test 0.0 angle 3+0.0i) -(test-nan.0 angle +nan.0) -(let ([pi (atan 0 -1)]) - (test pi angle -1) - (test pi angle -1.0) - (test pi angle -0.0) - (test pi angle (- big-num)) - (test pi angle -3/4) - (test pi angle -3+0.0i)) -(test -inf.0 atan 0+i) -(test -inf.0 atan 0-i) - -(error-test '(angle 'a)) -(error-test '(angle 0) exn:application:divide-by-zero?) -(error-test '(magnitude 'a)) -(arity-test angle 1 1) -(arity-test magnitude 1 1) - -(test 1 real-part 1+2i) -(test 1.0 real-part 1+2.0i) -(test 1.0 real-part 1+0.0i) -(test 1/5 real-part 1/5+2i) -(test-on-reals real-part (lambda (x) x)) -(test 2.0 imag-part 1+2.0i) -(test 0.0 imag-part 1+0.0i) -(test -0.0 imag-part 1-0.0i) -(test 1/5 imag-part 1+1/5i) -(test-on-reals imag-part (lambda (x) 0)) -(test-nan.0 real-part +nan.0) -(test 0 imag-part +nan.0) -(test 6@1 (lambda (x) x) 6.0@1.0) -(test 324.0 floor (* 100 (real-part 6@1))) -(test 50488.0 floor (* 10000 (imag-part 6@1))) -(test 1 make-polar 1 0) -(test 1.0+0.0i make-polar 1 0.0) -(test 1.0 make-polar 1.0 0) -(test 1.0+0.0i make-polar 1.0 0.0) -(test 1.0+0.0i make-polar 1.0 0.0+0.0i) -(test 1.0+0.0i make-polar 1.0+0.0i 0.0) -(let ([v (make-polar 1 1)]) - (test 5403.0 floor (* 10000 (real-part v))) - (test 84147.0 floor (* 100000 (imag-part v))) - (test 10000.0 round (* 10000.0 (magnitude v)))) -(let ([v (make-polar 1 2)]) - (test -416.0 ceiling (* 1000 (real-part v))) - (test 909.0 floor (* 1000 (imag-part v))) - (test 1.0 magnitude v) - (test 2.0 angle v)) -(test-nan.0 make-polar +nan.0 0) -(test-i-nan.0 make-polar +nan.0 1) -(test-i-nan.0 make-polar 1 +nan.0) -(test-i-nan.0 make-polar 1 +inf.0) -(test-i-nan.0 make-polar 1 -inf.0) -(test +inf.0 make-polar +inf.0 0) -(test -inf.0 make-polar -inf.0 0) -(test (make-rectangular +inf.0 +inf.0) make-polar +inf.0 (atan 1 1)) -(test (make-rectangular -inf.0 +inf.0) make-polar +inf.0 (atan 1 -1)) -(test (make-rectangular +inf.0 -inf.0) make-polar +inf.0 (atan -1 1)) -(test 785.0 floor (* 1000 (angle (make-rectangular 1 1)))) -(test 14142.0 floor (* 10000 (magnitude (make-rectangular 1 1)))) - -(error-test '(make-rectangular 1 'a)) -(error-test '(make-rectangular 'a 1)) -(error-test '(make-rectangular 1+2i 1)) -(error-test '(make-rectangular 1 1+2i)) -(arity-test make-rectangular 2 2) - -(error-test '(make-polar 1 'a)) -(error-test '(make-polar 'a 1)) -(error-test '(make-polar 1+2i 1)) -(error-test '(make-polar 1 1+2i)) -(arity-test make-polar 2 2) - -(error-test '(real-part 'a)) -(error-test '(imag-part 'a)) -(arity-test real-part 1 1) -(arity-test imag-part 1 1) - -(define (z-round c) (make-rectangular (round (real-part c)) (round (imag-part c)))) - -(test -1 * +i +i) -(test 1 * +i -i) -(test 2 * 1+i 1-i) -(test +2i * 1+i 1+i) -(test 0.5 - (+ 0.5 +i) +i) -(test 1/2 - (+ 1/2 +i) +i) -(test 1.0+0.0i - (+ 1 +0.5i) +1/2i) - -(test 1 sqrt 1) -(test 1.0 sqrt 1.0) -(test 25 sqrt 625) -(test 3/7 sqrt 9/49) -(test 0.5 sqrt 0.25) -(test +1i sqrt -1) -(test +2/3i sqrt -4/9) -(test +1.0i sqrt -1.0) -(test 1+1i sqrt +2i) -(test 2+1i sqrt 3+4i) -(test 2.0+0.0i sqrt 4+0.0i) -(test +inf.0 sqrt +inf.0) -(test (make-rectangular 0 +inf.0) sqrt -inf.0) -(test-nan.0 sqrt +nan.0) - -(test (expt 5 13) sqrt (expt 5 26)) -(test 545915034.0 round (sqrt (expt 5 25))) -(test (make-rectangular 0 (expt 5 13)) sqrt (- (expt 5 26))) -(test (make-rectangular 0 545915034.0) z-round (sqrt (- (expt 5 25)))) - -(error-test '(sqrt "a")) -(arity-test sqrt 1 1) - -(test -13/64-21/16i expt -3/4+7/8i 2) -(let ([v (expt -3/4+7/8i 2+3i)]) - (test 3826.0 floor (* 10000000 (real-part v))) - (test -137.0 ceiling (* 100000 (imag-part v)))) -(test 49.0+0.0i expt 7 2+0.0i) -(test 49.0 floor (* 10 (expt 2 2.3))) -(test 189.0 floor (* 1000 (expt 2.3 -2))) -(test 1/4 expt 2 -2) -(test 1/1125899906842624 expt 2 -50) -(test 1/1024 expt 1/2 10) -(test 1024 expt 1/2 -10) -(test 707.0 floor (* 1000 (expt 1/2 1/2))) -(test 707.0 floor (* 1000 (expt 1/2 0.5))) -(test 707.0 floor (* 1000 (expt 0.5 1/2))) -(test 100.0+173.0i z-round (* 100 (expt -8 1/3))) -(test 100.0+173.0i z-round (* 100 (expt -8.0 1/3))) -(test 101.0+171.0i z-round (* 100 (expt -8 0.33))) -(test 101.0+171.0i z-round (* 100 (expt -8.0 0.33))) -(test 108.0+29.0i z-round (* 100 (expt 1+i 1/3))) -(test 25.0-43.0i z-round (* 100 (expt -8 -1/3))) - -(test +inf.0 expt 2 +inf.0) -(test +inf.0 expt +inf.0 10) -(test 1 expt +inf.0 0) -(test 1.0 expt +inf.0 0.) -(test 0.0 expt 2 -inf.0) -(test -inf.0 expt -inf.0 11) -(test +inf.0 expt -inf.0 10) -(test 1 expt -inf.0 0) -(test 1.0 expt -inf.0 0.0) -(test 1 expt +nan.0 0) -(test 0 expt 0 10) -(test 0 expt 0 10.0) -(test 0 expt 0 +inf.0) -(test-nan.0 expt 0 +nan.0) -(test 1 expt 1 +inf.0) -(test 1 expt 1 -inf.0) -(test 1 expt 1 -nan.0) -(test 0.0 expt 0.0 10) -(test 0.0 expt 0.0 +inf.0) -(test +inf.0 expt 0.0 -5) -(test -inf.0 expt -0.0 -5) -(test +inf.0 expt 0.0 -4) -(test +inf.0 expt -0.0 -4) -(test +inf.0 expt 0.0 -4.3) -(test +inf.0 expt -0.0 -4.3) -(test +inf.0 expt 0.0 -inf.0) -(test-nan.0 expt 0.0 +nan.0) -(test 1 expt 0 0) -(test 1.0 expt 0 0.0) ; to match (expt 0 0) -(test 1.0 expt 0 -0.0) -(test 1.0 expt 0.0 0.0) -(test 1.0 expt 0.0 0.0) -(test -0.0 expt -0.0 1) -(test-nan.0 expt +nan.0 10) -(test-nan.0 expt 2 +nan.0) - -(test 0 expt 0 1+i) -(test 0 expt 0 1-i) - -(test-nan.0 expt 1.0 +inf.0) -(test-nan.0 expt 1.0 -inf.0) -(test-nan.0 expt 1.0 +nan.0) - -(test 0.0 expt 0.0 5) -(test -0.0 expt -0.0 5) -(test 0.0 expt 0.0 4) -(test 0.0 expt -0.0 4) -(test 0.0 expt 0.0 4.3) -(test 0.0 expt -0.0 4.3) - -(test 0.0 expt 0.5 +inf.0) -(test +inf.0 expt 0.5 -inf.0) -(test +inf.0 expt 1.5 +inf.0) -(test 0.0 expt 1.5 -inf.0) -(test 0.0 expt -0.5 +inf.0) -(test +inf.0 expt -0.5 -inf.0) -(test +inf.0 expt -1.5 +inf.0) -(test 0.0 expt -1.5 -inf.0) - -(error-test '(expt 0 -1) exn:application:divide-by-zero?) -(error-test '(expt 0 -1.0) exn:application:divide-by-zero?) -(error-test '(expt 0 -inf.0) exn:application:divide-by-zero?) -(error-test '(expt 0 -1+2i) exn:application:divide-by-zero?) -(error-test '(expt 0 -1.0+2i) exn:application:divide-by-zero?) -(error-test '(expt 0 0+2i) exn:application:divide-by-zero?) -(error-test '(expt 0 0.0+2i) exn:application:divide-by-zero?) -(error-test '(expt 0 -0.0+2i) exn:application:divide-by-zero?) -(error-test '(expt 0 0+0.0i) exn:application:divide-by-zero?) - -(error-test '(expt 'a 0)) -(error-test '(expt 'a 1)) -(error-test '(expt 'a 3)) -(error-test '(expt 0 'a)) -(error-test '(expt 1 'a)) -(error-test '(expt 3 'a)) - -;;;;From: fred@sce.carleton.ca (Fred J Kaudel) -;;; Modified by jaffer. -(define f3.9 (string->number "3.9")) -(define f4.0 (string->number "4.0")) -(define f-3.25 (string->number "-3.25")) -(define f.25 (string->number ".25")) -(define f4.5 (string->number "4.5")) -(define f3.5 (string->number "3.5")) -(define f0.0 (string->number "0.0")) -(define f0.8 (string->number "0.8")) -(define f1.0 (string->number "1.0")) -(newline) -(display ";testing inexact numbers; ") -(newline) -(SECTION 6 5 5) -(test #t inexact? f3.9) -(test #f exact? f3.9) -(test #t 'inexact? (inexact? (max f3.9 4))) -(test f4.0 'max (max f3.9 4)) -(test f4.0 'exact->inexact (exact->inexact 4)) - -; Should at least be close... -(test 4.0 round (log (exp 4.0))) -(test 125.0 round (* 1000 (asin (sin 0.125)))) -(test 125.0 round (* 1000 (asin (sin 0.125+0.0i)))) -(test 125.0 round (* 1000 (asin (sin 1/8)))) -(test 125.0 round (* 1000 (acos (cos 0.125)))) -(test 125.0 round (* 1000 (acos (cos 0.125+0.0i)))) -(test 125.0 round (* 1000 (acos (cos 1/8)))) -(test 785.0 round (* 1000 (atan 1 1))) -(test 785.0 round (* 1000 (atan 1.0 1.0))) -(test 785.0 round (* 1000 (atan 1.0 1.0+0.0i))) -(test 785.0 round (* 1000 (atan 1.0+0.0i 1.0))) -(test 2356.0 round (* 1000 (atan 1 -1))) -(test -785.0 round (* 1000 (atan -1 1))) -(test 785.0 round (* 1000 (atan 1))) -(test 100.0 round (* 100 (tan (atan 1)))) -(test 100.0 round (* 100 (tan (+ +0.0i (atan 1))))) -(test 0.0 atan 0.0 0) -(error-test '(atan 0 0) exn:application:divide-by-zero?) -(test 1024.0 round (expt 2.0 10.0)) -(test 1024.0 round (expt -2.0 10.0)) -(test -512.0 round (expt -2.0 9.0)) -(test 32.0 round (sqrt 1024.0)) -(test 32.0 round (sqrt 1024.0+0.0i)) - -(test 1 exp 0) -(test 1.0 exp 0.0) -(test 1.0 exp -0.0) -(test 272.0 round (* 100 (exp 1))) - -(test 0 log 1) -(test 0.0 log 1.0) -(test -inf.0 log 0.0) -(test -inf.0 log -0.0) -(error-test '(log 0) exn:application:divide-by-zero?) - -(test 1 cos 0) -(test 1.0 cos 0.0) -(test 0 sin 0) -(test 0.0 sin 0.0) -(test -0.0 sin -0.0) -(test 0 tan 0) -(test 0.0 tan 0.0) -(test -0.0 tan -0.0) - -(test 0 atan 0) -(test 0.0 atan 0.0) -(test -0.0 atan -0.0) -(test 314.0 round (* 400 (atan 1))) -(test 314.0 round (* 400 (atan 1.0))) -(test 0 asin 0) -(test 0.0 asin 0.0) -(test -0.0 asin -0.0) -(test 314.0 round (* 200 (asin 1))) -(test 314.0 round (* 200 (asin 1.0))) -(test 0 acos 1) -(test 0.0 acos 1.0) -(test 314.0 round (* 200 (acos 0))) -(test 314.0 round (* 200 (acos 0.0))) -(test 314.0 round (* 200 (acos -0.0))) - -(define (test-inf-bad f) - (test-nan.0 f +inf.0) - (test-nan.0 f -inf.0) - (test-nan.0 f +nan.0)) - -(test-inf-bad tan) -(test-inf-bad sin) -(test-inf-bad cos) -(test-inf-bad asin) -(test-inf-bad acos) - -(test 11/7 rationalize (inexact->exact (atan +inf.0 1)) 1/100) -(test -11/7 rationalize (inexact->exact (atan -inf.0 1)) 1/100) -(test 0.0 atan 1 +inf.0) -(test 22/7 rationalize (inexact->exact (atan 1 -inf.0)) 1/100) - -; Note on the following tests with atan and inf.0: -; The IEEE standard makes this decision. I think it's a bad one, -; since (limit (atan (g x) (f x))) as x -> +inf.0 is not necessarily -; (atan 1 1) when (limit (f x)) and (limit (g x)) are +inf.0. -; Perhaps IEEE makes this choice because it's easiest to compute. -(test 7/9 rationalize (inexact->exact (atan +inf.0 +inf.0)) 1/100) -(test 26/11 rationalize (inexact->exact (atan +inf.0 -inf.0)) 1/100) -(test -7/9 rationalize (inexact->exact (atan -inf.0 +inf.0)) 1/100) - -(test-nan.0 atan +nan.0) -(test-nan.0 atan 1 +nan.0) -(test-nan.0 atan +nan.0 1) - -(test -1178.+173.i z-round (* 1000 (atan -2+1i))) - -(map (lambda (f fname) - (error-test `(,fname "a")) - (arity-test f 1 1)) - (list log exp asin acos tan) - `(log exp asin acos tan)) -(error-test '(atan "a" 1)) -(error-test '(atan 2+i 1)) -(error-test '(atan "a")) -(error-test '(atan 1 "a")) -(error-test '(atan 1 2+i)) -(arity-test atan 1 2) - -(test 3166.+1960.i z-round (* 1000 (sin 1+2i))) -(test -3166.-1960.i z-round (* 1000 (sin -1-2i))) -(test 0+1175.i z-round (* 1000 (sin 0+i))) -(test -642.-1069.i z-round (* 1000 (cos 2+i))) -(test -642.-1069.i z-round (* 1000 (cos -2-i))) -(test 1543. z-round (* 1000 (cos 0+i))) -(test 272-1084.i z-round (* 1000 (tan 1-i))) -(test -272+1084.i z-round (* 1000 (tan -1+i))) - -(test 693.+3142.i z-round (* 1000 (log -2))) -(test 1571.-1317.i z-round (* 1000 (asin 2))) -(test -1571.+1317.i z-round (* 1000 (asin -2))) -(test 0+3688.i z-round (* 1000 (acos 20))) -(test 3142.-3688.i z-round (* 1000 (acos -20))) - -(define (cs2 c) (+ (* (cos c) (cos c)) (* (sin c) (sin c)))) -(test 0.0 imag-part (cs2 2+3i)) -(test 1000.0 round (* 1000 (real-part (cs2 2+3i)))) -(test 0.0 imag-part (cs2 -2+3i)) -(test 1000.0 round (* 1000 (real-part (cs2 -2+3i)))) -(test 0.0 imag-part (cs2 2-3i)) -(test 1000.0 round (* 1000 (real-part (cs2 2-3i)))) - -(test #t positive? (real-part (sqrt (- 1 (* 2+3i 2+3i))))) - -(test (- f4.0) round (- f4.5)) -(test (- f4.0) round (- f3.5)) -(test (- f4.0) round (- f3.9)) -(test f0.0 round f0.0) -(test f0.0 round f.25) -(test f1.0 round f0.8) -(test f4.0 round f3.5) -(test f4.0 round f4.5) -(let ((x (string->number "4195835.0")) - (y (string->number "3145727.0"))) - (test #t 'pentium-fdiv-bug (> f1.0 (- x (* (/ x y) y))))) - -(test (exact->inexact 1/3) rationalize .3 1/10) -(test 1/3 rationalize 3/10 1/10) -(test (exact->inexact 1/3) rationalize .3 -1/10) -(test 1/3 rationalize 3/10 -1/10) -(test 0 rationalize 3/10 4/10) -(test 0.0 rationalize .3 4/10) -(test 0.0 rationalize .3+0.0i 4/10) -(test #i1/3 rationalize .3+0.0i 1/10) - -(define (test-rat-inf v) - (define zero (if (exact? v) 0 0.0)) - - (test +inf.0 rationalize +inf.0 v) - (test -inf.0 rationalize -inf.0 v) - (test-nan.0 rationalize +nan.0 v) - - (test zero rationalize v +inf.0) - (test zero rationalize v -inf.0) - (test-nan.0 rationalize v +nan.0)) - -(let loop ([i 100]) - (unless (= i -100) - (test (/ i 100) rationalize (inexact->exact (/ i 100.0)) 1/100000) - (loop (sub1 i)))) - -(arity-test rationalize 2 2) - -(define tb - (lambda (n1 n2) - (= n1 (+ (* n2 (quotient n1 n2)) - (remainder n1 n2))))) - - -(SECTION 6 5 5) - -(test -2147483648 - 2147483648) -(test 2147483648 - -2147483648) -(test #f = -2147483648 2147483648) -(test #t = -2147483648 -2147483648) -(test #t = 2147483648 2147483648) -(test 2147483647 sub1 2147483648) -(test 2147483648 add1 2147483647) -(test 2147483648 * 1 2147483648) - -(test 437893890380859375 expt 15 15) - -(test 0 modulo -2177452800 86400) -(test 0 modulo 2177452800 -86400) -(test 0 modulo 2177452800 86400) -(test 0 modulo -2177452800 -86400) - -(test 86399 modulo -2177452801 86400) -(test -1 modulo 2177452799 -86400) -(test 1 modulo 2177452801 86400) -(test -86399 modulo -2177452799 -86400) - -(test #t 'remainder (tb 281474976710655 65535)) -(test #t 'remainder (tb 281474976710654 65535)) -(SECTION 6 5 6) -(test 281474976710655 string->number "281474976710655") -(test "281474976710655" number->string 281474976710655) -(test "-4" number->string -4 16) -(test "-e" number->string -14 16) -(test "0" number->string 0 16) -(test "30000000" number->string #x30000000 16) - - -(SECTION 6 5 6) -(test "0" number->string 0) -(test "100" number->string 100) -(test "100" number->string 256 16) -(test 256 string->number "100" 16) -(test 15 string->number "#o17") -(test 15 string->number "#o17" 10) - -(load-relative "numstrs.ss") -(let loop ([l number-table]) - (unless (null? l) - (let* ([pair (car l)] - [v (car pair)] - [v (if (or (eq? v 'X) - (symbol? v) - (eof-object? v)) - #f - v)] - [s (cadr pair)]) - (test v string->number s)) - (loop (cdr l)))) - -;; Test special inexact names in complex combinations: -(let ([parts '(+inf.0 -inf.0 +nan.0 1 0 0.0 1/2)]) - (for-each - (lambda (a) - (for-each - (lambda (b) - (let ([rect (format "~a~a~ai" - a - (if (member b '(+inf.0 -inf.0 +nan.0)) - "" - "+") - b)] - [polar (format "~a@~a" a b)]) - (test (make-rectangular a b) string->number rect) - (test (make-polar a b) string->number polar))) - parts)) - parts) - - (for-each - (lambda (a) - (let ([rect1 (format "~a+1/0i" a)] - [rect2 (format "1/0~a~ai" - (if (member a '(+inf.0 -inf.0 +nan.0)) - "" - "+") - a)] - [polar1 (format "~a@1/0" a)] - [polar2 (format "1/0@~a" a)] - [dbz-test (lambda (s) - (test 'div 'divide-by-zero - (with-handlers ([(lambda (x) - (and (exn:read? x) - (regexp-match "division by zero" - (exn-message x)))) - (lambda (x) 'div)]) - (read (open-input-string s)))))]) - (test #f string->number rect1) - (test #f string->number rect2) - (test #f string->number polar1) - (test #f string->number polar2) - (dbz-test rect1) - (dbz-test rect2) - (dbz-test polar1) - (dbz-test polar2))) - parts)) - -(test #f string->number "88" 7) -(test #f string->number "") -(test #f string->number " 1") -(test #f string->number ".") -(test #f string->number "#4@#i5") -(test #f string->number "190888 qwerqwerq") -(test #t symbol? '1/x) -(test #t symbol? '1+ei) -(test #t symbol? '|1/0|) - -(arity-test string->number 1 2) -(arity-test number->string 1 2) - -(error-test '(number->string 'a)) -(error-test '(number->string 1 'a)) -(error-test '(number->string 'a 10)) -(error-test '(number->string 1.8 8) exn:application:mismatch?) -(error-test '(number->string 1 -1)) - -(error-test '(string->number 'a)) -(error-test '(string->number 'a 'a)) -(error-test '(string->number "12" -1)) -(error-test '(string->number "12" 17)) -(error-test '(string->number "1" "1")) -(error-test '(string->number 1 1)) - -(test #t andmap (lambda (x) (and (>= x 0) (< x 10))) (map random '(10 10 10 10))) -(test (void) random-seed 5) -(test (begin (random-seed 23) (list (random 10) (random 20) (random 30))) - 'random-seed-same - (begin (random-seed 23) (list (random 10) (random 20) (random 30)))) -(arity-test random-seed 1 1) -(arity-test random 1 1) -(error-test '(random-seed "apple")) -(error-test '(random-seed 4.5)) -(error-test '(random-seed -1)) -(error-test '(random-seed (expt 2 31))) -(error-test '(random-seed big-num)) -(error-test '(random "apple")) -(error-test '(random 0)) -(error-test '(random -6)) -(error-test '(random (expt 2 31))) -(error-test '(random big-num)) - -(random-seed 101) -(define x (list (random 10) (random 20) (random 30))) -(random-seed 101) -(parameterize ([current-pseudo-random-generator (make-pseudo-random-generator)]) - (random 10) - (random 10)) -(test x 'generator-preserved (list (random 10) (random 20) (random 30))) -(random-seed 101) -(thread-wait (thread (lambda () - (random 10) - (random 10)))) -(test #f 'generator-not-preserved (equal? x (list (random 10) (random 20) (random 30)))) -(test #t pseudo-random-generator? (make-pseudo-random-generator)) -(test #t pseudo-random-generator? (current-pseudo-random-generator)) -(test #f pseudo-random-generator? 10) -(arity-test pseudo-random-generator? 1 1) -(arity-test make-pseudo-random-generator 0 0) -(arity-test current-pseudo-random-generator 0 1) -(error-test '(current-pseudo-random-generator 10)) - -(report-errs) diff --git a/collects/tests/mzscheme/numstrs.ss b/collects/tests/mzscheme/numstrs.ss deleted file mode 100644 index a337b9d1..00000000 --- a/collects/tests/mzscheme/numstrs.ss +++ /dev/null @@ -1,168 +0,0 @@ - -(define number-table - `((,(+ 1/2 +i) "1/2+i") - (100 "100") - (0.1 ".1") - (1/20000 "#e1/2e-4") - (10.0 "1e1") - (10.0 "1E1") - (10.0 "1s1") - (10.0 "1S1") - (10.0 "1f1") - (10.0 "1F1") - (10.0 "1l1") - (10.0 "1L1") - (10.0 "1d1") - (10.0 "1D1") - (0.0 "0e13") - (0.0 "#i0") - (-0.0 "#i-0") - (+inf.0 ".3e2666666666") - (+inf.0 "+INF.0") - (+nan.0 "+NaN.0") - (+inf.0 "1e500") ; Check simple overflows - (-inf.0 "-1e500") - (0.0 "1e-500") - (-0.0 "-1e-500") - (+inf.0 "1#e500") - (-inf.0 "-1#e500") - (0.0 "1#e-500") - (-0.0 "-1#e-500") - (+inf.0 "1e10000000000000000000000000000000") ; Check avoidance of extreme computations - (-inf.0 "-1e10000000000000000000000000000000") - (+inf.0 "1#e10000000000000000000000000000000") - (-inf.0 "-1#e10000000000000000000000000000000") - (+0.0 "1e-10000000000000000000000000000000") - (-0.0 "-1e-10000000000000000000000000000000") - (+0.0 "1#e-10000000000000000000000000000000") - (-0.0 "-1#e-10000000000000000000000000000000") - (10.0 "1#") - (10.0 "1#e0") - (10.0 "1####e-3") - (10.0 "1#.e0") - (10.0 "10.#e0") - (10.0 "10.e0") - (10.0 "1#.e0") - (10.0 "10.0#e0") - (10.0 "1#.##e0") - (10 "#e1#") - (10 "#e1#e0") - (10 "#e1#.e0") - (5e-5 "1/2e-4") - (5e-5 "#i1/2e-4") - (0.5 "#i1/2") - (1/2 "#e1/2") - (0.5 "#i0.5") - (1/2 "#e0.5") - (1/20 "#e0.5e-1") - (1/20 "#e0.005e1") - (1.0+0.5i "1+0.5i") - (1/2 "1/2@0") - (-1/2 "-1/2@0") - (1/2 "1/2@-0") - (0 "#b#e0") - (0.0 "#b#i0") - (4.0 "#b1e10") - (4 "#b#e1e10") - (1/10+1/5i "#e0.1+0.2i") - (0.0+80.0i "#i+8#i") - (521976 "#x7f6f8") - (1+8i "#b#e1+1#e10i") - (1.125 "#x1.2") - (1.1640625 "#x1.2a") - (1.1640625 "#x1.2a####") - (10.0 "#xa.") - (10.25 "#xa.4") - (160.0 "#xa#.") - (416.0 "#x1a#.") - (2816.0 "#xb##.##") - - (#f "d") - (D "D") - (#f "i") - (I "I") - (#f "3i") - (3I "3I") - (#f "33i") - (33I "33I") - (#f "3.3i") - (3.3I "3.3I") - (#f "e") - (#f "e1") - (#f "e1") - (#f "-") - (#f "+") - (X "#e-") - (X "#e+") - (X "#i-") - (X "#i+") - (#f "+.") - (X "#e+.") - (#f "/") - (#f "+1+1") - (#f "+1/+1") - (#f "1//2") - (#f "mod//") - (#f "-1.0/2") - (#f "/2") - (#f "2..") - (#f ".2.") - (X "#e2..") - (X "#e.2.") - (#f "1#.0e4") - (#f "1#0e4") - (#f "1#0.e4") - (#f "1##.##0e4") - (#f "2i") - (#f "/2i") - (#f "2@2i") - (#f "2@@2") - (#f "-2@-+2") - (#f "1/1-e4") - (#f "1.-2") - (#f "--1") - (#f "-+1") - (#f "-1+3-4") - (X "#xg") - (X "#xa#a") - (X "#x12.a#b") - (X "#e1.-2") - (X "#b#b0") - (X "#b#o0") - (X "#i#i0") - (X "#e#e0") - (X "#i8#i") - (X "#i4@#i5") - (X "#i4+#d6i") - (X "#i4+#d6") - (#f "4ef5") - (X "#e4ef5") - (X "1/0") - (X "5+1/0i") - (X "1/0+5i") - (X "5@1/0") - (X "1/0@5") - (X "1/0e2") - (#f "1/0+hi") - (#f "x+1/0i") - (+nan.0+1i "+nan.0+1i") - (1+nan.0i "1+nan.0i") - (#f "1++nan.0i") - (0.5+nan.0i "1/2+nan.0i") - (1+inf.0i "1+inf.0i") - (1-inf.0i "1-inf.0i") - (-inf.0-nan.0i "-inf.0-nan.0i") - (#f "1++inf.0i") - (+nan.0@1 "+nan.0@1") - (+inf.0@1 "+inf.0@1") - (#f "+inf.0@1@1") - (1@+inf.0 "1@+inf.0") - (1@+inf.0 "1/1@+inf.0") - (+inf.0@1 "+inf.0@1/1") - (#f "+inf.0@3@0") - (X "1/0+inf.0i") - (X "+inf.0+1/0i") - (X "1/0@+inf.0") - (X "+inf.0@1/0") - (#f "1e1/0") - (#f "011111122222222223333333333444444x"))) diff --git a/collects/tests/mzscheme/object.ss b/collects/tests/mzscheme/object.ss deleted file mode 100644 index 2e0fc57b..00000000 --- a/collects/tests/mzscheme/object.ss +++ /dev/null @@ -1,651 +0,0 @@ - -; Test MzScheme's object system - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'OBJECT) - -(define (test-class* cl* renames) - (syntax-test `(,cl*)) - (syntax-test `(,cl* ,@renames . x)) - (syntax-test `(,cl* ,@renames 0)) - (syntax-test `(,cl* ,@renames object% . x)) - (syntax-test `(,cl* ,@renames object% 0)) - (syntax-test `(,cl* ,@renames object% x)) - (syntax-test `(,cl* ,@renames object% ())) - (syntax-test `(,cl* ,@renames object% () (0) x)) - (syntax-test `(,cl* ,@renames object% () 0)) - (syntax-test `(,cl* ,@renames object% () . x)) - (syntax-test `(,cl* ,@renames object% () () . x)) - (syntax-test `(,cl* ,@renames object% () () x)) - (syntax-test `(,cl* ,@renames object% () () public)) - (syntax-test `(,cl* ,@renames object% () () (x))) - (syntax-test `(,cl* ,@renames object% () (x) ())) - - (let () - (define (try-dotted cl) - (syntax-test `(,cl* ,@renames object% () () (,cl . x)))) - - (map try-dotted '(public override private inherit rename - inherit-from rename-from - sequence))) - - (let () - (define (try-defn-kind cl) - (syntax-test `(,cl* ,@renames object% () () (,cl 8))) - (syntax-test `(,cl* ,@renames object% () () (,cl [8 9]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [(x) 9]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [(x y x) 9]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [x . 1]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [x 1 . 3]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [x 1 3])))) - - (try-defn-kind 'public) - (try-defn-kind 'override) - (try-defn-kind 'private)) - - (let () - (define (try-defn-rename-kind cl) - (syntax-test `(,cl* ,@renames object% () () (,cl [((x) y) 9]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [(x (y)) 9]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [(x . y) 9]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [(x 1) 9]))) - (syntax-test `(,cl* ,@renames object% () () (,cl [(1 x) 9])))) - (try-defn-rename-kind 'public) - (try-defn-rename-kind 'override)) - - (let () - (define (try-ref-kind cl) - (syntax-test `(,cl* ,@renames object% () () (,cl 8))) - (syntax-test `(,cl* ,@renames object% () () (,cl x 8))) - (syntax-test `(,cl* ,@renames object% () () (,cl (x . y)))) - (syntax-test `(,cl* ,@renames object% () () (,cl (x y z))))) - - (map try-ref-kind '(inherit rename share))) - (error-test `(,cl* ,@renames object% () () (inherit x)) exn:object?) - (error-test `(,cl* ,@renames object% () () (inherit (x y))) exn:object?) - (error-test `(,cl* ,@renames object% () () (override [x void])) exn:object?) - (error-test `(,cl* ,@renames object% () () (override [(x y) void])) exn:object?) - (syntax-test `(,cl* ,@renames object% () () (inherit (x y z)))) - (syntax-test `(,cl* ,@renames object% () () (inherit (x 5)))) - (syntax-test `(,cl* ,@renames object% () () (inherit (x)))) - (syntax-test `(,cl* ,@renames object% () () (rename x))) - (syntax-test `(,cl* ,@renames object% () () (rename (x)))) - (syntax-test `(,cl* ,@renames object% () () (rename ((x) y)))) - (syntax-test `(,cl* ,@renames object% () () (rename ((x y) y)))) - (syntax-test `(,cl* ,@renames object% () () (rename ((1) y)))) - - (syntax-test `(,cl* ,@renames object% () () (inherit x) (sequence (set! x 5)))) - (syntax-test `(,cl* ,@renames object% () () (rename [x y]) (sequence (set! x 5)))) - - (syntax-test `(,cl* ,@renames object% () () (sequence 1 . 2))) - - (syntax-test `(,cl* ,@renames object% () () (public [x 7] [x 9]))) - (syntax-test `(,cl* ,@renames object% () (x) (public [x 7]))) - (syntax-test `(,cl* ,@renames object% () (x) (public [(x w) 7]))) - (syntax-test `(,cl* ,@renames object% () () (public [(x y) 7] [(z y) 9]))) - (syntax-test `(,cl* ,@renames object% () () (public [(x y) 7] [(x z) 9]))) - - (syntax-test `(,cl* ,@renames object% a ())) - (syntax-test `(,cl* ,@renames object% (1 . a) ()))) - -(test-class* 'class* ()) -(test-class* 'class*/names '((this super))) - -(syntax-test `(class*/names 8 object% () () ())) -(syntax-test `(class*/names () object% () ())) -(syntax-test `(class*/names (8) object% () ())) -(syntax-test `(class*/names (this . 8) object% () ())) -(syntax-test `(class*/names (this 8) object% () ())) -(syntax-test `(class*/names (this super-init . 8) object% () ())) -(syntax-test `(class*/names (this super-init 8) object% () ())) - -(test #t class? (class* object% () ())) -(test #t class? (class* object% () ())) -(test #t class? (class* object% () x)) -(test #t class? (class* object% () () (public))) -(test #t class? (class* object% () () (public sequence))) -(test #t class? (class* object% () (x) (public [(y x) 9]))) -(test #t class? (class*/names (this super-init) object% () () (public))) - -(define c (class object% () (public x))) -(error-test `(class c () (public x)) exn:object?) -(error-test `(class c () (public ([y x] 5))) exn:object?) -(error-test `(class c () (override ([x y] 5))) exn:object?) - -(syntax-test `(interface)) -(syntax-test `(interface . x)) -(syntax-test `(interface 8)) -(syntax-test `(interface () 8)) -(syntax-test `(interface () x . y)) -(syntax-test `(interface () x 8)) -(syntax-test `(interface () x x)) -(error-test `(interface (8) x) exn:object?) - -(error-test `(interface ((class->interface (class object% ())) - (class->interface (class object% ())))) - exn:object?) - -(error-test `(interface ((interface () x)) x) exn:object?) -(error-test `(interface ((interface ((interface () x)) y)) x) exn:object?) -(test #t interface? (let ([i (interface () x)] - [j (interface () x)]) - (interface (i j) y))) -(error-test `(let ([i (interface () x)] - [j (interface () x)]) - (interface (i j) x)) - exn:object?) -(error-test `(interface ((class->interface (class object% () (public w)))) w) - exn:object?) - -(test #t interface? (interface ())) -(test #t interface? (interface () x)) -(test #f interface? (class* object% () ())) - -(define i0.1 (interface () x y)) -(define i0.2 (interface () y c d)) -(define i1 (interface (i0.1 i0.2) e)) -(define ix (interface () x y)) - -(test #t interface-extension? i1 i0.1) -(test #t interface-extension? i1 i0.2) -(test #f interface-extension? i0.1 i1) -(test #f interface-extension? i0.2 i1) -(test #f interface-extension? i0.2 i0.1) -(test #f interface-extension? i0.1 i0.2) - -(error-test '(let [(bad (class* object% (i0.1) ()))] bad) exn:object?) -(test #t class? (class* object% (i0.1) () (public x y))) -(error-test '(let ([cl (class* object% (i0.1 i0.2) () (public x y c))]) cl) exn:object?) -(error-test '(class* object% (i1) () (public x y c)) exn:object?) -(test #t class? (class* object% (i0.1 i0.1) () (public x y c d))) -(error-test '(class* object% (i1) () (public x y c d)) exn:object?) -(test #t class? (class* object% (i1) () (public x y c d e))) - -; No initialization: -(define no-init-c% (class* object% () ())) -(error-test '(make-object no-init-c%) exn:object?) - -(define c1 - (let ((v 10)) - (class* object% (i1) (in [in-2 'banana] . in-rest) - (public (x 1) (y 2)) - (private (a in) (b3 3)) - (public (b1 2) (b2 2) (e 0)) - (public (c 3) (d 7) - (f-1-a (lambda () a)) - (f-1-b1 (lambda () b1)) - (f-1-b2 (lambda () b2)) - (f-1-c (lambda () c)) - (f-1-v (lambda () v)) - (f-1-x (lambda () x)) - (f-1-top-a (lambda () (ivar this a))) - (f-1-other-e (lambda (o) (ivar o e))) - (f-1-set-b2 (lambda (v) (set! b2 v) b2)) - (f-1-in-2 (lambda () in-2)) - (f-1-in-rest (lambda () in-rest))) - (sequence - (set! e in) - (super-init))))) - -(test #t implementation? c1 i0.1) -(test #t implementation? c1 i0.2) -(test #t implementation? c1 (class->interface c1)) -(test #t implementation? c1 i1) -(test #f implementation? c1 ix) - -(test #t implementation? object% (class->interface object%)) -(test #t implementation? c1 (class->interface c1)) -(test #t implementation? (class c1 ()) (class->interface c1)) -(let ([i (interface ((class->interface c1)))]) - (test #f implementation? c1 i) - (test #t implementation? (class* c1 (i) ()) i)) - -(define o1 (make-object c1 0 'apple "first" "last")) - -(define c2 - (let ((v 20)) - (class c1 () - (inherit b2 (sup-set-b2 f-1-set-b2)) - (rename (also-e e) - (also-b2 b2)) - (override (b1 5) (c 6)) - (public (a 4) - (f-2-a (lambda () a)) - (f-2-b1 (lambda () b1)) - (f-2-b2 (lambda () b2)) - (f-2-also-b2 (lambda () also-b2)) - (f-2-c (lambda () c)) - ((i-f-2-v f-2-v) (lambda () v)) - (f-2-v-copy (lambda () (i-f-2-v))) - (f-2-set-b2 (lambda (v) (sup-set-b2 v)))) - (private (y 3)) - (sequence - (super-init 1))))) - -(test #t implementation? c2 i0.1) -(test #t implementation? c2 i0.2) -(test #t implementation? c2 i1) -(test #f implementation? c2 ix) -(test #t implementation? c2 (class->interface c2)) -(test #t implementation? c2 (class->interface c1)) -(test #f implementation? c1 (class->interface c2)) - -(test #t interface-extension? (class->interface c2) (class->interface object%)) -(test #t interface-extension? (class->interface c2) (class->interface c1)) -(test #t interface-extension? (class->interface c2) (class->interface c2)) -(test #f interface-extension? (class->interface c1) (class->interface c2)) -(test #t interface-extension? (class->interface c2) i0.1) -(test #f interface-extension? i0.1 (class->interface c2)) - -(define o2 (make-object c2)) - -(define c2.1 - (class*/names (this c2-init) c2 () () - (sequence - (c2-init)))) - -(define o2.1 (make-object c2.1)) - -(test #t interface? (interface ((class->interface c2) - (class->interface c2.1)))) - -(define c3 - (class* object% () () - (public (x 6) (z 7) (b2 8) - (f-3-b2 (lambda () b2))) - (sequence (super-init)))) - -(define o3 (make-object c3)) - -(define c6 - (class object% (x-x) - (public - [(i-a x-a) (lambda () 'x-a)] - [(x-a i-a) (lambda () 'i-a)] - [(i-x x-x) (lambda () 'x-x)] - [x-a-copy (lambda () (i-a))] - [i-a-copy (lambda () (x-a))]) - (sequence (super-init)))) - -(define o6 (make-object c6 'bad)) - -(define c7 - (class*/names (self super-init) object% () () - (public - [get-self (lambda () self)]) - (sequence (super-init)))) - -(define o7 (make-object c7)) - -(define display-test - (lambda (p v) - (printf "Should be ~s: ~s ~a~n" - p v (if (equal? p v) - "" - "ERROR")))) - -(define ivar? exn:object?) - -(test #t is-a? o1 c1) -(test #t is-a? o1 i1) -(test #t is-a? o1 (class->interface c1)) -(test #f is-a? o1 (interface ((class->interface c1)))) -(test #t is-a? o2 c1) -(test #t is-a? o2 i1) -(test #f is-a? o1 c2) -(test #f is-a? o1 (class->interface c2)) -(test #t is-a? o2 c2) -(test #t is-a? o2.1 c1) -(test #f is-a? o1 c3) -(test #f is-a? o2 c3) -(test #f is-a? o1 ix) -(test #f is-a? o2 ix) -(test #f is-a? o3 i1) -(test #f is-a? i1 i1) -(test #t subclass? c2 c1) -(test #t subclass? c2.1 c1) -(test #f subclass? c1 c2) -(test #f subclass? c1 c3) -(test #f subclass? i1 c3) -(test #t ivar-in-interface? 'f-1-a (class->interface c1)) -(test #t ivar-in-interface? 'f-1-a (class->interface c2)) -(test #f ivar-in-interface? 'f-2-a (class->interface c1)) -(test #t ivar-in-interface? 'f-2-a (class->interface c2)) -(test #t ivar-in-interface? 'x i0.1) -(test #t ivar-in-interface? 'x i1) -(test #f ivar-in-interface? 'x i0.2) -(test #f ivar-in-interface? 'c i0.1) -(test #t ivar-in-interface? 'c i0.2) -(test #t ivar-in-interface? 'c i1) -(test #f ivar-in-interface? 'zzz i1) -(test #t ivar-in-interface? 'f-1-a (class->interface c2)) -(test #t ivar-in-interface? 'f-1-a (interface ((class->interface c2)) one-more-method)) -(test #f ivar-in-interface? 'f-2-a (class->interface c1)) - -(error-test '(is-a? o1 o1)) -(error-test '(subclass? o1 o1)) -(error-test '(subclass? o1 i1)) -(error-test '(implementation? o1 o1)) -(error-test '(implementation? o1 c1)) -(error-test '(ivar-in-interface? 0 i1)) -(error-test '(ivar-in-interface? 'a o1)) -(error-test '(ivar-in-interface? 'a c1)) -(error-test '(ivar-in-interface? 'a o1)) - -(define (test/list l1 l2) - (test #t 'ivar-list (and (= (length l1) - (length l2)) - (andmap (lambda (i) (member i l2)) - l1) - #t))) - -(test/list '(hi there) - (interface->ivar-names - (interface () hi there))) -(test/list '(hi too mee there) - (interface->ivar-names - (interface ((interface () hi there)) mee too))) -(test/list '(hi too mee z y there) - (interface->ivar-names - (interface ((interface ((class->interface - (class object% () - (public y z) - (private nono)))) - hi there)) - mee too))) - - -(test 0 class-initialization-arity object%) -(test #t arity-at-least? (class-initialization-arity c1)) -(test 1 arity-at-least-value (class-initialization-arity c1)) -(test 0 class-initialization-arity c2) - -(test '(1 2) class-initialization-arity (class object% (a [b 2]))) - -(arity-test object? 1 1) -(arity-test class? 1 1) -(arity-test interface? 1 1) -(arity-test is-a? 2 2) -(arity-test subclass? 2 2) -(arity-test interface-extension? 2 2) -(arity-test ivar-in-interface? 2 2) -(arity-test class-initialization-arity 1 1) - -(arity-test ivar/proc 2 2) -(arity-test make-generic/proc 2 2) - -(error-test '(ivar o1 a) ivar?) -(test 4 ivar/proc o2 'a) - -(define (ivar-tests -ivar xtra-ok?) - (syntax-test `(,-ivar)) - (syntax-test `(,-ivar 7)) - (syntax-test `(,-ivar 7 8)) - (syntax-test `(,-ivar 7 (x))) - (syntax-test `(,-ivar 7 8 9)) - (unless xtra-ok? - (syntax-test `(,-ivar 7 x 9)))) -(ivar-tests 'ivar #f) -(ivar-tests 'send #t) -(ivar-tests 'make-generic #f) - -(test 0 'send (send o1 f-1-a)) -(test 1 'send (send o2 f-1-a)) -(test 4 'send (send o2 f-2-a)) - -(test 'apple 'send (send o1 f-1-in-2)) -(test 'banana 'send (send o2 f-1-in-2)) -(test '("first" "last") 'send (send o1 f-1-in-rest)) -(test '() 'send (send o2 f-1-in-rest)) - -(error-test '(send o1 f-1-top-a) ivar?) -(test 4 'send (send o2 f-1-top-a)) - -(test 5 ivar/proc o2 'b1) - -(test 2 'send (send o1 f-1-b1)) -(test 2 'send (send o1 f-1-b2)) -(test 5 'send (send o2 f-1-b1)) -(test 2 'send (send o2 f-1-b2)) -(test 5 'send (send o2 f-2-b1)) -(test 2 'send (send o2 f-2-b2)) -(test 2 'send (send o2 f-2-also-b2)) - -(test 3 ivar/proc o1 'c) -(test 6 ivar/proc o2 'c) - -(test 3 'send (send o1 f-1-c)) -(test 6 'send (send o2 f-1-c)) -(test 6 'send (send o2 f-2-c)) - -(test 7 ivar/proc o1 'd) -(test 7 ivar/proc o2 'd) - -(test 10 'send (send o1 f-1-v)) -(test 10 'send (send o2 f-1-v)) -(test 20 'send (send o2 f-2-v)) -(test 20 'send (send o2 f-2-v-copy)) - -(error-test '(ivar o2 i-f-2-v) ivar?) - -(test 0 'send (send o1 f-1-other-e o1)) -(test 1 'send (send o1 f-1-other-e o2)) - -(test 2 ivar/proc o2 'y) - -(test 3 'send (send o2 f-2-set-b2 3)) -(test 3 'send (send o2 f-2-also-b2)) - -(test 'i-a 'send (send o6 i-a)) -(test 'x-a 'send (send o6 x-a)) -(test 'i-a 'send (send o6 i-a-copy)) -(test 'x-a 'send (send o6 x-a-copy)) -(test 'x-x 'send (send o6 x-x)) - -(test #t eq? o7 (send o7 get-self)) - -(define g1 (make-generic c1 x)) -(test 1 g1 o1) -(test 1 g1 o2) -(arity-test g1 1 1) - -(error-test '(make-generic c1 www) exn:object?) - -(define g2 (make-generic c2 x)) -(test 1 g2 o2) - -(define g0 (make-generic i0.1 x)) -(test 1 g0 o1) -(test 1 g0 o2) -(arity-test g0 1 1) -(test 'hi g0 (make-object (class* object% (i0.1) () - (public [x 'hi][y 'bye]) - (sequence (super-init))))) - -(error-test '(make-generic i0.1 www) exn:object?) - -(error-test '(g2 o1) exn:object?) -(error-test '(g0 o3) exn:object?) - -(error-test '(class* 7 () ()) exn:object?) -(error-test '(class* null () ()) exn:object?) -(error-test '(let ([c (class* 7 () ())]) c) exn:object?) -(error-test '(class* object% (i1 7) ()) exn:object?) -(error-test '(let ([c (class* object% (i1 7) ())]) c) exn:object?) -(error-test '(interface (8) x) exn:object?) -(error-test '(let ([i (interface (8) x)]) i) exn:object?) -(error-test '(interface (i1 8) x) exn:object?) -(error-test '(make-generic c2 not-there) exn:object?) - -(error-test '(make-object (class* c1 () ())) exn:object?) -(error-test '(make-object (let ([c (class* c1 () ())]) c)) exn:object?) - -(error-test '(make-object - (class* c2 () () (sequence (super-init) (super-init)))) - exn:object?) -(error-test '(make-object - (let ([c (class* c2 () () (sequence (super-init) (super-init)))]) c)) - exn:object?) - -(error-test '(make-object (class object% (x))) exn:application:arity?) -(error-test '(make-object (let ([c (class object% (x))]) c)) exn:application:arity?) - - -(define c100 - (let loop ([n 99][c (class c1 args (public [z -1]) (sequence (apply super-init args)))]) - (if (zero? n) - c - (loop (sub1 n) (class c args - (override (z n)) - (sequence - (apply super-init args))))))) - -(define o100 (make-object c100 100)) -(test 100 'send (send o100 f-1-a)) -(test 1 'ivar (ivar o100 z)) - -(test 5 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init)))) g-x)) -(test 8 'init (let ([g-x 8]) (make-object (class* object% () ([x (set! g-x 5)]) (sequence (super-init))) 0) g-x)) - -(test (letrec ([x x]) x) 'init (send (make-object - (class* object% () ([x y] [y x]) - (public (f (lambda () x))) - (sequence (super-init)))) - f)) - -(define inh-test-expr - (lambda (super derive-pre? rename? override? override-pre?) - (let* ([order - (lambda (pre? a b) - (if pre? - (list a b) - (list b a)))] - [base-class - `(class ,(if super - super - '(class object% (n) - (public [name (lambda () n)]) - (sequence (super-init)))) - () - ,(if (not rename?) - '(inherit name) - '(rename [super-name name])) - ,@(order - derive-pre? - `(public [w ,(if rename? 'super-name 'name)]) - '(sequence (super-init 'tester))))]) - `(ivar - (make-object - ,(if override? - `(class ,base-class () - ,@(order - override-pre? - '(sequence (super-init)) - '(override [name (lambda () 'o-tester)]))) - base-class)) - w)))) - -(define (do-override-tests super) - (define (eval-test v e) - (teval `(test ,v (quote, e) - (let ([v ,e]) - (if (procedure? v) - (v) - v))))) - - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f #f #f)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #f #t #t)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #f #f #t #t)) - - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #f #f)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #t #f)) - (eval-test '(letrec ([x x]) x) (inh-test-expr super #t #t #t #t)) - - (eval-test ''tester (inh-test-expr super #f #f #f #f)) - (eval-test ''o-tester (inh-test-expr super #t #f #t #f)) - (eval-test ''o-tester (inh-test-expr super #f #f #t #f)) - - (eval-test ''tester (inh-test-expr super #f #t #f #f)) - (eval-test ''tester (inh-test-expr super #f #t #t #t)) - (eval-test ''tester (inh-test-expr super #f #t #t #f))) - -(do-override-tests #f) - -(when (defined? 'primclass%) - (error-test '(make-object primclass%) exn:application:arity?) - (error-test '(make-object primsubclass%) exn:application:arity?) - - (let () - (define o (make-object primclass% 'tester)) - (arity-test (ivar o name) 0 0) - (test 'tester (ivar o name)) - (test "primclass%" (ivar o class-name)) - - (let () - (define o2 (make-object primsubclass% 'tester)) - (arity-test (ivar o2 name) 0 0) - (arity-test (ivar o2 detail) 0 0) - (test 'tester (ivar o2 name)) - (test #f (ivar o2 detail)) - (test "primsubclass%" (ivar o2 class-name)) - - (do-override-tests 'primclass%) - (do-override-tests 'primsubclass%) - - (let () - (define name-g (make-generic primclass% name)) - (define class-name-g (make-generic primclass% class-name)) - - (define sub-name-g (make-generic primsubclass% name)) - (define sub-class-name-g (make-generic primsubclass% class-name)) - (define sub-detail-g (make-generic primsubclass% detail)) - - (test 'tester (name-g o)) - (test "primclass%" (class-name-g o)) - - (test 'tester (name-g o2)) - (test "primsubclass%" (class-name-g o2)) - (test 'tester (sub-name-g o2)) - (test "primsubclass%" (sub-class-name-g o2)) - (test #f (sub-detail-g o2)) - - (let () - (define c% - (class primsubclass% () - (inherit name detail class-name) - (sequence (super-init 'example)) - (public - [n name] - [d detail] - [c class-name]))) - - (define o3 (make-object c%)) - (test 'example (ivar o3 n)) - (test #f (ivar o3 d)) - (test "primsubclass%" (ivar o3 c)) - (test 'example (ivar o3 name)) - (test #f (ivar o3 detail)) - (test "primsubclass%" (ivar o3 class-name)) - - (test 'example (name-g o3)) - (test "primsubclass%" (class-name-g o3)) - (test 'example (sub-name-g o3)) - (test "primsubclass%" (sub-class-name-g o3)) - (test #f (sub-detail-g o3))))))) - - -; Test for override/rename order -(define bsc (class object% () - (public [x (lambda () 10)]) - (sequence (super-init)))) -(define orc (class bsc () - (public [y (lambda () (super-x))]) - (override [x (lambda () 20)]) - (rename [super-x x]) - (sequence (super-init)))) -(test 10 (ivar (make-object orc) y)) - -(report-errs) - diff --git a/collects/tests/mzscheme/oe.ss b/collects/tests/mzscheme/oe.ss deleted file mode 100644 index b2b17406..00000000 --- a/collects/tests/mzscheme/oe.ss +++ /dev/null @@ -1,42 +0,0 @@ -(define-values (odd) (lambda (x) (if (zero? x) #f (even (- x 1))))) -(define-values (even) (lambda (x) (if (zero? x) #t (odd (- x 1))))) - -(define-values (odd2) - (letrec ([even (lambda (x) (if (zero? x) #t (odd (- x 1))))] - [odd (lambda (x) (if (zero? x) #f (even (- x 1))))]) - odd)) - -(define-values (odd3) - (let ([test (lambda (base other) - (lambda (x) (if (zero? x) base ((other) (- x 1)))))]) - (letrec ([odd (test #f (lambda () even))] - [even (test #t (lambda () odd))]) - odd))) - -(define-values (fib) - (lambda (n) - (if (<= n 1) - 1 - (+ (fib (- n 1)) (fib (- n 2)))))) - -(define-values (mutate) - (lambda (n) - (let loop () - (unless (zero? n) - (set! n (sub1 n)) - (loop))))) - -(define-values (mutate-evil) - (lambda (n) - (let loop ([n n]) - (unless (zero? n) - (set! n (sub1 n)) - (loop n))))) - -(define-values (c-loop) - (let-values ([(a b c d e f g) (values 1 2 3 4 5 6 7)]) - (lambda (n) - (let loop ([n n]) - (if (zero? n) - (+ a b c d e f g) - (loop (sub1 n))))))) diff --git a/collects/tests/mzscheme/oee.ss b/collects/tests/mzscheme/oee.ss deleted file mode 100644 index d7e70adf..00000000 --- a/collects/tests/mzscheme/oee.ss +++ /dev/null @@ -1,45 +0,0 @@ - -; Test the oe extension - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(define b1 (class object% () (public [z1 7][z2 8]) (sequence (super-init)))) -(define b3 (class object% () (public [z1 13][z2 14]) (sequence (super-init)))) - -(define i1 (mktinterface (interface () z1))) -(define i3 (mktinterface (interface () z2))) - -(define c1 (mktclass b1 i1)) -(define c3 (mktclass b3 i3)) - -(define o1 (make-object c1 1 2)) -(define o2 (make-object c1 3 4)) -(define o3 (make-object c3 5 6)) - -(test 5 'oee (send o1 get-y)) -(test 5 'oee (send o2 get-y)) -(test 5 'oee (send o3 get-y)) - -(test 7 'oee (send o1 get-z1)) -(test 7 'oee (send o2 get-z1)) -(test 13 'oee (send o3 get-z1)) - -(test 8 'oee (send o1 get-z2)) -(test 8 'oee (send o2 get-z2)) -(test 14 'oee (send o3 get-z2)) - -(test 1 'oee (send o1 get-x1)) -(test 3 'oee (send o2 get-x1)) -(test 5 'oee (send o3 get-x1)) - -(test 2 'oee (send o1 get-x2)) -(test 4 'oee (send o2 get-x2)) -(test 6 'oee (send o3 get-x2)) - -(error-test '(mktinterface 0) exn:object:interface-type?) -(error-test '(mktclass 0 i1) exn:object:class-type?) -(error-test '(mktclass b1 0) exn:object:interface-type?) -(error-test '(mktclass b1 (interface () not-there)) exn:object:implement?) - -(report-errs) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss deleted file mode 100644 index 3a54a747..00000000 --- a/collects/tests/mzscheme/optimize.ss +++ /dev/null @@ -1,60 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'optimization) - -(define (comp=? c1 c2) - (let ([s1 (open-output-string)] - [s2 (open-output-string)]) - (write c1 s1) - (write c2 s2) - (string=? (get-output-string s1) (get-output-string s2)))) - -(define test-comp - (case-lambda - [(expr1 expr2) (test-comp expr1 expr2 #t)] - [(expr1 expr2 same?) - (test same? `(compile ,same? ,expr2) (comp=? (compile expr1) (compile expr2)))])) - -(test-comp 5 '(if #t 5 (cons 1 2))) -(test-comp 5 '(if #f (cons 1 2) 5)) - -(test-comp 5 '(begin0 5 'hi "apple" 1.5)) -(test-comp 5 '(begin0 5 (begin0 'hi "apple" 1.5))) -(test-comp 5 '(begin0 5 (begin0 'hi "apple") 1.5)) -(test-comp 5 '(begin0 5 (begin 'hi "apple" 1.5))) -(test-comp 5 '(begin0 5 (begin 'hi "apple") 1.5)) -(test-comp 5 '(begin0 (begin0 5 'hi "apple" 1.5))) -(test-comp 5 '(begin0 (begin0 5 'hi "apple") 1.5)) - -; Can't drop `begin0' if the first expresson is not valueable: -(test-comp '(begin0 (begin0 (+ 1 2) 0) 0) '(begin0 (begin0 (+ 1 2) 'hi "apple") 1.5)) - -(test-comp 5 '(begin 'hi "apple" 1.5 5)) -(test-comp 5 '(begin (begin 'hi "apple" 1.5) 5)) -(test-comp 5 '(begin (begin 'hi "apple") 1.5 5)) -(test-comp 5 '(begin (begin0 'hi "apple" 1.5) 5)) -(test-comp 5 '(begin (begin0 'hi "apple") 1.5 5)) -(test-comp 5 '(begin (begin 'hi "apple" 1.5 5))) -(test-comp 5 '(begin 'hi (begin "apple" 1.5 5))) - -(test-comp '(let ([x 8][y 9]) (lambda () x)) - '(let ([x 8][y 9]) (lambda () (if #f y x)))) -(test-comp '(let ([x 8][y 9]) (lambda () (+ x y))) - '(let ([x 8][y 9]) (lambda () (if #f y (+ x y))))) - -(test-comp '(let ([x 5]) (set! x 2)) '(let ([x 5]) (set! x x) (set! x 2))) - -(test-comp '(let* () (f 5)) - '(f 5)) -(test-comp '(letrec () (f 5)) - '(f 5)) -(test-comp '(with-handlers () (f 5)) - '(f 5)) -(test-comp '(parameterize () (f 5)) - '(f 5)) -(test-comp '(fluid-let () (f 5)) - '(f 5)) - -(report-errs) diff --git a/collects/tests/mzscheme/parallel.ss b/collects/tests/mzscheme/parallel.ss deleted file mode 100644 index 67aae077..00000000 --- a/collects/tests/mzscheme/parallel.ss +++ /dev/null @@ -1,57 +0,0 @@ - -;; Runs 3 threads perfoming the test suite simultaneously. Each -;; thread creates a directory sub to run in, so that filesystem -;; tests don't collide. - -(unless (defined? 'parallel-load) - (global-defined-value 'parallel-load "quiet.ss")) - -; Runs n versions of test in parallel threads and namespaces, -; waiting until all are done -(define (parallel n test) - (let ([done (make-semaphore)] - [go (make-semaphore)]) - (let loop ([n n]) - (unless (zero? n) - (let ([ns (make-namespace)]) - (thread - (lambda () - (parameterize ([current-namespace ns]) - (let ([dirname (format "sub~s" n)]) - (when (directory-exists? dirname) - (delete-directory* dirname)) - (make-directory dirname) - (current-directory dirname) - (dynamic-wind - void - (lambda () - (load test)) - (lambda () - (semaphore-post done) - (semaphore-wait go) - (printf "~nThread ~s:" n) - (eval '(report-errs)) - (current-directory (build-path 'up)) - (delete-directory* dirname) - (semaphore-post done))))))) - (loop (sub1 n))))) - (let loop ([n n]) - (unless (zero? n) - (semaphore-wait done) - (loop (sub1 n)))) - (let loop ([n n]) - (unless (zero? n) - (semaphore-post go) - (semaphore-wait done) - (loop (sub1 n)))))) - -(define (delete-directory* dir) - (for-each (lambda (f) - (let ([f (build-path dir f)]) - (if (or (link-exists? f) (file-exists? f)) - (delete-file f) - (delete-directory* f)))) - (directory-list dir)) - (delete-directory dir)) - -(parallel 3 (path->complete-path parallel-load (current-load-relative-directory))) diff --git a/collects/tests/mzscheme/param.ss b/collects/tests/mzscheme/param.ss deleted file mode 100644 index a35c5f07..00000000 --- a/collects/tests/mzscheme/param.ss +++ /dev/null @@ -1,388 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'parameters) - -(let ([p (open-output-file "tmp5" 'replace)]) - (display (compile '(cons 1 2)) p) - (close-output-port p)) - -(define-struct tester (x)) -(define a-tester (make-tester 5)) - -(define (check-write-string display v s) - (let ([p (open-output-string)]) - (display v p) - (let ([s2 (get-output-string p)]) - (or (string=? s s2) - (error 'check-string "strings didn't match: ~s vs. ~s" - s s2))))) - -(define exn:check-string? exn:user?) - -(define called-break? #f) - -(define erroring-set? #f) - -(define erroring-port - (make-output-port (let ([orig (current-output-port)]) - (lambda (s) - (if erroring-set? - (begin - (set! erroring-set? #f) - (error 'output)) - (display s orig)))) - void)) - -(define erroring-eval - (let ([orig (current-eval)]) - (lambda (x) - (if erroring-set? - (begin - (set! erroring-set? #f) - (error 'eval)) - (orig x))))) - -(define blocking-thread - (lambda (thunk) - (let ([x #f]) - (thread-wait (thread (lambda () (set! x (thunk))))) - x))) - -(define main-cust (current-custodian)) - -(define zero-arg-proc (lambda () #t)) -(define one-arg-proc (lambda (x) #t)) -(define two-arg-proc (lambda (x y) #t)) -(define three-arg-proc (lambda (x y z) #t)) - -(define test-param1 (make-parameter 'one)) -(define test-param2 (make-parameter - 'two - ; generates type error: - (lambda (x) (if (symbol? x) - x - (add1 'x))))) - -(test 'one test-param1) -(test 'two test-param2) - -(arity-test make-parameter 1 2) -(error-test '(make-parameter 0 zero-arg-proc)) -(error-test '(make-parameter 0 two-arg-proc)) - -(define-struct bad-test (value exn?)) - -(define params (list - (list read-case-sensitive - (list #f #t) - '(if (eq? (read (open-input-string "HELLO")) (quote hello)) - (void) - (error (quote hello))) - exn:user? - #f) - (list read-square-bracket-as-paren - (list #t #f) - '(when (symbol? (read (open-input-string "[4]"))) - (error 'read)) - exn:user? - #f) - (list read-curly-brace-as-paren - (list #t #f) - '(when (symbol? (read (open-input-string "{4}"))) - (error 'read)) - exn:user? - #f) - (list read-accept-box - (list #t #f) - '(read (open-input-string "#&5")) - exn:read? - #f) - (list read-accept-graph - (list #t #f) - '(read (open-input-string "#0=(1 . #0#)")) - exn:read? - #f) - (list read-accept-compiled - (list #t #f) - '(let ([p (open-input-file "tmp5")]) - (dynamic-wind - void - (lambda () (read p)) - (lambda () (close-input-port p)))) - exn:read? - #f) - (list read-accept-bar-quote - (list #t #f) - '(let ([p (open-input-string "|hello #$ there| x")]) - (read p) - (read p)) - exn:read? - #f) - (list print-graph - (list #t #f) - '(check-write-string display (quote (#0=(1 2) . #0#)) "(#0=(1 2) . #0#)") - exn:check-string? - #f) - (list print-struct - (list #t #f) - '(check-write-string display a-tester "#(struct:tester 5)") - exn:check-string? - #f) - (list print-box - (list #t #f) - '(check-write-string display (box 5) "#&5") - exn:check-string? - #f) - (list print-vector-length - (list #t #f) - '(check-write-string write (vector 1 2 2) "#3(1 2)") - exn:check-string? - #f) - - (list current-input-port - (list (make-input-port (lambda () #\x) (lambda () #t) void) - (make-input-port (lambda () 5) (lambda () #t) void)) - '(read-char) - exn:i/o:port:user? - '("bad string")) - (list current-output-port - (list (current-output-port) - erroring-port) - '(begin - (set! erroring-set? #t) - (display 5) - (set! erroring-set? #f)) - exn:user? - '("bad string")) - -#| - ; Doesn't work since error-test sets the port! - (list current-error-port - (list (current-error-port) - erroring-port) - '(begin - (set! erroring-set? #t) - ((error-display-handler) "hello") - (set! erroring-set? #f)) - exn:user? - "bad setting") -|# - - (list compile-allow-cond-fallthrough - (list #t #f) - '(cond) - exn:else? - #f) - - (list compile-allow-set!-undefined - (list #t #f) - '(eval `(set! ,(gensym) 9)) - exn:variable? - #f) - - (list current-namespace - (list (make-namespace) - (make-namespace 'hash-percent-syntax)) - '(begin 0) - exn:variable? - '("bad setting")) - - (list error-print-width - (list 10 50) - '(when (< 10 (error-print-width)) (error 'print-width)) - exn:user? - '("bad setting")) - (list error-value->string-handler - (list (error-value->string-handler) (lambda (x w) (error 'converter))) - '(format "~e" 10) - exn:user? - (list "bad setting" zero-arg-proc one-arg-proc three-arg-proc)) - - (list break-enabled - (list #t #f) - '(let ([cont? #f]) - (thread-wait - (thread - (lambda () - (break-thread (current-thread)) - (sleep) - (set! cont? #t)))) - (when cont? - (error 'break-enabled))) - exn:user? - #f) - - (list current-print - (list (current-print) - (lambda (x) (display "frog"))) - `(let ([i (open-input-string "5")] - [o (open-output-string)]) - (parameterize ([current-input-port i] - [current-output-port o]) - (read-eval-print-loop)) - (let ([s (get-output-string o)]) - (unless (char=? #\5 (string-ref s 2)) - (error 'print)))) - exn:user? - (list "bad setting" zero-arg-proc two-arg-proc)) - - (list current-prompt-read - (list (current-prompt-read) - (let ([x #f]) - (lambda () - (set! x (not x)) - (if x - '(quote hi) - eof)))) - `(let ([i (open-input-string "5")] - [o (open-output-string)]) - (parameterize ([current-input-port i] - [current-output-port o]) - (read-eval-print-loop)) - (let ([s (get-output-string o)]) - (unless (and (char=? #\> (string-ref s 0)) - (not (char=? #\h (string-ref s 0)))) - (error 'prompt)))) - exn:user? - (list "bad setting" one-arg-proc two-arg-proc)) - - (list current-load - (list (current-load) (lambda (f) (error "This won't do it"))) - '(load "tmp5") - exn:user? - (list "bad setting" zero-arg-proc two-arg-proc)) - (list current-eval - (list (current-eval) erroring-eval) - '(begin - (set! erroring-set? #t) - (eval 5) - (set! erroring-set? #f)) - exn:user? - (list "bad setting" zero-arg-proc two-arg-proc)) - - (list current-load-relative-directory - (list (current-load-relative-directory) - (build-path (current-load-relative-directory) 'up)) - '(load-relative "loadable.ss") - exn:i/o:filesystem? - (append (list 0) - (map - (lambda (t) - (make-bad-test t exn:i/o:filesystem?)) - (list - "definitely a bad path" - (string #\a #\nul #\b) - "relative" - (build-path 'up)))) - equal?) - - (list global-port-print-handler - (list write display) - '(let ([s (open-output-string)]) - (print "hi" s) - (unless (char=? #\" (string-ref (get-output-string s) 0)) - (error 'global-port-print-handler))) - exn:user? - (list "bad setting" zero-arg-proc one-arg-proc three-arg-proc)) - - (list current-custodian - (list main-cust (make-custodian)) - '(let ([th (parameterize ([current-custodian main-cust]) - (thread (lambda () (sleep 1))))]) - (kill-thread th)) - exn:misc? - (list "bad setting")) - - (list exit-handler - (list void (lambda (x) (error 'exit-handler))) - '(exit) - exn:user? - (list "bad setting" zero-arg-proc two-arg-proc)) - - (list test-param1 - (list 'one 'bad-one) - '(when (eq? (test-param1) 'bad-one) - (error 'bad-one)) - exn:user? - #f) - (list test-param2 - (list 'two 'bad-two) - '(when (eq? (test-param2) 'bad-two) - (error 'bad-two)) - exn:user? - '("bad string")))) - -(for-each - (lambda (d) - (let ([param (car d)] - [alt1 (caadr d)] - [alt2 (cadadr d)] - [expr (caddr d)] - [exn? (cadddr d)]) - (parameterize ([param alt1]) - (test (void) void (teval expr))) - (parameterize ([param alt2]) - (error-test expr exn?)))) - params) - -(define test-param3 (make-parameter 'hi)) -(test 'hi test-param3) -(test 'hi 'thread-param - (let ([v #f]) - (thread-wait (thread - (lambda () - (set! v (test-param3))))) - v)) -(test (void) test-param3 'bye) -(test 'bye test-param3) -(test 'bye 'thread-param - (let* ([v #f] - [r (make-semaphore)] - [s (make-semaphore)] - [t (thread - (lambda () - (semaphore-post r) - (semaphore-wait s) - (set! v (test-param3))))]) - (semaphore-wait r) - (test-param3 'bye-again) - (semaphore-post s) - (thread-wait t) - v)) -(test 'bye-again test-param3) - -(test #f parameter? add1) - -(for-each - (lambda (d) - (let* ([param (car d)] - [alt1 (caadr d)] - [bads (cadddr (cdr d))]) - (test #t parameter? param) - (arity-test param 0 1) - (when bads - (for-each - (lambda (bad) - (let-values ([(bad exn?) - (if (bad-test? bad) - (values (bad-test-value bad) - (bad-test-exn? bad)) - (values bad - exn:application:type?))]) - (error-test `(,param ,bad) exn?))) - bads)))) - params) - -(test #t parameter-procedure=? read-accept-compiled read-accept-compiled) -(test #f parameter-procedure=? read-accept-compiled read-case-sensitive) -(error-test '(parameter-procedure=? read-accept-compiled 5)) -(error-test '(parameter-procedure=? 5 read-accept-compiled)) -(arity-test parameter-procedure=? 2 2) -(arity-test parameter? 1 1) - -; Test current-library-collection-paths? -; Test require-library-use-compiled? - -(report-errs) diff --git a/collects/tests/mzscheme/path.ss b/collects/tests/mzscheme/path.ss deleted file mode 100644 index 208e19ef..00000000 --- a/collects/tests/mzscheme/path.ss +++ /dev/null @@ -1,397 +0,0 @@ -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'PATH) - -(define (make-/tf p exn?) - (lambda args - (with-handlers ([exn? (lambda (x) #f)] - [void (lambda (x) 'wrong-exn)]) - (if (void? (apply p args)) - #t - 'not-void)))) -(define delete-file/tf (lambda (x) ((make-/tf delete-file exn:i/o:filesystem?) x))) -(define delete-directory/tf (lambda (x) ((make-/tf delete-directory exn:i/o:filesystem?) x))) -(define rename-file-or-directory/tf (lambda (x y) ((make-/tf rename-file-or-directory exn:i/o:filesystem?) x y))) -(define make-directory/tf (lambda (x) ((make-/tf make-directory exn:i/o:filesystem?) x))) -(define copy-file/tf (lambda (x y) ((make-/tf copy-file exn:i/o:filesystem?) x y))) - -(test #f relative-path? (current-directory)) -(test #t relative-path? "down") -(test #t relative-path? (build-path 'up "down")) -(test #t relative-path? (build-path 'same "down")) -(test #t relative-path? (build-path 'same "down" "deep")) -(test #f relative-path? (build-path (current-directory) 'up "down")) -(test #f relative-path? (build-path (current-directory) 'same "down")) -(test #f relative-path? (build-path (current-directory) 'same "down" "deep")) -(test #f relative-path? (string #\a #\nul #\b)) - -(arity-test relative-path? 1 1) -(error-test '(relative-path? 'a)) - -(test #t absolute-path? (current-directory)) -(test #f absolute-path? (build-path 'up)) -(test #f absolute-path? (string #\a #\nul #\b)) - -(arity-test absolute-path? 1 1) -(error-test '(absolute-path? 'a)) - -(test #t complete-path? (current-directory)) -(test #f complete-path? (build-path 'up)) -(test #f complete-path? (string #\a #\nul #\b)) - -(arity-test complete-path? 1 1) -(error-test '(complete-path? 'a)) - -(call-with-output-file "tmp6" void 'replace) -(define existant "tmp6") - -(test #t file-exists? existant) - -(define deepdir (build-path "down" "deep")) - -(when (directory-exists? deepdir) - (for-each delete-file (directory-list deepdir)) - (delete-directory deepdir)) -(when (directory-exists? "down") - (for-each delete-file (directory-list "down")) - (delete-directory "down")) - -(test #t make-directory/tf "down") -(test #f make-directory/tf "down") -(test #t directory-exists? "down") -(test #f file-exists? "down") - -(test #t make-directory/tf deepdir) -(test #f make-directory/tf deepdir) -(test #t directory-exists? deepdir) -(test #f file-exists? deepdir) - -(test #t file-exists? (build-path "down" 'up existant)) -(test #t file-exists? (build-path deepdir 'up 'up existant)) -(test #t file-exists? (build-path 'same deepdir 'same 'up 'same 'up existant)) - -(test #f file-exists? (build-path "down" existant)) -(test #f file-exists? (build-path deepdir 'up existant)) -(test #f file-exists? (build-path 'same deepdir 'same 'same 'up existant)) - -(delete-file "tmp6") - -(test #f file-exists? (build-path "down" 'up "badfile")) -(test #f file-exists? (build-path deepdir 'up 'up "badfile")) -(test #f file-exists? (build-path 'same deepdir 'same 'up 'same 'up "badfile")) - -(error-test '(open-output-file (build-path "wrong" "down" "tmp8")) - exn:i/o:filesystem?) -(error-test '(open-output-file (build-path deepdir "wrong" "tmp7")) - exn:i/o:filesystem?) - -(define start-time (current-seconds)) -(let ([p (open-output-file "tmp5" 'replace)]) - (display "123456789" p) - (close-output-port p)) -(close-output-port (open-output-file (build-path "down" "tmp8") 'replace)) -(close-output-port (open-output-file (build-path deepdir "tmp7") 'replace)) -(define end-time (current-seconds)) - -(map - (lambda (f) - (let ([time (seconds->date (file-or-directory-modify-seconds f))] - [start (seconds->date start-time)] - [end (seconds->date end-time)]) - (test #t = (date-year start) (date-year time) (date-year end)) - (test #t = (date-month start) (date-month time) (date-month end)) - (test #t = (date-day start) (date-day time) (date-day end)) - (test #t = (date-week-day start) (date-week-day time) (date-week-day end)) - (test #t = (date-year-day start) (date-year-day time) (date-year-day end)) - (test #t = (date-hour start) (date-hour time) (date-hour end)) - (test #t <= (date-minute start) (date-minute time) (date-minute end)) - (test #t <= (date-second start) (date-second time) (date-second end)))) - (list "tmp5" - "down" - (build-path "down" "tmp8") - (build-path deepdir "tmp7"))) - -(test 'no-exists 'no-file-for-seconds (with-handlers ([void (lambda (x) 'no-exists)]) (file-or-directory-modify-seconds "non-existent-file"))) -(map - (lambda (f) - (test #t number? (file-or-directory-modify-seconds f))) - (filesystem-root-list)) - -(test #t file-exists? "tmp5") -(test #t file-exists? (build-path "down" "tmp8")) -(test #t file-exists? (build-path deepdir "tmp7")) - -(test #t copy-file/tf "tmp5" "tmp5y") -(test #f copy-file/tf "tmp5" "tmp5y") -(test #f copy-file/tf "tmp5" "down") -(test #f copy-file/tf "tmp5" (build-path deepdir "moredeep" "tmp5y")) -(test (file-size "tmp5") file-size "tmp5y") -(delete-file "tmp5y") - -(test #t rename-file-or-directory/tf "tmp5" "tmp5x") -(test #f rename-file-or-directory/tf "tmp5" "tmp5x") -(close-output-port (open-output-file "tmp5")) -(test #t file-exists? "tmp5") -(test #t file-exists? "tmp5x") -(test #f rename-file-or-directory/tf "tmp5" "tmp5x") -(test #f rename-file-or-directory/tf "tmp5" "down") -(delete-file "tmp5") -(test #f file-exists? "tmp5") -(test #t rename-file-or-directory/tf (build-path "down" "tmp8") (build-path "down" "tmp8x")) -(test #f rename-file-or-directory/tf (build-path "down" "tmp8") (build-path "down" "tmp8x")) -(test #t rename-file-or-directory/tf (build-path deepdir "tmp7") (build-path deepdir "tmp7x")) -(test #f rename-file-or-directory/tf (build-path deepdir "tmp7") (build-path deepdir "tmp7x")) - -(test #t make-directory/tf "downx") -(test #f rename-file-or-directory/tf "down" "downx") -(test #t delete-directory/tf "downx") - -(test #t rename-file-or-directory/tf "down" "downx") -(test #t directory-exists? "downx") -(test #f directory-exists? "down") -(test #t file-exists? (build-path "downx" "tmp8x")) -(test #f file-exists? (build-path "down" "tmp8x")) -(test #f rename-file-or-directory/tf "down" "downx") -(test #t rename-file-or-directory/tf "downx" "down") -(test #t file-exists? (build-path "down" "tmp8x")) - -(test #t rename-file-or-directory/tf (build-path deepdir "tmp7x") "tmp7x") -(test #f rename-file-or-directory/tf (build-path deepdir "tmp7x") "tmp7x") -(test #t rename-file-or-directory/tf "tmp7x" (build-path deepdir "tmp7x")) -(test #f rename-file-or-directory/tf "tmp7x" (build-path deepdir "tmp7x")) - -(test #f not (member "tmp5x" (directory-list))) -(test #t 'directory-list - (let ([l (directory-list "down")]) - (or (equal? l '("deep" "tmp8x")) - (equal? l '("tmp8x" "deep"))))) -(test '("tmp7x") directory-list deepdir) - -(test #f delete-directory/tf deepdir) -(test #f delete-directory/tf "down") - -(test #t delete-file/tf (build-path deepdir "tmp7x")) -(test #f delete-file/tf (build-path deepdir "tmp7x")) -(test #t delete-file/tf (build-path "down" "tmp8x")) -(test #f delete-file/tf (build-path "down" "tmp8x")) -(test #t delete-file/tf "tmp5x") -(test #f delete-file/tf "tmp5x") - -(test #f delete-directory/tf "down") -(test #t delete-directory/tf deepdir) -(test #f delete-directory/tf deepdir) -(test #t delete-directory/tf "down") -(test #f delete-directory/tf "down") - -; Redefine these per-platform -(define drives null) -(define nondrive-roots (list "/")) -(define -a (list "a")) -(define a/b (list "a/b" "a//b")) -(define a/b/c (list "a/b/c" "a//b/c")) -(define /a/b (list "/a/b")) -(define a/../b (list "a/../b")) -(define a/./b (list "a/./b")) -(define a/../../b (list "a/../../b")) -(define trail-sep "/") - -(define add-slashes - (lambda (l) - (if (null? l) - null - (let loop ([s (car l)][rest (add-slashes (cdr l))]) - (let ([naya (regexp-replace "/" s "\\")]) - (if (string=? naya s) - (cons s rest) - (loop naya (cons s rest)))))))) - -(when (eq? (system-type) 'windows) - (set! drives (list "c:" "c:/" "//hello/start" "//hello/start/")) - (set! nondrive-roots null) - (for-each - (lambda (var) - (eval `(set! ,var (add-slashes ,var)))) - '(-a a/b a/b/c /a/b a/../b a/./b a/../../b))) - - -(when (eq? (system-type) 'macos) - (set! drives null) - (set! nondrive-roots (filesystem-root-list)) - (set! -a (list ":a")) - (set! a/b (list ":a:b")) - (set! a/b/c (list ":a:b:c")) - (set! /a/b (list "a:b")) - (set! a/../b (list ":a::b")) - (set! a/./b null) - (set! a/../../b (list ":a:::b")) - (set! trail-sep ":")) - -(define roots (append drives nondrive-roots)) - -(define a/ (map (lambda (s) (string-append s trail-sep)) -a)) -(define a/b/ (map (lambda (s) (string-append s trail-sep)) a/b)) -(define a/b/c/ (map (lambda (s) (string-append s trail-sep)) a/b/c)) -(define /a/b/ (map (lambda (s) (string-append s trail-sep)) /a/b)) - -(define absols (append roots /a/b /a/b/)) -(define nondrive-absols (append nondrive-roots /a/b /a/b/)) -(define rels (append -a a/ a/b a/b/ a/b/c a/b/c/ a/../b a/./b a/../../b)) - -(define i (lambda (x) x)) - -(test #f ormap i (map relative-path? roots)) -(test #t andmap i (map relative-path? a/b)) -(test #f ormap i (map relative-path? /a/b)) - -(test #t andmap i (map absolute-path? roots)) -(test #f ormap i (map absolute-path? a/b)) - -(test #t andmap i (map complete-path? drives)) -(test #t andmap i (map complete-path? nondrive-roots)) -(test #f ormap i (map complete-path? a/b)) - -(for-each - (lambda (abs) - (for-each - (lambda (rel) - (test #t string? (build-path abs rel)) - (for-each - (lambda (rel2) - (test #t string? (build-path abs rel rel2))) - rels)) - rels)) - absols) - -(for-each - (lambda (drive) - (for-each - (lambda (root) - (test #t string? (build-path drive root)) - (for-each - (lambda (rel) - (test #t string? (build-path drive root rel))) - rels)) - nondrive-absols)) - drives) - -(for-each - (lambda (rel) - (test (build-path (current-directory) rel) - path->complete-path rel)) - rels) - -(define (test-path expect f . args) - (test (normal-case-path (expand-path expect)) - (or (inferred-name f) 'unknown) - (normal-case-path (expand-path (apply f args))))) - -(for-each - (lambda (absol) - (let ([cabsol (path->complete-path absol)]) - (for-each - (lambda (rel) - (test-path (build-path cabsol rel) path->complete-path rel cabsol) - (test-path (build-path cabsol rel rel) path->complete-path rel (build-path cabsol rel)) - (error-test `(path->complete-path ,rel ,rel) exn:i/o:filesystem?)) - rels))) - absols) - -(for-each - (lambda (drive) - (for-each - (lambda (rel) - (unless (relative-path? rel) - (test-path (build-path (current-drive) rel) - path->complete-path rel)) - (test-path (build-path drive rel) path->complete-path rel drive) - (test-path (if (relative-path? rel) - (build-path drive rel rel) - (build-path drive rel)) - path->complete-path rel (build-path drive rel))) - (append rels nondrive-absols))) - drives) - -(for-each - (lambda (drive) - (test drive path->complete-path drive) - (test drive path->complete-path drive drive)) - drives) - -(unless (eq? (system-type) 'macos) - (for-each - (lambda (abs1) - (for-each - (lambda (abs2) - (error-test `(build-path ,abs1 ,abs2) exn:i/o:filesystem?)) - absols)) - nondrive-roots)) - -(for-each - (lambda (root) - (let-values ([(base name dir?) (split-path root)]) - (test #f 'split-path base) - (test #t 'split-path dir?))) - roots) - -(let ([check-a/b - (lambda (a/b end/?) - (for-each - (lambda (path) - (let*-values ([(base name dir?) (split-path path)] - [(base2 name2 dir?2) (split-path base)]) - (test "b" substring name 0 1) - (test end/? 'split-path dir?) - (test "a" substring name2 0 1) - (test 'relative 'split-path base2) - (test #t 'split-path dir?2) - (for-each - (lambda (root) - (let ([bigpath (build-path root path)]) - (let*-values ([(base name dir?) (split-path bigpath)] - [(base2 name2 dir?2) (split-path base)] - [(base3 name3 dir?3) (split-path base2)]) - (test #f 'split-path base3) - (test #t 'split-path dir?3)))) - roots))) - a/b))]) - (check-a/b a/b #f) - (check-a/b a/b/ #t)) - -(arity-test split-path 1 1) - -(arity-test path->complete-path 1 2) -(error-test '(path->complete-path 1)) -(error-test '(path->complete-path "a" 1)) - -(test-path (build-path "a" "b") simplify-path (build-path "a" "b")) -(let ([full-path - (lambda args (apply build-path (current-directory) args))]) - (unless (string=? (build-path "a" "b") (build-path "a" 'same "b")) - (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "b"))) - (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'up "b")) - (test-path (full-path "a" "b") simplify-path (build-path "a" 'same "noexistsdir" 'same 'up "b" 'same 'same)) - (test-path (full-path "a" "b") simplify-path (build-path 'same "noexistsdir" 'same 'up "a" 'same "b" 'same 'same))) -(arity-test simplify-path 1 1) - -(arity-test expand-path 1 1) -(arity-test resolve-path 1 1) - -(map - (lambda (f) - (error-test `(,f (string #\a #\nul #\b)) exn:i/o:filesystem?)) - '(build-path split-path file-exists? directory-exists? - delete-file directory-list make-directory delete-directory - file-or-directory-modify-seconds file-or-directory-permissions - expand-path resolve-path simplify-path path->complete-path - open-input-file open-output-file)) -(map - (lambda (f) - (error-test `(,f (string #\a #\nul #\b) "a") exn:i/o:filesystem?) - (error-test `(,f "a" (string #\a #\nul #\b)) exn:i/o:filesystem?)) - '(rename-file-or-directory path->complete-path)) - -; normal-case-path doesn't check for pathness: -(test #t string? (normal-case-path (string #\a #\nul #\b))) - -(report-errs) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss deleted file mode 100644 index 1c719616..00000000 --- a/collects/tests/mzscheme/pconvert.ss +++ /dev/null @@ -1,369 +0,0 @@ - -(unless (defined? 'SECTION) - (load-relative "testing.ss")) - -(SECTION 'pconvert) - -(require-library "pconver.ss") - -(constructor-style-printing #t) -(quasi-read-style-printing #f) - -(define (xl) 1) -(define (xu) (unit (import) (export))) -(define (xc) (class object% () (sequence (super-init)))) - -(let () - (define-struct test (value constructor-sexp - whole/frac-constructor-sexp - shared-constructor-sexp - quasi-sexp - whole/frac-quasi-sexp - shared-quasi-sexp - cons-as-list)) - - (define-struct no-cons-test (value constructor-sexp shared-constructor-sexp - quasi-sexp shared-quasi-sexp)) - (define-struct same-test (value sexp)) - (define get-value - (lambda (test-case) - (cond - [(test? test-case) - (test-value test-case)] - [(no-cons-test? test-case) - (no-cons-test-value test-case)] - [(same-test? test-case) - (same-test-value test-case)]))) - (define run-test - (lambda (test-case) - (let* ([before (get-value test-case)] - [cmp - (lambda (selector constructor-style? - quasi-read? - sharing? - cons-as-list? - whole/fractional-numbers?) - (unless (parameterize ([constructor-style-printing constructor-style?] - [show-sharing sharing?] - [quasi-read-style-printing quasi-read?] - [abbreviate-cons-as-list cons-as-list?] - [whole/fractional-exact-numbers whole/fractional-numbers?]) - (test (selector test-case) print-convert before)) - (printf - ">> (constructor-style-printing ~a) (quasi-read-style-printing ~a) (show-sharing ~a) (abbreviate-cons-as-list ~a) (whole/fractional-exact-numbers ~a)~n" - constructor-style? quasi-read? - sharing? cons-as-list? - whole/fractional-numbers?)))]) - ;(printf "testing: ~s~n" before) - ;(printf ".") (flush-output (current-output-port)) - (cond - [(test? test-case) - (cmp test-constructor-sexp #t #f #f #t #f) - (cmp test-whole/frac-constructor-sexp #t #f #f #t #t) - (cmp test-shared-constructor-sexp #t #f #t #t #f) - (cmp test-quasi-sexp #f #f #f #t #f) - (cmp test-whole/frac-quasi-sexp #f #f #f #t #t) - (cmp test-shared-quasi-sexp #f #f #t #t #f) - (cmp test-cons-as-list #t #f #f #f #f)] - [(no-cons-test? test-case) - (cmp no-cons-test-shared-constructor-sexp #t #f #t #t #t) - (cmp no-cons-test-constructor-sexp #t #f #f #t #t) - (cmp no-cons-test-shared-quasi-sexp #f #f #t #t #t) - (cmp no-cons-test-quasi-sexp #f #f #f #t #t)] - [(same-test? test-case) - (cmp same-test-sexp #t #t #t #t #t) - (cmp same-test-sexp #t #t #t #t #f) - (cmp same-test-sexp #t #t #t #f #t) - (cmp same-test-sexp #t #t #t #f #f) - (cmp same-test-sexp #t #t #f #t #t) - (cmp same-test-sexp #t #t #f #t #f) - (cmp same-test-sexp #t #t #f #f #t) - (cmp same-test-sexp #t #t #f #f #f) - - (cmp same-test-sexp #t #f #t #t #t) - (cmp same-test-sexp #t #f #t #t #f) - (cmp same-test-sexp #t #f #t #f #t) - (cmp same-test-sexp #t #f #t #f #f) - (cmp same-test-sexp #t #f #f #t #t) - (cmp same-test-sexp #t #f #f #t #f) - (cmp same-test-sexp #t #f #f #f #t) - (cmp same-test-sexp #t #f #f #f #f) - - (cmp same-test-sexp #f #t #t #t #t) - (cmp same-test-sexp #f #t #t #t #f) - (cmp same-test-sexp #f #t #t #f #t) - (cmp same-test-sexp #f #t #t #f #f) - (cmp same-test-sexp #f #t #f #t #t) - (cmp same-test-sexp #f #t #f #t #f) - (cmp same-test-sexp #f #t #f #f #t) - (cmp same-test-sexp #f #t #f #f #f) - - (cmp same-test-sexp #f #f #t #t #t) - (cmp same-test-sexp #f #f #t #t #f) - (cmp same-test-sexp #f #f #t #f #t) - (cmp same-test-sexp #f #f #t #f #f) - (cmp same-test-sexp #f #f #f #t #t) - (cmp same-test-sexp #f #f #f #t #f) - (cmp same-test-sexp #f #f #f #f #t) - (cmp same-test-sexp #f #f #f #f #f)])))) - - (define - tests - (list - (make-same-test "abc" "abc") - (make-same-test 'a ''a) - - (make-same-test 8 8) - (make-same-test 1/2 1/2) - (make-same-test 1.1 1.1) - - (make-test 3/2 3/2 '(+ 1 1/2) 3/2 3/2 '(+ 1 1/2) 3/2 3/2) - - (make-test (list 1) '(list 1) '(list 1) '(list 1) '`(1) '`(1) '`(1) '(cons 1 empty)) - (make-test (list 1/2) '(list 1/2) '(list 1/2) '(list 1/2) - '`(1/2) '`(1/2) '`(1/2) - '(cons 1/2 empty)) - (make-test (list 3/2) '(list 3/2) '(list (+ 1 1/2)) '(list 3/2) - '`(3/2) '`(,(+ 1 1/2)) '`(3/2) - '(cons 3/2 empty)) - (make-test (list 1/2+1/2i) - '(list 1/2+1/2i) - '(list (+ 1/2 (* 0+1i 1/2))) - '(list 1/2+1/2i) - '`(1/2+1/2i) - '`(,(+ 1/2 (* 0+1i 1/2))) - '`(1/2+1/2i) - '(cons 1/2+1/2i empty)) - (make-test (list 3/2+1/2i) - '(list 3/2+1/2i) - '(list (+ (+ 1 1/2) (* 0+1i 1/2))) - '(list 3/2+1/2i) - '`(3/2+1/2i) - '`(,(+ (+ 1 1/2) (* 0+1i 1/2))) - '`(3/2+1/2i) - '(cons 3/2+1/2i empty)) - (make-test (list 1/2+3/2i) - '(list 1/2+3/2i) - '(list (+ 1/2 (* 0+1i (+ 1 1/2)))) - '(list 1/2+3/2i) - '`(1/2+3/2i) - '`(,(+ 1/2 (* 0+1i (+ 1 1/2)))) - '`(1/2+3/2i) - '(cons 1/2+3/2i empty)) - (make-test (list 3/2+3/2i) - '(list 3/2+3/2i) - '(list (+ (+ 1 1/2) (* 0+1i (+ 1 1/2)))) - '(list 3/2+3/2i) - '`(3/2+3/2i) - '`(,(+ (+ 1 1/2) (* 0+1i (+ 1 1/2)))) - '`(3/2+3/2i) - '(cons 3/2+3/2i empty)) - - (make-same-test (vector 0 0 0 0 0 0 0 0 0 0) '(vector 0 0 0 0 0 0 0 0 0 0)) - (make-same-test #t 'true) - (make-same-test #f 'false) - - (make-same-test (interface () a b c) '(interface ...)) - - (make-same-test (delay 1) '(delay ...)) - (make-same-test (let-struct a (a) (make-a 3)) '(make-a 3)) - (make-same-test (box 3) '(box 3)) - (make-test null 'empty 'empty 'empty '`() '`() '`() 'empty) - (make-same-test add1 'add1) - (make-same-test (void) '(void)) - (make-same-test (unit (import) (export)) '(unit ...)) - (make-same-test (make-weak-box 12) '(make-weak-box 12)) - (make-same-test (regexp "1") '(regexp ...)) - (make-same-test (lambda () 0) '(lambda () ...)) - (make-same-test xl 'xl) - (make-same-test (letrec ([xl (lambda () 1)]) xl) '(lambda () ...)) - (make-same-test (letrec ([xl-ID-BETTER-NOT-BE-DEFINED (lambda () 1)]) - xl-ID-BETTER-NOT-BE-DEFINED) - '(lambda () ...)) - (make-same-test xc 'xc) - (make-same-test (letrec ([xc (class object% ())]) xc) '(class ...)) - (make-same-test (letrec ([xc-ID-BETTER-NOT-BE-DEFINED (class object% ())]) - xc-ID-BETTER-NOT-BE-DEFINED) - '(class ...)) - (make-same-test xu 'xu) - (make-same-test (letrec ([xu (unit (import) (export))]) xu) - '(unit ...)) - (make-same-test (letrec ([xu-ID-BETTER-NOT-BE-DEFINED (unit (import) (export))]) - xu-ID-BETTER-NOT-BE-DEFINED) - '(unit ...)) - (make-same-test (lambda (x) x) '(lambda (a1) ...)) - (make-same-test (lambda x x) '(lambda args ...)) - (make-same-test (lambda (a b . c) a) '(lambda (a1 a2 . args) ...)) - (make-same-test (case-lambda) '(case-lambda)) - (make-same-test (case-lambda [() a] [(x) a]) '(case-lambda [() ...] [(a1) ...])) - (make-same-test (case-lambda [() a] [(x y) a]) - '(case-lambda [() ...] [(a1 a2) ...])) - (make-same-test (case-lambda [() a] [(x . y) a]) - '(case-lambda [() ...] [(a1 . args) ...])) - (make-same-test (case-lambda [() a] [x a]) - '(case-lambda [() ...] [args ...])) - (make-same-test (case-lambda [() a] [(x y z) a] [x a]) - '(case-lambda [() ...] [(a1 a2 a3) ...] [args ...])) - (make-same-test (let ([ht (make-hash-table)]) - (hash-table-put! ht 'x 1) - ht) - '(make-hash-table)) - (make-test (list 'a (box (list ())) (cons 1 '())) - '(list (quote a) (box (list empty)) (list 1)) - '(list (quote a) (box (list empty)) (list 1)) - '(list (quote a) (box (list empty)) (list 1)) - '`(a ,(box `(())) (1)) - '`(a ,(box `(())) (1)) - '`(a ,(box `(())) (1)) - '(cons 'a - (cons (box (cons empty empty)) - (cons (cons 1 empty) - empty)))) - (make-test (let ([x (list 1)]) (set-car! x x) x) - '(shared ([-0- (list -0-)]) -0-) - '(shared ([-0- (list -0-)]) -0-) - '(shared ([-0- (list -0-)]) -0-) - '(shared ([-0- `(,-0-)]) -0-) - '(shared ([-0- `(,-0-)]) -0-) - '(shared ([-0- `(,-0-)]) -0-) - '(shared ([-0- (cons -0- empty)]) -0-)) - (make-test (let ([x (list 1)]) (set-cdr! x x) x) - '(shared ([-0- (cons 1 -0-)]) -0-) - '(shared ([-0- (cons 1 -0-)]) -0-) - '(shared ([-0- (cons 1 -0-)]) -0-) - '(shared ([-0- `(1 . ,-0-)]) -0-) - '(shared ([-0- `(1 . ,-0-)]) -0-) - '(shared ([-0- `(1 . ,-0-)]) -0-) - '(shared ([-0- (cons 1 -0-)]) -0-)) - (make-test (let* ([a (list 1 2 3)] - [b (list 1 a (cdr a))]) - (set-car! b b) - (append b (list (list 2 3)))) - '(shared ([-1- (list -1- (list 1 2 3) (list 2 3))]) - (list -1- (list 1 2 3) (list 2 3) (list 2 3))) - '(shared ([-1- (list -1- (list 1 2 3) (list 2 3))]) - (list -1- (list 1 2 3) (list 2 3) (list 2 3))) - '(shared ([-1- (list -1- -3- -4-)] - [-3- (cons 1 -4-)] - [-4- (list 2 3)]) - (list -1- -3- -4- (list 2 3))) - '(shared ([-1- `(,-1- (1 2 3) (2 3))]) - `(,-1- (1 2 3) (2 3) (2 3))) - '(shared ([-1- `(,-1- (1 2 3) (2 3))]) - `(,-1- (1 2 3) (2 3) (2 3))) - '(shared ([-1- `(,-1- ,-3- ,-4-)] - [-3- `(1 . ,-4-)] - [-4- `(2 3)]) - `(,-1- ,-3- ,-4- (2 3))) - '(shared ([-1- (cons -1- - (cons (cons 1 (cons 2 (cons 3 empty))) - (cons (cons 2 (cons 3 empty)) - empty)))]) - (cons -1- - (cons (cons 1 (cons 2 (cons 3 empty))) - (cons (cons 2 (cons 3 empty)) - (cons (cons 2 (cons 3 empty)) - empty)))))) - (make-no-cons-test (let* ([a (list 1 2 3)] - [b (list 1 a (cdr a))]) - (set-car! b b) - (let* ([share-list (append b (list (list 2 3)))] - [v (vector 1 share-list (cdr share-list))]) - (vector-set! v 0 v) - v)) - '(shared - ((-0- (vector -0- - (list -2- - (list 1 2 3) - (list 2 3) - (list 2 3)) - (list (list 1 2 3) - (list 2 3) - (list 2 3)))) - (-2- (list -2- (list 1 2 3) (list 2 3)))) - -0-) - '(shared - ((-0- (vector -0- (cons -2- -8-) -8-)) - (-2- (list -2- -4- -5-)) - (-4- (cons 1 -5-)) - (-5- (list 2 3)) - (-8- (list -4- -5- (list 2 3)))) - -0-) - '(shared - ((-0- (vector -0- - `(,-2- - (1 2 3) - (2 3) - (2 3)) - `((1 2 3) - (2 3) - (2 3)))) - (-2- `(,-2- (1 2 3) (2 3)))) - -0-) - '(shared - ((-0- (vector -0- `(,-2- . ,-8-) -8-)) - (-2- `(,-2- ,-4- ,-5-)) - (-4- `(1 . ,-5-)) - (-5- `(2 3)) - (-8- `(,-4- ,-5- (2 3)))) - -0-)))) - (for-each run-test tests)) - -(let () - (define make-test-shared - (lambda (shared?) - (lambda (object output) - (parameterize ([constructor-style-printing #t] - [show-sharing #t] - [quasi-read-style-printing #f] - [abbreviate-cons-as-list #t]) - (test (if shared? - `(shared ((-1- ,output)) - (list -1- -1-)) - `(list ,output ,output)) - print-convert - (list object object)))))) - (define test-shared (make-test-shared #t)) - (define test-not-shared (make-test-shared #f)) - - (test-not-shared #t 'true) - (test-not-shared #f 'false) - (test-not-shared 1 1) - (test-not-shared 3276832768327683276832768327683276832768 - 3276832768327683276832768327683276832768) - (test-shared (regexp "") '(regexp ...)) - (let ([in (open-input-string "")]) (test-shared in in)) - (let ([out (open-output-string)]) (test-shared out out)) - (test-not-shared #\a #\a) - (test-not-shared 'x ''x) - (test-shared (lambda (x) x) '(lambda (a1) ...)) - (test-shared (make-promise (lambda () 1)) '(delay ...)) - (test-shared (class object% ()) '(class ...)) - (test-shared (unit (import) (export)) '(unit ...)) - (test-shared (make-object (class object% () (sequence (super-init)))) '(make-object (class ...) ...)) - - (test-shared "abc" "abc") - (test-shared (list 1 2 3) '(list 1 2 3)) - (test-shared (vector 1 2 3) '(vector 1 2 3)) - (let-struct a () (test-shared (make-a) '(make-a))) - (test-shared (box 1) '(box 1)) - (test-shared (make-hash-table) '(make-hash-table))) - -(arity-test print-convert 1 2) -(arity-test build-share 1 1) -(arity-test get-shared 1 2) -(arity-test print-convert-expr 3 3) - -(test 'empty print-convert '()) - -(let ([pc - (lambda (pv) - (lambda (x) - (parameterize ([booleans-as-true/false pv]) - (print-convert x))))]) - (test 'false (pc #t) #f) - (test 'true (pc #t) #t) - (test #f (pc #f) #f) - (test #t (pc #f) #t)) - -(report-errs) diff --git a/collects/tests/mzscheme/pretty.ss b/collects/tests/mzscheme/pretty.ss deleted file mode 100644 index e340e373..00000000 --- a/collects/tests/mzscheme/pretty.ss +++ /dev/null @@ -1,110 +0,0 @@ - -; Test pretty-print. Some of it relies on manual inspection of the results - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(require-library "pretty.ss") - -(define (pp-string v) - (let ([p (open-output-string)]) - (pretty-print v p) - (let ([s (get-output-string p)]) - (substring s 0 (sub1 (string-length s)))))) - - -(test "10" pp-string 10) -(test "1/2" pp-string 1/2) -(test "-1/2" pp-string -1/2) -(test "1/2+3/4i" pp-string 1/2+3/4i) -(test "0.333" pp-string #i0.333) -(test "2.0+1.0i" pp-string #i2+1i) - -(parameterize ([pretty-print-exact-as-decimal #t]) - (test "10" pp-string 10) - (test "0.5" pp-string 1/2) - (test "-0.5" pp-string -1/2) - (test "3500.5" pp-string 7001/2) - (test "0.0001220703125" pp-string 1/8192) - (test "0.0000000000000006869768746897623487" - pp-string 6869768746897623487/10000000000000000000000000000000000) - (test "0.00000000000001048576" pp-string (/ (expt 5 20))) - - (test "1/3" pp-string 1/3) - (test "1/300000000000000000000000" pp-string 1/300000000000000000000000) - - (test "0.5+0.75i" pp-string 1/2+3/4i) - (test "0.5-0.75i" pp-string 1/2-3/4i) - (test "1/9+3/17i" pp-string 1/9+3/17i) - (test "0.333" pp-string #i0.333) - (test "2.0+1.0i" pp-string #i2+1i)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Manual part -;; (Why is this manual? Probably I was too lazy to make -;; a proper test suite.) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-struct s (a b c)) - -(define (make k?) - (let ([make (if k? make (lambda (x) '(end)))]) - (list - 1 - 'a - "a" - (list 'long-name-numero-uno-one-the-first-supreme-item - 'long-name-number-two-di-ar-ge-second-line) - (map (lambda (v v2) - (make-s v 2 v2)) - (make #f) - (reverse (make #f))) - '(1) - '(1 2 3) - '(1 . 2) - #(1 2 3 4 5) - '(#0=() . #0#) - '#1=(1 . #1#) - (map box (make #f)) - (make #f)))) - -(define vs (make #t)) - -(define print-line-no - (lambda (line port offset width) - (if line - (begin - (when (positive? line) (write-char #\newline port)) - (fprintf port "~s~a~a~a " line - (if (< line 10) " " "") - (if (< line 100) " " "") - (if (< line 1000) " " "")) - 5) - (fprintf port "!~n")))) - -(define modes - (list - (list "DEPTH=2" pretty-print-depth 2) - (list "GRAPH-ON" print-graph #t) - (list "STRUCT-ON" print-struct #t) - (list "LINE-NO-ON" pretty-print-print-line print-line-no))) - -(define num-combinations (arithmetic-shift 1 (length modes))) - -(let loop ([n 0]) - (when (< n num-combinations) - (let loop ([modes modes][n n]) - (cond - [(null? modes) (printf ":~n") (map pretty-print vs)] - [(positive? (bitwise-and n 1)) - (let ([mode (car modes)]) - (printf "~s " (car mode)) - (parameterize ([(cadr mode) (caddr mode)]) - (loop (cdr modes) (arithmetic-shift n -1))))] - [else - (loop (cdr modes) (arithmetic-shift n -1))])) - (loop (add1 n)))) - - - -(report-errs) diff --git a/collects/tests/mzscheme/quiet.ss b/collects/tests/mzscheme/quiet.ss deleted file mode 100644 index 7a948cc1..00000000 --- a/collects/tests/mzscheme/quiet.ss +++ /dev/null @@ -1,9 +0,0 @@ - -(unless (defined? 'quiet-load) - (global-defined-value 'quiet-load "all.ss")) - -(let ([p (make-output-port void void)]) - (parameterize ([current-output-port p]) - (load-relative quiet-load)) - (report-errs)) - diff --git a/collects/tests/mzscheme/read.ss b/collects/tests/mzscheme/read.ss deleted file mode 100644 index 061c3ecd..00000000 --- a/collects/tests/mzscheme/read.ss +++ /dev/null @@ -1,169 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'READING) -(define readstr - (lambda (s) - (let* ([o (open-input-string s)] - [read (if (defined? 'read/zodiac) - (let ([r (read/zodiac (open-input-string s))]) - (lambda () - (let ([orig (error-escape-handler )]) - (dynamic-wind - (lambda () (error-escape-handler - (lambda () - (error-escape-handler orig) - (error 'read/zodiac)))) - r - (lambda () (error-escape-handler orig)))))) - (lambda () (read o)))]) - (let loop ([last eof]) - (let ([v (read)]) - (if (eof-object? v) - last - (loop v))))))) - -(define readerrtype - (if (defined? 'read/zodiac) - (lambda (x) (lambda (y) #t)) - (lambda (x) x))) - -; Make sure {whitespace} == {delimiter} -(let ([with-censor (load-relative "censor.ss")]) - (with-censor - (lambda () - (let loop ([n 0]) - (unless (= n 256) - (let* ([c0 (integer->char n)] - [c (if (read-case-sensitive) - c0 - (char-downcase c0))]) - (cond - [(char-whitespace? c) - (test 'b readstr (string #\a c #\b))] - [(char=? #\\ c) (test 'ab readstr (string #\a c #\b))] - [(char=? #\; c) (test 'a readstr (string #\a c #\b))] - [(char=? #\' c) (test ''b readstr (string #\a c #\b))] - [(char=? #\` c) (test '`b readstr (string #\a c #\b))] - [(char=? #\, c) (test ',b readstr (string #\a c #\b))] - [else - (test (string->symbol (string #\a (char-downcase c) #\b)) - 'readstr - (with-handlers ([void - (lambda (x) - (string->symbol (string #\a (char-downcase c) #\b)))]) - (readstr (string #\a c #\b))))])) - (loop (add1 n))))))) - -(error-test '(readstr ")") (readerrtype exn:read?)) -(error-test '(readstr "[)") (readerrtype exn:read?)) -(error-test '(readstr "[}") (readerrtype exn:read?)) -(error-test '(readstr "8 )") (readerrtype exn:read?)) -(error-test '(readstr "(8 . )") (readerrtype exn:read?)) - -(load-relative "numstrs.ss") -(let loop ([l number-table]) - (unless (null? l) - (let* ([pair (car l)] - [v (car pair)] - [s (cadr pair)]) - (cond - [(eq? v 'X) (error-test `(readstr ,s) (readerrtype exn:read?))] - [v (test v readstr s)] - [else (test (string->symbol s) readstr s)])) - (loop (cdr l)))) - -(error-test '(readstr "#\\silly") (readerrtype exn:read?)) -(error-test '(readstr "#\\nully") (readerrtype exn:read?)) -(error-test '(readstr "#\\nu") (readerrtype exn:read?)) -(error-test '(readstr "#\\733") (readerrtype exn:read?)) -(error-test '(readstr "#\\433") (readerrtype exn:read?)) - -(error-test '(readstr "(hi") (readerrtype exn:read:eof?)) -(error-test '(readstr "\"hi") (readerrtype exn:read:eof?)) -(error-test '(readstr "#(hi") (readerrtype exn:read:eof?)) -(error-test '(readstr "#4(hi") (readerrtype exn:read:eof?)) -(error-test '(readstr "|hi") (readerrtype exn:read:eof?)) -(error-test '(readstr "#\\") (readerrtype exn:read:eof?)) -(error-test '(readstr "#| hi") (readerrtype exn:read:eof?)) - -(error-test '(readstr ".") (readerrtype exn:read?)) -(error-test '(readstr "a .") (readerrtype exn:read?)) -(error-test '(readstr "a . b") (readerrtype exn:read?)) -(error-test '(readstr "( . )") (readerrtype exn:read?)) -(error-test '(readstr "( . 8)") (readerrtype exn:read?)) -(error-test '(readstr "(0 . 8 9)") (readerrtype exn:read?)) -(error-test '(readstr "( . 8 9)") (readerrtype exn:read?)) -(error-test '(readstr "#(8 . )") (readerrtype exn:read?)) -(error-test '(readstr "#( . )") (readerrtype exn:read?)) -(error-test '(readstr "#( . 8)") (readerrtype exn:read?)) -(error-test '(readstr "#(0 . 8 9)") (readerrtype exn:read?)) -(error-test '(readstr "#( . 8 9)") (readerrtype exn:read?)) -(error-test '(readstr "#( 8 . 9)") (readerrtype exn:read?)) -(error-test '(readstr "#( 8 . (9))") (readerrtype exn:read?)) - -(error-test '(readstr "#Q") (readerrtype exn:read?)) -(error-test '(readstr "##") (readerrtype exn:read?)) -(error-test '(readstr "#?") (readerrtype exn:read?)) -(error-test '(readstr "#-1()") (readerrtype exn:read?)) -(error-test '(readstr "#") (readerrtype exn:read?)) - -(test 2 vector-length (readstr "#2()")) -(test 0 vector-ref (readstr "#2()") 1) -(test 2 vector-length (readstr "#000000000000000000000000000000002()")) - -(error-test '(readstr "#2(1 2 3)") (readerrtype exn:read?)) -(error-test '(readstr "#200000000000(1 2 3)") (readerrtype exn:misc:out-of-memory?)) - -(unless (defined? 'read/zodiac) - (test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#0=(1 2) . #0#)")) - (test #t (lambda (x) (eq? (car x) (cdr x))) (readstr "(#1=(1 2) . #0001#)"))) - -(error-test '(readstr "#0#") (readerrtype exn:read?)) -(error-test '(readstr "#0=#0#") (readerrtype exn:read?)) -(error-test '(readstr "(#0# #0=7)") (readerrtype exn:read?)) -(error-test '(readstr "(#0=7 #1#)") (readerrtype exn:read?)) -(error-test '(readstr "#012345678=7") (readerrtype exn:read?)) -(error-test '(readstr "(#12345678=7 #012345678#)") (readerrtype exn:read?)) - -(test 3 string-length (readstr (string #\" #\a #\nul #\b #\"))) -(test (string->symbol (string #\a #\nul #\b)) 'sym (readstr (string #\a #\nul #\b))) -(test (string->symbol (string #\1 #\nul #\b)) 'sym (readstr (string #\1 #\nul #\b))) - -; Test read/write invariance on symbols and use of pipe quotes -(define (test-write-sym with-bar without-bar s) - (let ([sym (string->symbol s)]) - (parameterize ([read-case-sensitive #t]) - (let ([p (open-output-string)]) - (write sym p) - (test with-bar 'write-sym-with-bar (get-output-string p)) - (test sym read (open-input-string (get-output-string p)))) - (let ([p (open-output-string)]) - (parameterize ([read-accept-bar-quote #f]) - (write sym p) - (test without-bar 'write-sym-no-bar (get-output-string p)) - (test sym read (open-input-string (get-output-string p))))) - (let ([p (open-output-string)]) - (display sym p) - (test s 'display-sym (get-output-string p)))))) - -(test-write-sym "a->b" "a->b" "a->b") -(test-write-sym "|a,b|" "a\\,b" "a,b") -(test-write-sym "a\\|b" "a|b" "a|b") -(test-write-sym "|a\\b|" "a\\\\b" "a\\b") - -(load-relative "numstrs.ss") -(let loop ([l number-table]) - (cond - [(null? l) 'done] - [(or (number? (caar l)) (eq? (caar l) 'X)) - (test-write-sym (string-append "|" (cadar l) "|") - (string-append "\\" (cadar l)) - (cadar l)) - (loop (cdr l))] - [else - (test-write-sym (cadar l) (cadar l) (cadar l)) - (loop (cdr l))])) - -(report-errs) diff --git a/collects/tests/mzscheme/stream.ss b/collects/tests/mzscheme/stream.ss deleted file mode 100644 index be981dc3..00000000 --- a/collects/tests/mzscheme/stream.ss +++ /dev/null @@ -1,305 +0,0 @@ - -(printf "Stream Tests (current dir must be startup dir)~n") - -(define (log . args) - '(begin - (apply printf args) - (newline))) - -(define cs-prog - '(define (copy-stream in out) - (lambda () - (let ([s (make-string 4096)]) - (let loop () - (let ([l (read-string-avail! s in)]) - (log "in: ~a" l) - (unless (eof-object? l) - (let loop ([p 0][l l]) - (let ([r (write-string-avail s out p (+ p l))]) - (log "out: ~a" r) - (when (< r l) - (loop (+ p r) (- l r))))) - (loop)))))))) - -(eval cs-prog) - -(define test-file (find-system-path 'exec-file)) -(define tmp-file (build-path (find-system-path 'temp-dir) "ZstreamZ")) - -(define (feed-file out) - (let ([p (open-input-file test-file)]) - (let loop () - (let ([c (read-char p)]) - (unless (eof-object? c) - (write-char c out) - (loop)))))) - -(define (feed-file/fast out) - (let ([p (open-input-file test-file)]) - ((copy-stream p out)) - (close-input-port p))) - -(define (check-file in) - (let ([p (open-input-file test-file)]) - (let loop ([badc 0]) - (let ([c (read-char p)] - [c2 (read-char in)]) - (unless (eq? c c2) - (if (= badc 30) - (error "check-failed" (file-position p) c c2) - (begin - (fprintf (current-error-port) - "fail: ~a ~s ~s~n" - (file-position p) c c2) - (loop (add1 badc))))) - (unless (eof-object? c) - (loop badc)))))) - -(define (check-file/fast in) - (let ([p (open-input-file test-file)]) - (let loop () - (let* ([s (read-string 5000 p)] - [s2 (read-string (if (string? s) (string-length s) 100) in)]) - (unless (equal? s s2) - (error "fast check failed")) - (unless (eof-object? s) - (loop)))))) - -(define (check-file/fastest in) - (let ([p (open-input-file test-file)] - [s1 (make-string 5000)] - [s2 (make-string 5000)]) - (let loop ([leftover 0]) - (let* ([n1 (let ([n (read-string-avail! s1 p leftover)]) - (if (eof-object? n) - (if (zero? leftover) - n - leftover) - (+ n leftover)))] - [n2 (read-string-avail! s2 in 0 (if (eof-object? n1) - 1 - n1))]) - (unless (if (or (eof-object? n1) - (eof-object? n2) - (= n2 n1 5000)) - (equal? s1 s2) - (string=? (substring s1 0 n2) - (substring s2 0 n2))) - (error "fast check failed")) - (unless (eof-object? n1) - (loop (- n1 n2))))))) - -(define portno 40000) - -(define (setup-mzscheme-echo tcp?) - (define p (process* test-file "-q" "-b")) - (define s (make-string 256)) - (define r #f) - (define w #f) - (define r2 #f) - (define w2 #f) - (thread (copy-stream (cadddr p) (current-error-port))) - (fprintf (cadr p) "(define log void)~n") - (fprintf (cadr p) "~s~n" cs-prog) - (if tcp? - (let ([t - (thread (lambda () - (define-values (rr ww) (tcp-accept l1)) - (define-values (rr2 ww2) (tcp-accept l2)) - (set! r rr) - (set! w ww) - (set! r2 rr2) - (set! w2 ww2)))]) - (fprintf (cadr p) "(define-values (r w) (tcp-connect \"localhost\" ~a))~n" portno) - (fprintf (cadr p) "(define-values (r2 w2) (tcp-connect \"localhost\" ~a))~n" (add1 portno)) - (thread-wait t) - (fprintf (cadr p) "(begin ((copy-stream r w2)) (exit))~n")) - (fprintf (cadr p) "(begin ((copy-stream (current-input-port) (current-output-port))) (exit))~n")) - - ;; Flush initial output: - (read-string (string-length (banner)) (car p)) - (sleep 0.3) - (when (char-ready? (car p)) - (read-string-avail! s (car p))) - (sleep 0.3) - (when (char-ready? (car p)) - (read-string-avail! s (car p))) - - (if tcp? - (values r w r2 w2) - p)) - -(define start-ms 0) -(define start-ps-ms 0) -(define start-gc-ms 0) -(define (start s) - (printf s) - (set! start-ms (current-milliseconds)) - (set! start-gc-ms (current-gc-milliseconds)) - (set! start-ps-ms (current-process-milliseconds))) -(define (end) - (let ([ps-ms (current-process-milliseconds)] - [gc-ms (current-gc-milliseconds)] - [ms (current-milliseconds)]) - (printf "cpu: ~a real: ~a gc ~a~n" - (- ps-ms start-ps-ms) - (- ms start-ms) - (- gc-ms start-gc-ms)))) - -'(thread (lambda () - (let loop () - (printf "alive~n") - (sleep 1) - (loop)))) - -(start "Quick check:~n") -(define p (open-input-file test-file)) -(check-file/fast p) -(close-input-port p) -(end) - -(start "Quicker check:~n") -(define p (open-input-file test-file)) -(check-file/fastest p) -(close-input-port p) -(end) - -(start "Plain pipe...~n") -(define-values (r w) (make-pipe)) -(feed-file w) -(close-output-port w) -(check-file r) -(end) - -(start "Plain pipe, faster...~n") -(define-values (r w) (make-pipe)) -(feed-file/fast w) -(close-output-port w) -(check-file/fast r) -(end) - -(start "Plain pipe, fastest...~n") -(define-values (r w) (make-pipe)) -(feed-file/fast w) -(close-output-port w) -(check-file/fastest r) -(end) - -(start "To file and back:~n") -(start " to...~n") -(define-values (r w) (make-pipe)) -(define p (open-output-file tmp-file 'truncate)) -(define t (thread (copy-stream r p))) -(feed-file w) -(close-output-port w) -(thread-wait t) -(close-output-port p) -(end) - -(start " back...~n") -(define-values (r w) (make-pipe)) -(define p (open-input-file tmp-file)) -(define t (thread (copy-stream p w))) -(thread-wait t) -(close-output-port w) -(close-input-port p) -(check-file r) -(end) - -(start "To file and back, faster:~n") -(start " to...~n") -(define-values (r w) (make-pipe)) -(define p (open-output-file tmp-file 'truncate)) -(define t (thread (copy-stream r p))) -(feed-file/fast w) -(close-output-port w) -(thread-wait t) -(close-output-port p) -(end) - -(start " back...~n") -(define-values (r w) (make-pipe)) -(define p (open-input-file tmp-file)) -(define t (thread (copy-stream p w))) -(thread-wait t) -(close-output-port w) -(close-input-port p) -(check-file/fast r) -(end) - -(start "File back, fastest:~n") -(define-values (r w) (make-pipe)) -(define p (open-input-file tmp-file)) -(define t (thread (copy-stream p w))) -(thread-wait t) -(close-output-port w) -(close-input-port p) -(check-file/fastest r) -(end) - -(start "Echo...~n") -(define p (setup-mzscheme-echo #f)) -(thread (lambda () - (feed-file (cadr p)) - (close-output-port (cadr p)))) -(check-file (car p)) -(end) - -(start "Echo, faster...~n") -(define p (setup-mzscheme-echo #f)) -(thread (lambda () - (feed-file/fast (cadr p)) - (close-output-port (cadr p)))) -(check-file/fast (car p)) -(end) - -(start "Echo, indirect...~n") -(define p (setup-mzscheme-echo #f)) -(define-values (rp1 wp1) (make-pipe)) -(define-values (rp2 wp2) (make-pipe)) -(thread (lambda () ((copy-stream rp1 (cadr p))) (close-output-port (cadr p)))) -(thread (lambda () ((copy-stream (car p) wp2)) (close-output-port wp2))) -(thread (lambda () - (feed-file/fast wp1) - (close-output-port wp1))) -(check-file/fast rp2) -(end) - -(define l1 (tcp-listen portno)) -(define l2 (tcp-listen (add1 portno))) - -(start "TCP Echo...~n") -(define-values (r w r2 w2) (setup-mzscheme-echo #t)) -(close-input-port r) -(thread (lambda () - (feed-file w) - (close-output-port w))) -(check-file r2) -(close-input-port r2) -(end) - -(start "TCP Echo, faster...~n") -(define-values (r w r2 w2) (setup-mzscheme-echo #t)) -(close-input-port r) -(thread (lambda () - (feed-file/fast w) - (close-output-port w))) -(check-file/fast r2) -(close-input-port r2) -(end) - -(start "TCP Echo, indirect...~n") -(define-values (rp1 wp1) (make-pipe)) -(define-values (rp2 wp2) (make-pipe)) -(define-values (r w r2 w2) (setup-mzscheme-echo #t)) -(close-input-port r) -(thread (lambda () ((copy-stream rp1 w)) (close-output-port w))) -(thread (lambda () ((copy-stream r2 wp2)) (close-output-port wp2))) -(thread (lambda () - (feed-file/fast wp1) - (close-output-port wp1))) -(check-file/fast rp2) -(end) - -(tcp-close l1) -(tcp-close l2) diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss deleted file mode 100644 index b0b0a962..00000000 --- a/collects/tests/mzscheme/struct.ss +++ /dev/null @@ -1,234 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'STRUCT) - -(test 7 call-with-values - (lambda () (struct a (b c))) - (lambda args (length args))) -(let-values ([(type make pred sel1 set1 sel2 set2) (struct a (b c))]) - (test #t struct-type? type) - (test #t procedure? make) - (test 2 arity make) - (test 1 arity sel1) - (test 2 arity set1) - (test #t struct-setter-procedure? set2) - (test #f struct-setter-procedure? sel2)) - -(define-struct a (b c)) -(define-struct aa ()) -(define ai (make-a 1 2)) -(define aai (make-aa)) -(test #t struct-type? struct:a) -(test #f struct-type? 5) -(test #t procedure? a?) -(test #t a? ai) -(test #f a? 1) -(test #f aa? ai) -(test 1 a-b ai) -(test 2 a-c ai) -(define ai2 (make-a 1 2)) -(set-a-b! ai2 3) -(set-a-c! ai2 4) -(test 1 a-b ai) -(test 2 a-c ai) -(test 3 a-b ai2) -(test 4 a-c ai2) -(define-struct a (b c)) -(test #f a? ai) -(arity-test make-a 2 2) -(error-test `(make-aa 1) exn:application:arity?) -(arity-test a? 1 1) -(arity-test a-b 1 1) -(arity-test a-c 1 1) -(arity-test set-a-b! 2 2) -(arity-test set-a-c! 2 2) -(error-test `(a-b 5)) -(error-test `(a-b ,ai)) -(error-test `(set-a-b! ai 5)) -(error-test `(set-a-c! ai 5)) -(error-test `(begin (define-struct (a 9) (b c)) (void)) exn:struct?) - -(arity-test struct-type? 1 1) - -(define (gen-struct-syntax-test formname suffix) - (syntax-test `(,formname 1 (x) ,@suffix)) - (syntax-test `(,formname a (1) ,@suffix)) - (syntax-test `(,formname a (x 1) ,@suffix)) - (syntax-test `(,formname a (x . y) ,@suffix)) - (syntax-test `(,formname (a) (x) ,@suffix)) - (syntax-test `(,formname (a . y) (x) ,@suffix)) - (syntax-test `(,formname (a 2 3) (x) ,@suffix))) -(define (struct-syntax-test formname) - (syntax-test `(,formname)) - (syntax-test `(,formname . a)) - (syntax-test `(,formname a . x)) - (syntax-test `(,formname a x)) - (gen-struct-syntax-test formname '())) - -(struct-syntax-test 'struct) -(struct-syntax-test 'define-struct) -(gen-struct-syntax-test 'let-struct '(5)) - -(define-struct base0 ()) -(define-struct base1 (a)) -(define-struct base2 (l r)) -(define-struct base3 (x y z)) - -(define-struct (one00 struct:base0) ()) -(define-struct (one01 struct:base1) ()) -(define-struct (one02 struct:base2) ()) -(define-struct (one03 struct:base3) ()) - -(define-struct (one10 struct:base0) (a)) -(define-struct (one11 struct:base1) (a)) -(define-struct (one12 struct:base2) (a)) -(define-struct (one13 struct:base3) (a)) - -(define-struct (one20 struct:base0) (l r)) -(define-struct (one21 struct:base1) (l r)) -(define-struct (one22 struct:base2) (l r)) -(define-struct (one23 struct:base3) (l r)) - -(define-struct (one30 struct:base0) (x y z)) -(define-struct (one31 struct:base1) (x y z)) -(define-struct (one32 struct:base2) (x y z)) -(define-struct (one33 struct:base3) (x y z)) - -(define-struct (two100 struct:one00) (a)) -(define-struct (two101 struct:one01) (a)) -(define-struct (two102 struct:one02) (a)) -(define-struct (two103 struct:one03) (a)) -(define-struct (two110 struct:one10) (a)) -(define-struct (two111 struct:one11) (a)) -(define-struct (two112 struct:one12) (a)) -(define-struct (two113 struct:one13) (a)) -(define-struct (two120 struct:one20) (a)) -(define-struct (two121 struct:one21) (a)) -(define-struct (two122 struct:one22) (a)) -(define-struct (two123 struct:one23) (a)) -(define-struct (two130 struct:one30) (a)) -(define-struct (two131 struct:one31) (a)) -(define-struct (two132 struct:one32) (a)) -(define-struct (two133 struct:one33) (a)) - -(define x00 (make-one00)) - -(define x01 (make-one01 1)) - -(define x10 (make-one10 1)) -(define x11 (make-one11 1 2)) -(define x12 (make-one12 1 2 3)) -(define x13 (make-one13 1 2 3 4)) - -(define x31 (make-one31 1 2 3 4)) - -(define x33 (make-one33 1 2 3 4 5 6)) - -(define x132 (make-two132 1 2 3 4 5 6)) - -(define (ones v) - (cond - [(one00? v) 'one00] - [(one01? v) 'one01] - [(one02? v) 'one02] - [(one03? v) 'one03] - - [(one10? v) 'one10] - [(one11? v) 'one11] - [(one12? v) 'one12] - [(one13? v) 'one13] - - [(one20? v) 'one20] - [(one21? v) 'one21] - [(one22? v) 'one22] - [(one23? v) 'one23] - - [(one30? v) 'one30] - [(one31? v) 'one31] - [(one32? v) 'one32] - [(one33? v) 'one33])) - -(define (multi v) - (cond - [(two130? v) 'two130] - [(two131? v) 'two131] - [(two132? v) 'two132] - [(two133? v) 'two133] - - [(one10? v) 'one10] - [(one11? v) 'one11] - [(one12? v) 'one12] - [(one13? v) 'one13] - - [(one20? v) 'one20] - [(one21? v) 'one21] - [(one22? v) 'one22] - [(one23? v) 'one23] - - [(base0? v) 'base0] - [(base1? v) 'base1] - [(base2? v) 'base2] - [(base3? v) 'base3])) - -(define (dummy v) - 'ok) - -(define (go f v n) - (time - (let loop ([n n]) - (unless (zero? n) - (f v) - (loop (sub1 n)))))) - -(define check - (lambda (l) - (cond - [(null? l) #f] - [else - (test (caddr l) (car l) (cadr l)) - (check (cdddr l))]))) - -(define ones-test - (list x00 'one00 - x10 'one10 - x11 'one11 - x12 'one12 - x13 'one13 - x33 'one33)) - -(define multi-test - (list x00 'base0 - x10 'one10 - x11 'one11 - x12 'one12 - x13 'one13 - x33 'base3 - x132 'two132)) - -(letrec ([bundle - (lambda (l f) - (if (null? l) - null - (list* f (car l) (cadr l) - (bundle (cddr l) f))))]) - (check (append - (bundle ones-test ones) - (bundle multi-test multi) - (list base1-a x11 1 - one11-a x11 2 - one10-a x10 1 - - base1-a x31 1 - one31-z x31 4 - - base2-l x132 1 - two132-a x132 6 - one32-y x132 4)))) - - -(error-test '(struct x (y z)) exn:application:arity?) -(error-test '(let ([x (struct x (y z))]) 10) exn:application:arity?) - -(report-errs) diff --git a/collects/tests/mzscheme/structc.ss b/collects/tests/mzscheme/structc.ss deleted file mode 100644 index 2e7d616f..00000000 --- a/collects/tests/mzscheme/structc.ss +++ /dev/null @@ -1,182 +0,0 @@ - -(define ones-case - (make-struct-case - (list - one00? - one01? - one02? - one03? - - one10? - one11? - one12? - one13? - - one20? - one21? - one22? - one23? - - one30? - one31? - one32? - one33?) - - (list - (lambda (x) 'one00) - (lambda (x) 'one01) - (lambda (x) 'one02) - (lambda (x) 'one03) - - (lambda (x) 'one10) - (lambda (x) 'one11) - (lambda (x) 'one12) - (lambda (x) 'one13) - - (lambda (x) 'one20) - (lambda (x) 'one21) - (lambda (x) 'one22) - (lambda (x) 'one23) - - (lambda (x) 'one30) - (lambda (x) 'one31) - (lambda (x) 'one32) - (lambda (x) 'one33)))) - -(define multi-case - (make-struct-case - (list - two130? - two131? - two132? - two133? - - one10? - one11? - one12? - one13? - - one20? - one21? - one22? - one23? - - base0? - base1? - base2? - base3?) - - (list - (lambda (x) 'two130) - (lambda (x) 'two131) - (lambda (x) 'two132) - (lambda (x) 'two133) - - (lambda (x) 'one10) - (lambda (x) 'one11) - (lambda (x) 'one12) - (lambda (x) 'one13) - - (lambda (x) 'one20) - (lambda (x) 'one21) - (lambda (x) 'one22) - (lambda (x) 'one23) - - (lambda (x) 'base0) - (lambda (x) 'base1) - (lambda (x) 'base2) - (lambda (x) 'base3)) - - (lambda (x) x))) - -(letrec ([bundle - (lambda (l f) - (if (null? l) - null - (list* f (car l) (cadr l) - (bundle (cddr l) f))))]) - (check (append - (bundle ones-test ones-case) - (bundle multi-test multi-case) - (list base1-a x11 1 - one11-a x11 2 - one10-a x10 1 - - base1-a x31 1 - one31-z x31 4 - - base2-l x132 1 - two132-a x132 6 - one32-y x132 4)))) - -(test #t arity-at-least? (multi-case (arity void))) - -(arity-test multi-case 1 1) - -(error-test `(,ones-case 6) type?) -(error-test `(,multi-case 6) type?) - -(error-test `(,ones-case (arity void)) exn:else?) - -(test (void) (make-struct-case null null void) x00) -(test #t procedure? (make-struct-case null null)) - -(error-test `((make-struct-case null null) x00) exn:else?) - -(error-test `(make-struct-case (list 8) (list void))) -(error-test `(make-struct-case (list exn:misc? 8) (list void void))) -(error-test `(make-struct-case (list exn:misc? 8 exn?) (list void void void))) -(error-test `(make-struct-case exn? (list void))) -(error-test `(make-struct-case (list* exn:misc? exn?) (list void))) - -(error-test `(make-struct-case (list exn?) (list 8))) -(error-test `(make-struct-case (list exn?) (list (lambda () 8)))) -(error-test `(make-struct-case (list exn:misc? exn?) - (list void string-set!))) -(error-test `(make-struct-case (list exn:misc? exn:syntax? exn?) - (list void void string-set!))) -(error-test `(make-struct-case (list exn?) void)) -(error-test `(make-struct-case (list exn?) (list* void void))) - -(error-test `(make-struct-case (list exn:misc?) (list void void)) - exn:application:list-sizes?) -(error-test `(make-struct-case (list exn:misc? exn?) (list void)) - exn:application:list-sizes?) - -(arity-test make-struct-case 2 3) - -(test 0 (struct-case-lambda x (else 0)) (arity void)) -(test (arity void) (struct-case-lambda x (else)) (arity void)) -(test (arity void) (struct-case-lambda x (arity-at-least?)) (arity void)) -(test 0 (struct-case-lambda x (arity-at-least? 0) (else 1)) (arity void)) - -(define s (struct-case-lambda x - [exn? 'exn] - [arity-at-least? x] - [else (cons x 5)])) - -(test 'exn s (make-exn 1 2)) -(test (arity void) s (arity void)) -(test (cons x00 5) s x00) - -(arity-test s 1 1) - -(error-test '(s 9)) -(error-test '(struct-case-lambda) syntaxe?) -(error-test '(struct-case-lambda 5) syntaxe?) -(error-test '(struct-case-lambda x . 5) syntaxe?) -(error-test '(struct-case-lambda x ()) syntaxe?) -(error-test '(struct-case-lambda x else) syntaxe?) -(error-test '(struct-case-lambda x (else 9) (exn? 8)) syntaxe?)) - -(define time-branch - (lambda (proc list) - (time - (let loop ([n 1000]) - (unless (zero? n) - (let loop ([l list]) - (unless (null? l) - (proc (car l)) - (loop (cddr l)))) - (loop (sub1 n))))))) - diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss deleted file mode 100644 index d9b9d369..00000000 --- a/collects/tests/mzscheme/syntax.ss +++ /dev/null @@ -1,948 +0,0 @@ - -(unless (defined? 'SECTION) - (load-relative "testing.ss")) - -(test 0 'with-handlers (with-handlers () 0)) -(test 1 'with-handlers (with-handlers ([void void]) 1)) -(test 2 'with-handlers (with-handlers ([void void]) 1 2)) -(test 'zero 'zero - (with-handlers ((zero? (lambda (x) 'zero))) - (raise 0))) -(test 'zero 'zero - (with-handlers ((zero? (lambda (x) 'zero)) - (positive? (lambda (x) 'positive))) - (raise 0))) -(test 'positive 'positive - (with-handlers ((zero? (lambda (x) 'zero)) - (positive? (lambda (x) 'positive))) - (raise 1))) -(test 5 'with-handlers - (with-handlers ([void (lambda (x) 5)]) - (with-handlers ((zero? (lambda (x) 'zero))) - (/ 0)))) -(error-test '(with-handlers () - (/ 0)) - exn:application:divide-by-zero?) -(error-test '(with-handlers ((zero? (lambda (x) 'zero))) - (/ 0)) - exn:application:type?) -(error-test '(with-handlers ((zero? (lambda (x) 'zero)) - (boolean? (lambda (x) 'boolean))) - (/ 0)) - exn:application:type?) -(syntax-test '(with-handlers)) -(syntax-test '(with-handlers . 1)) -(syntax-test '(with-handlers ((zero? (lambda (x) 'zero))))) -(syntax-test '(with-handlers ((zero? (lambda (x) 'zero))) . 1)) -(syntax-test '(with-handlers (zero?) 1)) -(syntax-test '(with-handlers ((zero?)) 1)) -(syntax-test '(with-handlers ((zero? . zero?)) 1)) -(syntax-test '(with-handlers ((zero? zero?) . 2) 1)) -(syntax-test '(with-handlers ((zero? zero?) zero?) 1)) -(syntax-test '(with-handlers ((zero? zero?) (zero?)) 1)) -(syntax-test '(with-handlers ((zero? zero?) (zero?)) 1)) -(syntax-test '(with-handlers ((zero? zero? zero?)) 1)) -(syntax-test '(with-handlers ((zero? zero? . zero?)) 1)) -(syntax-test '(with-handlers ((zero? zero?)) 1 . 2)) - -(error-test '(with-handlers ((0 void)) (/ 0)) - exn:application:type?) -(error-test '(with-handlers ((void 0)) (/ 0)) - exn:application:type?) -(error-test '(with-handlers ((unbound-variable void)) 0) - exn:variable?) -(error-test '(with-handlers ((void unbound-variable)) 0) - exn:variable?) -(error-test '(with-handlers (((values 1 2) void)) 0) - arity?) -(error-test '(with-handlers ((void (values 1 2))) 0) - arity?) - -(test-values '(1 2) (lambda () (with-handlers ([void void]) - (values 1 2)))) - -(SECTION 4 1 2) -(test '(quote a) 'quote (quote 'a)) -(test '(quote a) 'quote ''a) -(syntax-test '(quote)) -(syntax-test '(quote 1 2)) - -(SECTION 4 1 3) -(test 12 (if #f + *) 3 4) -(syntax-test '(+ 3 . 4)) - -(SECTION 4 1 4) -(test 8 (lambda (x) (+ x x)) 4) -(define reverse-subtract - (lambda (x y) (- y x))) -(test 3 reverse-subtract 7 10) -(define add4 - (let ((x 4)) - (lambda (y) (+ x y)))) -(test 10 add4 6) -(test (letrec([x x]) x) 'lambda (let ([x (lambda () (define d d) d)]) (x))) -(test (letrec([x x]) x) 'lambda ((lambda () (define d d) d))) -(test '(3 4 5 6) (lambda x x) 3 4 5 6) -(test '(5 6) (lambda (x y . z) z) 3 4 5 6) -(test 'second (lambda () (cons 'first 2) 'second)) -(syntax-test '(lambda)) -(syntax-test '(lambda x)) -(syntax-test '(lambda ())) -(syntax-test '(lambda () (begin))) -(syntax-test '(lambda . x)) -(syntax-test '(lambda x . x)) -(syntax-test '(lambda x . 5)) -(syntax-test '(lambda ((x)) x)) -(syntax-test '(lambda 5 x)) -(syntax-test '(lambda (5) x)) -(syntax-test '(lambda (x (y)) x)) -(syntax-test '(lambda (x . 5) x)) -(syntax-test '(lambda (x) x . 5)) - -(let ([f - (case-lambda - [() 'zero] - [(x) (cons 1 1) 'one] - [(x y) 'two] - [(x y z . rest) 'three+] - [x 'bad])] - [g - (case-lambda - [(x y z) 'three] - [(x y) (cons 2 2) 'two] - [(x) 'one] - [() 'zero] - [x (cons 0 'more!) 'more])] - [h - (case-lambda - [(x y) 'two] - [(x y z w) 'four])]) - (test 'zero f) - (test 'one f 1) - (test 'two f 1 2) - (test 'three+ f 1 2 3) - (test 'three+ f 1 2 3 4) - (test 'three+ f 1 2 3 4 5 6 7 8 9 10) - - (test 'zero g) - (test 'one g 1) - (test 'two g 1 2) - (test 'three g 1 2 3) - (test 'more g 1 2 3 4 5 6 7 8 9 10) - - (test 'two h 1 2) - (test 'four h 1 2 3 4) - (let ([h '(case-lambda - [(x y) 'two] - [(x y z w) 'four])]) - (error-test (list h) arity?) - (error-test (list* h '(1)) arity?) - (error-test (list* h '(1 2 3)) arity?) - (error-test (list* h '(1 2 3 4 5 6)) arity?))) - -(error-test '((case-lambda)) arity?) - -(syntax-test '(case-lambda [])) -(syntax-test '(case-lambda 1)) -(syntax-test '(case-lambda x)) -(syntax-test '(case-lambda [x])) -(syntax-test '(case-lambda [x 8][y])) -(syntax-test '(case-lambda [x][y 9])) -(syntax-test '(case-lambda [8 8])) -(syntax-test '(case-lambda [((x)) 8])) -(syntax-test '(case-lambda [(8) 8])) -(syntax-test '(case-lambda [(x . 9) 8])) -(syntax-test '(case-lambda [x . 8])) -(syntax-test '(case-lambda [(x) . 8])) -(syntax-test '(case-lambda . [(x) 8])) -(syntax-test '(case-lambda [(x) 8] . [y 7])) -(syntax-test '(case-lambda [(x) 8] . [y 7])) -(syntax-test '(case-lambda [(x) 8] [8 7])) -(syntax-test '(case-lambda [(x) 8] [((y)) 7])) -(syntax-test '(case-lambda [(x) 8] [(8) 7])) -(syntax-test '(case-lambda [(x) 8] [(y . 8) 7])) -(syntax-test '(case-lambda [(x) 8] [y . 7])) -(syntax-test '(case-lambda [(x) 8] [(y) . 7])) -(syntax-test '(case-lambda [(x x) 8] [(y) 7])) -(syntax-test '(case-lambda [(x . x) 8] [(y) 7])) -(syntax-test '(case-lambda [(y) 7] [(x x) 8])) -(syntax-test '(case-lambda [(y) 7] [(x . x) 8])) - -(SECTION 4 1 5) -(test 'yes 'if (if (> 3 2) 'yes 'no)) -(test 'no 'if (if (> 2 3) 'yes 'no)) -(test '1 'if (if (> 3 2) (- 3 2) (+ 3 2))) -(test-values '(1 2) (lambda () (if (cons 1 2) (values 1 2) 0))) -(test-values '(1 2) (lambda () (if (not (cons 1 2)) 0 (values 1 2)))) -(syntax-test '(if . #t)) -(syntax-test '(if #t . 1)) -(syntax-test '(if #t 1 . 2)) -(syntax-test '(if #t)) -(syntax-test '(if #t 1 2 3)) -(syntax-test '(if #t 1 2 . 3)) -(error-test '(if (values 1 2) 3 4) arity?) - -(test (void) 'when (when (> 1 2) 0)) -(test (void) 'when (when (> 1 2) (cons 1 2) 0)) -(test 0 'when (when (< 1 2) 0)) -(test 0 'when (when (< 1 2) (cons 1 2) 0)) -(test-values '(0 10) (lambda () (when (< 1 2) (values 0 10)))) -(syntax-test '(when)) -(syntax-test '(when . 1)) -(syntax-test '(when 1)) -(syntax-test '(when 1 . 2)) -(error-test '(when (values 1 2) 0) arity?) - -(test (void) 'unless (unless (< 1 2) 0)) -(test (void) 'unless (unless (< 1 2) (cons 1 2) 0)) -(test 0 'unless (unless (> 1 2) 0)) -(test 0 'unless (unless (> 1 2) (cons 1 2) 0)) -(test-values '(0 10) (lambda () (unless (> 1 2) (values 0 10)))) -(syntax-test '(unless)) -(syntax-test '(unless . 1)) -(syntax-test '(unless 1)) -(syntax-test '(unless 1 . 2)) -(error-test '(unless (values 1 2) 0) arity?) - -(SECTION 4 1 6) -(define x 2) -(test 3 'define (+ x 1)) -(set! x 4) -(test 5 'set! (+ x 1)) -(syntax-test '(set!)) -(syntax-test '(set! x)) -(syntax-test '(set! x 1 2)) -(syntax-test '(set! 1 2)) -(syntax-test '(set! (x) 1)) -(syntax-test '(set! . x)) -(syntax-test '(set! x . 1)) -(syntax-test '(set! x 1 . 2)) - -(set!-values (x) 9) -(test 9 'set!-values x) -(test (void) 'set!-values (set!-values () (values))) -(set!-values (x x) (values 1 2)) -(test 2 'set!-values x) -(syntax-test '(set!-values)) -(syntax-test '(set!-values . x)) -(syntax-test '(set!-values x)) -(syntax-test '(set!-values 8)) -(syntax-test '(set!-values (x))) -(syntax-test '(set!-values (x) . 0)) -(syntax-test '(set!-values x 0)) -(syntax-test '(set!-values (x . y) 0)) -(syntax-test '(set!-values (x . 8) 0)) -(syntax-test '(set!-values (x 8) 0)) -(syntax-test '(set!-values (x) 0 1)) -(syntax-test '(set!-values (x) 0 . 1)) - -(error-test '(set!-values () 1) arity?) -(error-test '(set!-values () (values 1 2)) arity?) -(error-test '(set!-values (x) (values)) arity?) -(error-test '(set!-values (x) (values 1 2)) arity?) -(error-test '(set!-values (x y) 1) arity?) -(error-test '(set!-values (x y) (values 1 2 3)) arity?) - -(error-test '(set! unbound-variable 5) exn:variable?) - -(SECTION 4 2 1) -(test 'greater 'cond (cond ((> 3 2) 'greater) - ((< 3 2) 'less))) -(test 'equal 'cond (cond ((> 3 3) 'greater) - ((< 3 3) 'less) - (else 'equal))) -(test 2 'cond (cond ((assv 'b '((a 1) (b 2))) => cadr) - (else #f))) -(test #f 'cond (cond ((assv 'z '((a 1) (b 2))) => cadr) - (else #f))) -(syntax-test '(cond ((assv 'z '((a 1) (b 2))) => cadr) - (else 8) - (else #f))) -(test #f 'cond (let ([else #f]) - (cond ((assv 'z '((a 1) (b 2))) => cadr) - (else 8) - (#t #f)))) -(test 'second 'cond (cond ((< 1 2) (cons 1 2) 'second))) -(test 'second-again 'cond (cond ((> 1 2) 'ok) (else (cons 1 2) 'second-again))) -(test 1 'cond (cond (1))) -(test 1 'cond (cond (#f) (1))) -(test 1 'cond (cond (#f 7) (1))) -(test 2 'cond (cond (#f 7) (1 => add1))) -(test add1 'cond (let ([=> 9]) (cond (#f 7) (1 => add1)))) -(non-z '(test 0 'case (case (* 2 3) - (6 0) - (else 7)))) -(test 'composite 'case (case (* 2 3) - ((2 3 5 7) 'prime) - ((1 4 6 8 9) 'composite))) -(test 'consonant 'case (case (car '(c d)) - ((a e i o u) 'vowel) - ((w y) 'semivowel) - (else 'consonant))) -(test 'second 'case (case 10 - [(10) (cons 1 2) 'second] - [else 5])) -(test 'second-again 'case (case 11 - [(10) (cons 1 2) 'second] - [else (cons 1 2) 'second-again])) -(test-values '(10 9) (lambda () - (cond - [(positive? 0) 'a] - [(positive? 10) (values 10 9)] - [else #f]))) -(test-values '(10 9) (lambda () - (case (string->symbol "hello") - [(bye) 'a] - [(hello) (values 10 9)] - [else #f]))) -(error-test '(cond [(values 1 2) 8]) arity?) -(error-test '(case (values 1 2) [(a) 8]) arity?) - -(test #t 'and (and (= 2 2) (> 2 1))) -(test #f 'and (and (= 2 2) (< 2 1))) -(test '(f g) 'and (and 1 2 'c '(f g))) -(test #t 'and (and)) -(test-values '(1 12) (lambda () (and (cons 1 2) (values 1 12)))) -(test #t 'or (or (= 2 2) (> 2 1))) -(test #t 'or (or (= 2 2) (< 2 1))) -(test #f 'or (or #f #f #f)) -(test #f 'or (or)) -(test '(b c) 'or (or (memq 'b '(a b c)) (+ 3 0))) -(test-values '(1 12) (lambda () (or (not (cons 1 2)) (values 1 12)))) -(syntax-test '(cond #t)) -(syntax-test '(cond ()) ) -(syntax-test '(cond (1 =>)) ) -(syntax-test '(cond (1 => 3 4)) ) -(syntax-test '(cond . #t)) -(syntax-test '(cond (#t . 1))) -(syntax-test '(cond (#t 1) #f)) -(syntax-test '(cond (#t 1) . #f)) -(error-test '(cond ((values #t #f) 1)) arity?) -(syntax-test '(case)) -(syntax-test '(case 0 #t)) -(syntax-test '(case . 0)) -(syntax-test '(case 0 . #t)) -(syntax-test '(case 0 (0 #t))) -(syntax-test '(case 0 ())) -(syntax-test '(case 0 (0))) -(syntax-test '(case 0 (0 . 8))) -(syntax-test '(case 0 ((0 . 1) 8))) -(syntax-test '(case 0 (0 8) #f)) -(syntax-test '(case 0 (0 8) . #f)) -(syntax-test '(case 0 (else 1) (else 2))) -(error-test '(case 0 ((0) =>)) exn:variable?) -(syntax-test '(and . 1)) -(syntax-test '(and 1 . 2)) -(syntax-test '(or . 1)) -(syntax-test '(or 1 . 2)) -(error-test '(and #t (values 1 2) 8) arity?) -(error-test '(or #f (values 1 2) 8) arity?) - -(SECTION 4 2 2) -(test 6 'let (let ((x 2) (y 3)) (* x y))) -(test 'second 'let (let ((x 2) (y 3)) (* x y) 'second)) -(test 6 'let-values (let-values (((x) 2) ((y) 3)) (* x y))) -(test 6 'let-values (let-values (((x y) (values 2 3))) (* x y))) -(test 35 'let (let ((x 2) (y 3)) (let ((x 7) (z (+ x y))) (* z x)))) -(test 35 'let-values (let-values (((x y) (values 2 3))) (let-values (((x) 7) ((z) (+ x y))) (* z x)))) -(test 70 'let* (let ((x 2) (y 3)) (let* ((x 7) (z (+ x y))) (* z x)))) -(test 70 'let*-values (let ((x 2) (y 3)) (let*-values (((x) 7) ((z) (+ x y))) (* z x)))) -(test #t 'letrec (letrec ((-even? - (lambda (n) (if (zero? n) #t (-odd? (- n 1))))) - (-odd? - (lambda (n) (if (zero? n) #f (-even? (- n 1)))))) - (-even? 88))) -(test #t 'letrec-values (letrec-values (((-even? -odd?) - (values - (lambda (n) (if (zero? n) #t (-odd? (- n 1)))) - (lambda (n) (if (zero? n) #f (-even? (- n 1))))))) - (-even? 88))) -(define x 34) -(test 5 'let (let ((x 3)) (define x 5) x)) -(test 5 'let (let ((x 3)) (define-values (x w) (values 5 8)) x)) -(test 34 'let x) -(test 6 'let (let () (define x 6) x)) -(test 34 'let x) -(test 7 'let* (let* ((x 3)) (define x 7) x)) -(test 34 'let* x) -(test 8 'let* (let* () (define x 8) x)) -(test 34 'let* x) -(test 9 'letrec (letrec () (define x 9) x)) -(test 34 'letrec x) -(test 10 'letrec (letrec ((x 3)) (define x 10) x)) -(test 34 'letrec x) -(teval '(test 5 'letrec (letrec ((x 5)(y x)) y))) -(test 3 'let (let ((y 'apple) (x 3) (z 'banana)) x)) -(test 3 'let* (let* ((y 'apple) (x 3) (z 'banana)) x)) -(test 3 'letrec (letrec ((y 'apple) (x 3) (z 'banana)) x)) -(test 3 'let* (let* ((x 7) (y 'apple) (z (set! x 3))) x)) -(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #f) (set! x 3) #f))) x)) -(test 3 'let* (let* ((x 7) (y 'apple) (z (if (not #t) #t (set! x 3)))) x)) -(test 3 'let-values (let-values (((y x z) (values 'apple 3 'banana))) x)) -(test 3 'let*-values (let*-values (((y x z) (values 'apple 3 'banana))) x)) -(test 3 'letrec-values (letrec-values (((y x z) (values 'apple 3 'banana))) x)) -(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (set! x 3))) x)) -(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #f) (set! x 3) #f))) x)) -(test 3 'let*-values (let*-values (((x y) (values 7 'apple)) ((z) (if (not #t) #t (set! x 3)))) x)) -(test 1 'named-let-scope (let ([f add1]) (let f ([n (f 0)]) n))) - -(test-values '(3 4) (lambda () (let ([x 3][y 4]) (values x y)))) -(test-values '(3 -4) (lambda () (let loop ([x 3][y -4]) (values x y)))) -(test-values '(3 14) (lambda () (let* ([x 3][y 14]) (values x y)))) -(test-values '(3 24) (lambda () (letrec ([x 3][y 24]) (values x y)))) -(test-values '(3 54) (lambda () (let-values ([(x y) (values 3 54)]) (values x y)))) -(test-values '(3 64) (lambda () (let*-values ([(x y) (values 3 64)]) (values x y)))) -(test-values '(3 74) (lambda () (letrec-values ([(x y) (values 3 74)]) (values x y)))) - -(test '(10 11) 'letrec-values (letrec-values ([(names kps) - (letrec ([oloop 10]) - (values oloop (add1 oloop)))]) - (list names kps))) - -(define (error-test-let/no-* expr) - (syntax-test (cons 'let expr)) - (syntax-test (cons 'let (cons 'name expr))) - (syntax-test (cons 'letrec expr))) -(define (error-test-let expr) - (error-test-let/no-* expr) - (syntax-test (cons 'let* expr))) -(error-test-let 'x) -(error-test-let '(x)) -(error-test-let '(())) -(error-test-let '(x ())) -(syntax-test '(let* x () 1)) -(syntax-test '(letrec x () 1)) -(error-test-let '(x . 1)) -(error-test-let '(() . 1)) -(error-test-let '(((x 1)))) -(error-test-let '(((x 1)) . 1)) -(error-test-let '(((x . 1)) 1)) -(error-test-let '(((1 1)) 1)) -(error-test-let '(((x 1) 1) 1)) -(error-test-let '(((x 1) . 1) 1)) -(error-test-let '(((x 1 1)) 1)) -(error-test-let '(((x 1 1)) 1)) -(error-test-let '(((x 1)) 1 . 2)) -(error-test-let/no-* '(((x 1) (x 2)) 1)) -(error-test-let/no-* '(((x 1) (y 3) (x 2)) 1)) -(error-test-let/no-* '(((y 3) (x 1) (x 2)) 1)) -(error-test-let/no-* '(((x 1) (x 2) (y 3)) 1)) -(test 5 'let* (let* ([x 4][x 5]) x)) -(error-test-let '(() (define x 10))) -(error-test-let '(() (define x 10) (define y 20))) - -(define (do-error-test-let-values/no-* expr syntax-test) - (syntax-test (cons 'let-values expr)) - (syntax-test (cons 'letrec-values expr))) -(define (do-error-test-let-values expr syntax-test) - (do-error-test-let-values/no-* expr syntax-test) - (syntax-test (cons 'let*-values expr))) -(define (error-test-let-values/no-* expr) - (do-error-test-let-values/no-* expr syntax-test)) -(define (error-test-let-values expr) - (do-error-test-let-values expr syntax-test)) -(error-test-let-values 'x) -(error-test-let-values '(x)) -(error-test-let-values '(())) -(error-test-let-values '(x ())) -(syntax-test '(let*-values x () 1)) -(syntax-test '(letrec-values x () 1)) -(error-test-let-values '(x . 1)) -(error-test-let-values '(() . 1)) -(error-test-let-values '((((x) 1)))) -(error-test-let-values '((((x) 1)) . 1)) -(error-test-let-values '((((x) . 1)) 1)) -(error-test-let-values '((((1) 1)) 1)) -(error-test-let-values '((((x 1) 1)) 1)) -(error-test-let-values '((((1 x) 1)) 1)) -(error-test-let-values '((((x) 1) . 1) 1)) -(error-test-let-values '((((x) 1 1)) 1)) -(error-test-let-values '((((x . y) 1)) 1)) -(error-test-let-values '((((x . 1) 1)) 1)) -(error-test-let-values '((((x) 1)) 1 . 2)) -(error-test-let-values '((((x x) 1)) 1)) -(error-test-let-values '((((y) 0) ((x x) 1)) 1)) -(error-test-let-values '((((x x) 1) ((y) 0)) 1)) -(error-test-let-values/no-* '((((x) 1) ((x) 2)) 1)) -(error-test-let-values/no-* '((((x) 1) ((y) 3) ((x) 2)) 1)) -(error-test-let-values/no-* '((((y) 3) ((x) 1) ((x) 2)) 1)) -(error-test-let-values/no-* '((((x) 1) ((x) 2) ((y) 3)) 1)) -(test 5 'let* (let*-values ([(x) 4][(x) 5]) x)) - -(do-error-test-let-values '((((x y) 1)) 1) (lambda (x) (error-test x arity?))) -(do-error-test-let-values '((((x) (values 1 2))) 1) (lambda (x) (error-test x arity?))) -(do-error-test-let-values '(((() (values 1))) 1) (lambda (x) (error-test x arity?))) -(do-error-test-let-values '((((x) (values))) 1) (lambda (x) (error-test x arity?))) - -(test 5 'embedded (let () (define y (lambda () x)) (define x 5) (y))) - -(let ([wrap (lambda (body) - (syntax-test `(let () ,@body)) - (syntax-test `(let () (begin ,@body))))]) - (wrap '((define x 7) (define x 8) x)) - (wrap '(2 (define y 8) x)) - (wrap '((define 3 8) x)) - (wrap '((define-values x 8) x))) - -(let ([wrap - (lambda (val body) - (teval `(test ,val 'let-begin (let () ,@body))) - (teval `(test ,val 'let-begin (let ([xyzw 12]) ,@body))) - (teval `(test ,val (lambda () ,@body))) - (teval `(test ,val 'parameterize-begin - (parameterize () ,@body))) - (teval `(test ,val 'parameterize-begin - (parameterize ([current-directory (current-directory)]) - ,@body))) - (teval `(test ,val 'with-handlers-begin - (with-handlers () ,@body))) - (teval `(test ,val 'with-handlers-begin - (with-handlers ([void void]) ,@body))) - (teval `(test ,val 'fluid-let-begin (fluid-let () ,@body))) - (teval `(test ,val 'fluid-let-begin (fluid-let ([x 20]) ,@body))) - (syntax-test `(when (positive? 1) ,@body)) - (syntax-test `(unless (positive? -1) ,@body)) - (syntax-test `(cond [(positive? 1) ,@body][else #f])) - (syntax-test `(cond [(positive? -1) 0][else ,@body])) - (syntax-test `(case (positive? 1) [(#t) ,@body][else -12])) - (syntax-test `(cond [#t ,@body])) - (syntax-test `(do ((x 1)) (#t ,@body) ,@body)) - (syntax-test `(begin0 12 ,@body)))]) - (wrap 5 '((begin (define x 5)) x)) - (wrap 5 '((begin (define x 5) x))) - (wrap 15 '((begin (define x 5)) (begin (define y (+ x 10)) y))) - (wrap 13 '((begin) 13)) - (wrap 7 '((begin) (begin) (begin (define x 7) (begin) x))) - (wrap 7 '((begin (begin (begin (define x 7) (begin) x)))))) - -(SECTION 4 2 3) -(define x 0) -(define (test-begin bg nested-bg) - (let* ([make-args - (lambda (bg b) - (if (eq? bg 'begin) - b - (let* ([len (length b)] - [last (list-ref b (sub1 len))]) - (cons last - (let loop ([l b]) - (if (null? (cdr l)) - null - (cons (car l) (loop (cdr l)))))))))] - [test-bg - (lambda (v b) - (let* ([args (make-args bg b)] - [expr (cons bg args)]) - (printf "~s:~n" expr) - (teval `(test ,v (quote ,bg) ,expr))))] - [make-bg - (lambda (b) - (cons nested-bg (make-args nested-bg b)))] - [make-test-bg-d - (lambda (bg) - (lambda (v1 v2 b) - (test-bg (if (eq? bg 'begin) - v1 - v2) - b)))] - [test-bg-d (make-test-bg-d bg)] - [test-bg-d2 (make-test-bg-d nested-bg)]) - (teval '(set! x 0)) - (test-bg-d 6 1 '((set! x 5) (+ x 1))) - (test-bg 5 '(5)) - (test-bg 3 '(2 3)) - (test-bg 3 `(2 (,bg 3))) - (test-bg 3 `(,(make-bg '(2)) ,(make-bg '(3)))) - (test-bg-d 7 6 '((set! x 6) 'a (+ x 1))) - (test-bg ''w '((set! x 6) 'a (+ x 1) 'w)) - (test-bg-d 8 7 '('b (set! x 7) (+ x 1))) - (test-bg-d 9 8 '('b (set! x 8) 'a (+ x 1))) - (test-bg ''z '('b (set! x 8) 'a (+ x 1) 'z)) - (test-bg-d 7 9 `(,(make-bg '((set! x 6) 'a)) (+ x 1))) - (test-bg 10 `(,(make-bg '((set! x 60) 'a)) 10)) - (teval '(test 60 'x x)) - (test-bg 10 `(,(make-bg '((set! x 65) 'a)) (add1 20) 10)) - (teval '(test 65 'x x)) - (test-bg ''a `(10 ,(make-bg '((set! x 66) 'a)))) - (teval '(test 66 'x x)) - (test-bg ''a `(10 (add1 32) ,(make-bg '((set! x 67) 'a)))) - (teval '(test 67 'x x)) - (teval '(set! x 6)) - (test-bg-d 8 7 `(,(make-bg '('b (set! x 7) 'a)) (+ x 1))) - (test-bg-d 9 8 `(,(make-bg '('b (set! x 8))) ,(make-bg '('a (+ x 1))))) - (test-bg-d2 10 9 `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1))))))))) - (test-bg ''s `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1) 's)))))))) - (test-bg ''t `(,(make-bg `(,(make-bg `('b (set! x 9) ,(make-bg '('a (+ x 1))))))) 't)) - (teval `(test 5 call-with-values (lambda () ,(make-bg '((values 1 2) (values 1 3 1)))) +)) - (syntax-test `(let () 10 (,bg) 5)) - (syntax-test `(,bg . 1)) - (syntax-test `(,bg 1 . 2)))) - -(test-begin 'begin 'begin) -(test-begin 'begin0 'begin) -(test-begin 'begin0 'begin0) -(test-begin 'begin 'begin0) - -(syntax-test `(begin0)) -(begin) ; must succeed, but we can't wrap it - -(test 4 'implicit-begin (let ([x 4][y 7]) 'y x)) -(test 4 'implicit-begin (let ([x 4][y 7]) y x)) - -(SECTION 4 2 5) -(define f-check #t) -(define f (delay (begin (set! f-check #f) 5))) -(test #t (lambda () f-check)) -(test 5 force f) -(test #f (lambda () f-check)) -(test 5 force f) -(define f-check-2 (delay (values 1 5))) -(test-values '(1 5) (lambda () (force f-check-2))) -(values 1 2) -(test-values '(1 5) (lambda () (force f-check-2))) -(syntax-test '(delay)) -(syntax-test '(delay . 1)) -(syntax-test '(delay 1 . 2)) -(syntax-test '(delay 1 2)) - -(SECTION 4 2 6) -(test '(list 3 4) 'quasiquote `(list ,(+ 1 2) 4)) -(test '(list a (quote a)) 'quasiquote (let ((name 'a)) `(list ,name ',name))) -(test '(a 3 4 5 6 b) 'quasiquote `(a ,(+ 1 2) ,@(map abs '(4 -5 6)) b)) -(test '((foo 7) . cons) - 'quasiquote - `((foo ,(- 10 3)) ,@(cdr '(c)) . ,(car '(cons)))) -(test '#(10 5 2 4 3 8) 'quasiquote `#(10 5 ,(sqrt 4) ,@(map sqrt '(16 9)) 8)) -(test 5 'quasiquote `,(+ 2 3)) -(test '(a `(b ,(+ 1 2) ,(foo 4 d) e) f) - 'quasiquote `(a `(b ,(+ 1 2) ,(foo ,(+ 1 3) d) e) f)) -(test '(a `(b ,x ,'y d) e) 'quasiquote - (let ((name1 'x) (name2 'y)) `(a `(b ,,name1 ,',name2 d) e))) -(test '(list 3 4) 'quasiquote (quasiquote (list (unquote (+ 1 2)) 4))) -(test '`(list ,(+ 1 2) 4) 'quasiquote '(quasiquote (list (unquote (+ 1 2)) 4))) -(test '(()) 'qq `((,@()))) -(define x 5) -(test '(quasiquote (unquote x)) 'qq ``,x) -(test '(quasiquote (unquote 5)) 'qq ``,,x) -(test '(quasiquote (unquote-splicing x)) 'qq ``,@x) -(test '(quasiquote (unquote-splicing 5)) 'qq ``,@,x) -(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote x)))))) 'qq ````,,,x) -(test '(quasiquote (quasiquote (quasiquote (unquote (unquote (unquote 5)))))) 'qq ````,,,,x) - -(test '(quasiquote (unquote result)) 'qq `(quasiquote ,result)) -(test (list 'quasiquote car) 'qq `(,'quasiquote ,car)) - -(syntax-test '(quasiquote)) -(syntax-test '(quasiquote . 5)) -(syntax-test '(quasiquote 1 . 2)) -(syntax-test '(quasiquote 1 2)) -(syntax-test '(unquote 7)) -(syntax-test '(unquote-splicing 7)) - -(syntax-test '`(1 . ,@5)) -(error-test '`(1 ,@5)) -(error-test '`(1 ,@5 2)) - -(define (qq-test e) - (syntax-test e ) - (syntax-test (list 'quasiquote e)) - (syntax-test (list 'quasiquote e)) - (syntax-test (list 'quasiquote (list 'quasiquote e))) - (syntax-test (list 'quasiquote (list 'quasiquote (list 'unquote e)))) - (syntax-test (list 'quasiquote (list 'quasiquote (list 'unquote-splicing e))))) -(qq-test '(unquote)) -(qq-test '(unquote 7 8 9)) -(qq-test '(unquote-splicing)) -(qq-test '(unquote-splicing 7 8 9)) - -(test '(unquote . 5) 'qq (quasiquote (unquote . 5))) -(test '(unquote 1 . 5) 'qq (quasiquote (unquote 1 . 5))) -(test '(unquote 1 2 . 5) 'qq (quasiquote (unquote 1 2 . 5))) - -(test '(unquote 1 2 7 . 5) 'qq (quasiquote (unquote 1 2 ,(+ 3 4) . 5))) -(test '(unquote 1 2 (unquote (+ 3 4)) . 5) 'qq (quasiquote (unquote 1 2 ,',(+ 3 4) . 5))) - -(test '(1 2 3 4 . 5) 'qq `(1 ,@'(2 3 4) . 5)) - -(error-test '`(10 ,(values 1 2)) arity?) -(error-test '`(10 ,@(values 1 2)) arity?) - -(SECTION 5 2 1) -(define add3 (lambda (x) (+ x 3))) -(test 6 'define (add3 3)) -(define (add3 x) (+ x 3)) -(test 6 'define (add3 3)) -(define first car) -(test 1 'define (first '(1 2))) -(syntax-test '(define)) -(syntax-test '(define . x)) -(syntax-test '(define x)) -(syntax-test '(define x . 1)) -(syntax-test '(define 1 2)) -(syntax-test '(define (1) 1)) -(syntax-test '(define (x 1) 1)) -(syntax-test '(define x 1 . 2)) -(syntax-test '(define x 1 2)) - -(define-values (add3) (lambda (x) (+ x 3))) -(test 6 'define (add3 3)) -(define-values (add3 another) (values (lambda (x) (+ x 3)) 9)) -(test 6 'define (add3 3)) -(test 9 'define another) -(define-values (first second third) (values car cadr caddr)) -(test 1 'define (first '(1 2))) -(test 2 'define (second '(1 2))) -(test 3 'define (third '(1 2 3))) -(define-values () (values)) -(syntax-test '(define-values)) -(syntax-test '(define-values . x)) -(syntax-test '(define-values x)) -(syntax-test '(define-values (x))) -(syntax-test '(define-values x . 1)) -(syntax-test '(define-values (x) . 1)) -(syntax-test '(define-values 1 2)) -(syntax-test '(define-values (1) 2)) -(syntax-test '(define-values (x 1) 1)) -(syntax-test '(define-values (x . y) 1)) -(syntax-test '(define-values (x) 1 . 2)) -(syntax-test '(define-values (x) 1 2)) - -(syntax-test '((define x 2) 0 1)) -(syntax-test '(+ (define x 2) 1)) -(syntax-test '(if (define x 2) 0 1)) -(syntax-test '(begin0 (define x 2))) -(syntax-test '(begin0 (define x 2) 0)) -(syntax-test '(begin0 0 (define x 2))) -(syntax-test '(begin0 0 (define x 2) (define x 12))) -(syntax-test '(let () (define x 2))) -(syntax-test '(letrec () (define x 2))) -(syntax-test '(lambda () (define x 2))) -(syntax-test '(lambda () (void (define x 2)) 1)) - -; Unfortunately, there's no good way to test this for mzc: -(unless (defined? 'building-flat-tests) - (error-test '(define x (values)) exn:application:arity?) - (error-test '(define x (values 1 2)) exn:application:arity?) - (error-test '(define-values () 3) exn:application:arity?) - (error-test '(define-values () (values 1 3)) exn:application:arity?) - (error-test '(define-values (x y) (values)) exn:application:arity?) - (error-test '(define-values (x y) 3) exn:application:arity?) - (error-test '(define-values (x y) (values 1 2 3)) exn:application:arity?)) - -(begin (define ed-t1 1) (define ed-t2 2)) -(test 1 'begin-define ed-t1) -(test 2 'begin-define ed-t2) -(begin (begin (begin (begin 10 (define ed-t2.5 2.5) 12)))) -(test 2.5 'begin-define ed-t2.5) -(syntax-test '(if (zero? 0) (define ed-t3 3) (define ed-t3 -3))) -(syntax-test '(if #t (define ed-t3 3) (define ed-t3 -3))) -(syntax-test '(if #f (define ed-t3 3) (define ed-t3 -3))) - -(SECTION 5 2 2) -(test 45 'define - (let ((x 5)) - (define foo (lambda (y) (bar x y))) - (define bar (lambda (a b) (+ (* a b) a))) - (foo (+ x 3)))) -(define x 34) -(define (foo) (define x 5) x) -(test 5 foo) -(test 34 'define x) -(define foo (lambda () (define x 5) x)) -(test 5 foo) -(test 34 'define x) -(define (foo x) ((lambda () (define x 5) x)) x) -(test 88 foo 88) -(test 4 foo 4) -(test 34 'define x) - -'(teval '(test 5 'define - (let () - (define x 5) - (define define (lambda (a b) (+ a b))) - (define x 7) - x))) -'(teval '(syntax-test '(let () - (define define 5) - (define y 6) - y))) - -(syntax-test '(let () - (define x 5))) -(syntax-test '(let () - (if #t - (define x 5)) - 5)) - -; Can't shadow syntax/macros with embedded defines -(syntax-test '(let () - (define lambda 5) - lambda)) -(syntax-test '(let () - (define define 5) - define)) - -(syntax-test '(lambda () (define x 10) (begin))) -(syntax-test '(lambda () (define x 10) (begin) (begin))) -(syntax-test '(lambda () (define x 10) (begin) (begin x) (begin))) - -(test 87 (lambda () (define x 87) (begin) (begin x))) - -(SECTION 4 2 4) -(test '#(0 1 2 3 4) 'do (do ((vec (make-vector 5)) - (i 0 (+ i 1))) - ((= i 5) vec) - (vector-set! vec i i))) -(test 25 'do (let ((x '(1 3 5 7 9))) - (do ((x x (cdr x)) - (sum 0 (+ sum (car x)))) - ((null? x) sum)))) -(test 1 'let (let foo () 1)) -(test '((6 1 3) (-5 -2)) 'let - (let loop ((numbers '(3 -2 1 6 -5)) - (nonneg '()) - (neg '())) - (cond ((null? numbers) (list nonneg neg)) - ((negative? (car numbers)) - (loop (cdr numbers) - nonneg - (cons (car numbers) neg))) - (else - (loop (cdr numbers) - (cons (car numbers) nonneg) - neg))))) -(test 5 'do (do ((x 1)) (#t 5))) -(test-values '(10 5) (lambda () (do ((x 1)) (#t (values 10 5))))) -(syntax-test '(do)) -(syntax-test '(do ()) ) -(syntax-test '(do () ()) ) -(syntax-test '(do (1) (#t 5) 5)) -(syntax-test '(do ((1)) (#t 5) 5)) -(syntax-test '(do ((1 7)) (#t 5) 5)) -(syntax-test '(do ((x . 1)) (#t 5) 5)) -(syntax-test '(do ((x 1) 2) (#t 5) 5)) -(syntax-test '(do ((x 1) . 2) (#t 5) 5)) -(syntax-test '(do ((x 1)) (#t . 5) 5)) -(syntax-test '(do ((x 1)) (#t 5) . 5)) - -(SECTION 'let/cc) - -(test 0 'let/cc (let/cc k (k 0) 1)) -(test 0 'let/cc (let/cc k 0)) -(test 1 'let/cc (let/cc k (cons 1 2) 1)) -(test-values '(2 1) (lambda () (let/cc k (values 2 1)))) -(test-values '(2 1) (lambda () (let/cc k (k 2 1)))) -(syntax-test '(let/cc)) -(syntax-test '(let/cc . k)) -(syntax-test '(let/cc k)) -(syntax-test '(let/cc k . 1)) -(syntax-test '(let/cc 1 1)) - -(test 0 'let/ec (let/ec k (k 0) 1)) -(test 0 'let/ec (let/ec k 0)) -(test 1 'let/ec (let/ec k (cons 1 2) 1)) -(test-values '(2 1) (lambda () (let/ec k (values 2 1)))) -(test-values '(2 1) (lambda () (let/ec k (k 2 1)))) -(syntax-test '(let/ec)) -(syntax-test '(let/ec . k)) -(syntax-test '(let/ec k)) -(syntax-test '(let/ec k . 1)) -(syntax-test '(let/ec 1 1)) - -(SECTION 'fluid-let) -(define x 1) -(define y -1) -(define (get-x) x) -(test 5 'fluid-let (fluid-let () 5)) -(test 2 'fluid-let (fluid-let ([x 2]) x)) -(test 0 'fluid-let (fluid-let ([x 2][y -2]) (+ x y))) -(test 20 'fluid-let (fluid-let ([x 20]) (get-x))) -(test 1 'fluid-let-done x) -(error-test '(fluid-let ([x 10]) (error 'bad)) exn:user?) -(test 1 'fluid-let-done-escape x) -(test 3 'fluid-let (let* ([x 0][y (lambda () x)]) (fluid-let ([x 3]) (y)))) -(test 0 'fluid-let (let* ([x 0][y (lambda () x)]) (fluid-let ([x 3]) (y)) (y))) -(test-values '(34 56) (lambda () (fluid-let ([x 34][y 56]) (values x y)))) -(test 'second 'fluid-let (fluid-let ([x 2][y -2]) (+ x y) 'second)) - -(error-test '(fluid-let ([undefined-variable 0]) 8) exn:variable?) - -(syntax-test '(fluid-let)) -(syntax-test '(fluid-let . 1)) -(syntax-test '(fluid-let x 9)) -(syntax-test '(fluid-let 1 9)) -(syntax-test '(fluid-let (x) 9)) -(syntax-test '(fluid-let ([x]) 9)) -(syntax-test '(fluid-let ([x . 5]) 9)) -(syntax-test '(fluid-let ([x 5] . y) 9)) -(syntax-test '(fluid-let ([x 5] [y]) 9)) -(syntax-test '(fluid-let ([x 5]) . 9)) -(syntax-test '(fluid-let ([x 5]) 9 . 10)) - -(SECTION 'parameterize) - -(test 5 'parameterize (parameterize () 5)) -(test 6 'parameterize (parameterize ([error-print-width 10]) 6)) -(test 7 'parameterize (parameterize ([error-print-width 10] - [current-exception-handler void]) - 7)) -(define oepw (error-print-width)) -(error-test '(parameterize ([error-print-width 777]) (error 'bad)) exn:user?) -(test oepw 'parameterize (error-print-width)) -(error-test '(parameterize ([error-print-width 777] - [current-output-port (current-error-port)]) - (error 'bad)) - exn:user?) -(error-test '(parameterize ([error-print-width 'a]) 10)) - -(define p (make-parameter 1)) -(define q (make-parameter 2)) -(test '1 'pz-order (parameterize ([p 3][q (p)]) (q))) - -(error-test '(parameterize) syntaxe?) -(error-test '(parameterize ()) syntaxe?) -(error-test '(parameterize ((x y))) syntaxe?) -(error-test '(parameterize ((x y)) . 8) syntaxe?) -(error-test '(parameterize (x) 8) syntaxe?) -(error-test '(parameterize (9) 8) syntaxe?) -(error-test '(parameterize ((x z) . y) 8) syntaxe?) -(error-test '(parameterize ((x . z)) 8) syntaxe?) -(error-test '(parameterize ((x . 9)) 8) syntaxe?) -(error-test '(parameterize ((x . 9)) 8) syntaxe?) - -(SECTION 'time) -(test 1 'time (time 1)) -(test -1 'time (time (cons 1 2) -1)) -(test-values '(-1 1) (lambda () (time (values -1 1)))) -(syntax-test '(time)) -(syntax-test '(time . 1)) -(syntax-test '(time 1 . 2)) - -(SECTION 'compiler) -; Tests specifically aimed at the compiler -(error-test '(let ([x (values 1 2)]) x) exn:application:arity?) -; Known primitive -(error-test '(let ([x (#%make-pipe)]) x) exn:application:arity?) -; Known local -(error-test '(let* ([f (lambda () (values 1 2))][x (f)]) x) exn:application:arity?) - -; Known local with global in its closure -(test 15 'known (let ([g (lambda () - (letrec ([f (lambda (x) - (+ x 5))]) - (f 10)))]) - (g))) -; Known local with a set! -(test 16 'known (let ([g (lambda () - (letrec ([f (lambda (x) - (let ([y x]) - (set! x 7) - (+ y 5)))]) - (f 11)))]) - (g))) -; Known local non-function -(error-test '(apply (lambda () (let ([f 12]) (f))) null) exn:application:type?) -; Known local with revsed arguments: -(test 10 (letrec ([f (lambda (a b) (if (zero? a) b (f b a)))]) f) 10 0) - -(report-errs) diff --git a/collects/tests/mzscheme/tcp.ss b/collects/tests/mzscheme/tcp.ss deleted file mode 100644 index 3a917a63..00000000 --- a/collects/tests/mzscheme/tcp.ss +++ /dev/null @@ -1,59 +0,0 @@ - -(define id 40000) - -(define max-send 100000) -(define print-mod 10000) - -(define (client host) - (lambda () - (let-values ([(r w) (tcp-connect host id)]) - (values r w void)))) - -(define server - (lambda () - (let ([l (tcp-listen id)]) - (let-values ([(r w) (tcp-accept l)]) - (values r w (lambda () (tcp-close l))))))) - -(define (tread connect) - (let-values ([(r w close) (connect)]) - (printf "Hit return to start reading~n") - (read-line) - (let loop ([last -1]) - (let ([v (read r)]) - (if (eof-object? v) - (begin - (close-input-port r) - (close-output-port w) - (close) - last) - (begin - (unless (= v (add1 last)) - (printf "skipped! ~a ~a~n" last v)) - (when (zero? (modulo v print-mod)) - (printf "got ~a~n" v)) - (loop v))))))) - -(define (twrite connect) - (let-values ([(r w close) (connect)] - [(t) (thread (lambda () - (let loop () - (sleep 1) - (printf "tick~n") - (loop))))]) - (let ([done (lambda () - (close-output-port w) - (close-input-port r) - (close) - (kill-thread t))]) - (let loop ([n 0]) - (if (= n max-send) - (begin - (printf "stopped before ~a~n" n) - (done)) - - (begin - (fprintf w "~s~n" n) - (when (zero? (modulo n print-mod)) - (printf "sent ~a~n" n)) - (loop (add1 n)))))))) diff --git a/collects/tests/mzscheme/testing.ss b/collects/tests/mzscheme/testing.ss deleted file mode 100644 index 0bca4bf5..00000000 --- a/collects/tests/mzscheme/testing.ss +++ /dev/null @@ -1,250 +0,0 @@ -;;; `test.scm' Test correctness of MzScheme implementations. -;;; Copyright (C) 1991, 1992, 1993, 1994 Aubrey Jaffer. -;;; Modified for MzScheme by Matthew - -;;; MODIFIED for MzScheme - Matthew 8/95 -;;; Added a few more tests, like append!, reverse!, etc. -;;; Added testing for inexact numbers -;;; Added a lot of error testing -;;; modified for rational and complex numbers - Matthew 12/95 -;;; modified to test exceptions and more of MzScheme - Matthew 4/96 -;;; split into multiple files - Matthew 4/96 -;;; extended, extended, extended - -;;; This includes examples from -;;; William Clinger and Jonathan Rees, editors. -;;; Revised^4 Report on the Algorithmic Language Scheme -;;; and the IEEE specification. - -; The format of the next line is important: file.ss relies on it -(define cur-section '())(define errs '()) - -(define teval eval) - -(define SECTION (lambda args - (let ([ep (current-error-port)]) - (display "SECTION" ep) (write args ep) (newline ep) - (set! cur-section args) #t))) -(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) - -(print-struct #t) - -(define number-of-tests 0) -(define number-of-error-tests 0) -(define number-of-exn-tests 0) - -(define test - (lambda (expect fun . args) - (set! number-of-tests (add1 number-of-tests)) - (write (cons fun args)) - (display " ==> ") - (flush-output) - ((lambda (res) - (write res) - (newline) - (cond ((not (equal? expect res)) - (record-error (list res expect (cons fun args))) - (display " BUT EXPECTED ") - (write expect) - (newline) - #f) - (else #t))) - (if (procedure? fun) (apply fun args) (car args))))) - -(define exn-table - (list (cons exn? (cons exn-message string?)) - (cons exn? (cons exn-continuation-marks continuation-mark-set?)) - (cons exn:variable? (cons exn:variable-id symbol?)) - (cons exn:application:arity? (cons exn:application-value integer?)) - (cons exn:application:arity? (cons exn:application:arity-expected - (lambda (a) - (or (integer? a) - (and (arity-at-least? a) - (integer? (arity-at-least-value a))) - (and (list? a) - (andmap - (lambda (a) - (or (integer? a) - (and (arity-at-least? a) - (integer? - (arity-at-least-value a))))) - a)))))) - (cons exn:application:type? (cons exn:application:type-expected symbol?)) - - (cons exn:i/o:port? (cons exn:i/o:port-port (lambda (x) (or (input-port? x) (output-port? x))))) - (cons exn:i/o:port:read? (cons exn:i/o:port-port input-port?)) - (cons exn:i/o:port:write? (cons exn:i/o:port-port output-port?)) - (cons exn:i/o:port:user? (cons exn:i/o:port-port input-port?)) - (cons exn:i/o:filesystem? (cons exn:i/o:filesystem-pathname string?)) - (cons exn:i/o:filesystem? (cons exn:i/o:filesystem-detail (lambda (x) - (memq x '(#f - ill-formed-path - already-exists - wrong-version))))))) - -(define mz-test-syntax-errors-allowed? #t) - -(define thunk-error-test - (case-lambda - [(th expr) (thunk-error-test th expr exn:application:type?)] - [(th expr exn?) - (set! number-of-error-tests (add1 number-of-error-tests)) - (write expr) - (display " =e=> ") - (call/ec (lambda (escape) - (let* ([old-esc-handler (error-escape-handler)] - [old-handler (current-exception-handler)] - [orig-err-port (current-error-port)] - [test-handler - (lambda () - (escape #t))] - [test-exn-handler - (lambda (e) - (when (and exn? (not (exn? e))) - (printf " WRONG EXN TYPE: ~s " e) - (record-error (list e 'exn-type expr))) - (when (and (exn:syntax? e) - (not mz-test-syntax-errors-allowed?)) - (printf " LATE SYNTAX EXN: ~s " e) - (record-error (list e 'exn-late expr))) - - (for-each - (lambda (row) - (let ([pred? (car row)]) - (when (pred? e) - (set! number-of-exn-tests - (add1 number-of-exn-tests)) - (let ([sel (cadr row)] - [pred? (cddr row)]) - (unless (pred? (sel e)) - (printf " WRONG EXN ELEM: ~s " e) - (record-error (list e 'exn-elem expr))))))) - exn-table) - - (old-handler e))]) - (dynamic-wind - (lambda () - (current-error-port (current-output-port)) - (current-exception-handler test-exn-handler) - (error-escape-handler test-handler)) - (lambda () - (let ([v (th)]) - (write v) - (display " BUT EXPECTED ERROR") - (record-error (list v 'Error expr)) - (newline) - #f)) - (lambda () - (current-error-port orig-err-port) - (current-exception-handler old-handler) - (error-escape-handler old-esc-handler))))))])) - -(if (not (defined? 'error-test)) - (global-defined-value - 'error-test - (case-lambda - [(expr) (error-test expr exn:application:type?)] - [(expr exn?) - (thunk-error-test (lambda () (eval expr)) expr exn?)]))) - -(define (syntax-test expr) - (error-test expr exn:syntax?) - (error-test `(if #f ,expr) exn:syntax?)) - -(define (arity-test f min max) - (letrec ([aok? - (lambda (a) - (cond - [(integer? a) (= a min max)] - [(arity-at-least? a) (and (negative? max) - (= (arity-at-least-value a) min))] - [(and (list? a) (andmap integer? a)) - (and (= min (car a)) (= max - (let loop ([l a]) - (if (null? (cdr l)) - (car l) - (loop (cdr l))))))] - [(list? a) - ; Just check that all are consistent for now. - ; This should be improved. - (andmap - (lambda (a) - (if (number? a) - (<= min a (if (negative? max) a max)) - (>= (arity-at-least-value a) min))) - a)] - [else #f]))] - [make-ok? - (lambda (v) - (lambda (e) - (and (exn:application:arity? e) - (= (exn:application-value e) v) - (aok? (exn:application:arity-expected e)))))] - [do-test - (lambda (f args check?) - (set! number-of-error-tests (add1 number-of-error-tests)) - (printf "(apply ~s '~s) =e=> " f args) - (let/ec done - (let ([v (with-handlers ([void - (lambda (exn) - (if (check? exn) - (printf " ~a~n" (exn-message exn)) - (let ([ok-type? (exn:application:arity? exn)]) - (printf " WRONG EXN ~a: ~s~n" - (if ok-type? - "FIELD" - "TYPE") - exn) - (record-error (list exn - (if ok-type? - 'exn-field - 'exn-type) - (cons f args))))) - (done (void)))]) - (apply f args))]) - (printf "~s~n BUT EXPECTED ERROR~n" v) - (record-error (list v 'Error (cons f args))))))]) - (let loop ([n 0][l '()]) - (unless (>= n min) - (do-test f l (make-ok? n)) - (loop (add1 n) (cons 1 l)))) - (let loop ([n min]) - (test #t procedure-arity-includes? f n) - (unless (>= n max) - (loop (add1 n)))) - (if (>= max 0) - (do-test f (let loop ([n 0][l '(1)]) - (if (= n max) - l - (loop (add1 n) (cons 1 l)))) - (make-ok? (add1 max))) - (test #t procedure-arity-includes? f (arithmetic-shift 1 100))))) - -(define (test-values l thunk) - (test l call-with-values thunk list)) - -(define (report-errs) - (printf "~nPerformed ~a expression tests (~a good expressions, ~a bad expressions)~n" - (+ number-of-tests number-of-error-tests) - number-of-tests - number-of-error-tests) - (printf "and ~a exception field tests.~n~n" - number-of-exn-tests) - (if (null? errs) - (display "Passed all tests.") - (begin - (display "Errors were:") - (newline) - (display "(SECTION (got expected (call)))") - (newline) - (for-each (lambda (l) (write l) (newline)) - errs))) - (newline) - (display "(Other messages report successful tests of error-handling behavior.)") - (newline)) - -(define type? exn:application:type?) -(define arity? exn:application:arity?) -(define syntaxe? exn:syntax?) - -(define non-z void) diff --git a/collects/tests/mzscheme/thread.ss b/collects/tests/mzscheme/thread.ss deleted file mode 100644 index c07850d3..00000000 --- a/collects/tests/mzscheme/thread.ss +++ /dev/null @@ -1,369 +0,0 @@ - - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'threads) - -(define SLEEP-TIME 0.1) - -(define t (thread (lambda () 8))) -(test #t thread? t) - -(arity-test thread 1 1) -(error-test '(thread 5) type?) -(error-test '(thread (lambda (x) 8)) type?) -(arity-test thread? 1 1) - -; Should be able to make an arbitrarily deep chain of custodians -; if only the first & last are accssible: -(test #t custodian? - (let loop ([n 1000][c (current-custodian)]) - (if (zero? n) - c - (loop (sub1 n) (make-custodian c))))) - -(define result 0) -(define th1 0) -(define set-ready - (let ([s (make-semaphore 1)] - [r #f]) - (lambda (v) - (semaphore-wait s) - (begin0 - r - (set! r v) - (semaphore-post s))))) -(define cm (make-custodian)) -(define th2 (parameterize ([current-custodian cm]) - (thread - (lambda () - (let ([cm2 (make-custodian cm)]) - (parameterize ([current-custodian cm2]) - (set! th1 (thread - (lambda () - (let loop () - (let ([r (set-ready #f)]) - (sleep SLEEP-TIME) - (set! result (add1 result)) - (when r (semaphore-post r))) - (loop))))))))))) -(define start result) -(let ([r (make-semaphore)]) - (set-ready r) - (semaphore-wait r)) -(test #f eq? start result) -(kill-thread th2) -(set! start result) -(let ([r (make-semaphore)]) - (set-ready r) - (semaphore-wait r)) -(test #f eq? start result) -(test #t thread-running? th1) -(custodian-shutdown-all cm) -(thread-wait th1) -(set! start result) -(test #f thread-running? th1) -(sleep SLEEP-TIME) -(test #t eq? start result) - -(let ([kept-going? #f]) - (let ([c (make-custodian)]) - (parameterize ([current-custodian c]) - (thread-wait - (thread - (lambda () - (custodian-shutdown-all c) - (set! kept-going? #t)))))) - (test #f 'kept-going-after-shutdown? kept-going?)) - -(error-test `(parameterize ([current-custodian cm]) (kill-thread (current-thread))) - exn:misc?) - -(test #t custodian? cm) -(test #f custodian? 1) -(arity-test custodian? 1 1) - -(arity-test custodian-shutdown-all 1 1) - -(arity-test make-custodian 0 1) -(error-test '(make-custodian 0)) - -(test (void) kill-thread t) -(arity-test kill-thread 1 1) -(error-test '(kill-thread 5) type?) - -(test #t thread-running? (current-thread)) -(arity-test thread-running? 1 1) -(error-test '(thread-running? 5) type?) - -(arity-test sleep 0 1) -(error-test '(sleep 'a) type?) -(error-test '(sleep 1+3i) type?) - -(define s (make-semaphore 1)) - -(test #t semaphore? s) - -(arity-test make-semaphore 0 1) -(error-test '(make-semaphore "a") type?) -(error-test '(make-semaphore -1) type?) -(error-test '(make-semaphore 1.0) type?) -(error-test '(make-semaphore (expt 2 64)) exn:application:mismatch?) -(arity-test semaphore? 1 1) - -(define test-block - (lambda (block? thunk) - (let* ([hit? #f] - [t (parameterize ([current-custodian (make-custodian)]) - (thread (lambda () (thunk) (set! hit? #t))))]) - (sleep SLEEP-TIME) - (begin0 (test block? 'nondeterministic-block-test (not hit?)) - (kill-thread t))))) - -(test #t semaphore-try-wait? s) -(test #f semaphore-try-wait? s) -(semaphore-post s) -(test #t semaphore-try-wait? s) -(test #f semaphore-try-wait? s) -(semaphore-post s) -(test-block #f (lambda () (semaphore-wait s))) -(test-block #t (lambda () (semaphore-wait s))) -(semaphore-post s) -(test-block #f (lambda () (semaphore-wait/enable-break s))) -(test-block #t (lambda () (semaphore-wait/enable-break s))) - -(arity-test semaphore-try-wait? 1 1) -(arity-test semaphore-wait 1 1) -(arity-test semaphore-post 1 1) - -(define s (make-semaphore)) -(define result 0) -(define t-loop - (lambda (n m) - (lambda () - (if (zero? n) - (begin - (set! result m) - (semaphore-post s)) - (thread (t-loop (sub1 n) (add1 m))))))) -(thread (t-loop 25 1)) -(semaphore-wait s) -(test 26 'thread-loop result) - -; Make sure you can break a semaphore-wait: -(test 'ok - 'break-semaphore-wait - (let* ([s1 (make-semaphore 0)] - [s2 (make-semaphore 0)] - [t (thread (lambda () - (semaphore-post s1) - (with-handlers ([exn:misc:user-break? (lambda (x) (semaphore-post s2))]) - (semaphore-wait (make-semaphore 0)))))]) - (semaphore-wait s1) - (sleep SLEEP-TIME) - (break-thread t) - (semaphore-wait s2) - 'ok)) - -; Make sure two waiters can be released -(test 'ok - 'double-semaphore-wait - (let* ([s1 (make-semaphore 0)] - [s2 (make-semaphore 0)] - [go (lambda () - (semaphore-post s2) - (semaphore-wait s1) - (semaphore-post s2))]) - (thread go) (thread go) - (semaphore-wait s2) (semaphore-wait s2) - (semaphore-post s1) (semaphore-post s1) - (semaphore-wait s2) (semaphore-wait s2) - 'ok)) - -; Tests inspired by a question from David Tillman -(define (read-line/expire1 port expiration) - (with-handlers ([exn:misc:user-break? (lambda (exn) #f)]) - (let ([timer (thread (let ([id (current-thread)]) - (lambda () - (sleep expiration) - (break-thread id))))]) - (dynamic-wind - void - (lambda () (read-line port)) - (lambda () (kill-thread timer)))))) -(define (read-line/expire2 port expiration) - (let ([done (make-semaphore 0)] - [result #f]) - (let ([t1 (thread (lambda () - (set! result (read-line port)) - (semaphore-post done)))] - [t2 (thread (lambda () - (sleep expiration) - (semaphore-post done)))]) - (semaphore-wait done) - (kill-thread t1) - (kill-thread t2) - result))) - -(define (go read-line/expire) - (define p (let ([c 0] - [nl-sleep? #f] - [nl? #f]) - (make-input-port (lambda () - (when nl-sleep? - (sleep 0.4) - (set! nl-sleep? #f)) - (if nl? - (begin - (set! nl? #f) - #\newline) - (begin - (set! nl? #t) - (set! nl-sleep? #t) - (set! c (add1 c)) - (integer->char c)))) - (lambda () - (when nl-sleep? - (sleep 0.4) - (set! nl-sleep? #f)) - #t) - void))) - (test #f read-line/expire p 0.2) ; should get char but not newline - (test "" read-line/expire p 0.6)) ; picks up newline - -(go read-line/expire1) -(go read-line/expire2) - -;; Make sure queueing works, and check kill/wait interaction: -(let* ([s (make-semaphore)] - [l null] - [wait (lambda (who) - (thread - (lambda () - (semaphore-wait s) - (set! l (cons who l)))))] - [pause (lambda () (sleep 0.01))]) - (wait 0) (pause) - (wait 1) (pause) - (wait 2) - (pause) - (test null 'queue l) - (semaphore-post s) (pause) - (test '(0) 'queue l) - (semaphore-post s) (pause) - (test '(1 0) 'queue l) - (semaphore-post s) (pause) - (test '(2 1 0) 'queue l) - - (set! l null) - (wait 0) (pause) - (let ([t (wait 1)]) - (pause) - (wait 2) - (pause) - (test null 'queue l) - (kill-thread t) - (semaphore-post s) (pause) - (test '(0) 'queue l) - (semaphore-post s) (pause) - (test '(2 0) 'queue l) - (semaphore-post s) (pause) - (test '(2 0) 'queue l) - (wait 3) (pause) - (test '(3 2 0) 'queue l))) - -;; Nested threads -(test 5 call-in-nested-thread (lambda () 5)) - -(error-test '(call-in-nested-thread (lambda () (kill-thread (current-thread)))) exn:thread?) -(error-test '(call-in-nested-thread (lambda () ((error-escape-handler)))) exn:thread?) -(error-test '(call-in-nested-thread (lambda () (raise (box 5)))) box?) - -(define c1 (make-custodian)) -(define c2 (make-custodian)) -(define c3 (make-custodian)) -(define output-stream null) -(define (output v) - (set! output-stream - (append output-stream (list v)))) -(define (test-stream v) - (test v 'output-stream output-stream)) - -(define (chain c) - (set! output-stream null) - - (output 'os) - (with-handlers ([void (lambda (x) x)]) - (call-in-nested-thread - (lambda () - (output 'ms) - (begin0 - (dynamic-wind - (lambda () (output 'mpre)) - (lambda () - (let ([t1 (current-thread)]) - (call-in-nested-thread - (lambda () - (output 'is) - (with-handlers ([void (lambda (x) - (if (exn:misc:user-break? x) - (output 'ibreak) - (output 'iother)) - (raise x))]) - (if (procedure? c) - (c t1) - (custodian-shutdown-all c))) - (output 'ie) - 'inner-result) - c2))) - (lambda () (output 'mpost))) - (output 'me))) - c1))) - -(test 'inner-result chain c3) -(test-stream '(os ms mpre is ie mpost me)) - -(test #t exn:thread? (chain c1)) -(test-stream '(os ms mpre is ibreak)) - -(parameterize ([break-enabled #f]) - (test #t exn:thread? (chain c1)) - (test-stream '(os ms mpre is ie))) - -(test #t exn:thread? (chain c2)) -(test-stream '(os ms mpre is mpost)) - -(test #t exn:thread? (chain (lambda (t1) (kill-thread (current-thread))))) -(test-stream '(os ms mpre is mpost)) - -(test #t exn:application? (chain 'wrong)) -(test-stream '(os ms mpre is iother mpost)) - -(test #t exn:misc:user-break? (chain (let ([t (current-thread)]) (lambda (t1) (break-thread t))))) -(test-stream '(os ms mpre is ibreak mpost)) - -(test #t exn:thread? (chain (lambda (t1) (kill-thread t1)))) -(test-stream '(os ms mpre is ibreak)) - -(parameterize ([break-enabled #f]) - (test #t exn:thread? (let ([t (current-thread)]) - (chain (lambda (t1) - (custodian-shutdown-all c1) - (test #t thread-running? (current-thread)) - (test #t thread-running? t) - (test #f thread-running? t1))))) - (test-stream '(os ms mpre is ie))) - -(error-test '(let/cc k (call-in-nested-thread (lambda () (k)))) exn:application:continuation?) -(error-test '(let/ec k (call-in-nested-thread (lambda () (k)))) exn:application:continuation?) -(error-test '((call-in-nested-thread (lambda () (let/cc k k)))) exn:application:continuation?) -(error-test '((call-in-nested-thread (lambda () (let/ec k k)))) exn:application:continuation?) - -(error-test '(call-in-nested-thread 5)) -(error-test '(call-in-nested-thread (lambda (x) 10))) -(error-test '(call-in-nested-thread (lambda () 10) 5)) - -(arity-test call-in-nested-thread 1 2) - -(report-errs) diff --git a/collects/tests/mzscheme/thrport.ss b/collects/tests/mzscheme/thrport.ss deleted file mode 100644 index 86d378ff..00000000 --- a/collects/tests/mzscheme/thrport.ss +++ /dev/null @@ -1,59 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'multi-threaded-ports) - -; Read from file with 3 threads, all writing to the same pipe -; read from pipe with 3 threads, all writing to the same output string -; compare resulting character content to the original file -(test 0 'threaded-ports - (let*-values ([(f-in) (open-input-file - (path->complete-path "testing.ss" - (current-load-relative-directory)))] - [(p-in p-out) (make-pipe)] - [(s-out) (open-output-string)] - [(in->out) (lambda (in out) - (lambda () - (let loop () - (let ([c (read-char in)] - [dummy (lambda () 'hi)]) - (unless (eof-object? c) - (write-char c out) - (loop))))))] - [(f->p) (in->out f-in p-out)] - [(p->s) (in->out p-in s-out)] - [(sthread) (lambda (thunk) - (let ([t (thread (lambda () (sleep) (thunk)))]) - (thread-weight t 101) - t))]) - (thread - (lambda () - (for-each thread-wait - (list (sthread f->p) - (sthread f->p) - (sthread f->p))) - (close-output-port p-out))) - (for-each thread-wait - (list (sthread p->s) - (sthread p->s) - (sthread p->s))) - (let ([s (get-output-string s-out)] - [hits (make-vector 256 0)]) - (for-each (lambda (c) - (let ([n (char->integer c)]) - (vector-set! hits n (add1 (vector-ref hits n))))) - (string->list s)) - (file-position f-in 0) - (let loop () - (let ([c (read-char f-in)]) - (unless (eof-object? c) - (let ([n (char->integer c)]) - (vector-set! hits n (sub1 (vector-ref hits n)))) - (loop)))) - (let loop ([i 0][total 0]) - (if (= i 256) - total - (loop (add1 i) (+ total (abs (vector-ref hits i))))))))) - -(report-errs) diff --git a/collects/tests/mzscheme/ttt/listlib.ss b/collects/tests/mzscheme/ttt/listlib.ss deleted file mode 100644 index 15221d58..00000000 --- a/collects/tests/mzscheme/ttt/listlib.ss +++ /dev/null @@ -1,42 +0,0 @@ -;; -------------------------------------------------------------------------- -;; list-library.ss -;; export: -;; collect: -;; (A ((cons B (listof B)) (listof B) (union A C) -> (union A C)) -;; -> -;; ((listof B) -> (union A C))) - -; #| -; (unit/sig -; (collect filter set-minus subset?) -; (import plt:userspace^) -; |# - - (define collect - (lambda (base combine) - (letrec ([C - (lambda (l) - (cond - ((null? l) base) - (else (combine l (car l) (C (cdr l))))))]) - C))) - - (define filter - (lambda (p? l) - [(collect null (lambda (_ x rest) (if (p? x) (cons x rest) rest))) l])) - - ;; set library - (define set-minus - (lambda (set1 set2) - [(collect null (lambda (_ e1 rest) (if (member e1 set2) rest (cons e1 rest)))) - set1])) - - (define subset? - (lambda (state1 state2) - (cond - ((null? state1) #t) - (else (and (member (car state1) state2) - (subset? (cdr state1) state2)))))) -; #| -; ) -; |# diff --git a/collects/tests/mzscheme/ttt/tic-bang.ss b/collects/tests/mzscheme/ttt/tic-bang.ss deleted file mode 100644 index 85422cdc..00000000 --- a/collects/tests/mzscheme/ttt/tic-bang.ss +++ /dev/null @@ -1,123 +0,0 @@ -;; -------------------------------------------------------------------------- -;; tic-bang.ss -;; This is an imperative version. - -;; This program plays through all possibilities of a tic-tac-toe -;; game, given the first move of a player. It only prints how many -;; states are being processed and how many states are terminal at -;; each stage of the game. - -;; This program lacks the capability to print how a situation arose. - -;; It relies on list-library.ss. - -;; representations of fields, states, and collections of states -(define BLANK 0) - -(define new-state - (lambda () - (make-2vec 3 BLANK))) - -(define update-state - (lambda (state x y token) - (2vec-set! state x y token) - state)) - -(define blank? - (lambda (astate i j) - (eq? (2vec-ref astate i j) BLANK))) - -(define clone-state - (lambda (state) - (let ((s (new-state))) - (let loop ((i 0) (j 0)) - (cond - ((and (= i 3) (= j 0)) (void)) - ((< j 3) (update-state s i j (2vec-ref state i j)) (loop i (+ j 1))) - ((< i 3) (loop (+ i 1) 0)) - (else 'bad))) - s))) - -;(define-type state (2vector (union 'x 'o '_))) -;(define-type states (listof state)) - -(define PLAYER 1) -(define OPPONENT 2) - -(define tic-tac-toe - (lambda (x y) - (tic (list (update-state (new-state) (- x 1) (- y 1) PLAYER))))) - -(define make-move - (lambda (other-move p/o tag) - (lambda (states) - (printf "~s: processing ~s states ~n" tag (length states)) - (let ((t (print&remove-terminals states))) - (printf "terminal states removed: ~s~n" - (- (length states) (length t))) - (if (null? t) - (void) - (other-move (apply append (map p/o t)))))))) - -(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic)) - -(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac)) - -(define make-players - (lambda (p/o) - (lambda (astate) - (let loop ((i 0) (j 0)) - (cond - ((and (= i 3) (= j 0)) null) - ((< j 3) (if (blank? astate i j) - (cons (update-state (clone-state astate) i j p/o) - (loop i (+ j 1))) - (loop i (+ j 1)))) - ((< i 3) (loop (+ i 1) 0)) - (else (error 'make-player "ouch"))))))) - -(define player (make-players PLAYER)) - -(define opponent (make-players OPPONENT)) - -(define print&remove-terminals - (local ((define print-state - (lambda (x) - ;(display ".") - (void)))) - - (collect null (lambda (_ astate rest) - (if (terminal? astate) - (begin (print-state astate) rest) - (cons astate rest)))))) - -(define terminal? - (lambda (astate) - (or (terminal-row 0 astate) - (terminal-row 1 astate) - (terminal-row 2 astate) - (terminal-col 0 astate) - (terminal-col 1 astate) - (terminal-col 2 astate) - (terminal-posdg astate) - (terminal-negdg astate)))) - -(define terminal-row - (lambda (n state) - (and (not (blank? state n 0)) - (= (2vec-ref state n 0) (2vec-ref state n 1) (2vec-ref state n 2))))) - -(define terminal-col - (lambda (n state) - (and (not (blank? state 0 n)) - (= (2vec-ref state 0 n) (2vec-ref state 1 n) (2vec-ref state 2 n))))) - -(define terminal-posdg - (lambda (state) - (and (not (blank? state 0 0)) - (= (2vec-ref state 0 0) (2vec-ref state 1 1) (2vec-ref state 2 2))))) - -(define terminal-negdg - (lambda (state) - (and (not (blank? state 0 2)) - (= (2vec-ref state 0 2) (2vec-ref state 1 1) (2vec-ref state 2 0))))) diff --git a/collects/tests/mzscheme/ttt/tic-func.ss b/collects/tests/mzscheme/ttt/tic-func.ss deleted file mode 100644 index 538d4569..00000000 --- a/collects/tests/mzscheme/ttt/tic-func.ss +++ /dev/null @@ -1,120 +0,0 @@ -;; -------------------------------------------------------------------------- -;; tic-func.ss -;; This program plays through all possibilities of a tic-tac-toe -;; game, given the first move of a player. It only prints how many -;; states are being processed and how many states are terminal at -;; each stage of the game. But it is constructed so that it can -;; print how to get to a winning terminal state. - -;; It relies on list-library.ss. - -;; representations of fields, states, and collections of states -(define null '()) -(define-structure (entry x y who)) -(define entry-field - (lambda (an-entry) - (list (entry-x an-entry) (entry-y an-entry)))) -;(define-type state (listof (structure:entry num num (union 'x 'o))) -;(define-type states (listof state)) - -(define PLAYER 'x) -(define OPPONENT 'o) - -(define tic-tac-toe - (lambda (x y) - (tic (list (list (make-entry x y PLAYER)))))) - -(define make-move - (lambda (other-move p/o tag) - (lambda (states) - (printf "~s: processing ~s states of length ~s ~n" - tag (length states) (length (car states))) - (let ((t (print&remove-terminals states))) - (printf "terminal states removed: ~s~n" - (- (length states) (length t))) - (if (null? t) - (void) - (other-move (apply append (map p/o t)))))))) - -(define tic (make-move (lambda (x) (tac x)) (lambda (x) (opponent x)) 'tic)) - -(define tac (make-move (lambda (x) (tic x)) (lambda (x) (player x)) 'tac)) - -(define make-players - (let () - (define rest-of-fields - (lambda (used-fields) - (set-minus ALL-FIELDS used-fields))) - (lambda (player/opponent) - (lambda (astate) - (map (lambda (counter-move) - (let ((counter-x (car counter-move)) - (counter-y (cadr counter-move))) - (cons (make-entry counter-x counter-y player/opponent) - astate))) - (rest-of-fields (map entry-field astate))))))) - -(define player (make-players PLAYER)) - -(define opponent (make-players OPPONENT)) - -(define terminal? - (let () (define filter-p/o - (lambda (p/o astate) - (map entry-field - (filter (lambda (x) (eq? (entry-who x) p/o)) astate)))) - (lambda (astate) - (and (>= (length astate) 5) - (let ((PLAYERf (filter-p/o PLAYER astate)) - (OPPONENTf (filter-p/o OPPONENT astate))) - (or - (= (length astate) 9) - (ormap (lambda (ts) (subset? ts PLAYERf)) TERMINAL-STATES) - (ormap (lambda (ts) (subset? ts OPPONENTf)) TERMINAL-STATES))))))) - -(define print&remove-terminals - (let () - - (define print-state1 - (lambda (x) - (display x) - (newline))) - - (define print-state2 - (lambda (astate) - (cond - ((null? astate) (printf "------------~n")) - (else (print-state (cdr astate)) - (let ((x (car astate))) - (printf " ~s @ (~s,~s) ~n" - (entry-who x) (entry-x x) (entry-y x))))))) - - (define print-state - (lambda (x) - ;(display ".") - (void))) - - (collect null (lambda (_ astate rest) - (if (terminal? astate) - (begin (print-state astate) rest) - (cons astate rest)))))) -;; fields -(define T - (lambda (alof) - (cond - ((null? alof) null) - (else (cons (list (cadr (car alof)) (car (car alof))) - (T (cdr alof))))))) - -(define row1 (list (list 1 1) (list 1 2) (list 1 3))) -(define row2 (list (list 2 1) (list 2 2) (list 2 3))) -(define row3 (list (list 3 1) (list 3 2) (list 3 3))) -(define col1 (list (list 1 1) (list 2 1) (list 3 1))) -(define col2 (list (list 1 2) (list 2 2) (list 3 2))) -(define col3 (list (list 1 3) (list 2 3) (list 3 3))) -(define posd (list (list 1 1) (list 2 2) (list 3 3))) -(define negd (list (list 1 3) (list 2 2) (list 3 1))) - -(define TERMINAL-STATES (list row1 row2 row3 col1 col2 col3 posd negd)) - -(define ALL-FIELDS (append row1 row2 row3)) diff --git a/collects/tests/mzscheme/ttt/ttt.ss b/collects/tests/mzscheme/ttt/ttt.ss deleted file mode 100644 index 67a1898f..00000000 --- a/collects/tests/mzscheme/ttt/ttt.ss +++ /dev/null @@ -1,14 +0,0 @@ - -(read-case-sensitive #t) -(require-library "core.ss") -(load "listlib.ss") -(load "veclib.ss") -(load "tic-func.ss") - -(let loop () - (collect-garbage) - (collect-garbage) - (collect-garbage) - (dump-memory-stats) - (time (tic-tac-toe 1 1)) - '(loop)) diff --git a/collects/tests/mzscheme/ttt/uinc4.ss b/collects/tests/mzscheme/ttt/uinc4.ss deleted file mode 100644 index 31cef748..00000000 --- a/collects/tests/mzscheme/ttt/uinc4.ss +++ /dev/null @@ -1,7 +0,0 @@ - - -(define also-unused 'ok) - -(begin-elaboration-time - `(include ,(build-path 'up "uinc.ss"))) - diff --git a/collects/tests/mzscheme/ttt/veclib.ss b/collects/tests/mzscheme/ttt/veclib.ss deleted file mode 100644 index d840f099..00000000 --- a/collects/tests/mzscheme/ttt/veclib.ss +++ /dev/null @@ -1,57 +0,0 @@ -;; -------------------------------------------------------------------------- -;; 2vec-library.ss - -; #| -; (unit/sig -; (make-2vec 2vec-ref 2vec-set! collect) -; (import plt:userspace^) -; |# - - ;; 2 dimensional, square vectors - - (define collect - (lambda (base combine) - (define C - (lambda (l) - (cond - ((null? l) base) - (else (combine l (car l) (C (cdr l))))))) - C)) - - (define (make-2vec N element) - (make-vector (* N N) element)) - - (define (2vec-ref 2vec i j) - (let ((L (sqrt (vector-length 2vec)))) - (vector-ref 2vec (+ (* i L) j)))) - - (define (2vec-set! 2vec i j element) - (let ((L (sqrt (vector-length 2vec)))) - (if (and (< i L) (< j L)) - (vector-set! 2vec (+ (* i L) j) element) - (error '2vec-set! "~s ~s" i j)))) - - (define (I N) - (let ((2vec (make-2vec N 0))) - (let loop ((i 0) (j 0)) - (if (= i N) - (void) - (begin - (2vec-set! 2vec i j 1) - (loop (add1 i) (add1 j))))) - 2vec)) - - (define (P N) - (let ((2vec (make-2vec N 0))) - (let loop ((i 0) (j 0)) - (cond - [(and (= i N) (= j 0)) (void)] - [(< j N) (2vec-set! 2vec i j (list i j)) (loop i (add1 j))] - [(< i N) (loop (add1 i) 0)] - [else (error 'P "impossible ~s ~s" i j)])) - 2vec)) - -; #| -; ) -; |# - diff --git a/collects/tests/mzscheme/uinc.ss b/collects/tests/mzscheme/uinc.ss deleted file mode 100644 index ea489aaa..00000000 --- a/collects/tests/mzscheme/uinc.ss +++ /dev/null @@ -1,2 +0,0 @@ - -(+ 4 5) diff --git a/collects/tests/mzscheme/uinc2.ss b/collects/tests/mzscheme/uinc2.ss deleted file mode 100644 index c1de73fb..00000000 --- a/collects/tests/mzscheme/uinc2.ss +++ /dev/null @@ -1,2 +0,0 @@ - -(define x 8) diff --git a/collects/tests/mzscheme/uinc3.ss b/collects/tests/mzscheme/uinc3.ss deleted file mode 100644 index 822a984d..00000000 --- a/collects/tests/mzscheme/uinc3.ss +++ /dev/null @@ -1,6 +0,0 @@ - -(define unused 'hello) - -(begin-elaboration-time - `(include ,(build-path "ttt" "uinc4.ss"))) - diff --git a/collects/tests/mzscheme/unit.ss b/collects/tests/mzscheme/unit.ss deleted file mode 100644 index 5de6b918..00000000 --- a/collects/tests/mzscheme/unit.ss +++ /dev/null @@ -1,544 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'unit) - -(syntax-test '(unit)) -(syntax-test '(unit (import))) -(syntax-test '(unit (impLort))) -(syntax-test '(unit (impLort) (export) 5)) -(syntax-test '(unit (import) (expLort) 5)) -(syntax-test '(unit import (export) 5)) -(syntax-test '(unit (import) export 5)) -(syntax-test '(unit (import) (export) . 5)) -(syntax-test '(unit (import 8) (export) 5)) -(syntax-test '(unit (import . i) (export) 5)) -(syntax-test '(unit (import (i)) (export) 5)) -(syntax-test '(unit (import i 8) (export) 5)) -(syntax-test '(unit (import i . b) (export) 5)) -(syntax-test '(unit (import i (b)) (export) 5)) -(syntax-test '(unit (import i) (export 7) 5)) -(syntax-test '(unit (import i) (export . a) (define a 6))) -(syntax-test '(unit (import i) (export a . b) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export (a x) . b) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export (a 8) b) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export b (a 8)) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export (a . x) b) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export b (a . x)) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export (a x y) b) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export (a x . y) b) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export b (a x . y)) (define a 5) (define b 6))) - -(syntax-test '(unit (import i) (export) (begin 1 . 2))) -(syntax-test '(unit (import i) (export b a) (begin (define a 5) (define b 6) . x))) -(syntax-test '(unit (import i) (export b a) (begin (define a 5) (define b 6)) (define b 6))) - -(syntax-test '(unit (import #%car) (export) (define a 5))) -(syntax-test '(unit (import) (export #%car) (define a 5))) -(syntax-test '(unit (import) (export #%car) (define #%car 5))) -(syntax-test '(unit (import) (export) (define #%car 5))) -(syntax-test '(unit (import) (export) (define-values (3) 5))) - -(syntax-test '(unit (import a) (export (a x) b) (define a 5) (define b 6))) -(syntax-test '(unit (import a) (export (a x) (a y)) (define a 5) (define b 6))) -(syntax-test '(unit (import i a) (export (a x) b) (define a 5) (define b 6))) -(syntax-test '(unit (import b) (export (a x) b) (define a 5) (define b 6))) -(syntax-test '(unit (import i j i) (export (a x) b) (define a 5) (define b 6))) -(syntax-test '(unit (import i j j) (export (a x) b) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export a a) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export (a x) (b x)) (define a 5) (define b 6))) -(syntax-test '(unit (import i) (export (a x) b) (define a 5) (define a 6) (define b 6))) -(syntax-test '(unit (import make-i) (export (a x) b) (define a 5) (define-struct i ()) (define b 6))) -(syntax-test '(unit (import i) (export (make-a x) b) (define make-a 5) (define-struct a ()) (define b 6))) -(syntax-test '(unit (import i) (export (a x) b) (define a 5) (define r 6) (define r 7) (define b 6))) - -(syntax-test '(unit (import i) (export b (a x)) 5)) -(syntax-test '(unit (import i) (export (a x) b) (define x 5) (define b 6))) -(syntax-test '(unit (import i) (export (a x) b) (set! a 5) (define b 6))) - -(syntax-test '(unit (import i) (export) (set! g 5))) -(syntax-test '(unit (import i) (export) (set! i 5))) - -; Empty exports are syntactically ok:: -(error-test '(compound-unit (import) (link (A (0))) (export (A))) exn:unit?) -(error-test '(compound-unit (import) (link (A (0 (B))) (B (0))) (export)) exn:unit?) -(error-test '(compound-unit (import) (link (A (0)) (B (0))) (export (A x) (B))) exn:unit?) - -; Self-import is now allowed -; (syntax-test '(compound-unit (import) (link (A (0 (A)))) (export))) -; (syntax-test '(compound-unit (import) (link (A (0 (A x)))) (export))) -(test (list (letrec ([x x]) x) 5) - 'self-import - (invoke-unit - (compound-unit - (import) - (link [U ((unit (import a) (export b) (define x a) (define b 5) (list x a)) - (U b))]) - (export)))) - -(error-test '(invoke-unit (unit (import not-defined) (export) 10) not-defined) exn:unit?) - -(unless (defined? 'test-global-var) - (let () - (define test-global-var 5) - (syntax-test '(unit (import) (export) test-global-var)))) - -(test #t unit? (unit (import) (export))) -(test #t unit? (unit (import) (export) 5)) -(test #t unit? (unit (import i) (export (a x)) (define a 8) (define x 5))) -(test 5 (lambda (f) (invoke-unit f)) (unit (import) (export) 5)) - -(test #t unit? (unit (import i) (export b a) (begin (define a 5) (define b 6)))) -(test #t unit? (unit (import i) (export b a) 'a (begin (define a 5) (define b 6)) 'b)) -(test #t unit? (unit (import i) (export b a) (begin (define a 5)) (define b 6))) -(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define b 6)))) -(test #t unit? (unit (import i) (export b a) (define a 5) (begin (define y 7) (define b 6)) (+ y b a))) - -(test 3 'embedded-deeply ((invoke-unit (unit (import) (export) (lambda () (define x 3) x))))) -(test 1 'embedded-deeply-struct ((invoke-unit (unit (import) (export) (lambda () - (define-struct a ()) - make-a - 1))))) - -; Empty begin is OK in a unit context: -(test #t unit? (unit (import i) (export) (begin))) -(test #t unit? (unit (import i) (export) (begin (begin)))) - -(syntax-test '(compound-unit)) -(syntax-test '(compound-unit . x)) -(syntax-test '(compound-unit (import))) -(syntax-test '(compound-unit (import) . x)) -(syntax-test '(compound-unit (import) (link))) -(syntax-test '(compound-unit (import) (link) . x)) -(syntax-test '(compound-unit import (link) (export))) -(syntax-test '(compound-unit (import) link (export))) -(syntax-test '(compound-unit (import) (link) export)) -(syntax-test '(compound-unit ((import)) (link) (export))) -(syntax-test '(compound-unit (import) ((link)) (export))) -(syntax-test '(compound-unit (import) (link) ((export)))) -(syntax-test '(compound-unit (import . a) (link) (export))) -(syntax-test '(compound-unit (import b . a) (link) (export))) -(syntax-test '(compound-unit (import 1) (link) (export))) -(syntax-test '(compound-unit (import (a)) (link) (export))) -(syntax-test '(compound-unit (import (a . b)) (link) (export))) -(syntax-test '(compound-unit (import (a (b))) (link) (export))) -(syntax-test '(compound-unit (import ((a) b)) (link) (export))) -(syntax-test '(compound-unit (import) (link . a) (export))) -(syntax-test '(compound-unit (import) (link a) (export))) -(syntax-test '(compound-unit (import) (link (a)) (export))) -(syntax-test '(compound-unit (import) (link (a (b)) . c) (export))) -(syntax-test '(compound-unit (import) (link (a (b) . c)) (export))) -(syntax-test '(compound-unit (import) (link (a (b . c)) (c (d))) (export))) -(syntax-test '(compound-unit (import) (link (a (b c . e)) (c (d)) (e (f))) (export))) -(syntax-test '(compound-unit (import) (link (a (b 1))) (export))) -(syntax-test '(compound-unit (import) (link (a (b))) (export . a))) -(syntax-test '(compound-unit (import) (link (a (b))) (export a))) -(syntax-test '(compound-unit (import) (link (a (b))) (export (a w) . a))) -(syntax-test '(compound-unit (import) (link (a (b))) (export (a 1)))) -(syntax-test '(compound-unit (import) (link (a (b))) (export (a (x))))) -(syntax-test '(compound-unit (import) (link (a (b))) (export (1 w)))) - - -; Simple: - -(define m1 - (unit - (import) - (export x y a? set-a-b!) - - (define-struct a (b c)) - - (define x 7) - (define z 8) - (define y (lambda () (* z x))) - - (list x y z))) - -(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (arity y)))) - (invoke-unit m1)) - -(test #t apply - (lambda (x y-val a? set-a-b!) - (and (= x 7) (= y-val 56) - (= 1 (arity a?)) - (= 2 (arity set-a-b!)))) - (invoke-unit - (compound-unit - (import) - (link [M (m1)] - [N ((unit - (import x y a? set-a-b!) - (export) - (list x (y) a? set-a-b!)) - (M x y a? set-a-b!))]) - (export)))) - -; Structures: - - -(define m2-1 - (unit - (import) - (export x struct:a a? v y) - - (define x 5) - (define-struct a (b c)) - (define v (make-a 5 6)) - (define (y v) (a? v)))) - -(define m2-2 - (unit - (import struct:a a?) - (export x? make-x x-z both) - - (define-struct (x struct:a) (y z)) - (define both (lambda (v) - (and (a? v) (x? v)))))) - -(define m2-3 - (compound-unit - (import) - (link [O (m2-1)][T (m2-2 (O struct:a) (O a?))]) - (export [O x struct:a v y] - [T x? make-x x-z both]))) - - -(let ([p (open-output-string)]) - (invoke-unit - (compound-unit - (import) - (link [M (m2-3)] - [N ((unit - (import x v struct:a y x? make-x x-z both) - (export) - (define (filter v) - (if (procedure? v) - `(proc: ,(inferred-name v)) - v)) - (display - (map filter (list x v struct:a y make-x x? x-z both)) - p) - (let ([v2 (make-x 1 2 3 4)]) - (display (map filter - (list x (struct-type? struct:a) - v (y v) (y x) - v2 - (y v2) - (x? v2) - (both v) - (both v2))) - p))) - (M x v struct:a y x? make-x x-z both))]) - (export))) - - (test (string-append "(5 #(struct:a 5 6) # (proc: y)" - " (proc: make-x) (proc: x?)" - " (proc: x-z) (proc: both))" - "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 3 4) #t #t #f #t)") - get-output-string p)) - -; Compound with circularity - -(define make-z - (lambda (x-val) - (unit - (import z) - (export (x z) y) - - (define x x-val) - (define y (lambda () (- z x)))))) - -(define z1 (make-z 8)) -(define z2 (make-z 7)) - -; Dynamic linking - -(let ([u - (unit - (import x) - (export) - - (+ x 8))]) - - (test 10 'dynamic (invoke-unit - (unit - (import) - (export w) - - (define w 2) - - (invoke-unit u w))))) - -; Misc - -(test 12 'nested-units - (invoke-unit - (compound-unit - (import) - (link (a@ ((unit (import) (export s@:a) (define s@:a 5)))) - (u@ ((compound-unit - (import a@:s@:a) - (link (r@ ((unit (import a) (export) (+ a 7)) a@:s@:a))) - (export)) - (a@ s@:a)))) - (export)))) - -; Import linking via invoke-unit - -(test '(5 7 (7 2)) 'invoke-unit-linking - (let ([u (unit (import x) (export) x)] - [v (unit (import x) (export) (lambda () x))] - [x 5]) - (list (invoke-unit u x) - (begin - (set! x 7) - (invoke-unit u x)) - (let ([f (invoke-unit v x)]) - (list - (f) - (begin - (set! x 2) - (f))))))) - - -; Multiple values -(test '(1 2 3) - call-with-values - (lambda () (invoke-unit (unit (import) (export) (values 1 2 3)))) - list) - -; Units within units: - -(define u (unit - (import) - (export) - (define y 10) - (define x 5) - (unit - (import) - (export) - x))) -(test #t unit? u) -(define u2 (invoke-unit u)) -(test #t unit? u2) -(test 5 'invoke-unit-in-unit (invoke-unit u2)) - - -(syntax-test '(define u - (invoke-unit - (unit - (import) (export) - (define x 10) - x - (unit (import) (export) - apple - x))))) - -; Units and objects combined: - -(define u@ - (unit (import x) (export) - (class* object% () () - (public (y x)) - (sequence (super-init))))) -(define v (invoke-unit u@ car)) -(test #t class? v) -(define w (make-object v)) -(test car 'ivar (ivar w y)) - -(define c% - (class* object% () (x) - (public (z (unit (import) (export) x))) - (sequence (super-init)))) -(define u (ivar (make-object c% car) z)) -(test #t unit? u) -(test car 'invoke (invoke-unit u)) - - -(define c% - (class* object% () (x) (public (y x)) - (public (z (unit (import) (export) y))) - (sequence (super-init)))) -(define u (make-object c% 3)) -(define u2 (ivar u z)) -(test #t unit? u2) -(test 3 'invoke (invoke-unit u2)) - -(test (letrec ([x y][y 0]) x) 'invoke - (invoke-unit (unit (import) (export) (define x y) (define y 7) x))) - -; Can't shadow syntax/macros in unit -(syntax-test '(unit - (import) - (export) - (define define 10))) -(syntax-test '(unit - (import) - (export) - (define lambda 10))) - -; Shadowing ok if it's in the export list: -(test #t unit? (unit - (import) - (export define-values) - (define define-values 10))) -(test #t unit? (unit - (import) - (export lambda) - (define lambda 10))) -(test #t unit? (unit - (import) - (export [lambda l]) - (define lambda 10))) - -; These are ok, too: -(test #t unit? (unit - (import define) - (export) - (define define 10))) -(test #t unit? (let ([define-values 5]) - (unit - (import) - (export) - (define define-values 10)))) -(test 10 'invoke-w/shadowed - (let ([define-values 5]) - (invoke-unit - (unit - (import) - (export define-values) - (define define-values 10) - define-values)))) - -; Check set! of shadowed variable: -(test #t unit? (unit - (import x) - (export) - (let ([x 10]) - (set! x 5)))) -(test #t unit? (unit - (import x) - (export) - (class object% () - (public - [x 10]) - (sequence - (set! x 5))))) -(syntax-test '(let ([x 10]) - (unit - (import x) - (export) - (set! x 5)))) - -; Especially for zodiac: -(test '(b c 10 b a (c a b) (c b a) (c . c) (a) #t - (nested-b a b c) (a 2 b) (10 b c) (cl-unit-a 12 c)) - 'invoke-w/shadowed-a-lot - (let ([a 'bad-a] - [b 'bad-b] - [c 'bad-c] - [struct:d 'bad-d] - [i 'bad-i]) - (invoke-unit - (unit - (import) - (export b) - (define a 'a) - (define b 'tmp-b) - (begin - (define c 'c) - (define-struct d (w))) - (define x '...) - - (define-struct (e struct:d) ()) - (set! b 'b) - (set! x (cons c c)) - - (define i (interface ())) - - (list - (if (eq? a 'a) - b - c) - (if (eq? a 'bad-a) - b - c) - (d-w (make-e 10)) - (begin a b) - (begin0 a b) - (let ([ab (list a b)]) - (cons c ab)) - (letrec ([mk-ba (lambda () - (list b a))]) - (cons c (mk-ba))) - x - (with-continuation-mark - b a - (continuation-mark-set->list (current-continuation-marks) b)) - (interface? (interface (i))) - (invoke-unit - (unit - (import w a) - (export) - (define b 'nested-b) - (list b w a c)) - a b) - (invoke-unit - (compound-unit - (import a) - (link [u ((unit (import c) (export (xa a) (b xb)) - (define xa 1) - (define b 2) - (list a b c)) - a)]) - (export)) - b) - (send - (make-object - (class object% () - (public - [a 10] - [tester - (lambda () (list a b c))]) - (sequence (super-init)))) - tester) - (send - (make-object - (class object% () - (public - [a 10] - [b 12] - [tester - (lambda () - (invoke-unit - (unit - (import) - (export) - (define a 'cl-unit-a) - (list a b c))))]) - (sequence (super-init)))) - tester)))))) - -; Not ok if defining an imported name, but error should be about -; redefining an imported name. (This behavior is not actually tested.) -(syntax-test '(unit - (import define-values) - (export) - (define define-values 10))) - -(test #t unit? (unit - (import define-values) - (export) - (let () (define define-values 10) define-values))) - -;; Invoke-unit linking in let-bound variables -(test '(the-x 10) 'invoke - (let ([x 'the-x]) - (invoke-unit - (unit (import w) (export) - (list w 10)) - x))) - - -(report-errs) diff --git a/collects/tests/mzscheme/unitsig.ss b/collects/tests/mzscheme/unitsig.ss deleted file mode 100644 index fe571eae..00000000 --- a/collects/tests/mzscheme/unitsig.ss +++ /dev/null @@ -1,502 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'unit/sig) - -(undefine 'a) -(undefine 'b) - -(syntax-test '(define-signature)) -(syntax-test '(define-signature)) -(syntax-test '(define-signature 8)) -(syntax-test '(define-signature . x)) -(syntax-test '(define-signature x)) -(syntax-test '(define-signature 8)) -(syntax-test '(define-signature x (8))) -(syntax-test '(define-signature x (a . 8))) -(syntax-test '(define-signature x (a . y))) -(syntax-test '(define-signature x (y y))) -(syntax-test '(define-signature x ((y)))) -(syntax-test '(define-signature x ((struct)))) -(syntax-test '(define-signature x ((struct y)))) -(syntax-test '(define-signature x ((struct . y)))) -(syntax-test '(define-signature x ((struct y . x)))) -(syntax-test '(define-signature x ((struct y x)))) -(syntax-test '(define-signature x ((struct y (x)) . x))) -(syntax-test '(define-signature x ((unit)))) -(syntax-test '(define-signature x ((unit y)))) -(syntax-test '(define-signature x ((unit . y)))) -(syntax-test '(define-signature x ((unit y : a)))) -(define-signature a ()) -(syntax-test '(define-signature x ((unit y a)))) -(syntax-test '(define-signature x ((unit y . a)))) -(syntax-test '(define-signature x ((unit y : . a)))) -(syntax-test '(define-signature x ((unit y a) . x))) -(syntax-test '(define-signature x (y (unit y a)))) - -(syntax-test '(unit/sig)) -(syntax-test '(unit/sig 8)) -(syntax-test '(unit/sig b)) -(define-signature b (x y)) -(syntax-test '(unit/sig (a))) -(syntax-test '(unit/sig a (impLort))) -(syntax-test '(unit/sig a (impLort) 5)) -(syntax-test '(unit/sig a import 5)) -(syntax-test '(unit/sig a (import . x) . 5)) -(syntax-test '(unit/sig a (import (x) 8) 5)) -(syntax-test '(unit/sig a (import (x) . i) 5)) -(syntax-test '(unit/sig a (import (i : a) . b) 5)) -(syntax-test '(unit/sig b (import (i : a)) 5)) -(syntax-test '(unit/sig a (import (i : a x)) 5)) -(syntax-test '(unit/sig a (import (i : a) x) 5)) -(syntax-test '(unit/sig b (import (i : a)) (define x 7))) -(syntax-test '(unit/sig b (import (i : a)) (define x 7) (define i:y 6))) -(syntax-test '(unit/sig blah (import) (define x 7))) - -(syntax-test '(unit/sig () (import) (begin 1 . 2))) -(syntax-test '(unit/sig () (import) (begin (define x 5)) (define x 5))) - -(define b@ (unit/sig b (import) (define x 9) (define y 9))) -(define b2@ (unit/sig b (import (i : a)) (define x 9) (define y 9))) -(define b3@ (unit/sig b (import (i : ())) (define x 9) (define y 9))) -(define b3u@ (unit/sig b (import ()) (define x 9) (define y 9))) -(define b3u2@ (unit/sig b (import a) (define x 9) (define y 9))) -(define-signature >b ((unit b@ : b))) -(define b3u3@ (unit/sig b (import (i : >b)) (define x 9) (define y 9))) - -(define >b@ (compound-unit/sig (import) (link [b@ : b (b@)]) (export (unit b@)))) - -(syntax-test '(compound-unit/sig)) -(syntax-test '(compound-unit/sig 8)) -(syntax-test '(compound-unit/sig b)) -(syntax-test '(compound-unit/sig (import) (link) (export (var (U x))))) -(syntax-test '(compound-unit/sig (import a) (link) (export))) -(syntax-test '(compound-unit/sig (import 5) (link) (export))) -(syntax-test '(compound-unit/sig (import . i) (link) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link ()) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@)) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ b)) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b)) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b ())) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ 5))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ . i))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i . a)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i a a)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ c@))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (c@ a)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export . b@))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export b@))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit c@)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : c)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ (b@))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ : (b@))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open)))) -(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@ (i : a)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : a)) (link (b@ : b (5 (i : a)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3@ (i : b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u@ (i : b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : b)) (link (b@ : b (b3u2@ (i : b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : >b)) (link (b@ : b (b3@ (i : >b)))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((open a) x))) (link (b@ : b (b3@ (i : ((open a) x))))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((unit b@ : ((open b) w))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : a)) (link (b@ : (w) (b@))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ())) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((unit b@ : ())))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : (b@))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(error-test '(compound-unit/sig (import (i : ((unit b@ : (x (unit y : ())))))) (link (b@ : b (b3u3@ i))) (export)) exn:unit?) -(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 5)]) (export))) -(syntax-test '(compound-unit/sig (import) (link [b@ : b (0 ())]) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : a (5 (i : b)))) (export))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var b@)))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x y))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (5 x))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ 5))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ w) 5))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@ 7) 5))))) -(syntax-test '(compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x . a))))) - -; Self-import is now allowed -; (syntax-test '(compound-unit/sig (import) (link (A : () (0 A))) (export))) ; self-import -; (syntax-test '(compound-unit/sig (import) (link (A : (x) (0 A))) (export))) ; self-import -(test (list (letrec ([x x]) x) 5) - 'self-import - (invoke-unit/sig - (compound-unit/sig - (import) - (link [U : (a) ((unit/sig (a) (import (a)) (rename (b a)) (define x a) (define b 5) (list x a)) - U)]) - (export)))) - -(define-signature not-defined^ (not-defined)) -(error-test '(invoke-unit/sig (unit/sig () (import not-defined^) 10) not-defined^) exn:unit?) - -(test #t unit/sig? (unit/sig a (import))) -(test #t unit/sig? (unit/sig b (import) (define x 1) (define y 2))) -(test #t unit/sig? (unit/sig a (import (i : b)) i:x)) -(test 5 (lambda (f) (invoke-unit/sig f ())) (unit/sig a (import ()) 5)) -(test #t unit/sig? (unit/sig (x) (import) (begin (define x 5)))) -(test #t unit/sig? (unit/sig (x) (import) (define a 14) (begin (define x 5) (define y 10)) (define z 12))) -(test #t unit/sig? (compound-unit/sig (import) (link) (export))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ (i : a)))) (export))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : a)))) (export))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b2@ ((i) : ())))) (export))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x))))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var (b@ x) w)))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (var ((b@) x) w)))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@)))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit (b@))))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (unit b@ b@)))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open b@)))) -(test #t unit/sig? (compound-unit/sig (import (i : a)) (link (b@ : b (b@))) (export (open (b@ : b))))) - -(test #t unit/sig? (compound-unit/sig (import) - (link [compound-unit : () ((unit/sig () (import) 10))]) - (export))) -(test #t unit/sig? (compound-unit/sig - (import) - (link [export : () ((unit/sig () (import) 10))]) - (export))) - -; Empty begin is OK in a unit context: -(test #t unit/sig? (unit/sig () (import) (begin))) -(test #t unit/sig? (unit/sig () (import) (begin (begin)))) - -; Include: - -(define i1@ - (unit/sig - () - (import) - - (include "uinc.ss"))) - -(test 9 'include (invoke-unit/sig i1@)) - -;; Nested includes, macros that expand to `(include ...)' -(define i1.5@ - (unit/sig - () - (import) - - (+ 3 4) - (include "uinc3.ss"))) - -(test 9 'include (invoke-unit/sig i1.5@)) - -(define i2@ - (unit/sig - () - (import) - - (include "uinc.ss") - (include "uinc2.ss") - (include "uinc.ss") - (+ x 2))) - -(test 10 'include (invoke-unit/sig i2@)) - -; Simple: - -(define-signature m1^ - (x y a? set-a-b!)) - -(define m1@ - (unit/sig - m1^ - (import) - - (define-struct a (b c)) - - (define x 7) - (define z 8) - (define y (lambda () (* z x))) - - (list x y z))) - -(test #t apply (lambda (x y z) (and (= x 7) (= z 8) (procedure? y) (= 0 (arity y)))) - (invoke-unit/sig m1@)) - -(test #t apply - (lambda (x y-val a? set-a-b!) - (and (= x 7) (= y-val 56) - (= 1 (arity a?)) - (= 2 (arity set-a-b!)))) - (invoke-unit/sig - (compound-unit/sig - (import) - (link [M@ : m1^ (m1@)] - [N@ : () ((unit/sig - () - (import (i@ : m1^)) - (list i@:x (i@:y) i@:a? i@:set-a-b!)) - M@)]) - (export (open M@))))) - -; More: - -(define-signature m2-1-lite^ - (x struct:a v y)) - -(define-signature m2-1^ - (a? - (open m2-1-lite^))) - -(define-signature m2-2^ - (x? make-x x-z both)) - -(define m2-1@ - (unit/sig - m2-1^ - (import) - - (define x 5) - (define-struct a (b c)) - (define v (make-a 5 6)) - (define (y v) (a? v)))) - -(define m2-2@ - (unit/sig - m2-2^ - (import m2-1^) - - (define-struct (x struct:a) (y z)) - (define both (lambda (v) - (and (a? v) (x? v)))))) - -(define-signature m2-3^ - (simple)) - -(let-signature m2-3^ - ((unit one@ : m2-1-lite^) - (unit two@ : m2-2^) - a?-again) - - (define m2-3@ - (compound-unit/sig - (import) - (link [O@ : m2-1^ (m2-1@)] - [T@ : m2-2^ (m2-2@ O@)]) - (export (unit (O@ : m2-1-lite^) one@) - (unit T@ two@) - (var (O@ a?) a?-again)))) - - (let ([p (open-output-string)] - [filter (lambda (v) - (if (procedure? v) - `(proc: ,(inferred-name v)) - v))]) - (invoke-unit/sig - (compound-unit/sig - (import) - (link [M@ : m2-3^ (m2-3@)] - [N@ : () ((unit/sig - () - (import (i : m2-3^)) - (display (map - filter - (list i:one@:x i:one@:v i:one@:struct:a i:one@:y - i:two@:make-x i:two@:x? i:two@:x-z i:two@:both - i:a?-again)) - p) - (let ([v2 (i:two@:make-x 1 2 3 4)]) - (display (map - filter - (list i:one@:x (struct-type? i:one@:struct:a) - i:one@:v (i:one@:y i:one@:v) (i:one@:y i:one@:x) - v2 - (i:one@:y v2) - (i:two@:x? v2) - (i:two@:both i:one@:v) - (i:two@:both v2))) - p))) - M@)]) - (export))) - (test (string-append "(5 #(struct:a 5 6) # (proc: y)" - " (proc: make-x) (proc: x?)" - " (proc: x-z) (proc: both) (proc: a?))" - "(5 #t #(struct:a 5 6) #t #f #(struct:x 1 2 3 4) #t #t #f #t)") - get-output-string p))) - -(test 5 'let-sig - (invoke-unit/sig - (unit/sig - m2-3^ - (import) - (define simple 5) - simple))) - -(define-signature big^ - (a b c)) -(define-signature little^ - (a b c)) - -(test 11 - 'link-restrict - (invoke-unit/sig - (compound-unit/sig - (import) - (link [a@ : big^ ((unit/sig big^ (import) (define a 5) (define b 6) (define c 7)))] - [b@ : () ((unit/sig () (import (i : little^)) (+ i:a i:b)) - (a@ : little^))]) - (export)))) - -(define-signature just-a^ - (a)) -(define-signature >just-a^ - ((unit s@ : just-a^))) - -; Test a path for linking: root is a constiuent -(test 12 - 'link-path - (invoke-unit/sig - (compound-unit/sig - (import) - (link [a@ : >just-a^ ((compound-unit/sig - (import) - (link [i@ : just-a^ ((unit/sig - just-a^ - (import) - (define a 5)))]) - (export (unit i@ s@))))] - [r@ : () ((unit/sig - () - (import (i : just-a^)) - (+ i:a 7)) - (a@ s@))]) - (export)))) - -; Test a path for linking: root is an import -(test 12 - 'import-path - (invoke-unit/sig - (compound-unit/sig - (import) - (link [a@ : >just-a^ ((compound-unit/sig - (import) - (link [i@ : just-a^ ((unit/sig - just-a^ - (import) - (define a 5)))]) - (export (unit i@ s@))))] - [u@ : () ((compound-unit/sig - (import (a@ : >just-a^)) - (link [r@ : () ((unit/sig - () - (import (i : just-a^)) - (+ i:a 7)) - (a@ s@))]) - (export)) - a@)]) - (export)))) - -; Signature ordering - -(define o1 (unit/sig (num sym) (import) (define num 5) (define sym 'a))) -(define o2 (unit/sig () (import (sym num)) (list sym (+ num)))) - -(test (list 'a 5) - 'order - (invoke-unit/sig - (compound-unit/sig - (import) - (link [one : (num sym) (o1)] - [two : () (o2 one)]) - (export)))) - -; unit->unit/sig, etc. - -(define-signature s1 - (a b c)) -(define-signature s2 - (+)) - -(define us1 - (unit - (import +) - (export a b c) - - (define a 1) - (define b 2) - (define c 3) - (+ a b c))) - -(test 6 'u->s (invoke-unit us1 +)) -(test 6 'u->s (invoke-unit/sig (unit->unit/sig us1 (s2) s1) s2)) - -; Exporting a name twice: - -(syntax-test - '(compound-unit/sig - (import) - (link [A : (a) ((unit/sig (a) (import) (define a 1)))]) - (export (var (A a)) (open A)))) - -(syntax-test - '(compound-unit/sig - (import) - (link [A : (a) ((unit/sig (a) (import) (define a 1)))] - [B : (b) ((unit/sig (b) (import) (define b 2)))]) - (export (unit A x) (unit B x)))) - -(syntax-test - '(compound-unit/sig - (import) - (link [A : (a) ((unit/sig (a) (import) (define a 1)))] - [B : (b) ((unit/sig (b) (import) (define b 2)))]) - (export (unit A) (unit B A)))) - -; Can't shadow syntax/macros in unit -(syntax-test '(unit/sig () - (import) - (define define 10))) -(syntax-test '(unit/sig () - (import) - (define lambda 11))) - -; Shadowing ok if it's in the export list: -(test #t unit/sig? (unit/sig (define-values) - (import) - (define define-values 12))) -(test #t unit/sig? (unit/sig (lambda) - (import) - (define lambda 13))) -(test #t unit/sig? (unit/sig (l) - (import) - (rename (lambda l)) - (define lambda 14))) - -; These are ok, too: -(test #t unit/sig? (unit/sig () - (import (define)) - (define define 15))) -(test #t unit/sig? (let ([define-values 5]) - (unit/sig () - (import) - (define define-values 16)))) - -; Not ok if defining an imported name, but error should be about -; redefining an imported name. (This behavior is not actually tested.) -(syntax-test '(unit/sig () - (import (define-values)) - (define define-values 17))) - -(test #t unit/sig? (unit/sig () - (import (define-values)) - (let () (define define-values 10) define-values))) - -;; Invoke-unit linking in let-bound variables -(define x 'not-the-right-x) -(test '(the-x 10) 'invoke/sig - (let ([x 'the-x]) - (invoke-unit/sig - (unit/sig () (import (x)) - (list x 10)) - (x)))) - -(report-errs) - diff --git a/collects/tests/mzscheme/will.ss b/collects/tests/mzscheme/will.ss deleted file mode 100644 index 063a7726..00000000 --- a/collects/tests/mzscheme/will.ss +++ /dev/null @@ -1,59 +0,0 @@ - -(if (not (defined? 'SECTION)) - (load-relative "testing.ss")) - -(SECTION 'wills) - -(test #f will-executor? 5) -(test #t will-executor? (make-will-executor)) - -(define we (make-will-executor)) - -;; Never GC this one: -(test (void) will-register we test (lambda (x) (error 'bad-will-call))) - -; There's no excuse for not GCing half or more: -(define counter null) -(let loop ([n 10]) - (unless (zero? n) - (will-register we (cons n null) - (lambda (s) - (set! counter (cons (car s) counter)) - 12)) - (loop (sub1 n)))) -(collect-garbage) -(collect-garbage) -(let* ([v #f] - [t (thread (lambda () (set! v (will-execute we))))]) - (sleep 0.1) - (test #f thread-running? t) - (test v values 12)) -(let loop ([m 1]) - (if (let ([v (will-try-execute we)]) - (test #t 'good-result (or (not v) (= v 12))) - v) - (loop (add1 m)) - (begin - (test #t >= m 5) - ;; Make sure counter grew ok - (test m length counter) - ;; Make sure they're all different - (let loop ([l counter]) - (unless (or (null? l) (null? (cdr l))) - (test #f member (car l) (cdr l)) - (loop (cdr l))))))) - -(error-test '(will-register we we we)) -(error-test '(will-register we we (lambda () 10))) -(error-test '(will-register 5 we (lambda (s) 10))) - -(error-test '(will-execute "bad")) -(error-test '(will-try-execute "bad")) - -(arity-test make-will-executor 0 0) -(arity-test will-executor? 1 1) -(arity-test will-register 3 3) -(arity-test will-execute 1 1) -(arity-test will-try-execute 1 1) - -(report-errs) diff --git a/collects/tests/mzscheme/ztest.ss b/collects/tests/mzscheme/ztest.ss deleted file mode 100644 index 29567761..00000000 --- a/collects/tests/mzscheme/ztest.ss +++ /dev/null @@ -1,20 +0,0 @@ -;; rudimentary test harness for complex math routines in -;; zmath.ss - -(require-library "zmath.ss") - -(define ztest - (lambda (z) - (printf "z = ~a~n" z) - (printf " zabs(z) = ~a~n" (zabs z)) - (printf " zlog(z) = ~a~n" (zlog z)) - (printf " zexp(z) = ~a~n" (zexp z)) - (printf " zsqrt(z) = ~a~n" (zsqrt z)) - (printf " zsin(z) = ~a~n" (zsin z)) - (printf " zcos(z) = ~a~n" (zcos z)) - (printf " ztan(z) = ~a~n" (ztan z)) - (printf " zasin(z) = ~a~n" (zasin z)) - (printf " zacos(z) = ~a~n" (zacos z)) - (printf " zatan(z) = ~a~n" (zatan z)))) - -(ztest 0.5) diff --git a/collects/tests/utils/gui.ss b/collects/tests/utils/gui.ss deleted file mode 100644 index dc607171..00000000 --- a/collects/tests/utils/gui.ss +++ /dev/null @@ -1,6 +0,0 @@ -(require-library "guis.ss" "tests" "utils") - -(define-values/invoke-unit/sig test-utils:gui^ - (require-library "guir.ss" "tests" "utils") - #f - mred^) \ No newline at end of file diff --git a/collects/tests/utils/guir.ss b/collects/tests/utils/guir.ss deleted file mode 100644 index 12c44b8d..00000000 --- a/collects/tests/utils/guir.ss +++ /dev/null @@ -1,42 +0,0 @@ -(unit/sig test-utils:gui^ - (import mred^) - - ;;; find-labelled-window : (union ((union #f string) -> window<%>) - ;;; ((union #f string) (union #f class) -> window<%>) - ;;; ((union #f string) (union class #f) area-container<%> -> area-container<%>)) - ;;;; may call error, if no control with the label is found - (define find-labelled-window - (case-lambda - [(label) (find-labelled-window label #f)] - [(label class) (find-labelled-window label class (get-top-level-focus-window))] - [(label class window) - (unless (or (not label) - (string? label)) - (error 'find-labelled-window "first argument must be a string or #f, got ~e; other args: ~e ~e" - label class window)) - (unless (or (class? class) - (not class)) - (error 'find-labelled-window "second argument must be a class or #f, got ~e; other args: ~e ~e" - class label window)) - (unless (is-a? window area-container<%>) - (error 'find-labelled-window "third argument must be a area-container<%>, got ~e; other args: ~e ~e" - window label class)) - (let ([ans - (let loop ([window window]) - (cond - [(and (or (not class) - (is-a? window class)) - (let ([win-label (and (is-a? window window<%>) - (send window get-label))]) - (equal? label win-label))) - window] - [(is-a? window area-container<%>) (ormap loop (send window get-children))] - [else #f]))]) - (or ans - (error 'find-labelled-window "no window labelled ~e in ~e~a" - label - window - (if class - (format " matching class ~e" class) - ""))))]))) - diff --git a/collects/tests/utils/guis.ss b/collects/tests/utils/guis.ss deleted file mode 100644 index 637746dd..00000000 --- a/collects/tests/utils/guis.ss +++ /dev/null @@ -1,2 +0,0 @@ -(define-signature test-utils:gui^ - (find-labelled-window)) \ No newline at end of file diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt deleted file mode 100644 index 79f1fc3b..00000000 --- a/collects/texpict/doc.txt +++ /dev/null @@ -1,326 +0,0 @@ - - >>>>>> THIS IS UNSUPPORTED SOFTWARE <<<<<<< - -_texpict_ is a MzScheme utility for creating _LaTeX_ picture -expressions. - -LaTeX pictures are created as `pict' structures. Procedures in the -texpict library create new simple picts (e.g., `tex') or create new -picts that include other picts (e.g., `ht-append'). In the latter -case, the embedded picts retain their identity, so that offset-finding -functions (e.g., `find-lt') can find the offset of an embedded pict in -a larger pict. - -A pict has the following structure: - w - ------------------ - | | a \ - |------------------| | - | | | h - |------------------| | - | | d / - ------------------ -For a single `tex' line, d is descent below the baseline and -a + d = h. For multiple tex lines (created with vX-append), a is -ascent of top line above baseline and d is descent of bottom line, -so a + d < h. Other boxes have d = 0 and a = h. - -To create a LaTeX picture, assemble a `pict' and then call -`pict->string'. This string can be `display'ed to obtain the LaTeX -code, which is usually of the form: - \begin{picture} ... \end{picture} -When using colors, the output may be of the form: - \special{color push ...} ... \special{color pop ...} -so consider putting the output in an \hbox{} when using color. - -The `tex' function creates a pict given an arbitrary LaTeX -expression as a string. Initially, `tex' guess at the size of the -resulting pict. (It always guesses 10 x 10.) The LaTeX expression -generated for a `tex' pict causes information to be written to an -auxilliary file when LaTeX evaluates the expression. If you use -`tex' boxes, then: - - * Use the package "mztp.sty" at the start of your LaTeX - document "X.tex". - * In the MzScheme code creating `tex' picts, call - (read-in-sizes "X.mztp") before calling `tex'. - * Run the texpict-LaTeX cycle twice to get properly - draw pictures. - -texpict keys `tex' size information on the exact LaTeX expression -provided to `tex'. If you use a single `tex' pict in two different -contexts where the provided expression produces differently sized -output, texpict will not distinguish the uses (and the size of the -first instance of the pict will be used) by default. The -`serialize-tex-picts' parameter can solve this problem, but -serialization requires that the output is built in exactly the same -order every time, and generally requires more texpict-tex cycles to -reach a fixed point after a small change to the output. The -`tex-series-prefix' parameter may be used to explicitly tag `tex' -sequences in different contexts. - -All positions and sizes must be specified as exact integers. - -A pict is an instance of the `pict' structure type: - -> struct:pict :: (struct pict (draw width height ascent descent children)) - -The `children' field is a list of `child' structures: - -> struct:child :: (struct child (pict dx dy)) - ------------------------------------------------------------- -Procedures ------------------------------------------------------------- - - ;; Load `tex' pict size information generated by a LaTeX run. -> read-in-sizes ; string -> void - - ;; Parameter specifying whether to produce LaTeX commands to - ;; produce size information for a future run. - ;; Default: #t -> output-measure-commands - - ;; Parameter specifying whether the `pict2e' package is active. - ;; Default: #f -> using-pict2e-package - - ;; Parameter specifying whether to draw precise lines for `connect' - ;; with bezier curves. The value is a Boolean or a procedure that - ;; takes a length and returns the number of points to use. - ;; Default: #f -> draw-bezier-lines - - - ;; Parameter specifying a string to embed in the sizing key for a - ;; pict created with `tex'. The prefix is applied when the `tex' - ;; pict is created. Turning on the `serialize-tex-picts' parameter - ;; effectively generates a new series prefix for every `tex' pict. - ;; Default: #f -> tex-series-prefix - - ;; Parameter specifying whether to assign serial numbers to - ;; `tex'-generated strings for sizing purposes. Serial numbers - ;; allow the same tex string to be used in multiple contexts, but - ;; the output must be built in the same order every time. - ;; Default: #f -> serialize-tex-picts - - ;; Parameter specifying whether to draw in B&W or color (when - ;; `colorize' is used). - ;; Default: #f -> black-and-white - - ;; Find an embedded picture; see bottom for the definition of pict-path -> find-lt ; (left & top) ; pict pict-path -> dx dy -> find-lc ; (left & vertical center) -> find-lb ; (left & bottom) -> find-ltl ; (left and top baseline) -> find-lbl ; (left and bottom baseline) -> find-ct ; (horizontal center & top) -> find-cc -> find-cb -> find-ctl -> find-cbl -> find-rt -> find-rc -> find-rb -> find-rtl -> find-rbl - - ;; Create a new pict that hides the given pict from find-XX -> launder ; pict -> pict - - ;; Create an empty pict -> blank ; -> pict - ; s -> pict ; s is side length of square - ; w h -> pict - ; w h d -> pict - - ;; Create picts from LaTeX code -> tex ; string -> pict -> text-line ; string -> pict -> text-line/phantom ; string string -> pict -> tex-paragraph ; w string ['top|'bottom] -> pict - - ;; Delimitters to go around height h (result is taller than h; - ;; try h/2) -> left-brace ; h -> pict -> right-brace ; h -> pict -> left-delimit ; str h -> pict -> right-delimit ; str h -> pict -> middle-delimit ; str h -> pict - ;; Delimitter to go around width w (result is w wide) -> top-brace ; w -> pict -> bottom-brace ; w -> pict - -> clip-descent ; pict -> pict -> inset ; pict i -> pict - ; pict hi vi -> pict - ; pict l t r b -> pict - -> hline ; w h -> pict -> dash-hline ; w h seg-length -> pict ; default seg-length is 5 -> vline ; w h -> pict -> dash-vline ; w h seg-length -> pict ; default seg-length is 5 - ;; To draw other kinds of lines, use `picture' or `cons-picture' - -> frame ; pict -> pict -> dash-frame ; pict seg-length -> pict ; default seg-length is 5 -> oval ; pict -> pict -> oval/radius ; pict r -> pict ; r is radius of corners - - ;; Creates a fairly round circle using four splines: -> big-circle ; diameter -> pict - - ;; Set the line thickness for a picture (does not apply to - ;; slanted lines) -> thick ; pict -> pict -> thin ; pict -> pict - - ;; Make a container picture that doesn't draw the child picture, - ;; but uses the child's size -> ghost ; pict -> pict - -> record ; pict pict ... -> pict - - ;; Make a new picture as a column (vX-append) or row (hX-append) - ;; of other pictures. Different procedures align pictures in the - ;; orthogonal direction in different ways; e.g, vl-append left-aligns - ;; all of the pitures. A specified amount of space is inserted - ;; between each pair of pictures in making the column or row. -> vl-append ; d pict ... -> pict ; d units between each picture -> vc-append -> vr-append -> ht-append -> hc-append -> hb-append -> htl-append ; align bottoms of ascents -> hbl-append ; align tops of descents (normal text alignment) - - ;; Make a new picture by superimposing a set of pictures. The - ;; alignment indicators are essentially as above: horizontal - ;; alignment then vertical alignment. -> lt-superimpose ; pict ... -> pict -> lb-superimpose -> lc-superimpose -> ltl-superimpose -> lbl-superimpose -> rt-superimpose -> rb-superimpose -> rc-superimpose -> rtl-superimpose -> rbl-superimpose -> ct-superimpose -> cb-superimpose -> cc-superimpose -> ctl-superimpose -> cbl-superimpose - - ;; Make a table given a list of picts. The list is a - ;; concatentation of rows (which means that a Scheme `list' call - ;; can be formatted to reflect the shape of the output table). - ;; - ;; The col-aligns, row-aligns, col-seps, and row-seps arguments are - ;; `lists' specifying the row and columns alignments separation - ;; between rows and columns. For C columns and R rows, the first - ;; two should have C and R superimpose procedures, and the last two - ;; should have C - 1 and R - 1 numbers, respectively. The lists can - ;; be improper (e.g. just a number), in which case the non-pair cdr - ;; is used as the value for all remaining list items that were - ;; expected. The alignment procedures are used to superimpose all - ;; of the cells in a column or row; this superimposition determines - ;; the total width oir height of the column or row, and also - ;; determines the horizontal or vertical placement of each cell in - ;; the column or row. -> table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict - - ;; Apply a color to a picture. If the given picture has a colorized - ;; sub-picture, the color of the sub-picture is not affected. - ;; Be sure to use the LaTeX package `colordvi'. -> colorize ; pict color-string -> pict - - ;; Desribe a picture with low-level commands; see below. -> picture ; w h command-list -> pict - - ;; Create a new picture by `cons'ing drawing commands onto - ;; an existing picture. -> cons-picture ; pict command-list -> pict - - ;; Create a self-rendering picture (for dc output only) -> prog-picture ; (dc dx dy -> void) w a d -> pict - - - ;; Generate the LaTeX code for a pict. -> pict->string - - ;; Parameter to use the old implementation of `connect'. -> use-old-connect - ------------------------------------------------------------- -Picture Paths, Command, Putables, and Drawables ------------------------------------------------------------- - -pict-path: - - pict - non-empty-pict-path-list - -commands: - - `(place ,x ,y ,pict) - `(put ,x ,y ,putable) - `(connect ,x1 ,y1 ,x2 ,y2 ,bool) ; line or vector; bool => vector; - ; from (x1,y1) to (~x2,~y2) - ; as close as possible - ; (synonym for connect~xy with - ; an infinite tolerance when - ; draw-bezier-lines is #f, or - ; for curve when draw-bezier-lines - ; is #t) - `(dconnect ,x ,y ,dx ,dy ,bool) ; line or vector; bool => vector; - ; from (x,y) to (~(x+dx),~(y+dy)) - ; as close as possible (uses - ; connect) - `(connect~y ,tol ,x1 ,y2 ,x2 ,y2 ,bool) ; sequence of lines from - ; (~x1,~y1) to (~x2,~y2) where - ; either: - ; 1) ~x2=x2 and |~y2-y2| (lambda (m) - (parse-string (cadr m) - (send the-font-list find-or-create-font - (send f get-point-size) - (send f get-family) - (send f get-style) - 'bold)))] - [(regexp-match "^{\\\\it (.*)}$" s) - => (lambda (m) - (parse-string (cadr m) - (send the-font-list find-or-create-font - (send f get-point-size) - (send f get-family) - 'italic - (send f get-weight))))] - [else (values s f)])) - -(define (set-dc-for-text-size dc) - (output-measure-commands #f) - (draw-bezier-lines #t) - (current-tex-sizer - (lambda (s) - (let-values ([(s f) (parse-string s (send dc get-font))]) - (let-values ([(w h d a) (send dc get-text-extent s f)]) - (list w (- h d) d)))))) - -(define (draw-pict dc p dx dy) - - (define (render dc w h l dx dy) - (define b&w? #f) - (define straight? #f) - (define draw-line (ivar dc draw-line)) - (define draw-spline (ivar dc draw-spline)) - (define get-pen (ivar dc get-pen)) - (define get-brush (ivar dc get-brush)) - (define set-pen (ivar dc set-pen)) - (define set-brush (ivar dc set-brush)) - (define find-or-create-pen (ivar the-pen-list find-or-create-pen)) - (define find-or-create-brush (ivar the-brush-list find-or-create-brush)) - (set-brush (find-or-create-brush "black" 'solid)) - (let loop ([dx dx][dy dy][l l][color "black"]) - (unless (null? l) - (let ([x (car l)]) - (if (string? x) - (let-values ([(tw th td ta) (send dc get-text-extent x)] - [(c) (send dc get-text-foreground)] - [(f) (send dc get-font)]) - (let-values ([(x f2) (parse-string x f)]) - (send dc set-font f2) - (send dc set-text-foreground (make-object color% color)) - (send dc draw-text x dx (- h dy (- th td))) - (send dc set-text-foreground c) - (send dc set-font f))) - (case (car x) - [(offset) (loop (+ dx (cadr x)) - (+ dy (caddr x)) - (cadddr x) - color)] - [(line vector) - (let ([xs (cadr x)] - [ys (caddr x)] - [len (cadddr x)]) - (draw-line - dx (- h dy) - (+ dx (* xs len)) (- h (+ dy (* ys len)))))] - [(circle circle*) - (let ([size (cadr x)]) - (send dc draw-ellipse - dx (- h dy size) - size size))] - [(oval) - (let ([b (get-brush)]) - (set-brush (find-or-create-brush "BLACK" 'transparent)) - (send dc draw-rounded-rectangle - (- dx (/ (cadr x) 2)) - (- h dy (/ (caddr x) 2)) - (cadr x) (caddr x) - -0.2) - (set-brush b))] - [(bezier) - (if straight? - (draw-line (+ dx (list-ref x 1)) - (- h (+ dy (list-ref x 2))) - (+ dx (list-ref x 5)) - (- h (+ dy (list-ref x 6)))) - (draw-spline (+ dx (list-ref x 1)) - (- h (+ dy (list-ref x 2))) - (+ dx (list-ref x 3)) - (- h (+ dy (list-ref x 4))) - (+ dx (list-ref x 5)) - (- h (+ dy (list-ref x 6)))))] - [(with-color) - (if b&w? - (loop dx dy (caddr x) color) - (let ([p (get-pen)] - [b (get-brush)]) - (set-pen (find-or-create-pen (cadr x) (send p get-width) 'solid)) - (set-brush (find-or-create-brush (cadr x) 'solid)) - (loop dx dy (caddr x) (cadr x)) - (set-pen p) - (set-brush b)))] - [(with-thickness) - (let ([p (get-pen)]) - (set-pen (find-or-create-pen (send p get-color) - (if (eq? (cadr x) 'thicklines) - 1 - 0) - 'solid)) - (loop dx dy (caddr x) color) - (set-pen p))] - [(prog) - ((cadr x) dc dx (- h dy))] - [else (error 'rander "unknown command: ~a~n" x)]))) - (loop dx dy (cdr l) color)))) - - (render dc (pict-width p) (pict-height p) - (pict->commands p) - dx dy)) diff --git a/collects/texpict/texpict.ss b/collects/texpict/texpict.ss deleted file mode 100644 index 0aa09d36..00000000 --- a/collects/texpict/texpict.ss +++ /dev/null @@ -1,13 +0,0 @@ - -; For information about texpict, see texpicts.ss - -(require-library "refer.ss") - -(require-library "texpicts.ss" "texpict") - -(begin-elaboration-time - (require-library "invoke.ss")) - - -(define-values/invoke-unit/sig texpict^ - (require-library-unit/sig "texpictr.ss" "texpict")) diff --git a/collects/texpict/texpictr.ss b/collects/texpict/texpictr.ss deleted file mode 100644 index c7e78a7c..00000000 --- a/collects/texpict/texpictr.ss +++ /dev/null @@ -1,1119 +0,0 @@ - -; For information about texpict, see texpicts.ss - -(unit/sig - texpict^ - (import) - -(define default-seg 5) -(define recordseplinespace 4) - -(define using-pict2e-package - (make-parameter #f - (lambda (x) - (and x #t)))) - -(define use-old-connect - (make-parameter #f - (lambda (x) - (and x #t)))) - -(define output-measure-commands - (make-parameter #t - (lambda (x) - (and x #t)))) - -(define draw-bezier-lines - (make-parameter #f - (lambda (x) - (if (procedure? x) - (begin - (unless (procedure-arity-includes? x 1) - (raise-type-error 'draw-bezier-lines - "boolean or procedure of one argument" - x)) - x) - (and x #t))))) - -(define serialize-tex-picts - (make-parameter #f - (lambda (x) - (and x #t)))) - -(define tex-series-prefix - (make-parameter #f - (lambda (s) - (when s - (unless (string? s) - (raise-type-error 'tex-series-prefix "string or #f" s))) - s))) - -(define current-tex-sizer - (make-parameter (lambda (t) #f))) - -(define-struct pict (draw ; drawing instructions - width ; total width - height ; total height >= ascent + desecnt - ascent ; portion of height above top baseline - descent ; portion of height below bottom baseline - children)) ; list of child records -(define-struct child (pict dx dy)) - -(define (quotient* a b) - (if (integer? a) - (quotient a b) - (/ a b))) - -(define blank - (case-lambda - [() (blank 0 0 0)] - [(s) (blank s s)] - [(w h) (blank w h 0)] - [(w a d) (make-pict `(picture ,w ,(+ a d)) w (+ a d) a d null)])) - -(define (prog-picture f w a d) - (make-pict `(prog ,f) w (+ a d) a d null)) - -(define (extend-pict box dx dy dw da dd draw) - (let ([w (pict-width box)] - [h (pict-height box)] - [d (pict-descent box)] - [a (pict-ascent box)]) - (make-pict (if draw draw (pict-draw box)) - (+ w dw) (+ h da dd) - (+ a da) (+ d dd) - (list (make-child box dx dy))))) - -(define (single-pict-offset pict subbox) - (let floop ([box pict] - [found values] - [not-found (lambda () (error 'find-XX - "sub-pict: ~a not found in: ~a" - subbox pict))]) - (if (eq? box subbox) - (found 0 0) - (let loop ([c (pict-children box)]) - (if (null? c) - (not-found) - (floop (child-pict (car c)) - (lambda (dx dy) - (found (+ dx (child-dx (car c))) - (+ dy (child-dy (car c))))) - (lambda () - (loop (cdr c))))))))) - -(define (find-lb pict subbox-path) - (if (pict? subbox-path) - (single-pict-offset pict subbox-path) - (let loop ([p pict][l subbox-path][dx 0][dy 0]) - (if (null? l) - (values dx dy) - (let-values ([(x y) (find-lb p (car l))]) - (loop (car l) (cdr l) (+ x dx) (+ y dy))))))) - -(define-values (find-lt - find-lc - find-ltl - find-lbl - find-ct - find-cc - find-cb - find-ctl - find-cbl - find-rt - find-rc - find-rb - find-rtl - find-rbl) - (let ([lb (lambda (x w d a) x)] - [c (lambda (x w d a) (+ x (quotient* w 2)))] - [rt (lambda (x w d a) (+ x w))] - [tline (lambda (x w d a) (+ x (- w a)))] - [bline (lambda (x w d a) (+ x d))] - [find (lambda (get-x get-y) - (lambda (pict pict-path) - (let-values ([(dx dy) (find-lb pict pict-path)]) - (let ([p (let loop ([path pict-path]) - (cond - [(pict? path) path] - [(null? (cdr path)) (loop (car path))] - [else (loop (cdr path))]))]) - (values (get-x dx (pict-width p) 0 0) - (get-y dy (pict-height p) (pict-descent p) (pict-ascent p)))))))]) - (values (find lb rt) - (find lb c) - (find lb tline) - (find lb bline) - (find c rt) - (find c c) - (find c lb) - (find c tline) - (find c bline) - (find rt rt) - (find rt c) - (find rt lb) - (find rt tline) - (find rt bline)))) - -(define (launder box) - (let ([b (extend-pict box 0 0 0 0 0 #f)]) - (set-pict-children! b null) - b)) - -(define label-sizes null) -(define (extract-num s) ; strip off trainling `pt' - (let ([str (symbol->string s)]) - (inexact->exact - (ceiling - (string->number (substring str 0 (- (string-length str) 2))))))) - -(define (read-in-sizes file) - (parameterize ([read-case-sensitive #t]) - (when (file-exists? file) - (set! label-sizes - (append (with-input-from-file file - (lambda () - (let loop () - (let ([e (read)]) - (if (eof-object? e) - null - (let ([w (read)] - [h (read)] - [d (read)]) - (cons (list e - (extract-num w) - (extract-num h) - (extract-num d)) - (loop)))))))) - label-sizes))))) - -;; Marshall a tex string into a simple symbol -(define digits (make-vector 64)) -(let loop ([i 0]) - (unless (= i 10) - (vector-set! digits i (integer->char (+ i (char->integer #\0)))) - (loop (add1 i)))) -(let loop ([i 0]) - (unless (= i 26) - (vector-set! digits (+ i 10) (integer->char (+ i (char->integer #\a)))) - (vector-set! digits (+ i 36) (integer->char (+ i (char->integer #\A)))) - (loop (add1 i)))) -(vector-set! digits 62 #\-) -(vector-set! digits 63 #\+) -(define (number->base-64-string prefix n) - (let loop ([n n][s null]) - (if (zero? n) - (list->string (cons prefix s)) - (loop (arithmetic-shift n -6) - (cons (vector-ref digits (bitwise-and 63 n)) s))))) -(define serial-number 0) -(define (serialize s) - (cond - [(serialize-tex-picts) - (set! serial-number (add1 serial-number)) - (format "~a.~a" serial-number s)] - [(tex-series-prefix) - (format "~a.~a" (tex-series-prefix) s)] - [else s])) -(define (make-label s) - (string->symbol - (serialize - (number->base-64-string - #\T - (let loop ([l (string->list s)][n 0]) - (if (null? l) - n - (loop (cdr l) (+ (arithmetic-shift n 7) (char->integer (car l)))))))))) - -(define tex - (case-lambda - [(t) (tex t 10 10)] - [(t guess-width guess-height) - (let* ([label (make-label t)] - [info (or (assq label label-sizes) - (let ([v ((current-tex-sizer) t)]) - (and v - (cons label v))))] - [w (if info (cadr info) guess-width)] - [h (if info (caddr info) guess-height)] - [d (if info (cadddr info) guess-height)]) - (make-pict `(picture ,w ,(+ d h) - (put 0 ,d - ,(if (output-measure-commands) - (format "\\mztpMeasure{~a}{~a}" - t label) - t))) - w - (+ d h) - h d - null))])) - -(define (text-line/phantom text phantom . args) - (apply tex (format "\\makebox[0pt]{\\vphantom{~a}}~a" phantom text) args)) - -(define (text-line text . args) - (apply text-line/phantom text "Xy" args)) - -(define (tex-no-descent . args) - (clip-descent (apply tex args))) - -(define tex-paragraph - (case-lambda - [(w str) (tex-paragraph w str 'top)] - [(w str align) - (tex (format "\\parbox[~a]{~apt}{~a}" - (case align - [(top) 't] - [(bottom) 'b] - [else (error 'tex-paragraph "bad alignment: ~a" align)]) - w - str))])) - -(define (clip-descent b) - (let* ([w (pict-width b)] - [h (pict-height b)] - [d (pict-descent b)]) - (extend-pict - b 0 (- d) - 0 0 (- d) - `(picture ,w ,(- h d) - (put 0 ,(- d) ,(pict-draw b)))))) - -(define (thickness mode b) - (let* ([w (pict-width b)] - [h (pict-height b)]) - (extend-pict - b 0 0 0 0 0 - `(picture ,w ,h - (thickness ,mode ,(pict-draw b)))))) - -(define (thick b) (thickness 'thicklines b)) -(define (thin b) (thickness 'thinlines b)) - -(define delimit-str - "\\hbox{$\\~a{\\hbox{$\\left~a\\rule{0pt}{~apt}\\right.$}}$}") - -(define (mk-delimit left? middle? right? delim h) - (let ([str (format delimit-str - (cond - [left? "mathopen"] - [right? "mathclose"] - [middle? "mathrel"]) - delim - h)]) - (tex str 10 h))) - -(define (left-delimit delim h) - (mk-delimit #t #f #f delim h)) -(define (middle-delimit delim h) - (mk-delimit #f #t #f delim h)) -(define (right-delimit delim h) - (mk-delimit #f #f #t delim h)) - -(define (left-brace h) - (left-delimit "\\{" h)) -(define (right-brace h) - (right-delimit "\\}" h)) - -(define (make-h-brace kind w) - (tex (format "$\\~a{\\hbox{\\begin{picture}(~a,0)(0,0)\\end{picture}}}$" - kind w))) - -(define (top-brace w) - (make-h-brace "overbrace" w)) -(define (bottom-brace w) - (make-h-brace "underbrace" w)) - -(define inset - (case-lambda - [(box a) (inset box a a a a)] - [(box h v) (inset box h v h v)] - [(box l t r b) - (let ([w (+ l r (pict-width box))] - [h (+ t b (pict-height box))]) - (extend-pict - box l b - (+ l r) t b - `(picture - ,w ,h - (put ,l ,b ,(pict-draw box)))))])) - -(define dash-frame - (case-lambda - [(box) (dash-frame box default-seg)] - [(box seg) - (let ([w (pict-width box)] - [h (pict-height box)]) - (extend-pict - box 0 0 0 0 0 - `(picture - ,w ,h - (put 0 0 ,(pict-draw box)) - (put 0 0 ,(pict-draw (dash-hline w 0 seg))) - (put 0 ,h ,(pict-draw (dash-hline w 0 seg))) - (put 0 0 ,(pict-draw (dash-vline 0 h seg))) - (put ,w 0 ,(pict-draw (dash-vline 0 h seg))))))])) - -(define (frame box) - (dash-frame box (max (pict-width box) (pict-height box)))) - -(define (dash-line width height rotate seg) - (let ([vpos (quotient* height 2)]) - (make-pict - `(picture - ,@(rotate width height) - ,@(if (>= seg width) - `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,width))) - (let* ([remain (remainder width (* 2 seg))] - [count (quotient* width (* 2 seg))] - [lremain (quotient* remain 2)] - [rremain (- remain lremain)]) - `((put ,@(rotate 0 vpos) (line ,@(rotate 1 0) ,lremain)) - ,@(let loop ([count count][pos lremain]) - (if (zero? count) - null - (cons `(put ,@(rotate (+ pos seg) vpos) - (line ,@(rotate 1 0) ,seg)) - (loop (sub1 count) (+ pos seg seg))))) - (put ,@(rotate (- width rremain) vpos) - (line ,@(rotate 1 0) ,rremain)))))) - (car (rotate width height)) - (cadr (rotate width height)) - (cadr (rotate 0 height)) 0 - null))) - -(define (rlist b a) (list a b)) - -(define (hline width height) - (dash-line width height list width)) - -(define (vline width height) - (dash-line height width rlist height)) - -(define dash-hline - (case-lambda - [(width height) (dash-hline width height default-seg)] - [(width height seg) (dash-line width height list seg)])) - -(define dash-vline - (case-lambda - [(width height) (dash-vline width height default-seg)] - [(width height seg) (dash-line height width rlist seg)])) - -(define (oval box) - (let ([w (pict-width box)] - [h (pict-height box)]) - (extend-pict - box 0 0 0 0 0 - `(picture - ,w ,h - (put 0 0 ,(pict-draw box)) - (put ,(quotient* w 2) ,(quotient* h 2) (oval "" ,w ,h)))))) - -(define (oval/radius box r) - (let* ([w (pict-width box)] - [h (pict-height box)] - [rr (* 2 r)] - [lw (- w rr)] - [lh (- h rr)]) - (extend-pict - box 0 0 0 0 0 - `(picture - ,w ,h - (put 0 0 ,(pict-draw box)) - (put ,r ,r (oval "[bl]" ,rr ,rr)) - (put ,r 0 (line 1 0 ,lw)) - (put ,(- w r) ,r (oval "[br]" ,rr ,rr)) - (put ,w ,r (line 0 1 ,lh)) - (put ,r ,(- h r) (oval "[tl]" ,rr ,rr)) - (put ,r ,h (line 1 0 ,lw)) - (put ,(- w r) ,(- h r) (oval "[tr]" ,rr ,rr)) - (put ,0 ,r (line 0 1 ,lh)))))) - -(define (big-circle d) - (let ([r (quotient* d 2)]) - (picture - d d - `((curve 0 ,r ,r 0 0 0) - (curve ,r 0 ,d ,r ,d 0) - (curve ,d ,r ,r ,d ,d ,d) - (curve ,r ,d 0 ,r 0 ,d))))) - -(define (ghost box) - (let ([w (pict-width box)] - [h (pict-height box)]) - (extend-pict - box 0 0 0 0 0 - `(picture - ,w ,h)))) - -(define-values (vl-append - vc-append - vr-append - ht-append - hc-append - hb-append - htl-append - hbl-append) - (let ([make-append-boxes - (lambda (wcomb hcomb fxoffset fyoffset rxoffset ryoffset - combine-ascent combine-descent) - (lambda (sep . args) - (unless (number? sep) - (raise-type-error 'XXX-append "number" sep)) - (let append-boxes ([args args]) - (cond - [(null? args) (blank)] - [(null? (cdr args)) (car args)] - [else - (let* ([first (car args)] - [rest (append-boxes (cdr args))] - [w (wcomb (pict-width first) (pict-width rest) sep)] - [h (hcomb (pict-height first) (pict-height rest) sep)] - [fw (pict-width first)] - [fh (pict-height first)] - [rw (pict-width rest)] - [rh (pict-height rest)] - [fd1 (pict-ascent first)] - [fd2 (pict-descent first)] - [rd1 (pict-ascent rest)] - [rd2 (pict-descent rest)] - [dx1 (fxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] - [dy1 (fyoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] - [dx2 (rxoffset fw fh rw rh sep fd1 fd2 rd1 rd2)] - [dy2 (ryoffset fw fh rw rh sep fd1 fd2 rd1 rd2)]) - (make-pict - `(picture - ,w ,h - (put ,dx1 - ,dy1 - ,(pict-draw first)) - (put ,dx2 - ,dy2 - ,(pict-draw rest))) - w h - (combine-ascent fd1 rd1 fd2 rd2 fh rh h) - (combine-descent fd2 rd2 fd1 rd1 fh rh h) - (list (make-child first dx1 dy1) - (make-child rest dx2 dy2))))]))))] - [2max (lambda (a b c) (max a b))] - [zero (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) 0)] - [fv (lambda (a b . args) a)] - [sv (lambda (a b . args) b)] - [min2 (lambda (a b . args) (min a b))] - [max2 (lambda (a b . args) (max a b))] - [min-ad (lambda (a b oa ob ah bh h) - (if (and (= ah (+ a oa)) - (= bh (+ b ob))) - (- h (max oa ob)) - (min a b)))]) - (values - (make-append-boxes 2max + - zero (lambda (fw fh rw rh sep . a) (+ sep rh)) - zero zero - fv sv) - (make-append-boxes 2max + - (lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) fw) 2)) - (lambda (fw fh rw rh sep . a) (+ sep rh)) - (lambda (fw fh rw rh sep . a) (quotient* (- (max fw rw) rw) 2)) - zero - fv sv) - (make-append-boxes 2max + - (lambda (fw fh rw rh sep . a) (- (max fw rw) fw)) - (lambda (fw fh rw rh sep . a) (+ sep rh)) - (lambda (fw fh rw rh sep . a) (- (max fw rw) rw)) - zero - fv sv) - (make-append-boxes + 2max - zero - (lambda (fw fh rw rh sep . a) (- (max fh rh) fh)) - (lambda (fw fh rw rh sep . a) (+ sep fw)) - (lambda (fw fh rw rh sep . a) (- (max fh rh) rh)) - max2 min2) - (make-append-boxes + 2max - zero - (lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) fh) 2)) - (lambda (fw fh rw rh sep . a) (+ sep fw)) - (lambda (fw fh rw rh sep . a) (quotient* (- (max fh rh) rh) 2)) - min2 max2) - (make-append-boxes + 2max - zero zero - (lambda (fw fh rw rh sep . a) (+ sep fw)) zero - min2 max2) - (make-append-boxes + 2max - zero - (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) - (- (max fh rh) fh (- (max fd1 rd1) fd1))) - (lambda (fw fh rw rh sep . a) (+ sep fw)) - (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) - (- (max fh rh) rh (- (max fd1 rd1) rd1))) - max2 min-ad) - (make-append-boxes + 2max - zero - (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) - (- (max fd2 rd2) fd2)) - (lambda (fw fh rw rh sep . a) (+ sep fw)) - (lambda (fw fh rw rh sep fd1 fd2 rd1 rd2) - (- (max fd2 rd2) rd2)) - min-ad max2)))) - -(define-values (lt-superimpose - lb-superimpose - lc-superimpose - ltl-superimpose - lbl-superimpose - rt-superimpose - rb-superimpose - rc-superimpose - rtl-superimpose - rbl-superimpose - ct-superimpose - cb-superimpose - cc-superimpose - ctl-superimpose - cbl-superimpose) - (let ([make-superimpose - (lambda (get-h get-v get-th) - (lambda boxes - (let ([max-w (apply max (map pict-width boxes))] - [max-h (apply max (map pict-height boxes))] - [max-a (apply max (map pict-ascent boxes))] - [max-a-complement (apply max (map (lambda (b) (- (pict-height b) (pict-ascent b))) - boxes))] - [max-d (apply max (map pict-descent boxes))] - [max-d-complement (apply max (map (lambda (b) (- (pict-height b) (pict-descent b))) - boxes))]) - (picture max-w (get-th max-h max-a max-d max-a-complement max-d-complement) - (map (lambda (box) - `(place ,(get-h max-w (pict-width box)) - ,(get-v max-h (pict-height box) - max-d (pict-descent box) - max-a-complement) - ,box)) - boxes)))))] - [norm (lambda (h a d ac dc) h)] - [tbase (lambda (h a d ac dc) (+ a ac))] - [bbase (lambda (h a d ac dc) (+ d dc))] - [lb (lambda (m v . rest) 0)] - [rt (lambda (m v . rest) (- m v))] - [tline (lambda (m v md d mac) mac)] - [bline (lambda (m v md d mac) (- md d))] - [c (lambda (m v . rest) (quotient* (- m v) 2))]) - (values - (make-superimpose lb rt norm) - (make-superimpose lb lb norm) - (make-superimpose lb c norm) - (make-superimpose lb tline tbase) - (make-superimpose lb bline bbase) - (make-superimpose rt rt norm) - (make-superimpose rt lb norm) - (make-superimpose rt c norm) - (make-superimpose rt tline tbase) - (make-superimpose rt bline bbase) - (make-superimpose c rt norm) - (make-superimpose c lb norm) - (make-superimpose c c norm) - (make-superimpose c tline tbase) - (make-superimpose c bline bbase)))) - -(define table - (case-lambda - [(ncol cells col-aligns row-aligns col-seps row-seps) - (unless (positive? ncol) - (raise-type-error 'table "positive column count" ncol)) - (let ([count (length cells)]) - (unless (zero? (remainder count ncol)) - (error 'table "cell count isn't divisble by the provided column count")) - (let* ([w ncol] - [h (/ count w)] - [cells (let rloop ([r h][cells cells][r-acc null]) - (if (zero? r) - (list->vector (reverse r-acc)) - (let loop ([c w][cells cells][one-acc null]) - (if (zero? c) - (rloop (sub1 r) cells (cons (list->vector (reverse one-acc)) r-acc)) - (loop (sub1 c) (cdr cells) (cons (car cells) one-acc))))))] - [imp-list->vector (lambda (l n) - (let ([v (make-vector n)]) - (let loop ([l l][p 0]) - (unless (= n p) - (vector-set! v - p - (if (pair? l) - (car l) - l)) - (loop (if (pair? l) (cdr l) l) (add1 p)))) - v))] - [ralign (imp-list->vector row-aligns h)] - [calign (imp-list->vector col-aligns w)] - [rsep (imp-list->vector row-seps h)] - [csep (imp-list->vector col-seps w)] - [get-cell (lambda (c r) (vector-ref (vector-ref cells r) c))] - [nmap (lambda (f w) - (let loop ([n w][acc null]) - (if (zero? n) - acc - (loop (sub1 n) (cons (f (sub1 n)) acc)))))] - [rowmap (lambda (f) (nmap f h))] - [colmap (lambda (f) (nmap f w))] - [superimposed-rows (list->vector - (rowmap (lambda (r) - (apply - (vector-ref ralign r) - (colmap (lambda (c) (get-cell c r)))))))] - [superimposed-cols (list->vector - (colmap (lambda (c) - (apply - (vector-ref calign c) - (rowmap (lambda (r) (get-cell c r)))))))]) - ; No space after the last row/col - (vector-set! rsep (sub1 h) 0) - (vector-set! csep (sub1 w) 0) - - (apply - vl-append - 0 - (rowmap - (lambda (r) - (vl-append - 0 - (apply - ht-append - 0 - (colmap (lambda (c) - (ht-append - 0 - (let* ([cell (get-cell c r)] - [sc (vector-ref superimposed-cols c)] - [sr (vector-ref superimposed-rows r)] - [w (pict-width sc)] - [h (pict-height sr)]) - (let-values ([(x __) (find-lb sc cell)] - [(_ y) (find-lb sr cell)]) - (picture - w h - `((place ,x ,y ,cell))))) - (blank (vector-ref csep c) 0))))) - (blank 0 (vector-ref rsep r))))))))])) - -(define (record title . fields) - (let* ([totalwidth (apply max (pict-width title) (map pict-width fields))] - [linespace (if (null? fields) 0 recordseplinespace)] - [totalheight (+ (pict-height title) (apply + (map pict-height fields)) - linespace)] - [title-y (- totalheight (pict-height title))] - [field-ys (let loop ([pos (- totalheight (pict-height title) linespace)] - [fields fields]) - (if (null? fields) - null - (let* ([p (- pos (pict-height (car fields)))]) - (cons p - (loop p (cdr fields))))))]) - (make-pict - `(picture - ,totalwidth ,totalheight - (put 0 0 (line 1 0 ,totalwidth)) - (put 0 ,totalheight (line 1 0 ,totalwidth)) - (put 0 0 (line 0 1 ,totalheight)) - (put ,totalwidth 0 (line 0 1 ,totalheight)) - (put 0 ,title-y ,(pict-draw title)) - ,@(if (null? fields) - '() - `((put 0 ,(- totalheight (pict-height title) (quotient* linespace 2)) - (line 1 0 ,totalwidth)))) - ,@(map (lambda (f p) `(put 0 ,p ,(pict-draw f))) - fields field-ys)) - totalwidth totalheight - totalheight 0 - (cons - (make-child title 0 title-y) - (map (lambda (child child-y) (make-child child 0 child-y)) fields field-ys))))) - -(define (find-slope dh dv max-slope-num h-within v-within) ; max-slope-num is 4 or 6 - ; Result is (slope new-dh), where slope can be 'vertical, in which case - ; new-dh is really dv - (letrec ([best-of-two - (lambda (a b) - (let*-values ([(ls lh) (a)] - [(rs rh) (b)]) - (if (and ls (or (not rs) (< (abs (- lh dh)) (abs (- rh dh))))) - (values ls lh) - (values rs rh))))] - [search-h - (lambda (dh dv depth direction) - (if (zero? depth) - (values #f #f) - (if (zero? dh) - (values 'vertical dv) - (let ([slope (/ dv dh)]) - (if (and (<= (abs (numerator slope)) max-slope-num) - (<= (abs (denominator slope)) max-slope-num)) - (values slope dh) - (search-h (+ dh direction) dv (sub1 depth) direction))))))] - [sign (lambda (x) (if (positive? x) 1 -1))] - [flip - (lambda (s l) - (if s - (cond - [(eq? s 'vertical) (values (sign l) 0 (abs l))] - [(zero? s) (values 'vertical l)] - [else (values (/ 1 s) (round (* s l)))]) - (values #f #f)))] - [search-v - (lambda (dh dv depth direction) - (call-with-values (lambda () (search-h dv dh depth direction)) - flip))] - [change-h - (lambda (dh dv h-within) - (best-of-two (lambda () (search-h dh dv h-within -1)) - (lambda () (search-h dh dv h-within 1))))] - [change-v - (lambda (dh dv v-within) - (call-with-values (lambda () (change-h dv dh v-within)) - flip))]) - (cond - [(zero? v-within) (change-h dh dv h-within)] - [(zero? h-within) (change-v dh dv v-within)] - [else (let-values ([(s l) (search-h dh dv 1 0)]) - (if s - (values s l) - (best-of-two - (lambda () - (best-of-two (lambda () (find-slope dh (add1 dv) max-slope-num h-within (sub1 v-within))) - (lambda () (find-slope dh (sub1 dv) max-slope-num h-within (sub1 v-within))))) - (lambda () - (best-of-two (lambda () (find-slope (add1 dh) dv max-slope-num (sub1 h-within) v-within)) - (lambda () (find-slope (sub1 dh) dv max-slope-num (sub1 h-within) v-within)))))))]))) - -(define (parse-slope sl dh) - (if (eq? sl 'vertical) - (if (negative? dh) - (values 0 -1 (abs dh)) - (values 0 1 dh)) - (let ([d (denominator sl)] - [n (numerator sl)]) - (if (negative? dh) - (values (- d) (- n) (abs dh)) - (values d n dh))))) - -(define connect - (case-lambda - [(x1 y1 x2 y2) (connect x1 y1 x2 y2 #f)] - [(x1 y1 x2 y2 arrow?) - (if (not (or (use-old-connect) (draw-bezier-lines))) - (~connect 'r +inf.0 x1 y1 x2 y2 arrow?) - (let loop ([dd (if (draw-bezier-lines) 0 1)]) - (if (> dd (if (draw-bezier-lines) 0 4)) - ; give up - (if (draw-bezier-lines) - (let* ([get-len (lambda () (sqrt (+ (* (- x1 x2) (- x1 x2)) - (* (- y1 y2) (- y1 y2)))))] - [c (if (procedure? (draw-bezier-lines)) - ((draw-bezier-lines) (get-len)) - #f)]) - `((qbezier ,c ,x1 ,y1 ,(quotient* (+ x1 x2) 2) ,(quotient* (+ y1 y2) 2) ,x2 ,y2))) - (let ([xd (- x2 x1)]) - `((put ,x1 ,y1 (line ,(if (negative? xd) -1 1) 0 ,(abs xd)))))) - (let-values ([(s l) (find-slope (- x2 x1) (- y2 y1) - (if (using-pict2e-package) - +inf.0 - (if arrow? 4 6)) - dd dd)]) - (if s - (let-values ([(lh lv ll) (parse-slope s l)]) - `((put ,x1 ,y1 (,(if arrow? 'vector 'line) ,lh ,lv ,ll)))) - (loop (add1 dd)))))))])) - -(define ~connect - (case-lambda - [(exact close-enough x1 y1 x2 y2) (~connect exact close-enough x1 y1 x2 y2 #f)] - [(exact close-enough x1 y1 x2 y2 arrow?) - (if (= x2 x1) - ; "infinite" slope - (let ([dy (- y2 y1)]) - `((put ,x1 ,y1 (,(if arrow? 'vector 'line) 0 ,(if (negative? dy) -1 1) ,(abs dy))))) - (let ([real-slope (/ (- y2 y1) (- x2 x1))] - [split (lambda (xm ym) - (append - (~connect exact close-enough xm ym x1 y1 #f) - (~connect exact close-enough xm ym x2 y2 arrow?)))]) - (if (or (>= real-slope (if arrow? 7/8 11/12)) - (<= real-slope (if arrow? -7/8 -11/12))) - ; rounds to "infinite" slope - (if (> (abs (- x2 x1)) close-enough) - (split x1 (truncate (quotient (+ y1 y2) 2))) - (let ([dy (- y2 y1)]) - `((put ,x1 ,y1 (,(if arrow? 'vector 'line) - 0 - ,(if (negative? dy) -1 1) ,(abs dy)))))) - (let* ([slope (let loop ([slope real-slope][tolerances - (if arrow? - '(1/100 1/12 1/4) - '(1/100 1/50 1/25 1/10 1/6))]) - (if (<= (denominator slope) (if arrow? 4 6)) - slope - (loop (rationalize real-slope (car tolerances)) - (cdr tolerances))))] - [exact-x? (or (eq? exact 'x) (zero? slope))] - [r (sqrt (+ (* (- x1 x2) (- x1 x2)) (* (- y1 y2) (- y1 y2))))] - [dx (cond - [exact-x? (- x2 x1)] - [(eq? exact 'r) (truncate (* r (let ([d (denominator slope)] - [n (numerator slope)]) - (/ d (sqrt (+ (* d d) (* n n)))))))] - [else (truncate (* (/ slope) (- y2 y1)))])] - [dy (truncate (* slope dx))]) - (if (or (and exact-x? - (> (abs (- dy (- y2 y1))) close-enough)) - (and (not exact-x?) (eq? exact 'y) - (> (abs (- dx (- x2 x1))) close-enough)) - (and (not exact-x?) (eq? exact 'y) - (> (abs (- (sqrt (+ (* dx dx) (* dy dy))) r)) close-enough))) - (if (or exact-x? (eq? exact 'r)) - (let ([xm (truncate (quotient (+ x1 x2) 2))]) - (split xm (+ y1 (truncate (* slope (- xm x1)))))) - (let ([ym (truncate (quotient (+ y1 y2) 2))]) - (split (+ x1 (truncate (* (/ slope) (- ym y1)))) ym))) - (let ([same-sign (lambda (v s) - (if (negative? s) - (- (abs v)) - (abs v)))]) - `((put ,x1 ,y1 (,(if arrow? 'vector 'line) - ,(same-sign (denominator slope) (- x2 x1)) - ,(same-sign (numerator slope) (- y2 y1)) - ,(abs dx))))))))))])) - -(define (picture w h commands) - (let loop ([commands commands][translated null][children null]) - (if (null? commands) - (make-pict - `(picture ,w ,h - ,@(reverse translated)) - w h - h 0 - children) - (let ([c (car commands)] - [rest (cdr commands)]) - (unless (and (pair? c) (symbol? (car c))) - (error 'picture "bad command: ~a" c)) - (case (car c) - [(connect) (loop rest - (append (apply connect (cdr c)) - translated) - children)] - [(dconnect) (loop rest - (let ([x (cadr c)] - [y (caddr c)] - [dx (cadddr c)] - [dy (list-ref c 4)]) - (append (connect x y (+ x dx) (+ y dy) - (if (null? (list-tail c 5)) - #t - (list-ref c 5))) - translated)) - children)] - [(connect~y) (loop rest - (append (apply ~connect 'x (cdr c)) - translated) - children)] - [(connect~x) (loop rest - (append (apply ~connect 'y (cdr c)) - translated) - children)] - [(connect~xy) (loop rest - (append (apply ~connect 'r (cdr c)) - translated) - children)] - [(curve) (loop rest - (let ([x1 (cadr c)] - [y1 (caddr c)] - [x2 (cadddr c)] - [y2 (list-ref c 4)] - [xm (list-ref c 5)] - [ym (list-ref c 6)] - [d (if (null? (list-tail c 7)) - 1.0 - (list-ref c 7))]) - (let ([p (if (and d (>= d 0)) - (inexact->exact (floor (* d (sqrt (+ (expt (- x2 x1) 2) (expt (- y2 y1) 2)))))) - #f)]) - (if (and (= x1 x2) (= y1 y2)) - translated - (cons `(qbezier ,p ,x1 ,y1 ,xm ,ym ,x2 ,y2) - translated)))) - children)] - [(place) (let ([x (cadr c)] - [y (caddr c)] - [p (cadddr c)]) - (loop rest - (cons - `(put ,x ,y ,(pict-draw p)) - translated) - (cons - (make-child p x y) - children)))] - [else (loop rest (cons c translated) children)]))))) - -(define (cons-picture p commands) - (picture - (pict-width p) (pict-height p) - (cons - `(place 0 0 ,p) - commands))) - -(define black-and-white - (make-parameter #f - (lambda (x) - (and x #t)))) - -(define (colorize p color) - (if (black-and-white) - p - (extend-pict - p 0 0 0 0 0 - `(color ,color ,(pict-draw p))))) - -(define (optimize s) - (let o-loop ([s s][dx 0][dy 0]) - (if (string? s) - s - (let ([tag (car s)]) - (case tag - [(picture) - (list* 'picture (cadr s) (caddr s) - (map optimize (cdddr s)))] - [(color) - (let ([next (caddr s)]) - (if (and (pair? next) (eq? (car next) 'color)) - (optimize next) - (list* 'color (cadr s) - (list 'put dx dy (optimize next)))))] - [(thickness) - (let ([t (cadr s)] - [p (caddr s)]) - (list 'put dx dy - (list 'thickness t - (optimize p))))] - [(put) - (let ([x (cadr s)] - [y (caddr s)] - [next (cadddr s)]) - (if (and (pair? next) (eq? (car next) 'picture)) - ; optmize put-picture to just contents ... - (cons 'begin (map (lambda (s) (o-loop s (+ x dx) (+ y dy))) (cdddr next))) - ; normal - (list 'put (+ x dx) (+ y dy) (optimize next))))] - [(qbezier) - (let ([x1 (list-ref s 2)] - [y1 (list-ref s 3)] - [xm (list-ref s 4)] - [ym (list-ref s 5)] - [x2 (list-ref s 6)] - [y2 (list-ref s 7)] - [p (list-ref s 1)]) - (list 'qbezier p - (+ x1 dx) (+ y1 dy) - (+ xm dx) (+ ym dy) - (+ x2 dx) (+ y2 dy)))] - [(frame) - (list 'frame (optimize (cadr s)))] - [(colorbox) - (list 'colorbox (cadr s) (optimize (caddr s)))] - [(line vector circle circle* make-box oval prog) s] - [else (error 'optimize "bad tag: ~s" tag)]))))) - -(define (fixup-top s) - (cond - [(and (pair? s) (eq? (car s) 'color)) - ;; Drop initial put - (list* 'color (cadr s) (caddr (cdddr s)))] - [(and (pair? s) (eq? (car s) 'put)) - ;; Wrap initial put (from thickness) in a pair of braces - `(local ,(cadddr s))] - [else - ;; Do nothing - s])) - -(define (pict->string s) - (let output ([s (fixup-top (optimize (pict-draw s)))]) - (if (string? s) - s - (let ([tag (car s)]) - (case tag - [(local) - (format "{~a}~n" (output (cadr s)))] - [(begin) - (apply string-append (map output (cdr s)))] - [(picture) - (format "\\begin{picture}(~a,~a)~n~a\\end{picture}~n" - (cadr s) (caddr s) - (apply string-append (map output (cdddr s))))] - [(color) - (format "\\special{color push ~a}~n~a\\special{color pop}~n" - (cadr s) (output (cddr s)))] - [(thickness) - (format "\\~a~a" (cadr s) (output (caddr s)))] - [(put) - (format "\\put(~a,~a){~a}~n" (cadr s) (caddr s) (output (cadddr s)))] - [(qbezier) - (apply format "\\qbezier~a(~a,~a)(~a,~a)(~a,~a)~n" - (if (cadr s) - (format "[~a]" (cadr s)) - "") - (cddr s))] - [(line vector) - (format "\\~a(~a,~a){~a}" tag (cadr s) (caddr s) (cadddr s))] - [(circle) - (format "\\circle{~a}" (cadr s))] - [(circle*) - (format "\\circle*{~a}" (cadr s))] - [(frame) - (format "\\frame{~a}" (output (cadr s)))] - [(colorbox) - (format "\\colorbox{~a}{~a}" (cadr s) (output (caddr s)))] - [(oval) - (format "\\oval(~a,~a)~a" (caddr s) (cadddr s) (cadr s))] - [(make-box) - (format "\\makebox(~a, ~a)[~a]{~a}" - (cadr s) (caddr s) (cadddr s) (car (cddddr s)))] - [(prog) - (error 'pict->string "cannot handle prog pict")] - [else (error 'pict->string "bad tag: ~s" tag)]))))) - -(define (pict->commands s) - (let output ([s (fixup-top (optimize (pict-draw s)))]) - (if (string? s) - (list s) - (let ([tag (car s)]) - (case tag - [(local) - (output (cadr s))] - [(begin) - (apply append (map output (cdr s)))] - [(picture) - (apply append (map output (cdddr s)))] - [(color) - `((with-color ,(cadr s) ,(output (cddr s))))] - [(thickness) - `((with-thickness ,(cadr s) ,(output (caddr s))))] - [(put) - `((offset ,(cadr s) ,(caddr s) ,(output (cadddr s))))] - [(qbezier) - `((bezier ,@(cddr s)))] - [(line vector) - `((,tag ,(cadr s) ,(caddr s) ,(cadddr s)))] - [(circle circle*) - `((,tag ,(cadr s)))] - [(frame) - `((frame ,(output (cadr s))))] - [(colorbox) - `((colorbox ,(cadr s) ,(output (caddr s))))] - [(oval) - `((oval ,(caddr s) ,(cadddr s) ,(cadr s)))] - [(make-box) - `((make-box ,(cadr s) ,(caddr s) ,(cadddr s) ,(car (cddddr s))))] - [(prog) - `((prog ,(cadr s)))] - [else (error 'pict->commands "bad tag: ~s" tag)]))))) - -) diff --git a/collects/texpict/texpicts.ss b/collects/texpict/texpicts.ss deleted file mode 100644 index 2031275e..00000000 --- a/collects/texpict/texpicts.ss +++ /dev/null @@ -1,121 +0,0 @@ - -;; documentation moved to doc.txt - -(define-signature texpict^ - ((struct pict (draw width height ascent descent children)) - (struct child (pict dx dy)) - - read-in-sizes ; string -> void - - using-pict2e-package - - draw-bezier-lines - - output-measure-commands - - tex-series-prefix - serialize-tex-picts - - current-tex-sizer - - black-and-white - - find-lt ; (left & top) ; pict pict-path -> dx dy - find-lc ; (left & vertical center) - find-lb ; (left & bottom) - find-ltl ; (left and top baseline) - find-lbl ; (left and bottom baseline) - find-ct ; (horizontal center & top) - find-cc - find-cb - find-ctl - find-cbl - find-rt - find-rc - find-rb - find-rtl - find-rbl - - launder ; pict -> pict - - blank ; -> pict - ; w h -> pict - ; w h d -> pict - - tex ; string -> pict - text-line ; string -> pict - text-line/phantom ; string string -> pict - tex-paragraph ; w string ['top|'bottom] -> pict - - left-brace ; h -> pict - right-brace ; h -> pict - left-delimit ; str h -> pict - right-delimit ; str h -> pict - middle-delimit ; str h -> pict - top-brace ; w -> pict - bottom-brace ; w -> pict - - clip-descent ; pict -> pict - inset ; pict i -> pict - ; pict hi vi -> pict - ; pict l t r b -> pict - - hline ; w h -> pict - dash-hline ; w h seg-length -> pict ; default seg-length is 5 - vline ; w h -> pict - dash-vline ; w h seg-length -> pict ; default seg-length is 5 - - frame ; pict -> pict - dash-frame ; pict seg-length -> pict ; default seg-length is 5 - oval ; pict -> pict - oval/radius ; pict r -> pict ; r is radius of corners - - big-circle ; diameter -> pict - - thick ; pict -> pict - thin ; pict -> pict - - ghost ; pict -> pict - - record ; pict pict ... -> pict - - vl-append ; d pict ... -> pict ; d units between each picture - vc-append - vr-append - ht-append - hc-append - hb-append - htl-append ; align bottoms of ascents - hbl-append ; align tops of descents (normal text alignment) - - lt-superimpose ; pict ... -> pict - lb-superimpose - lc-superimpose - ltl-superimpose - lbl-superimpose - rt-superimpose - rb-superimpose - rc-superimpose - rtl-superimpose - rbl-superimpose - ct-superimpose - cb-superimpose - cc-superimpose - ctl-superimpose - cbl-superimpose - - table ; ncols pict-list col-aligns row-aligns col-seps row-seps -> pict - - colorize ; pict color-string -> pict - - picture ; w h command-list -> pict - - cons-picture ; pict command-list -> pict - - prog-picture ; (dx dy -> void) -> pict - - pict->string - - pict->commands - - use-old-connect)) diff --git a/collects/typeset/doc.txt b/collects/typeset/doc.txt deleted file mode 100644 index 548786f2..00000000 --- a/collects/typeset/doc.txt +++ /dev/null @@ -1,106 +0,0 @@ -_Typeset_ - -This tools provides a typesetting tool embedded into DrScheme. Unlike other -typesetting programs, this one has the full power of a modern programming -language (It only works in DrScheme's Full Scheme / Graphical with -Debugging language level currently). - -The typeset menu provides three options. Each inserts a new editor snip -boxes into DrScheme's main window. The first two insert blue boxes that -contain formatted text. The third inserts a red box whose contents are -Scheme text. These boxes can be nested, ala quasiquote. - -The blue boxes evaluate to their contents, except that any nested red boxes -are evaluated and their results are placed into the blue box. If the red -box evaluates to a value other than a blue box, the value is display'd into -the blue box. - -Technically speaking, the blue boxes evalute to an editor-snip% object, so -any of the methods of an editor snip will work on the objects. Using these -methods is discouraged, except possibly to provide better memory or time -performance. The editor-snip%'s set-tight-text-fit method is called with #t -and it's set-align-top-line method is called with #t. - -The tool also provides several new primitive functions: - - - postscript : (instance editor-snip%) string -> void - - generates postscript for the editor-snip% object and saves it into - the filename named by the second argument. - - - single-bracket : TST -> snip - - produces a snip that looks like its argument, except with square - brackets around it. - - - double-bracket : TST -> snip - - produces a snip that looks like its argument, except with double square - brackets around it. - - - tb-align : ((union 'base 'top 'center 'bottom) TST -> snip) - - if the second argument is not a snip, it just returns the second - argument. If it is a snip, this produces a new snip identical to the - second argument, except that it is aligned according to the first - argument. - - - greek : ((union char string number) -> snip) - - formats it's input in the symbol font, which contains greek letters and - mathemtical symbols. Evaluate this loop to see what is available (note - that the symbol font is the same on all platforms): - - (define (g n) (list n (integer->char n) (greek n))) - - (define (f n) - (cond - [(= n 33) null] - [else - (cons - (g (- n 1)) - (f (- n 1)))])) - - (f 256) - - - sup : (TST TST -> snip) - - sub : (TST TST -> snip) - - aligns the first two arguments as either base/superscript or - base/subscript positioning. The first argument is the base in each - case. - - - ellipses : snip - - This is vertically centered ellipses. It does not really look like - three periods, tho. - - - drawing : (string - (dc<%> -> exact-integer exact-integer exact-integer exact-integer) - (dc<%> exact-integer exact-integer -> void) - -> - snip) - - This is used to make snips that encode arbitrary drawing. The first - argument is name and it must be unique (it is used for copying, pasting - and saving the snip to disk). - - The second argument calculates the width, height, descent, space, - left-hand space and right-hand space of the snip. The last four numbers - are insets into the width and height. The descent is the bottom inset, - the space is the top inset and the left-hand and right-hand space are - the left and right insets. These insets are used when lining up the - snip with it's horizontal (and possibly vertical) neighbors. The dc<%> - is provided for size calculations but should not be drawn into. - - The final argument actually draws the snip into the dc<%>. It should be - drawn at the (x,y) coordinates given by the final argument's second and - third parameters. - - - typeset-size : (union (-> integer) (integer -> void)) - - This is a parameter-like function (not a true parameter) that controls - the size of the rendered font. It defaults to drscheme's font size, as - set in the preferences dialog. - - - position : ... diff --git a/collects/typeset/tool-sig.ss b/collects/typeset/tool-sig.ss deleted file mode 100644 index 5e1fdd3d..00000000 --- a/collects/typeset/tool-sig.ss +++ /dev/null @@ -1,22 +0,0 @@ -(define-signature typeset:utils-input^ - (typeset-size)) - -(define-signature typeset:utils^ - (single-bracket - double-bracket - tb-align - greek - drawing - ellipses - - ;(struct size (width height descent space left right)) - ;(struct pos (x y)) - position - sup sub - postscript - - typeset-size - - arrow b-arrow g-arrow bg-arrow checked-arrow blank-arrow)) ;; these should move out - -(require-library "invoke.ss") \ No newline at end of file diff --git a/collects/typeset/tool.ss b/collects/typeset/tool.ss deleted file mode 100644 index 7cbbe46e..00000000 --- a/collects/typeset/tool.ss +++ /dev/null @@ -1,345 +0,0 @@ -(unit/sig () - (import mred^ - framework^ - [drscheme : drscheme:export^] - [zodiac : zodiac:system^]) - -(define read/snips (lambda x (error x))) - -(define (snipize obj) - (if (is-a? obj snip%) - obj - (make-string-snip obj))) - -(define (make-string-snip obj) - (let* ([str (format "~a" obj)] - [sn (make-object string-snip% (string-length str))]) - (send sn insert str (string-length str) 0) - sn)) - -(define void-snip% - (class snip% () - (inherit get-style) - (override - [copy - (lambda () - (let ([ans (make-object void-snip%)]) - (send ans set-style (get-style)) - ans))]) - (sequence (super-init)))) - -(define (make-delta family) - (let ([d (make-object style-delta% 'change-family family)]) - (send d set-size-mult 0) - (send d set-size-add (preferences:get 'drscheme:font-size)) - ;(send d set-delta-foreground "BLACK") - d)) - -(define renderable-editor-snip% - (class editor-snip% (family color) - (inherit get-editor get-style) - - (private - [pen (send the-pen-list find-or-create-pen color 1 'solid)] - [brush (send the-brush-list find-or-create-brush "BLACK" 'transparent)]) - - (inherit get-extent get-inset) - (rename [super-draw draw]) - (override - [draw - (lambda (dc x y left top right bottom dx dy draw-caret) - (let ([bl (box 0)] - [br (box 0)] - [bt (box 0)] - [bb (box 0)] - [bw (box 0)] - [bh (box 0)]) - (get-extent dc x y bw bh #f #f #f #f) - (get-inset bl br bt bb) - (super-draw dc x y left top right bottom dx dy draw-caret) - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-pen pen) - (send dc set-brush brush) - (send dc draw-rectangle - (+ x (unbox bl)) - (+ y (unbox bt)) - (- (unbox bw) (unbox bl) (unbox br)) - (- (unbox bh) (unbox bt) (unbox bb))) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))]) - - (override - [write - (lambda (stream-out) - (send (get-editor) write-to-file stream-out 0 'eof))]) - (override - [copy - (lambda () - (let ([snip (make-snip)]) - (send snip set-editor (send (get-editor) copy-self)) - (send snip set-style (get-style)) - snip))]) - (public - [make-snip (lambda () (error 'make-snip "abstract method"))]) - - (public - [make-editor - (lambda () - (make-object (drscheme:unit:program-editor-mixin plain-text%) (make-delta family)))]) - - (sequence - (super-init (make-editor) #f)))) - -(define constant-snip% - (class* renderable-editor-snip% (zodiac:expands<%>) (family) - (inherit get-editor) - - (public - [expand - (lambda (obj) - (zodiac:structurize-syntax - `(,replace-in-template - ',family - ;,this - ;,(make-object editor-snip% (get-editor)) - ,(make-object editor-snip% (send (get-editor) copy-self)) - ,@(let loop ([snip (send (get-editor) find-first-snip)]) - (cond - [(not snip) `()] - [(transformable? snip) - `(,snip - . - ,(loop (send snip next)))] - [else (loop (send snip next))]))) - obj))]) - - (public - [get-family (lambda () family)]) - - (override - [write - (lambda (stream-out) - (send stream-out << (symbol->string family)) - (send (get-editor) write-to-file stream-out 0 'eof))] - [make-snip (lambda () (make-object constant-snip% family))]) - - (inherit show-border set-snipclass) - (sequence - (super-init family "BLUE") - (show-border #t) - (set-snipclass constant-snipclass)))) - -(define constant-snipclass% - (class snip-class% () - (override - [read - (lambda (stream-in) - (let* ([family (string->symbol (send stream-in get-string))] - [snip (make-object constant-snip% (if (member family '(roman modern)) - family - 'modern))]) - (send (send snip get-editor) read-from-file stream-in) - snip))]) - (sequence (super-init)))) -(define constant-snipclass (make-object constant-snipclass%)) -(send constant-snipclass set-version 1) -(send constant-snipclass set-classname "robby:constant-snip") -(send (get-the-snip-class-list) add constant-snipclass) - -(define evaluated-snip% - (class* renderable-editor-snip% (zodiac:expands<%>) () - (inherit get-editor) - - (public - [expand - (lambda (obj) - (let ([text (get-editor)]) - (let* ([loc (zodiac:make-location 0 0 0 text)] - [read - (zodiac:read - (gui-utils:read-snips/chars-from-text text 0 (send text last-position)) - loc - #t 1)]) - (zodiac:structurize-syntax - `(,snipize ,(read)) - (zodiac:make-zodiac #f loc loc)))))]) - - -;; MATTHEW -;; cannot do this because the styles information in the saved texts screws up. - (override - [make-editor - (lambda () - (make-object (drscheme:unit:program-editor-mixin (scheme:text-mixin text:basic%))))]) - - (override - [make-snip (lambda () (make-object evaluated-snip%))]) - - (inherit show-border set-snipclass) - (sequence - (super-init 'modern "RED") - (show-border #t) - (set-snipclass evaluated-snipclass)))) - -(define evaluated-snipclass% - (class snip-class% () - (override - [read - (lambda (stream-in) - (let* ([snip (make-object evaluated-snip%)] - [editor (send snip get-editor)]) - (send editor read-from-file stream-in) - snip))]) - (sequence (super-init)))) - -(define evaluated-snipclass (make-object evaluated-snipclass%)) -(send evaluated-snipclass set-version 1) -(send evaluated-snipclass set-classname "robby:evaluated-snip") -(send (get-the-snip-class-list) add evaluated-snipclass) - -(define plain-text% - (class text:keymap% ([delta (make-object style-delta%)]) - (inherit change-style copy-self-to) - (rename [super-after-insert after-insert] - [super-on-insert on-insert]) - (inherit begin-edit-sequence end-edit-sequence) - (override - [copy-self - (lambda () - (let ([t (make-object plain-text% delta)]) - (copy-self-to t) - t))] - [on-insert - (lambda (x y) - (super-on-insert x y) - (begin-edit-sequence))] - [after-insert - (lambda (x y) - (super-after-insert x y) - (change-style delta x (+ x y)) - (end-edit-sequence))]) - (inherit set-styles-sticky) - (sequence - (super-init) - (set-styles-sticky #f)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; -;;; EVALUATION ;;; -;;; ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define (transformable? snip) - (or (is-a? snip constant-snip%) - (is-a? snip evaluated-snip%))) - -(define typeset-size - (let ([value (preferences:get 'drscheme:font-size)]) - (case-lambda - [() value] - [(x) - (unless (and (exact? x) - (integer? x) - (> x 0)) - (error 'typeset-size - "expected an exact integer strictly greater than zero")) - (set! value x)]))) - -(define (replace-in-template family template-snip . replacements) - (let* ([delta (make-delta family)] - [_ (begin (send delta set-delta-foreground "BLACK") - (send delta set-size-mult 0) - (send delta set-size-add (typeset-size)))] - [text (make-object plain-text% delta)]) - (let loop ([replacements replacements] - [snip (send (send template-snip get-editor) find-first-snip)]) - (cond - [(not snip) - (unless (null? replacements) - (error 'replace-in-template "found end without doing all replacements: ~s" replacements)) - (void)] - - [(transformable? snip) - (when (null? replacements) - (error 'replace-in-template "found replacable without replacement")) - (let ([replacement (car replacements)] - [pos (send text get-snip-position snip)]) - (send text insert (if (is-a? replacement snip%) - (send replacement copy) - (make-string-snip replacement)) - (send text last-position) (send text last-position)) - (loop (cdr replacements) - (send snip next)))] - - [else - (send text insert (send snip copy) (send text last-position) (send text last-position)) - (loop replacements (send snip next))])) - - (let ([snip (make-object editor-snip% text #f - 0 0 0 0 - 0 0 0 0)]) - (send text hide-caret #t) - (send snip set-tight-text-fit #t) - (send snip set-align-top-line #t) - snip))) - -(define (typeset-frame-extension super%) - (class/d super% args - ((inherit get-editor get-menu-bar get-edit-target-object)) - - (apply super-init args) - - (let* ([mb (get-menu-bar)] - [menu (make-object menu% "Typeset" mb)] - [insert-snip - (lambda (make-obj) - (let ([editor (get-edit-target-object)]) - (when editor - (let loop ([editor editor]) - (let ([focused (send editor get-focus-snip)]) - (if (and focused - (is-a? focused editor-snip%)) - (loop (send focused get-editor)) - (let ([snip (make-obj)]) - (send editor insert snip) - (send editor set-caret-owner snip 'display))))))))]) - (make-object menu-item% "Modern Constant Snip" menu - (lambda (menu evt) - (insert-snip - (lambda () (make-object constant-snip% 'modern)))) - #\m) - (make-object menu-item% "Roman Constant Snip" menu - (lambda (menu evt) - (insert-snip - (lambda () (make-object constant-snip% 'roman)))) - #\r) - (make-object menu-item% "Evaluated Snip" menu - (lambda (menu evt) - (insert-snip - (lambda () (make-object evaluated-snip%)))))) - - (frame:reorder-menus this))) - -(define utils (invoke-unit/sig (require-library "utils.ss" "typeset") - mred^ framework^ - typeset:utils-input^)) - -(define (typeset-rep-extension super-text%) - (class/d super-text% args - ((override reset-console) - (rename [super-reset-console reset-console]) - (inherit user-namespace)) - - (define (reset-console) - (super-reset-console) - (parameterize ([current-namespace user-namespace]) - (global-define-values/invoke-unit/sig typeset:utils^ utils))) - - (apply super-init args))) - -(drscheme:get/extend:extend-unit-frame typeset-frame-extension) -(drscheme:get/extend:extend-interactions-text typeset-rep-extension) - - -) diff --git a/collects/typeset/utils.ss b/collects/typeset/utils.ss deleted file mode 100644 index 1ee8ba4c..00000000 --- a/collects/typeset/utils.ss +++ /dev/null @@ -1,957 +0,0 @@ -(unit/sig () - (import mred^ - framework^ - typeset:utils-input^) - - (define (snipize obj) - (if (is-a? obj snip%) - obj - (make-object string-snip% (format "~a" obj)))) - - (define (snipize/copy obj) - (if (is-a? obj snip%) - (send obj copy) - (make-object string-snip% (format "~a" obj)))) - - (define (set-box/f! b v) (when (box? b) (set-box! b v))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; -;;; POSTSCRIPT ;;; -;;; ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define ps-figure-editor-admin% - (class/d editor-admin% (filename editor) - ((override get-dc - get-max-view - get-view - grab-caret - needs-update - refresh-delayed? - resized - scroll-to - update-cursor)) - - (define delayed? #t) - - (define dc - (let ([ps-setup (make-object ps-setup%)]) - (send ps-setup copy-from (current-ps-setup)) - (send ps-setup set-file filename) - (send ps-setup set-mode 'file) - (parameterize ([current-ps-setup ps-setup]) - (make-object post-script-dc% #f)))) - - (define (get-dc xb yb) - (set-box/f! xb 0) - (set-box/f! yb 0) - dc) - - (define (calc-view xb yb wb hb full?) - (set-box/f! xb 0) - (set-box/f! yb 0) - (let-values ([(w h) (send dc get-size)]) - (set-box/f! wb w) - (set-box/f! hb h))) - (define (get-max-view xb yb wb hb full?) - (calc-view xb yb wb hb full?)) - - (define (get-view xb yb wb hb full?) - (calc-view xb yb wb hb full?)) - - (define (grab-caret domain) - (void)) - (define (needs-update localx localy x y) - (void)) - (define (refresh-delayed?) - delayed?) - (define (resized refresh?) - (when refresh? - (let-values ([(w h) (send dc get-size)]) - (send editor refresh 0 0 w h 'no-caret)))) - - (define (scroll-to localx localy w h refresh? bias) - (when refresh? - (let-values ([(w h) (send dc get-size)]) - (send editor refresh 0 0 w h 'no-caret)))) - (define (update-cursor) (void)) - - (super-init) - - (send dc start-doc (format "Creating ~a" filename)) - (send dc start-page) - - (set! delayed? #t) - (send editor set-admin #f) - (send editor size-cache-invalid) - (send editor set-admin this) - - (set! delayed? #f) - (let-values ([(w h) (send dc get-size)]) - (send editor refresh 0 0 w h 'no-caret)) - (send dc end-page) - (send dc end-doc))) - - (define (postscript snip filename) - (unless (is-a? snip editor-snip%) - (error 'postscript - "expected first argument to be an editor-snip%, got: ~e, other args: ~e" - snip filename)) - (unless (string? filename) - (error 'postscript - "expected second argument to be a string, got: ~e, other args: ~e" - filename - snip)) - (let* ([editor (send snip get-editor)] - [editor-admin (send editor get-admin)]) - (make-object ps-figure-editor-admin% filename editor) - (send editor set-admin editor-admin))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; -;;; ALIGNMENT ;;; -;;; ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define (para-align alignment) - (lambda (snip) - (if (is-a? snip editor-snip%) - (let* ([new (send snip copy)] - [new-e (send new get-editor)]) - (when (is-a? new-e text%) - (let loop ([pn (+ (send new-e last-paragraph) 1)]) - (unless (zero? pn) - (send new-e set-paragraph-alignment (- pn 1) alignment) - (loop (- pn 1))))) - new) - snip))) - - (define lr-align-center (para-align 'center)) - (define lr-align-left (para-align 'left)) - (define lr-align-right (para-align 'right)) - - (define (tb-align alignment snip) - (if (is-a? snip editor-snip%) - (let* ([new (send snip copy)] - [new-e (send new get-editor)]) - (when (is-a? new-e text%) - (let ([sd (make-object style-delta%)]) - (send sd set-alignment-on alignment) - (send new-e change-style sd 0 (send new-e last-position)))) - new) - snip)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; -;;; BRACKETS ;;; -;;; ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define bracket-snip% - (class editor-snip% (between-snip left-margin top-margin right-margin bottom-margin) - (inherit get-editor) - (override - [write - (lambda (p) - (send (get-editor) write-to-file p))]) - (public - [height #f] - [width #f]) - (rename [super-get-extent get-extent] - [super-draw draw]) - (override - [get-extent - (lambda (dc x y w h descent space lspace rspace) - (for-each (lambda (x) (when (and (box? x) (> 0 (unbox x))) (set-box! x 0))) - (list w h descent space lspace rspace)) - (super-get-extent dc x y w h descent space lspace rspace) - - ;(when (box? descent) (set-box! descent (+ (unbox descent) bottom-margin))) - ;(when (box? space) (set-box! space (+ (unbox space) top-margin))) - ;(when (box? lspace) (set-box! lspace (+ (unbox lspace) left-margin))) - ;(when (box? rspace) (set-box! rspace (+ (unbox rspace) right-margin))) - - (when (box? h) - (set! height (unbox h))) - (when (box? w) - (set! width (unbox w))))]) - - (inherit get-style) - (inherit set-tight-text-fit) - (sequence - (let ([text (make-object text:basic%)]) - (super-init text #f - left-margin top-margin right-margin bottom-margin - 0 0 0 0) - (set-tight-text-fit #t) - (send text insert (send between-snip copy)))))) - - (define double-bracket-snip% - (class* bracket-snip% () (between-snip) - (inherit get-style) - (override - [copy - (lambda () - (let ([snip (make-object double-bracket-snip% between-snip)]) - (send snip set-style (get-style)) - snip))]) - - (inherit height width) - (rename [super-draw draw]) - (override - [draw - (lambda (dc x y left top right bottom dx dy draw-caret) - (let ([vertical-line - (lambda (x) - (send dc draw-line x y x (+ y height -1)))] - [horizontal-lines - (lambda (x) - (send dc draw-line x y (+ x 5) y) - (send dc draw-line x (+ y height -1) (+ x 5) (+ y height -1)))] - [old-pen (send dc get-pen)]) - - (when (is-a? dc post-script-dc%) - (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))) - - (horizontal-lines x) - (horizontal-lines (+ x width -6)) - (vertical-line x) - (vertical-line (+ x width -1)) - (vertical-line (+ x 3)) - (vertical-line (+ x width -4)) - - (send dc set-pen old-pen)) - (super-draw dc x y left top right bottom dx dy draw-caret))]) - (inherit set-snipclass) - (sequence - (super-init between-snip 6 1 6 1) - (set-snipclass double-bracket-snipclass)))) - - (define single-bracket-snip% - (class* bracket-snip% () (between-snip) - (inherit get-style) - (override - [copy - (lambda () - (let ([snip (make-object single-bracket-snip% between-snip)]) - (send snip set-style (get-style)) - snip))]) - - (inherit height width) - (rename [super-draw draw]) - (override - [draw - (lambda (dc x y left top right bottom dx dy draw-caret) - (let ([vertical-line - (lambda (x) - (send dc draw-line x y x (+ y height -1)))] - [horizontal-lines - (lambda (x) - (send dc draw-line x y (+ x 3) y) - (send dc draw-line x (+ y height -1) (+ x 3) (+ y height -1)))] - [old-pen (send dc get-pen)]) - - (when (is-a? dc post-script-dc%) - (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))) - - (horizontal-lines (+ x 1)) - (horizontal-lines (+ x width -5)) - (vertical-line (+ x 1)) - (vertical-line (+ x width -2)) - (send dc set-pen old-pen)) - (super-draw dc x y left top right bottom dx dy draw-caret))]) - (inherit set-snipclass) - (sequence - (super-init between-snip 4 1 4 1) - (set-snipclass single-bracket-snipclass)))) - - (define bracket-snipclass% - (class snip-class% (%) - (override - [read - (lambda (p) - (let* ([bs (make-object % (make-object snip%))] - [t (send bs get-editor)]) - (send t read-from-file p)))]) - (sequence (super-init)))) - - (define single-bracket-snipclass (make-object bracket-snipclass% single-bracket-snip%)) - (send single-bracket-snipclass set-version 1) - (send single-bracket-snipclass set-classname "robby:single-bracket") - (send (get-the-snip-class-list) add single-bracket-snipclass) - - (define double-bracket-snipclass (make-object bracket-snipclass% double-bracket-snip%)) - (send double-bracket-snipclass set-version 1) - (send double-bracket-snipclass set-classname "robby:double-bracket") - (send (get-the-snip-class-list) add double-bracket-snipclass) - - ;; bracket : snip -> snip - ;; adds double square brackets around the snip - (define (double-bracket snip) - (make-object double-bracket-snip% (snipize snip))) - - (define (single-bracket snip) - (make-object single-bracket-snip% (snipize snip))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; -;;; GREEK ;;; -;;; ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; greek : (union char string number) -> snip - ;; renders the alphabetic characters in the argument into greek letters - (define greek - (letrec ([snipclass - (make-object (class snip-class% () - (override - [read - (lambda (stream-in) - (make-object greek-snip% - (send stream-in get-string) - (send stream-in get-number)))]) - (sequence (super-init))))] - [greek-snip% - (class snip% (str size) - (inherit get-style) - (private - [font - (send the-font-list find-or-create-font - size 'symbol 'normal 'normal #f)]) - (override - [write - (lambda (stream-out) - (send stream-out << str) - (send stream-out << size))] - [get-extent - (lambda (dc x y wb hb descentb spaceb lspace rspace) - (let-values ([(width height descent ascent) - (send dc get-text-extent str font)]) - (set-box/f! wb (max 0 width)) - (set-box/f! hb (max 0 height)) - (set-box/f! descentb (max 0 descent)) - (set-box/f! spaceb (max 0 ascent)) - (set-box/f! lspace 0) - (set-box/f! rspace 0)))] - [draw - (lambda (dc x y left top right bottom dx dy draw-caret) - (let ([old-font (send dc get-font)]) - (send dc set-font font) - (send dc draw-text str x y) - (send dc set-font old-font)))] - [copy - (lambda () - (let ([snip (make-object greek-snip% str size)]) - (send snip set-style (get-style)) - snip))]) - (inherit set-snipclass) - (sequence - (super-init) - (set-snipclass snipclass)))]) - - (send snipclass set-version 1) - (send snipclass set-classname "robby:greek") - (send (get-the-snip-class-list) add snipclass) - (lambda (in) - (let ([str (cond - [(string? in) in] - [(char? in) (string in)] - [(number? in) (string (integer->char in))])]) - (make-object greek-snip% str (typeset-size)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; -;;; DRAWINGS ;;; -;;; ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - ;; drawing : ((dc -> exact-int exact-int exact-int) (dc exact-int - ;; exact-int -> void) -> snip) get-extent determines the amount of - ;; space the new snip needs. The six results are the width, height, - ;; descent, ascent, lspace and rspace. (The descent and space do not - ;; actually add space to the snip, they only helps to determine - ;; where to lineup adjacent snips.) draw actually draws the snip. - (define (drawing name eextent ddraw) - (unless (string? name) - (error - 'draw - "expected string as first argument, got: ~e; other args: ~e ~e" - name eextent ddraw)) - (unless (and (procedure? eextent) (procedure? ddraw)) - (error - 'draw - "expected procedures as second and third arguments, got: ~e ~e; first args: ~e" - eextent ddraw name)) - (letrec ([drawing% - (class snip% () - (inherit get-style) - (override - [write - (lambda (stream-out) - (send stream-out put name))] - [copy - (lambda () - (let ([ans (make-object drawing%)]) - (send ans set-style (get-style)) - ans))] - [draw - (lambda (dc x y left top right bottom dx dy draw-caret) - (ddraw dc x y))] - [get-extent - (lambda (dc x y width-b height-b descent-b space-b lspace-b rspace-b) - (let ([old-font (send dc get-font)]) - (send dc set-font (send (get-style) get-font)) - (let-values ([(width height descent space lspace rspace) (eextent dc)]) - (set-box/f! width-b width) - (set-box/f! height-b height) - (set-box/f! descent-b descent) - (set-box/f! space-b space) - (set-box/f! lspace-b lspace) - (set-box/f! rspace-b rspace)) - (send dc set-font old-font)))]) - (inherit set-snipclass) - (sequence - (super-init) - (set-snipclass drawing-snipclass)))]) - (send drawing-snipclass add-drawing name drawing%) - (make-object drawing%))) - - (define drawing-snipclass - (make-object (class/d snip-class% () - ((override read) - (public add-drawing)) - - (define drawing-table null) - - (define (add-drawing name class%) - (let ([binding (assoc name drawing-table)]) - (if binding - (set-car! (cdr binding) class%) - (set! drawing-table (cons (list name class%) drawing-table))))) - - (define (read stream-in) - (let* ([name (send stream-in get-string)] - [class (assoc name drawing-table)]) - (if class - (make-object (cadr class)) - (let* ([bad-bitmap (make-object bitmap% 10 10 #t)] - [bdc (make-object bitmap-dc% bad-bitmap)]) - (send bdc clear) - (send bdc draw-rectangle 0 0 10 10) - (send bdc draw-line 0 0 10 10) - (send bdc draw-line 10 0 0 10) - (send bdc set-bitmap #f) - (make-object image-snip% bad-bitmap))))) - (super-init)))) - (send drawing-snipclass set-version 1) - (send drawing-snipclass set-classname "robby:drawing") - (send (get-the-snip-class-list) add drawing-snipclass) - - (define ellipses - (let* ([margin 2] - [get-w/h/d/s/l/r - (lambda (dc) - (let ([old-font (send dc get-font)]) - (send dc set-font (send the-font-list find-or-create-font (typeset-size) - 'roman 'normal 'normal #f)) - (let-values ([(width height descent space) (send dc get-text-extent "a")]) - (begin0 (values (+ margin (* 3 width) margin) height descent space margin margin) - (send dc set-font old-font)))))]) - (drawing "robby:ellipses" - get-w/h/d/s/l/r - (lambda (dc x y) - (let*-values ([(w h d s _1 _2) (get-w/h/d/s/l/r dc)] - [(yp) (+ y s (floor (+ 1/2 (/ (- h s d) 2))))] - [(l) (+ x margin)] - [(r) (+ x w (- margin))] - [(ellipse-size) 2/3] - [(draw-dot) - (lambda (x y) - (if (is-a? dc post-script-dc%) - (send dc draw-ellipse - (- x (/ ellipse-size 2)) (- y (/ ellipse-size 2)) - ellipse-size ellipse-size) - (send dc draw-point x y)))] - [(old-pen) (send dc get-pen)] - [(old-brush) (send dc get-brush)]) - ;(send dc draw-rectangle x y w h) - ;(send dc draw-rectangle x (+ y s) w (- h d s)) - - (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid)) - (send dc set-brush (send the-brush-list find-or-create-brush "BLACK" 'solid)) - - (draw-dot l yp) - (draw-dot (/ (+ l r) 2) yp) - (draw-dot r yp) - - (send dc set-brush old-brush) - (send dc set-pen old-pen)))))) - - (define-values (arrow b-arrow g-arrow bg-arrow checked-arrow blank-arrow) - (let* ([arrow/letter-space 1] - [arrow-height 6] - [get-w/h/d/s/l/r - (lambda (descender?) - (lambda (dc) - (let*-values ([(width height descent space) (send dc get-text-extent "bg")] - [(cap-size) (- height space descent)] - [(text-height) (- height (if descender? 0 descent))] - [(arrow-space) (- (+ text-height arrow/letter-space) - (- (/ cap-size 2) (/ arrow-height 2)))] - [(total-arrow-height) (+ cap-size arrow-space)]) - (values (* width 2) - total-arrow-height - 0 - arrow-space - 0 - 0))))] - [draw-arrow - (lambda (dc x y descender?) - (let*-values ([(w h d s _1 _2) ((get-w/h/d/s/l/r descender?) dc)] - [(bgw bgh bgd bgs) (send dc get-text-extent "bg")] - [(text-height) (- bgh (if descender? 0 bgd))] - [(cap-size) (- h d s)]) - - ;(send dc draw-rectangle x y w h) - ;(send dc draw-rectangle x (+ y s) w (- h d s)) - - (let* ([x1 (+ x w)] - [y1 (+ y (- h (/ cap-size 2)))] - [x2 (- x1 4)] - [y2 (- y1 3)] - [x3 x2] - [y3 (+ y1 3)] - [old-pen (send dc get-pen)]) - - (when (is-a? dc post-script-dc%) - (send dc set-pen (send the-pen-list find-or-create-pen "BLACK" 1 'solid))) - - (send dc draw-line x2 y1 x y1) - - (send dc draw-line x1 y1 x2 y2) - (send dc draw-line x2 y2 x3 y3) - (send dc draw-line x3 y3 x1 y1) - - (send dc set-pen old-pen))))] - - [draw-text - (lambda (dc x y text descender? set-font?) - (let-values ([(w h d s _1 _2) ((get-w/h/d/s/l/r descender?) dc)] - [(bw bh bd bs) (send dc get-text-extent text)] - [(old-font) (send dc get-font)]) - (when set-font? - (send dc set-font (send the-font-list find-or-create-font (typeset-size) - 'roman 'normal 'normal #f))) - (send dc draw-text text (floor (+ x (- (/ w 2) (/ bw 2)))) y) - (send dc set-font old-font)))] - - [arrow - (drawing "robby:arrow" - (get-w/h/d/s/l/r #t) - (lambda (dc x y) (draw-arrow dc x y #t)))] - [b-arrow - (drawing "robby:b-arrow" - (get-w/h/d/s/l/r #f) - (lambda (dc x y) - (draw-text dc x y "b" #f #t) - (draw-arrow dc x y #f)))] - [g-arrow - (drawing "robby:g-arrow" - (get-w/h/d/s/l/r #t) - (lambda (dc x y) - (draw-text dc x y "g" #t #t) - (draw-arrow dc x y #t)))] - [bg-arrow - (drawing "robby:bg-arrow" - (get-w/h/d/s/l/r #t) - (lambda (dc x y) - (draw-text dc x y "bg" #t #t) - (draw-arrow dc x y #t)))] - [checked-arrow - (drawing "robby:checked-arrow" - (get-w/h/d/s/l/r #f) - (lambda (dc x y) - (let ([old-font (send dc get-font)]) - (send dc set-font (send the-font-list - find-or-create-font - (typeset-size) - 'symbol - (send old-font get-style) - (send old-font get-weight) - (send old-font get-underlined))) - (draw-text dc x y (string (integer->char 214)) #f #f) - (send dc set-font old-font) - (draw-arrow dc x y #f))))] - [blank-arrow - (drawing "robby:blank-arrow" - (get-w/h/d/s/l/r #f) - (lambda (dc x y) - (void)))]) - (values arrow b-arrow g-arrow bg-arrow checked-arrow blank-arrow))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; -;;; SUB/SUPERSCRIPT ;;; -;;; ;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (define-struct size (width height descent space left right)) - (define-struct pos (x y)) - - (define position-admin% - (class/d snip-admin% (position-snip calc-positions snips) - ((public get-sizes get-poss) - (override get-dc get-editor - get-view get-view-size - needs-update - recounted release-snip - resized - scroll-to - set-caret-owner - update-cursor)) - - (define sizes (map (lambda (snip) (make-size 0 0 0 0 0 0)) snips)) - (define poss (map (lambda (snip) (make-pos 0 0)) snips)) - - (define (get-sizes) - (update-sizes/poss) - sizes) - - (define (get-poss) - (update-sizes/poss) - poss) - - (define (update-sizes/poss) - (with-editor - (lambda (editor) - (let ([dc (send editor get-dc)]) - (when dc - (set! sizes - (map - (lambda (snip) - (let ([bwb (box 0)] - [bhb (box 0)] - [bdb (box 0)] - [bsb (box 0)] - [blb (box 0)] - [brb (box 0)] - [xb (box 0)] - [yb (box 0)]) - ;(send editor get-snip-location position-snip xb yb) - (send snip get-extent dc (unbox xb) (unbox yb) bwb bhb bdb bsb blb brb) - (make-size (unbox bwb) - (unbox bhb) - (unbox bdb) - (unbox bsb) - (unbox blb) - (unbox brb)))) - snips)) - (set! poss (calc-positions sizes))))))) - - (define (with-editor f) - (let ([admin (send position-snip get-admin)]) - (if admin - (let ([editor (send admin get-editor)]) - (if editor - (f editor) - #f)) - #f))) - (define (with-editor-admin f) - (with-editor - (lambda (editor) - (let ([admin (send editor get-admin)]) - (if admin - (f admin) - #f))))) - - (define (get-dc) - (with-editor (lambda (editor) (send editor get-dc)))) - (define (get-editor) (with-editor (lambda (x) x))) - (define (get-view xb yb wb hb wanted-snip) - (for-each (lambda (b) (set-box/f! b 10)) (list xb yb wb hb)) - (with-editor - (lambda (editor) - (if wanted-snip - (begin - (update-sizes/poss) - (let loop ([snips snips] - [sizes sizes] - [poss poss]) - (cond - [(null? snips) (void)] - [else - (let ([snip (car snips)] - [size (car sizes)] - [pos (car poss)]) - (if (eq? wanted-snip snip) - (begin - (set-box/f! xb (pos-x pos)) - (set-box/f! yb (pos-y pos)) - (set-box/f! wb (size-width size)) - (set-box/f! hb (size-height size))) - (loop (cdr snips) - (cdr sizes) - (cdr poss))))]))) - (send editor get-view xb yb wb hb wanted-snip)))) - (void)) - - (define (get-view-size wb hb) - (set-box/f! wb 10) - (set-box/f! hb 10) - (with-editor - (lambda (editor) - (send editor get-view #f #f wb hb position-snip)))) - - (define (needs-update wanted-snip localx localy w h) - (with-editor-admin - (lambda (admin) - (update-sizes/poss) - (let-values ([(thisx thisy) - (let loop ([snips snips] - [poss poss]) - (cond - [(null? snips) (values 0 0)] - [else (let ([snip (car snips)] - [pos (car poss)]) - (if (eq? wanted-snip snip) - (values (pos-x pos) - (pos-y pos)) - (loop (cdr snips) - (cdr poss))))]))]) - (send admin needs-update position-snip thisx thisy w h))))) - - (define (refresh-snip wanted-snip) - (with-editor - (lambda (editor) - (let ([dc (send editor get-dc)]) - (when dc - (update-sizes/poss) - (let loop ([snips snips] - [sizes sizes]) - (cond - [(null? snips) (void)] - [else - (let ([snip (car snips)] - [size (car sizes)]) - (if (eq? snip wanted-snip) - (needs-update snip 0 0 (size-width size) (size-height size)) - (loop (cdr snips))))]))))))) - - (define (recounted snip update-now?) - (when update-now? - (refresh-snip snip))) - - (define (release-snip snip) #f) - - (define (resized snip refresh?) - (update-sizes/poss) - (when refresh? - (refresh-snip snip))) - - (define (scroll-to wanted-snip localx localy w h refresh? bias) - (with-editor-admin - (lambda (admin) - (let-values ([(thisx thisy) - (let loop ([snips snips] - [poss poss]) - (cond - [(null? snips) (values 0 0)] - [else (let ([snip (car snips)] - [pos (car poss)]) - (if (eq? wanted-snip snip) - (values (pos-x pos) - (pos-y pos)) - (loop (cdr snips) - (cdr poss))))]))]) - (send admin scroll-to thisx thisy w h refresh? bias))))) - - (define (set-caret-owner snip domain) - (void)) - - (define (update-cursor) - (with-editor-admin - (lambda (admin) - (send admin update-cursor)))) - - (super-init) - (for-each (lambda (snip) (send snip set-admin this)) snips))) - - (define position-snip% - (class/d snip% (position-snipclass calc-positions calc-size _snips) - ((inherit set-snipclass get-style) - (override get-extent draw copy write)) - - (define snips (map (lambda (snip) (send snip copy)) _snips)) - - (define (write p) - (send p << (length snips)) - (for-each (lambda (snip) - (send p << (send (send snip get-snipclass) get-classname)) - (send snip write p)) - snips)) - - (define (copy) - (let ([snip (make-object position-snip% - position-snipclass - calc-positions - calc-size - snips)]) - (send snip set-style (get-style)) - snip)) - - (define (get-extent dc x y wb hb db sb lb rb) - (let ([sizes (send admin get-sizes)]) - (let ([size (calc-size sizes)]) - (set-box/f! wb (size-width size)) - (set-box/f! hb (size-height size)) - (set-box/f! db (size-descent size)) - (set-box/f! sb (size-space size)) - (set-box/f! lb (size-left size)) - (set-box/f! rb (size-right size))))) - - (define (draw dc x y left top right bottom dx dy draw-caret) - (let ([positions (calc-positions (send admin get-sizes))]) - (for-each - (lambda (snip pos) - (send snip draw dc - (+ x (pos-x pos)) - (+ y (pos-y pos)) - left top right bottom dx dy draw-caret)) - snips - positions))) - - (super-init) - - (define admin (make-object position-admin% this calc-positions snips)) - (set-snipclass position-snipclass))) - - (define position-snipclass% - (class/d snip-class% (calc-positions calc-size) - ((override read)) - - (define (read f) - (define (get-next) - (let* ([classname (send f get-string)] - [snipclass (send (get-the-snip-class-list) find classname)]) - (send snipclass read f))) - - (make-object position-snip% - this - calc-positions - calc-size - (let loop ([n (send f get-exact)]) - (cond - [(<= n 0) null] - [else (cons (get-next) (loop (- n 1)))])))) - - (super-init))) - - (define (position calc-positions calc-size name) - (define position-snipclass (make-object position-snipclass% calc-positions calc-size)) - (send position-snipclass set-classname name) - (send position-snipclass set-version 1) - (send (get-the-snip-class-list) add position-snipclass) - - (lambda (snips) - (make-object position-snip% position-snipclass calc-positions calc-size snips))) - - (define sup - (let ([make-sup - (position - (lambda (sizes) - (let ([base (car sizes)] - [pow (cadr sizes)]) - (list (make-pos - 0 - (- (max (/ (size-height pow) 2) (size-space base)) - (size-space base))) - (make-pos - (size-width base) - (max 0 (- (size-space base) (/ (size-height pow) 2))))))) - (lambda (sizes) - (let ([base (car sizes)] - [pow (cadr sizes)]) - (make-size - (+ (size-width base) (size-width pow)) - (+ (- (size-height base) (size-space base)) (max (size-space base) (floor (/ (size-height pow) 2)))) - (size-descent base) - (max (size-space base) (floor (/ (size-height pow) 2))) - (size-left base) - (size-right pow)))) - "robby:sup")]) - (lambda (base pow) - (make-sup - (list (snipize/copy base) - (snipize/copy pow)))))) - - (define sub - (let ([make-sub - (position - (lambda (sizes) - (let ([base (car sizes)] - [sub (cadr sizes)]) - (list (make-pos 0 0) - (make-pos - (size-width base) - (- (size-height base) - (size-descent base) - (floor (/ (size-height sub) 2))))))) - (lambda (sizes) - (let ([base (car sizes)] - [sub (cadr sizes)]) - (make-size - (+ (size-width base) (size-width sub)) - (+ (- (size-height base) (size-descent base)) (max (size-descent base) (floor (/ (size-height sub) 2)))) - (max (size-descent base) (floor (/ (size-height sub) 2))) - (size-space base) - (size-left base) - (size-right sub)))) - "robby:sub")]) - (lambda (base sub) - (make-sub - (list (snipize/copy base) - (snipize/copy sub)))))) - - (unit/sig typeset:utils^ - (import) - (rename (-single-bracket single-bracket) - (-double-bracket double-bracket) - (-tb-align tb-align) - (-greek greek) - (-drawing drawing) - (-ellipses ellipses) - - (-position position) - (-sup sup) (-sub sub) - - (-postscript postscript) - - (-arrow arrow) (-b-arrow b-arrow) - (-g-arrow g-arrow) (-bg-arrow bg-arrow) - (-checked-arrow checked-arrow) - (-blank-arrow blank-arrow) - (-typeset-size typeset-size)) - - (define -single-bracket single-bracket) - (define -double-bracket double-bracket) - (define -tb-align tb-align) - (define -greek greek) - (define -drawing drawing) - (define -ellipses ellipses) - - (define -position position) - (define -sup sup) - (define -sub sub) - - (define -postscript postscript) - - (define -arrow arrow) - (define -b-arrow b-arrow) - (define -g-arrow g-arrow) - (define -bg-arrow bg-arrow) - (define -checked-arrow checked-arrow) - (define -blank-arrow blank-arrow) - - (define -typeset-size typeset-size))) \ No newline at end of file diff --git a/collects/userspce/advancedr.ss b/collects/userspce/advancedr.ss deleted file mode 100644 index 0aa5dc6d..00000000 --- a/collects/userspce/advancedr.ss +++ /dev/null @@ -1,13 +0,0 @@ -(compound-unit/sig - (import) - (link [core : mzlib:core-flat^ ((require-library "coreflatr.ss"))] - [turtles : turtle^ ((require-library "turtler.ss" "graphics") - (core : mzlib:function^))] - [posn : ((struct posn (x y))) - ((unit/sig ((struct posn (x y))) - (import) - (define-struct posn (x y))))]) - (export - (open core) - (open turtles) - (open posn))) diff --git a/collects/userspce/basis.ss b/collects/userspce/basis.ss deleted file mode 100644 index 30868e6b..00000000 --- a/collects/userspce/basis.ss +++ /dev/null @@ -1,28 +0,0 @@ -(compound-unit/sig - (import [import : plt:basis-import^] - [params : plt:userspace:params^] - [zodiac : zodiac:system^] - [zodiac:interface : drscheme:interface^] - [aries : plt:aries^] - [mzlib:print-convert : mzlib:print-convert^] - [mzlib:pretty-print : mzlib:pretty-print^] - [mzlib:function : mzlib:function^]) - (link - [init-params : plt:init-params^ ((require-relative-library "init-paramr.ss") - import - init-namespace - params - zodiac - zodiac:interface - aries - mzlib:print-convert - mzlib:pretty-print - mzlib:function)] - [init-namespace : plt:init-namespace^ ((require-relative-library "init-namespacer.ss") - import - init-params - mzlib:function)]) - (export - (open init-params) - (open init-namespace))) - diff --git a/collects/userspce/doc.txt b/collects/userspce/doc.txt deleted file mode 100644 index e32b4c91..00000000 --- a/collects/userspce/doc.txt +++ /dev/null @@ -1,31 +0,0 @@ -_Userspace_ libraries implement the common functionality -between DrScheme and DrScheme Jr. - -The libraries _beginner.ss_, _intermediate.ss_, and _advanced.ss_ -implement the additional function definitions that appear in the -initial namespace in the respective language levels. The other -language levels do not have any additional function definitions beyond -what is in the namespace automatically. - -- beginner.ss adds: - - mzlib's core libraries - - simple-draw.ss - - posn struture, without mutators - -- intermediate.ss adds exactly what beginner.ss does - -- advanced.ss adds: - - mzlib's core libraries - - the turtles, from turtle.ss in the graphics library, but only if - the namespace already contains mred@ - - posn struture, including mutators - -Each of the beginner.ss, intermediate.ss, and advanced.ss and -libraries returns a procedure that installs the corresponding bindings -into the current namespace. - -The file _advancedr.ss_ contains a unit that exports all of the defintions -in advanced.ss. - -The _simple-draw.ss_ library implements a simple drawing -library on top of sixlib. It uses _error.ss_. diff --git a/collects/userspce/errorr.ss b/collects/userspce/errorr.ss deleted file mode 100644 index fad49200..00000000 --- a/collects/userspce/errorr.ss +++ /dev/null @@ -1,22 +0,0 @@ -(unit/sig userspace:error^ - (import) - - ;; check-arg : sym bool str str TST -> void - (define (check-arg pname condition expected arg-posn given) - (unless condition - (error pname "expected <~a> as ~a argument, given: ~e" expected arg-posn given))) - - ;; check-arity : sym num (list-of TST) -> void - (define (check-arity name arg# args) - (if (>= (length args) arg#) - (void) - (error name "expects at least ~a arguments, given ~e" arg# (length args)))) - - ;; check-proc : sym (... *->* ...) num (union sym str) (union sym str) -> void - (define (check-proc proc f exp-arity arg# arg-err) - (unless (procedure? f) - (error proc "procedure expected as ~s argument; given ~e" arg# f)) - (unless (and (number? (arity f)) (= (arity f) exp-arity)) - (error proc - "procedure of ~a expected as ~s argument; given procedure of ~s args" - arg-err arg# (arity f))))) \ No newline at end of file diff --git a/collects/userspce/errors.ss b/collects/userspce/errors.ss deleted file mode 100644 index b177aac5..00000000 --- a/collects/userspce/errors.ss +++ /dev/null @@ -1 +0,0 @@ -(define-signature userspace:error^ (check-arg check-arity check-proc)) diff --git a/collects/userspce/info.ss b/collects/userspce/info.ss deleted file mode 100644 index e1af7e8a..00000000 --- a/collects/userspce/info.ss +++ /dev/null @@ -1,22 +0,0 @@ -(let ([userspace-info - (lambda (what failure) - (case what - [(name) "Userspace"] - [(compile-prefix) - '(begin - (require-library "refer.ss") - (require-library "coreflats.ss") - (when (with-handlers ([void (lambda (x) #f)]) - (collection-path "mred")) - (require-library "turtles.ss" "graphics") - (require-library "sig.ss" "mred")) - (require-library "errors.ss" "userspce") - (require-library "params.ss" "userspce") - (require-library "sig.ss" "userspce"))] - [(compile-omit-files) (list "sig.ss" "errors.ss" "params.ss" "ricedefs.ss" - "launcher-bootstrap.ss" - "launcher-bootstrap-mred.ss" - "launcher-bootstrap-mzscheme.ss")] - [(compile-elaboration-zos) (list "sig.ss")] - [else (failure)]))]) - userspace-info) diff --git a/collects/userspce/init-namespacer.ss b/collects/userspce/init-namespacer.ss deleted file mode 100644 index fe2b49c4..00000000 --- a/collects/userspce/init-namespacer.ss +++ /dev/null @@ -1,156 +0,0 @@ -(unit/sig plt:init-namespace^ - (import plt:basis-import^ - [init-params : plt:init-params^] - mzlib:function^) - - (define (exploded->flattened exploded) - (let ([sig exploded]) - (let loop ([l (vector->list sig)][r null]) - (cond - [(null? l) r] - [(symbol? (car l)) (loop (cdr l) (cons (car l) r))] - [else (let ([sub (loop (vector->list (cadr l)) null)] - [prefix (string-append (symbol->string (car l)) ":")]) - (loop (cdr l) - (append - (map (lambda (s) - (string->symbol - (string-append - prefix - (symbol->string s)))) - sub))))])))) - - (define (build-gdvs exploded) - (let ([flattened (exploded->flattened exploded)]) - (map - (lambda (x) - `(global-defined-value ',x ,x)) - flattened))) - - (define core-flat@ (require-library-unit/sig "coreflatr.ss")) - - ;; build-single-teachpack-unit : string -> (union #f (unit () X)) - (define (build-single-teachpack-unit v) - (with-handlers - ([(lambda (x) #t) - (lambda (x) - (invalid-teachpack (exn-message x)) - #f)]) - (let ([new-unit (parameterize ([read-case-sensitive #t]) - (load/cd v))]) - (if (unit/sig? new-unit) - ; Put the unit into a procedure that invokes it into - ; the current namespace - (let* ([signature - (exploded->flattened (unit-with-signature-exports new-unit))]) - (eval - `(unit/sig () - (import plt:userspace^) - (with-handlers ([(lambda (x) #t) - (lambda (x) - ((error-display-handler) - (format - "Invalid Teachpack: ~a~n~a" - ,v - (if (exn? x) - (exn-message x) - x))))]) - (global-define-values/invoke-unit/sig - ,signature - ,new-unit - #f - plt:userspace^))))) - (begin - (invalid-teachpack - (format "loading Teachpack file does not result in a unit/sig, got: ~e" - new-unit)) - #f))))) - - ;; build-namespace-thunk : (listof string) -> (union #f (list (union 'mz 'mr) (-> void))) - ;; accepts a filename and returns a thunk that invokes the corresponding teachpack and - ;; a symbol indicating if this is a mzscheme teachpack or a mred teachpack. - (define (build-namespace-thunk v) - (unless (and (list? v) - (andmap string? v)) - (error 'build-teachpack-thunk "expected a list of strings, got: ~e" v)) - (let* ([tagn 0] - [link-clauses - (let loop ([units v] - [link-clauses null]) - (cond - [(null? units) (reverse link-clauses)] - [else - (let ([unit (build-single-teachpack-unit (car units))]) - (if unit - (begin - (set! tagn (+ tagn 1)) - (loop (cdr units) - (cons - `[,(string->symbol (format "teachpack~a" tagn)) : () - (,unit userspace)] - link-clauses))) - (loop (cdr units) - link-clauses)))]))] - [cu - (eval - `(compound-unit/sig - (import) - (link - ,@(list* - `[userspace - : plt:userspace^ - (,(if (defined? 'mred@) - `(compound-unit/sig - (import) - (link [core : mzlib:core-flat^ (,core-flat@)] - [mred : mred^ (,(global-defined-value 'mred@))] - [turtles : turtle^ ((require-library "turtler.ss" "graphics") - (core : mzlib:function^))] - [posn : ((struct posn (x y))) - ((unit/sig ((struct posn (x y))) - (import) - (define-struct posn (x y))))]) - (export (open core) - (open mred) - (open posn) - (open turtles))) - `(compound-unit/sig - (import) - (link [core : mzlib:core-flat^ (,core-flat@)] - [posn : ((struct posn (x y))) - ((unit/sig ((struct posn (x y))) - (import) - (define-struct posn (x y))))]) - (export (open core) - (open posn)))))] - `[language-specific-additions - : () - ((unit/sig () - (import plt:userspace^) - - (cond - [(,init-params:beginner-language? (,init-params:current-setting)) - ,@(build-gdvs (signature->symbols plt:beginner-extras^))] - [(,init-params:intermediate-language? (,init-params:current-setting)) - ,@(build-gdvs (signature->symbols plt:intermediate-extras^))] - [(,init-params:advanced-language? (,init-params:current-setting)) - ,@(build-gdvs (signature->symbols plt:advanced-extras^))] - [(,init-params:full-language? (,init-params:current-setting)) (void)])) - userspace)] - - link-clauses)) - (export)))]) - (lambda () - (invoke-unit/sig - cu)))) - - (define (teachpack-ok? x) - (if (build-single-teachpack-unit x) - #t - #f)) - - (define namespace-thunk (build-namespace-thunk null)) - (define init-namespace (lambda () (namespace-thunk))) - - (define (teachpack-changed v) - (set! namespace-thunk (build-namespace-thunk v)))) diff --git a/collects/userspce/init-paramr.ss b/collects/userspce/init-paramr.ss deleted file mode 100644 index 980b076f..00000000 --- a/collects/userspce/init-paramr.ss +++ /dev/null @@ -1,732 +0,0 @@ -(unit/sig plt:init-params^ - (import [import : plt:basis-import^] - [init-namespace : plt:init-namespace^] - [params : plt:userspace:params^] - [zodiac : zodiac:system^] - [zodiac:interface : drscheme:interface^] - [aries : plt:aries^] - [mzlib:print-convert : mzlib:print-convert^] - [mzlib:pretty-print : mzlib:pretty-print^] - [mzlib:function : mzlib:function^]) - - (define initial-line 1) - (define initial-column 1) - (define initial-offset 0) - - (define original-output-port (current-output-port)) - (define (printf . args) - (apply fprintf original-output-port args)) - - (define (report-error . x) (error 'report-error)) - (define (report-unlocated-error . x) (error 'report-unlocated-error)) - - (define primitive-load (current-load)) - (define primitive-eval (current-eval)) - - (define r4rs-style-printing (make-parameter #f)) - - (define this-program (with-handlers ([void (lambda (x) "mzscheme")]) - (global-defined-value 'program))) - - (define-struct/parse setting (key - name - vocabulary-symbol - macro-libraries - case-sensitive? - allow-set!-on-undefined? - unmatched-cond/case-is-error? - allow-improper-lists? - allow-reader-quasiquote? - sharing-printing? - abbreviate-cons-as-list? - signal-undefined - signal-not-boolean - eq?-only-compares-symbols? - <=-at-least-two-args - error-sym/string-only - disallow-untagged-inexact-numbers - print-tagged-inexact-numbers - whole/fractional-exact-numbers - print-booleans-as-true/false - printing - print-exact-as-decimal? - read-decimal-as-exact? - define-argv? - use-pretty-printer?)) - - ;; settings : (list-of setting) - (define settings - (list (make-setting/parse - `((key beginner) - (name "Beginning Student") - (macro-libraries ()) - (vocabulary-symbol beginner) - (case-sensitive? #t) - (allow-set!-on-undefined? #f) - (unmatched-cond/case-is-error? #t) - (allow-improper-lists? #f) - (allow-reader-quasiquote? #f) - (sharing-printing? #f) - (abbreviate-cons-as-list? #f) - (signal-undefined #t) - (signal-not-boolean #t) - (eq?-only-compares-symbols? #t) - (<=-at-least-two-args #t) - (error-sym/string-only #t) - (disallow-untagged-inexact-numbers #f) - (print-tagged-inexact-numbers #t) - (whole/fractional-exact-numbers #f) - (print-booleans-as-true/false #t) - (printing constructor-style) - (print-exact-as-decimal? #t) - (read-decimal-as-exact? #t) - (define-argv? #f) - (use-pretty-printer? #t))) - (make-setting/parse - `((key intermediate) - (name "Intermediate Student") - (macro-libraries ()) - (vocabulary-symbol intermediate) - (case-sensitive? #t) - (allow-set!-on-undefined? #f) - (unmatched-cond/case-is-error? #t) - (allow-improper-lists? #f) - (allow-reader-quasiquote? #t) - (sharing-printing? #f) - (abbreviate-cons-as-list? #t) - (signal-undefined #t) - (signal-not-boolean #t) - (eq?-only-compares-symbols? #t) - (<=-at-least-two-args #t) - (error-sym/string-only #t) - (disallow-untagged-inexact-numbers #f) - (print-tagged-inexact-numbers #t) - (whole/fractional-exact-numbers #f) - (print-booleans-as-true/false #t) - (printing constructor-style) - (print-exact-as-decimal? #t) - (read-decimal-as-exact? #t) - (define-argv? #f) - (use-pretty-printer? #t))) - (make-setting/parse - `((key advanced) - (name "Advanced Student") - (macro-libraries ()) - (vocabulary-symbol advanced) - (case-sensitive? #t) - (allow-set!-on-undefined? #f) - (unmatched-cond/case-is-error? #t) - (allow-improper-lists? #f) - (allow-reader-quasiquote? #t) - (sharing-printing? #t) - (abbreviate-cons-as-list? #t) - (signal-undefined #t) - (signal-not-boolean #f) - (eq?-only-compares-symbols? #f) - (<=-at-least-two-args #t) - (error-sym/string-only #t) - (disallow-untagged-inexact-numbers #f) - (print-tagged-inexact-numbers #t) - (whole/fractional-exact-numbers #f) - (print-booleans-as-true/false #t) - (printing constructor-style) - (print-exact-as-decimal? #t) - (read-decimal-as-exact? #t) - (define-argv? #f) - (use-pretty-printer? #t))) - (make-setting/parse - `((key full) - (name "Textual Full Scheme (MzScheme)") - (vocabulary-symbol mzscheme-debug) - (macro-libraries ()) - (case-sensitive? #f) - (allow-set!-on-undefined? #f) - (unmatched-cond/case-is-error? #f) - (allow-improper-lists? #t) - (allow-reader-quasiquote? #t) - (sharing-printing? #f) - (abbreviate-cons-as-list? #t) - (signal-undefined #f) - (signal-not-boolean #f) - (eq?-only-compares-symbols? #f) - (<=-at-least-two-args #f) - (error-sym/string-only #f) - (disallow-untagged-inexact-numbers #f) - (print-tagged-inexact-numbers #f) - (whole/fractional-exact-numbers #f) - (print-booleans-as-true/false #f) - (printing r4rs-style) - (print-exact-as-decimal? #f) - (read-decimal-as-exact? #f) - (define-argv? #t) - (use-pretty-printer? #t))) - (make-setting/parse - `((key full) - (name "Textual Full Scheme without Debugging (MzScheme)") - (macro-libraries ()) - (vocabulary-symbol mzscheme) - (case-sensitive? #f) - (allow-set!-on-undefined? #f) - (unmatched-cond/case-is-error? #f) - (allow-improper-lists? #t) - (allow-reader-quasiquote? #t) - (sharing-printing? #f) - (abbreviate-cons-as-list? #t) - (signal-undefined #f) - (signal-not-boolean #f) - (eq?-only-compares-symbols? #f) - (<=-at-least-two-args #f) - (error-sym/string-only #f) - (disallow-untagged-inexact-numbers #f) - (print-tagged-inexact-numbers #f) - (whole/fractional-exact-numbers #f) - (print-booleans-as-true/false #f) - (printing r4rs-style) - (print-exact-as-decimal? #f) - (read-decimal-as-exact? #f) - (define-argv? #t) - (use-pretty-printer? #t))))) - - (define (snoc x y) (append y (list x))) - - ;; add-setting : (symbol setting -> void) - (define add-setting - (case-lambda - [(setting) (add-setting setting (length settings))] - [(setting number) - (set! settings - (let loop ([number number] - [settings settings]) - (cond - [(or (zero? number) (null? settings)) - (cons setting settings)] - [else - (cons - (car settings) - (loop (- number 1) - (cdr settings)))])))])) - - ;; find-setting-named : string -> setting - ;; effect: raises an exception if no setting named by the string exists - (define (find-setting-named name) - (unless (string? name) - (error 'find-setting-named "expected string, got ~e" name)) - (let loop ([settings settings]) - (cond - [(null? settings) (error 'find-setting-named "no setting named ~e" name)] - [else (let* ([setting (car settings)]) - (if (string=? name (setting-name setting)) - setting - (loop (cdr settings))))]))) - - - ;; copy-setting : setting -> setting - (define copy-setting - (lambda (x) - (unless (setting? x) - (error 'copy-setting "expected a setting, got ~e" x)) - (apply make-setting (cdr (vector->list (struct->vector x)))))) - - ;; get-default-setting : (-> setting) - (define (get-default-setting) (copy-setting (car settings))) - - ;; get-default-setting-name : (-> symbol) - (define (get-default-setting-name) (setting-name (get-default-setting))) - - ;; setting-name->number : string -> int - (define setting-name->number - (lambda (name) - (let loop ([n 0] - [settings settings]) - (cond - [(null? settings) (error 'level->number "unexpected level: ~a" name)] - [else (let ([setting (car settings)]) - (if (string=? name (setting-name setting)) - n - (loop (+ n 1) - (cdr settings))))])))) - - ;; number->setting : (int -> symbol) - (define number->setting (lambda (n) (list-ref settings n))) - - ;; zodiac-vocabulary? : setting -> boolean - (define (zodiac-vocabulary? setting) - (not (or (eq? (setting-vocabulary-symbol setting) 'mzscheme) - (eq? (setting-vocabulary-symbol setting) 'mred)))) - - ;; X-language : setting -> boolean - ;; returns true if the input language is the specified language - (define (beginner-language? setting) (eq? (setting-key setting) 'beginner)) - (define (intermediate-language? setting) (eq? (setting-key setting) 'intermediate)) - (define (advanced-language? setting) (eq? (setting-key setting) 'advanced)) - (define (full-language? setting) (eq? (setting-key setting) 'full)) - - ;; r4rs-style-printing? : setting -> boolean - (define (r4rs-style-printing? setting) - (eq? 'r4rs-style (setting-printing setting))) - - ;; current-setting : (parameter (+ #f setting)) - (define current-setting - (make-parameter - #f - (lambda (x) - (if (or (not x) - (setting? x)) - x - (error 'current-setting - "must be a setting or #f"))))) - - ;; current-vocabulary : (parameter (+ #f zodiac:vocabulary)) - (define current-vocabulary (make-parameter #f)) - - ;; current-zodiac-namespace : (parameter (+ #f namespace)) - ;; If another namespace is installed, drscheme-eval uses primitive-eval - (define current-zodiac-namespace (make-parameter #f)) - - ;; syntax-checking-primitive-eval : sexp -> value - ;; effect: raises user-exn if expression ill-formed - (define (syntax-checking-primitive-eval expr) - (primitive-eval - (with-handlers ([(lambda (x) #t) - (lambda (x) - (error 'internal-syntax-error - (format "~a" (exn-message x))))]) - (expand-defmacro expr)))) - - (define-struct process-finish (error?)) - - ;; process-file/zodiac : string - ;; (((+ process-finish sexp zodiac:parsed) ( -> void) -> void) - ;; boolean - ;; -> void - ;; note: the boolean controls which variant of the union is passed to the 3rd arg. - ;; expects to be called with user's parameter settings active - (define (process-file/zodiac filename f annotate?) - (let ([port (open-input-file filename 'text)] - [setting (current-setting)]) - (dynamic-wind - void - (lambda () - (process/zodiac - (zodiac:read port - (zodiac:make-location initial-line - initial-column - initial-offset - (path->complete-path filename)) - #t 1) - f - annotate?)) - (lambda () (close-input-port port))))) - - ;; process-file/no-zodiac : string - ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) - ;; -> void - ;; expects to be called with user's parameter settings active - (define (process-file/no-zodiac filename f) - (call-with-input-file filename - (lambda (port) - (process/no-zodiac (lambda () (read port)) f)))) - - ;; process-sexp/no-zodiac : sexp - ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) - ;; -> void - ;; expects to be called with user's parameter settings active - (define (process-sexp/no-zodiac sexp f) - (process/no-zodiac (let ([first? #t]) - (lambda () - (if first? - (begin (set! first? #f) - sexp) - eof))) - f)) - - ;; process-sexp/zodiac : sexp - ;; zodiac:sexp - ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) - ;; boolean - ;; -> void - ;; note: the boolean controls which variant of the union is passed to the 2nd arg. - ;; expects to be called with user's parameter settings active - (define (process-sexp/zodiac sexp z f annotate?) - (let* ([reader - (let ([gone #f]) - (lambda () - (or gone - (begin (set! gone (zodiac:make-eof z)) - (zodiac:structurize-syntax sexp z)))))]) - (process/zodiac reader f annotate?))) - - ;; process/zodiac : ( -> zodiac:sexp) - ;; ((+ process-finish sexp zodiac:parsed) ( -> void) -> void) - ;; boolean - ;; -> void - ;; expects to be called with user's parameter settings active - (define (process/zodiac reader f annotate?) - (let ([setting (current-setting)] - [vocab (current-vocabulary)] - [cleanup - (lambda (error?) - (f (make-process-finish error?) void))]) - (let loop () - (let ([next-iteration - (let/ec k - (let ([annotate - (lambda (term read-expr) - (dynamic-wind - (lambda () (zodiac:interface:set-zodiac-phase 'expander)) - (lambda () (aries:annotate term read-expr)) - (lambda () (zodiac:interface:set-zodiac-phase #f))))] - ; Always read with zodiac - [zodiac-read - (dynamic-wind - (lambda () (zodiac:interface:set-zodiac-phase 'reader)) - (lambda () (reader)) - (lambda () (zodiac:interface:set-zodiac-phase #f)))] - ; Sometimes, we throw away source information and - ; expand with MzScheme - [use-z-exp? (and (zodiac-vocabulary? (current-setting)) - (eq? (current-namespace) (current-zodiac-namespace)))]) - (if (zodiac:eof? zodiac-read) - (lambda () (cleanup #f)) - (let* ([evaluator - (lambda (exp _ macro) - (primitive-eval (annotate exp #f)))] - [user-macro-body-evaluator - (lambda (x . args) - (primitive-eval `(,x ,@(map (lambda (x) `(#%quote ,x)) args))))] - [exp - (if use-z-exp? - (dynamic-wind - (lambda () (zodiac:interface:set-zodiac-phase 'expander)) - (lambda () (parameterize ([zodiac:user-macro-body-evaluator user-macro-body-evaluator] - [zodiac:elaboration-evaluator evaluator]) - (zodiac:scheme-expand - zodiac-read - 'previous - vocab))) - (lambda () (zodiac:interface:set-zodiac-phase #f))) - - ;; call expand-defmacro here so errors - ;; are raised at the right time. - (expand-defmacro (zodiac:sexp->raw zodiac-read)))] - [heading-out (if (and annotate? use-z-exp?) - (annotate exp zodiac-read) - exp)]) - (lambda () (f heading-out loop))))))]) - (next-iteration))))) - - ;; process/no-zodiac : ( -> sexp) ((+ sexp process-finish) ( -> void) -> void) -> void - (define (process/no-zodiac reader f) - (let loop () - (let ([expr (reader)]) - (if (eof-object? expr) - (f (make-process-finish #f) void) - (f expr loop))))) - - (define format-source-loc - (case-lambda - [(start-location end-location) - (format-source-loc start-location end-location #t)] - [(start-location end-location start-at-one?) - (format-source-loc start-location end-location start-at-one? #t)] - [(start-location end-location start-at-one? lines-and-columns?) - (let ([file (zodiac:location-file start-location)]) - (if lines-and-columns? - (let ([offset (if start-at-one? 0 -1)]) - (format "~a: ~a.~a-~a.~a: " - file - (+ offset (zodiac:location-line start-location)) - (+ offset (zodiac:location-column start-location)) - (+ offset (zodiac:location-line end-location)) - (+ offset 1 (zodiac:location-column end-location)))) - (let ([offset (if start-at-one? 1 0)]) - (format "~a: ~a-~a: " - file - (+ offset (zodiac:location-offset start-location)) - (+ 1 offset (zodiac:location-offset end-location))))))])) - - - ;; (parameter (string zodiac:zodiac exn -> void)) - (define error-display/debug-handler - (make-parameter - (lambda (msg debug exn) - ((error-display-handler) - (if (zodiac:zodiac? debug) - (string-append (format-source-loc (zodiac:zodiac-start debug) - (zodiac:zodiac-finish debug)) - msg) - msg))))) - - ;; bottom-escape-handler : (parameter ( -> A)) - ;; escapes - (define bottom-escape-handler (make-parameter void)) - - ;; drscheme-exception-handler : exn -> A - ;; effect: displays the exn-message and escapes - (define (drscheme-exception-handler exn) - (let ([dh (error-display/debug-handler)]) - (if (exn? exn) - (let* ([marks (exn-continuation-marks exn)] - [debug (if (continuation-mark-set? marks) - (aries:extract-zodiac-location marks) - #f)]) - (dh (format "~a" (exn-message exn)) debug exn)) - (dh (format "uncaught exception: ~e" exn) #f #f))) - ((error-escape-handler)) - ((error-display-handler) "Exception handler did not escape") - ((bottom-escape-handler))) - - ;; drscheme-error-value->string-handler : TST number -> string - (define (drscheme-error-value->string-handler x n) - (let ([port (open-output-string)]) - (parameterize ([current-output-port port] - [mzlib:pretty-print:pretty-print-columns 'infinity]) - (drscheme-print/void x)) - (let* ([long-string (get-output-string port)]) - (close-output-port port) - (if (<= (string-length long-string) n) - long-string - (let ([short-string (substring long-string 0 n)] - [trim 3]) - (unless (<= n trim) - (let loop ([i trim]) - (unless (<= i 0) - (string-set! short-string (- n i) #\.) - (loop (sub1 i))))) - short-string))))) - - ;; intermediate-values-during-load : (parameter (TST *-> void)) - ;; probably obsolete - (define intermediate-values-during-load (make-parameter (lambda x (void)))) - - ;; drscheme-load-handler : string ->* TST - (define (drscheme-load-handler filename) - (unless (string? filename) - (raise (make-exn:application:arity - (format "drscheme-load-handler: expects argument of type ; given: ~e" filename) - (current-continuation-marks) - filename - 'string))) - (let ([zo-file? - (let ([l (string-length filename)]) - (and (<= 3 l) - (string=? ".zo" (substring filename (- l 3) l))))]) - - (cond - [zo-file? - (parameterize ([current-eval primitive-eval]) - (primitive-load filename))] - [(zodiac-vocabulary? (current-setting)) - (let* ([process-sexps - (let ([last (list (void))]) - (lambda (sexp recur) - (cond - [(process-finish? sexp) - last] - [else - (set! last - (call-with-values - (lambda () (syntax-checking-primitive-eval sexp)) - (lambda x - (apply (intermediate-values-during-load) x) - x))) - (recur)])))]) - (apply values (process-file/zodiac filename process-sexps #t)))] - [else - (call-with-input-file filename - (lambda (port) - (let loop ([last-vals (list (void))]) - (let ([r (read port)]) - (if (eof-object? r) - (apply values last-vals) - (call-with-values - (lambda () (eval r)) - (lambda x - (apply (intermediate-values-during-load) x) - (loop x))))))))]))) - - ;; drscheme-eval : sexp ->* TST - (define (drscheme-eval-handler sexp) - (if (and (zodiac-vocabulary? (current-setting)) - (eq? (current-namespace) (current-zodiac-namespace))) - (let* ([z (let ([continuation-stack (continuation-mark-set->list - (current-continuation-marks) - aries:w-c-m-key)]) - (if (null? continuation-stack) - (let ([loc (zodiac:make-location - initial-line initial-column initial-offset - 'eval)]) - (zodiac:make-zodiac 'mzrice-eval loc loc)) - (car continuation-stack)))] - [answer (list (void))] - [f - (lambda (annotated recur) - (if (process-finish? annotated) - answer - (begin (set! answer - (call-with-values - (lambda () (syntax-checking-primitive-eval annotated)) - (lambda x x))) - (recur))))]) - (apply values (process-sexp/zodiac sexp z f #t))) - (primitive-eval sexp))) - - - ;; drscheme-print : TST -> void - ;; effect: prints the value, on the screen, attending to the values of the current setting - (define drscheme-print - (lambda (v) - (unless (void? v) - (drscheme-print/void v)))) - - ;; drscheme-print/void : TST -> void - ;; effect: prints the value, on the screen, attending to the values of the current setting - (define (drscheme-print/void v) - (let* ([setting (current-setting)] - [value (if (r4rs-style-printing? setting) - v - (mzlib:print-convert:print-convert v))]) - (if (setting-use-pretty-printer? setting) - (mzlib:pretty-print:pretty-print value) - (write value)))) - - ;; drscheme-port-print-handler : TST port -> void - ;; effect: prints the value on the port - (define (drscheme-port-print-handler value port) - (parameterize ([mzlib:pretty-print:pretty-print-columns 'infinity] - [current-output-port port]) - (drscheme-print/void value))) - - (define ricedefs@ (require-library "ricedefr.ss" "userspce")) - - - (define (teaching-level? setting) - (let* ([name (setting-name setting)] - [ans (or (equal? name "Beginning Student") - (equal? name "Intermediate Student") - (equal? name "Advanced Student"))]) - ans)) - - ;; initialize-parameters : custodian - ;; (list-of symbols) - ;; setting - ;; -> void - ;; effect: sets the parameters for drscheme and drscheme-jr - (define (initialize-parameters custodian setting) - (let*-values ([(namespace-flags) (let ([name (setting-name setting)]) - (if (regexp-match "MrEd" name) - (list 'mred) - (list)))] - [(n) (apply make-namespace - (if (zodiac-vocabulary? setting) - (append (list 'hash-percent-syntax) namespace-flags) - namespace-flags))]) - - (when (zodiac-vocabulary? setting) - (use-compiled-file-kinds 'non-elaboration)) - (current-setting setting) - (compile-allow-set!-undefined #f) - (compile-allow-cond-fallthrough #f) - (current-custodian custodian) - (error-value->string-handler drscheme-error-value->string-handler) - (current-exception-handler drscheme-exception-handler) - (initial-exception-handler drscheme-exception-handler) - (current-namespace n) - (current-zodiac-namespace n) - (break-enabled #t) - (read-curly-brace-as-paren #t) - (read-square-bracket-as-paren #t) - (print-struct (not (eq? 'r4rs-style (setting-printing setting)))) - (read-decimal-as-inexact (not (setting-read-decimal-as-exact? setting))) - - (init-namespace:init-namespace) - - (error-print-width 250) - (current-print drscheme-print) - - (current-load-relative-directory #f) - (current-require-relative-collection #f) - - (when (zodiac-vocabulary? setting) - (current-vocabulary - (zodiac:create-vocabulary - 'scheme-w/user-defined-macros/drscheme - (case (setting-vocabulary-symbol setting) - [(beginner) zodiac:beginner-vocabulary] - [(intermediate) zodiac:intermediate-vocabulary] - [(advanced) zodiac:advanced-vocabulary] - [(mzscheme-debug mred-debug) zodiac:scheme-vocabulary] - [else (error 'init "bad vocabulary spec: ~a ~e" - (setting-vocabulary-symbol setting) setting)]))) - (zodiac:reset-previous-attribute - #f - (eq? (setting-vocabulary-symbol setting) - 'mred-debug))) - - (read-case-sensitive (setting-case-sensitive? setting)) - - (aries:signal-undefined (setting-signal-undefined setting)) - (aries:signal-not-boolean (setting-signal-not-boolean setting)) - - ;; Allow ` , and ,@ ? - FIXME! - (zodiac:allow-reader-quasiquote (setting-allow-reader-quasiquote? setting)) - (zodiac:disallow-untagged-inexact-numbers (setting-disallow-untagged-inexact-numbers setting)) - - ;; ricedefs - (let ([improper-lists? - (or (not (zodiac-vocabulary? setting)) - (setting-allow-improper-lists? setting))]) - (zodiac:allow-improper-lists improper-lists?) - (params:allow-improper-lists improper-lists?)) - (params:eq?-only-compares-symbols (setting-eq?-only-compares-symbols? setting)) - (params:<=-at-least-two-args (setting-<=-at-least-two-args setting)) - (params:error-sym/string-only (setting-error-sym/string-only setting)) - (when (teaching-level? setting) - (global-define-values/invoke-unit/sig ricedefs^ ricedefs@ #f (params : plt:userspace:params^))) - ;; end ricedefs - - (compile-allow-set!-undefined (setting-allow-set!-on-undefined? setting)) - (compile-allow-cond-fallthrough (not (setting-unmatched-cond/case-is-error? setting))) - - (current-eval drscheme-eval-handler) - (current-load drscheme-load-handler) - - (when (setting-define-argv? setting) - (global-defined-value 'argv #()) - (global-defined-value 'program this-program)) - - (global-port-print-handler drscheme-port-print-handler) - - (case (setting-printing setting) - [(constructor-style) - (r4rs-style-printing #f) - (mzlib:print-convert:constructor-style-printing #t)] - [(quasi-style) - (r4rs-style-printing #f) - (mzlib:print-convert:constructor-style-printing #f) - (mzlib:print-convert:quasi-read-style-printing #f)] - [(quasi-read-style) - (r4rs-style-printing #f) - (mzlib:print-convert:constructor-style-printing #f) - (mzlib:print-convert:quasi-read-style-printing #t)] - [(r4rs-style) (r4rs-style-printing #t)] - [else (error 'install-language "found bad setting-printing: ~a~n" - (setting-printing setting))]) - - (mzlib:pretty-print:pretty-print-exact-as-decimal - (setting-print-exact-as-decimal? setting)) - (mzlib:pretty-print:pretty-print-show-inexactness - (setting-print-tagged-inexact-numbers setting)) - (mzlib:print-convert:show-sharing (setting-sharing-printing? setting)) - (mzlib:print-convert:whole/fractional-exact-numbers - (setting-whole/fractional-exact-numbers setting)) - (mzlib:print-convert:booleans-as-true/false - (setting-print-booleans-as-true/false setting)) - (print-graph (and (r4rs-style-printing) (setting-sharing-printing? setting))) - (mzlib:print-convert:abbreviate-cons-as-list (setting-abbreviate-cons-as-list? setting)) - - ;; ROBBY : attempt to back out of John's changes - (global-defined-value '#%break aries:break) - - (for-each (lambda (l) (apply require-library/proc l)) - (setting-macro-libraries setting))))) diff --git a/collects/userspce/interface.ss b/collects/userspce/interface.ss deleted file mode 100644 index 6ed06e7e..00000000 --- a/collects/userspce/interface.ss +++ /dev/null @@ -1,80 +0,0 @@ -(unit/sig drscheme:interface^ - (import [aries : plt:aries^] - [zodiac : zodiac:system^]) - - (define zodiac-phase #f) - (define (set-zodiac-phase sym) - (unless (or (not sym) - (memq sym '(reader expander))) - (error 'set-zodiac-phase "unknown phase: ~a~n" sym)) - (set! zodiac-phase sym)) - - (define-struct (exn:zodiac-syntax struct:exn:syntax) (link-tag)) - (define-struct (exn:zodiac-read struct:exn:read) (link-tag)) - - ;; init-substring? : string string -> boolean - ;; calculates if sub is an initial substring of str - (define (init-substring? sub str) - (and (>= (string-length str) - (string-length sub)) - (string=? (substring str 0 (string-length sub)) - sub))) - - ;; dispatch-report : string zodiac:zodiac -> ALPHA - ;; escapes - (define (dispatch-report string object link-tag) - (raise - (with-continuation-mark - aries:w-c-m-key - (aries:make-zodiac-mark object) - (case zodiac-phase - [(expander) - (make-exn:zodiac-syntax string - (current-continuation-marks) - #f - link-tag)] - [(reader) - (make-exn:zodiac-read - string (current-continuation-marks) #f link-tag)] - [else (make-exn:user string (current-continuation-marks))])))) - - ;; report-error : symbol -> (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA - ;; escapes - (define report-error - (lambda (type) - (lambda (link-text link-tag z s . args) - (let ([string (apply format - (if (eq? type 'internal) - (string-append "Internal error: " - link-text - ": " - s) - (string-append link-text ": " s)) - args)]) - (cond - [(zodiac:zodiac? z) - (dispatch-report string z link-tag)] - [(zodiac:eof? z) - (dispatch-report - string - (zodiac:make-zodiac 'origin - (zodiac:eof-location z) - (zodiac:eof-location z)) - link-tag)] - [(zodiac:period? z) - (dispatch-report - string - (zodiac:make-zodiac 'origin - (zodiac:period-location z) - (zodiac:period-location z)) - link-tag)] - [else ((error-display-handler) - (format "internal-error.report-error: ~a: ~a" z string))]))))) - - ;; static-error : (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA - ;; escapes - (define static-error (report-error 'static)) - - ;; internal-error : (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA - ;; escapes - (define internal-error (report-error 'internal))) diff --git a/collects/userspce/launcher-bootstrap-mred.ss b/collects/userspce/launcher-bootstrap-mred.ss deleted file mode 100644 index 278bf1a0..00000000 --- a/collects/userspce/launcher-bootstrap-mred.ss +++ /dev/null @@ -1,60 +0,0 @@ -(let* ([main-unit - (let ([settings settings] - [teachpacks teachpacks] - [filename filename] - [mred@ mred@]) - (unit/sig drscheme-jr:settings^ - (import [prims : prims^] - [basis : plt:basis^] - [mzlib : mzlib:core^] - mred^) - - (basis:teachpack-changed teachpacks) - - (define show-banner? #f) - (define repl? #f) - - (define user-eventspace #f) - - (define (run-in-new-user-thread thunk) - (set! user-eventspace (make-eventspace)) - (parameterize ([current-eventspace user-eventspace]) - (let ([thread #f] - [sema (make-semaphore 0)]) - (queue-callback (lambda () - (set! thread (current-thread)) - (semaphore-post sema))) - (semaphore-wait sema) - (queue-callback - (lambda () - (thunk))) - thread))) - - (define (number-open-windows) - (parameterize ([current-eventspace user-eventspace]) - (length (get-top-level-windows)))) - - (define (load-and-repl-done) - (if (= 0 (number-open-windows)) - (exit) - (thread - (rec f - (lambda () - (sleep 1/2) - (if (= 0 (number-open-windows)) - (exit) - (f))))))) - - (define (initialize-userspace) - ;; add mred to the namespace - (global-define-values/invoke-unit/sig mred^ mred@)) - - (define setting (apply basis:make-setting (cdr (vector->list settings)))) - (define startup-file filename)))]) - (compound-unit/sig - (import [prims : prims^] - [basis : plt:basis^] - [mzlib : mzlib:core^]) - (link [mred : mred^ (mred@)] - [main : drscheme-jr:settings^ (main-unit prims basis mzlib mred)]) - (export (open main)))) diff --git a/collects/userspce/launcher-bootstrap-mzscheme.ss b/collects/userspce/launcher-bootstrap-mzscheme.ss deleted file mode 100644 index a27bef40..00000000 --- a/collects/userspce/launcher-bootstrap-mzscheme.ss +++ /dev/null @@ -1,22 +0,0 @@ -(let ([settings settings] - [teachpacks teachpacks] - [filename filename]) - (unit/sig drscheme-jr:settings^ - (import [prims : prims^] - [basis : plt:basis^] - [mzlib : mzlib:core^]) - - (basis:teachpack-changed teachpacks) - - (define show-banner? #f) - (define repl? #f) - (define (run-in-new-user-thread thunk) - (thread thunk)) - - (define (load-and-repl-done) - (exit)) - - (define (initialize-userspace) (void)) - - (define setting (apply basis:make-setting (cdr (vector->list settings)))) - (define startup-file filename))) diff --git a/collects/userspce/launcher-bootstrap.ss b/collects/userspce/launcher-bootstrap.ss deleted file mode 100644 index 73892a47..00000000 --- a/collects/userspce/launcher-bootstrap.ss +++ /dev/null @@ -1,10 +0,0 @@ -;; set things up so that the load-handler opens files into -;; a text when the file begins with WXME so that mred saved -;; files still load properly. - -(require-library "core.ss" "drscheme-jr") - -((make-go - (if (defined? 'mred@) - (load-relative "launcher-bootstrap-mred.ss") - (load-relative "launcher-bootstrap-mzscheme.ss")))) diff --git a/collects/userspce/paramr.ss b/collects/userspce/paramr.ss deleted file mode 100644 index cd913512..00000000 --- a/collects/userspce/paramr.ss +++ /dev/null @@ -1,6 +0,0 @@ -(unit/sig plt:userspace:params^ - (import) - (define error-sym/string-only (make-parameter #f)) - (define <=-at-least-two-args (make-parameter #t)) - (define allow-improper-lists (make-parameter #t)) - (define eq?-only-compares-symbols (make-parameter #f))) diff --git a/collects/userspce/params.ss b/collects/userspce/params.ss deleted file mode 100644 index c05d2afa..00000000 --- a/collects/userspce/params.ss +++ /dev/null @@ -1,5 +0,0 @@ -(define-signature plt:userspace:params^ - (error-sym/string-only - <=-at-least-two-args - allow-improper-lists - eq?-only-compares-symbols)) \ No newline at end of file diff --git a/collects/userspce/ricedefr.ss b/collects/userspce/ricedefr.ss deleted file mode 100644 index f505356f..00000000 --- a/collects/userspce/ricedefr.ss +++ /dev/null @@ -1,140 +0,0 @@ -(unit/sig ricedefs^ - (import [params : plt:userspace:params^]) - - (define check-second - (lambda (prim-name a b) - (unless (list? b) - (#%error prim-name - "second argument must be of type , given ~e and ~e" - a b)))) - - (define check-last - (lambda (prim-name args) - (let loop ([l args]) - (cond - [(null? l) (void)] - [(null? (cdr l)) - (let ([last (car l)]) - (unless (list? last) - (#%error prim-name - "last argument must be of type , given ~e; all args: ~a" - last - (map (lambda (x) (format "~e" x)) args))))] - [else (loop (cdr l))])))) - - (define (check-arity prim len lst) - (let ([lst-len (length lst)]) - (unless (#%>= lst-len len) - (#%error prim - "expects at least ~a arguments, given ~a" - len - (if (#%= 0 lst-len) - 0 - (format - "~a: ~a" - lst-len - (apply string-append - (cons (format "~e" (car lst)) - (let loop ([rst (cdr lst)]) - (cond - [(null? rst) null] - [else (cons (format " ~e" (car rst)) - (loop (cdr rst)))])))))))))) - - - (define = - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '= 2 args) - (apply #%= args)) - #%=)) - - (define + - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '+ 2 args) - (apply #%+ args)) - #%+)) - - (define / - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '/ 2 args) - (apply #%/ args)) - #%/)) - - (define * - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '* 2 args) - (apply #%* args)) - #%*)) - - (define >= - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '>= 2 args) - (apply #%>= args)) - #%>=)) - - (define < - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '< 2 args) - (apply #%< args)) - #%<)) - - (define > - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '> 2 args) - (apply #%> args)) - #%>)) - - (define <= - (if (params:<=-at-least-two-args) - (lambda args - (check-arity '<= 2 args) - (apply #%<= args)) - #%<=)) - - (define cons (if (params:allow-improper-lists) - #%cons - (lambda (a b) - (check-second 'cons a b) - (#%cons a b)))) - - (define set-cdr! (if (params:allow-improper-lists) - #%set-cdr! - (lambda (a b) - (check-second 'set-cdr! a b) - (#%set-cdr! a b)))) - - (define list* (if (params:allow-improper-lists) - #%list* - (lambda x - (check-last 'list* x) - (apply #%list* x)))) - - (define append (if (params:allow-improper-lists) - #%append - (lambda x - (check-last 'append x) - (apply #%append x)))) - - (define append! (if (params:allow-improper-lists) - #%append! - (lambda x - (check-last 'append! x) - (apply #%append! x)))) - - (define error (if (params:error-sym/string-only) - (lambda (sym str) - (unless (and (symbol? sym) - (string? str)) - (#%error 'error - "expected a symbol and a string, got ~e and ~e" - sym str)) - (#%error sym str)) - #%error)) - ) diff --git a/collects/userspce/ricedefs.ss b/collects/userspce/ricedefs.ss deleted file mode 100644 index d4a12f3d..00000000 --- a/collects/userspce/ricedefs.ss +++ /dev/null @@ -1,9 +0,0 @@ -(define-signature ricedefs^ - (<= < > >= - = + * / - cons - set-cdr! - list* - append - append! - error)) diff --git a/collects/userspce/sig.ss b/collects/userspce/sig.ss deleted file mode 100644 index c14c9475..00000000 --- a/collects/userspce/sig.ss +++ /dev/null @@ -1,160 +0,0 @@ -(require-relative-library "ricedefs.ss") -(require-library "sig.ss" "stepper") -(require-library "cores.ss") -(require-library "pconvers.ss") -(require-library "zsigs.ss" "zodiac") -(require-library "sigs.ss" "zodiac") -(require-library "coreflats.ss") -(require-relative-library "ricedefs.ss") -(require-library "sig.ss" "mred") -(require-library "turtles.ss" "graphics") - -(define-signature plt:beginner-extras^ - ((struct posn (x y) -setters) - (open mzlib:core-flat^))) - -(define-signature plt:intermediate-extras^ - plt:beginner-extras^) - -(begin-construction-time - (if (defined? 'mred@) - `(define-signature plt:userspace^ - ((open mred^) - (open mzlib:core-flat^) - (open turtle^) - (struct posn (x y)))) - `(define-signature plt:userspace^ - ((open mzlib:core-flat^) - (struct posn (x y)))))) - -(begin-construction-time - (if (defined? 'mred@) - `(define-signature plt:advanced-extras^ - ((struct posn (x y)) - (open mzlib:core-flat^) - (open turtle^))) - `(define-signature plt:advanced-extras^ - ((struct posn (x y)) - (open mzlib:core-flat^))))) - -;; extend structs with a parsing constructor -(define-macro define-struct/parse - (lambda (str fields) - (unless (symbol? str) - (error 'define-struct/parse "no super structs allowed")) - (let* ([first car] - [second cadr] - [second-name 'cadr] - [third caddr] - [defn (expand-defmacro `(#%define-struct ,str ,fields))] - [_ (unless (and (pair? defn) - (eq? (car defn) '#%define-values)) - (error 'define-struct/parse "expand-defmacro didn't return expected value: ~s~n" defn))] - [bindings (second defn)] - [exp (third defn)] - [make-parse (string->symbol (string-append "make-" (symbol->string str) "/parse"))] - [maker-name (second bindings)] - [parser - `(lambda (inits) - (apply ,maker-name - (map (lambda (field) - (let ([m (assq field inits)]) - (unless m - (error ',make-parse "no binding for: ~a" field)) - (unless (= (length m) 2) - (error ',make-parse "malformed binding: ~a" m)) - (,second-name m))) - ',fields)))]) - `(define-values ,(cons make-parse bindings) - (call-with-values (lambda () ,exp) - (lambda bindings (apply values (cons ,parser bindings)))))))) - -(define-signature plt:init-params^ - (initialize-parameters - settings - get-default-setting - get-default-setting-name - - drscheme-load-handler - - zodiac-vocabulary? - beginner-language? - intermediate-language? - advanced-language? - full-language? - - error-display/debug-handler - current-vocabulary - current-setting - intermediate-values-during-load - bottom-escape-handler - - drscheme-print - - initial-line - initial-column - initial-offset - - format-source-loc - - primitive-eval - primitive-load - syntax-checking-primitive-eval - - process/zodiac - process/no-zodiac - - process-file/zodiac - process-file/no-zodiac - process-sexp/zodiac - process-sexp/no-zodiac - - (struct process-finish (error?)) - - setting-name->number - number->setting - (struct setting (name - vocabulary-symbol - macro-libraries - case-sensitive? - allow-set!-on-undefined? - unmatched-cond/case-is-error? - allow-improper-lists? - sharing-printing? - abbreviate-cons-as-list? - signal-undefined - signal-not-boolean - eq?-only-compares-symbols? - <=-at-least-two-args - disallow-untagged-inexact-numbers - print-tagged-inexact-numbers - whole/fractional-exact-numbers - print-booleans-as-true/false - printing - use-pretty-printer?)) - make-setting/parse - - find-setting-named - add-setting - copy-setting - - r4rs-style-printing?)) - -(define-signature plt:init-namespace^ - (init-namespace - teachpack-ok? - teachpack-changed)) - -(define-signature plt:basis^ - ((open plt:init-params^) - (open plt:init-namespace^))) - -(define-signature drscheme:interface^ - ((open zodiac:interface^) - (struct exn:zodiac-syntax (link-tag)) - (struct exn:zodiac-read (link-tag)) - set-zodiac-phase)) - -(define-signature plt:basis-import^ - (invalid-teachpack - in-mzscheme?)) diff --git a/collects/userspce/userspce.ss b/collects/userspce/userspce.ss deleted file mode 100644 index 9c3df22d..00000000 --- a/collects/userspce/userspce.ss +++ /dev/null @@ -1,17 +0,0 @@ -; require this file within MrEd to install into the top-level -; the bindings normally available to a DrScheme library - -(begin-elaboration-time - (require-library "params.ss" "userspce")) - -(begin-elaboration-time - (require-library "invoke.ss")) - -(define-values/invoke-unit/sig ((open plt:userspace:params^) - (open plt:userspace^)) - (compound-unit/sig - (import) - (link [p : plt:userspace:params^ ((require-relative-library "paramr.ss"))] - [u : plt:userspace^ ((require-relative-library "userspcr.ss") p)]) - (export (open p) - (open u)))) diff --git a/collects/userspce/userspcr.ss b/collects/userspce/userspcr.ss deleted file mode 100644 index cf949d84..00000000 --- a/collects/userspce/userspcr.ss +++ /dev/null @@ -1,5 +0,0 @@ -(compound-unit/sig (import [params : plt:userspace:params^]) - (link [core : mzlib:core-flat^ ((require-library "coreflatr.ss"))] - [mred : mred^ (mred@)]) - (export (open core) - (open mred))) diff --git a/collects/xml/doc.txt b/collects/xml/doc.txt deleted file mode 100644 index d1f51311..00000000 --- a/collects/xml/doc.txt +++ /dev/null @@ -1,177 +0,0 @@ -_XML_ Library -============= - -Basic XML Data Types -==================== - -Document: - This structure represents an XML document. The only useful part is - the document-element, which contains all the content. The rest of - of the structure contains DTD information, which isn't supported, - and processing-instructions. - -Element: - Each pair of start/end tags and everything in between is an element. - It has the following pieces: - a name - attributes - contents including sub-elements -Xexpr: - S-expression representations of XML data. - -The end of this document has more details. - -Functions -========= - -> read-xml : [Input-port] -> Document - reads in an XML document from the given or current input port - XML documents contain exactly one element. It throws an xml-read:error - if there isn't any element or if there are more than one element. - -> write-xml : Document [Output-port] -> Void - writes a document to the given or current output port, currently - ignoring everything except the document's root element. - -> write-xml/content : Content [Output-port] -> Void - writes a document's contents to the given or current output port - -> display-xml : Document [Output-port] -> Void - just like write-xml, but newlines and indentation make the output more - readable, though less technically correct when white space is - significant. - -> display-xml/content : Content [Output-port] -> Void - just like write-xml/content, but with indentation and newlines - -> xml->xexpr : Content -> Xexpr - converts the interesting part of an XML document into an Xexpression - -> xexpr->xml : Xexpr -> Content - converts an Xexpression into the interesting part of an XML document - -> xexpr->string : Xexpression -> String - converts an Xexpression into a string representation - -> eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element - Some elements should not contain any text, only other tags, except they - often contain whitespace for formating purposes. Given a list of tag names - and the identity function, eliminate-whitespace produces a function that - filters out pcdata consisting solely of whitespace from those elements and - raises and error if any non-whitespace text appears. Passing in the function - called "not" instead of the identity function filters all elements which are not - named in the list. Using void filters all elements regardless of the list. - -Parameters -========== - -> empty-tag-shorthand : 'always | 'never | (listof Symbol) - Default: 'always - This determines if the output functions should use the tag - notation instead of writing . The first form is the - preferred XML notation. However, most browsers designed for HTML - will only properly render XHTML if the document uses a mixture of the - two formats. _html-empty-tags_ contains the W3 consortium's - recommended list of XHTML tags that should use the shorthand. - -> collapse-whitespace : Bool - Default: #f - All consecutive whitespace is replaced by a single space. - CDATA sections are not affected. - -> trim-whitespace : Bool - This parameter no longer exists. Consider using collapse-whitespace - and eliminate-whitespace instead. - -> read-comments : Bool - Default: #f - Comments, by definition, should be ignored by programs. However, - interoperating with ad hoc extentions to other languages sometimes - requires processing comments anyway. - -> xexpr-drop-empty-attributes : Bool - Default: #f - It's easier to write functions processing Xexpressions, if they always - have a list of attributes. On the other hand, it's less cumbersome to - write Xexpresssions by hand without empty lists of attributes - everywhere. Normally xml->xexpr leaves in empty attribute lists. - Setting this parameter to #t drops them, so further editing the - Xexpression by hand is less annoying. - -Examples -======== - -Reading an Xexpression: - (xml->xexpr (document-element (read-xml input-port))) - -Writing an Xexpression: - (empty-tag-shorthand html-empty-tags) - (write-xml/content (xexpr->xml `(html (head (title ,banner)) - (body ((bgcolor "white")) - ,text))) - output-port) - -What this Library Doesn't Provide -================================= - - Document Type Declaration (DTD) processing - Validation - Expanding user-defined entites - Reading user-defined entites in attributes - Unicode support - -XML Datatype Details -==================== - -Note: Users of the XML collection don't need to know most of these definitions. - -Note: Xexpr is the only important one to understand. Even then, - Processing-instructions may be ignored. - -> Xexpr ::= String - | (list* Symbol (listof (list Symbol String)) (list Xexpr)) - | (cons Symbol (listof Xexpr)) ;; an element with no attributes - | Symbol ;; symbolic entities such as   - | Number ;; numeric entities like  - | Misc - -> Document ::= (make-document Prolog Element (listof Processing-instruction)) - (define-struct document (prolog element misc)) - -> Prolog ::= (make-prolog (listof Misc) #f) - (define-struct prolog (misc dtd)) - -> Element ::= (make-element Location Location - Symbol - (listof Attribute) - (listof Content)) - (define-struct (element struct:source) (name attributes content)) - -> Attribute ::= (make-attribute Location Location Symbol String) - (define-struct (attribute struct:source) (name value)) - -> Content ::= Pcdata - | Element - | Entity - | Misc - - Misc ::= Comment - | Processing-instruction - -> Pcdata ::= (make-pcdata Location Location String) - (define-struct (pcdata struct:source) (string)) - -> Entity ::= (make-entity (U Nat Symbol)) - (define-struct entity (text)) - -> Processing-instruction ::= (make-pi Location Location String (list String)) - (define-struct (pi struct:source) (target-name instruction)) - -> Comment ::= (make-comment String) - (define-struct comment (text)) - - Source ::= (make-source Location Location) - (define-struct source (start stop)) - - Location ::= Nat - | Symbol diff --git a/collects/xml/info.ss b/collects/xml/info.ss deleted file mode 100644 index 93336256..00000000 --- a/collects/xml/info.ss +++ /dev/null @@ -1,10 +0,0 @@ -(lambda (sym fail) - (let* ([sig "xmls.ss"] - [signatures (list sig)]) - (case sym - [(name) "XML"] - [(compile-prefix) `(require-library ,sig "xml")] - [(compile-omit-files) signatures] - [(compile-elaboration-zos) signatures] - ;[(compile-subcollections) (list (list "xml" "xt3d"))] - [else (fail)]))) diff --git a/collects/xml/reader.ss b/collects/xml/reader.ss deleted file mode 100644 index 8407c35d..00000000 --- a/collects/xml/reader.ss +++ /dev/null @@ -1,346 +0,0 @@ -(unit/sig reader^ - (import xml-structs^ mzlib:function^) - - ;; Start-tag ::= (make-start-tag Location Location Symbol (listof Attribute)) - (define-struct (start-tag struct:source) (name attrs)) - - ;; End-tag ::= (make-end-tag Location Location Symbol) - (define-struct (end-tag struct:source) (name)) - - ;; Token ::= Contents | Start-tag | End-tag | Eof - - (define read-comments (make-parameter #f)) - (define collapse-whitespace (make-parameter #f)) - - ;; read-xml : [Input-port] -> Document - (define read-xml - (case-lambda - [(in) (read-from-port in)] - [() (read-from-port (current-input-port))])) - - ;; read-from-port : Input-port -> Document - (define (read-from-port in) - (let*-values ([(in pos) (positionify in)] - [(misc0 start) (read-misc in pos)]) - (make-document (make-prolog misc0 #f) - (cond - [(start-tag? start) (read-element start in pos)] - [(element? start) start] - [else (error 'read-xml "expected root element - received ~a" start)]) - (let-values ([(misc1 end-of-file) (read-misc in pos)]) - (unless (eof-object? end-of-file) - (error 'read-xml "extra stuff at end of document ~a" end-of-file)) - misc1)))) - - ;; read-misc : Input-port (-> Nat) -> (listof Misc) Token - (define (read-misc in pos) - (let read-more () - (let ([x (lex in pos)]) - (cond - [(or (pi? x) (comment? x)) - (let-values ([(lst next) (read-more)]) - (values (cons x lst) next))] - [(and (pcdata? x) (andmap char-whitespace? (string->list (pcdata-string x)))) - (read-more)] - [else (values null x)])))) - - ;; read-element : Start-tag Input-port (-> Nat) -> Element - (define (read-element start in pos) - (let ([name (start-tag-name start)] - [a (source-start start)] - [b (source-stop start)]) - (make-element - a b name (start-tag-attrs start) - (let read-content () - (let ([x (lex in pos)]) - (cond - [(eof-object? x) - (error 'read-xml "unclosed ~a tag at [~a ~a]" name a b)] - [(start-tag? x) (cons (read-element x in pos) (read-content))] - [(end-tag? x) - (unless (eq? name (end-tag-name x)) - (error 'read-xml "start tag ~a at [~a ~a] doesn't match end tag ~a at [~a ~a]" - name a b (end-tag-name x) (source-start x) (source-stop x))) - null] - [(entity? x) (cons (expand-entity x) (read-content))] - [(comment? x) (if (read-comments) - (cons x (read-content)) - (read-content))] - [else (cons x (read-content))])))))) - - ;; expand-entity : Entity -> (U Entity Pcdata) - ;; more here - allow expansion of user defined entities - (define (expand-entity x) - (let ([expanded (default-entity-table (entity-text x))]) - (if expanded - (make-pcdata (source-start x) (source-stop x) expanded) - x))) - - ;; default-entity-table : Symbol -> (U #f String) - (define (default-entity-table name) - (case name - [(amp) "&"] - [(lt) "<"] - [(gt) ">"] - [(quot) "\""] - [(apos) "'"] - [else #f])) - - ;; lex : Input-port (-> Nat) -> Token - (define (lex in pos) - (let ([c (peek-char in)]) - (cond - [(eof-object? c) c] - [(eq? c #\&) (lex-entity in pos)] - [(eq? c #\<) (lex-tag-cdata-pi-comment in pos)] - [else (lex-pcdata in pos)]))) - - ;; lex-entity : Input-port (-> Nat) -> Entity - (define (lex-entity in pos) - (let ([start (pos)]) - (read-char in) - (let ([data (case (peek-char in) - [(#\#) - (read-char in) - (let ([n (case (peek-char in) - [(#\x) (read-char in) - (string->number (read-until #\; in pos) 16)] - [else (string->number (read-until #\; in pos))])]) - (unless (number? n) - (lex-error in pos "malformed numeric entity")) - n)] - [else - (begin0 - (lex-name in pos) - (unless (eq? (read-char in) #\;) - (lex-error in pos "expected ; at the end of an entity")))])]) - (make-entity start (pos) data)))) - - ;; lex-tag-cdata-pi-comment : Input-port (-> Nat) -> Start-tag | Element | End-tag | Pcdata | Pi | Comment - (define (lex-tag-cdata-pi-comment in pos) - (let ([start (pos)]) - (read-char in) - (case (non-eof peek-char in pos) - [(#\!) - (read-char in) - (case (non-eof peek-char in pos) - [(#\-) (read-char in) - (unless (eq? (read-char in) #\-) - (lex-error in pos "expected second - after ) - (lex-error in pos "expected > to end comment (\"--\" can't appear in comments)")) - ;(make-comment start (pos) data) - (make-comment data))] - [(#\[) (read-char in) - (unless (string=? (read-string 6 in) "CDATA[") - (lex-error in pos "expected CDATA following <[")) - (let ([data (lex-cdata-contents in pos)]) - (make-pcdata start (pos) data))] - [else (skip-dtd in pos) - (skip-space in) - (unless (eq? (peek-char in) #\<) - (lex-error in pos "expected pi, comment, or element after doctype")) - (lex-tag-cdata-pi-comment in pos)])] - [(#\?) (read-char in) - (let ([name (lex-name in pos)]) - (skip-space in) - (let ([data (lex-pi-data in pos)]) - (make-pi start (pos) name data)))] - [(#\/) (read-char in) - (let ([name (lex-name in pos)]) - (skip-space in) - (unless (eq? (read-char in) #\>) - (lex-error in pos "expected > to close ~a's end tag" name)) - (make-end-tag start (pos) name))] - [else - (let ([name (lex-name in pos)] - [attrs (lex-attributes in pos)]) - (skip-space in) - (case (read-char in) - [(#\/) - (unless (eq? (read-char in) #\>) - (lex-error in pos "expected > to close empty element ~a" name)) - (make-element start (pos) name attrs null)] - [(#\>) (make-start-tag start (pos) name attrs)] - [else (lex-error in pos "expected / or > to close tag ~a" name)]))]))) - - ;; lex-attributes : Input-port (-> Nat) -> (listof Attribute) - (define (lex-attributes in pos) - (quicksort (let loop () - (skip-space in) - (cond - [(name-start? (peek-char in)) - (cons (lex-attribute in pos) (loop))] - [else null])) - (lambda (a b) - (let ([na (attribute-name a)] - [nb (attribute-name b)]) - (cond - [(eq? na nb) (lex-error in pos "duplicated attribute name ~a" na)] - [else (stringstring na) (symbol->string nb))]))))) - - ;; lex-attribute : Input-port (-> Nat) -> Attribute - (define (lex-attribute in pos) - (let ([start (pos)] - [name (lex-name in pos)]) - (skip-space in) - (unless (eq? (read-char in) #\=) - (lex-error in pos "expected = in attribute ~a" name)) - (skip-space in) - ;; more here - handle entites and disallow "<" - (let* ([delimiter (read-char in)] - [value (case delimiter - [(#\' #\") - (list->string - (let read-more () - (let ([c (non-eof peek-char in pos)]) - (cond - [(eq? c delimiter) (read-char in) null] - [(eq? c #\&) - (let ([entity (expand-entity (lex-entity in pos))]) - (if (pcdata? entity) - (append (string->list (pcdata-string entity)) (read-more)) - ;; more here - do something with user defined entites - (read-more)))] - [else (read-char in) (cons c (read-more))]))))] - [else (lex-error in pos "attribute values must be in ''s or in \"\"s")])]) - (make-attribute start (pos) name value)))) - - ;; skip-space : Input-port -> Void - ;; deviation - should sometimes insist on at least one space - (define (skip-space in) - (let loop () - (let ([c (peek-char in)]) - (when (and (not (eof-object? c)) (char-whitespace? c)) - (read-char in) - (loop))))) - - ;; lex-pcdata : Input-port (-> Nat) -> Pcdata - ;; deviation - disallow ]]> "for compatability" with SGML, sec 2.4 XML spec - (define (lex-pcdata in pos) - (let ([start (pos)] - [data (let loop () - (let ([next (peek-char in)]) - (cond - [(or (eof-object? next) (eq? next #\&) (eq? next #\<)) - null] - [(and (char-whitespace? next) (collapse-whitespace)) - (skip-space in) - (cons #\space (loop))] - [else (cons (read-char in) (loop))])))]) - (make-pcdata start - (pos) - (list->string data)))) - - ;; lex-name : Input-port (-> Nat) -> Symbol - (define (lex-name in pos) - (let ([c (read-char in)]) - (unless (name-start? c) - (lex-error in pos "expected name, received ~a" c)) - (string->symbol - (list->string - (cons c (let lex-rest () - (cond - [(name-char? (peek-char in)) - (cons (read-char in) (lex-rest))] - [else null]))))))) - - ;; skip-dtd : Input-port (-> Nat) -> Void - (define (skip-dtd in pos) - (let skip () - (case (non-eof read-char in pos) - [(#\') (read-until #\' in pos) (skip)] - [(#\") (read-until #\" in pos) (skip)] - [(#\<) - (case (non-eof read-char in pos) - [(#\!) (case (non-eof read-char in pos) - [(#\-) (read-char in) (lex-comment-contents in pos) (read-char in) (skip)] - [else (skip) (skip)])] - [(#\?) (lex-pi-data in pos) (skip)] - [else (skip) (skip)])] - [(#\>) (void)] - [else (skip)]))) - - ;; name-start? : Char -> Bool - (define (name-start? ch) - (or (char-alphabetic? ch) - (eq? ch #\_) - (eq? ch #\:))) - - ;; name-char? : Char -> Bool - (define (name-char? ch) - (or (name-start? ch) - (char-numeric? ch) - (eq? ch #\.) - (eq? ch #\-))) - - ;; read-until : Char Input-port (-> Nat) -> String - ;; discards the stop character, too - (define (read-until char in pos) - (list->string - (let read-more () - (let ([c (non-eof read-char in pos)]) - (cond - [(eq? c char) null] - [else (cons c (read-more))]))))) - - ;; non-eof : (Input-port -> (U Char Eof)) Input-port (-> Nat) -> Char - (define (non-eof f in pos) - (let ([c (f in)]) - (cond - [(eof-object? c) (lex-error in pos "unexpected eof")] - [else c]))) - - ;; gen-read-until-string : String -> Input-port (-> Nat) -> String - ;; uses Knuth-Morris-Pratt from - ;; Introduction to Algorithms, Cormen, Leiserson, and Rivest, pages 869-876 - ;; discards stop from input - (define (gen-read-until-string stop) - (let* ([len (string-length stop)] - [prefix (make-vector len 0)] - [fall-back - (lambda (k c) - (let ([k (let loop ([k k]) - (cond - [(and (> k 0) (not (eq? (string-ref stop k) c))) - (loop (vector-ref prefix (sub1 k)))] - [else k]))]) - (if (eq? (string-ref stop k) c) - (add1 k) - k)))]) - (let init ([k 0] [q 1]) - (when (< q len) - (let ([k (fall-back k (string-ref stop q))]) - (vector-set! prefix q k) - (init k (add1 q))))) - ;; (vector-ref prefix x) = the longest suffix that matches a prefix of stop - (lambda (in pos) - (list->string - (let/ec out - (let loop ([matched 0] [out out]) - (let* ([c (non-eof read-char in pos)] - [matched (fall-back matched c)]) - (cond - [(= matched len) (out null)] - [(zero? matched) (cons c (let/ec out (loop matched out)))] - [else (cons c (loop matched out))])))))))) - - ;; "-->" makes more sense, but "--" follows the spec. - (define lex-comment-contents (gen-read-until-string "--")) - (define lex-pi-data (gen-read-until-string "?>")) - (define lex-cdata-contents (gen-read-until-string "]]>")) - - ;; positionify : Input-port -> Input-port (-> Nat) - (define (positionify in) - (let ([n 0]) - (values (make-input-port - (lambda () (set! n (add1 n)) (read-char in)) - (lambda () (char-ready? in)) - (lambda () (peek-char in))) - (lambda () n)))) - - ;; lex-error : Input-port String (-> Nat) TST* -> alpha - (define (lex-error in pos str . rest) - (error 'lex-error " at positon ~a: ~a" (pos) - (apply format str rest)))) \ No newline at end of file diff --git a/collects/xml/space.ss b/collects/xml/space.ss deleted file mode 100644 index 6eec5302..00000000 --- a/collects/xml/space.ss +++ /dev/null @@ -1,28 +0,0 @@ -(unit/sig space^ - (import xml-structs^ mzlib:function^) - - ;; eliminate-whitespace : (listof Symbol) (Bool -> Bool) -> Element -> Element - (define (eliminate-whitespace special eliminate-special?) - (letrec ([blank-it - (lambda (el) - (let ([name (element-name el)] - [content (map (lambda (x) - (if (element? x) (blank-it x) x)) - (element-content el))]) - (make-element - (source-start el) - (source-stop el) - name - (element-attributes el) - (cond - [(eliminate-special? (memq (element-name el) special)) - (filter (lambda (s) - (not (and (pcdata? s) - (or (all-blank (pcdata-string s)) - (error 'eliminate-blanks "Element <~a> is not allowed to contain text ~s" name (pcdata-string s)))))) - content)] - [else content]))))]) - blank-it)) - - ;; all-blank : String -> Bool - (define (all-blank s) (andmap char-whitespace? (string->list s)))) diff --git a/collects/xml/structures.ss b/collects/xml/structures.ss deleted file mode 100644 index 392c81e4..00000000 --- a/collects/xml/structures.ss +++ /dev/null @@ -1,43 +0,0 @@ -(unit/sig xml-structs^ - (import) - - ;; Location ::= Nat | Symbol - ;; Source ::= (make-source Location Location) - (define-struct source (start stop)) - - ;; Document ::= (make-document Prolog Element (listof Misc)) - (define-struct document (prolog element misc)) - - ;; Prolog ::= (make-prolog (listof Misc) #f) - (define-struct prolog (misc dtd)) - - ;; Element ::= (make-element Location Location Symbol (listof Attribute) (listof Content)) - (define-struct (element struct:source) (name attributes content)) - - ;; Attribute ::= (make-attribute Location Location Symbol String) - (define-struct (attribute struct:source) (name value)) - - ;; Pcdata ::= (make-pcdata Location Location String) - (define-struct (pcdata struct:source) (string)) - - ;; Content ::= Pcdata - ;; | Element - ;; | Entity - ;; | Misc - - ;; Misc ::= Comment - ;; | Processing-instruction - - ;; Entity ::= (make-entity Location Location (U Nat Symbol)) - (define-struct (entity struct:source) (text)) - - ;; Processing-instruction ::= (make-pi Location Location String (list String)) - ;; also represents XMLDecl - (define-struct (pi struct:source) (target-name instruction)) - - ;; Comment ::= (make-comment String) - (define-struct comment (text)) - - ;; content? : TST -> Bool - (define (content? x) - (or (pcdata? x) (element? x) (entity? x) (comment? x) (pi? x)))) \ No newline at end of file diff --git a/collects/xml/writer.ss b/collects/xml/writer.ss deleted file mode 100644 index 7c674e9a..00000000 --- a/collects/xml/writer.ss +++ /dev/null @@ -1,130 +0,0 @@ -(unit/sig writer^ - (import xml-structs^ mzlib:function^) - - ;;(define empty-tag-shorthand (make-parameter #t)) - ;;(define empty-tag-shorthand (make-parameter void)) - - ;; (empty-tag-shorthand) : (U 'always 'never (listof Symbol)) - (define empty-tag-shorthand (make-parameter 'always)) - - (define html-empty-tags '(param meta link isindex input img hr frame col br basefont base area)) - - ;; var-argify : (a Output-port -> b) -> (a [Output-port] -> b) - (define (var-argify f) - (case-lambda - [(x out) (f x out)] - [(x) (f x (current-output-port))])) - - ;; gen-write/display-xml/content : (Nat Output-port -> Void) -> Content [Output-Port]-> Void - (define (gen-write/display-xml/content dent) - (var-argify (lambda (c out) (write-xml-content c 0 dent out)))) - - ;; indent : Nat Output-port -> Void - (define (indent n out) - (newline out) - (let loop ([n n]) - (unless (zero? n) - (display #\space out) - (loop (sub1 n))))) - - ;; write-xml/content : Content [Output-port] -> Void - (define write-xml/content (gen-write/display-xml/content void)) - - ;; display-xml/content : Content [Output-port] -> Void - (define display-xml/content (gen-write/display-xml/content indent)) - - ;; gen-write/display-xml : (Content [Output-port] -> Void) -> Document [Output-port] -> Void - (define (gen-write/display-xml output-content) - (var-argify (lambda (doc out) - (display-outside-misc (prolog-misc (document-prolog doc)) out) - (output-content (document-element doc) out) - (display-outside-misc (document-misc doc) out)))) - - ;; write-xml : Document [Output-port] -> Void - (define write-xml (gen-write/display-xml write-xml/content)) - - ;; display-xml : Document [Output-port] -> Void - (define display-xml (gen-write/display-xml display-xml/content)) - - ;; display-outside-misc : (listof Misc) Output-port -> Void - (define (display-outside-misc misc out) - (for-each (lambda (x) - ((cond - [(comment? x) write-xml-comment] - [(pi? x) write-xml-pi]) x 0 void out) - (newline out)) - misc)) - - ;; write-xml-content : Content Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-content el over dent out) - ((cond - [(element? el) write-xml-element] - [(pcdata? el) write-xml-pcdata] - [(entity? el) write-xml-entity] - [(comment? el) write-xml-comment] - [(pi? el) write-xml-pi] - [else (error 'write-xml-content "received ~a" el)]) - el over dent out)) - - ;; write-xml-element : Element Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-element el over dent out) - (let* ([name (element-name el)] - [start (lambda (f) (write-xml-base (format f name) over dent out))] - [content (element-content el)]) - (start "<~a") - (for-each (lambda (att) - (fprintf out " ~s=~s" (attribute-name att) - (escape (attribute-value att) escape-attribute-table))) - (element-attributes el)) - (if (and (null? content) - (let ([short (empty-tag-shorthand)]) - (case short - [(always) #t] - [(never) #f] - [else (memq name short)]))) - (fprintf out " />") - (begin - (fprintf out ">") - (for-each (lambda (c) (write-xml-content c (incr over) dent out)) content) - (start ""))))) - - ;; write-xml-base : (U String Char Symbol) Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-base el over dent out) - (dent over out) - (display el out)) - - ;; write-xml-pcdata : Pcdata Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-pcdata str over dent out) - (write-xml-base (escape (pcdata-string str) escape-table) over dent out)) - - ;; write-xml-pi : Processing-instruction Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-pi pi over dent out) - (write-xml-base (format "" (pi-target-name pi) (pi-instruction pi)) over dent out)) - - ;; write-xml-comment : Comment Nat (Nat Output-Stream -> Void) Output-Stream -> Void - (define (write-xml-comment comment over dent out) - (write-xml-base (format "" (comment-text comment)) over dent out)) - - ;; write-xml-entity : Entity Nat (Nat Output-stream -> Void) Output-stream -> Void - (define (write-xml-entity entity over dent out) - (let ([n (entity-text entity)]) - (fprintf out (if (number? n) "&#~a;" "&~a;") n))) - - (define escape-table - (map (lambda (x y) (cons (regexp (symbol->string x)) y)) - '(< > &) - '("\\<" "\\>" "\\&"))) - - (define escape-attribute-table - (list* (cons (regexp "'") "\\'") (cons (regexp "\"") "\\"") escape-table)) - - ;; escape : String -> String - ;; more here - this could be much more efficient - (define (escape x table) - (foldr (lambda (esc str) (regexp-replace* (car esc) str (cdr esc))) - x - table)) - - ;; incr : Nat -> Nat - (define (incr n) (+ n 2))) diff --git a/collects/xml/xexpr.ss b/collects/xml/xexpr.ss deleted file mode 100644 index 16e8dd0e..00000000 --- a/collects/xml/xexpr.ss +++ /dev/null @@ -1,82 +0,0 @@ -(unit/sig extra-xexpr^ - (import xml-structs^ writer^ mzlib:function^) - ;; Xexpr ::= String - ;; | (list* Symbol (listof Attribute-srep) (listof Xexpr)) - ;; | (cons Symbol (listof Xexpr)) - ;; | Symbol - ;; | Nat - ;; | Comment - ;; | Processing-instruction - ;; Attribute-srep ::= (list Symbol String) - - ;; sorting is no longer necessary, since xt3d uses xml->zxexpr, which sorts. - - ;; assoc-sort : (listof (list Symbol a)) -> (listof (list Symbol a)) - (define (assoc-sort to-sort) - (quicksort to-sort (bcompose stringstring car)))) - - (define xexpr-drop-empty-attributes (make-parameter #f)) - - ;; xml->xexpr : Content -> Xexpr - ;; The contract is loosely enforced. - (define (xml->xexpr x) - (let* ([non-dropping-combine - (lambda (atts body) - (cons (assoc-sort (map attribute->srep atts)) - body))] - [combine (if (xexpr-drop-empty-attributes) - (lambda (atts body) - (if (null? atts) - body - (non-dropping-combine atts body))) - non-dropping-combine)]) - (let loop ([x x]) - (cond - [(element? x) - (let ([body (map loop (element-content x))] - [atts (element-attributes x)]) - (cons (element-name x) (combine atts body)))] - [(pcdata? x) (pcdata-string x)] - [(entity? x) (entity-text x)] - [(or (comment? x) (pi? x)) x] - [(document? x) (error 'xml->xexpr "Expected content, given ~a~nUse document-element to extract the content." x)] - [else (error 'xml->xexpr "Expected content, given ~a" x)])))) - - ;; attribute->srep : Attribute -> Attribute-srep - (define (attribute->srep a) - (list (attribute-name a) (attribute-value a))) - - ;; srep->attribute : Attribute-srep -> Attribute - (define (srep->attribute a) - (unless (and (pair? a) (pair? (cdr a)) (null? (cddr a)) (symbol? (car a)) (string? (cadr a))) - (error 'srep->attribute "expected (cons Symbol String) given ~a" a)) - (make-attribute 'scheme 'scheme (car a) (cadr a))) - - ;; xexpr->xml : Xexpr -> Content - ;; The contract is enforced. - (define (xexpr->xml x) - (cond - [(pair? x) - (let ([f (lambda (atts body) - (unless (list? body) - (error 'xexpr->xml "expected a list of xexprs a the body in ~a" x)) - (make-element 'scheme 'scheme (car x) - atts - (map xexpr->xml body)))]) - (if (and (pair? (cdr x)) (or (null? (cadr x)) (and (pair? (cadr x)) (pair? (caadr x))))) - (f (map srep->attribute (cadr x)) (cddr x)) - (f null (cdr x))))] - [(string? x) (make-pcdata 'scheme 'scheme x)] - [(or (symbol? x) (and (integer? x) (>= x 0))) (make-entity 'scheme 'scheme x)] - [(or (comment? x) (pi? x)) x] - [else (error 'xexpr->xml "malformed xexpr ~s" x)])) - - ;; xexpr->string : Xexpression -> String - (define (xexpr->string xexpr) - (let ([port (open-output-string)]) - (write-xml/content (xexpr->xml xexpr) port) - (get-output-string port))) - - ;; bcompose : (a a -> c) (b -> a) -> (b b -> c) - (define (bcompose f g) - (lambda (x y) (f (g x) (g y))))) diff --git a/collects/xml/xml.ss b/collects/xml/xml.ss deleted file mode 100644 index 6632de9d..00000000 --- a/collects/xml/xml.ss +++ /dev/null @@ -1,9 +0,0 @@ -(require-library "xmls.ss" "xml") -(define-values/invoke-unit/sig - xml^ - (compound-unit/sig - (import) - (link - (FUN : mzlib:function^ ((require-library "functior.ss"))) - (X : xml^ ((require-library "xmlr.ss" "xml") FUN))) - (export (open X)))) \ No newline at end of file diff --git a/collects/xml/xmlr.ss b/collects/xml/xmlr.ss deleted file mode 100644 index 680a9cf8..00000000 --- a/collects/xml/xmlr.ss +++ /dev/null @@ -1,9 +0,0 @@ -(compound-unit/sig - (import (FUN : mzlib:function^)) - (link - (S : xml-structs^ ((require-library "structures.ss" "xml"))) - (R : reader^ ((require-library "reader.ss" "xml") S FUN)) - (U : writer^ ((require-library "writer.ss" "xml") S FUN)) - (T : xexpr^ ((require-library "xexpr.ss" "xml") S U FUN)) - (W : space^ ((require-library "space.ss" "xml") S FUN))) - (export (open S) (open R) (open U) (open T) (open W))) diff --git a/collects/xml/xmls.ss b/collects/xml/xmls.ss deleted file mode 100644 index 0a8e00c7..00000000 --- a/collects/xml/xmls.ss +++ /dev/null @@ -1,23 +0,0 @@ -(require-library "functios.ss") -(require-library "invoke.ss") - -(define-signature xml-structs^ - ((struct document (prolog element misc)) - (struct comment (text)) - (struct prolog (misc dtd)) - (struct element (name attributes content)) - (struct attribute (name value)) - (struct pi (target-name instruction)) - (struct source (start stop)) - (struct pcdata (string)) - (struct entity (text)) - content?)) - -(define-signature writer^ (write-xml display-xml write-xml/content display-xml/content empty-tag-shorthand html-empty-tags)) -(define-signature reader^ (read-xml read-comments collapse-whitespace)) - -(define-signature xexpr^ (xml->xexpr xexpr->xml xexpr->string xexpr-drop-empty-attributes)) -(define-signature extra-xexpr^ ((open xexpr^) assoc-sort bcompose attribute->srep)) -(define-signature space^ (eliminate-whitespace)) -(define-signature xml^ ((open xml-structs^) (open reader^) (open writer^) (open xexpr^) (open space^))) - diff --git a/collects/zodiac/back.ss b/collects/zodiac/back.ss deleted file mode 100644 index 4cb76422..00000000 --- a/collects/zodiac/back.ss +++ /dev/null @@ -1,85 +0,0 @@ -; $Id: back.ss,v 1.4 1997/07/21 15:51:43 shriram Exp $ - -(unit/sig zodiac:back-protocol^ - (import zodiac:misc^ zodiac:interface^) - - (define-struct secure-box (value)) - - (define init-value-list '()) - - (define register-initial-value - (lambda (index value-thunk) - (set! init-value-list - (append init-value-list - (list value-thunk))))) - - (define make-initial-value-vector - (lambda () - (let ((v (make-vector current-vector-size uninitialized-flag))) - (let loop ((index 0) (inits init-value-list)) - (unless (null? inits) - (vector-set! v index ((car inits))) - (loop (add1 index) (cdr inits)))) - v))) - - (define make-empty-back-box - (lambda () - (make-secure-box (make-initial-value-vector)))) - - (define current-vector-size 2) - - (define next-client-count - (let ((count -1)) - (lambda () - (set! count (add1 count)) - (when (>= count current-vector-size) - (set! current-vector-size (* 2 current-vector-size))) - count))) - - (define-struct uninitialized-back ()) - (define uninitialized-flag (make-uninitialized-back)) - - (define client-registry (make-hash-table)) - - (define register-client - (lambda (client-name default-initial-value-thunk) - (when (hash-table-get client-registry client-name - (lambda () #f)) - (internal-error client-name "Attempting duplicate registration")) - (hash-table-put! client-registry client-name #t) - (let ((index (next-client-count))) - (register-initial-value index default-initial-value-thunk) - (values - (lambda (back) ; getter - (let ((v (secure-box-value back))) - (with-handlers - ((exn:application:mismatch? - (lambda (exception) - (vector-ref (extend-back-vector back) index)))) - (let ((value (vector-ref v index))) - (if (uninitialized-back? value) - (let ((correct-value - ((list-ref init-value-list index)))) - (vector-set! v index correct-value) - correct-value) - value))))) - (lambda (back value) ; setter - (let ((v (secure-box-value back))) - (with-handlers - ((exn:application:mismatch? - (lambda (exception) - (vector-set! (extend-back-vector back) index value)))) - (vector-set! v index value)))))))) - - (define extend-back-vector - (lambda (back-box) - (let ((v (secure-box-value back-box))) - (let ((new-v (make-initial-value-vector))) - (let loop ((n (sub1 (vector-length v)))) - (when (>= n 0) - (vector-set! new-v n (vector-ref v n)) - (loop (sub1 n)))) - (set-secure-box-value! back-box new-v) - new-v)))) - - ) diff --git a/collects/zodiac/basestr.ss b/collects/zodiac/basestr.ss deleted file mode 100644 index 39744a07..00000000 --- a/collects/zodiac/basestr.ss +++ /dev/null @@ -1,19 +0,0 @@ -;; -;; zodiac:structures@ -;; $Id$ -;; -;; Top-level zodiac structures (outside the hierarchy) -;; and base of zodiac hierarchy. -;; - -(unit/sig zodiac:structures^ - (import) - - (define-struct origin (who how)) - (define-struct location (line column offset file)) - (define-struct period (location)) - (define-struct eof (location)) - - (define-struct zodiac (origin start finish)) - ) - diff --git a/collects/zodiac/corelate.ss b/collects/zodiac/corelate.ss deleted file mode 100644 index 00386e98..00000000 --- a/collects/zodiac/corelate.ss +++ /dev/null @@ -1,34 +0,0 @@ -; $Id$ - -(unit/sig zodiac:correlate^ - (import zodiac:structures^) - - (define-struct entry (location slots)) - - (define make-correlator - (lambda () - (box '()))) - - (define find-in-correlator - (lambda (location correlator) - (let loop ((entries (unbox correlator))) - (if (null? entries) #f - (let ((first (car entries))) - (if (same-location? location (entry-location first)) first - (loop (cdr entries)))))))) - - (define add-to-correlator - (lambda (location slot correlator) - (let ((entry (find-in-correlator location correlator))) - (if entry - (set-entry-slots! entry (cons slot (entry-slots entry))) - (set-box! correlator - (cons (make-entry location (list slot)) - (unbox correlator))))))) - - (define same-location? - (lambda (l1 l2) - (and (= (location-offset l1) (location-offset l2)) - (equal? (location-file l1) (location-file l2))))) - - ) diff --git a/collects/zodiac/doc.txt b/collects/zodiac/doc.txt deleted file mode 100644 index 50f8e0c8..00000000 --- a/collects/zodiac/doc.txt +++ /dev/null @@ -1,894 +0,0 @@ -(#| -_Zodiac_ --------- - -Using _Zodiac_ -============== - -The top-level way: - - (require-library "invoke.ss" "zodiac") - ; binds global names prefixed with `zodiac:'; - ; zodiac:internal-error and zodiac:static-error - ; can be redefined afterwards. - -The unit/sig way: - - Elaboration time: - (require-library "zsigs.ss" "zodiac") - (require-library "sigs.ss" "zodiac") - - Link time: - (require-library-unit/sig "link.ss" "zodiac") - (require-library-unit/sig "link2.ss" "zodiac") ; see "Error Handlers" below - Imports: - zodiac:interface^ ; see "Error Handlers" below - mzlib:pretty-print^ - mzlib:file^ - Exports: - zodiac:system^ ; no `zodiac:' prefix - -Reader Procedures ------------------ - -> (zodiac:read p (zodiac:make-location 1 1 0 filename)) - reads from - the port `p', which represents the file indicated by the `filename' - string. Returns a PROCEDURE that gets each expression as a zodiac - AST. When the reader encounters an eof-of-file, it returns an - instance of zodiac:eof. - -Expander Procedures -------------------- - -> (zodiac:scheme-expand expr [attr 'previous] [vocab #f]) - expands - one expression, reprsented as a zodiac AST, returning a zodiac AST. - -> (zodiac:scheme-expand-program exprs [attr 'previous] [vocab #f]) - - expands several expressions, reprsented as a list of zodiac ASTs, - returning a list of zodiac ASTs. - -Zodiac AST -> S-Expression --------------------------- - -> (zodiac:parsed->raw expr) - converts a zodiac AST to an S-expression - (losing location information, obviously). - -Vocabularies ------------- - -> beginner-vocabulary -> intermediate-vocabulary -> advanced-vocabulary -> full-vocabulary - advanced + units and objects -> scheme-vocabulary - MzScheme (unlike full-vocabulary, local, send*, - etc. are not present until the correcponding - `define-macro' expression in MzLib is evaluated - at elaboration time) - -Handler Parameters ------------------- - -> (elaboration-evaluator [proc]) - parameter for the evaluatotr used - to evaluate begin-elaboration-time bodies and the RHS of a macro - definition. - - default: (lambda (expr parsed->raw phase) - (eval (parsed->raw expr))) - -> (user-macro-body-evaluator [proc]) - parameter for the evaluator - used to evaluate macro applications. - - default: (lambda (x . args) - (eval `(,x ,@(map (lambda (x) `(#%quote ,x)) args)))) - -Error Handlers --------------- - -There are two interfaces to the error handler procedures. Programmers -choose the one they want by using link.ss or link2.ss, as appropriate. - -Zodiac relies on two error handlers that are provided by its -> zodiac:interface^ -import: -> internal-error - for when things go wrong in zodiac that should - never go wrong -> static-error - for input errors during read or expand - -Implementors of these procedures are expected to ensure that the -procedures never return. internal-error has the same interface in -both link.ss and link2.ss: - -internal-error: where fmt-spec . args - where -- a zodiac AST - fmt-spec -- a format-style string - args -- arguments for the format string - - Sample implementation: - - (define (internal-error where fmt-spec . args) - (printf "Internal error at: ~s~n" where) ; or, pull location out of `where' - (apply error 'internal-error fmt-spec args)) - -static-error has two different interfaces. In link.ss: - -static-error: where fmt-spec . args - where -- a zodiac AST - fmt-spec -- a format-style string - args -- arguments for the format string - - Sample implementation: - - (define (static-error where fmt-spec . args) - (printf "Static error at: ~s~n" where) ; or, pull location out of `where' - (apply error 'static-error fmt-spec args)) - -In link2.ss: - -static-error: link-text link-tag source-term fmt-spec . args - link-text -- a string reporting the major information about the - error; typically, this will be turned into a hyperlink - by a user interface - link-tag -- a tag specifying the nature of the error; typically, - this will be used by the user interface to look up a - database and generate a URL for the hyperlink - fmt-spec -- a format-style string for information not in link-text - args -- arguments for the format string - - Producers of error messages assume that the information in these - arguments will be used in the following manner: - - : - - Implementors may use them in any way they wish, so long as they keep - in mind that the error producer has made the above presumption. - Producers of errors *cannot* assume that the link-tag will be used - (since the implementor may not have access to a hypertext medium), - and must therefore provide enough useful information in the - link-text and fmt-spec arguments. - - Sample implementation: - - (define (static-error link-text link-tag where fmt-spec . args) - (printf "Error at: ~s~n" where) ; or, pull location out of `where' - (apply error 'syntax-error - (string-append link-text ": " fmt-spec) - args)) - -Example -------- - - (require-library "invoke.ss" "zodiac") - (let ([r ((zodiac:read (open-input-string "(cons 1 null)") - (zodiac:make-location 1 1 0 "string")))]) - (eval (zodiac:parsed->raw (zodiac:scheme-expand r)))) - = (list 1) - - -Correlating Source ------------------- - -Quickref: - - who how principal to a source expression? - --- --- --------------------------------- - 'source ... yes - 'reader ... yes - 'duplicate ... no - 'micro expr iff expr is principal - 'macro expr iff expr is principal - 'non-source ... no - -Details: - -Zodiac's start and end locations provide a client with a mapping from -fully elaborated "E-expressions" to source S-expressions. For example, -Aries relies on the E->S mapping to hilite a specific S-expression in -response to a run-time error for a particular E-expression. Certain -tools, such as DrScheme's syntax checker, require an S->E mapping, -instead. However, the inverse of the E->S relation is not a mapping, -because E->S can map many E-expressions to one S-expression, and it -can map zero E-expressions to some S-expressions. For example, (cond -[#f 5][#t 6]) expands to (if #f 5 (if #t 6)), where the `cond' -S-expression is identified as the source of both `if' -E-expressions. Other elaborations drop an S-expression entirely, such -that an S-expression has no reprentative in the final E-expression. - -The `origin' field of an E-expression provides information -for approximating an S->E function by dropping E-expression elements -from the E->S domain before inverting the relation. More specifically, -the `origin' field identifies each E-expression as either the -principal representative of its source expression or not. Zodiac -guarantees that at most one E-expression is a principal expression for -each S-expression in the source. - -Principal E-Expressions -- - - - - - - - - - - - - -A principal E-expression is not chosen arbitrarily. In the case of -'source, 'reader, 'macro, and 'micro principals, the E-expression is -equivalent to its S-expression in the sense that it encapsulates the -entire original expression. Thus, in the elaboration from (cond [#f -5][#t 6]) to (if #f 5 (if #t 6)), the outer `if' is identified as the -principal E-expression. The inner `if' encapsulates only a part of the -original `cond' expression (and it does not encapsulate any complete -expression from the source). - -Here's a more complete dissection of a slightly larger example: - - (cond [#f 5][#t (+ 3 3)]) - => (if #f 5 (if #t (+ 3 3))) - ^ ^ ^ ^ ^ ^^ ^-^- 'reader - | | | | | |`- 'source - | | | | | `- 'source - | | | | `- 'reader - | | | `- 'non-source - | | `- 'reader - | `- 'reader - `- 'micro; the how field points to the `cond' expression, which - has a source-who value of 'source - -Macros/micros that expand to macros/micros produce chains of origin -records. For example, (or a b) expands to (let ([g a]) ...) which -expands to (let-values ([(g) a]) ...). The source for the final -`letrec-values' expression is 'macro; the source-how field points to -the `let' expression, whose source is also 'macro. Finally, the -source-how field for the `let' expression is the `or' expression, -which has a 'source origin. - -Non-principal E-Expressions -- - - - - - - - - - - - - - - -The 'duplicate who value is used when a macro/micro duplcates a source -expression in its output, such as the `loop' in `(let loop () (loop))' -=> `(letrec ([loop (lambda () (loop))]) (loop))'). All but the first -instance of the duplicated expression get a 'duplcate source-who -annotation. (The source-how field contains the original source -record.) - -The 'non-source value for the who field indicates that there is no -source expression that is equivalent to the expanded expression. In -this case, a macro or micro must have manufactured the syntax; for -example, the `this' binding intoroduced by class* -> class*/names has -source-who value 'non-source. Of course, the location field of -"non-source" syntax still matches the syntax to a particular source -expression. Similarly, the nested `if' in the expansion of `cons' -contains a manufactured `if' expression. - -Error Tags -========== - -These are the tags generated by Zodiac to report static-error's. - -Using the scheme primitive `read' on this file produces a list of lists of -symbols. The symbols are the kwd: and term: tags for the language -levels. There are nine elements in the outer list. The first five list the -common, beginning, intermediate, advanced, and full scheme language levels -kwd: tags, respectively, and the last four list the beginning intermediate, -advanced, and full scheme langauge levels term: tags. - -kwd Tags --------- - -The following tags are prefixed with "kwd:", as in, - - kwd:lambda - -They correspond exclusively to forms built into the language. - - case-lambda lambda define-internal begin-internal begin begin0 if - with-continuation-mark quote set!-values local define local-define - define-values struct define-struct define-structure let-struct let - let* delay time let-values let*-values letrec-values letrec or nor - and nand recur rec cond case evcase when unless let/cc let/ec do - fluid-let parameterize with-handlers define-macro let-macro unquote - unquote-splicing quasiquote unit compound-unit invoke-unit - signature-struct signature->symbols define-signature let-signature - unit-include unit/sig compound-unit compound-unit/sig - invoke-unit/sig unit->unit/sig define-values global-define-values - polymorphic mrspidey:control : type: define-type define-constructor - reference-file require-library require-relative-library - require-library-unit require-unit require-unit/sig - require-library-unit/sig require-relative-library-unit - require-relative-library-unit/sig interface class-private - class-inherit class-rename class-sequence class class* class*/names - ivar send send* make-generic set! define-values require-unit - require-unit/sig require-library-unit require-library-unit/sig - require-relative-library-unit require-relative-library-unit/sig - -Pre-Parsing Tags ----------------- - -> read:syntax-error - - Any syntax error during the reading phase. - -> scan:syntax-error - - Any syntax error during the scanning phase. - -term Tags ---------- - -The following tags are used to denote syntactic errors while parsing -programs. - -> term:internal-def-not-foll-by-expr - - Internal definition must be followed by an expression. A sequence - of nothing but internal definitions is invalid (since this must - translate into the letrec family, which needs a body). - -> term:duplicate-interal-def - - Each name can be defined only once internally. - -> term:case/lambda-only-in-def - - At lower language levels, procedures may only be declared - immediately within a definition. - -> term:define-internal-invalid-posn - - Not at a legal internal define position. - -> term:define-illegal-implicit-begin - - A definition body has multiple body terms. This is illegal at lower - language levels. - -> term:if-must-have-else - - At lower language levels, if's must be two-armed. - -> term:quote-not-on-symbol - - At lower language levels, quote can only be used on symbols. - -> term:struct-not-id - - The field names in a structure must be valid identifiers. - -> term:super-struct-invalid - - Invalid super-structure declaration syntax. - -> term:super-struct-not-id - - Structure name declaration not an identifier when declaring a - super-structure. - -> term:cond-else-only-in-last - - The `else' clause in a cond must be the last such clause. - -> term:cond-clause-not-in-q/a-fmt - - The cond clause is not of the proper shape. - -> term:cond-=>-not-foll-by-1-rcvr - - The => clause of a cond must be followed by one expression, which - evaluates to a receiver function. - -> term:signature-out-of-context - - A name, bound to a signature, is used a context where it isn't - legal. - -> term:keyword-out-of-context - - A name, bound to a keyword, is used in a context where it isn't - legal. - -> term:empty-combination - - Use of the empty combination. Illegal at lower language levels. - -> term:app-first-term-not-var - - First term after parenthesis is a complex expression, not a variable - reference. Illegal at lower language levels. - -> term:app-first-term-lambda-bound - - First term after parenthesis is a lambda-bound identifier. Illegal - at lower language levels. - -> term:expected-an-identifier - - Attempt to use a syntactic non-identifier in a context that expected - one. - -> term:repeated-identifier - - Attempt to use the same identifier twice in a context that allows - only unique uses. - -> term:invalid-identifier - - Attempt to use a non-identifier in an identifier context. - -> term:arglist-after-init-value-spec - - Attempt to provide arguments without initial values following - arguments that have initial values in an argument list - specification. - -> term:arglist-after-catch-all-arg - - Attempt to provide arguments after a catch-all argument. - -> term:arglist-invalid-init-value - - Attempt to provide an initial value specification in an illegal - position. - -> term:arglist-invalid-init-var-decl - - Invalid initial value specification syntax. - -> term:arglist-last-arg-no-init - - Attempt to provide an initial value in the last position of an - argument list with a catch-all argument. - -> term:arglist-invalid-syntax - - Invalid argument list syntax. - -> term:proc-arity->=-1 - - Attempt to define a procedure with arity < 1. Illegal at lower - language levels. - -> term:unit-double-export - - Attempt to export the same name twice from a signed unit. - -> term:duplicate-signature - - Attempt to duplicately define a signature's name. - -> term:unbound-sig-name - - Attempt to refer to an signature name that hasn't been bound. - -> term:signature-no-sub-unit - - Attempt to refer to a sub-unit not contained in a signature. - -> term:signature-no-var - - Attempt to refer to a name not contained in a signature. - -> term:unit-link-unbound-tag - - Attempt to use an unbound tag in a unit linkage specification. - -> term:unit-link-duplicate-tag - - Attempt to define the same link name twice. - -> term:unit-link-self-import-tag - - Attempt to create a self-import in unit linkage. - -> term:unit-link-path-malformed - - Invalid linkage path syntax. - -> term:unit-duplicate-import - - Attempt to import the same name twice. - -> term:unit-duplicate-export - - Attempt to export the same name twice. - -> term:unit-import-exported - - Attempt to export a name that has been imported. - -> term:unit-defined-imported - - Attempt to define an imported name. - -> term:unit-redefined-import - - Attempt to re-define an imported name within a unit. - -> term:unit-export-not-defined - - Attempt to export a name that has not been defined from a unit. - -> term:unit-duplicate-definition - - Attempt to define the same name twice within a unit. - -> term:signature-not-matching - - Attempt to match non-matching signatures. - -> term:signature-struct-illegal-omit-name - - Attempt to omit an invalid name from a signature. - -> term:unit-export - - Invalid unit export syntax. - -> term:c-unit-linkage - - Invalid linkage clause syntax. - -> term:c-unit-export - - Invalid export clause syntax. - -> term:c-unit-not-import - - Use of a non-imported identifier in a compound-unit linkage. - -> term:c-unit-invalid-tag - - The use of a tag in a compound-unit linkage that is not - syntactically correct. - -> term:signature-invalid-struct-omit - - An invalid structure omission specification in a signature. - -> term:signature-malformed-omit-clause - - An invalid omission specification in a signature. - -> term:signature-malformed-open-clause - - An invalid open clause in a signature. - -> term:signature-malformed-unit-clause - - An invalid unit clause in a signature. - -> term:signature-ambiguous-: - - Use of : in signature ambiguous. - -> term:no-unit-exports - - Attempt to specify sub-signatures in a signed unit's export. - -> term:invalid-pos-symbol - - Invalid symbol expression syntax. - -> term:invalid-pos-literal - - Invalid literal expression syntax. - -> term:invalid-pos-list - - Invalid list expression syntax. - -> term:invalid-pos-ilist - - Invalid improper list expression syntax. - -> term:macro-error - - Any error during the evaluation of a macro application. - -> term:invalid-ivar-decl - - Invalid instance variable declaration syntax. - -> term:invalid-ivar-clause - - Invalid instance variable declaration syntax. - -> term:set!-no-mutate-lambda-bound - - Attempt to mutate a lambda-bound variable. Illegal at lower - language levels. - -> term:no-set!-inherited/renamed - - Attempt to mutate an inherited or renamed identifier in a class. - -> term:unit-unbound-id - - Unbound identifier in a unit. - -> term:def-not-at-top-level - - Attempted internal definition. Illegal at lower language levels. - -> term:invalid-intl-defn-posn - - Internal definition in an invalid position. - -> term:cannot-bind-kwd - - Attempt to re-define a keyword, in a unit or at the top-level. - -> term:no-set!-imported - - Attempt to mutate an imported identifier in a unit. - -Tags and Language Levels -======================== - -This documents the language level at which each tag can appear. - -Misc Tags ----------- - -These tags can appear at any language level: -|#( - - read:syntax-error - scan:syntax-error - -#| - -kwd: Tags ---------- - -If these are inserted at some language level, they are automatically -present at all subsequent language levels. - - common: |# - - kwd:define-macro - kwd:let-macro - -)#| beginner: |#( - - kwd:case-lambda - kwd:lambda - kwd:if - kwd:quote - kwd:define - kwd:define-values - kwd:struct - kwd:define-struct - kwd:or - kwd:nor - kwd:and - kwd:nand - kwd:cond - kwd:require-library - kwd:require-relative-library - kwd:reference-file - kwd:polymorphic - kwd:mrspidey:control - kwd:: - kwd:type: - kwd:define-type - kwd:define-constructor - - -)#| intermediate: |#( - - kwd:local - kwd:define-structure - kwd:let-struct - kwd:let - kwd:let* - kwd:time - kwd:let-values - kwd:let*-values - kwd:letrec-values - kwd:letrec - kwd:unquote - kwd:unquote-splicing - kwd:quasiquote - - -)#| advanced: |#( - - kwd:begin - kwd:begin0 - kwd:set! - kwd:set!-values - kwd:delay - kwd:recur - kwd:rec - kwd:case - kwd:evcase - kwd:when - kwd:unless - kwd:let/cc - kwd:let/ec - kwd:do - kwd:fluid-let - kwd:parameterize - kwd:with-handlers - - -)#| full scheme: |#( - - kwd:with-continuation-mark - kwd:unit - kwd:compound-unit - kwd:invoke-unit - kwd:signature-struct - kwd:signature->symbols - kwd:define-signature - kwd:let-signature - kwd:unit-include - kwd:unit/sig - kwd:compound-unit - kwd:compound-unit/sig - kwd:invoke-unit/sig - kwd:unit->unit/sig - kwd:global-define-values - kwd:require-library-unit - kwd:require-unit - kwd:require-unit/sig - kwd:require-library-unit - kwd:require-library-unit/sig - kwd:require-relative-library-unit - kwd:require-relative-library-unit/sig - kwd:interface - kwd:class-private - kwd:class-inherit - kwd:class-rename - kwd:class-sequence - kwd:class - kwd:class* - kwd:class*/names - kwd:ivar - kwd:send - kwd:send* - kwd:make-generic -)#| -term: Tags ---------- - -term tags are not automatically inherited by advanced levels, since -they sometimes designate an error corresponding to a restriction at a -certainl language level. Thus, the tags are explicitly listed for -each level at which they occur. Paradoxically, a tag can appear in a -more advanced level but not in a less advanced one. This is typically -because the advanced level has introduced or activated a feature not -allowed in a lower level (where an attempt to use it might merely -result in a syntax error), and its misuse is flagged by this tag. - -do not occur (fallbacks that are never fallen back to): - - invalid-pos-symbol - invalid-pos-literal - invalid-pos-list - invalid-pos-ilist - - - beginner: |#( - - term:internal-def-not-foll-by-expr ;; * - term:duplicate-interal-def ;; * - term:case/lambda-only-in-def - term:define-internal-invalid-posn ;; * - term:define-illegal-implicit-begin - term:if-must-have-else - term:quote-not-on-symbol - term:cond-else-only-in-last - term:cond-clause-not-in-q/a-fmt - term:cond-=>-not-foll-by-1-rcvr - term:keyword-out-of-context - term:empty-combination - term:app-first-term-not-var - term:app-first-term-lambda-bound - term:expected-an-identifier - term:repeated-identifier - term:invalid-identifier - term:proc-arity->=-1 - term:set!-no-mutate-lambda-bound ;; * - term:def-not-at-top-level - term:cannot-bind-kwd - term:macro-error - -)#| intermediate: |#( - - term:internal-def-not-foll-by-expr ;; * - term:duplicate-interal-def ;; * - term:define-internal-invalid-posn ;; * - term:define-illegal-implicit-begin - term:if-must-have-else - term:cond-else-only-in-last - term:cond-clause-not-in-q/a-fmt - term:cond-=>-not-foll-by-1-rcvr - term:keyword-out-of-context - term:empty-combination - term:app-first-term-not-var - term:app-first-term-lambda-bound - term:expected-an-identifier - term:repeated-identifier - term:invalid-identifier - term:proc-arity->=-1 - term:set!-no-mutate-lambda-bound ;; * - term:def-not-at-top-level - term:cannot-bind-kwd - term:macro-error - - -)#| advanced: |#( - - term:internal-def-not-foll-by-expr ;; * - term:duplicate-interal-def ;; * - term:define-internal-invalid-posn ;; * - term:struct-not-id - term:super-struct-invalid - term:super-struct-not-id - term:cond-else-only-in-last - term:cond-clause-not-in-q/a-fmt - term:cond-=>-not-foll-by-1-rcvr - term:keyword-out-of-context - term:empty-combination - term:expected-an-identifier - term:repeated-identifier - term:invalid-identifier - term:def-not-at-top-level - term:cannot-bind-kwd - term:macro-error - - -)#| full scheme: |#( - - term:internal-def-not-foll-by-expr - term:duplicate-interal-def - term:define-internal-invalid-posn - term:struct-not-id - term:super-struct-invalid - term:super-struct-not-id - term:cond-else-only-in-last - term:cond-=>-not-foll-by-1-rcvr - term:keyword-out-of-context - term:expected-an-identifier - term:repeated-identifier - term:invalid-identifier - term:signature-out-of-context - term:unit-double-export - term:duplicate-signature - term:unbound-sig-name - term:signature-no-sub-unit - term:signature-no-var - term:unit-link-unbound-tag - term:unit-link-duplicate-tag - term:unit-link-self-import-tag - term:unit-link-path-malformed - term:unit-duplicate-import - term:unit-duplicate-export - term:unit-import-exported - term:unit-defined-imported - term:unit-redefined-import - term:unit-export-not-defined - term:unit-duplicate-definition - term:signature-not-matching - term:signature-struct-illegal-omit-name - term:unit-export - term:c-unit-linkage - term:c-unit-export - term:c-unit-not-import - term:c-unit-invalid-tag - term:signature-invalid-struct-omit - term:signature-malformed-omit-clause - term:signature-malformed-open-clause - term:signature-malformed-unit-clause - term:signature-ambiguous-: - term:no-unit-exports - term:no-set!-inherited/renamed - term:no-set!-imported - term:unit-unbound-id - term:arglist-after-init-value-spec - term:arglist-after-catch-all-arg - term:arglist-invalid-init-value - term:arglist-invalid-init-var-decl - term:arglist-last-arg-no-init - term:arglist-invalid-syntax - term:invalid-ivar-decl - term:invalid-ivar-clause - term:invalid-intl-defn-posn - term:cannot-bind-kwd - term:macro-error -)) \ No newline at end of file diff --git a/collects/zodiac/info.ss b/collects/zodiac/info.ss deleted file mode 100644 index e6c4e56d..00000000 --- a/collects/zodiac/info.ss +++ /dev/null @@ -1,13 +0,0 @@ - -(lambda (request failure) - (case request - [(name) "zodiac"] - [(compile-prefix) '(begin - (require-library "refer.ss") - (require-library "zsigs.ss" "zodiac") - (require-library "sigs.ss" "zodiac"))] - [(compile-omit-files) - (list "sigs.ss" "zsigs.ss" "scm-hanc.ss" "quasi.ss")] - [(compile-elaboration-zos) - (list "zsigs.ss" "sigs.ss")] - [else (failure)])) diff --git a/collects/zodiac/invoke.ss b/collects/zodiac/invoke.ss deleted file mode 100644 index 450283e3..00000000 --- a/collects/zodiac/invoke.ss +++ /dev/null @@ -1,94 +0,0 @@ -; $Id: invoke.ss,v 1.42 2000/05/28 03:47:30 shriram Exp $ - -(begin-elaboration-time - (require-library "cores.ss")) - -(require-library "coreu.ss") - -(require-library "load.ss" "zodiac") - -(define zodiac:default-interface@ - (unit/sig zodiac:interface^ - (import) - (define internal-error - (lambda (where fmt-spec . args) - (printf "Error at: ~s~n" where) - (apply error 'internal-error fmt-spec args))) - (define (static-error link-text link-tag where fmt-spec . args) - (printf "Error tag: ~s~n" link-tag) - (printf "Error at: ~s~n" where) - (apply error 'static-error - (string-append link-text ": " fmt-spec) - args)))) - -(define zodiac:system@ - (require-library-unit/sig "link2.ss" "zodiac")) - -(begin-elaboration-time - (require-library "invoke.ss")) - -(define-values/invoke-unit/sig ((open zodiac:system^) - (open zodiac:interface^)) - (compound-unit/sig - (import) - (link - (INTERFACE : zodiac:interface^ - (zodiac:default-interface@)) - (SYSTEM : zodiac:system^ - (zodiac:system@ INTERFACE - (MZLIB-CORE pretty-print) - (MZLIB-CORE file))) - (MZLIB-CORE : mzlib:core^ - (mzlib:core@))) - (export (open SYSTEM) (open INTERFACE))) - zodiac) - -(define (zodiac:make-see expander) - (opt-lambda ((show-raw? #t)) - (parameterize ([current-prompt-read - (lambda () - (newline) - (display "e> ") - (flush-output) - (let ([read ((zodiac:read))]) - (newline) - (flush-output) - (if (zodiac:eof? read) - eof - read)))] - [current-eval - (lambda (in) - (let ((e (car (expander in)))) - (if show-raw? - (zodiac:parsed->raw e) - e)))]) - (read-eval-print-loop)))) - -(define zodiac:see - (zodiac:make-see - (lambda (in) - (zodiac:scheme-expand-program (list in))))) - -(define zodiac:see-parsed - (lambda () - ((zodiac:make-see - (lambda (in) - (zodiac:scheme-expand-program (list in)))) - #f))) - -(define zodiac:see - (opt-lambda ((print-as-sexp? #t) (vocab zodiac:scheme-vocabulary)) - ((zodiac:make-see - (lambda (in) - (zodiac:scheme-expand-program - (list in) - (zodiac:make-attributes) - vocab))) - print-as-sexp?))) - -(define zodiac:spidey-see (zodiac:make-see - (lambda (in) - (zodiac:scheme-expand-program - (list in) - (zodiac:make-attributes) - zodiac:mrspidey-vocabulary)))) diff --git a/collects/zodiac/link.ss b/collects/zodiac/link.ss deleted file mode 100644 index 6a83aca9..00000000 --- a/collects/zodiac/link.ss +++ /dev/null @@ -1,30 +0,0 @@ -; $Id: link.ss,v 1.17 2000/01/02 23:28:25 robby Exp $ - -(compound-unit/sig - (import - (INTERFACE : zodiac:interface^) - (PRETTY : mzlib:pretty-print^) - (MZLIB-FILE : mzlib:file^)) - (link - [NEW-INTERFACE : zodiac:interface^ - ((unit/sig zodiac:interface^ - (import (real : zodiac:interface^)) - (define static-error - (case-lambda - [(link-text link-tag source-term fmt-spec . args) - (apply real:static-error - source-term - (string-append link-text ": " fmt-spec) - args)] - [(where fmt-spec . args) - (real:internal-error where - "static-error interface has changed: called with ~s, ~s" - fmt-spec args)])) - (define internal-error real:internal-error)) - INTERFACE)] - [REAL-LINKER : zodiac:system^ - ((require-relative-library-unit/sig "link2.ss") - NEW-INTERFACE - PRETTY - MZLIB-FILE)]) - (export (open REAL-LINKER))) diff --git a/collects/zodiac/link2.ss b/collects/zodiac/link2.ss deleted file mode 100644 index d36be821..00000000 --- a/collects/zodiac/link2.ss +++ /dev/null @@ -1,80 +0,0 @@ -; $Id: link.ss,v 1.17 2000/01/02 23:28:25 robby Exp $ - -(compound-unit/sig - (import - (INTERFACE : zodiac:interface^) - (PRETTY : mzlib:pretty-print^) - (MZLIB-FILE : mzlib:file^)) - (link - [MISC : zodiac:misc^ - ((require-relative-library-unit/sig "misc.ss") PRETTY)] - [TOP-STRUCTS : zodiac:structures^ - ((require-relative-library-unit/sig "basestr.ss"))] - [SCAN-STRUCTS : zodiac:scanner-structs^ - ((require-relative-library-unit/sig "scanstr.ss") - TOP-STRUCTS)] - [READ-STRUCTS : zodiac:reader-structs^ - ((require-relative-library-unit/sig "readstr.ss") - TOP-STRUCTS)] - [SCAN-PARMS : zodiac:scanner-parameters^ - ((require-relative-library-unit/sig "scanparm.ss") - TOP-STRUCTS)] - [SCAN-CODE : zodiac:scanner-code^ - ((require-relative-library-unit/sig "scanner.ss") - TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS - SCAN-PARMS INTERFACE)] - [READ-CODE : zodiac:reader-code^ - ((require-relative-library-unit/sig "reader.ss") - TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS - SCAN-PARMS INTERFACE SCAN-CODE)] - [SEXP : zodiac:sexp^ - ((require-relative-library-unit/sig "sexp.ss") - MISC TOP-STRUCTS READ-STRUCTS INTERFACE - SCHEME-MAIN)] - [PATTERN : zodiac:pattern^ - ((require-relative-library-unit/sig "pattern.ss") - MISC SEXP READ-STRUCTS SCHEME-CORE)] - [EXPANDER : zodiac:expander^ - ((require-relative-library-unit/sig "x.ss") - MISC SEXP TOP-STRUCTS READ-STRUCTS - SCHEME-CORE INTERFACE)] - [CORRELATE : zodiac:correlate^ - ((require-relative-library-unit/sig "corelate.ss") - TOP-STRUCTS)] - [BACK-PROTOCOL : zodiac:back-protocol^ - ((require-relative-library-unit/sig "back.ss") - MISC INTERFACE)] - [SCHEME-CORE : zodiac:scheme-core^ - ((require-relative-library-unit/sig "scm-core.ss") - TOP-STRUCTS MISC SEXP READ-STRUCTS - BACK-PROTOCOL EXPANDER INTERFACE PATTERN)] - [SCHEME-MAIN : zodiac:scheme-main^ - ((require-relative-library-unit/sig "scm-main.ss") - MISC TOP-STRUCTS SCAN-PARMS - READ-STRUCTS READ-CODE SEXP - PATTERN SCHEME-CORE BACK-PROTOCOL EXPANDER INTERFACE)] - [SCHEME-SPIDEY : zodiac:scheme-mrspidey^ - ((require-relative-library-unit/sig "scm-spdy.ss") - MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP PATTERN - SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE - MZLIB-FILE)] - [SCHEME-OBJ : zodiac:scheme-objects^ - ((require-relative-library-unit/sig "scm-obj.ss") - MISC TOP-STRUCTS READ-STRUCTS SEXP - PATTERN SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE)] - [SCHEME-UNIT : zodiac:scheme-units^ - ((require-relative-library-unit/sig "scm-unit.ss") - MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP - PATTERN SCHEME-CORE SCHEME-MAIN SCHEME-OBJ BACK-PROTOCOL EXPANDER INTERFACE)] - [SCHEME-OBJ+UNIT : zodiac:scheme-objects+units^ - ((require-relative-library-unit/sig "scm-ou.ss") - MISC TOP-STRUCTS READ-STRUCTS SEXP PATTERN EXPANDER INTERFACE - SCHEME-CORE SCHEME-MAIN SCHEME-OBJ SCHEME-UNIT)]) - (export (open TOP-STRUCTS) (open SCAN-PARMS) - (open READ-STRUCTS) (open READ-CODE) - (open SEXP) (open PATTERN) (open CORRELATE) (open BACK-PROTOCOL) - (open EXPANDER) - (open SCHEME-CORE) (open SCHEME-MAIN) - (open SCHEME-OBJ) (open SCHEME-UNIT) - (open SCHEME-OBJ+UNIT) - (open SCHEME-SPIDEY))) diff --git a/collects/zodiac/load.ss b/collects/zodiac/load.ss deleted file mode 100644 index 02c9f990..00000000 --- a/collects/zodiac/load.ss +++ /dev/null @@ -1,12 +0,0 @@ -; $Id: load.ss,v 1.20 1998/04/21 02:59:55 robby Exp $ - -(require-library "macro.ss") -(require-library "cores.ss") - -(require-library "zsigs.ss" "zodiac") -(require-library "sigs.ss" "zodiac") - -; All this stuff needs to be disappeared. - -(define zodiac:system@ - (require-library-unit/sig "link.ss" "zodiac")) diff --git a/collects/zodiac/make.ss b/collects/zodiac/make.ss deleted file mode 100644 index 63c9db93..00000000 --- a/collects/zodiac/make.ss +++ /dev/null @@ -1,27 +0,0 @@ -; $Id$ - -(printf "Loading ...~n") -(load "invoke.ss") - -(require-library "compile.ss") - -(define file-names - '("corelate" "invoke" "link" "misc" "pattern" "back" - "scm-core" "scm-main" "scm-obj" "scm-unit" "scm-ou" "scm-spdy" - "sexp" "sigs" "x" "zsigs" "basestr" "readstr" "reader" - "scanner" "scanparm" "scanstr")) - -(printf "Deleting ...~n") -(for-each (lambda (f) - (delete-file (string-append f ".zo"))) - file-names) - -(for-each (lambda (f) - (printf "Compiling ~a~n" f) - (compile-file (string-append f ".ss") - (string-append f ".zo"))) - file-names) - -(printf "Done!~n") - -(exit) diff --git a/collects/zodiac/misc.ss b/collects/zodiac/misc.ss deleted file mode 100644 index eefce6fd..00000000 --- a/collects/zodiac/misc.ss +++ /dev/null @@ -1,46 +0,0 @@ -; $Id: misc.ss,v 1.8 1998/03/15 00:08:15 mflatt Exp $ - -(unit/sig zodiac:misc^ - (import (mz-pp : mzlib:pretty-print^)) - - (define attributes-resetters - (let ([x null]) - (case-lambda - [() x] - [(y) (set! x y)]))) - - ; This is to get around an ordering problem. Otherwise uses of - ; pretty-print show up as #, since this pretty-print - ; captures the MzScheme pretty-print too soon. - - (define pretty-print - (lambda args - (apply mz-pp:pretty-print args))) - - (define debug-level-list '(expand expose resolve lex-res)) - (define debug-level '()) - - (define symbol-append - (lambda args - (string->symbol - (apply string-append - (map (lambda (s) - (cond - ((string? s) s) - ((symbol? s) (symbol->string s)) - ((number? s) (number->string s)) - (else - (error 'symbol-append "~s illegal" s)))) - args))))) - - (define flush-printf - (lambda (format . args) - (apply printf format args) - (flush-output))) - - (define print-and-return - (lambda (v) - (pretty-print v) (newline) - v)) - - ) diff --git a/collects/zodiac/pattern.ss b/collects/zodiac/pattern.ss deleted file mode 100644 index 683bf728..00000000 --- a/collects/zodiac/pattern.ss +++ /dev/null @@ -1,151 +0,0 @@ -; $Id: pattern.ss,v 1.5 1998/05/08 22:15:22 mflatt Exp $ - -; Uses of memq are okay, since they look up pattern var in kwd list - -; Use of equal? WILL FAIL! - -(unit/sig zodiac:pattern^ - (import zodiac:misc^ zodiac:sexp^ - (z : zodiac:reader-structs^) zodiac:scheme-core^) - - (define (syntax-andmap pred l) - (andmap pred (expose-list l))) - - (define (syntax-ormap pred l) - (ormap pred (expose-list l))) - - ; ---------------------------------------------------------------------- - - (define make-match&env - (lambda (p k) ; pattern x kwd - (letrec - ((m&e - (lambda (p) - (cond - ((ellipsis? p) - (let ((p-head (car p))) - (let ((nestings (get-ellipsis-nestings p-head k))) - (let ((match-head (m&e p-head))) - (lambda (e esc env) - (if (z:list? e) - (list (cons nestings - (map (lambda (e) (match-head e esc env)) - (expose-list e)))) - (esc #f))))))) - ((pair? p) - (let ((match-head (m&e (car p))) - (match-tail (m&e (cdr p)))) - (lambda (e esc env) - (if (or (and (z:list? e) - (not (syntax-null? e))) - (z:improper-list? e)) - (append (match-head (syntax-car e) esc env) - (match-tail (syntax-cdr e) esc env)) - (esc #f))))) - ((null? p) - (lambda (e esc env) - (if (syntax-null? e) '() (esc #f)))) - ((symbol? p) - (if (memq p k) - (lambda (e esc env) - (if (z:symbol? e) - (if (lexically-resolved? e env) - (esc #f) - (if (name-eq? p (z:read-object e)) - '() - (esc #f))) - (esc #f))) - (lambda (e esc env) - (list (cons p e))))) - (else - (lambda (e esc env) - (if (equal? p e) '() (esc #f)))))))) - (m&e p)))) - - (define match-against - (lambda (matcher e env) - (let/ec esc - (matcher e esc env)))) - - (define penv-merge append) - - (define extend-penv - (lambda (name output env) - (cons (cons name output) env))) - - ; ---------------------------------------------------------------------- - - (define pexpand - (lambda (p r k) ; pattern x p-env x kwd - (letrec - ((expander - (lambda (p r) - (cond - ((ellipsis? p) - (append - (let* ((p-head (car p)) - (nestings (get-ellipsis-nestings p-head k)) - (rr (ellipsis-sub-envs nestings r))) - (map (lambda (r1) - (expander p-head (append r1 r))) - rr)) - (expander (cddr p) r))) - ((pair? p) - (cons (expander (car p) r) - (expander (cdr p) r))) - ((symbol? p) - (if (memq p k) p - (let ((x (assq p r))) - (if x (cdr x) p)))) - (else p))))) - (expander p r)))) - -;;; returns a list that nests a pattern variable as deeply as it -;;; is ellipsed - (define get-ellipsis-nestings - (lambda (p k) - (let sub ((p p)) - (cond ((ellipsis? p) (list (sub (car p)))) - ((pair? p) (append (sub (car p)) (sub (cdr p)))) - ((symbol? p) (if (memq p k) '() (list p))) - (else '()))))) - -;;; finds the subenvironments in r corresponding to the ellipsed -;;; variables in nestings - (define ellipsis-sub-envs - (lambda (nestings r) - (ormap (lambda (c) - (if (contained-in? nestings (car c)) (cdr c) #f)) - r))) - -;;; checks if nestings v and y have an intersection - (define contained-in? - (lambda (v y) - (if (or (symbol? v) (symbol? y)) (eq? v y) - (ormap (lambda (v_i) - (ormap (lambda (y_j) - (contained-in? v_i y_j)) - y)) - v)))) - -;;; tests if x is an ellipsing pattern, i.e., of the form -;;; (blah ... . blah2) - (define ellipsis? - (lambda (x) - (and (pair? x) (pair? (cdr x)) (eq? (cadr x) '...)))) - - ; ---------------------------------------------------------------------- - - (define match-and-rewrite - (case-lambda - ((expr rewriter out kwd env) - (let ((p-env (match-against rewriter expr env))) - (and p-env - (pexpand out p-env kwd)))) - ((expr rewriter out kwd succeed fail env) - (let ((p-env (match-against rewriter expr env))) - (if p-env - (succeed (pexpand out p-env kwd)) - (fail)))))) - - ) diff --git a/collects/zodiac/quasi.ss b/collects/zodiac/quasi.ss deleted file mode 100644 index 466634e9..00000000 --- a/collects/zodiac/quasi.ss +++ /dev/null @@ -1,125 +0,0 @@ -; $Id: quasi.ss,v 1.10 1999/06/13 21:41:25 mflatt Exp $ - -; Fix the null? in qq-normalize. - -(define qq-normalize - (lambda (new old) - (if (eq? new old) - (if (and (z:list? new) (zero? (z:sequence-length new))) - 'null - (list '#%quote new)) - new))) - -(define qq-process - (lambda (e source env attributes vocab) - (expand-expr - (structurize-syntax e source) - env attributes vocab))) - -(define quasiquote-micro - (let* ((kwd '()) - (in-pattern '(_ template)) - (m&e (pat:make-match&env in-pattern kwd)) - (qq-pattern-1 '(unquote body)) - (qq-pattern-2 '(unquote x ...)) - (qq-pattern-3 '(quasiquote x ...)) - (qq-pattern-4 '(unquote-splicing x ...)) - (qq-pattern-5 '((unquote-splicing body) . rest)) - (qq-pattern-6 '((unquote-splicing x ...) . y)) - (qq-m&e-1 (pat:make-match&env qq-pattern-1 '(unquote))) - (qq-m&e-2 (pat:make-match&env qq-pattern-2 '(unquote))) - (qq-m&e-3 (pat:make-match&env qq-pattern-3 '(quasiquote))) - (qq-m&e-4 (pat:make-match&env qq-pattern-4 '(unquote-splicing))) - (qq-m&e-5 (pat:make-match&env qq-pattern-5 '(unquote-splicing))) - (qq-m&e-6 (pat:make-match&env qq-pattern-6 '(unquote-splicing)))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((template (pat:pexpand 'template p-env kwd))) - (qq-process - (qq-normalize - (let qq ((x template) - (level 0)) - (let ((qq-list (lambda (x level) - (let* ((old-first (syntax-car x)) - (old-rest (syntax-cdr x)) - (first (qq old-first level)) - (rest (qq old-rest level))) - (if (and (eq? first old-first) - (eq? rest old-rest)) - x - (list '#%cons - (qq-normalize first old-first) - (qq-normalize rest old-rest))))))) - (cond - ((and (or (z:list? x) (z:improper-list? x)) - (not (zero? (z:sequence-length x)))) - (cond - ((pat:match-against qq-m&e-1 x env) - => - (lambda (p-env) - (let ((body (pat:pexpand 'body p-env kwd))) - (if (zero? level) - body - (qq-list x (sub1 level)))))) - ((pat:match-against qq-m&e-2 x env) - (static-error - "unquote" 'kwd:unquote x - "takes exactly one expression")) - ((pat:match-against qq-m&e-3 x env) - (qq-list x (add1 level))) - ((pat:match-against qq-m&e-4 x env) - (static-error - "unquote-splicing" 'kwd:unquote-splicing x - "invalid context inside quasiquote")) - ((pat:match-against qq-m&e-5 x env) - => - (lambda (p-env) - (let* ((body (pat:pexpand 'body p-env kwd)) - (rest (pat:pexpand 'rest p-env kwd)) - (q-rest (qq rest level))) - (if (zero? level) - (list '#%append body - (qq-normalize q-rest rest)) - (let ((q-body (qq body (sub1 level)))) - (if (and (eq? q-rest rest) - (eq? q-body body)) - x - (list '#%cons - (list '#%cons - (list '#%quote 'unquote-splicing) - (list '#%cons - (qq-normalize q-body body) - '())) - (qq-normalize q-rest rest)))))))) - ((pat:match-against qq-m&e-6 x env) - (static-error - "unquote-splicing" 'kwd:unquote-splicing x - "takes exactly one expression")) - (else - (qq-list x level)))) - ((z:vector? x) - (let* ((v (structurize-syntax (z:read-object x) x)) - (qv (qq v level))) - (if (eq? v qv) - x - (list '#%list->vector qv)))) - ((z:box? x) - (let* ((b (z:read-object x)) - (qb (qq b level))) - (if (eq? b qb) - x - (list '#%box qb)))) - (else - x)))) - template) - expr env attributes vocab)))) - (else - (static-error - "quasiquote" 'kwd:quasiquote expr "malformed expression")))))) - -(add-primitivized-micro-form 'quasiquote intermediate-vocabulary quasiquote-micro) -(add-primitivized-micro-form 'quasiquote scheme-vocabulary quasiquote-micro) - diff --git a/collects/zodiac/reader.ss b/collects/zodiac/reader.ss deleted file mode 100644 index 85ab7390..00000000 --- a/collects/zodiac/reader.ss +++ /dev/null @@ -1,384 +0,0 @@ -;; -;; zodiac:reader-code@ -;; $Id: reader.ss,v 1.7 1999/03/12 17:22:30 mflatt Exp $ -;; -;; Zodiac Reader July 96 -;; mwk, plt group, Rice university. -;; -;; The Reader returns one of three struct types: -;; -;; scalar (symbol, number, string, boolean, char) -;; sequence (list, vector, improper-list) -;; eof - -(unit/sig zodiac:reader-code^ - - (import - zodiac:structures^ - zodiac:scanner-structs^ - (zodiac : zodiac:reader-structs^) - zodiac:scanner-parameters^ - (report : zodiac:interface^) - zodiac:scanner-code^) - - ;; rename some things for now. will clean this up. - - (define paren-relation scan:paren-relation) - (define def-init-loc default-initial-location) - (define def-first-col scan:def-first-col) - - - (define default-vector-object - (lambda (start finish) - (zodiac:make-number - (make-origin 'reader 'vector) - start finish 0))) - - (define my-make-list - (lambda (len elt) - (let loop ([n 0] [l null]) - (if (= n len) l - (loop (+ n 1) (cons elt l)))))) - - (define paren-rel paren-relation) - - ;; Need to subdivide z:token with vector and sized-vector. - ;; Then object only has the paren, and size is separate. - - (define match? - (lambda (t1 t2) - (let ([c1 (token-object t1)] - [c2 (token-object t2)]) - (member (list (if (char? c1) c1 (cadr c1)) - c2) - paren-rel)))) - - (define z:endseq? - (lambda (obj) - (and (token? obj) - (eq? (token-type obj) 'endseq)))) - - (define read-origin - (lambda (how) - (make-origin 'reader how))) - - (define z:r-s-e - (lambda args - (apply report:static-error - "syntax error" - 'read:syntax-error - args))) - - (define z:int-error (lambda x (apply report:internal-error x))) - - ;; pack-quote into zodiac structure. - ;; ,@ --> ( unquote-splicing ) - ;; 12 3 4 1 1 2 3 4 4 - - (define pack-quote - (lambda (type token obj) - (let ([one (zodiac-start token)] - [two (zodiac-finish token)] - [four (zodiac-finish obj)]) - (zodiac:make-list - (read-origin type) one four - (list - (zodiac:make-symbol - (read-origin type) one two - type type '(-1)) - obj) - 2 '())))) - - ;; pack-box into zodiac structure. - ;; #& --> (z:box origin start finish ) - ;; 12 3 4 1 4 - - (define pack-box - (lambda (box obj) - (let ([one (zodiac-start box)] - [four (zodiac-finish obj)]) - (zodiac:make-box (read-origin 'box) one four obj)))) - - ;; pack-seqn combines pack-list, -vector - - (define pack-seqn - (lambda (z:maker) - (lambda (open-token close-token head len) - (z:maker - (zodiac-origin open-token) - (zodiac-start open-token) - (zodiac-finish close-token) - head - len)))) - - (define pack-list (pack-seqn (lambda (orig open close head len) - (zodiac:make-list orig open close - head len '())))) - (define pack-vector (pack-seqn zodiac:make-vector)) - - (define allow-improper-lists (make-parameter #t)) - (define allow-reader-quasiquote (make-parameter #t)) - - (define (dot-err s) - (if (allow-improper-lists) - s - "misuse of `.' (improper lists are not allowed)")) - - (define pack-imp-list - (lambda (open-token close-token head len dot) - (let ([obj (zodiac:make-improper-list - (zodiac-origin open-token) - (zodiac-start open-token) - (zodiac-finish close-token) - head len dot '())]) - (if (allow-improper-lists) - obj - (z:r-s-e obj (dot-err "")))))) - - ;; convert (a . (b . ())) ==> (a b) if parameter set - ;; and obj after dot is list or imp-list. - ;; REPLACE #f in cond with (not compact-imp-list-parameter). - - (define compact-imp-list - (lambda (open-token close-token head len dot before-dot after-dot) - (cond - [#f (pack-imp-list open-token close-token head len dot)] - [(zodiac:list? after-dot) - (set-cdr! before-dot (zodiac:read-object after-dot)) - (pack-list - open-token - close-token - head - (+ len (zodiac:sequence-length after-dot) -1))] - [(zodiac:improper-list? after-dot) - (set-cdr! before-dot (zodiac:read-object after-dot)) - (pack-imp-list - open-token - close-token - head - (+ len (zodiac:sequence-length after-dot) -1) - (zodiac:improper-list-period after-dot))] - [else (pack-imp-list open-token close-token head len dot)]))) - - - (define read - (opt-lambda - ([port (current-input-port)] - [init-loc def-init-loc] - [skip-script #t] - [first-col def-first-col]) - - (let* - ([get-token (scan port init-loc skip-script first-col)]) - - ;; read-obj returns one of: - ;; z:read zodiac object (scalar or sequence) - ;; z:token (type 'endseq) for close paren - ;; z:period - ;; z:eof - - (letrec - ([read-obj - (lambda () - (let ([token (get-token)]) - (cond - [(zodiac:scalar? token) token] - [(token? token) - (let ([type (token-type token)]) - (cond - [(eq? type 'endseq) token] - [(eq? type 'list) - (read-seqn type token pack-list)] - [(eq? type 'vector) - (read-seqn type token pack-vector)] - [(eq? type 'sized-vector) - (read-seqn type token finish-vector)] - [(or (eq? type 'quote) - (eq? type 'quasiquote) - (eq? type 'unquote) - (eq? type 'unquote-splicing)) - (unless (or (eq? type 'quote) - (allow-reader-quasiquote)) - (z:r-s-e token - (format "illegal use of \"~a\"" - (case type - [(quasiquote) "`"] - [(unquote) ","] - [else ",@"])))) - (read-quote type token)] - [(eq? type 'period) - (make-period (zodiac-start token))] - [(eq? type 'box) (read-box token)] - [(or (eq? type 'circular-obj) - (eq? type 'circular-ref)) - (z:r-s-e token - "circular objects are not implemented")] - [else - (z:int-error token - "unknown scanner token type: ~s" type)]))] - [(eof? token) token] - [else - (z:int-error token "unknown scanner object")])))] - - - ;; read-seqn combines read-list, -vector, -imp-list - ;; type = 'list, 'vector, 'improper-list - ;; token = z:token for (, #(, #nn( ;; ))) - ;; end-fcn = fcn to call when get close paren. - ;; sent = sentinel to simplify making list. - ;; p = last item in list, before obj. - - [read-seqn - (lambda (type token end-fcn) - (let ([sent (cons #f null)]) - (let loop ([p sent] [len 0]) - (let ([obj (read-obj)]) - (cond - [(zodiac:read? obj) - (set-cdr! p (cons obj null)) - (loop (cdr p) (+ len 1))] - [(z:endseq? obj) - (if (match? token obj) - (if (eq? type 'sized-vector) - (finish-vector token obj (cdr sent) p len) - (end-fcn token obj (cdr sent) len)) - (z:r-s-e obj - "close paren does not match open paren"))] - [(period? obj) - (if (eq? type 'list) - (if (= len 0) - (z:r-s-e obj - (dot-err "can't put `.' as first item in list")) - (finish-imp-list token obj (cdr sent) p len)) - (z:r-s-e obj (dot-err "can't use `.' inside vector")))] - [(eof? obj) - (z:r-s-e token "missing close paren")] - [else - (z:int-error obj "unknown reader object")])))))] - - - ;; read-improper-list - ;; exactly one object after dot, then close paren. - ;; p = item before dot. - ;; obj = item after dot (or else error). - ;; obj2 = close paren (or else error). - - [finish-imp-list - (lambda (token dot head p len) - (unless (allow-improper-lists) - (z:r-s-e dot (dot-err ""))) - (let ([obj (read-obj)]) - (cond - [(zodiac:read? obj) - (let ([obj2 (read-obj)]) - (cond - [(z:endseq? obj2) - (if (match? token obj2) - (begin - (set-cdr! p (cons obj null)) - (compact-imp-list token obj2 head (+ len 1) dot p obj)) - (z:r-s-e obj2 - "close paren does not match open paren"))] - [(zodiac:read? obj2) - (z:r-s-e obj2 "too many elements after `.'")] - [(period? obj2) - (z:r-s-e obj2 "can't have two `.'s in a list")] - [(eof? obj2) - (z:r-s-e obj2 "missing close paren")] - [else - (z:int-error obj2 "Unknown reader object")]))] - [(period? obj) - (z:r-s-e obj "can't have two `.'s in a list")] - [(z:endseq? obj) - (z:r-s-e obj "must put one object after `.' in list")] - [(eof? obj) - (z:r-s-e token "missing close paren")] - [else - (z:int-error obj "unknown reader object")])))] - - - ;; finish sized-vectors - ;; compare size with actual number of elements, - ;; and pad or complain as necessary. - ;; object in open-token = (size char) - - [finish-vector - (lambda (open-token close-token head tail len) - (let ([size (car (token-object open-token))]) - (cond - [(= len size) - (pack-vector open-token close-token head len)] - [(= len 0) - (let ([obj (default-vector-object - (zodiac-finish open-token) - (zodiac-finish close-token))]) - (pack-vector open-token close-token - (my-make-list size obj) size))] - [(< len size) - (let* ([last-obj (car tail)] - [p (my-make-list (- size len) last-obj)]) - (set-cdr! tail p) - (pack-vector open-token close-token head size))] - [else - (z:r-s-e open-token - "too many elements in vector constant")])))] - - - ;; read-quote ' --> (quote ) - ;; can only quote reader-objs, not dot, close paren, eof. - ;; quote-type is the symbol quote, unquote, ... (kludge!) - - [read-quote - (lambda (quote-type quote-token) - (let ([obj (read-obj)]) - (if (zodiac:read? obj) - (pack-quote quote-type quote-token obj) - (box/quote-error quote-type quote-token obj))))] - - ;; read-box #& --> (box (quote )) - ;; can only box reader-objs, not dot, close paren, eof. - - [read-box - (lambda (box-token) - (let ([obj (read-obj)]) - (if (zodiac:read? obj) - (pack-box box-token obj) - (box/quote-error 'box box-token obj))))] - - ;; Can't put dot, close paren, eof after box or quote. - ;; type = symbol box, quote, unquote, ... - ;; token = box or quote z:token. - ;; obj = bad object after box/quote. - - [box/quote-error - (lambda (type token obj) - (cond - [(eof? obj) - (z:r-s-e token "missing object after ~a" type)] - [(period? obj) - (z:r-s-e obj "can't put `.' after ~a" type)] - [(z:endseq? obj) - (z:r-s-e obj "can't put close paren after ~a" type)] - [else - (z:int-error obj "unknown reader object")]))] - - ;; read-top-level returns the next scheme object and - ;; complains if dot or close paren is outside a list. - ;; close paren is in z:token with type 'endseq. - - [read-top-level - (lambda () - (let ([obj (read-obj)]) - (cond - [(or (zodiac:read? obj) (eof? obj)) obj] - [(period? obj) - (z:r-s-e obj (dot-err "can't use `.' outside list"))] - [(z:endseq? obj) - (z:r-s-e obj "too many close parens")] - [else - (z:int-error obj "Unknown reader object")])))] - ) - read-top-level)))) - - ) - diff --git a/collects/zodiac/readstr.ss b/collects/zodiac/readstr.ss deleted file mode 100644 index 95854435..00000000 --- a/collects/zodiac/readstr.ss +++ /dev/null @@ -1,44 +0,0 @@ -;; -;; zodiac:reader-structs@ -;; $Id$ -;; -;; Reader's subtree of the hierarchy. -;; -;; zodiac (origin start finish) -;; read (object) -;; scalar -;; symbol (orig-name marks) -;; number -;; string -;; boolean -;; char -;; box -;; type-symbol -;; external -;; sequence (length) -;; list (marks) -;; vector -;; improper-list (period marks) -;; - -(unit/sig zodiac:reader-structs^ - (import zodiac:structures^) - - (define-struct (read struct:zodiac) (object)) - - (define-struct (scalar struct:read) ()) - (define-struct (symbol struct:scalar) (orig-name marks)) - (define-struct (number struct:scalar) ()) - (define-struct (string struct:scalar) ()) - (define-struct (boolean struct:scalar) ()) - (define-struct (char struct:scalar) ()) - (define-struct (box struct:scalar) ()) - (define-struct (type-symbol struct:scalar) ()) - (define-struct (external struct:scalar) ()) - - (define-struct (sequence struct:read) (length)) - (define-struct (list struct:sequence) (marks)) - (define-struct (vector struct:sequence) ()) - (define-struct (improper-list struct:sequence) (period marks)) - ) - diff --git a/collects/zodiac/scanner.ss b/collects/zodiac/scanner.ss deleted file mode 100644 index 157a1918..00000000 --- a/collects/zodiac/scanner.ss +++ /dev/null @@ -1,746 +0,0 @@ -;; -;; zodiac:scanner-code@ -;; $Id: scanner.ss,v 1.14 2000/03/24 14:50:29 clements Exp $ -;; -;; Zodiac Scanner July 96. -;; mwk, plt group, Rice university. -;; -;; The Scanner returns one of three struct types: -;; -;; scalar (symbol, number, string, boolean, char) -;; token (anything else) -;; eof - -;; -;; Imports: make- constructors and parameters. -;; Exports: scan. -;; - -(unit/sig zodiac:scanner-code^ - (import zodiac:structures^ - zodiac:scanner-structs^ - (zodiac : zodiac:reader-structs^) - zodiac:scanner-parameters^ - (report : zodiac:interface^)) - - ;; - ;; Insert elements into table of ascii chars (plus eof). - ;; Indices can be either chars or ints. - ;; Elts can be either single char/int or list of char/int. - ;; - - (define fill - (letrec ([loop - (lambda (table value char-list) - (if (null? char-list) 'done - (let* ([elt (car char-list)] - [num (if (integer? elt) elt (char->integer elt))]) - (vector-set! table num value) - (loop table value (cdr char-list)))))]) - (case-lambda - [(table value) - (vector-fill! table value)] - [(table value elts) - (if (list? elts) - (loop table value elts) - (loop table value (list elts)))]))) - - - - ;; Internal definitions for the scanner. - - (define z:void (void)) - (define z:location make-location) - - (define z:origin make-origin) - (define source (lambda () (z:origin 'source 'source))) - - (define z:scalar - (lambda (maker) - (lambda (obj st fin) - (maker (source) st fin obj)))) - - ;;;;; Moved from here - - (define z:token - (lambda (tag obj st fin) - (make-token (source) st fin obj tag))) - - (define z:eof (lambda (loc) (make-eof loc))) - - - ;; Codes for the tokens returned by the scanner. - ;; This is the "type" field in token. - ;; (it's safe to change these here, if needed.) - - (define open-tag 'list) - (define close-tag 'endseq) - (define dot-tag 'period) - (define quote-tag 'quote) - (define quasi-tag 'quasiquote) - (define unquote-tag 'unquote) - (define splicing-tag 'unquote-splicing) - (define string-tag 'string) - (define box-tag 'box) - (define boolean-tag 'boolean) - (define char-tag 'char) - (define circ-obj-tag 'circular-obj) - (define circ-ref-tag 'circular-ref) - (define vector-tag 'vector) - (define size-vec-tag 'sized-vector) - (define number-tag 'number) - (define symbol-tag 'symbol) - (define eof-tag 'eof) - (define error-tag 'error) - (define snip-tag 'snip) - - ;; Other codes for char classes. - - (define delim-tag 'delim) - (define space-tag 'space) - (define tab-tag 'tab) - (define newline-tag 'newline) - (define letter-tag 'letter) - (define octal-tag 'octal) - (define digit-tag 'digit) - - ;; The scanner's alphabet. - - (define dot-char #\. ) - (define dot-int (char->integer dot-char)) - (define quote-char #\' ) - (define quote-int (char->integer quote-char)) - (define quasi-char #\` ) - (define quasi-int (char->integer quasi-char)) - (define unquote-char #\, ) - (define unquote-int (char->integer unquote-char)) - (define comment-char #\; ) - (define comment-int (char->integer comment-char)) - (define string-char #\" ) - (define string-int (char->integer string-char)) - (define hash-char #\# ) - (define hash-int (char->integer hash-char)) - (define box-char #\& ) - (define bslash-char #\\ ) - (define bslash-int (char->integer bslash-char)) - (define stick-char #\| ) - (define stick-int (char->integer stick-char)) - (define bang-char #\! ) - (define zero-int (char->integer #\0)) - (define space-int (char->integer #\space)) - (define rangle-int (char->integer #\> )) - (define langle-int (char->integer #\< )) - - (define splicing-int (char->integer #\@ )) - (define eq-sign-int (char->integer #\= )) - (define eof-int 256) - (define snip-int 257) - (define ascii-size 258) - - (define open-list (map car scan:paren-relation)) - (define close-list (map cadr scan:paren-relation)) - - (define delim-list (cons eof-int (cons snip-int scan:delim-list))) - - ;;;;; Moved to here - - (define z:symbol (z:scalar (lambda (so st fi obj) - (zodiac:make-symbol so st fi obj obj '())))) - (define z:number (z:scalar zodiac:make-number)) - (define z:string (z:scalar zodiac:make-string)) - (define z:boolean (z:scalar zodiac:make-boolean)) - (define z:char (z:scalar zodiac:make-char)) - (define z:snip (z:scalar zodiac:make-external)) - (define z:type-sym (z:scalar zodiac:make-type-symbol)) - - ;;;;;;;;;;;;;;;; - - ;; letters and octals are used in #\space and #\012. - ;; digits are used in #3(. - ;; (nothing to do with the chars allowed in symbols.) - - (define letter-list - ((lambda (l) (append (map char-upcase l) l)) - (list #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m - #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z))) - - (define digit-list (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (define octal-list (list #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)) - - ;; Ambig = chars that can begin symbols or numbers. - ;; Dot and hash are also ambiguous, but in different ways. - - (define ambig-list (cons #\+ (cons #\- digit-list))) - - ;; Chars that come after #. - - (define prim-char #\% ) - (define prim-int (char->integer prim-char)) - (define boolean-list (list #\t #\f #\T #\F)) - (define hash-num-list - (list #\i #\e #\b #\o #\d #\x #\I #\E #\B #\O #\D #\X)) - - (define special-char-list - (map - (lambda (l) - (let ([str (car l)] [elt (cadr l)]) - (list (reverse (string->list str)) - (if (char? elt) elt - (integer->char elt))))) - scan:special-char-list)) - - ;; Number of columns that tab rounds up to. - - (define tab-mult 8) - - (define text->string - (lambda (text) (string->immutable-string (list->string (reverse text))))) - - (define text->number - (lambda (text) (string->number (text->string text)))) - - ;; Convert symbols to single case (if case-sensitive? = #f), - ;; so *make sure* all calls to z:symbol come through here. - - (define text->symbol - (lambda (text) - (let ([obj (if (read-case-sensitive) - text - (map char-downcase text))]) - (string->symbol (text->string obj))))) - - (define text->char - (lambda (text) - (let ([low-case (map char-downcase text)]) - (let loop ([l special-char-list]) - (cond - [(null? l) #f] - [(equal? low-case (caar l)) (cadar l)] - [else (loop (cdr l))]))))) - - (define char->digit (lambda (c) (- (char->integer c) zero-int))) - - - ;; - ;; The Scanner. Optional args (in order): - ;; port = input port to read from. - ;; init-loc = location of 1st (next) char from port. - ;; skip-script = #t if skip #!... at start of file. - ;; first-col = number (usually 1) of 1st column of each line. - ;; - ;; Basic Idea: States in DFA are implemented as procedures. - ;; Calling a procedure means you're in that state (history). - ;; - ;; Main Invariant: - ;; char = "current" char - ;; (line, col, offset) = loc of (current) char - ;; start-loc = global - ;; - - (define scan - (opt-lambda - ([port (current-input-port)] - [init-loc default-initial-location] - [skip-script? #t] - [first-col scan:def-first-col]) - - - ;; The Scanner's State. - ;; char = the "current" character. - ;; int = ascii code for char, or else 256 for eof. - ;; (line, col, offset) = (right) location of current char. - ;; (prev-line, prev-col) = (right) location of previous char. - ;; file = copied from location of init-loc. - - (let* - ([char #\a] ;; Dummy values, int must != newline. - [int 65] - [line (location-line init-loc)] - [col (- (location-column init-loc) 1)] - [offset (- (location-offset init-loc) 1)] - [file (location-file init-loc)] - [prev-line -99] - [prev-col -99] - [start-loc 'error] - [first-offset (location-offset init-loc)] - - [hash? (lambda () (= int hash-int))] - [bslash? (lambda () (= int bslash-int))] - [dquote? (lambda () (= int string-int))] - [eq-sign? (lambda () (= int eq-sign-int))] - [splicing? (lambda () (= int splicing-int))] - [stick? (lambda () (= int stick-int))] - [prim? (lambda () (= int prim-int))] - [eof? (lambda () (= int eof-int))] - [snip? (lambda () (= int snip-int))] - - [main-table (make-vector ascii-size (lambda () #f))] - [hash-table (make-vector ascii-size (lambda () #f))] - [delim-table (make-vector ascii-size #f)] - [char-table (make-vector ascii-size #f)] - - [delim? (lambda () (vector-ref delim-table int))] - [tab? (lambda () (eq? (vector-ref delim-table int) tab-tag))] - [newline? (lambda () (eq? (vector-ref delim-table int) newline-tag))] - [open? (lambda () (eq? (vector-ref delim-table int) open-tag))] - - [space? (lambda () (= int space-int))] - [rangle? (lambda () (= int rangle-int))] - [type-sym-delim? - (lambda () - (cond [(space?) #f] - [(rangle?) #t] - [else (delim?)]))] - - [letter? (lambda () (eq? (vector-ref char-table int) letter-tag))] - [octal? (lambda () (eq? (vector-ref char-table int) octal-tag))] - [digit? - (lambda () - (let ([tag (vector-ref char-table int)]) - (or (eq? tag octal-tag) (eq? tag digit-tag))))] - [fetch-char - (if (procedure? port) - port - (lambda () (read-char port)))] - [hash-char-list (list hash-char)]) - - (letrec - - ;; For now, a naive treatment of location. - ;; We always use the *right* side of a char, so: - ;; affects the following char, - ;; affects itself. - - ([get-char - (lambda () - (set! prev-line line) - (set! prev-col col) - (if (newline?) - (begin (set! line (+ line 1)) - (set! col first-col)) - (set! col (+ col 1))) - (set! char (fetch-char)) - (set! int - (cond [(char? char) (char->integer char)] - [(eof-object? char) eof-int] - [else snip-int])) - (if (tab?) - (set! col (* tab-mult (ceiling (/ col tab-mult))))) - (set! offset (+ offset 1)))] - - [this-loc - (lambda () - (z:location line col offset file))] - - [prev-loc - (lambda () - (z:location prev-line prev-col (- offset 1) file))] - - [start-here - (lambda () - (set! start-loc (this-loc)))] - - [z:error - (case-lambda - [(str) - (report:static-error - "syntax error" 'scan:syntax-error - (z:token error-tag z:void start-loc (prev-loc)) - str)] - [(str text) - (report:static-error - "syntax error" 'scan:syntax-error - (z:token error-tag z:void start-loc (prev-loc)) - (format str (text->string text)))])] - - [z:eof-error - (lambda (str) - (report:static-error - "syntax error" 'scan:syntax-error - (z:token error-tag z:void start-loc (prev-loc)) - (format "unexpected end of file inside ~a" str)))] - - ;; - ;; States in the scanner. - ;; Inv: When a state is called, (char, int) is the - ;; 1st char of that token. - ;; get-token = the thunk returned to the reader. - ;; - - [get-token - (lambda () - (start-here) - ((vector-ref main-table int)))] - - [scan-wspace - (lambda () - (get-char) - (get-token))] - - [scan-open - (lambda () - (let ([c char]) - (get-char) - (z:token open-tag c start-loc start-loc)))] - - [scan-close - (lambda () - (let ([c char]) - (get-char) - (z:token close-tag c start-loc start-loc)))] - - ;; Should we check for case-sensitive? here? - ;; You *really* don't want a letter being a delim! - - [scan-delim-sym - (lambda () - (let ([sym (text->symbol (list char))]) - (get-char) - (z:symbol sym start-loc start-loc)))] - - [scan-quote - (lambda () - (get-char) - (z:token quote-tag z:void start-loc start-loc))] - - [scan-quasi - (lambda () - (get-char) - (z:token quasi-tag z:void start-loc start-loc))] - - [scan-unquote - (lambda () - (get-char) - (if (or (eof?) (not (splicing?))) - (z:token unquote-tag z:void start-loc start-loc) - (let ([end-loc (this-loc)]) - (get-char) - (z:token splicing-tag z:void start-loc end-loc))))] - - [scan-comment - (lambda () - (cond - [(newline?) (begin (get-char) (get-token))] - [(eof?) (get-token)] - [else (begin (get-char) (scan-comment))]))] - - [scan-string - (lambda () - (let loop ([l null]) - (get-char) - (cond - [(eof?) (z:error "missing close quote in string")] - [(dquote?) - (let ([end-loc (this-loc)]) - (get-char) - (z:string (text->string l) start-loc end-loc))] - [(bslash?) - (begin - (get-char) - (cond - [(eof?) (z:error "missing close quote in string")] - [(snip?) (get-char) - (z:error "objects in string must be chars")] - [else (loop (cons char l))]))] - [(snip?) (get-char) - (z:error "objects in string must be chars")] - [else (loop (cons char l))])))] - - [scan-dot - (lambda () - (get-char) - (if (delim?) - (z:token dot-tag z:void start-loc start-loc) - (sym-or-num (list dot-char))))] - - [scan-hash - (lambda () - (get-char) - ((vector-ref hash-table int)))] - - [scan-box - (lambda () - (get-char) - (z:token box-tag z:void start-loc (prev-loc)))] - - [scan-boolean - (lambda () - (let ([val (char-ci=? char #\t)]) - (get-char) - (z:boolean val start-loc (prev-loc))))] - - [scan-char - (lambda () - (get-char) ; skip the \ char. - (cond - [(eof?) (z:error "missing character after #\\")] - [(snip?) (get-char) - (z:error "must put character after #\\")] - [(letter?) - (let loop ([l (list char)]) - (get-char) - (if (letter?) - (loop (cons char l)) - (if (null? (cdr l)) - (z:char (car l) start-loc (prev-loc)) - (let ([ch (text->char l)]) - (if ch - (z:char ch start-loc (prev-loc)) - (z:error "`~a' is not a valid character" - (append l (list bslash-char hash-char))))))))] - [(octal?) - (let ([c1 char] [d1 (char->digit char)]) - (get-char) - (if (octal?) - (let ([c2 char] [d2 (char->digit char)]) - (get-char) - (if (octal?) - (let ([c3 char] [d3 (char->digit char)]) - (get-char) - (let ([num (+ (* 64 d1) (* 8 d2) d3)]) - (if (<= 0 num 255) - (z:char (integer->char num) - start-loc (prev-loc)) - (z:error "`#\\~a' is not a valid octal character" - (list c3 c2 c1))))) - (z:char (integer->char (+ (* 8 d1) d2)) - start-loc (prev-loc)))) - (z:char c1 start-loc (prev-loc))))] - [else - (let ([c char]) - (get-char) - (z:char c start-loc (prev-loc)))]))] - - [scan-vector - (lambda () - (let ([c char]) - (get-char) - (z:token vector-tag c start-loc (prev-loc))))] - - [scan-hash-digit - (lambda () - (let loop ([l (list char)]) - (get-char) - (cond - [(digit?) (loop (cons char l))] - [(eof?) (z:eof-error "# syntax")] - [(open?) - (let ([c char] - [num (text->number l)]) - (get-char) - ; The vector-constant-size test is now to let mzscheme - ; try the malloc and see if it succeeds or raises exn. - (if (with-handlers - (((lambda (x) #t) (lambda (x) #f))) - (make-vector num 0) - #t) - (z:token size-vec-tag (list num c) - start-loc (prev-loc)) - (z:error "vector constant size too large")))] - [(hash?) - (let ([num (text->number l)]) - (get-char) - (z:token circ-ref-tag num start-loc (prev-loc)))] - [(eq-sign?) - (let ([num (text->number l)]) - (get-char) - (z:token circ-obj-tag num start-loc (prev-loc)))] - [(prim?) - (let ([text (append l (list hash-char))]) - (symbol-only text))] - [(snip?) (get-char) - (z:error "invalid # syntax")] - [else - (let ([c char]) - (get-char) - (z:error "invalid # syntax"))])))] - - [scan-hash-stick - (lambda () - (let loop ([nest 1]) - (get-char) - (cond - [(= nest 0) (get-token)] - [(eof?) (z:eof-error "#| comment")] - [(hash?) - (begin - (get-char) - (cond - [(eof?) (get-token)] - [(stick?) (loop (+ nest 1))] - [else (loop nest)]))] - [(stick?) - (begin - (get-char) - (cond - [(eof?) (get-token)] - [(hash?) (loop (- nest 1))] - [else (loop nest)]))] - [else (loop nest)])))] - - [scan-primitive - (lambda () (symbol-only hash-char-list))] - - [scan-hash-other - (lambda () - (let ([c char]) - (get-char) - (z:error "invalid # syntax")))] - - [scan-hash-eof - (lambda () (z:eof-error "# syntax"))] - - [scan-to-delim - (lambda (delim? text esc) - (cond - [(delim?) (values text esc)] - [(bslash?) - (begin - (get-char) - (cond - [(eof?) (z:error "missing character inside escape")] - [(snip?) (get-char) - (z:error "invalid object inside escape")] - [else (let ([c char]) - (get-char) - (scan-to-delim delim? (cons c text) #t))]))] - [(stick?) - (let loop ([l text]) - (get-char) - (cond - [(eof?) (z:error "missing close stick")] - [(snip?) (get-char) - (z:error "invalid object inside stick")] - [(stick?) - (begin - (get-char) - (scan-to-delim delim? l #t))] - [else (loop (cons char l))]))] - [else - (let ([c char]) - (get-char) - (scan-to-delim delim? (cons c text) esc))]))] - - [scan-sym-num (lambda () (sym-or-num null))] - [scan-symbol (lambda () (symbol-only null))] - [scan-number - (lambda () (number-only hash-char-list))] - - [sym-or-num - (lambda (text) - (let-values ([(text used-stick?) - (scan-to-delim delim? text #f)]) - (if used-stick? - (z:symbol (text->symbol text) - start-loc (prev-loc)) - (with-handlers - ([exn:read? - (lambda (x) (z:error "`~a' is not a valid number" - text))]) - (let* - ([str (text->string text)] - [num (read (open-input-string str))]) - (if (number? num) - (z:number (if (and (inexact? num) - (disallow-untagged-inexact-numbers)) - (z:error (format "`~~a' is not a valid number; try ~a" - (read (open-input-string (string-append "#e" str)))) - text) - num) - start-loc (prev-loc)) - (z:symbol (text->symbol text) - start-loc (prev-loc))))))))] - - [symbol-only - (lambda (text) - (let-values ([(text foo) (scan-to-delim delim? text #t)]) - (z:symbol (text->symbol text) - start-loc (prev-loc))))] - - [number-only - (lambda (text) - (let-values ([(text foo) (scan-to-delim delim? text #f)]) - (with-handlers - ([(lambda (x) #t) - (lambda (x) (z:error "`~a' starts out like a number, but isn't one" text))]) - (let* ([str (text->string text)] - [num (read (open-input-string str))]) - (if (number? num) - (z:number num start-loc (prev-loc)) - (z:error "`~a' starts out like a number, but isn't one" text))))))] - - [scan-eof - (lambda () (z:eof (this-loc)))] - - [scan-snip - (lambda () - (let ([obj char]) - (get-char) - (z:snip obj start-loc start-loc)))] - - ;; #! is treated as a comment if first two bytes of file. - [scan-hash-script - (lambda () - (if (and skip-script? - (= offset (add1 first-offset))) - (begin (skip-hash-script) - (get-token)) - (scan-hash-other)))] - - [skip-hash-script - (lambda () - (get-char) - (cond - [(eof?) 'return] - [(newline?) (get-char)] - [(bslash?) - (get-char) - (if (eof?) 'return (skip-hash-script))] - [else (skip-hash-script)]))] - ) - - (fill main-table scan-symbol) - (fill main-table scan-wspace scan:whitespace-list) - (fill main-table scan-sym-num ambig-list) - (fill main-table scan-dot dot-char) - (fill main-table scan-open open-list) - (fill main-table scan-close close-list) - (fill main-table scan-delim-sym scan:self-delim-symbols) - (fill main-table scan-quote quote-char) - (fill main-table scan-quasi quasi-char) - (fill main-table scan-unquote unquote-char) - (fill main-table scan-comment comment-char) - (fill main-table scan-string string-char) - (fill main-table scan-hash hash-char) - (fill main-table scan-eof eof-int) - (fill main-table scan-snip snip-int) - - (fill hash-table scan-hash-other) - (fill hash-table scan-box box-char) - (fill hash-table scan-boolean boolean-list) - (fill hash-table scan-char bslash-char) - (fill hash-table scan-number hash-num-list) - (fill hash-table scan-vector open-list) - (fill hash-table scan-hash-digit digit-list) - (fill hash-table scan-hash-stick stick-char) - (fill hash-table scan-primitive prim-char) - (fill hash-table scan-hash-eof eof-int) - (fill hash-table scan-hash-script bang-char) - - (fill delim-table #f) - (fill delim-table delim-tag delim-list) - (fill delim-table space-tag scan:whitespace-list) - (fill delim-table tab-tag scan:tab-list) - (fill delim-table newline-tag scan:newline-list) - (fill delim-table open-tag open-list) - (fill delim-table eof-tag eof-int) - (fill delim-table snip-tag snip-int) - - (fill char-table #f) - (fill char-table letter-tag letter-list) - (fill char-table digit-tag digit-list) - (fill char-table octal-tag octal-list) - - (get-char) - get-token))))) - diff --git a/collects/zodiac/scanparm.ss b/collects/zodiac/scanparm.ss deleted file mode 100644 index f174056d..00000000 --- a/collects/zodiac/scanparm.ss +++ /dev/null @@ -1,93 +0,0 @@ -;; -;; zodiac:scanner-parameters@ -;; $Id: scanparm.ss,v 1.7 2000/05/26 15:47:33 clements Exp $ -;; -;; Scanner/Reader Parameters. -;; -;; The scan values (outside make-scanner) mostly can -;; be reset at will. But don't use letters, digits, #, etc. -;; The parameters inside make-scanner should not be reset. -;; -;; The char lists can be either chars or ints. -;; - -(unit/sig zodiac:scanner-parameters^ - (import zodiac:structures^) - - (define disallow-untagged-inexact-numbers (make-parameter #f)) - - ;; Only #\space and #\newline are always builtin, - ;; so we specify the rest with ascii codes. - - (define space #\space) - (define nul 0) - (define backsp 8) - (define tab 9) - (define newline 10) - (define vtab 11) - (define page 12) - (define return 13) - (define rubout 127) - - (define scan:paren-relation - (let ((base '((#\( #\))))) - (let ((w/-brackets (if (read-square-bracket-as-paren) - (cons '(#\[ #\]) base) - base))) - (let ((w/-braces (if (read-curly-brace-as-paren) - (cons '(#\{ #\}) w/-brackets) - w/-brackets))) - w/-braces)))) - - (define scan:self-delim-symbols - (let ((base '())) - (let ((w/-brackets (if (read-square-bracket-as-paren) - base - (append '(#\[ #\]) base)))) - (let ((w/-braces (if (read-curly-brace-as-paren) - w/-brackets - (append '(#\{ #\}) w/-brackets)))) - w/-braces)))) - - (define scan:newline-list (list newline return)) - (define scan:tab-list (list tab)) - - (define scan:whitespace-list - (let loop ((n 0)) - (if (> n 255) '() - (if (char-whitespace? (integer->char n)) - (cons n (loop (+ n 1))) - (loop (+ n 1)))))) - - ;; Old definition: - ; (define scan:whitespace-list - ; (list space tab newline vtab page return)) - ;; removed because this list depends on platform (eg, - ;; char 202 is the non-breakable whitespace on the Mac); - ;; char-whitespace? helps us stay platform-independent - - (define scan:delim-list - (append scan:whitespace-list - (map car scan:paren-relation) - (map cadr scan:paren-relation) - scan:self-delim-symbols - (list #\; #\" #\, #\' #\` ))) - - (define scan:special-char-list - `(("space" ,space) - ("newline" ,newline) - ("linefeed" ,newline) - ("nul" ,nul) - ("null" ,nul) - ("backspace" ,backsp) - ("tab" ,tab) - ("vtab" ,vtab) - ("page" ,page) - ("return" ,return) - ("rubout" ,rubout))) - - (define default-initial-location (make-location 1 1 0 'nofile)) - (define scan:def-first-col 1) - (define scan:def-vect-val 0) - ) - diff --git a/collects/zodiac/scanstr.ss b/collects/zodiac/scanstr.ss deleted file mode 100644 index 74111490..00000000 --- a/collects/zodiac/scanstr.ss +++ /dev/null @@ -1,18 +0,0 @@ -;; -;; zodiac:scanner-structs@ -;; $Id$ -;; -;; Scanner's subtree of the hierarchy. -;; -;; zodiac (origin start finish) -;; scanned -;; token (object type) -;; - -(unit/sig zodiac:scanner-structs^ - (import zodiac:structures^) - - (define-struct (scanned struct:zodiac) ()) - (define-struct (token struct:scanned) (object type)) - ) - diff --git a/collects/zodiac/scm-core.ss b/collects/zodiac/scm-core.ss deleted file mode 100644 index 610bc2a2..00000000 --- a/collects/zodiac/scm-core.ss +++ /dev/null @@ -1,933 +0,0 @@ -; $Id: scm-core.ss,v 1.59 2000/04/30 22:37:34 clements Exp $ - -(unit/sig zodiac:scheme-core^ - (import zodiac:structures^ zodiac:misc^ zodiac:sexp^ - (z : zodiac:reader-structs^) zodiac:back-protocol^ - zodiac:expander^ zodiac:interface^ - (pat : zodiac:pattern^)) - - (define-struct (parsed struct:zodiac) (back)) - (define-struct (varref struct:parsed) (var)) - (define-struct (top-level-varref struct:varref) ()) - (define-struct (top-level-varref/bind struct:top-level-varref) (slot)) - (define-struct (top-level-varref/bind/unit struct:top-level-varref/bind) (unit?)) - (define-struct (bound-varref struct:varref) (binding)) - (define-struct (lexical-varref struct:bound-varref) ()) - (define-struct (lambda-varref struct:lexical-varref) ()) - (define-struct (app struct:parsed) (fun args)) - (define-struct (binding struct:parsed) (var orig-name)) - (define-struct (lexical-binding struct:binding) ()) - (define-struct (lambda-binding struct:lexical-binding) ()) - (define-struct (form struct:parsed) ()) - - ; ---------------------------------------------------------------------- - - (define name-eq? eq?) - - (define marks-equal? equal?) - - ; ---------------------------------------------------------------------- - - (define generate-name - (lambda (var) - (string->symbol - (string-append - (symbol->string (gensym)) ":" - (symbol->string (z:symbol-orig-name var)))))) - - (define create-binding+marks - (opt-lambda (constructor (nom-de-plume generate-name)) - (opt-lambda (v (s v)) - (cons - (constructor (zodiac-origin s) - (zodiac-start s) (zodiac-finish s) - (make-empty-back-box) - (nom-de-plume v) - (z:symbol-orig-name s)) - (z:symbol-marks v))))) - - (define create-lexical-binding+marks - (create-binding+marks make-lexical-binding)) - - (define create-lambda-binding+marks - (create-binding+marks make-lambda-binding)) - - (define create-top-level-varref - (lambda (v s) - (make-top-level-varref (zodiac-origin s) - (zodiac-start s) (zodiac-finish s) - (make-empty-back-box) v))) - - (define create-top-level-varref/bind - (lambda (v b s) - (make-top-level-varref/bind (zodiac-origin s) - (zodiac-start s) (zodiac-finish s) - (make-empty-back-box) v b))) - - (define create-top-level-varref/bind/unit - (lambda (v b s) - (make-top-level-varref/bind/unit (zodiac-origin s) - (zodiac-start s) (zodiac-finish s) - (make-empty-back-box) v b - (let ([l (unbox b)]) - (if (null? l) - #f - (top-level-varref/bind/unit-unit? (car l))))))) - - (define create-bound-varref - (lambda (constructor) - (opt-lambda (v (s v)) - (constructor (zodiac-origin s) - (zodiac-start s) (zodiac-finish s) - (make-empty-back-box) (binding-var v) - v)))) - - (define create-lexical-varref - (create-bound-varref make-lexical-varref)) - - (define create-lambda-varref - (create-bound-varref make-lambda-varref)) - - (define create-app - (lambda (fun args source) - (make-app (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) fun args))) - - ; ---------------------------------------------------------------------- - - (define p->r-table - '()) - - (define extend-parsed->raw - (lambda (predicate handler) - (set! p->r-table - (cons (cons predicate handler) - p->r-table)))) - - (define parsed->raw - (opt-lambda (expr (handler #f)) - (let loop ((table p->r-table)) - (if (null? table) - (internal-error expr "Invalid object for parsed->raw") - (let ((first (car table))) - (if ((car first) expr) - ((cdr first) expr (or handler parsed->raw)) - (loop (cdr table)))))))) - - (extend-parsed->raw varref? - (lambda (expr p->r) (varref-var expr))) - (extend-parsed->raw binding? - (lambda (expr p->r) (binding-var expr))) - - (extend-parsed->raw app? - (lambda (expr p->r) - (cons (p->r (app-fun expr)) - (map p->r (app-args expr))))) - - ; -------------------------------------------------------------------- - - (define add-primitivized-micro-form - (lambda (name vocab rewriter) - (unless (symbol? name) - (internal-error name "Must be symbol in add-primitivized-micro-form")) - (add-micro-form (list name (symbol-append "#%" name)) vocab rewriter))) - - (define add-primitivized-macro-form - (lambda (name vocab rewriter) - (unless (symbol? name) - (internal-error name "Must be symbol in add-primitivized-macro-form")) - (add-macro-form (list name (symbol-append "#%" name)) vocab rewriter))) - - ; -------------------------------------------------------------------- - - (define common-vocabulary - (create-vocabulary 'common-vocabulary - #f)) - - (define beginner-vocabulary - (create-vocabulary 'beginner-vocabulary - common-vocabulary)) - - (define intermediate-vocabulary - (create-vocabulary 'intermediate-vocabulary - beginner-vocabulary)) - - (define advanced-vocabulary - (create-vocabulary 'advanced-vocabulary - intermediate-vocabulary)) - - (define full-vocabulary - (create-vocabulary 'full-vocabulary - advanced-vocabulary)) - - (define scheme-vocabulary - (create-vocabulary 'scheme-vocabulary - common-vocabulary)) - - (define (check-for-signature-name expr attributes) - (let ([sig-space (get-attribute attributes 'sig-space)]) - (when sig-space - (unless (get-attribute attributes 'delay-sig-name-check?) - (when (hash-table-get sig-space (z:symbol-orig-name expr) (lambda () #f)) - (static-error - "signature" 'term:signature-out-of-context expr - "invalid use of signature name ~s" (z:symbol-orig-name expr))))))) - - (define ensure-not-macro/micro - (lambda (expr env vocab attributes) - (let ((r (resolve expr env vocab))) - (if (or (macro-resolution? r) (micro-resolution? r)) - (static-error - "keyword" 'term:keyword-out-of-context expr - "invalid use of keyword ~s" (z:symbol-orig-name expr)) - r)))) - - (define process-top-level-resolution - (lambda (expr attributes) - (let ((id (z:read-object expr))) - (let ((top-level-space (get-attribute attributes 'top-levels))) - (if top-level-space - (let ((ref - (create-top-level-varref/bind/unit - id - (hash-table-get top-level-space id - (lambda () - (let ((b (box '()))) - (hash-table-put! top-level-space id b) - b))) - expr))) - (let ((b (top-level-varref/bind-slot ref))) - (set-box! b (cons ref (unbox b)))) - ref) - (create-top-level-varref id expr)))))) - - (add-sym-micro common-vocabulary - (lambda (expr env attributes vocab) - (let ((r (ensure-not-macro/micro expr env vocab attributes))) - (cond - ((lambda-binding? r) - (create-lambda-varref r expr)) - ((lexical-binding? r) - (create-lexical-varref r expr)) - ((top-level-resolution? r) - (check-for-signature-name expr attributes) - (process-top-level-resolution expr attributes)) - (else - (internal-error expr "Invalid resolution in core: ~s" r)))))) - - (define (make-list-micro null-ok? lambda-bound-ok? expr-ok?) - (lambda (expr env attributes vocab) - (let ((contents (expose-list expr))) - (if (null? contents) - (if null-ok? - (expand-expr (structurize-syntax `(quote ,expr) expr) - env attributes vocab) - (static-error - "illegal term" 'term:empty-combination expr - "empty combination is not valid syntax")) - (as-nested - attributes - (lambda () - (let ((bodies - (map - (lambda (e) - (expand-expr e env attributes vocab)) - contents))) - (when (and (not lambda-bound-ok?) - (lambda-varref? (car bodies))) - (static-error - "illegal application" 'term:app-first-term-lambda-bound - expr - "first term in application is a function-bound identifier")) - (when (and (not expr-ok?) - (not (varref? (car bodies)))) - (static-error - "illegal application" 'term:app-first-term-not-var - expr - "first term in application must be a function name")) - (create-app (car bodies) (cdr bodies) expr)))))))) - - (add-list-micro beginner-vocabulary (make-list-micro #f #f #f)) - (add-list-micro advanced-vocabulary (make-list-micro #f #t #t)) - (add-list-micro scheme-vocabulary (make-list-micro #t #t #t)) - - (define lexically-resolved? - (lambda (expr env) - (let ((name (z:read-object expr)) (marks (z:symbol-marks expr))) - (let ((res (resolve-in-env name marks env))) - (and res (binding? res)))))) - - (define in-lexically-extended-env - (lambda (env vars handler) - (let ((new-vars+marks - (map create-lexical-binding+marks - vars))) - (let ((new-vars (map car new-vars+marks))) - (extend-env new-vars+marks env) - (let ((result (handler new-vars env))) - (retract-env new-vars env) - result))))) - - ; ---------------------------------------------------------------------- - - (define set-top-level-status - (opt-lambda (attributes (value #f)) - (put-attribute attributes 'at-scheme-top-level? value))) - - (define get-top-level-status - (lambda (attributes) - (get-attribute attributes 'at-scheme-top-level? - (lambda () #t)))) - - (define at-top-level? get-top-level-status) - - - (define set-internal-define-status - (opt-lambda (attributes (value #f)) - (put-attribute attributes 'at-internal-define-level? value))) - - (define get-internal-define-status - (lambda (attributes) - (get-attribute attributes 'at-internal-define-level? - (lambda () #f)))) - - (define at-internal-define? get-internal-define-status) - - (define (as-nested attributes f) - (let ([top? (get-top-level-status attributes)] - [internal? (get-internal-define-status attributes)]) - (if (or top? internal?) - (begin - (set-top-level-status attributes #f) - (set-internal-define-status attributes #f) - (begin0 - (f) - (set-top-level-status attributes top?) - (set-internal-define-status attributes internal?))) - (f)))) - - ; -------------------------------------------------------------------- - - (define previous-attribute (make-attributes)) - - (define mred-signature #f) - - (define (get-mred-signature attributes) - (unless mred-signature - (let ([v (create-vocabulary 'mred-vocabulary - scheme-vocabulary)] - [e (with-input-from-file - (build-path (collection-path "mred") "sig.ss") - read)] - [loc (make-location 0 0 0 "inlined")]) - (scheme-expand (structurize-syntax e (make-zodiac #f loc loc)) - attributes - v) - (let ([sig-space (get-attribute attributes 'sig-space void)]) - (set! mred-signature (hash-table-get sig-space 'mred^ void))))) - mred-signature) - - (define (reset-previous-attribute top? mred?) - (set! previous-attribute (make-attributes)) - (when top? - (put-attribute previous-attribute 'top-levels (make-hash-table))) - (when mred? - (let ([sig (get-mred-signature previous-attribute)] - [ss (make-hash-table)]) - (put-attribute previous-attribute 'sig-space ss) - (hash-table-put! ss 'mred^ sig)))) - - (define (reset-internal-attributes attr) - (set-top-level-status attr #t) - (set-internal-define-status attr #f) - (put-attribute attr 'delay-sig-name-check? #f) - (for-each (lambda (r) (r attr)) (attributes-resetters))) - - (define elaboration-evaluator - (make-parameter - (lambda (expr parsed->raw phase) - (eval (parsed->raw expr))))) - - (define user-macro-body-evaluator - (make-parameter - (lambda (x . args) - (eval `(,x ,@(map (lambda (x) `(#%quote ,x)) args)))))) - - (define scheme-expand - (opt-lambda (expr [attr 'previous] [vocab #f]) - (let ((attr (cond - ((eq? attr 'previous) previous-attribute) - ((not attr) (make-attributes)) - (else attr)))) - (reset-internal-attributes attr) - (expand expr - attr - (or vocab scheme-vocabulary) - (elaboration-evaluator) - (user-macro-body-evaluator))))) - - (define scheme-expand-program - (opt-lambda (exprs [attr 'previous] [vocab #f]) - (let ((attr (cond - ((eq? attr 'previous) previous-attribute) - ((not attr) (make-attributes)) - (else attr)))) - (reset-internal-attributes attr) - (expand-program exprs - attr - (or vocab scheme-vocabulary) - (elaboration-evaluator) - (user-macro-body-evaluator))))) - - ; ---------------------------------------------------------------------- - - (define valid-syntactic-id? - (lambda (id) - (or (z:symbol? id) - (static-error - "not an identifier" 'term:expected-an-identifier id - "~s" (sexp->raw id))))) - - (define valid-syntactic-id/s? - (lambda (ids) - (cond - ((null? ids) '()) - ((pair? ids) - (let ((first (car ids)) (rest (cdr ids))) - (if (valid-syntactic-id? first) - (cons (z:read-object first) (valid-syntactic-id/s? rest)) - (static-error - "not an identifier" 'term:expected-an-identifier first - "~e" (sexp->raw first))))) - (else (internal-error ids "Illegal to check validity of id/s"))))) - - (define distinct-valid-syntactic-id/s? - (lambda (given-ids) - (let ((input-ids (syntactic-id/s->ids given-ids))) - (let loop ((ids (valid-syntactic-id/s? input-ids)) (index 0)) - (or (null? ids) - (if (symbol? (car ids)) - (if (memq (car ids) (cdr ids)) - (static-error - "identifier" 'term:repeated-identifier - (list-ref input-ids index) - "~s repeated" (car ids)) - (loop (cdr ids) (add1 index))) - (let ((erroneous (list-ref input-ids index))) - (static-error - "not an identifier" 'term:expected-an-identifier - erroneous "~e" (sexp->raw erroneous))))))))) - - (define syntactic-id/s->ids - (lambda (ids) - (cond - ((or (z:list? ids) (z:improper-list? ids)) - (expose-list ids)) - ((z:symbol? ids) (list ids)) - ((pair? ids) ids) - ((null? ids) ids) - (else (static-error - "not an identifier" 'term:expected-an-identifier ids - "~e" (sexp->raw ids)))))) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define valid-id? - (lambda (id) - (or (binding? id) - (static-error - "identifier" 'term:invalid-identifier id "invalid")))) - - (define valid-id/s? - (lambda (ids) - (cond - ((null? ids) '()) - ((pair? ids) - (let ((first (car ids)) (rest (cdr ids))) - (if (valid-id? first) - (cons (binding-orig-name first) (valid-id/s? rest)) - (static-error - "identifier" 'term:invalid-identifier first "invalid")))) - (else (internal-error ids "Illegal to check validity of id/s"))))) - - (define distinct-valid-id/s? - (lambda (ids) - (let ((input-ids (id/s->ids ids))) - (let loop ((ids (valid-id/s? input-ids)) (index 0)) - (or (null? ids) - (if (memq (car ids) (cdr ids)) - (let ((v (list-ref input-ids index))) - (static-error - "identifier" 'term:repeated-identifier v - "~e repeated" (car ids))) - (loop (cdr ids) (add1 index)))))))) - - (define id/s->ids - (lambda (ids) - (cond - ((or (z:list? ids) (z:improper-list? ids)) - (expose-list ids)) - ((z:symbol? ids) (list ids)) - ((pair? ids) ids) - ((null? ids) ids) - (else (static-error - "identifier" 'term:invalid-identifier ids "invalid"))))) - - ; ---------------------------------------------------------------------- - - (define optarglist-pattern 'vars) - - (define-struct optarglist-entry (var+marks)) - (define-struct (initialized-optarglist-entry struct:optarglist-entry) - (expr)) - - (define-struct optarglist (vars)) - (define-struct (sym-optarglist struct:optarglist) ()) - (define-struct (list-optarglist struct:optarglist) ()) - (define-struct (ilist-optarglist struct:optarglist) ()) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define optarglist-decl-entry-parser-vocab - (create-vocabulary 'optarglist-decl-entry-parser-vocab #f - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry")) - - (add-sym-micro optarglist-decl-entry-parser-vocab - (lambda (expr env attributes vocab) - (let ((status-holder (get-attribute attributes 'optarglist-status))) - (case (unbox status-holder) - ((proper improper) (void)) - ((proper/defaults) - (static-error - "argument list" 'term:arglist-after-init-value-spec expr - "appears after initial value specifications")) - ((improper/defaults) - (set-box! status-holder 'improper/done)) - ((improper/done) - (static-error - "argument list" 'term:arglist-after-catch-all-arg expr - "appears past catch-all argument")) - (else (internal-error (unbox status-holder) - "Invalid in optarglist-decl-entry-parser-vocab sym")))) - (make-optarglist-entry - (create-lexical-binding+marks expr)))) - - (add-list-micro optarglist-decl-entry-parser-vocab - (let* ((kwd '()) - (in-pattern '(var val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (let ((status-holder (get-attribute attributes 'optarglist-status))) - (case (unbox status-holder) - ((proper) (set-box! status-holder 'proper/defaults)) - ((improper) (set-box! status-holder 'improper/defaults)) - ((proper/defaults improper/defaults) (void)) - ((improper/done) (static-error - "argument list" 'term:arglist-invalid-init-value - expr "invalid default value specification")) - (else (internal-error (unbox status-holder) - "Invalid in optarglist-decl-entry-parser-vocab list")))) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd)) - (val (pat:pexpand 'val p-env kwd))) - (valid-syntactic-id? var) - (make-initialized-optarglist-entry - (create-lexical-binding+marks var) - val)))) - (else - (static-error - "argument list" 'term:arglist-invalid-init-var-decl - expr "invalid init-var declaration")))))) - - (define optarglist-decls-vocab - (create-vocabulary 'optarglist-decls-vocab #f - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry")) - - (add-sym-micro optarglist-decls-vocab - (lambda (expr env attributes vocab) - (make-sym-optarglist - (list - (make-optarglist-entry - (create-lexical-binding+marks expr)))))) - - (add-list-micro optarglist-decls-vocab - (lambda (expr env attributes vocab) - (let ((expr (expose-list expr)) - (new-attr (put-attribute attributes 'optarglist-status - (box 'proper)))) - (make-list-optarglist - (map (lambda (decl) - (expand-expr decl env new-attr - optarglist-decl-entry-parser-vocab)) - expr))))) - - (add-ilist-micro optarglist-decls-vocab - (lambda (expr env attributes vocab) - (let ((expr-list (expose-list expr)) - (new-attr (put-attribute attributes 'optarglist-status - (box 'improper)))) - (let ((result - (map (lambda (decl) - (expand-expr decl env new-attr - optarglist-decl-entry-parser-vocab)) - expr-list))) - (let loop ((result result) (exprs expr-list)) - (if (null? (cdr result)) - (when (initialized-optarglist-entry? (car result)) - (static-error - "argument list" 'term:arglist-last-arg-no-init - (car exprs) - "last argument must not have an initial value")) - (loop (cdr result) (cdr exprs)))) - (make-ilist-optarglist result))))) - - (define make-optargument-list - (lambda (optarglist env attributes vocab) - (let ((result - (map - (lambda (e) - (extend-env (list (optarglist-entry-var+marks e)) env) - (if (initialized-optarglist-entry? e) - (cons - (car (optarglist-entry-var+marks e)) - (expand-expr - (initialized-optarglist-entry-expr - e) - env attributes vocab)) - (car (optarglist-entry-var+marks e)))) - (optarglist-vars optarglist)))) - (cond - ((sym-optarglist? optarglist) - (make-sym-optarglist result)) - ((list-optarglist? optarglist) - (make-list-optarglist result)) - ((ilist-optarglist? optarglist) - (make-ilist-optarglist result)) - (else - (internal-error optarglist - "Invalid in make-optargument-list")))))) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (extend-parsed->raw optarglist? - (lambda (expr p->r) - (let ((process-args - (lambda (element) - (if (pair? element) - (list (p->r (car element)) (p->r (cdr element))) - (p->r element))))) - (cond - ((sym-optarglist? expr) - (process-args (car (optarglist-vars expr)))) - ((list-optarglist? expr) - (map process-args (optarglist-vars expr))) - ((ilist-optarglist? expr) - (let loop ((vars (map process-args (optarglist-vars expr)))) - (cond - ((null? (cddr vars)) - (cons (car vars) (cadr vars))) - (else - (cons (car vars) (loop (cdr vars))))))) - (else - (internal-error expr "p->r: not an optarglist")))))) - - ; ---------------------------------------------------------------------- - - (define paroptarglist-pattern 'vars) - - (define-struct paroptarglist-entry (var+marks)) - (define-struct (initialized-paroptarglist-entry struct:paroptarglist-entry) - (expr)) - - (define-struct paroptarglist (vars)) - (define-struct (sym-paroptarglist struct:paroptarglist) ()) - (define-struct (list-paroptarglist struct:paroptarglist) ()) - (define-struct (ilist-paroptarglist struct:paroptarglist) ()) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define paroptarglist-decl-entry-parser-vocab - (create-vocabulary 'paroptarglist-decl-entry-parser-vocab #f - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry")) - - (add-sym-micro paroptarglist-decl-entry-parser-vocab - (lambda (expr env attributes vocab) - (let ((status-holder (get-attribute attributes 'paroptarglist-status))) - (case (unbox status-holder) - ((proper improper) (void)) - ((proper/defaults) - (static-error - "argument list" 'term:arglist-after-init-value-spec expr - "appears after initial value specifications")) - ((improper/defaults) - (set-box! status-holder 'improper/done)) - ((improper/done) - (static-error - "argument list" 'term:arglist-after-catch-all-arg expr - "appears past catch-all argument")) - (else (internal-error (unbox status-holder) - "Invalid in paroptarglist-decl-entry-parser-vocab sym")))) - (make-paroptarglist-entry - (create-lexical-binding+marks expr)))) - - (add-list-micro paroptarglist-decl-entry-parser-vocab - (let* ((kwd '()) - (in-pattern '(var val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (let ((status-holder (get-attribute attributes 'paroptarglist-status))) - (case (unbox status-holder) - ((proper) (set-box! status-holder 'proper/defaults)) - ((improper) (set-box! status-holder 'improper/defaults)) - ((proper/defaults improper/defaults) (void)) - ((improper/done) (static-error - "argument list" 'term:arglist-invalid-init-value - expr - "invalid default value specification")) - (else (internal-error (unbox status-holder) - "Invalid in paroptarglist-decl-entry-parser-vocab list")))) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd)) - (val (pat:pexpand 'val p-env kwd))) - (valid-syntactic-id? var) - (make-initialized-paroptarglist-entry - (create-lexical-binding+marks var) - val)))) - (else - (static-error - "argument list" 'term:arglist-invalid-init-var-decl - expr "invalid init-var declaration")))))) - - (define paroptarglist-decls-vocab - (create-vocabulary 'paroptarglist-decls-vocab #f - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry")) - - (add-sym-micro paroptarglist-decls-vocab - (lambda (expr env attributes vocab) - (make-sym-paroptarglist - (list - (make-paroptarglist-entry - (create-lexical-binding+marks expr)))))) - - (add-list-micro paroptarglist-decls-vocab - (lambda (expr env attributes vocab) - (let ((expr (expose-list expr)) - (new-attr (put-attribute attributes 'paroptarglist-status - (box 'proper)))) - (make-list-paroptarglist - (map (lambda (decl) - (expand-expr decl env new-attr - paroptarglist-decl-entry-parser-vocab)) - expr))))) - - (add-ilist-micro paroptarglist-decls-vocab - (lambda (expr env attributes vocab) - (let ((expr-list (expose-list expr)) - (new-attr (put-attribute attributes 'paroptarglist-status - (box 'improper)))) - (let ((result - (map (lambda (decl) - (expand-expr decl env new-attr - paroptarglist-decl-entry-parser-vocab)) - expr-list))) - (let loop ((result result) (exprs expr-list)) - (if (null? (cdr result)) - (when (initialized-paroptarglist-entry? (car result)) - (static-error - "argument list" 'term:arglist-last-arg-no-init - (car exprs) - "last argument must not have an initial value")) - (loop (cdr result) (cdr exprs)))) - (make-ilist-paroptarglist result))))) - - (define make-paroptargument-list - (lambda (paroptarglist env attributes vocab) - (extend-env - (map paroptarglist-entry-var+marks - (paroptarglist-vars paroptarglist)) - env) - (let ((result - (map - (lambda (e) - (if (initialized-paroptarglist-entry? e) - (cons - (car (paroptarglist-entry-var+marks e)) - (expand-expr - (initialized-paroptarglist-entry-expr - e) - env attributes vocab)) - (car (paroptarglist-entry-var+marks e)))) - (paroptarglist-vars paroptarglist)))) - (cond - ((sym-paroptarglist? paroptarglist) - (make-sym-paroptarglist result)) - ((list-paroptarglist? paroptarglist) - (make-list-paroptarglist result)) - ((ilist-paroptarglist? paroptarglist) - (make-ilist-paroptarglist result)) - (else - (internal-error paroptarglist - "Invalid in make-paroptargument-list")))))) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (extend-parsed->raw paroptarglist? - (lambda (expr p->r) - (let ((process-args - (lambda (element) - (if (pair? element) - (list (p->r (car element)) (p->r (cdr element))) - (p->r element))))) - (cond - ((sym-paroptarglist? expr) - (process-args (car (paroptarglist-vars expr)))) - ((list-paroptarglist? expr) - (map process-args (paroptarglist-vars expr))) - ((ilist-paroptarglist? expr) - (let loop ((vars (map process-args (paroptarglist-vars expr)))) - (cond - ((null? (cddr vars)) - (cons (car vars) (cadr vars))) - (else - (cons (car vars) (loop (cdr vars))))))) - (else - (internal-error expr "p->r: not an paroptarglist")))))) - - ; ---------------------------------------------------------------------- - - (define arglist-pattern '(args)) - - (define-struct arglist (vars)) - (define-struct (sym-arglist struct:arglist) ()) - (define-struct (list-arglist struct:arglist) ()) - (define-struct (ilist-arglist struct:arglist) ()) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define (make-arglist-decls-vocab) - (create-vocabulary 'arglist-decls-vocab #f - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry" - "malformed argument list entry")) - - ; note: the only difference between the lambda-<> vocabs and the <> vocabs - ; is that the lambda-<> vocabs use create-lambda-binding+marks instead - ; of create-lexical-bindings+marks - - (define full-arglist-decls-vocab (make-arglist-decls-vocab)) - (define proper-arglist-decls-vocab (make-arglist-decls-vocab)) - (define nonempty-arglist-decls-vocab (make-arglist-decls-vocab)) - (define lambda-full-arglist-decls-vocab (make-arglist-decls-vocab)) - (define lambda-proper-arglist-decls-vocab (make-arglist-decls-vocab)) - (define lambda-nonempty-arglist-decls-vocab (make-arglist-decls-vocab)) - - (define (setup-arglist-vocabs binding-constructor - full-vocab - proper-vocab - nonempty-vocab) - (add-sym-micro full-vocab - (lambda (expr env attributes vocab) - (make-sym-arglist - (list - (binding-constructor expr))))) - - (let ([m (lambda (expr env attributes vocab) - (static-error - "argument list" 'term:arglist-invalid-syntax expr - "invalid syntax"))]) - (add-sym-micro proper-vocab m) - (add-sym-micro nonempty-vocab m)) - - (let ([make-arg-list-micro - (lambda (null-ok?) - (lambda (expr env attributes vocab) - (let ((contents (expose-list expr))) - (when (and (not null-ok?) - (null? contents)) - (static-error - "application" 'term:proc-arity->=-1 expr - "all procedures must take at least one argument")) - (make-list-arglist - (map binding-constructor contents)))))]) - (add-list-micro nonempty-vocab (make-arg-list-micro #f)) - (add-list-micro proper-vocab (make-arg-list-micro #t)) - (add-list-micro full-vocab (make-arg-list-micro #t))) - - (let ([m (lambda (expr env attributes vocab) - (static-error - "argument list" 'term:arglist-invalid-syntax expr - "invalid syntax"))]) - (add-ilist-micro proper-vocab m) - (add-ilist-micro nonempty-vocab m)) - - (add-ilist-micro full-vocab - (lambda (expr env attributes vocab) - (make-ilist-arglist - (map binding-constructor (expose-list expr)))))) - - (setup-arglist-vocabs create-lexical-binding+marks - full-arglist-decls-vocab - proper-arglist-decls-vocab - nonempty-arglist-decls-vocab) - - (setup-arglist-vocabs create-lambda-binding+marks - lambda-full-arglist-decls-vocab - lambda-proper-arglist-decls-vocab - lambda-nonempty-arglist-decls-vocab) - - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define make-argument-list - (lambda (arglist) - (cond - ((sym-arglist? arglist) - (make-sym-arglist - (map car (arglist-vars arglist)))) - ((list-arglist? arglist) - (make-list-arglist - (map car (arglist-vars arglist)))) - ((ilist-arglist? arglist) - (make-ilist-arglist - (map car (arglist-vars arglist)))) - (else - (internal-error arglist "Invalid in make-argument-list"))))) - - (extend-parsed->raw arglist? - (lambda (expr p->r) - (cond - ((sym-arglist? expr) - (p->r (car (arglist-vars expr)))) - ((list-arglist? expr) - (map p->r (arglist-vars expr))) - ((ilist-arglist? expr) - (let loop ((vars (map p->r (arglist-vars expr)))) - (cond - ((null? (cddr vars)) - (cons (car vars) (cadr vars))) - (else - (cons (car vars) (loop (cdr vars))))))) - (else - (internal-error expr "p->r: not an arglist"))))) - - ) diff --git a/collects/zodiac/scm-hanc.ss b/collects/zodiac/scm-hanc.ss deleted file mode 100644 index e0439ab1..00000000 --- a/collects/zodiac/scm-hanc.ss +++ /dev/null @@ -1,2240 +0,0 @@ -; $Id: scm-hanc.ss,v 1.65 2000/05/28 03:47:31 shriram Exp $ - -(define-struct signature-element (source)) -(define-struct (name-element struct:signature-element) (name)) -(define-struct (unit-element struct:signature-element) (id signature)) - -(define immediate-signature-name '||) - -(define cu/s-this-link-attr 'cu/s-this-link-name) - -(define-struct signature (name elements exploded)) - -; Cheap trick: instead of fixing the vocabs to ignore the -; environment (if possible) , we just drop the environment. -(define (sig-env e) - (make-empty-environment)) - -(define check-unique-cu/s-exports - (lambda (in:exports sign:exports) - (let loop ((in:all in:exports) - (sign:all sign:exports) - (in:names null) - (sign:names null) - (in:rest null) - (sign:rest null)) - (if (or (null? sign:all) (null? in:all)) - (begin - (let loop ((in in:rest) - (signs (map car sign:rest))) - (unless (null? in) - (if (memq (car signs) (cdr signs)) - (static-error - "unit" 'term:unit-double-export (car in) - "name \"~s\" is exported twice" (car signs)) - (loop (cdr in) (cdr signs))))) - (let loop ((in in:names) - (signs sign:names)) - (unless (null? in) - (if (memq (car signs) (cdr signs)) - (static-error - "unit" 'term:unit-double-export (car in) - "name \"~s\" is exported twice" (car signs)) - (loop (cdr in) (cdr signs)))))) - (let ((in (car in:all)) (sign (car sign:all))) - (if (or (symbol? sign) (z:symbol? sign)) - (loop (cdr in:all) (cdr sign:all) - (cons in in:names) - (cons (if (symbol? sign) - sign - (z:read-object sign)) - sign:names) - in:rest sign:rest) - (loop (cdr in:all) (cdr sign:all) - in:names sign:names - (cons in in:rest) - (cons sign sign:rest)))))))) - -; This is based on code lifted from Matthew's implementation (note the -; use of brackets (-:). - -(define verify-duplicates-&-sort-signature-elements - (lambda (elements) - (let loop ((seen '()) (rest elements)) - (unless (null? rest) - (let ((first (car rest))) - (let ((first-name - (cond - ((name-element? first) - (name-element-name first)) - ((unit-element? first) - (unit-element-id first)) - (else - (internal-error first "Invalid unit element"))))) - (when (memq first-name seen) - (static-error - "signature" 'term:duplicate-signature - (signature-element-source first) - "duplicate entry: ~s" first-name)) - (loop (cons first-name seen) (cdr rest)))))) - (letrec - ((split - (lambda (l f s) - (cond - [(null? l) (values f s)] - [(null? (cdr l)) (values (cons (car l) f) s)] - [else (split (cddr l) (cons (car l) f) - (cons (cadr l) s))]))) - (merge - (lambda (f s) - (cond - [(null? f) s] - [(null? s) f] - [(less-than? (car s) (car f)) - (cons (car s) (merge f (cdr s)))] - [else - (cons (car f) (merge (cdr f) s))]))) - (less-than? - (lambda (a b) - (if (name-element? a) - (if (name-element? b) - (symbol-less-than? (name-element-name a) - (name-element-name b)) - #t) - (if (name-element? b) - #f - (symbol-less-than? (unit-element-id a) - (unit-element-id b)))))) - (symbol-less-than? - (lambda (a b) - (stringstring a) (symbol->string b))))) - (let loop ([elements elements]) - (cond - [(null? elements) null] - [(null? (cdr elements)) elements] - [else (let-values ([(f s) (split elements null null)]) - (merge (loop f) (loop s)))]))))) - -(define explode-signature-elements - (lambda (elements) - (map (lambda (elt) - (cond - ((name-element? elt) - (name-element-name elt)) - ((unit-element? elt) - (cons (unit-element-id elt) - (signature-exploded (unit-element-signature elt)))) - (else - (internal-error elt "Invalid signature element")))) - elements))) - -(define sig-list->sig-vector - (lambda (l) - (list->vector - (map - (lambda (e) - (if (or (z:symbol? e) (symbol? e)) - e - (named-sig-list->named-sig-vector e))) - l)))) - -(define named-sig-list->named-sig-vector - (lambda (l) - (cons (car l) - (sig-list->sig-vector (cdr l))))) - -(define create-signature - (opt-lambda (elements (name immediate-signature-name)) - (let ((sorted-elements - (verify-duplicates-&-sort-signature-elements elements))) - (make-signature name sorted-elements - (explode-signature-elements sorted-elements))))) - -(define add-signature - (lambda (name attributes elements) - (let ((sig-space (get-attribute attributes 'sig-space - (lambda () - (let ((ss (make-hash-table))) - (put-attribute attributes 'sig-space ss) - ss))))) - (hash-table-put! sig-space (z:read-object name) - (create-signature elements (z:read-object name)))))) - -(define push-signature - (lambda (name attributes elements) - (let ((sig-space (get-attribute attributes 'sig-space - (lambda () - (let ((ss (make-hash-table))) - (put-attribute attributes 'sig-space ss) - ss))))) - (begin0 - (hash-table-get sig-space (z:read-object name) - (lambda () #f)) - (hash-table-put! sig-space (z:read-object name) - (create-signature elements (z:read-object name))))))) - -(define pop-signature - (lambda (name attributes old-value) - (let ((sig-space (get-attribute attributes 'sig-space - (lambda () - (let ((ss (make-hash-table))) - (put-attribute attributes 'sig-space ss) - ss))))) - (hash-table-remove! sig-space (z:read-object name)) - (when old-value - (hash-table-put! sig-space (z:read-object name) - old-value))))) - -(define lookup-signature - (lambda (name attributes) - (let ((sig-space (get-attribute attributes 'sig-space))) - (if sig-space - (let ((entry - (hash-table-get sig-space (z:read-object name) - (lambda () - (static-error - "signature" 'term:unbound-sig-name name - "unbound name: ~s" (z:read-object name)))))) - entry) - (static-error - "signature" 'term:unbound-sig-name name - "unbound name: ~s" (z:read-object name)))))) - -(define extract-sub-unit-signature - (lambda (signature indices) - (if (null? indices) - signature - (let* ((first (car indices)) - (raw-first (z:read-object first))) - (let loop ((elements (signature-elements signature))) - (if (null? elements) - (static-error - "signature" 'term:signature-no-sub-unit first - "no such sub-unit") - (if (unit-element? (car elements)) - (if (eq? raw-first (unit-element-id (car elements))) - (extract-sub-unit-signature - (unit-element-signature (car elements)) - (cdr indices)) - (loop (cdr elements))) - (loop (cdr elements))))))))) - -; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(define cu/s-attr 'compound-unit/sig-table) - -(define-struct tag-table-entry (signature)) -(define-struct (tag-table-import-entry struct:tag-table-entry) ()) -(define-struct (tag-table-link-entry struct:tag-table-entry) ()) - -(define extract-cu/s-tag-table - (lambda (attributes) - (car - (get-attribute attributes cu/s-attr - (lambda () - (internal-error attributes - "Unable to find compound-unit/sig attribute")))))) - -(define cu/s-tag-table-put - (lambda (maker) - (lambda (table tag sig env attributes) - (hash-table-put! table (z:read-object tag) - (maker (expand-expr sig env attributes sig-vocab)))))) - -(define cu/s-tag-table-put/import - (cu/s-tag-table-put make-tag-table-import-entry)) - -(define cu/s-tag-table-put/link - (cu/s-tag-table-put make-tag-table-link-entry)) - -(define cu/s-tag-table-lookup - (opt-lambda (table tag (not-found (lambda () #f))) - (hash-table-get table (z:read-object tag) not-found))) - -(define cu/s-tag-table-lookup/static-error - (lambda (table tag) - (cu/s-tag-table-lookup table tag - (lambda () - (static-error - "unit linkage" 'term:unit-link-unbound-tag tag - "unbound tag"))))) - -(define cu/s-tag-table-lookup/internal-error - (lambda (table tag) - (cu/s-tag-table-lookup table tag - (lambda () - (internal-error tag "Should have been bound"))))) - -; -------------------------------------------------------------------- - -(define sig-vocab - (create-vocabulary 'sig-vocab #f - "malformed signature expression" - "malformed signature expression" - "malformed signature expression" - "malformed signature expression")) - -(add-sym-micro sig-vocab - (lambda (expr env attributes vocab) - (lookup-signature expr attributes))) - -(add-list-micro sig-vocab - (lambda (expr env attributes vocab) - (let ((contents (expose-list expr))) - (create-signature - (apply append - (map (lambda (e) - (expand-expr e env attributes sig-element-vocab)) - contents)))))) - -; -------------------------------------------------------------------- - -(define sig-element-vocab - (create-vocabulary 'sig-element-vocab #f - "malformed signature element" - "malformed signature element" - "malformed signature element" - "malformed signature element")) - -(add-sym-micro sig-element-vocab - (lambda (expr env attributes vocab) - (list (make-name-element expr (z:read-object expr))))) - -(add-micro-form 'struct sig-element-vocab - (let* ((kwd '(struct)) - (in-pattern '(struct base (field ...) omit ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((base (pat:pexpand 'base p-env kwd)) - (fields (pat:pexpand '(field ...) p-env kwd)) - (in:omits (pat:pexpand '(omit ...) p-env kwd))) - (valid-syntactic-id? base) - (valid-syntactic-id/s? fields) - (let ((omit-names - (map (lambda (o) - (expand-expr o env attributes - signature-struct-omission-checker-vocab)) - in:omits))) - (let ((generated-names - (map z:read-object - (generate-struct-names base fields expr - (memq '-selectors omit-names) - (memq '-setters omit-names))))) - (let loop ((omits omit-names)) - (unless (null? omits) - (let ((first (car omits))) - (when (z:symbol? first) - (unless (memq (z:read-object first) generated-names) - (static-error - "structs in signature" - 'term:signature-struct-illegal-omit-name - first - "name not generated; illegal to omit"))) - (loop (cdr omits))))) - (let ((real-omits - (let loop ((omits omit-names)) - (if (null? omits) '() - (if (symbol? (car omits)) - (loop (cdr omits)) - (cons (z:read-object (car omits)) - (loop (cdr omits)))))))) - (let loop ((names generated-names)) - (if (null? names) '() - (if (memq (car names) real-omits) - (loop (cdr names)) - (cons (make-name-element expr (car names)) - (loop (cdr names)))))))))))) - (else - (static-error - "struct" 'kwd:signature-struct expr - "malformed clause")))))) - -(define signature-struct-omission-checker-vocab - (create-vocabulary 'signature-struct-omission-checker-vocab #f - "malformed signature structure omission declaration" - "malformed signature structure omission declaration" - "malformed signature structure omission declaration" - "malformed signature structure omission declaration")) - -(add-sym-micro signature-struct-omission-checker-vocab - (lambda (expr env attributes vocab) - (let ((raw-expr (z:read-object expr))) - (unless (memq raw-expr '(-selectors -setters)) - (static-error - "structs in signature" 'term:signature-invalid-struct-omit - expr "invalid omission specifier")) - raw-expr))) - -(add-micro-form '- signature-struct-omission-checker-vocab - (let* ((kwd '(-)) - (in-pattern '(- var)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd))) - (valid-syntactic-id? var) - (structurize-syntax (z:read-object var) expr)))) - (else - (static-error - "structs in signature" 'term:signature-malformed-omit-clause - expr "malformed omission specifier")))))) - -(add-micro-form 'open sig-element-vocab - (let* ((kwd '(open)) - (in-pattern '(open sig)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? sig) - (signature-elements - (expand-expr sig env attributes sig-vocab))))) - (else - (static-error - "structs in signature" 'term:signature-malformed-open-clause - expr "malformed open clause")))))) - -(add-micro-form 'unit sig-element-vocab - (let* ((kwd '(unit :)) - (in-pattern '(unit id : sig)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((id (pat:pexpand 'id p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? id) - (list (make-unit-element expr (z:read-object id) - (expand-expr sig env attributes sig-vocab)))))) - (else - (static-error - "structs in signature" 'term:signature-malformed-unit-clause - expr "Malformed unit clause")))))) - -; -------------------------------------------------------------------- - -(define u/s-prim-imports-vocab - (create-vocabulary 'u/s-prim-imports-vocab #f - "malformed imports declaration" - "malformed imports declaration" - "malformed imports declaration" - "malformed imports declaration")) - -(add-sym-micro u/s-prim-imports-vocab - (lambda (expr env attributes vocab) - (convert-to-prim-format - (signature-elements - (lookup-signature expr attributes))))) - -(add-list-micro u/s-prim-imports-vocab - (let* ((kwd '(:)) - (in-pattern-1 '(id : sig)) - (in-pattern-2 '(id : any ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((id (pat:pexpand 'id p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? id) - (convert-to-prim-format - (signature-elements - (expand-expr sig env attributes sig-vocab)) - (z:read-object id))))) - ((pat:match-against m&e-2 expr env) - (static-error - "signature" 'term:signature-ambiguous-: - expr "ambiguous : in signature")) - (else - (convert-to-prim-format - (signature-elements - (expand-expr expr env attributes sig-vocab)))))))) - -(define convert-to-prim-format - (opt-lambda (sig-elements (prefix #f)) - (convert-to-prim-format-helper sig-elements - (cond - ((symbol? prefix) - (let ((s (symbol->string prefix))) - (if (string=? "" s) - s - (string-append s ":")))) - ((string? prefix) - prefix) - (else - ""))))) - -(define convert-to-prim-format-helper - (lambda (sig-elements prefix-string) - (apply append - (map (lambda (elt) - (cond - ((name-element? elt) - (list - (string->symbol - (string-append prefix-string - (symbol->string (name-element-name elt)))))) - ((unit-element? elt) - (let ((new-prefix - (string-append prefix-string - (symbol->string (unit-element-id elt)) - ":"))) - (convert-to-prim-format-helper - (signature-elements - (unit-element-signature elt)) - new-prefix))) - (else - (internal-error elt "Illegal signature element")))) - sig-elements)))) - -; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(define u/s-sign-imports-vocab - (create-vocabulary 'u/s-sign-imports-vocab #f - "malformed signature imports declaration" - "malformed signature imports declaration" - "malformed signature imports declaration" - "malformed signature imports declaration")) - -(add-sym-micro u/s-sign-imports-vocab - (lambda (expr env attributes vocab) - (cons (z:read-object expr) - (signature-exploded - (lookup-signature expr attributes))))) - -(add-list-micro u/s-sign-imports-vocab - (let* ((kwd '(:)) - (in-pattern-1 '(id : sig)) - (in-pattern-2 '(id : any ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((id (pat:pexpand 'id p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? id) - (cons (z:read-object id) - (signature-exploded - (expand-expr sig env attributes sig-vocab)))))) - ((pat:match-against m&e-2 expr env) - (static-error - "signature" 'term:signature-ambiguous-: - expr "ambiguous : in signature")) - (else - (cons immediate-signature-name - (explode-signature-elements - (signature-elements - (expand-expr expr env attributes sig-vocab))))))))) - -; -------------------------------------------------------------------- - -(define create-prim-exports - (lambda (export-sig renames source env attributes) - (let ((sig-names (signature-elements - (expand-expr export-sig env attributes sig-vocab)))) - (let ((table (make-hash-table))) - (for-each (lambda (z-rename) - (let ((rename-couple (expose-list z-rename))) - (hash-table-put! table - (z:read-object (cadr rename-couple)) - (z:read-object (car rename-couple))))) - renames) - (let loop ((sig-names sig-names)) - (if (null? sig-names) - '() - (let ((first (car sig-names))) - (when (unit-element? first) - (static-error - "unit" 'term:no-unit-exports source - "unit exports not allowed")) - (let ((name (name-element-name first))) - (cons - (let ((entry (hash-table-get table name (lambda () #f)))) - (if entry - (list entry name) - (list name name))) - (loop (cdr sig-names))))))))))) - -; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -(define u/s-sign-exports-vocab - (create-vocabulary 'u/s-sign-exports-vocab #f - "malformed signature exports declaration" - "malformed signature exports declaration" - "malformed signature exports declaration" - "malformed signature exports declaration")) - -(add-sym-micro u/s-sign-exports-vocab - (lambda (expr env attributes vocab) - (signature-exploded - (lookup-signature expr attributes)))) - -(add-list-micro u/s-sign-exports-vocab - (let* ((kwd '(:)) - (in-pattern-1 '(id : sig)) - (in-pattern-2 '(id : any ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((id (pat:pexpand 'id p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? id) - (signature-exploded - (expand-expr sig env attributes sig-vocab))))) - ((pat:match-against m&e-2 expr env) - (static-error - "signature" 'term:signature-ambiguous-: expr - "ambiguous : in signature")) - (else - (explode-signature-elements - (signature-elements - (expand-expr expr env attributes sig-vocab)))))))) - -; -------------------------------------------------------------------- - -(define signature->symbols-micro - (let* ((kwd '()) - (in-pattern '(_ name)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((name (pat:pexpand 'name p-env kwd))) - (valid-syntactic-id? name) - (let ((elements - (sig-list->sig-vector - (signature-exploded - (lookup-signature name attributes))))) - (expand-expr - (structurize-syntax `(,'quote ,elements) expr '(-1)) - env attributes vocab))))) - (else - (static-error - "signature->symbols" 'kwd:signature->symbols - expr "malformed expression")))))) - -(add-primitivized-micro-form 'signature->symbols full-vocabulary signature->symbols-micro) -(add-on-demand-form 'micro 'signature->symbols common-vocabulary signature->symbols-micro) - -(define define-signature-micro - (let* ((kwd '()) - (in-pattern '(_ name sig)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((name (pat:pexpand 'name p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? name) - (unless (get-top-level-status attributes) - (static-error - "define-signature" 'kwd:define-signature - expr "only supported at top-level")) - (let ((elements - (signature-elements - (expand-expr sig env attributes sig-vocab)))) - (add-signature name attributes elements)) - (expand-expr - (structurize-syntax '(#%void) expr '(-1) - #f (z:make-origin 'micro expr)) - env attributes vocab)))) - (else - (static-error - "define-signature" 'kwd:define-signature - expr "malformed definition")))))) - -(add-primitivized-micro-form 'define-signature full-vocabulary define-signature-micro) -(add-primitivized-micro-form 'define-signature scheme-vocabulary define-signature-micro) - -(define let-signature-micro - ;; >> Broken by current embedded define hacks! << - ;; e.g., (let ([a 7]) 5 (let-signature a () a)) - (let* ((kwd '()) - (in-pattern '(_ name sig b0 b1 ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((name (pat:pexpand 'name p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd)) - (body (pat:pexpand '(begin b0 b1 ...) p-env kwd))) - (valid-syntactic-id? name) - (let* ((elements - (signature-elements - (expand-expr sig env attributes sig-vocab))) - (old-value (push-signature name attributes elements))) - (dynamic-wind - void - (lambda () - ; Yuck - if name is in the environment, we shadow it - ; by retracting the env: - (let ([new-env - (let loop ([env env]) - (if (lexically-resolved? name env) - (let ([env (copy-env env)] - [var (let ((name (z:read-object name)) - (marks (z:symbol-marks name))) - (resolve-in-env name marks env))]) - (retract-env (list var) env) - (loop env)) - env))]) - (let ([r (expand-expr - (structurize-syntax body expr) - new-env attributes vocab)]) - r))) - (lambda () - (pop-signature name attributes old-value))))))) - (else - (static-error - "let-signature" 'kwd:let-signature - expr "malformed expression")))))) - -(add-primitivized-micro-form 'let-signature full-vocabulary let-signature-micro) -(add-primitivized-micro-form 'let-signature scheme-vocabulary let-signature-micro) - -(define u/s-expand-includes-vocab - (create-vocabulary 'u/s-expand-includes-vocab)) - -(add-primitivized-micro-form 'include u/s-expand-includes-vocab - (let* ((kwd '()) - (in-pattern '(_ filename)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd))) - (unless (z:string? filename) - (static-error - "include" 'kwd:unit-include - filename "file name must be a string")) - (let ((raw-filename (z:read-object filename))) - (let-values (((base name dir?) (split-path raw-filename))) - (when dir? - (static-error - "include" 'kwd:unit-include - filename "cannot include a directory")) - (let* ((original-directory (current-load-relative-directory)) - (p (with-handlers - ((exn:i/o:filesystem? - (lambda (exn) - (static-error - "include" 'kwd:unit-include filename - "unable to open file ~s: ~a" raw-filename exn)))) - (open-input-file - (if (and original-directory - (not (complete-path? raw-filename))) - (path->complete-path raw-filename - original-directory) - raw-filename))))) - (parameterize ([current-load-relative-directory - (if (string? base) - (if (complete-path? base) - base - (path->complete-path base - (or original-directory - (current-directory)))) - (or original-directory - (current-directory)))]) - (dynamic-wind - void - (lambda () - (let ([exprs - (let ((reader (z:read p - (z:make-location - (z:location-line - z:default-initial-location) - (z:location-column - z:default-initial-location) - (z:location-offset - z:default-initial-location) - (build-path - (current-load-relative-directory) - name))))) - (let loop () - (let ((input (reader))) - (if (z:eof? input) - '() - (cons input - (loop))))))]) - (expand-expr (structurize-syntax - (cons 'begin exprs) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes - vocab))) - (lambda () - (close-input-port p)))))))))) - (else - (static-error - "include" 'kwd:unit-include - expr "malformed expression")))))) - -(define unit/sig-micro - (let* ((kwd-1 '(import rename)) - (in-pattern-1 '(_ signature - (import imports ...) - (rename renames ...) - clauses ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd-1)) - (kwd-2 '(import)) - (in-pattern-2 '(_ signature - (import imports ...) - clauses ...)) - (out-pattern-2 '(unit/sig signature - (import imports ...) - (rename) - clauses ...)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd-2))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let* ((in:signature (pat:pexpand 'signature p-env kwd-1)) - (in:imports (pat:pexpand '(imports ...) p-env kwd-1)) - (in:renames (pat:pexpand '(renames ...) p-env kwd-1)) - (in:clauses (pat:pexpand '(clauses ...) p-env kwd-1)) - (sigenv (sig-env env))) - (let* ((prim-unit:imports (apply append - (map (lambda (import) - (expand-expr import sigenv - attributes - u/s-prim-imports-vocab)) - in:imports))) - (prim-unit:exports (create-prim-exports in:signature - in:renames expr env attributes)) - (prim-unit:clauses in:clauses) - (sign-unit:imports (map (lambda (import) - (expand-expr import sigenv - attributes - u/s-sign-imports-vocab)) - in:imports)) - (sign-unit:exports (expand-expr in:signature sigenv - attributes u/s-sign-exports-vocab))) - (expand-expr - ;; We don't use '(-1) as the third argument to - ;; structurize-syntax since the - ;; prim-unit:{imports,exports} are raw sexp's - ;; which get undesirably marked in the process, - ;; leading to imports not matching against uses in - ;; the body. This should be remedied by making - ;; these values structurized, so that the - ;; remainder can also be structurized with - ;; impunity and '(-1) can be used. - (structurize-syntax - `(#%make-unit-with-signature - (#%unit - (import ,@prim-unit:imports) - (export ,@prim-unit:exports) - ,@prim-unit:clauses) - (quote ,(map named-sig-list->named-sig-vector sign-unit:imports)) - (quote ,(sig-list->sig-vector sign-unit:exports))) - expr '() - #f - (z:make-origin 'micro expr)) - env attributes (append-vocabulary vocab - u/s-expand-includes-vocab - 'include-within-unit)))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (expand-expr - (structurize-syntax - (pat:pexpand out-pattern-2 p-env kwd-2) - expr - '() - #f - (z:make-origin 'micro expr)) - env attributes vocab))) - (else - (static-error - "unit/sig" 'kwd:unit/sig - expr "malformed expression")))))) - - -(add-primitivized-micro-form 'unit/sig full-vocabulary unit/sig-micro) -(add-primitivized-micro-form 'unit/sig scheme-vocabulary unit/sig-micro) - -; -------------------------------------------------------------------- - -(define cu/s-imports-record-tag-sigs-vocab - (create-vocabulary 'cu/s-imports-record-tag-sigs-vocab #f - "malformed import clause" - "malformed import clause" - "malformed import clause" - "malformed import clause")) - -(add-list-micro cu/s-imports-record-tag-sigs-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? tag) - (let ((table (extract-cu/s-tag-table attributes))) - (when (cu/s-tag-table-lookup table tag) - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig tag - "duplicate link tag definition")) - (cu/s-tag-table-put/import table tag sig env attributes))))) - (else - (static-error - "compound unit/sig" 'kwd:compound-unit/sig expr - "malformed import clause")))))) - -(define cu/s-sign-imports-vocab - (create-vocabulary 'cu/s-sign-imports-vocab #f - "malformed import clause" - "malformed import clause" - "malformed import clause" - "malformed import clause")) - -(add-list-micro cu/s-sign-imports-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd))) - (let ((table (extract-cu/s-tag-table attributes))) - (cons (z:read-object tag) - (signature-exploded - (tag-table-entry-signature - (cu/s-tag-table-lookup/internal-error table tag)))))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig expr - "malformed import clause")))))) - -(define cu/s-link-imports-vocab - (create-vocabulary 'cu/s-link-imports-vocab #f - "malformed link imports declaration" - "malformed link imports declaration" - "malformed link imports declaration" - "malformed link imports declaration")) - -(add-list-micro cu/s-link-imports-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd))) - (let ((table (extract-cu/s-tag-table attributes))) - (convert-to-prim-format - (signature-elements - (tag-table-entry-signature - (cu/s-tag-table-lookup/internal-error table tag))) - (z:read-object tag)))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig expr - "malformed import clause")))))) - -; -------------------------------------------------------------------- - -(define cu/s-link-record-tag-sigs-vocab - (create-vocabulary 'cu/s-link-record-tag-sigs-vocab #f - "malformed link clause" - "malformed link clause" - "malformed link clause" - "malformed link clause")) - -(add-list-micro cu/s-link-record-tag-sigs-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig misc)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? tag) - (let ((table (extract-cu/s-tag-table attributes))) - (when (cu/s-tag-table-lookup table tag) - (static-error - "unit linkage" 'term:unit-link-duplicate-tag - tag - "duplicate link tag name")) - (cu/s-tag-table-put/link table tag sig env attributes))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed link clause")))))) - -(define cu/s-link-exports-vocab - (create-vocabulary 'cu/s-link-exports-vocab #f - "malformed link export declaration" - "malformed link export declaration" - "malformed link export declaration" - "malformed link export declaration")) - -(add-list-micro cu/s-link-exports-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig misc)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd))) - (let ((table (extract-cu/s-tag-table attributes))) - (signature-exploded - (tag-table-entry-signature - (cu/s-tag-table-lookup/internal-error table tag))))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed link clause")))))) - -(define cu/s-link-tags-vocab - (create-vocabulary 'cu/s-link-tags-vocab #f - "malformed link tag declaration" - "malformed link tag declaration" - "malformed link tag declaration" - "malformed link tag declaration")) - -(add-list-micro cu/s-link-tags-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig misc)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd))) - tag))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed link clause")))))) - -(define cu/s-link-exprs-vocab - (create-vocabulary 'cu/s-link-exprs-vocab #f - "malformed link expression" - "malformed link expression" - "malformed link expression" - "malformed link expression")) - -(add-list-micro cu/s-link-exprs-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig (expr path ...))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((expr (pat:pexpand 'expr p-env kwd))) - expr))) - (else - (static-error - "compound-unit/sig" 'kwd:compount-unit/sig - expr "malformed link clause")))))) - -(define cu/s-link-linking-sigs-vocab - (create-vocabulary 'cu/s-link-linking-sigs-vocab #f - "malformed link clause" - "malformed link clause" - "malformed link clause" - "malformed link clause")) - -(add-list-micro cu/s-link-linking-sigs-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig (expr path ...))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (path-elts (pat:pexpand '(path ...) p-env kwd))) - (map (lambda (p) - (put-attribute attributes cu/s-this-link-attr - (z:read-object tag)) - (expand-expr p env attributes - cu/s-unit-path-linkage-vocab)) - path-elts)))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed link clause")))))) - -(define cu/s-check-self-import - (lambda (tag attributes) - (when #f ; we allow self-import, now - (when (eq? (z:read-object tag) - (get-attribute attributes cu/s-this-link-attr - (lambda () (internal-error tag "No this-link attribute")))) - (static-error - "unit linkage" 'term:unit-link-self-import-tag tag - "self import of tag ~s" (z:read-object tag)))))) - -(define cu/s-link-prim-unit-names-vocab - (create-vocabulary 'cu/s-link-prim-unit-names-vocab #f - "malformed link clause" - "malformed link clause" - "malformed link clause" - "malformed link clause")) - -(add-list-micro cu/s-link-prim-unit-names-vocab - (let* ((kwd '(:)) - (in-pattern '(tag : sig (expr path ...))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (path-elts (pat:pexpand '(path ...) p-env kwd))) - (apply append - (map (lambda (p) - (expand-expr p env attributes - cu/s-unit-path-prim-links-vocab)) - path-elts))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed link clause")))))) - -; -------------------------------------------------------------------- - -(define cu/s-unit-path-extract-final-sig-vocab - (create-vocabulary 'cu/s-unit-path-extract-final-sig-vocab)) - -(add-sym-micro cu/s-unit-path-extract-final-sig-vocab - (lambda (expr env attributes vocab) - (let ((sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) - expr)))) - sig))) - -(add-list-micro cu/s-unit-path-extract-final-sig-vocab - (let* ((kwd '(:)) - (in-pattern-1 '((tag id ...) : sig)) - (in-pattern-2 '(tag : sig)) - (in-pattern-3 '(tag id ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? tag) - (map valid-syntactic-id? ids) - (let ((initial-sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) tag)))) - (let ((final-sig - (extract-sub-unit-signature initial-sig ids)) - (small-sig - (expand-expr sig env attributes sig-vocab))) - (with-handlers - ((exn:unit? - (lambda (exn) - (static-error - "signature matching" 'term:signature-not-matching - expr (exn-message exn))))) - (verify-signature-match 'compound-unit/sig - #f - (format "signature ~s" (signature-name small-sig)) - (sig-list->sig-vector (signature-exploded small-sig)) - (format "signature ~s" (signature-name final-sig)) - (sig-list->sig-vector (signature-exploded final-sig)))) - small-sig))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? tag) - (let ((big-sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) tag))) - (small-sig - (expand-expr sig env attributes sig-vocab))) - (with-handlers - ((exn:unit? - (lambda (exn) - (static-error - "signature matching" 'term:signature-not-matching - expr (exn-message exn))))) - (verify-signature-match 'compound-unit/sig - #f - (format "signature ~s" (signature-name small-sig)) - (sig-list->sig-vector (signature-exploded small-sig)) - (format "signature ~s" (signature-name big-sig)) - (sig-list->sig-vector (signature-exploded big-sig))) - small-sig))))) - ((pat:match-against m&e-3 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd))) - (valid-syntactic-id? tag) - (map valid-syntactic-id? ids) - (let ((initial-sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) tag)))) - (let ((final-sig - (extract-sub-unit-signature initial-sig ids))) - final-sig))))) - (else - (static-error - "unit linkage" 'kwd:unit-link-path-malformed - expr "malformed unit path element")))))) - -(define cu/s-unit-path-linkage-vocab - (create-vocabulary 'cu/s-unit-path-linkage-vocab #f - "malformed linkage" - "malformed linkage" - "malformed linkage" - "malformed linkage")) - -(add-sym-micro cu/s-unit-path-linkage-vocab - (lambda (expr env attributes vocab) - (cu/s-check-self-import expr attributes) - (let ((sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) - expr)))) - (cons (z:read-object expr) - (signature-exploded sig))))) - -(add-list-micro cu/s-unit-path-linkage-vocab - (let* ((kwd '(:)) - (in-pattern-1 '((tag id ...) : sig)) - (in-pattern-2 '(tag : sig)) - (in-pattern-3 '(tag id ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? tag) - (cu/s-check-self-import tag attributes) - (map valid-syntactic-id? ids) - (let ((initial-sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) tag)))) - (let ((final-sig - (extract-sub-unit-signature initial-sig ids)) - (small-sig - (expand-expr sig env attributes sig-vocab))) - (with-handlers - ((exn:unit? - (lambda (exn) - (static-error - "signature matching" 'term:signature-not-matching - expr (exn-message exn))))) - (verify-signature-match 'compound-unit/sig - #f - (format "signature ~s" (signature-name small-sig)) - (sig-list->sig-vector (signature-exploded small-sig)) - (format "signature ~s" (signature-name final-sig)) - (sig-list->sig-vector (signature-exploded final-sig))) - (cons (z:read-object tag) - (signature-exploded small-sig)))))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? tag) - (cu/s-check-self-import tag attributes) - (let ((big-sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) tag))) - (small-sig - (expand-expr sig env attributes sig-vocab))) - (with-handlers - ((exn:unit? - (lambda (exn) - (static-error - "signature matching" 'term:signature-not-matching - expr (exn-message exn))))) - (verify-signature-match 'compound-unit/sig - #f - (format "signature ~s" (signature-name small-sig)) - (sig-list->sig-vector (signature-exploded small-sig)) - (format "signature ~s" (signature-name big-sig)) - (sig-list->sig-vector (signature-exploded big-sig))) - (cons (z:read-object tag) - (signature-exploded small-sig))))))) - ((pat:match-against m&e-3 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd))) - (valid-syntactic-id? tag) - (cu/s-check-self-import tag attributes) - (map valid-syntactic-id? ids) - (let ((initial-sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) tag)))) - (let ((final-sig - (extract-sub-unit-signature initial-sig ids))) - (cons (z:read-object tag) - (signature-exploded final-sig))))))) - (else - (static-error - "unit linkage" 'kwd:unit-link-path-malformed - expr "malformed unit path element")))))) - -(define cu/s-unit-path-prim-links-vocab - (create-vocabulary 'cu/s-unit-path-prim-links-vocab #f - "malformed linkage" - "malformed linkage" - "malformed linkage" - "malformed linkage")) - -(add-sym-micro cu/s-unit-path-prim-links-vocab - (lambda (expr env attributes vocab) - (let ((tag-table-entry - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) - expr))) - (let ((sig (tag-table-entry-signature tag-table-entry))) - (cond - ((tag-table-import-entry? tag-table-entry) - (cu/s-build-link-names sig - (string-append - (cu/s-build-link-prefix (list expr)) - ":"))) - ((tag-table-link-entry? tag-table-entry) - (list - (cons (z:read-object expr) - (cu/s-build-link-names sig)))) - (else - (internal-error tag-table-entry "Illegal tag-table entry"))))))) - -(add-list-micro cu/s-unit-path-prim-links-vocab - (let* ((kwd '(:)) - (in-pattern-1 '((tag id ...) : sig)) - (in-pattern-2 '(tag : sig)) - (in-pattern-3 '(tag id ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (let ((small-sig - (expand-expr sig env attributes sig-vocab))) - (let ((tag-table-entry (cu/s-tag-table-lookup/internal-error - (extract-cu/s-tag-table attributes) - tag))) - (cond - ((tag-table-import-entry? tag-table-entry) - (cu/s-build-link-names small-sig - (string-append - (cu/s-build-link-prefix ids tag) - ":"))) - ((tag-table-link-entry? tag-table-entry) - (list - (cons (z:read-object tag) - (cu/s-build-link-names small-sig - (cu/s-build-link-prefix ids))))) - (else - (internal-error tag-table-entry - "Illegal tag-table entry")))))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (let ((small-sig - (expand-expr sig env attributes sig-vocab))) - (let ((tag-table-entry (cu/s-tag-table-lookup/internal-error - (extract-cu/s-tag-table attributes) - tag))) - (cond - ((tag-table-import-entry? tag-table-entry) - (cu/s-build-link-names small-sig - (string-append - (cu/s-build-link-prefix (list tag)) - ":"))) - ((tag-table-link-entry? tag-table-entry) - (list - (cons (z:read-object tag) - (cu/s-build-link-names small-sig)))) - (else - (internal-error tag-table-entry - "Illegal tag-table entry")))))))) - ((pat:match-against m&e-3 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd))) - (let ((initial-sig - (tag-table-entry-signature - (cu/s-tag-table-lookup/static-error - (extract-cu/s-tag-table attributes) tag)))) - (let ((final-sig - (extract-sub-unit-signature initial-sig ids))) - (let ((tag-table-entry (cu/s-tag-table-lookup/internal-error - (extract-cu/s-tag-table attributes) - tag))) - (cond - ((tag-table-import-entry? tag-table-entry) - (cu/s-build-link-names final-sig - (string-append - (cu/s-build-link-prefix ids tag) - ":"))) - ((tag-table-link-entry? tag-table-entry) - (list - (cons (z:read-object tag) - (cu/s-build-link-names final-sig - (string-append - (cu/s-build-link-prefix ids) - ":"))))) - (else - (internal-error tag-table-entry - "Illegal tag-table entry"))))))))) - (else - (static-error - "unit linkage" 'kwd:unit-link-path-malformed - expr "malformed unit path element")))))) - -(define cu/s-unit-path-tag+build-prefix-vocab - (create-vocabulary 'cu/s-unit-path-tag+build-prefix-vocab)) - -; Returns a pair of values: -; - Prefix tag of unit-path as Scheme symbol -; - String representing unit-path with ":" interspersed - -(add-sym-micro cu/s-unit-path-tag+build-prefix-vocab - (lambda (expr env attributes vocab) - (cons (z:read-object expr) - ""))) - -(add-list-micro cu/s-unit-path-tag+build-prefix-vocab - (let* ((kwd '(:)) - (in-pattern-1 '((tag id ...) : sig)) - (in-pattern-2 '(tag : sig)) - (in-pattern-3 '(tag id ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (cons (z:read-object tag) - (apply symbol-append - (let loop ((ids ids)) - (if (null? ids) '("") - (if (null? (cdr ids)) - (list (z:read-object (car ids))) - (cons (z:read-object (car ids)) - (cons ":" - (loop (cdr ids)))))))))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd))) - (cons (z:read-object tag) - "")))) - ((pat:match-against m&e-3 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd))) - (cons (z:read-object tag) - (apply symbol-append - (let loop ((ids ids)) - (if (null? ids) '("") - (if (null? (cdr ids)) - (list (z:read-object (car ids))) - (cons (z:read-object (car ids)) - (cons ":" - (loop (cdr ids)))))))))))) - (else - (static-error - "unit linkage" 'kwd:unit-link-path-malformed - expr "malformed unit path element")))))) - -(define cu/s-unit-path-tag-vocab - (create-vocabulary 'cu/s-unit-path-tag-vocab)) - -; Returns prefix tag of unit-path as Scheme symbol - -(add-sym-micro cu/s-unit-path-tag-vocab - (lambda (expr env attributes vocab) - (z:read-object expr))) - -(add-list-micro cu/s-unit-path-tag-vocab - (let* ((kwd '(:)) - (in-pattern-1 '((tag id ...) : sig)) - (in-pattern-2 '(tag : sig)) - (in-pattern-3 '(tag id ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd)) - (sig (pat:pexpand 'sig p-env kwd))) - (cons (z:read-object tag) - (apply symbol-append - (let loop ((ids ids)) - (if (null? ids) '("") - (if (null? (cdr ids)) - (list (z:read-object (car ids))) - (cons (z:read-object (car ids)) - (cons ":" - (loop (cdr ids)))))))))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd))) - (z:read-object tag)))) - ((pat:match-against m&e-3 expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd))) - (z:read-object tag)))) - (else - (static-error - "unit linkage" 'kwd:unit-link-path-malformed - expr "malformed unit path element")))))) - -(define cu/s-build-link-names - (opt-lambda (signature (prefix-string "")) - (convert-to-prim-format-helper (signature-elements signature) - prefix-string))) - -(define cu/s-build-link-prefix - (opt-lambda (ids (tag #f)) - (if (null? ids) - "" - (apply string-append - (let ((result (let loop ((str-ids (map symbol->string - (map z:read-object ids)))) - (if (null? (cdr str-ids)) - (list (car str-ids)) - (cons (car str-ids) - (cons ":" - (loop (cdr str-ids)))))))) - (if tag - (cons (symbol->string (z:read-object tag)) - (cons ":" - result)) - result)))))) - -; -------------------------------------------------------------------- - -(define-struct cu/s-export ()) -(define-struct (cu/s-var-export struct:cu/s-export) (var external)) -(define-struct (cu/s-unit-export struct:cu/s-export) (sig name)) -(define-struct (cu/s-open-export struct:cu/s-export) (sig)) - -(define cu/s-verify-variable-in-path - (lambda (path variable env attributes) - (let ((tag-table (extract-cu/s-tag-table attributes))) - (let ((final-sig (expand-expr path env attributes - cu/s-unit-path-extract-final-sig-vocab))) - (cu/s-verify-variable-in-sig - (signature-exploded final-sig) - variable))))) - -(define cu/s-verify-variable-in-sig - (lambda (sig variable) - (let ((raw-var (z:read-object variable))) - (let loop ((elements (signature-elements sig))) - (if (null? elements) - (static-error - "signature" 'term:signature-no-var variable - "no such identifier") - (or (and (name-element? (car elements)) - (eq? raw-var (name-element-name (car elements)))) - (loop (cdr elements)))))))) - -(define cu/s-prim-export-vocab - (create-vocabulary 'cu/s-prim-export-vocab #f - "malformed export declaration" - "malformed export declaration" - "malformed export declaration" - "malformed export declaration")) - -; Returns a fully-formed export element of the form -; (tag (internal-name external-name)) -; where each is a symbol or a z:symbol - -(define prefix-w/-: - (lambda (prefix name) - (cond - ((symbol? prefix) - (if (string=? "" (symbol->string prefix)) - name - (symbol-append prefix ":" name))) - ((string? prefix) - (if (string=? "" prefix) - name - (symbol-append prefix ":" name))) - (else - (internal-error 'prefix-w/-: "Got ~s as prefix" prefix))))) - -(add-micro-form 'var cu/s-prim-export-vocab - (let* ((kwd '(var)) - (in-pattern-1 '(var (unit-path variable))) - (in-pattern-2 '(var (unit-path variable) external-variable)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) - (variable (pat:pexpand 'variable p-env kwd))) - (valid-syntactic-id? variable) - (let ((tag+prefix - (expand-expr unit-path env attributes - cu/s-unit-path-tag+build-prefix-vocab))) - (cons (car tag+prefix) - (list (list (prefix-w/-: (cdr tag+prefix) - (z:read-object variable)) - variable))))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) - (variable (pat:pexpand 'variable p-env kwd)) - (external (pat:pexpand 'external-variable p-env kwd))) - (valid-syntactic-id? variable) - (valid-syntactic-id? external) - (let ((tag+prefix - (expand-expr unit-path env attributes - cu/s-unit-path-tag+build-prefix-vocab))) - (cons (car tag+prefix) - (list (list (prefix-w/-: (cdr tag+prefix) - (z:read-object variable)) - external))))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed var export")))))) - -(add-micro-form 'open cu/s-prim-export-vocab - (let* ((kwd '(open)) - (in-pattern '(open unit-path)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) - (let ((tag+prefix - (expand-expr unit-path env attributes - cu/s-unit-path-tag+build-prefix-vocab)) - (final-sig - (expand-expr unit-path env attributes - cu/s-unit-path-extract-final-sig-vocab))) - (cons (car tag+prefix) - (map list - (convert-to-prim-format - (signature-elements final-sig) - (cdr tag+prefix)) - (convert-to-prim-format - (signature-elements final-sig)))))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed open export")))))) - -(add-micro-form 'unit cu/s-prim-export-vocab - (let* ((kwd '(unit)) - (in-pattern-1 '(unit unit-path)) - (in-pattern-2 '(unit unit-path variable)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) - (let ((tag+prefix - (expand-expr unit-path env attributes - cu/s-unit-path-tag+build-prefix-vocab)) - (final-sig - (expand-expr unit-path env attributes - cu/s-unit-path-extract-final-sig-vocab))) - (cons (car tag+prefix) - (map list - (convert-to-prim-format (signature-elements final-sig) - (cdr tag+prefix)) - (convert-to-prim-format (signature-elements final-sig) - (car tag+prefix)))))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) - (variable (pat:pexpand 'variable p-env kwd))) - (valid-syntactic-id? variable) - (let ((tag+prefix - (expand-expr unit-path env attributes - cu/s-unit-path-tag+build-prefix-vocab)) - (final-sig - (expand-expr unit-path env attributes - cu/s-unit-path-extract-final-sig-vocab))) - (cons (car tag+prefix) - (map list - (convert-to-prim-format (signature-elements final-sig) - (cdr tag+prefix)) - (convert-to-prim-format (signature-elements final-sig) - (z:read-object variable)))))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed unit export")))))) - -(define cu/s-export-sign-vocab - (create-vocabulary 'cu/s-export-sign-vocab)) - -(add-micro-form 'var cu/s-export-sign-vocab - (let* ((kwd '(var)) - (in-pattern-1 '(var (unit-path variable))) - (in-pattern-2 '(var (unit-path variable) external-variable)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) - (variable (pat:pexpand 'variable p-env kwd))) - (list variable)))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) - (variable (pat:pexpand 'variable p-env kwd)) - (external (pat:pexpand 'external-variable p-env kwd))) - (list external)))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed var export")))))) - -(add-micro-form 'open cu/s-export-sign-vocab - (let* ((kwd '(open)) - (in-pattern '(open unit-path)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) - (let ((final-sig - (expand-expr unit-path env attributes - cu/s-unit-path-extract-final-sig-vocab))) - (signature-exploded final-sig))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed open export")))))) - -(add-micro-form 'unit cu/s-export-sign-vocab - (let* ((kwd '(unit)) - (in-pattern-1 '(unit unit-path)) - (in-pattern-2 '(unit unit-path variable)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd))) - (let ((tag - (expand-expr unit-path env attributes - cu/s-unit-path-tag-vocab)) - (final-sig - (expand-expr unit-path env attributes - cu/s-unit-path-extract-final-sig-vocab))) - (list (cons tag - (signature-exploded final-sig))))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((unit-path (pat:pexpand 'unit-path p-env kwd)) - (variable (pat:pexpand 'variable p-env kwd))) - (let ((tag - (expand-expr unit-path env attributes - cu/s-unit-path-tag-vocab)) - (final-sig - (expand-expr unit-path env attributes - cu/s-unit-path-extract-final-sig-vocab))) - (list (cons (z:read-object variable) - (signature-exploded final-sig))))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed unit export")))))) - -; -------------------------------------------------------------------- - -(define record-tag-signatures - (lambda (imports links env attributes) - (map (lambda (i) - (expand-expr i env attributes cu/s-imports-record-tag-sigs-vocab)) - imports) - (map (lambda (l) - (expand-expr l env attributes cu/s-link-record-tag-sigs-vocab)) - links))) - -(define compound-unit/sig-micro - (let* ((kwd '(import link export)) - (in-pattern '(_ - (import imports ...) - (link links ...) - (export exports ...))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (put-attribute attributes cu/s-attr - (cons (make-hash-table) - (get-attribute attributes cu/s-attr - (lambda () '())))) - (let* ((in:imports (pat:pexpand '(imports ...) p-env kwd)) - (in:links (pat:pexpand '(links ...) p-env kwd)) - (in:exports (pat:pexpand '(exports ...) p-env kwd)) - (sigenv (sig-env env))) - (record-tag-signatures in:imports in:links sigenv attributes) - ;; linkage = given to verify-linkage-signature-match - ;; prim = goes into underlying compound-unit - ;; sign = given to make-unit-with-signature - (let* ((linkage:tags (map (lambda (l) - (expand-expr l sigenv attributes - cu/s-link-tags-vocab)) - in:links)) - (linkage:unit-vars linkage:tags) - (linkage:unit-exprs (map (lambda (l) - (expand-expr l sigenv attributes - cu/s-link-exprs-vocab)) - in:links)) - (linkage:link-exports - (map (lambda (l) - (expand-expr l sigenv attributes - cu/s-link-exports-vocab)) - in:links)) - (linkage:link-imports - (map (lambda (l) - (expand-expr l sigenv attributes - cu/s-link-linking-sigs-vocab)) - in:links)) - (prim:imports (apply append - (map (lambda (l) - (expand-expr l sigenv attributes - cu/s-link-imports-vocab)) - in:imports))) - (prim:links (map (lambda (l) - (expand-expr l sigenv attributes - cu/s-link-prim-unit-names-vocab)) - in:links)) - (prim:exports (map (lambda (e) - (expand-expr e sigenv attributes - cu/s-prim-export-vocab)) - in:exports)) - (sign:imports (map (lambda (i) - (expand-expr i sigenv attributes - cu/s-sign-imports-vocab)) - in:imports)) - (sign:exports (apply append - (map (lambda (e) - (expand-expr e sigenv attributes - cu/s-export-sign-vocab)) - in:exports)))) - (check-unique-cu/s-exports in:exports sign:exports) - (let ((output - `(let ,(map list linkage:unit-vars linkage:unit-exprs) - (#%verify-linkage-signature-match - 'compound-unit/sig - ',linkage:tags - (#%list ,@linkage:unit-vars) - ',(map sig-list->sig-vector linkage:link-exports) - ',(map (lambda (l) - (map named-sig-list->named-sig-vector l)) - linkage:link-imports)) - (#%make-unit-with-signature - (compound-unit - (import ,@prim:imports) - (link ,@(map (lambda (tag body) - `(,tag - ((#%unit-with-signature-unit - ,tag) - ,@body))) - linkage:tags prim:links)) - (export ,@prim:exports)) - ',(map named-sig-list->named-sig-vector sign:imports) - ',(sig-list->sig-vector sign:exports))))) - (expand-expr - (structurize-syntax - output - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))))) - (else - (static-error - "compound-unit/sig" 'kwd:compound-unit/sig - expr "malformed expression")))))) - -(add-primitivized-micro-form 'compound-unit/sig full-vocabulary compound-unit/sig-micro) -(add-primitivized-micro-form 'compound-unit/sig scheme-vocabulary compound-unit/sig-micro) - - -; -------------------------------------------------------------------- - -(define iu/s-linkage-vocab - (create-vocabulary 'iu/s-linkage-vocab #f - "malformed linkage declaration" - "malformed linkage declaration" - "malformed linkage declaration" - "malformed linkage declaration")) - -(add-sym-micro iu/s-linkage-vocab - (lambda (expr env attributes vocab) - (cons expr - (signature-exploded (expand-expr expr env attributes sig-vocab))))) - -(add-list-micro iu/s-linkage-vocab - (let* ((kwd '(:)) - (in-pattern-1 '(id : sig)) - (in-pattern-2 '(id : any ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((in:id (pat:pexpand 'id p-env kwd)) - (in:sig (pat:pexpand 'sig p-env kwd))) - (valid-syntactic-id? in:id) - (cons (z:read-object in:id) - (signature-exploded - (expand-expr in:sig env attributes sig-vocab)))))) - ((pat:match-against m&e-2 expr env) - (static-error - "signature" 'term:signature-ambiguous-: expr - "ambiguous : in signature")) - (else - (cons immediate-signature-name - (signature-exploded - (expand-expr expr env attributes sig-vocab)))))))) - -(define iu/s-imports-vocab - (create-vocabulary 'iu/s-imports-vocab #f - "malformed import declaration" - "malformed import declaration" - "malformed import declaration" - "malformed import declaration")) - -(add-sym-micro iu/s-imports-vocab - (lambda (expr env attributes vocab) - (convert-to-prim-format - (signature-elements (expand-expr expr env attributes sig-vocab))))) - -(add-list-micro iu/s-imports-vocab - (let* ((kwd '(:)) - (in-pattern-1 '(id : sig)) - (in-pattern-2 '(id : any ...)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((in:id (pat:pexpand 'id p-env kwd)) - (in:sig (pat:pexpand 'sig p-env kwd))) - (convert-to-prim-format - (signature-elements - (expand-expr in:sig env attributes sig-vocab)) - (z:read-object in:id))))) - ((pat:match-against m&e-2 expr env) - (static-error - "signature" 'term:signature-ambiguous-: expr - "ambiguous : in signature")) - (else - (convert-to-prim-format - (signature-elements - (expand-expr expr env attributes sig-vocab)))))))) - - -(define do-invoke-unit/sig-micro - (lambda (in:expr in:linkage expr env attributes vocab) - (let* ((sigenv (sig-env env)) - (proc:linkage (map (lambda (l) - (expand-expr l sigenv attributes - iu/s-linkage-vocab)) - in:linkage)) - (proc:imports (apply append - (map (lambda (l) - (expand-expr l sigenv attributes - iu/s-imports-vocab)) - in:linkage)))) - (expand-expr - (structurize-syntax - `(let ((unit ,in:expr)) - (#%verify-linkage-signature-match - 'invoke-unit/sig - '(invoke) - (#%list unit) - '(#()) - '(,(map named-sig-list->named-sig-vector proc:linkage))) - (#%invoke-unit - (#%unit-with-signature-unit unit) - ;; Structurize proc:imports without marks to allow capture - ,@(map (lambda (x) (structurize-syntax x expr '())) - proc:imports))) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))) - -(define invoke-unit/sig-micro - (let* ((kwd '()) - (in-pattern '(_ expr linkage ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((in:expr (pat:pexpand 'expr p-env kwd)) - (in:linkage (pat:pexpand '(linkage ...) p-env kwd))) - (do-invoke-unit/sig-micro - in:expr in:linkage - expr env attributes vocab)))) - (else - (static-error - "invoke-unit/sig" 'kwd:invoke-unit/sig - expr "malformed expression")))))) - -(add-primitivized-micro-form 'invoke-unit/sig full-vocabulary invoke-unit/sig-micro) -(add-primitivized-micro-form 'invoke-unit/sig scheme-vocabulary invoke-unit/sig-micro) - -(define unit->unit/sig-micro - (let* ((kwd '()) - (in-pattern '(_ expr (in-sig ...) out-sig)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((in-expr (pat:pexpand 'expr p-env kwd)) - (in-sigs (pat:pexpand '(in-sig ...) p-env kwd)) - (out-sig (pat:pexpand 'out-sig p-env kwd)) - (sigenv (sig-env env))) - (expand-expr - (structurize-syntax - `(#%make-unit-with-signature - ,in-expr - ',(map - named-sig-list->named-sig-vector - (map (lambda (s) - (let ((proc:s - (expand-expr s sigenv attributes - sig-vocab))) - (cons (signature-name proc:s) - (signature-exploded proc:s)))) - in-sigs)) - ',(sig-list->sig-vector - (let ((proc:s - (expand-expr out-sig sigenv attributes sig-vocab))) - (signature-exploded proc:s)))) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))) - (else - (static-error - "unit->unit/sig" 'kwd:unit->unit/sig - expr "malformed expression")))))) - -(add-primitivized-micro-form 'unit->unit/sig full-vocabulary unit->unit/sig-micro) -(add-primitivized-micro-form 'unit->unit/sig scheme-vocabulary unit->unit/sig-micro) - -(define do-define-invoke-micro - (lambda (global? in:expr in:export in:imports prefix expr env attributes vocab) - (let* ((sigenv (sig-env env)) - (proc:linkage (map (lambda (l) - (expand-expr l sigenv attributes - iu/s-linkage-vocab)) - in:imports)) - (proc:ex-linkage (expand-expr in:export sigenv attributes - u/s-sign-exports-vocab)) - (proc:imports (apply append - (map (lambda (l) - (expand-expr l sigenv attributes - iu/s-imports-vocab)) - in:imports))) - (proc:exports (expand-expr in:export sigenv attributes - iu/s-imports-vocab))) - (expand-expr - (structurize-syntax - `(,(if global? - 'global-define-values/invoke-unit - 'define-values/invoke-unit) - ,(map (lambda (x) (structurize-syntax x expr '())) - proc:exports) - (let ((unit ,in:expr)) - (#%verify-linkage-signature-match - 'invoke-unit/sig - '(invoke) - (#%list unit) - '(,(sig-list->sig-vector proc:ex-linkage)) - '(,(map named-sig-list->named-sig-vector proc:linkage))) - (#%unit/sig->unit unit)) - ,prefix - ;; Structurize proc:imports without marks to allow capture - ,@(map (lambda (x) (structurize-syntax x expr '())) - proc:imports)) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))) - -(define (make-define-values/invoke-unit/sig-micro global?) - (let* ((kwd '()) - (in-pattern '(_ export expr)) - (in-pattern2 '(_ export expr prefix linkage ...)) - (m&e (pat:make-match&env in-pattern kwd)) - (m&e2 (pat:make-match&env in-pattern2 kwd)) - (badsyntax (lambda (expr why) - (static-error - (if global? - "global-define-values" - "define-values") - (if global? - 'kwd:global-define-values - 'kwd:define-values) - expr - (format "Malformed ~adefine-values/invoke-unit/sig~a" - (if global? "global-" "") - why))))) - (lambda (expr env attributes vocab) - (let ([doit (lambda (p-env prefix?) - (let ((in:export (pat:pexpand 'export p-env kwd)) - (in:expr (pat:pexpand 'expr p-env kwd)) - (in:prefix (and prefix? (pat:pexpand 'prefix p-env kwd))) - (in:linkage (if prefix? - (pat:pexpand '(linkage ...) p-env kwd) - null))) - (unless (or (z:symbol? in:prefix) - (and (z:boolean? in:prefix) - (not (z:read-object in:prefix))) - (not in:prefix)) - (badsyntax expr " (bad prefix)")) - (do-define-invoke-micro - global? - in:expr in:export in:linkage in:prefix - expr env attributes vocab)))]) - - (cond - [(pat:match-against m&e expr env) - => (lambda (p-env) - (doit p-env #f))] - [(pat:match-against m&e2 expr env) - => (lambda (p-env) - (doit p-env #t))] - [else - (badsyntax expr "")]))))) - -(add-on-demand-form 'micro 'define-values/invoke-unit/sig common-vocabulary - (make-define-values/invoke-unit/sig-micro #f)) -(add-on-demand-form 'micro 'global-define-values/invoke-unit/sig common-vocabulary - (make-define-values/invoke-unit/sig-micro #t)) diff --git a/collects/zodiac/scm-main.ss b/collects/zodiac/scm-main.ss deleted file mode 100644 index 88b833fb..00000000 --- a/collects/zodiac/scm-main.ss +++ /dev/null @@ -1,2454 +0,0 @@ -; $Id: scm-main.ss,v 1.208 2000/05/31 18:55:21 shriram Exp $ - -(unit/sig zodiac:scheme-main^ - (import zodiac:misc^ zodiac:structures^ - (z : zodiac:scanner-parameters^) - (z : zodiac:reader-structs^) - (z : zodiac:reader-code^) - zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ - zodiac:back-protocol^ zodiac:expander^ zodiac:interface^) - - ; ---------------------------------------------------------------------- - - (define-struct (if-form struct:form) (test then else)) - (define-struct (set!-form struct:form) (var val)) - (define-struct (define-values-form struct:form) (vars val)) - (define-struct (let-values-form struct:form) (vars vals body)) - (define-struct (letrec-values-form struct:form) (vars vals body)) - (define-struct (quote-form struct:form) (expr)) - (define-struct (begin-form struct:form) (bodies)) - (define-struct (begin0-form struct:form) (bodies)) - (define-struct (case-lambda-form struct:form) (args bodies)) - (define-struct (struct-form struct:form) (type super fields)) - (define-struct (with-continuation-mark-form struct:form) (key val body)) - - ; ---------------------------------------------------------------------- - - (define create-const - (lambda (c s) - (make-quote-form (zodiac-origin s) - (zodiac-start s) (zodiac-finish s) - (make-empty-back-box) c))) - - (define expands<%> (interface () expand)) - - (add-lit-micro - common-vocabulary - (lambda (expr env attributes vocab) - (if (z:external? expr) - (let ([obj (z:read-object expr)]) - (if (is-a? obj expands<%>) - (expand-expr (send obj expand expr) env attributes vocab) - (create-const expr expr))) - (create-const expr expr)))) - - ; ---------------------------------------------------------------------- - - (define create-case-lambda-form - (lambda (args bodies source) - (make-case-lambda-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) args bodies))) - - (define create-if-form - (lambda (test then else source) - (make-if-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) test then else))) - - (define create-begin-form - (lambda (bodies source) - (make-begin-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) bodies))) - - (define create-begin0-form - (lambda (bodies source) - (make-begin0-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) bodies))) - - (define create-quote-form - (lambda (expr source) - (make-quote-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) expr))) - - (define create-set!-form - (lambda (var val source) - (make-set!-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) var val))) - - (define create-define-values-form - (lambda (vars val source) - (make-define-values-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) vars val))) - - (define create-let-values-form - (lambda (vars vals body source) - (make-let-values-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) vars vals body))) - - (define create-letrec-values-form - (lambda (vars vals body source) - (make-letrec-values-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) vars vals body))) - - (define create-struct-form - (lambda (type super fields source) - (make-struct-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) type super fields))) - - (define create-with-continuation-mark-form - (lambda (key val body source) - (make-with-continuation-mark-form (zodiac-origin source) - (zodiac-start source) (zodiac-finish source) - (make-empty-back-box) key val body))) - - ; ---------------------------------------------------------------------- - - (extend-parsed->raw if-form? - (lambda (expr p->r) - `(if ,(p->r (if-form-test expr)) - ,(p->r (if-form-then expr)) - ,(p->r (if-form-else expr))))) - - (extend-parsed->raw set!-form? - (lambda (expr p->r) - `(set! ,(p->r (set!-form-var expr)) - ,(p->r (set!-form-val expr))))) - - (extend-parsed->raw define-values-form? - (lambda (expr p->r) - `(define-values ,(map p->r (define-values-form-vars expr)) - ,(p->r (define-values-form-val expr))))) - - (extend-parsed->raw let-values-form? - (lambda (expr p->r) - `(let-values - ,(map (lambda (vars val) - (list (map p->r vars) (p->r val))) - (let-values-form-vars expr) (let-values-form-vals expr)) - ,(p->r (let-values-form-body expr))))) - - (extend-parsed->raw letrec-values-form? - (lambda (expr p->r) - `(letrec-values - ,(map (lambda (vars val) - (list (map p->r vars) (p->r val))) - (letrec-values-form-vars expr) (letrec-values-form-vals expr)) - ,(p->r (letrec-values-form-body expr))))) - - (extend-parsed->raw quote-form? - (lambda (expr p->r) - `(quote ,(sexp->raw (quote-form-expr expr))))) - - (extend-parsed->raw begin-form? - (lambda (expr p->r) - `(begin ,@(map p->r (begin-form-bodies expr))))) - - (extend-parsed->raw begin0-form? - (lambda (expr p->r) - `(begin0 ,@(map p->r (begin0-form-bodies expr))))) - - (extend-parsed->raw case-lambda-form? - (lambda (expr p->r) - `(case-lambda - ,@(map (lambda (arg body) - `(,(p->r arg) ,(p->r body))) - (case-lambda-form-args expr) - (case-lambda-form-bodies expr))))) - - (extend-parsed->raw struct-form? - (lambda (expr p->r) - `(struct - ,(if (struct-form-super expr) - (list (sexp->raw (struct-form-type expr)) - (p->r (struct-form-super expr))) - (sexp->raw (struct-form-type expr))) - ,(map sexp->raw (struct-form-fields expr))))) - - (extend-parsed->raw with-continuation-mark-form? - (lambda (expr p->r) - `(with-continuation-mark - ,(p->r (with-continuation-mark-form-key expr)) - ,(p->r (with-continuation-mark-form-val expr)) - ,(p->r (with-continuation-mark-form-body expr))))) - - ; ---------------------------------------------------------------------- - - (define (get-expr-pattern begin?) - (if begin? - (if (eq? begin? 'optional) - '(expr ...) - '(expr0 expr ...)) - '(expr))) - - (define parse-expr - (lambda (who-str kwd:who expr bodies env attributes vocab source) - ;; Do internal definition parsing - (let*-values - (((internal-define-vocab) - (append-vocabulary internal-define-vocab-delta - vocab 'internal-define-vocab)) - ((definitions parsed-first-term rest-terms bindings) - (let loop ((seen null) (rest bodies) (prev #f) (bindings null) (vars-seen null)) - (if (null? rest) - (static-error - "internal definition" 'term:internal-def-not-foll-by-expr - prev - (if (null? seen) - (static-error - who-str kwd:who - expr "malformed expression") - (if (null? (cdr seen)) - "internal definition not followed by expression" - "internal definitions not followed by expression"))) - (let ((first (car rest))) - (let* ((internal? (get-internal-define-status attributes)) - (_ (set-internal-define-status attributes #t)) - (e-first (expand-expr first env - attributes - internal-define-vocab)) - (_ (set-internal-define-status attributes internal?))) - (cond - [(internal-definition? e-first) - (let ((def-vars (internal-definition-vars e-first))) - (let* ((new-vars+marks - (map create-lexical-binding+marks - def-vars))) - (for-each - (lambda (v) - (when (memq (z:read-object v) - vars-seen) - (static-error - "internal definition" - 'term:duplicate-internal-def - v - "duplicate definition for identifier ~a" - (z:read-object v)))) - def-vars) - (extend-env new-vars+marks env) - (loop (cons e-first seen) - (cdr rest) - first - (cons new-vars+marks bindings) - (append vars-seen - (map z:read-object def-vars)))))] - [(internal-begin? e-first) - (loop seen - (append (internal-begin-exprs e-first) (cdr rest)) - first - bindings vars-seen)] - [else - (values (reverse seen) - e-first - (cdr rest) - bindings)]))))))) - (if (null? definitions) - - ;; No internal defines - (if (null? rest-terms) - parsed-first-term - (create-begin-form - (cons parsed-first-term - (map (lambda (e) - (expand-expr e env attributes - vocab)) - rest-terms)) - expr)) - - ;; Found internal defines - (begin0 - (create-letrec-values-form - (reverse (map (lambda (vars+marks) - (map car vars+marks)) - bindings)) - (map (lambda (def) - (expand-expr (internal-definition-val def) - env attributes vocab)) - definitions) - (if (null? rest-terms) - parsed-first-term - (create-begin-form - (cons parsed-first-term - (map (lambda (e) - (expand-expr e env attributes vocab)) - rest-terms)) - expr)) - expr) - (for-each (lambda (new-vars+marks) - (retract-env (map car new-vars+marks) env)) - bindings)))))) - - ; ---------------------------------------------------------------------- - - (define (make-lambda-error-micro who) - (lambda (expr env attributes vocab) - (static-error - "lambda" 'term:case/lambda-only-in-def - expr "allowed only in a definition"))) - - (define (make-case-lambda-micro begin? arglist-decls-vocab) - (let* ((kwd `(else)) - (in-pattern `(_ - (args ,@(get-expr-pattern begin?)) - ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((args (pat:pexpand '(args ...) p-env kwd)) - (bodies (pat:pexpand `((,@(get-expr-pattern begin?)) ...) - p-env kwd))) - (let ((arglists+exprs - (map - (lambda (arg body) - (distinct-valid-syntactic-id/s? arg) - (let* ((arglist - (expand-expr arg env attributes - arglist-decls-vocab)) - (arg-vars+marks - (arglist-vars arglist))) - (extend-env arg-vars+marks env) - (begin0 - (cons - (make-argument-list arglist) - (as-nested - attributes - (lambda () - (parse-expr "case-lambda" 'kwd:case-lambda - expr body env attributes vocab expr)))) - (retract-env (map car arg-vars+marks) env)))) - args bodies))) - (create-case-lambda-form - (map car arglists+exprs) - (map cdr arglists+exprs) - expr))))) - (else - (static-error - "case-lambda" 'kwd:case-lambda - expr "malformed expression")))))) - - (define beginner+lambda-vocabulary - (create-vocabulary 'beginner+lambda-vocabulary - beginner-vocabulary)) - (set-subexpr-vocab! beginner+lambda-vocabulary beginner-vocabulary) - - (add-primitivized-micro-form - 'case-lambda - beginner+lambda-vocabulary - (make-case-lambda-micro #f lambda-nonempty-arglist-decls-vocab)) - (add-primitivized-micro-form - 'case-lambda - beginner-vocabulary - (make-lambda-error-micro 'case-lambda)) - (add-primitivized-micro-form - 'case-lambda - intermediate-vocabulary - (make-case-lambda-micro #f lambda-nonempty-arglist-decls-vocab)) - (add-primitivized-micro-form - 'case-lambda - advanced-vocabulary - (make-case-lambda-micro #f lambda-full-arglist-decls-vocab)) - (add-primitivized-micro-form - 'case-lambda - scheme-vocabulary - (make-case-lambda-micro #t lambda-full-arglist-decls-vocab)) - - (define (make-lambda-macro begin?) - (let* ((kwd '()) - (in-pattern `(_ args ,@(get-expr-pattern begin?))) - (out-pattern `(case-lambda - (args ,@(get-expr-pattern begin?)))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "lambda" 'kwd:lambda - expr "malformed expression"))))) - - (add-primitivized-macro-form - 'lambda - beginner+lambda-vocabulary - (make-lambda-macro #f)) - (add-primitivized-micro-form - 'lambda - beginner-vocabulary - (make-lambda-error-micro 'lambda)) - (add-primitivized-macro-form - 'lambda - intermediate-vocabulary - (make-lambda-macro #f)) - (add-primitivized-macro-form - 'lambda - advanced-vocabulary - (make-lambda-macro #f)) - (add-primitivized-macro-form - 'lambda - scheme-vocabulary - (make-lambda-macro #t)) - - (define-struct internal-definition (vars val)) - (define-struct internal-begin (exprs)) - - (define internal-define-vocab-delta - (create-vocabulary 'internal-define-vocab-delta)) - - (add-primitivized-micro-form 'define-values internal-define-vocab-delta - (let* ((kwd '()) - (in-pattern `(_ (var ...) val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (unless (at-internal-define? attributes) - (static-error - "internal definition" 'term:define-internal-invalid-posn - expr "invalid position")) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let* ((vars (pat:pexpand '(var ...) p-env kwd)) - (_ (map valid-syntactic-id? vars)) - (val (pat:pexpand 'val p-env kwd))) - (for-each (lambda (var) - (let ((r (resolve var env vocab))) - (when (or (micro-resolution? r) - (macro-resolution? r)) - (static-error - "keyword" 'term:cannot-bind-kwd - var - "cannot bind keyword ~s" - (z:symbol-orig-name var))))) - vars) - (make-internal-definition vars val)))) - (else - (static-error - "internal definition" 'kwd:define expr - "malformed definition")))))) - - (add-primitivized-micro-form 'begin internal-define-vocab-delta - (let* ((kwd '()) - (in-pattern `(_ expr ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (if (at-internal-define? attributes) - - ;; Parse begin in internal define context - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let* ((exprs (pat:pexpand '(expr ...) p-env kwd))) - (make-internal-begin exprs)))) - (else - (static-error - "internal begin" 'kwd:begin - expr "malformed expression"))) - - ;; Chain to regular begin: - (begin-micro expr env attributes vocab))))) - - (define begin-micro - (let* ((kwd '()) - (in-pattern `(_ b ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let* ([bodies (pat:pexpand '(b ...) p-env kwd)] - [top? (get-top-level-status attributes)] - [as-nested (if top? (lambda (x y) (y)) as-nested)]) - (if (and (pair? bodies) (null? (cdr bodies))) - (as-nested - attributes - (lambda () - (expand-expr (car bodies) env attributes vocab))) - (if (and (not top?) - (null? bodies)) - (static-error - "begin" 'kwd:begin - expr "malformed expression") - (as-nested - attributes - (lambda () - (create-begin-form - (map (lambda (e) - (expand-expr e env attributes vocab)) - bodies) - expr)))))))) - (else - (static-error - "begin" 'kwd:begin - expr "malformed expression")))))) - - (add-primitivized-micro-form 'begin advanced-vocabulary begin-micro) - (add-primitivized-micro-form 'begin scheme-vocabulary begin-micro) - - (define begin0-micro - (let* ((kwd '()) - (in-pattern `(_ b0 b ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((bodies (pat:pexpand '(b ...) p-env kwd)) - (body0 (pat:pexpand 'b0 p-env kwd))) - (let ([first (as-nested - attributes - (lambda () (expand-expr body0 env attributes vocab)))]) - (if (null? bodies) - first - (let ([rest (as-nested - attributes - (lambda () - (map - (lambda (expr) - (expand-expr expr env attributes vocab)) - bodies)))]) - (create-begin0-form - (cons first rest) - expr))))))) - (else - (static-error - "begin0" 'kwd:begin0 - expr "malformed expression")))))) - - (add-primitivized-micro-form 'begin0 advanced-vocabulary begin0-micro) - (add-primitivized-micro-form 'begin0 scheme-vocabulary begin0-micro) - - (define (make-if-micro one-arm-ok?) - (let* ((kwd '()) - (in-pattern-1 `(_ test then)) - (in-pattern-2 `(_ test then else)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (unless one-arm-ok? - (static-error - "if" 'term:if-must-have-else - expr "must have an else clause")) - (as-nested - attributes - (lambda () - (set-macro-origin - (expand-expr - (structurize-syntax - (pat:pexpand '(if test then (#%void)) p-env kwd) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab) - (syntax-car expr)))))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (as-nested - attributes - (lambda () - (let* ((test-exp (expand-expr - (pat:pexpand 'test p-env kwd) - env attributes vocab)) - (then-exp (expand-expr - (pat:pexpand 'then p-env kwd) - env attributes vocab)) - (else-exp (expand-expr - (pat:pexpand 'else p-env kwd) - env attributes vocab))) - (create-if-form test-exp then-exp else-exp expr)))))) - (else - (static-error - "if" 'kwd:if - expr "malformed expression")))))) - - (add-primitivized-micro-form 'if beginner-vocabulary (make-if-micro #f)) - (add-primitivized-micro-form 'if advanced-vocabulary (make-if-micro #t)) - (add-primitivized-micro-form 'if scheme-vocabulary (make-if-micro #t)) - - (define with-continuation-mark-micro - (let* ((kwd '()) - (in-pattern `(_ key val body)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (as-nested - attributes - (lambda () - (let* ((key-exp (expand-expr - (pat:pexpand 'key p-env kwd) - env attributes vocab)) - (val-exp (expand-expr - (pat:pexpand 'val p-env kwd) - env attributes vocab)) - (body-exp (expand-expr - (pat:pexpand 'body p-env kwd) - env attributes vocab))) - (create-with-continuation-mark-form key-exp val-exp body-exp expr)))))) - (else - (static-error - "with-continuation-mark" 'kwd:with-continuation-mark - expr "malformed expression")))))) - - (add-primitivized-micro-form 'with-continuation-mark scheme-vocabulary with-continuation-mark-micro) - - ; Don't "simplify" this. If replaced with a pattern match, it will - ; die when passed a quote form whose underlying object is an actual - ; Scheme value (as opposed to a struct:read), because the matcher - ; will attempt to extract the source locations of the underlying - ; object, which will fail in this case. - - (define (make-quote-micro non-sym-ok?) - (lambda (expr env attributes vocab) - (if (and (z:list? expr) - (= 2 (z:sequence-length expr))) - (let ((contents (expose-list expr))) - (if (and (z:symbol? (car contents)) - (or (eq? 'quote (z:read-object (car contents))) - (eq? '#%quote (z:read-object (car contents))))) - (if (or non-sym-ok? - (z:symbol? (cadr contents))) - (create-quote-form (cadr contents) expr) - (let*-values ([(v) (sexp->raw (cadr contents))] - [(v prefix) - ;; Strip leading quotes, because user most likely typed ''x - ;; instead of '(quote x) - (let loop ([v v][prefix ""]) - (cond - [(and (pair? v) - (eq? (car v) 'quote) - (pair? (cdr v)) - (null? (cddr v))) - (loop (cadr v) (string-append "'" prefix))] - [else (values v prefix)]))]) - (static-error - "quote" 'term:quote-not-on-symbol - expr "misused: '~a~s is not a symbol" prefix v))) - (static-error - "quote" 'kwd:quote - expr "malformed expression"))) - (static-error - "quote" 'kwd:quote - expr "malformed expression")))) - - (add-primitivized-micro-form 'quote beginner-vocabulary (make-quote-micro #f)) - (add-primitivized-micro-form 'quote intermediate-vocabulary (make-quote-micro #t)) - (add-primitivized-micro-form 'quote scheme-vocabulary (make-quote-micro #t)) - - (define (make-set!-micro dont-mutate-lambda-varrefs?) - (let* ((kwd '()) - (in-pattern `(_ var val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (let ((p-env (pat:match-against m&e expr env))) - (if p-env - (let* ((var-p (pat:pexpand 'var p-env kwd)) - (_ (valid-syntactic-id? var-p)) - (id-expr (expand-expr var-p env attributes - vocab)) - (expr-expr (as-nested - attributes - (lambda () - (expand-expr - (pat:pexpand 'val p-env kwd) - env attributes vocab))))) - (when (and (lambda-varref? id-expr) - dont-mutate-lambda-varrefs?) - (static-error - "set!" 'term:set!-no-mutate-lambda-bound - expr "cannot mutate procedure-bound identifiers")) - (create-set!-form id-expr expr-expr expr)) - (static-error - "set!" 'kwd:set! - expr "malformed expression")))))) - - (add-primitivized-micro-form 'set! - advanced-vocabulary - (make-set!-micro #t)) - (add-primitivized-micro-form 'set! - scheme-vocabulary - (make-set!-micro #f)) - - (define set!-values-micro - (let* ((kwd '()) - (in-pattern '(_ (vars ...) val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let* ((vars (pat:pexpand '(vars ...) p-env kwd)) - (val (pat:pexpand 'val p-env kwd))) - (map valid-syntactic-id? vars) - (let ((new-names (map generate-name vars))) - (expand-expr - (structurize-syntax - `(let-values ((,new-names ,val)) - ,@(map (lambda (var new-name) - `(set! ,var ,new-name)) - vars new-names) - (#%void)) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab))))) - (else - (static-error - "set!-values" 'kwd:set!-values - expr "malformed expression")))))) - - (add-primitivized-micro-form 'set!-values advanced-vocabulary set!-values-micro) - (add-primitivized-micro-form 'set!-values scheme-vocabulary set!-values-micro) - - (define (make-local-extract-vocab) - (create-vocabulary 'local-extract-vocab #f - "invalid expression for local clause" - "invalid expression for local clause" - "invalid expression for local clause" - "invalid expression for local clause")) - - (define nobegin-local-extract-vocab (make-local-extract-vocab)) - (define full-local-extract-vocab (make-local-extract-vocab)) - - (define (make-local-micro begin? local-extract-vocab) - (let* ((kwd '()) - (in-pattern `(_ (defs ...) ,@(get-expr-pattern begin?))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (let ((p-env (pat:match-against m&e expr env))) - (if p-env - (let ((top-level? (get-top-level-status attributes)) - (internal? (get-internal-define-status attributes))) - (set-top-level-status attributes #t) - (set-internal-define-status attributes #f) - (let* - ((defs (pat:pexpand '(defs ...) p-env kwd)) - (vars+exprs - (map - (lambda (e) - (let ((out - (expand-expr e env - attributes - local-extract-vocab))) - out)) - defs))) - (set-top-level-status attributes) - (begin0 - (set-macro-origin - (expand-expr - (structurize-syntax - `(letrec-values - ,(map (lambda (vars+expr) - `(,(car vars+expr) ,(cdr vars+expr))) - vars+exprs) - ,@(pat:pexpand (get-expr-pattern begin?) p-env kwd)) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab) - (syntax-car expr)) - (set-top-level-status attributes top-level?) - (set-internal-define-status attributes internal?)))) - (static-error - "local" 'kwd:local - expr "malformed expression")))))) - - (add-primitivized-micro-form - 'local - intermediate-vocabulary - (make-local-micro #f nobegin-local-extract-vocab)) - (add-on-demand-form - 'micro - 'local - intermediate-vocabulary - (make-local-micro #f nobegin-local-extract-vocab)) - -; (add-primitivized-micro-form -; 'local -; advanced-vocabulary -; (make-local-micro #t full-local-extract-vocab)) -; (add-on-demand-form -; 'micro -; 'local -; advanced-vocabulary -; (make-local-micro #t full-local-extract-vocab)) - - (add-on-demand-form - 'micro - 'local - scheme-vocabulary - (make-local-micro #t full-local-extract-vocab)) - - (define (make-define-forms begin?) - (let* ((kwd '()) - (in-pattern-1 `(_ (fun . args) ,@(get-expr-pattern begin?))) - (out-pattern-1 `(define-values (fun) (lambda args ,@(get-expr-pattern begin?)))) - (in-pattern-2 `(_ var val)) - (out-pattern-2 `(define-values (var) val)) - (in-pattern-3 `(_ (fun . args) b0 b1 ...)) ;; for error reporting - (in-pattern-4 `(_ (fun . args))) ;; for error reporting - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd)) - (m&e-4 (pat:make-match&env in-pattern-4 kwd))) - (values - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) - (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (or (and (not begin?) - (or (pat:match-against m&e-3 expr env) - (pat:match-against m&e-4 expr env)) - (static-error - "define" 'term:define-illegal-implicit-begin - expr "body must have exactly one expression")) - (static-error - "define" 'kwd:define - expr "malformed definition")))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((fun (pat:pexpand 'fun p-env kwd)) - (expr (pat:pexpand `(lambda args ,@(get-expr-pattern begin?)) - p-env kwd))) - (valid-syntactic-id? fun) - (cons (list fun) expr)))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd)) - (val (pat:pexpand 'val p-env kwd))) - (valid-syntactic-id? var) - (cons (list var) val)))) - (else - (static-error - "local define" 'kwd:define - expr "malformed definition"))))))) - - (define-values - (nobegin-define-form nobegin-local-define-form) (make-define-forms #f)) - (define-values - (full-define-form full-local-define-form) (make-define-forms #t)) - - (add-primitivized-macro-form 'define beginner-vocabulary nobegin-define-form) -; (add-primitivized-macro-form 'define advanced-vocabulary full-define-form) - (add-primitivized-macro-form 'define scheme-vocabulary full-define-form) - - (add-primitivized-micro-form 'define - full-local-extract-vocab - full-local-define-form) - (add-primitivized-micro-form 'define - nobegin-local-extract-vocab - nobegin-local-define-form) - - (let* ((kwd '()) - (in-pattern-1 `(_ (var ...) val)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd))) - (let ((define-values-helper - (lambda (internal-ok? handler) - (lambda (expr env attributes vocab) - (unless (at-top-level? attributes) - (static-error - "definition" - (if internal-ok? - 'term:invalid-intl-defn-posn - 'term:def-not-at-top-level) - expr - (if internal-ok? - "invalid position for internal definition" - "must be at the top level"))) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let* ((vars (pat:pexpand '(var ...) - p-env kwd)) - (_ (map valid-syntactic-id? vars)) - (val (pat:pexpand 'val p-env kwd)) - (out (as-nested - attributes - (lambda () - (handler expr env - attributes vocab vars val))))) - out))) - (else (static-error - "define-values" 'kwd:define-values - expr - "malformed definition"))))))) - (let ([make-dv-micro - (lambda (internal-ok? use-beg-lambda-vocab?) - (define-values-helper - internal-ok? - (lambda (expr env attributes vocab vars val) - (let* ((id-exprs (map (lambda (v) - (expand-expr v env - attributes vocab)) - vars)) - (expr-expr (as-nested - attributes - (lambda () - (expand-expr val env - attributes - (if use-beg-lambda-vocab? - beginner+lambda-vocabulary - vocab)))))) - (create-define-values-form id-exprs - expr-expr expr)))))]) - (add-primitivized-micro-form 'define-values - beginner-vocabulary - (make-dv-micro #f #t)) - (add-primitivized-micro-form 'define-values - intermediate-vocabulary - (make-dv-micro #f #f)) - (add-primitivized-micro-form 'define-values - advanced-vocabulary - (make-dv-micro #f #f)) - (add-primitivized-micro-form 'define-values - scheme-vocabulary - (make-dv-micro #t #f))) - (let ([int-dv-micro (define-values-helper - #t - (lambda (expr env attributes vocab vars val) - (cons vars val)))]) - (add-primitivized-micro-form 'define-values nobegin-local-extract-vocab int-dv-micro) - (add-primitivized-micro-form 'define-values full-local-extract-vocab int-dv-micro)))) - - (define extract-type&super - (let* ((kwd '()) - (ts-pattern '(type super)) - (m&e-ts (pat:make-match&env ts-pattern kwd))) - (lambda (type-spec env allow-supertype?) - (if allow-supertype? - (cond - ((pat:match-against m&e-ts type-spec env) - => - (lambda (tsp-env) - (let* ((type (pat:pexpand 'type tsp-env '())) - (super (pat:pexpand 'super tsp-env '()))) - (and (or (z:symbol? type) - (static-error - "structure definition" 'term:struct-not-id - type "not an identifier")) - (values type super))))) - ((z:symbol? type-spec) - (values type-spec #f)) - (else - (static-error - "super-structure definition" 'term:super-struct-invalid - type-spec "invalid specification"))) - (begin - (unless (z:symbol? type-spec) - (static-error - "super-structure definition" 'term:super-struct-not-id - type-spec "not an identifier")) - (values type-spec #f)))))) - - (define (make-struct-micro allow-supertype?) - (let* ((kwd '()) - (in-pattern `(_ type-spec (fields ...))) - (m&e-in (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-in expr env) - => - (lambda (p-env) - (let* ((fields (pat:pexpand '(fields ...) p-env kwd)) - (type-spec (pat:pexpand 'type-spec p-env kwd))) - (distinct-valid-syntactic-id/s? fields) - (let-values (((type super) - (extract-type&super type-spec env allow-supertype?))) - (create-struct-form - type - (and super (as-nested attributes (lambda () (expand-expr super env attributes vocab)))) - fields - expr))))) - (else - (static-error - "struct" 'kwd:struct - expr "malformed definition")))))) - - (add-primitivized-micro-form 'struct beginner-vocabulary (make-struct-micro #f)) - (add-primitivized-micro-form 'struct advanced-vocabulary (make-struct-micro #t)) - (add-primitivized-micro-form 'struct scheme-vocabulary (make-struct-micro #t)) - - (define generate-struct-names - (opt-lambda (type fields source - (omit-selectors? #f) (omit-setters? #f)) - (let ((name (lambda parts - (structurize-syntax - (apply symbol-append parts) - source)))) - (let ((type (z:read-object type)) - (fields (map z:read-object fields))) - (cons - (name "struct:" type) - (cons - (name "make-" type) - (cons - (name type "?") - (apply append - (map (lambda (field) - (append - (if omit-selectors? - '() - (list (name type "-" field))) - (if omit-setters? - '() - (list (name "set-" type "-" field "!"))))) - fields))))))))) - - (let* ((kwd '()) - (in-pattern '(_ type-spec (fields ...))) - (m&e-in (pat:make-match&env in-pattern kwd))) - (let ((make-ds-micro - (lambda (handler allow-supertype?) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-in expr env) - => - (lambda (p-env) - (let ((fields (pat:pexpand '(fields ...) p-env kwd)) - (type-spec (pat:pexpand 'type-spec p-env kwd))) - (distinct-valid-syntactic-id/s? fields) - (let*-values - (((type super) (extract-type&super type-spec env allow-supertype?)) - ((names) (generate-struct-names type fields expr)) - ((struct-expr) - `(struct ,type-spec ,fields))) - (handler expr env attributes vocab - names struct-expr))))) - (else - (static-error - "define-struct" 'kwd:define-struct - expr "malformed definition"))))))) - (let ([top-level-handler - (lambda (expr env attributes vocab names struct-expr) - (expand-expr - (structurize-syntax - `(define-values ,names ,struct-expr) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab))] - [internal-handler - (lambda (expr env attributes vocab names struct-expr) - (cons names struct-expr))]) - - (add-primitivized-micro-form 'define-struct beginner-vocabulary - (make-ds-micro top-level-handler #f)) - (add-primitivized-micro-form 'define-struct advanced-vocabulary - (make-ds-micro top-level-handler #t)) - (add-primitivized-micro-form 'define-struct scheme-vocabulary - (make-ds-micro top-level-handler #t)) - - (add-primitivized-micro-form 'define-struct nobegin-local-extract-vocab - (make-ds-micro internal-handler #f)) - (add-primitivized-micro-form 'define-struct full-local-extract-vocab - (make-ds-micro internal-handler #t))))) - - (define (make-let-struct-micro begin? allow-supertype?) - (let* ((kwd '()) - (in-pattern `(_ type-spec (fields ...) ,@(get-expr-pattern begin?))) - (m&e-in (pat:make-match&env in-pattern kwd))) - (let ((ls-core - (lambda (handler) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-in expr env) - => - (lambda (p-env) - (handler expr env attributes vocab p-env))) - (else - (static-error - "let-struct" 'kwd:let-struct - expr "malformed expression"))))))) - (ls-core - (lambda (expr env attributes vocab p-env) - (let* ((fields (pat:pexpand '(fields ...) p-env kwd)) - (type-spec (pat:pexpand 'type-spec p-env kwd)) - (body (pat:pexpand `(,@(get-expr-pattern begin?)) p-env kwd))) - (distinct-valid-syntactic-id/s? fields) - (let-values (((type super) - (extract-type&super type-spec env allow-supertype?))) - (expand-expr - (structurize-syntax - `(let-values - ((,(generate-struct-names type fields expr) - (struct ,type-spec ,fields))) - ,@body) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab)))))))) - - (add-primitivized-micro-form 'let-struct - intermediate-vocabulary - (make-let-struct-micro #f #f)) -; (add-primitivized-micro-form 'let-struct -; advanced-vocabulary -; (make-let-struct-micro #t #t)) - (add-primitivized-micro-form 'let-struct - scheme-vocabulary - (make-let-struct-micro #t #t)) - - ; ---------------------------------------------------------------------- - - ; Sometimes a single source symbol appears twice in an expansion. - ; When that happens, we mark all but the first occurrence as a - ; "duplicate" so that syntax-processing tools can correlate - ; identifiers in elaboated syntax to source syntax. - - (define (dup-symbol s) - (z:make-symbol - (make-origin 'duplicated (zodiac-origin s)) - (zodiac-start s) - (zodiac-finish s) - (z:read-object s) - (z:symbol-orig-name s) - (z:symbol-marks s))) - - (define (make-let-macro begin? named?) - ;; >> Broken by current embedded define hacks! << - ;; e.g., (let ([a 7]) (let-macro a void (a)) - (let* ((kwd '()) - - (in-pattern-1 `(_ fun ((v e) ...) ,@(get-expr-pattern begin?))) - (out-pattern-1 `((letrec ((fun (lambda (v ...) ,@(get-expr-pattern begin?)))) - fun-copy) ; fun-copy is fun with a different source - e ...)) - - (in-pattern-2 `(_ ((v e) ...) ,@(get-expr-pattern begin?))) - (out-pattern-2 `(let-values (((v) e) ...) ,@(get-expr-pattern begin?))) - - (m&e-1 (and named? (pat:make-match&env in-pattern-1 kwd))) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env) - (let ((p-env (and named? (pat:match-against m&e-1 expr env)))) - (if (and p-env (z:symbol? (pat:pexpand 'fun p-env kwd))) - (let* ([fun (pat:pexpand 'fun p-env kwd)] - [fun-copy (dup-symbol fun)]) - (pat:pexpand out-pattern-1 - (pat:extend-penv 'fun-copy fun-copy p-env) - kwd)) - (or (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error - "let" 'kwd:let - expr "malformed expression"))))))) - - (add-primitivized-macro-form 'let - intermediate-vocabulary - (make-let-macro #f #f)) - (add-primitivized-macro-form 'let - advanced-vocabulary - (make-let-macro #f #t)) - (add-primitivized-macro-form 'let scheme-vocabulary (make-let-macro #t #t)) - - ; Turtle Macros for Robby - (let ([add-patterned-macro - (lambda (formname form-string kwd:form-name in-pattern out-pattern) - (add-macro-form - formname - intermediate-vocabulary - (let* ((kwd (list formname)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - form-string kwd:form-name - expr "malformed expression"))))))]) - (add-patterned-macro 'tprompt "tprompt" 'kwd:tprompt - '(tprompt E ...) - '(tpromptfn (lambda () E ...))) - (add-patterned-macro 'split "split" 'kwd:split - '(split E ...) - '(splitfn (lambda () E ...))) - (add-patterned-macro 'split* "split*" 'kwd:split* - '(split* E ...) - '(split*fn (list (lambda () E) ...)))) - - (define (make-let*-macro begin?) - (let* ((kwd '()) - (in-pattern-1 `(_ () ,@(get-expr-pattern begin?))) - (out-pattern-1 `(let-values () ,@(get-expr-pattern begin?))) - (in-pattern-2 `(_ ((v0 e0) (v1 e1) ...) ,@(get-expr-pattern begin?))) - (out-pattern-2 `(let ((v0 e0)) (let* ((v1 e1) ...) ,@(get-expr-pattern begin?)))) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) - (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error - "let*" 'kwd:let* - expr "malformed expression"))))) - - (add-primitivized-macro-form 'let* - intermediate-vocabulary - (make-let*-macro #f)) -; (add-primitivized-macro-form 'let* -; advanced-vocabulary -; (make-let*-macro #t)) - (add-primitivized-macro-form 'let* - scheme-vocabulary - (make-let*-macro #t)) - - (define delay-macro - (let* ((kwd '()) - (in-pattern '(_ expr)) - (out-pattern '(#%make-promise (lambda () expr))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "delay" 'kwd:delay - expr "malformed expression"))))) - - (add-primitivized-macro-form 'delay advanced-vocabulary delay-macro) - (add-primitivized-macro-form 'delay scheme-vocabulary delay-macro) - - (define (make-time-macro begin?) - (let* ((kwd '()) - (in-pattern - (if begin? - '(_ e0 e1 ...) - '(_ e0))) - (out-pattern - `(let-values (((v cpu user gc) - (#%time-apply (lambda (dont-care) - ,@(if begin? - '(e0 e1 ...) - '(e0))) - (#%cons (#%quote dont-care) #%null)))) - (#%begin - (#%printf - "cpu time: ~s real time: ~s gc time: ~s~n" - cpu user gc) - (#%apply #%values v)))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "time" 'kwd:time - expr "malformed expression"))))) - - (add-primitivized-macro-form 'time intermediate-vocabulary - (make-time-macro #f)) - (add-primitivized-macro-form 'time scheme-vocabulary - (make-time-macro #t)) - - (define break-list - (lambda (elements counter) - (let loop ((rev-head '()) (tail elements) (counter counter)) - (if (null? counter) - (values (reverse rev-head) tail) - (loop (cons (car tail) rev-head) (cdr tail) (cdr counter)))))) - - (define (make-let-values-micro begin?) - (let* ((kwd '()) - (in-pattern `(_ (((v ...) e) ...) ,@(get-expr-pattern begin?))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((vars (pat:pexpand '((v ...) ...) p-env kwd)) - (vals (pat:pexpand '(e ...) p-env kwd)) - (body (pat:pexpand `(,@(get-expr-pattern begin?)) - p-env kwd))) - (as-nested - attributes - (lambda () - (let* ((all-vars (apply append vars)) - (_ (distinct-valid-syntactic-id/s? all-vars)) - (expanded-vals - (map (lambda (e) - (expand-expr e env attributes vocab)) - vals)) - (new-vars+marks - (map create-lexical-binding+marks all-vars)) - (new-vars - (map car new-vars+marks)) - (_ - (extend-env new-vars+marks env))) - (begin0 - (create-let-values-form - (let loop ((var-lists vars) - (new-vars new-vars)) - (if (null? var-lists) - '() - (let-values (((head tail) - (break-list new-vars - (car var-lists)))) - (cons head - (loop (cdr var-lists) tail))))) - expanded-vals - (parse-expr "let-values" 'kwd:let-values - expr body env attributes vocab expr) - expr) - (retract-env new-vars env)))))))) - (else - (static-error - "let-values" 'kwd:let-values - expr "malformed expression")))))) - - (add-primitivized-micro-form 'let-values - intermediate-vocabulary - (make-let-values-micro #f)) -; (add-primitivized-micro-form 'let-values -; advanced-vocabulary -; (make-let-values-micro #t)) - (add-primitivized-micro-form 'let-values - scheme-vocabulary - (make-let-values-micro #t)) - - (define (make-let*-values-micro begin?) - (let* ((kwd '()) - (in-pattern-1 `(_ () ,@(get-expr-pattern begin?))) - (out-pattern-1 `(let-values () ,@(get-expr-pattern begin?))) - (in-pattern-2 `(_ ((v0 e0) (v1 e1) ...) - ,@(get-expr-pattern begin?))) - (out-pattern-2 `(let-values ((v0 e0)) - (let*-values ((v1 e1) ...) - ,@(get-expr-pattern begin?)))) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) - (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error - "let*-values" 'kwd:let*-values - expr "malformed expression"))))) - - (add-primitivized-macro-form 'let*-values - intermediate-vocabulary - (make-let*-values-micro #f)) -; (add-primitivized-macro-form 'let*-values -; advanced-vocabulary -; (make-let*-values-micro #t)) - (add-primitivized-macro-form 'let*-values - scheme-vocabulary - (make-let*-values-micro #t)) - - (define (make-letrec-values-micro begin?) - (let* ((kwd '()) - (in-pattern `(_ (((v ...) e) ...) ,@(get-expr-pattern begin?))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((vars (pat:pexpand '((v ...) ...) p-env kwd)) - (vals (pat:pexpand '(e ...) p-env kwd)) - (body (pat:pexpand `(,@(get-expr-pattern begin?)) - p-env kwd))) - (let* - ((all-vars (apply append vars)) - (_ (distinct-valid-syntactic-id/s? all-vars)) - (new-vars+marks - (map create-lexical-binding+marks all-vars)) - (new-vars - (map car new-vars+marks)) - (_ - (extend-env new-vars+marks env)) - (expanded-vals - (as-nested - attributes - (lambda () - (map (lambda (e) - (expand-expr e env attributes vocab)) - vals)))) - (result - (create-letrec-values-form - (let loop ((var-lists vars) - (new-vars new-vars)) - (if (null? var-lists) - '() - (let-values (((head tail) - (break-list new-vars - (car var-lists)))) - (cons head - (loop (cdr var-lists) tail))))) - expanded-vals - (as-nested - attributes - (lambda () - (parse-expr "letrec-values" 'kwd:letrec-values - expr body env attributes vocab expr))) - expr)) - (_ (retract-env new-vars env))) - result)))) - (else - (static-error - "letrec-values" 'kwd:letrec-values - expr "malformed expression")))))) - - (add-primitivized-micro-form 'letrec-values - intermediate-vocabulary - (make-letrec-values-micro #f)) -; (add-primitivized-micro-form 'letrec-values -; advanced-vocabulary -; (make-letrec-values-micro #t)) - (add-primitivized-micro-form 'letrec-values - scheme-vocabulary - (make-letrec-values-micro #t)) - - (define (make-letrec-macro begin?) - (let* ((kwd '()) - (in-pattern `(_ ((v e) ...) ,@(get-expr-pattern begin?))) - (m&e (pat:make-match&env in-pattern kwd)) - (out-pattern `(letrec-values (((v) e) ...) ,@(get-expr-pattern begin?)))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "letrec" 'kwd:letrec - expr "malformed expression"))))) - - (add-primitivized-macro-form 'letrec - intermediate-vocabulary - (make-letrec-macro #f)) -; (add-primitivized-macro-form 'letrec -; advanced-vocabulary -; (make-letrec-macro #t)) - (add-primitivized-macro-form 'letrec - scheme-vocabulary - (make-letrec-macro #t)) - - (define (make-or-macro boolean-result? one-or-zero-ok?) - (let* ((kwd '()) - (in-pattern-1 '(_)) - (out-pattern-1 '#f) - (in-pattern-2 '(_ e)) - (out-pattern-2 (if (not boolean-result?) - 'e - '(if e #t #f))) - (in-pattern-3 '(_ e0 e1)) - (out-pattern-3 (if (not boolean-result?) - '(let ((t e0)) (if t t e1)) - '(if e0 #t (if e1 #t #f)))) - (in-pattern-4 '(_ e0 e1 ...)) - (out-pattern-4 (if (not boolean-result?) - '(let ((t e0)) (if t t (or e1 ...))) - '(if e0 #t (or e1 ...)))) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd)) - (m&e-4 (pat:make-match&env in-pattern-4 kwd))) - (lambda (expr env) - (let ((p-env (and one-or-zero-ok? - (pat:match-against m&e-1 expr env)))) - (if p-env - (pat:pexpand out-pattern-1 p-env kwd) - (or (and one-or-zero-ok? - (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env)) - (and (not one-or-zero-ok?) - (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd env)) - (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd env) - (static-error - "or" 'kwd:or - expr "malformed expression"))))))) - - (add-primitivized-macro-form 'or beginner-vocabulary (make-or-macro #t #f)) - (add-primitivized-macro-form 'or advanced-vocabulary (make-or-macro #f #f)) - (add-primitivized-macro-form 'or scheme-vocabulary (make-or-macro #f #t)) - - (add-primitivized-macro-form - 'nor - beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ e0 e1 ...)) - (out-pattern '(#%not (or e0 e1 ...))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "nor" 'kwd:nor - expr "malformed expression"))))) - - (define (make-and-macro boolean-result? one-or-zero-ok?) - (let* ((kwd '()) - (in-pattern-1 '(_)) - (out-pattern-1 '#t) - (in-pattern-2 '(_ e)) - (out-pattern-2 'e) - (in-pattern-3 '(_ e0 e1)) - (out-pattern-3 (if (not boolean-result?) - '(if e0 e1 #f) - '(if e0 (if e1 #t #f) #f))) - (in-pattern-4 '(_ e0 e1 ...)) - (out-pattern-4 '(if e0 (and e1 ...) #f)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd)) - (m&e-4 (pat:make-match&env in-pattern-4 kwd))) - (lambda (expr env) - (or (and one-or-zero-ok? - (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env)) - (and one-or-zero-ok? - (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env)) - (and (not one-or-zero-ok?) - (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd env)) - (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd env) - (static-error - "and" 'kwd:and - expr "malformed expression"))))) - - (add-primitivized-macro-form 'and beginner-vocabulary (make-and-macro #t #f)) - (add-primitivized-macro-form 'and advanced-vocabulary (make-and-macro #f #f)) - (add-primitivized-macro-form 'and scheme-vocabulary (make-and-macro #f #t)) - - (add-primitivized-macro-form - 'nand - beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ e0 e1 ...)) - (out-pattern '(#%not (and e0 e1 ...))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "nand" 'kwd:nand - expr "malformed expression"))))) - - (define recur-macro - (let* ((kwd '()) - (in-pattern '(_ fun ((v e) ...) b ...)) - (out-pattern '(let fun ((v e) ...) b ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "recur" 'kwd:recur - expr "malformed expression"))))) - - (add-primitivized-macro-form 'recur advanced-vocabulary recur-macro) - (add-on-demand-form 'macro 'recur common-vocabulary recur-macro) - - (define rec-macro - (let* ((kwd '()) - (in-pattern '(_ looper body)) - (out-pattern '(letrec ((looper body)) looper-copy)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (let ((p-env (pat:match-against m&e expr env))) - (or (and p-env - (let ([looper (pat:pexpand 'looper p-env kwd)]) - (and (valid-syntactic-id? looper) - (pat:pexpand - out-pattern - (pat:extend-penv 'looper-copy - (dup-symbol looper) - p-env) - kwd)))) - (static-error - "rec" 'kwd:rec - expr "malformed expression")))))) - - (add-primitivized-macro-form 'rec advanced-vocabulary rec-macro) - (add-on-demand-form 'macro 'rec common-vocabulary rec-macro) - - (define-struct cond-clause (text question answer else? =>? or?)) - - (define (make-cond-clause-vocab) - (let([qa-error-msg "clause is not in question-answer format"]) - (create-vocabulary 'cond-clause-vocab #f - qa-error-msg ; symbol - qa-error-msg ; literal - qa-error-msg ; list - qa-error-msg))) ; ilist - - (define nobegin-cond-clause-vocab (make-cond-clause-vocab)) - (define full-cond-clause-vocab (make-cond-clause-vocab)) - - (define (make-cond-list-micro begin? answerless?) - (let* ((kwd '(else =>)) - (in-pattern-1 (if (not begin?) - '(else answer) - '(else answer ...))) - (get-pattern-1 (if (not begin?) - 'answer - '(begin answer ...))) - (in-pattern-3 '(question => answer)) - (in-pattern-2 '(question => answer ...)) - (in-pattern-5 (if (not answerless?) - '(question => answer) ; will not match - '(question))) - (in-pattern-4 (if (not begin?) - '(question answer) - '(question answer ...))) - (get-pattern-4 (if (not begin?) - 'answer - '(begin answer ...))) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd)) - (m&e-4 (pat:make-match&env in-pattern-4 kwd)) - (m&e-5 (pat:make-match&env in-pattern-5 kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((answer (pat:pexpand get-pattern-1 p-env kwd))) - (make-cond-clause expr #f answer #t #f #f)))) - ((pat:match-against m&e-3 expr env) - => - (lambda (p-env) - (let ((question (pat:pexpand 'question p-env kwd)) - (answer (pat:pexpand 'answer p-env kwd))) - (make-cond-clause expr question answer #f #t #f)))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (static-error - "cond" 'term:cond-=>-not-foll-by-1-rcvr - expr "=> not followed by exactly one receiver"))) - ((pat:match-against m&e-5 expr env) - => - (lambda (p-env) - (let ((question (pat:pexpand 'question p-env kwd))) - (make-cond-clause expr question #f #f #f #t)))) - ((pat:match-against m&e-4 expr env) - => - (lambda (p-env) - (let ((question (pat:pexpand 'question p-env kwd)) - (answer (pat:pexpand get-pattern-4 p-env kwd))) - (make-cond-clause expr question answer #f #f #f)))) - (else (static-error - "cond" 'term:cond-clause-not-in-q/a-fmt - expr "clause is not in question-answer format")))))) - - (add-list-micro nobegin-cond-clause-vocab (make-cond-list-micro #f #f)) - (add-list-micro full-cond-clause-vocab (make-cond-list-micro #t #t)) - - (define (make-cond-micro cond-clause-vocab allow-empty?) - (let* ((kwd '()) - (in-pattern '(_ bodies ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((bodies (pat:pexpand '(bodies ...) p-env kwd))) - (let ((exp-bodies - (as-nested - attributes - (lambda () - (map (lambda (e) - (expand-expr e env attributes - cond-clause-vocab)) - bodies))))) - (let ((had-no-clauses? (null? exp-bodies))) - (expand-expr - (structurize-syntax - (let loop ((exps exp-bodies)) - (if (null? exps) - (if (compile-allow-cond-fallthrough) - '(#%void) - `(#%raise - (#%make-exn:else - ,(if (and had-no-clauses? (not allow-empty?)) - "cond must contain at least one clause" - "no matching cond clause") - (#%current-continuation-marks)))) - (let ((first (car exps)) - (rest (cdr exps))) - (cond - ((cond-clause-=>? first) - `(let ((test ,(cond-clause-question first))) - (if test - (,(cond-clause-answer first) test) - ,(loop rest)))) - ((cond-clause-else? first) - (if (null? rest) - (cond-clause-answer first) - (static-error - "cond" 'term:cond-else-only-in-last - (cond-clause-text first) - "else allowed only in last position"))) - ((cond-clause-or? first) - `(or ,(cond-clause-question first) - ,(loop rest))) - (else - `(if ,(cond-clause-question first) - ,(cond-clause-answer first) - ,(loop rest))))))) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab)))))) - (else - (static-error - "cond" 'kwd:cond - expr "malformed expression")))))) - - (add-primitivized-micro-form 'cond beginner-vocabulary (make-cond-micro nobegin-cond-clause-vocab #f)) - (add-primitivized-micro-form 'cond scheme-vocabulary (make-cond-micro full-cond-clause-vocab #t)) - - (define case-macro - (let* ((kwd-1 '(else)) - (in-pattern-1 `(_ val (else ,@(get-expr-pattern #t)))) - (out-pattern-1 `(begin val ,@(get-expr-pattern #t))) - (kwd-2 '()) - (in-pattern-2 '(_ val)) - (out-pattern-2-signal-error - `(#%raise (#%make-exn:else - "no matching else clause" - (#%current-continuation-marks)))) - (out-pattern-2-no-error - '(begin val (#%void))) - (in-pattern-3 `(_ val ((keys ...) ,@(get-expr-pattern #t)) rest ...)) - (out-pattern-3 `(let ((tmp val)) - (if (#%memv tmp (quote (keys ...))) - (begin ,@(get-expr-pattern #t)) - (case tmp rest ...)))) - (m&e-1 (pat:make-match&env in-pattern-1 kwd-1)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd-2)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd-2))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd-1 env) - (if (compile-allow-cond-fallthrough) - (pat:match-and-rewrite expr m&e-2 - out-pattern-2-no-error kwd-2 env) - (pat:match-and-rewrite expr m&e-2 - out-pattern-2-signal-error kwd-2 env)) - (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd-2 env) - (static-error - "case" 'kwd:case - expr "malformed expression"))))) - - (add-primitivized-macro-form 'case advanced-vocabulary case-macro) - (add-primitivized-macro-form 'case scheme-vocabulary case-macro) - - (define evcase-macro - (let* ((kwd-1 '(else)) - (in-pattern-1 `(_ val (else ,@(get-expr-pattern #t)))) - (out-pattern-1 `(begin val ,@(get-expr-pattern #t))) - (kwd-2 '()) - (in-pattern-2 '(_ val)) - (out-pattern-2-signal-error - `(#%raise (#%make-exn:else - "no matching else clause" - (#%current-continuation-marks)))) - (out-pattern-2-no-error - '(begin val (#%void))) - (kwd-3 '(else)) - (in-pattern-3 `(_ val (else ,@(get-expr-pattern #t)) rest)) - (kwd-4 '()) - (in-pattern-4 `(_ val (test-expr ,@(get-expr-pattern #t)) rest ...)) - (out-pattern-4 `(let ((tmp val)) - (if (#%eqv? tmp test-expr) - (begin ,@(get-expr-pattern #t)) - (evcase tmp rest ...)))) - (m&e-1 (pat:make-match&env in-pattern-1 kwd-1)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd-2)) - (m&e-3 (pat:make-match&env in-pattern-3 kwd-3)) - (m&e-4 (pat:make-match&env in-pattern-4 kwd-4))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd-1 env) - (if (compile-allow-cond-fallthrough) - (pat:match-and-rewrite expr m&e-2 - out-pattern-2-no-error kwd-2 env) - (pat:match-and-rewrite expr m&e-2 - out-pattern-2-signal-error kwd-2 env)) - (let ((penv (pat:match-against m&e-3 expr env))) - (if penv - (static-error - "evcase" 'kwd:evcase - expr "else used before last branch") - (or (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd-4 env) - (static-error - "evcase" 'kwd:evcase - expr "malformed expression")))))))) - - (add-primitivized-macro-form 'evcase advanced-vocabulary evcase-macro) - (add-on-demand-form 'macro 'evcase common-vocabulary evcase-macro) - - (define when-macro - (let* ((kwd '()) - (in-pattern `(_ test ,@(get-expr-pattern #t))) - (out-pattern `(if test (begin ,@(get-expr-pattern #t)) (#%void))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "when" 'kwd:when - expr "malformed expression"))))) - - - (add-primitivized-macro-form 'when advanced-vocabulary when-macro) - (add-primitivized-macro-form 'when scheme-vocabulary when-macro) - - (define unless-macro - (let* ((kwd '()) - (in-pattern `(_ test ,@(get-expr-pattern #t))) - (out-pattern `(if test (#%void) (begin ,@(get-expr-pattern #t)))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "unless" 'kwd:unless - expr "malformed expression"))))) - - (add-primitivized-macro-form 'unless advanced-vocabulary unless-macro) - (add-primitivized-macro-form 'unless scheme-vocabulary unless-macro) - - (let ((rewriter - (lambda (call/cc the-kwd kwd-text kwd:the-kwd) - (let* ((kwd '()) - (in-pattern `(_ var ,@(get-expr-pattern #t))) - (out-pattern `(,call/cc (lambda (var) ,@(get-expr-pattern #t)))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - kwd-text kwd:the-kwd - expr "malformed expression"))))))) - (add-primitivized-macro-form 'let/cc advanced-vocabulary - (rewriter '#%call/cc 'let/cc "let/cc" 'kwd:let/cc)) - (add-primitivized-macro-form 'let/cc scheme-vocabulary - (rewriter '#%call/cc 'let/cc "let/cc" 'kwd:let/cc)) - - (add-primitivized-macro-form 'let/ec advanced-vocabulary - (rewriter '#%call/ec 'let/ec "let/ec" 'kwd:let/ec)) - (add-primitivized-macro-form 'let/ec scheme-vocabulary - (rewriter '#%call/ec 'let/ec "let/ec" 'kwd:let/ec))) - - (define do-macro - (let* ((in-kwd '()) - (in-pattern `(_ (var-init-step ...) - (test seq ...) - ,@(get-expr-pattern 'optional))) - (out-pattern `(letrec ((loop - (lambda (var ...) - (if test - (begin (#%void) seq ...) - (begin ,@(get-expr-pattern 'optional) - (loop step ...)))))) - (loop init ...))) - (in-m&e (pat:make-match&env in-pattern in-kwd)) - (vis-kwd '()) - (vis-pattern-1 '(var init step)) - (vis-m&e-1 (pat:make-match&env vis-pattern-1 vis-kwd)) - (vis-pattern-2 '(var init)) - (vis-m&e-2 (pat:make-match&env vis-pattern-2 vis-kwd))) - (lambda (expr env) - (cond - ((pat:match-against in-m&e expr env) - => - (lambda (p-env) - (let ((var-init-steps (pat:pexpand '(var-init-step ...) - p-env in-kwd)) - (test (pat:pexpand 'test p-env in-kwd)) - (seqs (pat:pexpand '(seq ...) p-env in-kwd)) - (body (pat:pexpand `(,@(get-expr-pattern 'optional)) - p-env in-kwd))) - (let - ((normalized-var-init-steps - (map - (lambda (vis) - (cond - ((pat:match-against vis-m&e-1 vis vis-kwd) - => - (lambda (p-env) - `(,(pat:pexpand 'var p-env vis-kwd) - ,(pat:pexpand 'init p-env vis-kwd) - ,(pat:pexpand 'step p-env vis-kwd)))) - ((pat:match-against vis-m&e-2 vis vis-kwd) - => - (lambda (p-env) - `(,(pat:pexpand 'var p-env vis-kwd) - ,(pat:pexpand 'init p-env vis-kwd) - ,(pat:pexpand 'var p-env vis-kwd)))) - (else - (static-error - "do" 'kwd:do - vis - "malformed var-init-step")))) - var-init-steps))) - (let ((vars (map car normalized-var-init-steps)) - (inits (map cadr normalized-var-init-steps)) - (steps (map caddr normalized-var-init-steps))) - (structurize-syntax - `(letrec ((loop - (lambda (,@vars) - (if ,test - (begin (#%void) ,@seqs) - (begin ,@body - (loop ,@steps)))))) - (loop ,@inits)) - expr '(-1) - #f - (make-origin 'macro expr))))))) - (else - (static-error - "do" 'kwd:do - expr "malformed expression")))))) - - (add-primitivized-macro-form 'do advanced-vocabulary do-macro) - (add-primitivized-macro-form 'do scheme-vocabulary do-macro) - - (define fluid-let-macro - (let* ((kwd '()) - (in-pattern `(_ ((var val) ...) ,@(get-expr-pattern #t))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((vars (pat:pexpand '(var ...) p-env kwd)) - (vals (pat:pexpand '(val ...) p-env kwd)) - (body (pat:pexpand (get-expr-pattern #t) p-env kwd))) - (distinct-valid-syntactic-id/s? vars) - (let* ((new-vars (map generate-name vars))) - (expand-expr - (structurize-syntax - (if (null? vars) - `(let-values () ,@body) - `(let ,(map list new-vars vars) - (#%dynamic-wind - (lambda () - ,@(map (lambda (var val) - `(set! ,var ,val)) - vars vals)) - (lambda () - ,@body) - (lambda () - ,@(map (lambda (var tmp) - `(set! ,(dup-symbol var) ,tmp)) - vars new-vars))))) - expr '(-1) - #f - (make-origin 'macro expr)) - env attributes vocab))))) - (else - (static-error - "fluid-let" 'kwd:fluid-let - expr "malformed expression")))))) - - (add-primitivized-micro-form 'fluid-let advanced-vocabulary fluid-let-macro) - (add-primitivized-micro-form 'fluid-let scheme-vocabulary fluid-let-macro) - - (define parameterize-micro - (let* ((kwd '()) - (body (get-expr-pattern #t)) - (in-pattern `(_ ((param value) ...) ,@body)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (let ([p-env (pat:match-against m&e expr env)]) - (if p-env - (let* ((params (pat:pexpand '(param ...) p-env kwd)) - (vals (pat:pexpand '(value ...) p-env kwd)) - (body (pat:pexpand body p-env kwd)) - ;; The following two have this strange code - ;; because generate-name expects a z:symbol, - ;; but the param can be an arbitrary expression, - ;; not just the name of a parameter - (pzs (map generate-name - (map (lambda (param) - (structurize-syntax 'pz param '(-1))) - params))) - (saves (map generate-name - (map (lambda (param) - (structurize-syntax 'save param '(-1))) - params))) - (swap (generate-name (structurize-syntax 'swap expr '(-1))))) - (expand-expr - (structurize-syntax - (if (null? params) - `(let-values () ,@body) - `(let ,(append - (map list pzs params) - (map list saves vals)) - (let ((,swap (lambda () - ,@(map - (lambda (save pz) - `(let ([x ,save]) - (begin - (set! ,save (,pz)) - (,pz x)))) - saves pzs)))) - (#%dynamic-wind - ,swap - (#%lambda () ,@body) - ,swap)))) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab)) - (static-error - "parameterize" 'kwd:parameterize - expr "malformed expression")))))) - - (add-primitivized-micro-form 'parameterize advanced-vocabulary parameterize-micro) - (add-primitivized-micro-form 'parameterize scheme-vocabulary parameterize-micro) - - (define (make-with-handlers-macro begin?) - (let* ((kwd '()) - (in-pattern-1 `(_ () ,@(get-expr-pattern begin?))) - (out-pattern-1 (if (not begin?) - 'expr - `(let-values () ,@(get-expr-pattern begin?)))) - (in-pattern-2 `(_ ((pred handler) ...) ,@(get-expr-pattern begin?))) - (out-pattern-2 - `((#%call/ec - (lambda (k) - (let ((handlers (#%list - (#%cons pred handler) - ...))) - (parameterize - ((#%current-exception-handler - (lambda (e) - (k - (lambda () - (let loop ((handlers handlers)) - (cond - ((#%null? handlers) - (#%raise e)) - (((#%caar handlers) e) - ((#%cdar handlers) e)) - (else - (loop (#%cdr handlers)))))))))) - (#%call-with-values - (lambda () ,@(get-expr-pattern begin?)) - (lambda args - (lambda () (#%apply #%values args)))))))))) - (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) - (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error - "with-handlers" 'kwd:with-handlers - expr "malformed expression"))))) - - (add-primitivized-macro-form 'with-handlers - advanced-vocabulary - (make-with-handlers-macro #f)) - (add-primitivized-macro-form 'with-handlers - scheme-vocabulary - (make-with-handlers-macro #t)) - - (define (norm-path p) ; normalizes ending slash or not - (and p - (let-values ([(base name dir?) (split-path p)]) - (build-path base name)))) - (define mzlib-directory (with-handlers ([void void]) - (norm-path (collection-path "mzlib")))) - (define (get-on-demand-form name vocab) - (let ([dir (norm-path (current-load-relative-directory))]) - (and (equal? dir mzlib-directory) - (find-on-demand-form name vocab)))) - - (add-primitivized-micro-form 'define-macro common-vocabulary - (let* ((kwd '()) - (in-pattern `(_ macro-name macro-handler)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((macro-name (pat:pexpand 'macro-name p-env kwd)) - (macro-handler (pat:pexpand 'macro-handler p-env kwd))) - (valid-syntactic-id? macro-name) - (unless (get-top-level-status attributes) - (static-error - "define-macro" 'kwd:define-macro - expr "only supported at top-level")) - (let* ((real-name (sexp->raw macro-name))) - (let ([on-demand (get-on-demand-form real-name vocab)]) - (if on-demand - (case (car on-demand) - [(micro) (add-primitivized-micro-form real-name vocab (cadr on-demand))] - [(macro) (add-primitivized-macro-form real-name vocab (cadr on-demand))]) - (let* ((expanded-handler (as-nested - attributes - (lambda () - (expand-expr macro-handler - env attributes vocab)))) - (real-handler (m3-elaboration-evaluator - expanded-handler - parsed->raw - 'define-macro)) - (cache-table (make-hash-table))) - (unless (procedure? real-handler) - (static-error - "define-macro" 'kwd:define-macro - expr "expander is not a procedure")) - (add-user-macro-form - real-name vocab - (lambda (m-expr m-env) - (structurize-syntax - (apply m3-macro-body-evaluator real-handler - (cdr (sexp->raw m-expr cache-table))) - m-expr '() cache-table - (make-origin 'macro expr))))))) - (expand-expr (structurize-syntax '(#%void) expr - '() #f (make-origin 'micro expr)) - env attributes vocab))))) - (else - (static-error - "define-macro" 'kwd:define-macro - expr "malformed definition")))))) - - (add-primitivized-micro-form 'let-macro common-vocabulary - (let* ((kwd '()) - (in-pattern `(_ macro-name macro-handler b0 b1 ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((macro-name (pat:pexpand 'macro-name p-env kwd)) - (macro-handler (pat:pexpand 'macro-handler p-env kwd)) - (body (pat:pexpand '(begin b0 b1 ...) p-env kwd))) - (valid-syntactic-id? macro-name) - (let* ((real-name (sexp->raw macro-name)) - (expanded-handler (as-nested - attributes - (lambda () - (expand-expr macro-handler - env attributes vocab)))) - (real-handler (m3-elaboration-evaluator - expanded-handler - parsed->raw - 'let-macro)) - (cache-table (make-hash-table))) - (unless (procedure? real-handler) - (static-error - "let-macro" 'kwd:let-macro - expr "expander is not a procedure")) - (let ((extended-vocab - (create-vocabulary 'user-macro-extended-vocab - vocab))) - (add-user-macro-form real-name extended-vocab - (lambda (m-expr m-env) - (structurize-syntax - (apply m3-macro-body-evaluator real-handler - (cdr (sexp->raw m-expr cache-table))) - m-expr '() cache-table - (make-origin 'macro expr)))) - (expand-expr - (structurize-syntax body expr - '() - #f (make-origin 'micro expr)) - env attributes extended-vocab)))))) - (else - (static-error - "let-macro" 'kwd:let-macro - expr "malformed expression")))))) - - (let ((b-e/c-t - (lambda (kwd-symbol kwd:kwd-symbol kwd-string phase-string on-demand?) - (let ([micro (let* ((kwd '()) - (in-pattern '(_ e0 e1 ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((exprs (pat:pexpand '(begin e0 e1 ...) - p-env kwd))) - (expand-expr - (structurize-syntax - (with-handlers - ((exn? (lambda (exn) - (static-error - kwd-string - kwd:kwd-symbol - expr - "exception at ~a time: ~a" - phase-string - (exn-message exn))))) - (m3-elaboration-evaluator - (let ([top-level? (get-top-level-status attributes)] - [internal? (get-internal-define-status attributes)]) - (dynamic-wind - (lambda () - (set-top-level-status attributes #t) - (set-internal-define-status attributes #f)) - (lambda () - (expand - (structurize-syntax exprs expr) - attributes vocab - m3-elaboration-evaluator - m3-macro-body-evaluator)) - (lambda () - (set-top-level-status attributes top-level?) - (set-internal-define-status attributes internal?)))) - parsed->raw - kwd-symbol)) - expr - '() #f (make-origin 'micro expr)) - env attributes vocab)))) - (else - (static-error - kwd-string kwd:kwd-symbol - expr - "malformed expression")))))]) - (add-micro-form kwd-symbol full-vocabulary micro) - (if on-demand? - (add-on-demand-form 'micro kwd-symbol scheme-vocabulary micro) - (add-micro-form kwd-symbol scheme-vocabulary micro)))))) - (b-e/c-t 'begin-construction-time 'kwd:begin-construction-time - "begin-construction-time" "construction" #t) - (b-e/c-t 'begin-elaboration-time 'kwd:begin-elaboration-time - "begin-elaboration-time" "elaboration" #f)) - - (define unquote-micro - (lambda (expr env) - (static-error - "unquote" 'kwd:unquote - expr "outside quasiquote"))) - (add-primitivized-macro-form 'unquote intermediate-vocabulary unquote-micro) - (add-primitivized-macro-form 'unquote scheme-vocabulary unquote-micro) - - (define unquote-splicing-micro - (lambda (expr env) - (static-error - "unquote-splicing" 'kwd:unquote-splicing - expr "outside quasiquote"))) - (add-primitivized-macro-form 'unquote-splicing intermediate-vocabulary unquote-splicing-micro) - (add-primitivized-macro-form 'unquote-splicing scheme-vocabulary unquote-splicing-micro) - - (include "quasi.ss") - - (define reference-file-macro - (let* ((kwd '()) - (in-pattern '(_ filename)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd))) - (let ((f (expand-expr filename env attributes vocab))) - (if (and (quote-form? f) - (z:string? (quote-form-expr f))) - (expand-expr - (structurize-syntax - `(#%load/use-compiled ,(quote-form-expr f)) - expr '(-1) - #f - (make-origin 'macro expr)) - env attributes vocab) - (static-error - "reference-file" 'kwd:reference-file - filename "Does not yield a filename")))))) - (else - (static-error - "reference-file" 'kwd:reference-file - expr "Malformed reference-file")))))) - - (add-primitivized-micro-form 'reference-file beginner-vocabulary reference-file-macro) - (add-on-demand-form 'micro 'reference-file common-vocabulary reference-file-macro) - - (define require-library-micro - (let* ((kwd '()) - (in-pattern '(_ filename collections ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd)) - (collections (pat:pexpand '(collections ...) p-env kwd))) - (let ((f (as-nested attributes (lambda () (expand-expr filename env attributes vocab)))) - (cs (as-nested - attributes - (lambda () - (map (lambda (c) - (expand-expr c env attributes vocab)) - collections))))) - (unless (and (quote-form? f) - (z:string? (quote-form-expr f))) - (static-error - "require-library" 'kwd:require-library - filename "Does not yield a filename")) - (for-each - (lambda (c collection) - (unless (and (quote-form? c) - (z:string? (quote-form-expr c))) - (static-error - "require-library" 'kwd:require-library - collection "Does not yield a string"))) - cs collections) - (let ((raw-f (z:read-object (quote-form-expr f))) - (raw-cs (map (lambda (c) - (z:read-object (quote-form-expr c))) - cs))) - (unless (relative-path? raw-f) - (static-error - "require-library" 'kwd:require-library - f - "Library path ~s must be a relative path" - raw-f)) - (expand-expr - (structurize-syntax - `(#%require-library/proc ,(quote-form-expr f) - ,@(map quote-form-expr cs)) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab)))))) - (else - (static-error - "require-library" 'kwd-require-library - expr "Malformed require-library")))))) - - (add-primitivized-micro-form 'require-library beginner-vocabulary require-library-micro) - (add-primitivized-micro-form 'require-library scheme-vocabulary require-library-micro) - - (define require-relative-library-micro - (let* ((kwd '()) - (in-pattern '(_ filename collections ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd)) - (collections (pat:pexpand '(collections ...) p-env kwd))) - (let ((f (as-nested attributes (lambda () (expand-expr filename env attributes vocab)))) - (cs (as-nested - attributes - (lambda () - (map (lambda (c) - (expand-expr c env attributes vocab)) - collections))))) - (unless (and (quote-form? f) - (z:string? (quote-form-expr f))) - (static-error - "require-relative-library" - 'kwd:require-relative-library - filename "Does not yield a filename")) - (for-each - (lambda (c collection) - (unless (and (quote-form? c) - (z:string? (quote-form-expr c))) - (static-error - "require-relative-library" - 'kwd:require-relative-library - collection "Does not yield a string"))) - cs collections) - (let ((raw-f (z:read-object (quote-form-expr f))) - (raw-cs (map (lambda (c) - (z:read-object (quote-form-expr c))) - cs))) - (unless (relative-path? raw-f) - (static-error - "require-relative-library" - 'kwd:require-relative-library - f - "library path ~s must be a relative path" - raw-f)) - (expand-expr - (structurize-syntax - `(#%require-relative-library/proc ,(quote-form-expr f) - ,@(map quote-form-expr cs)) - expr '(-1) - #f - (make-origin 'micro expr)) - env attributes vocab)))))) - (else - (static-error - "require-relative-library" 'kwd:require-relative-library - expr "malformed expression")))))) - - (add-primitivized-micro-form 'require-relative-library beginner-vocabulary require-relative-library-micro) - (add-primitivized-micro-form 'require-relative-library scheme-vocabulary require-relative-library-micro) - - (add-on-demand-form 'micro 'define-constructor beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ sym modes ...)) - (m&e (pat:make-match&env in-pattern kwd)) - (out-pattern '(#%void))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "define-constructor" 'kwd:define-constructor - expr "malformed definition"))))) - - (add-on-demand-form 'macro 'define-type beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ sym type)) - (m&e (pat:make-match&env in-pattern kwd)) - (out-pattern '(#%void))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "define-type" 'kwd:define-type - expr "malformed definition"))))) - - (add-on-demand-form 'macro ': beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ expr type)) - (m&e (pat:make-match&env in-pattern kwd)) - (out-pattern 'expr)) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - ":" 'kwd:: - expr "malformed declaration"))))) - - (add-on-demand-form 'macro 'type: beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ type attr ...)) - (out-pattern '(#%void)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "type:" 'kwd:type: - expr "malformed declaration"))))) - - (add-on-demand-form 'macro 'mrspidey:control beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ para val)) - (m&e (pat:make-match&env in-pattern kwd)) - (out-pattern '(#%void))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "mrspidey:control" 'kwd:mrspidey:control - expr "malformed declaration"))))) - - (add-on-demand-form 'macro 'polymorphic beginner-vocabulary - (let* ((kwd '()) - (in-pattern '(_ body)) - (m&e (pat:make-match&env in-pattern kwd)) - (out-pattern 'body)) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "polymorphic" 'kwd:polymorpic - expr "malformed declaration"))))) - - ) diff --git a/collects/zodiac/scm-obj.ss b/collects/zodiac/scm-obj.ss deleted file mode 100644 index bc8f325c..00000000 --- a/collects/zodiac/scm-obj.ss +++ /dev/null @@ -1,880 +0,0 @@ -; $Id: scm-obj.ss,v 1.44 1999/05/21 12:53:29 mflatt Exp $ - -(unit/sig zodiac:scheme-objects^ - (import zodiac:misc^ (z : zodiac:structures^) (z : zodiac:reader-structs^) - zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ - zodiac:scheme-main^ zodiac:back-protocol^ - zodiac:expander^ zodiac:interface^) - - (define-struct (class*/names-form struct:parsed) - (this super-init super-expr interfaces init-vars inst-clauses)) - - (define-struct (interface-form struct:parsed) - (super-exprs variables)) - - (define create-class*/names-form - (lambda (this super-init super-expr interfaces - init-vars inst-clauses source) - (make-class*/names-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - this super-init super-expr interfaces init-vars inst-clauses))) - - (define create-interface-form - (lambda (super-exprs variables source) - (make-interface-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - super-exprs variables))) - - (define-struct (supervar-binding struct:binding) ()) - (define-struct (superinit-binding struct:binding) ()) - (define-struct (public-binding struct:binding) ()) - (define-struct (override-binding struct:binding) ()) - (define-struct (private-binding struct:binding) ()) - (define-struct (inherit-binding struct:binding) ()) - (define-struct (rename-binding struct:binding) ()) - - (define create-supervar-binding+marks - (create-binding+marks make-supervar-binding)) - (define create-superinit-binding+marks - (create-binding+marks make-superinit-binding)) - (define create-public-binding+marks - (create-binding+marks make-public-binding)) - (define create-override-binding+marks - (create-binding+marks make-override-binding)) - (define create-private-binding+marks - (create-binding+marks make-private-binding)) - (define create-inherit-binding+marks - (create-binding+marks make-inherit-binding)) - (define create-rename-binding+marks - (create-binding+marks make-rename-binding)) - - (define-struct (supervar-varref struct:bound-varref) ()) - (define-struct (superinit-varref struct:bound-varref) ()) - (define-struct (public-varref struct:bound-varref) ()) - (define-struct (override-varref struct:bound-varref) ()) - (define-struct (private-varref struct:bound-varref) ()) - (define-struct (inherit-varref struct:bound-varref) ()) - (define-struct (rename-varref struct:bound-varref) ()) - - (define create-supervar-varref - (create-bound-varref make-supervar-varref)) - (define create-superinit-varref - (create-bound-varref make-superinit-varref)) - (define create-public-varref - (create-bound-varref make-public-varref)) - (define create-override-varref - (create-bound-varref make-override-varref)) - (define create-private-varref - (create-bound-varref make-private-varref)) - (define create-inherit-varref - (create-bound-varref make-inherit-varref)) - (define create-rename-varref - (create-bound-varref make-rename-varref)) - - (define-struct public-clause (exports internals exprs)) - (define-struct override-clause (exports internals exprs)) - (define-struct private-clause (internals exprs)) - (define-struct inherit-clause (internals imports)) - (define-struct rename-clause (internals imports)) - (define-struct sequence-clause (exprs)) - - ; -------------------------------------------------------------------- - - (define interface-micro - (let* ((kwd '()) - (in-pattern `(_ - (super-interfaces ...) - variables ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((super-interfaces - (pat:pexpand '(super-interfaces ...) p-env kwd)) - (variables - (pat:pexpand '(variables ...) p-env kwd))) - (distinct-valid-syntactic-id/s? variables) - (let* ((proc:super-interfaces - (as-nested - attributes - (lambda () - (map (lambda (e) - (expand-expr e env - attributes vocab)) - super-interfaces))))) - (create-interface-form - proc:super-interfaces - variables - expr))))) - (else - (static-error - "interface" 'kwd:interface - expr "malformed declaration")))))) - - (add-primitivized-micro-form 'interface full-vocabulary interface-micro) - (add-primitivized-micro-form 'interface scheme-vocabulary interface-micro) - - ; ---------------------------------------------------------------------- - - (define sym-micro - (lambda (expr env attributes vocab) - (let ((r (resolve expr env vocab))) - (cond - ((lambda-binding? r) - (create-lambda-varref r expr)) - ((lexical-binding? r) - (create-lexical-varref r expr)) - ((top-level-resolution? r) - (check-for-signature-name expr attributes) - (process-top-level-resolution expr attributes)) - ((public-binding? r) - (create-public-varref r expr)) - ((override-binding? r) - (create-override-varref r expr)) - ((private-binding? r) - (create-private-varref r expr)) - ((inherit-binding? r) - (create-inherit-varref r expr)) - ((rename-binding? r) - (create-rename-varref r expr)) - ((supervar-binding? r) - (create-supervar-varref r expr)) - ((superinit-binding? r) - (create-superinit-varref r expr)) - ((or (macro-resolution? r) (micro-resolution? r)) - (static-error - "keyword" 'term:keyword-out-of-context expr - "invalid use of keyword ~s" (z:symbol-orig-name expr))) - (else - (internal-error expr "Invalid resolution in obj: ~s" r)))))) - - (add-sym-micro full-vocabulary sym-micro) - (add-sym-micro scheme-vocabulary sym-micro) - - ; ---------------------------------------------------------------------- - - (define-struct ivar-entry (bindings)) - (define-struct (public-entry struct:ivar-entry) (exports exprs)) - (define-struct (override-entry struct:ivar-entry) (exports exprs)) - (define-struct (private-entry struct:ivar-entry) (exprs)) - (define-struct (inherit-entry struct:ivar-entry) (imports)) - (define-struct (rename-entry struct:ivar-entry) (imports)) - - (define-struct sequence-entry (exprs)) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define make-void-init-expr - (lambda (expr) - (structurize-syntax '(#%void) expr '(-1)))) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define ivar-decls-vocab - (create-vocabulary 'ivar-decls-vocab #f - "malformed ivar declaration" - "malformed ivar declaration" - "malformed ivar declaration" - "malformed ivar declaration")) - - (define public-ivar-decl-entry-parser-vocab - (create-vocabulary 'public-ivar-decl-entry-parser-vocab #f - "malformed public declaration" - "malformed public declaration" - "malformed public declaration" - "malformed public declaration")) - - (define override-ivar-decl-entry-parser-vocab - (create-vocabulary 'override-ivar-decl-entry-parser-vocab #f - "malformed override declaration" - "malformed override declaration" - "malformed override declaration" - "malformed override declaration")) - - (add-sym-micro public-ivar-decl-entry-parser-vocab - (lambda (expr env attributes vocab) - (list - (create-public-binding+marks expr) - expr - (make-void-init-expr expr)))) - - (define (mk-public/override-micro kind-sym kind-str - ivar-decl-entry-parser-vocab - create-binding+marks - make-entry) - (add-list-micro ivar-decl-entry-parser-vocab - (let* ((kwd '()) - (in-pattern-1 '((internal-var var) expr)) - (in-pattern-2 '(var expr)) - (in-pattern-3 '(var)) - (m&e-1 (pat:make-match&env in-pattern-1 '())) - (m&e-2 (pat:make-match&env in-pattern-2 '())) - (m&e-3 (pat:make-match&env in-pattern-3 '()))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((internal-var (pat:pexpand 'internal-var p-env kwd)) - (var (pat:pexpand 'var p-env kwd)) - (expr (pat:pexpand 'expr p-env kwd))) - (valid-syntactic-id? internal-var) - (valid-syntactic-id? var) - (list (create-binding+marks internal-var) var expr)))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd)) - (expr (pat:pexpand 'expr p-env kwd))) - (valid-syntactic-id? var) - (list (create-binding+marks var) var expr)))) - ((pat:match-against m&e-3 expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd))) - (valid-syntactic-id? var) - (list - (create-binding+marks var) - var - (make-void-init-expr expr))))) - (else - (static-error - "ivar" 'term:invalid-ivar-decl - expr (format "malformed ~a declaration" kind-str))))))) - - (let* ((kwd `(,kind-sym)) - (in-pattern `(,kind-sym ivar-decl ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (add-micro-form kind-sym ivar-decls-vocab - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((decls - (map (lambda (decl) - (expand-expr decl env attributes - ivar-decl-entry-parser-vocab)) - (pat:pexpand '(ivar-decl ...) p-env kwd)))) - (make-entry - (map car decls) - (map cadr decls) - (map caddr decls))))) - (else - (static-error - "ivar" 'term:invalid-ivar-clause - expr (format "malformed ~a clause" kind-str)))))))) - - (mk-public/override-micro 'public "public" - public-ivar-decl-entry-parser-vocab - create-public-binding+marks - make-public-entry) - - (mk-public/override-micro 'override "override" - override-ivar-decl-entry-parser-vocab - create-override-binding+marks - make-override-entry) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define private-ivar-decl-entry-parser-vocab - (create-vocabulary 'private-ivar-decl-entry-parser-vocab #f - "malformed private declaration" - "malformed private declaration" - "malformed private declaration" - "malformed private declaration")) - - (add-sym-micro private-ivar-decl-entry-parser-vocab - (lambda (expr env attributes vocab) - (cons (create-private-binding+marks expr) - (make-void-init-expr expr)))) - - (add-list-micro private-ivar-decl-entry-parser-vocab - (let* ((kwd '()) - (in-pattern-1 '(var expr)) - (in-pattern-2 '(var)) - (m&e-1 (pat:make-match&env in-pattern-1 '())) - (m&e-2 (pat:make-match&env in-pattern-2 '()))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd)) - (expr (pat:pexpand 'expr p-env kwd))) - (valid-syntactic-id? var) - (cons (create-private-binding+marks var) expr)))) - ((pat:match-against m&e-2 expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd))) - (valid-syntactic-id? var) - (cons (create-private-binding+marks var) - (make-void-init-expr expr))))) - (else - (static-error - "ivar" 'term:invalid-ivar-decl - expr "malformed declaration")))))) - - (let* ((kwd '(private)) - (in-pattern '(private ivar-decl ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (add-micro-form 'private ivar-decls-vocab - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((decls - (map (lambda (decl) - (expand-expr decl env attributes - private-ivar-decl-entry-parser-vocab)) - (pat:pexpand '(ivar-decl ...) p-env kwd)))) - (make-private-entry - (map car decls) - (map cdr decls))))) - (else - (static-error - "private" 'kwd:class-private - expr "malformed declaration")))))) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define inherit-ivar-decl-entry-parser-vocab - (create-vocabulary 'inherit-ivar-decl-entry-parser-vocab #f - "malformed inherit declaration" - "malformed inherit declaration" - "malformed inherit declaration" - "malformed inherit declaration")) - - (add-sym-micro inherit-ivar-decl-entry-parser-vocab - (lambda (expr env attributes vocab) - (cons - (create-inherit-binding+marks expr) - expr))) - - (add-list-micro inherit-ivar-decl-entry-parser-vocab - (let* ((kwd '()) - (in-pattern '(internal-var var)) - (m&e (pat:make-match&env in-pattern '()))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((internal-var (pat:pexpand 'internal-var p-env kwd)) - (var (pat:pexpand 'var p-env kwd))) - (valid-syntactic-id? internal-var) - (valid-syntactic-id? var) - (cons - (create-inherit-binding+marks internal-var) - var)))) - (else - (static-error - "ivar" 'term:invalid-ivar-decl - expr "malformed declaration")))))) - - (let* ((kwd '(inherit)) - (in-pattern '(inherit ivar-decl ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (add-micro-form 'inherit ivar-decls-vocab - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((decls - (map (lambda (decl) - (expand-expr decl env attributes - inherit-ivar-decl-entry-parser-vocab)) - (pat:pexpand '(ivar-decl ...) p-env kwd)))) - (make-inherit-entry - (map car decls) - (map cdr decls))))) - (else - (static-error - "inherit" 'kwd:class-inherit - expr "malformed declaration")))))) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (define rename-ivar-decl-entry-parser-vocab - (create-vocabulary 'rename-ivar-decl-entry-parser-vocab #f - "malformed rename declaration" - "malformed rename declaration" - "malformed rename declaration" - "malformed rename declaration")) - - (add-list-micro rename-ivar-decl-entry-parser-vocab - (let* ((kwd '()) - (in-pattern-1 '(var inherited-var)) - (m&e-1 (pat:make-match&env in-pattern-1 '()))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let ((var (pat:pexpand 'var p-env kwd)) - (inherited-var (pat:pexpand 'inherited-var p-env kwd))) - (valid-syntactic-id? var) - (valid-syntactic-id? inherited-var) - (cons (create-rename-binding+marks var) inherited-var)))) - (else - (static-error - "ivar" 'term:invalid-ivar-decl - expr "malformed declaration")))))) - - (let* ((kwd '(rename)) - (in-pattern '(rename ivar-decl ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (add-micro-form 'rename ivar-decls-vocab - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((decls - (map (lambda (decl) - (expand-expr decl env attributes - rename-ivar-decl-entry-parser-vocab)) - (pat:pexpand '(ivar-decl ...) p-env kwd)))) - (make-rename-entry - (map car decls) - (map cdr decls))))) - (else - (static-error - "rename" 'kwd:class-rename - expr "malformed declaration")))))) - - ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - (let* ((kwd '(sequence)) - (in-pattern '(sequence expr ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (add-micro-form 'sequence ivar-decls-vocab - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (make-sequence-entry - (pat:pexpand '(expr ...) p-env kwd)))) - (else - (static-error - "sequence" 'kwd:class-sequence - expr "malformed declaration")))))) - - ; ---------------------------------------------------------------------- - - (define class-micro - (let* ((kwd '()) - (in-pattern `(kwd super args insts ...)) - (out-pattern '(class*/names (this super-init) - super () args insts ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let* ((kwd-pos (pat:pexpand 'kwd p-env kwd)) - (captured-this - (introduce-fresh-identifier 'this kwd-pos)) - (captured-super-init - (introduce-fresh-identifier 'super-init kwd-pos)) - (new-p-env (pat:extend-penv - 'this captured-this - (pat:extend-penv - 'super-init - captured-super-init - p-env)))) - (expand-expr - (structurize-syntax - (pat:pexpand out-pattern new-p-env kwd) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))) - (else - (static-error - "class" 'kwd:class - expr "malformed expression")))))) - - (add-primitivized-micro-form 'class full-vocabulary class-micro) - (add-primitivized-micro-form 'class scheme-vocabulary class-micro) - - (define class*-micro - (let* ((kwd '()) - (in-pattern `(kwd super interfaces args insts ...)) - (out-pattern '(class*/names (this super-init) - super interfaces args insts ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let* ((kwd-pos (pat:pexpand 'kwd p-env kwd)) - (captured-this - (introduce-fresh-identifier 'this kwd-pos)) - (captured-super-init - (introduce-fresh-identifier 'super-init kwd-pos)) - (new-p-env (pat:extend-penv - 'this captured-this - (pat:extend-penv - 'super-init - captured-super-init - p-env)))) - (expand-expr - (structurize-syntax - (pat:pexpand out-pattern new-p-env kwd) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))) - (else - (static-error - "class*" 'kwd:class* - expr "malformed expression")))))) - - (add-primitivized-micro-form 'class* full-vocabulary class*-micro) - (add-primitivized-micro-form 'class* scheme-vocabulary class*-micro) - - (define class*/names-micro - (let* ((kwd '()) - (in-pattern `(kwd (this super-init) - super-expr - (interface ...) - ,paroptarglist-pattern - inst-vars ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((in:this (pat:pexpand 'this p-env kwd)) - (in:superinit (pat:pexpand 'super-init - p-env kwd)) - (in:super-expr (pat:pexpand 'super-expr - p-env kwd)) - (in:interfaces (pat:pexpand '(interface ...) - p-env kwd)) - (in:initvars (pat:pexpand `,paroptarglist-pattern - p-env kwd)) - (in:ivars (pat:pexpand '(inst-vars ...) - p-env kwd))) - (valid-syntactic-id? in:this) - (valid-syntactic-id? in:superinit) - (as-nested - attributes - (lambda () - (let* ((proc:superinit - (create-superinit-binding+marks - in:superinit)) - (proc:super-expr - (expand-expr in:super-expr env - attributes vocab)) - (proc:interfaces - (map (lambda (e) - (expand-expr e env - attributes vocab)) - in:interfaces)) - (proc:this (create-lexical-binding+marks - in:this)) - (proc:initvar-info - (expand-expr in:initvars env attributes - paroptarglist-decls-vocab)) - (proc:ivar-info - (map (lambda (iv-decl) - (expand-expr iv-decl env attributes - ivar-decls-vocab)) - in:ivars))) - (let ((proc:initvars - (map paroptarglist-entry-var+marks - (paroptarglist-vars - proc:initvar-info))) - (proc:ivars - (apply append - (map (lambda (i) - (if (ivar-entry? i) - (ivar-entry-bindings i) - '())) - proc:ivar-info)))) - (let ((extensions - (cons proc:this - (cons proc:superinit - proc:ivars)))) - (let* ((new-names (map car extensions)) - (parsed-initvars - (make-paroptargument-list - proc:initvar-info - env attributes vocab))) - (distinct-valid-id/s? (append new-names - (map car - proc:initvars))) - (let ((external-ivars - (apply append - (map - (lambda (e) - (cond - ((public-entry? e) - (public-entry-exports e)) - ((override-entry? e) - (override-entry-exports e)) - (else null))) - proc:ivar-info)))) - (distinct-valid-syntactic-id/s? external-ivars) - (void)) - (extend-env extensions env) - (let - ((result - (create-class*/names-form - (car proc:this) - (car proc:superinit) - proc:super-expr - proc:interfaces - parsed-initvars - (let ((expand-exprs - (lambda (exprs) - (map (lambda (expr) - (expand-expr expr env - attributes vocab)) - exprs)))) - (map - (lambda (e) - (cond - ((public-entry? e) - (make-public-clause - (public-entry-exports e) - (map car (ivar-entry-bindings e)) - (expand-exprs - (public-entry-exprs e)))) - ((override-entry? e) - (make-override-clause - (override-entry-exports e) - (map car (ivar-entry-bindings e)) - (expand-exprs - (override-entry-exprs e)))) - ((private-entry? e) - (make-private-clause - (map car (ivar-entry-bindings e)) - (expand-exprs - (private-entry-exprs e)))) - ((inherit-entry? e) - (make-inherit-clause - (map car - (ivar-entry-bindings e)) - (inherit-entry-imports e))) - ((rename-entry? e) - (make-rename-clause - (map car (ivar-entry-bindings e)) - (rename-entry-imports e))) - ((sequence-entry? e) - (make-sequence-clause - (expand-exprs - (sequence-entry-exprs e)))) - (else - (internal-error e - "Invalid entry in class*/names maker")))) - proc:ivar-info)) - expr))) - (retract-env (append - (map car proc:initvars) - new-names) - env) - result)))))))))) - (else - (static-error - "class*/names" 'kwd:class*/names - expr "malformed expression")))))) - - - (add-primitivized-micro-form 'class*/names full-vocabulary class*/names-micro) - (add-primitivized-micro-form 'class*/names scheme-vocabulary class*/names-micro) - - ; ---------------------------------------------------------------------- - - (define ivar-micro - (let* ((kwd '()) - (in-pattern '(_ object name)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((object (pat:pexpand 'object p-env kwd)) - (name (pat:pexpand 'name p-env kwd))) - (valid-syntactic-id? name) - (as-nested - attributes - (lambda () - (expand-expr - (structurize-syntax - `(#%ivar/proc ,object (quote ,name)) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))))) - (else - (static-error - "ivar" 'kwd:ivar - expr "malformed expression")))))) - - (add-primitivized-micro-form 'ivar full-vocabulary ivar-micro) - (add-primitivized-micro-form 'ivar scheme-vocabulary ivar-micro) - - (define send-macro - (let* ((kwd '()) - (in-pattern '(_ object name arg ...)) - (out-pattern '((ivar object name) arg ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "send" 'kwd:send - expr "malformed expression"))))) - - (add-primitivized-macro-form 'send full-vocabulary send-macro) - (add-primitivized-macro-form 'send scheme-vocabulary send-macro) - - (define send*-macro - (let* ((kwd '()) - (in-pattern '(_ object (n0 a0 ...) ...)) - (m&e (pat:make-match&env in-pattern kwd)) - (out-pattern '(begin - (send object n0 a0 ...) - ...))) - (lambda (expr env) - (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error - "send*" 'kwd:send* - expr "malformed expression"))))) - - (add-primitivized-macro-form 'send* full-vocabulary send*-macro) - (add-on-demand-form 'macro 'send* common-vocabulary send*-macro) - - (define make-generic-micro - (let* ((kwd '()) - (in-pattern '(_ ci name)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((ci (pat:pexpand 'ci p-env kwd)) - (name (pat:pexpand 'name p-env kwd))) - (valid-syntactic-id? name) - (as-nested - attributes - (lambda () - (expand-expr - (structurize-syntax - `(#%make-generic/proc ,ci (quote ,name)) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))))) - (else - (static-error - "make-generic" 'kwd:make-generic - expr "malformed expression")))))) - - (add-primitivized-micro-form 'make-generic full-vocabulary make-generic-micro) - (add-primitivized-micro-form 'make-generic scheme-vocabulary make-generic-micro) - - ; ---------------------------------------------------------------------- - - (define set!-micro - (let* ((kwd '()) - (in-pattern `(_ var val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (let ((p-env (pat:match-against m&e expr env))) - (if p-env - (let* ((var-p (pat:pexpand 'var p-env kwd)) - (_ (valid-syntactic-id? var-p)) - (id-expr (expand-expr var-p env attributes vocab)) - (expr-expr (as-nested - attributes - (lambda () - (expand-expr - (pat:pexpand 'val p-env kwd) - env attributes vocab))))) - (when (or (inherit-varref? id-expr) - (rename-varref? id-expr)) - (static-error - "set!" 'term:no-set!-inherited/renamed - var-p - "cannot mutate inherited or renamed variables")) - (create-set!-form id-expr expr-expr expr)) - (static-error - "set!" 'kwd:set! - expr "malformed expression")))))) - - (add-primitivized-micro-form 'set! full-vocabulary set!-micro) - (add-primitivized-micro-form 'set! scheme-vocabulary set!-micro) - - ; -------------------------------------------------------------------- - - (extend-parsed->raw class*/names-form? - (lambda (expr p->r) - `(class*/names - (,(p->r (class*/names-form-this expr)) - ,(p->r (class*/names-form-super-init expr))) - ,(p->r (class*/names-form-super-expr expr)) - ,(map p->r (class*/names-form-interfaces expr)) - ,(p->r (class*/names-form-init-vars expr)) - ,@(map (lambda (clause) - (cond - ((public-clause? clause) - `(public - ,@(map (lambda (internal export expr) - `((,(p->r internal) ,(sexp->raw export)) - ,(p->r expr))) - (public-clause-internals clause) - (public-clause-exports clause) - (public-clause-exprs clause)))) - ((override-clause? clause) - `(override - ,@(map (lambda (internal export expr) - `((,(p->r internal) ,(sexp->raw export)) - ,(p->r expr))) - (override-clause-internals clause) - (override-clause-exports clause) - (override-clause-exprs clause)))) - ((private-clause? clause) - `(private - ,@(map (lambda (internal expr) - `(,(p->r internal) ,(p->r expr))) - (private-clause-internals clause) - (private-clause-exprs clause)))) - ((inherit-clause? clause) - `(inherit - ,@(map (lambda (internal inherited) - `(,(p->r internal) ,(sexp->raw inherited))) - (inherit-clause-internals clause) - (inherit-clause-imports clause)))) - ((rename-clause? clause) - `(rename - ,@(map (lambda (internal inherited) - `(,(p->r internal) ,(sexp->raw inherited))) - (rename-clause-internals clause) - (rename-clause-imports clause)))) - ((sequence-clause? clause) - `(sequence - ,@(map p->r (sequence-clause-exprs clause)))))) - (class*/names-form-inst-clauses expr))))) - - (extend-parsed->raw interface-form? - (lambda (expr p->r) - `(interface ,(map p->r (interface-form-super-exprs expr)) - ,@(map sexp->raw (interface-form-variables expr))))) - - ) diff --git a/collects/zodiac/scm-ou.ss b/collects/zodiac/scm-ou.ss deleted file mode 100644 index c14fe2af..00000000 --- a/collects/zodiac/scm-ou.ss +++ /dev/null @@ -1,50 +0,0 @@ -; $Id: scm-ou.ss,v 1.18 1999/04/07 22:38:04 mflatt Exp $ - -(unit/sig zodiac:scheme-objects+units^ - (import zodiac:misc^ (z : zodiac:structures^) (z : zodiac:reader-structs^) - zodiac:sexp^ (pat : zodiac:pattern^) - zodiac:expander^ zodiac:interface^ - zodiac:scheme-core^ zodiac:scheme-main^ - zodiac:scheme-objects^ zodiac:scheme-units^) - - (let ((handler - (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) - (lambda (expr env attributes vocab) - (let loop ((r (resolve expr env vocab))) - (cond - ((lambda-binding? r) - (create-lambda-varref r expr)) - ((lexical-binding? r) - (create-lexical-varref r expr)) - ((top-level-resolution? r) - (check-for-signature-name expr attributes) - (process-unit-top-level-resolution expr attributes)) - ((public-binding? r) - (create-public-varref r expr)) - ((override-binding? r) - (create-override-varref r expr)) - ((private-binding? r) - (create-private-varref r expr)) - ((inherit-binding? r) - (create-inherit-varref r expr)) - ((rename-binding? r) - (create-rename-varref r expr)) - ((supervar-binding? r) - (create-supervar-varref r expr)) - ((superinit-binding? r) - (create-superinit-varref r expr)) - ((or (macro-resolution? r) (micro-resolution? r)) - (if (and (inside-unit? attributes) - (check-export expr attributes)) - (loop top-level-resolution) - (static-error - "keyword" 'term:keyword-out-of-context expr - "invalid use of keyword ~s" (z:symbol-orig-name expr)))) - (else - (internal-error expr "Invalid resolution in ou: ~s" r)))))))) - - (add-sym-micro full-vocabulary handler) - (add-sym-micro scheme-vocabulary handler) - (add-sym-micro unit-clauses-vocab-delta handler)) - - ) diff --git a/collects/zodiac/scm-spdy.ss b/collects/zodiac/scm-spdy.ss deleted file mode 100644 index 11ec8303..00000000 --- a/collects/zodiac/scm-spdy.ss +++ /dev/null @@ -1,599 +0,0 @@ -; $Id: scm-spdy.ss,v 1.43 1999/03/15 14:35:40 mflatt Exp $ - -(unit/sig zodiac:scheme-mrspidey^ - (import zodiac:misc^ (z : zodiac:structures^) - (z : zodiac:scanner-parameters^) - (z : zodiac:reader-structs^) - (z : zodiac:reader-code^) - zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ - zodiac:scheme-main^ zodiac:back-protocol^ - zodiac:expander^ zodiac:interface^ - (mzlib : mzlib:file^)) - - (define-struct (poly-form struct:parsed) (exp)) - (define-struct (:-form struct:parsed) (exp type)) - (define-struct (type:-form struct:parsed) (type attrs)) - (define-struct (st:control-form struct:parsed) (para val)) - (define-struct (reference-unit-form struct:parsed) - (file kind signed?)) - (define-struct (define-type-form struct:parsed) (sym type)) - (define-struct (define-constructor-form struct:parsed) (sym modes)) - - (define create-poly-form - (lambda (exp source) - (make-poly-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - exp))) - - (define create-:-form - (lambda (exp type source) - (make-:-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - exp type))) - - (define create-type:-form - (lambda (type attrs source) - (make-type:-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - type attrs))) - - (define create-st:control-form - (lambda (para val source) - (make-st:control-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - para val))) - - (define create-reference-unit-form - (lambda (file kind signed? source) - (make-reference-unit-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - file kind signed?))) - - (define create-define-type-form - (lambda (sym type source) - (make-define-type-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - sym type))) - - (define create-define-constructor-form - (lambda (sym modes source) - (make-define-constructor-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - sym modes))) - - ; -------------------------------------------------------------------- - - (define mrspidey-vocabulary - (create-vocabulary 'mrspidey-vocabulary scheme-vocabulary)) - - ; -------------------------------------------------------------------- - - (add-primitivized-micro-form 'polymorphic mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ p-expr)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((p-expr (pat:pexpand 'p-expr p-env kwd))) - (create-poly-form - (expand-expr p-expr env attributes vocab) - expr)))) - (else - (static-error - "polymorphic" 'kwd:polymorphic - expr "malformed definition")))))) - - (add-primitivized-micro-form ': mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ :-expr type)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((:-expr (pat:pexpand ':-expr p-env kwd)) - (type (pat:pexpand 'type p-env kwd))) - (create-:-form - (expand-expr :-expr env attributes vocab) - (sexp->raw type) - expr)))) - (else - (static-error - ":" 'kwd:: - expr "malformed declaration")))))) - - (add-primitivized-micro-form 'type: mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ type attr ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((type (pat:pexpand 'type p-env kwd)) - (attrs (pat:pexpand '(attr ...) p-env kwd))) - (create-type:-form - (sexp->raw type) - (map sexp->raw attrs) - expr)))) - (else - (static-error - "type:" 'kwd:type: - expr "malformed declaration")))))) - - (add-primitivized-micro-form 'mrspidey:control mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ para val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((para (pat:pexpand 'para p-env kwd)) - (val (pat:pexpand 'val p-env kwd))) - (create-st:control-form - (sexp->raw para) - (sexp->raw val) - expr)))) - (else - (static-error - "mrspidey:control" 'kwd:mrspidey:control - expr "malformed declaration")))))) - - (add-primitivized-micro-form 'define-type mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ sym type)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((sym (pat:pexpand 'sym p-env kwd)) - (type (pat:pexpand 'type p-env kwd))) - (valid-syntactic-id? sym) - (create-define-type-form - (z:read-object sym) - (sexp->raw type) - expr)))) - (else - (static-error - "define-type" 'kwd:define-type - expr "malformed definition")))))) - - (add-primitivized-micro-form 'define-constructor mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ sym modes ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((sym (pat:pexpand 'sym p-env kwd)) - (modes (pat:pexpand '(modes ...) p-env kwd))) - (valid-syntactic-id? sym) - ; Cormac has an (assert-syn def (andmap boolean? modes)) - ; here. I only do the andmap z:boolean? part since - ; I have no idea what (assert-syn def ...) does. - (map (lambda (mode) - (unless (z:boolean? mode) - (static-error - "define-constructor" 'kwd:define-constructor - mode "malformed mode"))) - modes) - (create-define-constructor-form - (z:read-object sym) - (map sexp->raw modes) - expr)))) - (else - (static-error - "define-constructor" 'kwd:define-constructor - expr "malformed definition")))))) - - (add-primitivized-micro-form 'reference-file mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern `(_ file)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((file (pat:pexpand 'file p-env kwd))) - (let ((f (expand-expr file env attributes vocab))) - (if (and (quote-form? f) - (z:string? (quote-form-expr f))) - (let* ((raw-filename (z:read-object (quote-form-expr f)))) - (let-values (((base name dir?) - (split-path raw-filename))) - (when dir? - (static-error - "reference-file" 'kwd:reference-file - file - "cannot include a directory")) - (let* ((original-directory - (current-load-relative-directory)) - (p (with-handlers - ((exn:i/o:filesystem? - (lambda (exn) - (static-error - "reference-file" - 'kwd:reference-file - file - "unable to open file ~a" - raw-filename)))) - (open-input-file - (if (complete-path? raw-filename) - raw-filename - (build-path - (or original-directory - (current-directory)) - raw-filename)))))) - (dynamic-wind - (lambda () - (when (string? base) - (current-load-relative-directory - (if (complete-path? base) - base - (build-path (or original-directory - (current-directory)) - base))))) - (lambda () - (let ((reader - (z:read p - (z:make-location - (z:location-line - z:default-initial-location) - (z:location-column - z:default-initial-location) - (z:location-offset - z:default-initial-location) - (build-path - (current-load-relative-directory) - name))))) - (let ((code - (let loop () - (let ((input (reader))) - (if (z:eof? input) - '() - (cons input - (loop))))))) - (if (null? code) - (static-error - "reference-file" 'kwd:reference-file - expr "empty file") - (expand-expr - (structurize-syntax - `(begin ,@code) - expr '(-1)) - env attributes vocab))))) - (lambda () - (current-load-relative-directory original-directory) - (close-input-port p)))))) - (static-error - "reference-file" 'kwd:reference-file - file "does not yield a filename")))))) - (else - (static-error - "reference-file" 'kwd:reference-file - expr "malformed expression")))))) - - (define reference-library/relative-maker - (lambda (form-name kwd:form-name make-raw-filename) - (let* ((kwd '()) - (in-pattern '(_ filename collections ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd)) - (collections (pat:pexpand '(collections ...) p-env kwd))) - (let ((f (expand-expr filename env attributes vocab)) - (cs (map (lambda (c) - (expand-expr c env attributes vocab)) - collections))) - (unless (and (quote-form? f) - (z:string? (quote-form-expr f))) - (static-error - (symbol->string form-name) kwd:form-name - filename "does not yield a filename")) - (for-each - (lambda (c collection) - (unless (and (quote-form? c) - (z:string? (quote-form-expr c))) - (static-error - (symbol->string form-name) kwd:form-name - collection "does not yield a string"))) - cs collections) - (let* ((raw-f (z:read-object (quote-form-expr f))) - (raw-cs (map (lambda (c) - (z:read-object (quote-form-expr c))) - cs)) - (raw-filename - (if (relative-path? raw-f) - (or (make-raw-filename raw-f raw-cs expr) - (static-error - (symbol->string form-name) kwd:form-name - filename - "no such library file found")) - (static-error - (symbol->string form-name) kwd:form-name - f - "library path ~s must be a relative path" - raw-f)))) - (let-values (((base name dir?) - (split-path raw-filename))) - (when dir? - (static-error - (symbol->string form-name) kwd:form-name - filename - "cannot include a directory")) - (let ((original-directory - (current-load-relative-directory)) - (original-collections - (current-require-relative-collection)) - (p (with-handlers - ((exn:i/o:filesystem? - (lambda (exn) - (static-error - (symbol->string form-name) - kwd:form-name - filename - "unable to open file ~a" - raw-filename)))) - (open-input-file raw-filename)))) - (dynamic-wind - (lambda () - (current-require-relative-collection - (if (null? raw-cs) '("mzlib") raw-cs)) - (when (string? base) - (current-load-relative-directory base))) - (lambda () - (let ((reader - (z:read p - (z:make-location - (z:location-line - z:default-initial-location) - (z:location-column - z:default-initial-location) - (z:location-offset - z:default-initial-location) - (build-path - (current-load-relative-directory) - name))))) - (let ((code - (let loop () - (let ((input (reader))) - (if (z:eof? input) - '() - (cons input - (loop))))))) - (if (null? code) - (static-error - (symbol->string form-name) - kwd:form-name - expr "empty file") - (expand-expr - (structurize-syntax - `(begin ,@code) - expr '(-1)) - env attributes vocab))))) - (lambda () - (current-load-relative-directory - original-directory) - (current-require-relative-collection - original-collections) - (close-input-port p)))))))))) - (else - (static-error - (symbol->string form-name) kwd:form-name - expr - (string-append "malformed expression")))))))) - - (add-primitivized-micro-form 'require-library mrspidey-vocabulary - (reference-library/relative-maker 'require-library - 'kwd:require-library - (lambda (raw-f raw-cs expr) - (apply mzlib:find-library raw-f raw-cs)))) - - (add-primitivized-micro-form 'require-relative-library mrspidey-vocabulary - (reference-library/relative-maker 'require-relative-library - 'kwd:require-relative-library - (lambda (raw-f raw-cs expr) - (apply mzlib:find-library raw-f - (append (or (current-require-relative-collection) - (static-error - "require-relative-library" 'kwd:require-relative-library - expr - "no current collection for library \"~a\"" raw-f)) - raw-cs))))) - - (define reference-unit-maker - (lambda (form-name kwd:form-name signed?) - (add-primitivized-micro-form form-name mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern `(_ file)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((file (pat:pexpand 'file p-env kwd))) - (let ((f (expand-expr file env attributes vocab))) - (if (and (quote-form? f) - (z:string? (quote-form-expr f))) - (create-reference-unit-form - (structurize-syntax - (path->complete-path (z:read-object - (quote-form-expr f)) - (or (current-load-relative-directory) - (current-directory))) - expr) - 'exp - signed? - expr) - (static-error - (symbol->string form-name) kwd:form-name - file "does not yield a filename")))))) - (else - (static-error - (symbol->string form-name) kwd:form-name - expr "malformed expression")))))))) - - (reference-unit-maker 'require-unit 'kwd:require-unit #f) - (reference-unit-maker 'require-unit/sig 'kwd:require-unit/sig #t) - - (define reference-library-unit-maker - (lambda (form-name kwd:form-name sig? relative?) - (add-primitivized-micro-form form-name mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ filename collections ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd)) - (collections (pat:pexpand '(collections ...) - p-env kwd))) - (let ((f (expand-expr filename env attributes vocab)) - (cs (map (lambda (c) - (expand-expr c env attributes vocab)) - collections))) - (unless (and (quote-form? f) - (z:string? (quote-form-expr f))) - (static-error - (symbol->string form-name) kwd:form-name - filename "does not yield a filename")) - (for-each - (lambda (c collection) - (unless (and (quote-form? c) - (z:string? (quote-form-expr c))) - (static-error - (symbol->string form-name) kwd:form-name - collection - "does not yield a string"))) - cs collections) - (let ((raw-f (z:read-object (quote-form-expr f))) - (raw-cs (map (lambda (c) - (z:read-object - (quote-form-expr c))) - cs))) - (unless (relative-path? raw-f) - (static-error - (symbol->string form-name) kwd:form-name - f - "library path ~s must be a relative path" - raw-f)) - (create-reference-unit-form - (structurize-syntax - (path->complete-path - (or (apply mzlib:find-library raw-f - (if relative? - (append (or (current-require-relative-collection) - null) - raw-cs) - raw-cs)) - (static-error - (symbol->string form-name) kwd:form-name - expr - "unable to locate library ~a in collection path ~a" - raw-f - (if (null? raw-cs) "mzlib" raw-cs))) - (or (current-load-relative-directory) - (current-directory))) - expr) - 'exp - sig? - expr)))))) - (else - (static-error - (symbol->string form-name) kwd:form-name - expr "malformed expression")))))))) - - (reference-library-unit-maker 'require-library-unit - 'kwd:require-library-unit #f #f) - (reference-library-unit-maker 'require-library-unit/sig - 'kwd:require-library-unit/sig #t #f) - (reference-library-unit-maker 'require-relative-library-unit - 'kwd:require-relative-library-unit #f #t) - (reference-library-unit-maker 'require-relative-library-unit/sig - 'kwd:require-relative-library-unit/sig #t #t) - -' (add-primitivized-micro-form 'references-unit-imports mrspidey-vocabulary - (let* ((kwd '()) - (in-pattern '(_ file)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((file (pat:pexpand 'file p-env kwd))) - (create-reference-unit-form - file - (current-directory) - 'imp - expr)))) - (else - (static-error expr "Malformed require-unit-imports")))))) - - ; -------------------------------------------------------------------- - - (extend-parsed->raw poly-form? - (lambda (expr p->r) - `(polymorphic ,(p->r (poly-form-exp expr))))) - - (extend-parsed->raw :-form? - (lambda (expr p->r) - `(: ,(p->r (:-form-exp expr)) ,(:-form-type expr)))) - - (extend-parsed->raw type:-form? - (lambda (expr p->r) - `(type: ,(type:-form-type expr) ,@(type:-form-attrs expr)))) - - (extend-parsed->raw st:control-form? - (lambda (expr p->r) - `(mrspidey:control ,(st:control-form-para expr) - ,(st:control-form-val expr)))) - - (extend-parsed->raw reference-unit-form? - (lambda (expr p->r) - (case (reference-unit-form-kind expr) - ((exp) `(,(if (reference-unit-form-signed? expr) - 'require-unit/sig - 'require-unit) - ,(sexp->raw (reference-unit-form-file expr)))) - ((imp) `(require-unit-imports - ,(sexp->raw (reference-unit-form-file expr)))) - (else (internal-error 'require-unit-form "Invalid kind"))))) - - (extend-parsed->raw define-type-form? - (lambda (expr p->r) - `(define-type ,(define-type-form-sym expr) - ,(define-type-form-type expr)))) - - (extend-parsed->raw define-constructor-form? - (lambda (expr p->r) - `(define-constructor-form ,(define-constructor-form-sym expr) - ,@(define-constructor-form-modes expr)))) - - ) diff --git a/collects/zodiac/scm-unit.ss b/collects/zodiac/scm-unit.ss deleted file mode 100644 index 06646fc0..00000000 --- a/collects/zodiac/scm-unit.ss +++ /dev/null @@ -1,1245 +0,0 @@ -; $Id: scm-unit.ss,v 1.87 2000/01/10 22:51:12 clements Exp $ - -(unit/sig zodiac:scheme-units^ - (import zodiac:misc^ (z : zodiac:structures^) - (z : zodiac:scanner-parameters^) - (z : zodiac:reader-structs^) - (z : zodiac:reader-code^) - zodiac:sexp^ (pat : zodiac:pattern^) zodiac:scheme-core^ - zodiac:scheme-main^ zodiac:scheme-objects^ zodiac:back-protocol^ - zodiac:expander^ zodiac:interface^) - - (define-struct (unit-form struct:parsed) - (imports exports clauses)) - - (define-struct (compound-unit-form struct:parsed) - (imports links exports)) - - (define-struct (invoke-unit-form struct:parsed) - (unit variables)) - - (define create-unit-form - (lambda (imports exports clauses source) - (make-unit-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - imports exports clauses))) - - (define create-compound-unit-form - (lambda (imports links exports source) - (make-compound-unit-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - imports links exports))) - - (define create-invoke-unit-form - (lambda (unit variables source) - (make-invoke-unit-form (z:zodiac-origin source) - (z:zodiac-start source) (z:zodiac-finish source) - (make-empty-back-box) - unit variables))) - - ; -------------------------------------------------------------------- - - (define (make-put-get-remove attr) - (define put - (lambda (attributes v) - (put-attribute - attributes attr - (cons v - (get-attribute attributes attr - (lambda () null)))))) - (define get - (lambda (attributes) - (car (get-attribute attributes attr)))) - (define remove - (lambda (attributes) - (put-attribute - attributes attr - (cdr (get-attribute attributes attr))))) - (values put get remove)) - - (define-values (put-c-unit-vocab-attribute - get-c-unit-vocab-attribute - remove-c-unit-vocab-attribute) - (make-put-get-remove 'c-unit-link-import/body-vocab)) - - - (define-values (put-c-unit-current-link-tag-attribute - get-c-unit-current-link-tag-attribute - remove-c-unit-current-link-tag-attribute) - (make-put-get-remove 'c-unit-current-link-tag-attribute)) - - (define-values (put-c-unit-expand-env - get-c-unit-expand-env - remove-c-unit-expand-env) - (make-put-get-remove 'c-unit-expand-env)) - - (define-values (put-vars-attribute - get-vars-attribute - remove-vars-attribute) - (make-put-get-remove 'unit-vars)) - (define (make-vars-attribute attributes) - (put-vars-attribute attributes (make-hash-table))) - - (define-struct unresolved (id varref)) - - (define make-unresolved-attribute - (lambda (attributes) - (put-attribute attributes 'unresolved-unit-vars - (cons '() - (get-attribute attributes - 'unresolved-unit-vars (lambda () '())))))) - - (define get-unresolved-attribute - (lambda (attributes) - (car (get-attribute attributes 'unresolved-unit-vars)))) - - (define update-unresolved-attribute - (lambda (attributes id varref) - (let ((new-value (make-unresolved id varref)) - (current (get-attribute attributes 'unresolved-unit-vars - (lambda () '())))) ; List of lists to accomodate - ; nested units - (unless (null? current) - (put-attribute attributes 'unresolved-unit-vars - (cons - (cons new-value (car current)) - (cdr current))))))) - - (define remove/update-unresolved-attribute - (lambda (attributes unresolveds) - (let ((left-unresolveds - (cdr (get-attribute attributes - 'unresolved-unit-vars)))) - (if (null? left-unresolveds) - (begin - (put-attribute attributes 'unresolved-unit-vars null) - (unless (null? unresolveds) - (let ([id (unresolved-id (car unresolveds))]) - (check-for-signature-name id attributes) - (static-error - "unit" 'term:unit-unbound-id - (unresolved-id (car unresolveds)) - "unbound identifier ~a" - (z:read-object id))))) - (put-attribute attributes 'unresolved-unit-vars - (cons (append unresolveds (car left-unresolveds)) - (cdr left-unresolveds))))))) - - ; -------------------------------------------------------------------- - - (define-struct unit-id (id)) - (define-struct (import-id struct:unit-id) ()) - (define-struct (export-id struct:unit-id) (defined?)) - (define-struct (internal-id struct:unit-id) ()) - (define-struct (link-id struct:unit-id) ()) - - (define register-links - (lambda (ids attributes) - (map - (lambda (id) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (cond - ((not entry) - (hash-table-put! id-table id-name - (make-link-id id))) - ((link-id? entry) - (static-error - "unit linkage" 'term:unit-link-duplicate-tag - id "duplicate link tag name")) - (else - (internal-error entry "Invalid in register-links")))))) - ids))) - - (define check-link - (lambda (id attributes) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (link-id? entry))))) - - (define check-import - (lambda (id attributes) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (import-id? entry))))) - - (define inside-unit? - (lambda (attributes) - (not (null? (get-attribute attributes 'unit-vars - (lambda () null)))))) - - (define check-export - (lambda (id attributes) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (export-id? entry))))) - - (define register-import - (lambda (id attributes) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (cond - ((not entry) - (hash-table-put! id-table id-name - (make-import-id id))) - ((import-id? entry) - (static-error - "unit" 'term:unit-duplicate-import - id "duplicate import identifier ~a" id-name)) - ((export-id? entry) - (static-error - "unit" 'term:unit-import-exported - id "exported identifier ~a being imported" id-name)) - ((internal-id? entry) - (static-error - "unit" 'term:unit-defined-imported - id "defined identifier ~a being imported" id-name)) - (else - (internal-error entry - "Invalid in register-import/export"))))))) - - (define register-definitions - (lambda (ids attributes) - (map - (lambda (id) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (cond - ((not entry) - (hash-table-put! id-table id-name - (make-internal-id id))) - ((import-id? entry) - (static-error - "unit" 'term:unit-redefined-import - id "redefined imported identifier ~a" id-name)) - ((export-id? entry) - (if (export-id-defined? entry) - (static-error - "unit" 'term:unit-duplicate-definition - id "redefining exported identifier ~a" id-name) - (set-export-id-defined?! entry #t))) - ((internal-id? entry) - (static-error - "unit" 'term:unit-duplicate-definition - id "duplicate internal definition for ~a" id-name)) - (else - (internal-error entry - "Invalid entry in register-definitions")))))) - ids))) - - (define register-export - (lambda (id attributes) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (cond - ((not entry) - (hash-table-put! id-table id-name - (make-export-id id #f))) - ((import-id? entry) - (static-error - "unit" 'term:unit-import-exported - id "imported identifier ~a being exported" id-name)) - ((export-id? entry) - (static-error - "unit" 'term:unit-duplicate-export - id "duplicate export identifier ~a" id-name)) - ((internal-id? entry) - (internal-error entry - "Should not have had an internal-id in register-export")) - (else - (internal-error entry - "Invalid in register-import/export"))))))) - - (define verify-export - (lambda (id attributes) - (let ((id-table (get-vars-attribute attributes)) - (id-name (z:read-object id))) - (let ((entry (hash-table-get id-table id-name - (lambda () #f)))) - (cond - ((not entry) - (static-error - "unit" 'term:unit-export-not-defined - id "Exported identifier ~a not defined" id-name)) - ((import-id? entry) - (static-error - "unit" 'term:unit-import-exported - id "imported identifier ~a being exported" id-name)) - ((export-id? entry) - (unless (export-id-defined? entry) - (static-error - "unit" 'term:unit-export-not-defined - id "exported identifier ~a not defined" id-name))) - ((internal-id? entry) - (internal-error entry - "Should not have had an internal-id in verify-export")) - (else - (internal-error entry - "Invalid in register-import/export"))))))) - - (define get-unresolved-vars - (lambda (attributes) - (let ((id-table (get-vars-attribute attributes)) - (top-level-space (get-attribute attributes 'top-levels)) - (unresolveds (get-unresolved-attribute attributes))) - (let loop ((remaining unresolveds) - (unr null)) - (if (null? remaining) unr - (let* ((u (car remaining)) - (uid (unresolved-id u))) - (let ((entry (hash-table-get id-table - (z:read-object uid) (lambda () #f)))) - (cond - ((or (internal-id? entry) (export-id? entry)) - ; Need to set the box here - (when (top-level-varref/bind? (unresolved-varref u)) - (let* ([id (unit-id-id entry)] - [box (and top-level-space - (hash-table-get top-level-space - (z:read-object uid) - (lambda () - (internal-error - entry - "Can't find box in get-unresolved-vars"))))]) - (set-top-level-varref/bind-slot! - (unresolved-varref u) - box) - (set-top-level-varref/bind/unit-unit?! - (unresolved-varref u) - #t))) - (loop (cdr remaining) unr)) - ((import-id? entry) - (loop (cdr remaining) unr)) - ((not entry) - (loop (cdr remaining) (cons u unr))) - (else - (internal-error entry - "Invalid in get-unresolved-vars")))))))))) - - ; ---------------------------------------------------------------------- - - (define c/imports-vocab - (create-vocabulary 'c/imports-vocab #f - "malformed import declaration" - "malformed import declaration" - "malformed import declaration" - "malformed import declaration")) - - (add-sym-micro c/imports-vocab - (lambda (expr env attributes vocab) - (register-import expr attributes) - (create-lexical-binding+marks expr))) - - ; ---------------------------------------------------------------------- - - (define unit-register-exports-vocab - (create-vocabulary 'unit-register-exports-vocab #f - "malformed export declaration" - "malformed export declaration" - "malformed export declaration" - "malformed export declaration")) - - (add-sym-micro unit-register-exports-vocab - (lambda (expr env attributes vocab) - (register-export expr attributes))) - - (add-list-micro unit-register-exports-vocab - (let* ((kwd '()) - (in-pattern '(internal-id external-id)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((internal (pat:pexpand 'internal-id p-env kwd)) - (external (pat:pexpand 'external-id p-env kwd))) - (valid-syntactic-id? internal) - (valid-syntactic-id? external) - (register-export internal attributes)))) - (else - (static-error - "unit export" 'term:unit-export - expr "malformed declaration")))))) - - ;; ---------------------------------------------------------------------- - - (define unit-generate-external-names-vocab - (create-vocabulary 'unit-generate-external-names-vocab #f - "malformed export declaration" - "malformed export declaration" - "malformed export declaration" - "malformed export declaration")) - - (add-sym-micro unit-generate-external-names-vocab - (lambda (expr env attributes vocab) - expr)) - - (add-list-micro unit-generate-external-names-vocab - (let* ((kwd '()) - (in-pattern '(internal-id external-id)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (pat:pexpand 'external-id p-env kwd))) - (else - (static-error - "unit export" 'term:unit-export - expr "malformed declaration")))))) - - ;; -------------------------------------------------------------------- - - (define unit-verify-exports-vocab - (create-vocabulary 'unit-verify-exports-vocab #f - "malformed export declaration" - "malformed export declaration" - "malformed export declaration" - "malformed export declaration")) - - (add-sym-micro unit-verify-exports-vocab - (lambda (expr env attributes vocab) - (verify-export expr attributes) - (let ((expand-vocab (get-attribute attributes 'exports-expand-vocab))) - (cons (process-unit-top-level-resolution expr attributes) - expr)))) - - (add-list-micro unit-verify-exports-vocab - (let* ((kwd '()) - (in-pattern '(internal-id external-id)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((internal (pat:pexpand 'internal-id p-env kwd)) - (external (pat:pexpand 'external-id p-env kwd))) - (verify-export internal attributes) - (let ((expand-vocab (get-attribute attributes - 'exports-expand-vocab))) - (cons (process-unit-top-level-resolution internal attributes) - external))))) - (else - (static-error - "unit export" 'term:unit-export - expr "malformed declaration")))))) - - ; ---------------------------------------------------------------------- - - (define (fixup-shadowed-varrefs exprs exports env attributes vocab) - (let ([shadowed (let loop ([exports exports]) - (if (null? exports) - null - (let ([r (resolve (car exports) env vocab)] - [rest (loop (cdr exports))]) - (if (binding? r) - (cons (cons - r - (lambda () - (process-unit-top-level-resolution - (car exports) - attributes))) - rest) - rest))))]) - (if (null? shadowed) - exprs - (begin - (map - (lambda (expr) - (fixup expr shadowed)) - exprs))))) - - ;; Yuck - traverse and patch expressions to fix varrefs pointing to - ;; lexical bindings that are shadowed by unit definitions. - - (define (fixup expr binding-map) - (let fix ([expr expr]) - (if (bound-varref? expr) - (let ([fixed (assoc (bound-varref-binding expr) binding-map)]) - (if fixed - ((cdr fixed)) - expr)) - (begin - (cond - [(not expr) expr] - [(varref? expr) expr] - [(quote-form? expr) expr] - [(app? expr) - (set-app-fun! expr (fix (app-fun expr))) - (set-app-args! expr (map fix (app-args expr)))] - [(struct-form? expr) - (set-struct-form-super! expr (fix (struct-form-super expr)))] - [(if-form? expr) - (set-if-form-test! expr (fix (if-form-test expr))) - (set-if-form-then! expr (fix (if-form-then expr))) - (set-if-form-else! expr (fix (if-form-else expr)))] - [(begin-form? expr) - (set-begin-form-bodies! expr (map fix (begin-form-bodies expr)))] - [(begin0-form? expr) - (set-begin0-form-bodies! expr (map fix (begin0-form-bodies expr)))] - [(let-values-form? expr) - (set-let-values-form-vals! expr (map fix (let-values-form-vals expr))) - (set-let-values-form-body! expr (fix (let-values-form-body expr)))] - [(letrec-values-form? expr) - (set-letrec-values-form-vals! expr (map fix (letrec-values-form-vals expr))) - (set-letrec-values-form-body! expr (fix (letrec-values-form-body expr)))] - [(define-values-form? expr) - (set-define-values-form-val! expr (fix (define-values-form-val expr)))] - [(set!-form? expr) - (set-set!-form-var! expr (fix (set!-form-var expr))) - (set-set!-form-val! expr (fix (set!-form-val expr)))] - [(case-lambda-form? expr) - (set-case-lambda-form-bodies! expr (map fix (case-lambda-form-bodies expr)))] - [(with-continuation-mark-form? expr) - (set-with-continuation-mark-form-key! expr (fix (with-continuation-mark-form-key expr))) - (set-with-continuation-mark-form-val! expr (fix (with-continuation-mark-form-val expr))) - (set-with-continuation-mark-form-body! expr (fix (with-continuation-mark-form-body expr)))] - [(class*/names-form? expr) - (for-each - (lambda (clause) - (cond - [(public-clause? clause) - (set-public-clause-exprs! clause (map fix (public-clause-exprs clause)))] - [(private-clause? clause) - (set-private-clause-exprs! clause (map fix (private-clause-exprs clause)))] - [(sequence-clause? clause) - (set-sequence-clause-exprs! clause (map fix (sequence-clause-exprs clause)))] - [else (void)])) - (class*/names-form-inst-clauses expr))] - [(interface-form? expr) - (set-interface-form-super-exprs! expr (map fix (interface-form-super-exprs expr)))] - [(unit-form? expr) - (set-unit-form-clauses! expr (map fix (unit-form-clauses expr)))] - [(compound-unit-form? expr) - (for-each - (lambda (link) - (set-car! (cdr link) (fix (cadr link)))) - (compound-unit-form-links expr))] - [(invoke-unit-form? expr) - (set-invoke-unit-form-unit! expr (fix (invoke-unit-form-unit expr))) - (set-invoke-unit-form-variables! expr (map fix (invoke-unit-form-variables expr)))] - [else - (internal-error expr "Cannot fix unknown form: ~s" expr)]) - expr)))) - - ; ---------------------------------------------------------------------- - - (define unit-micro - (let* ((kwd `(import export)) - (in-pattern `(_ - (import imports ...) - (export exports ...) - clauses ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ([top-level? (get-top-level-status attributes)] - [internal? (get-internal-define-status attributes)] - [old-top-level (get-attribute attributes 'top-levels)] - [old-delay (get-attribute attributes 'delay-sig-name-check?)] - [unit-clauses-vocab - (append-vocabulary unit-clauses-vocab-delta - vocab 'unit-clauses-vocab)]) - (dynamic-wind - void - (lambda () - (set-top-level-status attributes #t) - (set-internal-define-status attributes #f) - (put-attribute attributes 'top-levels (make-hash-table)) - (put-attribute attributes 'delay-sig-name-check? #t) - (let ((in:imports (pat:pexpand '(imports ...) p-env kwd)) - (in:exports (pat:pexpand '(exports ...) p-env kwd)) - (in:clauses (pat:pexpand '(clauses ...) p-env kwd))) - (make-vars-attribute attributes) - (make-unresolved-attribute attributes) - (let* ((proc:imports (map (lambda (e) - (expand-expr e env - attributes c/imports-vocab)) - in:imports)) - (_ (extend-env proc:imports env)) - (_ (put-attribute attributes 'exports-expand-vocab - unit-clauses-vocab)) - (_ (for-each (lambda (e) - (expand-expr e env attributes - unit-register-exports-vocab)) - in:exports)) - (proc:clauses (map (lambda (e) - (expand-expr e env - attributes - unit-clauses-vocab)) - in:clauses)) - (_ (retract-env (map car proc:imports) env)) - (proc:exports (map (lambda (e) - (expand-expr e env - attributes - unit-verify-exports-vocab)) - in:exports)) - (proc:exports-externals - (map (lambda (e) - (expand-expr e env attributes - unit-generate-external-names-vocab)) - in:exports)) - (unresolveds (get-unresolved-vars attributes)) - (fixed-proc:clauses (fixup-shadowed-varrefs - proc:clauses - (hash-table-map - (get-vars-attribute attributes) - (lambda (key val) (unit-id-id val))) - env - attributes - vocab))) - - (put-attribute attributes 'delay-sig-name-check? old-delay) - - (distinct-valid-syntactic-id/s? proc:exports-externals) - (remove-vars-attribute attributes) - (remove/update-unresolved-attribute attributes - unresolveds) - (set-top-level-status attributes top-level?) - (set-internal-define-status attributes internal?) - (put-attribute attributes 'exports-expand-vocab #f) - - (create-unit-form - (map car proc:imports) - proc:exports - fixed-proc:clauses - expr)))) - (lambda () (put-attribute attributes 'top-levels old-top-level)))))) - (else - (static-error - "unit" 'kwd:unit - expr "malformed expression")))))) - - (add-primitivized-micro-form 'unit full-vocabulary unit-micro) - (add-primitivized-micro-form 'unit scheme-vocabulary unit-micro) - - ; ---------------------------------------------------------------------- - - (define c-unit-link-import-vocab - (create-vocabulary 'c-unit-link-import-vocab #f - "malformed link import declaration" - "malformed link import declaration" - "malformed link import declaration" - "malformed link import declaration")) - - (add-sym-micro c-unit-link-import-vocab - (lambda (expr env attributes vocab) - (if (check-import expr attributes) - (list (expand-expr expr env attributes - (get-c-unit-vocab-attribute attributes))) - (static-error - "compound-unit linkage" 'term:c-unit-not-import - expr "~a: not an imported identifier" (z:read-object expr))))) - - (add-list-micro c-unit-link-import-vocab - (let* ((kwd '()) - (in-pattern '(tag id ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (ids (pat:pexpand '(id ...) p-env kwd))) - (when #f ; we allow self-import, now - (when (eq? (z:read-object tag) - (get-c-unit-current-link-tag-attribute - attributes)) - (static-error - "compound-unit linkage" 'term:unit-link-self-import-tag - expr "self-import of tag ~a" (z:read-object tag)))) - (map (lambda (id) (cons tag id)) ids)))) - (else - (static-error - "compound-unit linkage" 'term:c-unit-linkage - expr "invalid syntax")))))) - - (define c-unit-link-body-vocab - (create-vocabulary 'c-unit-link-body-vocab #f - "malformed link body declaration" - "malformed link body declaration" - "malformed link body declaration" - "malformed link body declaration")) - - (add-list-micro c-unit-link-body-vocab - (let* ((kwd '()) - (in-pattern '(sub-unit-expr imported-var ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((sub-unit-expr (pat:pexpand 'sub-unit-expr p-env kwd)) - (imported-vars - (pat:pexpand '(imported-var ...) p-env kwd))) - (cons (expand-expr sub-unit-expr - (get-c-unit-expand-env attributes) - attributes - (get-c-unit-vocab-attribute attributes)) - (map (lambda (imported-var) - (expand-expr imported-var env attributes - c-unit-link-import-vocab)) - imported-vars))))) - (else - (static-error - "compound-unit linkage" 'term:c-unit-linkage - expr "malformed body")))))) - - (define c-unit-exports-vocab - (create-vocabulary 'c-unit-exports-vocab #f - "malformed unit export declaration" - "malformed unit export declaration" - "malformed unit export declaration" - "malformed unit export declaration")) - - (add-sym-micro c-unit-exports-vocab - (lambda (expr env attributes vocab) - (cons expr expr))) - - (add-list-micro c-unit-exports-vocab - (let* ((kwd '()) - (in-pattern '(internal-id external-id)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((internal-id (pat:pexpand 'internal-id p-env kwd)) - (external-id (pat:pexpand 'external-id p-env kwd))) - (valid-syntactic-id? internal-id) - (valid-syntactic-id? external-id) - (cons internal-id external-id)))) - (else - (static-error - "compound-unit" 'term:c-unit-export - expr "malformed export clause")))))) - - (define c-unit-export-clause-vocab - (create-vocabulary 'c-unit-export-clause-vocab #f - "malformed export clause declaration" - "malformed export clause declaration" - "malformed export clause declaration" - "malformed export clause declaration")) - - (add-list-micro c-unit-export-clause-vocab - (let* ((kwd '()) - (in-pattern '(tag exports ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((tag (pat:pexpand 'tag p-env kwd)) - (exports (pat:pexpand '(exports ...) p-env kwd))) - (valid-syntactic-id? tag) - (if (check-link tag attributes) - (map (lambda (e) - (cons tag - (expand-expr e env attributes - c-unit-exports-vocab))) - exports) - (static-error - "compound-unit" 'term:c-unit-invalid-tag - tag "not a valid tag"))))) - (else - (static-error - "compound-unit" 'term:c-unit-export - expr "malformed export clause")))))) - - (define compound-unit-micro - (let* ((kwd `(import link export)) - (in-pattern `(_ - (import imports ...) - (link - (link-tag link-body) ...) - (export export-clause ...))) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((in:imports (pat:pexpand '(imports ...) p-env kwd)) - (in:link-tags (pat:pexpand '(link-tag ...) p-env kwd)) - (in:link-bodies - (pat:pexpand '(link-body ...) p-env kwd)) - (in:export-clauses - (pat:pexpand '(export-clause ...) p-env kwd))) - (distinct-valid-syntactic-id/s? in:link-tags) - (make-vars-attribute attributes) - (put-c-unit-vocab-attribute attributes vocab) - (put-c-unit-expand-env attributes (copy-env env)) - (let* ((proc:imports (map (lambda (e) - (expand-expr e env - attributes c/imports-vocab)) - in:imports)) - (_ (extend-env proc:imports env)) - (_ (register-links in:link-tags attributes)) - (raw-link-clauses (map z:read-object in:link-tags)) - (proc:link-clauses - (map (lambda (link-tag link-body) - (let ((this-tag (z:read-object link-tag))) - (put-c-unit-current-link-tag-attribute - attributes this-tag) - (let ((expanded-body - (as-nested - attributes - (lambda () - (expand-expr link-body env - attributes - c-unit-link-body-vocab))))) - (let ((unit-expr (car expanded-body)) - (unit-args (apply append - (cdr expanded-body)))) - (let loop ((args unit-args)) - (if (null? args) - (begin - (remove-c-unit-current-link-tag-attribute - attributes) - (cons link-tag - (cons unit-expr unit-args))) - (begin - (if (pair? (car args)) - (let ((arg (caar args))) - (if (z:symbol? arg) - (when (not (memq (z:read-object arg) - raw-link-clauses)) - (static-error - "compound-unit" - 'term:c-unit-invalid-tag - arg - "not a valid tag")) - (static-error - "compound-unit" - 'term:c-unit-invalid-tag - arg - "tag must be a symbol")))) - (loop (cdr args))))))))) - in:link-tags in:link-bodies)) - (proc:export-clauses - (apply append - (map (lambda (e) - (expand-expr e env - attributes c-unit-export-clause-vocab)) - in:export-clauses))) - (_ (retract-env (map car proc:imports) env))) - (remove-c-unit-vocab-attribute attributes) - (remove-c-unit-expand-env attributes) - (remove-vars-attribute attributes) - (create-compound-unit-form - (map car proc:imports) - proc:link-clauses - proc:export-clauses - expr))))) - (else - (static-error - "compound-unit" 'kwd:compound-unit - expr "malformed expression")))))) - - (add-primitivized-micro-form 'compound-unit full-vocabulary compound-unit-micro) - (add-primitivized-micro-form 'compound-unit scheme-vocabulary compound-unit-micro) - - ; -------------------------------------------------------------------- - - (define invoke-unit-micro - (let* ((kwd '()) - (in-pattern `(_ unit vars ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((unit (pat:pexpand 'unit p-env kwd)) - (vars (pat:pexpand '(vars ...) p-env kwd))) - (valid-syntactic-id/s? vars) - (let* ((expr-expr - (as-nested - attributes - (lambda () - (expand-expr unit env attributes vocab)))) - (var-exprs - (map (lambda (e) - (expand-expr e env - attributes vocab)) - vars))) - (create-invoke-unit-form - expr-expr - var-exprs - expr))))) - (else - (static-error - "invoke-unit" 'kwd:invoke-unit - expr "malformed expression")))))) - - (add-primitivized-micro-form 'invoke-unit full-vocabulary invoke-unit-micro) - (add-primitivized-micro-form 'invoke-unit scheme-vocabulary invoke-unit-micro) - - ; -------------------------------------------------------------------- - - (extend-parsed->raw unit-form? - (lambda (expr p->r) - `(unit (import ,@(map p->r (unit-form-imports expr))) - (export ,@(map (lambda (e) - `(,(p->r (car e)) ,(sexp->raw (cdr e)))) - (unit-form-exports expr))) - ,@(map p->r (unit-form-clauses expr))))) - - (extend-parsed->raw compound-unit-form? - (lambda (expr p->r) - `(compound-unit - (import ,@(map p->r (compound-unit-form-imports expr))) - (link - ,@(map (lambda (link-clause) - (let ((tag (car link-clause)) - (sub-unit (cadr link-clause)) - (imports (map (lambda (import) - (if (lexical-varref? import) - (p->r import) - `(,(sexp->raw (car import)) - ,(sexp->raw (cdr import))))) - (cddr link-clause)))) - `(,(sexp->raw tag) - (,(p->r sub-unit) - ,@imports)))) - (compound-unit-form-links expr))) - (export - ,@(map (lambda (export-clause) - `(,(sexp->raw (car export-clause)) - (,(sexp->raw (cadr export-clause)) - ,(sexp->raw (cddr export-clause))))) - (compound-unit-form-exports expr)))))) - - (extend-parsed->raw invoke-unit-form? - (lambda (expr p->r) - `(invoke-unit ,(p->r (invoke-unit-form-unit expr)) - ,@(map p->r (invoke-unit-form-variables expr))))) - - ; ---------------------------------------------------------------------- - - (define unit-clauses-vocab-delta - (create-vocabulary 'unit-clauses-vocab-delta)) - - (let* ((kwd '()) - (in-pattern-1 `(_ (var ...) val)) - (m&e-1 (pat:make-match&env in-pattern-1 kwd))) - (let ((define-values-helper - (lambda (handler) - (lambda (expr env attributes vocab) - (unless (at-top-level? attributes) - (static-error - "definition" 'term:def-not-at-top-level - expr - "must be at the top level")) - (cond - ((pat:match-against m&e-1 expr env) - => - (lambda (p-env) - (let* ((top-level? (get-top-level-status - attributes)) - (_ (set-top-level-status - attributes)) - (vars (pat:pexpand '(var ...) - p-env kwd)) - (_ (map valid-syntactic-id? vars)) - (_ (for-each - (lambda (var) - (let ((r (resolve var env vocab))) - (when (or (micro-resolution? r) - (macro-resolution? r)) - (unless (check-export var attributes) - (static-error - "keyword" - 'term:cannot-bind-kwd - var - "cannot bind keyword ~s" - (z:symbol-orig-name var)))))) - vars)) - (out (handler expr env attributes - vocab p-env vars))) - (set-top-level-status attributes - top-level?) - out))) - (else (static-error - "define-values" 'kwd:define-values - expr "malformed definition"))))))) - - (add-primitivized-micro-form 'define-values unit-clauses-vocab-delta - (define-values-helper - (lambda (expr env attributes vocab p-env vars) - (register-definitions vars attributes) - (let* ((id-exprs (map (lambda (v) - (let ((parsed - (expand-expr v env attributes - define-values-id-parse-vocab))) - parsed)) - vars)) - (expr-expr (expand-expr - (pat:pexpand 'val p-env kwd) - env attributes vocab))) - (create-define-values-form id-exprs expr-expr expr))))))) - - (define define-values-id-parse-vocab - (create-vocabulary 'define-values-id-parse-vocab #f - "malformed in identifier position" - "malformed in identifier position" - "malformed in identifier position" - "malformed in identifier position")) - - (add-sym-micro define-values-id-parse-vocab - (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) - (lambda (expr env attributes vocab) - (let ((id (z:read-object expr))) - (let ((top-level-space (get-attribute attributes 'top-levels))) - (if top-level-space - (begin - (let ((ref - (create-top-level-varref/bind/unit - id - (hash-table-get top-level-space id - (lambda () - (let ((b (box '()))) - (hash-table-put! top-level-space id b) - b))) - expr))) - ;; Define a unit-bound variable => mark this and pre-existing as unit - (set-top-level-varref/bind/unit-unit?! ref #t) - (let ((b (top-level-varref/bind-slot ref))) - (map (lambda (r) (set-top-level-varref/bind/unit-unit?! r #t)) (unbox b)) - (set-box! b (cons ref (unbox b)))) - ref)) - (create-top-level-varref id expr))))))) - - (add-primitivized-micro-form 'set! unit-clauses-vocab-delta - (let* ((kwd '()) - (in-pattern `(_ var val)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (let ((p-env (pat:match-against m&e expr env))) - (if p-env - (let* ((top-level? (get-top-level-status attributes)) - (_ (set-top-level-status attributes)) - (var-p (pat:pexpand 'var p-env kwd)) - (_ (valid-syntactic-id? var-p)) - (id-expr (expand-expr var-p env attributes vocab)) - (expr-expr (expand-expr - (pat:pexpand 'val p-env kwd) - env attributes vocab))) - (when (check-import var-p attributes) - (static-error - "set!" 'term:no-set!-imported - var-p "cannot mutate imported identifier")) - (set-top-level-status attributes top-level?) - (create-set!-form id-expr expr-expr expr)) - (static-error - "set!" 'kwd:set! - expr "malformed expression")))))) - - (define process-unit-top-level-resolution - (lambda (expr attributes) - (let ([varref - (process-top-level-resolution expr attributes)]) - (let ([id (z:read-object expr)]) - (unless (built-in-name id) - (update-unresolved-attribute attributes expr varref))) - varref))) - - (add-sym-micro unit-clauses-vocab-delta - (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) - (lambda (expr env attributes vocab) - (let loop ((r (resolve expr env vocab))) - (cond - ((or (macro-resolution? r) (micro-resolution? r)) - (if (check-export expr attributes) - (loop top-level-resolution) - (static-error - "keyword" 'term:keyword-out-of-context expr - "invalid use of keyword ~s" (z:symbol-orig-name expr)))) - ((lambda-binding? r) - (create-lambda-varref r expr)) - ((lexical-binding? r) - (create-lexical-varref r expr)) - ((top-level-resolution? r) - (check-for-signature-name expr attributes) - (process-unit-top-level-resolution expr attributes)) - (else - (internal-error expr "Invalid resolution in unit delta: ~s" - r))))))) - - ; -------------------------------------------------------------------- - - (include "scm-hanc.ss") - - ; -------------------------------------------------------------------- - - (define reference-unit-maker - (lambda (form-name form-name-str kwd:form-name sig?) - (let ([micro - (let* ((kwd '()) - (in-pattern `(_ filename)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd))) - (let ((f (expand-expr filename env attributes vocab))) - (if (and (quote-form? f) - (z:string? (quote-form-expr f))) - (expand-expr - (structurize-syntax - `(let ((result (#%load/use-compiled - ,(quote-form-expr f)))) - (unless (,(if sig? - '#%unit/sig? - '#%unit?) - result) - (#%raise - (#%make-exn:unit - ,(format - "~s: result from ~s is not ~aunit" - form-name - (sexp->raw (quote-form-expr f)) - (if sig? "signed " "")) - (#%current-continuation-marks)))) - result) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab) - (static-error - form-name-str kwd:form-name - filename "does not yield a filename")))))) - (else - (static-error - form-name-str kwd:form-name - expr "malformed expression")))))]) - (add-primitivized-micro-form form-name full-vocabulary micro) - (add-on-demand-form 'micro form-name common-vocabulary micro)))) - - (reference-unit-maker 'require-unit "require-unit" 'kwd:require-unit #f) - (reference-unit-maker 'require-unit/sig - "require-unit/sig" 'kwd:require-unit/sig #t) - - (define reference-library-unit-maker - (lambda (form-name form-name-str kwd:form-name sig? relative?) - (let ([micro - (let* ((kwd '()) - (in-pattern '(_ filename collections ...)) - (m&e (pat:make-match&env in-pattern kwd))) - (lambda (expr env attributes vocab) - (cond - ((pat:match-against m&e expr env) - => - (lambda (p-env) - (let ((filename (pat:pexpand 'filename p-env kwd)) - (collections (pat:pexpand '(collections ...) - p-env kwd))) - (let ((f (expand-expr filename env attributes vocab)) - (cs (map (lambda (c) - (expand-expr c env attributes vocab)) - collections))) - (unless (and (quote-form? f) - (z:string? (quote-form-expr f))) - (static-error - form-name-str kwd:form-name - filename "does not yield a filename")) - (for-each - (lambda (c collection) - (unless (and (quote-form? c) - (z:string? (quote-form-expr c))) - (static-error - form-name-str kwd:form-name - collection "does not yield a string"))) - cs collections) - (let ((raw-f (z:read-object (quote-form-expr f))) - (raw-cs (map (lambda (c) - (z:read-object - (quote-form-expr c))) - cs))) - (unless (relative-path? raw-f) - (static-error - form-name-str kwd:form-name - f - "library path ~s must be a relative path" - raw-f)) - (expand-expr - (structurize-syntax - `(let ((result (,(if relative? - '#%require-relative-library - '#%require-library) - ,(quote-form-expr f) - ,@(map quote-form-expr cs)))) - (unless (,(if sig? '#%unit/sig? '#%unit?) - result) - (#%raise - (#%make-exn:unit - ,(format - "~s: result from ~s in collection ~a not a ~aunit" - form-name - raw-f - (if (null? raw-cs) - '"mzlib" - raw-cs) - (if sig? "signed " "")) - (#%current-continuation-marks)))) - result) - expr '(-1) - #f - (z:make-origin 'micro expr)) - env attributes vocab)))))) - (else - (static-error - form-name-str kwd:form-name - expr "malformed expression")))))]) - (add-primitivized-micro-form form-name full-vocabulary micro) - (add-on-demand-form 'micro form-name common-vocabulary micro)))) - - (reference-library-unit-maker 'require-library-unit - "require-library-unit" 'kwd:require-library-unit #f #f) - (reference-library-unit-maker 'require-library-unit/sig - "require-library-unit/sig" 'kwd:require-library-unit/sig #t #f) - (reference-library-unit-maker 'require-relative-library-unit - "require-relative-library-unit" 'kwd:require-relative-library-unit #f #t) - (reference-library-unit-maker 'require-relative-library-unit/sig - "require-relative-library-unit/sig" - 'kwd:require-relative-library-unit/sig #t #t) - - (define (reset-unit-attributes attr) - (put-attribute attr 'c-unit-link-import/body-vocab null) - (put-attribute attr 'c-unit-current-link-tag-attribute null) - (put-attribute attr 'c-unit-expand-env null) - (put-attribute attr 'unit-vars null) - (put-attribute attr 'unresolved-unit-vars null) - (put-attribute attr 'exports-expand-vocab #f)) - - (attributes-resetters (cons reset-unit-attributes (attributes-resetters))) - - ) diff --git a/collects/zodiac/sexp.ss b/collects/zodiac/sexp.ss deleted file mode 100644 index 9b6705d1..00000000 --- a/collects/zodiac/sexp.ss +++ /dev/null @@ -1,278 +0,0 @@ -; $Id: sexp.ss,v 1.24 1999/06/02 11:29:38 mflatt Exp $ - -(unit/sig zodiac:sexp^ - (import zodiac:misc^ - zodiac:structures^ - (z : zodiac:reader-structs^) - zodiac:interface^ - zodiac:scheme-main^) - - (define identity (lambda (x) x)) - - (define structurize-syntax - (let ((default-origin (make-origin 'non-source 'never-mind))) - (opt-lambda (expr source (marks '()) (table #f) (origin default-origin)) - (let ((start (zodiac-start source)) - (finish (zodiac-finish source))) - (letrec - ((structurize - (lambda (expr origin) - (cond - ((zodiac? expr) expr) - ((and table - (hash-table-get table expr (lambda () #f))) - => - (lambda (cached-input) - cached-input)) - ((pair? expr) - (let loop ((expr expr) (rev-seen '()) (length 0)) - (cond - ((pair? expr) - (loop (cdr expr) - (cons (structurize (car expr) default-origin) rev-seen) - (add1 length))) - ((null? expr) - (z:make-list origin start finish - (reverse rev-seen) - length '())) - (else - (z:make-improper-list origin start finish - (reverse - (cons (structurize expr default-origin) rev-seen)) - (add1 length) - (make-period start) - '()))))) - ((vector? expr) - (z:make-vector origin start finish - (map (lambda (x) (structurize x default-origin)) (vector->list expr)) - (vector-length expr))) - ((symbol? expr) - (z:make-symbol - origin start finish expr expr marks)) - ((null? expr) - (z:make-list origin start finish '() 0 marks)) - ((string? expr) - (z:make-string origin start finish expr)) - ((number? expr) - (z:make-number origin start finish expr)) - ((boolean? expr) - (z:make-boolean origin start finish expr)) - ((char? expr) - (z:make-char origin start finish expr)) - [(and (object? expr) - (is-a? expr expands<%>)) - (z:make-external origin start finish expr)] - (else - (z:make-list origin start finish - (list - (z:make-symbol origin start finish - 'quote 'quote '(-1)) - expr) - 2 marks)))))) - (structurize expr origin)))))) - - (define set-macro-origin - (lambda (parsed-term head-sexp) - (when (zodiac? parsed-term) - (set-zodiac-origin! parsed-term - (make-origin 'macro - (if (z:symbol? head-sexp) - head-sexp - (internal-error 'set-macro-origin - "Shouldn't get ~s here" head-sexp))))) - parsed-term)) - - (define sexp->raw - (opt-lambda (expr (table #f)) - (cond - ((z:scalar? expr) - (if (z:box? expr) - (let ([b (box (sexp->raw (z:read-object expr) table))]) - (when table - (hash-table-put! table b expr)) - b) - (z:read-object expr))) - - ((z:sequence? expr) - (let ((output - (let ((objects (map (lambda (s) - (sexp->raw s table)) - (z:read-object expr)))) - (cond - ((z:list? expr) objects) - ((z:improper-list? expr) - (let loop ((objects objects)) - (if (or (null? objects) (null? (cdr objects))) - (internal-error expr - "Invalid ilist in sexp->raw") - (if (null? (cddr objects)) - (cons (car objects) (cadr objects)) - (cons (car objects) (loop (cdr objects))))))) - ((z:vector? expr) - (apply vector objects)))))) - (when table - (hash-table-put! table output expr)) - output)) - (else - expr)))) - - (define sanitized-sexp->raw - (let ((sa string-append)) - (lambda (expr) - (cond - ((z:scalar? expr) - (if (z:box? expr) - (box - (sanitized-sexp->raw (z:read-object expr))) - (z:read-object expr))) - ((z:vector? expr) - '#(...)) - ((z:list? expr) - '(...)) - ((z:improper-list? expr) - '(... . ...)) - (else - expr))))) - - ; ---------------------------------------------------------------------- - - (define syntax-null? - (lambda (l) - (and (z:list? l) - (= 0 (z:sequence-length l))))) - - (define syntax-car - (lambda (l) - (cond - ((or (z:list? l) (z:improper-list? l)) - (let ((object (expose-list l))) - (if (null? object) - (internal-error l "Empty list for syntax-car") - (car object)))) - (else (internal-error l "Not a list for syntax-car"))))) - - (define syntax-cdr - (lambda (l) - (cond - ((z:list? l) - (let ((object (expose-list l)) - (length (z:sequence-length l))) - (if (zero? length) - (internal-error l "Empty list for syntax-cdr") - (let ((result (cdr object))) - (z:make-list (zodiac-origin l) - (if (null? result) (zodiac-finish l) - (zodiac-start (car result))) - (zodiac-finish l) - result - (- length 1) '()))))) - ((z:improper-list? l) - (let ((object (expose-list l)) - (length (z:sequence-length l))) - (case length - ((0 1) (internal-error l "Improper list length is 0 or 1")) - ((2) (cadr object)) - (else - (let ((result (cdr object))) - (z:make-improper-list (zodiac-origin l) - (zodiac-start l) (zodiac-finish l) - result - (- length 1) - (z:improper-list-period l) '())))))) - (else (internal-error l "Not a list for syntax-cdr"))))) - - (define syntax-map - (case-lambda - ((f l) - (if (z:list? l) - (let ((object (expose-list l)) - (length (z:sequence-length l))) - (z:make-list (zodiac-origin l) - (zodiac-start l) (zodiac-finish l) - (map f object) length '())) - (internal-error l "Not a list for syntax-map"))) - ((f l1 l2) - (if (and (z:list? l1) (z:list? l2)) - (let ((object-1 (expose-list l1)) - (object-2 (expose-list l2)) - (length-1 (z:sequence-length l1)) - (length-2 (z:sequence-length l2))) - (if (= length-1 length-2) - (z:make-list (zodiac-origin l1) - (zodiac-start l1) (zodiac-finish l1) - (map f object-1 object-2) length-1 '()) - (internal-error l1 "Not of same length as ~s in syntax-map" - l2))) - (if (z:list? l1) - (internal-error l2 "Not a list for syntax-map") - (internal-error l1 "Not a list for syntax-map")))))) - - ; ---------------------------------------------------------------------- - - (define new-mark - (let ((m 0)) - (lambda () - (set! m (+ m 1)) - m))) - - (define mark-expression - (lambda (mark) - (lambda (expr) - (cond - ((z:list? expr) - (z:set-list-marks! expr - (add/remove-mark (z:list-marks expr) mark)) - expr) - ((z:symbol? expr) - (z:make-symbol (zodiac-origin expr) - (zodiac-start expr) (zodiac-finish expr) - (z:read-object expr) (z:symbol-orig-name expr) - (add/remove-mark (z:symbol-marks expr) mark))) - (else expr))))) - - (define carl car) - - (define add/remove-mark - (lambda (marks m) - (let loop - ((marks marks)) - (if (null? marks) (list m) - (let ((a (carl marks)) (d (cdr marks))) - (if (= a m) d - (cons a (loop d)))))))) - - (define expose-list - (lambda (l) - (cond - ((z:list? l) - (let ((marks (z:list-marks l)) - (object (z:read-object l))) - (if (null? marks) - object - (let - ((object - (let loop ((marks marks) (object object)) - (if (null? marks) object - (loop (cdr marks) - (map (mark-expression (carl marks)) object)))))) - (z:set-read-object! l object) - (z:set-list-marks! l '()) - object)))) - ((z:improper-list? l) - (let ((marks (z:improper-list-marks l)) - (object (z:read-object l))) - (if (null? marks) - object - (let - ((object - (let loop ((marks marks) (object object)) - (if (null? marks) object - (loop (cdr marks) - (map (mark-expression (carl marks)) object)))))) - (z:set-read-object! l object) - (z:set-improper-list-marks! l '()) - object)))) - (else - (internal-error l "Not appropriate for expose-list"))))) - - ) diff --git a/collects/zodiac/sigs.ss b/collects/zodiac/sigs.ss deleted file mode 100644 index 649e0bc8..00000000 --- a/collects/zodiac/sigs.ss +++ /dev/null @@ -1,209 +0,0 @@ -; $Id: sigs.ss,v 1.72 2000/01/10 22:51:13 clements Exp $ - -(begin-elaboration-time (require-library "macro.ss")) -(begin-elaboration-time (require-library "prettys.ss")) -(begin-elaboration-time (require-library "files.ss")) -(begin-elaboration-time (require-library "refer.ss")) -(require-library "refer.ss") - -(require-library "zsigs.ss" "zodiac") - -(define-signature zodiac:misc^ - (pretty-print debug-level symbol-append flush-printf print-and-return - attributes-resetters)) - -(define-signature zodiac:correlate^ - (make-correlator add-to-correlator find-in-correlator)) - -(define-signature zodiac:sexp^ - (structurize-syntax sexp->raw sanitized-sexp->raw - syntax-null? syntax-car syntax-cdr syntax-map - set-macro-origin - new-mark mark-expression add/remove-mark expose-list)) - -(define-signature zodiac:pattern^ - (make-match&env match-against penv-merge pexpand extend-penv - match-and-rewrite)) - -(define-signature zodiac:interface^ - (static-error internal-error)) - -(define-signature zodiac:expander^ - (expand expand-program expand-expr - m3-elaboration-evaluator - m3-macro-body-evaluator - add-system-macro-form add-user-macro-form - add-micro-form add-macro-form - add-list-micro add-ilist-micro add-lit-micro add-sym-micro - get-list-micro get-ilist-micro get-lit-micro get-sym-micro - make-attributes get-attribute put-attribute - extend-env copy-env retract-env print-env make-empty-environment - resolve resolve-in-env - macro-resolution? micro-resolution? - (struct top-level-resolution ()) - introduce-identifier introduce-fresh-identifier introduce-bound-id - create-vocabulary append-vocabulary - add-on-demand-form find-on-demand-form - set-subexpr-vocab! - (struct vocabulary-record - (name this rest symbol-error literal-error list-error ilist-error)))) - -(define-signature zodiac:scheme-core^ - (name-eq? marks-equal? - parsed->raw extend-parsed->raw - lexically-resolved? in-lexically-extended-env - add-primitivized-micro-form add-primitivized-macro-form - generate-name - elaboration-evaluator user-macro-body-evaluator - scheme-expand scheme-expand-program - common-vocabulary - beginner-vocabulary - intermediate-vocabulary - advanced-vocabulary - full-vocabulary - scheme-vocabulary - reset-previous-attribute - set-top-level-status get-top-level-status at-top-level? - set-internal-define-status get-internal-define-status at-internal-define? - as-nested - process-top-level-resolution ensure-not-macro/micro - check-for-signature-name - (struct parsed (back)) - (struct varref (var)) - (struct top-level-varref ()) create-top-level-varref - (struct top-level-varref/bind (slot)) create-top-level-varref/bind - (struct top-level-varref/bind/unit (unit?)) create-top-level-varref/bind/unit - (struct bound-varref (binding)) create-bound-varref - (struct lexical-varref ()) create-lexical-varref - (struct lambda-varref ()) create-lambda-varref - (struct app (fun args)) create-app - (struct binding (var orig-name)) create-binding+marks - (struct lexical-binding ()) create-lexical-binding+marks - (struct lambda-binding ()) create-lambda-binding+marks - (struct form ()) - valid-syntactic-id? valid-syntactic-id/s? - distinct-valid-syntactic-id/s? - valid-id? valid-id/s? - distinct-valid-id/s? - optarglist-pattern - (struct optarglist-entry (var+marks)) - (struct initialized-optarglist-entry (expr)) - (struct optarglist (vars)) - (struct sym-optarglist ()) - (struct list-optarglist ()) - (struct ilist-optarglist ()) - nonempty-arglist-decls-vocab lambda-nonempty-arglist-decls-vocab - proper-arglist-decls-vocab lambda-proper-arglist-decls-vocab - full-arglist-decls-vocab lambda-full-arglist-decls-vocab - optarglist-decls-vocab - make-optargument-list - paroptarglist-pattern - (struct paroptarglist-entry (var+marks)) - (struct initialized-paroptarglist-entry (expr)) - (struct paroptarglist (vars)) - (struct sym-paroptarglist ()) - (struct list-paroptarglist ()) - (struct ilist-paroptarglist ()) - paroptarglist-decls-vocab - make-paroptargument-list - arglist-pattern - (struct arglist (vars)) - (struct sym-arglist ()) - (struct list-arglist ()) - (struct ilist-arglist ()) - make-argument-list)) - -(define-signature zodiac:scheme-main^ - (create-const - (struct struct-form (type super fields)) create-struct-form - (struct if-form (test then else)) create-if-form - (struct quote-form (expr)) create-quote-form - (struct begin-form (bodies)) create-begin-form - (struct begin0-form (bodies)) create-begin0-form - (struct let-values-form (vars vals body)) create-let-values-form - (struct letrec-values-form (vars vals body)) create-letrec-values-form - (struct define-values-form (vars val)) create-define-values-form - (struct set!-form (var val)) create-set!-form - (struct case-lambda-form (args bodies)) create-case-lambda-form - (struct with-continuation-mark-form (key val body)) create-with-continuation-mark-form - generate-struct-names - expands<%>)) - -(define-signature zodiac:scheme-objects^ - (create-class*/names-form - create-interface-form - (struct supervar-varref ()) create-supervar-varref - (struct superinit-varref ()) create-superinit-varref - (struct public-varref ()) create-public-varref - (struct override-varref ()) create-override-varref - (struct private-varref ()) create-private-varref - (struct inherit-varref ()) create-inherit-varref - (struct rename-varref ()) create-rename-varref - (struct supervar-binding ()) create-supervar-binding+marks - (struct superinit-binding ()) create-superinit-binding+marks - (struct public-binding ()) create-public-binding+marks - (struct override-binding ()) create-override-binding+marks - (struct private-binding ()) create-private-binding+marks - (struct inherit-binding ()) create-inherit-binding+marks - (struct rename-binding ()) create-rename-binding+marks - (struct class*/names-form - (this super-init super-expr interfaces init-vars inst-clauses)) - (struct interface-form (super-exprs variables)) - (struct public-clause (exports internals exprs)) - (struct override-clause (exports internals exprs)) - (struct private-clause (internals exprs)) - (struct inherit-clause (internals imports)) - (struct rename-clause (internals imports)) - (struct sequence-clause (exprs)))) - -(define-signature zodiac:scheme-units^ - (create-unit-form - create-compound-unit-form - create-invoke-unit-form - (struct unit-form (imports exports clauses)) - (struct compound-unit-form (imports links exports)) - (struct invoke-unit-form (unit variables)) - unit-clauses-vocab-delta update-unresolved-attribute - inside-unit? check-export - process-unit-top-level-resolution - )) - -(define-signature zodiac:scheme-objects+units^ - ()) - -(define-signature zodiac:scheme-mrspidey^ - (mrspidey-vocabulary - (struct poly-form (exp)) - (struct :-form (exp type)) - (struct type:-form (type attrs)) - (struct st:control-form (para val)) - (struct reference-unit-form (file kind signed?)) - (struct define-type-form (sym type)) - (struct define-constructor-form (sym modes)) - create-poly-form - create-:-form - create-type:-form - create-st:control-form - create-reference-unit-form - create-define-type-form - create-define-constructor-form)) - -(define-signature zodiac:back-protocol^ - (make-empty-back-box register-client)) - -(define-signature zodiac:system^ - ((open zodiac:structures^) - (open zodiac:scanner-parameters^) - (open zodiac:reader-structs^) - (open zodiac:reader-code^) - (open zodiac:sexp^) - (open zodiac:pattern^) - (open zodiac:correlate^) - (open zodiac:back-protocol^) - (open zodiac:expander^) - (open zodiac:scheme-core^) - (open zodiac:scheme-main^) - (open zodiac:scheme-objects^) - (open zodiac:scheme-units^) - (open zodiac:scheme-objects+units^) - (open zodiac:scheme-mrspidey^))) diff --git a/collects/zodiac/x.ss b/collects/zodiac/x.ss deleted file mode 100644 index 38e5bcc5..00000000 --- a/collects/zodiac/x.ss +++ /dev/null @@ -1,392 +0,0 @@ -; $Id: x.ss,v 1.53 1999/07/09 18:44:34 mflatt Exp $ - -(unit/sig zodiac:expander^ - (import - zodiac:misc^ zodiac:sexp^ - zodiac:structures^ - (z : zodiac:reader-structs^) - zodiac:scheme-core^ - zodiac:interface^) - - ; ---------------------------------------------------------------------- - - (define-struct resolutions (name user?)) - (define-struct (micro-resolution struct:resolutions) (rewriter)) - (define-struct (macro-resolution struct:resolutions) (rewriter)) - - ; ---------------------------------------------------------------------- - - (define-struct vocabulary-record (name this rest - symbol-error literal-error - list-error ilist-error - on-demand subexpr-vocab)) - - (define get-vocabulary-name vocabulary-record-name) - - (define (self-subexpr-vocab v) - (set-vocabulary-record-subexpr-vocab! v v) - v) - - (define (set-subexpr-vocab! v subexpr-v) - (set-vocabulary-record-subexpr-vocab! v subexpr-v)) - - (define create-vocabulary - (opt-lambda (name (root #f) - (symbol-error (if root - (vocabulary-record-symbol-error root) - "symbol invalid in this position")) - (literal-error (if root - (vocabulary-record-literal-error root) - "literal invalid in this position")) - (list-error (if root - (vocabulary-record-list-error root) - "list invalid in this position")) - (ilist-error (if root - (vocabulary-record-ilist-error root) - "improper-list syntax invalid in this position"))) - (let ((h (make-hash-table))) - (self-subexpr-vocab - (make-vocabulary-record - name h root - symbol-error literal-error list-error ilist-error - null #f))))) - - (define append-vocabulary - (opt-lambda (new old (name #f)) - (let loop ((this new) (first? #t)) - (let ((name (if (and first? name) name - (vocabulary-record-name this)))) - (self-subexpr-vocab - (make-vocabulary-record - name - (vocabulary-record-this this) - (if (vocabulary-record-rest this) - (loop (vocabulary-record-rest this) #f) - old) - (vocabulary-record-symbol-error this) - (vocabulary-record-literal-error this) - (vocabulary-record-list-error this) - (vocabulary-record-ilist-error this) - (vocabulary-record-on-demand this) - #f)))))) - - (define add-micro/macro-form - (lambda (constructor) - (lambda (name/s vocab rewriter) - (let ((v (vocabulary-record-this vocab)) - (names (if (symbol? name/s) (list name/s) name/s)) - (r (constructor rewriter))) - (set-resolutions-name! r name/s) - (map (lambda (n) - (hash-table-put! v n r)) - names))))) - - (define vocab->list - (lambda (vocab) - (cons (vocabulary-record-name vocab) - (hash-table-map cons (vocabulary-record-this vocab))))) - - (define add-micro-form - (add-micro/macro-form (lambda (r) - (make-micro-resolution 'dummy #f r)))) - - (define add-system-macro-form - (add-micro/macro-form (lambda (r) - (make-macro-resolution 'dummy #f r)))) - - (define add-user-macro-form - (add-micro/macro-form (lambda (r) - (make-macro-resolution 'dummy #t r)))) - - (define add-macro-form add-system-macro-form) - - (define list-micro-kwd - (string->uninterned-symbol "list-expander")) - (define ilist-micro-kwd - (string->uninterned-symbol "ilist-expander")) - (define sym-micro-kwd - (string->uninterned-symbol "symbol-expander")) - (define lit-micro-kwd - (string->uninterned-symbol "literal-expander")) - - (define add-list/sym/lit-micro - (lambda (kwd) - (lambda (vocab rewriter) - (hash-table-put! (vocabulary-record-this vocab) - kwd - (make-micro-resolution kwd #f rewriter))))) - - (define add-list-micro (add-list/sym/lit-micro list-micro-kwd)) - (define add-ilist-micro (add-list/sym/lit-micro ilist-micro-kwd)) - (define add-sym-micro (add-list/sym/lit-micro sym-micro-kwd)) - (define add-lit-micro (add-list/sym/lit-micro lit-micro-kwd)) - - (define get-list/sym/lit-micro - (lambda (kwd) - (lambda (vocab) - (let loop ((vocab vocab)) - (hash-table-get (vocabulary-record-this vocab) - kwd - (lambda () - (let ((v (vocabulary-record-rest vocab))) - (if v - (loop v) - #f)))))))) - - (define get-list-micro (get-list/sym/lit-micro list-micro-kwd)) - (define get-ilist-micro (get-list/sym/lit-micro ilist-micro-kwd)) - (define get-sym-micro (get-list/sym/lit-micro sym-micro-kwd)) - (define get-lit-micro (get-list/sym/lit-micro lit-micro-kwd)) - - (define (add-on-demand-form kind name vocab micro) - (set-vocabulary-record-on-demand! - vocab - (cons (list* name kind micro) - (vocabulary-record-on-demand vocab)))) - - (define (find-on-demand-form name vocab) - (let ([v (assq name (vocabulary-record-on-demand vocab))]) - (if v - (list (cadr v) (cddr v)) - (let ([super (vocabulary-record-rest vocab)]) - (and super (find-on-demand-form name super)))))) - - ; ---------------------------------------------------------------------- - - (define expand-expr - (lambda (expr env attributes vocab) - ; (printf "Expanding in ~s:~n" (get-vocabulary-name vocab)) - ; (pretty-print (sexp->raw expr)) (newline) - ; (printf "top-level-status: ~s~n" (get-top-level-status attributes)) - ; (printf "Expanding~n") (pretty-print expr) (newline) - ; (printf "Expanding~n") (pretty-print (sexp->raw expr)) (newline) - ; (printf "Expanding~n") (display expr) (newline) (newline) - ; (printf "in ~s~n" (get-vocabulary-name vocab)) - ; (printf "in vocabulary~n") (print-env vocab) - ; (printf "in attributes~n") (hash-table-map attributes cons) - ; (printf "in~n") (print-env env) - ; (newline) - (cond - ((z:symbol? expr) - (let ((sym-expander (get-sym-micro vocab))) - (cond - ((micro-resolution? sym-expander) - ((micro-resolution-rewriter sym-expander) - expr env attributes (vocabulary-record-subexpr-vocab vocab))) - (sym-expander - (internal-error expr "Invalid sym expander ~s" sym-expander)) - (else - (static-error - "symbol syntax" 'term:invalid-pos-symbol - expr - (vocabulary-record-symbol-error vocab)))))) - ((or (z:scalar? expr) ; "literals" = scalars - symbols - (z:vector? expr)) - (let ((lit-expander (get-lit-micro vocab))) - (cond - ((micro-resolution? lit-expander) - ((micro-resolution-rewriter lit-expander) - expr env attributes (vocabulary-record-subexpr-vocab vocab))) - (lit-expander - (internal-error expr - "Invalid lit expander ~s" lit-expander)) - (else - (static-error - "literal syntax" 'term:invalid-pos-literal - expr - (vocabulary-record-literal-error vocab)))))) - ((z:list? expr) - (let ((invoke-list-expander - (lambda () - (let ((list-expander (get-list-micro vocab))) - (cond - ((micro-resolution? list-expander) - ((micro-resolution-rewriter list-expander) - expr env attributes (vocabulary-record-subexpr-vocab vocab))) - (list-expander - (internal-error expr - "Invalid list expander ~s" list-expander)) - (else - (static-error - "list syntax" 'term:invalid-pos-list - expr - (vocabulary-record-list-error vocab))))))) - (contents (expose-list expr))) - (if (null? contents) - (invoke-list-expander) - (let ((app-pos (car contents))) - (if (z:symbol? app-pos) - (let ((r (resolve app-pos env vocab))) - (cond - ((macro-resolution? r) - (with-handlers ((exn:user? - (lambda (exn) - (static-error - "macro error" - 'term:macro-error - expr - (exn-message exn))))) - (let* ((rewriter (macro-resolution-rewriter r)) - (m (new-mark)) - (rewritten (rewriter expr env)) - (structurized (structurize-syntax - rewritten expr (list m) - #f - (make-origin 'macro - expr)))) - (expand-expr structurized env - attributes vocab)))) - ((micro-resolution? r) - ((micro-resolution-rewriter r) - expr env attributes (vocabulary-record-subexpr-vocab vocab))) - (else - (invoke-list-expander)))) - (invoke-list-expander)))))) - ((z:improper-list? expr) - (let ((ilist-expander (get-ilist-micro vocab))) - (cond - ((micro-resolution? ilist-expander) - ((micro-resolution-rewriter ilist-expander) - expr env attributes (vocabulary-record-subexpr-vocab vocab))) - (ilist-expander - (internal-error expr - "Invalid ilist expander ~s" ilist-expander)) - (else - (static-error - "improper list syntax" 'term:invalid-pos-ilist - expr - (vocabulary-record-ilist-error vocab)))))) - (else - (internal-error expr - "Invalid body: ~s" expr))))) - - (define m3-elaboration-evaluator #f) - (define m3-macro-body-evaluator #f) - - (define expand - (lambda (expr attr vocab elaboration-eval macro-body-eval) - (fluid-let ((m3-elaboration-evaluator elaboration-eval) - (m3-macro-body-evaluator macro-body-eval)) - (expand-expr expr (make-new-environment) attr vocab)))) - - (define expand-program - (lambda (exprs attr vocab elaboration-eval macro-body-eval) - (fluid-let ((m3-elaboration-evaluator elaboration-eval) - (m3-macro-body-evaluator macro-body-eval)) - (put-attribute attr 'top-levels (make-hash-table)) - (map (lambda (expr) - (expand-expr expr (make-new-environment) attr vocab)) - exprs)))) - - ; ---------------------------------------------------------------------- - - (define make-attributes make-hash-table) - (define put-attribute - (lambda (table key value) - (hash-table-put! table key value) - table)) - (define get-attribute - (opt-lambda (table key (failure-thunk (lambda () #f))) - (hash-table-get table key failure-thunk))) - - ; ---------------------------------------------------------------------- - - (define introduce-identifier - (lambda (new-name old-id) - (z:make-symbol (zodiac-origin old-id) - (zodiac-start old-id) (zodiac-finish old-id) - new-name new-name (z:symbol-marks old-id)))) - - (define introduce-fresh-identifier - (lambda (new-name source) - (z:make-symbol (make-origin 'non-source 'never-mind) - (zodiac-start source) (zodiac-finish source) - new-name new-name '()))) - - (define introduce-bound-id - (lambda (binding-gen name-gen old-id old-id-marks) - (let* ((base-name (binding-var old-id)) - (real-base-name (binding-orig-name old-id)) - (new-base-name (name-gen real-base-name)) - (new-name (symbol-append base-name "-init"))) - (let ((s (z:make-symbol (zodiac-origin old-id) - (zodiac-start old-id) (zodiac-finish old-id) - new-base-name new-base-name old-id-marks))) - ((create-binding+marks binding-gen - (lambda (_) new-name)) - s))))) - - ; ---------------------------------------------------------------------- - - (define-struct (top-level-resolution struct:resolutions) ()) - - ; ---------------------------------------------------------------------- - - (define make-new-environment make-hash-table) - - (define make-empty-environment make-new-environment) - - (define resolve - (lambda (id env vocab) - (let ((name (z:read-object id)) (marks (z:symbol-marks id))) - (or (resolve-in-env name marks env) - (resolve-in-vocabulary name vocab))))) - - (define resolve-in-env - (lambda (name marks env) - (let ((v (hash-table-get env name (lambda () #f)))) ; name-eq? - (and v - (let ((w (assoc marks v))) ; marks-equal? - (and w (cdr w))))))) - - (define resolve-in-vocabulary - (let ((top-level-resolution (make-top-level-resolution 'dummy #f))) ; name-eq? - (lambda (name vocab) - (let loop ((vocab vocab)) - (hash-table-get (vocabulary-record-this vocab) - name - (lambda () - (let ((v (vocabulary-record-rest vocab))) - (if v - (loop v) - top-level-resolution)))))))) - - (define print-env - (lambda (env) - (hash-table-map env (lambda (key value) - (printf "~s ->~n" key) - (pretty-print value))))) - - ; ---------------------------------------------------------------------- - - (define extend-env - (lambda (new-vars+marks env) - (for-each - (lambda (var+marks) - (let ((new-var (car var+marks))) - (let ((real-name (binding-orig-name new-var))) - (hash-table-put! env real-name - (cons (cons (cdr var+marks) new-var) - (hash-table-get env real-name (lambda () '()))))))) - new-vars+marks))) - - (define retract-env - (lambda (vars env) - (let ((names (map binding-orig-name vars))) - (for-each (lambda (name) - (hash-table-put! env name - (cdr (hash-table-get env name - (lambda () - '(internal-error:dummy-for-sake-of-cdr!)))))) - names)))) - - (define copy-env - (lambda (env) - (let ([new (make-hash-table)]) - (hash-table-for-each - env - (lambda (key val) - (hash-table-put! new key val))) - new))) - - ) diff --git a/collects/zodiac/zsigs.ss b/collects/zodiac/zsigs.ss deleted file mode 100644 index 346d0718..00000000 --- a/collects/zodiac/zsigs.ss +++ /dev/null @@ -1,96 +0,0 @@ -;; -;; $Id: zsigs.ss,v 1.9 1998/03/05 18:30:42 mflatt Exp $ -;; -;; The signatures for all scanner/reader units. -;; - -;; -;; Top-level zodiac structures (outside the hierarchy) -;; and base of zodiac hierarchy. -;; - -(define-signature zodiac:structures^ - ((struct origin (who how)) - (struct location (line column offset file)) - (struct period (location)) - (struct eof (location)) - (struct zodiac (origin start finish)))) - -;; -;; Scanner's subtree of the hierarchy. -;; -;; zodiac (origin start finish) -;; scanned -;; token (object type) -;; - -(define-signature zodiac:scanner-structs^ - ((struct scanned ()) - (struct token (object type)))) - -;; -;; Reader's subtree of the hierarchy. -;; -;; zodiac (origin start finish) -;; read (object) -;; scalar -;; symbol (orig-name marks) -;; number -;; string -;; boolean -;; char -;; box -;; type-symbol -;; external -;; sequence (length) -;; list -;; vector -;; improper-list (period) -;; - -(define-signature zodiac:reader-structs^ - ((struct read (object)) - (struct scalar ()) - (struct symbol (orig-name marks)) - (struct number ()) - (struct string ()) - (struct boolean ()) - (struct char ()) - (struct box ()) - (struct type-symbol ()) - (struct external ()) - (struct sequence (length)) - (struct list (marks)) - (struct vector ()) - (struct improper-list (period marks)))) - -;; -;; Scanner/Reader Parameters. -;; -;; The scan values (outside make-scanner) mostly can -;; be reset at will. But don't use letters, digits, #, etc. -;; The parameters inside make-scanner should not be reset. -;; -;; The char lists can be either chars or ints. -;; - -(define-signature zodiac:scanner-parameters^ - (disallow-untagged-inexact-numbers - scan:paren-relation - scan:self-delim-symbols - scan:newline-list - scan:tab-list - scan:whitespace-list - scan:delim-list - scan:special-char-list - default-initial-location - scan:def-first-col - scan:def-vect-val)) - -;; -;; The scanner & reader units just export one function. -;; - -(define-signature zodiac:scanner-code^ (scan)) -(define-signature zodiac:reader-code^ (read allow-improper-lists allow-reader-quasiquote)) - diff --git a/install b/install deleted file mode 100755 index 7f8d46ec..00000000 --- a/install +++ /dev/null @@ -1,158 +0,0 @@ -#!/bin/sh - -# PLT software installer -# Configures PLTHOME path within scripts -# For certain platforms and installations, adds extra -# directory links (to reach non-standard binaries -# through the platform's standard path) -# Creates .zo files if the user assents - -didnothing=" (nothing to do)" - -showhelp () -{ - echo "Usage: $0 [ newplthomedir ]" - echo " newplthomedir defaults to the current directory" - echo " use \"\" for newplthomedir to keep the current setting" - exit 1 -} - -if [ $# -gt 1 ] ; then - showhelp -fi -if [ "$1" = '-h' ] ; then - showhelp -fi - -if [ ! \( \( -x install \) -a \( -d collects \) \) ] ; then - echo "$0: must be run from its own directory" - exit 1 -fi - -if [ $# -eq 1 ] ; then - installplthome="$1" -else - installplthome=`pwd` -fi - -PLTHOME="$installplthome" -export PLTHOME -PLTCOLLECTS="" -export PLTCOLLECTS -PLTEXTENSION="" -export PLTEXTENSION - -echo "setting PLTHOME to $installplthome in scripts:" - -case `uname -s` in - *BSD) # FreeBSD and OpenBSD, at least - chmod='chmod -RH' - ;; - *) - chmod='chmod' - ;; -esac - -if [ "$installplthome" != '' ] ; then - # Change the scripts in bin/, replacing - # PLTHOME=.* - # with - # PLTHOME= - # where is provided to this script - - PROGRAM="/set PLTHOME=.*/ { print \" set PLTHOME=$installplthome\"; next } /PLTHOME=.*/ { print \" PLTHOME=$installplthome\"; next } /.*/ {print} " - - for f in bin/* ; do - if [ -f $f ] ; then - echo " updating $f" - didnothing="" - awk "$PROGRAM" $f > $f.tmp - if [ -w $f ] ; then - cat $f.tmp > $f - else - # Ugh - temporarily chmod to allow writing - oldstate=`ls -Ll $f` - $chmod a+w $f - cat $f.tmp > $f - $chmod a-w $f - ucanwrite=`echo $oldstate | cut -c3,3` - gcanwrite=`echo $oldstate | cut -c6,6` - ocanwrite=`echo $oldstate | cut -c9,9` - if [ $ucanwrite = 'w' ] ; then - $chmod u+w $f - fi - if [ $gcanwrite = 'w' ] ; then - $chmod g+w $f - fi - if [ $ocanwrite = 'w' ] ; then - $chmod o+w $f - fi - fi - rm $f.tmp - else - if [ -d $f ]; then - echo "$0: weird - $f is not a file!" - fi - fi - done -fi - -checklink () -{ - PACKAGE=$1 - SPECIAL=$2 - STD=$3 - SHORTSPECIAL=$4 - SPECIALNAME=$5 - STDNAME=$6 - - if [ -r $SPECIAL ] ; then - if [ ! \( -r $STD \) ] ; then - echo "If you *do not* plan to install the $STDNAME " - echo " version of the PLT software, a soft-link to" - echo " the $SPECIALNAME version should be installed for" - echo " $PACKAGE." - echo -n " Add this link (y/n)? [y] " - read response - if [ "$response" != 'n' ] ; then - if [ "$response" != 'N' ] ; then - didnothing="" - ln -s $SHORTSPECIAL $STD - echo "link from $STDNAME ($STD) to $SPECIALNAME ($SHORTSPECIAL) added" - fi - fi - fi - fi -} - -checklink "MrEd/DrScheme" ".bin/rs6k-aix-xt/mred" ".bin/rs6k-aix/mred" "../rs6k-aix-xt/mred" "AIX Xt" "AIX Motif" -checklink "MrEd/DrScheme" ".bin/sparc-solaris-motif/mred" ".bin/sparc-solaris/mred" "../sparc-solaris-motif/mred" "Solaris Motif" "Solaris Xt" -checklink "MzScheme/MrEd/DrScheme" ".bin/sparc-sunos4-static" ".bin/sparc-sunos4" "sparc-sunos4-static" "SunOS4 Static" "Regular SunOS4" - -if [ `bin/archsys` = "sparc-solaris" ] ; then - checklink "MzScheme/MrEd/DrScheme" ".bin/sparc-sunos4" ".bin/sparc-solaris" "sparc-sunos4" "SunOS4" "Solaris" - checklink "MzScheme/MrEd/DrScheme" ".bin/sparc-sunos4-static" ".bin/sparc-solaris" "sparc-sunos4-static" "SunOS4 Static" "Solaris" -fi - -if [ -z "${RPM_INSTALL_PREFIX}" ] ; then - echo 'PLT software starts up much faster with .zo files, but creating .zo' - echo 'files now takes a few minutes and requires about 5MB of additional' - echo 'disk space. Create .zo files later by running plt/bin/setup-plt.' - echo -n ' Create .zo files now (y/n)? [y] ' - read response -else - response="y" -fi -if [ "$response" != 'n' ] ; then - if [ "$response" != 'N' ] ; then - didnothing="" - bin/setup-plt - fi -fi - -echo -echo "PLT installation done${didnothing}." -if [ -f bin/drscheme ] ; then - echo "Run DrScheme as bin/drscheme." - echo "For Help, select \`Help Desk' from DrScheme's \`Help' menu, or run bin/help-desk." -fi diff --git a/man/man1/drscheme-jr.1 b/man/man1/drscheme-jr.1 deleted file mode 100644 index 0b3517b3..00000000 --- a/man/man1/drscheme-jr.1 +++ /dev/null @@ -1,127 +0,0 @@ -.\" dummy line -.TH DRSCHEME JR 1 "28 October 1999" -.UC 4 -.SH NAME -drscheme-jr \- The Rice PLT Scheme programming shell -.SH SYNOPSIS -.B drscheme-jr -[ -.I Xflag ... -] -[ -.I file ... -] -.SH DESCRIPTION -.I DrScheme Jr -is the Rice University PLT Scheme -programming shell. It is the text-only version of the -.I DrScheme -programming environment. -.PP -.I DrScheme Jr -treats its command line arguments as filenames and loads them after -starting up. -.SH OPTIONS - -Startup file and expression switches: -.TP -.BI \-l \ language ,\ \-\-language \ language -Set the language to one of the following: -Beginner Intermediate Advanced R4RS+ MzScheme. -.TP -.BR \-\-case\-sens \ { on , off } -Enable/disable case-sensitive symbols and variables -.TP -.BR \-\-set\-undef \ { on , off } -Enable/disable set! on undefined variables -.TP -.BR \-\-auto\-else \ { on , off } -Enable/disable non-matching cond/case produces (void) -.TP -.BR \-\-improper\-lists \ { on , off } -Enable/disable improper lists -.TP -.BR \-\-print\-sharing \ { on , off } -Enable/disable show sharing in values -.TP -.BR \-\-print\-list \ { on , off } -Enable/disable use `list' where appropriate in constructor style printing -.TP -.BR \-\-signal\-undef \ { on , off } -Enable/disable error if using # variable -.TP -.BR \-\-boolean\-conds \ { on , off } -Enable/disable conditionals must be #t or #f -.TP -.BR \-\-eq\-syms \ { on , off } -Enable/disable eq? only for symbols -.TP -.BR \-\-tag\-inexacts \ { on , off } -Enable/disable print inexact numbers with #i -.TP -.BR \-\-whole\-frac \ { on , off } -Enable/disable separate whole and fractional parts of exact numbers in printer -.TP -.BR \-\-constructor\-printing \ { on , off } -Enable/disable print values using constructor style input syntax -.TP -.BR \-\-quasi\-printing \ { on , off } -Enable/disable print values using quasi-quote style input syntax -.TP -.BI \-\-choose -Interactively choose the language level -.TP -.BI \-\-save\ \ \ -Save current settings to ~/.drscheme-jr.settings -.TP -.BI \-\-show\ \ \ -Show the current settings -.TP -.BI \-\-lhelp \ language -Show the flags implied by a particular language -.TP -.B \-\-help,\ \-h -Show help -.TP -.B \-\-\ \ \ \ \ -Do not treat any remaining argument as a flag (at this level) - -.PP -Multiple single-letter flags can be combined after one `-'. -For example, `-h-' is the same as `-h --' -If ~/.drscheme-jr.settings exists, it initializes the language settings. - -.pp -For further information on -.I DrScheme Jr, -please consult the on-line -documentation and other information available at -.PP -.ce 1 -http://www.cs.rice.edu/CS/PLT/packages/drschemejr/ -.SH FILES -.I DrScheme Jr -looks for its libraries using the environment variables -PLTHOME and PLTCOLLECTS. If this variable is not defined, -the installation directory is assumed (usually -"/usr/local/lib/plt/"). See the documentation for details. -.PP -Please consult your local administrator to determine whether -the on-line documentation has been installed locally. -.SH BUGS -Submit bug reports via -.ce 1 -http://www.cs.rice.edu/CS/PLT/Bugs/ (encouraged) -or by e-mail to -.ce 1 -plt-bugs@cs.rice.edu (discouraged) -.SH AUTHOR -.I DrScheme Jr -was implemented by Robby Findler (robby@cs.rice.edu), -Shriram Krishnamurthi (shriram@cs.rice.edu), Cormac Flanagan -(cormac@cs.rice.edu), Matthew Flatt (mflatt@cs.rice.edu), -and Paul Steckler (steck@cs.rice.edu). -.SH SEE ALSO -.BR drscheme(1), -.BR mred(1), -.BR mzscheme(1) diff --git a/man/man1/drscheme.1 b/man/man1/drscheme.1 deleted file mode 100644 index c40a8f84..00000000 --- a/man/man1/drscheme.1 +++ /dev/null @@ -1,60 +0,0 @@ -.\" dummy line -.TH DRSCHEME 1 "28 October 1999" -.UC 4 -.SH NAME -drscheme \- The PLT Scheme programming environment -.SH SYNOPSIS -.B drscheme -[ -.I Xflag ... -] -[ -.I file ... -] -.SH DESCRIPTION -.I DrScheme -is the PLT Scheme -programming environment. A text-only version, -.I DrScheme Jr, -is also available. -.PP -.I DrScheme -opens the files given as command-line arguments. -.pp -For further information on -.I DrScheme, -please consult the on-line -documentation and other information available at -.PP -.ce 1 -http://www.cs.rice.edu/CS/PLT/packages/drscheme/ -.SH FILES -.I DrScheme -looks for its libraries using the environment variables -PLTHOME and PLTCOLLECTS. If this variable is not defined, -the installation directory is assumed (usually -"/usr/local/lib/plt/"). See the documentation for details. -.PP -Please consult your local administrator to determine whether -the on-line documentation has been installed locally. -.SH BUGS -Submit bug reports via -.ce 1 -Help Desk (encouraged), -or via the web -.ce 1 -http://www.cs.rice.edu/CS/PLT/Bugs/ (discouraged) -or by e-mail to -.ce 1 -plt-bugs@cs.rice.edu (discouraged) -.SH AUTHOR -.I DrScheme -was implemented by Robby Findler (robby@cs.rice.edu), -Shriram Krishnamurthi (shriram@cs.rice.edu), -John Clements (clements@cs.rice.edu), Cormac Flanagan -(cormac@cs.rice.edu), Matthew Flatt (mflatt@cs.utah.edu), -and Paul Steckler (steck@cs.rice.edu). -.SH SEE ALSO -.BR drscheme-jr(1), -.BR mred(1), -.BR mzscheme(1) diff --git a/man/man1/mred.1 b/man/man1/mred.1 deleted file mode 100644 index 98a6e189..00000000 --- a/man/man1/mred.1 +++ /dev/null @@ -1,290 +0,0 @@ -\" dummy line -.TH MRED 1 "16 March 2000" -.UC 4 -.SH NAME -mred \- The PLT Graphical Scheme implementation -.SH SYNOPSIS -.B mred -[ -.I X option ... -] -[ -.I option ... -] [ -.I argument ... -] - -.SH DESCRIPTION -.I MrEd -is the PLT's graphical Scheme -implementation. -It embeds and extends -.I MzScheme -with a graphical user interface (GUI) toolbox. -.PP -.I DrScheme -is the graphical development environment for creating -.I MzScheme -and -.I MrEd -applications. - -.SH X OPTIONS - -MrEd accepts the following standard -.I X flags -: -.B -display -.IR disp , -.B -geometry -.IR geom , -.B -bg -.IR color , -.B -background -.IR color , -.B -fg -.IR color , -.B -foreground -.IR color , -.B -fn -.IR font , -.B -font -.IR font , -.BR -iconic , -.B -name -.IR name , -.BR -rv , -.BR -reverse , -.BR +rv , -.B -selectionTimeout -.IR time , -.BR -synchronous , -.B -title -.IR name , -.B -xnllanguage -.IR lang , -.B -xrm -.IR file . -These flags must appear before all other flags. -.PP - -.SH OPTIONS - -Startup file and expression switches: -.TP -.BI \-e \ expr -Evaluates -.I expr -after -.I MrEd -starts. -.TP -.BI \-f \ file -Loads -.I file -after -.I MrEd -starts. -.TP -.BI \-d \ file -Load/cds -.I file -after -.I MrEd -starts. -.TP -.B \-F -.br -Loads all remaining arguments after -.I MrEd -starts. -.TP -.B \-D -.br -Load/cds all remaining arguments after -.I MrEd -starts. -.TP -.BI \-l \ file -Same as -.BR -e \ '(require-library\ "\|\c -.I file\|\c -")'. -.TP -.BI \-L \ file \ coll -Same as -.BR -e \ '(require-library\ "\|\c -.I file\|\c -" "\|\c -.I coll\|\c -")'. -.TP -.B \-r, --script -Script mode: use as last flag for scripts. -Same as -.BR -fmv- . -.TP -.B \-i, --script-cd -Like -r, but also sets the directory. -Same as -.BR -dmv- . -.TP -.B \-z, --stdio -Use stdio REPL. Same as -.BR -ve \ '(read-eval-print-loop)'. -.TP -.B \-w, --awk -Same as -.B -l -.BR awk.ss . -.PP - -Initialization switches: -.TP -.B \-x, --no-lib-path -Does not try to set current-library-collection-paths. -.TP -.B \-q, --no-init-file -Does not try to load "~/.MrEdrc". -.PP - -Language setting switches: -.TP -.B \-g, --case-sens -Identifiers and symbols are initially case-sensitive. -.TP -.B \-c, --esc-cont -Call/cc is replaced with call/ec. -.TP -.B \-s, --set-undef -Set! works on undefined identifiers. -.TP -.B \-a, --no-auto-else -Fall-through cond or case is an error. -.TP -.B \-n, --no-key -Keywords are not enforced. -.TP -.B \-y, --hash-percent-syntax -Only #% syntactic forms are present. -.TP -.B \-p, --persistent -Catches AIX SIGDANGER (low page space) signal. (AIX only) -.PP - -Miscellaneous switches: -.TP -.B \-- -.br -No argument following this switch is used as a switch. -.TP -.B \-m, --mute-banner -Suppresses -.BR -v / --version -text. -.TP -.B \-v, --version -Suppresses the read-eval-print loop, prints version. -.TP -.B \-h, --help -Shows help for command-line arguments and exits, ignoring other switches. -.TP -.BI \-R file ,\ --restore \ file -Restores an image; must be the only switch. (Special versions only) -.PP -Multiple single-letter switches can be collapsed, with arguments placed -after the collapsed switches; the first collapsed switch cannot be -.BR -- . -E.g.: -.B -vfme file expr -is the same as -.B -v -f file -m -e -.BR expr . -.PP -Extra arguments following the last switch are put into the Scheme global -variable `argv' as a vector of strings. The name used to start -.I MrEd -is put into the global variable `program' as a string. -.PP -Extra arguments after a -.B --restore -file are returned as a vector of -strings to the continuation of the `write-image-to-file' call that created -the image. -.PP -Expressions/files are evaluated/loaded in order as provided. -.PP -The current-library-collections-paths parameter is automatically set before any -expressions/files are evaluated/loaded, unless the -.B -x -or -.B --no-lib-path -switch is used. -.PP -.PP -For further information on -.IR MrEd , -please consult the on-line -documentation and other information available at -.PP -.ce 1 -http://www.cs.rice.edu/CS/PLT/packages/MrEd/ -.SH FILES -The file "~/.mredrc" is loaded before any provided -expressions/files are evaluated/loaded, unless the -.B -q -or -.B --no-init-file -switch is used. -.PP -The library collections search path is read -from the PLTCOLLECTS environment variable -(as a colon-separated list of paths). Wherever the empty path -appears appears in PLTCOLLECTS, it is replaced with the default -collections directory. If PLTCOLLECTS is not defined, the default -collections directory is used as the only element in the search path. -.PP -.I MrEd -looks for the default collections directory as one of the -following (tried in order): -.IP -The path in the environment variable PLTHOME is checked -for a "collects" subdirectory. -.IP -If -.I MrEd -was invoked with an absolute pathname, the directory -of the invoked executable is checked. If the executable -is a link, the directory of the referenced file is also -checked, recursively following links. -.IP -If -.I MrEd -is invoked with a relative pathname, the -directories in the PATH environment variable containing -a file with the name of the program as invoked (usually -"MrEd") are checked. Links are followed as in the -first case. -.IP -The "/usr/local/lib/plt/collects" directory is -tried. -.PP -Please consult your local administrator to determine whether -the on-line documentation has been installed locally. -.SH BUGS -Submit bug reports via -.ce 1 -http://www.cs.rice.edu/CS/PLT/Bugs/ (encouraged) -or by e-mail to -.ce 1 -plt-bugs@cs.rice.edu (discouraged) -.SH AUTHOR -.I MrEd -was implemented by Matthew Flatt (mflatt@cs.utah.edu) with -Robert Bruce Findler (robby@cs.rice.edu) and -John Clements (clements@cs.rice.edu), based on -MzScheme. -.SH SEE ALSO -.BR mzscheme(1), -.BR drscheme(1), -.BR drscheme-jr(1) diff --git a/man/man1/mzscheme.1 b/man/man1/mzscheme.1 deleted file mode 100644 index 874a538b..00000000 --- a/man/man1/mzscheme.1 +++ /dev/null @@ -1,244 +0,0 @@ -.\" dummy line -.TH MZSCHEME 1 "16 March 2000" -.UC 4 -.SH NAME -MzScheme \- The PLT Scheme implementation -.SH SYNOPSIS -.B mzscheme -[ -.I option ... -] [ -.I argument ... -] -.SH DESCRIPTION -.I MzScheme -is the PLT -Scheme implementation. It nearly implements the language as -described in the -.I Revised^5 Report on -.I the Algorithmic Language Scheme -(the macro system is not fully supported), and adds numerous extensions. -.PP -.I MrEd -embeds and extends MzScheme with a graphical user interface (GUI) toolbox. -.PP -.I DrScheme -is the graphical development environment for creating -.I MzScheme -and -.I MrEd -applications. -.SH OPTIONS - -Startup file and expression switches: -.TP -.BI \-e \ expr -Evaluates -.I expr -after -.I MzScheme -starts. -.TP -.BI \-f \ file -Loads -.I file -after -.I MzScheme -starts. -.TP -.BI \-d \ file -Load/cds -.I file -after -.I MzScheme -starts. -.TP -.B \-F -.br -Loads all remaining arguments after -.I MzScheme -starts. -.TP -.B \-D -.br -Load/cds all remaining arguments after -.I MzScheme -starts. -.TP -.BI \-l \ file -Same as -.BR -e \ '(require-library\ "\|\c -.I file\|\c -")'. -.TP -.BI \-L \ file \ coll -Same as -.BR -e \ '(require-library\ "\|\c -.I file\|\c -" "\|\c -.I coll\|\c -")'. -.TP -.B \-r, --script -Script mode: use as last flag for scripts. -Same as -.BR -fmv- . -.TP -.B \-i, --script-cd -Like -r, but also sets the directory. -Same as -.BR -dmv- . -.TP -.B \-w, --awk -Same as -.B -l -.BR awk.ss . -.PP - -Initialization switches: -.TP -.B \-x, --no-lib-path -Does not try to set current-library-collection-paths. -.TP -.B \-q, --no-init-file -Does not try to load "~/.mzschemerc". -.PP - -Language setting switches: -.TP -.B \-g, --case-sens -Identifiers and symbols are initially case-sensitive. -.TP -.B \-c, --esc-cont -Call/cc is replaced with call/ec. -.TP -.B \-s, --set-undef -Set! works on undefined identifiers. -.TP -.B \-a, --no-auto-else -Fall-through cond or case is an error. -.TP -.B \-n, --no-key -Keywords are not enforced. -.TP -.B \-y, --hash-percent-syntax -Only #% syntactic forms are present. -.TP -.B \-p, --persistent -Catches AIX SIGDANGER (low page space) signal. (AIX only) -.PP - -Miscellaneous switches: -.TP -.B \-- -.br -No argument following this switch is used as a switch. -.TP -.B \-m, --mute-banner -Suppresses the startup banner. -.TP -.B \-v, --version -Suppresses the read-eval-print loop. -.TP -.B \-h, --help -Shows help for command-line arguments. -.TP -.BI \-R file ,\ --restore \ file -Restores an image; must be the only switch. (Special versions only) -.PP -Multiple single-letter switches can be collapsed, with arguments placed -after the collapsed switches; the first collapsed switch cannot be -.BR -- . -E.g.: -.B -vfme file expr -is the same as -.B -v -f file -m -e -.BR expr . -.PP -Extra arguments following the last switch are put into the Scheme global -variable `argv' as a vector of strings. The name used to start -.I MzScheme -is put into the global variable `program' as a string. -.PP -Extra arguments after a -.B --restore -file are returned as a vector of -strings to the continuation of the `write-image-to-file' call that created -the image. -.PP -Expressions/files are evaluated/loaded in order as provided. -.PP -The current-library-collections-paths parameter is automatically set before any -expressions/files are evaluated/loaded, unless the -.B -x -or -.B --no-lib-path -switch is used. -.PP -.PP -For further information on -.IR MzScheme , -please consult the on-line -documentation and other information available at -.PP -.ce 1 -http://www.cs.rice.edu/CS/PLT/packages/mzscheme/ -.SH FILES -The file "~/.mzschemerc" is loaded before any provided -expressions/files are evaluated/loaded, unless the -.B -q -or -.B --no-init-file -switch is used. -.PP -The library collections search path is read -from the PLTCOLLECTS environment variable -(as a colon-separated list of paths). Wherever the empty path -appears appears in PLTCOLLECTS, it is replaced with the default -collections directory. If PLTCOLLECTS is not defined, the default -collections directory is used as the only element in the search path. -.PP -.I MzScheme -looks for the default collections directory as one of the -following (tried in order): -.IP -The path in the environment variable PLTHOME is checked -for a "collects" subdirectory. -.IP -If -.I MzScheme -was invoked with an absolute pathname, the directory -of the invoked executable is checked. If the executable -is a link, the directory of the referenced file is also -checked, recursively following links. -.IP -If -.I MzScheme -is invoked with a relative pathname, the -directories in the PATH environment variable containing -a file with the name of the program as invoked (usually -"mzscheme") are checked. Links are followed as in the -first case. -.IP -The "/usr/local/lib/plt/collects" directory is -tried. -.PP -Please consult your local administrator to determine whether -the on-line documentation has been installed locally. -.SH BUGS -Submit bug reports via -.ce 1 -http://www.cs.rice.edu/CS/PLT/Bugs/ (encouraged) -or by e-mail to -.ce 1 -plt-bugs@cs.rice.edu (discouraged) -.SH AUTHOR -.I MzScheme -was implemented by Matthew Flatt (mflatt@cs.utah.edu). -It uses the conservative garbage collector implemented by Hans -Boehm and extended by John Ellis. MzScheme was originally based -on libscheme, written by Brent Benson. -.SH SEE ALSO -.BR drscheme(1), -.BR drscheme-jr(1), -.BR mred(1) diff --git a/notes/COPYING.LIB b/notes/COPYING.LIB deleted file mode 100644 index eb685a5e..00000000 --- a/notes/COPYING.LIB +++ /dev/null @@ -1,481 +0,0 @@ - GNU LIBRARY GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1991 Free Software Foundation, Inc. - 675 Mass Ave, Cambridge, MA 02139, USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - -[This is the first released version of the library GPL. It is - numbered 2 because it goes with version 2 of the ordinary GPL.] - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -Licenses are intended to guarantee your freedom to share and change -free software--to make sure the software is free for all its users. - - This license, the Library General Public License, applies to some -specially designated Free Software Foundation software, and to any -other libraries whose authors decide to use it. You can use it for -your libraries, too. - - When we speak of free software, we are referring to freedom, not -price. Our General Public Licenses are designed to make sure that you -have the freedom to distribute copies of free software (and charge for -this service if you wish), that you receive source code or can get it -if you want it, that you can change the software or use pieces of it -in new free programs; and that you know you can do these things. - - To protect your rights, we need to make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if -you distribute copies of the library, or if you modify it. - - For example, if you distribute copies of the library, whether gratis -or for a fee, you must give the recipients all the rights that we gave -you. You must make sure that they, too, receive or can get the source -code. If you link a program with the library, you must provide -complete object files to the recipients so that they can relink them -with the library, after making changes to the library and recompiling -it. And you must show them these terms so they know their rights. - - Our method of protecting your rights has two steps: (1) copyright -the library, and (2) offer you this license which gives you legal -permission to copy, distribute and/or modify the library. - - Also, for each distributor's protection, we want to make certain -that everyone understands that there is no warranty for this free -library. If the library is modified by someone else and passed on, we -want its recipients to know that what they have is not the original -version, so that any problems introduced by others will not reflect on -the original authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that companies distributing free -software will individually obtain patent licenses, thus in effect -transforming the program into proprietary software. To prevent this, -we have made it clear that any patent must be licensed for everyone's -free use or not licensed at all. - - Most GNU software, including some libraries, is covered by the ordinary -GNU General Public License, which was designed for utility programs. This -license, the GNU Library General Public License, applies to certain -designated libraries. This license is quite different from the ordinary -one; be sure to read it in full, and don't assume that anything in it is -the same as in the ordinary license. - - The reason we have a separate public license for some libraries is that -they blur the distinction we usually make between modifying or adding to a -program and simply using it. Linking a program with a library, without -changing the library, is in some sense simply using the library, and is -analogous to running a utility program or application program. However, in -a textual and legal sense, the linked executable is a combined work, a -derivative of the original library, and the ordinary General Public License -treats it as such. - - Because of this blurred distinction, using the ordinary General -Public License for libraries did not effectively promote software -sharing, because most developers did not use the libraries. We -concluded that weaker conditions might promote sharing better. - - However, unrestricted linking of non-free programs would deprive the -users of those programs of all benefit from the free status of the -libraries themselves. This Library General Public License is intended to -permit developers of non-free programs to use free libraries, while -preserving your freedom as a user of such programs to change the free -libraries that are incorporated in them. (We have not seen how to achieve -this as regards changes in header files, but we have achieved it as regards -changes in the actual functions of the Library.) The hope is that this -will lead to faster development of free libraries. - - The precise terms and conditions for copying, distribution and -modification follow. Pay close attention to the difference between a -"work based on the library" and a "work that uses the library". The -former contains code derived from the library, while the latter only -works together with the library. - - Note that it is possible for a library to be covered by the ordinary -General Public License rather than by this special one. - - GNU LIBRARY GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License Agreement applies to any software library which -contains a notice placed by the copyright holder or other authorized -party saying it may be distributed under the terms of this Library -General Public License (also called "this License"). Each licensee is -addressed as "you". - - A "library" means a collection of software functions and/or data -prepared so as to be conveniently linked with application programs -(which use some of those functions and data) to form executables. - - The "Library", below, refers to any such software library or work -which has been distributed under these terms. A "work based on the -Library" means either the Library or any derivative work under -copyright law: that is to say, a work containing the Library or a -portion of it, either verbatim or with modifications and/or translated -straightforwardly into another language. (Hereinafter, translation is -included without limitation in the term "modification".) - - "Source code" for a work means the preferred form of the work for -making modifications to it. For a library, complete source code means -all the source code for all modules it contains, plus any associated -interface definition files, plus the scripts used to control compilation -and installation of the library. - - Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running a program using the Library is not restricted, and output from -such a program is covered only if its contents constitute a work based -on the Library (independent of the use of the Library in a tool for -writing it). Whether that is true depends on what the Library does -and what the program that uses the Library does. - - 1. You may copy and distribute verbatim copies of the Library's -complete source code as you receive it, in any medium, provided that -you conspicuously and appropriately publish on each copy an -appropriate copyright notice and disclaimer of warranty; keep intact -all the notices that refer to this License and to the absence of any -warranty; and distribute a copy of this License along with the -Library. - - You may charge a fee for the physical act of transferring a copy, -and you may at your option offer warranty protection in exchange for a -fee. - - 2. You may modify your copy or copies of the Library or any portion -of it, thus forming a work based on the Library, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) The modified work must itself be a software library. - - b) You must cause the files modified to carry prominent notices - stating that you changed the files and the date of any change. - - c) You must cause the whole of the work to be licensed at no - charge to all third parties under the terms of this License. - - d) If a facility in the modified Library refers to a function or a - table of data to be supplied by an application program that uses - the facility, other than as an argument passed when the facility - is invoked, then you must make a good faith effort to ensure that, - in the event an application does not supply such function or - table, the facility still operates, and performs whatever part of - its purpose remains meaningful. - - (For example, a function in a library to compute square roots has - a purpose that is entirely well-defined independent of the - application. Therefore, Subsection 2d requires that any - application-supplied function or table used by this function must - be optional: if the application does not supply it, the square - root function must still compute square roots.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Library, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Library, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote -it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Library. - -In addition, mere aggregation of another work not based on the Library -with the Library (or with a work based on the Library) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may opt to apply the terms of the ordinary GNU General Public -License instead of this License to a given copy of the Library. To do -this, you must alter all the notices that refer to this License, so -that they refer to the ordinary GNU General Public License, version 2, -instead of to this License. (If a newer version than version 2 of the -ordinary GNU General Public License has appeared, then you can specify -that version instead if you wish.) Do not make any other change in -these notices. - - Once this change is made in a given copy, it is irreversible for -that copy, so the ordinary GNU General Public License applies to all -subsequent copies and derivative works made from that copy. - - This option is useful when you wish to copy part of the code of -the Library into a program that is not a library. - - 4. You may copy and distribute the Library (or a portion or -derivative of it, under Section 2) in object code or executable form -under the terms of Sections 1 and 2 above provided that you accompany -it with the complete corresponding machine-readable source code, which -must be distributed under the terms of Sections 1 and 2 above on a -medium customarily used for software interchange. - - If distribution of object code is made by offering access to copy -from a designated place, then offering equivalent access to copy the -source code from the same place satisfies the requirement to -distribute the source code, even though third parties are not -compelled to copy the source along with the object code. - - 5. A program that contains no derivative of any portion of the -Library, but is designed to work with the Library by being compiled or -linked with it, is called a "work that uses the Library". Such a -work, in isolation, is not a derivative work of the Library, and -therefore falls outside the scope of this License. - - However, linking a "work that uses the Library" with the Library -creates an executable that is a derivative of the Library (because it -contains portions of the Library), rather than a "work that uses the -library". The executable is therefore covered by this License. -Section 6 states terms for distribution of such executables. - - When a "work that uses the Library" uses material from a header file -that is part of the Library, the object code for the work may be a -derivative work of the Library even though the source code is not. -Whether this is true is especially significant if the work can be -linked without the Library, or if the work is itself a library. The -threshold for this to be true is not precisely defined by law. - - If such an object file uses only numerical parameters, data -structure layouts and accessors, and small macros and small inline -functions (ten lines or less in length), then the use of the object -file is unrestricted, regardless of whether it is legally a derivative -work. (Executables containing this object code plus portions of the -Library will still fall under Section 6.) - - Otherwise, if the work is a derivative of the Library, you may -distribute the object code for the work under the terms of Section 6. -Any executables containing that work also fall under Section 6, -whether or not they are linked directly with the Library itself. - - 6. As an exception to the Sections above, you may also compile or -link a "work that uses the Library" with the Library to produce a -work containing portions of the Library, and distribute that work -under terms of your choice, provided that the terms permit -modification of the work for the customer's own use and reverse -engineering for debugging such modifications. - - You must give prominent notice with each copy of the work that the -Library is used in it and that the Library and its use are covered by -this License. You must supply a copy of this License. If the work -during execution displays copyright notices, you must include the -copyright notice for the Library among them, as well as a reference -directing the user to the copy of this License. Also, you must do one -of these things: - - a) Accompany the work with the complete corresponding - machine-readable source code for the Library including whatever - changes were used in the work (which must be distributed under - Sections 1 and 2 above); and, if the work is an executable linked - with the Library, with the complete machine-readable "work that - uses the Library", as object code and/or source code, so that the - user can modify the Library and then relink to produce a modified - executable containing the modified Library. (It is understood - that the user who changes the contents of definitions files in the - Library will not necessarily be able to recompile the application - to use the modified definitions.) - - b) Accompany the work with a written offer, valid for at - least three years, to give the same user the materials - specified in Subsection 6a, above, for a charge no more - than the cost of performing this distribution. - - c) If distribution of the work is made by offering access to copy - from a designated place, offer equivalent access to copy the above - specified materials from the same place. - - d) Verify that the user has already received a copy of these - materials or that you have already sent this user a copy. - - For an executable, the required form of the "work that uses the -Library" must include any data and utility programs needed for -reproducing the executable from it. However, as a special exception, -the source code distributed need not include anything that is normally -distributed (in either source or binary form) with the major -components (compiler, kernel, and so on) of the operating system on -which the executable runs, unless that component itself accompanies -the executable. - - It may happen that this requirement contradicts the license -restrictions of other proprietary libraries that do not normally -accompany the operating system. Such a contradiction means you cannot -use both them and the Library together in an executable that you -distribute. - - 7. You may place library facilities that are a work based on the -Library side-by-side in a single library together with other library -facilities not covered by this License, and distribute such a combined -library, provided that the separate distribution of the work based on -the Library and of the other library facilities is otherwise -permitted, and provided that you do these two things: - - a) Accompany the combined library with a copy of the same work - based on the Library, uncombined with any other library - facilities. This must be distributed under the terms of the - Sections above. - - b) Give prominent notice with the combined library of the fact - that part of it is a work based on the Library, and explaining - where to find the accompanying uncombined form of the same work. - - 8. You may not copy, modify, sublicense, link with, or distribute -the Library except as expressly provided under this License. Any -attempt otherwise to copy, modify, sublicense, link with, or -distribute the Library is void, and will automatically terminate your -rights under this License. However, parties who have received copies, -or rights, from you under this License will not have their licenses -terminated so long as such parties remain in full compliance. - - 9. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Library or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Library (or any work based on the -Library), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Library or works based on it. - - 10. Each time you redistribute the Library (or any work based on the -Library), the recipient automatically receives a license from the -original licensor to copy, distribute, link with or modify the Library -subject to these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 11. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -conditions are imposed on you (whether by court order, agreement or -otherwise) that contradict the conditions of this License, they do not -excuse you from the conditions of this License. If you cannot -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Library at all. For example, if a patent -license would not permit royalty-free redistribution of the Library by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Library. - -If any portion of this section is held invalid or unenforceable under any -particular circumstance, the balance of the section is intended to apply, -and the section as a whole is intended to apply in other circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 12. If the distribution and/or use of the Library is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Library under this License may add -an explicit geographical distribution limitation excluding those countries, -so that distribution is permitted only in or among countries not thus -excluded. In such case, this License incorporates the limitation as if -written in the body of this License. - - 13. The Free Software Foundation may publish revised and/or new -versions of the Library General Public License from time to time. -Such new versions will be similar in spirit to the present version, -but may differ in detail to address new problems or concerns. - -Each version is given a distinguishing version number. If the Library -specifies a version number of this License which applies to it and -"any later version", you have the option of following the terms and -conditions either of that version or of any later version published by -the Free Software Foundation. If the Library does not specify a -license version number, you may choose any version ever published by -the Free Software Foundation. - - 14. If you wish to incorporate parts of the Library into other free -programs whose distribution conditions are incompatible with these, -write to the author to ask for permission. For software which is -copyrighted by the Free Software Foundation, write to the Free -Software Foundation; we sometimes make exceptions for this. Our -decision will be guided by the two goals of preserving the free status -of all derivatives of our free software and of promoting the sharing -and reuse of software generally. - - NO WARRANTY - - 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO -WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. -EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR -OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY -KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE -LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME -THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. - - 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN -WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY -AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU -FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR -CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE -LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING -RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A -FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF -SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH -DAMAGES. - - END OF TERMS AND CONDITIONS - - Appendix: How to Apply These Terms to Your New Libraries - - If you develop a new library, and you want it to be of the greatest -possible use to the public, we recommend making it free software that -everyone can redistribute and change. You can do so by permitting -redistribution under these terms (or, alternatively, under the terms of the -ordinary General Public License). - - To apply these terms, attach the following notices to the library. It is -safest to attach them to the start of each source file to most effectively -convey the exclusion of warranty; and each file should have at least the -"copyright" line and a pointer to where the full notice is found. - - - Copyright (C) - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. - -Also add information on how to contact you by electronic and paper mail. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the library, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the - library `Frob' (a library for tweaking knobs) written by James Random Hacker. - - , 1 April 1990 - Ty Coon, President of Vice - -That's all there is to it! diff --git a/notes/drscheme/HISTORY b/notes/drscheme/HISTORY deleted file mode 100644 index da3871d0..00000000 --- a/notes/drscheme/HISTORY +++ /dev/null @@ -1,690 +0,0 @@ -Version 102: - -102 - - PRS: - - FUNCTIONALITY CHANGES - - - the help desk language level specific documentation has been - integrated into drscheme. - - MINOR CHANGES AND BUG FIXES - - - added parents for these dialogs: - - Keybindings - Choose Language... - Add Teachpack... - Create Launcher -> "you must save before creating a launcher" message box - "The thread has been killed" message box - "Uncaught Error" - Break, Break -> "do you want to kill it?" message box - Click unbound id in DrScheme -> "nothing found for " message box - - - Only the platform-specific dialogs are used in drscheme now, on - all platforms. The preference has been removed from the dialog. - -102d10: - - PRS: - - 1461: Kill menu problems - 1460: Help Desk has empty preferences - 1459: search menu items work on empty search text - 1456: teachpacks don't add - 1455: project windows never leave `Windows' menu - 1428: setup -c deletes files for all platforms - 1424: long (list ...) displays don't display correctly - 1405: memory usage box should be read only - 1398: Downloading doc files requires restart - 1377: replacing by empty string loops - 1330: killing repl, then check-syntax hangs - 1144: match docs not setup right in Help Desk - 737: mred:preferences library too global - 599: mac: can't double click to open files while mred starts up - 406: bad error message for sixlib op - - FUNCTIONALITY CHANGES - - - the framework now imports a definition of the preferences - file location. Use this to have a separate preferences file - for each different application. - - - do not use 'drscheme:settings anymore to get the current - language settings from drscheme. Now, use - - drscheme:language:settings-preferences-symbol - - (which is bound to the right symbol) instead. - - - setup plt's ``clean'' info.ss flag does not recur - into subdirectories anymore. - - MINOR CHANGES AND BUG FIXES - - - Added Replace and Find again to edit menu - - - changed `h' shortcut to find and replace again. show keybindings - has no shortcut anymore. - - * Moved the filename and (define ...) popups to the left, swapping with - the Save button. (The popups in the middle of space look strange.) - - * Merged the Project menu with the File menu. - - * Changed the "Configure Language" menu item in the project window to - "Choose Language", to match the menu item in the file window. - - * Add "..." to "Open Project" menu item. - - * Got rid of "Insert Lambda". It's not nearly useful enough to be - worth all the bugs it creates. (Try inserting a lambda by itself and - hit return --- nothing happens. Try () --- bad selection for - the error message.) - - * Give windows for untitled files/projects unique names: "Untitled 1", - "Untitled 2", etc. - - * Fix multiple adjacent separators in the project window's File and - Edit menus. - - * Dropped the old "platform independent" file dialogs, and use - get-file-list for projects. - - * Disabled "Keybindings" menu item when not applicable. - -102d9: - - NEW DIRECTORY: plt/collects/defaults - - be sure to get the new directory with: - - cvs update -d plt/collects/defaults - - or DrScheme will fail to start up. - - WARNINGS: - - this release breaks the stepper. - - the "create launcher" menu item is - not yet fully functional, so use at your - own risk. - - PRS: 1424, 1437 - - FUNCTIONALITY CHANGES - - - drscheme-jr now supports teachpacks - (those that don't use GUIs, like htdp/dir.ss) - - - the graphics library (sometimes known as sixlib) no longer - accepts any scaling arguments. - - - drscheme:rep:process-text/zodiac and - drscheme:rep:process-text/no-zodiac - are now called drscheme:load-handler:process-text/zodiac and - drscheme:load-handler:process-text/no-zodiac. - - - Windows and unix launchers can now be run from any directory. - They do not need to be saved in a particular place (this has been - true for some time, but it is officially true now.). - - - the debug full scheme languages now allow loading of files - that contain graphics. - - - the framework's preferences system now requires you to - set the marshall/unmarshalling functions (if any) before - setting the default preference. - - - drscheme now supports site-specific default preferences. - To use, create a file prefs.ss in the defaults collection - that is a copy of the preferences file that you want to - be the defaults. Then, if the user-specific preferences file - doesn't exist (or the preferences in it are from an old version), - the contents of the prefs.ss file in the defaults collection is - used as the preferences. - - - drscheme now wraps uses with-handlers so that if a tool - signals an error when it is loaded or invoked, it just - puts a window with the error message and continues, instead - of keeping drscheme from starting up. - - - the .plt installer no longer automatically deletes compiled - files when installing a .plt file. - - - setup-plt now uses the 'clean flag in info.ss to determine - the files to be deleted when --clean-ing a collection. It - defaults to the files in the "compiled" sub-collection of a - collection. - - - setup-plt no longer automatically runs --clean when installing - a .plt file. - - MINOR CHANGES AND BUG FIXES - - - the searching dialog now has two-line find and replace editors. - - - #! is treated like a comment when executing the defintions window, - if it is the first two characters in the definitions window. - - - constructing the project manager's "collection projects" menu - was adding something like a 25% overhead to drscheme's startup, - so that menu is gone (I doubt anyone really used it anyway...) - - - rarely used save menu items relegated to sub-menu. - - - wrap text is now a checkable item that is checked when the editor - is wrapped. - - - drscheme-jr now has a doc.txt file that explains its implementation. - The implementation was factored so that DrScheme's new launchers - can re-use drscheme-jr's implementation. So, if you change - drscheme-jr, be aware that you might affecting these launchers. - -102d8 - - PRS: 1358, 1344, 1341, 1329, 1322, 1242 (docs not yet built), 1235 - - FUNCTIONALITY CHANGES - - - added a "keymap" menu to the edit menu (shortcut: k) - that opens a window where you can see all of the key - bindings' names and short cuts, and you can choose one - to invoke. - - - framework: - - added canonicalize-keybinding-string - - added aug-keymap%, aug-keymap<%> - - editor:basic now sets it's keymap to an - aug-keymap<%> during initialization. - - MINOR CHANGES AND BUG FIXES - - - added a "Kill" menu item that kills all computation and reclaims - all resources from the program that drscheme is executing. - This is useful for multi-threaded apps that get out of hand. - - - improved the look of the "(define" (now "(define ...)") and - filename buttons on the left in drscheme's toolbar - - - if ``#!'' appears at the beginning of the first line in the definitions - window, the first line is treated as a comment during execution - (this is only a change for the non-debug language levels -- the - teaching and debug language levels all already did this) - - - meta-control-d, meta-control-u, meta-shift-control-d, meta-shift-control-u - keybindings all restored. - - -102d7 - - - drscheme now has a little button on the bar that lets you hop - around between definitions in the program. It is approximate in - that it doesn't really know every detail about the lexical - structure of scheme, but it should still be quite useful. - -102d6 - - PRS: 1341 - - FUN INFO - - - DrScheme's rep class now exports a method with this type: - - ((((-> void) -> void) -> void) -> void) - 4 3 2 1 - - believe it or not. It is used to evaluate user expressions in the - repl. Arrow 1 sets up the repl (watch cursor and stuff) and then - calls arrow 2, which should loop, once for each expression (say in - the definitions window), calling arrow 3. Arrow 2 then calls arrow 3 - with arrow 4. Arrow 3 does a little before/after setup to get - breaking right and calls arrow 4 to actually evaluate each - expression. - - FUNCTIONALITY CHANGES - - - the framework's info frame mixins no longer require frame:editor<%> - as an input. Also, they are moved lower in the hierarchy of the - instantiated mixin classes in the framework. This affects all of the - frame:XX% classes. - - - project manager windows now have a repl. - The repl shows the values returned by loading each of the files - in the project. - - tools: - - - ensure-interactions-shown is now ensure-rep-shown - - do-many-buffer-evals is now do-many-text-evals - - teachpacks: - - - interactions window now shows the names of the teachpacks that - were installed at last execute. - - teachpack names are not in the area with the execute button, instead - they are now shown in the language menu. - - it is now an error to add the same teachpack twice. - - - GRAPHICAL_DEBUG is no longer supported. It was always wierd, becuase - it changed the semantics of require-library in a way that was - mostly the same, and keeping drscheme in the consistent - intersection of the two semantics was getting painful (not to - mention confusing...) - - MINOR CHANGES AND BUG FIXES - - - repl errors that are in some loaded file have little clickable - icons that open the file and show the error's source location in - the file. Icon suggestions welcome. To test them out, just replace - file.gif in the icons collection. - - - common file dialog keyboard navigation improved (typing letters now - may go backwards now -- before it only went fowards) - - - common file dialogs are now resizable. - - - common file dialogs now sort in case insensitive mode always - (typing letters doesn't make much sense otherwise) - - - lucky search now sets the focus to the html viewing canvas instead - of leaving the focus on the search text-field. - -102d5 - - PRS: 1334 - - FUNCTIONALITY CHANGES - - - THE FILE FORMAT FOR PROJECT FILES HAS CHANGED - - to update your old project files to the new format, use emacs or - something to insert a ' at the front of the file. Then open and - save the project in drscheme. - - - project files are now `load'able. That is, if you have the right - language settings, you can do - - mzscheme -qmvr myproj.proj - - and have the same effect as clicking execute on the project - window. For mred, you will need to do something like this: - - mred -qmvr myproj.proj -e "(yield (make-semaphore 0))" - - so that mred doesn't quit automatically. - - MINOR CHANGES AND BUG FIXES - - - typeset now uses scheme-mode editors for red boxes. - - - Help Desk now has a "feeling lucky" option ala google (menu - shortcut: l). It goes directly to the first item that would have - been found in a regular search. - - - Clicking on an error message link in drscheme now uses the "feeling - lucky" style search in help desk. - -102d4 - - minor bug fixes - -102d3 - - PRS: 1235 - - FUNCTIONALITY CHANGES - - - drscheme now allows multiple teachpacks. - - - added typeset-size to typeset utilities. Used to control the size - of the rendered text. - - - clever-file-format now symetrically changes the file's format to - 'standard. It used to rever the file format to 'text when there - were no more images in it. Now, it also changes back to non-'text - when images (and other non-string-snips) are added back. - - MINOR CHANGES AND BUG FIXES - - - clicking on the name in the topleft of the drscheme frame opens a - little window with the full path. - - - check syntax now shows its syntax errors in a separate window. - (PR 1235) - -102d2 - - PRS: 1297, 1306, 1171 - - FUNCTIONALITY CHANGES - - - the framework's gui-utils:get-snips/chars-from-buffer is now - gui-utils:get-snips/chars-from-text - - - zodiac now supports graphical expressions. If a snip implements - zodiac's expand<%> interface, zodiac calls a method of the snip to - expand it. Docs updated but not built. - - - the teaching languages now come with: - - make-posn, posn-x, posn-y, and posn? - - by default (no library required). - - - added typeset tool. To get, there are two new directories: - - plt/collects/typeset - plt/collects/drscheme/tools/typeset - - be sure to check those out. Search for Typeset in help desk for - more info. - - - teaching levels print exact numbers whose denominators are evenly - disivible by 2 and 5 as decimals. - - - teaching levels treat input decimals as exact numbers. - - MINOR CHANGES AND BUG FIXES - - - fixed a bug (PR 1297, steck submission) in a call to message-box - from the get-file dialog but was unable to repdoduce the bug. Paul, - can you see if the bug has gone away? Thanks. - - - changed the new version "welcome to drs" window back to something - much like the one in previous versions. - - - drscheme should now print with a fixed-width font. - - - in the main help-desk window, space does pgdn and backspace does - pgup, ala netscape. Also, typing return or enter while the cursor - is on a link follows the link. - -102d1 - - PRS: 1274, 1280, 1264, 1260, 1239, 1225, 1220, 1268, 1209, 1208, - 1196, 1180, 1096, 1088, 1043, 771, 752, 846 - - FUNCTIONALITY CHANGES - - - New project manager. The manual is not yet available, so - you will have to play with the Project menu yourself. I hope that - things are self-explanatory. There is no REPL support. Any repl - support that comes will be part of the debugger. - - *** WARNING: NEW DIRECTORY *** - - To get it, run these simple commands: - - % cd PLTHOME/collects/drscheme - % cvs update -r exp -d - - - added class/d macro. It's syntax is like that for a unit, but it - defines a class. Roughly: - - (class/d - super-expresion - init-args - ((public var ...) - (override var ...) - (inherit var ...) - (rename (var var) ...)) - - definitions-and-expressions ...) - - - the drscheme:get/extend:extend-* functions no longer haver %s at - the end of their names. - - MINOR CHANGES AND BUG FIXES - - - bug report form cleaned up. - - - improved the welcome window (merged with about box) - - -Version 101: - -General -------- - - - The teaching libraries are now called teachpacks. See the teachpack - release notes for more information. - - - DrScheme's languages have changed (again). The langauges are now: - - - Beginning Student - - Intermediate Student - - Advanced Student - - Full Scheme, which contains: - - Graphical Full Scheme (with and without debugging), and - - Textual Full Scheme (with and without debugging) - - - Help Desk now supports bug report submissions. Please use it in - favor of the web based form. To submit a bug, follow the "Sumbit a - Bug" link near the bottom of Help Desk's front page - - - On European keyboards, the backslash character - may not work properly in DrScheme. If you - experience this problem, comment out this line: - - (map-meta "\\" "remove-space") - - in PLTHOME/collects/framework/keymap.ss. - - - For tools, invoke-library is now called invoke-teachpack. - - - Renamed two files in the graphics collection: - graphic.ss is now graphics.ss - graphics.ss is now graphicss.ss - - - DrScheme's print menu now inserts the time, date and filename in the - header of the file to be printed. - - - comment/uncomment is improved. Now, it blindly adds a semicolon to the - front of each line (and doesn't add extra semicolons on following lines) - and aways removes one semicolon (if present) from the front of each line. - - - Parenthesis highlighting now turns unmatched parens red - in addition to turning matched parenthesis regions grey. - Also (now that the caret flashes) if the caret is between two - parens, both before and after parens will be highlighted, - not just the ones before. - - Thus, every time the cursor is next to an uncommented - paren, the programmer sees some feedback about the paren. - -Version 100: - -General -------- - - - DrScheme's languages have changed. The new languages are: - - - Beginner - - Intermediate - - Advanced - - MzScheme - - MrEd - - The first three languages are essentially the same as in version - 53, except that graphics primitives have been removed. (Instead, - domain-specific graphics commands can be loaded as libraries.) The - turtles remain in the advanced language. - - The MzScheme and MrEd languages match exactly the languages - provided by the MzScheme and MrEd executables. - - - A simple algebraic stepper, dubbed The Foot, is now available. The - Foot permits users to construct a source-level evaluation trace for - programs written in the Beginner language. It will be expanded in - future releases. - - - DrScheme's Help Desk provides online help for DrScheme, its - languages, and its libraries. - - - Graphics functions were removed from the teaching languages - (Beginner, Intermediate, and Advanced), except Turtles in - Advanced. To use graphics functions, you must select a library (and - the teaching libraries are not yet updated). - - - The old viewport-based graphics library can be loaded into the MrEd - Debug language via (require-library "graphic.ss" "graphics"). - - - I/O within DrScheme is substantially improved. - - - The library and tool interfaces for extended DrScheme have - changed. - - -Version 53: - -General -------- - - - view menu items now have accelerators - - - (<= exp) isn't allowed in beginner. (same for <, >, and >=) - - - print primitive is now setup correctly to print based on the language level - - - paren-matching in semi-colon comments is disabled - - - info panel "running" message is now aligned correctly - - - The check synatax and analyze buttons are now disabled during evaluation - - - library directory now starts in "MZLIB_COLLECTS_DIR/../../lib" - which is our best approximation to "PLTHOME/lib" - - - elevator library can now select more than one floor at a time - - -Version 52: - -General -------- - -- The words "running" or "not running" at the bottom of the - DrScheme frame indicate whether or not work is happening in the - user's program. - -- a "Windows" menu has been added which keeps track of the currently - open drscheme windows. - -- the source locations for "load"ed files now match the numbers - in the bottom of the drscheme window. - -- the thread that evaluations (including execution) take place on is - the same as the eventspace's main thread, unless the evaluation - thread is killed. In that case, the eventspace's main thread is - re-generated, but the execution thread does not. - -- The REPL implementation has been cleaned up. - -- the turtles window does not survive across executions anymore - -- the Quasi-R4RS language level has been renamed to R4RS+ - -DrScheme Tools/Libraries ------------------------- - -- new methods on rep:edit%: report-exception-error accepts an exception and - prints the error message in the console. - -- send-scheme is outdated. Use run-in-evaluation-thread instead - -- the drscheme:tool^ signature has changed. A new subunit, "basis" has - been aded and the process-finish struct is now in that subunit. So, - drscheme:language:process-finish? becomes - drscheme:basis:process-finish?, etc. - - The process-finish structure no longer has a boolean indicating sucess. - Instead, an exception is raised. - - -- the settings for the language have been re-aranged - - there are two new parameters, exported from the basis - subunit of drscheme:export^, current-setting and current-vocabulary - - current-vocabulary contains the vocabulary that zodiac uses to - perform macro expansion - - current-setting is bound to a setting struct, which encapsulates - all of the information about the language level - - the process-*/zodiac and process-*/no-zodiac proceudres - are no longer methods and their arguments have changed - - -Version 51: - -General -------- -- fixed error message for "eq?" and "cons" at beginner level. - -- check syntax does not work with an unitialized repl when: - the source contains define-macro. (won't be fixed in the release) - -- eval no longer loops forever in mred vocabulary - -- searching keybindings have changed. There are four distinct actions: - action1: move keyboard focus to the searching window, opening it if necessary, - or if already there search forward - action2: move keyboard focus to the searching window, opening it if necessary, - or if already there search backward. - action3: search again, in the same direction - action4: move the focus between the main window, searching window and replacment window - action5: hide the searching window - -The actions are mapped to different keys, based on the platform. - -On unix: - action1 => control-s, meta-% - action2 => control-r - action3 => f3 - action4 => control-i - action5 => control-g - -On the macintosh: - action1 => command-f - action2 => command-r - action3 => command-g - action4 => command-o - action5 => command-. - -On windows: - action1 => control-f - action2 => control-r - action3 => f3, control-g - action4 => control-i - action5 => escape - -- turned off the file name printouts on splash screen - - evaluate: - (wx:write-resource "mred" "splashMessages" 1 (wx:find-path 'setup-file)) - to turn them back on. - -- fixed a bug that caused error messages to be displayed in message - boxes more often than neccessary. (as opposed to printing in the - repl) - -- parenthesis matching is improved - -- The empty list is now called "empty" instead of "null" with the - constructor style printer. - -- The analyze button puts up a dialog saying "please wait, loading", - now. - -- the fonts dialog now shows previews of the selected fonts. You - still need to restart to see the changes, unfortunately. - -DrScheme Tools/Libraries ------------------------- - -- tools must now import wx names explicitly, as a new first import. - -- the parameters interface has changed. Instead getting and setting - the class, the tool programmer must register a function that - accepts a class and returns a class. See the manual for more - details. - -- process/zodiac-finish has been renamed to process-finish diff --git a/notes/drscheme/OPENBUGS b/notes/drscheme/OPENBUGS deleted file mode 100644 index d81a5022..00000000 --- a/notes/drscheme/OPENBUGS +++ /dev/null @@ -1,19 +0,0 @@ -Check Syntax alpha-renaming does not work with `define-struct'. - -The alpha-renaming feature of Check Syntax may miss some - identifiers. Check which identifiers will be renamed by moving the - mouse cursor over the *binding* occurrance of the variable you want - to rename. The arrows point to all known bound occurrances, which - are the identifiers that are renamed by alpha renaming. - -After breaking a long interaction several times, one of the breaks - may carry over to the next interaction. - -The yellow execute warning in the interactions window does not go away - if the user undoes all changes to the defintions window. - -Backup files don't preserve file permissions. - -For a more complete listing of known bugs, see our - -online bug report database \ No newline at end of file diff --git a/notes/mred/FONTS b/notes/mred/FONTS deleted file mode 100644 index e89503d8..00000000 --- a/notes/mred/FONTS +++ /dev/null @@ -1,410 +0,0 @@ - -This file describes how to set up mappings for PostScript fonts and -complex X fonts for MrEd within a configuration file. However, you -will probably find that it's much easier to use the set-screen-name, -set-post-script-name, and set-afm-name methods provided by -the-font-name-directory. - ---------------------------------------------------- - 1. Welcome to the Weird World of MrEd Fonts ---------------------------------------------------- - -MrEd's font system is designed to appear to work gracefully across -platforms to a naive MrEd user. It is also designed to provide -complete configuration control to a knowledgeable user (this may be -especially necessary under X Windows). These are somewhat -contradictory goals, and they leave MrEd with a somewhat complex font -system. - -We'll develop terminology here to explain the working of the font -system, but don't expect these terms to be used by the MrEd -toolbox. The toolbox is designed to do what a programmer or user -probably wanted using names that a programmer or user would probably -understand intuitively. - -A "real font" is a device-speicific font used to draw or measure text -for a screen or a printer. MrEd handles three kinds of real fonts: - - * Screen fonts - * PostScript font names - * AFM font files - -An "abstract font" is a platform- and device-independent entity that -describes a font. MrEd uses 7 abstract fonts: - - * "Default" - * "Decorative" - * "Roman" - * "Script" - * "Swiss" - * "Modern" - * "System" - -The "System" abstract font is intended only for use with screen-based -controls. - -There are two basic problems: - - * Mapping abstract fonts to real fonts - * Specifying a real font without a corresponding abstract font - -The solution in the latter case is simply to let the user or -programmer invent new abstract fonts. However, the new abstract font -is associated with a core abstract font so that a suitable default -real font can be selected when no information about the new abstract -font is available. - -Abstract fonts are mapped to real fonts via the low-level setup -resource file read by MrEd at startup time. (Under X Windows, X -resources can be specified in any way, but specifying X resources -through the startup file is the preferred mechanism.) - -In the case of real fonts for an X Windows screen, it is necssary to -map not only an abstract font to a real font, but an abstract font -combined with a weight, style, and size to a real font --- hence the -insane complexity of MrEd's font system. - ---------------------------- - 1. Resource Entries ---------------------------- - -First, we consider the mechanism that maps abstract fonts to real -fonts in the case that the information is provided via resources. - -To find a font name in the resource, MrEd looks for a resource item -named by: - -