suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into samth/new-logic2

Browse Source
This commit is contained in:
Sam Tobin-Hochstadt 2010-04-19 16:14:11 -04:00
commit fca1044972
466 changed files with 33458 additions and 11525 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.gitignore vendored Normal file
View File

@ -0,0 +1,11 @@
# these directories are generated by the build
/bin/
/include/
/lib/
# Windows and OSX executables
/*.app
/*.exe
# a common convenient place to set the PLTADDON directory to
/add-on/

2
collects/.gitignore vendored Normal file
View File

@ -0,0 +1,2 @@
compiled/
/info-domain/

203
collects/2htdp/batch-io.ss
View File

@ -1,21 +1,93 @@
#lang scheme/base
#lang scheme
(require htdp/error)
(require (for-syntax syntax/parse) srfi/13 htdp/error "private/csv/csv.ss")
(define (read-file f)
(check-arg 'read-file (string? f) "string" "first" f)
(check-arg 'read-file (file-exists? f) "name of file in program's folder" "first" f)
(list->string
(with-input-from-file f
(lambda ()
(let loop ([accu '()])
(define nxt (read-char))
(if (eof-object? nxt)
(reverse (if (char=? (car accu) #\newline) (cdr accu) accu))
(loop (cons nxt accu))))))))
;; todo?
;; -- export tokenization?
;; -----------------------------------------------------------------------------
(provide
;; all reader functions consume the name of a file f:
;; -- f must be a file name (string) in the same folder as the program
read-file ;; String -> String
;; read the specified file as a string
read-as-1strings ;; String -> [Listof 1String]
;; read the specified file as a list of 1strings (characters)
read-as-lines ;; String -> [Listof String]
;; read the specified file as a list of strings, one per line
read-as-words ;; String -> [Listof String]
;; read the specified file as a list of white-space separated tokens
read-as-words/line ;; String -> [Listof [Listof String]]
;; read the specified file as a list of lines, each line as a list of words
read-as-csv ;; String -> [Listof [Listof (U Any)]]
;; -- f must be formated as a a file with comma-separated values (Any)
;; read the specified file as a list of lists---one per line---of values (Any)
read-as-csv/rows ;; String ([Listof Any] -> X) -> [Listof X]
;; -- f must be formated as a a file with comma-separated values (Any)
;; read the specified file as a file of comma-separated values, apply the second
;; argument to each row, i.e., list of CSV on one line
write-file ;; String String -> Boolean
;; write the second argument to specified file in the same folder as the program
;; produce false, if f exists
;; produce true, if f doesn't exist
)
;; -----------------------------------------------------------------------------
(define-syntax-rule
(def-reader (name f s ...) body ...)
(define (name f s ...)
(check-file f 'name)
(let ()
body ...)))
;; --- exported functions --
(def-reader (read-file f)
(list->string (read-chunks f read-char drop-last-newline)))
(def-reader (read-as-1strings f)
(map string (read-chunks f read-char drop-last-newline)))
(def-reader (read-as-lines f)
(read-chunks f read-line reverse))
(def-reader (read-as-words f)
(read-as-words/line/internal f append))
(def-reader (read-as-words/line f)
;; String -> [Listof [Listof String]]
;; read the specified file as a list of lines, each line as a list of words
(read-as-words/line/internal f cons))
(define (read-as-words/line/internal f combine)
(define lines (read-chunks f read-line (lambda (x) x)))
(foldl (lambda (f r)
(define fst (filter (compose not (curry string=? "")) (split f)))
(if (empty? fst) r (combine fst r)))
'() lines))
(def-reader (read-as-csv f)
(read-as-csv/func f))
(def-reader (read-as-csv/rows f row)
(check-proc 'read-as-cvs row 1 "one argument" "row")
(read-as-csv/func f row))
;; -----------------------------------------------------------------------------
;; writer
(define (write-file f str)
(check-arg 'read-file (string? f) "string" "first" f)
(check-arg 'write-file (string? f) "string (name of file)" "first" f)
(check-arg 'write-file (string? str) "string" "second" str)
(let ([result (not (file-exists? f))])
(with-output-to-file f
(lambda () (printf "~a" str))
@ -23,80 +95,41 @@
result))
;; -----------------------------------------------------------------------------
;; auxiliaries
(provide
read-file ;; String -> String
;; read the file f (in current-directory) as a string
write-file ;; String String -> Boolean
;; write str to file f (in current-directory);
;; false, if f exists
;; true, if f doesn't exist
)
;; String [([Listof X] -> Y)] -> [Listof Y]
(define (read-as-csv/func f [row (lambda (x) x)])
(local ((define (reader o)
(make-csv-reader o '((strip-leading-whitespace? . #t)
(strip-trailing-whitespace? . #t)))))
(map row (call-with-input-file f (compose csv->list reader)))))
;; String (-> X) ([Listof X] -> [Listof X]) -> [Listof X]
;; read a file as a list of X where process-accu is applied to accu when eof
(define (read-chunks f read-chunk process-accu)
(with-input-from-file f
(lambda ()
(let loop ([accu '()])
(define nxt (read-chunk))
(if (eof-object? nxt) (process-accu accu) (loop (cons nxt accu)))))))
;
;
;
; ;
; ;
; ;;;; ; ; ;; ; ;; ; ;;; ;;;; ;;;;; ;;; ;;; ; ;; ;;;;
; ; ; ; ; ;; ; ;; ; ; ; ; ; ; ; ;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ; ; ; ; ; ; ;;;;; ;;; ; ; ; ; ; ; ;;;
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ;; ; ;; ; ;; ; ; ; ; ; ; ; ; ;
; ;;;; ;; ; ;; ; ;; ; ;;;; ;;;; ;;; ; ;;; ; ; ;;;;
; ; ;
; ;;; ;;;
;
;; [Listof Char] -> [Listof Char]
(define (drop-last-newline accu)
(reverse (if (char=? (car accu) #\newline) (cdr accu) accu)))
#|
;; String[file name] Symbol -> Void
;; effect: ensure that f is a file in current directory or report error for t
(define (check-file f t)
(check-arg t (string? f) "string" "first" f)
(check-arg t (file-exists? f) "name of file in program's folder" "first" f))
For basic i/o, I find the following two functions extremely helpful to provide as a teachpack along with what batch-io gives. Perhaps it would be possible to include them in the standard teachpack?
;; split : String [Regexp] -> [Listof String]
;; splits a string into a list of substrings using the given delimiter
;; (white space by default)
(define (split str [ptn #rx"[ ]+"])
(regexp-split ptn (string-trim-both str)))
;; split : String String -> Listof[String]
;; splits a string into a list of substrings using the given delimiter (space
;; by default)
(define (split str [ptn "[ ]+"])
(unless (string? str)
(error 'split "expects string as first argument"))
(unless (string? ptn)
(error 'split "expects string as second argument"))
(regexp-split ptn (string-trim-both str)))
;; split : String -> Listof[String]
;; splits a string into a list of lines
(define (split-lines str)
(map string-trim-both (split str "\r*\n")))
These are some other functions that I've also found helpful... the first two because sometimes it's handy to be able to use the GUI dialog box to figure out the complete pathname of a file; the third to be able to load images from a program:
(define (pick-a-file)
(path->string (get-file)))
(define (pick-a-save-file)
(path->string (put-file)))
(define (read-image-file file-name)
(make-object image-snip% file-name))
I realize that it might not be good to provide too much i/o stuff from the HtDP perspective, because it could start to distract from the more important issues that are to be taught/learned.
;; ---
Why don't you incorporate this into the Teachpack?
#lang scheme
(require (planet neil/csv:1:2/csv))
(require lang/prim)
(provide-higher-order-primitive read-csv-file (_ convert-each-line))
(define (read-csv-file filename mapper)
(with-input-from-file filename
(lambda ()
(csv-map mapper (current-input-port)))))
|#
;; split-lines : String -> Listof[String]
;; splits a string with newlines into a list of lines
(define (split-lines str)
(map string-trim-both (split str "\r*\n")))

26
collects/2htdp/image.ss
View File

@ -46,12 +46,14 @@ and they all have good sample contracts. (It is amazing what we can do with kids
|#
(require "../mrlib/image-core.ss"
(require (except-in "../mrlib/image-core.ss" make-color make-pen)
"private/image-more.ss"
"private/img-err.ss"
(only-in lang/prim provide-primitive provide-primitives define-primitive)
htdp/error)
(provide overlay
(provide-primitives
overlay
overlay/align
overlay/xy
underlay
@ -93,7 +95,6 @@ and they all have good sample contracts. (It is amazing what we can do with kids
scene+curve
text
text/font
bitmap
x-place?
y-place?
@ -105,12 +106,23 @@ and they all have good sample contracts. (It is amazing what we can do with kids
pen-style?
pen-cap?
pen-join?
(rename-out [build-color make-color])
color-red color-blue color-green color? color
(rename-out [build-pen make-pen])
pen-color pen-width pen-style pen-cap pen-join pen
image-width
image-height
image-baseline)
image-baseline
make-color
make-pen
)
(provide bitmap)
(define-primitive make-color build-color)
(define-primitive make-pen build-pen)
#;
(provide (rename-out [build-color make-color])
(rename-out [build-pen make-pen]))

963
collects/2htdp/private/csv/csv.ss Normal file
View File

@ -0,0 +1,963 @@
;;; @Package csv
;;; @Subtitle Comma-Separated Value (CSV) Utilities in Scheme
;;; @HomePage http://www.neilvandyke.org/csv-scheme/
;;; @Author Neil Van Dyke
;;; @Version 0.10
;;; @Date 2010-04-13
;;; @PLaneT neil/csv:1:6
;; $Id: csv.ss,v 1.199 2010/04/13 17:56:20 neilpair Exp $
;;; @legal
;;; Copyright @copyright{} 2004--2009 Neil Van Dyke. This program is Free
;;; Software; you can redistribute it and/or modify it under the terms of the
;;; GNU Lesser General Public License as published by the Free Software
;;; Foundation; either version 3 of the License (LGPL 3), or (at your option)
;;; any later version. This program 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
;;; @indicateurl{http://www.gnu.org/licenses/} for details. For other licenses
;;; and consulting, please contact the author.
;;; @end legal
#lang scheme/base
;;; @section Introduction
;;; The @b{csv} Scheme library provides utilities for reading various kinds of
;;; what are commonly known as ``comma-separated value'' (CSV) files. Since
;;; there is no standard CSV format, this library permits CSV readers to be
;;; constructed from a specification of the peculiarities of a given variant.
;;; A default reader handles the majority of formats.
;;;
;;; One of the main uses of this library is to import data from old crusty
;;; legacy applications into Scheme for data conversion and other processing.
;;; To that end, this library includes various conveniences for iterating over
;;; parsed CSV rows, and for converting CSV input to the
;;; @uref{http://pobox.com/~oleg/ftp/Scheme/SXML.html, SXML 3.0} Scheme XML
;;; format.
;;;
;;; This library requires R5RS, SRFI-6, SRFI-23, and an @code{integer->char}
;;; procedure that accepts ASCII values.
;;;
;;; Other implementations of some kind of CSV reading for Scheme include
;;; Gauche's @code{text.csv} module, and Scsh's @code{record-reader} and
;;; related procedures. This library intends to be portable and more
;;; comprehensive.
;; TODO: Briefly introduce terms "row", "column", and "field".
(define-syntax %csv:error
(syntax-rules () ((_ p m o)
(error (string-append p " : " m) o)
;; Bigloo: (error p m o)
)))
(define-syntax %csv:type-error
(syntax-rules ()
((_ proc-str expected-str got-value)
(%csv:error proc-str
(string-append "expected " expected-str ", received:")
got-value))))
(define %csv:a2c integer->char)
(define %csv:cr (%csv:a2c 13))
(define %csv:lf (%csv:a2c 10))
(define-syntax %csv:gosc
(syntax-rules ()
((_ os-stx)
(let* ((os os-stx)
(str (get-output-string os)))
(close-output-port os)
str))))
(define (%csv:in-arg proc-name in)
(cond ((input-port? in) in)
((string? in) (open-input-string in))
(else (%csv:type-error proc-name "input port or string" in))))
(define (%csv:reader-or-in-arg proc-name reader-or-in)
(cond ((procedure? reader-or-in) reader-or-in)
((input-port? reader-or-in) (make-csv-reader reader-or-in))
((string? reader-or-in) (make-csv-reader (open-input-string
reader-or-in)))
(else (%csv:type-error proc-name
"csv reader or input port or string"
reader-or-in))))
;;; @section Reader Specs
;;; CSV readers are constructed using @dfn{reader specs}, which are sets of
;;; attribute-value pairs, represented in Scheme as association lists keyed on
;;; symbols. Each attribute has a default value if not specified otherwise.
;;; The attributes are:
;;; @table @code
;;;
;;; @item newline-type
;;; Symbol representing the newline, or record-terminator, convention. The
;;; convention can be a fixed character sequence (@code{lf}, @code{crlf}, or
;;; @code{cr}, corresponding to combinations of line-feed and carriage-return),
;;; any string of one or more line-feed and carriage-return characters
;;; (@code{lax}), or adaptive (@code{adapt}). @code{adapt} attempts to detect
;;; the newline convention at the start of the input and assume that convention
;;; for the remainder of the input. Default: @code{lax}
;;;
;;; @item separator-chars
;;; Non-null list of characters that serve as field separators. Normally, this
;;; will be a list of one character. Default: @code{(#\,)} (list of the comma
;;; character)
;;;
;;; @item quote-char
;;; Character that should be treated as the quoted field delimiter character,
;;; or @code{#f} if fields cannot be quoted. Note that there can be only one
;;; quote character. Default: @code{#\"} (double-quote)
;;;
;;; @item quote-doubling-escapes?
;;; Boolean for whether or not a sequence of two @code{quote-char} quote
;;; characters within a quoted field constitute an escape sequence for
;;; including a single @code{quote-char} within the string. Default: @code{#t}
;;;
;;; @item comment-chars
;;; List of characters, possibly null, which comment out the entire line of
;;; input when they appear as the first character in a line. Default:
;;; @code{()} (null list)
;;;
;;; @item whitespace-chars
;;; List of characters, possibly null, that are considered @dfn{whitespace}
;;; constituents for purposes of the @code{strip-leading-whitespace?} and
;;; @code{strip-trailing-whitespace?} attributes described below.
;;; Default: @code{(#\space)} (list of the space character)
;;;
;;; @item strip-leading-whitespace?
;;; Boolean for whether or not leading whitespace in fields should be
;;; stripped. Note that whitespace within a quoted field is never stripped.
;;; Default: @code{#f}
;;;
;;; @item strip-trailing-whitespace?
;;; Boolean for whether or not trailing whitespace in fields should be
;;; stripped. Note that whitespace within a quoted field is never stripped.
;;; Default: @code{#f}
;;;
;;; @item newlines-in-quotes?
;;; Boolean for whether or not newline sequences are permitted within quoted
;;; fields. If true, then the newline characters are included as part of the
;;; field value; if false, then the newline sequence is treated as a premature
;;; record termination. Default: @code{#t}
;;;
;;; @end table
;; TODO: Do not expose this procedure for now. We expect it to go away and be
;; replaced with two other procedures.
;;
;; @defproc %csv:csv-spec-derive orig-spec changes
;;
;; Yields a new CSV spec that is derived from @var{orig-spec} by applying spec
;; @var{changes} as attribute substitions and additions to the original. For
;; example, given an original CSV reader spec:
;;
;; @lisp
;; (define my-first-csv-spec
;; '((newline-type . lax)
;; (separator-chars . (#\,))
;; (quote-char . #\")
;; (quote-doubling-escapes? . #t)
;; (whitespace-chars . (#\space))))
;; @end lisp
;;
;; a derived spec with a different @code{separator-chars} attribute and an
;; added @code{comment-chars} attribute can be created like:
;;
;; @lisp
;; (%csv:csv-spec-derive my-first-csv-spec
;; '((separator-chars . (#\%))
;; (comment-chars . (#\#))))
;; @result{}
;; ((separator-chars . (#\%))
;; (comment-chars . (#\#))
;; (newline-type . lax)
;; (quote-char . #\")
;; (quote-doubling-escapes? . #t)
;; (whitespace-chars . (#\space)))
;; @end lisp
;;
;; In that the yielded spec might share some structure with @var{orig-spec}
;; and/or @var{changes}. Most applications will not use this procedure
;; directly.
(define (%csv:csv-spec-derive orig-spec changes)
;; TODO: Make this not share structure. Error-check and normalize at the
;; same time we clone.
(let ((new-spec '()))
(let ((add-to-new-spec
(lambda (alist)
(for-each (lambda (cell)
(or (assq (car cell) new-spec)
(set! new-spec (cons cell new-spec))))
alist))))
(add-to-new-spec changes)
(add-to-new-spec orig-spec)
(reverse new-spec))))
;;; @section Making Reader Makers
;;; CSV readers are procedures that are constructed dynamically to close over a
;;; particular CSV input and yield a parsed row value each time the procedure
;;; is applied. For efficiency reasons, the reader procedures are themselves
;;; constructed by another procedure, @code{make-csv-reader-maker}, for
;;; particular CSV reader specs.
(define (%csv:csv-error code extra)
;; TODO: Maybe make the CSV error handler user-specifiable, or allow user to
;; specify some errors that should be disregarded.
;;
;; TODO: Add position information. Keep track of character position while
;; reading.
(%csv:error
"[csv-reader]"
(string-append "Erroneous CSV format: "
(case code
((junk-after-quote-close)
"Junk after close of quoted field:")
(else (string-append "INTERNAL ERROR: Unknown code: "
(symbol->string code)))))
extra))
(define (%csv:newline-check-step0 newline-type c port)
;; (display "*DEBUG* (equal? newline-type 'lax) = ")
;; (write (equal? newline-type 'lax))
;; (newline)
;; (display "*DEBUG* (eqv? newline-type 'lax) = ")
;; (write (eqv? newline-type 'lax))
;; (newline)
(case newline-type
((cr) (eqv? c %csv:cr))
((lf) (eqv? c %csv:lf))
((crlf) (if (eqv? c %csv:cr)
(let ((c2 (peek-char port)))
(cond ((eof-object? c2)
;; Note: This is a CR-EOF in an input that uses CR-LF
;; for terminating records. We are discarding the CR,
;; so it will not be added to the field string. We
;; might want to signal an error.
#t)
((eqv? c2 %csv:lf)
(read-char port)
#t)
(else #f)))
#f))
((lax detect) (cond ((eqv? c %csv:cr)
(let ((c2 (peek-char port)))
(cond ((eof-object? c2) #t)
((eqv? c2 %csv:lf)
(read-char port)
'crlf)
(else 'cr))))
((eqv? c %csv:lf) 'lf)
(else #f)))
(else (%csv:error
"%csv:make-portreader/positional"
"unrecognized newline-type"
newline-type))))
(define %csv:make-portreader/positional
(letrec-syntax
((newline-check
(syntax-rules ()
((_ newline-type c port detected-newline-type)
;; Note: "port" and "detected-newline-type" must be identifiers.
;; "newline-type" and "c" must be identifiers or self-evals.
(if (eqv? newline-type 'detect)
(begin (set! detected-newline-type
(%csv:newline-check-step0 newline-type c port))
detected-newline-type)
(%csv:newline-check-step0 newline-type c port)))))
(gosc-cons
;; Note: This is to ensure the output string is gotten and closed
;; before consing it with the result of a recursive call.
(syntax-rules ()
((_ os b) (let ((s (%csv:gosc os))) (cons s b))))))
(lambda (newline-type
separator-chars
quote-char
quote-doubling-escapes?
comment-chars
whitespace-chars
strip-leading-whitespace?
strip-trailing-whitespace?
newlines-in-quotes?)
(lambda (port)
(let ((dnlt #f))
(let read-fields-or-eof ((c (read-char port)))
(cond
((eof-object? c) '())
((and strip-leading-whitespace? (memv c whitespace-chars))
;; It's leading whitespace char when we're ignoring leading
;; whitespace in fields, and there might just be whitespace and
;; then an EOF, which should probably be considered just an EOF
;; rather than a row with one empty field, so just skip this
;; whitespace char.
(read-fields-or-eof (read-char port)))
((and (not (null? comment-chars)) (memv c comment-chars))
;; It's a comment char in the first column (or in the first
;; non-whitespace column, if "strip-leading-whitespace?" is
;; true), so skip to end of line.
(let ((fake-dnlt #f))
(let loop ((c (read-char port)))
(cond ((eof-object? c) '())
((newline-check newline-type c port fake-dnlt)
(read-fields-or-eof (read-char port)))
(else (loop (read-char port)))))))
(else
;; It's not going to be just an EOF, so try to read a row.
(let ((row
(let read-fields ((c c))
(cond
;; If an EOF or newline in an unquoted field, consider
;; the field and row finished. (We don't consider EOF
;; before newline to be an error, although perhaps that
;; would be a useful check for a freak premature
;; end-of-input when dealing with "well-formed" CSV).
((or (eof-object? c)
(newline-check newline-type c port dnlt))
(list ""))
;; If a field separator, finish this field and cons
;; with value of recursive call to get the next field.
((memv c separator-chars)
(cons "" (read-fields (read-char port))))
;; If we're ignoring leading whitespace, and it's a
;; whitespace-chars character, then recurse to keep
;; finding the field start.
((and strip-leading-whitespace?
(memv c whitespace-chars))
(read-fields (read-char port)))
;; If a quote, read a quoted field.
((and quote-char (eqv? c quote-char))
(let ((os (open-output-string)))
(let loop ((c (read-char port)))
(cond
((or (eof-object? c)
(and (not newlines-in-quotes?)
(newline-check newline-type
c port dnlt)))
(list (%csv:gosc os)))
((and quote-char (eqv? c quote-char))
(if quote-doubling-escapes?
(let ((c2 (read-char port)))
(if (eqv? c2 quote-char)
(begin (write-char c2 os)
(loop (read-char port)))
(gosc-cons
os
(let skip-after ((c c2))
(cond
((or (eof-object? c)
(newline-check
newline-type c port dnlt))
'())
((memv c separator-chars)
(read-fields (read-char port)))
((memv c whitespace-chars)
;; Note: We tolerate
;; whitespace after field
;; close quote even if
;; skip-trailing-whitespace?
;; is false.
(skip-after (read-char port)))
(else (%csv:csv-error
'junk-after-quote-close
c)))))))
(gosc-cons os
(read-fields (read-char port)))))
(else (write-char c os)
(loop (read-char port)))))))
;; It's the start of an unquoted field.
(else
(let ((os (open-output-string)))
(write-char c os)
(let loop ((c (read-char port)))
(cond
((or (eof-object? c)
(newline-check newline-type c port dnlt))
(list (get-output-string os)))
((memv c separator-chars)
(gosc-cons os (read-fields (read-char port))))
((and strip-trailing-whitespace?
(memv c whitespace-chars))
;; TODO: Maybe optimize to avoid creating a new
;; output string every time we see whitespace.
;; We could use a string collector with unwrite.
;; And/or do lookahead to see whether whitespace
;; is only one character. Do this after we have
;; a better regression test suite.
(let ((ws-os (open-output-string)))
(write-char c ws-os)
(let ws-loop ((c (read-char port)))
(cond
((or (eof-object? c)
(newline-check
newline-type c port dnlt))
(close-output-port ws-os)
(list (%csv:gosc os)))
((memv c separator-chars)
(close-output-port ws-os)
(gosc-cons os (read-fields (read-char
port))))
((memv c whitespace-chars)
(write-char c ws-os)
(ws-loop (read-char port)))
(else
(display (%csv:gosc ws-os) os)
(write-char c os)
(loop (read-char port)))))))
(else (write-char c os)
(loop (read-char port)))))))))))
(if (null? row)
row
(if (eq? newline-type 'detect)
(cons dnlt row)
row)))))))))))
(define %csv:make-portreader
;; TODO: Make a macro for the three times we list the spec attributes.
(letrec ((pb (lambda (x) (if x #t #f)))
(pc (lambda (x)
(cond ((char? x) x)
((string? x) (case (string-length x)
((1) (string-ref x 0))
(else (%csv:type-error
"make-csv-reader-maker"
"character"
x))))
(else (%csv:type-error "make-csv-reader-maker"
"character"
x)))))
(pc-f (lambda (x)
(cond ((not x) x)
((char? x) x)
((string? x) (case (string-length x)
((0) #f)
((1) (string-ref x 0))
(else (%csv:type-error
"make-csv-reader-maker"
"character or #f"
x))))
(else (%csv:type-error "make-csv-reader-maker"
"character or #f"
x)))))
(pe (lambda (x acceptable)
(if (memq x acceptable)
x
(%csv:type-error
"make-csv-reader-maker"
(let ((os (open-output-string)))
(display "symbol from the set " os)
(write acceptable os)
(%csv:gosc os))
x))))
(plc-n (lambda (x)
(or (list? x)
(%csv:type-error "make-csv-reader-maker"
"list of characters"
x))
(map pc x)))
(plc (lambda (x)
(let ((result (plc-n x)))
(if (null? result)
(%csv:type-error "make-csv-reader-maker"
"non-null list of characters"
x)
result)))))
(lambda (reader-spec)
(let ((newline-type 'lax)
(separator-chars '(#\,))
(quote-char #\")
(quote-doubling-escapes? #t)
(comment-chars '())
(whitespace-chars '(#\space))
(strip-leading-whitespace? #f)
(strip-trailing-whitespace? #f)
(newlines-in-quotes? #t))
;; TODO: It's erroneous to have two entries for the same attribute in a
;; spec. However, it would be nice if we error-detected duplicate
;; entries, or at least had assq semantics (first, rather than last,
;; wins). Use csv-spec-derive's descendants for that.
(for-each
(lambda (item)
(let ((v (cdr item)))
(case (car item)
((newline-type)
(set! newline-type (pe v '(cr crlf detect lax lf))))
((separator-chars)
(set! separator-chars (plc v)))
((quote-char)
(set! quote-char (pc-f v)))
((quote-doubling-escapes?)
(set! quote-doubling-escapes? (pb v)))
((comment-chars)
(set! comment-chars (plc-n v)))
((whitespace-chars)
(set! whitespace-chars (plc-n v)))
((strip-leading-whitespace?)
(set! strip-leading-whitespace? (pb v)))
((strip-trailing-whitespace?)
(set! strip-trailing-whitespace? (pb v)))
((newlines-in-quotes?)
(set! newlines-in-quotes? (pb v))))))
reader-spec)
(%csv:make-portreader/positional
newline-type
separator-chars
quote-char
quote-doubling-escapes?
comment-chars
whitespace-chars
strip-leading-whitespace?
strip-trailing-whitespace?
newlines-in-quotes?)))))
;;; @defproc make-csv-reader-maker reader-spec
;;;
;;; Constructs a CSV reader constructor procedure from the @var{reader-spec},
;;; with unspecified attributes having their default values.
;;;
;;; For example, given the input file @code{fruits.csv} with the content:
;;;
;;; @example
;;; apples | 2 | 0.42
;;; bananas | 20 | 13.69
;;; @end example
;;;
;;; a reader for the file's apparent format can be constructed like:
;;;
;;; @lisp
;;; (define make-food-csv-reader
;;; (make-csv-reader-maker
;;; '((separator-chars . (#\|))
;;; (strip-leading-whitespace? . #t)
;;; (strip-trailing-whitespace? . #t))))
;;; @end lisp
;;;
;;; The resulting @code{make-food-csv-reader} procedure accepts one argument,
;;; which is either an input port from which to read, or a string from which to
;;; read. Our example input file then can be be read by opening an input port
;;; on a file and using our new procedure to construct a reader on it:
;;;
;;; @lisp
;;; (define next-row
;;; (make-food-csv-reader (open-input-file "fruits.csv")))
;;; @end lisp
;;;
;;; This reader, @code{next-row}, can then be called repeatedly to yield a
;;; parsed representation of each subsequent row. The parsed format is a list
;;; of strings, one string for each column. The null list is yielded to
;;; indicate that all rows have already been yielded.
;;;
;;; @lisp
;;; (next-row) @result{} ("apples" "2" "0.42")
;;; (next-row) @result{} ("bananas" "20" "13.69")
;;; (next-row) @result{} ()
;;; @end lisp
(define (make-csv-reader-maker reader-spec)
(let ((make-portread
(if (let ((p (assq 'newline-type reader-spec))) (and p (cdr p)))
;; Newline-adapting portreader-maker.
(letrec
((detect-portread
(%csv:make-portreader
(%csv:csv-spec-derive reader-spec
'((newline-type . detect)))))
;; TODO: The set of cr/crlf/lf newline-type portreaders are
;; constructed optimistically right now for two reasons:
;; 1. we don't yet sanitize reader-specs of shared structure
;; that can be mutated behind our backs; 2. eventually, we
;; want to add a "lots-o-shots?" argument that, when true,
;; would do this anyway. Consider.
(cr-portread
(%csv:make-portreader
(%csv:csv-spec-derive reader-spec
'((newline-type . cr)))))
(crlf-portread
(%csv:make-portreader
(%csv:csv-spec-derive reader-spec
'((newline-type . crlf)))))
(lf-portread
(%csv:make-portreader
(%csv:csv-spec-derive reader-spec
'((newline-type . lf))))))
(lambda ()
(let ((actual-portread #f))
(let ((adapt-portread
(lambda (port)
(let ((dnlt-row (detect-portread port)))
(if (null? dnlt-row)
dnlt-row
(begin (set! actual-portread
(case (car dnlt-row)
((cr) cr-portread)
((crlf) crlf-portread)
((lf) lf-portread)
(else actual-portread)))
(cdr dnlt-row)))))))
(set! actual-portread adapt-portread)
(lambda (port) (actual-portread port))))))
;; Stateless portreader-maker.
(let ((reusable-portread
(%csv:make-portreader reader-spec)))
(lambda () reusable-portread)))))
(lambda (in)
(let ((port (%csv:in-arg "[csv-reader]" in))
(portread (make-portread)))
(lambda () (portread port))))))
;;; @section Making Readers
;;; In addition to being constructed from the result of
;;; @code{make-csv-reader-maker}, CSV readers can also be constructed using
;;; @code{make-csv-reader}.
;;; @defproc make-csv-reader in [reader-spec]
;;;
;;; Construct a CSV reader on the input @var{in}, which is an input port or a
;;; string. If @var{reader-spec} is given, and is not the null list, then a
;;; ``one-shot'' reader constructor is constructed with that spec and used. If
;;; @var{reader-spec} is not given, or is the null list, then the default CSV
;;; reader constructor is used. For example, the reader from the
;;; @code{make-csv-reader-maker} example could alternatively have been
;;; constructed like:
;;;
;;; @lisp
;;; (define next-row
;;; (make-csv-reader
;;; (open-input-file "fruits.csv")
;;; '((separator-chars . (#\|))
;;; (strip-leading-whitespace? . #t)
;;; (strip-trailing-whitespace? . #t))))
;;; @end lisp
(define make-csv-reader
(let ((default-maker (make-csv-reader-maker '())))
(lambda (in . rest)
(let ((spec (cond
((null? rest) '())
((null? (cdr rest)) (car rest))
(else (%csv:error "make-csv-reader" "extraneous arguments" (cdr rest))))))
((if (null? spec)
default-maker
(make-csv-reader-maker spec))
(%csv:in-arg "make-csv-reader" in))))))
;;; @section High-Level Conveniences
;;; Several convenience procedures are provided for iterating over the CSV rows
;;; and for converting the CSV to a list.
;;;
;;; To the dismay of some Scheme purists, each of these procedures accepts a
;;; @var{reader-or-in} argument, which can be a CSV reader, an input port, or a
;;; string. If not a CSV reader, then the default reader constructor is used.
;;; For example, all three of the following are equivalent:
;;;
;;; @lisp
;;; (csv->list STRING )
;;; @equiv{}
;;; (csv->list (make-csv-reader STRING ))
;;; @equiv{}
;;; (csv->list (make-csv-reader (open-input-string STRING )))
;;; @end lisp
;;; @defproc csv-for-each proc reader-or-in
;;;
;;; Similar to Scheme's @code{for-each}, applies @var{proc}, a procedure of one
;;; argument, to each parsed CSV row in series. @var{reader-or-in} is the CSV
;;; reader, input port, or string. The return value is undefined.
;; TODO: Doc an example for this.
(define (csv-for-each proc reader-or-in)
(let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
(let loop ((row (reader)))
(or (null? row)
(begin (proc row)
(loop (reader)))))))
;;; @defproc csv-map proc reader-or-in
;;;
;;; Similar to Scheme's @code{map}, applies @var{proc}, a procedure of one
;;; argument, to each parsed CSV row in series, and yields a list of the values
;;; of each application of @var{proc}, in order. @var{reader-or-in} is the CSV
;;; reader, input port, or string.
;; TODO: Doc an example for this.
;; (define (csv-map proc reader-or-in)
;; (let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
;; (let ((head '()))
;; (let ((row (reader)))
;; (if (null? row)
;; head
;; (let ((pair (cons (proc row) '())))
;; (set! head pair)
;; (let loop ((prior pair))
;; (let ((row (reader)))
;; (if (null? row)
;; head
;; (let ((pair (cons (proc row) '())))
;; (set-cdr! prior pair)
;; (loop pair)))))))))))
(define (csv-map proc reader-or-in)
(let ((reader (%csv:reader-or-in-arg "csv-for-each" reader-or-in)))
(let loop ((row (reader)) (ret null))
(if (null? row)
(reverse ret)
(let ((ret (cons (proc row) ret)))
(loop (reader) ret))))))
;;; @defproc csv->list reader-or-in
;;;
;;; Yields a list of CSV row lists from input @var{reader-or-in}, which is a
;;; CSV reader, input port, or string.
;; TODO: Doc an example for this.
;; (define (csv->list reader-or-in)
;; (let ((reader (%csv:reader-or-in-arg "csv->list" reader-or-in)))
;; (let ((head '()))
;; (let ((row (reader)))
;; (if (null? row)
;; head
;; (let ((pair (cons row '())))
;; (set! head pair)
;; (let loop ((prior pair))
;; (let ((row (reader)))
;; (if (null? row)
;; head
;; (let ((pair (cons row '())))
;; (set-cdr! prior pair)
;; (loop pair)))))))))))
(define (csv->list reader-or-in)
(csv-map values reader-or-in))
;;; @section Converting CSV to SXML
;;; The @code{csv->sxml} procedure can be used to convert CSV to SXML format,
;;; for processing with various XML tools.
;;; @defproc csv->sxml reader-or-in [row-element [col-elements]]
;;;
;;; Reads CSV from input @var{reader-or-in} (which is a CSV reader, input port,
;;; or string), and yields an SXML representation. If given, @var{row-element}
;;; is a symbol for the XML row element. If @var{row-element} is not given,
;;; the default is the symbol @code{row}. If given @var{col-elements} is a
;;; list of symbols for the XML column elements. If not given, or there are
;;; more columns in a row than given symbols, column element symbols are of the
;;; format @code{col-@var{n}}, where @var{n} is the column number (the first
;;; column being number 0, not 1).
;;;
;;; For example, given a CSV-format file @code{friends.csv} that has the
;;; contents:
;;;
;;; @example
;;; Binoche,Ste. Brune,33-1-2-3
;;; Posey,Main St.,555-5309
;;; Ryder,Cellblock 9,
;;; @end example
;;;
;;; with elements not given, the result is:
;;;
;;; @lisp
;;; (csv->sxml (open-input-file "friends.csv"))
;;; @result{}
;;; (*TOP*
;;; (row (col-0 "Binoche") (col-1 "Ste. Brune") (col-2 "33-1-2-3"))
;;; (row (col-0 "Posey") (col-1 "Main St.") (col-2 "555-5309"))
;;; (row (col-0 "Ryder") (col-1 "Cellblock 9") (col-2 "")))
;;; @end lisp
;;;
;;; With elements given, the result is like:
;;;
;;; @lisp
;;; (csv->sxml (open-input-file "friends.csv")
;;; 'friend
;;; '(name address phone))
;;; @result{}
;;; (*TOP* (friend (name "Binoche")
;;; (address "Ste. Brune")
;;; (phone "33-1-2-3"))
;;; (friend (name "Posey")
;;; (address "Main St.")
;;; (phone "555-5309"))
;;; (friend (name "Ryder")
;;; (address "Cellblock 9")
;;; (phone "")))
;;; @end lisp
(define csv->sxml
(let* ((top-symbol
(string->symbol "*TOP*"))
(make-col-symbol
(lambda (n)
(string->symbol (string-append "col-" (number->string n)))))
(default-col-elements
(let loop ((i 0))
(if (= i 32) ; arbitrary magic number
'()
(cons (make-col-symbol i) (loop (+ 1 i)))))))
;; TODO: Have option to error when columns count doesn't match provided
;; column name list.
(lambda (reader-or-in . rest)
(let ((reader (%csv:reader-or-in-arg "csv->sxml"
reader-or-in))
(row-element 'row)
(col-elements #f))
;; TODO: Maybe use case-lambda.
(or (null? rest)
(begin (set! row-element (car rest))
(let ((rest (cdr rest)))
(or (null? rest)
(begin (set! col-elements (car rest))
(let ((rest (cdr rest)))
(or (null? rest)
(%csv:error
"csv->sxml"
"extraneous arguments"
rest))))))))
;; TODO: We could clone and grow default-col-elements for the duration
;; of this procedure.
(cons top-symbol
(csv-map (lambda (row)
(cons row-element
(let loop ((vals row)
(i 0)
(names (or col-elements
default-col-elements)))
(if (null? vals)
'()
(cons (list (if (null? names)
(make-col-symbol i)
(car names))
(car vals))
(loop (cdr vals)
(+ 1 i)
(if (null? names)
'()
(cdr names))))))))
reader))))))
;; TODO: Make a define-csv-reader/positional, for great constant-folding.
;; That's part of the reason some things are done the way they are.
;; TODO: Make a csv-bind, as a newbie convenience for people without advanced
;; match forms, which looks good in examples. This is better than a
;; csv-map/bind and a csv-for-each/bind.
;;
;; (csv-for-each/bind ((column-binding ...) body ...)
;; { (else => closure) | (else body ...) | }
;; input-port
;; [ csv-reader ])
;;
;; (csv-for-each/bind
;; ((lastname firstname email)
;; ...)
;; (else => (lambda (row) (error "CSV row didn't match pattern" row)))
;; my-input-port
;; my-csv-reader)
;; TODO: Handle escapes, once we find an actual example or specification of any
;; flavor of escapes in CSV other than quote-doubling inside a quoted field.
;; TODO: Add a spec attribute for treating adjacent separators as one, or
;; skipping empty fields. This would probably only be used in practice for
;; parsing whitespace-separated input.
;; TODO: Get access to MS Excel or documentation, and make this correct.
;;
;; (define msexcel-csv-reader-spec
;; '((newline-type . crlf)
;; (separator-chars . (#\,))
;; (quote-char . #\")
;; (quote-doubling-escapes? . #t)
;; (comment-chars . ())
;; (whitespace-chars . (#\space))
;; (strip-leading-whitespace? . #f)
;; (strip-trailing-whitespace? . #f)
;; (newlines-in-quotes? . #t)))
;; TODO: Maybe put this back in.
;;
;; (define default-csv-reader-spec
;; '((newline-type . lax)
;; (separator-chars . (#\,))
;; (quote-char . #\")
;; (quote-doubling-escapes? . #t)
;; (comment-chars . ())
;; (whitespace-chars . (#\space))
;; (strip-leading-whitespace? . #f)
;; (strip-trailing-whitespace? . #f)
;; (newlines-in-quotes? . #t)))
;; TODO: Implement CSV writing, after CSV reading is field-tested and polished.
;; TODO: Call "close-input-port" once eof-object is hit, but make sure we still
;; can return an empty list on subsequent calls to the CSV reader.
;; TODO: Consider switching back to returning eof-object at the end of input.
;; We originally changed to returning the null list because we might want to
;; synthesize the EOF, and there is no R5RS binding for the eof-object.
;; TODO: [2005-12-09] In one test, Guile has a stack overflow when parsing a
;; row with 425 columns. Wouldn't hurt to see if we can make things more
;; tail-recursive.
;;; @unnumberedsec History
;;; @table @asis
;;;
;;; @item Version 0.10 -- 2010-04-13 -- PLaneT @code{(1 6)}
;;; Documentation fix.
;;;
;;; @item Version 0.9 -- 2009-03-14 -- PLaneT @code{(1 5)}
;;; Documentation fix.
;;;
;;; @item Version 0.8 -- 2009-02-23 -- PLaneT @code{(1 4)}
;;; Documentation changes.
;;;
;;; @item Version 0.7 -- 2009-02-22 -- PLaneT @code{(1 3)}
;;; License is now LGPL 3. Moved to author's new Scheme administration system.
;;;
;;; @item Version 0.6 -- 2008-08-12 -- PLaneT @code{(1 2)}
;;; For PLT 4 compatibility, new versions of @code{csv-map} and
;;; @code{csv->list} that don't use @code{set-cdr!} (courtesy of Doug
;;; Orleans). PLT 4 @code{if} compatibility change. Minor documentation fixes.
;;;
;;; @item Version 0.5 --- 2005-12-09
;;; Changed a non-R5RS use of @code{letrec} to @code{let*}, caught by Guile and
;;; David Pirotte.
;;;
;;; @item Version 0.4 --- 2005-06-07
;;; Converted to Testeez. Minor documentation changes.
;;;
;;; @item Version 0.3 --- 2004-07-21
;;; Minor documentation changes. Test suite now disabled by default.
;;;
;;; @item Version 0.2 --- 2004-06-01
;;; Work-around for @code{case}-related bug observed in Gauche 0.8 and 0.7.4.2
;;; that was tickled by @code{csv-internal:make-portreader/positional}. Thanks
;;; to Grzegorz Chrupa@l{}a for reporting.
;;;
;;; @item Version 0.1 --- 2004-05-31
;;; First release, for testing with real-world input.
;;;
;;; @end table
(provide
csv->list
csv->sxml
csv-for-each
csv-map
make-csv-reader
make-csv-reader-maker)

3
collects/2htdp/private/csv/friends.csv Normal file
View File

@ -0,0 +1,3 @@
Binoche,Ste. Brune,33-1-2-3
Posey,Main St.,555-5309
Ryder,Cellblock 9,
1 Binoche Ste. Brune 33-1-2-3
2 Posey Main St. 555-5309
3 Ryder Cellblock 9

2
collects/2htdp/private/csv/fruit.csv Normal file
View File

@ -0,0 +1,2 @@
apples | 2 | 0.42
bananas | 20 | 13.69
1 apples 2 0.42
2 bananas 20 13.69

26
collects/2htdp/private/csv/permission.txt Normal file
View File

@ -0,0 +1,26 @@
From: Neil Van Dyke <neil@neilvandyke.org>
Date: April 13, 2010 2:39:54 PM EDT
To: Matthias Felleisen <matthias@ccs.neu.edu>
Subject: Re: csv package
Matthias, sure, you guys may include it, if you want to.
I have to retain copyright, since it's used by people with several non-PLT Scheme implementations.
If LGPL 3 license is a problem, and you're looking for a LPGL 2.x, I could change the license.
I've attached a ".zip" file of the sources of the latest version.  PLaneT has the sources for the specific version you mentioned.  Let me know if you need something else.
Cheers,
Neil
Matthias Felleisen wrote at 04/13/2010 11:08 AM:
Neil, would it be okay with you if I provide your csv package from the core:
 (require (planet neil/csv:1:2/csv))
If so, could you send me your sources? Thanks -- Matthias

82
collects/2htdp/private/syn-aux.ss
View File

@ -1,6 +1,10 @@
#lang scheme
(provide define-keywords function-with-arity expr-with-check except err
(provide define-keywords
;; (define-keywords (name1:identifier ... spec:expr) ...)
;; constraint: the first name is the original name
;; and it is also the name of the field in the class
function-with-arity expr-with-check except err
->args
->kwds-in
clauses-use-kwd)
@ -10,6 +14,41 @@
scheme
(rename-in lang/prim (first-order->higher-order f2h))))
(require (for-syntax syntax/parse))
(define-syntax (define-keywords stx)
(syntax-parse stx
[(define-keywords the-list (kw:identifier ... coerce:expr) ...)
#'(begin
(provide kw ...) ...
(define-syntaxes (kw ...)
(values (lambda (x)
(raise-syntax-error 'kw "used out of context" x))
...))
...
(define-for-syntax the-list
(apply append
(list
(let* ([x (list (list #'kw ''kw) ...)]
[f (caar x)])
(map (lambda (x)
(define clause-name (car x))
(define clause-spec (cadr x))
(list clause-name f (coerce clause-spec)))
x))
...))))]))
#;
(define-syntax-rule
(define-keywords the-list (kw coerce) ...)
(begin
(provide kw ...)
(define-syntax kw
(lambda (x)
(raise-syntax-error 'kw "used out of context" x)))
...
(define-for-syntax the-list
(list (list #'kw (coerce ''kw)) ...))))
#|
transform the clauses into the initial arguments specification
for a new expression that instantiates the appropriate class
@ -21,25 +60,50 @@
if anything fails, use the legal keyword to specialize the error message
|#
(define (->args stx clauses AllSpec PartSpec ->rec? legal)
(define (->args tag stx clauses AllSpec PartSpec ->rec? legal)
(define msg (format "not a legal clause in a ~a description" legal))
(define Spec (append AllSpec PartSpec))
(define kwds (map (compose (curry datum->syntax stx) car) Spec))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg (->kwds-in kwds)))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
(duplicates? tag spec)
(map (lambda (x)
(define kw (car x))
(define-values (key coercion)
(let loop ([kwds kwds][Spec Spec])
(if (free-identifier=? (car kwds) kw)
(values (car kwds) (cadar Spec))
;; -- the original keyword, which is also the init-field name
;; -- the coercion that comes with it
(values (cadar Spec) (caddar Spec))
(loop (cdr kwds) (cdr Spec)))))
(list key (coercion (cdr x))))
spec))
(define (clauses-use-kwd stx:list ->rec? legal-clause kwd-in?)
;; Symbol [Listof kw] -> true
;; effect: raise syntax error about duplicated clause
(define (duplicates? tag lox)
(let duplicates? ([lox lox])
(cond
[(empty? lox) false]
[else
(let* ([f (caar lox)]
[id (syntax-e f)]
[x (memf (lambda (x) (free-identifier=? (car x) f)) (rest lox))])
(if x
(raise-syntax-error tag (format "duplicate ~a clause" id) (cdar x))
(duplicates? (rest lox))))])))
;; check whether rec? occurs, produce list of keywords
(define (clauses-use-kwd stx:list ->rec? legal-clause kwds)
(define kwd-in? (->kwds-in kwds))
(define double (string-append legal-clause ", ~a has been redefined"))
(map (lambda (stx)
(syntax-case stx ()
[(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw #'E) (cons #'kw stx))]
[(kw . E)
(let ([kw (syntax-e #'kw)])
(if (member kw (map syntax-e kwds))
(raise-syntax-error #f (format double kw) stx)
(raise-syntax-error #f legal-clause stx)))]
[_ (raise-syntax-error #f legal-clause stx)]))
stx:list))
@ -48,14 +112,6 @@
(lambda (k)
(and (identifier? k) (for/or ([n kwds]) (free-identifier=? k n)))))
(define-syntax-rule (define-keywords the-list (kw coerce) ...)
(begin
(provide kw ...)
(define-syntax (kw x)
(raise-syntax-error 'kw "used out of context" x))
...
(define-for-syntax the-list (list (list #'kw (coerce ''kw)) ...))))
(define-syntax (expr-with-check stx)
(syntax-case stx ()
[(_ check> msg)

2
collects/2htdp/tests/bad-draw.ss
View File

@ -5,7 +5,7 @@
(define s "")
(define x 0)
(with-handlers ((exn? void))
(with-handlers ((exn? (lambda _ "success!")))
(big-bang 0
(on-tick (lambda (w) (begin (set! x (+ x 1)) w)))
(on-draw (lambda (w) (set! s (number->string w))))))

89
collects/2htdp/tests/batch-io.ss Normal file
View File

@ -0,0 +1,89 @@
#lang scheme/load
(require schemeunit)
(require 2htdp/batch-io)
(define file "batch-io.txt")
(define test1 #<<eos
test1
eos
)
(define test2-as-list '("test1" "test2"))
(define test2
(apply string-append
(list (first test2-as-list)
(string #\newline)
(second test2-as-list))))
(write-file file test1)
(check-true (string=? (read-file file) test1) "read-file 1")
(write-file file test2)
(check-true (string=? (read-file file) test2) "read-file 2")
(write-file file test1)
(check-equal? (read-as-lines file) (list test1) "as-lines 1")
(write-file file test2)
(check-equal? (read-as-lines file) test2-as-list "as-lines 2")
(define as-1strings1 (map string (string->list test1)))
(write-file file test1)
(check-equal? (read-as-1strings file) as-1strings1 "as-1strings 1")
(define as-1strings2
(map string
(apply append
(map string->list
(cdr
(foldr (lambda (f r) (cons "\n" (cons f r))) '()
test2-as-list))))))
(write-file file test2)
(check-equal? (read-as-1strings file) as-1strings2 "as-lines 2")
(define test2-a-as-list '("test1" "" "test2"))
(define test2-a
(apply string-append
(list (first test2-as-list)
(string #\newline)
(string #\newline)
(second test2-as-list))))
(write-file file test2-a)
(check-equal? (read-as-lines file) test2-a-as-list "as-lines 2-a")
(check-equal? (read-as-words file) '("test1" "test2") "as-words 2-a")
(define test3 #<< eos
word1, word2
word3, word4
eos
)
(write-file file test3)
(check-equal? (read-as-words file) '("word1," "word2" "word3," "word4")
"as-words")
(check-equal? (read-as-words/line file) '(("word1," "word2") ("word3," "word4"))
"as-words")
(check-equal? (read-as-csv file) '(("word1" "word2") ("word3" "word4"))
"as-cvs 1")
(check-equal? (read-as-csv/rows file length) '(2 2)
"as-csv/rows")
(check-exn exn:fail:contract? (lambda () (write-file 0 1)))
(check-exn exn:fail:contract? (lambda () (write-file '("test") 1)))
(check-exn exn:fail:contract? (lambda () (write-file "test" '("test"))))
(check-exn exn:fail:contract? (lambda () (read-file 0)))
(check-exn exn:fail:contract? (lambda () (read-file '("test"))))
(check-exn exn:fail:contract? (lambda () (read-as-lines 0)))
(check-exn exn:fail:contract? (lambda () (read-as-lines '("test"))))
(check-exn exn:fail:contract? (lambda () (read-as-1strings 0)))
(check-exn exn:fail:contract? (lambda () (read-as-1strings '("test"))))

40
collects/2htdp/tests/clause-once.ss Normal file
View File

@ -0,0 +1,40 @@
#lang scheme/load
;; purpose: make sure that each clause exists at most once
;; (why am I running this in scheme/load for the namespace in eval)
(error-print-source-location #f)
(with-handlers ((exn:fail:syntax?
(lambda (e)
(define msg (exn-message e))
(define ext "big-bang: duplicate on-draw clause") ; " in: (on-draw render2 400 200)")
(unless (string=? msg ext)
(raise e)))))
(eval '(module a scheme
(require 2htdp/universe)
(require 2htdp/image)
(define (render1 n) (text (number->string n) 12 "red"))
(define (render2 n) (text (number->string n) 10 "blue"))
(define (main a)
(big-bang 0
(on-draw render1 200 400)
(on-draw render2 400 200)
; (on-tick sub1)
(on-tick add1))))))
(with-handlers ((exn:fail:syntax?
(lambda (e)
(define msg (exn-message e))
(unless (string=? msg "universe: duplicate on-tick clause"); " in: (on-tick sub1)")
(raise e)))))
(eval '(module a scheme
(require 2htdp/universe)
(define (main a)
(universe 0
(on-tick add1)
(on-tick sub1))))))

22
collects/2htdp/tests/mp.ss
View File

@ -1,9 +1,8 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-beginner-reader.ss" "lang")((modname mp) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
#lang scheme (require test-engine/scheme-tests)
(require 2htdp/universe)
(require htdp/image)
;; WorldState = Image
;; graphical constants
@ -13,11 +12,11 @@
;; add a dot at (x,y) to ws
(check-expect
(clack mt 10 20 "something mousy")
(clack mt 10 20 "button-down")
(place-image (circle 1 "solid" "red") 10 20 mt))
(check-expect
(clack (place-image (circle 1 "solid" "red") 1 2 mt) 3 3 "")
(clack (place-image (circle 1 "solid" "red") 1 2 mt) 3 3 "button-down")
(place-image (circle 1 "solid" "red") 3 3
(place-image (circle 1 "solid" "red") 1 2 mt)))
@ -34,8 +33,13 @@
(define (show ws)
ws)
(test)
;; run program run
(big-bang (empty-scene 100 100)
(on-draw show)
(record? true)
(on-mouse clack))
(define (main x)
(big-bang (empty-scene 100 100)
(on-draw show)
(record? x)
(on-mouse clack)))
(main false)

40
collects/2htdp/tests/on-tick-defined.ss Normal file
View File

@ -0,0 +1,40 @@
#lang scheme/load
;; purpose: when on-tick or on-xxx has been redefined,
;; --- raise more specific error message
;; (why am I running this in scheme/load for the namespace in eval)
(error-print-source-location #f)
(define legal "~a: not a legal clause in a world description")
(define double
(string-append (format legal 'on-tick) ", on-tick has been redefined"))
(with-handlers ((exn:fail:syntax?
(lambda (x)
(unless (string=? (exn-message x) double) (raise x)))))
(eval '(module a scheme
(require 2htdp/universe)
(local ((define (run) (big-bang 0 (on-tick on-tick)))
(define (on-tick t) 0))
10))))
;; purpose: catch illegal shapes of the form (kwd . stuff)
(with-handlers ((exn:fail:syntax?
(lambda (e)
(unless (string=? (exn-message e) (format legal 'on-tic))
(raise e)))))
(eval '(module a scheme
(require 2htdp/universe)
(big-bang 0 (on-tic add1)))))
;; purpose: catch illegal atomic clauses
(with-handlers ((exn:fail:syntax?
(lambda (e)
(unless (string=? (exn-message e) (format legal 'stop-when))
(raise e)))))
(eval '(module a scheme
(require 2htdp/universe)
(big-bang 0 (on-tick add1) stop-when))))

3
collects/2htdp/tests/test-image.ss
View File

@ -38,7 +38,8 @@
(only-in "../private/image-more.ss"
bring-between
swizzle)
"../private/img-err.ss"
(only-in "../private/img-err.ss" image-snip->image)
; "../private/img-err.ss"
"../../mrlib/private/image-core-bitmap.ss"
lang/posn
scheme/math

47
collects/2htdp/universe.ss
View File

@ -11,10 +11,7 @@
-- what if the initial world or universe state is omitted? the error message is bad then.
|#
(require (for-syntax "private/syn-aux.ss"
scheme/function
#;
(rename-in lang/prim (first-order->higher-order f2h)))
(require (for-syntax "private/syn-aux.ss" scheme/function)
"private/syn-aux-aux.ss"
"private/syn-aux.ss"
"private/check-aux.ss"
@ -26,8 +23,9 @@
htdp/error
(rename-in lang/prim (first-order->higher-order f2h)))
(provide
(rename-out (make-stop-the-world stop-with))) ;; World -> STOP
(define-primitive stop-with make-stop-the-world)
(provide stop-with) ;; World -> STOP
(provide
launch-many-worlds
@ -35,7 +33,7 @@
;; run expressions e1 through e2 in parallel, produce all values in same order
)
(provide
(provide-primitive
sexp? ;; Any -> Boolean
)
@ -71,6 +69,9 @@
;
(provide big-bang ;; <syntax> : see below
)
(provide-primitives
make-package ;; World Sexp -> Package
package? ;; Any -> Boolean
run-movie ;; [Listof Image] -> true
@ -79,7 +80,9 @@
key-event? ;; Any -> Boolean : KEY-EVTS
key=? ;; KEY-EVTS KEY-EVTS -> Boolean
;; IP : a string that points to a machine on the net
LOCALHOST ;; IP
)
(provide LOCALHOST ;; IP
)
(provide-higher-order-primitive
@ -134,13 +137,14 @@
(define-keywords WldSpec
;; -- on-draw must specify a rendering function; it may specify dimensions
[on-draw (function-with-arity
[on-draw to-draw
(function-with-arity
1
except
[(_ f width height)
#'(list (proc> 'on-draw (f2h f) 1)
(nat> 'on-draw width "width")
(nat> 'on-draw height "height"))])]
[(_ f width height)
#'(list (proc> 'to-draw (f2h f) 1)
(nat> 'to-draw width "width")
(nat> 'to-draw height "height"))])]
;; -- on-mouse must specify a mouse event handler
[on-mouse (function-with-arity 4)]
;; -- on-key must specify a key event handler
@ -175,7 +179,7 @@
[(V) (set! rec? #'V)]
[_ (err '#'record? stx)])))]
[args
(->args stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
(->args 'big-bang stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
#`(let* ([esp (make-eventspace)]
[thd (eventspace-handler-thread esp)])
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
@ -185,7 +189,7 @@
(define (run-simulation f)
(check-proc 'run-simulation f 1 "first" "one argument")
(big-bang 1 (on-tick add1) (on-draw f)))
(big-bang 1 (on-draw f) (on-tick add1)))
(define animate run-simulation)
@ -235,20 +239,23 @@
;
;
(provide
(provide-primitives
;; type World
iworld? ;; Any -> Boolean
iworld=? ;; World World -> Boolean
iworld-name ;; World -> Symbol
iworld1 ;; sample worlds
iworld2
iworld3
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
;; type Mail = (make-mail World S-expression)
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
bundle? ;; is this a bundle?
make-mail ;; World S-expression -> Mail
mail? ;; is this a real mail?
)
(provide
iworld1 ;; sample worlds
iworld2
iworld3
universe ;; <syntax> : see below
)
@ -269,7 +276,7 @@
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u bind ...)
(let*
([args (->args stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
([args (->args 'universe stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
[domain (map (compose syntax-e car) args)])
(cond
[(not (memq 'on-new domain))

183
collects/compiler/cm.ss
View File

@ -40,29 +40,34 @@
;; use the date of the original file (or the zo, whichever
;; is newer).
(let-values ([(base name dir) (split-path p)])
(let* ([ext (filename-extension p)]
[pbytes (path->bytes name)]
[zo-file-name
(and ext
(bytes->path
(bytes-append
(subbytes
pbytes
0
(- (bytes-length pbytes)
(bytes-length ext)))
#"zo")))]
[zo-path (and zo-file-name
(build-path
base
(car (use-compiled-file-paths))
zo-file-name))])
(cond
[(and zo-file-name (file-exists? zo-path))
(max (file-or-directory-modify-seconds p)
(file-or-directory-modify-seconds zo-file-name))]
[else
(file-or-directory-modify-seconds p)])))]
(let* ([p-date (file-or-directory-modify-seconds p #f (lambda () #f))]
[alt-date (and (not p-date)
(file-or-directory-modify-seconds
(rkt->ss p)
#f
(lambda () #f)))]
[date (or p-date alt-date)]
[get-zo-date (lambda (name)
(file-or-directory-modify-seconds
(build-path
base
(car (use-compiled-file-paths))
(path-add-suffix name #".zo"))
#f
(lambda () #f)))]
[main-zo-date (and (or p-date (not alt-date))
(get-zo-date name))]
[alt-zo-date (and (or alt-date
(and (not p-date)
(not alt-date)
(not main-zo-date)))
(get-zo-date (rkt->ss name)))]
[zo-date (or main-zo-date alt-zo-date)])
(or (and date
zo-date
(max date zo-date))
date
zo-date)))]
[(null? p-eles)
;; this case shouldn't happen... I think.
(c-loop (cdr paths))]
@ -81,7 +86,8 @@
(define (get-deps code path)
(filter-map (lambda (x)
(let ([r (resolve-module-path-index x path)])
(and (path? r) (path->bytes r))))
(and (path? r)
(path->bytes r))))
(append-map cdr (module-compiled-imports code))))
(define (get-compilation-dir+name mode path)
@ -104,8 +110,7 @@
(close-output-port (open-output-file path #:exists 'append)))
(define (try-file-time path)
;; might be better to use a `with-handlers'
(and (file-exists? path) (file-or-directory-modify-seconds path)))
(file-or-directory-modify-seconds path #f (lambda () #f)))
(define (try-delete-file path)
;; Attempt to delete, but give up if it doesn't work:
@ -165,7 +170,7 @@
(date-hour d) (date-minute d) (date-second d))))
(define (verify-times ss-name zo-name)
(define ss-sec (try-file-time ss-name)) ; should exist
(define ss-sec (try-file-time ss-name))
(define zo-sec (try-file-time zo-name))
(cond [(not ss-sec) (error 'compile-zo "internal error")]
[(not zo-sec) (error 'compile-zo "failed to create .zo file (~a) for ~a"
@ -184,6 +189,8 @@
(define-struct file-dependency (path) #:prefab)
(define (compile-zo* mode path read-src-syntax zo-name)
;; The `path' argument has been converted to .rkt or .ss form,
;; as appropriate.
;; External dependencies registered through reader guard and
;; accomplice-logged events:
(define external-deps null)
@ -275,30 +282,39 @@
(define depth (make-parameter 0))
(define (compile-zo mode path read-src-syntax)
((manager-compile-notify-handler) path)
(trace-printf "compiling: ~a" path)
(parameterize ([indent (string-append " " (indent))])
(let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
[zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos))
(touch zo-name)
(begin (when zo-exists? (delete-file zo-name))
(log-info (format "cm: ~acompiling ~a"
(build-string
(depth)
(λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
path))
(parameterize ([depth (+ (depth) 1)])
(with-handlers
([exn:get-module-code?
(lambda (ex)
(compilation-failure mode path zo-name
(exn:get-module-code-path ex)
(exn-message ex))
(raise ex))])
(compile-zo* mode path read-src-syntax zo-name)))))))
(trace-printf "end compile: ~a" path))
(define (actual-source-path path)
(if (file-exists? path)
path
(let ([alt-path (rkt->ss path)])
(if (file-exists? alt-path)
alt-path
path))))
(define (compile-zo mode path orig-path read-src-syntax)
(let ([actual-path (actual-source-path orig-path)])
((manager-compile-notify-handler) actual-path)
(trace-printf "compiling: ~a" actual-path)
(parameterize ([indent (string-append " " (indent))])
(let* ([zo-name (path-add-suffix (get-compilation-path mode path) #".zo")]
[zo-exists? (file-exists? zo-name)])
(if (and zo-exists? (trust-existing-zos))
(touch zo-name)
(begin (when zo-exists? (delete-file zo-name))
(log-info (format "cm: ~acompiling ~a"
(build-string
(depth)
(λ (x) (if (= 2 (modulo x 3)) #\| #\space)))
actual-path))
(parameterize ([depth (+ (depth) 1)])
(with-handlers
([exn:get-module-code?
(lambda (ex)
(compilation-failure mode path zo-name
(exn:get-module-code-path ex)
(exn-message ex))
(raise ex))])
(compile-zo* mode path read-src-syntax zo-name)))))))
(trace-printf "end compile: ~a" actual-path)))
(define (get-compiled-time mode path)
(define-values (dir name) (get-compilation-dir+name mode path))
@ -308,31 +324,44 @@
(try-file-time (build-path dir (path-add-suffix name #".zo")))
-inf.0))
(define (rkt->ss p)
(let ([b (path->bytes p)])
(if (regexp-match? #rx#"[.]rkt$" b)
(path-replace-suffix p #".ss")
p)))
(define (compile-root mode path0 up-to-date read-src-syntax)
(define path (simplify-path (cleanse-path path0)))
(define (read-deps)
(define orig-path (simplify-path (cleanse-path path0)))
(define (read-deps path)
(with-handlers ([exn:fail:filesystem? (lambda (ex) (list (version)))])
(call-with-input-file
(path-add-suffix (get-compilation-path mode path) #".dep")
read)))
(define (do-check)
(define path-zo-time (get-compiled-time mode path))
(define path-time (try-file-time path))
(cond
[(not path-time)
(trace-printf "~a does not exist" path)
path-zo-time]
[else
(cond
(let* ([main-path orig-path]
[alt-path (rkt->ss orig-path)]
[main-path-time (try-file-time main-path)]
[alt-path-time (and (not main-path-time)
(not (eq? alt-path main-path))
(try-file-time alt-path))]
[path (if alt-path-time alt-path main-path)]
[path-time (or main-path-time alt-path-time)]
[path-zo-time (get-compiled-time mode path)])
(cond
[(not path-time)
(trace-printf "~a does not exist" orig-path)
path-zo-time]
[else
(cond
[(> path-time path-zo-time)
(trace-printf "newer src...")
(compile-zo mode path read-src-syntax)]
(compile-zo mode path orig-path read-src-syntax)]
[else
(let ([deps (read-deps)])
(let ([deps (read-deps path)])
(cond
[(not (and (pair? deps) (equal? (version) (car deps))))
(trace-printf "newer version...")
(compile-zo mode path read-src-syntax)]
(compile-zo mode path orig-path read-src-syntax)]
[(ormap
(lambda (p)
;; (cons 'ext rel-path) => a non-module file (check date)
@ -348,13 +377,15 @@
d t path-zo-time)
#t)))
(cdr deps))
(compile-zo mode path read-src-syntax)]))])
(compile-zo mode path orig-path read-src-syntax)]))])
(let ([stamp (get-compiled-time mode path)])
(hash-set! up-to-date path stamp)
stamp)]))
(or (and up-to-date (hash-ref up-to-date path #f))
((manager-skip-file-handler) path)
(begin (trace-printf "checking: ~a" path)
(hash-set! up-to-date main-path stamp)
(unless (eq? main-path alt-path)
(hash-set! up-to-date alt-path stamp))
stamp)])))
(or (and up-to-date (hash-ref up-to-date orig-path #f))
((manager-skip-file-handler) orig-path)
(begin (trace-printf "checking: ~a" orig-path)
(do-check))))
(define (managed-compile-zo zo [read-src-syntax read-syntax])
@ -362,13 +393,14 @@
(define (make-caching-managed-compile-zo [read-src-syntax read-syntax])
(let ([cache (make-hash)])
(lambda (zo)
(lambda (src)
(parameterize ([current-load/use-compiled
(make-compilation-manager-load/use-compiled-handler/table
cache)])
(compile-root (car (use-compiled-file-paths))
(path->complete-path zo)
cache read-src-syntax)
(path->complete-path src)
cache
read-src-syntax)
(void)))))
(define (make-compilation-manager-load/use-compiled-handler)
@ -383,7 +415,10 @@
(define (compilation-manager-load-handler path mod-name)
(cond [(not mod-name)
(trace-printf "skipping: ~a mod-name ~s" path mod-name)]
[(not (file-exists? path))
[(not (or (file-exists? path)
(let ([p2 (rkt->ss path)])
(and (not (eq? path p2))
(file-exists? p2)))))
(trace-printf "skipping: ~a file does not exist" path)]
[(or (null? (use-compiled-file-paths))
(not (equal? (car modes)

398
collects/compiler/commands/c-ext.ss Normal file
View File

@ -0,0 +1,398 @@
#lang scheme/base
;; On error, exit with 1 status code
(error-escape-handler (lambda () (exit 1)))
(error-print-width 512)
(require (prefix-in compiler:option: "../option.ss")
"../compiler.ss"
rico/command-name
mzlib/cmdline
dynext/file
dynext/compile
dynext/link
scheme/pretty
setup/pack
setup/getinfo
setup/dirs)
(define dest-dir (make-parameter #f))
(define auto-dest-dir (make-parameter #f))
(define ld-output (make-parameter #f))
(define exe-output (make-parameter #f))
(define exe-embedded-flags (make-parameter '("-U" "--")))
(define exe-embedded-libraries (make-parameter null))
(define exe-aux (make-parameter null))
(define exe-embedded-collects-path (make-parameter #f))
(define exe-embedded-collects-dest (make-parameter #f))
(define exe-dir-add-collects-dirs (make-parameter null))
(define exe-dir-output (make-parameter #f))
(define mods-output (make-parameter #f))
(define module-mode (make-parameter #f))
(define default-plt-name "archive")
(define disable-inlining (make-parameter #f))
(define plt-output (make-parameter #f))
(define plt-name (make-parameter default-plt-name))
(define plt-files-replace (make-parameter #f))
(define plt-files-plt-relative? (make-parameter #f))
(define plt-files-plt-home-relative? (make-parameter #f))
(define plt-force-install-dir? (make-parameter #f))
(define plt-setup-collections (make-parameter null))
(define plt-include-compiled (make-parameter #f))
(define stop-at-source (make-parameter #f))
(define (extract-suffix appender)
(bytes->string/latin-1
(subbytes (path->bytes (appender (bytes->path #"x"))) 1)))
(define ((add-to-param param) f v) (param (append (param) (list v))))
(define mzc-symbol (string->symbol (short-program+command-name)))
;; Returns (values mode files prefixes)
;; where mode is 'compile, 'make-zo, etc.
(define-values (mode source-files prefix)
(parse-command-line
(short-program+command-name)
(current-command-line-arguments)
`([help-labels
"-------------------------------- mode flags ---------------------------------"]
[once-any
[("--cc")
,(lambda (f) 'cc)
(,(format "Compile arbitrary file(s) for an extension: ~a -> ~a"
(extract-suffix append-c-suffix)
(extract-suffix append-object-suffix)))]
[("--ld")
,(lambda (f name) (ld-output name) 'ld)
(,(format "Link arbitrary file(s) to create <extension>: ~a -> ~a"
(extract-suffix append-object-suffix)
(extract-suffix append-extension-suffix))
"extension")]
[("-x" "--xform")
,(lambda (f) 'xform)
((,(format "Convert for 3m compilation: ~a -> ~a"
(extract-suffix append-c-suffix)
(extract-suffix append-c-suffix))
""))]
[("--c-mods")
,(lambda (f name) (mods-output name) 'c-mods)
((,(format "Write C-embeddable module bytecode to <file>") "")
"file")]
[("-e" "--extension")
,(lambda (f) 'compile)
(,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-extension-suffix)))]
[("-c" "--c-source")
,(lambda (f) 'compile-c)
(,(format "Output ~a file(s) from Scheme source(s)" (extract-suffix append-c-suffix)))]]
[help-labels ""]
[once-any
[("--3m")
,(lambda (f) (compiler:option:3m #t))
(,(format "Compile/link for 3m~a"
(if (eq? '3m (system-type 'gc)) " [current default]" "")))]
[("--cgc")
,(lambda (f) (compiler:option:3m #f))
(,(format "Compile/link for CGC~a"
(if (eq? 'cgc (system-type 'gc)) " [current default]" "")))]]
[once-each
[("-m" "--module")
,(lambda (f) (module-mode #t))
("Skip eval of top-level syntax, etc. for -e/-c")]
[("--embedded")
,(lambda (f) (compiler:option:compile-for-embedded #t))
("Compile for embedded run-time engine, with -c")]
[("-p" "--prefix")
,(lambda (f v) v)
("Add elaboration-time prefix file for -e/-c/-z" "file")]
[("-n" "--name")
,(lambda (f name) (compiler:option:setup-prefix name))
("Use <name> as extra part of public low-level names" "name")]]
[once-any
[("-d" "--destination")
,(lambda (f d)
(unless (directory-exists? d)
(error mzc-symbol "the destination directory does not exist: ~s" d))
(dest-dir d))
("Output -e/-c/-x file(s) to <dir>" "dir")]
[("--auto-dir")
,(lambda (f) (auto-dest-dir #t))
(,(format "Output -e to ~s"
(path->string (build-path "compiled" "native"
(system-library-subpath #f)))))]]
[help-labels
"------------------- compiler/linker configuration flags ---------------------"]
[once-each
[("--tool")
,(lambda (f v)
(let ([v (string->symbol v)])
(use-standard-compiler v)
(use-standard-linker v)))
(,(format "Use pre-defined <tool> as C compiler/linker:~a"
(apply string-append
(apply append (map (lambda (t)
(list " " (symbol->string t)))
(get-standard-compilers)))))
"tool")]
[("--compiler")
,(lambda (f v) (current-extension-compiler v))
("Use <compiler-path> as C compiler" "compiler-path")]]
[multi
[("++ccf")
,(add-to-param current-extension-compiler-flags)
("Add C compiler flag" "flag")]
[("--ccf")
,(lambda (f v)
(current-extension-compiler-flags
(remove v (current-extension-compiler-flags))))
("Remove C compiler flag" "flag")]
[("--ccf-clear")
,(lambda (f) (current-extension-compiler-flags null))
("Clear C compiler flags")]
[("--ccf-show")
,(lambda (f)
(printf "C compiler flags: ~s\n"
(expand-for-link-variant (current-extension-compiler-flags))))
("Show C compiler flags")]]
[once-each
[("--linker")
,(lambda (f v) (current-extension-linker v))
("Use <linker-path> as C linker" "linker-path")]]
[multi
[("++ldf")
,(add-to-param current-extension-linker-flags)
("Add C linker flag" "flag")]
[("--ldf")
,(lambda (f v)
(current-extension-linker-flags
(remove v (current-extension-linker-flags))))
("Remove C linker flag" "flag")]
[("--ldf-clear")
,(lambda (f) (current-extension-linker-flags null))
("Clear C linker flags")]
[("--ldf-show")
,(lambda (f)
(printf "C linker flags: ~s\n"
(expand-for-link-variant (current-extension-linker-flags))))
("Show C linker flags")]
[("++ldl")
,(add-to-param current-standard-link-libraries)
("Add C linker library" "lib")]
[("--ldl-show")
,(lambda (f)
(printf "C linker libraries: ~s\n"
(expand-for-link-variant (current-standard-link-libraries))))
("Show C linker libraries")]]
[multi
[("++cppf")
,(add-to-param current-extension-preprocess-flags)
("Add C preprocess (xform) flag" "flag")]
[("--cppf")
,(lambda (f v)
(current-extension-preprocess-flags
(remove v (current-extension-preprocess-flags))))
("Remove C preprocess (xform) flag" "flag")]
[("--cppf-clear")
,(lambda (f) (current-extension-preprocess-flags null))
("Clear C preprocess (xform) flags")]
[("--cppf-show")
,(lambda (f)
(printf "C compiler flags: ~s\n"
(expand-for-link-variant (current-extension-preprocess-flags))))
("Show C preprocess (xform) flags")]]
[help-labels
"-------------------- -c/-e compiler optimization flags ----------------------"]
[once-each
[("--no-prop")
,(lambda (f) (compiler:option:propagate-constants #f))
("Don't propagate constants")]
[("--inline")
,(lambda (f d)
(compiler:option:max-inline-size
(with-handlers ([void (lambda (x)
(error mzc-symbol "bad size for --inline: ~a" d))])
(let ([v (string->number d)])
(unless (and (not (negative? v)) (exact? v) (real? v))
(error 'bad))
v))))
("Set the maximum inlining size" "size")]
[("--no-prim")
,(lambda (f) (compiler:option:assume-primitives #f))
("Do not assume `scheme' bindings at top level")]
[("--stupid")
,(lambda (f) (compiler:option:stupid #t))
("Compile despite obvious non-syntactic errors")]
[("--unsafe-disable-interrupts")
,(lambda (f) (compiler:option:disable-interrupts #t))
("Ignore threads, breaks, and stack overflow")]
[("--unsafe-skip-tests")
,(lambda (f) (compiler:option:unsafe #t))
("Skip run-time tests for some primitive operations")]
[("--unsafe-fixnum-arithmetic")
,(lambda (f) (compiler:option:fixnum-arithmetic #t))
("Assume fixnum arithmetic yields a fixnum")]]
[help-labels
"-------------------------- miscellaneous flags ------------------------------"]
[once-each
[("-v")
,(lambda (f) (compiler:option:somewhat-verbose #t))
("Slightly verbose mode, including version banner and output files")]
[("--vv")
,(lambda (f) (compiler:option:somewhat-verbose #t) (compiler:option:verbose #t))
("Very verbose mode")]
[("--save-temps")
,(lambda (f) (compiler:option:clean-intermediate-files #f))
("Keep intermediate files")]
[("--debug")
,(lambda (f) (compiler:option:debug #t))
("Write debugging output to dump.txt")]])
(lambda (accum . files)
(let ([mode (let ([l (filter symbol? accum)])
(if (null? l)
(error mzc-symbol "no mode flag specified")
(car l)))])
(values
mode
files
(let ([prefixes (filter string? accum)])
(unless (or (memq mode '(compile compile-c)) (null? prefixes))
(error mzc-symbol "prefix files are not useful in ~a mode" mode))
(if (module-mode)
(begin
(unless (compiler:option:assume-primitives)
(error mzc-symbol "--no-prim is not useful with -m or --module"))
(unless (null? prefixes)
(error mzc-symbol "prefix files not allowed with -m or --module"))
#f)
`(begin
(require scheme)
,(if (compiler:option:assume-primitives)
'(void)
'(namespace-require/copy 'scheme))
(require compiler/cffi)
,@(map (lambda (s) `(load ,s)) prefixes)
(void)))))))
(list "file")))
(when (compiler:option:somewhat-verbose)
(printf "~a v~a [~a], Copyright (c) 2004-2010 PLT Scheme Inc.\n"
(short-program+command-name)
(version)
(system-type 'gc)))
(when (and (auto-dest-dir) (not (memq mode '(zo compile))))
(error mzc-symbol "--auto-dir works only with -z, --zo, -e, or --extension (or default mode)"))
(define (never-embedded action)
(when (compiler:option:compile-for-embedded)
(error mzc-symbol "cannot ~a an extension for an embedded MzScheme" action)))
(if (compiler:option:3m)
(begin (link-variant '3m) (compile-variant '3m))
(begin (link-variant 'cgc) (compile-variant 'cgc)))
(define (compiler-warning)
(fprintf (current-error-port)
"Warning: ~a\n ~a\n"
"compilation to C is usually less effective for performance"
"than relying on the bytecode just-in-time compiler."))
(case mode
[(compile)
(compiler-warning)
(never-embedded "compile")
((compile-extensions prefix)
source-files
(if (auto-dest-dir) 'auto (dest-dir)))]
[(compile-c)
((compile-extensions-to-c prefix) source-files (dest-dir))]
[(cc)
(for ([file source-files])
(let* ([base (extract-base-filename/c file mzc-symbol)]
[dest (append-object-suffix
(let-values ([(base name dir?) (split-path base)])
(build-path (or (dest-dir) 'same) name)))])
(when (compiler:option:somewhat-verbose)
(printf "\"~a\":\n" file))
(compile-extension (not (compiler:option:verbose)) file dest null)
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" dest))))]
[(ld)
(extract-base-filename/ext (ld-output) mzc-symbol)
;; (for ([file source-files]) (extract-base-filename/o file mzc-symbol))
(let ([dest (if (dest-dir)
(build-path (dest-dir) (ld-output))
(ld-output))])
(when (compiler:option:somewhat-verbose)
(printf "~a:\n" (let ([s (apply string-append
(map (lambda (n) (format " \"~a\"" n))
source-files))])
(substring s 1 (string-length s)))))
(link-extension (not (compiler:option:verbose))
source-files
dest)
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" dest)))]
[(xform)
(for ([file source-files])
(let* ([out-file (path-replace-suffix file ".3m.c")]
[out-file (if (dest-dir)
(build-path (dest-dir) out-file)
out-file)])
((dynamic-require 'compiler/xform 'xform)
(not (compiler:option:verbose))
file
out-file
(list (find-include-dir)))
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" out-file))))]
[(c-mods)
(let ([dest (mods-output)])
(let-values ([(in out) (make-pipe)])
(parameterize ([current-output-port out])
((dynamic-require 'compiler/embed 'write-module-bundle)
#:modules
(append (map (lambda (l) `(#f (file ,l))) source-files)
(map (lambda (l) `(#t (lib ,l))) (exe-embedded-libraries)))))
(close-output-port out)
(let ([out (open-output-file dest #:exists 'truncate/replace)])
(fprintf out "#ifdef MZ_XFORM\n")
(fprintf out "XFORM_START_SKIP;\n")
(fprintf out "#endif\n")
(fprintf out "static void declare_modules(Scheme_Env *env) {\n")
(fprintf out " static unsigned char data[] = {")
(let loop ([pos 0])
(let ([b (read-byte in)])
(when (zero? (modulo pos 20)) (fprintf out "\n "))
(unless (eof-object? b) (fprintf out "~a," b) (loop (add1 pos)))))
(fprintf out "0\n };\n")
(fprintf out " Scheme_Object *eload = NULL, *a[3] = {NULL, NULL, NULL};\n")
(fprintf out " MZ_GC_DECL_REG(4);\n")
(fprintf out " MZ_GC_VAR_IN_REG(0, eload);\n")
(fprintf out " MZ_GC_ARRAY_VAR_IN_REG(1, a, 3);\n")
(fprintf out " MZ_GC_REG();\n")
(fprintf out " eload = scheme_builtin_value(\"embedded-load\");\n")
(fprintf out " a[0] = scheme_false;\n")
(fprintf out " a[1] = scheme_false;\n")
(fprintf out " a[2] = scheme_make_sized_byte_string((char *)data, ~a, 0);\n"
(file-position in))
(fprintf out " scheme_apply(eload, 3, a);\n")
(fprintf out " MZ_GC_UNREG();\n")
(fprintf out "}\n")
(fprintf out "#ifdef MZ_XFORM\n")
(fprintf out "XFORM_END_SKIP;\n")
(fprintf out "#endif\n")
(close-output-port out)))
(when (compiler:option:somewhat-verbose)
(printf " [output to \"~a\"]\n" dest)))]
[else (printf "bad mode: ~a\n" mode)])

25
collects/compiler/commands/decompile.ss Normal file
View File

@ -0,0 +1,25 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/zo-parse
compiler/decompile
scheme/pretty)
(define source-files
(command-line
#:program (short-program+command-name)
#:args source-or-bytecode-file
source-or-bytecode-file))
(for ([zo-file source-files])
(let ([zo-file (path->complete-path zo-file)])
(let-values ([(base name dir?) (split-path zo-file)])
(let ([alt-file (build-path base "compiled" (path-add-suffix name #".zo"))])
(parameterize ([current-load-relative-directory base]
[print-graph #t])
(pretty-print
(decompile
(call-with-input-file*
(if (file-exists? alt-file) alt-file zo-file)
(lambda (in)
(zo-parse in))))))))))

31
collects/compiler/commands/exe-dir.ss Normal file
View File

@ -0,0 +1,31 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/distribute)
(define verbose (make-parameter #f))
(define exe-embedded-collects-path (make-parameter #f))
(define exe-dir-add-collects-dirs (make-parameter null))
(define-values (dest-dir source-files)
(command-line
#:program (short-program+command-name)
#:once-each
[("--collects-path") path "Set <path> as main collects for executables"
(exe-embedded-collects-path path)]
#:multi
[("++collects-copy") dir "Add collects in <dir> to directory"
(exe-dir-add-collects-dirs (append (exe-dir-add-collects-dirs) (list dir)))]
#:once-each
[("-v") "Verbose mode"
(verbose #t)]
#:args (dest-dir . executable)
(values dest-dir executable)))
(assemble-distribution
dest-dir
source-files
#:collects-path (exe-embedded-collects-path)
#:copy-collects (exe-dir-add-collects-dirs))
(when (verbose)
(printf " [output to \"~a\"]\n" dest-dir))

90
collects/compiler/commands/exe.ss Normal file
View File

@ -0,0 +1,90 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/private/embed
dynext/file)
(define verbose (make-parameter #f))
(define very-verbose (make-parameter #f))
(define gui (make-parameter #f))
(define 3m (make-parameter #t))
(define exe-output (make-parameter #f))
(define exe-embedded-flags (make-parameter '("-U" "--")))
(define exe-embedded-libraries (make-parameter null))
(define exe-aux (make-parameter null))
(define exe-embedded-collects-path (make-parameter #f))
(define exe-embedded-collects-dest (make-parameter #f))
(define source-file
(command-line
#:program (short-program+command-name)
#:once-each
[("-o") file "Write executable as <file>"
(exe-output file)]
[("--gui") "Geneate GUI executable"
(gui #t)]
[("--collects-path") path "Set <path> as main collects for executable"
(exe-embedded-collects-path path)]
[("--collects-dest") dir "Write collection code to <dir>"
(exe-embedded-collects-dest dir)]
[("--ico") .ico-file "Set Windows icon for executable"
(exe-aux (cons (cons 'ico .ico-file) (exe-aux)))]
[("--icns") .icns-file "Set Mac OS X icon for executable"
(exe-aux (cons (cons 'icns .icns-file) (exe-aux)))]
[("--orig-exe") "Use original executable instead of stub"
(exe-aux (cons (cons 'original-exe? #t) (exe-aux)))]
[("--3m") "Generate using 3m variant"
(3m #t)]
[("--cgc") "Generate using CGC variant"
(3m #f)]
#:multi
[("++lib") lib "Embed <lib> in executable"
(exe-embedded-libraries (append (exe-embedded-libraries) (list lib)))]
[("++exf") flag "Add flag to embed in executable"
(exe-embedded-flags (append (exe-embedded-flags) (list flag)))]
[("--exf") flag "Remove flag to embed in executable"
(exe-embedded-flags (remove flag (exe-embedded-flags)))]
[("--exf-clear") "Clear flags to embed in executable"
(exe-embedded-flags null)]
[("--exf-show") "Show flags to embed in executable"
(printf "Flags to embed: ~s\n" (exe-embedded-flags))]
#:once-each
[("-v") "Verbose mode"
(verbose #t)]
[("--vv") "Very verbose mode"
(verbose #t)
(very-verbose #t)]
#:args (source-file)
source-file))
(let ([dest (mzc:embedding-executable-add-suffix
(or (exe-output)
(extract-base-filename/ss source-file
(string->symbol (short-program+command-name))))
(gui))])
(mzc:create-embedding-executable
dest
#:mred? (gui)
#:variant (if (3m) '3m 'cgc)
#:verbose? (very-verbose)
#:modules (cons `(#%mzc: (file ,source-file))
(map (lambda (l) `(#t (lib ,l)))
(exe-embedded-libraries)))
#:configure-via-first-module? #t
#:literal-expression
(parameterize ([current-namespace (make-base-namespace)])
(compile
`(namespace-require
'',(string->symbol
(format "#%mzc:~a"
(let-values ([(base name dir?)
(split-path source-file)])
(path->bytes (path-replace-suffix name #""))))))))
#:cmdline (exe-embedded-flags)
#:collects-path (exe-embedded-collects-path)
#:collects-dest (exe-embedded-collects-dest)
#:aux (exe-aux))
(when (verbose)
(printf " [output to \"~a\"]\n" dest)))

26
collects/compiler/commands/expand.ss Normal file
View File

@ -0,0 +1,26 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
scheme/pretty)
(define source-files
(command-line
#:program (short-program+command-name)
#:args source-file
source-file))
(for ([src-file source-files])
(let ([src-file (path->complete-path src-file)])
(let-values ([(base name dir?) (split-path src-file)])
(parameterize ([current-load-relative-directory base]
[current-namespace (make-base-namespace)]
[read-accept-reader #t])
(call-with-input-file*
src-file
(lambda (in)
(port-count-lines! in)
(let loop ()
(let ([e (read-syntax src-file in)])
(unless (eof-object? e)
(pretty-print (syntax->datum (expand e)))
(loop))))))))))

10
collects/compiler/commands/info.ss Normal file
View File

@ -0,0 +1,10 @@
#lang setup/infotab
(define rico
'(("make" compiler/commands/make "compile source to bytecode" 100)
("exe" compiler/commands/exe "create executable" 20)
("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10)
("decompile" compiler/commands/decompile "decompile bytecode" #f)
("expand" compiler/commands/expand "macro-expand source" #f)
("distribute" compiler/commands/exe-dir "prepare executable(s) in a directory for distribution" #f)
("c-ext" compiler/commands/c-ext "compile and link C-based extensions" #f)))

79
collects/compiler/commands/make.ss Normal file
View File

@ -0,0 +1,79 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
compiler/cm
"../compiler.ss"
dynext/file)
(define verbose (make-parameter #f))
(define very-verbose (make-parameter #f))
(define disable-inlining (make-parameter #f))
(define disable-deps (make-parameter #f))
(define prefixes (make-parameter null))
(define assume-primitives (make-parameter #t))
(define source-files
(command-line
#:program (short-program+command-name)
#:once-each
[("--disable-inline") "Disable procedure inlining during compilation"
(disable-inlining #t)]
[("--no-deps") "Compile immediate files without updating depdencies"
(disable-deps #t)]
[("-p" "--prefix") file "Add elaboration-time prefix file for --no-deps"
(prefixes (append (prefixes) (list file)))]
[("--no-prim") "Do not assume `scheme' bindings at top level for --no-deps"
(assume-primitives #f)]
[("-v") "Verbose mode"
(verbose #t)]
[("--vv") "Very verbose mode"
(verbose #t)
(very-verbose #t)]
#:args file file))
(if (disable-deps)
;; Just compile one file:
(let ([prefix
`(begin
(require scheme)
,(if (assume-primitives)
'(void)
'(namespace-require/copy 'scheme))
(require compiler/cffi)
,@(map (lambda (s) `(load ,s)) (prefixes))
(void))])
((compile-zos prefix #:verbose? (verbose))
source-files
'auto))
;; Normal make:
(let ([n (make-base-empty-namespace)]
[did-one? #f])
(parameterize ([current-namespace n]
[manager-trace-handler
(lambda (p)
(when (very-verbose)
(printf " ~a\n" p)))]
[manager-compile-notify-handler
(lambda (p)
(set! did-one? #t)
(when (verbose)
(printf " making ~s\n" (path->string p))))])
(for ([file source-files])
(unless (file-exists? file)
(error 'mzc "file does not exist: ~a" file))
(set! did-one? #f)
(let ([name (extract-base-filename/ss file 'mzc)])
(when (verbose)
(printf "\"~a\":\n" file))
(parameterize ([compile-context-preservation-enabled
(disable-inlining)])
(managed-compile-zo file))
(let ([dest (append-zo-suffix
(let-values ([(base name dir?) (split-path file)])
(build-path (if (symbol? base) 'same base)
"compiled" name)))])
(when (verbose)
(printf " [~a \"~a\"]\n"
(if did-one? "output to" "already up-to-date at")
dest))))))))

99
collects/compiler/commands/pack.ss Normal file
View File

@ -0,0 +1,99 @@
#lang scheme/base
(require scheme/cmdline
rico/command-name
setup/pack
setup/getinfo
compiler/distribute)
(define verbose (make-parameter #f))
(define collection? (make-parameter #f))
(define default-plt-name "archive")
(define plt-name (make-parameter default-plt-name))
(define plt-files-replace (make-parameter #f))
(define plt-files-plt-relative? (make-parameter #f))
(define plt-files-plt-home-relative? (make-parameter #f))
(define plt-force-install-dir? (make-parameter #f))
(define plt-setup-collections (make-parameter null))
(define plt-include-compiled (make-parameter #f))
(define-values (plt-output source-files)
(command-line
#:program (short-program+command-name)
#:once-each
[("--collect") "Pack collections instead of files and directories"
(collection? #t)]
[("--plt-name") name "Set the printed <name> describing the archive"
(plt-name name)]
[("--replace") "Files in archive replace existing files when unpacked"
(plt-files-replace #t)]
[("--at-plt") "Files/dirs in archive are relative to user's add-ons directory"
(plt-files-plt-relative? #t)]
#:once-any
[("--all-users") "Files/dirs in archive go to PLT installation if writable"
(plt-files-plt-home-relative? #t)]
[("--force-all-users") "Files/dirs forced to PLT installation"
(plt-files-plt-home-relative? #t) (plt-force-install-dir? #t)]
#:once-each
[("--include-compiled") "Include \"compiled\" subdirectories in the archive"
(plt-include-compiled #t)]
#:multi
[("++setup") collect "Setup <collect> after the archive is unpacked"
(plt-setup-collections (append (plt-setup-collections) (list collect)))]
#:once-each
[("-v") "Verbose mode"
(verbose #t)]
#:args (dest-file . file)
(values dest-file file)))
(if (not (collection?))
;; Files and directories
(begin
(for ([fd source-files])
(unless (relative-path? fd)
(error 'mzc
"file/directory is not relative to the current directory: \"~a\""
fd)))
(pack-plt plt-output
(plt-name)
source-files
#:collections (map list (plt-setup-collections))
#:file-mode (if (plt-files-replace) 'file-replace 'file)
#:plt-relative? (or (plt-files-plt-relative?)
(plt-files-plt-home-relative?))
#:at-plt-home? (plt-files-plt-home-relative?)
#:test-plt-dirs (if (or (plt-force-install-dir?)
(not (plt-files-plt-home-relative?)))
#f
'("collects" "doc" "include" "lib"))
#:requires
;; Get current version of mzscheme for require:
(let* ([i (get-info '("mzscheme"))]
[v (and i (i 'version (lambda () #f)))])
(list (list '("mzscheme") v))))
(when (verbose)
(printf " [output to \"~a\"]\n" plt-output)))
;; Collection
(begin
(pack-collections-plt
plt-output
(if (eq? default-plt-name (plt-name)) #f (plt-name))
(map (lambda (sf)
(let loop ([sf sf])
(let ([m (regexp-match "^([^/]*)/(.*)$" sf)])
(if m (cons (cadr m) (loop (caddr m))) (list sf)))))
source-files)
#:replace? (plt-files-replace)
#:extra-setup-collections (map list (plt-setup-collections))
#:file-filter (if (plt-include-compiled)
(lambda (path)
(or (regexp-match #rx#"compiled$" (path->bytes path))
(std-filter path)))
std-filter)
#:at-plt-home? (plt-files-plt-home-relative?)
#:test-plt-collects? (not (plt-force-install-dir?)))
(when (verbose)
(printf " [output to \"~a\"]\n" plt-output))))

6
collects/compiler/decompile.ss
View File

@ -207,9 +207,9 @@
,@(map (lambda (lam)
(decompile-lam lam globs stack closed))
lams))]
[(struct let-one (rhs body flonum?))
[(struct let-one (rhs body flonum? unused?))
(let ([id (or (extract-id rhs)
(gensym 'local))])
(gensym (if unused? 'unused 'local)))])
`(let ([,id ,(let ([v (decompile-expr rhs globs (cons id stack) closed)])
(if flonum?
(list '#%as-flonum v)
@ -336,7 +336,7 @@
bitwise-bit-set? char=?
+ - * / quotient remainder min max bitwise-and bitwise-ior bitwise-xor
arithmetic-shift vector-ref string-ref bytes-ref
set-mcar! set-mcdr! cons mcons
set-mcar! set-mcdr! cons mcons set-box!
list list* vector vector-immutable))]
[(4) (memq (car a) '(vector-set! string-set! bytes-set!
list list* vector vector-immutable

33
collects/compiler/distribute.ss
View File

@ -75,9 +75,11 @@
(let* ([specific-lib-dir
(build-path "lib"
"plt"
(let-values ([(base name dir?)
(split-path (car binaries))])
(path-replace-suffix name #"")))]
(if (null? binaries)
"generic"
(let-values ([(base name dir?)
(split-path (car binaries))])
(path-replace-suffix name #""))))]
[relative-collects-dir
(or collects-path
(build-path specific-lib-dir
@ -120,18 +122,19 @@
(collects-path->bytes
(relative->binary-relative sub-dir type relative-collects-dir))))
binaries types sub-dirs)
;; Copy over extensions and adjust embedded paths:
(copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir
relative-exts-dir
relative->binary-relative)
;; Copy over runtime files and adjust embedded paths:
(copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir
relative-exts-dir
relative->binary-relative)
;; Done!
(void)))))
(unless (null? binaries)
;; Copy over extensions and adjust embedded paths:
(copy-extensions-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir
relative-exts-dir
relative->binary-relative)
;; Copy over runtime files and adjust embedded paths:
(copy-runtime-files-and-patch-binaries orig-binaries binaries types sub-dirs
exts-dir
relative-exts-dir
relative->binary-relative)
;; Done!
(void))))))
(define (install-libs lib-dir types)
(case (system-type)

87
collects/compiler/embed-unit.ss
View File

@ -71,7 +71,7 @@
(lambda ()
(error 'create-embedding-executable
"can't find ~a executable for variant ~a"
(if mred? "MrEd" "MzScheme")
(if mred? "GRacket" "Racket")
variant))])
(let ([exe (build-path
base
@ -80,22 +80,22 @@
(cond
[(not mred?)
;; Need MzScheme:
(string-append "mzscheme" (variant-suffix variant #f))]
(string-append "racket" (variant-suffix variant #f))]
[mred?
;; Need MrEd:
(let ([sfx (variant-suffix variant #t)])
(build-path (format "MrEd~a.app" sfx)
(build-path (format "GRacket~a.app" sfx)
"Contents" "MacOS"
(format "MrEd~a" sfx)))])]
(format "GRacket~a" sfx)))])]
[(windows)
(format "~a~a.exe" (if mred?
"MrEd"
"MzScheme")
"Gracket"
"Racket")
(variant-suffix variant #t))]
[(unix)
(format "~a~a" (if mred?
"mred"
"mzscheme")
"gracket"
"racket")
(variant-suffix variant #f))]))])
(unless (or (file-exists? exe)
(directory-exists? exe))
@ -746,21 +746,19 @@
;; Write a module bundle that can be loaded with 'load' (do not embed it
;; into an executable). The bundle is written to the current output port.
(define (do-write-module-bundle outp verbose? modules literal-files literal-expressions collects-dest
(define (do-write-module-bundle outp verbose? modules config? literal-files literal-expressions collects-dest
on-extension program-name compiler expand-namespace
src-filter get-extra-imports)
(let* ([module-paths (map cadr modules)]
[files (map
(lambda (mp)
(let ([f (resolve-module-path mp #f)])
(unless f
(error 'write-module-bundle "bad module path: ~e" mp))
(normalize f)))
module-paths)]
[collapsed-mps (map
(lambda (mp)
(collapse-module-path mp (build-path (current-directory) "dummy.ss")))
module-paths)]
[resolve-one-path (lambda (mp)
(let ([f (resolve-module-path mp #f)])
(unless f
(error 'write-module-bundle "bad module path: ~e" mp))
(normalize f)))]
[files (map resolve-one-path module-paths)]
[collapse-one (lambda (mp)
(collapse-module-path mp (build-path (current-directory) "dummy.ss")))]
[collapsed-mps (map collapse-one module-paths)]
[prefix-mapping (map (lambda (f m)
(cons f (let ([p (car m)])
(cond
@ -774,13 +772,29 @@
files modules)]
;; Each element is created with `make-mod'.
;; As we descend the module tree, we append to the front after
;; loasing imports, so the list in the right order.
[codes (box null)])
(for-each (lambda (f mp) (get-code f mp codes prefix-mapping verbose? collects-dest
;; loading imports, so the list in the right order.
[codes (box null)]
[get-code-at (lambda (f mp)
(get-code f mp codes prefix-mapping verbose? collects-dest
on-extension compiler expand-namespace
get-extra-imports))
files
collapsed-mps)
get-extra-imports))]
[__
;; Load all code:
(for-each get-code-at files collapsed-mps)]
[config-infos (if config?
(let ([a (assoc (car files) (unbox codes))])
(let ([info (module-compiled-language-info (mod-code a))])
(when info
(let ([get-info ((dynamic-require (vector-ref info 0) (vector-ref info 1))
(vector-ref info 2))])
(get-info 'configure-runtime null)))))
null)])
;; Add module for runtime configuration:
(when config-infos
(for ([config-info (in-list config-infos)])
(let ([mp (vector-ref config-info 0)])
(get-code-at (resolve-one-path mp)
(collapse-one mp)))))
;; Drop elements of `codes' that just record copied libs:
(set-box! codes (filter mod-code (unbox codes)))
;; Bind `module' to get started:
@ -917,6 +931,13 @@
(write (compile-using-kernel '(namespace-set-variable-value! 'module #f #t)) outp)
(write (compile-using-kernel '(namespace-undefine-variable! 'module)) outp)
(newline outp)
(when config-infos
(for ([config-info (in-list config-infos)])
(let ([a (assoc (resolve-one-path (vector-ref config-info 0)) (unbox codes))])
(write (compile-using-kernel `((dynamic-require '',(mod-full-name a)
',(vector-ref config-info 1))
',(vector-ref config-info 2)))
outp))))
(for-each (lambda (f)
(when verbose?
(fprintf (current-error-port) "Copying from ~s~n" f))
@ -928,6 +949,7 @@
(define (write-module-bundle #:verbose? [verbose? #f]
#:modules [modules null]
#:configure-via-first-module? [config? #f]
#:literal-files [literal-files null]
#:literal-expressions [literal-expressions null]
#:on-extension [on-extension #f]
@ -937,7 +959,7 @@
(compile expr)))]
#:src-filter [src-filter (lambda (filename) #f)]
#:get-extra-imports [get-extra-imports (lambda (filename code) null)])
(do-write-module-bundle (current-output-port) verbose? modules literal-files literal-expressions
(do-write-module-bundle (current-output-port) verbose? modules config? literal-files literal-expressions
#f ; collects-dest
on-extension
"?" ; program-name
@ -967,9 +989,11 @@
;; Use `write-module-bundle', but figure out how to put it into an executable
(define (create-embedding-executable dest
#:mred? [mred? #f]
#:mred? [really-mred? #f]
#:gracket? [gracket? #f]
#:verbose? [verbose? #f]
#:modules [modules null]
#:configure-via-first-module? [config? #f]
#:literal-files [literal-files null]
#:literal-expression [literal-expression #f]
#:literal-expressions [literal-expressions
@ -989,6 +1013,7 @@
(compile expr)))]
#:src-filter [src-filter (lambda (filename) #f)]
#:get-extra-imports [get-extra-imports (lambda (filename code) null)])
(define mred? (or really-mred? gracket?))
(define keep-exe? (and launcher?
(let ([m (assq 'forget-exe? aux)])
(or (not m)
@ -1065,8 +1090,8 @@
(when (regexp-match #rx"^@executable_path"
(get-current-framework-path dest
(if mred?
"PLT_MrEd"
"PLT_MzScheme")))
"GRacket"
"Racket")))
(update-framework-path (string-append
(path->string (find-lib-dir))
"/")
@ -1086,7 +1111,7 @@
(let ([write-module
(lambda (s)
(do-write-module-bundle s
verbose? modules literal-files literal-expressions collects-dest
verbose? modules config? literal-files literal-expressions collects-dest
on-extension
(file-name-from-path dest)
compiler

1
collects/compiler/main.ss
View File

@ -569,6 +569,7 @@
#:modules (cons `(#%mzc: (file ,(car source-files)))
(map (lambda (l) `(#t (lib ,l)))
(exe-embedded-libraries)))
#:configure-via-first-module? #t
#:literal-expression
(parameterize ([current-namespace (make-base-namespace)])
(compile

4
collects/compiler/private/macfw.ss
View File

@ -37,8 +37,8 @@
#"$"))
(string->bytes/utf-8 new-path))))
(if mred?
'("PLT_MrEd")
'("PLT_MzScheme")))))
'("GRacket")
'("Racket")))))
(define (get-current-framework-path dest p)
(let ([v (get/set-dylib-path dest

25
collects/compiler/zo-marshal.ss
View File

@ -160,7 +160,7 @@
[(struct case-lam (name lams))
(traverse-data name visit)
(for-each (lambda (lam) (traverse-lam lam visit)) lams)]
[(struct let-one (rhs body flonum?))
[(struct let-one (rhs body flonum? unused?))
(traverse-expr rhs visit)
(traverse-expr body visit)]
[(struct let-void (count boxes? body))
@ -247,11 +247,11 @@
(define wcm-type-num 14)
(define quote-syntax-type-num 15)
(define variable-type-num 24)
(define top-type-num 87)
(define case-lambda-sequence-type-num 96)
(define begin0-sequence-type-num 97)
(define module-type-num 100)
(define prefix-type-num 102)
(define top-type-num 89)
(define case-lambda-sequence-type-num 99)
(define begin0-sequence-type-num 100)
(define module-type-num 103)
(define prefix-type-num 105)
(define-syntax define-enum
(syntax-rules ()
@ -297,7 +297,8 @@
CPT_PATH
CPT_CLOSURE
CPT_DELAY_REF
CPT_PREFAB)
CPT_PREFAB
CPT_LET_ONE_UNUSED)
(define-enum
0
@ -314,7 +315,7 @@
APPVALS_EXPD
SPLICE_EXPD)
(define CPT_SMALL_NUMBER_START 35)
(define CPT_SMALL_NUMBER_START 36)
(define CPT_SMALL_NUMBER_END 60)
(define CPT_SMALL_SYMBOL_START 60)
@ -715,8 +716,12 @@
(cons (or name null)
lams)
out)]
[(struct let-one (rhs body flonum?))
(out-byte (if flonum? CPT_LET_ONE_FLONUM CPT_LET_ONE) out)
[(struct let-one (rhs body flonum? unused?))
(out-byte (cond
[flonum? CPT_LET_ONE_FLONUM]
[unused? CPT_LET_ONE_UNUSED]
[else CPT_LET_ONE])
out)
(out-expr (protect-quote rhs) out)
(out-expr (protect-quote body) out)]
[(struct let-void (count boxes? body))

16
collects/compiler/zo-parse.ss
View File

@ -314,10 +314,10 @@
[(15) 'quote-syntax-type]
[(24) 'variable-type]
[(25) 'module-variable-type]
[(96) 'case-lambda-sequence-type]
[(97) 'begin0-sequence-type]
[(100) 'module-type]
[(102) 'resolve-prefix-type]
[(99) 'case-lambda-sequence-type]
[(100) 'begin0-sequence-type]
[(103) 'module-type]
[(105) 'resolve-prefix-type]
[else (error 'int->type "unknown type: ~e" i)]))
(define type-readers
@ -412,7 +412,8 @@
[32 closure]
[33 delayed]
[34 prefab]
[35 60 small-number]
[35 let-one-unused]
[36 60 small-number]
[60 80 small-symbol]
[80 92 small-marshalled]
[92 ,(+ 92 small-list-max) small-proper-list]
@ -766,9 +767,10 @@
(if ppr null (read-compact cp)))
(read-compact-list l ppr cp))
(loop l ppr)))]
[(let-one let-one-flonum)
[(let-one let-one-flonum let-one-unused)
(make-let-one (read-compact cp) (read-compact cp)
(eq? cpt-tag 'let-one-flonum))]
(eq? cpt-tag 'let-one-flonum)
(eq? cpt-tag 'let-one-unused))]
[(branch)
(make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
[(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]

2
collects/compiler/zo-structs.ss
View File

@ -118,7 +118,7 @@
(define-form-struct (closure expr) ([code lam?] [gen-id symbol?])) ; a static closure (nothing to close over)
(define-form-struct (case-lam expr) ([name (or/c symbol? vector? empty?)] [clauses (listof (or/c lam? indirect?))])) ; each clause is a lam (added indirect)
(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?])) ; pushes one value onto stack
(define-form-struct (let-one expr) ([rhs (or/c expr? seq? indirect? any/c)] [body (or/c expr? seq? indirect? any/c)] [flonum? boolean?] [unused? boolean?])) ; pushes one value onto stack
(define-form-struct (let-void expr) ([count exact-nonnegative-integer?] [boxes? boolean?] [body (or/c expr? seq? indirect? any/c)])) ; create new stack slots
(define-form-struct (install-value expr) ([count exact-nonnegative-integer?]
[pos exact-nonnegative-integer?]

35
collects/deinprogramm/contract/contract-syntax.ss
View File

@ -83,7 +83,8 @@
#'(contract-update-syntax contract/contract #'?loc)))
(?id
(identifier? #'?id)
(with-syntax ((?stx (phase-lift stx)))
(with-syntax ((?stx (phase-lift stx))
(?name name))
(let ((name (symbol->string (syntax->datum #'?id))))
(if (char=? #\% (string-ref name 0))
#'(make-type-variable-contract '?id ?stx)
@ -91,13 +92,19 @@
((?raise
(syntax/loc #'?stx
(error 'contracts "expected a contract, found ~e" ?id))))
#'(make-delayed-contract '?name
(delay
(begin
(when (not (contract? ?id))
?raise)
(contract-update-syntax ?id ?stx)))
#'?stx))))))
(with-syntax
((?ctr
#'(make-delayed-contract '?name
(delay
(begin
(when (not (contract? ?id))
?raise)
?id)))))
;; for local variables (parameters, most probably),
;; we want the value to determine the blame location
(if (eq? (identifier-binding #'?id) 'lexical)
#'?ctr
#'(contract-update-syntax ?ctr #'?stx))))))))
((combined ?contract ...)
(with-syntax ((?stx (phase-lift stx))
(?name name)
@ -118,14 +125,16 @@
((?contract-abstr ?contract ...)
(identifier? #'?contract-abstr)
(with-syntax ((?stx (phase-lift stx))
(?name name)
((?contract-expr ...) (map (lambda (ctr)
(parse-contract #f ctr))
(syntax->list #'(?contract ...)))))
(with-syntax
((?call (syntax/loc stx (?contract-abstr ?contract-expr ...))))
#'(make-delayed-contract '?name
(delay ?call)
?stx))))
#'(make-call-contract '?name
(delay ?call)
(delay ?contract-abstr) (delay (list ?contract-expr ...))
?stx))))
(else
(raise-syntax-error 'contract
"ungültiger Vertrag" stx))))
@ -175,7 +184,7 @@
(syntax-case stx ()
((_ ?name ?cnt ?expr)
(with-syntax ((?enforced
(stepper-syntax-property #'(attach-name '?name (apply-contract/blame (contract ?cnt) ?expr))
(stepper-syntax-property #'(attach-name '?name (apply-contract/blame ?cnt ?expr))
'stepper-skipto/discard
;; apply-contract/blame takes care of itself
;; remember there's an implicit #%app
@ -205,7 +214,7 @@
((?id ?cnt)
(identifier? #'?id)
(cons #'?id
#'(attach-name '?id (apply-contract/blame (contract ?cnt) ?id))))))
#'(attach-name '?id (apply-contract/blame ?cnt ?id))))))
(syntax->list #'(?bind ...)))))
(with-syntax (((?id ...) (map car ids+enforced))
((?enforced ...) (map cdr ids+enforced)))

249
collects/deinprogramm/contract/contract.ss
View File

@ -3,9 +3,11 @@
(provide contract?
contract-name contract-syntax
contract-arbitrary set-contract-arbitrary!
contract-violation-proc
call-with-contract-violation-proc
contract-info-promise
contract-violation
contract-violation-proc call-with-contract-violation-proc
make-delayed-contract
make-call-contract
make-property-contract
make-predicate-contract
make-type-variable-contract
@ -14,21 +16,56 @@
make-combined-contract
make-case-contract
make-procedure-contract
contract-update-syntax
apply-contract apply-contract/blame)
contract-update-syntax contract-update-info-promise
apply-contract apply-contract/blame
procedure-contract-info?
procedure-contract-info-arg-contracts procedure-contract-info-return-contract
make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors
prop:lazy-wrap lazy-wrap-ref
make-struct-wrap-contract
check-struct-wraps!
contract=? contract<=?)
(require scheme/promise
mzlib/struct
(for-syntax scheme/base)
(for-syntax stepper/private/shared))
(require deinprogramm/quickcheck/quickcheck)
(define (contract=? c1 c2)
(or (eq? c1 c2)
(eq? (contract-enforcer c1) (contract-enforcer c2))
(and (contract-=?-proc c1)
((contract-=?-proc c1)
(force (contract-info-promise c1))
(force (contract-info-promise c2))))))
; name may be #f
; enforcer: contract val -> val
;
; syntax: syntax data from where the contract was defined
(define-struct contract (name enforcer syntax (arbitrary-promise #:mutable)))
(define-struct contract (name enforcer syntax-promise (arbitrary-promise #:mutable) info-promise <=?-proc =?-proc)
#:constructor-name really-make-contract
#:transparent ; #### for debugging, remove
#:property prop:equal+hash
(list (lambda (c1 c2 equal?) (contract=? c1 c2)) ; #### use equal?
void void)) ; hash procs
(define (make-contract name enforcer syntax-promise
#:arbitrary-promise (arbitrary-promise #f)
#:info-promise (info-promise (delay #f))
#:<=?-proc (<=?-proc
(lambda (this-info other-info)
#f))
#:=?-proc (=?-proc
(lambda (this-info other-info)
#f)))
(really-make-contract name enforcer syntax-promise arbitrary-promise info-promise <=?-proc =?-proc))
(define (contract-syntax ctr)
(force (contract-syntax-promise ctr)))
(define (contract-arbitrary ctr)
(force (contract-arbitrary-promise ctr)))
@ -37,7 +74,11 @@
(set-contract-arbitrary-promise! ctr (delay arb)))
(define (contract-update-syntax ctr stx)
(struct-copy contract ctr (syntax stx)))
(struct-copy contract ctr (syntax-promise (delay stx))))
;; it's a promise because of ordering constraints in the structs
(define (contract-update-info-promise ctr inf)
(struct-copy contract ctr (info-promise inf)))
; message may be #f
(define contract-violation-proc (make-parameter (lambda (obj contract message blame)
@ -52,13 +93,45 @@
(parameterize ((contract-violation-proc proc))
(thunk)))
(define (make-delayed-contract name promise syntax)
(define (make-delayed-contract name promise)
(make-contract name
(lambda (self obj)
((contract-enforcer (force promise)) self obj))
syntax
(delay (contract-syntax (force promise)))
#:arbitrary-promise
(delay
(force (contract-arbitrary-promise (force promise))))))
(force (contract-arbitrary-promise (force promise))))
#:info-promise
(delay
(force (contract-info-promise (force promise))))
#:<=?-proc
(lambda (this-info other-info)
((contract-<=?-proc (force promise)) this-info other-info))
#:=?-proc
(lambda (this-info other-info)
((contract-=?-proc (force promise)) this-info other-info))))
; specialized version of the above, supports comparison
; the promise must produce the result of (proc . args), but its passed separately
; to give us the right location on backtrace
(define (make-call-contract name promise proc-promise args-promise syntax)
(make-contract name
(lambda (self obj)
((contract-enforcer (force promise)) self obj))
(delay syntax)
#:arbitrary-promise
(delay
(force (contract-arbitrary-promise (force promise))))
#:info-promise
(delay
(make-call-info (force proc-promise) (force args-promise)))
#:=?-proc
(lambda (this-info other-info)
(and (call-info? other-info)
(eqv? (force proc-promise) (call-info-proc other-info))
(equal? (force args-promise) (call-info-args other-info))))))
(define-struct call-info (proc args) #:transparent)
(define (make-property-contract name access contract syntax)
(let ((enforce (contract-enforcer contract)))
@ -66,8 +139,7 @@
(lambda (self obj)
(enforce self (access obj)) ; #### problematic: enforcement doesn't stick
obj)
syntax
#f)))
syntax)))
(define (make-predicate-contract name predicate-promise syntax)
(make-contract
@ -78,11 +150,29 @@
(begin
(contract-violation obj self #f #f)
obj)))
syntax
#f))
(delay syntax)
#:info-promise
(delay (make-predicate-info (force predicate-promise)))
#:=?-proc
(lambda (this-info other-info)
(and (predicate-info? other-info)
(eq? (force predicate-promise)
(predicate-info-predicate other-info))))))
(define-struct predicate-info (predicate) #:transparent)
(define (make-type-variable-contract name syntax)
(make-predicate-contract name (lambda (obj) #t) syntax))
(make-contract
name
(lambda (self obj) obj)
(delay syntax)
#:info-promise
(delay (make-type-variable-info))
#:=?-proc
(lambda (this-info other-info)
(type-variable-info? other-info))))
(define-struct type-variable-info ())
; maps lists to pairs of contract, enforced value
(define lists-table (make-weak-hasheq))
@ -116,8 +206,17 @@
(else
(go-on)))))
syntax
#:arbitrary-promise
(delay
(lift->arbitrary arbitrary-list arg-contract))))
(lift->arbitrary arbitrary-list arg-contract))
#:info-promise
(delay (make-list-info arg-contract))
#:=?-proc
(lambda (this-info other-info)
(and (list-info? other-info)
(contract=? arg-contract (list-info-arg-contract other-info))))))
(define-struct list-info (arg-contract) #:transparent)
(define (lift->arbitrary proc . contracts)
(let ((arbitraries (map force (map contract-arbitrary-promise contracts))))
@ -147,7 +246,8 @@
obj
values
(lambda () (loop (cdr alternative-contracts))))))))
syntax
(delay syntax)
#:arbitrary-promise
(delay
(let ((arbitraries (map force (map contract-arbitrary-promise alternative-contracts))))
(if (andmap values arbitraries)
@ -191,8 +291,7 @@
(lambda () obj)
(loop (cdr contracts)
(apply-contract (car contracts) obj))))))))))
syntax
#f))
(delay syntax)))
(define (make-case-contract name cases =? syntax)
(make-contract
@ -207,13 +306,16 @@
obj)
(else
(loop (cdr cases))))))
syntax
(delay syntax)
#:arbitrary-promise
(delay (apply arbitrary-one-of =? cases))))
(define-struct procedure-to-blame (proc syntax))
(define contract-key (gensym 'contract-key))
(define-struct procedure-contract-info (arg-contracts return-contract) #:transparent)
(define (make-procedure-contract name arg-contracts return-contract syntax)
(let ((arg-count (length arg-contracts)))
(make-contract
@ -265,9 +367,13 @@
(lambda ()
(apply-contract return-contract retval)))))))))))
(procedure-arity proc)))))))
syntax
(delay syntax)
#:arbitrary-promise
(delay
(apply lift->arbitrary arbitrary-procedure return-contract arg-contracts)))))
(apply lift->arbitrary arbitrary-procedure return-contract arg-contracts))
#:info-promise
(delay
(make-procedure-contract-info arg-contracts return-contract)))))
(define (attach-name name thing)
(if (and (procedure? thing)
@ -275,6 +381,96 @@
(procedure-rename thing name)
thing))
; Lazy contract checking for structs
;; This is attached prop:lazy-wrap property of struct types subject to
;; lazy checking.
(define-struct lazy-wrap-info
(constructor
raw-accessors raw-mutators
;; procedures for referencing or setting an additional field within the struct
;; that field contains a list of lists of unchecked field contracts
ref-proc set!-proc))
; value should be a lazy-wrap-info
(define-values (prop:lazy-wrap lazy-wrap lazy-wrap-ref)
(make-struct-type-property 'lazy-wrap))
(define (make-struct-wrap-contract name type-descriptor field-contracts syntax)
(let ((lazy-wrap-info (lazy-wrap-ref type-descriptor))
(struct-wrap-info (make-struct-wrap-info type-descriptor field-contracts))
(predicate (lambda (thing)
(and (struct? thing)
(let-values (((thing-descriptor _) (struct-info thing)))
(eq? thing-descriptor type-descriptor))))))
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
(make-contract
name
(lambda (self thing)
(cond
((not (predicate thing))
(contract-violation thing self #f #f)
thing)
((ormap (lambda (wrap-field-contracts)
(andmap contract<=?
wrap-field-contracts
field-contracts))
(wrap-ref thing))
thing)
(else
(wrap-set! thing
(cons field-contracts (wrap-ref thing)))
thing)))
(delay syntax)
#:info-promise
(delay struct-wrap-info)
#:=?-proc
(lambda (this-info other-info)
(and (struct-wrap-info? other-info)
(struct-wrap-info-field-contracts other-info)
(eq? type-descriptor (struct-wrap-info-descriptor other-info))
(andmap contract=?
field-contracts
(struct-wrap-info-field-contracts other-info))))
#:<=?-proc
(lambda (this-info other-info)
(and (struct-wrap-info? other-info)
(struct-wrap-info-field-contracts other-info)
(eq? type-descriptor (struct-wrap-info-descriptor other-info))
(andmap contract<=?
field-contracts
(struct-wrap-info-field-contracts other-info))))))))
(define-struct struct-wrap-info (descriptor field-contracts))
(define (check-struct-wraps! thing)
(let-values (((descriptor skipped?) (struct-info thing)))
(let ((lazy-wrap-info (lazy-wrap-ref descriptor)))
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info))
(raw-mutators (lazy-wrap-info-raw-mutators lazy-wrap-info))
(wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info))
(wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info)))
(when (pair? (wrap-ref thing)) ; fast path
(let loop ((field-vals (map (lambda (raw-accessor)
(raw-accessor thing))
raw-accessors))
(field-contracts-list (wrap-ref thing)))
(if (null? field-contracts-list)
(begin
(for-each (lambda (raw-mutator field-val)
(raw-mutator thing field-val))
raw-mutators field-vals)
(wrap-set! thing '()))
(loop (map apply-contract (car field-contracts-list) field-vals)
(cdr field-contracts-list)))))))))
; like apply-contract, but can track more precise blame into the contract itself
(define-syntax apply-contract/blame
(lambda (stx)
@ -306,3 +502,14 @@
(define (apply-contract contract val)
((contract-enforcer contract) contract val))
; "do the values that fulfill c1 also fulfill c2?"
(define (contract<=? c1 c2)
(or (contract=? c1 c2)
(let ((i1 (force (contract-info-promise c1)))
(i2 (force (contract-info-promise c2))))
(or (type-variable-info? i2) ; kludge, maybe dispatch should be on second arg
(and i1 i2
((contract-<=?-proc c1) i1 i2))))))

18
collects/deinprogramm/contract/module-begin.ss
View File

@ -86,15 +86,15 @@
((define-values (?id ...) ?e1)
(with-syntax (((?enforced ...)
(map (lambda (id)
(with-syntax ((?id id))
(cond
((bound-identifier-mapping-get contract-table #'?id (lambda () #f))
=> (lambda (cnt)
(bound-identifier-mapping-put! contract-table #'?id #f) ; check for orphaned contracts
(with-syntax ((?cnt cnt))
#'(?id ?cnt))))
(else
#'?id))))
(cond
((bound-identifier-mapping-get contract-table id (lambda () #f))
=> (lambda (cnt)
(bound-identifier-mapping-put! contract-table id #f) ; check for orphaned contracts
(with-syntax ((?id id)
(?cnt cnt))
#'(?id (contract ?cnt)))))
(else
id)))
(syntax->list #'(?id ...))))
(?rest (loop (cdr exprs))))
(with-syntax ((?defn

29
collects/deinprogramm/convert-explicit.scm
View File

@ -1,4 +1,4 @@
;; I HATE DEFINE-STRUCT!
; I HATE DEFINE-STRUCT!
(define-struct/properties :empty-list ()
((prop:custom-write
(lambda (r port write?)
@ -72,21 +72,20 @@
(else
(cons (recur (car v))
(list-recur (cdr v))))))))
((deinprogramm-struct? v)
((struct? v)
(or (hash-ref hash v #f)
(let*-values (((ty skipped?) (struct-info v))
((name-symbol
init-field-k auto-field-k accessor-proc mutator-proc immutable-k-list
super-struct-type skipped?)
(struct-type-info ty)))
(let* ((indices (iota (+ init-field-k auto-field-k)))
(val (apply (struct-type-make-constructor ty) indices)))
(hash-set! hash v val)
(for-each (lambda (index)
(mutator-proc val index
(recur (accessor-proc v index))))
indices)
val))))
(let-values (((ty skipped?) (struct-info v)))
(cond
((and ty (lazy-wrap-ref ty))
=> (lambda (lazy-wrap-info)
(let ((constructor (lazy-wrap-info-constructor lazy-wrap-info))
(raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)))
(let ((val (apply constructor (map (lambda (raw-accessor)
(recur (raw-accessor v)))
raw-accessors))))
(hash-set! hash v val)
val))))
(else v)))))
(else
v)))))

5
collects/deinprogramm/convert-explicit.ss
View File

@ -2,10 +2,9 @@
(provide convert-explicit)
(require mzlib/pretty
mzlib/struct
(only-in srfi/1 iota))
mzlib/struct)
(require deinprogramm/deinprogramm-struct)
(require deinprogramm/contract/contract)
(require scheme/include)
(include "convert-explicit.scm")

278
collects/deinprogramm/define-record-procedures.scm
View File

@ -27,13 +27,15 @@
(lambda (x)
(syntax-case x ()
((_ ?type-name
?mutable?
?contract-constructor-name
?constructor
?predicate
(?field-spec ...))
(with-syntax
(((accessor ...)
((number-of-fields (length (syntax->list (syntax (?field-spec ...)))))
((accessor ...)
(map (lambda (field-spec)
(syntax-case field-spec ()
((accessor mutator) (syntax accessor))
@ -47,129 +49,151 @@
(syntax->list (syntax (?field-spec ...)))
(generate-temporaries (syntax (?field-spec ...))))))
(with-syntax
((number-of-fields (length (syntax->list
(syntax (accessor ...)))))
(generic-access (syntax generic-access))
(generic-mutate (syntax generic-mutate)))
(with-syntax
(((accessor-proc ...)
(map-with-index
(lambda (i accessor)
(with-syntax ((i i)
(tag accessor))
(syntax-property (syntax/loc
accessor
(lambda (s)
(when (not (?predicate s))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: Argument kein ~a: ~e"
'tag '?type-name s))
(current-continuation-marks))))
(generic-access s i)))
'inferred-name
(syntax-e accessor))))
(syntax->list (syntax (accessor ...)))))
((our-accessor ...) (generate-temporaries #'(accessor ...)))
((mutator-proc ...)
(map-with-index
(lambda (i mutator)
(with-syntax ((i i)
(tag mutator))
(syntax-property (syntax/loc
mutator
(lambda (s v)
(when (not (?predicate s))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: Argument kein ~a: ~e"
'tag '?type-name s))
(current-continuation-marks))))
(generic-mutate s i v)))
'inferred-name
(syntax-e mutator))))
(syntax->list (syntax (mutator ...)))))
(constructor-proc
(syntax-property (syntax
(lambda (accessor ...)
(?constructor accessor ...)))
'inferred-name
(syntax-e (syntax ?constructor))))
(predicate-proc
(syntax-property (syntax
(lambda (thing)
(?predicate thing)))
'inferred-name
(syntax-e (syntax ?predicate))))
(constructor-name (syntax ?constructor)))
(with-syntax
((defs
#'(define-values (?constructor
?predicate real-predicate
accessor ...
our-accessor ...
mutator ...)
(letrec-values (((type-descriptor
?constructor
?predicate
generic-access
generic-mutate)
(make-struct-type
'?type-name #f number-of-fields 0
#f
(list
(cons prop:print-convert-constructor-name
'constructor-name)
(cons prop:deinprogramm-struct
#t)
(cons prop:custom-write
(lambda (r port write?)
(custom-write-record '?type-name
(access-record-fields r generic-access number-of-fields)
port write?))))
(make-inspector))))
(values constructor-proc
predicate-proc predicate-proc
accessor-proc ...
accessor-proc ...
mutator-proc ...))))
(contract
(with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...))))
(with-syntax (((component-contract ...)
(map (lambda (accessor param)
(with-syntax ((?accessor accessor)
(?param param))
#'(at ?param (property ?accessor ?param))))
(syntax->list #'(our-accessor ...))
(syntax->list #'(?param ...)))))
(with-syntax ((base-contract
(stepper-syntax-property
#'(define ?type-name (contract (predicate real-predicate)))
'stepper-skip-completely
#t))
(constructor-contract
(stepper-syntax-property
#'(define (?contract-constructor-name ?param ...)
(contract
(combined (at ?type-name (predicate real-predicate))
component-contract ...)))
'stepper-skip-completely
#t)))
#'(begin
;; we use real-predicate to avoid infinite recursion if a contract
;; for ?type-name using ?predicate is inadvertently defined
base-contract
constructor-contract))))))
(with-syntax ((defs
(stepper-syntax-property
(syntax/loc x defs) 'stepper-skip-completely #t)))
(((accessor-proc ...)
(map-with-index
(lambda (i accessor)
(with-syntax ((i i)
(tag accessor))
(syntax-property (syntax/loc
accessor
(lambda (s)
(when (not (raw-predicate s))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: Argument kein ~a: ~e"
'tag '?type-name s))
(current-continuation-marks))))
(check-struct-wraps! s)
(raw-generic-access s i)))
'inferred-name
(syntax-e accessor))))
(syntax->list #'(accessor ...))))
((our-accessor ...) (generate-temporaries #'(accessor ...)))
((mutator-proc ...)
(map-with-index
(lambda (i mutator)
(with-syntax ((i i)
(tag mutator))
(syntax-property (syntax/loc
mutator
(lambda (s v)
(when (not (raw-predicate s))
(raise
(make-exn:fail:contract
(string->immutable-string
(format "~a: Argument kein ~a: ~e"
'tag '?type-name s))
(current-continuation-marks))))
(raw-generic-mutate s i v)))
'inferred-name
(syntax-e mutator))))
(syntax->list #'(mutator ...))))
(constructor-proc
(syntax-property #'(lambda (accessor ...)
(raw-constructor accessor ... '()))
'inferred-name
(syntax-e #'?constructor)))
(predicate-proc
(syntax-property #'(lambda (thing)
(raw-predicate thing))
'inferred-name
(syntax-e #'?predicate)))
((raw-accessor-proc ...)
(map-with-index (lambda (i _)
#`(lambda (r)
(raw-generic-access r #,i)))
(syntax->list #'(?field-spec ...))))
((raw-mutator-proc ...)
(map-with-index (lambda (i _)
#`(lambda (r val)
(raw-generic-mutate r #,i val)))
(syntax->list #'(?field-spec ...))))
(record-equal? #`(lambda (r1 r2 equal?)
(and #,@(map-with-index (lambda (i field-spec)
#`(equal? (raw-generic-access r1 #,i)
(raw-generic-access r2 #,i)))
(syntax->list #'(?field-spec ...)))))))
#'(begin
contract
;; the contract might be used in the definitions, hence this ordering
defs)))))))
(with-syntax
((defs
#'(begin
(define-values (type-descriptor
raw-constructor
raw-predicate
raw-generic-access
raw-generic-mutate)
(make-struct-type
'?type-name #f (+ 1 number-of-fields) 0
#f
(list
(cons prop:print-convert-constructor-name
'?constructor)
(cons prop:custom-write
(lambda (r port write?)
(custom-write-record '?type-name
(access-record-fields r raw-generic-access number-of-fields)
port write?)))
(cons prop:equal+hash
(list record-equal? void void))
(cons prop:lazy-wrap
(make-lazy-wrap-info constructor-proc
(list raw-accessor-proc ...)
(list raw-mutator-proc ...)
(lambda (r)
(raw-generic-access r number-of-fields))
(lambda (r val)
(raw-generic-mutate r number-of-fields val)))))
(make-inspector)))
(define ?constructor constructor-proc)
(define-values (?predicate real-predicate)
(values predicate-proc predicate-proc))
(define-values (accessor ... our-accessor ...)
(values accessor-proc ... accessor-proc ...))
(define mutator mutator-proc) ...))
(contract
(with-syntax (((?param ...) (generate-temporaries #'(?field-spec ...))))
(with-syntax (((component-contract ...)
(map (lambda (accessor param)
(with-syntax ((?accessor accessor)
(?param param))
#'(at ?param (property ?accessor ?param))))
(syntax->list #'(our-accessor ...))
(syntax->list #'(?param ...)))))
(with-syntax ((base-contract
(stepper-syntax-property
#'(define ?type-name
(contract (predicate real-predicate)))
'stepper-skip-completely
#t))
(constructor-contract
(stepper-syntax-property
(if (syntax->datum #'?mutable?)
;; no lazy contracts
#'(define (?contract-constructor-name ?param ...)
(contract
(combined (at ?type-name (predicate real-predicate))
component-contract ...)))
;; lazy contracts
#'(define (?contract-constructor-name ?param ...)
(make-struct-wrap-contract '?type-name type-descriptor (list ?param ...) #'?type-name)))
'stepper-skip-completely
#t)))
#'(begin
;; we use real-predicate to avoid infinite recursion if a contract
;; for ?type-name using ?predicate is inadvertently defined
base-contract
constructor-contract))))))
(with-syntax ((defs
(stepper-syntax-property
(syntax/loc x defs) 'stepper-skip-completely #t)))
#'(begin
contract
;; the contract might be used in the definitions, hence this ordering
defs))))))
((_ ?type-name
?contract-constructor-name
@ -295,7 +319,7 @@ prints as:
(with-syntax (((dummy-mutator ...)
(generate-temporaries (syntax (accessor ...)))))
(syntax
(define-record-procedures* ?type-name
(define-record-procedures* ?type-name #f
dummy-contract-constructor-name
?constructor
?predicate
@ -362,7 +386,7 @@ prints as:
(with-syntax (((dummy-mutator ...)
(generate-temporaries (syntax (accessor ...)))))
(syntax
(define-record-procedures* ?type-name ?contract-constructor-name
(define-record-procedures* ?type-name #f ?contract-constructor-name
?constructor
?predicate
((accessor dummy-mutator) ...))))))
@ -424,7 +448,7 @@ prints as:
"Selektor ist kein Bezeichner"))))
(syntax->list (syntax (?field-spec ...))))
#'(define-record-procedures* ?type-name
#'(define-record-procedures* ?type-name #t
dummy-contract-constructor-name
?constructor
?predicate
@ -486,7 +510,7 @@ prints as:
"Selektor ist kein Bezeichner"))))
(syntax->list (syntax (?field-spec ...))))
#'(define-record-procedures* ?type-name ?contract-constructor-name
#'(define-record-procedures* ?type-name #t ?contract-constructor-name
?constructor
?predicate
(?field-spec ...))))

4
collects/deinprogramm/define-record-procedures.ss
View File

@ -6,11 +6,13 @@
define-record-procedures-parametric-2)
(require scheme/include
scheme/promise
mzlib/struct
mzlib/pconvert-prop
mzlib/pretty
deinprogramm/contract/contract
deinprogramm/contract/contract-syntax)
(require deinprogramm/deinprogramm-struct)
(require (for-syntax scheme/base)
(for-syntax deinprogramm/syntax-checkers)
(for-syntax stepper/private/shared))

7
collects/deinprogramm/deinprogramm-langs.ss
View File

@ -21,10 +21,6 @@
wxme/wxme
setup/dirs
;; this module is shared between the drscheme's namespace (so loaded here)
;; and the user's namespace in the teaching languages
"deinprogramm-struct.ss"
lang/stepper-language-interface
lang/debugger-language-interface
lang/run-teaching-program
@ -171,8 +167,6 @@
(define/override (on-execute settings run-in-user-thread)
(let ([drs-namespace (current-namespace)]
[deinprogramm-struct-module-name
((current-module-name-resolver) '(lib "deinprogramm/deinprogramm-struct.ss") #f #f)]
[scheme-test-module-name
((current-module-name-resolver) '(lib "test-engine/scheme-tests.ss") #f #f)]
[scheme-contract-module-name
@ -182,7 +176,6 @@
(read-accept-quasiquote (get-accept-quasiquote?))
(ensure-drscheme-secrets-declared drs-namespace)
(namespace-attach-module drs-namespace ''drscheme-secrets)
(namespace-attach-module drs-namespace deinprogramm-struct-module-name)
(error-display-handler teaching-languages-error-display-handler)
(current-eval (add-annotation (deinprogramm-lang-settings-tracing? settings) (current-eval)))

6
collects/deinprogramm/deinprogramm-struct.ss
View File

@ -1,6 +0,0 @@
#lang scheme/base
(provide prop:deinprogramm-struct
deinprogramm-struct?)
(define-values (prop:deinprogramm-struct deinprogramm-struct? deinprogramm-struct-ref)
(make-struct-type-property 'deinprogramm-struct))

6
collects/deinprogramm/scribblings/DMdA-assignments.scrbl
View File

@ -45,7 +45,11 @@ Mutators sein.
@defform[(define-record-procedures-parametric-2 t cc c p (field-spec1 ...))]{
Diese Form ist wie @scheme[define-record-procedures-2], nur parametrisch
wie @schemeidfont{define-record-procedures-parametric}.}
wie @schemeidfont{define-record-procedures-parametric}. Außerdem
werden die Verträge für die Feldinhalte, anders als bei
@scheme[define-record-procedures-parametric], sofort bei der
Konstruktion überprüft und nicht erst beim Aufruf eines Selektors.
}
@section{@scheme[set!]}

3
collects/deinprogramm/scribblings/DMdA-beginner.scrbl
View File

@ -368,6 +368,9 @@ Beispiel:
Dann ist @scheme[(pare-of integer string)] der Vertrag für
@scheme[pare]-Records, bei dem die Feldinhalte die Verträge
@scheme[integer] bzw. @scheme[string] erfüllen müssen.
Die Verträge für die Feldinhalte werden erst überprüft, wenn ein
Selektor aufgerufen wird.
}
@; ----------------------------------------------------------------------

4
collects/drscheme/info.ss
View File

@ -2,5 +2,9 @@
(define tools '("syncheck.ss" #;"sprof.ss"))
(define tool-names '("Check Syntax" #;"Sampling Profiler"))
(define gracket-launcher-names '("DrRacket"))
(define gracket-launcher-libraries '("drscheme.ss"))
(define mred-launcher-names '("DrScheme"))
(define mred-launcher-libraries '("drscheme.ss"))

10
collects/drscheme/private/drsig.ss
View File

@ -93,7 +93,7 @@
definitions-text-mixin
definitions-text<%>))
(define-signature drscheme:module-language-tools^ extends drscheme:module-language-tools-cm^
())
(add-opt-out-toolbar-button))
(define-signature drscheme:get-collection-cm^ ())
(define-signature drscheme:get-collection^ extends drscheme:get-collection-cm^
@ -329,7 +329,9 @@
(open (prefix drscheme:help-desk: drscheme:help-desk-cm^))
(open (prefix drscheme:eval: drscheme:eval-cm^))
(open (prefix drscheme:modes: drscheme:modes-cm^))
(open (prefix drscheme:tracing: drscheme:tracing-cm^))))
(open (prefix drscheme:tracing: drscheme:tracing-cm^))
(open (prefix drscheme:module-language: drscheme:module-language-cm^))
(open (prefix drscheme:module-language-tools: drscheme:module-language-tools-cm^))))
(define-signature drscheme:tool^
((open (prefix drscheme:debug: drscheme:debug^))
@ -342,4 +344,6 @@
(open (prefix drscheme:help-desk: drscheme:help-desk^))
(open (prefix drscheme:eval: drscheme:eval^))
(open (prefix drscheme:modes: drscheme:modes^))
(open (prefix drscheme:tracing: drscheme:tracing^))))
(open (prefix drscheme:tracing: drscheme:tracing^))
(open (prefix drscheme:module-language: drscheme:module-language^))
(open (prefix drscheme:module-language-tools: drscheme:module-language-tools^))))

8
collects/drscheme/private/link.ss
View File

@ -37,7 +37,9 @@
drscheme:help-desk^
drscheme:eval^
drscheme:modes^
drscheme:tracing^)
drscheme:tracing^
drscheme:module-language^
drscheme:module-language-tools^)
(link init@ tools@ modes@ text@ eval@ frame@ rep@ language@
module-overview@ unit@ debug@ multi-file-search@ get-extend@
language-configuration@ font@ module-language@ module-language-tools@
@ -56,5 +58,7 @@
(prefix drscheme:help-desk: drscheme:help-desk^)
(prefix drscheme:eval: drscheme:eval^)
(prefix drscheme:modes: drscheme:modes^)
(prefix drscheme:tracing: drscheme:tracing^))
(prefix drscheme:tracing: drscheme:tracing^)
(prefix drscheme:module-language: drscheme:module-language^)
(prefix drscheme:module-language-tools: drscheme:module-language-tools^))
drscheme-unit@))

136
collects/drscheme/private/module-language-tools.ss
View File

@ -17,7 +17,15 @@
(export drscheme:module-language-tools^)
(define-local-member-name initialized? move-to-new-language)
(define-struct opt-out-toolbar-button (make-button id))
(define opt-out-toolbar-buttons '())
(define (add-opt-out-toolbar-button make-button id)
(set! opt-out-toolbar-buttons
(cons (make-opt-out-toolbar-button make-button id)
opt-out-toolbar-buttons)))
(define tab<%> (interface ()))
(define tab-mixin
@ -122,23 +130,45 @@
(-> (is-a?/c drscheme:unit:frame<%>) any))))
(info-result 'drscheme:toolbar-buttons #f)
(get-lang-name pos)
'drscheme/private/module-language-tools)))))))
'drscheme/private/module-language-tools)
(info-result 'drscheme:opt-out-toolbar-buttons '())))))))
(inherit get-tab)
(define/private (register-new-buttons buttons)
(when buttons
(let* ([tab (get-tab)]
[frame (send tab get-frame)])
(send tab set-lang-toolbar-buttons
(map (λ (button-spec)
(new switchable-button%
[label (list-ref button-spec 0)]
[bitmap (list-ref button-spec 1)]
[parent (send frame get-toolbar-button-panel)]
[callback
(lambda (button)
((list-ref button-spec 2) frame))]))
buttons)))))
(define/private (register-new-buttons buttons opt-out-ids)
(let* ([tab (get-tab)]
[frame (send tab get-frame)])
(when (send frame initialized?)
(send frame begin-container-sequence)
(let ([directly-specified-buttons
(map (λ (button-spec)
(new switchable-button%
[label (list-ref button-spec 0)]
[bitmap (list-ref button-spec 1)]
[parent (send frame get-toolbar-button-panel)]
[callback
(lambda (button)
((list-ref button-spec 2) frame))]))
(or buttons '()))]
[opt-out-buttons
(if (eq? opt-out-ids #f)
'()
(map
(λ (opt-out-toolbar-button)
((opt-out-toolbar-button-make-button opt-out-toolbar-button)
frame
(send frame get-toolbar-button-panel)))
(filter (λ (opt-out-toolbar-button)
(not (member (opt-out-toolbar-button-id opt-out-toolbar-button)
opt-out-ids)))
opt-out-toolbar-buttons)))])
(send tab set-lang-toolbar-buttons
(sort
(append directly-specified-buttons
opt-out-buttons)
string<=?
#:key (λ (x) (send x get-label)))))
(send frame end-container-sequence))))
(inherit get-text)
(define/private (get-lang-name pos)
@ -163,79 +193,3 @@
(set! in-module-language?
(is-a? (drscheme:language-configuration:language-settings-language (get-next-settings))
drscheme:module-language:module-language<%>)))))
#|
#lang scheme/gui
(require mrlib/switchable-button
mrlib/bitmap-label
drscheme/tool
scheme/system
setup/xref)
(provide tool@)
(define-namespace-anchor anchor)
(define scribble-bm (make-object bitmap% 1 1))
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define phase1 void)
(define phase2 void)
(define (make-new-unit-frame% super%)
(class super%
(inherit get-button-panel
get-definitions-text)
(super-instantiate ())
(define client-panel
(new horizontal-pane% (parent (get-button-panel))))
(define (make-render-button label mode suffix extra-cmdline)
(new switchable-button%
[label label]
[bitmap scribble-bm]
[parent client-panel]
[callback
(lambda (button)
(let* ([t (get-definitions-text)]
[fn (send t get-filename)])
(if fn
(begin
(send t save-file)
(parameterize ([current-namespace (make-base-namespace)]
[current-command-line-arguments
(list->vector
(append
extra-cmdline
(list mode (if (path? fn) (path->string fn) fn))))])
(namespace-attach-module (namespace-anchor->empty-namespace anchor) 'setup/xref)
(dynamic-require 'scribble/run #f)
(let-values ([(base name dir?) (split-path fn)])
(system (format "open ~a" (path-replace-suffix name suffix))))))
(message-box "Not Named" "Cannot render unsaved file"))))]))
(inherit register-toolbar-button)
(define pdf-button (make-render-button "PDF" "--pdf" #".pdf" null))
(register-toolbar-button pdf-button)
(define html-button (make-render-button "HTML" "--html" #".html" '("++xref-in" "setup/xref" "load-collections-xref")))
(register-toolbar-button html-button)
(send (get-button-panel) change-children
(lambda (l) (cons client-panel (remq client-panel l))))))
(drscheme:get/extend:extend-unit-frame make-new-unit-frame% #f)))
|#

44
collects/drscheme/private/module-language.ss
View File

@ -97,7 +97,6 @@
(cond
[(eq? key 'drscheme:autocomplete-words)
(drscheme:language-configuration:get-all-manual-keywords)]
[(eq? key 'macro-stepper:enabled) #t]
[else (drscheme:language:get-capability-default key)]))
;; config-panel : as in super class
@ -251,7 +250,10 @@
(define path
(cond [(get-filename port) => (compose simplify-path cleanse-path)]
[else #f]))
(define resolved-modpath (and path (make-resolved-module-path path)))
(define resolved-modpath (and path (module-path-index-resolve
(module-path-index-join
path
#f))))
(define-values (name lang module-expr)
(let ([expr
;; just reading the definitions might be a syntax error,
@ -291,13 +293,16 @@
;; module. So the code is split among several thunks that follow.
(define (*pre)
(thread-cell-set! repl-init-thunk *error)
(current-module-declare-name resolved-modpath))
(current-module-declare-name resolved-modpath)
(current-module-declare-source path))
(define (*post)
(current-module-declare-name #f)
(current-module-declare-source #f)
(when path ((current-module-name-resolver) resolved-modpath))
(thread-cell-set! repl-init-thunk *init))
(define (*error)
(current-module-declare-name #f)
(current-module-declare-source #f)
;; syntax error => try to require the language to get a working repl
(with-handlers ([void (λ (e)
(raise-hopeless-syntax-error
@ -309,9 +314,24 @@
(parameterize ([current-namespace (current-namespace)])
;; the prompt makes it continue after an error
(call-with-continuation-prompt
(λ () (with-stack-checkpoint (namespace-require modspec)))))
(λ () (with-stack-checkpoint
(begin
(*do-module-specified-configuration modspec)
(namespace-require modspec))))))
(current-namespace (module->namespace modspec))
(check-interactive-language))
(define (*do-module-specified-configuration modspec)
(let ([info (module->language-info modspec #t)])
(when info
(let ([get-info
((dynamic-require (vector-ref info 0)
(vector-ref info 1))
(vector-ref info 2))])
(let ([configs (get-info 'configure-runtime '())])
(for ([config (in-list configs)])
((dynamic-require (vector-ref config 0)
(vector-ref config 1))
(vector-ref config 2))))))))
;; here's where they're all combined with the module expression
(expr-getter *pre module-expr *post))
@ -319,6 +339,21 @@
(cond [(thread-cell-ref repl-init-thunk)
=> (λ (t) (thread-cell-set! repl-init-thunk #f) (t))]))
(define/override (front-end/interaction port settings)
(λ ()
(let ([v (parameterize ([read-accept-reader #t])
(with-stack-checkpoint
((current-read-interaction)
(object-name port)
port)))])
(if (eof-object? v)
v
(let ([w (cons '#%top-interaction v)])
(if (syntax? v)
(namespace-syntax-introduce
(datum->syntax #f w v))
v))))))
;; printer settings are just ignored here.
(define/override (create-executable setting parent program-filename)
(let* ([executable-specs (drscheme:language:create-executable-gui
@ -350,6 +385,7 @@
#:mred? gui?
#:verbose? #f ;; verbose?
#:modules (list (list #f program-filename))
#:configure-via-first-module? #t
#:literal-expression
(begin
(parameterize ([current-namespace (make-base-empty-namespace)])

37
collects/drscheme/private/tools.ss
View File

@ -10,7 +10,8 @@
framework/splash
"drsig.ss"
"language-object-contract.ss"
string-constants)
mrlib/switchable-button
string-constants)
(require (for-syntax scheme/base scheme/match))
@ -25,7 +26,9 @@
[prefix drscheme:debug: drscheme:debug^]
[prefix drscheme:eval: drscheme:eval^]
[prefix drscheme:modes: drscheme:modes^]
[prefix drscheme:tracing: drscheme:tracing^])
[prefix drscheme:tracing: drscheme:tracing^]
[prefix drscheme:module-language: drscheme:module-language^]
[prefix drscheme:module-language-tools: drscheme:module-language-tools^])
(export drscheme:tools^)
;; An installed-tool is
@ -410,21 +413,21 @@
(define tool-bitmap-y tool-bitmap-gap)
(define tool-bitmap-size 32)
;; ; ;;;
; ;;; ;;; ; ;
; ; ; ; ; ;
; ;;; ; ;; ;;;; ;;; ;;; ; ; ; ;
; ; ;; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ;;;; ;;; ;;;;; ; ;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
;;;; ;;; ;;; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;;;;
;
;
;;;
;
;
; ;; ; ;;;
; ; ;;; ;;; ; ;
; ; ; ; ; ; ;
; ; ;;; ; ;; ;;;; ;;; ;;; ; ; ; ;
; ; ; ;; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ;;;; ;;; ;;;;; ; ;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
; ;;;; ;;; ;;; ;;; ; ;;; ;;; ;;;;; ;;; ; ;;;;;
; ;
; ;
; ;;;
;
;; run-phases : -> void
(define (run-phases phase1-extras phase2-extras)

18
collects/drscheme/syncheck-drscheme-button.ss Normal file
View File

@ -0,0 +1,18 @@
#lang scheme/base
(require scheme/class
scheme/gui/base
string-constants/string-constant)
(provide syncheck-drscheme-button
syncheck-bitmap
syncheck:button-callback)
(define-local-member-name syncheck:button-callback)
(define syncheck-bitmap (make-object bitmap% (build-path (collection-path "icons") "syncheck.png") 'png/mask))
(define syncheck-drscheme-button
(list
(string-constant check-syntax)
syncheck-bitmap
(λ (drs-frame) (send drs-frame syncheck:button-callback))))

17
collects/drscheme/syncheck.ss
View File

@ -37,7 +37,8 @@ If the namespace does not, they are colored the unbound color.
net/url
net/uri-codec
browser/external
(for-syntax scheme/base))
(for-syntax scheme/base)
"syncheck-drscheme-button.ss")
(provide tool@)
(define o (current-output-port))
@ -66,7 +67,6 @@ If the namespace does not, they are colored the unbound color.
syncheck:jump-to-definition
syncheck:clear-highlighting
syncheck:button-callback
syncheck:add-to-cleanup-texts
;syncheck:error-report-visible? ;; test suite uses this one.
;syncheck:get-bindings-table ;; test suite uses this one.
@ -92,6 +92,14 @@ If the namespace does not, they are colored the unbound color.
(define currently-processing-definitions-text (make-parameter #f))
(define (phase1)
(drscheme:module-language-tools:add-opt-out-toolbar-button
(λ (frame parent)
(new switchable-button%
(label (string-constant check-syntax))
(bitmap syncheck-bitmap)
(parent parent)
(callback (λ (button) (send frame syncheck:button-callback)))))
'drscheme:syncheck)
(drscheme:unit:add-to-program-editor-mixin clearing-text-mixin))
(define (phase2) (void))
@ -953,8 +961,6 @@ If the namespace does not, they are colored the unbound color.
(super-new)))))
(define syncheck-bitmap (make-object bitmap% (build-path (collection-path "icons") "syncheck.png") 'png/mask))
(define syncheck-frame<%>
(interface ()
syncheck:button-callback
@ -1030,7 +1036,8 @@ If the namespace does not, they are colored the unbound color.
(update-button-visibility/settings (send (send tab get-defs) get-next-settings)))
(define/public (update-button-visibility/settings settings)
(let* ([lang (drscheme:language-configuration:language-settings-language settings)]
[visible? (send lang capability-value 'drscheme:check-syntax-button)])
[visible? (and (not (is-a? lang drscheme:module-language:module-language<%>))
(send lang capability-value 'drscheme:check-syntax-button))])
(send check-syntax-button-parent-panel change-children
(λ (l)
(if visible?

38
collects/drscheme/tool-lib.ss
View File

@ -19,6 +19,7 @@ all of the names in the tools library, for use defining keybindings
framework
framework/splash
mrlib/switchable-button
scribble/srcdoc
drscheme/private/language-object-contract)
@ -44,6 +45,43 @@ all of the names in the tools library, for use defining keybindings
(provide/doc
(proc-doc/names
drscheme:module-language-tools:add-opt-out-toolbar-button
(-> (-> (is-a?/c top-level-window<%>)
(is-a?/c area-container<%>)
(is-a?/c switchable-button%))
symbol?
void?)
(make-button id)
@{Call this function to add another button to DrScheme's toolbar. When buttons are added this way,
DrScheme monitors the @tt{#lang} line at the top of the file; when it changes DrScheme queries
the language to see if this button should be included.
These buttons are ``opt out'', meaning that if the language doesn't explicitly ask to not
have this button (or all such buttons), the button will appear.
@section-index["drscheme:opt-out-toolbar-buttons"]
See @scheme[read-language] for more details on how language's specify how to opt out.
DrScheme will invoke the @tt{get-info} proc from @scheme[read-language] with
@tt{'drscheme:opt-out-toolbar-buttons}. If the result is a list of symbols, the
listed symbols are opted out. If the result is @scheme[#f], all buttons are opted
out. The default is the empty list, meaning that all opt-out buttons appear..
})
(proc-doc/names
drscheme:module-language:add-module-language
(-> any)
()
@{Adds the module language to DrScheme. This is called during DrScheme's startup.})
(proc-doc/names
drscheme:module-language:module-language-put-file-mixin
(-> (implementation?/c text:basic<%>) (implementation?/c text:basic<%>))
(super%)
@{Extends @scheme[super%] by overriding the @method[editor<%> put-file] method
to use a default name from the buffer, if the buffer contains something like
@tt{(module name ...)}.})
;
;
;

52
collects/errortrace/errortrace-lib.ss
View File

@ -8,6 +8,7 @@
scheme/contract
scheme/unit
scheme/runtime-path
(for-template scheme/base)
(for-syntax scheme/base))
(define oprintf
@ -43,15 +44,17 @@
(define (add-test-coverage-init-code stx)
(syntax-case stx (#%plain-module-begin)
[(mod name init-import (#%plain-module-begin b1 b2 body ...))
#`(#,(namespace-module-identifier) name init-import
#,(syntax-recertify
#`(#%plain-module-begin
b1 b2 ;; the two requires that were introduced earlier
(#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state))
body ...)
(list-ref (syntax->list stx) 3)
orig-inspector
#f))]))
(copy-props
stx
#`(#,(namespace-module-identifier) name init-import
#,(syntax-recertify
#`(#%plain-module-begin
b1 b2 ;; the two requires that were introduced earlier
(#%plain-app init-test-coverage '#,(remove-duplicates test-coverage-state))
body ...)
(list-ref (syntax->list stx) 3)
orig-inspector
#f)))]))
(define (annotate-covered-file filename-path [display-string #f])
(annotate-file filename-path
@ -102,6 +105,9 @@
[else
(< (list-ref x 1) (list-ref y 1))])))))
(define (copy-props orig new)
(datum->syntax orig (syntax-e new) orig orig))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Profiling run-time support
@ -415,19 +421,21 @@
[(mod name init-import (#%plain-module-begin body ...))
(add-test-coverage-init-code
(normal
#`(#,(namespace-module-identifier) name init-import
#,(syntax-recertify
#`(#%plain-module-begin
#,((make-syntax-introducer)
(syntax/loc (datum->syntax #f 'x #f)
(#%require errortrace/errortrace-key)))
#,((make-syntax-introducer)
(syntax/loc (datum->syntax #f 'x #f)
(#%require (for-syntax errortrace/errortrace-key))))
body ...)
(list-ref (syntax->list top-e) 3)
orig-inspector
#f))))])))]
(copy-props
top-e
#`(#,(namespace-module-identifier) name init-import
#,(syntax-recertify
#`(#%plain-module-begin
#,((make-syntax-introducer)
(syntax/loc (datum->syntax #f 'x #f)
(#%require errortrace/errortrace-key)))
#,((make-syntax-introducer)
(syntax/loc (datum->syntax #f 'x #f)
(#%require (for-syntax errortrace/errortrace-key))))
body ...)
(list-ref (syntax->list top-e) 3)
orig-inspector
#f)))))])))]
[_else
(normal top-e)])))

21
collects/errortrace/lang/body.ss Normal file
View File

@ -0,0 +1,21 @@
#lang scheme/base
(require (for-syntax scheme/base
syntax/strip-context
"../errortrace-lib.ss"))
(provide (rename-out [module-begin #%module-begin]))
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ lang . body)
(let ([e (annotate-top
(syntax-local-introduce
(local-expand #`(module . #,(strip-context #`(n lang . body)))
'top-level
null))
0)])
(syntax-case e ()
[(mod nm lang (mb . body))
#`(#%plain-module-begin
(require (only-in lang) errortrace/errortrace-key)
. body)]))]))

30
collects/errortrace/lang/reader.ss Normal file
View File

@ -0,0 +1,30 @@
(module reader scheme/base
(require syntax/module-reader)
(provide (rename-out [et-read read]
[et-read-syntax read-syntax]
[et-get-info get-info]))
(define (wrap-reader p)
(lambda args
(let ([r (apply p args)])
;; Re-write module to use `errortrace':
(if (syntax? r)
(syntax-case r ()
[(mod name lang . body)
(quasisyntax/loc r
(mod name errortrace/lang/body (#,(datum->syntax #f '#%module-begin) lang . body)))])
`(,(car r) ,(cadr r) errortrace/lang/body (#%module-begin . ,(cddr r)))))))
(define-values (et-read et-read-syntax et-get-info)
(make-meta-reader
'errortrace
"language path"
(lambda (str)
(let ([s (string->symbol
(string-append (bytes->string/latin-1 str)
"/lang/reader"))])
(and (module-path? s) s)))
wrap-reader
wrap-reader
values)))

8
collects/errortrace/scribblings/errortrace.scrbl
View File

@ -99,6 +99,14 @@ top-level. The functions also can be accessed by importing
@schememodname[errortrace/errortrace-lib], which does not install any
handlers.
As a language name, @schememodname[errortrace] chains to another
language that is specified immediately after @schememodname[at-exp],
but instruments the module for debugging in the same way as if
@schememodname[errortrace] is required before loading the module from
source. Using the @schememodname[errortrace] meta-language is one way
to ensure that debugging instrumentation is present when the module is
compiled.}
@; ---------------------------------------------
@subsection[#:tag "instrumentation-and-profiling"]{Instrumentation and Profiling}

562
collects/errortrace/stacktrace.ss
View File

@ -2,6 +2,7 @@
(require scheme/unit
syntax/kerncase
syntax/stx
(for-template scheme/base)
(for-syntax scheme/base)) ; for matching
(provide stacktrace@ stacktrace^ stacktrace-imports^)
@ -154,54 +155,54 @@
(with-syntax ([expr sexpr]
[e se])
(kernel-syntax-case/phase sexpr phase
;; negligible time to eval
[id
(identifier? sexpr)
(syntax (begin e expr))]
[(quote _) (syntax (begin e expr))]
[(quote-syntax _) (syntax (begin e expr))]
[(#%top . d) (syntax (begin e expr))]
[(#%variable-reference . d) (syntax (begin e expr))]
;; No tail effect, and we want to account for the time
[(#%plain-lambda . _) (syntax (begin0 expr e))]
[(case-lambda . _) (syntax (begin0 expr e))]
[(set! . _) (syntax (begin0 expr e))]
[(let-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(letrec-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(begin . _)
(insert-at-tail* se sexpr phase)]
[(with-continuation-mark . _)
(insert-at-tail* se sexpr phase)]
[(begin0 body ...)
(certify sexpr (syntax (begin0 body ... e)))]
[(if test then else)
;; WARNING: se inserted twice!
(certify
sexpr
(rebuild
sexpr
(list
(cons #'then (insert-at-tail se (syntax then) phase))
(cons #'else (insert-at-tail se (syntax else) phase)))))]
[(#%plain-app . rest)
(if (stx-null? (syntax rest))
;; null constant
(syntax (begin e expr))
;; application; exploit guaranteed left-to-right evaluation
(insert-at-tail* se sexpr phase))]
[_else
(error 'errortrace
"unrecognized (non-top-level) expression form: ~e"
(syntax->datum sexpr))])))
;; negligible time to eval
[id
(identifier? sexpr)
(syntax (begin e expr))]
[(quote _) (syntax (begin e expr))]
[(quote-syntax _) (syntax (begin e expr))]
[(#%top . d) (syntax (begin e expr))]
[(#%variable-reference . d) (syntax (begin e expr))]
;; No tail effect, and we want to account for the time
[(#%plain-lambda . _) (syntax (begin0 expr e))]
[(case-lambda . _) (syntax (begin0 expr e))]
[(set! . _) (syntax (begin0 expr e))]
[(let-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(letrec-values bindings . body)
(insert-at-tail* se sexpr phase)]
[(begin . _)
(insert-at-tail* se sexpr phase)]
[(with-continuation-mark . _)
(insert-at-tail* se sexpr phase)]
[(begin0 body ...)
(certify sexpr (syntax (begin0 body ... e)))]
[(if test then else)
;; WARNING: se inserted twice!
(certify
sexpr
(rebuild
sexpr
(list
(cons #'then (insert-at-tail se (syntax then) phase))
(cons #'else (insert-at-tail se (syntax else) phase)))))]
[(#%plain-app . rest)
(if (stx-null? (syntax rest))
;; null constant
(syntax (begin e expr))
;; application; exploit guaranteed left-to-right evaluation
(insert-at-tail* se sexpr phase))]
[_else
(error 'errortrace
"unrecognized (non-top-level) expression form: ~e"
(syntax->datum sexpr))])))
(define (profile-annotate-lambda name expr clause bodys-stx phase)
(let* ([bodys (stx->list bodys-stx)]
@ -303,6 +304,7 @@
(datum->syntax
expr
x
expr
expr)))))]
[else (same-k)])))))
@ -311,6 +313,7 @@
[(syntax? expr)
(datum->syntax expr
(append-rebuild (syntax-e expr) end)
expr
expr)]
[(pair? expr)
(cons (car expr) (append-rebuild (cdr expr) end))]
@ -329,234 +332,241 @@
(lambda (expr phase)
(test-coverage-point
(kernel-syntax-case/phase expr phase
[_
(identifier? expr)
(let ([b (identifier-binding expr phase)])
(cond
[(eq? 'lexical b)
;; lexical variable - no error possile
expr]
[(and (pair? b) (eq? '#%kernel (car b)))
;; built-in - no error possible
expr]
[else
;; might be undefined/uninitialized
(with-mark expr expr)]))]
[(#%top . id)
;; might be undefined/uninitialized
(with-mark expr expr)]
[(#%variable-reference . _)
;; no error possible
expr]
[(define-values names rhs)
top?
;; Can't put annotation on the outside
(let* ([marked
(with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
phase))]
[with-coverage
(let loop ([stx #'names]
[obj marked])
(cond
[(not (syntax? stx)) obj]
[(identifier? stx)
(test-coverage-point obj stx phase)]
[(pair? (syntax-e stx))
(loop (car (syntax-e stx))
(loop (cdr (syntax-e stx))
obj))]
[else obj]))])
(certify
expr
(rebuild
expr
(list (cons #'rhs with-coverage)))))]
[(begin . exprs)
top?
(certify
expr
(annotate-seq expr
(syntax exprs)
annotate-top phase))]
[(define-syntaxes (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'(name ...))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(define-values-for-syntax (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name (syntax (name ...)))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(module name init-import (__plain-module-begin body ...))
;; Just wrap body expressions
(let ([bodys (syntax->list (syntax (body ...)))]
[mb (list-ref (syntax->list expr) 3)])
(let ([bodyl (map (lambda (b)
(annotate-top b 0))
bodys)])
(certify
expr
(rebuild
expr
(list (cons
mb
(certify
mb
(rebuild mb (map cons bodys bodyl)))))))))]
[(#%expression e)
top?
(certify expr #`(#%expression #,(annotate (syntax e) phase)))]
;; No way to wrap
[(#%require i ...) expr]
;; No error possible (and no way to wrap)
[(#%provide i ...) expr]
;; No error possible
[(quote _)
expr]
[(quote-syntax _)
expr]
;; Wrap body, also a profile point
[(#%plain-lambda args . body)
(certify
expr
(keep-lambda-properties
expr
(profile-annotate-lambda name expr expr (syntax body)
phase)))]
[(case-lambda clause ...)
(with-syntax ([([args . body] ...)
(syntax (clause ...))])
(let* ([clauses (syntax->list (syntax (clause ...)))]
[clausel (map
(lambda (body clause)
(profile-annotate-lambda
name expr clause body phase))
(syntax->list (syntax (body ...)))
clauses)])
(certify
expr
(keep-lambda-properties
expr
(rebuild expr (map cons clauses clausel))))))]
;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
[(letrec-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
;; Wrap RHS
[(set! var rhs)
(let ([new-rhs (annotate-named
(syntax var)
(syntax rhs)
phase)])
;; set! might fail on undefined variable, or too many values:
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'rhs new-rhs))))))]
;; Wrap subexpressions only
[(begin e)
;; Single expression: no mark
(certify
expr
#`(begin #,(annotate (syntax e) phase)))]
[(begin . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(begin0 . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(if tst thn els)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)]
[w-els (annotate (syntax els) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn)
(cons #'els w-els))))))]
[(if tst thn)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))]
[(with-continuation-mark . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate phase)))]
;; Wrap whole application, plus subexpressions
[(#%plain-app . body)
(cond
[(stx-null? (syntax body))
;; It's a null:
expr]
[(syntax-case* expr (#%plain-app void)
(if (positive? phase)
free-transformer-identifier=?
free-identifier=?)
[(#%plain-app void) #t]
[_else #f])
;; It's (void):
expr]
[else
(with-mark expr (certify
expr
(annotate-seq expr (syntax body)
annotate phase)))])]
[_else
(error 'errortrace "unrecognized expression form~a: ~e"
(if top? " at top-level" "")
(syntax->datum expr))])
[_
(identifier? expr)
(let ([b (identifier-binding expr phase)])
(cond
[(eq? 'lexical b)
;; lexical variable - no error possile
expr]
[(and (pair? b) (let-values ([(base rel) (module-path-index-split (car b))])
(equal? '(quote #%kernel) base)))
;; built-in - no error possible
expr]
[else
;; might be undefined/uninitialized
(with-mark expr expr)]))]
[(#%top . id)
;; might be undefined/uninitialized
(with-mark expr expr)]
[(#%variable-reference . _)
;; no error possible
expr]
[(define-values names rhs)
top?
;; Can't put annotation on the outside
(let* ([marked
(with-mark expr
(annotate-named
(one-name #'names)
(syntax rhs)
phase))]
[with-coverage
(let loop ([stx #'names]
[obj marked])
(cond
[(not (syntax? stx)) obj]
[(identifier? stx)
(test-coverage-point obj stx phase)]
[(pair? (syntax-e stx))
(loop (car (syntax-e stx))
(loop (cdr (syntax-e stx))
obj))]
[else obj]))])
(certify
expr
(rebuild
expr
(list (cons #'rhs with-coverage)))))]
[(begin . exprs)
top?
(certify
expr
(annotate-seq expr
(syntax exprs)
annotate-top phase))]
[(define-syntaxes (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name #'(name ...))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(define-values-for-syntax (name ...) rhs)
top?
(let ([marked (with-mark expr
(annotate-named
(one-name (syntax (name ...)))
(syntax rhs)
(add1 phase)))])
(certify
expr
(rebuild expr (list (cons #'rhs marked)))))]
[(module name init-import (__plain-module-begin body ...))
;; Just wrap body expressions
(let ([bodys (syntax->list (syntax (body ...)))]
[mb (list-ref (syntax->list expr) 3)])
(let ([bodyl (map (lambda (b)
(annotate-top b 0))
bodys)])
(certify
expr
(rebuild
expr
(list (cons
mb
(certify
mb
(rebuild mb (map cons bodys bodyl)))))))))]
[(#%expression e)
top?
(certify expr #`(#%expression #,(annotate (syntax e) phase)))]
;; No way to wrap
[(#%require i ...) expr]
;; No error possible (and no way to wrap)
[(#%provide i ...) expr]
;; No error possible
[(quote _)
expr]
[(quote-syntax _)
expr]
;; Wrap body, also a profile point
[(#%plain-lambda args . body)
(certify
expr
(keep-lambda-properties
expr
(profile-annotate-lambda name expr expr (syntax body)
phase)))]
[(case-lambda clause ...)
(with-syntax ([([args . body] ...)
(syntax (clause ...))])
(let* ([clauses (syntax->list (syntax (clause ...)))]
[clausel (map
(lambda (body clause)
(profile-annotate-lambda
name expr clause body phase))
(syntax->list (syntax (body ...)))
clauses)])
(certify
expr
(keep-lambda-properties
expr
(rebuild expr (map cons clauses clausel))))))]
;; Wrap RHSs and body
[(let-values ([vars rhs] ...) . body)
(with-mark expr
(certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body))))]
[(letrec-values ([vars rhs] ...) . body)
(let ([fm (certify
expr
(annotate-let expr phase
(syntax (vars ...))
(syntax (rhs ...))
(syntax body)))])
(kernel-syntax-case/phase expr phase
[(lv ([(var1) (#%plain-lambda . _)]) var2)
(and (identifier? #'var2)
(free-identifier=? #'var1 #'var2))
fm]
[_
(with-mark expr fm)]))]
;; Wrap RHS
[(set! var rhs)
(let ([new-rhs (annotate-named
(syntax var)
(syntax rhs)
phase)])
;; set! might fail on undefined variable, or too many values:
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'rhs new-rhs))))))]
;; Wrap subexpressions only
[(begin e)
;; Single expression: no mark
(certify
expr
#`(begin #,(annotate (syntax e) phase)))]
[(begin . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(begin0 . body)
(with-mark expr
(certify
expr
(annotate-seq expr #'body annotate phase)))]
[(if tst thn els)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)]
[w-els (annotate (syntax els) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn)
(cons #'els w-els))))))]
[(if tst thn)
(let ([w-tst (annotate (syntax tst) phase)]
[w-thn (annotate (syntax thn) phase)])
(with-mark expr
(certify
expr
(rebuild expr (list (cons #'tst w-tst)
(cons #'thn w-thn))))))]
[(with-continuation-mark . body)
(with-mark expr
(certify
expr
(annotate-seq expr (syntax body)
annotate phase)))]
;; Wrap whole application, plus subexpressions
[(#%plain-app . body)
(cond
[(stx-null? (syntax body))
;; It's a null:
expr]
[(syntax-case* expr (#%plain-app void)
(if (positive? phase)
free-transformer-identifier=?
free-identifier=?)
[(#%plain-app void) #t]
[_else #f])
;; It's (void):
expr]
[else
(with-mark expr (certify
expr
(annotate-seq expr (syntax body)
annotate phase)))])]
[_else
(error 'errortrace "unrecognized expression form~a: ~e"
(if top? " at top-level" "")
(syntax->datum expr))])
expr
phase)))

2
collects/framework/private/decode.ss
View File

@ -6,7 +6,7 @@
(define-syntax (module-begin stx)
(syntax-case stx ()
[(_ x ...)
(andmap (lambda (x) (or identifier? (integer? (syntax-e x))))
(andmap (lambda (x) (or (identifier? x) (integer? (syntax-e x))))
(syntax->list #'(x ...)))
(let* ([data (format "~a" (syntax->datum #'(x ...)))]
[data (substring data 1 (sub1 (string-length data)))]

43
collects/games/chat-noir/chat-noir-literate.ss
View File

@ -2253,13 +2253,7 @@ and reports the results.
'playing 3 (make-posn 0 0) #f)
"h")
(make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #t))
(test (change (make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #t)
"release")
(make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))]
'playing 3 (make-posn 0 0) #t))]
@chunk[<point-in-this-circle?-tests>
@ -2338,7 +2332,7 @@ and reports the results.
This section contains expressions that start
the Chat Noir game going.
First, a function to compute state of the world at the start of a game is defined.
First, here is a function to compute state of the world at the start of a game.
@chunk[<initial-world>
(define board-size 11)
@ -2349,21 +2343,24 @@ First, a function to compute state of the world at the start of a game is define
(empty-board board-size)
board-size))
(make-world initial-board
(make-posn (quotient board-size 2)
(quotient board-size 2))
'playing
board-size
#f
#f))]
(make-posn (quotient board-size 2)
(quotient board-size 2))
'playing
board-size
#f
#f))]
Next, the game starts by calling @scheme[big-bang] with the appropriate arguments.
Finally, we can define and provide a function to start the game
by calling @scheme[big-bang] with the appropriate arguments.
@chunk[<go>
(void
(big-bang (make-initial-world)
(on-draw render-world
(world-width board-size)
(world-height board-size))
(on-key change)
(on-mouse clack)
(name "Chat Noir")))]
(provide main)
(define (main)
(void
(big-bang (make-initial-world)
(on-draw render-world
(world-width board-size)
(world-height board-size))
(on-key change)
(on-mouse clack)
(name "Chat Noir"))))]

70
collects/games/chat-noir/chat-noir-unit.ss
View File

@ -15,31 +15,59 @@
(define-unit game@
(import)
(export)
(define ns (make-base-namespace))
(define sub-custodian (make-custodian))
(define main-custodian (current-custodian))
(define (find-windows)
(let loop ([cust sub-custodian])
(let o-loop ([objs (custodian-managed-list cust main-custodian)])
(cond
[(null? objs) null]
[else
(let ([obj (car objs)])
(cond
[(custodian? obj)
(append (loop obj)
(o-loop (cdr objs)))]
[(eventspace? obj)
(append (parameterize ([current-eventspace obj])
(get-top-level-windows))
(o-loop (cdr objs)))]
[else
(o-loop (cdr objs))]))]))))
;; a hack.
;; this adds a help button to the world.ss window
(thread
(λ ()
(let loop ([n 0])
(when (n . < . 100)
(sleep 1/10)
(let ([fs (get-top-level-windows)])
(cond
[(null? fs)
(loop (+ n 1))]
[else
(let ([f (car fs)]
[show-help
(show-scribbling
'(lib "games/scribblings/games.scrbl")
"chat-noir")])
(new button%
[parent f]
[callback (λ (x y) (show-help))]
[label (string-constant help)]))]))))))
(cond
[(n . < . 100)
(sleep 1/10)
(let ([fs (find-windows)])
(cond
[(null? fs)
(loop (+ n 1))]
[else
(let ([f (car fs)]
[show-help
(show-scribbling
'(lib "games/scribblings/games.scrbl")
"chat-noir")])
(new button%
[parent f]
[callback (λ (x y) (show-help))]
[label (string-constant help)]))]))]
[else
(fprintf (current-error-port) "never found a window\n")]))))
(parameterize ([current-namespace ns])
(namespace-attach-module orig-namespace '(lib "mred.ss" "mred"))
(namespace-attach-module orig-namespace '(lib "class.ss" "scheme"))
(dynamic-require chat-noir #f)))
;; start up the game
(parameterize ([current-custodian sub-custodian])
(parameterize ([current-namespace (make-base-namespace)])
(namespace-attach-module orig-namespace '(lib "mred.ss" "mred"))
(namespace-attach-module orig-namespace '(lib "class.ss" "scheme"))
((dynamic-require chat-noir 'main)))))

34
collects/games/parcheesi/admin-gui.ss
View File

@ -333,17 +333,23 @@ corresponds to the unplayed move! that's confusing.
[(0) best-player%]
[(1) polite-player%]
[(2) reckless-player%]
[(3) gui-player%]))
[(3) gui-player%]
[else
(message-box "Parcheesi" (format "index->player got ~s" i))
gui-player%]))
(define players (vector (index->player 0)
(index->player 0)
(index->player 0)
(index->player 0)))
(define players (vector 'unfilled-in-players-array
'unfilled-in-players-array
'unfilled-in-players-array
'unfilled-in-players-array))
(define/private (add-choose-player-controls color parent-panel)
(let ([color-order '((green . 0) (red . 1) (blue . 2) (yellow . 3))])
(define/private (add-choose-player-controls color parent-panel init-selection)
(let* ([color-order '((green . 0) (red . 1) (blue . 2) (yellow . 3))]
[color-index (cdr (assq color color-order))])
(vector-set! players color-index (index->player init-selection))
(new radio-box%
(parent parent-panel)
(selection init-selection)
(label #f)
(choices '("Amazing Grace"
"Polite Polly"
@ -352,7 +358,7 @@ corresponds to the unplayed move! that's confusing.
(callback
(lambda (rb y)
(vector-set! players
(cdr (assq color color-order))
color-index
(index->player
(send rb get-selection))))))))
@ -361,7 +367,7 @@ corresponds to the unplayed move! that's confusing.
;; put all the gui elements together
;;
(define/private (make-player-control-panel parent color ah aw)
(define/private (make-player-control-panel parent color ah aw init-selection)
(let* ([parent
(new panel:single%
(stretchable-height #f)
@ -379,14 +385,14 @@ corresponds to the unplayed move! that's confusing.
(stretchable-width #f)
(stretchable-height #f))])
(add-gui-player-controls color control-player-panel)
(add-choose-player-controls color choose-player-panel)
(add-choose-player-controls color choose-player-panel init-selection)
(list color parent choose-player-panel control-player-panel)))
(define gui-player-control-panels
(list (make-player-control-panel green-player-panel 'green 'top 'left)
(make-player-control-panel red-player-panel 'red 'bottom 'left)
(make-player-control-panel yellow-player-panel 'yellow 'top 'right)
(make-player-control-panel blue-player-panel 'blue 'bottom 'right)))
(list (make-player-control-panel green-player-panel 'green 'top 'left 0)
(make-player-control-panel red-player-panel 'red 'bottom 'left 1)
(make-player-control-panel yellow-player-panel 'yellow 'top 'right 2)
(make-player-control-panel blue-player-panel 'blue 'bottom 'right 3)))
(define/private (get-player-panel color i)
(let ([e (assq color gui-player-control-panels)])

11
collects/gui-debugger/debug-tool.ss
View File

@ -22,12 +22,22 @@
; what is the right way to deal with macros?
; how can the three tool classes communicate with each other safely
(define-local-member-name debug-callback)
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1)
(drscheme:module-language-tools:add-opt-out-toolbar-button
(λ (frame parent)
(new switchable-button%
(label (string-constant debug-tool-button-name))
(bitmap debug-bitmap)
(parent parent)
(callback (λ (button) (send frame debug-callback)))))
'macro-stepper)
(drscheme:language:extend-language-interface
debugger-language<%>
(lambda (superclass)
@ -1395,6 +1405,7 @@
(let* ([settings (send (get-definitions-text) get-next-settings)]
[lang (drscheme:language-configuration:language-settings-language settings)]
[visible? (and (send lang capability-value 'gui-debugger:debug-button)
(not (is-a? lang drscheme:module-language:module-language<%>)) ;; the opt-out button handles this language
(not (debugger-does-not-work-for?
(extract-language-level settings))))])
(if visible?

1
collects/help/info.ss
View File

@ -1,3 +1,4 @@
#lang setup/infotab
(define post-install-collection "installer.ss")
(define rico '(("docs" help/help "search and view documentation" 100)))

9
collects/help/installer.ss
View File

@ -1,6 +1,9 @@
;; Builds different kinds of executables for different platforms.
#lang scheme/base
;; Builds different kinds of executables for different platforms.
;; proposed changes below -robby.
(provide post-installer)
(require launcher)
@ -23,8 +26,8 @@
(for ([variant (variants)])
(parameterize ([current-launcher-variant variant])
(mk-launcher '("-l-" "help/help")
(mk-path "plt-help")
`([exe-name . "plt-help"]
(mk-path "plt-help") ;; change to "Racket Docs"
`([exe-name . "plt-help"] ;; get rid of this (in favor of 'rico docs')
[relative? . #t]
[framework-root . #f]
[dll-dir . #f]

4
collects/htdp/asl/lang/reader.ss Normal file
View File

@ -0,0 +1,4 @@
#lang s-exp htdp/bsl/reader
lang/htdp-intermediate-lambda
'(abbreviate-cons-as-list
read-accept-quasiquote)

4
collects/htdp/bsl+/lang/reader.ss Normal file
View File

@ -0,0 +1,4 @@
#lang s-exp htdp/bsl/reader
lang/htdp-beginner-abbr
'(abbreviate-cons-as-list
read-accept-quasiquote)

3
collects/htdp/bsl/lang/reader.ss Normal file
View File

@ -0,0 +1,3 @@
#lang s-exp htdp/bsl/reader
lang/htdp-beginner
'()

8
collects/htdp/bsl/module-info.ss Normal file
View File

@ -0,0 +1,8 @@
#lang scheme/base
(provide module-info)
(define ((module-info options) key default)
(case key
[(configure-runtime) `(#(htdp/bsl/runtime configure ,options))]
[else default]))

40
collects/htdp/bsl/reader.ss Normal file
View File

@ -0,0 +1,40 @@
#lang scheme/base
(require (rename-in syntax/module-reader
[#%module-begin #%reader-module-begin]))
(provide (rename-out [module-begin #%module-begin])
(except-out (all-from-out scheme/base)
#%module-begin))
(define-syntax-rule (module-begin lang opts)
(#%reader-module-begin
lang
#:read (wrap-reader read options)
#:read-syntax (wrap-reader read-syntax options)
#:info (make-info options)
#:module-info (make-module-info options)
(define options opts)))
(define (wrap-reader read-proc options)
(lambda args
(parameterize ([read-decimal-as-inexact #f]
[read-accept-dot #f]
[read-accept-quasiquote (memq 'read-accept-quasiquote options)])
(apply read-proc args))))
(define ((make-info options) key default use-default)
(case key
[(drscheme:toolbar-buttons)
(list (dynamic-require 'stepper/drscheme-button 'stepper-drscheme-button)
(dynamic-require 'drscheme/syncheck-drscheme-button 'syncheck-drscheme-button))]
[(drscheme:opt-out-toolbar-buttons)
;; opt-out of all of the extra buttons b/c
;; we don't want anything to confuse in the teaching languages.
#f]
[else (use-default key default)]))
(define (make-module-info options)
`#(htdp/bsl/module-info module-info ,options))

41
collects/htdp/bsl/runtime.ss Normal file
View File

@ -0,0 +1,41 @@
#lang scheme/base
(require mzlib/pconvert
scheme/pretty
lang/private/set-result)
(provide configure)
(define (configure options)
;; Set print-convert options:
(booleans-as-true/false #t)
(constructor-style-printing #t)
(abbreviate-cons-as-list (memq 'abbreviate-cons-as-list options))
(current-print-convert-hook
(let ([ph (current-print-convert-hook)])
(lambda (val basic sub)
(cond
[(equal? val set!-result) '(void)]
[else (ph val basic sub)]))))
(use-named/undefined-handler
(lambda (x)
(and (memq 'use-function-output-syntax options)
(procedure? x)
(object-name x))))
(named/undefined-handler
(lambda (x)
(string->symbol
(format "function:~a" (object-name x)))))
;; Set pretty-print options:
(pretty-print-show-inexactness #t)
(pretty-print-exact-as-decimal #t)
;; Set print handlers to use print-convert and pretty-print:
(current-print
(lambda (v)
(unless (void? v)
(pretty-print (print-convert v)))))
(global-port-print-handler
(lambda (val port [depth 0])
(let ([val (print-convert val)])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print val port depth))))))

4
collects/htdp/isl+/lang/reader.ss Normal file
View File

@ -0,0 +1,4 @@
#lang s-exp htdp/bsl/reader
lang/htdp-intermediate-lambda
'(abbreviate-cons-as-list
read-accept-quasiquote)

4
collects/htdp/isl/lang/reader.ss Normal file
View File

@ -0,0 +1,4 @@
#lang s-exp htdp/bsl/reader
lang/htdp-intermediate
'(abbreviate-cons-as-list
read-accept-quasiquote)

6
collects/launcher/.gitignore vendored Normal file
View File

@ -0,0 +1,6 @@
Starter.app
Starter3m.app
MzStart.exe
MzStart3m.exe
MrStart.exe
MrStart3m.exe

21
collects/launcher/launcher-sig.ss
View File

@ -1,30 +1,47 @@
#lang scheme/signature
make-gracket-launcher
make-racket-launcher
make-mred-launcher
make-mzscheme-launcher
make-gracket-program-launcher
make-racket-program-launcher
make-mred-program-launcher
make-mzscheme-program-launcher
gracket-program-launcher-path
racket-program-launcher-path
mred-program-launcher-path
mzscheme-program-launcher-path
install-gracket-program-launcher
install-racket-program-launcher
install-mred-program-launcher
install-mzscheme-program-launcher
gracket-launcher-up-to-date?
racket-launcher-up-to-date?
mred-launcher-up-to-date?
mzscheme-launcher-up-to-date?
gracket-launcher-is-directory?
racket-launcher-is-directory?
mred-launcher-is-directory?
mzscheme-launcher-is-directory?
gracket-launcher-is-actually-directory?
racket-launcher-is-actually-directory?
mred-launcher-is-actually-directory?
mzscheme-launcher-is-actually-directory?
gracket-launcher-add-suffix
racket-launcher-add-suffix
mred-launcher-add-suffix
mzscheme-launcher-add-suffix
gracket-launcher-put-file-extension+style+filters
racket-launcher-put-file-extension+style+filters
mred-launcher-put-file-extension+style+filters
mzscheme-launcher-put-file-extension+style+filters
@ -32,3 +49,5 @@ build-aux-from-path
current-launcher-variant
available-mred-variants
available-mzscheme-variants
available-gracket-variants
available-racket-variants

92
collects/launcher/launcher-unit.ss
View File

@ -26,7 +26,7 @@
v))
v)))
(define (variant-available? kind cased-kind-name variant)
(define (variant-available? kind cased-kind-name variant)
(cond
[(or (eq? 'unix (system-type))
(and (eq? 'macosx (system-type))
@ -35,7 +35,11 @@
(and bin-dir
(file-exists?
(build-path bin-dir
(format "~a~a" kind (variant-suffix variant #f))))))]
(format "~a~a"
(case kind
[(mzscheme) 'racket]
[(mred) 'gracket])
(variant-suffix variant #f))))))]
[(eq? 'macosx (system-type))
;; kind must be mred, because mzscheme case is caught above
(directory-exists? (build-path (find-gui-bin-dir)
@ -51,8 +55,8 @@
(define (available-variants kind)
(let* ([cased-kind-name (if (eq? kind 'mzscheme)
"MzScheme"
"MrEd")]
"Racket"
"GRacket")]
[normal-kind (system-type 'gc)]
[alt-kind (if (eq? '3m normal-kind)
'cgc
@ -78,9 +82,13 @@
null)])
(append normal alt script script-alt)))
(define (available-gracket-variants)
(available-variants 'mred))
(define (available-mred-variants)
(available-variants 'mred))
(define (available-racket-variants)
(available-variants 'mzscheme))
(define (available-mzscheme-variants)
(available-variants 'mzscheme))
@ -323,7 +331,9 @@
(make-absolute-path-header bindir)))]
[exec (format
"exec \"${bindir}/~a~a\" ~a"
(or alt-exe kind)
(or alt-exe (case kind
[(mred) "gracket"]
[(mzscheme) "racket"]))
(if alt-exe "" (variant-suffix variant #f))
pre-str)]
[args (format
@ -434,12 +444,12 @@
;; OS X launcher code:
; make-macosx-launcher : symbol (listof str) pathname ->
;; make-macosx-launcher : symbol (listof str) pathname ->
(define (make-macosx-launcher kind variant flags dest aux)
(if (or (eq? kind 'mzscheme) (script-variant? variant))
;; MzScheme or script launcher is the same as for Unix
;; Racket or script launcher is the same as for Unix
(make-unix-launcher kind variant flags dest aux)
;; MrEd "launcher" is a stand-alone executable
;; Gracket "launcher" is a stand-alone executable
(make-embedding-executable dest (eq? kind 'mred) #f
null null null
flags
@ -474,11 +484,15 @@
[(macos) make-macos-launcher]
[(macosx) make-macosx-launcher]))
(define (make-mred-launcher flags dest [aux null])
(define (make-gracket-launcher flags dest [aux null])
((get-maker) 'mred (current-launcher-variant) flags dest aux))
(define (make-mred-launcher flags dest [aux null])
((get-maker) 'mred (current-launcher-variant) (list* "-I" "scheme/gui/init" flags) dest aux))
(define (make-mzscheme-launcher flags dest [aux null])
(define (make-racket-launcher flags dest [aux null])
((get-maker) 'mzscheme (current-launcher-variant) flags dest aux))
(define (make-mzscheme-launcher flags dest [aux null])
((get-maker) 'mzscheme (current-launcher-variant) (list* "-I" "scheme/init" flags) dest aux))
(define (strip-suffix s)
(path-replace-suffix s #""))
@ -530,19 +544,23 @@
(let ([d (read)])
(list (cons 'uti-exports d)))))))))))
(define (make-mred-program-launcher file collection dest)
(define (make-gracket-program-launcher file collection dest)
(make-mred-launcher (list "-l-" (string-append collection "/" file))
dest
(build-aux-from-path
(build-path (collection-path collection)
(strip-suffix file)))))
(define (make-mred-program-launcher file collection dest)
(make-gracket-program-launcher file collection dest))
(define (make-mzscheme-program-launcher file collection dest)
(define (make-racket-program-launcher file collection dest)
(make-mzscheme-launcher (list "-l-" (string-append collection "/" file))
dest
(build-aux-from-path
(build-path (collection-path collection)
(strip-suffix file)))))
(define (make-mzscheme-program-launcher file collection dest)
(make-racket-program-launcher file collection dest))
(define (unix-sfx file mred?)
(string-downcase (regexp-replace* #px"\\s" file "-")))
@ -571,25 +589,37 @@
(path-replace-suffix p #".app")
p))))
(define (mred-program-launcher-path name)
(define (gracket-program-launcher-path name)
(program-launcher-path name #t))
(define (mred-program-launcher-path name)
(gracket-program-launcher-path name))
(define (mzscheme-program-launcher-path name)
(define (racket-program-launcher-path name)
(case (system-type)
[(macosx)
(add-file-suffix (build-path (find-console-bin-dir) (unix-sfx name #f))
(current-launcher-variant)
#f)]
[else (program-launcher-path name #f)]))
(define (mzscheme-program-launcher-path name)
(racket-program-launcher-path name))
(define (gracket-launcher-is-directory?)
#f)
(define (racket-launcher-is-directory?)
#f)
(define (mred-launcher-is-directory?)
#f)
(define (mzscheme-launcher-is-directory?)
#f)
(define (mred-launcher-is-actually-directory?)
(define (gracket-launcher-is-actually-directory?)
(and (eq? 'macosx (system-type))
(not (script-variant? (current-launcher-variant)))))
(define (mred-launcher-is-actually-directory?)
(gracket-launcher-is-actually-directory?))
(define (racket-launcher-is-actually-directory?)
#f)
(define (mzscheme-launcher-is-actually-directory?)
#f)
@ -600,27 +630,39 @@
[(macosx) (values "app" '(packages) '(("App" "*.app")))]
[else (values #f null null)]))
(define (mred-launcher-add-suffix path)
(define (gracket-launcher-add-suffix path)
(embedding-executable-add-suffix path #t))
(define (mred-launcher-add-suffix path)
(gracket-launcher-add-suffix path))
(define (mzscheme-launcher-add-suffix path)
(define (racket-launcher-add-suffix path)
(embedding-executable-add-suffix path #f))
(define (mzscheme-launcher-add-suffix path)
(racket-launcher-add-suffix path))
(define (mred-launcher-put-file-extension+style+filters)
(define (gracket-launcher-put-file-extension+style+filters)
(put-file-extension+style+filters
(if (and (eq? 'macosx (system-type))
(script-variant? (current-launcher-variant)))
'unix
(system-type))))
(define (mred-launcher-put-file-extension+style+filters)
(gracket-launcher-put-file-extension+style+filters))
(define (mzscheme-launcher-put-file-extension+style+filters)
(define (racket-launcher-put-file-extension+style+filters)
(put-file-extension+style+filters
(if (eq? 'macosx (system-type)) 'unix (system-type))))
(define (mzscheme-launcher-put-file-extension+style+filters)
(racket-launcher-put-file-extension+style+filters))
(define (gracket-launcher-up-to-date? dest [aux null])
(racket-launcher-up-to-date? dest aux))
(define (mred-launcher-up-to-date? dest [aux null])
(mzscheme-launcher-up-to-date? dest aux))
(racket-launcher-up-to-date? dest aux))
(define (mzscheme-launcher-up-to-date? dest [aux null])
(racket-launcher-up-to-date? dest aux))
(define (racket-launcher-up-to-date? dest [aux null])
(cond
;; When running Setup PLT under Windows, the
;; launcher process stays running until MzScheme
@ -636,6 +678,14 @@
;; launchers.
[else #f]))
(define (install-gracket-program-launcher file collection name)
(make-gracket-program-launcher file collection
(gracket-program-launcher-path name)))
(define (install-racket-program-launcher file collection name)
(make-racket-program-launcher file collection
(racket-program-launcher-path name)))
(define (install-mred-program-launcher file collection name)
(make-mred-program-launcher file collection
(mred-program-launcher-path name)))

13
collects/macro-debugger/tool.ss
View File

@ -76,12 +76,23 @@
(super-new)))
(define macro-stepper-button-label "Macro Stepper")
(define tool@
(unit
(import drscheme:tool^)
(export drscheme:tool-exports^)
(define (phase1)
(drscheme:module-language-tools:add-opt-out-toolbar-button
(λ (frame parent)
(new switchable-button%
(label macro-stepper-button-label)
(bitmap macro-debugger-bitmap)
(alternate-bitmap macro-debugger-up-bitmap)
(parent parent)
(callback (lambda (button) (send frame run-macro-stepper)))))
'macro-stepper)
(drscheme:language:register-capability
'macro-stepper:enabled
boolean?
@ -118,7 +129,7 @@
(stretchable-width #f)))
(define macro-debug-button
(new switchable-button%
(label "Macro Stepper")
(label macro-stepper-button-label)
(bitmap macro-debugger-bitmap)
(alternate-bitmap macro-debugger-up-bitmap)
(parent macro-debug-panel)

18
collects/meta/checker.ss
View File

@ -479,10 +479,18 @@
(define (set-bin-files-delayed-lists! p)
(set! bin-files-lists p))
(define (add-alts l)
(if (null? l)
null
(let ([v (regexp-replace #rx"[.]ss$" (car l) ".rkt")])
(if (equal? v (car l))
(cons (car l) (add-alts (cdr l)))
(list* (car l) v (add-alts (cdr l)))))))
(define (check-dependencies spec distname)
(add-dependency-contents!)
(dprintf "Verifying dependencies for ~s..." distname)
(let* ([all-files (sort* (tree-flatten (tree-filter spec *plt-tree*)))]
(let* ([all-files (sort* (add-alts (tree-flatten (tree-filter spec *plt-tree*))))]
[deps0 (or (tree-filter `(and ,spec "*.dep") *plt-tree*)
(error 'check-dependencies
"got no .dep files for ~s" distname))]
@ -507,8 +515,12 @@
;; trees). No need to optimize since this happens very
;; infrequently.
(let ([dep (regexp-replace #rx"/([^/]+)\\.([^/]+)$" (car deps)
"/compiled/\\1_\\2.zo")])
(if (andmap (lambda (files) (member dep files))
"/compiled/\\1_\\2.zo")]
[alt-dep (and (regexp-match #rx"[.]rkt$" (car deps))
(regexp-replace #rx"/([^/]+)\\.([^/]+)$" (car deps)
"/compiled/\\1_ss.zo"))])
(if (andmap (lambda (files) (or (member dep files)
(member alt-dep files)))
(force bin-files-lists))
(loop files (cdr deps) (car deps))
(error 'dependencies "unsatisfied dependency for ~s: ~s ~s"

135
collects/meta/contrib/completion/racket-completion.bash Normal file
View File

@ -0,0 +1,135 @@
# -*- mode: shell-script; sh-basic-offset: 2; indent-tabs-mode: nil -*-
# ex: ts=2 sw=2 noet filetype=sh
# to enable this, add the following line to ~/.bash_completion you
# will need to make sure that you've enable bash completion more
# generally, usually via '. /etc/bash_completion'
#
# source $PLTHOME/collects/meta/contrib/completion/racket-completion.bash
#
# Change $PLTHOME to whatever references your Racket installation
# this completes only *.{rkt,ss,scm,scrbl} files unless there are
# none, in which case it completes other things
_smart_filedir()
{
COMPREPLY=()
_filedir '@(rkt|ss|scm|scrbl)'
if [[ ${#COMPREPLY[@]} -eq 0 ]]; then
_filedir
fi
return 0
}
_racket()
{
local cur prev singleopts doubleopts
COMPREPLY=()
cur=`_get_cword`
prev="${COMP_WORDS[COMP_CWORD-1]}"
doubleopts="--help --version --eval --load --require --lib --script --require-script\
--main --repl --no-lib --version --warn --syslog --collects --search --addon --no-compiled --no-init-file"
singleopts="-h -e -f -t -l -p -r -u -k -m -i -n -v -W -L -X -S -A -I -U -N -j -d -b -c -q"
warnlevels="none fatal error warning info debug"
# if '--' is already given, complete all kind of files, but no options
for (( i=0; i < ${#COMP_WORDS[@]}-1; i++ )); do
if [[ ${COMP_WORDS[i]} == -- ]]; then
_smart_filedir
return 0
fi
done
# -k takes *two* integer arguments
if [[ 2 < ${#COMP_WORDS[@]} ]]; then
if [[ ${COMP_WORDS[COMP_CWORD-2]} == -k ]]; then
return 0
fi
fi
case "${cur}" in
--*)
COMPREPLY=( $(compgen -W "${doubleopts}" -- ${cur}) )
;;
-*)
COMPREPLY=( $(compgen -W "${singleopts}" -- ${cur}) )
;;
*)
case "${prev}" in
# these do not take anything completable as arguments
--help|-h|-e|--eval|-p|-k)
;;
# these take dirs (not files) as arguments
-X|-S|-A|--collects|--search|--addon)
_filedir '-d'
;;
# these take warnlevels as arguments
-W|--warn|-L|--syslog)
COMPREPLY=( $(compgen -W "${warnlevels}" -- ${cur}) )
;;
# otherwise, just a file
*)
_smart_filedir
;;
esac
;;
esac
return 0
}
complete -F _racket $filenames racket
complete -F _racket $filenames gracket
complete -F _racket $filenames gracket-text
_rico_planet()
{
local cur="${COMP_WORDS[COMP_CWORD]}"
local planetcmds=$( echo '' '--help' ; for x in `rico planet --help 2>&1 | sed -n -e 's/^ \(.[^ ]*\).*/\1/p'` ; do echo ${x} ; done )
COMPREPLY=( $(compgen -W "${planetcmds}" -- ${cur}) )
}
_rico()
{
COMPREPLY=()
local cur="${COMP_WORDS[COMP_CWORD]}"
#
# Complete the arguments to some of the basic commands.
#
local makeopts="--disable-inline --no-deps -p --prefix --no-prim -v -vv --help -h"
if [ $COMP_CWORD -eq 1 ]; then
# removing the empty string on the next line breaks things. such as my brain.
local cmds=$( echo '' '--help' ; for x in `racket -e '(begin (require rico/all-tools) (for ([(k v) (all-tools)]) (printf "~a\n" k)))'` ; do echo ${x} ; done )
COMPREPLY=($(compgen -W "${cmds}" -- ${cur}))
elif [ $COMP_CWORD -eq 2 ]; then
# Here we'll handle the main rico commands
local prev="${COMP_WORDS[1]}"
case "${prev}" in
make)
case "${cur}" in
-*)
COMPREPLY=( $(compgen -W "${makeopts}" -- ${cur}) )
;;
*)
_filedir
;;
esac
;;
planet)
_rico_planet
;;
--help)
;;
*)
_filedir
;;
esac
else
_filedir
fi
return 0
}
complete -F _rico rico

