1#lang racket/base 2 3(provide beginner-module-begin vanilla-module-begin advanced-module-begin) 4 5(require deinprogramm/signature/signature 6 deinprogramm/signature/signature-syntax) 7 8(require (for-syntax racket/base) 9 (for-syntax racket/list) 10 (for-syntax syntax/boundmap) 11 (for-syntax syntax/id-table) 12 (for-syntax syntax/kerncase) 13 (for-syntax racket/struct-info)) 14 15(require (only-in test-engine/syntax test)) 16 17(define-syntax (print-results stx) 18 (syntax-case stx () 19 ((_ expr) 20 (not (or (syntax-property #'expr 'stepper-hide-completed) 21 (syntax-property #'expr 'stepper-skip-completely) 22 (syntax-property #'expr 'test-call))) 23 (syntax-property 24 (syntax-property 25 #'(#%app call-with-values (lambda () expr) 26 do-print-results) 27 'stepper-skipto 28 '(syntax-e cdr cdr car syntax-e cdr cdr car)) 29 'certify-mode 30 'transparent)) 31 ((_ expr) #'expr))) 32 33(define (do-print-results . vs) 34 (for-each (current-print) vs) 35 ;; Returning 0 values avoids any further result printing 36 ;; (even if void values are printed) 37 (values)) 38 39(define-syntaxes (beginner-module-begin vanilla-module-begin advanced-module-begin module-continue) 40 (let () 41 ;; takes a list of syntax objects (the result of syntax-e) and returns all the syntax objects that correspond to 42 ;; a signature declaration. Syntax: (: id signature) 43 (define extract-signatures 44 (lambda (lostx) 45 (let* ((table (make-free-id-table)) ; bound doesn't work as we need to match signature declarations and definitions 46 (non-signatures 47 (filter-map (lambda (maybe) 48 (syntax-case maybe (:) 49 ((: ?exp ?sig) 50 (not (identifier? #'?exp)) 51 #'(apply-signature/blame (signature ?sig) ?exp)) 52 ((: ?id ?sig) 53 (begin 54 (cond 55 ((free-id-table-ref table #'?id #f) 56 => (lambda (old-sig-stx) 57 (unless (equal? (syntax->datum old-sig-stx) 58 (syntax->datum #'?sig)) 59 (raise-syntax-error #f 60 "Zweite Signaturdeklaration für denselben Namen." 61 maybe)))) 62 (else 63 (let ((si (syntax-local-value #'?id (lambda () #f)))) 64 (if (and (struct-info? si) 65 (procedure? si)) ; record constructor, just a macro 66 (free-id-table-set! table (si #'?id) #'?sig) 67 (free-id-table-set! table #'?id #'?sig))))) 68 #f)) 69 ((: ?id) 70 (raise-syntax-error #f "Bei dieser Signaturdeklaration fehlt die Signatur" maybe)) 71 ((: ?id ?sig ?stuff0 ?stuff1 ...) 72 (raise-syntax-error #f "In der :-Form werden ein Name und eine Signatur erwartet; da steht noch mehr" 73 (syntax/loc #'?stuff0 74 (?stuff0 ?stuff1 ...)))) 75 (_ maybe))) 76 lostx))) 77 (values table non-signatures)))) 78 79 (define local-expand-stop-list 80 (append (list #': #'define-contract) 81 (kernel-form-identifier-list))) 82 83 (define (expand-signature-expressions signature-table expressions) 84 85 (let loop ((exprs expressions)) 86 87 (cond 88 ((null? exprs) 89 ; check for orphaned signatures 90 (free-id-table-for-each signature-table 91 (lambda (id thing) 92 (if (identifier-binding id) 93 (raise-syntax-error #f "Zu einer eingebauten Form kann keine Signatur deklariert werden" id) 94 (raise-syntax-error #f "Zu dieser Signatur gibt es keine Definition" id)))) 95 #'(begin)) 96 (else 97 (let ((expanded (car exprs))) 98 99 (syntax-case expanded (begin define-values) 100 ((define-values (?id ...) ?e1) 101 (with-syntax (((?enforced ...) 102 (map (lambda (id) 103 (cond 104 ((free-id-table-ref signature-table id #f) 105 => (lambda (sig) 106 (free-id-table-remove! signature-table id) ; enables the check for orphaned signatures 107 (with-syntax ((?id id) 108 (?sig sig)) 109 #'(?id (signature ?sig))))) 110 (else id))) 111 (syntax->list #'(?id ...)))) 112 (?rest (loop (cdr exprs)))) 113 (with-syntax ((?defn 114 (syntax-track-origin 115 #'(define-values/signature (?enforced ...) 116 ?e1) 117 (car exprs) 118 (car (syntax-e expanded))))) 119 120 (syntax/loc (car exprs) 121 (begin 122 ?defn 123 ?rest))))) 124 ((begin e1 ...) 125 (loop (append (syntax-e (syntax (e1 ...))) (cdr exprs)))) 126 (else 127 (with-syntax ((?first expanded) 128 (?rest (loop (cdr exprs)))) 129 (syntax/loc (car exprs) 130 (begin 131 ?first ?rest)))))))))) 132 133 (define (mk-module-begin options) 134 (lambda (stx) 135 (syntax-case stx () 136 ((_ e1 ...) 137 ;; module-begin-continue takes a sequence of expanded 138 ;; exprs and a sequence of to-expand exprs; that way, 139 ;; the module-expansion machinery can be used to handle 140 ;; requires, etc.: 141 #`(#%plain-module-begin 142 (module-continue (e1 ...) () ()) 143 (module configure-runtime racket/base 144 (require deinprogramm/sdp/private/runtime) 145 (configure '#,options)) 146 (module+ test (test))))))) 147 148 (values 149 (mk-module-begin 'beginner) 150 (mk-module-begin 'vanilla) 151 (mk-module-begin 'advanced) 152 153 ;; module-continue 154 (lambda (stx) 155 (syntax-case stx () 156 ((_ () (e1 ...) (defined-id ...)) 157 ;; Local-expanded all body elements, lifted out requires, etc. 158 ;; Now process the result. 159 (begin 160 ;; The expansion for signatures breaks the way that beginner-define, etc., 161 ;; check for duplicate definitions, so we have to re-check here. 162 ;; A better strategy might be to turn every define into a define-syntax 163 ;; to redirect the binding, and then the identifier-binding check in 164 ;; beginner-define, etc. will work. 165 (let ((defined-ids (make-bound-identifier-mapping))) 166 (for-each (lambda (id) 167 (when (bound-identifier-mapping-get defined-ids id (lambda () #f)) 168 (raise-syntax-error 169 #f 170 "Für diesen Namen gibt es schon eine Definition." 171 id)) 172 (bound-identifier-mapping-put! defined-ids id #t)) 173 (reverse (syntax->list #'(defined-id ...))))) 174 ;; Now handle signatures: 175 (let ((top-level (reverse (syntax->list (syntax (e1 ...)))))) 176 (let-values (((sig-table expr-list) 177 (extract-signatures top-level))) 178 (expand-signature-expressions sig-table expr-list))))) 179 ((frm e3s e1s def-ids) 180 (let loop ((e3s #'e3s) 181 (e1s #'e1s) 182 (def-ids #'def-ids)) 183 (syntax-case e3s () 184 (() 185 #`(frm () #,e1s #,def-ids)) 186 ((e2 . e3s) 187 (let ((e2 (local-expand #'e2 'module local-expand-stop-list))) 188 ;; Lift out certain forms to make them visible to the module 189 ;; expander: 190 (syntax-case e2 (#%require #%provide #%declare 191 define-syntaxes begin-for-syntax define-values begin 192 :) 193 ((#%require . __) 194 #`(begin #,e2 (frm e3s #,e1s #,def-ids))) 195 ((#%provide . __) 196 #`(begin #,e2 (frm e3s #,e1s #,def-ids))) 197 ((#%declare . __) 198 #`(begin #,e2 (frm e3s #,e1s #,def-ids))) 199 ((define-syntaxes (id ...) . _) 200 #`(begin #,e2 (frm e3s #,e1s (id ... . #,def-ids)))) 201 ((begin-for-syntax . _) 202 #`(begin #,e2 (frm e3s #,e1s #,def-ids))) 203 ((begin b1 ...) 204 (syntax-track-origin 205 (loop (append (syntax->list #'(b1 ...)) #'e3s) e1s def-ids) 206 e2 207 (car (syntax-e e2)))) 208 ((define-values (id ...) . _) 209 (loop #'e3s (cons e2 e1s) (append (syntax->list #'(id ...)) def-ids))) 210 ((: stuff ...) 211 (loop #'e3s (cons e2 e1s) def-ids)) 212 (_ 213 (loop #'e3s (cons #`(print-results #,e2) e1s) def-ids))))))))))))) 214