A lot of "MzScheme" -> "Racket"s.
original commit: 2d9601089d1d127374238fdbe41a344ca88ca52f
This commit is contained in:
Eli Barzilay
parent
29e1296e08
b2b3c44aa4
e0799c3d05
a4948a39a4
53ba15e706
b7928f0fa1
a9c5ca02a2
212171f54f
6807d90add
commit
eff0b85b6a
|
|
@ -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,9 @@
|
|||
#lang mzscheme
|
||||
|
||||
(require setup/main-collects
|
||||
scheme/local
|
||||
scheme/bool
|
||||
racket/local
|
||||
racket/bool
|
||||
racket/block
|
||||
(only scheme/base
|
||||
build-string
|
||||
build-list
|
||||
|
|
@ -46,7 +47,7 @@
|
|||
|
||||
hash-table
|
||||
|
||||
begin-with-definitions
|
||||
(rename block begin-with-definitions)
|
||||
|
||||
begin-lifted)
|
||||
|
||||
|
|
@ -349,80 +350,6 @@
|
|||
ht)))]
|
||||
[_else (raise-syntax-error 'hash-table "bad syntax" stx)]))]))
|
||||
|
||||
(define-syntax (begin-with-definitions stx)
|
||||
;; Body can have mixed exprs and defns. Wrap expressions with
|
||||
;; `(define-values () ... (values))' as needed, and add a (void)
|
||||
;; at the end if needed.
|
||||
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||
[ctx (list (gensym 'intdef))]
|
||||
[kernel-forms (kernel-form-identifier-list)]
|
||||
[init-exprs (let ([v (syntax->list stx)])
|
||||
(unless v
|
||||
(raise-syntax-error #f "bad syntax" stx))
|
||||
(cdr v))]
|
||||
[exprs (let loop ([exprs init-exprs])
|
||||
(apply
|
||||
append
|
||||
(map (lambda (expr)
|
||||
(let ([expr (local-expand expr ctx kernel-forms def-ctx)])
|
||||
(syntax-case expr (begin define-syntaxes define-values)
|
||||
[(begin . rest)
|
||||
(loop (syntax->list #'rest))]
|
||||
[(define-syntaxes (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(syntax-local-bind-syntaxes
|
||||
(syntax->list #'(id ...))
|
||||
#'rhs def-ctx)
|
||||
(list #'(define-syntaxes (id ...) rhs)))]
|
||||
[(define-values (id ...) rhs)
|
||||
(andmap identifier? (syntax->list #'(id ...)))
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(list expr))]
|
||||
[else
|
||||
(list expr)])))
|
||||
exprs)))])
|
||||
(internal-definition-context-seal def-ctx)
|
||||
(let loop ([exprs exprs]
|
||||
[prev-stx-defns null]
|
||||
[prev-defns null]
|
||||
[prev-exprs null])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
#`(letrec-syntaxes+values
|
||||
#,(map stx-cdr (reverse prev-stx-defns))
|
||||
#,(map stx-cdr (reverse prev-defns))
|
||||
#,@(if (null? prev-exprs)
|
||||
(list #'(void))
|
||||
(reverse prev-exprs)))]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(module-identifier=? #'define-syntaxes (stx-car (car exprs))))
|
||||
(loop (cdr exprs)
|
||||
(cons (car exprs) prev-stx-defns)
|
||||
prev-defns
|
||||
prev-exprs)]
|
||||
[(and (stx-pair? (car exprs))
|
||||
(identifier? (stx-car (car exprs)))
|
||||
(module-identifier=? #'define-values (stx-car (car exprs))))
|
||||
(loop (cdr exprs)
|
||||
prev-stx-defns
|
||||
(cons (car exprs)
|
||||
(append
|
||||
(map (lambda (expr)
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
prev-exprs)
|
||||
prev-defns))
|
||||
null)]
|
||||
[else (loop (cdr exprs)
|
||||
prev-stx-defns
|
||||
prev-defns
|
||||
(cons (car exprs) prev-exprs))]))))
|
||||
|
||||
(define-syntax (begin-lifted stx)
|
||||
(syntax-case stx ()
|
||||
[(_ expr0 expr ...)
|
||||
216
collects/mzlib/include.rkt
Normal file
216
collects/mzlib/include.rkt
Normal file
|
|
@ -0,0 +1,216 @@
|
|||
|
||||
(module include mzscheme
|
||||
(require-for-syntax syntax/stx
|
||||
"private/increader.ss"
|
||||
"cm-accomplice.ss")
|
||||
(require mzlib/etc)
|
||||
|
||||
(define-for-syntax (resolve-path-spec fn loc stx build-path-stx)
|
||||
(let ([file
|
||||
(syntax-case* fn (lib) module-or-top-identifier=?
|
||||
[_
|
||||
(string? (syntax-e fn))
|
||||
(let ([s (syntax-e fn)])
|
||||
(unless (or (relative-path? s)
|
||||
(absolute-path? s))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad pathname string"
|
||||
stx
|
||||
fn))
|
||||
(string->path s))]
|
||||
[(-build-path elem ...)
|
||||
(module-or-top-identifier=? #'-build-path build-path-stx)
|
||||
(let ([l (syntax-object->datum (syntax (elem ...)))])
|
||||
(when (null? l)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"`build-path' keyword is not followed by at least one string"
|
||||
stx
|
||||
fn))
|
||||
(apply build-path l))]
|
||||
[(lib filename ...)
|
||||
(let ([l (syntax-object->datum (syntax (filename ...)))])
|
||||
(unless (or (andmap string? l)
|
||||
(pair? l))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"`lib' keyword is not followed by a sequence of string datums"
|
||||
stx
|
||||
fn))
|
||||
(build-path (if (null? (cdr l))
|
||||
(collection-path "mzlib")
|
||||
(apply collection-path (cdr l)))
|
||||
(car l)))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a pathname string, `build-path' form, or `lib' form for file"
|
||||
stx
|
||||
fn)])])
|
||||
(if (complete-path? file)
|
||||
file
|
||||
(path->complete-path
|
||||
file
|
||||
(cond
|
||||
;; Src of include expression is a path?
|
||||
[(and (path? (syntax-source loc))
|
||||
(complete-path? (syntax-source loc)))
|
||||
(let-values ([(base name dir?)
|
||||
(split-path (syntax-source loc))])
|
||||
(if dir?
|
||||
(syntax-source loc)
|
||||
base))]
|
||||
;; Load relative?
|
||||
[(current-load-relative-directory)]
|
||||
;; Current directory
|
||||
[(current-directory)])))))
|
||||
|
||||
(define-syntax-set (do-include ; private
|
||||
include-at/relative-to
|
||||
include
|
||||
include-at/relative-to/reader
|
||||
include/reader)
|
||||
|
||||
(define (do-include/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ orig-stx ctx loc fn reader)
|
||||
;; Parse the file name
|
||||
(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)]
|
||||
[rkt->ss (lambda (p)
|
||||
(let ([b (path->bytes p)])
|
||||
(if (regexp-match? #rx#"[.]rkt$" b)
|
||||
(path-replace-suffix p #".ss")
|
||||
p)))])
|
||||
|
||||
(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))
|
||||
|
||||
;; 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 ()
|
||||
[(_ fn)
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx (do-include _stx _stx _stx fn #f)))]))
|
||||
|
||||
(define (include-at/relative-to/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ctx loc fn)
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx (do-include _stx ctx loc fn #f)))]))
|
||||
|
||||
(define (include/reader/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ fn reader)
|
||||
;; Expand to do-include:
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx
|
||||
(do-include _stx _stx _stx fn
|
||||
(letrec-syntax ([the-reader (lambda (stx)
|
||||
(datum->syntax-object
|
||||
#'here
|
||||
(make-reader reader)))])
|
||||
the-reader))))]))
|
||||
|
||||
(define (include-at/relative-to/reader/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ctx loc fn reader)
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx
|
||||
(do-include _stx ctx loc fn
|
||||
(letrec-syntax ([the-reader (lambda (stx)
|
||||
(datum->syntax-object
|
||||
#'here
|
||||
(make-reader reader)))])
|
||||
the-reader))))])))
|
||||
|
||||
(provide include
|
||||
include-at/relative-to
|
||||
include/reader
|
||||
include-at/relative-to/reader))
|
||||
|
|
@ -1,205 +0,0 @@
|
|||
|
||||
(module include mzscheme
|
||||
(require-for-syntax syntax/stx
|
||||
"private/increader.ss"
|
||||
"cm-accomplice.ss")
|
||||
(require mzlib/etc)
|
||||
|
||||
(define-for-syntax (resolve-path-spec fn loc stx build-path-stx)
|
||||
(let ([file
|
||||
(syntax-case* fn (lib) module-or-top-identifier=?
|
||||
[_
|
||||
(string? (syntax-e fn))
|
||||
(let ([s (syntax-e fn)])
|
||||
(unless (or (relative-path? s)
|
||||
(absolute-path? s))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad pathname string"
|
||||
stx
|
||||
fn))
|
||||
(string->path s))]
|
||||
[(-build-path elem ...)
|
||||
(module-or-top-identifier=? #'-build-path build-path-stx)
|
||||
(let ([l (syntax-object->datum (syntax (elem ...)))])
|
||||
(when (null? l)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"`build-path' keyword is not followed by at least one string"
|
||||
stx
|
||||
fn))
|
||||
(apply build-path l))]
|
||||
[(lib filename ...)
|
||||
(let ([l (syntax-object->datum (syntax (filename ...)))])
|
||||
(unless (or (andmap string? l)
|
||||
(pair? l))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"`lib' keyword is not followed by a sequence of string datums"
|
||||
stx
|
||||
fn))
|
||||
(build-path (if (null? (cdr l))
|
||||
(collection-path "mzlib")
|
||||
(apply collection-path (cdr l)))
|
||||
(car l)))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a pathname string, `build-path' form, or `lib' form for file"
|
||||
stx
|
||||
fn)])])
|
||||
(if (complete-path? file)
|
||||
file
|
||||
(path->complete-path
|
||||
file
|
||||
(cond
|
||||
;; Src of include expression is a path?
|
||||
[(and (path? (syntax-source loc))
|
||||
(complete-path? (syntax-source loc)))
|
||||
(let-values ([(base name dir?)
|
||||
(split-path (syntax-source loc))])
|
||||
(if dir?
|
||||
(syntax-source loc)
|
||||
base))]
|
||||
;; Load relative?
|
||||
[(current-load-relative-directory)]
|
||||
;; Current directory
|
||||
[(current-directory)])))))
|
||||
|
||||
(define-syntax-set (do-include ; private
|
||||
include-at/relative-to
|
||||
include
|
||||
include-at/relative-to/reader
|
||||
include/reader)
|
||||
|
||||
(define (do-include/proc stx)
|
||||
(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)]
|
||||
[ctx (syntax ctx)]
|
||||
[loc (syntax loc)]
|
||||
[reader (syntax reader)]
|
||||
[orig-stx (syntax orig-stx)])
|
||||
|
||||
(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))
|
||||
|
||||
;; 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 ()
|
||||
[(_ fn)
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx (do-include _stx _stx _stx fn #f)))]))
|
||||
|
||||
(define (include-at/relative-to/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ctx loc fn)
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx (do-include _stx ctx loc fn #f)))]))
|
||||
|
||||
(define (include/reader/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ fn reader)
|
||||
;; Expand to do-include:
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx
|
||||
(do-include _stx _stx _stx fn
|
||||
(letrec-syntax ([the-reader (lambda (stx)
|
||||
(datum->syntax-object
|
||||
#'here
|
||||
(make-reader reader)))])
|
||||
the-reader))))]))
|
||||
|
||||
(define (include-at/relative-to/reader/proc stx)
|
||||
(syntax-case stx ()
|
||||
[(_ ctx loc fn reader)
|
||||
(with-syntax ([_stx stx])
|
||||
(syntax/loc stx
|
||||
(do-include _stx ctx loc fn
|
||||
(letrec-syntax ([the-reader (lambda (stx)
|
||||
(datum->syntax-object
|
||||
#'here
|
||||
(make-reader reader)))])
|
||||
the-reader))))])))
|
||||
|
||||
(provide include
|
||||
include-at/relative-to
|
||||
include/reader
|
||||
include-at/relative-to/reader))
|
||||
|
|
@ -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
|
||||
4
collects/mzlib/match.rkt
Normal file
4
collects/mzlib/match.rkt
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/match/legacy-match)
|
||||
(provide (all-from-out racket/match/legacy-match))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/match/legacy-match)
|
||||
(provide (all-from-out scheme/match/legacy-match))
|
||||
4
collects/mzlib/plt-match.rkt
Normal file
4
collects/mzlib/plt-match.rkt
Normal file
|
|
@ -0,0 +1,4 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require racket/match/match)
|
||||
(provide (all-from-out racket/match/match))
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/match/match)
|
||||
(provide (all-from-out scheme/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))
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
;; ;Portable regular expressions for Scheme
|
||||
;; ;Dorai Sitaram
|
||||
;; ;http://www.ccs.neu.edu/~dorai/pregexp/pregexp.html
|
||||
;; but `pregexp' functionality is now built into MzScheme, so
|
||||
;; but `pregexp' functionality is now built into Racket, so
|
||||
;; this is mostly a wrapper module.
|
||||
|
||||
(module pregexp mzscheme
|
||||
|
|
@ -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
|
||||
|
|
@ -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,4 +16,4 @@
|
|||
(define make-check-cdr #f)
|
||||
;; Include the implementation.
|
||||
;; See private/shared-body.ss.
|
||||
(include "private/shared-body.ss")))
|
||||
(include "private/shared-body.rkt")))
|
||||
|
|
@ -8,6 +8,7 @@
|
|||
syntax/name
|
||||
syntax/parse
|
||||
syntax/struct
|
||||
scheme/struct-info
|
||||
syntax/stx
|
||||
unstable/location
|
||||
"private/unit-contract-syntax.ss"
|
||||
|
|
@ -15,17 +16,19 @@
|
|||
"private/unit-syntax.ss"))
|
||||
|
||||
(require mzlib/etc
|
||||
scheme/contract/base
|
||||
racket/contract/base
|
||||
scheme/stxparam
|
||||
unstable/location
|
||||
"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,168 @@
|
|||
((_)
|
||||
(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))
|
||||
|
||||
(define-for-syntax option-keywords
|
||||
"#:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
|
||||
|
||||
;; Replacement `struct' signature form for `scheme/unit':
|
||||
(define-for-syntax (do-struct~ stx extra-make?)
|
||||
(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? opt-cname)
|
||||
(let loop ([opts (syntax->list #'(opt ...))]
|
||||
[no-ctr? #f]
|
||||
[mutable? #f]
|
||||
[no-stx? #f]
|
||||
[no-rt? #f]
|
||||
[cname #f])
|
||||
(if (null? opts)
|
||||
(values no-ctr? mutable? no-stx? no-rt? cname)
|
||||
(let ([opt (car opts)])
|
||||
(case (syntax-e opt)
|
||||
[(#:constructor-name #:extra-constructor-name)
|
||||
(if cname
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(if (null? (cdr opts))
|
||||
(raise-syntax-error #f
|
||||
"missing identifier after option"
|
||||
stx
|
||||
opt)
|
||||
(if (identifier? (cadr opts))
|
||||
(loop (cddr opts) #f mutable? no-stx? no-rt?
|
||||
(if (eq? (syntax-e opt) '#:extra-constructor-name)
|
||||
(list (cadr opts))
|
||||
(cadr opts)))
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for a constructor name"
|
||||
stx
|
||||
(cadr opts)))))]
|
||||
[(#:omit-constructor)
|
||||
(if no-ctr?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
|
||||
[(#:mutable)
|
||||
(if mutable?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
|
||||
[(#:omit-define-syntaxes)
|
||||
(if no-stx?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
|
||||
[(#:omit-define-values)
|
||||
(if no-rt?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
|
||||
[else
|
||||
(raise-syntax-error #f
|
||||
(string-append
|
||||
"expected a keyword to specify option: "
|
||||
option-keywords)
|
||||
stx
|
||||
opt)]))))]
|
||||
[(def-cname) (cond
|
||||
[opt-cname (if (pair? opt-cname)
|
||||
(car opt-cname)
|
||||
opt-cname)]
|
||||
[extra-make? #f]
|
||||
[else (car (generate-temporaries #'(name)))])]
|
||||
[(cname) (cond
|
||||
[opt-cname (if (pair? opt-cname)
|
||||
(cons def-cname #'name)
|
||||
(cons opt-cname opt-cname))]
|
||||
[extra-make? #f]
|
||||
[else (cons def-cname #'name)])]
|
||||
[(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
|
||||
(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 def-cname)])
|
||||
(if self-ctr?
|
||||
#`(make-self-name-struct-info
|
||||
(lambda () #,e)
|
||||
(lambda () (quote-syntax #,def-cname)))
|
||||
e)))
|
||||
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#:constructor-name def-cname)])
|
||||
(cond
|
||||
[no-ctr? (cons (car names) (cddr names))]
|
||||
[self-ctr? (cons #`(define-values-for-export (#,def-cname) 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 #t))
|
||||
(define-signature-form (struct~r stx)
|
||||
(do-struct~ stx #f))
|
||||
|
||||
(define-signature-form (struct/ctc stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
(syntax-case stx ()
|
||||
|
|
@ -214,28 +381,205 @@
|
|||
((_)
|
||||
(raise-stx-err "missing name and fields")))))
|
||||
|
||||
;; Replacement struct/ctc form for `scheme/unit':
|
||||
(define-for-syntax (do-struct~/ctc stx extra-make?)
|
||||
(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? opt-cname)
|
||||
(let loop ([opts (syntax->list #'(opt ...))]
|
||||
[no-ctr? #f]
|
||||
[mutable? #f]
|
||||
[no-stx? #f]
|
||||
[no-rt? #f]
|
||||
[cname #f])
|
||||
(if (null? opts)
|
||||
(values no-ctr? mutable? no-stx? no-rt? cname)
|
||||
(let ([opt (car opts)])
|
||||
(case (syntax-e opt)
|
||||
[(#:constructor-name #:extra-constructor-name)
|
||||
(if cname
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(if (null? (cdr opts))
|
||||
(raise-syntax-error #f
|
||||
"missing identifier after option"
|
||||
stx
|
||||
opt)
|
||||
(if (identifier? (cadr opts))
|
||||
(loop (cddr opts) #f mutable? no-stx? no-rt?
|
||||
(if (eq? (syntax-e opt) '#:extra-constructor-name)
|
||||
(list (cadr opts))
|
||||
(cadr opts)))
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for a constructor name"
|
||||
stx
|
||||
(cadr opts)))))]
|
||||
[(#:omit-constructor)
|
||||
(if no-ctr?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
|
||||
[(#:mutable)
|
||||
(if mutable?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
|
||||
[(#:omit-define-syntaxes)
|
||||
(if no-stx?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
|
||||
[(#:omit-define-values)
|
||||
(if no-rt?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
|
||||
[else
|
||||
(raise-syntax-error #f
|
||||
(string-append
|
||||
"expected a keyword to specify option: "
|
||||
option-keywords)
|
||||
stx
|
||||
opt)]))))]
|
||||
[(def-cname) (cond
|
||||
[opt-cname (if (pair? opt-cname)
|
||||
(car opt-cname)
|
||||
opt-cname)]
|
||||
[extra-make? #f]
|
||||
[else (car (generate-temporaries #'(name)))])]
|
||||
[(cname) (cond
|
||||
[opt-cname (if (pair? opt-cname)
|
||||
(cons def-cname #'name)
|
||||
(cons def-cname def-cname))]
|
||||
[extra-make? #f]
|
||||
[else (cons def-cname #'name)])]
|
||||
[(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
|
||||
(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)
|
||||
#,(let ([e (build-struct-expand-info
|
||||
#'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#f '(#f) '(#f)
|
||||
#:omit-constructor? no-ctr?
|
||||
#:constructor-name def-cname)])
|
||||
(if self-ctr?
|
||||
#`(make-self-name-struct-info
|
||||
(lambda () #,e)
|
||||
(lambda () (quote-syntax #,def-cname)))
|
||||
e)))
|
||||
(let* ([names (add-contracts
|
||||
(build-struct-names #'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#:constructor-name def-cname))]
|
||||
[cpairs (cons 'contracted
|
||||
(cond
|
||||
[no-ctr? (cddr names)]
|
||||
[else (cdr names)]))]
|
||||
[l (list (car names) cpairs)])
|
||||
(if self-ctr?
|
||||
(cons #`(define-values-for-export (#,def-cname) name) l)
|
||||
l))))))
|
||||
((_ 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 #t))
|
||||
(define-signature-form (struct~r/ctc stx)
|
||||
(do-struct~/ctc stx #f))
|
||||
|
||||
;; 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 +605,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 +619,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 +631,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 +663,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 +683,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 +706,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 +715,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 +727,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 +747,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 +773,7 @@
|
|||
bindings
|
||||
val-defs
|
||||
stx-defs
|
||||
post-val-defs
|
||||
ctcs))))
|
||||
(x (raise-stx-err
|
||||
"expected either an identifier or signature form"
|
||||
|
|
@ -532,6 +897,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 +969,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
|
||||
|
|
@ -249,7 +249,7 @@
|
|||
(define/kw (zip->output files #:optional [out (current-output-port)])
|
||||
(parameterize ([current-output-port out])
|
||||
(let* ([seekable? (seekable-port? (current-output-port))]
|
||||
[headers ; note: MzScheme's `map' is always left-to-right
|
||||
[headers ; note: Racket's `map' is always left-to-right
|
||||
(map (lambda (file)
|
||||
(zip-one-entry (build-metadata file) seekable?))
|
||||
files)])
|
||||
|
|
@ -68,9 +68,9 @@
|
|||
""
|
||||
"<html>"
|
||||
"<!-- The form was processed, and this document was generated,"
|
||||
" using the CGI utilities for MzScheme. For more information"
|
||||
" on MzScheme, see"
|
||||
" http://www.plt-scheme.org/software/mzscheme/"
|
||||
" using the CGI utilities for Racket. For more information"
|
||||
" on Racket, see"
|
||||
" http://racket-lang.org/"
|
||||
" and for the CGI utilities, contact"
|
||||
" (sk@cs.brown.edu). -->"
|
||||
"<head>"
|
||||
|
|
@ -255,7 +255,7 @@
|
|||
;; appear as a block to be legal, and " may only appear as \"
|
||||
(define (rfc2068:quoted-string? s)
|
||||
(and (regexp-match?
|
||||
#rx"^\"([^\"#\u0000-#\u001F]| |#\return#\newline|#\tab|\\\\\")*\"$"
|
||||
#rx"^\"([^\"\u0000-\u001F]| |\r\n|\t|\\\\\")*\"$"
|
||||
s)
|
||||
s))
|
||||
|
||||
|
|
@ -88,7 +88,7 @@
|
|||
(unless (null? cc-recipients)
|
||||
(write-recipient-header "CC" cc-recipients)))
|
||||
(fprintf writer "Subject: ~a\n" subject)
|
||||
(fprintf writer "X-Mailer: MzScheme: see www.plt-scheme.org\n")
|
||||
(fprintf writer "X-Mailer: Racket (racket-lang.org)\n")
|
||||
(for-each (lambda (s)
|
||||
(display s writer)
|
||||
(newline writer))
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user