rename all files .ss -> .rkt
original commit: 28b404307793f041bb3363135a2968e283855318
This commit is contained in:
Matthew Flatt
commit
b7928f0fa1
|
|
@ -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
|
||||
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))
|
||||
|
|
@ -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")))
|
||||
|
|
@ -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"
|
||||
|
|
@ -142,19 +142,22 @@
|
|||
(syntax-case stx ()
|
||||
[(_ arg ...) (datum->syntax
|
||||
stx
|
||||
(cons (self-name-struct-info-id me)
|
||||
(cons ((self-name-struct-info-id me))
|
||||
#'(arg ...))
|
||||
stx
|
||||
stx)]
|
||||
[_ (let ([id (self-name-struct-info-id me)])
|
||||
[_ (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 type-as-ctr?)
|
||||
(define-for-syntax (do-struct~ stx extra-make?)
|
||||
(syntax-case stx ()
|
||||
((_ name (field ...) opt ...)
|
||||
(begin
|
||||
|
|
@ -175,53 +178,85 @@
|
|||
stx
|
||||
field)])))
|
||||
(syntax->list #'(field ...)))
|
||||
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
|
||||
(let loop ([opts (syntax->list #'(opt ...))]
|
||||
[no-ctr? #f]
|
||||
[mutable? #f]
|
||||
[no-stx? #f]
|
||||
[no-rt? #f])
|
||||
(if (null? opts)
|
||||
(values no-ctr? mutable? no-stx? no-rt?)
|
||||
(let ([opt (car opts)])
|
||||
(case (syntax-e opt)
|
||||
[(#:omit-constructor)
|
||||
(if no-ctr?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
|
||||
[(#:mutable)
|
||||
(if mutable?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
|
||||
[(#:omit-define-syntaxes)
|
||||
(if no-stx?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
|
||||
[(#:omit-define-values)
|
||||
(if no-rt?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
|
||||
[else
|
||||
(raise-syntax-error #f
|
||||
(string-append
|
||||
"expected a keyword to specify option: "
|
||||
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
|
||||
stx
|
||||
opt)]))))]
|
||||
[(tmp-name) (and type-as-ctr?
|
||||
(car (generate-temporaries #'(name))))])
|
||||
(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
|
||||
|
|
@ -229,19 +264,19 @@
|
|||
#f (not mutable?)
|
||||
#f '(#f) '(#f)
|
||||
#:omit-constructor? no-ctr?
|
||||
#:constructor-name (and type-as-ctr? (cons #'name tmp-name)))])
|
||||
(if type-as-ctr?
|
||||
#:constructor-name def-cname)])
|
||||
(if self-ctr?
|
||||
#`(make-self-name-struct-info
|
||||
(lambda () #,e)
|
||||
(quote-syntax #,tmp-name))
|
||||
(lambda () (quote-syntax #,def-cname)))
|
||||
e)))
|
||||
(let ([names (build-struct-names #'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#:constructor-name (and type-as-ctr?
|
||||
(cons #'name tmp-name)))])
|
||||
#:constructor-name def-cname)])
|
||||
(cond
|
||||
[no-ctr? (cons (car names) (cddr names))]
|
||||
[tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)]
|
||||
[self-ctr? (cons #`(define-values-for-export (#,def-cname) name)
|
||||
names)]
|
||||
[else names]))))))
|
||||
((_ name fields opt ...)
|
||||
(raise-syntax-error #f
|
||||
|
|
@ -258,9 +293,9 @@
|
|||
stx))))
|
||||
|
||||
(define-signature-form (struct~s stx)
|
||||
(do-struct~ stx #f))
|
||||
(define-signature-form (struct~r stx)
|
||||
(do-struct~ stx #t))
|
||||
(define-signature-form (struct~r stx)
|
||||
(do-struct~ stx #f))
|
||||
|
||||
(define-signature-form (struct/ctc stx)
|
||||
(parameterize ((error-syntax stx))
|
||||
|
|
@ -347,7 +382,7 @@
|
|||
(raise-stx-err "missing name and fields")))))
|
||||
|
||||
;; Replacement struct/ctc form for `scheme/unit':
|
||||
(define-for-syntax (do-struct~/ctc stx type-as-ctr?)
|
||||
(define-for-syntax (do-struct~/ctc stx extra-make?)
|
||||
(syntax-case stx ()
|
||||
((_ name ([field ctc] ...) opt ...)
|
||||
(begin
|
||||
|
|
@ -368,53 +403,85 @@
|
|||
stx
|
||||
field)])))
|
||||
(syntax->list #'(field ...)))
|
||||
(let-values ([(no-ctr? mutable? no-stx? no-rt?)
|
||||
(let loop ([opts (syntax->list #'(opt ...))]
|
||||
[no-ctr? #f]
|
||||
[mutable? #f]
|
||||
[no-stx? #f]
|
||||
[no-rt? #f])
|
||||
(if (null? opts)
|
||||
(values no-ctr? mutable? no-stx? no-rt?)
|
||||
(let ([opt (car opts)])
|
||||
(case (syntax-e opt)
|
||||
[(#:omit-constructor)
|
||||
(if no-ctr?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) #t mutable? no-stx? no-rt?))]
|
||||
[(#:mutable)
|
||||
(if mutable?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))]
|
||||
[(#:omit-define-syntaxes)
|
||||
(if no-stx?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? #t no-rt?))]
|
||||
[(#:omit-define-values)
|
||||
(if no-rt?
|
||||
(raise-syntax-error #f
|
||||
"redundant option"
|
||||
stx
|
||||
opt)
|
||||
(loop (cdr opts) no-ctr? mutable? no-stx? #t))]
|
||||
[else
|
||||
(raise-syntax-error #f
|
||||
(string-append
|
||||
"expected a keyword to specify option: "
|
||||
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
|
||||
stx
|
||||
opt)]))))]
|
||||
[(tmp-name) (and type-as-ctr?
|
||||
(car (generate-temporaries #'(name))))])
|
||||
(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)]
|
||||
|
|
@ -435,20 +502,29 @@
|
|||
(map list (cdddr l) field-ctcs))))
|
||||
(cons
|
||||
#`(define-syntaxes (name)
|
||||
#,(build-struct-expand-info
|
||||
#'name (syntax->list #'(field ...))
|
||||
#f (not mutable?)
|
||||
#f '(#f) '(#f)
|
||||
#:omit-constructor? no-ctr?
|
||||
#:constructor-name (and type-as-ctr? (cons #'name tmp-name))))
|
||||
#,(let ([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 (and type-as-ctr?
|
||||
(cons #'name tmp-name))))]
|
||||
#:constructor-name def-cname))]
|
||||
[cpairs (cons 'contracted
|
||||
(if no-ctr? (cddr names) (cdr names)))])
|
||||
(list (car names) cpairs))))))
|
||||
(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"
|
||||
|
|
@ -464,9 +540,9 @@
|
|||
stx))))
|
||||
|
||||
(define-signature-form (struct~s/ctc stx)
|
||||
(do-struct~/ctc stx #f))
|
||||
(define-signature-form (struct~r/ctc stx)
|
||||
(do-struct~/ctc stx #t))
|
||||
(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)
|
||||
|
|
@ -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))
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user