From 87da2f35b962187ad900472a7962f47f058695e9 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Fri, 8 Oct 2010 11:19:38 +0200 Subject: [PATCH] Provide English and German versions of deinprogramm/signature/signature. --- collects/deinprogramm/convert-explicit.rkt | 2 +- .../deinprogramm/define-record-procedures.rkt | 1 + .../signature/signature-english.rkt | 14 + .../signature/signature-german.rkt | 14 + .../signature/signature-syntax.rkt | 1 + .../deinprogramm/signature/signature-unit.rkt | 652 ++++++++++++++++++ collects/deinprogramm/signature/signature.rkt | 632 +---------------- collects/lang/private/signature-syntax.rkt | 1 + collects/lang/private/teach.rkt | 1 + collects/lang/private/teachprims.rkt | 3 +- collects/tests/deinprogramm/signature.rkt | 1 + 11 files changed, 700 insertions(+), 622 deletions(-) create mode 100644 collects/deinprogramm/signature/signature-english.rkt create mode 100644 collects/deinprogramm/signature/signature-german.rkt create mode 100644 collects/deinprogramm/signature/signature-unit.rkt diff --git a/collects/deinprogramm/convert-explicit.rkt b/collects/deinprogramm/convert-explicit.rkt index e1067a4efc..757bf652f2 100644 --- a/collects/deinprogramm/convert-explicit.rkt +++ b/collects/deinprogramm/convert-explicit.rkt @@ -4,7 +4,7 @@ (require mzlib/pretty mzlib/struct) -(require deinprogramm/signature/signature) +(require deinprogramm/signature/signature-german) (require scheme/include) (include "convert-explicit.scm") diff --git a/collects/deinprogramm/define-record-procedures.rkt b/collects/deinprogramm/define-record-procedures.rkt index f1e7a3f230..e0d0297d86 100644 --- a/collects/deinprogramm/define-record-procedures.rkt +++ b/collects/deinprogramm/define-record-procedures.rkt @@ -11,6 +11,7 @@ mzlib/pconvert-prop mzlib/pretty deinprogramm/signature/signature + deinprogramm/signature/signature-german deinprogramm/signature/signature-syntax) (require (for-syntax scheme/base) diff --git a/collects/deinprogramm/signature/signature-english.rkt b/collects/deinprogramm/signature/signature-english.rkt new file mode 100644 index 0000000000..e69e2838b8 --- /dev/null +++ b/collects/deinprogramm/signature/signature-english.rkt @@ -0,0 +1,14 @@ +#lang scheme/base +(require deinprogramm/signature/signature-unit + racket/unit) + +(provide-signature-elements signatures^) + +(define recursive-signature-message "recursive signature") +(define parameter-count-mismatch-message "wrong number of parameters") +(define argument-count-mismatch-message "wrong number of arguments") + +(define-values/invoke-unit signatures@ + (import signature-messages^) + (export signatures^)) + diff --git a/collects/deinprogramm/signature/signature-german.rkt b/collects/deinprogramm/signature/signature-german.rkt new file mode 100644 index 0000000000..1557e3a9fe --- /dev/null +++ b/collects/deinprogramm/signature/signature-german.rkt @@ -0,0 +1,14 @@ +#lang scheme/base +(require deinprogramm/signature/signature-unit + racket/unit) + +(provide-signature-elements signatures^) + +(define recursive-signature-message "rekursive Signatur") +(define parameter-count-mismatch-message "falsche Anzahl von Parametern") +(define argument-count-mismatch-message "falsche Anzahl von Argumenten") + +(define-values/invoke-unit signatures@ + (import signature-messages^) + (export signatures^)) + diff --git a/collects/deinprogramm/signature/signature-syntax.rkt b/collects/deinprogramm/signature/signature-syntax.rkt index 899997aa92..d83b0792d9 100644 --- a/collects/deinprogramm/signature/signature-syntax.rkt +++ b/collects/deinprogramm/signature/signature-syntax.rkt @@ -7,6 +7,7 @@ -> mixed one-of predicate combined property list-of) (require deinprogramm/signature/signature + deinprogramm/signature/signature-german scheme/promise (for-syntax scheme/base) (for-syntax syntax/stx) diff --git a/collects/deinprogramm/signature/signature-unit.rkt b/collects/deinprogramm/signature/signature-unit.rkt new file mode 100644 index 0000000000..4bce52faec --- /dev/null +++ b/collects/deinprogramm/signature/signature-unit.rkt @@ -0,0 +1,652 @@ +#lang scheme/base +(provide signature-messages^ signatures^ signatures@) + +(require racket/unit) + +(require scheme/promise + mzlib/struct + (for-syntax scheme/base) + (for-syntax stepper/private/shared)) + +(require deinprogramm/signature/signature) + +(require deinprogramm/quickcheck/quickcheck) + +(define-signature signature-messages^ + (recursive-signature-message + parameter-count-mismatch-message + argument-count-mismatch-message)) + +(define-signature signatures^ + (make-delayed-signature + make-call-signature + make-property-signature + make-predicate-signature + make-type-variable-signature + make-list-signature + make-mixed-signature + make-combined-signature + make-case-signature + make-procedure-signature + procedure-signature-info? + procedure-signature-info-arg-signatures procedure-signature-info-return-signature + make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors + prop:lazy-wrap lazy-wrap? lazy-wrap-ref + make-lazy-wrap-signature + check-lazy-wraps! + make-pair-signature checked-car checked-cdr)) + +(define-unit signatures@ + (import signature-messages^) + (export signatures^) + +(define (make-delayed-signature name promise) + (make-signature name + (lambda (self obj) + ((signature-enforcer (force promise)) self obj)) + (delay (signature-syntax (force promise))) + #:arbitrary-promise + (delay + (force (signature-arbitrary-promise (force promise)))) + #:info-promise + (delay + (force (signature-info-promise (force promise)))) + #:<=?-proc + (lambda (this-info other-info) + ((signature-<=?-proc (force promise)) this-info other-info)) + #:=?-proc + (lambda (this-info other-info) + ((signature-=?-proc (force promise)) this-info other-info)))) + +; specialized version of the above, supports comparison +; the promise must produce the result of (proc . args), but its passed separately +; to give us the right location on backtrace +(define (make-call-signature name promise proc-promise args-promise syntax) + (make-signature name + (lambda (self obj) + ((signature-enforcer (force promise)) self obj)) + (delay syntax) + #:arbitrary-promise + (delay + (force (signature-arbitrary-promise (force promise)))) + #:info-promise + (delay + (make-call-info promise (force proc-promise) (force args-promise))) + #:=?-proc + (lambda (this-info other-info) + (and (call-info? other-info) + (eqv? (force proc-promise) (call-info-proc other-info)) + (equal? (force args-promise) (call-info-args other-info)))))) + +(define-struct call-info (promise proc args) #:transparent) + +; klude to support mixed +(define (real-signature-info sig) + (let ((raw-info (force (signature-info-promise sig)))) + (if (call-info? raw-info) + (real-signature-info (force (call-info-promise raw-info))) + (force raw-info)))) + +(define (make-property-signature name access signature syntax) + (let ((enforce (signature-enforcer signature))) + (make-signature name + (lambda (self obj) + (enforce self (access obj)) ; #### problematic: enforcement doesn't stick + obj) + syntax))) + +(define (make-predicate-signature name predicate-promise syntax) + (make-signature + name + (lambda (self obj) ; dynamic binding because of syntax remapping via `signature-update-syntax' + (if ((force predicate-promise) obj) + obj + (begin + (signature-violation obj self #f #f) + obj))) + (delay syntax) + #:info-promise + (delay (make-predicate-info (force predicate-promise))) + #:=?-proc + (lambda (this-info other-info) + (and (predicate-info? other-info) + (eq? (force predicate-promise) + (predicate-info-predicate other-info)))))) + +(define-struct predicate-info (predicate) #:transparent) + +(define (make-type-variable-signature name syntax) + (make-signature + name + (lambda (self obj) obj) + (delay syntax) + #:info-promise + (delay (make-type-variable-info)) + #:=?-proc + (lambda (this-info other-info) + (type-variable-info? other-info)))) + +; maps lists to pairs of signature, enforced value +(define lists-table (make-weak-hasheq)) + +(define (make-list-signature name arg-signature syntax) + (make-signature + name + (lambda (self obj) + ;;(write (list 'list obj) (current-error-port)) (newline (current-error-port)) + (let recur ((l obj)) + + (define (go-on) + (let ((enforced (cons (apply-signature arg-signature (car l)) + (recur (cdr l))))) + (hash-set! lists-table l (cons self enforced)) + (hash-set! lists-table enforced (cons self enforced)) + enforced)) + + (cond + ((null? l) + l) + ((not (pair? l)) + (signature-violation obj self #f #f) + obj) + ((hash-ref lists-table l #f) + => (lambda (seen) + ;;(write (list 'seen seen (eq? self (car seen))) (current-error-port)) (newline (current-error-port)) + (if (eq? self (car seen)) + (cdr seen) + (go-on)))) + (else + (go-on))))) + syntax + #:arbitrary-promise + (delay + (lift->arbitrary arbitrary-list arg-signature)) + #:info-promise + (delay (make-list-info arg-signature)) + #:=?-proc + (lambda (this-info other-info) + (and (list-info? other-info) + (signature=? arg-signature (list-info-arg-signature other-info)))))) + +(define-struct list-info (arg-signature) #:transparent) + +(define (lift->arbitrary proc . signatures) + (let ((arbitraries (map force (map signature-arbitrary-promise signatures)))) + (if (andmap values arbitraries) + (apply proc arbitraries) + #f))) + +(define (make-mixed-signature name alternative-signatures syntax) + (letrec ((alternative-signatures-promise + (delay + (normalize-mixed-signatures mixed-signature alternative-signatures))) + (mixed-signature + (make-signature + name + (lambda (self obj) + (let loop ((alternative-signatures (force alternative-signatures-promise))) + (cond + ((null? alternative-signatures) + (signature-violation obj self #f #f) + obj) + ((eq? (car alternative-signatures) self) + (raise + (make-exn:fail:contract + (string->immutable-string + (if name + (format "~a: ~a" recursive-signature-message) + recursive-signature-message)) + (current-continuation-marks)))) + (else + (check-signature (car alternative-signatures) + obj + values + (lambda () (loop (cdr alternative-signatures)))))))) + (delay syntax) + #:info-promise + (delay (make-mixed-info (force alternative-signatures-promise))) + #:arbitrary-promise + (delay + (let ((arbitraries (map force (map signature-arbitrary-promise (force alternative-signatures-promise))))) + (if (andmap values arbitraries) + (arbitrary-mixed + (map (lambda (sig arb) + (cons (signature->predicate sig) + arb)) + (force alternative-signatures-promise) arbitraries)) + #f))) + #:=?-proc + (lambda (this-info other-info) + (and (mixed-info? other-info) + (andmap signature=? + (mixed-info-signatures this-info) + (mixed-info-signatures other-info)))) + #:<=?-proc + (lambda (this-info other-info) + (and (mixed-info? other-info) + (mixed-signature<=? (mixed-info-signatures this-info) + (mixed-info-signatures other-info))))))) + mixed-signature)) + +(define (mixed-signature<=? sigs1 sigs2) + (andmap (lambda (sig1) + (ormap (lambda (sig2) + (signature<=? sig1 sig2)) + sigs2)) + sigs1)) + +; Flatten out mixed signatures, and fold in in the lazy-wrap +; signatures + +(define (normalize-mixed-signatures mixed-signature sigs) + (fold-lazy-wrap-signatures mixed-signature (flatten-mixed-signatures sigs))) + +(define (flatten-mixed-signatures sigs) + (apply append + (map (lambda (sig) + (let ((info (force (signature-info-promise sig)))) + (if (mixed-info? info) + (mixed-info-signatures info) + (list sig)))) + sigs))) + +(define-struct mixed-info (signatures) #:transparent) + +(define (check-signature sig val success fail) + ((let/ec exit + (let ((enforced + (call-with-signature-violation-proc + (lambda (signature syntax msg blame) + (exit fail)) + (lambda () + (apply-signature sig val))))) + (lambda () (success enforced)))))) + +(define (signature->predicate sig) + (lambda (val) + (check-signature sig val (lambda (_) #t) (lambda () #f)))) + +(define (make-combined-signature name signatures syntax) + (make-signature + name + (lambda (self obj) + (let ((old-violation-proc (signature-violation-proc))) + ((let/ec exit + (call-with-signature-violation-proc + (lambda (signature syntax msg blame) + (exit + (lambda () + (old-violation-proc signature syntax msg blame) + obj))) + (lambda () + (let loop ((signatures signatures) + (obj obj)) + (if (null? signatures) + (lambda () obj) + (loop (cdr signatures) + (apply-signature (car signatures) obj)))))))))) + (delay syntax))) + +(define (make-case-signature name cases =? syntax) + (make-signature + name + (lambda (self obj) + (let loop ((cases cases)) + (cond + ((null? cases) + (signature-violation obj self #f #f) + obj) + ((=? (car cases) obj) + obj) + (else + (loop (cdr cases)))))) + (delay syntax) + #:arbitrary-promise + (delay (apply arbitrary-one-of =? cases)))) + +(define signature-key (gensym 'signature-key)) + +(define-struct procedure-signature-info (arg-signatures return-signature) #:transparent) + +(define (make-procedure-signature name arg-signatures return-signature syntax) + (let ((arg-count (length arg-signatures))) + (make-signature + name + (lambda (self thing) + (let-values (((proc blame-syntax) + (if (procedure-to-blame? thing) + (values (procedure-to-blame-proc thing) + (procedure-to-blame-syntax thing)) + (values thing #f)))) + (cond + ((not (procedure? proc)) + (signature-violation proc self #f #f) + thing) + ((not (procedure-arity-includes? proc arg-count)) ; #### variable arity + (signature-violation proc self parameter-count-mismatch-message #f) + thing) + (else + (attach-name + (object-name proc) + (procedure-reduce-arity + (lambda args + (call-with-immediate-continuation-mark + signature-key + (lambda (maybe) + (if (not (= (length args) arg-count)) + (begin + (signature-violation proc self argument-count-mismatch-message #f) + (apply-signature return-signature (apply proc args))) + (let* ((old-violation-proc (signature-violation-proc)) + (arg-violation? #f) + (args + (call-with-signature-violation-proc + (lambda (obj signature message blame) + (set! arg-violation? #t) + (old-violation-proc obj signature message blame)) + (lambda () + (map apply-signature arg-signatures args))))) + (if (eq? maybe return-signature) + (apply proc args) + (let ((retval + (with-continuation-mark + signature-key return-signature + (apply proc args)))) + (if arg-violation? + retval + (call-with-signature-violation-proc + (lambda (obj signature message _) + ;; blame the procedure + (old-violation-proc obj signature message blame-syntax)) + (lambda () + (apply-signature return-signature retval))))))))))) + (procedure-arity proc))))))) + (delay syntax) + #:arbitrary-promise + (delay + (apply lift->arbitrary arbitrary-procedure return-signature arg-signatures)) + #:info-promise + (delay + (make-procedure-signature-info arg-signatures return-signature))))) + +(define (attach-name name thing) + (if (and (procedure? thing) + (symbol? name)) + (procedure-rename thing name) + thing)) + +; Lazy signature checking for structs + +;; This is attached prop:lazy-wrap property of struct types subject to +;; lazy checking. +(define-struct lazy-wrap-info + (constructor + raw-accessors raw-mutators + ;; procedures for referencing or setting an additional field within the struct + ;; that field contains a list of lists of unchecked field signatures + ref-proc set!-proc)) + +; value should be a lazy-wrap-info +(define-values (prop:lazy-wrap lazy-wrap? lazy-wrap-ref) + (make-struct-type-property 'lazy-wrap)) + +; The field accessed by ref-proc and set!-proc contains one of these: + +(define-struct lazy-wrap-log + ;; list of lazy-log-not-checked + (not-checked + ;; list of lists of field signatures + checked) + #:transparent) + +; This situation makes trouble: +; (make-mixed-signature (make-lazy-wrap-signature ...) (make-lazy-wrap-signature ...) ...) + +; We need to push the `mixed' signature inside the lazy-wrap +; signature, which is why the struct-map signature has an implicit +; `mixed'. +; To this end, a `lazy-log-not-checked' object tracks a list of +; `mixed' alternatives. The `mixed-signature' field tracks from which +; `mixed' contract the mixture has originally come from. +; (It may be #f, in which case the `field-signatures-list' is a one-element list.) +(define-struct lazy-log-not-checked + (mixed-signature field-signatures-list) + #:transparent) + +(define (make-lazy-wrap-signature name type-descriptor predicate field-signatures syntax) + (really-make-lazy-wrap-signature name type-descriptor predicate #f (list field-signatures) syntax)) + +; The lists of signatures in `field-signatures-list' form an implicit mixed signature. +(define (really-make-lazy-wrap-signature name type-descriptor predicate + mixed-signature field-signatures-list + syntax) + (let ((lazy-wrap-info (lazy-wrap-ref type-descriptor)) + (not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list)) + (lazy-wrap-signature-info (make-lazy-wrap-signature-info type-descriptor predicate field-signatures-list))) + (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) + (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)) + (wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info)) + (wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info))) + (make-signature + name + (lambda (self thing) + + (if (not (predicate thing)) + (signature-violation thing self #f #f) + (let ((log (wrap-ref thing))) + (cond + ((not log) + (wrap-set! thing + (make-lazy-wrap-log (list not-checked) '()))) + ((not (let () + (define (<=? sigs1 sigs2) + (andmap signature<=? sigs1 sigs2)) + (define (check wrap-field-signatures) + (ormap (lambda (field-signatures) + (<=? wrap-field-signatures field-signatures)) + field-signatures-list)) + (or (ormap (lambda (wrap-not-checked) + (andmap check + (lazy-log-not-checked-field-signatures-list wrap-not-checked))) + (lazy-wrap-log-not-checked log)) + (ormap check (lazy-wrap-log-checked log))))) + (wrap-set! thing + (make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log)) + (lazy-wrap-log-checked log))))))) + + thing) + (delay syntax) + #:info-promise + (delay lazy-wrap-signature-info) + #:=?-proc + (lambda (this-info other-info) + (and (lazy-wrap-signature-info? other-info) + (lazy-wrap-signature-info-field-signatures-list other-info) + (eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info)) + (andmap (lambda (this-field-signatures) + (andmap (lambda (other-field-signatures) + (andmap signature=? this-field-signatures other-field-signatures)) + (lazy-wrap-signature-info-field-signatures-list other-info))) + (lazy-wrap-signature-info-field-signatures-list this-info)))) + #:<=?-proc + (lambda (this-info other-info) + (and (lazy-wrap-signature-info? other-info) + (lazy-wrap-signature-info-field-signatures-list other-info) + (eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info)) + (andmap (lambda (this-field-signatures) + (ormap (lambda (other-field-signatures) + (andmap signature<=? this-field-signatures other-field-signatures)) + (lazy-wrap-signature-info-field-signatures-list other-info))) + (lazy-wrap-signature-info-field-signatures-list this-info)))))))) + +(define-struct lazy-wrap-signature-info (descriptor predicate field-signatures-list) #:transparent) + +(define (check-lazy-wraps! descriptor thing) + (let ((lazy-wrap-info (lazy-wrap-ref descriptor))) + + (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) + (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)) + (raw-mutators (lazy-wrap-info-raw-mutators lazy-wrap-info)) + (wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info)) + (wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info))) + + (let ((log (wrap-ref thing))) + (when (and log (pair? (lazy-wrap-log-not-checked log))) + (let loop ((field-vals (map (lambda (raw-accessor) + (raw-accessor thing)) + raw-accessors)) + (now-checked '()) + (not-checkeds (lazy-wrap-log-not-checked log))) + (if (null? not-checkeds) + (begin + (for-each (lambda (raw-mutator field-val) + (raw-mutator thing field-val)) + raw-mutators field-vals) + (wrap-set! thing + (make-lazy-wrap-log '() + (append now-checked + (lazy-wrap-log-checked log))))) + (let ((not-checked (car not-checkeds))) + (let ((field-signatures-list (lazy-log-not-checked-field-signatures-list not-checked)) + (mixed-signature (lazy-log-not-checked-mixed-signature not-checked))) + (if (not mixed-signature) ; one-element list + (loop (map apply-signature (car field-signatures-list) field-vals) + (cons (car field-signatures-list) now-checked) + (cdr not-checkeds)) + (let inner ((field-signatures-list field-signatures-list)) ; implicit mixed + (if (null? field-signatures-list) + (signature-violation thing mixed-signature #f #f) + (let map ((sigs (car field-signatures-list)) + (field-vals field-vals) + (new-field-vals '())) + (if (null? sigs) + (loop (reverse new-field-vals) + (cons (car field-signatures-list) now-checked) + (cdr not-checkeds)) + (check-signature (car sigs) + (car field-vals) + (lambda (new-val) + (map (cdr sigs) + (cdr field-vals) + (cons new-val new-field-vals))) + (lambda () + (inner (cdr field-signatures-list)))))))))))))))))) + +; pushes down mixed contracts +(define (fold-lazy-wrap-signatures mixed-signature sigs) + (let ((lazy-wrap-sigs (make-hasheq))) ; maps a type descriptor to signatures + + (define (push-down-lazy-wrap-sigs) + (hash-map lazy-wrap-sigs + (lambda (type-desc signatures) + (really-make-lazy-wrap-signature + (signature-name (car signatures)) type-desc + (lazy-wrap-signature-info-predicate (real-signature-info (car signatures))) + mixed-signature + (apply append + (map (lambda (sig) + (lazy-wrap-signature-info-field-signatures-list (real-signature-info sig))) + signatures)) + (signature-syntax (car signatures)))))) + + (let loop ((sigs sigs) + (vanilla-sigs '())) + (if (null? sigs) + (append (push-down-lazy-wrap-sigs) + (reverse vanilla-sigs)) + (let* ((sig (car sigs)) + (info (real-signature-info sig))) + (if (lazy-wrap-signature-info? info) + (let ((type-desc (lazy-wrap-signature-info-descriptor info))) + (hash-update! lazy-wrap-sigs + type-desc + (lambda (old) + (cons sig old)) + (lambda () + (list sig))) + (loop (cdr sigs) vanilla-sigs)) + (loop (cdr sigs) (cons sig vanilla-sigs)))))))) + +(define checked-pair-table (make-weak-hasheq)) + +(define-struct checked-pair + (car cdr log) + #:mutable) + +(define (checked-pair-access checked-access raw-access) + (lambda (p) + (cond + ((hash-ref checked-pair-table + p + (lambda () #f)) + => checked-access) + (else (raw-access p))))) + +(define checked-raw-car (checked-pair-access checked-pair-car car)) +(define checked-raw-cdr (checked-pair-access checked-pair-cdr cdr)) + +(define (checked-raw-set! checked-set!) + (lambda (p new) + (cond + ((hash-ref checked-pair-table + p + (lambda () #f)) + => (lambda (cp) + (checked-set! cp new))) + (else + (let ((cp (make-checked-pair (car p) (cdr p) #f))) + (checked-set! cp new) + (hash-set! checked-pair-table p cp)))))) + +(define checked-raw-set-car! (checked-raw-set! set-checked-pair-car!)) +(define checked-raw-set-cdr! (checked-raw-set! set-checked-pair-cdr!)) + +(define (checked-pair-get-log p) + (cond + ((hash-ref checked-pair-table + p + (lambda () #f)) + => checked-pair-log) + (else #f))) + +(define (checked-pair-set-log! p new) + (cond + ((hash-ref checked-pair-table + p + (lambda () #f)) + => (lambda (cp) + (set-checked-pair-log! cp new))) + (else + (hash-set! checked-pair-table p + (make-checked-pair (car p) (cdr p) new))))) + +(define checked-pair-lazy-wrap-info + (make-lazy-wrap-info cons + (list checked-raw-car checked-raw-cdr) + (list checked-raw-set-car! checked-raw-set-cdr!) + checked-pair-get-log + checked-pair-set-log!)) + +(define checked-pair-descriptor + (call-with-values + (lambda () + (make-struct-type 'dummy-checked-pair #f 0 0 #f + (list + (cons prop:lazy-wrap checked-pair-lazy-wrap-info)))) + (lambda (desc . _) + desc))) + +(define (make-pair-signature car-sig cdr-sig) + (make-lazy-wrap-signature 'pair checked-pair-descriptor pair? (list car-sig cdr-sig) #'pair)) + +(define (checked-car p) + (car p) + (check-lazy-wraps! checked-pair-descriptor p) + (checked-raw-car p)) + +(define (checked-cdr p) + (cdr p) + (check-lazy-wraps! checked-pair-descriptor p) + (checked-raw-cdr p)) + +) \ No newline at end of file diff --git a/collects/deinprogramm/signature/signature.rkt b/collects/deinprogramm/signature/signature.rkt index c8740cf301..02dfda1637 100644 --- a/collects/deinprogramm/signature/signature.rkt +++ b/collects/deinprogramm/signature/signature.rkt @@ -1,31 +1,20 @@ #lang scheme/base -(provide signature? - signature-name signature-syntax +(provide make-signature signature? + signature-name signature-syntax signature-enforcer + signature-arbitrary-promise + signature-<=?-proc signature-=?-proc signature-arbitrary set-signature-arbitrary! signature-info-promise signature-violation signature-violation-proc call-with-signature-violation-proc - make-delayed-signature - make-call-signature - make-property-signature - make-predicate-signature - make-type-variable-signature - make-list-signature - make-mixed-signature - make-combined-signature - make-case-signature - make-procedure-signature signature-update-syntax signature-update-info-promise apply-signature apply-signature/blame - procedure-signature-info? - procedure-signature-info-arg-signatures procedure-signature-info-return-signature - make-lazy-wrap-info lazy-wrap-info-constructor lazy-wrap-info-raw-accessors - prop:lazy-wrap lazy-wrap? lazy-wrap-ref - make-lazy-wrap-signature - check-lazy-wraps! - make-pair-signature checked-car checked-cdr - signature=? signature<=?) + signature=? signature<=? + make-procedure-to-blame + procedure-to-blame? + procedure-to-blame-proc procedure-to-blame-syntax + make-type-variable-info type-variable-info?) (require scheme/promise mzlib/struct @@ -108,220 +97,6 @@ (parameterize ((signature-violation-proc proc)) (thunk))) -(define (make-delayed-signature name promise) - (make-signature name - (lambda (self obj) - ((signature-enforcer (force promise)) self obj)) - (delay (signature-syntax (force promise))) - #:arbitrary-promise - (delay - (force (signature-arbitrary-promise (force promise)))) - #:info-promise - (delay - (force (signature-info-promise (force promise)))) - #:<=?-proc - (lambda (this-info other-info) - ((signature-<=?-proc (force promise)) this-info other-info)) - #:=?-proc - (lambda (this-info other-info) - ((signature-=?-proc (force promise)) this-info other-info)))) - -; specialized version of the above, supports comparison -; the promise must produce the result of (proc . args), but its passed separately -; to give us the right location on backtrace -(define (make-call-signature name promise proc-promise args-promise syntax) - (make-signature name - (lambda (self obj) - ((signature-enforcer (force promise)) self obj)) - (delay syntax) - #:arbitrary-promise - (delay - (force (signature-arbitrary-promise (force promise)))) - #:info-promise - (delay - (make-call-info promise (force proc-promise) (force args-promise))) - #:=?-proc - (lambda (this-info other-info) - (and (call-info? other-info) - (eqv? (force proc-promise) (call-info-proc other-info)) - (equal? (force args-promise) (call-info-args other-info)))))) - -(define-struct call-info (promise proc args) #:transparent) - -; klude to support mixed -(define (real-signature-info sig) - (let ((raw-info (force (signature-info-promise sig)))) - (if (call-info? raw-info) - (real-signature-info (force (call-info-promise raw-info))) - (force raw-info)))) - -(define (make-property-signature name access signature syntax) - (let ((enforce (signature-enforcer signature))) - (make-signature name - (lambda (self obj) - (enforce self (access obj)) ; #### problematic: enforcement doesn't stick - obj) - syntax))) - -(define (make-predicate-signature name predicate-promise syntax) - (make-signature - name - (lambda (self obj) ; dynamic binding because of syntax remapping via `signature-update-syntax' - (if ((force predicate-promise) obj) - obj - (begin - (signature-violation obj self #f #f) - obj))) - (delay syntax) - #:info-promise - (delay (make-predicate-info (force predicate-promise))) - #:=?-proc - (lambda (this-info other-info) - (and (predicate-info? other-info) - (eq? (force predicate-promise) - (predicate-info-predicate other-info)))))) - -(define-struct predicate-info (predicate) #:transparent) - -(define (make-type-variable-signature name syntax) - (make-signature - name - (lambda (self obj) obj) - (delay syntax) - #:info-promise - (delay (make-type-variable-info)) - #:=?-proc - (lambda (this-info other-info) - (type-variable-info? other-info)))) - -(define-struct type-variable-info ()) - -; maps lists to pairs of signature, enforced value -(define lists-table (make-weak-hasheq)) - -(define (make-list-signature name arg-signature syntax) - (make-signature - name - (lambda (self obj) - ;;(write (list 'list obj) (current-error-port)) (newline (current-error-port)) - (let recur ((l obj)) - - (define (go-on) - (let ((enforced (cons (apply-signature arg-signature (car l)) - (recur (cdr l))))) - (hash-set! lists-table l (cons self enforced)) - (hash-set! lists-table enforced (cons self enforced)) - enforced)) - - (cond - ((null? l) - l) - ((not (pair? l)) - (signature-violation obj self #f #f) - obj) - ((hash-ref lists-table l #f) - => (lambda (seen) - ;;(write (list 'seen seen (eq? self (car seen))) (current-error-port)) (newline (current-error-port)) - (if (eq? self (car seen)) - (cdr seen) - (go-on)))) - (else - (go-on))))) - syntax - #:arbitrary-promise - (delay - (lift->arbitrary arbitrary-list arg-signature)) - #:info-promise - (delay (make-list-info arg-signature)) - #:=?-proc - (lambda (this-info other-info) - (and (list-info? other-info) - (signature=? arg-signature (list-info-arg-signature other-info)))))) - -(define-struct list-info (arg-signature) #:transparent) - -(define (lift->arbitrary proc . signatures) - (let ((arbitraries (map force (map signature-arbitrary-promise signatures)))) - (if (andmap values arbitraries) - (apply proc arbitraries) - #f))) - -(define (make-mixed-signature name alternative-signatures syntax) - (letrec ((alternative-signatures-promise - (delay - (normalize-mixed-signatures mixed-signature alternative-signatures))) - (mixed-signature - (make-signature - name - (lambda (self obj) - (let loop ((alternative-signatures (force alternative-signatures-promise))) - (cond - ((null? alternative-signatures) - (signature-violation obj self #f #f) - obj) - ((eq? (car alternative-signatures) self) - (raise - (make-exn:fail:contract - (string->immutable-string - (if name - (format "rekursive Signatur: ~a" name) - "rekursive Signatur")) - (current-continuation-marks)))) - (else - (check-signature (car alternative-signatures) - obj - values - (lambda () (loop (cdr alternative-signatures)))))))) - (delay syntax) - #:info-promise - (delay (make-mixed-info (force alternative-signatures-promise))) - #:arbitrary-promise - (delay - (let ((arbitraries (map force (map signature-arbitrary-promise (force alternative-signatures-promise))))) - (if (andmap values arbitraries) - (arbitrary-mixed - (map (lambda (sig arb) - (cons (signature->predicate sig) - arb)) - (force alternative-signatures-promise) arbitraries)) - #f))) - #:=?-proc - (lambda (this-info other-info) - (and (mixed-info? other-info) - (andmap signature=? - (mixed-info-signatures this-info) - (mixed-info-signatures other-info)))) - #:<=?-proc - (lambda (this-info other-info) - (and (mixed-info? other-info) - (mixed-signature<=? (mixed-info-signatures this-info) - (mixed-info-signatures other-info))))))) - mixed-signature)) - -(define (mixed-signature<=? sigs1 sigs2) - (andmap (lambda (sig1) - (ormap (lambda (sig2) - (signature<=? sig1 sig2)) - sigs2)) - sigs1)) - -; Flatten out mixed signatures, and fold in in the lazy-wrap -; signatures - -(define (normalize-mixed-signatures mixed-signature sigs) - (fold-lazy-wrap-signatures mixed-signature (flatten-mixed-signatures sigs))) - -(define (flatten-mixed-signatures sigs) - (apply append - (map (lambda (sig) - (let ((info (force (signature-info-promise sig)))) - (if (mixed-info? info) - (mixed-info-signatures info) - (list sig)))) - sigs))) - -(define-struct mixed-info (signatures) #:transparent) - (define (check-signature sig val success fail) ((let/ec exit (let ((enforced @@ -336,392 +111,9 @@ (lambda (val) (check-signature sig val (lambda (_) #t) (lambda () #f)))) -(define (make-combined-signature name signatures syntax) - (make-signature - name - (lambda (self obj) - (let ((old-violation-proc (signature-violation-proc))) - ((let/ec exit - (call-with-signature-violation-proc - (lambda (signature syntax msg blame) - (exit - (lambda () - (old-violation-proc signature syntax msg blame) - obj))) - (lambda () - (let loop ((signatures signatures) - (obj obj)) - (if (null? signatures) - (lambda () obj) - (loop (cdr signatures) - (apply-signature (car signatures) obj)))))))))) - (delay syntax))) - -(define (make-case-signature name cases =? syntax) - (make-signature - name - (lambda (self obj) - (let loop ((cases cases)) - (cond - ((null? cases) - (signature-violation obj self #f #f) - obj) - ((=? (car cases) obj) - obj) - (else - (loop (cdr cases)))))) - (delay syntax) - #:arbitrary-promise - (delay (apply arbitrary-one-of =? cases)))) - (define-struct procedure-to-blame (proc syntax) #:property prop:procedure 0) - -(define signature-key (gensym 'signature-key)) - -(define-struct procedure-signature-info (arg-signatures return-signature) #:transparent) - -(define (make-procedure-signature name arg-signatures return-signature syntax) - (let ((arg-count (length arg-signatures))) - (make-signature - name - (lambda (self thing) - (let-values (((proc blame-syntax) - (if (procedure-to-blame? thing) - (values (procedure-to-blame-proc thing) - (procedure-to-blame-syntax thing)) - (values thing #f)))) - (cond - ((not (procedure? proc)) - (signature-violation proc self #f #f) - thing) - ((not (procedure-arity-includes? proc arg-count)) ; #### variable arity - (signature-violation proc self "falsche Anzahl von Parametern" #f) - thing) - (else - (attach-name - (object-name proc) - (procedure-reduce-arity - (lambda args - (call-with-immediate-continuation-mark - signature-key - (lambda (maybe) - (if (not (= (length args) arg-count)) - (begin - (signature-violation proc self "falsche Anzahl von Argumenten" #f) - (apply-signature return-signature (apply proc args))) - (let* ((old-violation-proc (signature-violation-proc)) - (arg-violation? #f) - (args - (call-with-signature-violation-proc - (lambda (obj signature message blame) - (set! arg-violation? #t) - (old-violation-proc obj signature message blame)) - (lambda () - (map apply-signature arg-signatures args))))) - (if (eq? maybe return-signature) - (apply proc args) - (let ((retval - (with-continuation-mark - signature-key return-signature - (apply proc args)))) - (if arg-violation? - retval - (call-with-signature-violation-proc - (lambda (obj signature message _) - ;; blame the procedure - (old-violation-proc obj signature message blame-syntax)) - (lambda () - (apply-signature return-signature retval))))))))))) - (procedure-arity proc))))))) - (delay syntax) - #:arbitrary-promise - (delay - (apply lift->arbitrary arbitrary-procedure return-signature arg-signatures)) - #:info-promise - (delay - (make-procedure-signature-info arg-signatures return-signature))))) - -(define (attach-name name thing) - (if (and (procedure? thing) - (symbol? name)) - (procedure-rename thing name) - thing)) - -; Lazy signature checking for structs - -;; This is attached prop:lazy-wrap property of struct types subject to -;; lazy checking. -(define-struct lazy-wrap-info - (constructor - raw-accessors raw-mutators - ;; procedures for referencing or setting an additional field within the struct - ;; that field contains a list of lists of unchecked field signatures - ref-proc set!-proc)) - -; value should be a lazy-wrap-info -(define-values (prop:lazy-wrap lazy-wrap? lazy-wrap-ref) - (make-struct-type-property 'lazy-wrap)) - -; The field accessed by ref-proc and set!-proc contains one of these: - -(define-struct lazy-wrap-log - ;; list of lazy-log-not-checked - (not-checked - ;; list of lists of field signatures - checked) - #:transparent) - -; This situation makes trouble: -; (make-mixed-signature (make-lazy-wrap-signature ...) (make-lazy-wrap-signature ...) ...) - -; We need to push the `mixed' signature inside the lazy-wrap -; signature, which is why the struct-map signature has an implicit -; `mixed'. -; To this end, a `lazy-log-not-checked' object tracks a list of -; `mixed' alternatives. The `mixed-signature' field tracks from which -; `mixed' contract the mixture has originally come from. -; (It may be #f, in which case the `field-signatures-list' is a one-element list.) -(define-struct lazy-log-not-checked - (mixed-signature field-signatures-list) - #:transparent) - -(define (make-lazy-wrap-signature name type-descriptor predicate field-signatures syntax) - (really-make-lazy-wrap-signature name type-descriptor predicate #f (list field-signatures) syntax)) - -; The lists of signatures in `field-signatures-list' form an implicit mixed signature. -(define (really-make-lazy-wrap-signature name type-descriptor predicate - mixed-signature field-signatures-list - syntax) - (let ((lazy-wrap-info (lazy-wrap-ref type-descriptor)) - (not-checked (make-lazy-log-not-checked mixed-signature field-signatures-list)) - (lazy-wrap-signature-info (make-lazy-wrap-signature-info type-descriptor predicate field-signatures-list))) - (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) - (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)) - (wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info)) - (wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info))) - (make-signature - name - (lambda (self thing) - - (if (not (predicate thing)) - (signature-violation thing self #f #f) - (let ((log (wrap-ref thing))) - (cond - ((not log) - (wrap-set! thing - (make-lazy-wrap-log (list not-checked) '()))) - ((not (let () - (define (<=? sigs1 sigs2) - (andmap signature<=? sigs1 sigs2)) - (define (check wrap-field-signatures) - (ormap (lambda (field-signatures) - (<=? wrap-field-signatures field-signatures)) - field-signatures-list)) - (or (ormap (lambda (wrap-not-checked) - (andmap check - (lazy-log-not-checked-field-signatures-list wrap-not-checked))) - (lazy-wrap-log-not-checked log)) - (ormap check (lazy-wrap-log-checked log))))) - (wrap-set! thing - (make-lazy-wrap-log (cons not-checked (lazy-wrap-log-not-checked log)) - (lazy-wrap-log-checked log))))))) - - thing) - (delay syntax) - #:info-promise - (delay lazy-wrap-signature-info) - #:=?-proc - (lambda (this-info other-info) - (and (lazy-wrap-signature-info? other-info) - (lazy-wrap-signature-info-field-signatures-list other-info) - (eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info)) - (andmap (lambda (this-field-signatures) - (andmap (lambda (other-field-signatures) - (andmap signature=? this-field-signatures other-field-signatures)) - (lazy-wrap-signature-info-field-signatures-list other-info))) - (lazy-wrap-signature-info-field-signatures-list this-info)))) - #:<=?-proc - (lambda (this-info other-info) - (and (lazy-wrap-signature-info? other-info) - (lazy-wrap-signature-info-field-signatures-list other-info) - (eq? type-descriptor (lazy-wrap-signature-info-descriptor other-info)) - (andmap (lambda (this-field-signatures) - (ormap (lambda (other-field-signatures) - (andmap signature<=? this-field-signatures other-field-signatures)) - (lazy-wrap-signature-info-field-signatures-list other-info))) - (lazy-wrap-signature-info-field-signatures-list this-info)))))))) - -(define-struct lazy-wrap-signature-info (descriptor predicate field-signatures-list) #:transparent) - -(define (check-lazy-wraps! descriptor thing) - (let ((lazy-wrap-info (lazy-wrap-ref descriptor))) - - (let ((constructor (lazy-wrap-info-constructor lazy-wrap-info)) - (raw-accessors (lazy-wrap-info-raw-accessors lazy-wrap-info)) - (raw-mutators (lazy-wrap-info-raw-mutators lazy-wrap-info)) - (wrap-ref (lazy-wrap-info-ref-proc lazy-wrap-info)) - (wrap-set! (lazy-wrap-info-set!-proc lazy-wrap-info))) - - (let ((log (wrap-ref thing))) - (when (and log (pair? (lazy-wrap-log-not-checked log))) - (let loop ((field-vals (map (lambda (raw-accessor) - (raw-accessor thing)) - raw-accessors)) - (now-checked '()) - (not-checkeds (lazy-wrap-log-not-checked log))) - (if (null? not-checkeds) - (begin - (for-each (lambda (raw-mutator field-val) - (raw-mutator thing field-val)) - raw-mutators field-vals) - (wrap-set! thing - (make-lazy-wrap-log '() - (append now-checked - (lazy-wrap-log-checked log))))) - (let ((not-checked (car not-checkeds))) - (let ((field-signatures-list (lazy-log-not-checked-field-signatures-list not-checked)) - (mixed-signature (lazy-log-not-checked-mixed-signature not-checked))) - (if (not mixed-signature) ; one-element list - (loop (map apply-signature (car field-signatures-list) field-vals) - (cons (car field-signatures-list) now-checked) - (cdr not-checkeds)) - (let inner ((field-signatures-list field-signatures-list)) ; implicit mixed - (if (null? field-signatures-list) - (signature-violation thing mixed-signature #f #f) - (let map ((sigs (car field-signatures-list)) - (field-vals field-vals) - (new-field-vals '())) - (if (null? sigs) - (loop (reverse new-field-vals) - (cons (car field-signatures-list) now-checked) - (cdr not-checkeds)) - (check-signature (car sigs) - (car field-vals) - (lambda (new-val) - (map (cdr sigs) - (cdr field-vals) - (cons new-val new-field-vals))) - (lambda () - (inner (cdr field-signatures-list)))))))))))))))))) - -; pushes down mixed contracts -(define (fold-lazy-wrap-signatures mixed-signature sigs) - (let ((lazy-wrap-sigs (make-hasheq))) ; maps a type descriptor to signatures - - (define (push-down-lazy-wrap-sigs) - (hash-map lazy-wrap-sigs - (lambda (type-desc signatures) - (really-make-lazy-wrap-signature - (signature-name (car signatures)) type-desc - (lazy-wrap-signature-info-predicate (real-signature-info (car signatures))) - mixed-signature - (apply append - (map (lambda (sig) - (lazy-wrap-signature-info-field-signatures-list (real-signature-info sig))) - signatures)) - (signature-syntax (car signatures)))))) - - (let loop ((sigs sigs) - (vanilla-sigs '())) - (if (null? sigs) - (append (push-down-lazy-wrap-sigs) - (reverse vanilla-sigs)) - (let* ((sig (car sigs)) - (info (real-signature-info sig))) - (if (lazy-wrap-signature-info? info) - (let ((type-desc (lazy-wrap-signature-info-descriptor info))) - (hash-update! lazy-wrap-sigs - type-desc - (lambda (old) - (cons sig old)) - (lambda () - (list sig))) - (loop (cdr sigs) vanilla-sigs)) - (loop (cdr sigs) (cons sig vanilla-sigs)))))))) - -(define checked-pair-table (make-weak-hasheq)) - -(define-struct checked-pair - (car cdr log) - #:mutable) - -(define (checked-pair-access checked-access raw-access) - (lambda (p) - (cond - ((hash-ref checked-pair-table - p - (lambda () #f)) - => checked-access) - (else (raw-access p))))) - -(define checked-raw-car (checked-pair-access checked-pair-car car)) -(define checked-raw-cdr (checked-pair-access checked-pair-cdr cdr)) - -(define (checked-raw-set! checked-set!) - (lambda (p new) - (cond - ((hash-ref checked-pair-table - p - (lambda () #f)) - => (lambda (cp) - (checked-set! cp new))) - (else - (let ((cp (make-checked-pair (car p) (cdr p) #f))) - (checked-set! cp new) - (hash-set! checked-pair-table p cp)))))) - -(define checked-raw-set-car! (checked-raw-set! set-checked-pair-car!)) -(define checked-raw-set-cdr! (checked-raw-set! set-checked-pair-cdr!)) - -(define (checked-pair-get-log p) - (cond - ((hash-ref checked-pair-table - p - (lambda () #f)) - => checked-pair-log) - (else #f))) - -(define (checked-pair-set-log! p new) - (cond - ((hash-ref checked-pair-table - p - (lambda () #f)) - => (lambda (cp) - (set-checked-pair-log! cp new))) - (else - (hash-set! checked-pair-table p - (make-checked-pair (car p) (cdr p) new))))) - -(define checked-pair-lazy-wrap-info - (make-lazy-wrap-info cons - (list checked-raw-car checked-raw-cdr) - (list checked-raw-set-car! checked-raw-set-cdr!) - checked-pair-get-log - checked-pair-set-log!)) - -(define checked-pair-descriptor - (call-with-values - (lambda () - (make-struct-type 'dummy-checked-pair #f 0 0 #f - (list - (cons prop:lazy-wrap checked-pair-lazy-wrap-info)))) - (lambda (desc . _) - desc))) - -(define (make-pair-signature car-sig cdr-sig) - (make-lazy-wrap-signature 'pair checked-pair-descriptor pair? (list car-sig cdr-sig) #'pair)) - -(define (checked-car p) - (car p) - (check-lazy-wraps! checked-pair-descriptor p) - (checked-raw-car p)) - -(define (checked-cdr p) - (cdr p) - (check-lazy-wraps! checked-pair-descriptor p) - (checked-raw-cdr p)) - + ; like apply-signature, but can track more precise blame into the signature itself (define-syntax apply-signature/blame (lambda (stx) @@ -754,6 +146,8 @@ (define (apply-signature signature val) ((signature-enforcer signature) signature val)) +(define-struct type-variable-info ()) + ; "do the values that fulfill c1 also fulfill c2?" (define (signature<=? c1 c2) (or (signature=? c1 c2) @@ -762,5 +156,3 @@ (or (type-variable-info? i2) ; kludge, maybe dispatch should be on second arg (and i1 i2 ((signature-<=?-proc c1) i1 i2)))))) - - diff --git a/collects/lang/private/signature-syntax.rkt b/collects/lang/private/signature-syntax.rkt index 46ed9ba0b3..f12e901d3f 100644 --- a/collects/lang/private/signature-syntax.rkt +++ b/collects/lang/private/signature-syntax.rkt @@ -6,6 +6,7 @@ -> mixed one-of predicate combined property list-of) (require deinprogramm/signature/signature + deinprogramm/signature/signature-english scheme/promise (for-syntax scheme/base) (for-syntax syntax/stx) diff --git a/collects/lang/private/teach.rkt b/collects/lang/private/teach.rkt index b27591eb3e..870ec16986 100644 --- a/collects/lang/private/teach.rkt +++ b/collects/lang/private/teach.rkt @@ -42,6 +42,7 @@ "set-result.ss" (only racket/base define-struct) racket/struct-info + deinprogramm/signature/signature-english (all-except deinprogramm/signature/signature signature-violation) (all-except lang/private/signature-syntax property) (rename lang/private/signature-syntax signature:property property) diff --git a/collects/lang/private/teachprims.rkt b/collects/lang/private/teachprims.rkt index de9be9b6be..755a3147c5 100644 --- a/collects/lang/private/teachprims.rkt +++ b/collects/lang/private/teachprims.rkt @@ -17,7 +17,8 @@ namespace. (require mzlib/list mzlib/math mzlib/etc - deinprogramm/signature/signature) + deinprogramm/signature/signature + deinprogramm/signature/signature-english) (define-syntax (define-teach stx) (syntax-case stx () diff --git a/collects/tests/deinprogramm/signature.rkt b/collects/tests/deinprogramm/signature.rkt index c274973287..6543b7419f 100644 --- a/collects/tests/deinprogramm/signature.rkt +++ b/collects/tests/deinprogramm/signature.rkt @@ -5,6 +5,7 @@ (require rackunit deinprogramm/define-record-procedures deinprogramm/signature/signature + deinprogramm/signature/signature-german deinprogramm/signature/signature-syntax) (require scheme/promise)