18
collects/meta/dist-specs.ss
View File

@ -204,7 +204,7 @@ binary-keep/throw-templates :=
(cond win => "/plt/*<!>.exe"
"/plt/lib/**/lib*<!>???????.{dll|lib|exp}"
mac => "/plt/*<!>.app/"
"/plt/lib/PLT_*.framework/Versions/*<_!>/")
"/plt/lib/*Racket*.framework/Versions/*<_!>/")
"/plt/collects/**/compiled/**/<!/>*.*"
binary-keep := "3[mM]"
@ -332,7 +332,7 @@ mz-base := "/plt/readme.txt" ; generated
(cond (not src) => (collects: "info-domain/")) ; filtered
(package: "config")
;; basic code
(collects: "scheme" "s-exp" "reader")
(collects: "scheme" "s-exp" "reader" "racket")
;; include the time-stamp collection when not a public release
(cond (not release)
=> (- (collects: "repos-time-stamp/")
@ -391,14 +391,14 @@ foreign-src := (src: "foreign/{Makefile.in|README}"
;; queries have no point elsewhere.)
mz-bins := (lib: "buildinfo" "**/mzdyn{|w}{|3[mM]|cgc|CGC}.{o|obj|exp|def}")
(cond mac => (lib: "PLT_MzScheme*/")
win => (dll: "libmz{gc|sch}" "UnicoWS" "iconv")
(cond mac => (lib: "Racket*/")
win => (dll: "lib{mzgc|racket}" "UnicoWS" "iconv")
(lib: "gcc/{fixup|init}.o" "bcc/mzdynb.{obj|def}")
unix => (lib: "starter"))
extra-dynlibs
mr-bins := (cond mac => (lib: "PLT_MrEd*/")
win => (dll: "libmred"))
mr-bins := (cond mac => (lib: "GRacket*/")
win => (dll: "libgracket"))
extra-dynlibs := (cond win => (dll: "{ssl|lib}eay32"))
@ -411,10 +411,12 @@ binaries := (+ "/plt/bin/"
"/plt/include/"
"/plt/collects/**/compiled/native/"
(cond unix => "/plt/bin/{mzscheme|mred}*"
"/plt/bin/{|g}racket*"
win => "/plt/*.exe"
"/plt/*.dll"
"/plt/collects/launcher/*.exe"
mac => "/plt/bin/mzscheme*"
"/plt/bin/racket*"
"/plt/*.app"
"/plt/collects/launcher/*.app")
platform-dependent)
@ -428,6 +430,9 @@ platform-dependent := ; hook for package rules
mz-extras :+= (- (package: "setup-plt" #:collection "setup/")
(cond (not dr) => (srcfile: "plt-installer{|-sig|-unit}.ss")))
;; -------------------- rico
mz-extras :+= (package: "rico")
;; -------------------- launcher
mz-extras :+= (- (collects: "launcher")
(cond (not mr) => "[Mm]r[Ss]tart*.exe"))
@ -593,7 +598,6 @@ plt-extras :+= (package: "algol60/")
;; -------------------- games
plt-extras :+= (- (+ (package: "games/" #:executable "plt-games")
(doc+src: "gl-board-game/" "cards/"))
"loa/"
"paint-by-numbers/{hattori|solution-sets|raw-problems}")
;; -------------------- texpict & slideshow

12
collects/meta/drdr/analyze.ss
View File

@ -7,6 +7,7 @@
"cache.ss"
"dirstruct.ss"
"status.ss"
"metadata.ss"
"path-utils.ss"
"rendering.ss")
(provide (all-from-out "rendering.ss"))
@ -107,6 +108,7 @@
[responsible-ht-id->str (hash/c symbol? string?)]
[responsible-ht-difference (responsible-ht/c responsible-ht/c . -> . responsible-ht/c)])
(define ERROR-LIMIT 50)
(define (notify cur-rev
start end
duration
@ -174,7 +176,8 @@
(if (empty? paths)
empty
(list (format "\t~a" id)
(for/list ([f (in-list paths)])
(for/list ([f (in-list paths)]
[i (in-range ERROR-LIMIT)])
(format "\t\t~a" (path->url f)))
""))))
"")
@ -185,7 +188,8 @@
(for/list ([(id files) (in-hash (hash-ref responsible-ht r))]
#:when (not (symbol=? id 'changes)))
(list (format "\t~a:" id)
(for/list ([f (in-list files)])
(for/list ([f (in-list files)]
[i (in-range ERROR-LIMIT)])
(format "\t\t~a" (path->url f)))
""))
""))))))
@ -260,7 +264,7 @@
(log-different? output-log (status-output-log (read-cache prev-log-pth))))
#f))
(define responsible
(or (svn-property-value/root (trunk-path log-pth) plt:responsible)
(or (path-responsible (trunk-path log-pth))
(and (regexp-match #rx"/planet/" (path->string* log-pth))
"jay")
; XXX maybe mflatt, eli, or tewk
@ -314,7 +318,7 @@
(and committer?
(with-handlers ([exn:fail? (lambda (x) #f)])
(svn-rev-log-author (read-cache (revision-commit-msg (current-rev))))))
(or (svn-property-value/root (trunk-path dir-pth) plt:responsible)
(or (path-responsible (trunk-path dir-pth))
"unknown"))
empty)

56
collects/meta/drdr/metadata.ss
View File

@ -1,6 +1,8 @@
#lang scheme
(require "path-utils.ss"
"svn.ss")
"dirstruct.ss"
"svn.ss"
scheme/system)
(define (testable-file? pth)
(define suffix (filename-extension pth))
@ -8,11 +10,11 @@
(ormap (lambda (bs) (bytes=? suffix bs))
(list #"ss" #"scm" #"scrbl"))))
(define SVN-PROP:command-line "plt:drdr:command-line")
(define SVN-PROP:timeout "plt:drdr:timeout")
(define PROP:command-line "drdr:command-line")
(define PROP:timeout "drdr:timeout")
(define (path-command-line a-path)
(match (svn-property-value/root a-path SVN-PROP:command-line)
(match (get-prop a-path 'drdr:command-line #f)
[#f
(if (testable-file? a-path)
(list "mzscheme" "-qt" (path->string* a-path))
@ -21,15 +23,49 @@
#f]
[(? string? s)
(map (lambda (s)
(regexp-replace (regexp-quote "$path") s (path->string* a-path)))
(regexp-replace (regexp-quote "~s") s (path->string* a-path)))
(regexp-split #rx" " s))]))
(define (path-timeout a-path)
(with-handlers ([exn:fail? (lambda (x) #f)])
(string->number (svn-property-value/root a-path SVN-PROP:timeout))))
(get-prop a-path 'drdr:timeout #f))
(define (path-responsible a-path)
(get-prop a-path 'responsible #:as-string? #t))
(provide/contract
[SVN-PROP:command-line string?]
[SVN-PROP:timeout string?]
[PROP:command-line string?]
[PROP:timeout string?]
[path-responsible (path-string? . -> . (or/c string? false/c))]
[path-command-line (path-string? . -> . (or/c (listof string?) false/c))]
[path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))])
[path-timeout (path-string? . -> . (or/c exact-nonnegative-integer? false/c))])
;;; Property lookup
(define props-cache (make-hasheq))
(define (get-prop a-fs-path prop [def #f] #:as-string? [as-string? #f])
(define rev (current-rev))
(define a-path
(substring
(path->string
((rebase-path (revision-trunk-dir rev) "/") a-fs-path))
1))
(define props:get-prop
(hash-ref! props-cache rev
(lambda ()
(define tmp-file (make-temporary-file "props~a.ss"))
(and
; Checkout the props file
(system* (svn-path)
"export"
"--quiet"
"-r" (number->string rev)
(format "~a/collects/meta/props" (plt-repository))
(path->string tmp-file))
; Dynamic require it
(begin0
(dynamic-require `(file ,(path->string tmp-file))
'get-prop)
(delete-file tmp-file))))))
(unless props:get-prop
(error 'get-prop "Could not load props file for ~e" (current-rev)))
(props:get-prop a-path prop def
#:as-string? as-string?))

14
collects/meta/drdr/render.ss
View File

@ -11,7 +11,9 @@
revision-trunk-dir)
"status.ss"
"monitor-svn.ss"
"metadata.ss"
(only-in "metadata.ss"
PROP:command-line
PROP:timeout)
"formats.ss"
"path-utils.ss"
"analyze.ss")
@ -416,9 +418,9 @@
@p{Only one build runs at a time and when none is running the SVN repository is polled every @,(number->string (current-monitoring-interval-seconds)) seconds.}
@h1{How is the revision "tested"?}
@p{Each file's @code{@,SVN-PROP:command-line} SVN property is consulted. If it is the empty string, the file is ignored. If it is a string, then @code{$path} is replaced with the file's path, @code{mzscheme} and @code{mzc} with their path (for the current revision), and @code{mred} and @code{mred-text} with @code{mred-text}'s path (for the current revision); then the resulting command-line is executed.
@p{Each file's @code{@,PROP:command-line} property is consulted. If it is the empty string, the file is ignored. If it is a string, then a single @code{~s} is replaced with the file's path, @code{mzscheme} and @code{mzc} with their path (for the current revision), and @code{mred} and @code{mred-text} with @code{mred-text}'s path (for the current revision); then the resulting command-line is executed.
(Currently no other executables are allowed, so you can't @code{rm -fr /}.)
If there is no property value, the default (@code{mzscheme -t $path}) is used if the file's suffix is @code{.ss}, @code{.scm}, or @code{.scrbl}.}
If there is no property value, the default (@code{mzscheme -t ~s}) is used if the file's suffix is @code{.ss}, @code{.scm}, or @code{.scrbl}.}
@p{The command-line is always executed with a fresh empty current directory which is removed after the run. But all the files share the same home directory and X server, which are both removed after each revision's testing is complete.}
@ -426,10 +428,10 @@
@p{One per core, or @,(number->string (number-of-cpus)).}
@h1{How long may a file run?}
@p{The execution timeout is @,(number->string (current-subprocess-timeout-seconds)) seconds by default, but the @code{@,SVN-PROP:timeout} property is used if @code{string->number} returns a number on it.}
@p{The execution timeout is @,(number->string (current-subprocess-timeout-seconds)) seconds by default, but the @code{@,PROP:timeout} property is used if @code{string->number} returns a number on it.}
@h1{May these settings be set on a per-directory basis?}
@p{Yes; if the SVN property is set on any ancestor directory, then its value is used for its descendents when theirs is not set.
@p{Yes; if the property is set on any ancestor directory, then its value is used for its descendents when theirs is not set.
}
@h1{What data is gathered during these runs?}
@ -467,7 +469,7 @@
@p{So DrDr can be effective with all testing packages and untested code, it only pays attention to error output and non-zero exit codes. You can make the most of this strategy by ensuring that when your tests are run successfully they have no STDERR output and exit cleanly, but have both when they fail.}
@h1{How do I fix the reporting of an error in my code?}
@p{If you know you code does not have a bug, but DrDr thinks it does, you can probably fix it by setting its SVN properties: allow it to run longer with @code{@,SVN-PROP:timeout} (but be kind and perhaps change the program to support work load selection on the command-line) or make sure it is run with the right command-line using @code{@,SVN-PROP:command-line}.}
@p{If you know you code does not have a bug, but DrDr thinks it does, you can probably fix it by setting its properties: allow it to run longer with @code{@,PROP:timeout} (but be kind and perhaps change the program to support work load selection on the command-line) or make sure it is run with the right command-line using @code{@,PROP:command-line}.}
@h1{How can I do the most for DrDr?}
@p{The most important thing you can do is eliminate false positives by configuring DrDr for your code and removing spurious error output.}

4
collects/meta/drdr/rendering.ss
View File

@ -2,7 +2,6 @@
(require "list-count.ss")
(define-struct rendering (start end duration timeout? unclean-exit? stderr? responsible changed?) #:prefab)
(define plt:responsible "plt:responsible")
(define (rendering-responsibles r)
(regexp-split #rx"," (rendering-responsible r)))
@ -16,5 +15,4 @@
[stderr? list/count]
[responsible string?]
[changed? list/count])]
[rendering-responsibles (rendering? . -> . (listof string?))]
[plt:responsible string?])
[rendering-responsibles (rendering? . -> . (listof string?))])

45
collects/meta/drdr/svn.ss
View File

@ -1,7 +1,6 @@
#lang scheme
(require xml
"notify.ss"
(prefix-in ffi: (planet jaymccarthy/svn-prop)))
"notify.ss")
(define svn-path
(make-parameter "/opt/local/bin/svn"))
@ -35,48 +34,6 @@
(subprocess-kill the-process #t)
#f)))))
;; Finding out a property going towards the root
(define (sublists l)
(if (empty? l)
empty
(list* l (sublists (rest l)))))
(define (svn-property-value/real working-copy-path property)
#;(printf "propget ~a @ ~a~n" property working-copy-path)
(with-handlers ([exn:fail? (lambda (x) 'error)])
(ffi:svn-property-value working-copy-path property))
#;(match (svn/xml-parse "propget" property working-copy-path)
[(? exn:xml? x)
'error]
[`(properties " ")
'none]
[`(properties " " (target ((path ,_path)) " " (property ((name ,_prop)) ,value) " ") " ")
value]))
(define property-cache (make-hash))
(define (svn-property-value working-copy-path property)
(define key (cons working-copy-path property))
(hash-ref! property-cache key
(lambda ()
(svn-property-value/real working-copy-path property)))
#;(if (hash-has-key? property-cache key)
(or (weak-box-value (hash-ref property-cache key))
(begin (hash-remove! property-cache key)
(svn-property-value working-copy-path property)))
(local [(define val (svn-property-value/real working-copy-path property))]
(hash-set! property-cache key (make-weak-box val))
val)))
(define (svn-property-value/root working-copy-path property)
(define wc-path-parts (reverse (explode-path working-copy-path)))
(define potentials (sublists wc-path-parts))
(for/or ([potential (in-list potentials)])
(define val (svn-property-value (path->string (apply build-path (reverse potential))) property))
(if (string? val) val #f)))
(provide/contract
[svn-property-value/root (path-string? string? . -> . (or/c false/c string?))])
;;; Finding out about SVN revisions
(define-struct svn-rev () #:prefab)

1738
collects/meta/props Executable file
View File

File diff suppressed because it is too large Load Diff

38
collects/mred/installer.ss
View File

@ -1,27 +1,51 @@
#lang scheme/base
(require launcher)
(require launcher compiler/embed)
(provide post-installer)
(define (post-installer path)
(define variants (available-mred-variants))
(for ([v variants] #:when (memq v '(3m cgc)))
(parameterize ([current-launcher-variant v])
(create-embedding-executable
(mred-program-launcher-path "MrEd")
#:cmdline '("-I" "scheme/gui/init")
#:variant v
#:launcher? #t
#:gracket? #t
#:aux '((framework-root . #f)
(dll-dir . #f)
(relative? . #t)))))
;; add a mred-text executable that uses the -z flag (preferring a script)
(for ([vs '((script-3m 3m) (script-cgc cgc))])
(let ([v (findf (lambda (v) (memq v variants)) vs)])
(when v
(parameterize ([current-launcher-variant v])
(make-mred-launcher
(make-gracket-launcher
'("-z")
(mred-program-launcher-path "gracket-text")
'([relative? . #t] [subsystem . console] [single-instance? . #f]
;; the following two are required to avoid using a full path,
;; should be removed when `relative?' will imply this
[framework-root . #f] [dll-dir . #f]))
(make-gracket-launcher
'("-I" "scheme/gui/init" "-z")
(mred-program-launcher-path "mred-text")
'([relative? . #t] [subsystem . console] [single-instance? . #f]
;; the following two are required to avoid using a full path,
;; should be removed when `relative?' will imply this
[framework-root . #f] [dll-dir . #f]))))))
;; add a bin/mred script under OS X
;; add bin/gracket and bin/mred script under OS X
(when (eq? 'macosx (system-type))
(for ([v variants] #:when (memq v '(script-3m script-cgc)))
(parameterize ([current-launcher-variant v])
(make-mred-launcher null
(mred-program-launcher-path "MrEd")
'([exe-name . "MrEd"] [relative? . #t]
[framework-root . #f] [dll-dir . #f]))))))
(make-gracket-launcher
'()
(mred-program-launcher-path "GRacket")
'([exe-name . "GRacket"] [relative? . #t]
[framework-root . #f] [dll-dir . #f]))
(make-gracket-launcher
'()
(mred-program-launcher-path "MrEd")
'([exe-name . "MrEd"] [relative? . #t]
[framework-root . #f] [dll-dir . #f]))))))

18
collects/mred/private/repl.ss
View File

@ -50,14 +50,18 @@
(super-init)
(let ([s (last-position)]
[m (regexp-match #rx"^(.*), (Copyright.*)$" (banner))])
(insert (format "Welcome to ~a." (cadr m)))
(let ([e (last-position)])
(insert #\newline)
(change-style (send (make-object wx:style-delta% 'change-bold) set-delta-foreground "BLUE") s e))
(output (caddr m)))
(insert "This is a simple window for evaluating MrEd Scheme expressions.") (insert #\newline)
(insert (if m
(format "~a." (cadr m))
(let ([b (banner)])
(substring b 0 (sub1 (string-length b))))))
(let ([e (last-position)])
(insert #\newline)
(change-style (send (make-object wx:style-delta% 'change-bold) set-delta-foreground "BLUE") s e))
(when m
(output (caddr m))))
(insert "This is a simple window for evaluating Racket expressions.") (insert #\newline)
(let ([s (last-position)])
(insert "Quit now and run DrScheme to get a better window.")
(insert "Quit now and run DrRacket to get a better window.")
(let ([e (last-position)])
(insert #\newline)
(change-style

169
collects/mzlib/include.ss
View File

@ -76,91 +76,102 @@
(syntax-case stx ()
[(_ orig-stx ctx loc fn reader)
;; Parse the file name
(let ([c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)]
(let ([orig-c-file (resolve-path-spec (syntax fn) (syntax loc) (syntax orig-stx) #'build-path)]
[ctx (syntax ctx)]
[loc (syntax loc)]
[reader (syntax reader)]
[orig-stx (syntax orig-stx)])
[orig-stx (syntax orig-stx)]
[rkt->ss (lambda (p)
(let ([b (path->bytes p)])
(if (regexp-match? #rx#"[.]rkt$" b)
(path-replace-suffix p #".ss")
p)))])
(register-external-file c-file)
(let ([c-file (if (file-exists? orig-c-file)
orig-c-file
(let ([p2 (rkt->ss orig-c-file)])
(if (file-exists? p2)
p2
orig-c-file)))])
(register-external-file c-file)
(let ([read-syntax (if (syntax-e reader)
(reader-val
(let loop ([e (syntax-object->datum
(local-expand reader 'expression null))])
(cond
[(reader? e) e]
[(pair? e) (or (loop (car e))
(loop (cdr e)))]
[else #f])))
read-syntax)])
(unless (and (procedure? read-syntax)
(procedure-arity-includes? read-syntax 2))
(raise-syntax-error
#f
"reader is not a procedure of two arguments"
orig-stx))
(let ([read-syntax (if (syntax-e reader)
(reader-val
(let loop ([e (syntax-object->datum
(local-expand reader 'expression null))])
(cond
[(reader? e) e]
[(pair? e) (or (loop (car e))
(loop (cdr e)))]
[else #f])))
read-syntax)])
(unless (and (procedure? read-syntax)
(procedure-arity-includes? read-syntax 2))
(raise-syntax-error
#f
"reader is not a procedure of two arguments"
orig-stx))
;; Open the included file
(let ([p (with-handlers ([exn:fail?
(lambda (exn)
(raise-syntax-error
#f
(format
"can't open include file (~a)"
(if (exn? exn)
(exn-message exn)
exn))
orig-stx
c-file))])
(open-input-file c-file))])
(port-count-lines! p)
;; Read expressions from file
(let ([content
(let loop ()
(let ([r (with-handlers ([exn:fail?
(lambda (exn)
(close-input-port p)
(raise-syntax-error
#f
(format
"read error (~a)"
(if (exn? exn)
(exn-message exn)
exn))
orig-stx))])
(read-syntax c-file p))])
(if (eof-object? r)
null
(cons r (loop)))))])
(close-input-port p)
;; Preserve src info for content, but set its
;; lexical context to be that of the include expression
(let ([lexed-content
(let loop ([content content])
(cond
[(pair? content)
(cons (loop (car content))
(loop (cdr content)))]
[(null? content) null]
[else
(let ([v (syntax-e content)])
(datum->syntax-object
ctx
(cond
[(pair? v)
(loop v)]
[(vector? v)
(list->vector (loop (vector->list v)))]
[(box? v)
(box (loop (unbox v)))]
[else
v])
content))]))])
(datum->syntax-object
(quote-syntax here)
`(begin ,@lexed-content)
orig-stx))))))]))
;; Open the included file
(let ([p (with-handlers ([exn:fail?
(lambda (exn)
(raise-syntax-error
#f
(format
"can't open include file (~a)"
(if (exn? exn)
(exn-message exn)
exn))
orig-stx
c-file))])
(open-input-file c-file))])
(port-count-lines! p)
;; Read expressions from file
(let ([content
(let loop ()
(let ([r (with-handlers ([exn:fail?
(lambda (exn)
(close-input-port p)
(raise-syntax-error
#f
(format
"read error (~a)"
(if (exn? exn)
(exn-message exn)
exn))
orig-stx))])
(read-syntax c-file p))])
(if (eof-object? r)
null
(cons r (loop)))))])
(close-input-port p)
;; Preserve src info for content, but set its
;; lexical context to be that of the include expression
(let ([lexed-content
(let loop ([content content])
(cond
[(pair? content)
(cons (loop (car content))
(loop (cdr content)))]
[(null? content) null]
[else
(let ([v (syntax-e content)])
(datum->syntax-object
ctx
(cond
[(pair? v)
(loop v)]
[(vector? v)
(list->vector (loop (vector->list v)))]
[(box? v)
(box (loop (unbox v)))]
[else
v])
content))]))])
(datum->syntax-object
(quote-syntax here)
`(begin ,@lexed-content)
orig-stx)))))))]))
(define (include/proc stx)
(syntax-case stx ()

14
collects/mzlib/pconvert.ss
View File

@ -1,10 +1,8 @@
(module pconvert mzscheme
(require (only "string.ss" expr->string)
(only "list.ss" sort)
(require (only "list.ss" sort)
scheme/mpair
"etc.ss"
"pconvert-prop.ss"
"class.ss")
@ -169,7 +167,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define map-share-name
(lambda (name)
(string->symbol (string-append "-" (expr->string name) "-"))))
(string->symbol (format "-~s-" name))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; prints an expression given that it has already been hashed. This
@ -458,8 +456,7 @@
[str-name (if (string? name)
name
(symbol->string name))])
(string->symbol (string-append "make-" str-name))))]
[uniq (begin-lifted (box #f))])
(string->symbol (string-append "make-" str-name))))])
`(,constructor
,@(map (lambda (x)
(if (eq? uniq x)
@ -497,6 +494,7 @@
[(null? x) null]
[else (f x)]))
(define uniq (gensym))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; these functions get the list of shared items. If just-circular is
@ -536,8 +534,8 @@
(get-shared-helper csi))
(get-shared-helper csi))]
[cmp (lambda (x y)
(string<? (expr->string (share-info-name (car x)))
(expr->string (share-info-name (car y)))))])
(string<? (format "~s" (share-info-name (car x)))
(format "~s" (share-info-name (car y)))))])
(map cdr (sort shared-listss cmp)))]))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

12
collects/mzlib/private/unit-compiletime.ss
View File

@ -103,9 +103,10 @@
;; (listof identifier)
;; (listof (cons (listof identifier) syntax-object))
;; (listof (cons (listof identifier) syntax-object))
;; (listof (cons (listof identifier) syntax-object))
;; (listof (U syntax-object #f))
;; identifier)
(define-struct/proc signature (siginfo vars val-defs stx-defs ctcs orig-binder)
(define-struct/proc signature (siginfo vars val-defs stx-defs post-val-defs ctcs orig-binder)
(lambda (_ stx)
(parameterize ((error-syntax stx))
(raise-stx-err "illegal use of signature name"))))
@ -233,6 +234,7 @@
(vars (signature-vars sig))
(vals (signature-val-defs sig))
(stxs (signature-stx-defs sig))
(p-vals (signature-post-val-defs sig))
(ctcs (signature-ctcs sig))
(delta-introduce (if bind?
(let ([f (syntax-local-make-delta-introducer
@ -259,7 +261,8 @@
(car stx))
(cdr stx)))
stxs)
ctcs))))
ctcs
p-vals))))
(define (sig-names sig)
(append (car sig)
@ -292,7 +295,10 @@
(list (map (lambda (x) (cons (f (car x)) (g (cdr x)))) (car sig))
(map (lambda (x) (map-def f g x)) (cadr sig))
(map (lambda (x) (map-def f g x)) (caddr sig))
(map (lambda (x) (map-ctc f g x)) (cadddr sig))))
(map (lambda (x) (map-ctc f g x)) (cadddr sig))
(map (lambda (x) (cons (map f (car x))
(g (cdr x))))
(list-ref sig 4))))
;; An import-spec is one of
;; - signature-name

2
collects/mzlib/restart.ss
View File

@ -111,7 +111,7 @@
(init-namespace)
(when scheme?
(namespace-require 'scheme))
(namespace-require 'scheme/init))
(let/ec k
(exit-handler

18
collects/mzlib/scribblings/unit.scrbl
View File

@ -37,3 +37,21 @@ but with a different syntax for the options that limit exports.}
A signature form like @scheme-struct/ctc from @schememodname[scheme/unit],
but with a different syntax for the options that limit exports.}
@deftogether[(
@defidform[struct~s]
@defidform[struct~s/ctc]
)]{
The same as @|scheme-struct| and @|scheme-struct/ctc| from
@schememodname[scheme/unit].}
@deftogether[(
@defidform[struct~r]
@defidform[struct~r/ctc]
)]{
Like @scheme[struct~s] and @scheme[struct~s/ctc], but the constructor is
named the same as the type, instead of with @schemeidfont{make-} prefix.}

328
collects/mzlib/unit.ss
View File

@ -8,6 +8,7 @@
syntax/name
syntax/parse
syntax/struct
scheme/struct-info
syntax/stx
unstable/location
"private/unit-contract-syntax.ss"
@ -21,11 +22,13 @@
"private/unit-contract.ss"
"private/unit-keywords.ss"
"private/unit-runtime.ss"
"private/unit-utils.ss")
"private/unit-utils.ss"
(rename-in racket/private/struct [struct struct~]))
(provide define-signature-form struct struct/ctc open
define-signature provide-signature-elements
only except rename import export prefix link tag init-depend extends contracted
define-values-for-export
unit?
(rename-out [:unit unit]) define-unit
compound-unit define-compound-unit compound-unit/infer define-compound-unit/infer
@ -35,7 +38,9 @@
define-unit-binding
unit/new-import-export define-unit/new-import-export
unit/s define-unit/s
unit/c define-unit/contract)
unit/c define-unit/contract
struct~s struct~s/ctc
struct~r struct~r/ctc)
(define-syntax/err-param (define-signature-form stx)
(syntax-case stx ()
@ -130,6 +135,133 @@
((_)
(raise-stx-err "missing name and fields")))))
(begin-for-syntax
(define-struct self-name-struct-info (id)
#:super struct:struct-info
#:property prop:procedure (lambda (me stx)
(syntax-case stx ()
[(_ arg ...) (datum->syntax
stx
(cons (self-name-struct-info-id me)
#'(arg ...))
stx
stx)]
[_ (let ([id (self-name-struct-info-id me)])
(datum->syntax id
(syntax-e id)
stx
stx))]))
#:omit-define-syntaxes))
;; Replacement `struct' signature form for `scheme/unit':
(define-for-syntax (do-struct~ stx type-as-ctr?)
(syntax-case stx ()
((_ name (field ...) opt ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))]
[(tmp-name) (and type-as-ctr?
(car (generate-temporaries #'(name))))])
(cons
#`(define-syntaxes (name)
#,(let ([e (build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?
#:constructor-name (and type-as-ctr? (cons #'name tmp-name)))])
(if type-as-ctr?
#`(make-self-name-struct-info
(lambda () #,e)
(quote-syntax #,tmp-name))
e)))
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?)
#:constructor-name (and type-as-ctr?
(cons #'name tmp-name)))])
(cond
[no-ctr? (cons (car names) (cddr names))]
[tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)]
[else names]))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx))))
(define-signature-form (struct~s stx)
(do-struct~ stx #f))
(define-signature-form (struct~r stx)
(do-struct~ stx #t))
(define-signature-form (struct/ctc stx)
(parameterize ((error-syntax stx))
(syntax-case stx ()
@ -214,28 +346,164 @@
((_)
(raise-stx-err "missing name and fields")))))
;; Replacement struct/ctc form for `scheme/unit':
(define-for-syntax (do-struct~/ctc stx type-as-ctr?)
(syntax-case stx ()
((_ name ([field ctc] ...) opt ...)
(begin
(unless (identifier? #'name)
(raise-syntax-error #f
"expected an identifier to name the structure type"
stx
#'name))
(for-each (lambda (field)
(unless (identifier? field)
(syntax-case field ()
[(id #:mutable)
(identifier? #'id)
'ok]
[_
(raise-syntax-error #f
"bad field specification"
stx
field)])))
(syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
(let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f]
[mutable? #f]
[no-stx? #f]
[no-rt? #f])
(if (null? opts)
(values no-ctr? mutable? no-stx? no-rt?)
(let ([opt (car opts)])
(case (syntax-e opt)
[(#:omit-constructor)
(if no-ctr?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
[(#:mutable)
(if mutable?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
[(#:omit-define-syntaxes)
(if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
stx
opt)]))))]
[(tmp-name) (and type-as-ctr?
(car (generate-temporaries #'(name))))])
(define (add-contracts l)
(let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)]
[pred-ctc #'(-> any/c boolean?)]
[field-ctcs
(apply append
(map (λ (f c)
(cons #`(-> #,pred #,c)
(if (and (not mutable?)
(not (pair? (syntax-e f))))
null
#`(-> #,pred #,c void?))))
(syntax->list #'(field ...))
(syntax->list #'(ctc ...))))])
(list* (car l)
(list (cadr l) ctor-ctc)
(list pred pred-ctc)
(map list (cdddr l) field-ctcs))))
(cons
#`(define-syntaxes (name)
#,(build-struct-expand-info
#'name (syntax->list #'(field ...))
#f (not mutable?)
#f '(#f) '(#f)
#:omit-constructor? no-ctr?
#:constructor-name (and type-as-ctr? (cons #'name tmp-name))))
(let* ([names (add-contracts
(build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?)
#:constructor-name (and type-as-ctr?
(cons #'name tmp-name))))]
[cpairs (cons 'contracted
(if no-ctr? (cddr names) (cdr names)))])
(list (car names) cpairs))))))
((_ name fields opt ...)
(raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields"
stx
#'fields))
((_ name)
(raise-syntax-error #f
"bad syntax; missing fields"
stx))
((_)
(raise-syntax-error #f
"missing name and fields"
stx))))
(define-signature-form (struct~s/ctc stx)
(do-struct~/ctc stx #f))
(define-signature-form (struct~r/ctc stx)
(do-struct~/ctc stx #t))
;; build-val+macro-defs : sig -> (list syntax-object^3)
(define-for-syntax (build-val+macro-defs sig)
(with-syntax ([(((int-ivar . ext-ivar) ...)
((((int-vid . ext-vid) ...) . vbody) ...)
((((int-sid . ext-sid) ...) . sbody) ...)
(cbody ...))
_
_)
(map-sig (lambda (x) x)
(make-syntax-introducer)
sig)])
(list
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
(values
(make-rename-transformer
(quote-syntax int-ivar)) ...
(make-rename-transformer
(quote-syntax int-vid)) ... ...
(make-rename-transformer
(quote-syntax int-sid)) ... ...))
(make-rename-transformer (quote-syntax int-ivar)) ...
(make-rename-transformer (quote-syntax int-vid)) ... ...
(make-rename-transformer (quote-syntax int-sid)) ... ...))
#'(((int-sid ...) sbody) ...)
#'(((int-vid ...) vbody) ...))))
;; build-post-val-defs : sig -> (list syntax-object)
(define-for-syntax (build-post-val-defs sig)
(with-syntax ([(((int-ivar . ext-ivar) ...)
((((int-vid . ext-vid) ...) . _) ...)
((((int-sid . ext-sid) ...) . _) ...)
_
(((post-id ...) . post-rhs) ...))
(map-sig (lambda (x) x)
(make-syntax-introducer)
sig)])
(list
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
(values
(make-rename-transformer (quote-syntax int-ivar)) ...
(make-rename-transformer (quote-syntax int-vid)) ... ...
(make-rename-transformer (quote-syntax int-sid)) ... ...))
#'(post-rhs ...))))
(define-signature-form (open stx)
(define (build-sig-elems sig)
@ -261,7 +529,9 @@
(_
(raise-stx-err (format "must match (~a export-spec)"
(syntax-e (stx-car stx))))))))
(define-signature-form (define-values-for-export stx)
(raise-syntax-error #f "internal error" stx))
(define-for-syntax (introduce-def d)
(cons (map syntax-local-introduce (car d))
@ -273,7 +543,8 @@
(raise-stx-err "expected syntax matching (sig-expr ...)" sig-exprs))
(let ([ses (checked-syntax->list sig-exprs)])
(define-values (super-names super-ctimes super-rtimes super-bindings
super-val-defs super-stx-defs super-ctcs)
super-val-defs super-stx-defs super-post-val-defs
super-ctcs)
(if super-sigid
(let* ([super-sig (lookup-signature super-sigid)]
[super-siginfo (signature-siginfo super-sig)])
@ -284,22 +555,25 @@
(map syntax-local-introduce (signature-vars super-sig))
(map introduce-def (signature-val-defs super-sig))
(map introduce-def (signature-stx-defs super-sig))
(map introduce-def (signature-post-val-defs super-sig))
(map (lambda (ctc)
(if ctc
(syntax-local-introduce ctc)
ctc))
(signature-ctcs super-sig))))
(values '() '() '() '() '() '() '())))
(values '() '() '() '() '() '() '() '())))
(let loop ((sig-exprs ses)
(bindings null)
(val-defs null)
(stx-defs null)
(post-val-defs null)
(ctcs null))
(cond
((null? sig-exprs)
(let* ([all-bindings (append super-bindings (reverse bindings))]
[all-val-defs (append super-val-defs (reverse val-defs))]
[all-stx-defs (append super-stx-defs (reverse stx-defs))]
[all-post-val-defs (append super-post-val-defs (reverse post-val-defs))]
[all-ctcs (append super-ctcs (reverse ctcs))]
[dup
(check-duplicate-identifier
@ -313,7 +587,8 @@
((var ...) all-bindings)
((ctc ...) all-ctcs)
((((vid ...) . vbody) ...) all-val-defs)
((((sid ...) . sbody) ...) all-stx-defs))
((((sid ...) . sbody) ...) all-stx-defs)
((((pvid ...) . pvbody) ...) all-post-val-defs))
#`(begin
(define signature-tag (gensym))
(define-syntax #,sigid
@ -332,6 +607,10 @@
((syntax-local-certifier)
(quote-syntax sbody)))
...)
(list (cons (list (quote-syntax pvid) ...)
((syntax-local-certifier)
(quote-syntax pvbody)))
...)
(list #,@(map (lambda (c)
(if c
#`((syntax-local-certifier)
@ -351,7 +630,7 @@
(syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
(x
(identifier? #'x)
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs (cons #f ctcs)))
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs post-val-defs (cons #f ctcs)))
((x (y z) ...)
(and (identifier? #'x)
(free-identifier=? #'x #'contracted)
@ -360,6 +639,7 @@
(append (syntax->list #'(y ...)) bindings)
val-defs
stx-defs
post-val-defs
(append (syntax->list #'(z ...)) ctcs)))
((x . z)
(and (identifier? #'x)
@ -371,7 +651,8 @@
((x . y)
(and (identifier? #'x)
(or (free-identifier=? #'x #'define-values)
(free-identifier=? #'x #'define-syntaxes)))
(free-identifier=? #'x #'define-syntaxes)
(free-identifier=? #'x #'define-values-for-export)))
(begin
(check-def-syntax (car sig-exprs))
(syntax-case #'y ()
@ -390,12 +671,19 @@
(cons (cons (syntax->list #'(name ...)) b)
stx-defs)
stx-defs)
(if (free-identifier=? #'x #'define-values-for-export)
(cons (cons (syntax->list #'(name ...)) b)
post-val-defs)
post-val-defs)
ctcs)))))))
((x . y)
(let ((trans
(set!-trans-extract
(syntax-local-value
(syntax-local-introduce #'x)
;; redirect struct~ to struct~r
(if (free-identifier=? #'x #'struct~)
#'struct~r
(syntax-local-introduce #'x))
(lambda ()
(raise-stx-err "unknown signature form" #'x))))))
(unless (signature-form? trans)
@ -409,6 +697,7 @@
bindings
val-defs
stx-defs
post-val-defs
ctcs))))
(x (raise-stx-err
"expected either an identifier or signature form"
@ -532,6 +821,8 @@
(map build-val+macro-defs import-sigs)]
[(((int-ivar . ext-ivar) ...) ...) (map car import-sigs)]
[(((int-evar . ext-evar) ...) ...) (map car export-sigs)]
[((((e-post-id ...) . _) ...) ...) (map (lambda (s) (list-ref s 4)) export-sigs)]
[((post-renames (e-post-rhs ...)) ...) (map build-post-val-defs export-sigs)]
[((iloc ...) ...)
(map (lambda (x) (generate-temporaries (car x))) import-sigs)]
[((eloc ...) ...)
@ -602,7 +893,10 @@
(int-evar ... ...)
(eloc ... ...)
(ectc ... ...)
. body)))))
(begin . body)
(define-values (e-post-id ...)
(letrec-syntaxes+values (post-renames ...) ()
e-post-rhs)) ... ...)))))
(unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...)))))))
import-tagged-sigids
export-tagged-sigids

2
collects/mzscheme/info.ss
View File

@ -2,6 +2,8 @@
(define version '(400))
(define post-install-collection "installer.ss")
(define scribblings '(("mzscheme.scrbl" (multi-page) (legacy))))
(define compile-omit-paths '("examples"))

17
collects/mzscheme/installer.ss Normal file
View File

@ -0,0 +1,17 @@
#lang scheme/base
(require launcher compiler/embed)
(provide post-installer)
(define (post-installer path)
(define variants (available-mzscheme-variants))
(for ([v (in-list variants)])
(parameterize ([current-launcher-variant v])
(create-embedding-executable
(mzscheme-program-launcher-path "MzScheme")
#:variant v
#:cmdline '("-I" "scheme/init")
#:launcher? #t
#:aux '((framework-root . #f)
(dll-dir . #f)
(relative? . #t))))))

2
collects/planet/info.ss
View File

@ -4,3 +4,5 @@
(define mzscheme-launcher-names '("planet"))
(define mzscheme-launcher-libraries '("planet.ss"))
(define scribblings '(("planet.scrbl" (multi-page) (tool))))
(define rico '(("planet" planet/planet "manage Planet package installations" 80)))

3
collects/planet/planet.ss
View File

@ -11,6 +11,7 @@ PLANNED FEATURES:
(only mzlib/list sort)
net/url
mzlib/match
rico/command-name
"config.ss"
"private/planet-shared.ss"
@ -27,7 +28,7 @@ PLANNED FEATURES:
(planet-logging-to-stdout #t)
(svn-style-command-line
#:program "planet"
#:program (short-program+command-name)
#:argv (current-command-line-arguments)
"PLT Scheme PLaneT command-line tool. Provides commands to help you manipulate your local planet cache."
["create" "create a PLaneT archive from a directory"

1
collects/plot/src/.gitignore vendored Normal file
View File

@ -0,0 +1 @@
/tmp/

3
collects/r6rs/run.ss
View File

@ -202,6 +202,7 @@
(let ([code (get-module-code main #:source-reader r6rs-read-syntax)]
[rpath (module-path-index-resolve
(module-path-index-join main #f))])
(parameterize ([current-module-declare-name rpath])
(parameterize ([current-module-declare-name rpath]
[current-module-declare-source main])
(eval code))
(dynamic-require rpath #f))))])

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