138 lines
5.1 KiB
Scheme
138 lines
5.1 KiB
Scheme
#lang scheme/base
|
|
|
|
(require "sc.ss"
|
|
"../util.ss"
|
|
syntax/stx
|
|
syntax/kerncase
|
|
scheme/struct-info
|
|
scheme/private/contract-helpers
|
|
(for-syntax scheme/base
|
|
"rep.ss")
|
|
(for-template scheme/base
|
|
scheme/contract))
|
|
(provide (all-defined-out))
|
|
|
|
(define-syntax-rule (define-pred-stxclass name pred)
|
|
(define-syntax-class name #:attributes ([datum 0])
|
|
(pattern x
|
|
#:with datum (if (syntax? #'x) (syntax-e #'x) #'x)
|
|
#:when (pred (attribute datum)))))
|
|
|
|
(define-pred-stxclass identifier symbol?)
|
|
(define-pred-stxclass boolean boolean?)
|
|
(define-pred-stxclass str string?)
|
|
(define-pred-stxclass character char?)
|
|
(define-pred-stxclass keyword keyword?)
|
|
|
|
(define-pred-stxclass number number?)
|
|
(define-pred-stxclass integer integer?)
|
|
(define-pred-stxclass exact-integer exact-integer?)
|
|
(define-pred-stxclass exact-nonnegative-integer exact-nonnegative-integer?)
|
|
(define-pred-stxclass exact-positive-integer exact-positive-integer?)
|
|
|
|
(define-syntax-class (static-of name pred)
|
|
#:attributes (value)
|
|
(pattern x:id
|
|
#:with value-list (syntax-local-value* #'x)
|
|
#:when (pair? (attribute value-list))
|
|
#:with value (car (attribute value-list))
|
|
#:when (pred (attribute value))))
|
|
|
|
(define (syntax-local-value* id)
|
|
(let/ec escape
|
|
(list (syntax-local-value id (lambda () (escape null))))))
|
|
|
|
(define-syntax-class static #:attributes (value)
|
|
(pattern x
|
|
#:declare x (static-of "static" (lambda _ #t))
|
|
#:with value #'x.value))
|
|
|
|
(define-syntax-class struct-name
|
|
#:description "struct name"
|
|
#:attributes (descriptor
|
|
constructor
|
|
predicate
|
|
[accessor 1]
|
|
super
|
|
complete?)
|
|
(pattern s
|
|
#:declare s (static-of "struct name" struct-info?)
|
|
#:with info (extract-struct-info (attribute s.value))
|
|
#:with descriptor (list-ref (attribute info) 0)
|
|
#:with constructor (list-ref (attribute info) 1)
|
|
#:with predicate (list-ref (attribute info) 2)
|
|
#:with r-accessors (reverse (list-ref (attribute info) 3))
|
|
#:with (accessor ...)
|
|
(datum->syntax #f (let ([r-accessors (attribute r-accessors)])
|
|
(if (and (pair? r-accessors) (eq? #f (car r-accessors)))
|
|
(cdr r-accessors)
|
|
r-accessors)))
|
|
#:with super (list-ref (attribute info) 5)
|
|
#:with complete? (or (null? (attribute r-accessors))
|
|
(and (pair? (attribute r-accessors))
|
|
(not (eq? #f (car (attribute r-accessors))))))))
|
|
|
|
(define-syntax-class expr/local-expand
|
|
#:attributes (expanded)
|
|
(pattern x
|
|
#:with expanded (local-expand #'x 'expression null)))
|
|
|
|
(define-syntax-class expr/head-local-expand
|
|
#:attributes (expanded)
|
|
(pattern x
|
|
#:with expanded (local-expand #'x 'expression (kernel-form-identifier-list))))
|
|
|
|
(define-syntax-class block/head-local-expand
|
|
#:attributes (expanded-block
|
|
[expanded 1]
|
|
[def 1]
|
|
[vdef 1]
|
|
[sdef 1]
|
|
[expr 1])
|
|
(pattern x
|
|
#:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...))
|
|
(datum->syntax #f
|
|
(let-values ([(ex1 ex2 defs vdefs sdefs exprs)
|
|
(head-local-expand-and-categorize-syntaxes
|
|
#'x #f #| #t |#)])
|
|
(list ex1 ex2 defs vdefs sdefs exprs)))))
|
|
|
|
(define-syntax-class internal-definitions
|
|
#:attributes (expanded-block
|
|
[expanded 1]
|
|
[def 1]
|
|
[vdef 1]
|
|
[sdef 1]
|
|
[expr 1])
|
|
(pattern x
|
|
#:with (expanded-block (expanded ...) (def ...) (vdef ...) (sdef ...) (expr ...))
|
|
(datum->syntax #f
|
|
(let-values ([(ex1 ex2 defs vdefs sdefs exprs)
|
|
(head-local-expand-and-categorize-syntaxes
|
|
#'x #t #| #f |#)])
|
|
(list ex1 ex2 defs vdefs sdefs exprs)))))
|
|
|
|
(define-syntax-class expr
|
|
#:attributes ()
|
|
(pattern x
|
|
#:when (and (syntax? #'x) (not (keyword? (syntax-e #'x))))))
|
|
|
|
|
|
;; FIXME: hack
|
|
(define expr/c-use-contracts? (make-parameter #t))
|
|
|
|
(define-syntax-class (expr/c ctc)
|
|
#:attributes (c)
|
|
(pattern x:expr
|
|
#:with c #`(contract #,ctc
|
|
x
|
|
(quote #,(string->symbol (or (build-src-loc-string #'x) "")))
|
|
(quote #,(or (current-macro-name) '<this-macro>))
|
|
(quote-syntax #,(syntax/loc #'x (<there>))))))
|
|
|
|
;; Aliases
|
|
|
|
(define-syntax id (make-rename-transformer #'identifier))
|
|
(define-syntax nat (make-rename-transformer #'exact-nonnegative-integer))
|
|
(define-syntax char (make-rename-transformer #'character))
|