enabling shared in plai with some shameless copying of kernel code
This commit is contained in:
Jay McCarthy
parent
c02797b121
commit
b778e4e03c
|
|
@ -1,14 +1,17 @@
|
|||
#lang scheme
|
||||
(require (for-syntax scheme/list))
|
||||
#lang racket/base
|
||||
(require (for-syntax racket/base
|
||||
racket/list)
|
||||
racket/list
|
||||
racket/contract)
|
||||
|
||||
(provide define-type type-case)
|
||||
|
||||
(define-for-syntax (plai-syntax-error id stx-loc format-string . args)
|
||||
(raise-syntax-error
|
||||
(raise-syntax-error
|
||||
id (apply format (cons format-string args)) stx-loc))
|
||||
|
||||
(define bug:fallthru-no-else
|
||||
(string-append
|
||||
(string-append
|
||||
"You have encountered a bug in the PLAI code. (Error: type-case "
|
||||
"fallthru on cond without an else clause.)"))
|
||||
(define-for-syntax bound-id
|
||||
|
|
@ -41,146 +44,202 @@
|
|||
(define-for-syntax (assert-unique variant-stx)
|
||||
(let ([dup-id (check-duplicate-identifier (syntax->list variant-stx))])
|
||||
(when dup-id
|
||||
(plai-syntax-error 'define-type dup-id
|
||||
(plai-syntax-error 'define-type dup-id
|
||||
define-type:duplicate-variant))))
|
||||
|
||||
(define-for-syntax type-symbol (gensym))
|
||||
|
||||
(define-for-syntax (validate-and-remove-type-symbol stx-loc lst)
|
||||
(if (and (list? lst) (eq? type-symbol (first lst)))
|
||||
(rest lst)
|
||||
(plai-syntax-error 'type-case stx-loc type-case:not-a-type)))
|
||||
(rest lst)
|
||||
(plai-syntax-error 'type-case stx-loc type-case:not-a-type)))
|
||||
|
||||
(require (for-syntax syntax/parse
|
||||
racket/syntax unstable/syntax
|
||||
(only-in scheme/function curry)))
|
||||
(only-in racket/function curry)))
|
||||
|
||||
(define-for-syntax (syntax-string s)
|
||||
(symbol->string (syntax-e s)))
|
||||
|
||||
;; XXX Copied from racket/private/define-struct
|
||||
(begin-for-syntax
|
||||
(require racket/struct-info)
|
||||
(define (transfer-srcloc orig stx)
|
||||
(datum->syntax orig (syntax-e orig) stx orig))
|
||||
(struct self-ctor-checked-struct-info (info renamer)
|
||||
#:property prop:struct-info
|
||||
(λ (i)
|
||||
((self-ctor-checked-struct-info-info i)))
|
||||
#:property prop:procedure
|
||||
(λ (i stx)
|
||||
(define orig ((self-ctor-checked-struct-info-renamer i)))
|
||||
(syntax-case stx ()
|
||||
[(self arg ...)
|
||||
(datum->syntax
|
||||
stx
|
||||
(cons (syntax-property (transfer-srcloc orig #'self)
|
||||
'constructor-for
|
||||
(syntax-local-introduce
|
||||
#'self))
|
||||
(syntax-e (syntax (arg ...))))
|
||||
stx
|
||||
stx)]
|
||||
[_ (transfer-srcloc orig stx)]))))
|
||||
|
||||
(define the-undefined
|
||||
(letrec ([x x]) x))
|
||||
(define (undefined? x)
|
||||
(eq? the-undefined x))
|
||||
|
||||
(define-syntax (define-type stx)
|
||||
(syntax-parse
|
||||
stx
|
||||
[(_ datatype:id
|
||||
[variant:id (field:id field/c:expr) ...]
|
||||
...)
|
||||
|
||||
; Ensure we have at least one variant.
|
||||
(when (empty? (syntax->list #'(variant ...)))
|
||||
(plai-syntax-error 'define-type stx define-type:zero-variants
|
||||
(syntax-e #'datatype)))
|
||||
|
||||
; Ensure variant names are unique.
|
||||
(assert-unique #'(variant ...))
|
||||
; Ensure each set of fields have unique names.
|
||||
(syntax-map assert-unique #'((field ...) ...))
|
||||
|
||||
; Ensure type and variant names are unbound
|
||||
(map (assert-unbound 'define-type)
|
||||
(cons #'datatype? (syntax->list #'(variant ...))))
|
||||
(with-syntax
|
||||
([(variant* ...)
|
||||
(generate-temporaries #'(variant ...))])
|
||||
|
||||
(with-syntax
|
||||
([((field/c-val ...) ...)
|
||||
(syntax-map generate-temporaries #'((field/c ...) ...))]
|
||||
[datatype?
|
||||
(format-id stx "~a?" #'datatype #:source #'datatype)]
|
||||
[(variant? ...)
|
||||
(syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))]
|
||||
[(variant*? ...)
|
||||
(syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))]
|
||||
[(make-variant ...)
|
||||
(syntax-map (λ (x) (format-id stx "make-~a" x #:source x)) #'(variant ...))]
|
||||
[(make-variant* ...)
|
||||
(syntax-map (λ (x) (format-id x "make-~a" x #:source x)) #'(variant* ...))])
|
||||
|
||||
(with-syntax
|
||||
([((f:variant? ...) ...)
|
||||
(syntax-map (lambda (v? fs)
|
||||
(syntax-map (lambda (f) v?) fs))
|
||||
#'(variant? ...)
|
||||
#'((field ...) ...))]
|
||||
[((variant-field ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f))
|
||||
fields))
|
||||
#'(variant ...)
|
||||
#'((field ...) ...))]
|
||||
[((variant*-field ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id variant "~a-~a" variant f #:source f))
|
||||
fields))
|
||||
#'(variant* ...)
|
||||
#'((field ...) ...))]
|
||||
|
||||
[((set-variant-field! ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id stx "set-~a-~a!" variant f #:source f))
|
||||
fields))
|
||||
#'(variant ...)
|
||||
#'((field ...) ...))]
|
||||
[((set-variant*-field! ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f))
|
||||
fields))
|
||||
#'(variant* ...)
|
||||
#'((field ...) ...))])
|
||||
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-syntax datatype
|
||||
(list type-symbol
|
||||
(list (list #'variant (list #'variant-field ...) #'variant?)
|
||||
...)
|
||||
#'datatype?))
|
||||
(define-struct variant* (field ...)
|
||||
#:transparent
|
||||
#:omit-define-syntaxes
|
||||
#:mutable
|
||||
#:reflection-name 'variant)
|
||||
...
|
||||
(define variant?
|
||||
variant*?)
|
||||
...
|
||||
(define (datatype? x)
|
||||
(or (variant? x) ...))
|
||||
(begin
|
||||
; If this is commented in, then contracts will be checked early.
|
||||
; However, this will disallow mutual recursion, which PLAI relies on.
|
||||
; It could be allowed if we could have module-begin cooperate and lift the define-struct to the top-level
|
||||
; but, that would break web which doesn't use the plai language AND would complicate going to a student-language based deployment
|
||||
#;(define field/c-val field/c)
|
||||
;...
|
||||
(define make-variant
|
||||
(lambda-memocontract (field ...)
|
||||
(contract (field/c ... . -> . variant?)
|
||||
make-variant*
|
||||
'make-variant 'use
|
||||
'make-variant #'variant)))
|
||||
(define variant
|
||||
(lambda-memocontract (field ...)
|
||||
(contract (field/c ... . -> . variant?)
|
||||
make-variant*
|
||||
'variant 'use
|
||||
'variant #'variant)))
|
||||
(define variant-field
|
||||
(lambda-memocontract (v)
|
||||
(contract (f:variant? . -> . field/c)
|
||||
variant*-field
|
||||
'variant-field 'use
|
||||
'variant-field #'field)))
|
||||
...
|
||||
(define set-variant-field!
|
||||
(lambda-memocontract (v nv)
|
||||
(contract (f:variant? field/c . -> . void)
|
||||
set-variant*-field!
|
||||
'set-variant-field! 'use
|
||||
'set-variant-field! #'field)))
|
||||
...
|
||||
)
|
||||
...)))))]))
|
||||
stx
|
||||
[(_ datatype:id
|
||||
[variant:id (field:id field/c:expr) ...]
|
||||
...)
|
||||
|
||||
;; Ensure we have at least one variant.
|
||||
(when (empty? (syntax->list #'(variant ...)))
|
||||
(plai-syntax-error 'define-type stx define-type:zero-variants
|
||||
(syntax-e #'datatype)))
|
||||
|
||||
;; Ensure variant names are unique.
|
||||
(assert-unique #'(variant ...))
|
||||
;; Ensure each set of fields have unique names.
|
||||
(syntax-map assert-unique #'((field ...) ...))
|
||||
|
||||
;; Ensure type and variant names are unbound
|
||||
(map (assert-unbound 'define-type)
|
||||
(cons #'datatype? (syntax->list #'(variant ...))))
|
||||
(with-syntax
|
||||
([(variant* ...)
|
||||
(generate-temporaries #'(variant ...))]
|
||||
[(underlying-variant ...)
|
||||
(generate-temporaries #'(variant ...))])
|
||||
|
||||
(with-syntax
|
||||
([((field/c-val ...) ...)
|
||||
(syntax-map generate-temporaries #'((field/c ...) ...))]
|
||||
[((the-field/c ...) ...)
|
||||
(syntax-map generate-temporaries #'((field/c ...) ...))]
|
||||
[datatype?
|
||||
(format-id stx "~a?" #'datatype #:source #'datatype)]
|
||||
[(variant? ...)
|
||||
(syntax-map (λ (x) (format-id stx "~a?" x #:source x)) #'(variant ...))]
|
||||
[(variant*? ...)
|
||||
(syntax-map (λ (x) (format-id x "~a?" x #:source x)) #'(variant* ...))]
|
||||
[(make-variant ...)
|
||||
(syntax-map (λ (x) (format-id stx "make-~a" x #:source x)) #'(variant ...))]
|
||||
[(make-variant* ...)
|
||||
(syntax-map (λ (x) (format-id x "make-~a" x #:source x)) #'(variant* ...))])
|
||||
|
||||
(with-syntax
|
||||
([((f:variant? ...) ...)
|
||||
(syntax-map (lambda (v? fs)
|
||||
(syntax-map (lambda (f) v?) fs))
|
||||
#'(variant? ...)
|
||||
#'((field ...) ...))]
|
||||
[((variant-field ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id stx "~a-~a" variant f #:source f))
|
||||
fields))
|
||||
#'(variant ...)
|
||||
#'((field ...) ...))]
|
||||
[((variant*-field ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id variant "~a-~a" variant f #:source f))
|
||||
fields))
|
||||
#'(variant* ...)
|
||||
#'((field ...) ...))]
|
||||
|
||||
[((set-variant-field! ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id stx "set-~a-~a!" variant f #:source f))
|
||||
fields))
|
||||
#'(variant ...)
|
||||
#'((field ...) ...))]
|
||||
[((set-variant*-field! ...) ...)
|
||||
(syntax-map (lambda (variant fields)
|
||||
(syntax-map (λ (f) (format-id variant "set-~a-~a!" variant f #:source f))
|
||||
fields))
|
||||
#'(variant* ...)
|
||||
#'((field ...) ...))])
|
||||
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-syntax datatype
|
||||
(list type-symbol
|
||||
(list (list #'variant (list #'variant-field ...) #'variant?)
|
||||
...)
|
||||
#'datatype?))
|
||||
(define-struct variant* (field ...)
|
||||
#:transparent
|
||||
#:omit-define-syntaxes
|
||||
#:mutable
|
||||
#:reflection-name 'variant)
|
||||
...
|
||||
(define variant?
|
||||
variant*?)
|
||||
...
|
||||
(define (datatype? x)
|
||||
(or (variant? x) ...))
|
||||
(begin
|
||||
;; If this is commented in, then contracts will be
|
||||
;; checked early. However, this will disallow mutual
|
||||
;; recursion, which PLAI relies on. It could be
|
||||
;; allowed if we could have module-begin cooperate
|
||||
;; and lift the define-struct to the top-level but,
|
||||
;; that would break web which doesn't use the plai
|
||||
;; language AND would complicate going to a
|
||||
;; student-language based deployment
|
||||
|
||||
;; (define field/c-val field/c)
|
||||
;; ...
|
||||
|
||||
(define (the-field/c)
|
||||
(or/c undefined?
|
||||
field/c))
|
||||
...
|
||||
|
||||
(define make-variant
|
||||
(lambda-memocontract (field ...)
|
||||
(contract ((the-field/c) ... . -> . variant?)
|
||||
make-variant*
|
||||
'make-variant 'use
|
||||
'make-variant #'variant)))
|
||||
(define underlying-variant
|
||||
(lambda-memocontract (field ...)
|
||||
(contract ((the-field/c) ... . -> . variant?)
|
||||
make-variant*
|
||||
'variant 'use
|
||||
'variant #'variant)))
|
||||
(define-syntax
|
||||
variant
|
||||
(self-ctor-checked-struct-info
|
||||
(λ ()
|
||||
(list #'struct:variant*
|
||||
#'make-variant*
|
||||
#'variant*?
|
||||
(reverse (list #'variant*-field ...))
|
||||
(reverse (list #'set-variant*-field! ...))
|
||||
#t))
|
||||
(λ () #'underlying-variant)))
|
||||
(define variant-field
|
||||
(lambda-memocontract (v)
|
||||
(contract (f:variant? . -> . (the-field/c))
|
||||
variant*-field
|
||||
'variant-field 'use
|
||||
'variant-field #'field)))
|
||||
...
|
||||
(define set-variant-field!
|
||||
(lambda-memocontract (v nv)
|
||||
(contract (f:variant? (the-field/c) . -> . void)
|
||||
set-variant*-field!
|
||||
'set-variant-field! 'use
|
||||
'set-variant-field! #'field)))
|
||||
...
|
||||
)
|
||||
...)))))]))
|
||||
|
||||
(define-syntax-rule (lambda-memocontract (field ...) c-expr)
|
||||
(let ([cd #f])
|
||||
|
|
@ -189,10 +248,10 @@
|
|||
(set! cd c-expr))
|
||||
(cd field ...))))
|
||||
|
||||
;;; Asserts that variant-id-stx is a variant of the type described by
|
||||
;;; Asserts that variant-id-stx is a variant of the type described by
|
||||
;;; type-stx.
|
||||
(define-for-syntax ((assert-variant type-info) variant-id-stx)
|
||||
(unless (ormap (λ (stx) (free-identifier=? variant-id-stx stx))
|
||||
(unless (ormap (λ (stx) (free-identifier=? variant-id-stx stx))
|
||||
(map first type-info))
|
||||
(plai-syntax-error 'type-case variant-id-stx type-case:not-a-variant)))
|
||||
|
||||
|
|
@ -204,13 +263,13 @@
|
|||
(length (second type))))
|
||||
type-info)])
|
||||
(unless (= field-count (length (syntax->list field-stx)))
|
||||
(plai-syntax-error 'type-case variant-id-stx type-case:argument-count
|
||||
(plai-syntax-error 'type-case variant-id-stx type-case:argument-count
|
||||
field-count (length (syntax->list field-stx))))))
|
||||
|
||||
(define-for-syntax ((ensure-variant-present stx-loc variants) variant)
|
||||
(unless (ormap (λ (id-stx) (free-identifier=? variant id-stx))
|
||||
(syntax->list variants))
|
||||
(plai-syntax-error 'type-case stx-loc type-case:missing-variant
|
||||
(plai-syntax-error 'type-case stx-loc type-case:missing-variant
|
||||
(syntax->datum variant))))
|
||||
|
||||
(define-for-syntax ((variant-missing? stx-loc variants) variant)
|
||||
|
|
@ -234,14 +293,14 @@
|
|||
[(not (identifier? #'variant))
|
||||
(plai-syntax-error 'type-case #'variant
|
||||
"this must be the name of a variant")]
|
||||
[(ormap (λ (stx)
|
||||
[(ormap (λ (stx)
|
||||
(and (not (identifier? stx)) stx)) (syntax->list #'(field ...)))
|
||||
=> (λ (malformed-field)
|
||||
(plai-syntax-error
|
||||
'type-case malformed-field
|
||||
"this must be an identifier that names the value of a field"))]
|
||||
[(not (= (length (syntax->list #'(body ...))) 1))
|
||||
(plai-syntax-error
|
||||
(plai-syntax-error
|
||||
'type-case clause-stx
|
||||
(string-append
|
||||
"there must be just one body expression in a clause, but you "
|
||||
|
|
@ -252,7 +311,7 @@
|
|||
(plai-syntax-error
|
||||
'type-case clause-stx
|
||||
"this case is missing a body expression")]
|
||||
[_
|
||||
[_
|
||||
(plai-syntax-error
|
||||
'type-case clause-stx
|
||||
"this case is missing a field list (possibly an empty field list)")]))
|
||||
|
|
@ -261,15 +320,15 @@
|
|||
(syntax-case stx ()
|
||||
[(_ (binding-name ...) case-variant-id ((variant-id (selector-id ...) ___) . rest) value-id body-expr)
|
||||
(if (free-identifier=? #'case-variant-id #'variant-id)
|
||||
#'(let ([binding-name (selector-id value-id)]
|
||||
...)
|
||||
body-expr)
|
||||
#'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))]))
|
||||
#'(let ([binding-name (selector-id value-id)]
|
||||
...)
|
||||
body-expr)
|
||||
#'(bind-fields-in (binding-name ...) case-variant-id rest value-id body-expr))]))
|
||||
|
||||
(define-syntax (type-case stx)
|
||||
(syntax-case stx (else)
|
||||
[(_ type-id test-expr [variant (field ...) case-expr] ... [else else-expr])
|
||||
; Ensure that everything that should be an identifier is an identifier.
|
||||
;; Ensure that everything that should be an identifier is an identifier.
|
||||
(and (identifier? #'type-id)
|
||||
(andmap identifier? (syntax->list #'(variant ...)))
|
||||
(andmap (λ (stx) (andmap identifier? (syntax->list stx)))
|
||||
|
|
@ -278,76 +337,76 @@
|
|||
#'type-id (syntax-local-value #'type-id (λ () #f)))]
|
||||
[type-info (first info)]
|
||||
[type? (second info)])
|
||||
|
||||
; Ensure all names are unique
|
||||
|
||||
;; Ensure all names are unique
|
||||
(assert-unique #'(variant ...))
|
||||
(map assert-unique (syntax->list #'((field ...) ...)))
|
||||
|
||||
; Ensure variants are valid.
|
||||
|
||||
;; Ensure variants are valid.
|
||||
(map (assert-variant type-info) (syntax->list #'(variant ...)))
|
||||
|
||||
; Ensure field counts match.
|
||||
(map (assert-field-count type-info)
|
||||
|
||||
;; Ensure field counts match.
|
||||
(map (assert-field-count type-info)
|
||||
(syntax->list #'(variant ...))
|
||||
(syntax->list #'((field ...) ...)))
|
||||
|
||||
; Ensure some variant is missing.
|
||||
(unless (ormap (variant-missing? stx #'(variant ...))
|
||||
|
||||
;; Ensure some variant is missing.
|
||||
(unless (ormap (variant-missing? stx #'(variant ...))
|
||||
(map first type-info))
|
||||
(plai-syntax-error 'type-case stx type-case:unreachable-else))
|
||||
|
||||
|
||||
|
||||
|
||||
#`(let ([expr test-expr])
|
||||
(if (not (#,type? expr))
|
||||
#,(syntax/loc #'test-expr
|
||||
(error 'type-case "expected a value from type ~a, got: ~a"
|
||||
'type-id
|
||||
expr))
|
||||
(cond
|
||||
[(let ([variant-info (lookup-variant variant #,type-info)])
|
||||
((second variant-info) expr))
|
||||
(bind-fields-in (field ...) variant #,type-info expr case-expr)]
|
||||
...
|
||||
[else else-expr]))))]
|
||||
#,(syntax/loc #'test-expr
|
||||
(error 'type-case "expected a value from type ~a, got: ~a"
|
||||
'type-id
|
||||
expr))
|
||||
(cond
|
||||
[(let ([variant-info (lookup-variant variant #,type-info)])
|
||||
((second variant-info) expr))
|
||||
(bind-fields-in (field ...) variant #,type-info expr case-expr)]
|
||||
...
|
||||
[else else-expr]))))]
|
||||
[(_ type-id test-expr [variant (field ...) case-expr] ...)
|
||||
; Ensure that everything that should be an identifier is an identifier.
|
||||
;; Ensure that everything that should be an identifier is an identifier.
|
||||
(and (identifier? #'type-id)
|
||||
(andmap identifier? (syntax->list #'(variant ...)))
|
||||
(andmap (λ (stx) (andmap identifier? (syntax->list stx)))
|
||||
(syntax->list #'((field ...) ...))))
|
||||
(let* ([info (validate-and-remove-type-symbol
|
||||
(let* ([info (validate-and-remove-type-symbol
|
||||
#'type-id (syntax-local-value #'type-id (λ () #f)))]
|
||||
[type-info (first info)]
|
||||
[type? (second info)])
|
||||
|
||||
; Ensure all names are unique
|
||||
|
||||
;; Ensure all names are unique
|
||||
(assert-unique #'(variant ...))
|
||||
(map assert-unique (syntax->list #'((field ...) ...)))
|
||||
|
||||
; Ensure variants are valid.
|
||||
|
||||
;; Ensure variants are valid.
|
||||
(map (assert-variant type-info) (syntax->list #'(variant ...)))
|
||||
|
||||
; Ensure field counts match.
|
||||
(map (assert-field-count type-info)
|
||||
|
||||
;; Ensure field counts match.
|
||||
(map (assert-field-count type-info)
|
||||
(syntax->list #'(variant ...))
|
||||
(syntax->list #'((field ...) ...)))
|
||||
|
||||
; Ensure all variants are covered
|
||||
|
||||
;; Ensure all variants are covered
|
||||
(map (ensure-variant-present stx #'(variant ...))
|
||||
(map first type-info))
|
||||
|
||||
|
||||
#`(let ([expr test-expr])
|
||||
(if (not (#,type? expr))
|
||||
#,(syntax/loc #'test-expr
|
||||
(error 'type-case "expected a value from type ~a, got: ~a"
|
||||
'type-id
|
||||
expr))
|
||||
(cond
|
||||
[(let ([variant-info (lookup-variant variant #,type-info)])
|
||||
((second variant-info) expr))
|
||||
(bind-fields-in (field ...) variant #,type-info expr case-expr)]
|
||||
...
|
||||
[else (error 'type-case bug:fallthru-no-else)]))))]
|
||||
#,(syntax/loc #'test-expr
|
||||
(error 'type-case "expected a value from type ~a, got: ~a"
|
||||
'type-id
|
||||
expr))
|
||||
(cond
|
||||
[(let ([variant-info (lookup-variant variant #,type-info)])
|
||||
((second variant-info) expr))
|
||||
(bind-fields-in (field ...) variant #,type-info expr case-expr)]
|
||||
...
|
||||
[else (error 'type-case bug:fallthru-no-else)]))))]
|
||||
;;; The remaining clauses are for error reporting only. If we got this
|
||||
;;; far, either the clauses are malformed or the error is completely
|
||||
;;; unintelligible.
|
||||
|
|
@ -359,6 +418,3 @@
|
|||
(andmap validate-clause (syntax->list #'(clauses ...)))
|
||||
(plai-syntax-error 'type-case stx "Unknown error"))]
|
||||
[_ (plai-syntax-error 'type-case stx type-case:generic)]))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -11,6 +11,6 @@
|
|||
(let ([exports (syntax-local-module-exports (syntax->datum #'module-name))])
|
||||
#`(quote #,(cdaddr exports)))]))
|
||||
|
||||
(test (exports-of 'ex)
|
||||
(test (sort (exports-of 'ex) string-ci<? #:key symbol->string)
|
||||
=>
|
||||
'(Type set-Variant-field! make-Variant Variant? Variant-field Variant Type?))
|
||||
'(make-Variant set-Variant-field! Type Type? Variant Variant-field Variant?))
|
||||
|
|
|
|||
24
collects/tests/plai/shared.rkt
Normal file
24
collects/tests/plai/shared.rkt
Normal file
|
|
@ -0,0 +1,24 @@
|
|||
#lang plai
|
||||
|
||||
(define-type Node
|
||||
(node (data string?) (adj list?)))
|
||||
|
||||
(define g
|
||||
(shared ([PVD (node "Providence" (list ORH BOS))]
|
||||
[ORH (node "Worcester" (list PVD BOS))]
|
||||
[BOS (node "Boston" (list PVD ORH))])
|
||||
(list PVD ORH BOS)))
|
||||
|
||||
g
|
||||
|
||||
(define PVD (first g))
|
||||
(define ORH (second g))
|
||||
(define BOS (third g))
|
||||
|
||||
PVD
|
||||
ORH
|
||||
BOS
|
||||
|
||||
(test (node-adj PVD) (list ORH BOS))
|
||||
(test (node-adj ORH) (list PVD BOS))
|
||||
(test (node-adj BOS) (list PVD ORH))
|
||||
Loading…
Reference in New Issue
Block a user