44 lines
1.3 KiB
Scheme
44 lines
1.3 KiB
Scheme
#lang scheme/base
|
|
(require syntax/stx
|
|
(for-template scheme/base
|
|
syntax/stx
|
|
scheme/stxparam
|
|
"runtime.ss"))
|
|
(provide (all-defined-out))
|
|
|
|
(define (get-kind kind)
|
|
(syntax-case kind ()
|
|
[#:pair pairK]
|
|
[#:vector vectorK]
|
|
[#:box boxK]
|
|
[(#:pstruct key)
|
|
(make-kind #`(lambda (x)
|
|
(let ([xkey (prefab-struct-key x)])
|
|
(and xkey (equal? xkey (quote key)))))
|
|
(list (lambda (s d)
|
|
#`(datum->syntax #,s (cdr (vector->list (struct->vector #,d))) #,s)))
|
|
(list #'dfc-add-unpstruct))]))
|
|
|
|
;; A Kind is
|
|
;; (make-kind id (listof (id id -> stx)) (listof expr))
|
|
|
|
(define-struct kind (predicate selectors frontier-procs) #:transparent)
|
|
|
|
(define pairK
|
|
(make-kind #'pair?
|
|
(list (lambda (s d) #`(car #,d))
|
|
(lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s)))
|
|
(list #'dfc-add-car
|
|
#'dfc-add-cdr)))
|
|
|
|
(define vectorK
|
|
(make-kind #'vector?
|
|
(list (lambda (s d)
|
|
#`(datum->syntax #,s (vector->list #,d) #,s)))
|
|
(list #'dfc-add-unvector)))
|
|
|
|
(define boxK
|
|
(make-kind #'box?
|
|
(list (lambda (s d) #`(unbox #,d)))
|
|
(list #'dfc-add-unbox)))
|