Start on adding contracts to units. Here we're just adding contract(ed) forms,
but they're not (yet) used further in. svn: r12711 original commit: 1b4d2cb7bf4eb7a3340e8a29b370994d9eaf1b35
This commit is contained in:
Stevie Strickland
|
|
@ -88,3 +88,10 @@
|
|||
flat-prop flat-pred? flat-get
|
||||
first-order-prop first-order-get
|
||||
(rename-out [or/c union]))
|
||||
|
||||
|
||||
;; copied here because not provided by scheme/contract anymore
|
||||
(define (flat-contract/predicate? pred)
|
||||
(or (flat-contract? pred)
|
||||
(and (procedure? pred)
|
||||
(procedure-arity-includes? pred 1))))
|
||||
|
|
@ -386,6 +386,7 @@
|
|||
[else
|
||||
(list expr)])))
|
||||
exprs)))])
|
||||
(internal-definition-context-seal def-ctx)
|
||||
(let loop ([exprs exprs]
|
||||
[prev-stx-defns null]
|
||||
[prev-defns null]
|
||||
|
|
|
|||
|
|
@ -467,14 +467,26 @@
|
|||
;; Creates a simple function type that can be used for callouts and callbacks,
|
||||
;; optionally applying a wrapper function to modify the result primitive
|
||||
;; (callouts) or the input procedure (callbacks).
|
||||
(define* (_cprocedure itypes otype [abi #f] [wrapper #f])
|
||||
(if wrapper
|
||||
(define* (_cprocedure itypes otype
|
||||
#:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f])
|
||||
(_cprocedure* itypes otype abi wrapper keep))
|
||||
|
||||
;; for internal use
|
||||
(define held-callbacks (make-weak-hasheq))
|
||||
(define (_cprocedure* itypes otype abi wrapper keep)
|
||||
(define-syntax-rule (make-it wrap)
|
||||
(make-ctype _fpointer
|
||||
(lambda (x) (ffi-callback (wrapper x) itypes otype abi))
|
||||
(lambda (x) (wrapper (ffi-call x itypes otype abi))))
|
||||
(make-ctype _fpointer
|
||||
(lambda (x) (ffi-callback x itypes otype abi))
|
||||
(lambda (x) (ffi-call x itypes otype abi)))))
|
||||
(lambda (x)
|
||||
(let ([cb (ffi-callback (wrap x) itypes otype abi)])
|
||||
(cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
|
||||
[(box? keep)
|
||||
(let ([x (unbox keep)])
|
||||
(set-box! keep
|
||||
(if (or (null? x) (pair? x)) (cons cb x) cb)))]
|
||||
[(procedure? keep) (keep cb)])
|
||||
cb))
|
||||
(lambda (x) (wrap (ffi-call x itypes otype abi)))))
|
||||
(if wrapper (make-it wrapper) (make-it begin)))
|
||||
|
||||
;; Syntax for the special _fun type:
|
||||
;; (_fun [{(name ... [. name]) | name} [-> expr] ::]
|
||||
|
|
@ -500,6 +512,7 @@
|
|||
(define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub))
|
||||
(define xs #f)
|
||||
(define abi #f)
|
||||
(define keep #f)
|
||||
(define inputs #f)
|
||||
(define output #f)
|
||||
(define bind '())
|
||||
|
|
@ -557,15 +570,16 @@
|
|||
;; parse keywords
|
||||
(let loop ()
|
||||
(let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))])
|
||||
(when (keyword? k)
|
||||
(define-syntax-rule (kwds [key var] ...)
|
||||
(case k
|
||||
[(#:abi) (if abi
|
||||
(err "got a second #:abi keyword" (car xs))
|
||||
(begin (set! abi (cadr xs))
|
||||
(set! xs (cddr xs))
|
||||
(loop)))]
|
||||
[else (err "unknown keyword" (car xs))]))))
|
||||
(unless abi (set! abi #'#f))
|
||||
[(key) (if var
|
||||
(err (format "got a second ~s keyword") 'key (car xs))
|
||||
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
|
||||
...
|
||||
[else (err "unknown keyword" (car xs))]))
|
||||
(when (keyword? k) (kwds [#:abi abi] [#:keep keep]))))
|
||||
(unless abi (set! abi #'#f))
|
||||
(unless keep (set! keep #'#t))
|
||||
;; parse known punctuation
|
||||
(set! xs (map (lambda (x)
|
||||
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
|
||||
|
|
@ -655,9 +669,10 @@
|
|||
body 'inferred-name
|
||||
(string->symbol (string-append "ffi-wrapper:" n)))
|
||||
body))])
|
||||
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi
|
||||
(lambda (ffi) #,body)))
|
||||
#`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi)))
|
||||
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
|
||||
#,abi (lambda (ffi) #,body) #,keep))
|
||||
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
|
||||
#,abi #f #,keep)))
|
||||
(syntax-case stx ()
|
||||
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))]))
|
||||
|
||||
|
|
@ -961,7 +976,7 @@
|
|||
|
||||
(define-struct cvector (ptr type length))
|
||||
|
||||
(provide* cvector? cvector-length cvector-type
|
||||
(provide* cvector? cvector-length cvector-type cvector-ptr
|
||||
;; make-cvector* is a dangerous operation
|
||||
(unsafe (rename-out [make-cvector make-cvector*])))
|
||||
|
||||
|
|
@ -998,13 +1013,13 @@
|
|||
(list->cvector args type))
|
||||
|
||||
(define* (cvector-ref v i)
|
||||
(if (and (integer? i) (<= 0 i (sub1 (cvector-length v))))
|
||||
(if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
|
||||
(ptr-ref (cvector-ptr v) (cvector-type v) i)
|
||||
(error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
|
||||
i (sub1 (cvector-length v)))))
|
||||
|
||||
(define* (cvector-set! v i x)
|
||||
(if (and (integer? i) (<= 0 i (sub1 (cvector-length v))))
|
||||
(if (and (exact-nonnegative-integer? i) (< i (cvector-length v)))
|
||||
(ptr-set! (cvector-ptr v) (cvector-type v) i x)
|
||||
(error 'cvector-ref "bad index ~e for cvector bounds of 0..~e"
|
||||
i (sub1 (cvector-length v)))))
|
||||
|
|
@ -1061,14 +1076,14 @@
|
|||
(list->TAG vals))
|
||||
(define* (TAG-ref v i)
|
||||
(if (TAG? v)
|
||||
(if (and (integer? i) (< -1 i (TAG-length v)))
|
||||
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
|
||||
(ptr-ref (TAG-ptr v) type i)
|
||||
(error 'TAG-ref "bad index ~e for ~a bounds of 0..~e"
|
||||
i 'TAG (sub1 (TAG-length v))))
|
||||
(raise-type-error 'TAG-ref TAGname v)))
|
||||
(define* (TAG-set! v i x)
|
||||
(if (TAG? v)
|
||||
(if (and (integer? i) (< -1 i (TAG-length v)))
|
||||
(if (and (exact-nonnegative-integer? i) (< i (TAG-length v)))
|
||||
(ptr-set! (TAG-ptr v) type i x)
|
||||
(error 'TAG-set! "bad index ~e for ~a bounds of 0..~e"
|
||||
i 'TAG (sub1 (TAG-length v))))
|
||||
|
|
@ -1176,40 +1191,36 @@
|
|||
[error-str (format "~a`~a' pointer"
|
||||
(if nullable? "" "non-null ") tag)]
|
||||
[error* (lambda (p) (raise-type-error tag->C error-str p))])
|
||||
(let-syntax ([tag-or-error
|
||||
(syntax-rules ()
|
||||
[(tag-or-error ptr t)
|
||||
(let ([p ptr])
|
||||
(if (cpointer? p)
|
||||
(unless (cpointer-has-tag? p t) (error* p))
|
||||
(error* p)))])]
|
||||
[tag-or-error/null
|
||||
(syntax-rules ()
|
||||
[(tag-or-error/null ptr t)
|
||||
(let ([p ptr])
|
||||
(if (cpointer? p)
|
||||
(when p (unless (cpointer-has-tag? p t) (error* p)))
|
||||
(error* p)))])])
|
||||
(make-ctype (or ptr-type _pointer)
|
||||
;; bad hack: `if's outside the lambda for efficiency
|
||||
(if nullable?
|
||||
(if scheme->c
|
||||
(lambda (p) (tag-or-error/null (scheme->c p) tag) p)
|
||||
(lambda (p) (tag-or-error/null p tag) p))
|
||||
(if scheme->c
|
||||
(lambda (p) (tag-or-error (scheme->c p) tag) p)
|
||||
(lambda (p) (tag-or-error p tag) p)))
|
||||
(if nullable?
|
||||
(if c->scheme
|
||||
(lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
|
||||
(lambda (p) (when p (cpointer-push-tag! p tag)) p))
|
||||
(if c->scheme
|
||||
(lambda (p)
|
||||
(if p (cpointer-push-tag! p tag) (error* p))
|
||||
(c->scheme p))
|
||||
(lambda (p)
|
||||
(if p (cpointer-push-tag! p tag) (error* p))
|
||||
p))))))]))
|
||||
(define-syntax-rule (tag-or-error ptr t)
|
||||
(let ([p ptr])
|
||||
(if (cpointer? p)
|
||||
(if (cpointer-has-tag? p t) p (error* p))
|
||||
(error* p))))
|
||||
(define-syntax-rule (tag-or-error/null ptr t)
|
||||
(let ([p ptr])
|
||||
(if (cpointer? p)
|
||||
(and p (if (cpointer-has-tag? p t) p (error* p)))
|
||||
(error* p))))
|
||||
(make-ctype (or ptr-type _pointer)
|
||||
;; bad hack: `if's outside the lambda for efficiency
|
||||
(if nullable?
|
||||
(if scheme->c
|
||||
(lambda (p) (tag-or-error/null (scheme->c p) tag))
|
||||
(lambda (p) (tag-or-error/null p tag)))
|
||||
(if scheme->c
|
||||
(lambda (p) (tag-or-error (scheme->c p) tag))
|
||||
(lambda (p) (tag-or-error p tag))))
|
||||
(if nullable?
|
||||
(if c->scheme
|
||||
(lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p))
|
||||
(lambda (p) (when p (cpointer-push-tag! p tag)) p))
|
||||
(if c->scheme
|
||||
(lambda (p)
|
||||
(if p (cpointer-push-tag! p tag) (error* p))
|
||||
(c->scheme p))
|
||||
(lambda (p)
|
||||
(if p (cpointer-push-tag! p tag) (error* p))
|
||||
p)))))]))
|
||||
|
||||
;; This is a kind of a pointer that gets a specific tag when converted to
|
||||
;; Scheme, and accepts only such tagged pointers when going to C. An optional
|
||||
|
|
@ -1268,10 +1279,13 @@
|
|||
;; Simple structs: call this with a list of types, and get a type that marshals
|
||||
;; C structs to/from Scheme lists.
|
||||
(define* (_list-struct . types)
|
||||
(let ([stype (make-cstruct-type types)]
|
||||
[offsets (compute-offsets types)])
|
||||
(let ([stype (make-cstruct-type types)]
|
||||
[offsets (compute-offsets types)]
|
||||
[len (length types)])
|
||||
(make-ctype stype
|
||||
(lambda (vals)
|
||||
(unless (and (list vals) (= len (length vals)))
|
||||
(raise-type-error 'list-struct (format "list of ~a items" len) vals))
|
||||
(let ([block (malloc stype)])
|
||||
(for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val))
|
||||
types offsets vals)
|
||||
|
|
@ -1452,12 +1466,15 @@
|
|||
list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))
|
||||
(define (identifiers? stx)
|
||||
(andmap identifier? (syntax->list stx)))
|
||||
(define (_-identifier? stx)
|
||||
(and (identifier? stx)
|
||||
(regexp-match #rx"^_.+" (symbol->string (syntax-e stx)))))
|
||||
(define (_-identifier? id stx)
|
||||
(and (identifier? id)
|
||||
(or (regexp-match #rx"^_." (symbol->string (syntax-e id)))
|
||||
(raise-syntax-error #f "cstruct name must begin with a `_'"
|
||||
stx id))))
|
||||
(syntax-case stx ()
|
||||
[(_ _TYPE ([slot slot-type] ...))
|
||||
(and (_-identifier? #'_TYPE) (identifiers? #'(slot ...)))
|
||||
(and (_-identifier? #'_TYPE stx)
|
||||
(identifiers? #'(slot ...)))
|
||||
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))]
|
||||
[(_ (_TYPE _SUPER) ([slot slot-type] ...))
|
||||
(and (_-identifier? #'_TYPE) (identifiers? #'(slot ...)))
|
||||
|
|
@ -1553,8 +1570,7 @@
|
|||
(define killer-executor (make-will-executor))
|
||||
(define killer-thread #f)
|
||||
|
||||
(provide* (unsafe register-finalizer))
|
||||
(define (register-finalizer obj finalizer)
|
||||
(define* (register-finalizer obj finalizer)
|
||||
(unless killer-thread
|
||||
(set! killer-thread
|
||||
(thread (lambda ()
|
||||
|
|
|
|||
|
|
@ -44,20 +44,21 @@
|
|||
(let ([c (read-bytes-avail! s src)])
|
||||
(cond
|
||||
[(number? c)
|
||||
(for-each
|
||||
(lambda (dest)
|
||||
(let loop ([start 0])
|
||||
(unless (= start c)
|
||||
(let ([c2 (write-bytes-avail s dest start c)])
|
||||
(loop (+ start c2))))))
|
||||
dests)
|
||||
(let loop ([dests dests])
|
||||
(unless (null? dests)
|
||||
(let loop ([start 0])
|
||||
(unless (= start c)
|
||||
(let ([c2 (write-bytes-avail s (car dests) start c)])
|
||||
(loop (+ start c2)))))
|
||||
(loop (cdr dests))))
|
||||
(loop)]
|
||||
[(procedure? c)
|
||||
(let ([v (let-values ([(l col p) (port-next-location src)])
|
||||
(c (object-name src) l col p))])
|
||||
(for-each
|
||||
(lambda (dest) (write-special v dest))
|
||||
dests))
|
||||
(let loop ([dests dests])
|
||||
(unless (null? dests)
|
||||
(write-special v (car dests))
|
||||
(loop (cdr dests)))))
|
||||
(loop)]
|
||||
[else
|
||||
;; Must be EOF
|
||||
|
|
|
|||
|
|
@ -736,7 +736,9 @@
|
|||
(lambda ()
|
||||
(out (if (hash-table? obj 'equal)
|
||||
"#hash"
|
||||
"#hasheq"))
|
||||
(if (hash-table? obj 'eqv)
|
||||
"#hasheqv"
|
||||
"#hasheq")))
|
||||
(wr-lst (hash-table-map obj (lambda (k v)
|
||||
(cons k (make-hide v))))
|
||||
#f depth
|
||||
|
|
@ -855,7 +857,9 @@
|
|||
[(hash-table? obj)
|
||||
(out (if (hash-table? obj 'equal)
|
||||
"#hash"
|
||||
"#hasheq"))
|
||||
(if (hash-table? obj 'eqv)
|
||||
"#hasheqv"
|
||||
"#hasheq")))
|
||||
(pp-list (hash-table-map obj cons) extra pp-expr #f depth
|
||||
pair? car cdr pair-open pair-close)]
|
||||
[(and (box? obj) print-box?)
|
||||
|
|
@ -1084,11 +1088,14 @@
|
|||
|
||||
(define max-call-head-width 5)
|
||||
|
||||
(define (no-sharing? expr count acdr)
|
||||
(if (and found (hash-table-get found (acdr expr) #f))
|
||||
#f
|
||||
(or (zero? count)
|
||||
(no-sharing? (acdr expr) (sub1 count) acdr))))
|
||||
(define (no-sharing? expr count apair? acdr)
|
||||
(if (apair? expr)
|
||||
(if (and found
|
||||
(hash-table-get found (acdr expr) #f))
|
||||
#f
|
||||
(or (zero? count)
|
||||
(no-sharing? (acdr expr) (sub1 count) apair? acdr)))
|
||||
#f))
|
||||
|
||||
(define (style head expr apair? acar acdr)
|
||||
(case (look-in-style-table head)
|
||||
|
|
@ -1096,22 +1103,22 @@
|
|||
syntax-rules
|
||||
shared
|
||||
unless when)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-lambda))
|
||||
((if set! set!-values)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-if))
|
||||
((cond case-lambda)
|
||||
(and (no-sharing? expr 0 acdr)
|
||||
(and (no-sharing? expr 0 apair? acdr)
|
||||
pp-cond))
|
||||
((case class)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-case))
|
||||
((and or import export
|
||||
require require-for-syntax require-for-template
|
||||
provide link
|
||||
public private override rename inherit field init)
|
||||
(and (no-sharing? expr 0 acdr)
|
||||
(and (no-sharing? expr 0 apair? acdr)
|
||||
pp-and))
|
||||
((let letrec let*
|
||||
let-values letrec-values let*-values
|
||||
|
|
@ -1122,20 +1129,21 @@
|
|||
(symbol? (acar (acdr expr))))
|
||||
2
|
||||
1)
|
||||
apair?
|
||||
acdr)
|
||||
pp-let))
|
||||
((begin begin0)
|
||||
(and (no-sharing? expr 0 acdr)
|
||||
(and (no-sharing? expr 0 apair? acdr)
|
||||
pp-begin))
|
||||
((do letrec-syntaxes+values)
|
||||
(and (no-sharing? expr 2 acdr)
|
||||
(and (no-sharing? expr 2 apair? acdr)
|
||||
pp-do))
|
||||
|
||||
((send syntax-case instantiate module)
|
||||
(and (no-sharing? expr 2 acdr)
|
||||
(and (no-sharing? expr 2 apair? acdr)
|
||||
pp-syntax-case))
|
||||
((make-object)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-make-object))
|
||||
|
||||
(else #f)))
|
||||
|
|
@ -1173,7 +1181,7 @@
|
|||
(and (pretty-print-abbreviate-read-macros)
|
||||
(let ((head (car l)) (tail (cdr l)))
|
||||
(case head
|
||||
((quote quasiquote unquote unquote-splicing syntax)
|
||||
((quote quasiquote unquote unquote-splicing syntax unsyntax unsyntax-splicing)
|
||||
(length1? tail))
|
||||
(else #f)))))
|
||||
|
||||
|
|
|
|||
|
|
@ -62,62 +62,66 @@
|
|||
;; func : the wrapper function maker. It accepts a procedure for
|
||||
;; checking the first-order properties and the contracts
|
||||
;; and it produces a wrapper-making function.
|
||||
(define-struct/prop -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
|
||||
((proj-prop (λ (ctc)
|
||||
(let* ([doms/c (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest ctc)
|
||||
(append (->-doms ctc) (list (->-dom-rest ctc)))
|
||||
(->-doms ctc)))]
|
||||
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
|
||||
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms/c)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-ranges partial-kwds)))))))
|
||||
(name-prop (λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs ctc))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([l (length (->-doms ctc))])
|
||||
(if (->-dom-rest ctc)
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-accepts-and-more? x l)))
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x l)
|
||||
(no-mandatory-keywords? x)))))))
|
||||
(stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs that)))))))
|
||||
(define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
|
||||
#:omit-define-syntaxes
|
||||
#:property proj-prop
|
||||
(λ (ctc)
|
||||
(let* ([doms/c (map (λ (x) ((proj-get x) x))
|
||||
(if (->-dom-rest ctc)
|
||||
(append (->-doms ctc) (list (->-dom-rest ctc)))
|
||||
(->-doms ctc)))]
|
||||
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
|
||||
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
|
||||
[mandatory-keywords (->-quoted-kwds ctc)]
|
||||
[func (->-func ctc)]
|
||||
[dom-length (length (->-doms ctc))]
|
||||
[has-rest? (and (->-dom-rest ctc) #t)])
|
||||
(lambda (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
||||
doms/c)]
|
||||
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
||||
rngs/c)]
|
||||
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str))
|
||||
kwds/c)])
|
||||
(apply func
|
||||
(λ (val)
|
||||
(if has-rest?
|
||||
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
|
||||
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
|
||||
(append partial-doms partial-ranges partial-kwds))))))
|
||||
|
||||
#:property name-prop
|
||||
(λ (ctc) (single-arrow-name-maker
|
||||
(->-doms ctc)
|
||||
(->-dom-rest ctc)
|
||||
(->-kwds ctc)
|
||||
(->-quoted-kwds ctc)
|
||||
(->-rng-any? ctc)
|
||||
(->-rngs ctc)))
|
||||
#:property first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([l (length (->-doms ctc))])
|
||||
(if (->-dom-rest ctc)
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-accepts-and-more? x l)))
|
||||
(λ (x)
|
||||
(and (procedure? x)
|
||||
(procedure-arity-includes? x l)
|
||||
(no-mandatory-keywords? x))))))
|
||||
#:property stronger-prop
|
||||
(λ (this that)
|
||||
(and (->? that)
|
||||
(= (length (->-doms that))
|
||||
(length (->-doms this)))
|
||||
(andmap contract-stronger?
|
||||
(->-doms that)
|
||||
(->-doms this))
|
||||
(= (length (->-rngs that))
|
||||
(length (->-rngs this)))
|
||||
(andmap contract-stronger?
|
||||
(->-rngs this)
|
||||
(->-rngs that)))))
|
||||
|
||||
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -645,7 +645,9 @@
|
|||
swapped-renames)
|
||||
(loop (cdr e))
|
||||
(cons (car e) (loop (cdr e)))))))]
|
||||
[local-vars (append renamed-internals filtered-exported-names imported-names)]
|
||||
[local-vars (map (lambda (s)
|
||||
(datum->syntax-object expr s))
|
||||
(append renamed-internals filtered-exported-names imported-names))]
|
||||
[expand-context (generate-expand-context)]
|
||||
[import-stxes (apply append (map (lambda (i)
|
||||
(map
|
||||
|
|
@ -665,6 +667,7 @@
|
|||
(let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
|
||||
(cond
|
||||
[(and (null? pre-lines) (not port) (null? lines))
|
||||
(internal-definition-context-seal def-ctx)
|
||||
(make-parsed-unit imports
|
||||
renames
|
||||
vars
|
||||
|
|
|
|||
|
|
@ -1,103 +1,102 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base
|
||||
syntax/kerncase
|
||||
syntax/context))
|
||||
|
||||
(module stxset mzscheme
|
||||
(provide finish-syntax-set)
|
||||
|
||||
(require-for-syntax syntax/kerncase
|
||||
syntax/context)
|
||||
|
||||
(provide finish-syntax-set)
|
||||
|
||||
;; Used in the expansion of `define-syntax-set' from "etc.ss"
|
||||
(define-syntax (finish-syntax-set stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
(let ([stx (syntax stx)])
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) defn ...)
|
||||
;; The ids have already been checked --------------------
|
||||
(let ([ids (syntax->list (syntax (id ...)))])
|
||||
(let ([internal-ids (map (lambda (id)
|
||||
(datum->syntax-object
|
||||
id
|
||||
(string->symbol (format "~a/proc" (syntax-e id)))
|
||||
id))
|
||||
ids)]
|
||||
[expand-context (generate-expand-context)])
|
||||
;; Check defns (requires expand) ---------
|
||||
(let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))])
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn)
|
||||
(let ([defn (local-expand
|
||||
defn
|
||||
expand-context
|
||||
(kernel-form-identifier-list))])
|
||||
(syntax-case defn (define-values define-syntaxes begin)
|
||||
[(define-values (id ...) expr)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(list defn)]
|
||||
[(define-values . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad definition"
|
||||
stx
|
||||
defn)]
|
||||
[(define-syntaxes (id ...) expr)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(list defn)]
|
||||
[(define-syntaxes . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad definition"
|
||||
stx
|
||||
defn)]
|
||||
[(begin defn ...)
|
||||
(loop (syntax->list (syntax (defn ...))))]
|
||||
[(begin . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad `begin'"
|
||||
stx
|
||||
defn)]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition"
|
||||
stx
|
||||
defn)])))
|
||||
defns)))]
|
||||
|
||||
[def-ids (apply append (map (lambda (defn)
|
||||
(syntax-case defn ()
|
||||
[(_ (id ...) expr)
|
||||
(syntax->list (syntax (id ...)))]))
|
||||
defns))]
|
||||
[val-ids (apply append (map (lambda (defn)
|
||||
(syntax-case defn (define-values)
|
||||
[(define-values (id ...) expr)
|
||||
(syntax->list (syntax (id ...)))]
|
||||
[_else null]))
|
||||
defns))])
|
||||
(let ([dup (check-duplicate-identifier def-ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate defined identifier"
|
||||
stx
|
||||
dup)))
|
||||
;; Check that declared are defined ---------
|
||||
(for-each (lambda (id)
|
||||
(unless (check-duplicate-identifier (cons id val-ids))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected identifier is not defined"
|
||||
stx
|
||||
id)))
|
||||
internal-ids)
|
||||
;; Produce result ------------------------------
|
||||
(with-syntax ([(defn ...) defns]
|
||||
[(internal-id ...) internal-ids])
|
||||
(syntax/loc stx
|
||||
(let ()
|
||||
defn ...
|
||||
(values internal-id ...)))))))]))])))
|
||||
;; Used in the expansion of `define-syntax-set' from "etc.ss"
|
||||
(define-syntax (finish-syntax-set stx)
|
||||
(syntax-case stx ()
|
||||
[(_ stx)
|
||||
(let ([stx (syntax stx)])
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) defn ...)
|
||||
;; The ids have already been checked --------------------
|
||||
(let ([ids (syntax->list (syntax (id ...)))])
|
||||
(let ([internal-ids (map (lambda (id)
|
||||
(datum->syntax
|
||||
id
|
||||
(string->symbol (format "~a/proc" (syntax-e id)))
|
||||
id))
|
||||
ids)]
|
||||
[expand-context (generate-expand-context)])
|
||||
;; Check defns (requires expand) ---------
|
||||
(let* ([defns (let loop ([defns (syntax->list (syntax (defn ...)))])
|
||||
(apply
|
||||
append
|
||||
(map
|
||||
(lambda (defn)
|
||||
(let ([defn (local-expand
|
||||
defn
|
||||
expand-context
|
||||
(kernel-form-identifier-list))])
|
||||
(syntax-case defn (define-values define-syntaxes begin)
|
||||
[(define-values (id ...) expr)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(list defn)]
|
||||
[(define-values . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad definition"
|
||||
stx
|
||||
defn)]
|
||||
[(define-syntaxes (id ...) expr)
|
||||
(andmap identifier? (syntax->list (syntax (id ...))))
|
||||
(list defn)]
|
||||
[(define-syntaxes . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad definition"
|
||||
stx
|
||||
defn)]
|
||||
[(begin defn ...)
|
||||
(loop (syntax->list (syntax (defn ...))))]
|
||||
[(begin . _)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad `begin'"
|
||||
stx
|
||||
defn)]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not a definition"
|
||||
stx
|
||||
defn)])))
|
||||
defns)))]
|
||||
|
||||
[def-ids (apply append (map (lambda (defn)
|
||||
(syntax-case defn ()
|
||||
[(_ (id ...) expr)
|
||||
(syntax->list (syntax (id ...)))]))
|
||||
defns))]
|
||||
[val-ids (apply append (map (lambda (defn)
|
||||
(syntax-case defn (define-values)
|
||||
[(define-values (id ...) expr)
|
||||
(syntax->list (syntax (id ...)))]
|
||||
[_else null]))
|
||||
defns))])
|
||||
(let ([dup (check-duplicate-identifier def-ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate defined identifier"
|
||||
stx
|
||||
dup)))
|
||||
;; Check that declared are defined ---------
|
||||
(for-each (lambda (id)
|
||||
(unless (check-duplicate-identifier (cons id val-ids))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected identifier is not defined"
|
||||
stx
|
||||
id)))
|
||||
internal-ids)
|
||||
;; Produce result ------------------------------
|
||||
(with-syntax ([(defn ...) defns]
|
||||
[(internal-id ...) internal-ids])
|
||||
(syntax/loc stx
|
||||
(let ()
|
||||
defn ...
|
||||
(values internal-id ...)))))))]))]))
|
||||
|
|
|
|||
|
|
@ -1,124 +1,118 @@
|
|||
(module sandbox scheme/base
|
||||
(require scheme/sandbox
|
||||
(prefix-in mz: (only-in mzscheme make-namespace)))
|
||||
(provide sandbox-init-hook
|
||||
sandbox-reader
|
||||
sandbox-input
|
||||
sandbox-output
|
||||
sandbox-error-output
|
||||
sandbox-propagate-breaks
|
||||
sandbox-coverage-enabled
|
||||
sandbox-namespace-specs
|
||||
sandbox-override-collection-paths
|
||||
sandbox-security-guard
|
||||
sandbox-path-permissions
|
||||
sandbox-network-guard
|
||||
sandbox-make-inspector
|
||||
sandbox-eval-limits
|
||||
kill-evaluator
|
||||
break-evaluator
|
||||
set-eval-limits
|
||||
put-input
|
||||
get-output
|
||||
get-error-output
|
||||
get-uncovered-expressions
|
||||
call-with-limits
|
||||
with-limits
|
||||
exn:fail:resource?
|
||||
exn:fail:resource-resource
|
||||
(rename-out [*make-evaluator make-evaluator]
|
||||
[gui? mred?]))
|
||||
#lang scheme/base
|
||||
|
||||
(define-namespace-anchor anchor)
|
||||
(require scheme/sandbox
|
||||
(prefix-in mz: (only-in mzscheme make-namespace)))
|
||||
|
||||
;; Compatbility:
|
||||
;; * recognize 'r5rs, etc, and wrap them as a list.
|
||||
;; * 'begin form of reqs
|
||||
;; * more agressively extract requires from lang and reqs
|
||||
(define *make-evaluator
|
||||
(case-lambda
|
||||
[(lang reqs . progs)
|
||||
(with-ns-params
|
||||
(lambda ()
|
||||
(let ([beg-req? (and (list? reqs)
|
||||
(pair? reqs)
|
||||
(eq? 'begin (car reqs)))]
|
||||
[reqs (or reqs '())]
|
||||
[lang (or lang '(begin))])
|
||||
(keyword-apply
|
||||
make-evaluator
|
||||
'(#:allow-read #:requires)
|
||||
(list (extract-requires lang reqs)
|
||||
(if beg-req? null reqs))
|
||||
(case lang
|
||||
[(r5rs beginner beginner-abbr intermediate intermediate-lambda advanced)
|
||||
(list 'special lang)]
|
||||
[else lang])
|
||||
(append
|
||||
(if beg-req? (cdr reqs) null)
|
||||
progs)))))]
|
||||
[(mod)
|
||||
(with-ns-params
|
||||
(lambda ()
|
||||
(make-module-evaluator mod)))]))
|
||||
(provide sandbox-init-hook
|
||||
sandbox-reader
|
||||
sandbox-input
|
||||
sandbox-output
|
||||
sandbox-error-output
|
||||
sandbox-propagate-breaks
|
||||
sandbox-coverage-enabled
|
||||
sandbox-namespace-specs
|
||||
sandbox-override-collection-paths
|
||||
sandbox-security-guard
|
||||
sandbox-path-permissions
|
||||
sandbox-network-guard
|
||||
sandbox-make-inspector
|
||||
sandbox-eval-limits
|
||||
kill-evaluator
|
||||
break-evaluator
|
||||
set-eval-limits
|
||||
put-input
|
||||
get-output
|
||||
get-error-output
|
||||
get-uncovered-expressions
|
||||
call-with-limits
|
||||
with-limits
|
||||
exn:fail:resource?
|
||||
exn:fail:resource-resource
|
||||
(rename-out [*make-evaluator make-evaluator]
|
||||
[gui? mred?]))
|
||||
|
||||
(define (make-mz-namespace)
|
||||
(let ([ns (mz:make-namespace)])
|
||||
;; Because scheme/sandbox needs scheme/base:
|
||||
(namespace-attach-module (namespace-anchor->namespace anchor)
|
||||
'scheme/base
|
||||
ns)
|
||||
ns))
|
||||
(define-namespace-anchor anchor)
|
||||
|
||||
(define (with-ns-params thunk)
|
||||
(let ([v (sandbox-namespace-specs)])
|
||||
(cond
|
||||
[(and (not gui?)
|
||||
(eq? (car v) make-base-namespace))
|
||||
(parameterize ([sandbox-namespace-specs
|
||||
(cons make-mz-namespace
|
||||
(cdr v))])
|
||||
(thunk))]
|
||||
[(and gui?
|
||||
(eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
|
||||
(parameterize ([sandbox-namespace-specs
|
||||
;; Simulate the old make-namespace-with-mred:
|
||||
(cons (lambda ()
|
||||
(let ([ns (make-mz-namespace)]
|
||||
[ns2 ((dynamic-require 'mred 'make-gui-namespace))])
|
||||
(namespace-attach-module ns2 'mred ns)
|
||||
(namespace-attach-module ns2 'scheme/class ns)
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require 'mred)
|
||||
(namespace-require 'scheme/class))
|
||||
ns))
|
||||
(cdr v))])
|
||||
(thunk))]
|
||||
[else (thunk)])))
|
||||
|
||||
(define (literal-identifier=? x y)
|
||||
(or (free-identifier=? x y)
|
||||
(eq? (syntax-e x) (syntax-e y))))
|
||||
;; Compatbility:
|
||||
;; * recognize 'r5rs, etc, and wrap them as a list.
|
||||
;; * 'begin form of reqs
|
||||
;; * more agressively extract requires from lang and reqs
|
||||
(define *make-evaluator
|
||||
(case-lambda
|
||||
[(lang reqs . progs)
|
||||
(with-ns-params
|
||||
(lambda ()
|
||||
(let ([beg-req? (and (list? reqs)
|
||||
(pair? reqs)
|
||||
(eq? 'begin (car reqs)))]
|
||||
[reqs (or reqs '())]
|
||||
[lang (or lang '(begin))])
|
||||
(keyword-apply
|
||||
make-evaluator
|
||||
'(#:allow-read #:requires)
|
||||
(list (extract-requires lang reqs)
|
||||
(if beg-req? null reqs))
|
||||
(case lang
|
||||
[(r5rs beginner beginner-abbr intermediate intermediate-lambda
|
||||
advanced)
|
||||
(list 'special lang)]
|
||||
[else lang])
|
||||
(append (if beg-req? (cdr reqs) null) progs)))))]
|
||||
[(mod) (with-ns-params (lambda () (make-module-evaluator mod)))]))
|
||||
|
||||
(define (extract-requires language requires)
|
||||
(define (find-requires forms)
|
||||
(let loop ([forms (reverse forms)] [reqs '()])
|
||||
(if (null? forms)
|
||||
reqs
|
||||
(loop (cdr forms)
|
||||
(syntax-case* (car forms) (require) literal-identifier=?
|
||||
[(require specs ...)
|
||||
(append (syntax->datum #'(specs ...)) reqs)]
|
||||
[_else reqs])))))
|
||||
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires)))
|
||||
(find-requires (cdr requires))
|
||||
null)]
|
||||
[requires (cond [(string? language) requires]
|
||||
[(not (pair? language)) requires]
|
||||
[(memq (car language) '(lib file planet quote))
|
||||
requires]
|
||||
[(eq? (car language) 'begin)
|
||||
(append (find-requires (cdr language)) requires)]
|
||||
[else (error 'extract-requires
|
||||
"bad language spec: ~e" language)])])
|
||||
requires)))
|
||||
(define (make-mz-namespace)
|
||||
(let ([ns (mz:make-namespace)])
|
||||
;; Because scheme/sandbox needs scheme/base:
|
||||
(namespace-attach-module (namespace-anchor->namespace anchor)
|
||||
'scheme/base ns)
|
||||
ns))
|
||||
|
||||
(define (with-ns-params thunk)
|
||||
(let ([v (sandbox-namespace-specs)])
|
||||
(cond [(and (not gui?) (eq? (car v) make-base-namespace))
|
||||
(parameterize ([sandbox-namespace-specs
|
||||
(cons make-mz-namespace (cdr v))])
|
||||
(thunk))]
|
||||
[(and gui? (eq? (car v) (dynamic-require 'mred 'make-gui-namespace)))
|
||||
(parameterize
|
||||
([sandbox-namespace-specs
|
||||
;; Simulate the old make-namespace-with-mred:
|
||||
(cons (lambda ()
|
||||
(let ([ns (make-mz-namespace)]
|
||||
[ns2 ((dynamic-require
|
||||
'mred 'make-gui-namespace))])
|
||||
(namespace-attach-module ns2 'mred ns)
|
||||
(namespace-attach-module ns2 'scheme/class ns)
|
||||
(parameterize ([current-namespace ns])
|
||||
(namespace-require 'mred)
|
||||
(namespace-require 'scheme/class))
|
||||
ns))
|
||||
(cdr v))])
|
||||
(thunk))]
|
||||
[else (thunk)])))
|
||||
|
||||
(define (literal-identifier=? x y)
|
||||
(or (free-identifier=? x y) (eq? (syntax-e x) (syntax-e y))))
|
||||
|
||||
(define (extract-requires language requires)
|
||||
(define (find-requires forms)
|
||||
(let loop ([forms (reverse forms)] [reqs '()])
|
||||
(if (null? forms)
|
||||
reqs
|
||||
(loop (cdr forms)
|
||||
(syntax-case* (car forms) (require) literal-identifier=?
|
||||
[(require specs ...)
|
||||
(append (syntax->datum #'(specs ...)) reqs)]
|
||||
[_else reqs])))))
|
||||
(let* ([requires (if (and (pair? requires) (eq? 'begin (car requires)))
|
||||
(find-requires (cdr requires))
|
||||
null)]
|
||||
[requires (cond [(string? language) requires]
|
||||
[(not (pair? language)) requires]
|
||||
[(memq (car language) '(lib file planet quote))
|
||||
requires]
|
||||
[(eq? (car language) 'begin)
|
||||
(append (find-requires (cdr language)) requires)]
|
||||
[else (error 'extract-requires
|
||||
"bad language spec: ~e" language)])])
|
||||
requires))
|
||||
|
|
|
|||
|
|
@ -126,8 +126,7 @@
|
|||
((((int-sid . ext-sid) ...) . sbody) ...))
|
||||
(map-sig (lambda (x) x)
|
||||
(make-syntax-introducer)
|
||||
sig)
|
||||
#;(add-context-to-sig sig)])
|
||||
sig)])
|
||||
(list
|
||||
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
|
||||
(values
|
||||
|
|
@ -165,13 +164,17 @@
|
|||
(cons (map syntax-local-introduce (car d))
|
||||
(syntax-local-introduce (cdr d))))
|
||||
|
||||
(define-for-syntax (introduce-ctc-pair cp)
|
||||
(cons (syntax-local-introduce (car cp))
|
||||
(syntax-local-introduce (cdr cp))))
|
||||
|
||||
;; build-define-syntax : identifier (or/c identifier #f) syntax-object -> syntax-object
|
||||
(define-for-syntax (build-define-signature sigid super-sigid sig-exprs)
|
||||
(unless (or (stx-null? sig-exprs) (stx-pair? sig-exprs))
|
||||
(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-val-defs super-stx-defs super-ctc-pairs)
|
||||
(if super-sigid
|
||||
(let* ([super-sig (lookup-signature super-sigid)]
|
||||
[super-siginfo (signature-siginfo super-sig)])
|
||||
|
|
@ -181,17 +184,20 @@
|
|||
(siginfo-rtime-ids super-siginfo))
|
||||
(map syntax-local-introduce (signature-vars super-sig))
|
||||
(map introduce-def (signature-val-defs super-sig))
|
||||
(map introduce-def (signature-stx-defs super-sig))))
|
||||
(values '() '() '() '() '() '())))
|
||||
(map introduce-def (signature-stx-defs super-sig))
|
||||
(map introduce-ctc-pair (signature-ctc-pairs super-sig))))
|
||||
(values '() '() '() '() '() '() '())))
|
||||
(let loop ((sig-exprs ses)
|
||||
(bindings null)
|
||||
(val-defs null)
|
||||
(stx-defs null))
|
||||
(stx-defs null)
|
||||
(ctc-pairs 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-ctc-pairs (append super-ctc-pairs (reverse ctc-pairs))]
|
||||
[dup
|
||||
(check-duplicate-identifier
|
||||
(append all-bindings
|
||||
|
|
@ -203,7 +209,8 @@
|
|||
((super-name ...) super-names)
|
||||
((var ...) all-bindings)
|
||||
((((vid ...) . vbody) ...) all-val-defs)
|
||||
((((sid ...) . sbody) ...) all-stx-defs))
|
||||
((((sid ...) . sbody) ...) all-stx-defs)
|
||||
(((cid . cbody) ...) all-ctc-pairs))
|
||||
#`(begin
|
||||
(define signature-tag (gensym))
|
||||
(define-syntax #,sigid
|
||||
|
|
@ -221,12 +228,26 @@
|
|||
(list (cons (list (quote-syntax sid) ...)
|
||||
((syntax-local-certifier)
|
||||
(quote-syntax sbody)))
|
||||
...))))))))
|
||||
...)
|
||||
(list (cons (quote-syntax cid)
|
||||
((syntax-local-certifier)
|
||||
(quote-syntax cbody)))
|
||||
...)
|
||||
(quote-syntax #,sigid))))))))
|
||||
(else
|
||||
(syntax-case (car sig-exprs) (define-values define-syntaxes)
|
||||
(syntax-case (car sig-exprs) (define-values define-syntaxes contracted)
|
||||
(x
|
||||
(identifier? #'x)
|
||||
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs))
|
||||
(loop (cdr sig-exprs) (cons #'x bindings) val-defs stx-defs ctc-pairs))
|
||||
((x y z)
|
||||
(and (identifier? #'x)
|
||||
(module-identifier=? #'x #'contracted)
|
||||
(identifier? #'y))
|
||||
(loop (cdr sig-exprs)
|
||||
(cons #'y bindings)
|
||||
val-defs
|
||||
stx-defs
|
||||
(cons (cons #'y #'z) ctc-pairs)))
|
||||
((x . y)
|
||||
(and (identifier? #'x)
|
||||
(or (module-identifier=? #'x #'define-values)
|
||||
|
|
@ -248,7 +269,8 @@
|
|||
(if (module-identifier=? #'x #'define-syntaxes)
|
||||
(cons (cons (syntax->list #'(name ...)) b)
|
||||
stx-defs)
|
||||
stx-defs))))))))
|
||||
stx-defs)
|
||||
ctc-pairs)))))))
|
||||
((x . y)
|
||||
(let ((trans
|
||||
(set!-trans-extract
|
||||
|
|
@ -266,7 +288,8 @@
|
|||
(loop (append results (cdr sig-exprs))
|
||||
bindings
|
||||
val-defs
|
||||
stx-defs))))
|
||||
stx-defs
|
||||
ctc-pairs))))
|
||||
(x (raise-stx-err
|
||||
"expected either an identifier or signature form"
|
||||
#'x))))))))
|
||||
|
|
@ -328,13 +351,6 @@
|
|||
'expression
|
||||
(list #'stop)
|
||||
def-ctx))))
|
||||
|
||||
(define-for-syntax (add-context-to-sig sig)
|
||||
(let ((def-ctx (syntax-local-make-definition-context)))
|
||||
(syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx)
|
||||
(map-sig (lambda (x) x)
|
||||
(lambda (x) (localify x def-ctx))
|
||||
sig)))
|
||||
|
||||
(define-for-syntax (iota n)
|
||||
(let loop ((n n)
|
||||
|
|
@ -618,6 +634,7 @@
|
|||
[_ (void)]))
|
||||
expanded-body)
|
||||
table)])
|
||||
(internal-definition-context-seal def-ctx)
|
||||
|
||||
;; Mark exported names and
|
||||
;; check that all exported names are defined (as var):
|
||||
|
|
@ -1274,7 +1291,8 @@
|
|||
(make-unit-info ((syntax-local-certifier) (quote-syntax u))
|
||||
(list (cons 'itag (quote-syntax isig)) ...)
|
||||
(list (cons 'etag (quote-syntax esig)) ...)
|
||||
(list (cons 'deptag (quote-syntax deptag)) ...))))))))))
|
||||
(list (cons 'deptag (quote-syntax deptag)) ...)
|
||||
(quote-syntax name))))))))))
|
||||
((_)
|
||||
(raise-stx-err err-msg))))
|
||||
|
||||
|
|
@ -1356,9 +1374,12 @@
|
|||
(define-syntax/err-param (define-values/invoke-unit/infer stx)
|
||||
(syntax-case stx ()
|
||||
((_ u)
|
||||
(let ((ui (lookup-def-unit #'u)))
|
||||
(with-syntax (((sig ...) (map unprocess-tagged-id (unit-info-export-sig-ids ui)))
|
||||
((isig ...) (map unprocess-tagged-id (unit-info-import-sig-ids ui))))
|
||||
(let* ((ui (lookup-def-unit #'u))
|
||||
(unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))])
|
||||
(lambda (p)
|
||||
(unprocess-tagged-id (cons (car p) (i (cdr p))))))))
|
||||
(with-syntax (((sig ...) (map unprocess (unit-info-export-sig-ids ui)))
|
||||
((isig ...) (map unprocess (unit-info-import-sig-ids ui))))
|
||||
(quasisyntax/loc stx
|
||||
(define-values/invoke-unit u (import isig ...) (export sig ...))))))
|
||||
((_)
|
||||
|
|
@ -1437,19 +1458,23 @@
|
|||
s))
|
||||
(apply make-link-record l))
|
||||
|
||||
(define (process-tagged-sigid sid)
|
||||
(make-link-record (car sid) #f (cdr sid) (signature-siginfo (lookup-signature (cdr sid)))))
|
||||
(define ((process-tagged-sigid introducer) sid)
|
||||
(make-link-record (car sid) #f (introducer (cdr sid)) (signature-siginfo (lookup-signature (cdr sid)))))
|
||||
|
||||
(syntax-case stx ()
|
||||
(((import ...)
|
||||
(export ...)
|
||||
(((out ...) u l ...) ...))
|
||||
(let* ([units (map lookup-def-unit (syntax->list #'(u ...)))]
|
||||
(let* ([us (syntax->list #'(u ...))]
|
||||
[units (map lookup-def-unit us)]
|
||||
[import-sigs (map process-signature
|
||||
(syntax->list #'(import ...)))]
|
||||
[sig-introducers (map (lambda (unit u)
|
||||
(make-syntax-delta-introducer u (unit-info-orig-binder unit)))
|
||||
units us)]
|
||||
[sub-outs
|
||||
(map
|
||||
(lambda (outs unit)
|
||||
(lambda (outs unit sig-introducer)
|
||||
(define o
|
||||
(map
|
||||
(lambda (clause)
|
||||
|
|
@ -1457,10 +1482,11 @@
|
|||
(make-link-record (car c) (cadr c) (cddr c)
|
||||
(signature-siginfo (lookup-signature (cddr c)))))
|
||||
(syntax->list outs)))
|
||||
(complete-exports (map process-tagged-sigid (unit-info-export-sig-ids unit))
|
||||
(complete-exports (map (process-tagged-sigid sig-introducer) (unit-info-export-sig-ids unit))
|
||||
o))
|
||||
(syntax->list #'((out ...) ...))
|
||||
units)]
|
||||
units
|
||||
sig-introducers)]
|
||||
[link-defs (append import-sigs (apply append sub-outs))])
|
||||
|
||||
(define lnk-table (make-bound-identifier-mapping))
|
||||
|
|
@ -1486,7 +1512,7 @@
|
|||
|
||||
(let ([sub-ins
|
||||
(map
|
||||
(lambda (ins unit unit-stx)
|
||||
(lambda (ins unit sig-introducer unit-stx)
|
||||
(define is (syntax->list ins))
|
||||
(define lrs
|
||||
(map
|
||||
|
|
@ -1510,12 +1536,13 @@
|
|||
is)
|
||||
(complete-imports sig-table
|
||||
lrs
|
||||
(map process-tagged-sigid
|
||||
(map (process-tagged-sigid sig-introducer)
|
||||
(unit-info-import-sig-ids unit))
|
||||
unit-stx))
|
||||
(syntax->list #'((l ...) ...))
|
||||
units
|
||||
(syntax->list #'(u ...)))]
|
||||
sig-introducers
|
||||
us)]
|
||||
[exports
|
||||
(map
|
||||
(lambda (e)
|
||||
|
|
|
|||
|
|
@ -158,7 +158,10 @@
|
|||
[else (list defn-or-expr)])))
|
||||
defns&exprs)))
|
||||
values)])
|
||||
|
||||
(let ([all-expanded (expand-all (syntax->list (syntax (defn&expr ...))))])
|
||||
(when def-ctx
|
||||
(internal-definition-context-seal def-ctx))
|
||||
;; Get all the defined names, sorting out variable definitions
|
||||
;; from syntax definitions.
|
||||
(let* ([definition?
|
||||
|
|
|
|||
394
collects/scheme/package.ss
Normal file
394
collects/scheme/package.ss
Normal file
|
|
@ -0,0 +1,394 @@
|
|||
#lang scheme/base
|
||||
(require (for-syntax scheme/base
|
||||
syntax/kerncase
|
||||
syntax/boundmap
|
||||
syntax/define))
|
||||
|
||||
(provide define-package
|
||||
package-begin
|
||||
|
||||
open-package
|
||||
open*-package
|
||||
|
||||
define*
|
||||
define*-values
|
||||
define*-syntax
|
||||
define*-syntaxes)
|
||||
|
||||
(define-for-syntax (do-define-* stx define-values-id)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) rhs)
|
||||
(let ([ids (syntax->list #'(id ...))])
|
||||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected an identifier for definition"
|
||||
stx
|
||||
id)))
|
||||
ids)
|
||||
(with-syntax ([define-values define-values-id])
|
||||
(syntax/loc stx
|
||||
(define-values (id ...) rhs))))]))
|
||||
(define-syntax (define*-values stx)
|
||||
(do-define-* stx #'define-values))
|
||||
(define-syntax (define*-syntaxes stx)
|
||||
(do-define-* stx #'define-syntaxes))
|
||||
|
||||
(define-syntax (define* stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-values (#,id) #,rhs))))
|
||||
(define-syntax (define*-syntax stx)
|
||||
(let-values ([(id rhs) (normalize-definition stx #'lambda)])
|
||||
(quasisyntax/loc stx
|
||||
(define*-syntaxes (#,id) #,rhs))))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-struct package (exports hidden)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:procedure (lambda (r stx)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"misuse of a package name"
|
||||
stx)))
|
||||
|
||||
(define (reverse-mapping who id exports hidden)
|
||||
(or (ormap (lambda (m)
|
||||
(and (free-identifier=? id (cdr m))
|
||||
(car m)))
|
||||
exports)
|
||||
(ormap (lambda (h)
|
||||
(and (free-identifier=? id h)
|
||||
;; Not at top level, where free-id=? is unreliable,
|
||||
;; and re-definition is ok:
|
||||
(identifier-binding id)
|
||||
;; Name is inaccessible. Generate a temporary to
|
||||
;; avoid potential duplicate-definition errors
|
||||
;; when the name is bound in the same context as
|
||||
;; the package.
|
||||
(car (generate-temporaries (list id)))))
|
||||
hidden)
|
||||
id)))
|
||||
|
||||
(define-for-syntax (do-define-package stx exp-stx)
|
||||
(syntax-case exp-stx ()
|
||||
[(_ pack-id mode exports form ...)
|
||||
(let ([id #'pack-id]
|
||||
[exports #'exports]
|
||||
[mode (syntax-e #'mode)])
|
||||
(unless (eq? mode '#:begin)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier"
|
||||
stx
|
||||
id)))
|
||||
(let ([exports
|
||||
(cond
|
||||
[(syntax->list exports)
|
||||
=> (lambda (l)
|
||||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error #f
|
||||
"expected identifier to export"
|
||||
stx
|
||||
i)))
|
||||
l)
|
||||
(let ([dup-id (check-duplicate-identifier l)])
|
||||
(when dup-id
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"duplicate export"
|
||||
stx
|
||||
dup-id)))
|
||||
l)]
|
||||
[else (raise-syntax-error #f
|
||||
(format "expected a parenthesized sequence of identifiers ~a"
|
||||
(case mode
|
||||
[(#:only) "to export"]
|
||||
[(#:all-defined-except) "to exclude from export"]
|
||||
[else (format "for ~a" mode)]))
|
||||
stx
|
||||
exports)])])
|
||||
(let* ([def-ctx (syntax-local-make-definition-context)]
|
||||
[ctx (cons (gensym 'intdef)
|
||||
(let ([orig-ctx (syntax-local-context)])
|
||||
(if (pair? orig-ctx)
|
||||
orig-ctx
|
||||
null)))]
|
||||
[pre-package-id (lambda (id def-ctxes)
|
||||
(for/fold ([id id])
|
||||
([def-ctx (in-list def-ctxes)])
|
||||
(identifier-remove-from-definition-context
|
||||
id
|
||||
def-ctx)))]
|
||||
[kernel-forms (list*
|
||||
#'define*-values
|
||||
#'define*-syntaxes
|
||||
(kernel-form-identifier-list))]
|
||||
[init-exprs (syntax->list #'(form ...))]
|
||||
[new-bindings (make-bound-identifier-mapping)]
|
||||
[fixup-sub-package (lambda (renamed-exports renamed-defines def-ctxes)
|
||||
(lambda (stx)
|
||||
(syntax-case* stx (define-syntaxes #%plain-app make-package quote-syntax
|
||||
list cons #%plain-lambda)
|
||||
free-transformer-identifier=?
|
||||
[(define-syntaxes (pack-id)
|
||||
(#%plain-app
|
||||
make-package
|
||||
(#%plain-lambda ()
|
||||
(#%plain-app list
|
||||
(#%plain-app cons
|
||||
(quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
hidden))
|
||||
(with-syntax ([(export ...)
|
||||
(map (lambda (id)
|
||||
(if (or (ormap (lambda (e-id)
|
||||
(bound-identifier=? id e-id))
|
||||
renamed-exports)
|
||||
(not (ormap (lambda (e-id)
|
||||
(bound-identifier=? id e-id))
|
||||
renamed-defines)))
|
||||
;; Need to preserve the original
|
||||
(pre-package-id id def-ctxes)
|
||||
;; It's not accessible, so just hide the name
|
||||
;; to avoid re-binding errors.
|
||||
(car (generate-temporaries (list id)))))
|
||||
(syntax->list #'(export ...)))])
|
||||
(syntax/loc stx
|
||||
(define-syntaxes (pack-id)
|
||||
(make-package
|
||||
(lambda ()
|
||||
(list (cons (quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
hidden))))]
|
||||
[_ stx])))]
|
||||
[complement (lambda (bindings ids)
|
||||
(let ([tmp (make-bound-identifier-mapping)])
|
||||
(bound-identifier-mapping-for-each bindings
|
||||
(lambda (k v)
|
||||
(bound-identifier-mapping-put! tmp k #t)))
|
||||
(for-each (lambda (id)
|
||||
(bound-identifier-mapping-put! tmp id #f))
|
||||
ids)
|
||||
(filter
|
||||
values
|
||||
(bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))])
|
||||
(let ([register-bindings!
|
||||
(lambda (ids)
|
||||
(for-each (lambda (id)
|
||||
(when (bound-identifier-mapping-get new-bindings id (lambda () #f))
|
||||
(raise-syntax-error #f
|
||||
"duplicate binding"
|
||||
stx
|
||||
id))
|
||||
(bound-identifier-mapping-put! new-bindings
|
||||
id
|
||||
#t))
|
||||
ids))]
|
||||
[add-package-context (lambda (def-ctxes)
|
||||
(lambda (stx)
|
||||
(for/fold ([stx stx])
|
||||
([def-ctx (in-list (reverse def-ctxes))])
|
||||
(let ([q (local-expand #`(quote #,stx)
|
||||
ctx
|
||||
(list #'quote)
|
||||
def-ctx)])
|
||||
(syntax-case q ()
|
||||
[(_ stx) #'stx])))))])
|
||||
(let loop ([exprs init-exprs]
|
||||
[rev-forms null]
|
||||
[defined null]
|
||||
[def-ctxes (list def-ctx)])
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(for-each (lambda (def-ctx)
|
||||
(internal-definition-context-seal def-ctx))
|
||||
def-ctxes)
|
||||
(let ([exports-renamed (map (add-package-context def-ctxes) exports)]
|
||||
[defined-renamed (bound-identifier-mapping-map new-bindings
|
||||
(lambda (k v) k))])
|
||||
(for-each (lambda (ex renamed)
|
||||
(unless (bound-identifier-mapping-get new-bindings
|
||||
renamed
|
||||
(lambda () #f))
|
||||
(raise-syntax-error #f
|
||||
(format "no definition for ~a identifier"
|
||||
(case mode
|
||||
[(#:only) "exported"]
|
||||
[(#:all-defined-except) "excluded"]))
|
||||
stx
|
||||
ex)))
|
||||
exports
|
||||
exports-renamed)
|
||||
(let-values ([(exports exports-renamed)
|
||||
(if (memq mode '(#:only #:begin))
|
||||
(values exports exports-renamed)
|
||||
(let ([all-exports-renamed (complement new-bindings exports-renamed)])
|
||||
;; In case of define*, get only the last definition:
|
||||
(let ([tmp (make-bound-identifier-mapping)])
|
||||
(for-each (lambda (id)
|
||||
(bound-identifier-mapping-put!
|
||||
tmp
|
||||
((add-package-context def-ctxes)
|
||||
(pre-package-id id def-ctxes))
|
||||
#t))
|
||||
all-exports-renamed)
|
||||
(let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))]
|
||||
[exports (map (lambda (id) (pre-package-id id def-ctxes))
|
||||
exports-renamed)])
|
||||
(values exports exports-renamed)))))])
|
||||
(with-syntax ([(export ...) exports]
|
||||
[(renamed ...) exports-renamed]
|
||||
[(hidden ...) (complement new-bindings exports-renamed)])
|
||||
(let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
|
||||
(reverse rev-forms))])
|
||||
(if (eq? mode '#:begin)
|
||||
(if (eq? 'expression (syntax-local-context))
|
||||
(quasisyntax/loc stx (let () #,@body))
|
||||
(quasisyntax/loc stx (begin #,@body)))
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
#,@(if (eq? 'top-level (syntax-local-context))
|
||||
;; delcare all bindings before they are used:
|
||||
#`((define-syntaxes #,defined-renamed (values)))
|
||||
null)
|
||||
#,@body
|
||||
(define-syntax pack-id
|
||||
(make-package
|
||||
(lambda ()
|
||||
(list (cons (quote-syntax export)
|
||||
(quote-syntax renamed))
|
||||
...))
|
||||
(lambda ()
|
||||
(list (quote-syntax hidden) ...)))))))))))]
|
||||
[else
|
||||
(let ([expr ((add-package-context (cdr def-ctxes))
|
||||
(local-expand ((add-package-context (cdr def-ctxes)) (car exprs))
|
||||
ctx
|
||||
kernel-forms
|
||||
(car def-ctxes)))])
|
||||
(syntax-case expr (begin)
|
||||
[(begin . rest)
|
||||
(loop (append (syntax->list #'rest) (cdr exprs))
|
||||
rev-forms
|
||||
defined
|
||||
def-ctxes)]
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-syntaxes)
|
||||
(free-identifier=? #'def #'define*-syntaxes))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(with-syntax ([rhs (local-transformer-expand
|
||||
#'rhs
|
||||
'expression
|
||||
null)])
|
||||
(let ([star? (free-identifier=? #'def #'define*-syntaxes)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context)
|
||||
(car def-ctxes))]
|
||||
[ids (if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids)])
|
||||
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons #`(define-syntaxes #,ids rhs)
|
||||
rev-forms)
|
||||
(cons ids defined)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes)))))]
|
||||
[(def (id ...) rhs)
|
||||
(and (or (free-identifier=? #'def #'define-values)
|
||||
(free-identifier=? #'def #'define*-values))
|
||||
(andmap identifier? (syntax->list #'(id ...))))
|
||||
(let ([star? (free-identifier=? #'def #'define*-values)]
|
||||
[ids (syntax->list #'(id ...))])
|
||||
(let* ([def-ctx (if star?
|
||||
(syntax-local-make-definition-context)
|
||||
(car def-ctxes))]
|
||||
[ids (if star?
|
||||
(map (add-package-context (list def-ctx)) ids)
|
||||
ids)])
|
||||
(syntax-local-bind-syntaxes ids #f def-ctx)
|
||||
(register-bindings! ids)
|
||||
(loop (cdr exprs)
|
||||
(cons #`(define-values #,ids rhs) rev-forms)
|
||||
(cons ids defined)
|
||||
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
|
||||
[else
|
||||
(loop (cdr exprs)
|
||||
(cons (if (and (eq? mode '#:begin)
|
||||
(null? (cdr exprs)))
|
||||
expr
|
||||
#`(define-values () (begin #,expr (values))))
|
||||
rev-forms)
|
||||
defined
|
||||
def-ctxes)]))]))))))]))
|
||||
|
||||
(define-syntax (define-package stx)
|
||||
(syntax-case stx ()
|
||||
[(_ id #:all-defined form ...)
|
||||
(do-define-package stx #'(define-package id #:all-defined () form ...))]
|
||||
[(_ id #:all-defined-except ids form ...)
|
||||
(do-define-package stx stx)]
|
||||
[(_ id #:only ids form ...)
|
||||
(do-define-package stx stx)]
|
||||
[(_ id ids form ...)
|
||||
(do-define-package stx #'(define-package id #:only ids form ...))]))
|
||||
|
||||
(define-syntax (package-begin stx)
|
||||
(syntax-case stx ()
|
||||
[(_ form ...)
|
||||
(do-define-package stx #'(define-package #f #:begin () form ...))]))
|
||||
|
||||
(define-for-syntax (do-open stx define-syntaxes-id)
|
||||
(syntax-case stx ()
|
||||
[(_ pack-id)
|
||||
(let ([id #'pack-id])
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error #f
|
||||
"expected an identifier for a package"
|
||||
stx
|
||||
id))
|
||||
(let ([v (syntax-local-value id (lambda () #f))])
|
||||
(unless (package? v)
|
||||
(raise-syntax-error #f
|
||||
"identifier is not bound to a package"
|
||||
stx
|
||||
id))
|
||||
(let ([introduce (syntax-local-make-delta-introducer
|
||||
(syntax-local-introduce id))])
|
||||
(with-syntax ([(intro ...)
|
||||
(map (lambda (i)
|
||||
(syntax-local-introduce
|
||||
(syntax-local-get-shadower
|
||||
(introduce i))))
|
||||
(map car ((package-exports v))))]
|
||||
[(defined ...)
|
||||
(map (lambda (v) (syntax-local-introduce (cdr v)))
|
||||
((package-exports v)))]
|
||||
[((a . b) ...) (map (lambda (p)
|
||||
(cons (syntax-local-introduce (car p))
|
||||
(syntax-local-introduce (cdr p))))
|
||||
((package-exports v)))]
|
||||
[(h ...) (map syntax-local-introduce ((package-hidden v)))])
|
||||
#`(begin
|
||||
(#,define-syntaxes-id (intro ...)
|
||||
(let ([rev-map (lambda (x)
|
||||
(reverse-mapping
|
||||
'pack-id
|
||||
x
|
||||
(list (cons (quote-syntax a)
|
||||
(quote-syntax b))
|
||||
...)
|
||||
(list (quote-syntax h) ...)))])
|
||||
(values (make-rename-transformer #'defined rev-map)
|
||||
...))))))))]))
|
||||
|
||||
(define-syntax (open-package stx)
|
||||
(do-open stx #'define-syntaxes))
|
||||
(define-syntax (open*-package stx)
|
||||
(do-open stx #'define*-syntaxes))
|
||||
|
|
@ -54,12 +54,18 @@
|
|||
(make-hash)
|
||||
(if (eq? a 'weak)
|
||||
(make-weak-hasheq)
|
||||
(raise-mismatch-error 'make-hash-table "bad argument: " a)))]
|
||||
[(a b) (if (or (and (eq? a 'equal)
|
||||
(if (eq? a 'eqv)
|
||||
(make-hasheqv)
|
||||
(raise-mismatch-error 'make-hash-table "bad argument: " a))))]
|
||||
[(a b) (if (or (and (or (eq? a 'equal)
|
||||
(eq? a 'eqv))
|
||||
(eq? b 'weak))
|
||||
(and (eq? a 'weak)
|
||||
(eq? b 'equal)))
|
||||
(make-weak-hash)
|
||||
(or (eq? b 'equal)
|
||||
(eq? b 'eqv))))
|
||||
(if (or (eq? a 'eqv) (eq? b 'eqv))
|
||||
(make-weak-hasheqv)
|
||||
(make-weak-hash))
|
||||
(raise-mismatch-error 'make-hash-table "bad arguments: " (list a b)))]))
|
||||
|
||||
(define make-immutable-hash-table
|
||||
|
|
@ -67,23 +73,30 @@
|
|||
[(l) (make-immutable-hasheq l)]
|
||||
[(l a) (if (eq? a 'equal)
|
||||
(make-immutable-hash l)
|
||||
(raise-mismatch-error 'make-immutable-hash-table "bad argument: " a))]))
|
||||
(if (eq? a 'eqv)
|
||||
(make-immutable-hasheqv l)
|
||||
(raise-mismatch-error 'make-immutable-hash-table "bad argument: " a)))]))
|
||||
|
||||
(define hash-table?
|
||||
(case-lambda
|
||||
[(v) (hash? v)]
|
||||
[(v a) (if (eq? a 'equal)
|
||||
(and (hash? v)
|
||||
(not (hash-eq? v)))
|
||||
(not (hash-eq? v))
|
||||
(not (hash-eqv? v)))
|
||||
(if (eq? a 'weak)
|
||||
(and (hash? v)
|
||||
(hash-weak? v))
|
||||
(raise-mismatch-error 'hash-table? "bad argument: " a)))]
|
||||
[(v a b) (if (or (and (eq? a 'equal)
|
||||
(if (eq? a 'eqv)
|
||||
(hash-eqv? v)
|
||||
(raise-mismatch-error 'hash-table? "bad argument: " a))))]
|
||||
[(v a b) (if (or (and (or (eq? a 'equal) (eq? a 'eqv))
|
||||
(eq? b 'weak))
|
||||
(and (eq? a 'weak)
|
||||
(eq? b 'equal)))
|
||||
(or (eq? b 'equal) (eq? b 'eqv))))
|
||||
(and (hash? v)
|
||||
(not (hash-eq? v))
|
||||
(if (or (eq? a 'eqv) (eq? b 'eqv))
|
||||
(hash-eqv? v)
|
||||
(not (or (hash-eq? v) (hash-eqv? v))))
|
||||
(hash-weak? v))
|
||||
(raise-mismatch-error 'hash-table? "bad arguments: " (list a b)))])))
|
||||
|
|
|
|||
|
|
@ -4162,7 +4162,7 @@ so that propagation occurs.
|
|||
(test-name '(real-in 1 10) (real-in 1 10))
|
||||
(test-name '(string-len/c 3) (string/len 3))
|
||||
(test-name 'natural-number/c natural-number/c)
|
||||
(test-name 'false/c false/c)
|
||||
(test-name #f false/c)
|
||||
(test-name 'printable/c printable/c)
|
||||
(test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c))
|
||||
(test-name '(one-of/c 1 2 3) (one-of/c 1 2 3))
|
||||
|
|
|
|||
|
|
@ -112,6 +112,7 @@
|
|||
(list
|
||||
(make-same-test "abc" "abc")
|
||||
(make-same-test 'a ''a)
|
||||
(make-same-test '#:abc ''#:abc)
|
||||
|
||||
(make-same-test 8 8)
|
||||
(make-same-test 1/2 1/2)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user