suzanne.soy/whalesong
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

updating the signature support with latest sources from sk

Browse Source
This commit is contained in:
Danny Yoo 2011-11-09 14:06:44 -05:00
parent 5712576e72
commit 7aeb2d5043
4 changed files with 391 additions and 724 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

749
cs019/private/sigs-patched.rkt
View File

@ -1,362 +1,389 @@
#lang s-exp "../../lang/base.rkt" #lang s-exp "../../lang/base.rkt"
(require (only-in "../cs019-pre-base.rkt" (require (only-in "../cs019-pre-base.rkt"
[cs019-define asl:define] [cs019-define asl:define]
[cs019-lambda asl:lambda])) [cs019-lambda asl:lambda]))
(require [for-syntax syntax/struct] (require [for-syntax syntax/struct]
[for-syntax racket]) [for-syntax racket])
(provide define: lambda: define-struct: and: or: not:
(provide define: lambda: define-struct: and: or: not: (struct-out signature-violation))
(struct-out signature-violation))
(define the-undefined-value (letrec ([x x]) x))
(define-struct (signature-violation exn:fail) (define-struct (signature-violation exn:fail)
(srclocs) ;; listof srcloc-vector (srclocs) ;; listof srcloc-vector
#:property prop:exn:srclocs #:property prop:exn:srclocs
(lambda (violation) (lambda (violation)
(map (lambda (vec) (map (lambda (vec)
(apply srcloc (vector->list vec))) (apply srcloc (vector->list vec)))
(signature-violation-srclocs violation)))) (signature-violation-srclocs violation))))
;; syntax-srcloc: syntax -> srcloc-vector ;; syntax-srcloc: syntax -> srcloc-vector
(define-for-syntax (syntax-srcloc stx) (define-for-syntax (syntax-srcloc stx)
(vector (syntax-source stx) (vector (syntax-source stx)
(syntax-line stx) (syntax-line stx)
(syntax-column stx) (syntax-column stx)
(syntax-position stx) (syntax-position stx)
(syntax-span stx))) (syntax-span stx)))
(define-for-syntax (parse-sig stx) (define-for-syntax (parse-sig stx)
(syntax-case stx (->) (syntax-case stx (->)
[(A ... -> R) [(A ... -> R)
(with-syntax ([(A ...) (map parse-sig (syntax->list #'(A ...)))] (with-syntax ([(A ...) (map parse-sig (syntax->list #'(A ...)))]
[R (parse-sig #'R)]) [R (parse-sig #'R)])
(syntax/loc stx (syntax/loc stx
(proc: (A ... -> R))))] (proc: (A ... -> R))))]
[_ stx])) [_ stx]))
(define-for-syntax (parse-sigs stxs) (define-for-syntax (parse-sigs stxs)
(map parse-sig (syntax->list stxs))) (map parse-sig (syntax->list stxs)))
(define-syntax (define-struct: stx) (define-syntax (define-struct: stx)
(syntax-case stx (:) (syntax-case stx (:)
[(_ sn ([f : S] ...)) [(_ sn ([f : S] ...))
(with-syntax ([(names ...) (with-syntax ([(names ...)
(build-struct-names #'sn (map (lambda (i)
(syntax->list #'(f ...)) (datum->syntax stx i))
#f #f)] (map syntax->datum
[term-srcloc (syntax-srcloc stx)] (build-struct-names #'sn
[(S ...) (parse-sigs #'(S ...))]) (syntax->list #'(f ...))
(with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))] #f #f)))]
[sig-name (datum->syntax #'sn [term-srcloc (syntax-srcloc stx)]
(string->symbol [(S ...) (parse-sigs #'(S ...))])
(string-append (with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))]
(symbol->string [sig-name (datum->syntax #'sn
(syntax->datum #'sn)) (string->symbol
"$")))] (string-append
[cnstr (syntax-case #'(names ...) () (symbol->string
[(struct:name-id constructor misc ...) (syntax->datum #'sn))
#'constructor])] "$")))]
[(_sid _ctr _id? setters ...) [(cnstr pred get/set! ...)
(build-struct-names #'sn (syntax-case #'(names ...) ()
(syntax->list #'(f ...)) [(_s:id constructor predicate? getters/setters! ...)
#t #f)] #'(constructor predicate? getters/setters! ...)])])
[pred (syntax-case #'(names ...) () (with-syntax ([(setters ...) (let loop ([g/s! (syntax->list #'(get/set! ...))])
[(struct:name-id const predicate misc ...) (if (empty? g/s!)
#'predicate])]) empty
#'(begin (cons (second g/s!)
(define-values (names ...) (loop (rest (rest g/s!))))))])
(let () #|
(begin This expansion used to use
(define-struct sn (f ...) #:transparent #:mutable) #'(begin
(let ([cnstr (define-values (names ...)
(lambda (f ...) (let ()
(let ([wrapped-args (begin
(let loop ([sigs (list S ... )] (define-struct sn (f ...) #:transparent #:mutable)
[args (list f ...)] (let ([cnstr
[sig-srclocs (list S-srcloc ...)] (lambda (f ...)
[n 1]) (let ([wrapped-args ETC])
(if (null? sigs) (apply cnstr wrapped-args)))]
'() [setters ETC]
(cons (wrap (car sigs) ...)
(car args) (values names ...)))))
(car sig-srclocs)) ETC.
(loop (cdr sigs) It does not because that fails with shared:
(cdr args) (define-struct: foo ([n : Number$]))
(cdr sig-srclocs) (shared ([f (make-foo A)]
(add1 n)))))]) [A 3])
(apply cnstr wrapped-args)))] f)
[setters produces (make-foo #<undefined>) rather than (make-foo 3).
(lambda (struct-inst new-val) The version below, which mutates the setters, does not suffer from this.
(setters struct-inst (wrap S new-val S-srcloc)))] |#
...) #'(begin
(values names ...))))) (define-struct sn (f ...) #:transparent #:mutable)
;; This could be a define below, but it's a define-values (define dummy
;; due to a bug in ISL's local. See users@racket-lang.org (set! cnstr
;; thread, 2011-09-03, "splicing into local". Should not (let ([prim-cnstr cnstr])
;; be necessary with next release. (lambda (f ...)
(define-values (sig-name) (let ([wrapped-args
(first-order-sig pred term-srcloc)))))])) (let loop ([sigs (list S ... )]
[args (list f ...)]
[sig-srclocs (list S-srcloc ...)]
(define (raise-signature-violation msg srclocs) [n 1])
(raise (signature-violation msg (current-continuation-marks) srclocs))) (if (null? sigs)
'()
(define (not-sig-error srcloc) (cons (wrap (car sigs)
(raise-signature-violation "not a valid signature" (list srcloc))) (car args)
(car sig-srclocs))
(define (wrap sig val srcloc) (loop (cdr sigs)
(if (signature? sig) (cdr args)
((signature-wrapper sig) val) (cdr sig-srclocs)
(not-sig-error srcloc))) (add1 n)))))])
(apply prim-cnstr wrapped-args))))))
(provide Number$ String$ Char$ Boolean$ Any$ Sig: Listof: Vectorof:) (define more-dummies
(list
(define-struct signature (pred wrapper ho? srcloc)) (set! setters
(let ([prim-setter setters])
(define-syntax (Listof: stx) (lambda (struct-inst new-val)
(syntax-case stx () (prim-setter struct-inst (wrap S new-val S-srcloc)))))
[(_ S) ...))
(with-syntax ([S (parse-sig #'S)] ;; This could be a define below, but it's a define-values
[sig-srcloc (syntax-srcloc #'S)] ;; due to a bug in ISL's local. See users@racket-lang.org
[term-srcloc (syntax-srcloc stx)]) ;; thread, 2011-09-03, "splicing into local". Should not
#'(let ([s S]) ;; be necessary with next release.
(if (signature? s) (define-values (sig-name)
(if (signature-ho? s) (first-order-sig pred term-srcloc))))))]))
(make-signature list?
(lambda (v) (define (raise-signature-violation msg srclocs)
(map (lambda (e) (wrap s e sig-srcloc)) v)) (raise (signature-violation msg (current-continuation-marks) srclocs)))
#t
term-srcloc) (define (not-sig-error srcloc)
(let ([pred (lambda (v) (raise-signature-violation "not a valid signature" (list srcloc)))
(and (list? v)
(andmap (signature-pred s) v)))]) (define (wrap sig val srcloc)
(make-signature pred (if (signature? sig)
(lambda (v) (if (eq? val the-undefined-value)
(if (pred v) val
v ((signature-wrapper sig) val))
(if (list? v) (not-sig-error srcloc)))
(raise-signature-violation
(format "not an appropriate list: ~e" v) (provide Number$ String$ Char$ Boolean$ Any$ Sig: Listof: Vectorof:)
(list sig-srcloc))
(raise-signature-violation (define-struct signature (pred wrapper ho? srcloc))
(format "not a list: ~e" v)
(list term-srcloc))))) (define-syntax (Listof: stx)
#f (syntax-case stx ()
term-srcloc))) [(_ S)
(not-sig-error sig-srcloc))))])) (with-syntax ([S (parse-sig #'S)]
[sig-srcloc (syntax-srcloc #'S)]
(define-syntax (Vectorof: stx) [term-srcloc (syntax-srcloc stx)])
(syntax-case stx () #'(let ([s S])
[(_ S) (if (signature? s)
(with-syntax ([S (parse-sig #'S)] (if (signature-ho? s)
[sig-srcloc (syntax-srcloc #'S)] (make-signature list?
[term-srcloc (syntax-srcloc stx)]) (lambda (v)
#'(let ([s S]) (map (lambda (e) (wrap s e sig-srcloc)) v))
(if (signature? s) #t
(if (signature-ho? s) term-srcloc)
(make-signature vector? (let ([pred (lambda (v)
(lambda (v) (and (list? v)
(list->vector (andmap (signature-pred s) v)))])
(map (lambda (e) (wrap s e sig-srcloc)) (make-signature pred
(vector->list v)))) (lambda (v)
#t (if (pred v)
term-srcloc) v
(let ([pred (lambda (v) (if (list? v)
(and (vector? v) (raise-signature-violation
(andmap (signature-pred s) (format "not an appropriate list: ~e" v)
(vector->list v))))]) (list sig-srcloc))
(make-signature pred (raise-signature-violation
(lambda (v) (format "not a list: ~e" v)
(if (pred v) (list term-srcloc)))))
v #f
(if (vector? v) term-srcloc)))
(raise-signature-violation (not-sig-error sig-srcloc))))]))
(format "not an appropriate vector: ~e" v)
(list sig-srcloc)) (define-syntax (Vectorof: stx)
(raise-signature-violation (syntax-case stx ()
(format "not a vector: ~e" v) [(_ S)
(list term-srcloc))))) (with-syntax ([S (parse-sig #'S)]
#f [sig-srcloc (syntax-srcloc #'S)]
term-srcloc))) [term-srcloc (syntax-srcloc stx)])
(not-sig-error sig-srcloc))))])) #'(let ([s S])
(if (signature? s)
(define (first-order-sig pred? term-srcloc) (if (signature-ho? s)
(make-signature pred? (make-signature vector?
(lambda (v) (lambda (v)
(if (pred? v) (list->vector
v (map (lambda (e) (wrap s e sig-srcloc))
(raise-signature-violation (vector->list v))))
(format "value ~a failed the signature" v) #t
(list term-srcloc)))) term-srcloc)
#f (let ([pred (lambda (v)
term-srcloc)) (and (vector? v)
(andmap (signature-pred s)
(define-syntax (Sig: stx) (vector->list v))))])
(syntax-case stx () (make-signature pred
[(_ S) (lambda (v)
(with-syntax ([Sp (parse-sig #'S)] (if (pred v)
[term-srcloc (syntax-srcloc stx)]) v
(if (eq? #'Sp #'S) ;; currently means S is NOT (... -> ...) (if (vector? v)
#'(first-order-sig S term-srcloc) (raise-signature-violation
#'Sp))])) (format "not an appropriate vector: ~e" v)
(list sig-srcloc))
(define-syntax (Number$ stx) (raise-signature-violation
(syntax-case stx (Number$) (format "not a vector: ~e" v)
[Number$ (list term-srcloc)))))
(with-syntax ([term-srcloc (syntax-srcloc stx)]) #f
#'(first-order-sig number? term-srcloc))])) term-srcloc)))
(not-sig-error sig-srcloc))))]))
(define-syntax (String$ stx)
(syntax-case stx (String$) (define (first-order-sig pred? term-srcloc)
[String$ (make-signature pred?
(with-syntax ([term-srcloc (syntax-srcloc stx)]) (lambda (v)
#'(first-order-sig string? term-srcloc))])) (if (pred? v)
v
(define-syntax (Char$ stx) (raise-signature-violation
(syntax-case stx (char$) (format "value ~s failed the signature" v)
[Char$ (list term-srcloc))))
(with-syntax ([term-srcloc (syntax-srcloc stx)]) #f
#'(first-order-sig char? term-srcloc))])) term-srcloc))
(define-syntax (Boolean$ stx) (define-syntax (Sig: stx)
(syntax-case stx (Boolean$) (syntax-case stx ()
[Boolean$ [(_ S)
(with-syntax ([term-srcloc (syntax-srcloc stx)]) (with-syntax ([Sp (parse-sig #'S)]
#'(first-order-sig boolean? term-srcloc))])) [term-srcloc (syntax-srcloc stx)])
(if (eq? #'Sp #'S) ;; currently means S is NOT (... -> ...)
(define-syntax (Any$ stx) #'(first-order-sig S term-srcloc)
(syntax-case stx (Any$) #'Sp))]))
[Any$
(with-syntax ([term-srcloc (syntax-srcloc stx)]) (define-syntax (Number$ stx)
#'(first-order-sig (lambda (_) #t) term-srcloc))])) (syntax-case stx (Number$)
[Number$
;; proc: is for internal use only. (with-syntax ([term-srcloc (syntax-srcloc stx)])
;; Stand-alone procedural signatures are defined using Sig:; e.g., #'(first-order-sig number? term-srcloc))]))
;; (define n->n (Sig: (Number$ -> Number$)))
;; In all other cases, the macros invoke parse-sig, which takes care of (define-syntax (String$ stx)
;; automatically wrapping (proc: ...) around procedure signatures. (syntax-case stx (String$)
(define-syntax (proc: stx) [String$
(syntax-case stx (->) (with-syntax ([term-srcloc (syntax-srcloc stx)])
[(_ (A ... -> R)) #'(first-order-sig string? term-srcloc))]))
(with-syntax ([(args ...) (generate-temporaries #'(A ...))]
[(A ...) (parse-sigs #'(A ...))] (define-syntax (Char$ stx)
[R (parse-sig #'R)] (syntax-case stx (char$)
[term-srcloc (syntax-srcloc stx)]) [Char$
(with-syntax ([(A-srcloc ...) (with-syntax ([term-srcloc (syntax-srcloc stx)])
(map syntax-srcloc (syntax->list #'(A ...)))] #'(first-order-sig char? term-srcloc))]))
[R-srcloc (syntax-srcloc #'R)])
#'(make-signature (define-syntax (Boolean$ stx)
procedure? (syntax-case stx (Boolean$)
(lambda (v) [Boolean$
(if (procedure? v) (with-syntax ([term-srcloc (syntax-srcloc stx)])
(lambda (args ...) #'(first-order-sig boolean? term-srcloc))]))
(wrap R (v (wrap A args A-srcloc) ...) R-srcloc))
(raise-signature-violation (define-syntax (Any$ stx)
(format "not a procedure: ~e" v) (syntax-case stx (Any$)
(list term-srcloc)))) [Any$
#t (with-syntax ([term-srcloc (syntax-srcloc stx)])
term-srcloc)))])) #'(first-order-sig (lambda (_) #t) term-srcloc))]))
(define-syntax (define: stx) ;; proc: is for internal use only.
(syntax-case stx (: ->) ;; Stand-alone procedural signatures are defined using Sig:; e.g.,
[(_ id : S exp) ;; (define n->n (Sig: (Number$ -> Number$)))
(identifier? #'id) ;; In all other cases, the macros invoke parse-sig, which takes care of
(with-syntax ([S (parse-sig #'S)]) ;; automatically wrapping (proc: ...) around procedure signatures.
(with-syntax ([S-srcloc (syntax-srcloc #'S)]) (define-syntax (proc: stx)
#'(asl:define id (wrap S exp S-srcloc))))] (syntax-case stx (->)
[(_ (f [a : Sa] ...) -> Sr exp) [(_ (A ... -> R))
(with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))] (with-syntax ([(args ...) (generate-temporaries #'(A ...))]
[Sr (parse-sig #'Sr)]) [(A ...) (parse-sigs #'(A ...))]
#'(asl:define f (lambda: ([a : Sa] ...) -> Sr exp)))])) [R (parse-sig #'R)]
[term-srcloc (syntax-srcloc stx)])
(define-syntax (lambda: stx) (with-syntax ([(A-srcloc ...)
(syntax-case stx (: ->) (map syntax-srcloc (syntax->list #'(A ...)))]
[(_ ([a : Sa] ...) -> Sr exp) [R-srcloc (syntax-srcloc #'R)])
(with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))] #'(make-signature
[Sr (parse-sig #'Sr)]) procedure?
(with-syntax ([(Sa-srcloc ...) (map syntax-srcloc (syntax->list #'(Sa ...)))] (lambda (v)
[Sr-srcloc (syntax-srcloc #'Sr)]) (if (procedure? v)
#'(asl:lambda (a ...) (lambda (args ...)
(let ([a (wrap Sa a Sa-srcloc)] ...) (wrap R (v (wrap A args A-srcloc) ...) R-srcloc))
(wrap Sr exp Sr-srcloc)))))])) (raise-signature-violation
(format "not a procedure: ~e" v)
(define-syntax (or: stx) (list term-srcloc))))
(syntax-case stx () #t
[(_ S ...) term-srcloc)))]))
(with-syntax ([(S ...) (parse-sigs #'(S ...))]
[term-srcloc (syntax-srcloc stx)]) (define-syntax (define: stx)
(with-syntax ([(S-srcloc ...) (syntax-case stx (: ->)
(map syntax-srcloc (syntax->list #'(S ...)))]) [(_ id : S exp)
#'(first-order-sig (identifier? #'id)
(lambda (x) (with-syntax ([S (parse-sig #'S)])
(let loop ([sigs (list S ...)] (with-syntax ([S-srcloc (syntax-srcloc #'S)])
[sig-srclocs (list S-srcloc ...)]) #'(asl:define id (wrap S exp S-srcloc))))]
(if (null? sigs) [(_ (f [a : Sa] ...) -> Sr exp)
#f (with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
(let ([s (car sigs)]) [Sr (parse-sig #'Sr)])
(if (signature? s) #'(asl:define f (lambda: ([a : Sa] ...) -> Sr exp)))]))
(if (signature-ho? s)
(raise-signature-violation (define-syntax (lambda: stx)
"or: cannot combine higher-order signature" (syntax-case stx (: ->)
(list term-srcloc (signature-srcloc s))) [(_ ([a : Sa] ...) -> Sr exp)
(or ((signature-pred s) x) (with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
(loop (cdr sigs) (cdr sig-srclocs)))) [Sr (parse-sig #'Sr)])
(not-sig-error (car sig-srclocs))))))) (with-syntax ([(Sa-srcloc ...) (map syntax-srcloc (syntax->list #'(Sa ...)))]
term-srcloc)))])) [Sr-srcloc (syntax-srcloc #'Sr)])
#'(asl:lambda (a ...)
(define-syntax (and: stx) (let ([a (wrap Sa a Sa-srcloc)] ...)
(syntax-case stx () (wrap Sr exp Sr-srcloc)))))]))
[(_ S ...)
(with-syntax ([(S ...) (parse-sigs #'(S ...))] (define-syntax (or: stx)
[term-srcloc (syntax-srcloc stx)]) (syntax-case stx ()
(with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))]) [(_ S ...)
#'(first-order-sig (with-syntax ([(S ...) (parse-sigs #'(S ...))]
(lambda (x) [term-srcloc (syntax-srcloc stx)])
(let loop ([sigs (list S ...)] (with-syntax ([(S-srcloc ...)
[sig-srclocs (list S-srcloc ...)]) (map syntax-srcloc (syntax->list #'(S ...)))])
(if (null? sigs) #'(first-order-sig
#t (lambda (x)
(let ([s (car sigs)]) (let loop ([sigs (list S ...)]
(if (signature? s) [sig-srclocs (list S-srcloc ...)])
(if (signature-ho? s) (if (null? sigs)
(raise-signature-violation #f
"and: cannot combine higher-order signature" (let ([s (car sigs)])
(list term-srcloc (signature-srcloc s))) (if (signature? s)
(and ((signature-pred s) x) (if (signature-ho? s)
(loop (cdr sigs) (cdr sig-srclocs)))) (raise-signature-violation
(not-sig-error (car sig-srclocs))))))) "or: cannot combine higher-order signature"
term-srcloc)))])) (list term-srcloc (signature-srcloc s)))
(or ((signature-pred s) x)
(define-syntax (not: stx) (loop (cdr sigs) (cdr sig-srclocs))))
(syntax-case stx () (not-sig-error (car sig-srclocs)))))))
[(_ S) term-srcloc)))]))
(with-syntax ([S (parse-sig #'S)]
[term-srcloc (syntax-srcloc stx)]) (define-syntax (and: stx)
(with-syntax ([sig-srcloc(syntax-srcloc #'S)]) (syntax-case stx ()
#'(let ([s S]) [(_ S ...)
(if (signature? s) (with-syntax ([(S ...) (parse-sigs #'(S ...))]
(if (signature-ho? s) [term-srcloc (syntax-srcloc stx)])
(raise-signature-violation (with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))])
"not: cannot negate higher-order signature" #'(first-order-sig
(list term-srcloc)) (lambda (x)
(first-order-sig (lambda (x) (not ((signature-pred s) x))) term-srcloc)) (let loop ([sigs (list S ...)]
(not-sig-error sig-srcloc)))))])) [sig-srclocs (list S-srcloc ...)])
(if (null? sigs)
#| #t
(provide : defvar:) (let ([s (car sigs)])
(if (signature? s)
(define-syntax (: stx) (raise-syntax-error stx ': "Cannot be used outside ...")) (if (signature-ho? s)
(raise-signature-violation
(define-syntax (defvar: stx) "and: cannot combine higher-order signature"
(syntax-parse stx #:literals(:) (list term-srcloc (signature-srcloc s)))
[(_ i:id : S:expr b:expr) (and ((signature-pred s) x)
#'(asl:define i (loop (cdr sigs) (cdr sig-srclocs))))
(let ([e b]) (not-sig-error (car sig-srclocs)))))))
(if (S e) term-srcloc)))]))
e
(error 'signature "violation of ~a" S))))])) (define-syntax (not: stx)
(syntax-case stx ()
[(_ S)
(with-syntax ([S (parse-sig #'S)]
[term-srcloc (syntax-srcloc stx)])
(with-syntax ([sig-srcloc(syntax-srcloc #'S)])
#'(let ([s S])
(if (signature? s)
(if (signature-ho? s)
(raise-signature-violation
"not: cannot negate higher-order signature"
(list term-srcloc))
(first-order-sig (lambda (x) (not ((signature-pred s) x))) term-srcloc))
(not-sig-error sig-srcloc)))))]))
#|
(provide : defvar:)
(define-syntax (: stx) (raise-syntax-error stx ': "Cannot be used outside ..."))
(define-syntax (defvar: stx)
(syntax-parse stx #:literals(:)
[(_ i:id : S:expr b:expr)
#'(asl:define i
(let ([e b])
(if (S e)
e
(error 'signature "violation of ~a" S))))]))
|# |#

362
cs019/private/sigs.rkt
View File

@ -1,362 +0,0 @@
#lang racket/base
(require (only-in lang/htdp-advanced
[define asl:define]
[lambda asl:lambda]))
(require [for-syntax syntax/struct]
[for-syntax racket])
(provide define: lambda: define-struct: and: or: not:
(struct-out signature-violation))
(define-struct (signature-violation exn:fail)
(srclocs) ;; listof srcloc-vector
#:property prop:exn:srclocs
(lambda (violation)
(map (lambda (vec)
(apply srcloc (vector->list vec)))
(signature-violation-srclocs violation))))
;; syntax-srcloc: syntax -> srcloc-vector
(define-for-syntax (syntax-srcloc stx)
(vector (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx)))
(define-for-syntax (parse-sig stx)
(syntax-case stx (->)
[(A ... -> R)
(with-syntax ([(A ...) (map parse-sig (syntax->list #'(A ...)))]
[R (parse-sig #'R)])
(syntax/loc stx
(proc: (A ... -> R))))]
[_ stx]))
(define-for-syntax (parse-sigs stxs)
(map parse-sig (syntax->list stxs)))
(define-syntax (define-struct: stx)
(syntax-case stx (:)
[(_ sn ([f : S] ...))
(with-syntax ([(names ...)
(build-struct-names #'sn
(syntax->list #'(f ...))
#f #f)]
[term-srcloc (syntax-srcloc stx)]
[(S ...) (parse-sigs #'(S ...))])
(with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))]
[sig-name (datum->syntax #'sn
(string->symbol
(string-append
(symbol->string
(syntax->datum #'sn))
"$")))]
[cnstr (syntax-case #'(names ...) ()
[(struct:name-id constructor misc ...)
#'constructor])]
[(_sid _ctr _id? setters ...)
(build-struct-names #'sn
(syntax->list #'(f ...))
#t #f)]
[pred (syntax-case #'(names ...) ()
[(struct:name-id const predicate misc ...)
#'predicate])])
#'(begin
(define-values (names ...)
(let ()
(begin
(define-struct sn (f ...) #:transparent #:mutable)
(let ([cnstr
(lambda (f ...)
(let ([wrapped-args
(let loop ([sigs (list S ... )]
[args (list f ...)]
[sig-srclocs (list S-srcloc ...)]
[n 1])
(if (null? sigs)
'()
(cons (wrap (car sigs)
(car args)
(car sig-srclocs))
(loop (cdr sigs)
(cdr args)
(cdr sig-srclocs)
(add1 n)))))])
(apply cnstr wrapped-args)))]
[setters
(lambda (struct-inst new-val)
(setters struct-inst (wrap S new-val S-srcloc)))]
...)
(values names ...)))))
;; This could be a define below, but it's a define-values
;; due to a bug in ISL's local. See users@racket-lang.org
;; thread, 2011-09-03, "splicing into local". Should not
;; be necessary with next release.
(define-values (sig-name)
(first-order-sig pred term-srcloc)))))]))
(define (raise-signature-violation msg srclocs)
(raise (signature-violation msg (current-continuation-marks) srclocs)))
(define (not-sig-error srcloc)
(raise-signature-violation "not a valid signature" (list srcloc)))
(define (wrap sig val srcloc)
(if (signature? sig)
((signature-wrapper sig) val)
(not-sig-error srcloc)))
(provide Number$ String$ Char$ Boolean$ Any$ Sig: Listof: Vectorof:)
(define-struct signature (pred wrapper ho? srcloc))
(define-syntax (Listof: stx)
(syntax-case stx ()
[(_ S)
(with-syntax ([S (parse-sig #'S)]
[sig-srcloc (syntax-srcloc #'S)]
[term-srcloc (syntax-srcloc stx)])
#'(let ([s S])
(if (signature? s)
(if (signature-ho? s)
(make-signature list?
(lambda (v)
(map (lambda (e) (wrap s e sig-srcloc)) v))
#t
term-srcloc)
(let ([pred (lambda (v)
(and (list? v)
(andmap (signature-pred s) v)))])
(make-signature pred
(lambda (v)
(if (pred v)
v
(if (list? v)
(raise-signature-violation
(format "not an appropriate list: ~e" v)
(list sig-srcloc))
(raise-signature-violation
(format "not a list: ~e" v)
(list term-srcloc)))))
#f
term-srcloc)))
(not-sig-error sig-srcloc))))]))
(define-syntax (Vectorof: stx)
(syntax-case stx ()
[(_ S)
(with-syntax ([S (parse-sig #'S)]
[sig-srcloc (syntax-srcloc #'S)]
[term-srcloc (syntax-srcloc stx)])
#'(let ([s S])
(if (signature? s)
(if (signature-ho? s)
(make-signature vector?
(lambda (v)
(list->vector
(map (lambda (e) (wrap s e sig-srcloc))
(vector->list v))))
#t
term-srcloc)
(let ([pred (lambda (v)
(and (vector? v)
(andmap (signature-pred s)
(vector->list v))))])
(make-signature pred
(lambda (v)
(if (pred v)
v
(if (vector? v)
(raise-signature-violation
(format "not an appropriate vector: ~e" v)
(list sig-srcloc))
(raise-signature-violation
(format "not a vector: ~e" v)
(list term-srcloc)))))
#f
term-srcloc)))
(not-sig-error sig-srcloc))))]))
(define (first-order-sig pred? term-srcloc)
(make-signature pred?
(lambda (v)
(if (pred? v)
v
(raise-signature-violation
(format "value ~a failed the signature" v)
(list term-srcloc))))
#f
term-srcloc))
(define-syntax (Sig: stx)
(syntax-case stx ()
[(_ S)
(with-syntax ([Sp (parse-sig #'S)]
[term-srcloc (syntax-srcloc stx)])
(if (eq? #'Sp #'S) ;; currently means S is NOT (... -> ...)
#'(first-order-sig S term-srcloc)
#'Sp))]))
(define-syntax (Number$ stx)
(syntax-case stx (Number$)
[Number$
(with-syntax ([term-srcloc (syntax-srcloc stx)])
#'(first-order-sig number? term-srcloc))]))
(define-syntax (String$ stx)
(syntax-case stx (String$)
[String$
(with-syntax ([term-srcloc (syntax-srcloc stx)])
#'(first-order-sig string? term-srcloc))]))
(define-syntax (Char$ stx)
(syntax-case stx (char$)
[Char$
(with-syntax ([term-srcloc (syntax-srcloc stx)])
#'(first-order-sig char? term-srcloc))]))
(define-syntax (Boolean$ stx)
(syntax-case stx (Boolean$)
[Boolean$
(with-syntax ([term-srcloc (syntax-srcloc stx)])
#'(first-order-sig boolean? term-srcloc))]))
(define-syntax (Any$ stx)
(syntax-case stx (Any$)
[Any$
(with-syntax ([term-srcloc (syntax-srcloc stx)])
#'(first-order-sig (lambda (_) #t) term-srcloc))]))
;; proc: is for internal use only.
;; Stand-alone procedural signatures are defined using Sig:; e.g.,
;; (define n->n (Sig: (Number$ -> Number$)))
;; In all other cases, the macros invoke parse-sig, which takes care of
;; automatically wrapping (proc: ...) around procedure signatures.
(define-syntax (proc: stx)
(syntax-case stx (->)
[(_ (A ... -> R))
(with-syntax ([(args ...) (generate-temporaries #'(A ...))]
[(A ...) (parse-sigs #'(A ...))]
[R (parse-sig #'R)]
[term-srcloc (syntax-srcloc stx)])
(with-syntax ([(A-srcloc ...)
(map syntax-srcloc (syntax->list #'(A ...)))]
[R-srcloc (syntax-srcloc #'R)])
#'(make-signature
procedure?
(lambda (v)
(if (procedure? v)
(lambda (args ...)
(wrap R (v (wrap A args A-srcloc) ...) R-srcloc))
(raise-signature-violation
(format "not a procedure: ~e" v)
(list term-srcloc))))
#t
term-srcloc)))]))
(define-syntax (define: stx)
(syntax-case stx (: ->)
[(_ id : S exp)
(identifier? #'id)
(with-syntax ([S (parse-sig #'S)])
(with-syntax ([S-srcloc (syntax-srcloc #'S)])
#'(asl:define id (wrap S exp S-srcloc))))]
[(_ (f [a : Sa] ...) -> Sr exp)
(with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
[Sr (parse-sig #'Sr)])
#'(asl:define f (lambda: ([a : Sa] ...) -> Sr exp)))]))
(define-syntax (lambda: stx)
(syntax-case stx (: ->)
[(_ ([a : Sa] ...) -> Sr exp)
(with-syntax ([(Sa ...) (parse-sigs #'(Sa ...))]
[Sr (parse-sig #'Sr)])
(with-syntax ([(Sa-srcloc ...) (map syntax-srcloc (syntax->list #'(Sa ...)))]
[Sr-srcloc (syntax-srcloc #'Sr)])
#'(asl:lambda (a ...)
(let ([a (wrap Sa a Sa-srcloc)] ...)
(wrap Sr exp Sr-srcloc)))))]))
(define-syntax (or: stx)
(syntax-case stx ()
[(_ S ...)
(with-syntax ([(S ...) (parse-sigs #'(S ...))]
[term-srcloc (syntax-srcloc stx)])
(with-syntax ([(S-srcloc ...)
(map syntax-srcloc (syntax->list #'(S ...)))])
#'(first-order-sig
(lambda (x)
(let loop ([sigs (list S ...)]
[sig-srclocs (list S-srcloc ...)])
(if (null? sigs)
#f
(let ([s (car sigs)])
(if (signature? s)
(if (signature-ho? s)
(raise-signature-violation
"or: cannot combine higher-order signature"
(list term-srcloc (signature-srcloc s)))
(or ((signature-pred s) x)
(loop (cdr sigs) (cdr sig-srclocs))))
(not-sig-error (car sig-srclocs)))))))
term-srcloc)))]))
(define-syntax (and: stx)
(syntax-case stx ()
[(_ S ...)
(with-syntax ([(S ...) (parse-sigs #'(S ...))]
[term-srcloc (syntax-srcloc stx)])
(with-syntax ([(S-srcloc ...) (map syntax-srcloc (syntax->list #'(S ...)))])
#'(first-order-sig
(lambda (x)
(let loop ([sigs (list S ...)]
[sig-srclocs (list S-srcloc ...)])
(if (null? sigs)
#t
(let ([s (car sigs)])
(if (signature? s)
(if (signature-ho? s)
(raise-signature-violation
"and: cannot combine higher-order signature"
(list term-srcloc (signature-srcloc s)))
(and ((signature-pred s) x)
(loop (cdr sigs) (cdr sig-srclocs))))
(not-sig-error (car sig-srclocs)))))))
term-srcloc)))]))
(define-syntax (not: stx)
(syntax-case stx ()
[(_ S)
(with-syntax ([S (parse-sig #'S)]
[term-srcloc (syntax-srcloc stx)])
(with-syntax ([sig-srcloc(syntax-srcloc #'S)])
#'(let ([s S])
(if (signature? s)
(if (signature-ho? s)
(raise-signature-violation
"not: cannot negate higher-order signature"
(list term-srcloc))
(first-order-sig (lambda (x) (not ((signature-pred s) x))) term-srcloc))
(not-sig-error sig-srcloc)))))]))
#|
(provide : defvar:)
(define-syntax (: stx) (raise-syntax-error stx ': "Cannot be used outside ..."))
(define-syntax (defvar: stx)
(syntax-parse stx #:literals(:)
[(_ i:id : S:expr b:expr)
#'(asl:define i
(let ([e b])
(if (S e)
e
(error 'signature "violation of ~a" S))))]))
|#

2
tests/more-tests/hashes.expected
View File

@ -76,6 +76,8 @@ true
(author name) (author name)
(graham-knuth-patashnik concrete-mathematics) (graham-knuth-patashnik concrete-mathematics)
(graham-knuth-patashnik concrete-mathematics) (graham-knuth-patashnik concrete-mathematics)
((graham-knuth-patashnik author) (concrete-mathematics name))
((graham-knuth-patashnik author) (concrete-mathematics name))
"author" "author"
"name" "name"
"graham-knuth-patashnik" "graham-knuth-patashnik"

2
version.rkt
View File

@ -6,4 +6,4 @@
(provide version) (provide version)
(: version String) (: version String)
(define version "1.72") (define version "1.76")