1#lang racket/base 2(require (for-syntax racket/base) 3 (only-in racket/list remove-duplicates) 4 racket/stxparam 5 racket/unsafe/ops 6 "serialize-structs.rkt" 7 "class-wrapped.rkt" 8 racket/runtime-path 9 (only-in "../contract/region.rkt" current-contract-region) 10 "../contract/base.rkt" 11 "../contract/combinator.rkt" 12 racket/unsafe/undefined 13 "class-undef.rkt" 14 (for-syntax racket/stxparam 15 racket/private/immediate-default 16 syntax/kerncase 17 syntax/stx 18 syntax/name 19 syntax/define 20 syntax/flatten-begin 21 syntax/private/boundmap 22 syntax/parse 23 "classidmap.rkt" 24 "intdef-util.rkt")) 25 26(define insp (current-inspector)) ; for all opaque structures 27 28;;-------------------------------------------------------------------- 29;; spec for external interface 30;;-------------------------------------------------------------------- 31 32(provide provide-public-names 33 ;; needed for Typed Racket 34 (protect-out do-make-object find-method/who)) 35(define-syntax (provide-public-names stx) 36 (class-syntax-protect 37 (datum->syntax 38 stx 39 '(provide class class* class/derived 40 define-serializable-class define-serializable-class* 41 class? 42 mixin 43 interface interface* interface? 44 object% object? externalizable<%> printable<%> writable<%> equal<%> 45 object=? object-or-false=? object=-hash-code 46 new make-object instantiate 47 send send/apply send/keyword-apply send* send+ dynamic-send 48 class-field-accessor class-field-mutator with-method 49 get-field set-field! field-bound? field-names 50 dynamic-get-field dynamic-set-field! 51 private* public* pubment* 52 override* overment* 53 augride* augment* 54 public-final* override-final* augment-final* 55 define/private define/public define/pubment 56 define/override define/overment 57 define/augride define/augment 58 define/public-final define/override-final define/augment-final 59 define-local-member-name define-member-name 60 member-name-key generate-member-key 61 member-name-key? member-name-key=? member-name-key-hash-code 62 generic make-generic send-generic 63 is-a? subclass? implementation? interface-extension? 64 object-interface object-info object->vector 65 object-method-arity-includes? 66 method-in-interface? interface->method-names class->interface class-info 67 (struct-out exn:fail:object) 68 make-primitive-class 69 class/c ->m ->*m ->dm case->m object/c instanceof/c 70 dynamic-object/c 71 class-seal class-unseal 72 73 ;; "keywords": 74 private public override augment 75 pubment overment augride 76 public-final override-final augment-final 77 field init init-field init-rest 78 rename-super rename-inner inherit inherit/super inherit/inner inherit-field 79 this this% super inner 80 super-make-object super-instantiate super-new 81 inspect absent abstract) 82 stx))) 83 84;;-------------------------------------------------------------------- 85;; keyword setup 86;;-------------------------------------------------------------------- 87 88(define-for-syntax (do-class-keyword stx orig-sym) 89 (let ([orig-stx (datum->syntax #f orig-sym stx)]) 90 (if (identifier? stx) 91 (raise-syntax-error 92 #f 93 "illegal (unparenthesized) use of a class keyword" 94 orig-stx) 95 (raise-syntax-error 96 #f 97 "use of a class keyword is not in a class top-level" 98 orig-stx)))) 99 100(define-for-syntax (rewrite-renaming-class-keyword stx internal-id) 101 (syntax-case stx () 102 [(_ elem ...) 103 ;; Set taint mode on elem ... 104 (with-syntax ([internal-id internal-id] 105 [(elem ...) (for/list ([e (in-list (syntax->list #'(elem ...)))]) 106 (if (identifier? e) 107 e 108 (syntax-property e 'taint-mode 'transparent)))]) 109 (class-syntax-protect 110 (syntax-property (syntax/loc stx (internal-id elem ...)) 111 'taint-mode 112 'transparent)))])) 113 114(define-syntax provide-renaming-class-keyword 115 (syntax-rules () 116 [(_ [id internal-id] ...) 117 (begin 118 (define-syntax (id stx) (rewrite-renaming-class-keyword stx #'internal-id)) 119 ... 120 (define-syntax (internal-id stx) (do-class-keyword stx 'id)) 121 ... 122 (provide id ...))])) 123 124(provide-renaming-class-keyword [private -private] 125 [public -public] 126 [override -override] 127 [augride -augride] 128 [pubment -pubment] 129 [overment -overment] 130 [augment -augment] 131 [public-final -public-final] 132 [override-final -override-final] 133 [augment-final -augment-final] 134 [rename-super -rename-super] 135 [rename-inner -rename-inner] 136 [inherit -inherit] 137 [inherit-field -inherit-field] 138 [inherit/super -inherit/super] 139 [inherit/inner -inherit/inner] 140 [abstract -abstract]) 141 142(define-for-syntax (rewrite-naming-class-keyword stx internal-id) 143 (syntax-case stx () 144 [(_ elem ...) 145 (with-syntax ([internal-id internal-id]) 146 (class-syntax-protect 147 (syntax-property (syntax/loc stx (internal-id elem ...)) 148 'taint-mode 149 'transparent)))])) 150 151(define-syntax provide-naming-class-keyword 152 (syntax-rules () 153 [(_ [id internal-id] ...) 154 (begin 155 (define-syntax (id stx) (rewrite-naming-class-keyword stx #'internal-id)) 156 ... 157 (define-syntax (internal-id stx) (do-class-keyword stx 'id)) 158 ... 159 (provide id ...))])) 160 161(provide-naming-class-keyword [inspect -inspect] 162 [init-rest -init-rest]) 163 164;; Going ahead and doing this in a generic fashion, in case we later realize that 165;; we need more class contract-specific keywords. 166(define-for-syntax (do-class-contract-keyword stx) 167 (raise-syntax-error 168 #f 169 "use of a class contract keyword is not in a class contract" 170 stx)) 171 172(define-syntax provide-class-contract-keyword 173 (syntax-rules () 174 [(_ id ...) 175 (begin 176 (define-syntax (id stx) (do-class-contract-keyword stx)) 177 ... 178 (provide id ...))])) 179 180(provide-class-contract-keyword absent) 181 182(define-for-syntax (do-define-like-internal stx) 183 (syntax-case stx () 184 [(_ orig . __) 185 (raise-syntax-error 186 #f 187 "use of a class keyword is not in a class top-level" 188 #'orig)])) 189 190(define-for-syntax (do-define-like stx internal-id) 191 (syntax-case stx () 192 [(_ elem ...) 193 (syntax-property 194 #`(#,internal-id #,stx 195 #,@(map (lambda (e) 196 (if (identifier? e) 197 e 198 (syntax-property 199 (syntax-case e () 200 [((n1 n2) . expr) 201 (syntax-property 202 (quasisyntax/loc e 203 (#,(syntax-property 204 #'(n1 n2) 205 'certify-mode 'transparent) 206 . expr)) 207 'certify-mode 'transparent)] 208 [(n . expr) 209 (identifier? #'n) 210 (syntax-property e 'certify-mode 'transparent)] 211 [_else e]) 212 'certify-mode 'transparent))) 213 (syntax-e #'(elem ...)))) 214 'certify-mode 215 'transparent)] 216 [(_ . elems) 217 #`(#,internal-id #,stx . elems)] 218 [_else 219 (raise-syntax-error #f "illegal (unparenthesized) use of class keyword" stx)])) 220 221(define-syntax provide-class-define-like-keyword 222 (syntax-rules () 223 [(_ [internal-id id] ...) 224 (begin 225 (define-syntax (internal-id stx) (do-define-like-internal stx)) 226 ... 227 (define-syntax (id stx) (do-define-like stx #'internal-id)) 228 ... 229 (provide id ...))])) 230 231(provide-class-define-like-keyword 232 [-field field] 233 [-init init] 234 [-init-field init-field]) 235 236 237(define-for-syntax not-in-a-class 238 (lambda (stx) 239 (if (eq? (syntax-local-context) 'expression) 240 (raise-syntax-error 241 #f 242 "use of a class keyword is not in a class" 243 stx) 244 (quasisyntax/loc stx (#%expression #,stx))))) 245 246(define-syntax define/provide-context-keyword 247 (syntax-rules () 248 [(_ (id param-id) ...) 249 (begin 250 (begin 251 (provide id) 252 (define-syntax-parameter param-id 253 (make-set!-transformer not-in-a-class)) 254 (define-syntax id 255 (make-parameter-rename-transformer #'param-id))) 256 ...)])) 257 258(define/provide-context-keyword 259 [this this-param] 260 [this% this%-param] 261 [super super-param] 262 [inner inner-param] 263 [super-make-object super-make-object-param] 264 [super-instantiate super-instantiate-param] 265 [super-new super-new-param]) 266 267;;-------------------------------------------------------------------- 268;; local member name lookup 269;;-------------------------------------------------------------------- 270 271(define-for-syntax (localize orig-id) 272 (do-localize orig-id #'validate-local-member)) 273 274(define (validate-local-member orig s) 275 (if (symbol? s) 276 s 277 (obj-error 'local-member-name 278 "used before its definition" 279 "name" (as-write orig)))) 280 281;;-------------------------------------------------------------------- 282;; field info creation/access 283;;-------------------------------------------------------------------- 284 285;; A field-info is a (vector iref iset eref eset) 286;; where 287;; iref, iset, eref, and eset are projections to be applied 288;; on internal and external access and mutation. 289 290;; make-field-info creates a new field-info for a field. 291;; The caller gives the class and relative position (in the 292;; new object struct layer), and this function fills 293;; in the projections. 294(define (make-field-info cls rpos) 295 (let ([field-ref (make-struct-field-accessor (class-field-ref cls) rpos)] 296 [field-set! (make-struct-field-mutator (class-field-set! cls) rpos)]) 297 (vector field-ref field-set! field-ref field-set!))) 298 299(define (field-info-extend-internal fi ppos pneg neg-party) 300 (let* ([old-ref (unsafe-vector-ref fi 0)] 301 [old-set! (unsafe-vector-ref fi 1)]) 302 (vector (λ (o) (ppos (old-ref o) neg-party)) 303 (λ (o v) (old-set! o (pneg v neg-party))) 304 (unsafe-vector-ref fi 2) 305 (unsafe-vector-ref fi 3)))) 306 307(define (field-info-extend-external fi ppos pneg neg-party) 308 (let* ([old-ref (unsafe-vector-ref fi 2)] 309 [old-set! (unsafe-vector-ref fi 3)]) 310 (vector (unsafe-vector-ref fi 0) 311 (unsafe-vector-ref fi 1) 312 (λ (o) (ppos (old-ref o) neg-party)) 313 (λ (o v) (old-set! o (pneg v neg-party)))))) 314 315(define (field-info-internal-ref fi) (unsafe-vector-ref fi 0)) 316(define (field-info-internal-set! fi) (unsafe-vector-ref fi 1)) 317(define (field-info-external-ref fi) (unsafe-vector-ref fi 2)) 318(define (field-info-external-set! fi) (unsafe-vector-ref fi 3)) 319 320;;-------------------------------------------------------------------- 321;; class macros 322;;-------------------------------------------------------------------- 323 324(define-syntaxes (class* _class class/derived) 325 (let () 326 ;; Start with Helper functions 327 328 (define (expand-all-forms stx defn-and-exprs def-ctx bind-local-id) 329 (let* ([stop-forms 330 (append 331 (kernel-form-identifier-list) 332 (list 333 (quote-syntax #%app) ; racket/base app, as opposed to #%plain-app 334 (quote-syntax lambda) ; racket/base lambda, as opposed to #%plain-lambda 335 (quote-syntax -init) 336 (quote-syntax -init-rest) 337 (quote-syntax -field) 338 (quote-syntax -init-field) 339 (quote-syntax -inherit-field) 340 (quote-syntax -private) 341 (quote-syntax -public) 342 (quote-syntax -override) 343 (quote-syntax -augride) 344 (quote-syntax -public-final) 345 (quote-syntax -override-final) 346 (quote-syntax -augment-final) 347 (quote-syntax -pubment) 348 (quote-syntax -overment) 349 (quote-syntax -augment) 350 (quote-syntax -rename-super) 351 (quote-syntax -inherit) 352 (quote-syntax -inherit/super) 353 (quote-syntax -inherit/inner) 354 (quote-syntax -rename-inner) 355 (quote-syntax -abstract) 356 (quote-syntax super) 357 (quote-syntax inner) 358 (quote-syntax this) 359 (quote-syntax this%) 360 (quote-syntax super-instantiate) 361 (quote-syntax super-make-object) 362 (quote-syntax super-new) 363 (quote-syntax -inspect)))] 364 [expand-context (generate-class-expand-context)] 365 [expand 366 (lambda (defn-or-expr) 367 (local-expand 368 defn-or-expr 369 expand-context 370 stop-forms 371 def-ctx))] 372 [defn-and-exprs-in-scope 373 (for/list ([s defn-and-exprs]) 374 (internal-definition-context-add-scopes def-ctx s))]) 375 (let loop ([l defn-and-exprs-in-scope]) 376 (if (null? l) 377 null 378 (let ([e (expand (car l))]) 379 (define (copy-prop stx . ps) (for/fold ([stx stx]) 380 ([p ps]) 381 (syntax-property stx p (syntax-property e p)))) 382 (syntax-case e (begin define-syntaxes define-values) 383 [(begin . _) 384 (loop (append 385 (flatten-begin e) 386 (cdr l)))] 387 [(define-syntaxes (id ...) rhs) 388 (andmap identifier? (syntax->list #'(id ...))) 389 (begin 390 (with-syntax ([rhs (local-transformer-expand 391 #'rhs 392 'expression 393 null)]) 394 (with-syntax ([(id ...) (syntax-local-bind-syntaxes (syntax->list #'(id ...)) #'rhs def-ctx)]) 395 (cons (copy-prop (syntax/loc e (define-syntaxes (id ...) rhs)) 396 'disappeared-use 'origin 'disappeared-binding) 397 (loop (cdr l))))))] 398 [(define-values (id ...) rhs) 399 (andmap identifier? (syntax->list #'(id ...))) 400 (let ([ids (map bind-local-id (syntax->list #'(id ...)))]) 401 (with-syntax ([(id ...) ids]) 402 (cons (datum->syntax e (list #'define-values #'(id ...) #'rhs) e e) 403 (loop (cdr l)))))] 404 [_else 405 (cons e (loop (cdr l)))])))))) 406 407 ;; returns two lists: expressions that start with an identifier in 408 ;; `kws', and expressions that don't 409 (define (extract kws l out-cons) 410 (let loop ([l l]) 411 (if (null? l) 412 (values null null) 413 (let-values ([(in out) (loop (cdr l))]) 414 (cond 415 [(and (stx-pair? (car l)) 416 (let ([id (stx-car (car l))]) 417 (and (identifier? id) 418 (ormap (lambda (k) (free-identifier=? k id)) kws)))) 419 (values (cons (car l) in) out)] 420 [else 421 (values in (out-cons (car l) out))]))))) 422 423 (define (extract* kws l) 424 (let-values ([(in out) (extract kws l void)]) 425 in)) 426 427 (define ((flatten/def-ctx def-ctx) alone l) 428 (apply append 429 (map (lambda (i) 430 (let ([l (let ([l (syntax->list i)]) 431 (if (ormap (lambda (i) 432 (free-identifier=? (car l) i)) 433 (syntax-e (quote-syntax (-init -init-field -field)))) 434 (cddr l) 435 (cdr l)))]) 436 (if alone 437 (map (lambda (i) 438 (if (identifier? i) 439 (alone (syntax-local-identifier-as-binding i def-ctx)) 440 (cons (syntax-local-identifier-as-binding (stx-car i) def-ctx) 441 (syntax-local-identifier-as-binding (stx-car (stx-cdr i)) def-ctx)))) 442 l) 443 l))) 444 l))) 445 446 ;; Used with flatten: 447 (define (pair i) (cons i i)) 448 449 (define (normalize-init/field i) 450 ;; Put i in ((iid eid) optional-expr) form 451 (cond 452 [(identifier? i) (list (list i i))] 453 [else (let ([a (stx-car i)]) 454 (if (identifier? a) 455 (cons (list a a) (stx-cdr i)) 456 i))])) 457 458 (define ((norm-init/field-iid/def-ctx def-ctx) norm) (syntax-local-identifier-as-binding (stx-car (stx-car norm)) def-ctx)) 459 (define ((norm-init/field-eid/def-ctx def-ctx) norm) (syntax-local-identifier-as-binding (stx-car (stx-cdr (stx-car norm))) def-ctx)) 460 461 ;; expands an expression enough that we can check whether it has 462 ;; the right form for a method; must use local syntax definitions 463 (define (proc-shape name orig-stx xform? 464 the-obj the-finder 465 bad class-name expand-stop-names 466 def-ctx lookup-localize) 467 (define (expand expr locals) 468 (local-expand 469 expr 470 'expression 471 (append locals (list #'lambda #'λ) expand-stop-names) 472 def-ctx)) 473 ;; Checks whether the vars sequence is well-formed 474 (define (vars-ok? vars) 475 (or (identifier? vars) 476 (stx-null? vars) 477 (and (stx-pair? vars) 478 (identifier? (stx-car vars)) 479 (vars-ok? (stx-cdr vars))))) 480 (define (kw-vars-ok? vars) 481 (or (identifier? vars) 482 (stx-null? vars) 483 (and (stx-pair? vars) 484 (let ([a (stx-car vars)] 485 [opt-arg-ok? 486 (lambda (a) 487 (or (identifier? a) 488 (and (stx-pair? a) 489 (identifier? (stx-car a)) 490 (stx-pair? (stx-cdr a)) 491 (stx-null? (stx-cdr (stx-cdr a))))))]) 492 (or (and (opt-arg-ok? a) 493 (kw-vars-ok? (stx-cdr vars))) 494 (and (keyword? (syntax-e a)) 495 (stx-pair? (stx-cdr vars)) 496 (opt-arg-ok? (stx-car (stx-cdr vars))) 497 (kw-vars-ok? (stx-cdr (stx-cdr vars))))))))) 498 ;; mk-name: constructs a method name 499 ;; for error reporting, etc. 500 (define (mk-name name) 501 (datum->syntax 502 #f 503 (string->symbol (format "~a method~a~a" 504 (syntax-e name) 505 (if class-name 506 " in " 507 "") 508 (or class-name 509 ""))) 510 #f)) 511 ;; -- transform loop starts here -- 512 (let loop ([stx orig-stx][can-expand? #t][name name][locals null]) 513 (syntax-case (disarm stx) (#%plain-lambda lambda λ case-lambda letrec-values let-values) 514 [(lam vars body1 body ...) 515 (or (and (free-identifier=? #'lam #'#%plain-lambda) 516 (vars-ok? (syntax vars))) 517 (and (or (free-identifier=? #'lam #'lambda) 518 (free-identifier=? #'lam #'λ)) 519 (kw-vars-ok? (syntax vars)))) 520 (if xform? 521 (with-syntax ([the-obj the-obj] 522 [the-finder the-finder] 523 [name (mk-name name)]) 524 (with-syntax ([vars (if (or (free-identifier=? #'lam #'lambda) 525 (free-identifier=? #'lam #'λ)) 526 (let loop ([vars #'vars]) 527 (cond 528 [(identifier? vars) vars] 529 [(syntax? vars) 530 (datum->syntax vars 531 (loop (syntax-e vars)) 532 vars 533 vars)] 534 [(pair? vars) 535 (syntax-case (car vars) () 536 [(id expr) 537 (and (identifier? #'id) (not (immediate-default? #'expr))) 538 ;; optional argument; need to wrap arg expression 539 (cons 540 (with-syntax ([expr (syntax/loc #'expr 541 (syntax-parameterize ([the-finder (quote-syntax the-obj)]) 542 (#%expression expr)))]) 543 (syntax/loc (car vars) 544 (id expr))) 545 (loop (cdr vars)))] 546 [_ (cons (car vars) (loop (cdr vars)))])] 547 [else vars])) 548 #'vars)]) 549 (let ([l (syntax/loc stx 550 (lambda (the-obj . vars) 551 (syntax-parameterize ([the-finder (quote-syntax the-obj)]) 552 body1 body ...)))]) 553 (syntax-track-origin 554 (with-syntax ([l (rearm (add-method-property l) stx)]) 555 (syntax/loc stx 556 (let ([name l]) name))) 557 stx 558 (syntax-local-introduce #'lam))))) 559 stx)] 560 [(#%plain-lambda . _) 561 (bad "ill-formed lambda expression for method" stx)] 562 [(lambda . _) 563 (bad "ill-formed lambda expression for method" stx)] 564 [(λ . _) 565 (bad "ill-formed lambda expression for method" stx)] 566 [(case-lam [vars body1 body ...] ...) 567 (and (free-identifier=? #'case-lam #'case-lambda) 568 (andmap vars-ok? (syntax->list (syntax (vars ...))))) 569 (if xform? 570 (with-syntax ([the-obj the-obj] 571 [the-finder the-finder] 572 [name (mk-name name)]) 573 (let ([cl (syntax/loc stx 574 (case-lambda [(the-obj . vars) 575 (syntax-parameterize ([the-finder (quote-syntax the-obj)]) 576 body1 body ...)] ...))]) 577 (syntax-track-origin 578 (with-syntax ([cl (rearm (add-method-property cl) stx)]) 579 (syntax/loc stx 580 (let ([name cl]) name))) 581 stx 582 (syntax-local-introduce #'case-lam)))) 583 stx)] 584 [(case-lambda . _) 585 (bad "ill-formed case-lambda expression for method" stx)] 586 [(let- ([(id) expr] ...) let-body) 587 (and (or (free-identifier=? (syntax let-) 588 (quote-syntax let-values)) 589 (free-identifier=? (syntax let-) 590 (quote-syntax letrec-values))) 591 (andmap identifier? (syntax->list (syntax (id ...))))) 592 (let* ([letrec? (free-identifier=? (syntax let-) 593 (quote-syntax letrec-values))] 594 [ids (syntax->list (syntax (id ...)))] 595 [new-ids (if xform? 596 (map 597 (lambda (id) 598 (datum->syntax 599 #f 600 (gensym (syntax-e id)))) 601 ids) 602 ids)] 603 [body-locals (append ids locals)] 604 [exprs (map (lambda (expr id) 605 (loop expr #t id (if letrec? 606 body-locals 607 locals))) 608 (syntax->list (syntax (expr ...))) 609 ids)] 610 [body (let ([body (syntax let-body)]) 611 (if (identifier? body) 612 (ormap (lambda (id new-id) 613 (and (bound-identifier=? body id) 614 new-id)) 615 ids new-ids) 616 (loop body #t name body-locals)))]) 617 (unless body 618 (bad "bad form for method definition" orig-stx)) 619 (with-syntax ([(proc ...) exprs] 620 [(new-id ...) new-ids] 621 [mappings 622 (if xform? 623 (map 624 (lambda (old-id new-id) 625 (with-syntax ([old-id old-id] 626 [old-id-localized (lookup-localize (localize old-id))] 627 [new-id new-id] 628 [the-obj the-obj] 629 [the-finder the-finder]) 630 (syntax (old-id (make-direct-method-map 631 (quote-syntax the-finder) 632 (quote the-obj) 633 (quote-syntax old-id) 634 (quote-syntax old-id-localized) 635 (quote new-id)))))) 636 ids new-ids) 637 null)] 638 [body body]) 639 (syntax-track-origin 640 (rearm 641 (if xform? 642 (if letrec? 643 (syntax/loc stx (letrec-syntax mappings 644 (let- ([(new-id) proc] ...) 645 body))) 646 (syntax/loc stx (let- ([(new-id) proc] ...) 647 (letrec-syntax mappings 648 body)))) 649 (syntax/loc stx (let- ([(new-id) proc] ...) 650 body))) 651 stx) 652 stx 653 (syntax-local-introduce #'let-))))] 654 [(-#%app -chaperone-procedure expr . rst) 655 (and (free-identifier=? (syntax -#%app) 656 (quote-syntax #%plain-app)) 657 (free-identifier=? (syntax -chaperone-procedure) 658 (quote-syntax chaperone-procedure))) 659 (with-syntax ([expr (loop #'expr #t name locals)]) 660 (syntax-track-origin 661 (rearm 662 (syntax/loc stx (-#%app -chaperone-procedure expr . rst)) 663 stx) 664 stx 665 (syntax-local-introduce #'-#%app)))] 666 [_else 667 (if can-expand? 668 (loop (expand stx locals) #f name locals) 669 (bad "bad form for method definition" orig-stx))]))) 670 671 (define (add-method-property l) 672 (syntax-property l 'method-arity-error #t)) 673 674 ;; `class' wants to be priviledged with respect to 675 ;; syntax taints: save the declaration-time inspector and use it 676 ;; to disarm syntax taints 677 (define method-insp (variable-reference->module-declaration-inspector 678 (#%variable-reference))) 679 (define (disarm stx) 680 (syntax-disarm stx method-insp)) 681 (define (rearm new old) 682 (syntax-rearm new old)) 683 684 ;; -------------------------------------------------------------------------------- 685 ;; Start here: 686 687 (define (main stx super-expr deserialize-id-expr name-id interface-exprs defn-and-exprs) 688 (let-values ([(this-id) #'this-id] 689 [(the-obj) (datum->syntax (quote-syntax here) (gensym 'self))] 690 [(the-finder) (datum->syntax #f (gensym 'find-self))]) 691 692 (let* ([def-ctx (syntax-local-make-definition-context)] 693 [norm-init/field-iid (norm-init/field-iid/def-ctx def-ctx)] 694 [norm-init/field-eid (norm-init/field-eid/def-ctx def-ctx)] 695 [flatten (flatten/def-ctx def-ctx)] 696 [localized-map (make-bound-identifier-mapping)] 697 [any-localized? #f] 698 [localize/set-flag (lambda (id) 699 (let ([id2 (localize id)]) 700 (unless (eq? id id2) 701 (set! any-localized? #t)) 702 id2))] 703 [bind-local-id (lambda (orig-id) 704 (let ([l (localize/set-flag orig-id)] 705 [id (car (syntax-local-bind-syntaxes (list orig-id) #f def-ctx))]) 706 (bound-identifier-mapping-put! 707 localized-map 708 id 709 l) 710 id))] 711 [lookup-localize (lambda (id) 712 (bound-identifier-mapping-get 713 localized-map 714 id 715 (lambda () 716 ;; If internal & external names are distinguished, 717 ;; we need to fall back to localize: 718 (localize id))))]) 719 720 ;; ----- Expand definitions ----- 721 (let ([defn-and-exprs (expand-all-forms stx defn-and-exprs def-ctx bind-local-id)] 722 [bad (lambda (msg expr) 723 (raise-syntax-error #f msg stx expr))] 724 [class-name (if name-id 725 (syntax-e name-id) 726 (let ([s (syntax-local-infer-name stx)]) 727 (if (syntax? s) 728 (syntax-e s) 729 s)))]) 730 731 ;; ------ Basic syntax checks ----- 732 (for-each (lambda (stx) 733 (syntax-case stx (-init -init-rest -field -init-field -inherit-field 734 -private -public -override -augride 735 -public-final -override-final -augment-final 736 -pubment -overment -augment 737 -rename-super -inherit -inherit/super -inherit/inner -rename-inner 738 -abstract 739 -inspect) 740 [(form orig idp ...) 741 (and (identifier? (syntax form)) 742 (or (free-identifier=? (syntax form) (quote-syntax -init)) 743 (free-identifier=? (syntax form) (quote-syntax -init-field)))) 744 745 (let ([form (syntax-e (stx-car (syntax orig)))]) 746 (for-each 747 (lambda (idp) 748 (syntax-case idp () 749 [id (identifier? (syntax id)) 'ok] 750 [((iid eid)) (and (identifier? (syntax iid)) 751 (identifier? (syntax eid))) 'ok] 752 [(id expr) (identifier? (syntax id)) 'ok] 753 [((iid eid) expr) (and (identifier? (syntax iid)) 754 (identifier? (syntax eid))) 'ok] 755 [else 756 (bad 757 (format 758 "~a element is not an optionally renamed identifier or identifier-expression pair" 759 form) 760 idp)])) 761 (syntax->list (syntax (idp ...)))))] 762 [(-inspect expr) 763 'ok] 764 [(-inspect . rest) 765 (bad "ill-formed inspect clause" stx)] 766 [(-init orig . rest) 767 (bad "ill-formed init clause" #'orig)] 768 [(-init-rest) 769 'ok] 770 [(-init-rest rest) 771 (identifier? (syntax rest)) 772 'ok] 773 [(-init-rest . rest) 774 (bad "ill-formed init-rest clause" stx)] 775 [(-init-field orig . rest) 776 (bad "ill-formed init-field clause" #'orig)] 777 [(-field orig idp ...) 778 (for-each (lambda (idp) 779 (syntax-case idp () 780 [(id expr) (identifier? (syntax id)) 'ok] 781 [((iid eid) expr) (and (identifier? (syntax iid)) 782 (identifier? (syntax eid))) 783 'ok] 784 [else 785 (bad 786 "field element is not an optionally renamed identifier-expression pair" 787 idp)])) 788 (syntax->list (syntax (idp ...))))] 789 [(-field orig . rest) 790 (bad "ill-formed field clause" #'orig)] 791 [(-private id ...) 792 (for-each 793 (lambda (id) 794 (unless (identifier? id) 795 (bad "private element is not an identifier" id))) 796 (syntax->list (syntax (id ...))))] 797 [(-private . rest) 798 (bad "ill-formed private clause" stx)] 799 [(-abstract id ...) 800 (for-each 801 (lambda (id) 802 (unless (identifier? id) 803 (bad "abstract element is not an identifier" id))) 804 (syntax->list (syntax (id ...))))] 805 [(-abstract . rest) 806 (bad "ill-formed abstract clause" stx)] 807 [(form idp ...) 808 (and (identifier? (syntax form)) 809 (ormap (lambda (f) (free-identifier=? (syntax form) f)) 810 (syntax-e (quote-syntax (-public 811 -override 812 -augride 813 -public-final 814 -override-final 815 -augment-final 816 -pubment 817 -overment 818 -augment 819 -inherit 820 -inherit/super 821 -inherit/inner 822 -inherit-field))))) 823 (let ([form (syntax-e (syntax form))]) 824 (for-each 825 (lambda (idp) 826 (syntax-case idp () 827 [id (identifier? (syntax id)) 'ok] 828 [(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok] 829 [else 830 (bad 831 (format 832 "~a element is not an identifier or pair of identifiers" 833 form) 834 idp)])) 835 (syntax->list (syntax (idp ...)))))] 836 [(-public . rest) 837 (bad "ill-formed public clause" stx)] 838 [(-override . rest) 839 (bad "ill-formed override clause" stx)] 840 [(-augride . rest) 841 (bad "ill-formed augride clause" stx)] 842 [(-public-final . rest) 843 (bad "ill-formed public-final clause" stx)] 844 [(-override-final . rest) 845 (bad "ill-formed override-final clause" stx)] 846 [(-augment-final . rest) 847 (bad "ill-formed augment-final clause" stx)] 848 [(-pubment . rest) 849 (bad "ill-formed pubment clause" stx)] 850 [(-overment . rest) 851 (bad "ill-formed overment clause" stx)] 852 [(-augment . rest) 853 (bad "ill-formed augment clause" stx)] 854 [(-inherit . rest) 855 (bad "ill-formed inherit clause" stx)] 856 [(-inherit/super . rest) 857 (bad "ill-formed inherit/super clause" stx)] 858 [(-inherit/inner . rest) 859 (bad "ill-formed inherit/inner clause" stx)] 860 [(-inherit-field . rest) 861 (bad "ill-formed inherit-field clause" stx)] 862 [(kw idp ...) 863 (and (identifier? #'kw) 864 (or (free-identifier=? #'-rename-super #'kw) 865 (free-identifier=? #'-rename-inner #'kw))) 866 (for-each 867 (lambda (idp) 868 (syntax-case idp () 869 [(iid eid) (and (identifier? (syntax iid)) (identifier? (syntax eid))) 'ok] 870 [else 871 (bad 872 (format "~a element is not a pair of identifiers" (syntax-e #'kw)) 873 idp)])) 874 (syntax->list (syntax (idp ...))))] 875 [(-rename-super . rest) 876 (bad "ill-formed rename-super clause" stx)] 877 [(-rename-inner . rest) 878 (bad "ill-formed rename-inner clause" stx)] 879 [_ 'ok])) 880 defn-and-exprs) 881 882 ;; ----- Sort body into different categories ----- 883 (let*-values ([(decls exprs) 884 (extract (syntax-e (quote-syntax (-inherit-field 885 -private 886 -public 887 -override 888 -augride 889 -public-final 890 -override-final 891 -augment-final 892 -pubment 893 -overment 894 -augment 895 -rename-super 896 -inherit 897 -inherit/super 898 -inherit/inner 899 -abstract 900 -rename-inner))) 901 defn-and-exprs 902 cons)] 903 [(inspect-decls exprs) 904 (extract (list (quote-syntax -inspect)) 905 exprs 906 cons)] 907 [(plain-inits) 908 ;; Normalize after, but keep un-normal for error reporting 909 (flatten #f (extract* (syntax-e 910 (quote-syntax (-init -init-rest))) 911 exprs))] 912 [(normal-plain-inits) (map normalize-init/field plain-inits)] 913 [(init-rest-decls _) 914 (extract (list (quote-syntax -init-rest)) 915 exprs 916 void)] 917 [(inits) 918 (flatten #f (extract* (syntax-e 919 (quote-syntax (-init -init-field))) 920 exprs))] 921 [(normal-inits) 922 (map normalize-init/field inits)] 923 [(plain-fields) 924 (flatten #f (extract* (list (quote-syntax -field)) exprs))] 925 [(normal-plain-fields) 926 (map normalize-init/field plain-fields)] 927 [(plain-init-fields) 928 (flatten #f (extract* (list (quote-syntax -init-field)) exprs))] 929 [(normal-plain-init-fields) 930 (map normalize-init/field plain-init-fields)] 931 [(inherit-fields) 932 (flatten pair (extract* (list (quote-syntax -inherit-field)) decls))] 933 [(privates) 934 (flatten pair (extract* (list (quote-syntax -private)) decls))] 935 [(publics) 936 (flatten pair (extract* (list (quote-syntax -public)) decls))] 937 [(overrides) 938 (flatten pair (extract* (list (quote-syntax -override)) decls))] 939 [(augrides) 940 (flatten pair (extract* (list (quote-syntax -augride)) decls))] 941 [(public-finals) 942 (flatten pair (extract* (list (quote-syntax -public-final)) decls))] 943 [(override-finals) 944 (flatten pair (extract* (list (quote-syntax -override-final)) decls))] 945 [(pubments) 946 (flatten pair (extract* (list (quote-syntax -pubment)) decls))] 947 [(overments) 948 (flatten pair (extract* (list (quote-syntax -overment)) decls))] 949 [(augments) 950 (flatten pair (extract* (list (quote-syntax -augment)) decls))] 951 [(augment-finals) 952 (flatten pair (extract* (list (quote-syntax -augment-final)) decls))] 953 [(rename-supers) 954 (flatten pair (extract* (list (quote-syntax -rename-super)) decls))] 955 [(inherits) 956 (flatten pair (extract* (list (quote-syntax -inherit)) decls))] 957 [(inherit/supers) 958 (flatten pair (extract* (list (quote-syntax -inherit/super)) decls))] 959 [(inherit/inners) 960 (flatten pair (extract* (list (quote-syntax -inherit/inner)) decls))] 961 [(abstracts) 962 (flatten pair (extract* (list (quote-syntax -abstract)) decls))] 963 [(rename-inners) 964 (flatten pair (extract* (list (quote-syntax -rename-inner)) decls))]) 965 966 967 ;; At most one inspect: 968 (unless (or (null? inspect-decls) 969 (null? (cdr inspect-decls))) 970 (bad "multiple inspect clauses" (cadr inspect-decls))) 971 972 ;; At most one init-rest: 973 (unless (or (null? init-rest-decls) 974 (null? (cdr init-rest-decls))) 975 (bad "multiple init-rest clauses" (cadr init-rest-decls))) 976 977 ;; Make sure init-rest is last 978 (unless (null? init-rest-decls) 979 (let loop ([l exprs] [saw-rest? #f]) 980 (unless (null? l) 981 (cond 982 [(and (stx-pair? (car l)) 983 (identifier? (stx-car (car l)))) 984 (let ([form (stx-car (car l))]) 985 (cond 986 [(free-identifier=? #'-init-rest form) 987 (loop (cdr l) #t)] 988 [(not saw-rest?) (loop (cdr l) #f)] 989 [(free-identifier=? #'-init form) 990 (bad "init clause follows init-rest clause" (stx-car (stx-cdr (car l))))] 991 [(free-identifier=? #'-init-field form) 992 (bad "init-field clause follows init-rest clause" (stx-car (stx-cdr (car l))))] 993 [else (loop (cdr l) #t)]))] 994 [else (loop (cdr l) saw-rest?)])))) 995 996 ;; --- Check initialization on inits: --- 997 (let loop ([inits inits] [normal-inits normal-inits]) 998 (unless (null? normal-inits) 999 (if (stx-null? (stx-cdr (car normal-inits))) 1000 (loop (cdr inits)(cdr normal-inits)) 1001 (let loop ([inits (cdr inits)] [normal-inits (cdr normal-inits)]) 1002 (unless (null? inits) 1003 (if (stx-null? (stx-cdr (car normal-inits))) 1004 (bad "initializer without default follows an initializer with default" 1005 (car inits)) 1006 (loop (cdr inits) (cdr normal-inits)))))))) 1007 1008 ;; ----- Extract method definitions; check that they look like procs ----- 1009 ;; Optionally transform them, can expand even if not transforming. 1010 (let* ([field-names (map norm-init/field-iid 1011 (append normal-plain-fields normal-plain-init-fields))] 1012 [inherit-field-names (map car inherit-fields)] 1013 [plain-init-names (map norm-init/field-iid normal-plain-inits)] 1014 [inherit-names (map car inherits)] 1015 [inherit/super-names (map car inherit/supers)] 1016 [inherit/inner-names (map car inherit/inners)] 1017 [abstract-names (map car abstracts)] 1018 [rename-super-names (map car rename-supers)] 1019 [rename-inner-names (map car rename-inners)] 1020 [local-public-dynamic-names (map car (append publics overrides augrides 1021 overments augments 1022 override-finals augment-finals 1023 abstracts))] 1024 [local-public-names (append (map car (append pubments public-finals)) 1025 local-public-dynamic-names)] 1026 [local-method-names (append (map car privates) local-public-names)] 1027 [expand-stop-names (append 1028 local-method-names 1029 field-names 1030 inherit-field-names 1031 plain-init-names 1032 inherit-names 1033 inherit/super-names 1034 inherit/inner-names 1035 rename-super-names 1036 rename-inner-names 1037 (kernel-form-identifier-list))]) 1038 ;; Do the extraction: 1039 (let-values ([(methods ; (listof (cons id stx)) 1040 private-methods ; (listof (cons id stx)) 1041 exprs ; (listof stx) 1042 stx-defines) ; (listof (cons (listof id) stx)) 1043 (let loop ([exprs exprs][ms null][pms null][es null][sd null]) 1044 (if (null? exprs) 1045 (values (reverse ms) (reverse pms) (reverse es) (reverse sd)) 1046 (syntax-case (car exprs) (define-values define-syntaxes) 1047 [(d-v (id ...) expr) 1048 (free-identifier=? #'d-v #'define-values) 1049 (let ([ids (syntax->list (syntax (id ...)))]) 1050 ;; Check form: 1051 (for-each (lambda (id) 1052 (unless (identifier? id) 1053 (bad "not an identifier for definition" id))) 1054 ids) 1055 ;; method defn? (id in the list of privates/publics/overrides/augrides?) 1056 (if (ormap (lambda (id) 1057 (ormap (lambda (i) (bound-identifier=? i id)) 1058 local-method-names)) 1059 ids) 1060 ;; Yes, it's a method: 1061 (begin 1062 (unless (null? (cdr ids)) 1063 (bad "each method variable needs its own definition" 1064 (car exprs))) 1065 (let ([expr 1066 (syntax-track-origin 1067 (proc-shape #f (syntax expr) #f 1068 the-obj the-finder 1069 bad class-name expand-stop-names 1070 def-ctx lookup-localize) 1071 (car exprs) 1072 (syntax-local-introduce #'d-v))] 1073 [public? (ormap (lambda (i) 1074 (bound-identifier=? i (car ids))) 1075 local-public-names)]) 1076 (loop (cdr exprs) 1077 (if public? 1078 (cons (cons (car ids) expr) ms) 1079 ms) 1080 (if public? 1081 pms 1082 (cons (cons (car ids) expr) pms)) 1083 es 1084 sd))) 1085 ;; Non-method defn: 1086 (loop (cdr exprs) ms pms (cons (car exprs) es) sd)))] 1087 [(define-values . _) 1088 (bad "ill-formed definition" (car exprs))] 1089 [(define-syntaxes (id ...) expr) 1090 (let ([ids (syntax->list (syntax (id ...)))]) 1091 (for-each (lambda (id) (unless (identifier? id) 1092 (bad "syntax name is not an identifier" id))) 1093 ids) 1094 (loop (cdr exprs) ms pms es (cons (cons ids (car exprs)) sd)))] 1095 [(define-syntaxes . _) 1096 (bad "ill-formed syntax definition" (car exprs))] 1097 [_else 1098 (loop (cdr exprs) ms pms (cons (car exprs) es) sd)])))]) 1099 1100 ;; ---- Extract all defined names, including field accessors and mutators --- 1101 (let ([defined-syntax-names (apply append (map car stx-defines))] 1102 [defined-method-names (append (map car methods) 1103 (map car private-methods))] 1104 [private-field-names (let loop ([l exprs]) 1105 (if (null? l) 1106 null 1107 (syntax-case (car l) (define-values) 1108 [(define-values (id ...) expr) 1109 (append (syntax->list (syntax (id ...))) 1110 (loop (cdr l)))] 1111 [_else (loop (cdr l))])))] 1112 [init-mode (cond 1113 [(null? init-rest-decls) 'normal] 1114 [(stx-null? (stx-cdr (car init-rest-decls))) 'stop] 1115 [else 'list])]) 1116 1117 ;; -- Look for duplicates -- 1118 (let ([dup (check-duplicate-identifier 1119 (append defined-syntax-names 1120 defined-method-names 1121 private-field-names 1122 field-names 1123 inherit-field-names 1124 plain-init-names 1125 inherit-names 1126 inherit/super-names 1127 inherit/inner-names 1128 rename-super-names 1129 rename-inner-names))]) 1130 (when dup 1131 (bad "duplicate declared identifier" dup))) 1132 1133 ;; -- Could still have duplicates within private/public/override/augride -- 1134 (let ([dup (check-duplicate-identifier local-method-names)]) 1135 (when dup 1136 (bad "duplicate declared identifier" dup))) 1137 1138 ;; -- Check for duplicate external method names, init names, or field names 1139 (let ([check-dup 1140 (lambda (what l) 1141 (let ([ht (make-hasheq)]) 1142 (for-each (lambda (id) 1143 (define key (let ([l-id (lookup-localize id)]) 1144 (if (identifier? l-id) 1145 (syntax-e l-id) 1146 ;; For a given localized id, `lookup-localize` 1147 ;; will return the same (eq?) value 1148 l-id))) 1149 (when (hash-ref ht key #f) 1150 (bad (format "duplicate declared external ~a name" what) id)) 1151 (hash-set! ht key #t)) 1152 l)))]) 1153 ;; method names 1154 (check-dup "method" (map cdr (append publics overrides augrides 1155 pubments overments augments 1156 public-finals override-finals augment-finals))) 1157 ;; inits 1158 (check-dup "init" (map norm-init/field-eid (append normal-inits))) 1159 ;; fields 1160 (check-dup "field" (map norm-init/field-eid (append normal-plain-fields normal-plain-init-fields)))) 1161 1162 ;; -- Check that private/public/override/augride are defined -- 1163 ;; -- and that abstracts are *not* defined -- 1164 (let ([ht (make-hasheq)] 1165 [stx-ht (make-hasheq)]) 1166 (for-each 1167 (lambda (defined-name) 1168 (let ([l (hash-ref ht (syntax-e defined-name) null)]) 1169 (hash-set! ht (syntax-e defined-name) (cons defined-name l)))) 1170 defined-method-names) 1171 (for-each 1172 (lambda (defined-name) 1173 (let ([l (hash-ref stx-ht (syntax-e defined-name) null)]) 1174 (hash-set! stx-ht (syntax-e defined-name) (cons defined-name l)))) 1175 defined-syntax-names) 1176 (for-each 1177 (lambda (pubovr-name) 1178 (let ([l (hash-ref ht (syntax-e pubovr-name) null)] 1179 [stx-l (hash-ref stx-ht (syntax-e pubovr-name) null)]) 1180 (cond ;; defined as value 1181 [(ormap (lambda (i) (bound-identifier=? i pubovr-name)) l) 1182 ;; check if abstract and fail if so 1183 (when (memq pubovr-name abstract-names) 1184 (bad "method declared as abstract but was defined" 1185 pubovr-name))] 1186 ;; defined as syntax 1187 [(ormap (lambda (i) (bound-identifier=? i pubovr-name)) stx-l) 1188 (bad "method declared but defined as syntax" 1189 pubovr-name)] 1190 ;; undefined 1191 [else 1192 (unless (memq pubovr-name abstract-names) 1193 (bad "method declared as concrete but not defined" 1194 pubovr-name))]))) 1195 local-method-names)) 1196 1197 ;; ---- Check that rename-inner doesn't have a non-final decl --- 1198 (unless (null? rename-inners) 1199 (let ([ht (make-hasheq)]) 1200 (for-each (lambda (pub) 1201 (hash-set! ht (syntax-e (cdr pub)) #t)) 1202 (append publics public-finals overrides override-finals augrides)) 1203 (for-each (lambda (inn) 1204 (when (hash-ref ht (syntax-e (cdr inn)) #f) 1205 (bad 1206 "inner method is locally declared as public, override, public-final, override-final, or augride" 1207 (cdr inn)))) 1208 rename-inners))) 1209 1210 ;; ---- Convert expressions ---- 1211 ;; Non-method definitions to set! 1212 ;; Initializations args access/set! 1213 (let ([exprs (map (lambda (e) 1214 (syntax-case e () 1215 [(d-v (id ...) expr) 1216 (and (identifier? #'d-v) 1217 (free-identifier=? #'d-v #'define-values)) 1218 (let* ([ids (syntax->list #'(id ...))] 1219 [assignment 1220 (if (= 1 (length ids)) 1221 ;; Special-case single variable in case the RHS 1222 ;; uses the name: 1223 (syntax/loc e 1224 (set! id ... (field-initialization-value expr))) 1225 ;; General case: 1226 (with-syntax ([(temp ...) (generate-temporaries ids)]) 1227 (syntax/loc e 1228 (let-values ([(temp ...) expr]) 1229 (set! id (field-initialization-value temp)) 1230 ... 1231 (void)))))]) 1232 (syntax-track-origin assignment e #'d-v))] 1233 [(_init orig idp ...) 1234 (and (identifier? (syntax _init)) 1235 (ormap (lambda (it) 1236 (free-identifier=? it (syntax _init))) 1237 (syntax-e (quote-syntax (-init 1238 -init-field))))) 1239 (let* ([norms (map normalize-init/field 1240 (syntax->list (syntax (idp ...))))] 1241 [iids (map norm-init/field-iid norms)] 1242 [exids (map norm-init/field-eid norms)]) 1243 (with-syntax ([(id ...) iids] 1244 [(idpos ...) (map localize/set-flag exids)] 1245 [(defval ...) 1246 (map (lambda (norm) 1247 (if (stx-null? (stx-cdr norm)) 1248 (syntax #f) 1249 (with-syntax ([defexp (stx-car (stx-cdr norm))]) 1250 (syntax (lambda () defexp))))) 1251 norms)] 1252 [class-name class-name] 1253 [wrapper (if (free-identifier=? #'_init #'-init-field) 1254 #'field-initialization-value 1255 #'begin)]) 1256 (syntax-track-origin 1257 (syntax/loc e 1258 (begin 1259 (set! id (wrapper (extract-arg 'class-name `idpos init-args defval))) 1260 ...)) 1261 e 1262 #'_init)))] 1263 [(-fld orig idp ...) 1264 (and (identifier? #'-fld) 1265 (free-identifier=? #'-fld #'-field)) 1266 (with-syntax ([(((iid eid) expr) ...) 1267 (map normalize-init/field (syntax->list #'(idp ...)))]) 1268 (syntax-track-origin 1269 (syntax/loc e (begin 1270 (set! iid (field-initialization-value expr)) 1271 ...)) 1272 e 1273 #'-fld))] 1274 [(-i-r id/rename) 1275 (and (identifier? #'-i-r) 1276 (free-identifier=? #'-i-r #'-init-rest)) 1277 (with-syntax ([n (+ (length plain-inits) 1278 (length plain-init-fields) 1279 -1)] 1280 [id (if (identifier? #'id/rename) 1281 #'id/rename 1282 (stx-car #'id/rename))]) 1283 (syntax-track-origin 1284 (syntax/loc e 1285 (set! id (extract-rest-args n init-args))) 1286 e 1287 #'-i-r))] 1288 [(-i-r) 1289 (and (identifier? #'-i-r) 1290 (free-identifier=? #'-i-r #'-init-rest)) 1291 (syntax-track-origin (syntax (void)) e #'-i-r)] 1292 [_else e])) 1293 exprs)] 1294 [mk-method-temp 1295 (lambda (id-stx) 1296 (datum->syntax (quote-syntax here) 1297 (gensym (syntax-e id-stx))))] 1298 [rename-super-extras (append overments overrides override-finals inherit/supers)] 1299 [rename-inner-extras (append pubments overments augments inherit/inners)] 1300 [all-rename-inners (append (map car rename-inners) 1301 (generate-temporaries (map car pubments)) 1302 (generate-temporaries (map car overments)) 1303 (generate-temporaries (map car augments)) 1304 (generate-temporaries (map car inherit/inners)))] 1305 [all-inherits (append inherits inherit/supers inherit/inners)] 1306 [definify (lambda (l) 1307 (map bind-local-id l))]) 1308 1309 ;; ---- set up field and method mappings ---- 1310 (with-syntax ([(rename-super-orig ...) (definify (map car rename-supers))] 1311 [(rename-super-orig-localized ...) (map lookup-localize (map car rename-supers))] 1312 [(rename-super-extra-orig ...) (map car rename-super-extras)] 1313 [(rename-super-temp ...) (definify (generate-temporaries (map car rename-supers)))] 1314 [(rename-super-extra-temp ...) (generate-temporaries (map car rename-super-extras))] 1315 [(rename-inner-orig ...) (definify (map car rename-inners))] 1316 [(rename-inner-orig-localized ...) (map lookup-localize (map car rename-inners))] 1317 [(rename-inner-extra-orig ...) (map car rename-inner-extras)] 1318 [(rename-inner-temp ...) (generate-temporaries (map car rename-inners))] 1319 [(rename-inner-extra-temp ...) (generate-temporaries (map car rename-inner-extras))] 1320 [(private-name ...) (map car privates)] 1321 [(private-name-localized ...) (map lookup-localize (map car privates))] 1322 [(private-temp ...) (map mk-method-temp (map car privates))] 1323 [(pubment-name ...) (map car pubments)] 1324 [(pubment-name-localized ...) (map lookup-localize (map car pubments))] 1325 [(pubment-temp ...) (map 1326 mk-method-temp 1327 (map car pubments))] 1328 [(public-final-name ...) (map car public-finals)] 1329 [(public-final-name-localized ...) (map lookup-localize (map car public-finals))] 1330 [(public-final-temp ...) (map 1331 mk-method-temp 1332 (map car public-finals))] 1333 [(method-name ...) (append local-public-dynamic-names 1334 (map car all-inherits))] 1335 [(method-name-localized ...) (map lookup-localize 1336 (append local-public-dynamic-names 1337 (map car all-inherits)))] 1338 [(method-accessor ...) (generate-temporaries 1339 (append local-public-dynamic-names 1340 (map car all-inherits)))] 1341 [(inherit-field-accessor ...) (generate-temporaries 1342 (map (lambda (id) 1343 (format "get-~a" 1344 (syntax-e id))) 1345 inherit-field-names))] 1346 [(inherit-field-mutator ...) (generate-temporaries 1347 (map (lambda (id) 1348 (format "set-~a!" 1349 (syntax-e id))) 1350 inherit-field-names))] 1351 [(inherit-name ...) (definify (map car all-inherits))] 1352 [(inherit-field-name ...) (definify inherit-field-names)] 1353 [(inherit-field-name-localized ...) (map lookup-localize inherit-field-names)] 1354 [(local-field ...) (definify 1355 (append field-names 1356 private-field-names))] 1357 [(local-field-localized ...) (map lookup-localize 1358 (append field-names 1359 private-field-names))] 1360 [(local-field-pos ...) (let loop ([pos 0][l (append field-names 1361 private-field-names)]) 1362 (if (null? l) 1363 null 1364 (cons pos (loop (add1 pos) (cdr l)))))] 1365 [(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))] 1366 [(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))] 1367 [(plain-init-name ...) (definify plain-init-names)] 1368 [(plain-init-name-localized ...) (map lookup-localize plain-init-names)] 1369 [(local-plain-init-name ...) (generate-temporaries plain-init-names)]) 1370 (let ([mappings 1371 ;; make-XXX-map is supplied by private/classidmap.rkt 1372 (with-syntax ([the-obj the-obj] 1373 [the-finder the-finder] 1374 [this-id this-id]) 1375 (syntax 1376 ([(inherit-field-name ... 1377 local-field ... 1378 rename-super-orig ... 1379 rename-inner-orig ... 1380 method-name ... 1381 private-name ... 1382 public-final-name ... 1383 pubment-name ...) 1384 (values 1385 (make-field-map #t 1386 (quote-syntax the-finder) 1387 (quote the-obj) 1388 (quote-syntax inherit-field-name) 1389 (quote-syntax inherit-field-name-localized) 1390 (quote-syntax inherit-field-accessor) 1391 (quote-syntax inherit-field-mutator)) 1392 ... 1393 (make-field-map #f 1394 (quote-syntax the-finder) 1395 (quote the-obj) 1396 (quote-syntax local-field) 1397 (quote-syntax local-field-localized) 1398 (quote-syntax local-field-accessor) 1399 (quote-syntax local-field-mutator)) 1400 ... 1401 (make-rename-super-map (quote-syntax the-finder) 1402 (quote the-obj) 1403 (quote-syntax rename-super-orig) 1404 (quote-syntax rename-super-orig-localized) 1405 (quote-syntax rename-super-temp)) 1406 ... 1407 (make-rename-inner-map (quote-syntax the-finder) 1408 (quote the-obj) 1409 (quote-syntax rename-inner-orig) 1410 (quote-syntax rename-inner-orig-localized) 1411 (quote-syntax rename-inner-temp)) 1412 ... 1413 (make-method-map (quote-syntax the-finder) 1414 (quote the-obj) 1415 (quote-syntax method-name) 1416 (quote-syntax method-name-localized) 1417 (quote-syntax method-accessor)) 1418 ... 1419 (make-direct-method-map (quote-syntax the-finder) 1420 (quote the-obj) 1421 (quote-syntax private-name) 1422 (quote-syntax private-name-localized) 1423 (quote private-temp)) 1424 ... 1425 (make-direct-method-map (quote-syntax the-finder) 1426 (quote the-obj) 1427 (quote-syntax public-final-name) 1428 (quote-syntax public-final-name-localized) 1429 (quote public-final-temp)) 1430 ... 1431 (make-direct-method-map (quote-syntax the-finder) 1432 (quote the-obj) 1433 (quote-syntax pubment-name) 1434 (quote-syntax pubment-name-localized) 1435 (quote pubment-temp)) 1436 ...)])))] 1437 [extra-init-mappings (syntax 1438 ([(plain-init-name ...) 1439 (values 1440 (make-init-error-map (quote-syntax plain-init-name-localized)) 1441 ...)]))]) 1442 1443 (let ([find-method 1444 (lambda (methods) 1445 (lambda (name) 1446 (ormap 1447 (lambda (m) 1448 (and (bound-identifier=? (car m) name) 1449 (with-syntax ([proc (proc-shape (car m) (cdr m) #t 1450 the-obj the-finder 1451 bad class-name expand-stop-names 1452 def-ctx lookup-localize)] 1453 [extra-init-mappings extra-init-mappings]) 1454 (syntax 1455 (syntax-parameterize 1456 ([super-instantiate-param super-error-map] 1457 [super-make-object-param super-error-map] 1458 [super-new-param super-error-map]) 1459 (letrec-syntaxes+values extra-init-mappings () 1460 proc)))))) 1461 methods)))] 1462 [lookup-localize-cdr (lambda (p) (lookup-localize (cdr p)))]) 1463 1464 ;; ---- build final result ---- 1465 (with-syntax ([public-names (map lookup-localize-cdr publics)] 1466 [public-final-names (map lookup-localize-cdr public-finals)] 1467 [override-names (map lookup-localize-cdr overrides)] 1468 [override-final-names (map lookup-localize-cdr override-finals)] 1469 [augride-names (map lookup-localize-cdr augrides)] 1470 [pubment-names (map lookup-localize-cdr pubments)] 1471 [overment-names (map lookup-localize-cdr overments)] 1472 [augment-names (map lookup-localize-cdr augments)] 1473 [augment-final-names (map lookup-localize-cdr augment-finals)] 1474 [(rename-super-name ...) (map lookup-localize-cdr rename-supers)] 1475 [(rename-super-extra-name ...) (map lookup-localize-cdr rename-super-extras)] 1476 [(rename-inner-name ...) (map lookup-localize-cdr rename-inners)] 1477 [(rename-inner-extra-name ...) (map lookup-localize-cdr rename-inner-extras)] 1478 [inherit-names (map lookup-localize-cdr all-inherits)] 1479 [abstract-names (map lookup-localize-cdr abstracts)] 1480 [num-fields (datum->syntax 1481 (quote-syntax here) 1482 (+ (length private-field-names) 1483 (length plain-init-fields) 1484 (length plain-fields)))] 1485 [field-names (map (lambda (norm) 1486 (lookup-localize (norm-init/field-eid norm))) 1487 (append 1488 normal-plain-fields 1489 normal-plain-init-fields))] 1490 [inherit-field-names (map lookup-localize (map cdr inherit-fields))] 1491 [init-names (map (lambda (norm) 1492 (lookup-localize 1493 (norm-init/field-eid norm))) 1494 normal-inits)] 1495 [init-mode init-mode] 1496 [(private-method ...) (map (find-method private-methods) (map car privates))] 1497 [public-methods (map (find-method methods) (map car publics))] 1498 [override-methods (map (find-method methods) (map car (append overments 1499 override-finals 1500 overrides)))] 1501 [augride-methods (map (find-method methods) (map car (append augments 1502 augment-finals 1503 augrides)))] 1504 [(pubment-method ...) (map (find-method methods) (map car pubments))] 1505 [(public-final-method ...) (map (find-method methods) (map car public-finals))] 1506 ;; store a dummy method body that should never be called for abstracts 1507 [(abstract-method ...) (map (lambda (abs) 1508 #'(lambda (this . rest) 1509 (obj-error 'class "cannot call abstract method"))) 1510 (map car abstracts))] 1511 [mappings mappings] 1512 1513 [exprs exprs] 1514 [the-obj the-obj] 1515 [the-finder the-finder] 1516 [name class-name] 1517 [(stx-def ...) (map cdr stx-defines)] 1518 [super-expression super-expr] 1519 [(interface-expression ...) interface-exprs] 1520 [inspector (if (pair? inspect-decls) 1521 (stx-car (stx-cdr (car inspect-decls))) 1522 #'(current-inspector))] 1523 [deserialize-id-expr deserialize-id-expr] 1524 [private-field-names private-field-names]) 1525 (class-syntax-protect 1526 (add-decl-props 1527 def-ctx 1528 (append inspect-decls decls) 1529 (quasisyntax/loc stx 1530 (detect-field-unsafe-undefined 1531 compose-class 1532 'name 1533 super-expression 1534 (list interface-expression ...) 1535 inspector deserialize-id-expr #,any-localized? 1536 ;; Field count: 1537 num-fields 1538 ;; Field names: 1539 `field-names 1540 `inherit-field-names 1541 `private-field-names ; for undefined-checking property 1542 ;; Method names: 1543 `(rename-super-name ... rename-super-extra-name ...) 1544 `(rename-inner-name ... rename-inner-extra-name ...) 1545 `pubment-names 1546 `public-final-names 1547 `public-names 1548 `overment-names 1549 `override-final-names 1550 `override-names 1551 `augment-names 1552 `augment-final-names 1553 `augride-names 1554 `inherit-names 1555 `abstract-names 1556 ;; Init arg names (in order) 1557 `init-names 1558 (quote init-mode) 1559 ;; Methods (when given needed super-methods, etc.): 1560 #, ;; Attach srcloc (useful for profiling) 1561 (quasisyntax/loc stx 1562 (lambda (local-accessor 1563 local-mutator 1564 inherit-field-accessor ... ; inherit 1565 inherit-field-mutator ... 1566 rename-super-temp ... rename-super-extra-temp ... 1567 rename-inner-temp ... rename-inner-extra-temp ... 1568 method-accessor ...) ; for a local call that needs a dynamic lookup 1569 (define-syntax-parameter the-finder #f) 1570 (let ([local-field-accessor 1571 (make-struct-field-accessor local-accessor local-field-pos #f)] 1572 ... 1573 [local-field-mutator 1574 (make-struct-field-mutator local-mutator local-field-pos #f)] 1575 ...) 1576 (syntax-parameterize 1577 ([this-param (make-this-map (quote-syntax this-id) 1578 (quote-syntax the-finder) 1579 (quote the-obj))] 1580 [this%-param (make-this%-map (quote-syntax (object-ref this)) 1581 (quote-syntax the-finder))]) 1582 (let-syntaxes 1583 mappings 1584 (syntax-parameterize 1585 ([super-param 1586 (lambda (stx) 1587 (syntax-case stx (rename-super-extra-orig ...) 1588 [(_ rename-super-extra-orig . args) 1589 (generate-super-call 1590 stx 1591 (quote-syntax the-finder) 1592 (quote the-obj) 1593 (quote-syntax rename-super-extra-temp) 1594 (syntax args))] 1595 ... 1596 [(_ id . args) 1597 (identifier? #'id) 1598 (raise-syntax-error 1599 #f 1600 (string-append 1601 "identifier for super call does not have an override, " 1602 "override-final, overment, or inherit/super declaration") 1603 stx 1604 #'id)] 1605 [_else 1606 (raise-syntax-error 1607 #f 1608 "expected an identifier after the keyword" 1609 stx)]))] 1610 [inner-param 1611 (lambda (stx) 1612 (syntax-case stx (rename-inner-extra-orig ...) 1613 [(_ default-expr rename-inner-extra-orig . args) 1614 (generate-inner-call 1615 stx 1616 (quote-syntax the-finder) 1617 (quote the-obj) 1618 (syntax default-expr) 1619 (quote-syntax rename-inner-extra-temp) 1620 (syntax args))] 1621 ... 1622 [(_ default-expr id . args) 1623 (identifier? #'id) 1624 (raise-syntax-error 1625 #f 1626 (string-append 1627 "identifier for inner call does not have a pubment, augment, " 1628 "overment, or inherit/inner declaration") 1629 stx 1630 #'id)] 1631 [(_) 1632 (raise-syntax-error 1633 #f 1634 "expected a default-value expression after the keyword" 1635 stx 1636 #'id)] 1637 [_else 1638 (raise-syntax-error 1639 #f 1640 "expected an identifier after the keyword and default-value expression" 1641 stx)]))]) 1642 stx-def ... 1643 (letrec ([private-temp private-method] 1644 ... 1645 [pubment-temp pubment-method] 1646 ... 1647 [public-final-temp public-final-method] 1648 ...) 1649 (values 1650 (list pubment-temp ... public-final-temp ... 1651 abstract-method ... . public-methods) 1652 (list . override-methods) 1653 (list . augride-methods) 1654 ;; Initialization 1655 #, ;; Attach srcloc (useful for profiling) 1656 (quasisyntax/loc stx 1657 (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) 1658 (syntax-parameterize ([the-finder (quote-syntax the-obj)]) 1659 (syntax-parameterize 1660 ([super-instantiate-param 1661 (lambda (stx) 1662 (syntax-case stx () 1663 [(_ (arg (... ...)) (kw kwarg) (... ...)) 1664 (with-syntax ([stx stx]) 1665 (syntax 1666 (begin 1667 `(declare-super-new) 1668 (-instantiate super-go stx #f (the-obj si_c si_inited? 1669 si_leftovers) 1670 (list arg (... ...)) 1671 (kw kwarg) (... ...)))))]))] 1672 [super-new-param 1673 (lambda (stx) 1674 (syntax-case stx () 1675 [(_ (kw kwarg) (... ...)) 1676 (with-syntax ([stx stx]) 1677 (syntax 1678 (begin 1679 `(declare-super-new) 1680 (-instantiate super-go stx #f (the-obj si_c si_inited? 1681 si_leftovers) 1682 null 1683 (kw kwarg) (... ...)))))]))] 1684 [super-make-object-param 1685 (lambda (stx) 1686 (let ([code 1687 (quote-syntax 1688 (lambda args 1689 (super-go the-obj si_c si_inited? si_leftovers args null)))]) 1690 #`(begin 1691 `(declare-super-new) 1692 #,(if (identifier? stx) 1693 code 1694 (datum->syntax 1695 code 1696 (cons code 1697 (cdr (syntax-e stx))))))))]) 1698 (letrec-syntaxes+values 1699 ([(plain-init-name) (make-init-redirect 1700 (quote-syntax local-plain-init-name) 1701 (quote-syntax plain-init-name-localized))] ...) 1702 ([(local-plain-init-name) unsafe-undefined] ...) 1703 (void) ; in case the body is empty 1704 (begin 1705 '(declare-field-use-start) ; see "class-undef.rkt" 1706 . exprs)))))))))))))) 1707 ;; Extra argument added here by `detect-field-unsafe-undefined` 1708 #; check-undef? 1709 ;; Not primitive: 1710 #f))))))))))))))))) 1711 1712 ;; The class* and class entry points: 1713 (values 1714 ;; class* 1715 (lambda (stx) 1716 (syntax-case stx () 1717 [(_ super-expression (interface-expr ...) 1718 defn-or-expr 1719 ...) 1720 (main stx 1721 #'super-expression 1722 #f #f 1723 (syntax->list #'(interface-expr ...)) 1724 (syntax->list #'(defn-or-expr ...)))] 1725 [(_ super-expression no-parens-interface-expr 1726 defn-or-expr 1727 ...) 1728 (raise-syntax-error 'class* 1729 "expected a sequence of interfaces" 1730 stx 1731 #'no-parens-interface-expr)])) 1732 ;; class 1733 (lambda (stx) 1734 (syntax-case stx () 1735 [(_ super-expression 1736 defn-or-expr 1737 ...) 1738 (main stx 1739 #'super-expression 1740 #f #f 1741 null 1742 (syntax->list #'(defn-or-expr ...)))])) 1743 ;; class/derived 1744 (lambda (stx) 1745 (syntax-case stx () 1746 [(_ orig-stx 1747 [name-id super-expression (interface-expr ...) deserialize-id-expr] 1748 defn-or-expr 1749 ...) 1750 (main #'orig-stx 1751 #'super-expression 1752 #'deserialize-id-expr 1753 (and (syntax-e #'name-id) #'name-id) 1754 (syntax->list #'(interface-expr ...)) 1755 (syntax->list #'(defn-or-expr ...)))])) 1756 ))) 1757 1758(define-syntax (-define-serializable-class stx) 1759 (syntax-case stx () 1760 [(_ orig-stx name super-expression (interface-expr ...) 1761 defn-or-expr ...) 1762 (let ([deserialize-name-info (datum->syntax 1763 #'name 1764 (string->symbol 1765 (format "deserialize-info:~a" (syntax-e #'name))) 1766 #'name)]) 1767 (unless (memq (syntax-local-context) '(top-level module)) 1768 (raise-syntax-error 1769 #f 1770 "allowed only at the top level or within a module top level" 1771 #'orig-stx)) 1772 (with-syntax ([deserialize-name-info deserialize-name-info] 1773 [(provision ...) (if (eq? (syntax-local-context) 'module) 1774 #`((runtime-require (submod "." deserialize-info)) 1775 (module+ deserialize-info (provide #,deserialize-name-info))) 1776 #'())]) 1777 (class-syntax-protect 1778 #'(begin 1779 (define-values (name deserialize-name-info) 1780 (class/derived orig-stx [name 1781 super-expression 1782 (interface-expr ...) 1783 #'deserialize-name-info] 1784 defn-or-expr ...)) 1785 provision ...))))])) 1786 1787(define-syntax (define-serializable-class* stx) 1788 (syntax-case stx () 1789 [(_ name super-expression (interface-expr ...) 1790 defn-or-expr ...) 1791 (with-syntax ([orig-stx stx]) 1792 (class-syntax-protect 1793 #'(-define-serializable-class orig-stx 1794 name 1795 super-expression 1796 (interface-expr ...) 1797 defn-or-expr ...)))])) 1798 1799(define-syntax (define-serializable-class stx) 1800 (syntax-case stx () 1801 [(_ name super-expression 1802 defn-or-expr ...) 1803 (with-syntax ([orig-stx stx]) 1804 (class-syntax-protect 1805 #'(-define-serializable-class orig-stx 1806 name 1807 super-expression 1808 () 1809 defn-or-expr ...)))])) 1810 1811(define-syntaxes (private* public* pubment* override* overment* augride* augment* 1812 public-final* override-final* augment-final*) 1813 (let ([mk 1814 (lambda (who decl-form) 1815 (lambda (stx) 1816 (unless (class-top-level-context? (syntax-local-context)) 1817 (raise-syntax-error 1818 #f 1819 "use of a class keyword is not in a class top-level" 1820 stx)) 1821 (syntax-case stx () 1822 [(_ binding ...) 1823 (let ([bindings (syntax->list (syntax (binding ...)))]) 1824 (let ([name-exprs 1825 (map (lambda (binding) 1826 (syntax-case binding () 1827 [(name expr) 1828 (identifier? (syntax name)) 1829 (cons (syntax name) (syntax expr))] 1830 [_else 1831 (identifier? (syntax name)) 1832 (raise-syntax-error 1833 #f 1834 "expected an identifier and expression" 1835 stx 1836 binding)])) 1837 bindings)]) 1838 (with-syntax ([(name ...) (map car name-exprs)] 1839 [(expr ...) (map cdr name-exprs)] 1840 [decl-form decl-form]) 1841 (class-syntax-protect 1842 (syntax 1843 (begin 1844 (decl-form name ...) 1845 (define name expr) 1846 ...))))))])))]) 1847 (values 1848 (mk 'private* (syntax private)) 1849 (mk 'public* (syntax public)) 1850 (mk 'pubment* (syntax pubment)) 1851 (mk 'override* (syntax override)) 1852 (mk 'overment* (syntax overment)) 1853 (mk 'augride* (syntax augride)) 1854 (mk 'augment* (syntax augment)) 1855 (mk 'public-final* (syntax public-final)) 1856 (mk 'override-final* (syntax override-final)) 1857 (mk 'augment-final* (syntax augment))))) 1858 1859(define-syntaxes (define/private define/public define/pubment 1860 define/override define/overment 1861 define/augride define/augment 1862 define/public-final define/override-final define/augment-final) 1863 (let ([mk 1864 (lambda (decl-form) 1865 (lambda (stx) 1866 (unless (class-top-level-context? (syntax-local-context)) 1867 (raise-syntax-error 1868 #f 1869 "use of a class keyword is not in a class top-level" 1870 stx)) 1871 (let-values ([(id rhs) (normalize-definition stx #'lambda #f #t)]) 1872 (quasisyntax/loc stx 1873 (begin 1874 (#,decl-form #,id) 1875 (define #,id #,rhs))))))]) 1876 (values 1877 (mk #'private) 1878 (mk #'public) 1879 (mk #'pubment) 1880 (mk #'override) 1881 (mk #'overment) 1882 (mk #'augride) 1883 (mk #'augment) 1884 (mk #'public-final) 1885 (mk #'override-final) 1886 (mk #'augment-final)))) 1887 1888(define-syntax (define-local-member-name stx) 1889 (syntax-case stx () 1890 [(_ id ...) 1891 (let ([ids (syntax->list (syntax (id ...)))]) 1892 (for-each (lambda (id) 1893 (unless (identifier? id) 1894 (raise-syntax-error 1895 #f 1896 "expected an identifier" 1897 stx 1898 id))) 1899 ids) 1900 (let ([dup (check-duplicate-identifier ids)]) 1901 (when dup 1902 (raise-syntax-error 1903 #f 1904 "duplicate identifier" 1905 stx 1906 dup))) 1907 (if (eq? (syntax-local-context) 'top-level) 1908 ;; Does nothing in particular at the top level: 1909 (syntax/loc stx (define-syntaxes (id ...) (values 'id ...))) 1910 ;; Map names to private indicators, which are made private 1911 ;; simply by introduction: 1912 (with-syntax ([(gen-id ...) (generate-temporaries ids)]) 1913 (with-syntax ([stx-defs 1914 ;; Need to attach srcloc to this definition: 1915 (syntax/loc stx 1916 (define-syntaxes (id ...) 1917 (values (make-private-name (quote-syntax id) (quote-syntax gen-id)) 1918 ...)))]) 1919 (class-syntax-protect 1920 (syntax/loc stx 1921 (begin 1922 (define-values (gen-id ...) 1923 (values (generate-local-member-name 'id) ...)) 1924 stx-defs)))))))])) 1925 1926(define-syntax (define-member-name stx) 1927 (syntax-case stx () 1928 [(_ id expr) 1929 (let ([name #'id]) 1930 (unless (identifier? name) 1931 (raise-syntax-error 1932 #f 1933 "expected an identifier for definition" 1934 stx 1935 name)) 1936 (with-syntax ([stx-def 1937 ;; Need to attach srcloc to this definition: 1938 (syntax/loc stx 1939 (define-syntax id 1940 (make-private-name (quote-syntax id) 1941 ((syntax-local-certifier) (quote-syntax member-name)))))]) 1942 (class-syntax-protect 1943 #'(begin 1944 (define member-name (check-member-key 'id expr)) 1945 stx-def))))])) 1946 1947(define (generate-local-member-name id) 1948 (string->uninterned-symbol 1949 (symbol->string id))) 1950 1951 1952(define-values (struct:member-key make-member-key member-name-key? member-key-ref member-key-set!) 1953 (make-struct-type 'member-name-key 1954 #f 1955 1 0 #f 1956 (list 1957 (cons prop:custom-write 1958 (lambda (v p write?) 1959 (fprintf p "#<member-key:~a>" (member-key-id v))))))) 1960 1961(define member-key-id (make-struct-field-accessor member-key-ref 0)) 1962 1963(define (check-member-key id v) 1964 (unless (member-name-key? v) 1965 (obj-error 'define-local-member-name 1966 "value is not a member key" 1967 "value" v 1968 "local name" (as-write id))) 1969 (member-key-id v)) 1970 1971(define-syntax (member-name-key stx) 1972 (syntax-case stx () 1973 [(_ id) 1974 (identifier? #'id) 1975 (with-syntax ([id (localize #'id)]) 1976 (class-syntax-protect 1977 (syntax/loc stx (make-member-key `id))))] 1978 [(_ x) 1979 (raise-syntax-error 1980 #f 1981 "not an identifier" 1982 stx 1983 #'x)])) 1984 1985(define (generate-member-key) 1986 (make-member-key (generate-local-member-name (gensym 'member)))) 1987 1988(define (member-name-key=? a b) 1989 (if (and (member-name-key? a) 1990 (member-name-key? b)) 1991 (eq? (member-key-id a) (member-key-id b)) 1992 (eq? a b))) 1993 1994(define (member-name-key-hash-code a) 1995 (unless (member-name-key? a) 1996 (raise-argument-error 1997 'member-name-key-hash-code 1998 "member-name-key?" 1999 a)) 2000 (eq-hash-code (member-key-id a))) 2001 2002;;-------------------------------------------------------------------- 2003;; class implementation 2004;;-------------------------------------------------------------------- 2005 2006(define-struct class (name 2007 pos supers ; pos is subclass depth, supers is vector 2008 self-interface ; self interface 2009 insp-mk ; dummy struct maker to control inspection access 2010 obj-inspector ; the inspector used for instances of this class 2011 2012 method-width ; total number of methods 2013 method-ht ; maps public names to vector positions 2014 method-ids ; reverse-ordered list of public method names 2015 abstract-ids ; list of abstract method names 2016 method-ictcs ; list of indices of methods to fix for interface ctcs 2017 2018 [ictc-classes ; #f or weak hash of cached classes keyed by blame 2019 #:mutable] 2020 2021 methods ; vector of methods (for external dynamic dispatch) 2022 ; vector might also contain lists; see comment below from Stevie 2023 super-methods ; vector of methods (for subclass super calls) 2024 int-methods ; vector of vector of methods (for internal dynamic dispatch) 2025 beta-methods ; vector of vector of methods 2026 meth-flags ; vector: #f => primitive-implemented 2027 ; 'final => final 2028 ; 'augmentable => can augment 2029 2030 inner-projs ; vector of projections for the last inner slot 2031 dynamic-idxs ; vector of indexs for access into int-methods 2032 dynamic-projs ; vector of vector of projections for internal dynamic dispatch 2033 2034 field-width ; total number of fields 2035 field-pub-width ; total number of public fields 2036 field-ht ; maps public field names to field-infos (see make-field-info above) 2037 field-ids ; list of public field names 2038 all-field-ids ; list of field names in reverse order, used for `undefined` error reporting 2039 2040 [struct:object ; structure type for instances 2041 #:mutable] 2042 [object? ; predicate 2043 #:mutable] 2044 [make-object ; : (-> object), constructor that creates an uninitialized object 2045 #:mutable] 2046 [field-ref ; accessor 2047 #:mutable] 2048 [field-set! ; mutator 2049 #:mutable] 2050 2051 init-args ; list of symbols in order; #f => only by position 2052 init-mode ; 'normal, 'stop (don't accept by-pos for super), or 'list 2053 2054 [init ; initializer 2055 #:mutable] ; : object 2056 ; (object class (box boolean) leftover-args new-by-pos-args new-named-args 2057 ; -> void) // always continue-make-super? 2058 ; class 2059 ; (box boolean) 2060 ; leftover-args 2061 ; named-args 2062 ; -> void 2063 2064 [orig-cls ; uncontracted version of this class (or same class) 2065 #:mutable] 2066 [serializer ; proc => serializer, #f => not serializable 2067 #:mutable] 2068 [fixup ; for deserialization 2069 #:mutable] 2070 2071 check-undef? ; objects need an unsafe-undefined guarding chaperone? 2072 2073 no-super-init?); #t => no super-init needed 2074 #:inspector insp 2075 #:property prop:equal+hash 2076 (list (λ (cls-a cls-b recur) (eq? (class-orig-cls cls-a) (class-orig-cls cls-b))) 2077 (λ (cls recur) (eq-hash-code (class-orig-cls cls))) 2078 (λ (cls recur) (eq-hash-code (class-orig-cls cls))))) 2079 2080#| 2081 2082From Stevie, explaining the shape of the elements of the vector in the 'methods' field: 2083 2084For each level of interface, we build up the following structure: 2085 2086(list <contract> <name of interface that contains this contract> <pos blame or #f> <neg blame or #f>) 2087 2088The second part of the list is used for certain types of failure reporting, I think, 2089whereas the other parts are what we need to build the correct contract forms (once we 2090have the method implementation to contract). In the interface contract info returned 2091from a list of contracts, the info for the leaves contains #f negative blame (which 2092will be filled in with the class that implements the interface) and the info for the 2093"roots" (more on that later) contains #f positive blame (which is filled in with the 2094info for the client of the class). 2095 2096When we have a particular class, we can fill in the neg. blame for the leaves in the hierarchy, and 2097then we also apply as much of these structures have complete data to the method implementation 2098 (that is, non-#f pos and neg blames so we can appropriately construct the correct `contract' forms). 2099 2100What's left is a list of non-complete data for the root(s) of the hierarchy (by roots, I mean 2101the first interfaces where this method is mentioned in the interface hierarchy). We store that 2102list along with the method implementation, so that once we have the neg. blame (the blame region 2103that instantiates the class in question), we can complete this data and apply those 2104last few projections. 2105 2106|# 2107 2108;; compose-class: produces one result if `deserialize-id' is #f, two 2109;; results if `deserialize-id' is not #f 2110(define (compose-class name ; symbol 2111 super ; class, possibly with contract impersonator properties 2112 interfaces ; list of interfaces 2113 inspector ; inspector or #f 2114 deserialize-id ; identifier or #f 2115 any-localized? ; #t => need to double-check distinct external names 2116 2117 num-fields ; total fields (public & private) 2118 public-field-names ; list of symbols (shorter than num-fields) 2119 inherit-field-names ; list of symbols (not included in num-fields) 2120 private-field-names ; list of symbols (the rest of num-fields) 2121 2122 rename-super-names ; list of symbols 2123 rename-inner-names 2124 pubment-names 2125 public-final-names 2126 public-normal-names 2127 overment-names 2128 override-final-names 2129 override-normal-names 2130 augment-names 2131 augment-final-names 2132 augride-normal-names 2133 inherit-names 2134 abstract-names 2135 2136 init-args ; list of symbols in order, or #f 2137 init-mode ; 'normal, 'stop, or 'list 2138 2139 make-methods ; takes field and method accessors 2140 2141 check-undef? 2142 2143 make-struct:prim) ; see "primitive classes", below 2144 (define (make-method proc meth-name) 2145 (procedure-rename 2146 (procedure->method proc) 2147 (string->symbol 2148 (format "~a method~a~a" 2149 meth-name 2150 (if name " in " "") 2151 (or name ""))))) 2152 2153 ;; -- Check superclass -- 2154 (unless (class? super) 2155 (obj-error 'class* "superclass expression result is not a class" 2156 "result" super 2157 #:class-name name)) 2158 2159 (when any-localized? 2160 (check-still-unique name 2161 init-args 2162 "initialization argument names") 2163 ;; We intentionally leave inherited names out of the lists below, 2164 ;; on the theory that it's ok to decide to inherit from yourself: 2165 (check-still-unique name public-field-names "field names") 2166 (check-still-unique name 2167 (append pubment-names public-final-names public-normal-names 2168 overment-names override-final-names override-normal-names 2169 augment-names augment-final-names augride-normal-names 2170 abstract-names) 2171 "method names")) 2172 2173 ;; -- Run class-seal/unseal checkers -- 2174 (when (has-seals? super) 2175 (define seals (get-seals super)) 2176 (define all-inits init-args) 2177 (define all-fields (append public-field-names inherit-field-names)) 2178 (define all-methods (append rename-super-names 2179 rename-inner-names 2180 pubment-names 2181 public-final-names 2182 public-normal-names 2183 overment-names 2184 override-final-names 2185 override-normal-names 2186 augment-names 2187 augment-final-names 2188 augride-normal-names 2189 inherit-names 2190 abstract-names)) 2191 (define all-init-checkers 2192 (map (λ (sl) (seal-init-checker sl)) seals)) 2193 (define all-field-checkers 2194 (map (λ (sl) (seal-field-checker sl)) seals)) 2195 (define all-method-checkers 2196 (map (λ (sl) (seal-method-checker sl)) seals)) 2197 (for ([f all-init-checkers]) (f all-inits)) 2198 (for ([f all-field-checkers]) (f all-fields)) 2199 (for ([f all-method-checkers]) (f all-methods))) 2200 2201 ;; -- Create new class's name -- 2202 (let* ([name (or name 2203 (let ([s (class-name super)]) 2204 (and s 2205 (not (eq? super object%)) 2206 (if (symbol? s) ;; how can 's' not be a symbol at this point? 2207 (string->symbol (format "derived-from-~a" s)) 2208 s))))] 2209 ;; Combine method lists 2210 [public-names (append pubment-names public-final-names public-normal-names abstract-names)] 2211 [override-names (append overment-names override-final-names override-normal-names)] 2212 [augride-names (append augment-names augment-final-names augride-normal-names)] 2213 [final-names (append public-final-names override-final-names augment-final-names)] 2214 [augonly-names (append pubment-names overment-names augment-names)] 2215 ;; Misc utilities 2216 [no-new-methods? (null? public-names)] 2217 [no-method-changes? (and (null? public-names) 2218 (null? override-names) 2219 (null? augride-names) 2220 (null? final-names))] 2221 [no-new-fields? (null? public-field-names)] 2222 [xappend (lambda (a b) (if (null? b) a (append a b)))]) 2223 2224 ;; -- Check interfaces --- 2225 (for-each 2226 (lambda (intf) 2227 (unless (interface? intf) 2228 (obj-error 'class* "interface expression result is not an interface" 2229 "result" intf 2230 #:class-name name))) 2231 interfaces) 2232 2233 ;; -- Check inspectors --- 2234 (when inspector 2235 (unless (inspector? inspector) 2236 (obj-error 'class* "class `inspect' result is not an inspector or #f" 2237 "result" inspector 2238 #:class-name name))) 2239 2240 ;; -- Match method and field names to indices -- 2241 (let ([method-ht (if no-new-methods? 2242 (class-method-ht super) 2243 (hash-copy (class-method-ht super)))] 2244 [field-ht (if no-new-fields? 2245 (class-field-ht super) 2246 (hash-copy (class-field-ht super)))] 2247 [super-method-ht (class-method-ht super)] 2248 [super-method-ids (class-method-ids super)] 2249 [super-field-ids (class-field-ids super)] 2250 [super-field-ht (class-field-ht super)] 2251 [super-abstract-ids (class-abstract-ids super)]) 2252 2253 ;; Put new ids in table, with pos (replace field pos with accessor info later) 2254 (unless no-new-methods? 2255 (for ([id (in-list public-names)] 2256 [p (in-naturals (class-method-width super))]) 2257 (when (hash-ref method-ht id #f) 2258 (obj-error 'class* "superclass already contains method" 2259 "superclass" super 2260 "method name" (as-write id) 2261 #:class-name name)) 2262 (hash-set! method-ht id p))) 2263 2264 ;; Keep check here for early failure, will add to hashtable later in this function. 2265 (unless no-new-fields? 2266 (for ([id (in-list public-field-names)]) 2267 (when (hash-ref field-ht id #f) 2268 (obj-error 'class* "superclass already contains field" 2269 "superclass" super 2270 "field name" (as-write id) 2271 #:class-name name)))) 2272 2273 ;; Check that superclass has expected fields 2274 (for-each (lambda (id) 2275 (unless (hash-ref field-ht id #f) 2276 (obj-error 'class* "superclass does not provide field" 2277 "superclass" super 2278 "field name" (as-write id) 2279 (and name "class") name))) 2280 inherit-field-names) 2281 2282 ;; Check that superclass has expected methods, and get indices 2283 (let ([get-indices 2284 (lambda (method-ht what ids) 2285 (map 2286 (lambda (id) 2287 (hash-ref 2288 method-ht id 2289 (lambda () 2290 (obj-error 'class* 2291 (format "~a does not provide an expected method for ~a" 2292 (if (eq? method-ht super-method-ht) "superclass" "class") 2293 what) 2294 (format "~a name" what) (as-write id) 2295 #:class-name name)))) 2296 ids))] 2297 [method-width (+ (class-method-width super) (length public-names))] 2298 [field-width (+ (class-field-width super) num-fields)] 2299 [field-pub-width (+ (class-field-pub-width super) (length public-field-names))]) 2300 (let ([inherit-indices (get-indices super-method-ht "inherit" inherit-names)] 2301 [replace-augonly-indices (get-indices super-method-ht "overment" overment-names)] 2302 [replace-final-indices (get-indices super-method-ht "override-final" override-final-names)] 2303 [replace-normal-indices (get-indices super-method-ht "override" override-normal-names)] 2304 [refine-augonly-indices (get-indices super-method-ht "augment" augment-names)] 2305 [refine-final-indices (get-indices super-method-ht "augment-final" augment-final-names)] 2306 [refine-normal-indices (get-indices super-method-ht "augride" augride-normal-names)] 2307 [rename-super-indices (get-indices super-method-ht "rename-super" rename-super-names)] 2308 [rename-inner-indices (get-indices method-ht "rename-inner" rename-inner-names)] 2309 [new-augonly-indices (get-indices method-ht "pubment" pubment-names)] 2310 [new-final-indices (get-indices method-ht "public-final" public-final-names)] 2311 [new-normal-indices (get-indices method-ht "public" public-normal-names)] 2312 [new-abstract-indices (get-indices method-ht "abstract" abstract-names)]) 2313 2314 ;; -- Check that all interfaces are satisfied -- 2315 (for-each 2316 (lambda (intf) 2317 (for-each 2318 (lambda (var) 2319 (unless (hash-ref method-ht var #f) 2320 (obj-error 'class* 2321 "missing interface-required method" 2322 "method name" (as-write var) 2323 (and name "class name") (as-write name) 2324 (and (interface-name intf) "interface name") (as-write (interface-name intf))))) 2325 (interface-public-ids intf))) 2326 interfaces) 2327 (let ([c (get-implement-requirement interfaces 'class* #:class-name name)]) 2328 (when (and c (not (subclass? super c))) 2329 (obj-error 'class* 2330 "interface-required implementation not satisfied" 2331 (and name "class name") (as-write name) 2332 (and (class-name c) "required class name") (as-write (class-name c))))) 2333 2334 ;; -- For serialization, check that the superclass is compatible -- 2335 (when deserialize-id 2336 (unless (class-serializer super) 2337 (obj-error 'class* 2338 "superclass is not serialiazable, not transparent, and does not implement externalizable<%>" 2339 "superclass" super 2340 #:class-name name))) 2341 2342 ;; ---- Make the class and its interface ---- 2343 (let* ([class-make (if name 2344 (make-naming-constructor struct:class name "class") 2345 make-class)] 2346 [interface-make (if name 2347 (make-naming-constructor 2348 struct:interface 2349 (string->symbol (format "interface:~a" name)) 2350 #f) 2351 make-interface)] 2352 [method-names (append (reverse public-names) super-method-ids)] 2353 [field-names (append public-field-names super-field-ids)] 2354 ;; Superclass abstracts that have not been concretized 2355 [remaining-abstract-names 2356 (append abstract-names 2357 (remq* override-names super-abstract-ids))] 2358 [super-interfaces (cons (class-self-interface super) interfaces)] 2359 [i (interface-make name super-interfaces #f method-names (make-immutable-hash) #f null)] 2360 [methods (if no-method-changes? 2361 (class-methods super) 2362 (make-vector method-width))] 2363 [super-methods (if no-method-changes? 2364 (class-super-methods super) 2365 (make-vector method-width))] 2366 [int-methods (if no-method-changes? 2367 (class-int-methods super) 2368 (make-vector method-width))] 2369 [beta-methods (if no-method-changes? 2370 (class-beta-methods super) 2371 (make-vector method-width))] 2372 [inner-projs (if no-method-changes? 2373 (class-inner-projs super) 2374 (make-vector method-width))] 2375 [dynamic-idxs (if no-method-changes? 2376 (class-dynamic-idxs super) 2377 (make-vector method-width))] 2378 [dynamic-projs (if no-method-changes? 2379 (class-dynamic-projs super) 2380 (make-vector method-width))] 2381 [meth-flags (if no-method-changes? 2382 (class-meth-flags super) 2383 (make-vector method-width))] 2384 [c (class-make name 2385 (add1 (class-pos super)) 2386 (list->vector (append (vector->list (class-supers super)) (list #f))) 2387 i 2388 (let-values ([(struct: make- ? -ref -set) (make-struct-type 'insp #f 0 0 #f null inspector)]) 2389 make-) 2390 inspector 2391 method-width method-ht method-names remaining-abstract-names 2392 (interfaces->contracted-methods (list i)) 2393 #f 2394 methods super-methods int-methods beta-methods meth-flags 2395 inner-projs dynamic-idxs dynamic-projs 2396 field-width field-pub-width field-ht field-names 2397 (append (reverse private-field-names) 2398 (reverse public-field-names) 2399 (class-all-field-ids super)) 2400 'struct:object 'object? 'make-object 'field-ref 'field-set! 2401 init-args 2402 init-mode 2403 'init 2404 #f #f #f ; serializer is set later 2405 (or check-undef? (class-check-undef? super)) 2406 (and make-struct:prim #t))] 2407 [obj-name (if name 2408 (string->symbol (format "object:~a" name)) 2409 'object)] 2410 ;; Used only for prim classes 2411 [preparer (lambda (name) 2412 ;; Map symbol to number: 2413 (hash-ref method-ht name))] 2414 [dispatcher (lambda (obj n) 2415 ;; Extract method: 2416 (vector-ref (class-methods (object-ref obj)) n))]) 2417 2418 (setup-all-implemented! i) 2419 (vector-set! (class-supers c) (add1 (class-pos super)) c) 2420 (set-class-orig-cls! c c) 2421 2422 2423 ;; --- Make the new external method contract records --- 2424 ;; (they are just copies of the super at this point, updated below) 2425 (define wci-neg-extra-arg-vec 2426 (if (impersonator-prop:has-wrapped-class-neg-party? super) 2427 (let* ([the-info (impersonator-prop:get-wrapped-class-info super)] 2428 [ov (wrapped-class-info-neg-extra-arg-vec the-info)]) 2429 (if no-method-changes? 2430 ov 2431 (let ([v (make-vector method-width #f)]) 2432 (vector-copy! v 0 ov) 2433 v))) 2434 #f)) 2435 (define wci-neg-acceptors-ht 2436 (if (impersonator-prop:has-wrapped-class-neg-party? super) 2437 (let* ([the-info (impersonator-prop:get-wrapped-class-info super)] 2438 [oh (wrapped-class-info-neg-acceptors-ht the-info)]) 2439 (if no-method-changes? 2440 oh 2441 (hash-copy oh))) 2442 #f)) 2443 2444 ;; --- Make the new object struct --- 2445 (let*-values ([(prim-object-make prim-object? struct:prim-object) 2446 (if make-struct:prim 2447 (make-struct:prim c prop:object 2448 preparer dispatcher 2449 (get-properties interfaces)) 2450 (values #f #f #f))] 2451 [(struct:object object-make object? object-field-ref object-field-set!) 2452 (if make-struct:prim 2453 ;; Use prim struct: 2454 (values struct:prim-object prim-object-make prim-object? #f #f) 2455 ;; Normal struct creation: 2456 (make-struct-type obj-name 2457 (add-properties (class-struct:object super) interfaces) 2458 0 ;; No init fields 2459 ;; Fields for new slots: 2460 num-fields unsafe-undefined 2461 ;; Map object property to class: 2462 (append 2463 (list (cons prop:object c)) 2464 (if (class-check-undef? c) 2465 (list (cons prop:chaperone-unsafe-undefined 2466 (class-all-field-ids c))) 2467 null) 2468 (if deserialize-id 2469 (list 2470 (cons prop:serializable 2471 ;; Serialization: 2472 (make-serialize-info 2473 (lambda (obj) 2474 ((class-serializer c) obj)) 2475 deserialize-id 2476 (not (interface-extension? i externalizable<%>)) 2477 (or (current-load-relative-directory) 2478 (current-directory))))) 2479 null)) 2480 inspector))]) 2481 (set-class-struct:object! c struct:object) 2482 (set-class-object?! c object?) 2483 (set-class-make-object! c object-make) 2484 (unless (zero? num-fields) 2485 ;; We need these only if there are fields, used for for public-field 2486 ;; access or for inspection: 2487 (set-class-field-ref! c object-field-ref) 2488 (set-class-field-set!! c object-field-set!)) 2489 2490 ;; --- Build field accessors and mutators --- 2491 ;; Use public field names to name the accessors and mutators 2492 (let-values ([(inh-accessors inh-mutators) 2493 (for/lists (accs muts) ([id (in-list inherit-field-names)]) 2494 (let ([fi (hash-ref field-ht id)]) 2495 (values (field-info-internal-ref fi) (field-info-internal-set! fi))))]) 2496 ;; Add class/index pairs for public fields. 2497 (unless no-new-fields? 2498 (for ([id (in-list public-field-names)] 2499 [i (in-naturals)]) 2500 (hash-set! field-ht id (make-field-info c i)))) 2501 2502 ;; -- Extract superclass methods and make rename-inners --- 2503 (let ([rename-supers (map (lambda (index mname) 2504 ;; While the last part of the vector is indeed the right 2505 ;; method, if there have been super contracts placed since, 2506 ;; they won't be reflected there, only in the super-methods 2507 ;; vector of the superclass. 2508 (let ([vec (vector-ref (class-beta-methods super) index)]) 2509 (when (and (positive? (vector-length vec)) 2510 (not (vector-ref vec (sub1 (vector-length vec))))) 2511 (obj-error 'class* 2512 (string-append 2513 "superclass method for override, overment, inherit/super, " 2514 "or rename-super is not overrideable") 2515 "superclass" super 2516 "method name" (as-write mname) 2517 #:class-name name))) 2518 (vector-ref (class-super-methods super) index)) 2519 rename-super-indices 2520 rename-super-names)] 2521 [rename-inners (let ([new-augonly (make-vector method-width #f)]) 2522 (define (get-depth index) 2523 (+ (if (index . < . (class-method-width super)) 2524 (vector-length (vector-ref (class-beta-methods super) 2525 index)) 2526 0) 2527 (if (vector-ref new-augonly index) 0 -1))) 2528 ;; To compute `rename-inner' indices, we need to know which methods 2529 ;; are augonly in this new class. 2530 (for-each (lambda (id) 2531 (vector-set! new-augonly (hash-ref method-ht id) #t)) 2532 (append pubment-names overment-names)) 2533 (let ([check-aug 2534 (lambda (maybe-here?) 2535 (lambda (mname index) 2536 (let ([aug-ok? 2537 (or (if (index . < . (class-method-width super)) 2538 (eq? (vector-ref (class-meth-flags super) index) 'augmentable) 2539 #f) 2540 (and maybe-here? 2541 (or (memq mname pubment-names) 2542 (memq mname overment-names))))]) 2543 (unless aug-ok? 2544 (obj-error 'class* 2545 (string-append 2546 "superclass method for augride, augment, inherit/inner, " 2547 "or rename-inner method is not augmentable") 2548 "superclass" super 2549 "method name" (as-write mname) 2550 #:class-name name)))))]) 2551 (for-each (check-aug #f) 2552 augride-normal-names 2553 (get-indices method-ht "augride" augride-normal-names)) 2554 (for-each (check-aug #f) 2555 augment-final-names 2556 refine-final-indices) 2557 (for-each (check-aug #t) 2558 rename-inner-names 2559 rename-inner-indices)) 2560 ;; Now that checking is done, add `augment': 2561 (for-each (lambda (id) 2562 (vector-set! new-augonly (hash-ref method-ht id) #t)) 2563 augment-names) 2564 (map (lambda (mname index) 2565 (let ([depth (get-depth index)]) 2566 (lambda (obj) 2567 (vector-ref (vector-ref (class-beta-methods (object-ref obj)) 2568 index) 2569 depth)))) 2570 rename-inner-names 2571 rename-inner-indices))]) 2572 2573 ;; Have to update these before making the method-accessors, since this is a "static" piece 2574 ;; of information (instead of being dynamic => method call time). 2575 (unless no-method-changes? 2576 (vector-copy! dynamic-idxs 0 (class-dynamic-idxs super)) 2577 (for-each (lambda (index) 2578 (vector-set! dynamic-idxs index 0)) 2579 (append new-augonly-indices new-final-indices 2580 new-normal-indices new-abstract-indices))) 2581 2582 ;; -- Create method accessors -- 2583 (let ([method-accessors 2584 (map (lambda (index) 2585 (let ([dyn-idx (vector-ref dynamic-idxs index)]) 2586 (lambda (obj) 2587 (vector-ref (vector-ref (class-int-methods (object-ref obj)) 2588 index) 2589 dyn-idx)))) 2590 (append new-normal-indices replace-normal-indices refine-normal-indices 2591 replace-augonly-indices refine-augonly-indices 2592 replace-final-indices refine-final-indices 2593 new-abstract-indices inherit-indices))]) 2594 2595 ;; -- Get new methods and initializers -- 2596 (let-values ([(new-methods override-methods augride-methods init) 2597 (apply make-methods object-field-ref object-field-set! 2598 (append inh-accessors 2599 inh-mutators 2600 rename-supers 2601 rename-inners 2602 method-accessors))]) 2603 ;; -- Fill in method tables -- 2604 ;; First copy old methods 2605 (unless no-method-changes? 2606 (vector-copy! methods 0 (class-methods super)) 2607 (vector-copy! super-methods 0 (class-super-methods super)) 2608 (vector-copy! int-methods 0 (class-int-methods super)) 2609 (vector-copy! beta-methods 0 (class-beta-methods super)) 2610 (vector-copy! meth-flags 0 (class-meth-flags super)) 2611 (vector-copy! inner-projs 0 (class-inner-projs super)) 2612 (vector-copy! dynamic-projs 0 (class-dynamic-projs super))) 2613 ;; Add new methods: 2614 (for-each (lambda (index method) 2615 (vector-set! methods index method) 2616 (vector-set! super-methods index method) 2617 (vector-set! int-methods index (vector method)) 2618 (vector-set! beta-methods index (vector)) 2619 (vector-set! inner-projs index values) 2620 (vector-set! dynamic-idxs index 0) 2621 (vector-set! dynamic-projs index (vector values))) 2622 (append new-augonly-indices new-final-indices 2623 new-abstract-indices new-normal-indices) 2624 new-methods) 2625 ;; Add only abstracts, making sure the super method just calls (void) 2626 (let ([dummy (lambda args (void))]) 2627 (for-each (lambda (index) 2628 (vector-set! super-methods index dummy)) 2629 new-abstract-indices)) 2630 ;; Override old methods: 2631 (for-each (lambda (index method id) 2632 (when (eq? 'final (vector-ref meth-flags index)) 2633 (obj-error 'class* 2634 "cannot override or augment final method" 2635 "method name" (as-write id) 2636 #:class-name name)) 2637 (let ([v (vector-ref beta-methods index)]) 2638 (if (zero? (vector-length v)) 2639 ;; Normal mode - set vtable entry 2640 (begin (vector-set! methods index method) 2641 (vector-set! super-methods index method) 2642 (let* ([dyn-idx (vector-ref dynamic-idxs index)] 2643 [new-vec (make-vector (add1 dyn-idx))] 2644 [proj-vec (vector-ref dynamic-projs index)]) 2645 (let loop ([n dyn-idx] [m method]) 2646 (if (< n 0) 2647 (void) 2648 (let* ([p (vector-ref proj-vec n)] 2649 [new-m (make-method (p m) id)]) 2650 (vector-set! new-vec n new-m) 2651 (loop (sub1 n) new-m))) 2652 (vector-set! int-methods index new-vec)))) 2653 ;; Under final mode - set extended vtable entry 2654 (let ([v (list->vector (vector->list v))]) 2655 (vector-set! super-methods index method) 2656 (vector-set! v (sub1 (vector-length v)) 2657 ;; Apply current inner contract projection 2658 (make-method ((vector-ref inner-projs index) method) id)) 2659 (vector-set! beta-methods index v)))) 2660 (unless (vector-ref meth-flags index) 2661 (vector-set! meth-flags index (not make-struct:prim))) 2662 2663 ;; clear out external contracts for methods that are overridden 2664 (when wci-neg-extra-arg-vec 2665 (vector-set! wci-neg-extra-arg-vec index #f) 2666 (hash-remove! wci-neg-acceptors-ht method))) 2667 (append replace-augonly-indices replace-final-indices replace-normal-indices 2668 refine-augonly-indices refine-final-indices refine-normal-indices) 2669 (append override-methods augride-methods) 2670 (append override-names augride-names)) 2671 ;; Update 'augmentable flags: 2672 (unless no-method-changes? 2673 (for-each (lambda (id) 2674 (vector-set! meth-flags (hash-ref method-ht id) 'augmentable)) 2675 (append overment-names pubment-names)) 2676 (for-each (lambda (id) 2677 (vector-set! meth-flags (hash-ref method-ht id) #t)) 2678 augride-normal-names)) 2679 ;; Expand `rename-inner' vector, adding a #f to indicate that 2680 ;; no rename-inner function is available, so far 2681 (for-each (lambda (id) 2682 (let ([index (hash-ref method-ht id)]) 2683 (let ([v (list->vector (append (vector->list (vector-ref beta-methods index)) 2684 (list #f)))]) 2685 ;; Since this starts a new part of the chain, reset the projection. 2686 (vector-set! inner-projs index values) 2687 (vector-set! beta-methods index v)))) 2688 augonly-names) 2689 ;; Mark final methods: 2690 (for-each (lambda (id) 2691 (let ([index (hash-ref method-ht id)]) 2692 (vector-set! meth-flags index 'final))) 2693 final-names) 2694 ;; Handle interface contracted methods: 2695 (for-each (lambda (id) 2696 (let ([index (hash-ref method-ht id)] 2697 [blame `(class ,name)]) 2698 ;; Store blame information that will be instantiated later 2699 (define ictc-infos (get-interface-contract-info 2700 (class-self-interface c) id)) 2701 (define meth-entry (vector-ref methods index)) 2702 (define meth (if (pair? meth-entry) 2703 (car meth-entry) 2704 meth-entry)) 2705 (vector-set! methods index 2706 (list meth 2707 ;; Replace #f positive parties w/ this class 2708 (replace-ictc-blame ictc-infos #t blame))))) 2709 (class-method-ictcs c)) 2710 2711 ;; --- Install serialize info into class -- 2712 (set-class-serializer! 2713 c 2714 (cond 2715 [(interface-extension? i externalizable<%>) 2716 (let ([index (car (get-indices method-ht "???" '(externalize)))]) 2717 (lambda (obj) 2718 (vector ((vector-ref methods index) obj))))] 2719 [(and (or deserialize-id 2720 (not inspector)) 2721 (class-serializer super)) 2722 => (lambda (ss) 2723 (lambda (obj) 2724 (vector (cons (ss obj) 2725 (let loop ([i 0]) 2726 (if (= i num-fields) 2727 null 2728 (cons (object-field-ref obj i) 2729 (loop (add1 i)))))))))] 2730 [else #f])) 2731 2732 (set-class-fixup! 2733 c 2734 ;; Used only for non-externalizable: 2735 (lambda (o args) 2736 (if (pair? args) 2737 (begin 2738 ((class-fixup super) o (vector-ref (car args) 0)) 2739 (let loop ([i 0][args (cdr args)]) 2740 (unless (= i num-fields) 2741 (object-field-set! o i (car args)) 2742 (loop (add1 i) (cdr args))))) 2743 (begin 2744 ((class-fixup super) o args) 2745 (let loop ([i 0]) 2746 (unless (= i num-fields) 2747 (object-field-set! o i (object-field-ref args i)) 2748 (loop (add1 i)))))))) 2749 2750 ;; --- Install initializer into class --- 2751 ;; and create contract-wrapped subclass 2752 (define c+ctc 2753 (cond 2754 [wci-neg-extra-arg-vec 2755 (define neg-party (impersonator-prop:get-wrapped-class-neg-party super)) 2756 (define info (impersonator-prop:get-wrapped-class-info super)) 2757 (define blame (wrapped-class-info-blame info)) 2758 (define sub-init-proj-pairs 2759 (let loop ([proj-pairs (wrapped-class-info-init-proj-pairs info)]) 2760 (cond 2761 [(null? proj-pairs) '()] 2762 [else 2763 (define pr (car proj-pairs)) 2764 (if (member (list-ref pr 0) init-args) 2765 (loop (cdr proj-pairs)) 2766 (cons pr (loop (cdr proj-pairs))))]))) 2767 (define super-init-proj-pairs (wrapped-class-info-init-proj-pairs info)) 2768 2769 ;; use an init that checks the super contracts on a super call 2770 (set-class-init! 2771 c 2772 (λ (o continue-make-super c inited? leftovers named-args) 2773 (define (contract-checking-continue-make-super o c inited? 2774 leftovers 2775 by-pos-args 2776 new-named-args) 2777 (check-arg-contracts blame neg-party c 2778 super-init-proj-pairs 2779 new-named-args) 2780 (continue-make-super o c inited? 2781 leftovers 2782 by-pos-args 2783 new-named-args)) 2784 (init o contract-checking-continue-make-super 2785 c inited? leftovers named-args))) 2786 2787 ;; add properties to the subclass that 2788 ;; check the residual external contracts 2789 (impersonate-struct 2790 c 2791 2792 set-class-orig-cls! (λ (a b) b) 2793 2794 impersonator-prop:wrapped-class-neg-party 2795 neg-party 2796 2797 impersonator-prop:wrapped-class-info 2798 (wrapped-class-info 2799 blame 2800 wci-neg-extra-arg-vec 2801 wci-neg-acceptors-ht 2802 (wrapped-class-info-pos-field-projs info) 2803 (wrapped-class-info-neg-field-projs info) 2804 sub-init-proj-pairs))] 2805 [else 2806 (set-class-init! c init) 2807 c])) 2808 2809 ;; -- result is the class, and maybe deserialize-info --- 2810 (if deserialize-id 2811 (values c+ctc 2812 (make-deserialize-info 2813 (if (interface-extension? i externalizable<%>) 2814 (lambda (args) 2815 (let ([o (make-object c)]) 2816 (send o internalize args) 2817 o)) 2818 (lambda (args) 2819 (let ([o (make-object-uninitialized c `(class ,name))]) 2820 ((class-fixup c) o args) 2821 o))) 2822 (if (interface-extension? i externalizable<%>) 2823 (lambda () 2824 (obj-error 'deserialize 2825 "cannot deserialize instance with cycles" 2826 #:class-name name)) 2827 (lambda () 2828 (let ([o (object-make)]) 2829 (values o 2830 (lambda (o2) 2831 ((class-fixup c) o o2)))))))) 2832 (copy-seals super c+ctc))))))))))))) 2833 2834;; (listof interface?) -> (listof symbol?) 2835;; traverse the interfaces and figure out contracted methods 2836(define (interfaces->contracted-methods loi) 2837 (define immediate-methods 2838 (map (λ (ifc) (hash-keys (interface-contracts ifc))) loi)) 2839 (define super-methods 2840 (map (λ (ifc) (interfaces->contracted-methods (interface-supers ifc))) loi)) 2841 (remove-duplicates (apply append (append immediate-methods super-methods)) eq?)) 2842 2843#| 2844An example 2845 2846(define (c1 x) #t) 2847(define (c2 x) #t) 2848(define (c3 x) #t) 2849(define (c4 x) #t) 2850(define (c5 x) #t) 2851(define (c6 x) #t) 2852(define (c7 x) #t) 2853(define (c8 x) #t) 2854 2855(define i1 2856 (interface () [x c1])) 2857(define i2 2858 (interface (i1) [x c2])) 2859(define i3 2860 (interface (i1) [x c3])) 2861(define i4 2862 (interface (i2 i3) [x c4])) 2863(define i5 2864 (interface (i3) [x c5])) 2865(define i6 2866 (interface (i2) [x c6])) 2867(define i7 2868 (interface (i4 i5) [x c7])) 2869(define i8 2870 (interface (i6 i7) [x c8])) 2871 2872(get-interface-contract-info i8 'x) 2873 2874 '((#<procedure:c8> i8 #f i8) (#<procedure:c6> i6 i8 i6) 2875 (#<procedure:c2> i2 i6 i2) (#<procedure:c1> i1 i2 #f) 2876 2877 (#<procedure:c7> i7 i8 i7) (#<procedure:c4> i4 i7 i4) 2878 2879 (#<procedure:c3> i3 i4 i3) 2880 2881 (#<procedure:c5> i5 i7 i5)) 2882|# 2883;; interface symbol -> (listof (list contract name (or blame #f) (or blame #f))) 2884;; traverse hierarchy to find ctc/blame info for a given method 2885(define (get-interface-contract-info ifc meth) 2886 ;; recur on hierarchy 2887 (define super-infos 2888 (apply append (map (λ (ifc) (get-interface-contract-info ifc meth)) 2889 (interface-supers ifc)))) 2890 ;; deduplicate the infos we get 2891 (define dedup-infos 2892 (let loop ([infos super-infos]) 2893 (if (null? infos) 2894 '() 2895 (cons (car infos) 2896 (loop (remove* (list (car infos)) 2897 (cdr infos) 2898 (λ (i1 i2) (eq? (car i1) (car i2))))))))) 2899 (define our-ctc (hash-ref (interface-contracts ifc) meth #f)) 2900 (define our-ctcs (hash-keys (interface-contracts ifc))) 2901 (define our-name `(interface ,(interface-name ifc))) 2902 (cond ;; if we don't have the contract, the parent's info is fine 2903 [(not our-ctc) dedup-infos] 2904 ;; if the parent's don't contract it, then it's just our ctc 2905 [(null? dedup-infos) (list (list our-ctc our-name #f #f))] 2906 ;; our ctc should have a negative party of ourself (for behav. subtyping) 2907 [else (cons (list our-ctc our-name #f our-name) 2908 ;; replace occurrences of #f positive blame with this interface 2909 (map (λ (info) 2910 (if (not (caddr info)) 2911 (list (car info) (cadr info) our-name (cadddr info)) 2912 info)) 2913 dedup-infos))])) 2914 2915;; infos bool blame -> infos 2916;; replace either positive or negative parties that are #f with blame 2917(define (replace-ictc-blame infos pos? blame) 2918 (if pos? 2919 (for/list ([info infos]) 2920 (list (car info) (cadr info) (or (caddr info) blame) (cadddr info))) 2921 (for/list ([info infos]) 2922 (list (car info) (cadr info) (caddr info) (or (cadddr info) blame))))) 2923 2924(define (check-still-unique name syms what) 2925 (let ([ht (make-hasheq)]) 2926 (for-each (lambda (s) 2927 (when (hash-ref ht s 2928 (lambda () 2929 (hash-set! ht s #t) 2930 #f)) 2931 (obj-error 'class* (format "external ~a mapped to overlapping keys" 2932 what) 2933 #:class-name name))) 2934 syms))) 2935 2936(define (get-properties intfs) 2937 (if (ormap (lambda (i) 2938 (pair? (interface-properties i))) 2939 intfs) 2940 (let ([ht (make-hash)]) 2941 ;; Hash on gensym to avoid providing the same property multiple 2942 ;; times when it originated from a single interface. 2943 (for-each (lambda (i) 2944 (for-each (lambda (p) 2945 (hash-set! ht (vector-ref p 0) p)) 2946 (interface-properties i))) 2947 intfs) 2948 (hash-map ht (lambda (k v) (cons (vector-ref v 1) 2949 (vector-ref v 2))))) 2950 ;; No properties to add: 2951 null)) 2952 2953(define (add-properties struct-type intfs) 2954 (let ([props (get-properties intfs)]) 2955 (if (null? props) 2956 struct-type 2957 ;; Create a new structure type to house the properties, so 2958 ;; that they can't see any fields directly via guards: 2959 (let-values ([(struct: make- ? -ref -set!) 2960 (make-struct-type 'props struct-type 0 0 #f props #f)]) 2961 struct:)))) 2962 2963(define-values (prop:object _object? object-ref) 2964 (make-struct-type-property 'object 'can-impersonate)) 2965(define (object? o) 2966 (or (_object? o) 2967 (wrapped-object? o))) 2968(define (object-ref/unwrap o) 2969 (cond 2970 [(_object? o) (object-ref o)] 2971 [(wrapped-object? o) (object-ref/unwrap (wrapped-object-object o))] 2972 [else 2973 ;; error case 2974 (object-ref o)])) 2975 2976 2977 2978;;-------------------------------------------------------------------- 2979;; sealing/unsealing 2980;;-------------------------------------------------------------------- 2981 2982;; represents a seal on a class, only for internal use 2983;; 2984;; sym - the symbol used to identify the particular seal 2985;; inst-checker - a function to run when a sealed class is instantiated 2986;; init-checker - these three fields respectively are functions to run when 2987;; field-checker a sealed class is subclassed and should error when a sealed 2988;; method-checker member is added in the subclass 2989(struct seal (sym inst-checker init-checker field-checker method-checker) 2990 #:transparent) 2991 2992(define-values (prop:seals has-seals? get-seals) 2993 (make-impersonator-property 'class-seals)) 2994 2995(define (class-seal cls seal-sym 2996 inits fields methods 2997 inst-proc 2998 member-proc) 2999 (unless (class? cls) 3000 (raise-argument-error 'class-seal "class?" cls)) 3001 (unless (symbol? seal-sym) 3002 (raise-argument-error 'class-seal "symbol?" seal-sym)) 3003 (define (check-unsealed-names val) 3004 (unless (and (list? val) 3005 (andmap symbol? val)) 3006 (raise-argument-error 'class-seal "(listof symbol?)" val))) 3007 (check-unsealed-names inits) 3008 (check-unsealed-names fields) 3009 (check-unsealed-names methods) 3010 (unless (procedure-arity-includes? inst-proc 1) 3011 (raise-argument-error 'class-seal 3012 "(procedure-arity-includes/c 1)" inst-proc)) 3013 (unless (procedure-arity-includes? member-proc 2) 3014 (raise-argument-error 'class-seal 3015 "(procedure-arity-includes/c 2)" member-proc)) 3016 3017 (define new-seal 3018 (seal seal-sym 3019 inst-proc 3020 (make-seal-checker member-proc cls inits) 3021 (make-seal-checker member-proc cls fields) 3022 (make-seal-checker member-proc cls methods))) 3023 (define seals (cons new-seal 3024 (or (and (has-seals? cls) (get-seals cls)) null))) 3025 ;; impersonate to avoid the cost of creating a class wrapper 3026 (impersonate-struct cls 3027 class-object? #f ; just here as a witness 3028 set-class-object?! #f ; also need this witness 3029 prop:seals seals)) 3030 3031;; make-seal-checker : procedure? class? (listof symbol?) 3032;; -> (listof symbol?) -> void? 3033;; constructs a checker function parameterized over the user-provided 3034;; checker procedure and the list of unsealed names 3035(define ((make-seal-checker proc cls unsealed) actual) 3036 (define sealed-actuals (remove* unsealed actual)) 3037 (unless (null? sealed-actuals) 3038 (proc cls sealed-actuals))) 3039 3040(define (class-unseal cls sym wrong-key-proc) 3041 (unless (class? cls) 3042 (raise-argument-error 'class-seal "class?" cls)) 3043 (unless (symbol? sym) 3044 (raise-argument-error 'class-seal "symbol?" seal-sym)) 3045 3046 (define old-seals (and (has-seals? cls) (get-seals cls))) 3047 (define has-seal-with-sym? 3048 (and old-seals 3049 (for/or ([old-seal (in-list old-seals)]) 3050 (eq? sym (seal-sym old-seal))))) 3051 (unless has-seal-with-sym? 3052 (wrong-key-proc cls)) 3053 (define new-seals 3054 (remove sym (get-seals cls) 3055 (λ (sym sl) (eq? sym (seal-sym sl))))) 3056 (impersonate-struct cls 3057 class-object? #f 3058 set-class-object?! #f 3059 prop:seals new-seals)) 3060 3061;; copy-seals : class? class? -> class? 3062;; Copy the seal properties from one class to another 3063(define (copy-seals cls1 cls2) 3064 (if (has-seals? cls1) 3065 (impersonate-struct cls2 3066 class-object? #f 3067 set-class-object?! #f 3068 prop:seals (get-seals cls1)) 3069 cls2)) 3070 3071;;-------------------------------------------------------------------- 3072;; interfaces 3073;;-------------------------------------------------------------------- 3074 3075;; >> Simplistic implementation for now << 3076 3077(define-for-syntax do-interface 3078 (lambda (stx m-stx) 3079 (syntax-case m-stx () 3080 [((interface-expr ...) ([prop prop-val] ...) var ...) 3081 (let ([name (syntax-local-infer-name stx)]) 3082 (define-values (vars ctcs) 3083 (for/fold ([vars '()] [ctcs '()]) 3084 ([v (syntax->list #'(var ...))]) 3085 (syntax-case v () 3086 [id 3087 (identifier? #'id) 3088 (values (cons #'id vars) (cons #f ctcs))] 3089 [(id ctc) 3090 (identifier? #'id) 3091 (values (cons #'id vars) (cons #'ctc ctcs))] 3092 [_ (raise-syntax-error #f "not an identifier or identifier-contract pair" 3093 stx v)]))) 3094 (let ([dup (check-duplicate-identifier vars)]) 3095 (when dup 3096 (raise-syntax-error #f 3097 "duplicate name" 3098 stx 3099 dup))) 3100 (with-syntax ([name (datum->syntax #f name #f)] 3101 [(var ...) (map localize vars)] 3102 [((v c) ...) (filter (λ (p) (cadr p)) (map list vars ctcs))]) 3103 (class-syntax-protect 3104 (syntax/loc stx 3105 (compose-interface 3106 'name 3107 (list interface-expr ...) 3108 `(var ...) 3109 (make-immutable-hash (list (cons 'v c) ...)) 3110 (list prop ...) 3111 (list prop-val ...))))))]))) 3112 3113(define-syntax (_interface stx) 3114 (syntax-case stx () 3115 [(_ (interface-expr ...) var ...) 3116 (do-interface stx #'((interface-expr ...) () var ...))])) 3117 3118(define-syntax (interface* stx) 3119 (syntax-case stx () 3120 [(_ (interface-expr ...) ([prop prop-val] ...) var ...) 3121 (do-interface stx #'((interface-expr ...) ([prop prop-val] ...) var ...))] 3122 [(_ (interface-expr ...) (prop+val ...) var ...) 3123 (for-each (lambda (p+v) 3124 (syntax-case p+v () 3125 [(p v) (void)] 3126 [_ (raise-syntax-error #f 3127 "expected `[<prop-expr> <val-expr>]'" 3128 stx 3129 p+v)])) 3130 (syntax->list #'(prop+val ...)))] 3131 [(_ (interface-expr ...) prop+vals . _) 3132 (raise-syntax-error #f 3133 "expected `([<prop-expr> <val-expr>] ...)'" 3134 stx 3135 #'prop+vals)])) 3136 3137(define-struct interface 3138 (name ; symbol 3139 supers ; (listof interface) 3140 [all-implemented ; hash-table: interface -> #t 3141 #:mutable] 3142 public-ids ; (listof symbol) (in any order?!?) 3143 contracts ; (hashof symbol? contract?) 3144 [class ; (union #f class) -- means that anything implementing 3145 #:mutable] ; this interface must be derived from this class 3146 properties) ; (listof (vector gensym prop val)) 3147 #:inspector insp) 3148 3149(define (compose-interface name supers vars ctcs props vals) 3150 (for-each 3151 (lambda (intf) 3152 (unless (interface? intf) 3153 (obj-error 'interface 3154 "superinterface expression result is not an interface" 3155 "result" intf 3156 #:intf-name name))) 3157 supers) 3158 (for-each 3159 (lambda (p) 3160 (unless (struct-type-property? p) 3161 (obj-error 'interface 3162 "property expression result is not a property" 3163 "result" p 3164 #:intf-name name))) 3165 props) 3166 (let ([ht (make-hasheq)]) 3167 (for-each 3168 (lambda (var) 3169 (hash-set! ht var #t)) 3170 vars) 3171 ;; Check that vars don't already exist in supers: 3172 (for-each 3173 (lambda (super) 3174 (for-each 3175 (lambda (var) 3176 (when (and (hash-ref ht var #f) 3177 (not (hash-ref ctcs var #f))) 3178 (obj-error 'interface "variable already in superinterface" 3179 "variable name" (as-write var) 3180 (and (interface-name super) "already in") (as-write (interface-name super)) 3181 #:intf-name name))) 3182 (interface-public-ids super))) 3183 supers) 3184 ;; merge properties: 3185 (let ([prop-ht (make-hash)]) 3186 ;; Hash on gensym to avoid providing the same property multiple 3187 ;; times when it originated from a single interface. 3188 (for-each (lambda (i) 3189 (for-each (lambda (p) 3190 (hash-set! prop-ht (vector-ref p 0) p)) 3191 (interface-properties i))) 3192 supers) 3193 (for-each (lambda (p v) 3194 (let ([g (gensym)]) 3195 (hash-set! prop-ht g (vector g p v)))) 3196 props vals) 3197 ;; Check for [conflicting] implementation requirements 3198 (let ([class (get-implement-requirement supers 'interface #:intf-name name)] 3199 [interface-make (if name 3200 (make-naming-constructor struct:interface 3201 name 3202 "interface") 3203 make-interface)]) 3204 ;; Add supervars to table: 3205 (for-each 3206 (lambda (super) 3207 (for-each 3208 (lambda (var) (hash-set! ht var #t)) 3209 (interface-public-ids super))) 3210 supers) 3211 ;; Done 3212 (let* ([new-ctcs (for/hash ([(k v) (in-hash ctcs)]) 3213 (values k (coerce-contract 'interface v)))] 3214 [i (interface-make name supers #f (hash-map ht (lambda (k v) k)) 3215 new-ctcs class (hash-map prop-ht (lambda (k v) v)))]) 3216 (setup-all-implemented! i) 3217 i))))) 3218 3219;; setup-all-implemented! : interface -> void 3220;; Creates the hash table for all implemented interfaces 3221(define (setup-all-implemented! i) 3222 (let ([ht (make-hasheq)]) 3223 (hash-set! ht i #t) 3224 (for-each (lambda (si) 3225 (hash-for-each 3226 (interface-all-implemented si) 3227 (lambda (k v) 3228 (hash-set! ht k #t)))) 3229 (interface-supers i)) 3230 (set-interface-all-implemented! i ht))) 3231 3232(define (get-implement-requirement interfaces where 3233 #:class-name [class-name #f] 3234 #:intf-name [intf-name #f]) 3235 (let loop ([class #f] 3236 [supers interfaces]) 3237 (if (null? supers) 3238 class 3239 (let ([c (interface-class (car supers))]) 3240 (loop 3241 (cond 3242 [(not c) class] 3243 [(not class) c] 3244 [(subclass? c class) class] 3245 [(subclass? class c) c] 3246 [else 3247 (obj-error 3248 where 3249 "conflicting class implementation requirements in superinterfaces" 3250 #:class-name class-name 3251 #:intf-name intf-name)]) 3252 (cdr supers)))))) 3253 3254;;-------------------------------------------------------------------- 3255;; object% 3256;;-------------------------------------------------------------------- 3257 3258(define (make-naming-constructor type name prefix) 3259 (define (writeer obj port mode) 3260 (write-string "#<" port) 3261 (when prefix 3262 (write-string prefix port) 3263 (write-string ":" port)) 3264 (write-string (symbol->string name) port) 3265 (write-string ">" port)) 3266 (define props (list (cons prop:custom-write writeer))) 3267 (define-values (struct: make- ? -accessor -mutator) 3268 (make-struct-type name type 0 0 #f props insp)) 3269 make-) 3270 3271(define not-all-visible (gensym 'not-all-visible)) 3272(define (inspectable-struct->vector v) 3273 (define vec (struct->vector v not-all-visible)) 3274 (and (for/and ([elem (in-vector vec)]) 3275 (not (eq? elem not-all-visible))) 3276 vec)) 3277 3278; Even though equality on objects is morally just struct equality, we have to reimplement it here 3279; because of the way class contracts work. Every time a class contract is applied, it creates a new 3280; class, which in turn creates a new struct. This breaks equal? on objects, since two structs of 3281; different types are never equal? (without a custom prop:equal+hash), even if one is a subtype of the 3282; other. Therefore, we need to emulate what the behavior of equal? would have been if class contracts 3283; didn’t create new struct types. (This can go away if class/c is ever rewritten to use chaperones.) 3284(define (object-equal? obj-a obj-b recur) 3285 (and (equal? (object-ref obj-a) (object-ref obj-b)) 3286 (let ([vec-a (inspectable-struct->vector obj-a)]) 3287 (and vec-a (let ([vec-b (inspectable-struct->vector obj-b)]) 3288 (and vec-b (for/and ([elem-a (in-vector vec-a 1)] 3289 [elem-b (in-vector vec-b 1)]) 3290 (recur elem-a elem-b)))))))) 3291(define (object-hash-code obj recur) 3292 (let ([vec (inspectable-struct->vector obj)]) 3293 (if vec 3294 (recur (vector (object-ref obj) vec)) 3295 (eq-hash-code obj)))) 3296 3297(define object<%> ((make-naming-constructor struct:interface 'interface:object% #f) 3298 'object% null #f null (make-immutable-hash) #f null)) 3299(setup-all-implemented! object<%>) 3300(define object% ((make-naming-constructor struct:class 'object% "class") 3301 'object% 3302 0 (vector #f) 3303 object<%> 3304 void ; never inspectable 3305 #f ; this is for the inspector on the object 3306 3307 0 (make-hasheq) null null null 3308 #f 3309 (vector) (vector) (vector) (vector) (vector) 3310 3311 (vector) (vector) (vector) 3312 3313 0 0 (make-hasheq) null null 3314 3315 'struct:object object? 'make-object 3316 'field-ref-not-needed 'field-set!-not-needed 3317 3318 null 3319 'normal 3320 3321 (lambda (this super-init si_c si_inited? si_leftovers args) 3322 (unless (null? args) 3323 (unused-args-error this args)) 3324 (void)) 3325 3326 #f 3327 (lambda (obj) #(())) ; serialize 3328 (lambda (obj args) (void)) ; deserialize-fixup 3329 3330 #f ; no chaperone to guard against unsafe-undefined 3331 3332 #t)) ; no super-init 3333 3334(vector-set! (class-supers object%) 0 object%) 3335(set-class-orig-cls! object% object%) 3336(let*-values ([(struct:obj make-obj obj? -get -set!) 3337 (make-struct-type 'object #f 0 0 #f 3338 (list (cons prop:object object%) 3339 (cons prop:equal+hash 3340 (list object-equal? 3341 object-hash-code 3342 object-hash-code))) 3343 #f)]) 3344 (set-class-struct:object! object% struct:obj) 3345 (set-class-make-object! object% make-obj)) 3346(set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes 3347 3348(set-interface-class! object<%> object%) 3349 3350;;-------------------------------------------------------------------- 3351;; instantiation 3352;;-------------------------------------------------------------------- 3353 3354(define-syntax (new stx) 3355 (syntax-case stx () 3356 [(_ cls (id arg) ...) 3357 (andmap identifier? (syntax->list (syntax (id ...)))) 3358 (class-syntax-protect 3359 (quasisyntax/loc stx 3360 (instantiate cls () (id arg) ...)))] 3361 [(_ cls (id arg) ...) 3362 (for-each (lambda (id) 3363 (unless (identifier? id) 3364 (raise-syntax-error 'new "expected identifier" stx id))) 3365 (syntax->list (syntax (id ...))))] 3366 [(_ cls pr ...) 3367 (for-each 3368 (lambda (pr) 3369 (syntax-case pr () 3370 [(x y) (void)] 3371 [else (raise-syntax-error 'new "expected name and value binding" stx pr)])) 3372 (syntax->list (syntax (pr ...))))])) 3373 3374(define ((make-object/proc blame) class . args) 3375 (do-make-object blame class args null)) 3376 3377(define-syntax make-object 3378 (make-set!-transformer 3379 (lambda (stx) 3380 (syntax-case stx () 3381 [id 3382 (identifier? #'id) 3383 (class-syntax-protect 3384 (quasisyntax/loc stx 3385 (make-object/proc (current-contract-region))))] 3386 [(_ class arg ...) 3387 (class-syntax-protect 3388 (quasisyntax/loc stx 3389 (do-make-object 3390 (current-contract-region) 3391 class (list arg ...) (list))))] 3392 [(_) (raise-syntax-error 'make-object "expected class" stx)])))) 3393 3394(define-syntax (instantiate stx) 3395 (syntax-case stx () 3396 [(form class (arg ...) . x) 3397 (with-syntax ([orig-stx stx]) 3398 (class-syntax-protect 3399 (quasisyntax/loc stx 3400 (-instantiate do-make-object orig-stx #t (class) (list arg ...) . x))))])) 3401 3402;; Helper; used by instantiate and super-instantiate 3403(define-syntax -instantiate 3404 (lambda (stx) 3405 (syntax-case stx () 3406 [(_ do-make-object orig-stx first? (maker-arg ...) args (kw arg) ...) 3407 (andmap identifier? (syntax->list (syntax (kw ...)))) 3408 (with-syntax ([(kw ...) (map localize (syntax->list (syntax (kw ...))))] 3409 [(blame ...) (if (syntax-e #'first?) #'((current-contract-region)) null)]) 3410 (class-syntax-protect 3411 (syntax/loc stx 3412 (do-make-object blame ... 3413 maker-arg ... 3414 args 3415 (list (cons `kw arg) 3416 ...)))))] 3417 [(_ super-make-object orig-stx first? (make-arg ...) args kwarg ...) 3418 ;; some kwarg must be bad: 3419 (for-each (lambda (kwarg) 3420 (syntax-case kwarg () 3421 [(kw arg) 3422 (identifier? (syntax kw)) 3423 'ok] 3424 [(kw arg) 3425 (raise-syntax-error 3426 #f 3427 "by-name argument does not start with an identifier" 3428 (syntax orig-stx) 3429 kwarg)] 3430 [_else 3431 (raise-syntax-error 3432 #f 3433 "ill-formed by-name argument" 3434 (syntax orig-stx) 3435 kwarg)])) 3436 (syntax->list (syntax (kwarg ...))))]))) 3437 3438(define (alist->sexp alist) 3439 (map (lambda (pair) (list (car pair) (cdr pair))) alist)) 3440 3441;; class blame -> class 3442;; takes a class and concretize interface ctc methods 3443(define (fetch-concrete-class cls blame) 3444 (cond [(null? (class-method-ictcs cls)) cls] 3445 [(and (class-ictc-classes cls) 3446 (hash-ref (class-ictc-classes cls) blame #f)) 3447 => values] 3448 [else 3449 ;; if there are contracted methods to concretize, do so 3450 (let* ([name (class-name cls)] 3451 [ictc-meths (class-method-ictcs cls)] 3452 [method-width (class-method-width cls)] 3453 [method-ht (class-method-ht cls)] 3454 [meths (if (null? ictc-meths) 3455 (class-methods cls) 3456 (make-vector method-width))] 3457 [field-pub-width (class-field-pub-width cls)] 3458 [field-ht (class-field-ht cls)] 3459 [class-make (if name 3460 (make-naming-constructor struct:class name "class") 3461 make-class)] 3462 [c (class-make name 3463 (class-pos cls) 3464 (list->vector (vector->list (class-supers cls))) 3465 (class-self-interface cls) 3466 void ;; No inspecting 3467 (class-obj-inspector cls) 3468 3469 method-width 3470 method-ht 3471 (class-method-ids cls) 3472 null 3473 null 3474 3475 #f 3476 3477 meths 3478 (class-super-methods cls) 3479 (class-int-methods cls) 3480 (class-beta-methods cls) 3481 (class-meth-flags cls) 3482 3483 (class-inner-projs cls) 3484 (class-dynamic-idxs cls) 3485 (class-dynamic-projs cls) 3486 3487 (class-field-width cls) 3488 field-pub-width 3489 field-ht 3490 (class-field-ids cls) 3491 (class-all-field-ids cls) 3492 3493 'struct:object 'object? 'make-object 3494 'field-ref 'field-set! 3495 3496 (class-init-args cls) 3497 (class-init-mode cls) 3498 (class-init cls) 3499 3500 (class-orig-cls cls) 3501 #f #f ; serializer is never set 3502 3503 (class-check-undef? cls) 3504 #f)] 3505 [obj-name (if name 3506 (string->symbol (format "wrapper-object:~a" name)) 3507 'object)]) 3508 3509 (vector-set! (class-supers c) (class-pos c) c) 3510 3511 ;; --- Make the new object struct --- 3512 (let-values ([(struct:object object-make object? object-field-ref object-field-set!) 3513 (make-struct-type obj-name 3514 (class-struct:object cls) 3515 0 ;; No init fields 3516 0 ;; No new fields in this class replacement 3517 unsafe-undefined 3518 ;; Map object property to class: 3519 (list (cons prop:object c)) 3520 (class-obj-inspector cls))]) 3521 (set-class-struct:object! c struct:object) 3522 (set-class-object?! c object?) 3523 (set-class-make-object! c object-make) 3524 (set-class-field-ref! c object-field-ref) 3525 (set-class-field-set!! c object-field-set!)) 3526 3527 ;; Don't concretize if all concrete 3528 (unless (null? ictc-meths) 3529 ;; First, fill up since we're empty 3530 (vector-copy! meths 0 (class-methods cls)) 3531 ;; Then apply the projections to get the concrete methods 3532 (for ([m (in-list ictc-meths)]) 3533 (define index (hash-ref method-ht m)) 3534 (define entry (vector-ref meths index)) 3535 (define meth (car entry)) 3536 (define ictc-infos (replace-ictc-blame (cadr entry) #f blame)) 3537 (define wrapped-meth (concretize-ictc-method m meth ictc-infos)) 3538 (vector-set! meths index wrapped-meth))) 3539 3540 ;; initialize if not yet initialized 3541 (unless (class-ictc-classes cls) 3542 (set-class-ictc-classes! cls (make-weak-hasheq))) 3543 3544 ;; cache the concrete class 3545 (hash-set! (class-ictc-classes cls) blame c) 3546 (copy-seals cls c))])) 3547 3548;; name method info -> method 3549;; appropriately wraps the method with interface contracts 3550(define (concretize-ictc-method m meth info) 3551 (for/fold ([meth meth]) 3552 ([info (in-list info)]) 3553 (define ctc (car info)) 3554 (define pos-blame (caddr info)) 3555 (define neg-blame (cadddr info)) 3556 (contract ctc meth pos-blame neg-blame m #f))) 3557 3558(define (make-object-uninitialized class blame) 3559 (do-make-object blame class 'uninit 'uninit)) 3560 3561(define (do-make-object blame class by-pos-args named-args) 3562 (cond 3563 [(impersonator-prop:has-wrapped-class-neg-party? class) 3564 (define the-info (impersonator-prop:get-wrapped-class-info class)) 3565 (define neg-party (impersonator-prop:get-wrapped-class-neg-party class)) 3566 (define unwrapped-o 3567 (do-make-object/real-class blame class by-pos-args named-args 3568 (wrapped-class-info-blame the-info) 3569 neg-party 3570 (wrapped-class-info-init-proj-pairs the-info))) 3571 (wrapped-object 3572 unwrapped-o 3573 (wrapped-class-info-neg-extra-arg-vec the-info) 3574 (wrapped-class-info-pos-field-projs the-info) 3575 (wrapped-class-info-neg-field-projs the-info) 3576 neg-party)] 3577 [(class? class) 3578 (do-make-object/real-class blame class by-pos-args named-args #f #f '())] 3579 [else 3580 (raise-argument-error 'instantiate "class?" class)])) 3581 3582(define (do-make-object/real-class blame class by-pos-args named-args 3583 wrapped-blame wrapped-neg-party init-proj-pairs) 3584 ;; make sure the class isn't abstract 3585 (unless (null? (class-abstract-ids class)) 3586 (obj-error 'instantiate 3587 "cannot instantiate class with abstract methods" 3588 "class" class 3589 "abstract methods" (as-write-list (class-abstract-ids class)))) 3590 ;; if the class is sealed, run all sealing error procedures 3591 ;; usually, only running the first one is necessary since these are 3592 ;; expected to be error-reporting procedures. 3593 (when (has-seals? class) 3594 (for ([seal (in-list (get-seals class))]) 3595 ((seal-inst-checker seal) class))) 3596 ;; Generate correct class by concretizing methods w/interface ctcs 3597 (define concrete-class (fetch-concrete-class class blame)) 3598 (define o ((class-make-object concrete-class))) 3599 (unless (eq? by-pos-args 'uninit) 3600 (continue-make-object o concrete-class by-pos-args named-args #t 3601 wrapped-blame wrapped-neg-party init-proj-pairs)) 3602 o) 3603 3604(define (get-field-alist obj) 3605 (map (lambda (id) (cons id (get-field/proc id obj))) 3606 (field-names obj))) 3607 3608(define (continue-make-object o c by-pos-args named-args explict-named-args? 3609 wrapped-blame wrapped-neg-party init-proj-pairs) 3610 (let ([by-pos-only? (not (class-init-args c))]) 3611 ;; When a superclass has #f for init-args (meaning "by-pos args with no names"), 3612 ;; some propagated named args may have #f keys; move them to by-position args. 3613 (let-values ([(by-pos-args named-args) 3614 (if by-pos-only? 3615 (let ([l (filter (lambda (x) (not (car x))) named-args)]) 3616 (if (pair? l) 3617 (values (append by-pos-args (map cdr l)) 3618 (filter car named-args)) 3619 (values by-pos-args named-args))) 3620 (values by-pos-args named-args))]) 3621 ;; Primitive class with by-pos arguments? 3622 (when by-pos-only? 3623 (unless (null? named-args) 3624 (if explict-named-args? 3625 (obj-error 3626 'instantiate 3627 "class has only by-position initializers, but given by-name arguments" 3628 "arguments" (as-lines (make-named-arg-string named-args)) 3629 #:class-name (class-name c)) 3630 ;; If args were implicit from subclass, should report as unused: 3631 (unused-args-error o named-args)))) 3632 ;; Merge by-pos into named args: 3633 (let* ([named-args (if (not by-pos-only?) 3634 ;; Normal merge 3635 (do-merge by-pos-args (class-init-args c) c named-args by-pos-args c) 3636 ;; Non-merge for by-position initializers 3637 by-pos-args)] 3638 [leftovers (if (not by-pos-only?) 3639 (get-leftovers named-args (class-init-args c)) 3640 null)]) 3641 ;; In 'list mode, make sure no by-name arguments are left over 3642 (when (eq? 'list (class-init-mode c)) 3643 (unless (or (null? leftovers) 3644 (not (ormap car leftovers))) 3645 (unused-args-error o (filter car leftovers)))) 3646 (unless (and (eq? c object%) 3647 (null? named-args)) 3648 (let ([named-args (check-arg-contracts wrapped-blame wrapped-neg-party 3649 c init-proj-pairs named-args)]) 3650 (let ([inited? (box (class-no-super-init? c))]) 3651 ;; ----- Execute the class body ----- 3652 ((class-init c) 3653 o 3654 continue-make-super 3655 c inited? leftovers ; merely passed through to continue-make-super 3656 named-args) 3657 (unless (unbox inited?) 3658 (obj-error 'instantiate 3659 "superclass initialization not invoked by initialization" 3660 #:class-name (class-name c)))))))))) 3661 3662(define (continue-make-super o c inited? leftovers by-pos-args new-named-args) 3663 (when (unbox inited?) 3664 (obj-error 'instantiate 3665 "superclass already initialized by class initialization" 3666 #:class-name (class-name c))) 3667 (set-box! inited? #t) 3668 (let ([named-args (if (eq? 'list (class-init-mode c)) 3669 ;; all old args must have been used up 3670 new-named-args 3671 ;; Normal mode: merge leftover keyword-based args with new ones 3672 (append 3673 new-named-args 3674 leftovers))]) 3675 (continue-make-object o 3676 (vector-ref (class-supers c) (sub1 (class-pos c))) 3677 by-pos-args 3678 named-args 3679 (pair? new-named-args) 3680 #f #f '()))) 3681 3682(define (do-merge al nl ic named-args by-pos-args c) 3683 (cond 3684 [(null? al) named-args] 3685 [(null? nl) 3686 ;; continue mapping with superclass init args, if allowed 3687 (let ([super (and (eq? 'normal (class-init-mode ic)) 3688 (positive? (class-pos ic)) 3689 (vector-ref (class-supers ic) (sub1 (class-pos ic))))]) 3690 (cond 3691 [super 3692 (if (class-init-args super) 3693 (do-merge al (class-init-args super) super named-args by-pos-args c) 3694 ;; Like 'list mode: 3695 (append (map (lambda (x) (cons #f x)) al) 3696 named-args))] 3697 [(eq? 'list (class-init-mode ic)) 3698 ;; All unconsumed named-args must have #f 3699 ;; "name"s, otherwise an error is raised in 3700 ;; the leftovers checking. 3701 (if (null? al) 3702 named-args 3703 (append (map (lambda (x) (cons #f x)) al) 3704 named-args))] 3705 [else 3706 (obj-error 'instantiate 3707 "too many initialization arguments" 3708 "arguments" (as-lines (make-pos-arg-string by-pos-args)) 3709 #:class-name (class-name c))]))] 3710 [else (cons (cons (car nl) (car al)) 3711 (do-merge (cdr al) (cdr nl) ic named-args by-pos-args c))])) 3712 3713(define (get-leftovers l names) 3714 (cond 3715 [(null? l) null] 3716 [(memq (caar l) names) 3717 (get-leftovers (cdr l) (remq (caar l) names))] 3718 [else (cons (car l) (get-leftovers (cdr l) names))])) 3719 3720(define (extract-arg class-name name arguments default) 3721 (if (symbol? name) 3722 ;; Normal mode 3723 (let ([a (assq name arguments)]) 3724 (cond 3725 [a (cdr a)] 3726 [default (default)] 3727 [else (missing-argument-error class-name name)])) 3728 ;; By-position mode 3729 (cond 3730 [(< name (length arguments)) 3731 (cdr (list-ref arguments name))] 3732 [default (default)] 3733 [else (obj-error 'instantiate "too few initialization arguments")]))) 3734 3735(define (extract-rest-args skip arguments) 3736 (if (< skip (length arguments)) 3737 (map cdr (list-tail arguments skip)) 3738 null)) 3739 3740(define (make-pos-arg-string args) 3741 (let ([len (length args)]) 3742 (apply string-append 3743 (map (lambda (a) 3744 (format " ~e" a)) 3745 args)))) 3746 3747(define (make-named-arg-string args) 3748 (apply 3749 string-append 3750 (let loop ([args args][count 0]) 3751 (cond 3752 [(null? args) null] 3753 [(= count 3) '("\n ...")] 3754 [else (let ([rest (loop (cdr args) (add1 count))]) 3755 (cons (format "\n [~a ~e]" 3756 (caar args) 3757 (cdar args)) 3758 rest))])))) 3759 3760(define (unused-args-error this args) 3761 (let ([arg-string (make-named-arg-string args)]) 3762 (obj-error 'instantiate "unused initialization arguments" 3763 "unused arguments" (as-lines arg-string) 3764 #:class-name (class-name (object-ref/unwrap this)) 3765 #:which-class "instantiated "))) 3766 3767(define (missing-argument-error class-name name) 3768 (obj-error 'instantiate 3769 "no argument for required init variable" 3770 "init variable name" (as-write name) 3771 #:class-name class-name 3772 #:which-class "instantiated ")) 3773 3774;;-------------------------------------------------------------------- 3775;; methods and fields 3776;;-------------------------------------------------------------------- 3777 3778(define-syntaxes (send send/apply send/keyword-apply) 3779 (let () 3780 3781 (define (do-method stx form obj name args rest-arg? kw-args) 3782 (with-syntax ([(sym method receiver) 3783 (generate-temporaries (syntax (1 2 3)))] 3784 [(kw-arg-tmp) (generate-temporaries '(kw-vals-x))]) 3785 (define kw-args/var (and kw-args 3786 (list (car kw-args) #'kw-arg-tmp))) 3787 (define arg-list '()) 3788 (define let-bindings '()) 3789 (for ([x (in-list (if (list? args) 3790 args 3791 (syntax->list args)))]) 3792 (cond 3793 [(keyword? (syntax-e x)) 3794 (set! arg-list (cons x arg-list))] 3795 [else 3796 (define var (car (generate-temporaries '(send-arg)))) 3797 (set! arg-list (cons var arg-list)) 3798 (set! let-bindings (cons #`[#,var #,x] let-bindings))])) 3799 (set! arg-list (reverse arg-list)) 3800 (set! let-bindings (reverse let-bindings)) 3801 3802 (class-syntax-protect 3803 (syntax-property 3804 (quasisyntax/loc stx 3805 (let*-values ([(sym) (quasiquote (unsyntax (localize name)))] 3806 [(receiver) (unsyntax obj)] 3807 [(method) (find-method/who '(unsyntax form) receiver sym)]) 3808 (let (#,@(if kw-args 3809 (list #`[kw-arg-tmp #,(cadr kw-args)]) 3810 (list)) 3811 #,@let-bindings) 3812 (unsyntax 3813 (make-method-call-to-possibly-wrapped-object 3814 stx kw-args/var arg-list rest-arg? 3815 #'sym #'method #'receiver 3816 (quasisyntax/loc stx (find-method/who '(unsyntax form) receiver sym))))))) 3817 'feature-profile:send-dispatch #t)))) 3818 3819 (define (core-send apply? kws?) 3820 (lambda (stx) 3821 (syntax-case stx () 3822 [(form obj name . args) 3823 (identifier? (syntax name)) 3824 (if (stx-list? (syntax args)) 3825 ;; (send obj name arg ...) or (send/apply obj name arg ...) 3826 (do-method stx #'form #'obj #'name 3827 (if kws? (cddr (syntax->list #'args)) #'args) 3828 apply? 3829 (and kws? 3830 (let ([l (syntax->list #'args)]) 3831 (list (car l) (cadr l))))) 3832 (if apply? 3833 ;; (send/apply obj name arg ... . rest) 3834 (raise-syntax-error 3835 #f "bad syntax (illegal use of `.')" stx) 3836 ;; (send obj name arg ... . rest) 3837 (do-method stx #'form #'obj #'name 3838 (flatten-args #'args) #t #f)))] 3839 [(form obj name . args) 3840 (raise-syntax-error 3841 #f "method name is not an identifier" stx #'name)] 3842 [(form obj) 3843 (raise-syntax-error 3844 #f "expected a method name" stx)]))) 3845 3846 (define (send/keyword-apply stx) 3847 (syntax-case stx () 3848 [(form obj name) 3849 (identifier? (syntax name)) 3850 (raise-syntax-error #f "missing expression for list of keywords" stx)] 3851 [(form obj name a) 3852 (identifier? (syntax name)) 3853 (raise-syntax-error #f "missing expression for list of keyword arguments" stx)] 3854 [else ((core-send #t #t) stx)])) 3855 3856 (values 3857 ;; send 3858 (core-send #f #f) 3859 ;; send/apply 3860 (core-send #t #f) 3861 ;; send/keyword-apply 3862 send/keyword-apply))) 3863 3864(define dynamic-send 3865 (make-keyword-procedure 3866 (lambda (kws kw-vals obj method-name . args) 3867 (unless (object? obj) (raise-argument-error 'dynamic-send "object?" obj)) 3868 (unless (symbol? method-name) (raise-argument-error 'dynamic-send "symbol?" method-name)) 3869 (define mtd (find-method/who 'dynamic-send obj method-name)) 3870 (cond 3871 [(wrapped-object? obj) 3872 (if mtd 3873 (keyword-apply mtd kws kw-vals 3874 (wrapped-object-neg-party obj) 3875 (wrapped-object-object obj) 3876 args) 3877 (keyword-apply dynamic-send kws kw-vals 3878 (wrapped-object-object obj) 3879 method-name 3880 args))] 3881 [else 3882 (keyword-apply mtd kws kw-vals obj args)])))) 3883 3884;; imperative chained send 3885(define-syntax (send* stx) 3886 (syntax-case stx () 3887 [(form obj clause ...) 3888 (class-syntax-protect 3889 (quasisyntax/loc stx 3890 (let* ([o obj]) 3891 (unsyntax-splicing 3892 (map 3893 (lambda (clause-stx) 3894 (syntax-case clause-stx () 3895 [(meth . args) 3896 (quasisyntax/loc stx 3897 (send o meth . args))] 3898 [_ (raise-syntax-error 3899 #f "bad method call" stx clause-stx)])) 3900 (syntax->list (syntax (clause ...))))))))])) 3901 3902;; functional chained send 3903(define-syntax (send+ stx) 3904 (define-syntax-class send-clause 3905 #:description "method clause" 3906 (pattern [name:id . args])) 3907 (syntax-parse stx 3908 [(_ obj:expr clause-0:send-clause clause:send-clause ...) 3909 (class-syntax-protect 3910 (quasisyntax/loc stx 3911 (let ([o (send obj clause-0.name . clause-0.args)]) 3912 (send+ o clause ...))))] 3913 [(_ obj:expr) (class-syntax-protect 3914 (syntax/loc stx obj))])) 3915 3916;; find-method/who : symbol[top-level-form/proc-name] 3917;; any[object] 3918;; symbol[method-name] 3919;; -> method-proc 3920;; returns the method's procedure 3921 3922(define (find-method/who who in-object name) 3923 (cond 3924 [(object-ref in-object #f) ; non-#f result implies `_object?` 3925 => (lambda (cls) 3926 (define mth-idx (hash-ref (class-method-ht cls) name #f)) 3927 (if mth-idx 3928 (vector-ref (class-methods cls) mth-idx) 3929 (no-such-method who name cls)))] 3930 [(wrapped-object? in-object) 3931 (define cls 3932 (let loop ([obj in-object]) 3933 (cond 3934 [(wrapped-object? obj) (loop (wrapped-object-object obj))] 3935 [else 3936 (object-ref obj #f)]))) 3937 (define mth-idx (hash-ref (class-method-ht cls) name #f)) 3938 (unless mth-idx (no-such-method who name (object-ref in-object))) 3939 (vector-ref (wrapped-object-neg-extra-arg-vec in-object) mth-idx)] 3940 [else 3941 (obj-error who "target is not an object" 3942 "target" in-object 3943 "method name" (as-write name))])) 3944 3945(define (no-such-method who name cls) 3946 (obj-error who 3947 "no such method" 3948 "method name" (as-write name) 3949 #:class-name (class-name cls))) 3950 3951(define-values (make-class-field-accessor make-class-field-mutator) 3952 (let () 3953 (define (check-and-get-proc who class name get?) 3954 (unless (class? class) 3955 (raise-argument-error who "class?" class)) 3956 (unless (symbol? name) 3957 (raise-argument-error who "symbol?" name)) 3958 (define field-info-external-X (if get? field-info-external-ref field-info-external-set!)) 3959 (define wrapped-class-info-X-field-projs 3960 (if get? 3961 wrapped-class-info-pos-field-projs 3962 wrapped-class-info-neg-field-projs)) 3963 (define (get-accessor) 3964 (field-info-external-X 3965 (hash-ref (class-field-ht class) name 3966 (lambda () 3967 (obj-error who "no such field" 3968 "field-name" (as-write name) 3969 #:class-name (class-name class)))))) 3970 (cond 3971 [(impersonator-prop:has-wrapped-class-neg-party? class) 3972 (define the-info (impersonator-prop:get-wrapped-class-info class)) 3973 (define projs (hash-ref (wrapped-class-info-X-field-projs the-info) name #f)) 3974 (define np (impersonator-prop:get-wrapped-class-neg-party class)) 3975 (cond 3976 [projs 3977 (if get? 3978 (let loop ([projs projs]) 3979 (cond 3980 [(pair? projs) 3981 (define f-rest (loop (cdr projs))) 3982 (define f-this (car projs)) 3983 (λ (val) ((f-this (f-rest val)) np))] 3984 [else projs])) 3985 (let loop ([projs projs]) 3986 (cond 3987 [(pair? projs) 3988 (define f-rest (loop (cdr projs))) 3989 (define f-this (car projs)) 3990 (λ (o val) ((f-this (f-rest o val)) np))] 3991 [else projs])))] 3992 [else (get-accessor)])] 3993 [else 3994 (get-accessor)])) 3995 (values (λ (class name) 3996 (define ref (check-and-get-proc 'class-field-accessor class name #t)) 3997 (λ (o) 3998 (cond 3999 [(_object? o) 4000 (ref o)] 4001 [(wrapped-object? o) 4002 (ref (wrapped-object-object o))] 4003 [else 4004 (raise-argument-error 'class-field-accessor "object?" o)]))) 4005 (λ (class name) 4006 (define setter! (check-and-get-proc 'class-field-mutator class name #f)) 4007 (λ (o v) 4008 (cond 4009 [(_object? o) 4010 (setter! o v)] 4011 [(wrapped-object? o) 4012 (setter! (unwrap-object o) v)] 4013 [else 4014 (raise-argument-error 'class-field-mutator "object?" o)])))))) 4015 4016(define-struct generic (name applicable)) 4017 4018;; Internally, make-generic comes from the struct def. 4019;; Externally, make-generic is the following procedure. 4020;; The extra `let' gives it the right name. 4021(define make-generic/proc 4022 (let ([make-generic 4023 (lambda (class name) 4024 (unless (or (class? class) (interface? class)) 4025 (raise-argument-error 'make-generic "(or/c class? interface?)" class)) 4026 (unless (symbol? name) 4027 (raise-argument-error 'make-generic "symbol?" name)) 4028 (make-generic 4029 name 4030 (if (interface? class) 4031 (let ([intf class]) 4032 (unless (method-in-interface? name intf) 4033 (obj-error 'make-generic "no such method" 4034 "method name" (as-write name) 4035 #:intf-name (interface-name intf))) 4036 (lambda (obj) 4037 (unless (is-a? obj intf) 4038 (obj-error 4039 (string->symbol (format "generic:~a" name)) 4040 "target is not an instance of the generic's interface" 4041 "target" obj 4042 #:intf-name (interface-name intf))) 4043 (find-method/who 'make-generic obj name))) 4044 (let* ([pos (hash-ref (class-method-ht class) name 4045 (lambda () 4046 (obj-error 'make-generic "no such method" 4047 "method name" (as-write name) 4048 #:class-name (class-name class))))] 4049 [instance? (class-object? (class-orig-cls class))] 4050 [fail (λ (obj) 4051 (obj-error 4052 (string->symbol (format "generic:~a" name)) 4053 "target is not an instance of the generic's class" 4054 "target" obj 4055 #:class-name (class-name class)))] 4056 [dynamic-generic 4057 (lambda (obj) 4058 (cond 4059 [(wrapped-object? obj) 4060 (vector-ref (wrapped-object-neg-extra-arg-vec obj) pos)] 4061 [(instance? obj) 4062 (vector-ref (class-methods (object-ref obj)) pos)] 4063 [else (fail obj)]))]) 4064 (if (eq? 'final (vector-ref (class-meth-flags class) pos)) 4065 (let ([method (vector-ref (class-methods class) pos)]) 4066 (lambda (obj) 4067 (unless (instance? obj) (fail obj)) 4068 method)) 4069 dynamic-generic)))))]) 4070 make-generic)) 4071 4072(define-syntax (send-generic stx) 4073 (syntax-case stx () 4074 [(_ object generic . args) 4075 (let* ([args-stx (syntax args)] 4076 [proper? (stx-list? args-stx)] 4077 [flat-stx (if proper? args-stx (flatten-args args-stx))]) 4078 (with-syntax ([(gen obj) 4079 (generate-temporaries (syntax (generic object)))]) 4080 (class-syntax-protect 4081 (quasisyntax/loc stx 4082 (let* ([obj object] 4083 [gen generic]) 4084 ;(check-generic gen) 4085 (unsyntax 4086 (make-method-call-to-possibly-wrapped-object 4087 stx #f flat-stx (not proper?) 4088 #'(generic-name gen) 4089 #'((generic-applicable gen) obj) 4090 #'obj 4091 #'((generic-applicable gen) obj))))))))])) 4092 4093(define (check-generic gen) 4094 (unless (generic? gen) 4095 (raise-argument-error 'send-generic "generic?" gen))) 4096 4097(define-syntaxes (class-field-accessor class-field-mutator generic/form) 4098 (let ([mk 4099 (lambda (make targets) 4100 (lambda (stx) 4101 (syntax-case stx () 4102 [(_ class-expr name) 4103 (let ([name (syntax name)]) 4104 (unless (identifier? name) 4105 (raise-syntax-error 4106 #f 4107 "expected an indentifier" 4108 stx 4109 name)) 4110 (with-syntax ([name (localize name)] 4111 [make make]) 4112 (class-syntax-protect 4113 (syntax/loc stx (make class-expr `name)))))] 4114 [(_ class-expr) 4115 (raise-syntax-error 4116 #f 4117 (format "expected a field name after the ~a expression" 4118 targets) 4119 stx)])))]) 4120 (values 4121 (mk (quote-syntax make-class-field-accessor) "class") 4122 (mk (quote-syntax make-class-field-mutator) "class") 4123 (mk (quote-syntax make-generic/proc) "class or interface")))) 4124 4125(define-syntax (set-field! stx) 4126 (syntax-case stx () 4127 [(_ name obj val) 4128 (identifier? #'name) 4129 (with-syntax ([localized (localize #'name)]) 4130 (class-syntax-protect 4131 (syntax/loc stx (set-field!/proc `localized obj val))))] 4132 [(_ name obj val) 4133 (raise-syntax-error 4134 'set-field! "expected a field name as first argument" 4135 stx #'name)])) 4136 4137(define (set-field!/proc id obj val) 4138 (do-set-field! 'set-field! id obj val)) 4139 4140(define (do-set-field! who id obj val) 4141 (cond 4142 [(_object? obj) 4143 (do-set-field!/raw-object who id obj val)] 4144 [(wrapped-object? obj) 4145 (define projs+set! (hash-ref (wrapped-object-neg-field-projs obj) id #f)) 4146 (cond 4147 [projs+set! 4148 (define np (wrapped-object-neg-party obj)) 4149 (let loop ([projs+set! projs+set!] 4150 [val val]) 4151 (cond 4152 [(pair? projs+set!) 4153 (define the-proj (car projs+set!)) 4154 (loop (cdr projs+set!) 4155 ((the-proj val) np))] 4156 [else 4157 (projs+set! (wrapped-object-object obj) val)]))] 4158 [else 4159 (do-field-get/raw-object who id (wrapped-object-object obj))])] 4160 [else 4161 (raise-argument-error who 4162 "object?" 4163 obj)])) 4164 4165(define (do-set-field!/raw-object who id obj val) 4166 (define cls (object-ref obj)) 4167 (define field-ht (class-field-ht cls)) 4168 (define fi (hash-ref field-ht id #f)) 4169 (if fi 4170 ((field-info-external-set! fi) obj val) 4171 (obj-error who 4172 "given object does not have the requested field" 4173 "field name" (as-write id) 4174 "object" obj))) 4175 4176(define (dynamic-set-field! id obj val) 4177 (unless (symbol? id) (raise-argument-error 'dynamic-set-field! "symbol?" id)) 4178 (do-set-field! 'dynamic-set-field! id obj val)) 4179 4180(define-syntax (get-field stx) 4181 (syntax-case stx () 4182 [(_ name obj) 4183 (identifier? (syntax name)) 4184 (with-syntax ([localized (localize (syntax name))]) 4185 (class-syntax-protect 4186 (syntax/loc stx (get-field/proc `localized obj))))] 4187 [(_ name obj) 4188 (raise-syntax-error 4189 'get-field "expected a field name as first argument" 4190 stx (syntax name))])) 4191 4192(define (get-field/proc id obj) 4193 (do-get-field 'get-field id obj)) 4194 4195(define (do-get-field who id obj) 4196 (cond 4197 [(_object? obj) 4198 (do-field-get/raw-object who id obj)] 4199 [(wrapped-object? obj) 4200 (define projs+ref (hash-ref (wrapped-object-pos-field-projs obj) id #f)) 4201 (cond 4202 [projs+ref 4203 (define np (wrapped-object-neg-party obj)) 4204 (let loop ([projs+ref projs+ref]) 4205 (cond 4206 [(pair? projs+ref) 4207 (define the-proj (car projs+ref)) 4208 (define field-val-with-other-contracts (loop (cdr projs+ref))) 4209 ((the-proj field-val-with-other-contracts) np)] 4210 [else 4211 ;; projs+ref is the struct field accessor 4212 (projs+ref (wrapped-object-object obj))]))] 4213 [else 4214 (do-field-get/raw-object who id (wrapped-object-object obj))])] 4215 [else 4216 (raise-argument-error who 4217 "object?" 4218 obj)])) 4219 4220(define (do-field-get/raw-object who id obj) 4221 (define cls (object-ref obj)) 4222 (define field-ht (class-field-ht cls)) 4223 (define fi (hash-ref field-ht id #f)) 4224 (if fi 4225 ((field-info-external-ref fi) obj) 4226 (obj-error who 4227 "given object does not have the requested field" 4228 "field name" (as-write id) 4229 "object" obj))) 4230 4231(define (dynamic-get-field id obj) 4232 (unless (symbol? id) (raise-argument-error 'dynamic-get-field "symbol?" id)) 4233 (do-get-field 'dynamic-get-field id obj)) 4234 4235(define-syntax (field-bound? stx) 4236 (syntax-case stx () 4237 [(_ name obj) 4238 (identifier? (syntax name)) 4239 (with-syntax ([localized (localize (syntax name))]) 4240 (class-syntax-protect 4241 (syntax (field-bound?/proc `localized obj))))] 4242 [(_ name obj) 4243 (raise-syntax-error 4244 'field-bound? "expected a field name as first argument" 4245 stx (syntax name))])) 4246 4247(define (field-bound?/proc id obj) 4248 (unless (object? obj) 4249 (raise-argument-error 'field-bound? 4250 "object?" 4251 obj)) 4252 (let loop ([obj obj]) 4253 (let* ([cls (object-ref/unwrap obj)] 4254 [field-ht (class-field-ht cls)]) 4255 (and (hash-ref field-ht id #f) 4256 #t)))) ;; ensure that only #t and #f leak out, not bindings in ht 4257 4258(define (field-names obj) 4259 (unless (object? obj) 4260 (raise-argument-error 'field-names 4261 "object?" 4262 obj)) 4263 (let loop ([obj obj]) 4264 (let* ([cls (object-ref/unwrap obj)] 4265 [field-ht (class-field-ht cls)] 4266 [flds (filter interned? (hash-map field-ht (lambda (x y) x)))]) 4267 flds))) 4268 4269(define-syntax (with-method stx) 4270 (syntax-case stx () 4271 [(_ ([id (obj-expr name)] ...) body0 body1 ...) 4272 (let ([ids (syntax->list (syntax (id ...)))] 4273 [names (syntax->list (syntax (name ...)))]) 4274 (for-each (lambda (id name) 4275 (unless (identifier? id) 4276 (raise-syntax-error #f 4277 "not an identifier for binding" 4278 stx 4279 id)) 4280 (unless (identifier? name) 4281 (raise-syntax-error #f 4282 "not an identifier for method name" 4283 stx 4284 name))) 4285 ids names) 4286 (with-syntax ([(method ...) (generate-temporaries ids)] 4287 [(method-obj ...) (generate-temporaries ids)] 4288 [(name ...) (map localize names)]) 4289 (class-syntax-protect 4290 (syntax/loc stx (let-values ([(method method-obj) 4291 (let ([obj obj-expr]) 4292 (values (find-method/who 'with-method obj `name) 4293 obj))] 4294 ...) 4295 (letrec-syntaxes+values ([(id) (make-with-method-map 4296 (quote-syntax set!) 4297 (quote-syntax id) 4298 (quote-syntax method) 4299 (quote-syntax method-obj))] 4300 ...) 4301 () 4302 body0 body1 ...))))))] 4303 ;; Error cases: 4304 [(_ (clause ...) . body) 4305 (begin 4306 (for-each (lambda (clause) 4307 (syntax-case clause () 4308 [(id (obj-expr name)) 4309 (and (identifier? (syntax id)) 4310 (identifier? (syntax name))) 4311 'ok] 4312 [_else 4313 (raise-syntax-error 4314 #f 4315 "binding clause is not of the form (identifier (object-expr method-identifier))" 4316 stx 4317 clause)])) 4318 (syntax->list (syntax (clause ...)))) 4319 ;; If we get here, the body must be bad 4320 (if (stx-null? (syntax body)) 4321 (raise-syntax-error 4322 #f 4323 "empty body" 4324 stx) 4325 (raise-syntax-error 4326 #f 4327 "bad syntax (illegal use of `.')" 4328 stx)))] 4329 [(_ x . rest) 4330 (raise-syntax-error 4331 #f 4332 "not a binding sequence" 4333 stx 4334 (syntax x))])) 4335 4336 4337;;-------------------------------------------------------------------- 4338;; class, interface, and object properties 4339;;-------------------------------------------------------------------- 4340 4341(define (is-a? v c) 4342 (cond 4343 [(class? c) 4344 (and (object? v) ((class-object? (class-orig-cls c)) (unwrap-object v)))] 4345 [(interface? c) (and (object? v) (implementation? (object-ref/unwrap v) c))] 4346 [else (raise-argument-error 'is-a? "(or/c class? interface?)" 1 v c)])) 4347 4348(define (subclass? v c) 4349 (unless (class? c) 4350 (raise-argument-error 'subclass? "class?" 1 v c)) 4351 (and (class? v) 4352 (let* ([c (class-orig-cls c)] 4353 [v (class-orig-cls v)] 4354 [p (class-pos c)]) 4355 (and (<= p (class-pos v)) 4356 (eq? c (vector-ref (class-supers v) p)))))) 4357 4358(define (object-interface o) 4359 (unless (object? o) 4360 (raise-argument-error 'object-interface "object?" o)) 4361 (class-self-interface (object-ref/unwrap o))) 4362 4363(define (object-method-arity-includes? o name cnt) 4364 (unless (object? o) 4365 (raise-argument-error 'object-method-arity-includes? "object?" o)) 4366 (unless (symbol? name) 4367 (raise-argument-error 'object-method-arity-includes? "symbol?" name)) 4368 (unless (and (integer? cnt) 4369 (exact? cnt) 4370 (not (negative? cnt))) 4371 (raise-argument-error 'object-method-arity-includes? "exact-nonnegative-integer?" cnt)) 4372 (define c (object-ref/unwrap o)) 4373 (define pos (hash-ref (class-method-ht c) name #f)) 4374 (cond 4375 [pos (procedure-arity-includes? (vector-ref (class-methods c) pos) 4376 (add1 cnt))] 4377 [else #f])) 4378 4379(define (implementation? v i) 4380 (unless (interface? i) 4381 (raise-argument-error 'implementation? "interface?" 1 v i)) 4382 (and (class? v) 4383 (interface-extension? (class-self-interface v) i))) 4384 4385(define (interface-extension? v i) 4386 (unless (interface? i) 4387 (raise-argument-error 'interface-extension? "interface?" 1 v i)) 4388 (and (interface? i) 4389 (hash-ref (interface-all-implemented v) i #f))) 4390 4391(define (method-in-interface? s i) 4392 (unless (symbol? s) 4393 (raise-argument-error 'method-in-interface? "symbol?" 0 s i)) 4394 (unless (interface? i) 4395 (raise-argument-error 'method-in-interface? "interface?" 1 s i)) 4396 (and (memq s (interface-public-ids i)) #t)) 4397 4398(define (class->interface c) 4399 (unless (class? c) 4400 (raise-argument-error 'class->interface "class?" c)) 4401 (class-self-interface c)) 4402 4403(define (interned? sym) 4404 (eq? sym (string->symbol (symbol->string sym)))) 4405 4406(define (interface->method-names i) 4407 (unless (interface? i) 4408 (raise-argument-error 'interface->method-names "interface?" i)) 4409 (filter interned? (interface-public-ids i))) 4410 4411 4412(define (object-info o) 4413 (unless (object? o) 4414 (raise-argument-error 'object-info "object?" o)) 4415 (let ([o* (if (has-original-object? o) (original-object o) o)]) 4416 (let loop ([c (object-ref/unwrap o*)] 4417 [skipped? #f]) 4418 (if (struct? ((class-insp-mk c))) 4419 ;; current objec can inspect this object 4420 (values c skipped?) 4421 (if (zero? (class-pos c)) 4422 (values #f #t) 4423 (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))) 4424 4425(define (to-sym s) 4426 (if (string? s) 4427 (string->symbol s) 4428 s)) 4429 4430(define (class-info c) 4431 (unless (class? c) 4432 (raise-argument-error 'class-info "class?" c)) 4433 (if (struct? ((class-insp-mk c))) 4434 (let ([super (vector-ref (class-supers c) (sub1 (class-pos c)))]) 4435 (let loop ([next super][skipped? #f]) 4436 (if (or (not next) 4437 (struct? ((class-insp-mk next)))) 4438 (values (to-sym (class-name c)) 4439 (- (class-field-width c) (class-field-width super)) 4440 (filter interned? (class-field-ids c)) 4441 (class-field-ref c) 4442 (class-field-set! c) 4443 next 4444 skipped?) 4445 (if (zero? (class-pos next)) 4446 (loop #f #t) 4447 (loop (vector-ref (class-supers next) (sub1 (class-pos next))) #t))))) 4448 (raise-arguments-error 'class-info "current inspector cannot inspect class" 4449 "class" c))) 4450 4451(define object->vector 4452 (lambda (in-o [opaque-v '...]) 4453 (unless (object? in-o) 4454 (raise-argument-error 'object->vector "object?" in-o)) 4455 (let ([o in-o]) 4456 (list->vector 4457 (cons 4458 (string->symbol (format "object:~a" (class-name (object-ref/unwrap o)))) 4459 (reverse 4460 (let-values ([(c skipped?) (object-info o)]) 4461 (let loop ([c c][skipped? skipped?]) 4462 (cond 4463 [(not c) (if skipped? (list opaque-v) null)] 4464 [else (let-values ([(name num-fields field-ids field-ref 4465 field-set next next-skipped?) 4466 (class-info c)]) 4467 (let ([rest (loop next next-skipped?)] 4468 [here (let loop ([n num-fields]) 4469 (if (zero? n) 4470 null 4471 (cons (field-ref o (sub1 n)) 4472 (loop (sub1 n)))))]) 4473 (append (if skipped? (list opaque-v) null) 4474 here 4475 rest)))]))))))))) 4476 4477(define (object=? o1 o2) 4478 (cond 4479 [(not (object? o1)) 4480 (raise-argument-error 'object=? "object?" 0 o1 o2)] 4481 [(not (object? o2)) 4482 (raise-argument-error 'object=? "object?" 1 o1 o2)] 4483 [else 4484 (or (eq? o1 o2) (-object=? o1 o2))])) 4485 4486(define (object-or-false=? o1 o2) 4487 (cond 4488 [(and o1 (not (object? o1))) 4489 (raise-argument-error 'object-or-false=? "(or/c object? #f)" 0 o1 o2)] 4490 [(and o2 (not (object? o2))) 4491 (raise-argument-error 'object-or-false=? "(or/c object? #f)" 1 o1 o2)] 4492 [else 4493 (or (eq? o1 o2) 4494 (and o1 o2 (-object=? o1 o2)))])) 4495 4496(define (-object=? o1 o2) 4497 (eq? (object=-original-object o1) 4498 (object=-original-object o2))) 4499 4500(define (object=-original-object o) 4501 (define orig-o (if (has-original-object? o) (original-object o) o)) 4502 (define orig-orig-o 4503 (if (wrapped-object? orig-o) 4504 (wrapped-object-object orig-o) 4505 orig-o)) 4506 orig-orig-o) 4507 4508(define (object=-hash-code o) 4509 (unless (object? o) 4510 (raise-argument-error 'object=-hash-code "object?" 0 o)) 4511 (eq-hash-code (object=-original-object o))) 4512 4513;;-------------------------------------------------------------------- 4514;; primitive classes 4515;;-------------------------------------------------------------------- 4516 4517(define (make-primitive-class 4518 make-struct:prim ; see below 4519 prim-init ; primitive initializer: takes obj and list of name-arg pairs 4520 name ; symbol 4521 super ; superclass 4522 intfs ; interfaces 4523 init-arg-names ; #f or list of syms and sym--value lists 4524 override-names ; overridden method names 4525 new-names ; new (public) method names 4526 override-methods ; list of methods 4527 new-methods) ; list of methods 4528 4529 ; The `make-struct:prim' function takes prop:object, a class, 4530 ; a preparer, a dispatcher function, an unwrap property, 4531 ; an unwrapper, and a property assoc list, and produces: 4532 ; * a struct constructor (must have prop:object) 4533 ; * a struct predicate 4534 ; * a struct type for derived classes (mustn't have prop:object) 4535 ; 4536 ; The supplied preparer takes a symbol and returns a num. 4537 ; 4538 ; The supplied dispatcher takes an object and a num and returns a method. 4539 ; 4540 ; The supplied unwrap property is used for adding the unwrapper 4541 ; as a property value on new objects. 4542 ; 4543 ; The supplied unwrapper takes an object and returns the unwrapped 4544 ; version (or the original object). 4545 ; 4546 ; When a primitive class has a superclass, the struct:prim maker 4547 ; is responsible for ensuring that the returned struct items match 4548 ; the supertype predicate. 4549 4550 (compose-class name 4551 (or super object%) 4552 intfs 4553 #f 4554 #f 4555 #f 4556 4557 0 null null null ; no fields 4558 4559 null ; no rename-supers 4560 null ; no rename-inners 4561 null null new-names 4562 null null override-names 4563 null null null ; no augrides 4564 null ; no inherits 4565 4566 ; #f => init args by position only 4567 ; sym => required arg 4568 ; sym--value list => optional arg 4569 (and init-arg-names 4570 (map (lambda (s) 4571 (if (symbol? s) s (car s))) 4572 init-arg-names)) 4573 'stop 4574 4575 (lambda ignored 4576 (values 4577 new-methods 4578 override-methods 4579 null ; no augride-methods 4580 (lambda (this super-go/ignored si_c/ignored si_inited?/ignored si_leftovers/ignored init-args) 4581 (apply prim-init this 4582 (if init-arg-names 4583 (extract-primitive-args this name init-arg-names init-args) 4584 init-args))))) 4585 4586 #f 4587 4588 make-struct:prim)) 4589 4590(define (extract-primitive-args this class-name init-arg-names init-args) 4591 (let loop ([names init-arg-names][args init-args]) 4592 (cond 4593 [(null? names) 4594 (unless (null? args) 4595 (unused-args-error this args)) 4596 null] 4597 [else (let* ([name (car names)] 4598 [id (if (symbol? name) 4599 name 4600 (car name))]) 4601 (let ([arg (assq id args)]) 4602 (cond 4603 [arg 4604 (cons (cdr arg) (loop (cdr names) (remq arg args)))] 4605 [(symbol? name) 4606 (missing-argument-error class-name name)] 4607 [else 4608 (cons (cadr name) (loop (cdr names) args))])))]))) 4609 4610;;-------------------------------------------------------------------- 4611;; wrapper for contracts 4612;;-------------------------------------------------------------------- 4613 4614(define-values (impersonator-prop:original-object has-original-object? original-object) 4615 (make-impersonator-property 'impersonator-prop:original-object)) 4616 4617 4618(define (check-arg-contracts wrapped-blame wrapped-neg-party val init-proj-pairs orig-named-args) 4619 ;; blame will be #f only when init-ctc-pairs is '() 4620 (define arg-blame (and wrapped-blame (blame-swap wrapped-blame))) 4621 4622 (define (missing-one init-ctc-pair) 4623 (raise-blame-error arg-blame #:missing-party wrapped-neg-party val 4624 '(expected: "an init arg named ~a" 4625 given: 4626 "~a") 4627 (car init-ctc-pair) 4628 (case (length orig-named-args) 4629 [(0) "no init args"] 4630 [(1) "an init arg named ~a" 4631 (car (car orig-named-args))] 4632 [(2) "init args named~a" 4633 (apply string-append 4634 (map (λ (x) (format " ~a" (car x))) 4635 orig-named-args))]))) 4636 ;; this loop optimizes for the case where the init-ctc-pairs 4637 ;; and the named-args are in the same order, making extra 4638 ;; passes over the named-args when they aren't. 4639 (let loop ([init-proj-pairs init-proj-pairs] 4640 [named-args orig-named-args] 4641 [named-skipped-args '()] 4642 [progress? #f]) 4643 (cond 4644 [(null? init-proj-pairs) 4645 (append named-args named-skipped-args)] 4646 [(and (null? named-args) (null? named-skipped-args)) 4647 '()] 4648 [(null? named-args) 4649 (if progress? 4650 (loop init-proj-pairs named-skipped-args '() #f) 4651 (loop (cdr init-proj-pairs) named-skipped-args '() #f))] 4652 [else 4653 (define proj-pair (car init-proj-pairs)) 4654 (define named-arg (car named-args)) 4655 (cond 4656 [(equal? (list-ref proj-pair 0) (list-ref named-arg 0)) 4657 (define value-with-contracts-added 4658 (for/fold ([val (cdr named-arg)]) ([proj (in-list (cdr proj-pair))]) 4659 ((proj val) wrapped-neg-party))) 4660 (define new-ele (cons (car named-arg) value-with-contracts-added)) 4661 (cons new-ele 4662 (loop (cdr init-proj-pairs) (cdr named-args) named-skipped-args #t))] 4663 [else 4664 (loop init-proj-pairs 4665 (cdr named-args) 4666 (cons (car named-args) named-skipped-args) 4667 progress?)])]))) 4668 4669 4670;;-------------------------------------------------------------------- 4671;; misc utils 4672;;-------------------------------------------------------------------- 4673 4674(define-struct (exn:fail:object exn:fail) () #:inspector insp) 4675 4676(struct as-write (content)) 4677(struct as-write-list (content)) 4678(struct as-value-list (content)) 4679(struct as-lines (content)) 4680 4681(define (obj-error where 4682 msg 4683 #:class-name [class-name #f] 4684 #:intf-name [intf-name #f] 4685 #:which-class [which-class ""] 4686 . fields) 4687 (define all-fields 4688 (append fields 4689 (if class-name 4690 (list (string-append which-class "class name") 4691 (as-write class-name)) 4692 null) 4693 (if intf-name 4694 (list "interface name" 4695 (as-write intf-name)) 4696 null))) 4697 (raise (make-exn:fail:object 4698 (format "~a: ~a~a" where msg 4699 (apply 4700 string-append 4701 (let loop ([fields all-fields]) 4702 (cond 4703 [(null? fields) null] 4704 [else 4705 (define field (car fields)) 4706 (define val (cadr fields)) 4707 (list* 4708 "\n " 4709 field 4710 (if (or (as-write-list? val) 4711 (as-lines? val)) 4712 ":" 4713 ": ") 4714 (cond 4715 [(or (as-write-list? val) 4716 (as-value-list? val)) 4717 (apply string-append 4718 (for/list ([v (in-list (if (as-write-list? val) 4719 (as-write-list-content val) 4720 (as-value-list-content val)))]) 4721 (format (if (as-write-list? val) 4722 "\n ~s" 4723 "\n ~e") 4724 v)))] 4725 [(as-write? val) 4726 (format "~s" (as-write-content val))] 4727 [(as-lines? val) 4728 (as-lines-content val)] 4729 [else 4730 (format "~e" val)]) 4731 (loop (cddr fields)))])))) 4732 (current-continuation-marks)))) 4733 4734(define (for-class name) 4735 (if name (format " for class: ~a" name) "")) 4736(define (for-class/which which name) 4737 (if name (format " for ~a class: ~a" which name) "")) 4738(define (for-intf name) 4739 (if name (format " for interface: ~a" name) "")) 4740 4741;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 4742;; 4743;; mixin 4744;; 4745 4746(define (check-mixin-super mixin-name super% from-ids) 4747 (let ([mixin-name (or mixin-name 'mixin)]) 4748 (unless (class? super%) 4749 (obj-error mixin-name 4750 "argument is not a class" 4751 "argument" super%)) 4752 (for-each (lambda (from-id) 4753 (unless (implementation? super% from-id) 4754 (obj-error mixin-name 4755 "argument class does not implement interface" 4756 "argument" super% 4757 "interface name" (as-write from-id)))) 4758 from-ids))) 4759 4760(define (check-mixin-from-interfaces all-from) 4761 (for-each (lambda (from-id) 4762 (unless (interface? from-id) 4763 (obj-error 'mixin 4764 "given value for from-interface is not an interface" 4765 "given" from-id 4766 "all given" (as-value-list all-from)))) 4767 all-from)) 4768 4769(define (check-mixin-to-interfaces all-to) 4770 (for-each (lambda (to-id) 4771 (unless (interface? to-id) 4772 (obj-error 'mixin 4773 "given values for from-interface is not an interface" 4774 "given" to-id 4775 "all given" (as-value-list all-to)))) 4776 all-to)) 4777 4778 4779(define (check-interface-includes xs from-ids) 4780 (for-each 4781 (lambda (x) 4782 (unless (ormap (lambda (i) (method-in-interface? x i)) from-ids) 4783 (obj-error 'mixin 4784 "method was referenced in definition, but is not in any of the from-interfaces" 4785 "method name" (as-write x) 4786 "from-interfaces" (as-write-list from-ids)))) 4787 xs)) 4788 4789(define-syntax (mixin stx) 4790 (syntax-case stx () 4791 [(_ (from ...) (to ...) clauses ...) 4792 (let ([extract-renamed-names 4793 (λ (x) 4794 (map (λ (x) 4795 (localize 4796 (syntax-case x () 4797 [(internal-name external-name) (syntax external-name)] 4798 [else x]))) 4799 (syntax->list x)))]) 4800 (define (get-super-names stx) 4801 (syntax-case stx (inherit rename 4802 override overment override-final 4803 define/override define/overment define/override-final 4804 augment augride augment-final 4805 define/augment define/augride define/augment-final) 4806 [(inherit names ...) (extract-renamed-names (syntax (names ...)))] 4807 [(rename [x names] ...) (syntax->list (syntax (names ...)))] 4808 [(override names ...) (extract-renamed-names (syntax (names ...)))] 4809 [(overment names ...) (extract-renamed-names (syntax (names ...)))] 4810 [(override-final names ...) (extract-renamed-names (syntax (names ...)))] 4811 [(augment names ...) (extract-renamed-names (syntax (names ...)))] 4812 [(augride names ...) (extract-renamed-names (syntax (names ...)))] 4813 [(augment-final names ...) (extract-renamed-names (syntax (names ...)))] 4814 4815 [(define/augment (name . names) . rest) (extract-renamed-names (syntax (name)))] 4816 [(define/augment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))] 4817 [(define/augride (name . names) . rest) (extract-renamed-names (syntax (name)))] 4818 [(define/augride name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))] 4819 [(define/augment-final (name . names) . rest) (extract-renamed-names (syntax (name)))] 4820 [(define/augment-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))] 4821 [(define/override (name . names) . rest) (extract-renamed-names (syntax (name)))] 4822 [(define/override name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))] 4823 [(define/overment (name . names) . rest) (extract-renamed-names (syntax (name)))] 4824 [(define/overment name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))] 4825 [(define/override-final (name . names) . rest) (extract-renamed-names (syntax (name)))] 4826 [(define/override-final name . rest) (identifier? (syntax name)) (extract-renamed-names (syntax (name)))] 4827 [else null])) 4828 (with-syntax ([(from-ids ...) (generate-temporaries (syntax (from ...)))] 4829 [(to-ids ...) (generate-temporaries (syntax (to ...)))] 4830 [(super-vars ...) 4831 (apply 4832 append 4833 (map get-super-names 4834 (syntax->list (syntax (clauses ...)))))] 4835 [mixin-name (or (with-syntax ([tmp (syntax-local-name)]) 4836 (syntax (quote tmp))) 4837 (syntax (quote mixin)))]) 4838 4839 ;; Build the class expression first, to give it a good src location: 4840 (with-syntax ([class-expr 4841 (with-syntax ([orig-stx stx]) 4842 (syntax/loc stx 4843 (class/derived orig-stx [#f super% (to-ids ...) #f] 4844 clauses ...)))]) 4845 4846 ;; Now build mixin proc, again to give it a good src location: 4847 (with-syntax ([mixin-expr 4848 (syntax/loc stx 4849 (λ (super%) 4850 (check-mixin-super mixin-name super% (list from-ids ...)) 4851 class-expr))]) 4852 ;; Finally, build the complete mixin expression: 4853 (class-syntax-protect 4854 (syntax/loc stx 4855 (let ([from-ids from] ...) 4856 (let ([to-ids to] ...) 4857 (check-mixin-from-interfaces (list from-ids ...)) 4858 (check-mixin-to-interfaces (list to-ids ...)) 4859 (check-interface-includes (list (quasiquote super-vars) ...) 4860 (list from-ids ...)) 4861 mixin-expr))))))))])) 4862 4863(define externalizable<%> 4864 (_interface () externalize internalize)) 4865 4866(define writable<%> 4867 (interface* () 4868 ([prop:custom-write (lambda (obj port mode) 4869 (if mode 4870 (send obj custom-write port) 4871 (send obj custom-display port)))]) 4872 custom-write custom-display)) 4873 4874(define printable<%> 4875 (interface* () 4876 ([prop:custom-write (lambda (obj port mode) 4877 (case mode 4878 [(#t) (send obj custom-write port)] 4879 [(#f) (send obj custom-display port)] 4880 [else (send obj custom-print port mode)]))]) 4881 custom-write custom-display custom-print)) 4882 4883(define equal<%> 4884 (interface* () 4885 ([prop:equal+hash (list 4886 (lambda (obj obj2 base-equal?) 4887 (send obj equal-to? obj2 base-equal?)) 4888 (lambda (obj base-hash-code) 4889 (send obj equal-hash-code-of base-hash-code)) 4890 (lambda (obj base-hash2-code) 4891 (send obj equal-secondary-hash-code-of base-hash2-code)))]) 4892 equal-to? equal-hash-code-of equal-secondary-hash-code-of)) 4893 4894;; Providing normal functionality: 4895(provide (protect-out get-field/proc) 4896 4897 ;; for class-c-old.rkt: 4898 (protect-out 4899 make-naming-constructor prop:object _object? object-ref replace-ictc-blame 4900 concretize-ictc-method field-info-extend-external field-info-extend-internal this-param 4901 object-ref/unwrap impersonator-prop:original-object has-original-object? original-object) 4902 ;; end class-c-old.rkt requirements 4903 4904 field-info-internal-ref 4905 field-info-internal-set! 4906 4907 (rename-out [_class class]) class* class/derived 4908 define-serializable-class define-serializable-class* 4909 class? 4910 mixin 4911 (rename-out [_interface interface]) interface* interface? 4912 object% object? object=? object-or-false=? object=-hash-code 4913 externalizable<%> printable<%> writable<%> equal<%> 4914 new make-object instantiate 4915 get-field set-field! field-bound? field-names 4916 dynamic-get-field dynamic-set-field! 4917 send send/apply send/keyword-apply send* send+ dynamic-send 4918 class-field-accessor class-field-mutator with-method 4919 private* public* pubment* 4920 override* overment* 4921 augride* augment* 4922 public-final* override-final* augment-final* 4923 define/private define/public define/pubment 4924 define/override define/overment 4925 define/augride define/augment 4926 define/public-final define/override-final define/augment-final 4927 define-local-member-name define-member-name 4928 member-name-key generate-member-key member-name-key? member-name-key=? member-name-key-hash-code 4929 (rename-out [generic/form generic]) (rename-out [make-generic/proc make-generic]) send-generic generic? 4930 is-a? subclass? implementation? interface-extension? 4931 object-interface object-info object->vector 4932 object-method-arity-includes? 4933 method-in-interface? interface->method-names class->interface class-info 4934 class-seal class-unseal copy-seals 4935 (struct-out exn:fail:object) 4936 make-primitive-class 4937 (for-syntax localize) 4938 (except-out (struct-out class) class class?) 4939 (rename-out [class? class-struct-predicate?]) 4940 (struct-out wrapped-object)) 4941