1#lang racket/base 2(require (for-syntax racket/base 3 syntax/define 4 syntax/boundmap 5 racket/pretty)) 6 7(provide define-package 8 package-begin 9 10 open-package 11 open*-package 12 13 define* 14 define*-values 15 define*-syntax 16 define*-syntaxes 17 18 (for-syntax package? 19 package-exported-identifiers 20 package-original-identifiers)) 21 22 23;; For permission to move scopes from a definition in a package 24;; to a binding of the identifier when the package is opened: 25(define-for-syntax code-insp 26 (variable-reference->module-declaration-inspector 27 (#%variable-reference))) 28 29;; ---------------------------------------- 30 31(begin-for-syntax 32 (struct package (root-id sig-ids impl-ids)) 33 34 (define (get-package who id) 35 (let ([p (syntax-local-value id (lambda () #f))]) 36 (unless (package? p) 37 (error who 38 "not defined as a package\n identifier: ~a" 39 id)))) 40 41 (define (package-exported-identifiers id) 42 (define p (get-package 'package-exported-identifiers id)) 43 (map 44 (lambda (sig-id) 45 (make-syntax-delta-introducer sig-id (package-root-id p)) 46 (datum->syntax id (syntax-e sig-id) sig-id sig-id)) 47 (syntax->list (package-sig-ids p)))) 48 49 (define (package-original-identifiers id) 50 (define p (get-package 'package-original-identifiers id)) 51 (syntax->list (package-impl-ids p)))) 52 53(define-syntax (define-package stx) 54 (check-definition-context stx) 55 (syntax-case stx () 56 [(_ id . _) 57 (let ([id #'id]) 58 (unless (identifier? id) 59 (raise-syntax-error #f 60 "expected an identifier for the package name" 61 stx 62 id)) 63 (define (accumulate exports forms) 64 (define intro (make-syntax-introducer #t)) 65 #`(drive-top-level 66 (accumulate-package #,id #,(intro id) #,(intro id) #f #,stx 67 #,exports 68 () 69 #,(intro forms)))) 70 (syntax-case stx () 71 [(_ _ #:only (export-id ...) form ...) 72 (accumulate #'(#:only (export-id ...)) #'(form ...))] 73 [(_ _ #:all-defined-except (export-id ...) form ...) 74 (accumulate #'(#:all-defined-except (export-id ...)) #'(form ...))] 75 [(_ _ #:all-defined form ...) 76 (accumulate #'(#:all-defined-except ()) #'(form ...))] 77 [(_ _ (export-id ...) form ...) 78 (accumulate #'(#:only (export-id ...)) #'(form ...))]))])) 79 80(define-syntax (accumulate-package stx) 81 (syntax-case stx () 82 [(_ id intro-id star-id any-stars? orig-form exports defined-ids (form . forms)) 83 (let ([exp-form (local-expand #'form 84 (list (gensym)) 85 (list #'define-values 86 #'-define*-values 87 #'define-syntaxes 88 #'-define*-syntaxes 89 #'begin) 90 #f)]) 91 (syntax-case exp-form (begin) 92 [(begin seq-form ...) 93 #`(accumulate-package id intro-id star-id any-stars? orig-form 94 exports 95 defined-ids 96 (seq-form ... . forms))] 97 [(def (new-def-id ...) rhs) 98 (or (free-identifier=? #'def #'define-values) 99 (free-identifier=? #'def #'define-syntaxes) 100 (free-identifier=? #'def #'-define*-values) 101 (free-identifier=? #'def #'-define*-syntaxes)) 102 (let* ([star? (or (free-identifier=? #'def #'-define*-values) 103 (free-identifier=? #'def #'-define*-syntaxes))] 104 [next-intro (if star? 105 (make-syntax-introducer #t) 106 (lambda (s) s))] 107 [exp-form 108 (with-syntax ([(new-def-id ...) (if star? 109 ;; Add another scope layer: 110 (next-intro #'(new-def-id ...)) 111 ;; Remove star layers: 112 ((make-syntax-delta-introducer #'star-id #'intro-id) 113 #'(new-def-id ...) 114 'remove))]) 115 (syntax/loc exp-form 116 (def (new-def-id ...) rhs)))]) 117 (with-syntax ([(_ (new-def-id ...) _) exp-form]) ; sync with above adjustments to `new-def-id` 118 (when (and (not star?) 119 (syntax-e #'any-stars?)) 120 ;; Make sure that a name is not defined with `define` if 121 ;; there's a preceeding `define*` 122 (let ([intro (make-syntax-delta-introducer #'star-id #'intro-id)]) 123 (for ([id (in-list (syntax->list #'(new-def-id ...)))]) 124 (unless (free-identifier=? id (intro id)) 125 (raise-syntax-error #f 126 "duplicate definition for identifier" 127 #'orig-form 128 id))))) 129 ;; Let definition out of `accumulate-package` form, accumulate new 130 ;; defintions, and continue with the rest of the package body: 131 (with-syntax ([forms (next-intro #'forms)] 132 [star-id (next-intro #'star-id)] 133 [any-stars? (or star? (syntax-e #'any-stars?))]) 134 #`(begin 135 #,exp-form 136 (accumulate-package id intro-id star-id any-stars? orig-form 137 exports 138 (new-def-id ... . defined-ids) 139 forms)))))] 140 [_ 141 (and (not (syntax-e #'id)) 142 (null? (syntax-e #'forms))) 143 ;; Allow last expression to produce a result for `package-begin` 144 exp-form] 145 [_ 146 #`(begin 147 (begin0 (void) #,exp-form) 148 (accumulate-package id intro-id star-id any-stars? orig-form 149 exports 150 defined-ids 151 forms))]))] 152 [(_ #f #f #f _ orig-form exports defined-ids ()) 153 ;; Last thing in `begin-package` was a definition; add a `(void)` 154 #'(void)] 155 [(_ id intro-id star-id any-stars? orig-form exports defined-ids ()) 156 (let () 157 (define (find-ids ids keep?) 158 (define intro (make-syntax-delta-introducer #'star-id #'id)) 159 (let ([ids (syntax->list ids)] 160 [defined-ids (syntax->list #'defined-ids)]) 161 (define defined-bindings (make-bound-identifier-mapping)) 162 ;; `defined-ids` were accumulated in reverse order; add them 163 ;; in the original order, so that we end up with the last 164 ;; definition of each equilavent id (in the case of `define*`s 165 (for-each 166 (lambda (defined-id) 167 (bound-identifier-mapping-put! defined-bindings 168 (syntax-local-identifier-as-binding 169 (intro defined-id 'remove)) 170 defined-id)) 171 (reverse defined-ids)) 172 ;; Check that each explicitly named `id` is defined: 173 (define mentioned-ids (make-bound-identifier-mapping)) 174 (for-each (lambda (id) 175 (define bind-id (syntax-local-identifier-as-binding 176 id)) 177 (unless (bound-identifier-mapping-get defined-bindings 178 bind-id 179 (lambda () #f)) 180 (raise-syntax-error #f 181 "identifier not defined within the package" 182 #'orig-form 183 id)) 184 (bound-identifier-mapping-put! mentioned-ids 185 bind-id 186 #t)) 187 ids) 188 ;; Get identifiers that should be exported: 189 (filter 190 values 191 (bound-identifier-mapping-map 192 defined-bindings 193 (lambda (bind-id defined-id) 194 (and (keep? (bound-identifier-mapping-get mentioned-ids bind-id 195 (lambda () #f))) 196 (cons bind-id 197 defined-id))))))) 198 (define mapping 199 (syntax-case #'exports () 200 [(#:only (id ...)) 201 (find-ids #'(id ...) values)] 202 [(#:all-defined-except (id ...)) 203 (find-ids #'(id ...) not)])) 204 (cond 205 [(not (syntax-e #'id)) 206 #'(begin)] 207 [else 208 #`(define-syntax id (package (quote-syntax star-id) 209 (quote-syntax #,(map car mapping)) 210 (quote-syntax #,(map cdr mapping))))]))])) 211 212(define-for-syntax (do-open-package stx def-stxes) 213 (check-definition-context stx) 214 (syntax-case stx () 215 [(_ id) 216 (let ([id #'id]) 217 (unless (identifier? id) 218 (raise-syntax-error #f 219 "not an identifier for a package to open" 220 stx 221 id)) 222 (let ([p (syntax-local-value id (lambda () #f))]) 223 (unless (package? p) 224 (raise-syntax-error #f 225 "not defined as a package" 226 stx 227 id)) 228 (define (locally sig-id) 229 (define local-id 230 ((make-syntax-delta-introducer (syntax-disarm sig-id code-insp) (package-root-id p)) 231 (datum->syntax (syntax-disarm id code-insp) (syntax-e sig-id) sig-id sig-id))) 232 (syntax-rearm (syntax-rearm local-id sig-id) id)) 233 #`(begin 234 #,@(map (lambda (sig-id impl-id) 235 #`(#,def-stxes (#,(locally sig-id)) 236 (make-rename-transformer (quote-syntax #,impl-id)))) 237 (syntax->list (package-sig-ids p)) 238 (syntax->list (syntax-local-introduce (package-impl-ids p)))))))])) 239 240(define-syntax (open-package stx) 241 (do-open-package stx #'define-syntaxes)) 242(define-syntax (open*-package stx) 243 (do-open-package stx #'define*-syntaxes)) 244 245(define-syntax (package-begin stx) 246 (if (eq? 'expression (syntax-local-context)) 247 #`(let () #,stx) 248 (syntax-case stx () 249 [(_ form ...) 250 #`(drive-top-level 251 (accumulate-package #f id id #f #,stx 252 (#:only ()) 253 () 254 #,((make-syntax-introducer) 255 #'(form ...))))]))) 256 257(define-for-syntax (check-definition-context stx) 258 (when (eq? 'expression (syntax-local-context)) 259 (raise-syntax-error #f 260 "not in a definition context" 261 stx))) 262 263;; ---------------------------------------- 264 265(define-syntax (drive-top-level stx) 266 (syntax-case stx () 267 [(_ form) 268 (cond 269 [(eq? 'top-level (syntax-local-context)) 270 ;; In a opt-level context, we need to use the `(define-syntaxes 271 ;; (...) (values))` trick to introduce all defined names before 272 ;; expanding expressions. 273 #'(accumulate-top-level () (form))] 274 [else 275 ;; No special treatment needed: 276 #'form])])) 277 278(define-syntax (accumulate-top-level stx) 279 (syntax-case stx () 280 [(_ exp-forms ()) 281 #`(begin 282 #,@(reverse (syntax->list #'exp-forms)))] 283 [(_ exp-forms (form . forms)) 284 (let ([exp-form (local-expand #'form 285 (list (gensym)) 286 (list #'define-values 287 #'define-syntaxes 288 #'begin) 289 #f)]) 290 (syntax-case exp-form (begin define-values define-syntaxes) 291 [(begin form ...) 292 #'(accumulate-top-level exp-forms (form ... . forms))] 293 [(define-values (new-def-id ...) rhs) 294 #`(begin 295 (define-syntaxes (new-def-id ...) (values)) 296 (accumulate-top-level (#,exp-form . exp-forms) 297 forms))] 298 [(define-syntaxes . _) 299 #`(begin 300 #,exp-form 301 (accumulate-top-level exp-forms forms))] 302 [_ 303 #`(accumulate-top-level (#,exp-form . exp-forms) forms)]))])) 304 305;; ---------------------------------------- 306 307(define-for-syntax (do-define-* stx define-values-id) 308 (syntax-case stx () 309 [(_ (id ...) rhs) 310 (let ([ids (syntax->list #'(id ...))]) 311 (for-each (lambda (id) 312 (unless (identifier? id) 313 (raise-syntax-error 314 #f 315 "expected an identifier for definition" 316 stx 317 id))) 318 ids) 319 (with-syntax ([define-values define-values-id]) 320 (syntax/loc stx 321 (define-values (id ...) rhs))))])) 322(define-syntax (-define*-values stx) 323 (do-define-* stx #'define-values)) 324(define-syntax (-define*-syntaxes stx) 325 (do-define-* stx #'define-syntaxes)) 326(define-syntax (define*-values stx) 327 (syntax-case stx () 328 [(_ (id ...) rhs) 329 (syntax-property 330 (syntax/loc stx (-define*-values (id ...) rhs)) 331 'certify-mode 332 'transparent-binding)])) 333(define-syntax (define*-syntaxes stx) 334 (syntax-case stx () 335 [(_ (id ...) rhs) 336 (syntax-property 337 (syntax/loc stx (-define*-syntaxes (id ...) rhs)) 338 'certify-mode 339 'transparent-binding)])) 340 341(define-syntax (define* stx) 342 (let-values ([(id rhs) (normalize-definition stx #'lambda)]) 343 (quasisyntax/loc stx 344 (define*-values (#,id) #,rhs)))) 345(define-syntax (define*-syntax stx) 346 (let-values ([(id rhs) (normalize-definition stx #'lambda)]) 347 (quasisyntax/loc stx 348 (define*-syntaxes (#,id) #,rhs)))) 349