Merge branch 'master' into samth/new-logic2
This commit is contained in:
commit
c50cb0ff18
3
.mailmap
Normal file
3
.mailmap
Normal file
|
@ -0,0 +1,3 @@
|
|||
Eli Barzilay <eli@racket-lang.org> <eli@barzilay.org>
|
||||
Kevin Tew <tewk@racket-lang.org> <tewk@tan.tewk.com>
|
||||
Sam Tobin-Hochstadt <samth@racket-lang.org> <samth@punge.ccs.neu.edu>
|
|
@ -53,6 +53,8 @@
|
|||
transform the clauses into the initial arguments specification
|
||||
for a new expression that instantiates the appropriate class
|
||||
|
||||
ensure that the initial state (state0) is not in the shape of a clause
|
||||
|
||||
ensure that all clauses mention only keywords specified in AllSpec or PartSpec
|
||||
move the contracts from AppSpecl and PartSpec to the clauses
|
||||
|
||||
|
@ -60,12 +62,13 @@
|
|||
|
||||
if anything fails, use the legal keyword to specialize the error message
|
||||
|#
|
||||
(define (->args tag stx clauses AllSpec PartSpec ->rec? legal)
|
||||
(define (->args tag stx state0 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))
|
||||
(duplicates? tag spec)
|
||||
(not-a-clause tag stx state0 kwds)
|
||||
(map (lambda (x)
|
||||
(define kw (car x))
|
||||
(define-values (key coercion)
|
||||
|
@ -78,6 +81,15 @@
|
|||
(list key (coercion (cdr x))))
|
||||
spec))
|
||||
|
||||
;; Symbol Syntax Syntax [Listof Kw] -> true
|
||||
;; effect: if state0 looks like a clause, raise special error
|
||||
(define (not-a-clause tag stx state0 kwds)
|
||||
(syntax-case state0 ()
|
||||
[(kw . E)
|
||||
((->kwds-in kwds) #'kw)
|
||||
(raise-syntax-error tag "missing initial state" stx)]
|
||||
[_ #t]))
|
||||
|
||||
;; Symbol [Listof kw] -> true
|
||||
;; effect: raise syntax error about duplicated clause
|
||||
(define (duplicates? tag lox)
|
||||
|
|
|
@ -37,4 +37,23 @@
|
|||
(raise e)))))
|
||||
(eval '(module a scheme
|
||||
(require 2htdp/universe)
|
||||
(big-bang 0 (on-tick add1) stop-when))))
|
||||
(big-bang 0 (on-tick add1) stop-when))))
|
||||
|
||||
;; -----------------------------------------------------------------------------
|
||||
;; purpose: catch illegal big-bang use w/o world expression
|
||||
|
||||
(with-handlers ((exn:fail:syntax?
|
||||
(lambda (x)
|
||||
(unless (string=? (exn-message x) "big-bang: missing initial state")
|
||||
(raise x)))))
|
||||
(eval '(module a scheme
|
||||
(require 2htdp/universe)
|
||||
(big-bang (on-key add1)))))
|
||||
|
||||
(with-handlers ((exn:fail:syntax?
|
||||
(lambda (x)
|
||||
(unless (string=? (exn-message x) "universe: missing initial state")
|
||||
(raise x)))))
|
||||
(eval '(module a scheme
|
||||
(require 2htdp/universe)
|
||||
(universe (on-msg sub1) (on-new add1)))))
|
||||
|
|
|
@ -179,7 +179,7 @@
|
|||
[(V) (set! rec? #'V)]
|
||||
[_ (err '#'record? stx)])))]
|
||||
[args
|
||||
(->args 'big-bang stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
|
||||
(->args 'big-bang stx (syntax w) (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
|
||||
#`(let* ([esp (make-eventspace)]
|
||||
[thd (eventspace-handler-thread esp)])
|
||||
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
|
||||
|
@ -276,7 +276,7 @@
|
|||
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
|
||||
[(universe u bind ...)
|
||||
(let*
|
||||
([args (->args 'universe stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
|
||||
([args (->args 'universe stx (syntax u) (syntax (bind ...)) AllSpec UniSpec void "universe")]
|
||||
[domain (map (compose syntax-e car) args)])
|
||||
(cond
|
||||
[(not (memq 'on-new domain))
|
||||
|
|
|
@ -173,7 +173,7 @@
|
|||
(bytes=? (subbytes b 0 len) skip-path)))
|
||||
-inf.0))])
|
||||
(let* ([sses (append
|
||||
;; Find all .ss/.scm files:
|
||||
;; Find all .rkt/.ss/.scm files:
|
||||
(filter extract-base-filename/ss (directory-list))
|
||||
;; Add specified doc sources:
|
||||
(if skip-docs?
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide add-plt-segment
|
||||
get/set-dylib-path)
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide bytes->utf-16-bytes
|
||||
utf-16-bytes->bytes)
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "config.ss")
|
||||
(provide (all-from-out "config.ss"))
|
||||
|
|
|
@ -48,7 +48,7 @@
|
|||
[else #f]))
|
||||
extract-base-filename)])
|
||||
(values
|
||||
(mk 'extract-base-filename/ss #"ss|scm" "Scheme" #f)
|
||||
(mk 'extract-base-filename/ss #"rkt|ss|scm" "Racket" #f)
|
||||
(mk 'extract-base-filename/c
|
||||
#"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m")
|
||||
(mk 'extract-base-filename/kp #"kp" "constant pool" ".kp")
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(require syntax/moddep
|
||||
mzlib/class
|
||||
scheme/private/namespace
|
||||
racket/private/namespace
|
||||
mred)
|
||||
|
||||
(provide eval/annotations
|
||||
|
|
|
@ -2,6 +2,52 @@
|
|||
|
||||
;; 4. integrate with snips
|
||||
|
||||
#|
|
||||
|
||||
From: Mark Engelberg <mark.engelberg@gmail.com>
|
||||
|
||||
|
||||
In a flash of inspiration, I searched on matrix, and turned up the
|
||||
matrix teachpack. I really like it! I especially like:
|
||||
* the ease of converting back and forth between "rectangles" and "matrices"
|
||||
* the multiple ways of constructing matrices
|
||||
* the ability to set cells non-destructively or destructively
|
||||
|
||||
Two questions:
|
||||
1. The documentation warns that the teachpack is experimental. Are
|
||||
there any major problems I need to be aware of, or is the warning just
|
||||
an indicator that the API is likely to continue to be revised?
|
||||
2. Are there other similar built-in PLT Scheme libraries that I should
|
||||
be aware of, or is this the main one I should be considering?
|
||||
|
||||
A few API comments and suggestions:
|
||||
|
||||
matrix-render is a nice low-level function for extracting information
|
||||
from the matrix in preparation for displaying or printing, but perhaps
|
||||
there could also be a higher-level matrix->string function.
|
||||
For example,
|
||||
(define (matrix->string m col-separator row-separator)
|
||||
(string-join (map (λ (row) (string-join row col-separator))
|
||||
(matrix-render m)) row-separator))
|
||||
|
||||
Since matrix-ref returns an error with a bogus row,column, it would be
|
||||
nice to be able to easily test for that in advance:
|
||||
(define (matrix-within-bounds? m i j)
|
||||
(and (<= 0 i) (< i (matrix-rows m)) (<= 0 j) (< j (matrix-cols m))))
|
||||
or alternatively adjust matrix-ref to take an optional argument to
|
||||
return if the entry is invalid (like hash-ref).
|
||||
|
||||
Since matrix-where? returns a list of posn structures, it would be
|
||||
ideal if the other matrix functions (e.g., matrix-ref, matrix-set)
|
||||
could optionally consume a single posn rather than a separate i and j.
|
||||
|
||||
Speaking of which, shouldn't the matrix teachpack automatically
|
||||
provide lang/posn so that you can call posn-x and posn-y on the
|
||||
position structures returned by matrix-where?
|
||||
|
||||
|#
|
||||
|
||||
|
||||
(require htdp/matrix-sig
|
||||
htdp/matrix-render-sig
|
||||
htdp/matrix-unit
|
||||
|
|
|
@ -297,6 +297,9 @@
|
|||
" if so, it produces the suffix of the list that starts with x"
|
||||
" if not, it produces false."
|
||||
" (it compares values with the eqv? predicate.)")
|
||||
((beginner-member member?) (any (listof any) -> boolean)
|
||||
"to determine whether some value is on the list"
|
||||
" (comparing values with equal?)")
|
||||
((beginner-member member) (any (listof any) -> boolean)
|
||||
"to determine whether some value is on the list"
|
||||
" (comparing values with equal?)")
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
|
||||
#lang scheme/base
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax scheme/private/struct-info)
|
||||
(for-syntax racket/private/struct-info)
|
||||
scheme/list
|
||||
scheme/match
|
||||
unstable/struct
|
||||
|
|
|
@ -156,9 +156,10 @@ docsrc-filter := (+ (collects: "setup/scribble.ss") ; only with doc sources
|
|||
std-docs)
|
||||
man-filter := (man: "*")
|
||||
tests-filter := (+ (collects: "**/tests/") (srcfile: "tests.ss"))
|
||||
gui-filter := (- (+ (collects: "**/gui/") (srcfile: "gui.ss"))
|
||||
gui-filter := (- (+ (collects: "**/gui/") (srcfile: "gui.rkt"))
|
||||
;; for use in mz code that works in mr too
|
||||
(srcfile: "scheme/gui/dynamic.ss"))
|
||||
(srcfile: "scheme/gui/dynamic.rkt")
|
||||
(srcfile: "racket/gui/dynamic.rkt"))
|
||||
tools-filter := (+ (collects: "**/tools/") (srcfile: "tools.ss"))
|
||||
|
||||
;; these are in the doc directory, but are comitted in svn and should be
|
||||
|
|
|
@ -197,9 +197,7 @@
|
|||
(lambda ()
|
||||
(define l (pth-cmd))
|
||||
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]
|
||||
["HOME" (home-dir (current-worker))])
|
||||
; XXX Maybe this should destroy the old home and copy in a new one
|
||||
; Otherwise it is a source of randomness
|
||||
["HOME" (make-fresh-home-dir)])
|
||||
(with-temporary-directory
|
||||
(run/collect/wait/log log-pth
|
||||
#:timeout pth-timeout
|
||||
|
@ -234,14 +232,6 @@
|
|||
(build-path log-dir "src" "build" "set-browser.ss")
|
||||
mzscheme-path
|
||||
(list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss"))))
|
||||
; Make home directories
|
||||
(cache/file/timestamp
|
||||
(build-path rev-dir "homedir-dup")
|
||||
(lambda ()
|
||||
(notify! "Copying home directory for each worker")
|
||||
(for ([i (in-range (number-of-cpus))])
|
||||
(with-handlers ([exn:fail? void])
|
||||
(copy-directory/files (hash-ref (current-env) "HOME") (home-dir i))))))
|
||||
; And go
|
||||
(notify! "Starting testing")
|
||||
(test-directory collects-pth top-sema)
|
||||
|
@ -250,10 +240,11 @@
|
|||
(notify! "Stopping testing")
|
||||
(stop-job-queue! test-workers))
|
||||
|
||||
(define (home-dir i)
|
||||
(format "~a~a"
|
||||
(hash-ref (current-env) "HOME")
|
||||
i))
|
||||
(define (make-fresh-home-dir)
|
||||
(define new-dir (make-temporary-file "home~a" 'directory))
|
||||
(with-handlers ([exn:fail? void])
|
||||
(copy-directory/files (hash-ref (current-env) "HOME") new-dir))
|
||||
(path->string new-dir))
|
||||
|
||||
(define (recur-many i r f)
|
||||
(if (zero? i)
|
||||
|
|
|
@ -557,7 +557,8 @@
|
|||
(define name (path->string rev-pth))
|
||||
(define url (format "~a/" name))
|
||||
(define rev (string->number name))
|
||||
(define log (read-cache (revision-commit-msg rev)))
|
||||
(define log-pth (revision-commit-msg rev))
|
||||
(define log (read-cache log-pth))
|
||||
(define committer (svn-rev-log-author log))
|
||||
(define commit-msg (string-first-line (svn-rev-log-msg log)))
|
||||
(define title
|
||||
|
@ -566,7 +567,7 @@
|
|||
commit-msg))
|
||||
(define (no-rendering-row)
|
||||
(define mtime
|
||||
(file-or-directory-modify-seconds (build-path builds-pth rev-pth)))
|
||||
(file-or-directory-modify-seconds log-pth))
|
||||
|
||||
`(tr ([class "dir"]
|
||||
[title ,title])
|
||||
|
|
|
@ -1,30 +1,31 @@
|
|||
#lang scheme
|
||||
(require "dirstruct.ss"
|
||||
"status.ss")
|
||||
(require "status.ss")
|
||||
|
||||
(define (rewrite-status s)
|
||||
(if (current-rev)
|
||||
(local [(define from (number->string (current-rev)))]
|
||||
(match s
|
||||
[(struct exit (start end command-line output-log code))
|
||||
(make-exit start end (rewrite-strings from command-line) (rewrite-events from output-log) code)]
|
||||
[(struct timeout (start end command-line output-log))
|
||||
(make-timeout start end (rewrite-strings from command-line) (rewrite-events from output-log))]))
|
||||
s))
|
||||
(define (rewrite-status #:rewrite rewrite-string s)
|
||||
(match s
|
||||
[(struct exit (start end command-line output-log code))
|
||||
(make-exit start end
|
||||
(rewrite-strings #:rewrite rewrite-string command-line)
|
||||
(rewrite-events #:rewrite rewrite-string output-log)
|
||||
code)]
|
||||
[(struct timeout (start end command-line output-log))
|
||||
(make-timeout start end
|
||||
(rewrite-strings #:rewrite rewrite-string command-line)
|
||||
(rewrite-events #:rewrite rewrite-string output-log))]))
|
||||
|
||||
(define (rewrite-strings from los)
|
||||
(map (curry rewrite-string from) los))
|
||||
(define (rewrite-events from loe)
|
||||
(map (rewrite-event from) loe))
|
||||
(define (rewrite-event from)
|
||||
(define (rewrite-strings #:rewrite rewrite-string los)
|
||||
(map rewrite-string los))
|
||||
(define (rewrite-events #:rewrite rewrite-string loe)
|
||||
(map (rewrite-event #:rewrite rewrite-string) loe))
|
||||
(define (rewrite-event #:rewrite rewrite-bytes)
|
||||
(match-lambda
|
||||
[(struct stdout (b)) (make-stdout (rewrite-bytes from b))]
|
||||
[(struct stderr (b)) (make-stderr (rewrite-bytes from b))]))
|
||||
[(struct stdout (b)) (make-stdout (rewrite-bytes b))]
|
||||
[(struct stderr (b)) (make-stderr (rewrite-bytes b))]))
|
||||
|
||||
(define (rewrite-string from s)
|
||||
(regexp-replace* from s "<current-rev>"))
|
||||
|
||||
(define rewrite-bytes rewrite-string)
|
||||
(define rewrite-string/c
|
||||
((or/c string? bytes?) . -> . (or/c string? bytes?)))
|
||||
|
||||
(provide/contract
|
||||
[rewrite-status (status? . -> . status?)])
|
||||
[rewrite-string/c contract?]
|
||||
[rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)])
|
|
@ -2,6 +2,7 @@
|
|||
(require "status.ss"
|
||||
"notify.ss"
|
||||
"rewriting.ss"
|
||||
"dirstruct.ss"
|
||||
"cache.ss")
|
||||
|
||||
(define (command+args+env->command+args
|
||||
|
@ -97,6 +98,17 @@
|
|||
|
||||
final-status))
|
||||
|
||||
(define-syntax regexp-replace**
|
||||
(syntax-rules ()
|
||||
[(_ () s) s]
|
||||
[(_ ([pat0 subst0]
|
||||
[pat subst]
|
||||
...)
|
||||
s)
|
||||
(regexp-replace* pat0
|
||||
(regexp-replace** ([pat subst] ...) s)
|
||||
subst0)]))
|
||||
|
||||
(define (run/collect/wait/log log-path command
|
||||
#:timeout timeout
|
||||
#:env env
|
||||
|
@ -105,8 +117,20 @@
|
|||
(cache/file
|
||||
log-path
|
||||
(lambda ()
|
||||
(define rev (number->string (current-rev)))
|
||||
(define home (hash-ref env "HOME"))
|
||||
(define tmp (hash-ref env "TMPDIR"))
|
||||
(define cwd (path->string (current-directory)))
|
||||
(define (rewrite s)
|
||||
(regexp-replace** ([rev "<current-rev>"]
|
||||
[home "<home>"]
|
||||
[tmp "<tmp>"]
|
||||
[cwd "<cwd>"])
|
||||
s))
|
||||
|
||||
(set! ran? #t)
|
||||
(rewrite-status
|
||||
#:rewrite rewrite
|
||||
(run/collect/wait
|
||||
#:timeout timeout
|
||||
#:env env
|
||||
|
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
;; All of the implementation is actually in private/class-internal.ss,
|
||||
;; which provides extra (private) functionality to contract.ss.
|
||||
(require scheme/private/class-internal)
|
||||
(require racket/private/class-internal)
|
||||
|
||||
(provide (rename class-traced class)
|
||||
(rename class*-traced class*)
|
||||
|
|
|
@ -1,3 +1,3 @@
|
|||
(module class mzscheme
|
||||
(require scheme/private/class-internal)
|
||||
(require racket/private/class-internal)
|
||||
(provide-public-names))
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
|
@ -25,37 +25,37 @@
|
|||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;
|
||||
;; provide everything from the scheme/ implementation
|
||||
;; provide everything from the racket/ implementation
|
||||
;; except the arrow contracts
|
||||
;;
|
||||
|
||||
(require scheme/contract/private/base
|
||||
scheme/contract/private/misc
|
||||
scheme/contract/private/provide
|
||||
scheme/contract/private/guts
|
||||
scheme/contract/private/ds
|
||||
scheme/contract/private/opt
|
||||
scheme/contract/private/basic-opters)
|
||||
(require racket/contract/private/base
|
||||
racket/contract/private/misc
|
||||
racket/contract/private/provide
|
||||
racket/contract/private/guts
|
||||
racket/contract/private/ds
|
||||
racket/contract/private/opt
|
||||
racket/contract/private/basic-opters)
|
||||
|
||||
(provide
|
||||
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
|
||||
(except-out (all-from-out scheme/contract/private/ds)
|
||||
(except-out (all-from-out racket/contract/private/ds)
|
||||
lazy-depth-to-look)
|
||||
|
||||
(all-from-out scheme/contract/private/base)
|
||||
(all-from-out scheme/contract/private/provide)
|
||||
(except-out (all-from-out scheme/contract/private/misc)
|
||||
(all-from-out racket/contract/private/base)
|
||||
(all-from-out racket/contract/private/provide)
|
||||
(except-out (all-from-out racket/contract/private/misc)
|
||||
check-between/c
|
||||
string-len/c
|
||||
check-unary-between/c)
|
||||
(rename-out [or/c union])
|
||||
(rename-out [string-len/c string/len])
|
||||
(except-out (all-from-out scheme/contract/private/guts)
|
||||
(except-out (all-from-out racket/contract/private/guts)
|
||||
check-flat-contract
|
||||
check-flat-named-contract))
|
||||
|
||||
|
||||
;; copied here because not provided by scheme/contract anymore
|
||||
;; copied here because not provided by racket/contract anymore
|
||||
(define (flat-contract/predicate? pred)
|
||||
(or (flat-contract? pred)
|
||||
(and (procedure? pred)
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
#lang mzscheme
|
||||
|
||||
(require setup/main-collects
|
||||
scheme/local
|
||||
scheme/bool
|
||||
racket/local
|
||||
racket/bool
|
||||
(only scheme/base
|
||||
build-string
|
||||
build-list
|
||||
|
|
|
@ -1,31 +1,13 @@
|
|||
#lang mzscheme
|
||||
#lang scheme/base
|
||||
|
||||
;; The `first', etc. operations in this library
|
||||
;; work on pairs, not lists.
|
||||
|
||||
(require (only scheme/base
|
||||
foldl
|
||||
foldr
|
||||
|
||||
remv
|
||||
remq
|
||||
remove
|
||||
remv*
|
||||
remq*
|
||||
remove*
|
||||
|
||||
findf
|
||||
memf
|
||||
assf
|
||||
|
||||
filter
|
||||
|
||||
sort)
|
||||
(only scheme/list
|
||||
cons?
|
||||
empty?
|
||||
empty
|
||||
last-pair))
|
||||
(require (only-in scheme/list
|
||||
cons?
|
||||
empty?
|
||||
empty
|
||||
last-pair))
|
||||
|
||||
(provide first
|
||||
second
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require scheme/match/legacy-match)
|
||||
(provide (all-from-out scheme/match/legacy-match))
|
||||
(require racket/match/legacy-match)
|
||||
(provide (all-from-out racket/match/legacy-match))
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/match/match)
|
||||
(provide (all-from-out scheme/match/match))
|
||||
(require racket/match/match)
|
||||
(provide (all-from-out racket/match/match))
|
||||
|
|
|
@ -1,8 +1,7 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
mzlib/etc
|
||||
scheme/contract/base
|
||||
(require (for-syntax racket/base)
|
||||
racket/contract/base
|
||||
mzlib/list
|
||||
"private/port.ss")
|
||||
|
||||
|
@ -118,13 +117,13 @@
|
|||
;; 0 always (which implies that the `read' proc must not return
|
||||
;; a pipe input port).
|
||||
(define make-input-port/read-to-peek
|
||||
(opt-lambda (name read fast-peek close
|
||||
[location-proc #f]
|
||||
[count-lines!-proc void]
|
||||
[init-position 1]
|
||||
[buffer-mode-proc #f]
|
||||
[buffering? #f]
|
||||
[on-consumed #f])
|
||||
(lambda (name read fast-peek close
|
||||
[location-proc #f]
|
||||
[count-lines!-proc void]
|
||||
[init-position 1]
|
||||
[buffer-mode-proc #f]
|
||||
[buffering? #f]
|
||||
[on-consumed #f])
|
||||
(define lock-semaphore (make-semaphore 1))
|
||||
(define commit-semaphore (make-semaphore 1))
|
||||
(define-values (peeked-r peeked-w) (make-pipe))
|
||||
|
@ -440,7 +439,7 @@
|
|||
(buffer-mode-proc mode)])))))
|
||||
|
||||
(define peeking-input-port
|
||||
(opt-lambda (orig-in [name (object-name orig-in)] [delta 0])
|
||||
(lambda (orig-in [name (object-name orig-in)] [delta 0])
|
||||
(make-input-port/read-to-peek
|
||||
name
|
||||
(lambda (s)
|
||||
|
@ -452,11 +451,11 @@
|
|||
void)))
|
||||
|
||||
(define relocate-input-port
|
||||
(opt-lambda (p line col pos [close? #t])
|
||||
(lambda (p line col pos [close? #t])
|
||||
(transplant-to-relocate transplant-input-port p line col pos close?)))
|
||||
|
||||
(define transplant-input-port
|
||||
(opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
|
||||
(lambda (p location-proc pos [close? #t] [count-lines!-proc void])
|
||||
(make-input-port
|
||||
(object-name p)
|
||||
(lambda (s)
|
||||
|
@ -486,7 +485,7 @@
|
|||
;; thread when write evts are active; otherwise, we use a lock semaphore.
|
||||
;; (Actually, the lock semaphore has to be used all the time, to guard
|
||||
;; the flag indicating whether the manager thread is running.)
|
||||
(opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe])
|
||||
(lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe])
|
||||
(let-values ([(r w) (make-pipe limit)]
|
||||
[(more) null]
|
||||
[(more-last) #f]
|
||||
|
@ -724,7 +723,7 @@
|
|||
(values in out))))
|
||||
|
||||
(define input-port-append
|
||||
(opt-lambda (close-orig? . ports)
|
||||
(lambda (close-orig? . ports)
|
||||
(make-input-port
|
||||
(map object-name ports)
|
||||
(lambda (str)
|
||||
|
@ -815,7 +814,7 @@
|
|||
(loop half skip)))))))
|
||||
|
||||
(define make-limited-input-port
|
||||
(opt-lambda (port limit [close-orig? #t])
|
||||
(lambda (port limit [close-orig? #t])
|
||||
(let ([got 0])
|
||||
(make-input-port
|
||||
(object-name port)
|
||||
|
@ -1208,13 +1207,13 @@
|
|||
(loop (add1 i) (add1 j))]))))]))
|
||||
|
||||
(define reencode-input-port
|
||||
(opt-lambda (port encoding [error-bytes #f] [close? #f]
|
||||
[name (object-name port)]
|
||||
[newline-convert? #f]
|
||||
[decode-error (lambda (msg port)
|
||||
(error 'reencode-input-port
|
||||
(format "~a: ~e" msg)
|
||||
port))])
|
||||
(lambda (port encoding [error-bytes #f] [close? #f]
|
||||
[name (object-name port)]
|
||||
[newline-convert? #f]
|
||||
[decode-error (lambda (msg port)
|
||||
(error 'reencode-input-port
|
||||
(format "~a: ~e" msg)
|
||||
port))])
|
||||
(let ([c (let ([c (bytes-open-converter encoding "UTF-8")])
|
||||
(if newline-convert? (mcons c #f) c))]
|
||||
[ready-bytes (make-bytes 1024)]
|
||||
|
@ -1345,13 +1344,13 @@
|
|||
;; --------------------------------------------------
|
||||
|
||||
(define reencode-output-port
|
||||
(opt-lambda (port encoding [error-bytes #f] [close? #f]
|
||||
[name (object-name port)]
|
||||
[convert-newlines-to #f]
|
||||
[decode-error (lambda (msg port)
|
||||
(error 'reencode-input-port
|
||||
(format "~a: ~e" msg)
|
||||
port))])
|
||||
(lambda (port encoding [error-bytes #f] [close? #f]
|
||||
[name (object-name port)]
|
||||
[convert-newlines-to #f]
|
||||
[decode-error (lambda (msg port)
|
||||
(error 'reencode-input-port
|
||||
(format "~a: ~e" msg)
|
||||
port))])
|
||||
(let ([c (bytes-open-converter "UTF-8" encoding)]
|
||||
[ready-bytes (make-bytes 1024)]
|
||||
[ready-start 0]
|
||||
|
@ -1664,7 +1663,7 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(define dup-output-port
|
||||
(opt-lambda (p [close? #f])
|
||||
(lambda (p [close? #f])
|
||||
(let ([new (transplant-output-port
|
||||
p
|
||||
(lambda () (port-next-location p))
|
||||
|
@ -1677,7 +1676,7 @@
|
|||
new)))
|
||||
|
||||
(define dup-input-port
|
||||
(opt-lambda (p [close? #f])
|
||||
(lambda (p [close? #f])
|
||||
(let ([new (transplant-input-port
|
||||
p
|
||||
(lambda () (port-next-location p))
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide (all-defined-out))
|
||||
(require scheme/contract/private/guts)
|
||||
(require racket/contract/private/guts)
|
||||
|
||||
(define empty-case-lambda/c
|
||||
(flat-named-contract '(case->)
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
|
||||
(require (for-syntax scheme/base))
|
||||
(require (for-template scheme/base)
|
||||
(for-template scheme/contract/private/guts)
|
||||
(for-template racket/contract/private/guts)
|
||||
(for-template "contract-arr-checks.ss"))
|
||||
|
||||
(provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require scheme/contract/private/guts
|
||||
scheme/contract/private/opt
|
||||
(require racket/contract/private/guts
|
||||
racket/contract/private/opt
|
||||
"contract-arr-checks.ss")
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax scheme/contract/private/opt-guts)
|
||||
(for-syntax scheme/contract/private/helpers)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax racket/contract/private/opt-guts)
|
||||
(for-syntax racket/contract/private/helpers)
|
||||
(for-syntax "contract-arr-obj-helpers.ss")
|
||||
(for-syntax syntax/stx)
|
||||
(for-syntax syntax/name))
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide define/contract)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
(require (for-syntax racket/base
|
||||
unstable/srcloc
|
||||
(prefix-in a: scheme/contract/private/helpers))
|
||||
(only-in scheme/contract/private/base contract))
|
||||
(prefix-in a: racket/contract/private/helpers))
|
||||
(only-in racket/contract/private/base contract))
|
||||
|
||||
;; First, we have the old define/contract implementation, which
|
||||
;; is still used in mzlib/contract.
|
||||
|
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require "contract-arrow.ss"
|
||||
scheme/contract/private/guts
|
||||
scheme/private/class-internal
|
||||
racket/contract/private/guts
|
||||
racket/private/class-internal
|
||||
"contract-arr-checks.ss")
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/contract/private/helpers
|
||||
(require (for-syntax racket/base
|
||||
racket/contract/private/helpers
|
||||
"contract-arr-obj-helpers.ss"))
|
||||
|
||||
(provide mixin-contract
|
||||
|
|
|
@ -3,15 +3,14 @@
|
|||
;; used by contract.ss, which is used by port.ss --- so we
|
||||
;; break the cycle with this module.
|
||||
|
||||
(module port mzscheme
|
||||
(require "../etc.ss")
|
||||
(module port racket/base
|
||||
(provide open-output-nowhere
|
||||
relocate-output-port
|
||||
transplant-output-port
|
||||
transplant-to-relocate)
|
||||
|
||||
(define open-output-nowhere
|
||||
(opt-lambda ([name 'nowhere] [specials-ok? #t])
|
||||
(lambda ([name 'nowhere] [specials-ok? #t])
|
||||
(make-output-port
|
||||
name
|
||||
always-evt
|
||||
|
@ -42,13 +41,13 @@
|
|||
close?)))
|
||||
|
||||
(define relocate-output-port
|
||||
(opt-lambda (p line col pos [close? #t])
|
||||
(lambda (p line col pos [close? #t])
|
||||
(transplant-to-relocate
|
||||
transplant-output-port
|
||||
p line col pos close?)))
|
||||
|
||||
(define transplant-output-port
|
||||
(opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
|
||||
(lambda (p location-proc pos [close? #t] [count-lines!-proc void])
|
||||
(make-output-port
|
||||
(object-name p)
|
||||
p
|
||||
|
|
|
@ -7,7 +7,7 @@
|
|||
(require (for-template scheme/base
|
||||
"unit-keywords.ss"
|
||||
"unit-runtime.ss"))
|
||||
(require scheme/private/define-struct)
|
||||
(require racket/private/define-struct)
|
||||
|
||||
(provide (struct-out var-info)
|
||||
(struct-out signature)
|
||||
|
|
|
@ -1,14 +1,14 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/boundmap
|
||||
syntax/name
|
||||
syntax/parse
|
||||
"unit-compiletime.ss"
|
||||
"unit-contract-syntax.ss"
|
||||
"unit-syntax.ss")
|
||||
(for-meta 2 scheme/base)
|
||||
scheme/contract/base
|
||||
(for-meta 2 racket/base)
|
||||
racket/contract/base
|
||||
"unit-utils.ss"
|
||||
"unit-runtime.ss")
|
||||
|
||||
|
|
|
@ -4,7 +4,7 @@
|
|||
syntax/boundmap
|
||||
"unit-compiletime.ss"
|
||||
"unit-syntax.ss")
|
||||
scheme/contract/base)
|
||||
racket/contract/base)
|
||||
|
||||
(provide (for-syntax build-key
|
||||
check-duplicate-sigs
|
||||
|
|
|
@ -4,13 +4,13 @@
|
|||
mzlib/etc
|
||||
mzlib/list
|
||||
;; core [de]serializer:
|
||||
scheme/private/serialize)
|
||||
racket/private/serialize)
|
||||
|
||||
(provide define-serializable-struct
|
||||
define-serializable-struct/versions
|
||||
|
||||
;; core [de]serializer:
|
||||
(all-from scheme/private/serialize))
|
||||
(all-from racket/private/serialize))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; define-serializable-struct
|
||||
|
|
|
@ -16,7 +16,7 @@
|
|||
"private/unit-syntax.ss"))
|
||||
|
||||
(require mzlib/etc
|
||||
scheme/contract/base
|
||||
racket/contract/base
|
||||
scheme/stxparam
|
||||
unstable/location
|
||||
"private/unit-contract.ss"
|
||||
|
|
|
@ -1,4 +1,4 @@
|
|||
(module config mzscheme
|
||||
(module config racket/base
|
||||
(require "private/define-config.ss")
|
||||
(define-parameters
|
||||
(PLANET-SERVER-NAME "planet.plt-scheme.org")
|
||||
|
|
|
@ -1,4 +1,5 @@
|
|||
(module define-config mzscheme
|
||||
(module define-config racket/base
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(provide define-parameters)
|
||||
|
||||
|
|
|
@ -18,7 +18,7 @@
|
|||
(and
|
||||
(and (len . < . (bytes-length s))
|
||||
(bytes=? p (subbytes s 0 len)))
|
||||
(let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](ss|sls)$"
|
||||
(let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](rkt|ss|sls)$"
|
||||
(subbytes s len))])
|
||||
(and m
|
||||
(or (not (cadr m))
|
||||
|
@ -37,7 +37,7 @@
|
|||
ext)))))))))
|
||||
files))]
|
||||
[versions
|
||||
(let* ([eo '(#".mzscheme.ss" #".mzscheme.sls" #".ss" #".sls")]
|
||||
(let* ([eo '(#".mzscheme.ss" #".mzscheme.sls" #".ss" #".sls" #".rkt")]
|
||||
[ext< (lambda (a b)
|
||||
(> (length (member a eo)) (length (member b eo))))])
|
||||
(sort candidate-versions
|
||||
|
|
4
collects/racket/base.rkt
Normal file
4
collects/racket/base.rkt
Normal file
|
@ -0,0 +1,4 @@
|
|||
#lang racket/private
|
||||
|
||||
(require "private/base.rkt")
|
||||
(provide (all-from-out "private/base.rkt"))
|
|
@ -1,5 +0,0 @@
|
|||
#lang racket/private
|
||||
(require "private/struct.rkt")
|
||||
|
||||
(provide (all-from-out scheme/base)
|
||||
struct)
|
11
collects/racket/class.rkt
Normal file
11
collects/racket/class.rkt
Normal file
|
@ -0,0 +1,11 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "contract/private/object.rkt")
|
||||
(provide (all-from-out "contract/private/object.rkt"))
|
||||
|
||||
;; All of the implementation is actually in private/class-internal.rkt,
|
||||
;; which provides extra (private) functionality to contract.rkt.
|
||||
(require "private/class-internal.rkt")
|
||||
|
||||
(provide-public-names)
|
||||
(provide generic?)
|
|
@ -9,14 +9,15 @@ differences from v3:
|
|||
|
||||
|#
|
||||
|
||||
(require scheme/contract/exists
|
||||
scheme/contract/regions
|
||||
"contract/private/basic-opters.ss"
|
||||
"contract/base.ss")
|
||||
(require racket/contract/exists
|
||||
racket/contract/regions
|
||||
"contract/private/basic-opters.rkt"
|
||||
"contract/base.rkt"
|
||||
"private/define-struct.rkt")
|
||||
|
||||
(provide (all-from-out "contract/base.ss")
|
||||
(except-out (all-from-out scheme/contract/exists) ∃?)
|
||||
(all-from-out scheme/contract/regions))
|
||||
(provide (all-from-out "contract/base.rkt")
|
||||
(except-out (all-from-out racket/contract/exists) ∃?)
|
||||
(all-from-out racket/contract/regions))
|
||||
|
||||
;; ======================================================================
|
||||
;; The alternate implementation disables contracts. Its useful mainly to
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
;; A stripped down version of scheme/contract for use in
|
||||
;; the PLT code base where appropriate.
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "private/guts.ss")
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
#|
|
||||
|
||||
|
@ -20,8 +20,8 @@ v4 todo:
|
|||
|
||||
(require "guts.ss"
|
||||
"opt.ss"
|
||||
scheme/stxparam)
|
||||
(require (for-syntax scheme/base)
|
||||
racket/stxparam)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax "opt-guts.ss")
|
||||
(for-syntax "helpers.ss")
|
||||
(for-syntax syntax/stx)
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
#|
|
||||
|
||||
|
@ -13,8 +13,8 @@ improve method arity mismatch contract violation error messages?
|
|||
recursive-contract
|
||||
current-contract-region)
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/stxparam
|
||||
(require (for-syntax racket/base)
|
||||
racket/stxparam
|
||||
unstable/srcloc
|
||||
unstable/location
|
||||
"guts.ss"
|
|
@ -1,9 +1,9 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "guts.ss"
|
||||
"opt.ss"
|
||||
"base.ss")
|
||||
(require (for-syntax scheme/base
|
||||
(require (for-syntax racket/base
|
||||
"opt-guts.ss"))
|
||||
|
||||
;;
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require unstable/srcloc scheme/pretty)
|
||||
(require unstable/srcloc racket/pretty)
|
||||
|
||||
(provide blame?
|
||||
make-blame
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(provide ensure-well-formed
|
||||
build-func-params
|
||||
build-clauses
|
||||
|
@ -6,8 +6,7 @@
|
|||
generate-arglists)
|
||||
|
||||
(require "opt-guts.ss")
|
||||
(require (for-template scheme/base)
|
||||
(for-syntax scheme/base))
|
||||
(require (for-template racket/base))
|
||||
|
||||
#|
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
#|
|
||||
|
||||
|
@ -18,13 +18,11 @@ it around flattened out.
|
|||
|#
|
||||
|
||||
(require "guts.ss"
|
||||
"opt.ss"
|
||||
mzlib/etc)
|
||||
"opt.ss")
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax "ds-helpers.ss")
|
||||
(for-syntax "helpers.ss")
|
||||
(for-syntax "opt-guts.ss")
|
||||
(for-syntax mzlib/etc))
|
||||
(for-syntax "opt-guts.ss"))
|
||||
|
||||
(provide define-contract-struct
|
||||
|
|
@ -1,11 +1,11 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "helpers.ss"
|
||||
"blame.ss"
|
||||
"prop.ss"
|
||||
scheme/pretty)
|
||||
racket/pretty)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
(require (for-syntax racket/base
|
||||
"helpers.ss"))
|
||||
|
||||
(provide (except-out (all-from-out "blame.ss") make-blame)
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide mangle-id mangle-id-for-maker
|
||||
build-struct-names
|
||||
|
@ -9,8 +9,8 @@
|
|||
known-good-contract?)
|
||||
|
||||
(require setup/main-collects
|
||||
scheme/struct-info
|
||||
(for-template scheme/base))
|
||||
racket/struct-info
|
||||
(for-template racket/base))
|
||||
|
||||
;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
|
||||
(define (lookup-struct-info stx provide-stx)
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "guts.ss" "blame.ss" unstable/srcloc)
|
||||
|
|
@ -1,10 +1,10 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/struct-info
|
||||
(require (for-syntax racket/base
|
||||
racket/struct-info
|
||||
"helpers.ss"
|
||||
"opt-guts.ss")
|
||||
scheme/promise
|
||||
racket/promise
|
||||
"opt.ss"
|
||||
"guts.ss")
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require "arrow.ss"
|
||||
"guts.ss"
|
||||
scheme/private/class-internal
|
||||
racket/private/class-internal
|
||||
scheme/stxparam)
|
||||
|
||||
(require (for-syntax scheme/base))
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts
|
||||
(for-template scheme/base)
|
||||
(for-template racket/base)
|
||||
(for-template "guts.ss")
|
||||
(for-syntax scheme/base))
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide get-opter reg-opter! opter
|
||||
interleave-lifts
|
|
@ -1,13 +1,12 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require "guts.ss"
|
||||
scheme/stxparam
|
||||
mzlib/etc)
|
||||
(require (for-syntax scheme/base)
|
||||
racket/stxparam)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax "opt-guts.ss")
|
||||
(for-syntax mzlib/etc)
|
||||
(for-syntax scheme/stxparam))
|
||||
(for-syntax racket/stxparam))
|
||||
|
||||
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref)
|
||||
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref
|
||||
begin-lifted)
|
||||
|
||||
;; define/opter : id -> syntax
|
||||
;;
|
||||
|
@ -151,6 +150,11 @@
|
|||
(vector)
|
||||
(begin-lifted (box #f)))))))]))
|
||||
|
||||
(define-syntax (begin-lifted stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr)
|
||||
(syntax-local-lift-expression #'expr)]))
|
||||
|
||||
(define-syntax-parameter define/opt-recursive-fn #f)
|
||||
|
||||
(define-syntax (define-opt/c stx)
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require "blame.ss")
|
||||
|
|
@ -1,14 +1,14 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide provide/contract
|
||||
(for-syntax make-provide/contract-transformer))
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/list
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
(prefix-in a: "helpers.ss"))
|
||||
"arrow.ss"
|
||||
"base.ss"
|
||||
scheme/contract/exists
|
||||
racket/contract/exists
|
||||
"guts.ss"
|
||||
unstable/location
|
||||
unstable/srcloc)
|
|
@ -1,19 +1,19 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide define-struct/contract
|
||||
define/contract
|
||||
with-contract)
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
scheme/list
|
||||
scheme/struct-info
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
racket/struct-info
|
||||
syntax/define
|
||||
syntax/kerncase
|
||||
syntax/parse
|
||||
unstable/syntax
|
||||
(prefix-in a: "private/helpers.ss"))
|
||||
scheme/splicing
|
||||
scheme/stxparam
|
||||
racket/splicing
|
||||
racket/stxparam
|
||||
unstable/location
|
||||
"private/arrow.ss"
|
||||
"private/base.ss"
|
|
@ -1,4 +1,4 @@
|
|||
|
||||
(module control scheme/base
|
||||
(module control racket/base
|
||||
(require mzlib/control)
|
||||
(provide (all-from-out mzlib/control)))
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
(require (for-syntax racket/base))
|
||||
|
||||
(provide prop:dict
|
||||
dict?
|
||||
|
@ -268,7 +268,7 @@
|
|||
[else
|
||||
(raise-type-error 'dict-count "dict" d)]))
|
||||
|
||||
(define-struct assoc-iter (head pos))
|
||||
(struct assoc-iter (head pos))
|
||||
|
||||
(define (dict-iterate-first d)
|
||||
(cond
|
||||
|
@ -276,7 +276,7 @@
|
|||
[(vector? d) (if (zero? (vector-length d))
|
||||
#f
|
||||
0)]
|
||||
[(assoc? d) (if (null? d) #f (make-assoc-iter d d))]
|
||||
[(assoc? d) (if (null? d) #f (assoc-iter d d))]
|
||||
[(dict-struct? d) ((get-dict-iterate-first (dict-struct-ref d)) d)]
|
||||
[else
|
||||
(raise-type-error 'dict-iterate-first "dict" d)]))
|
||||
|
@ -302,7 +302,7 @@
|
|||
(let ([pos (cdr (assoc-iter-pos i))])
|
||||
(if (null? pos)
|
||||
#f
|
||||
(make-assoc-iter d pos)))]
|
||||
(assoc-iter d pos)))]
|
||||
[(dict-struct? d) ((get-dict-iterate-next (dict-struct-ref d)) d i)]
|
||||
[(assoc? d)
|
||||
(raise-mismatch-error
|
||||
|
@ -409,7 +409,7 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define-struct hash-box (key))
|
||||
(struct hash-box (key))
|
||||
|
||||
(define custom-hash-ref
|
||||
(case-lambda
|
||||
|
@ -433,8 +433,8 @@
|
|||
(let ([table (hash-set (custom-hash-table d)
|
||||
((custom-hash-make-box d) k)
|
||||
v)])
|
||||
(make-immutable-custom-hash table
|
||||
(custom-hash-make-box d))))
|
||||
(immutable-custom-hash table
|
||||
(custom-hash-make-box d))))
|
||||
|
||||
(define (custom-hash-remove! d k)
|
||||
(hash-remove! (custom-hash-table d)
|
||||
|
@ -443,8 +443,8 @@
|
|||
(define (custom-hash-remove d k)
|
||||
(let ([table (hash-remove (custom-hash-table d)
|
||||
((custom-hash-make-box d) k))])
|
||||
(make-immutable-custom-hash table
|
||||
(custom-hash-make-box d))))
|
||||
(immutable-custom-hash table
|
||||
(custom-hash-make-box d))))
|
||||
|
||||
(define (custom-hash-count d)
|
||||
(hash-count (custom-hash-table d)))
|
||||
|
@ -461,7 +461,7 @@
|
|||
(define (custom-hash-iterate-value d i)
|
||||
(hash-iterate-value (custom-hash-table d) i))
|
||||
|
||||
(define-struct custom-hash (table make-box)
|
||||
(struct custom-hash (table make-box)
|
||||
#:property prop:dict
|
||||
(vector custom-hash-ref
|
||||
custom-hash-set!
|
||||
|
@ -482,7 +482,7 @@
|
|||
(lambda (a recur) (recur (custom-hash-table a)))
|
||||
(lambda (a recur) (recur (custom-hash-table a)))))
|
||||
|
||||
(define-struct (immutable-custom-hash custom-hash) ()
|
||||
(struct immutable-custom-hash custom-hash ()
|
||||
#:property prop:dict
|
||||
(vector custom-hash-ref
|
||||
#f
|
||||
|
@ -510,7 +510,7 @@
|
|||
(procedure-arity-includes? hash2 1))
|
||||
(raise-type-error who "procedure (arity 1)" hash2))
|
||||
(let ()
|
||||
(define-struct (box hash-box) ()
|
||||
(struct box hash-box ()
|
||||
#:property prop:equal+hash (list
|
||||
(lambda (a b recur)
|
||||
(=? (hash-box-key a) (hash-box-key b)))
|
||||
|
@ -518,16 +518,16 @@
|
|||
(hash (hash-box-key v)))
|
||||
(lambda (v recur)
|
||||
(hash2 (hash-box-key v)))))
|
||||
(make-custom-hash table (wrap-make-box make-box))))])
|
||||
(make-custom-hash table (wrap-make-box box))))])
|
||||
(let ([make-custom-hash
|
||||
(lambda (=? hash [hash2 (lambda (v) 10001)])
|
||||
(mk hash hash2 =? 'make-custom-hash make-custom-hash (make-hash) values))]
|
||||
(mk hash hash2 =? 'make-custom-hash custom-hash (make-hash) values))]
|
||||
[make-immutable-custom-hash
|
||||
(lambda (=? hash [hash2 (lambda (v) 10001)])
|
||||
(mk hash hash2 =? 'make-immutable-custom-hash make-immutable-custom-hash #hash() values))]
|
||||
(mk hash hash2 =? 'make-immutable-custom-hash immutable-custom-hash #hash() values))]
|
||||
[make-weak-custom-hash
|
||||
(lambda (=? hash [hash2 (lambda (v) 10001)])
|
||||
(mk hash hash2 =? 'make-weak-custom-hash make-custom-hash (make-weak-hash)
|
||||
(mk hash hash2 =? 'make-weak-custom-hash custom-hash (make-weak-hash)
|
||||
(lambda (make-box)
|
||||
(let ([ht (make-weak-hasheq)])
|
||||
(lambda (v)
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require syntax/modcode
|
||||
(for-syntax scheme/base))
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide enter!)
|
||||
|
||||
|
@ -29,10 +29,10 @@
|
|||
(enter-require mod)
|
||||
(let ([ns (module->namespace mod)])
|
||||
(current-namespace ns)
|
||||
(namespace-require 'scheme/enter)))
|
||||
(namespace-require 'racket/enter)))
|
||||
(current-namespace orig-namespace)))
|
||||
|
||||
(define-struct mod (name timestamp depends))
|
||||
(struct mod (name timestamp depends))
|
||||
|
||||
(define loaded (make-hash))
|
||||
|
||||
|
@ -66,13 +66,13 @@
|
|||
(or (current-load-relative-directory)
|
||||
(current-directory)))))])
|
||||
;; Record module timestamp and dependencies:
|
||||
(let ([mod (make-mod name
|
||||
(get-timestamp path)
|
||||
(if code
|
||||
(apply append
|
||||
(map cdr (module-compiled-imports code)))
|
||||
null))])
|
||||
(hash-set! loaded path mod))
|
||||
(let ([a-mod (mod name
|
||||
(get-timestamp path)
|
||||
(if code
|
||||
(apply append
|
||||
(map cdr (module-compiled-imports code)))
|
||||
null))])
|
||||
(hash-set! loaded path a-mod))
|
||||
;; Evaluate the module:
|
||||
(eval code))
|
||||
;; Not a module:
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide s-exp->fasl
|
||||
fasl->s-exp)
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(provide delete-directory/files
|
||||
copy-directory/files
|
||||
|
@ -22,7 +22,7 @@
|
|||
write-to-file
|
||||
display-lines-to-file)
|
||||
|
||||
(require "private/portlines.ss")
|
||||
(require "private/portlines.rkt")
|
||||
|
||||
;; utility: sorted dirlist so functions are deterministic
|
||||
(define (sorted-dirlist [dir (current-directory)])
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require '#%futures)
|
||||
|
||||
(provide future?
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base)
|
||||
scheme/control
|
||||
scheme/stxparam scheme/splicing)
|
||||
(require (for-syntax racket/base)
|
||||
racket/control
|
||||
racket/stxparam racket/splicing)
|
||||
|
||||
(provide yield generator generator-state in-generator infinite-generator
|
||||
sequence->generator sequence->repeated-generator)
|
4
collects/racket/gui.rkt
Normal file
4
collects/racket/gui.rkt
Normal file
|
@ -0,0 +1,4 @@
|
|||
(module gui racket
|
||||
(require racket/gui/base)
|
||||
(provide (all-from-out racket)
|
||||
(all-from-out racket/gui/base)))
|
2
collects/racket/gui/lang/reader.ss
Normal file
2
collects/racket/gui/lang/reader.ss
Normal file
|
@ -0,0 +1,2 @@
|
|||
#lang s-exp syntax/module-reader
|
||||
racket/gui
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base) scheme/promise)
|
||||
(require (for-syntax racket/base) racket/promise)
|
||||
|
||||
(provide help)
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-syntax scheme/base
|
||||
(require (for-syntax racket/base
|
||||
syntax/stx
|
||||
syntax/path-spec
|
||||
mzlib/private/increader
|
|
@ -1,7 +1,6 @@
|
|||
#lang racket
|
||||
(require scheme/enter
|
||||
scheme/help
|
||||
"private/runtime.ss")
|
||||
(require racket/enter
|
||||
racket/help)
|
||||
|
||||
;; Set the printer:
|
||||
(current-print (let ([pretty-printer
|
||||
|
@ -11,5 +10,5 @@
|
|||
pretty-printer))
|
||||
|
||||
(provide (all-from-out racket
|
||||
scheme/enter
|
||||
scheme/help))
|
||||
racket/enter
|
||||
racket/help))
|
55
collects/racket/main.rkt
Normal file
55
collects/racket/main.rkt
Normal file
|
@ -0,0 +1,55 @@
|
|||
#lang racket/private
|
||||
|
||||
(require racket/base
|
||||
racket/contract
|
||||
racket/class
|
||||
racket/unit
|
||||
racket/dict
|
||||
racket/include
|
||||
racket/pretty
|
||||
racket/math
|
||||
racket/match
|
||||
racket/shared
|
||||
racket/set
|
||||
racket/tcp
|
||||
racket/udp
|
||||
racket/list
|
||||
racket/vector
|
||||
racket/string
|
||||
racket/function
|
||||
racket/path
|
||||
racket/file
|
||||
racket/port
|
||||
racket/cmdline
|
||||
racket/promise
|
||||
racket/bool
|
||||
racket/local
|
||||
racket/nest
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide (all-from-out racket/contract
|
||||
racket/class
|
||||
racket/unit
|
||||
racket/dict
|
||||
racket/include
|
||||
racket/pretty
|
||||
racket/math
|
||||
racket/match
|
||||
racket/shared
|
||||
racket/base
|
||||
racket/set
|
||||
racket/tcp
|
||||
racket/udp
|
||||
racket/list
|
||||
racket/vector
|
||||
racket/string
|
||||
racket/function
|
||||
racket/path
|
||||
racket/file
|
||||
racket/port
|
||||
racket/cmdline
|
||||
racket/promise
|
||||
racket/bool
|
||||
racket/local
|
||||
racket/nest)
|
||||
(for-syntax (all-from-out racket/base)))
|
|
@ -1,8 +0,0 @@
|
|||
#lang racket/private
|
||||
(require (except-in scheme struct struct/ctc)
|
||||
(only-in mzlib/unit struct~r/ctc)
|
||||
"private/struct.rkt")
|
||||
|
||||
(provide (all-from-out scheme)
|
||||
(rename-out [struct~r/ctc struct/ctc])
|
||||
struct)
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
(require scheme/match/match
|
||||
(for-syntax scheme/base))
|
||||
(provide (except-out (all-from-out scheme/match/match)
|
||||
#lang racket/base
|
||||
(require racket/match/match
|
||||
(for-syntax racket/base))
|
||||
(provide (except-out (all-from-out racket/match/match)
|
||||
define-match-expander)
|
||||
(rename-out [define-match-expander* define-match-expander]))
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (only-in "runtime.ss"
|
||||
match-equality-test
|
|
@ -1,4 +1,4 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (only-in "runtime.ss"
|
||||
match-equality-test
|
|
@ -1,9 +1,9 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
|
||||
(require (for-template scheme/base)
|
||||
(require (for-template racket/base)
|
||||
syntax/boundmap
|
||||
syntax/stx
|
||||
scheme/struct-info
|
||||
racket/struct-info
|
||||
"patterns.ss"
|
||||
"compiler.ss"
|
||||
"parse-helper.ss"
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user