301 lines
10 KiB
Scheme
301 lines
10 KiB
Scheme
|
|
#lang scheme/base
|
|
(require (for-syntax scheme/base
|
|
scheme/struct-info)
|
|
syntax/boundmap
|
|
syntax/kerncase
|
|
syntax/stx)
|
|
|
|
(provide make
|
|
|
|
with-temporaries
|
|
generate-temporary
|
|
generate-n-temporaries
|
|
|
|
chunk-kw-seq/no-dups
|
|
chunk-kw-seq
|
|
reject-duplicate-chunks
|
|
check-id
|
|
check-nat/f
|
|
check-string
|
|
check-idlist
|
|
|
|
head-local-expand-and-categorize-syntaxes
|
|
categorize-expanded-syntaxes
|
|
head-local-expand-syntaxes)
|
|
|
|
(define-syntax (make stx)
|
|
(syntax-case stx ()
|
|
[(make S expr ...)
|
|
(unless (identifier? #'S)
|
|
(raise-syntax-error #f "not an identifier" stx #'S))
|
|
(let ()
|
|
(define (no-info) (raise-syntax-error #f "not a struct" stx #'S))
|
|
(define info
|
|
(extract-struct-info
|
|
(syntax-local-value #'S no-info)))
|
|
(define constructor (list-ref info 1))
|
|
(define accessors (list-ref info 3))
|
|
(unless (identifier? #'constructor)
|
|
(raise-syntax-error #f "constructor not available for struct" stx #'S))
|
|
(unless (andmap identifier? accessors)
|
|
(raise-syntax-error #f "incomplete info for struct type" stx #'S))
|
|
(let ([num-slots (length accessors)]
|
|
[num-provided (length (syntax->list #'(expr ...)))])
|
|
(unless (= num-provided num-slots)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "wrong number of arguments for struct ~s (expected ~s)"
|
|
(syntax-e #'S)
|
|
num-slots)
|
|
stx)))
|
|
(with-syntax ([constructor constructor])
|
|
#'(constructor expr ...)))]))
|
|
|
|
(define-syntax-rule (with-temporaries (temp-name ...) . body)
|
|
(with-syntax ([(temp-name ...) (generate-temporaries (quote-syntax (temp-name ...)))])
|
|
. body))
|
|
|
|
(define (generate-temporary [stx 'g])
|
|
(car (generate-temporaries (list stx))))
|
|
|
|
(define (generate-n-temporaries n)
|
|
(generate-temporaries
|
|
(for/list ([i (in-range n)])
|
|
(string->symbol (format "g~sx" i)))))
|
|
|
|
(define (chunk-kw-seq/no-dups stx kws #:context [ctx #f])
|
|
(let-values ([(chunks rest) (chunk-kw-seq stx kws #:context ctx)])
|
|
(reject-duplicate-chunks chunks)
|
|
(values chunks rest)))
|
|
|
|
;; chunk-kw-seq : stx
|
|
;; alist[keyword => (listof (stx -> any))
|
|
;; -> (listof (cons kw (cons stx(kw) (listof any)))) stx
|
|
(define (chunk-kw-seq stx kws #:context [ctx #f])
|
|
(define (loop stx rchunks)
|
|
(syntax-case stx ()
|
|
[(kw . more)
|
|
(and (keyword? (syntax-e #'kw)) (assq (syntax-e #'kw) kws))
|
|
(let* ([kw-value (syntax-e #'kw)]
|
|
[arity (cdr (assq kw-value kws))]
|
|
[args+rest (stx-split #'more arity)])
|
|
(if args+rest
|
|
(loop (cdr args+rest)
|
|
(cons (list* kw-value #'kw (car args+rest)) rchunks))
|
|
(raise-syntax-error #f "too few arguments for keyword" #'kw ctx)))]
|
|
[(kw . more)
|
|
(keyword? (syntax-e #'kw))
|
|
(raise-syntax-error #f "unexpected keyword" #'kw ctx)]
|
|
[_
|
|
(values (reverse rchunks) stx)]))
|
|
(loop stx null))
|
|
|
|
(define (reject-duplicate-chunks chunks #:context [ctx #f])
|
|
(define kws (make-hasheq))
|
|
(define (loop chunks)
|
|
(when (pair? chunks)
|
|
(let ([kw (caar chunks)])
|
|
(when (hash-ref kws kw #f)
|
|
(raise-syntax-error #f "duplicate keyword argument" (cadar chunks) ctx))
|
|
(hash-set! kws kw #t))
|
|
(loop (cdr chunks))))
|
|
(loop chunks))
|
|
|
|
;; stx-split : stx nat -> (cons (listof stx) stx)
|
|
(define (stx-split stx procs)
|
|
(define (loop stx procs acc)
|
|
(cond [(null? procs)
|
|
(cons (reverse acc) stx)]
|
|
[(stx-pair? stx)
|
|
(loop (stx-cdr stx) (cdr procs) (cons ((car procs) (stx-car stx)) acc))]
|
|
[else #f]))
|
|
(loop stx procs null))
|
|
|
|
;; check-id : stx -> identifier
|
|
(define (check-id stx)
|
|
(unless (identifier? stx)
|
|
(raise-syntax-error 'pattern "expected identifier" stx))
|
|
stx)
|
|
|
|
(define (check-string stx)
|
|
(unless (string? (syntax-e stx))
|
|
(raise-syntax-error #f "expected string" stx))
|
|
stx)
|
|
|
|
;; nat/f : any -> boolean
|
|
(define (nat/f x)
|
|
(or (not x) (exact-nonnegative-integer? x)))
|
|
|
|
(define (check-nat/f stx)
|
|
(let ([d (syntax-e stx)])
|
|
(unless (nat/f d)
|
|
(raise-syntax-error #f "expected exact nonnegative integer or #f" stx))
|
|
stx))
|
|
|
|
(define (check-idlist stx)
|
|
(unless (and (stx-list? stx) (andmap identifier? (stx->list stx)))
|
|
(raise-syntax-error #f "expected list of identifiers" stx))
|
|
(stx->list stx))
|
|
|
|
|
|
;; head-local-expand-syntaxes : syntax boolean boolean -> stxs ^ 6
|
|
;; Setting allow-def-after-expr? allows def/expr interleaving.
|
|
(define (head-local-expand-and-categorize-syntaxes x allow-def-after-expr?)
|
|
(define estxs (head-local-expand-syntaxes x allow-def-after-expr?))
|
|
(define-values (defs vdefs sdefs exprs)
|
|
(categorize-expanded-syntaxes estxs))
|
|
(values estxs estxs defs vdefs sdefs exprs))
|
|
|
|
(define (categorize-expanded-syntaxes estxs0)
|
|
(let loop ([estxs estxs0] [defs null] [vdefs null] [sdefs null] [exprs null])
|
|
(cond [(pair? estxs)
|
|
(let ([ee (car estxs)])
|
|
(syntax-case ee (begin define-values define-syntaxes)
|
|
[(define-values . _)
|
|
(loop (cdr estxs)
|
|
(cons ee defs)
|
|
(cons ee vdefs)
|
|
sdefs
|
|
exprs)]
|
|
[(define-syntaxes (var ...) rhs)
|
|
(loop (cdr estxs)
|
|
(cons ee defs)
|
|
vdefs
|
|
(cons ee sdefs)
|
|
exprs)]
|
|
[_
|
|
(loop (cdr estxs)
|
|
defs
|
|
vdefs
|
|
sdefs
|
|
(cons ee exprs))]))]
|
|
[(null? estxs)
|
|
(values (reverse defs)
|
|
(reverse vdefs)
|
|
(reverse sdefs)
|
|
(reverse exprs))])))
|
|
|
|
;; head-local-expand-syntaxes : syntax boolean -> (listof syntax)
|
|
(define (head-local-expand-syntaxes x allow-def-after-expr?)
|
|
(let ([intdef (syntax-local-make-definition-context)]
|
|
[ctx '(block)])
|
|
(let loop ([x x] [ex null] [expr? #f])
|
|
(cond [(stx-pair? x)
|
|
(let ([ee (local-expand (stx-car x)
|
|
ctx
|
|
(kernel-form-identifier-list)
|
|
intdef)])
|
|
(syntax-case ee (begin define-values define-syntaxes)
|
|
[(begin e ...)
|
|
(loop (append (syntax->list #'(e ...)) (stx-cdr x)) ex expr?)]
|
|
[(begin . _)
|
|
(raise-syntax-error #f "bad begin form" ee)]
|
|
[(define-values (var ...) rhs)
|
|
(andmap identifier? (syntax->list #'(var ...)))
|
|
(begin
|
|
(when (and expr? (not allow-def-after-expr?))
|
|
(raise-syntax-error #f "definition after expression" ee))
|
|
(syntax-local-bind-syntaxes (syntax->list #'(var ...)) #f intdef)
|
|
(loop (stx-cdr x) (cons ee ex) expr?))]
|
|
[(define-values . _)
|
|
(raise-syntax-error #f "bad define-values form" ee)]
|
|
[(define-syntaxes (var ...) rhs)
|
|
(andmap identifier? (syntax->list #'(var ...)))
|
|
(begin
|
|
(when (and expr? (not allow-def-after-expr?))
|
|
(raise-syntax-error #f "definition after expression" ee))
|
|
(syntax-local-bind-syntaxes (syntax->list #'(var ...))
|
|
#'rhs
|
|
intdef)
|
|
(loop (stx-cdr x) (cons ee ex) expr?))]
|
|
[(define-syntaxes . _)
|
|
(raise-syntax-error #f "bad define-syntaxes form" ee)]
|
|
[_
|
|
(loop (stx-cdr x) (cons ee ex) #t)]))]
|
|
[(stx-null? x)
|
|
(reverse ex)]))))
|
|
|
|
|
|
#|
|
|
;; Mappings
|
|
|
|
(define dummy (box #f))
|
|
(define fdummy (lambda () dummy))
|
|
(define (false/p) #f)
|
|
|
|
;; --
|
|
|
|
(define-struct monomap (table getter putter mapper foreacher injfail))
|
|
|
|
(define (monomap-get im key [fail false/p])
|
|
((monomap-getter im) (monomap-table im) key fail))
|
|
|
|
(define (monomap-put! im key val)
|
|
(let ([val ((monomap-getter im) (monomap-table im) key fdummy)])
|
|
(unless (eq? val dummy)
|
|
((monomap-injfail im) key val))
|
|
((monomap-putter im) (monomap-table im) key val)))
|
|
|
|
(define (monomap-map im p)
|
|
((monomap-mapper im) (monomap-table im) p))
|
|
|
|
(define (monomap-for-each im p)
|
|
((monomap-foreacher im) (monomap-table im) p)
|
|
(void))
|
|
|
|
(define (monomap-domain im)
|
|
(monomap-map (lambda (k v) k)))
|
|
|
|
(define (monomap-range im)
|
|
(monomap-map (lambda (k v) v)))
|
|
|
|
(define (make-bound-id-monomap fail)
|
|
(make-monomap (make-bound-identifier-mapping)
|
|
bound-identifier-mapping-get
|
|
bound-identifier-mapping-put!
|
|
bound-identifier-mapping-map
|
|
bound-identifier-mapping-for-each
|
|
fail))
|
|
|
|
(define (make-free-id-monomap fail)
|
|
(make-monomap (make-module-identifier-mapping)
|
|
module-identifier-mapping-get
|
|
module-identifier-mapping-put!
|
|
module-identifier-mapping-map
|
|
module-identifier-mapping-for-each
|
|
fail))
|
|
|
|
(define (make-hash-monomap fail)
|
|
(make-monomap (make-hash-table)
|
|
hash-table-get
|
|
hash-table-put!
|
|
hash-table-map
|
|
hash-table-for-each
|
|
fail))
|
|
|
|
(define-struct isomap (forward backward))
|
|
|
|
(define (isomap-get im k [fail false/p])
|
|
(monomap-get (isomap-forward im) k fail))
|
|
(define (isomap-put! im k v)
|
|
(monomap-put! (isomap-forward im) k v)
|
|
(monomap-put! (isomap-backward im) k v))
|
|
(define (isomap-map im p)
|
|
(monomap-map (isomap-forward im) p))
|
|
(define (isomap-for-each im p)
|
|
(monomap-for-each (isomap-forward im) p))
|
|
|
|
(define (isomap-reverse-get im k [fail false/p])
|
|
(monomap-get (isomap-backward im) k fail))
|
|
|
|
(define (isomap-domain im)
|
|
(monomap-domain (isomap-forward im)))
|
|
(define (isomap-range im)
|
|
(monomap-domain (isomap-backward im)))
|
|
|
|
(define (-make-isomap fmake rmake ffail rfail)
|
|
(make-isomap (fmake ffail)
|
|
(rmake rfail)))
|
|
|#
|