1;;; Heavily hacked by Eli Barzilay: Maze is Life! (eli@barzilay.org) 2 3;;> This module is the core object system. It is a heavily hacked version 4;;> of the original Tiny-CLOS code from Xerox, but it has been fitted to 5;;> Racket, optimized and extended. See the source file for a lot of 6;;> details about how the CLOS magic is created. 7;;> 8;;> [There is one difference between Swindle and Tiny-CLOS: the meta object 9;;> hierarchy is assumed to be using only single inheritance, or if there is 10;;> multiple inheritance then the built in meta objects should come first to 11;;> make the slots allocated in the same place. This should not be a 12;;> problem in realistic situations.] 13 14;;; Original copyright: 15;;; *************************************************************************** 16;;; Copyright (c) 1992 Xerox Corporation. All Rights Reserved. 17;;; 18;;; Use, reproduction, and preparation of derivative works are permitted. Any 19;;; copy of this software or of any derivative work must include the above 20;;; copyright notice of Xerox Corporation, this paragraph and the one after it. 21;;; Any distribution of this software or derivative works must comply with all 22;;; applicable United States export control laws. 23;;; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS ALL 24;;; WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE IMPLIED 25;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE, AND 26;;; NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY LIABILITY FOR 27;;; DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS EXPRESSLY DISCLAIMED, 28;;; WHETHER ARISING IN CONTRACT, TORT (INCLUDING NEGLIGENCE) OR STRICT 29;;; LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED OF THE POSSIBILITY OF SUCH 30;;; DAMAGES. 31;;; *************************************************************************** 32 33#lang s-exp swindle/base 34 35;;; A very simple CLOS-like language, embedded in Scheme, with a simple MOP. 36;;; The features of the default base language are: 37;;; * Classes, with instance slots, but no slot options. 38;;; * Multiple-inheritance. 39;;; * Generic functions with multi-methods and class specializers only. 40;;; * Primary methods and call-next-method; no other method combination. 41;;; * Uses Scheme's lexical scoping facilities as the class and generic 42;;; function naming mechanism. Another way of saying this is that class, 43;;; generic function and methods are first-class (meta)objects. 44;;; 45;;; While the MOP is simple, it is essentially equal in power to both MOPs in 46;;; AMOP. This implementation is not at all optimized, but the MOP is designed 47;;; so that it can be optimized. In fact, this MOP allows better optimization 48;;; of slot access extenstions than those in AMOP. 49;;; 50;;; In addition to calling a generic, the entry points to the default base 51;;; language are: 52;;; 53;;; (MAKE-CLASS list-of-superclasses list-of-slot-names) 54;;; (MAKE-GENERIC-FUNCTION) 55;;; (MAKE-METHOD list-of-specializers procedure) 56;;; (ADD-METHOD generic method) 57;;; 58;;; (MAKE class . initargs) 59;;; (INITIALIZE instance initargs) ; Add methods to this, dont call directly. 60;;; 61;;; (SLOT-REF object slot-name) 62;;; (SLOT-SET! object slot-name new-value) 63;;; (SLOT-BOUND? object slot-name) 64;;; 65;;; So, for example, one might do: 66;;; (define <position> (make-class (list <object>) (list 'x 'y))) 67;;; (add-method initialize 68;;; (make-method (list <position>) 69;;; (lambda (call-next-method pos initargs) 70;;; (for-each (lambda (initarg-name slot-name) 71;;; (slot-set! pos slot-name 72;;; (getarg initargs initarg-name 0))) 73;;; '(x y) 74;;; '(x y))))) 75;;; (set! p1 (make <position> 'x 1 'y 3)) 76;;; 77;;; NOTE! Do not use EQUAL? to compare objects! Use EQ? or some hand written 78;;; procedure. Objects have a pointer to their class, and classes are 79;;; circular structures, and... 80;;; 81;;; The introspective part of the MOP looks like the following. Note that 82;;; these are ordinary procedures, not generics. 83;;; * CLASS-OF 84;;; INSTANCE-OF? 85;;; SUBCLASS? 86;;; * CLASS-DIRECT-SUPERS 87;;; CLASS-DIRECT-SLOTS 88;;; CLASS-CPL 89;;; CLASS-SLOTS 90;;; CLASS-NAME 91;;; * GENERIC-METHODS 92;;; GENERIC-ARITY 93;;; GENERIC-NAME 94;;; GENERIC-COMBINATION 95;;; * METHOD-SPECIALIZERS 96;;; METHOD-PROCEDURE 97;;; METHOD-NAME 98;;; 99;;; The intercessory protocol looks like (generics in uppercase): 100;;; ELI: All of these are generic functions now! 101;;; MAKE 102;;; ALLOCATE-INSTANCE 103;;; INITIALIZE (really a base-level generic) 104;;; class initialization 105;;; COMPUTE-CPL 106;;; COMPUTE-SLOTS 107;;; COMPUTE-GETTER-AND-SETTER 108;;; method initialization 109;;; COMPUTE-APPLY-METHOD 110;;; ADD-METHOD (Notice this is not a generic!) [eli: yes!] 111;;; COMPUTE-APPLY-GENERIC 112;;; COMPUTE-METHODS 113;;; COMPUTE-METHOD-MORE-SPECIFIC? 114;;; COMPUTE-APPLY-METHODS 115 116;;; OK, now let's get going. But, as usual, before we can do anything 117;;; interesting, we have to muck around for a bit first. First, we need to 118;;; load the support library. [-- replaced with a module.] 119(require swindle/misc 120 racket/undefined) 121 122;; This is a convenient function for raising exceptions 123(define (raise* exn-maker fmt . args) 124 (let ([sym (and (symbol? fmt) 125 (begin0 fmt 126 (when (null? args) (error 'raise* "got too few arguments")) 127 (set! fmt (car args)) (set! args (cdr args))))] 128 [fmt-num (- (length args) (procedure-arity exn-maker) -2)]) 129 (when (< fmt-num 0) 130 (error 'raise* "got too few arguments")) 131 (let loop ([fmt-args '()] [args args] [a fmt-num]) 132 (if (zero? a) 133 (raise (exn-maker 134 (if sym 135 (apply format (concat "~s: " fmt) sym (reverse fmt-args)) 136 (apply format fmt (reverse fmt-args))) 137 (current-continuation-marks) . args)) 138 (loop (cons (car args) fmt-args) (cdr args) (sub1 a)))))) 139 140;; A simple topological sort. 141;; It's in this file so that both TinyClos and Objects can use it. 142;; This is a fairly modified version of code I originally got from Anurag 143;; Mendhekar <anurag@moose.cs.indiana.edu>. 144(define (compute-std-cpl c get-direct-supers) 145 (top-sort (build-transitive-closure get-direct-supers c) 146 (build-constraints get-direct-supers c) 147 (std-tie-breaker get-direct-supers))) 148(define (top-sort elements constraints tie-breaker) 149 (let loop ([elements elements] [constraints constraints] [result '()]) 150 (if (null? elements) 151 result 152 (let ([can-go-in-now 153 (filter (lambda (x) 154 (every (lambda (constraint) 155 (or (not (eq? (cadr constraint) x)) 156 (memq (car constraint) result))) 157 constraints)) 158 elements)]) 159 (if (null? can-go-in-now) 160 (error 'top-sort "invalid constraints") 161 (let ([choice (if (null? (cdr can-go-in-now)) 162 (car can-go-in-now) 163 (tie-breaker result can-go-in-now))]) 164 (loop (filter (lambda (x) (not (eq? x choice))) elements) 165 constraints (append result (list choice))))))))) 166(define (std-tie-breaker get-supers) 167 (lambda (partial-cpl min-elts) 168 (let loop ([pcpl (reverse partial-cpl)]) 169 (let* ([current-elt (car pcpl)] 170 [ds-of-ce (get-supers current-elt)] 171 [common (filter (lambda (x) (memq x ds-of-ce)) min-elts)]) 172 (if (null? common) 173 (if (null? (cdr pcpl)) 174 (error 'std-tie-breaker "nothing valid") (loop (cdr pcpl))) 175 (car common)))))) 176(define (build-transitive-closure get-follow-ons x) 177 (let track ([result '()] [pending (list x)]) 178 (if (null? pending) 179 result 180 (let ([next (car pending)]) 181 (if (memq next result) 182 (track result (cdr pending)) 183 (track (cons next result) 184 (append (get-follow-ons next) (cdr pending)))))))) 185(define (build-constraints get-follow-ons x) 186 (let loop ([elements (build-transitive-closure get-follow-ons x)] 187 [this-one '()] 188 [result '()]) 189 (if (or (null? this-one) (null? (cdr this-one))) 190 (if (null? elements) 191 result 192 (loop (cdr elements) 193 (cons (car elements) (get-follow-ons (car elements))) 194 result)) 195 (loop elements 196 (cdr this-one) 197 (cons (list (car this-one) (cadr this-one)) result))))) 198 199;;; Then, we need to build what, in a more real implementation, would be the 200;;; interface to the memory subsystem: instances and entities. The former are 201;;; used for instances of instances of <class>; the latter are used for 202;;; instances of instances of <entity-class>. In this MOP, none of this is 203;;; visible to base- or MOP-level programmers. 204;;; A few things to note, that have influenced the way all this is done: 205;;; - R4RS doesn't provide a mechanism for specializing the 206;;; behavior of the printer for certain objects. 207;;; - Some Scheme implementations bomb when printing circular structures -- 208;;; that is, arrays and/or lists that somehow point back to themselves. 209;;; So, the natural implementation of instances -- vectors whose first field 210;;; point to the class -- is straight on out. Instead, we use a procedure to 211;;; `encapsulate' that natural representation. 212;;; Having gone that far, it makes things simpler to unify the way normal 213;;; instances and entities are handled, at least in the lower levels of the 214;;; system. Don't get faked out by this -- the user shouldn't think of normal 215;;; instances as being procedures, they aren't. (At least not in this 216;;; language.) If you are using this to teach, you probably want to hide the 217;;; implementation of instances and entities from people. 218 219;;>> ??? 220;;> This is Racket's `unspecified' value which is used as the default 221;;> value for unbound slots. It is provided so you can check if a slot is 222;;> unbound. 223(define* ??? undefined) 224(define unspecified-initializer (lambda args ???)) 225(define false-func (lambda args #f)) 226 227;; Basic allocation follows, all was in a single let, but this is not needed 228;; with Racket's modules. Also modified to use simple structs for 229;; everything, including entities since PLT has applicable struct objects. 230 231(define-values (struct:instance make-instance instance? inst-ref inst-set!) 232 ;; slots: applicable, class, function, slots-vector 233 (make-struct-type 'swindleobj #f 3 0 #f '() (current-inspector) 234 (lambda (o . args) (apply (instance-proc o) args)))) 235(defsubst (instance-class x) (inst-ref x 0)) 236(defsubst (instance-proc x) (inst-ref x 1)) 237(defsubst (instance-slots x) (inst-ref x 2)) 238(defsubst (set-instance-class! x c) (inst-set! x 0 c)) 239(defsubst (set-instance-proc! x p) (inst-set! x 1 p)) 240(defsubst (set-instance-slots! x s) (inst-set! x 2 s)) 241 242(defsubst (%instance-ref o f) (vector-ref (instance-slots o) f)) 243(defsubst (%instance-set! o f n) (vector-set! (instance-slots o) f n)) 244 245(define (%allocate-instance class nfields) 246 (make-instance class 247 (lambda args 248 (error 'instance 249 "an instance isn't a procedure -- can't apply it")) 250 (make-vector nfields ???))) 251 252(define (%allocate-entity class nfields) 253 (letrec ([o (make-instance 254 class 255 (lambda args 256 (error 'entity 257 "tried to call an entity before its proc is set")) 258 (make-vector nfields ???))]) 259 o)) 260 261;; This is used only once as part of bootstrapping the braid. 262(define (set-instance-class-to-self! class) 263 (set-instance-class! class class)) 264 265;;>>... 266;;> *** Low level functionality 267;;> (These functions should be used with caution, since they make shooting 268;;> legs in exotic ways extremely easy.) 269 270;;>> (change-class! object new-class initargs ...) 271;;> This operation changes the class of the given `object' to the given 272;;> `new-class'. The way this is done is by creating a fresh instance of 273;;> `new-class', then copying all slot values from `object' to the new 274;;> instance for all shared slot names. Finally, the new instance's set 275;;> of slots is used for the original object with the new class, so it 276;;> preserves its identity. 277(define* (change-class! obj new-class . initargs) 278 (let ([new (make new-class . initargs)] 279 [new-slots (%class-slots new-class)]) 280 (dolist [slot (%class-slots (class-of obj))] 281 (when (and (not (eq? :class (getarg (cdr slot) :allocation :instance))) 282 (assq (car slot) new-slots)) 283 (slot-set! new (car slot) (slot-ref obj (car slot))))) 284 (set-instance-slots! obj (instance-slots new)) 285 (set-instance-class! obj new-class))) 286 287;; This might be cute for some ugly hacks but not needed for now. 288;; Copies the contents of source to target, making it an "alias" object. This 289;; is no re-provided by clos.rkt, but maybe it will in the future... 290;; (define* (copy-object-contents! target source) 291;; (set-instance-class! target (instance-class source)) 292;; (set-instance-proc! target (instance-proc source)) 293;; (set-instance-slots! target (instance-slots source))) 294 295;;>> (set-instance-proc! object proc) 296;;> This function sets the procedure of an entity object. It is useful 297;;> only for making new entity classes. 298(provide set-instance-proc!) ; dangerous! 299 300;; Basic allocation ends here. 301 302;;>>... 303;;> *** Basic functionality 304 305;;>> (instance? x) 306;;>> (object? x) 307;;> These two are synonyms: a predicate that returns #t for objects that 308;;> are allocated and managed by Swindle. 309(provide instance?) 310(define* object? instance?) 311 312;;>> (class-of x) 313;;> Return the class object of `x'. This will either be a Swindle class 314;;> for objects, or a built-in class for other Scheme values. 315;;; %allocate-instance, %allocate-entity, %instance-ref, %instance-set! and 316;;; class-of are the normal interface, from the rest of the code, to the 317;;; low-level memory system. One thing to take note of is that the protocol 318;;; does not allow the user to add low-level instance representations. I have 319;;; never seen a way to make that work. 320;;; Note that this implementation of class-of assumes the name of a the 321;;; primitive classes that are set up later. 322(define* (class-of x) 323 ;; This is an early version that will be modified when built-in types are 324 ;; introduced later. 325 (if (instance? x) (instance-class x) <top>)) 326 327;;; Now we can get down to business. First, we initialize the braid. 328;;; For Bootstrapping, we define an early version of MAKE. It will be changed 329;;; to the real version later on. 330(define* (make class . initargs) 331 (cond [(or (eq? class <class>) (eq? class <entity-class>)) 332 (let* ([new (%allocate-instance class 333 (length the-slots-of-a-class))] 334 [dsupers (getarg initargs :direct-supers '())] 335 [dslots (map list (getarg initargs :direct-slots '()))] 336 [cpl (let loop ([sups dsupers] [so-far (list new)]) 337 (if (null? sups) 338 (reverse so-far) 339 (loop (append (cdr sups) 340 (%class-direct-supers (car sups))) 341 (if (memq (car sups) so-far) 342 so-far 343 (cons (car sups) so-far)))))] 344 [slots 345 (apply append dslots (map %class-direct-slots (cdr cpl)))] 346 [nfields 0] 347 [name (or (getarg initargs :name) '-anonymous-)] 348 [field-initializers '()] 349 ;; this is a temporary allocator version, kept as the original 350 ;; one in tiny-clos. the permanent version below is modified. 351 [allocator 352 (lambda (init) 353 (let ([f nfields]) 354 (set! nfields (+ nfields 1)) 355 (set! field-initializers (cons init field-initializers)) 356 (mcons (lambda (o) (%instance-ref o f)) 357 (lambda (o n) (%instance-set! o f n)))))] 358 [getters-n-setters 359 (map (lambda (s) 360 (cons (car s) (allocator unspecified-initializer))) 361 slots)]) 362 (%set-class-direct-supers! new dsupers) 363 (%set-class-direct-slots! new dslots) 364 (%set-class-cpl! new cpl) 365 (%set-class-slots! new slots) 366 (%set-class-nfields! new nfields) 367 (%set-class-field-initializers! new (reverse field-initializers)) 368 (%set-class-getters-n-setters! new getters-n-setters) 369 (%set-class-name! new name) 370 (%set-class-initializers! new '()) ; no class inits now 371 (%set-class-valid-initargs! new #f) ; no initargs now 372 new)] 373 [(eq? class <generic>) 374 (let ([new (%allocate-entity class (length (%class-slots class)))] 375 [arity (getarg initargs :arity #f)] 376 [name (or (getarg initargs :name) '-anonymous-)]) 377 (%set-generic-methods! new '()) 378 (%set-generic-arity! new arity) 379 (%set-generic-name! new name) 380 (%set-generic-combination! new #f) 381 new)] 382 [(eq? class <method>) 383 (let ([new (%allocate-entity class (length (%class-slots class)))] 384 [name (or (getarg initargs :name) '-anonymous-)]) 385 (%set-method-specializers! new (getarg initargs :specializers)) 386 (%set-method-procedure! new (getarg initargs :procedure)) 387 (%set-method-qualifier! new (or (getarg initargs :qualifier) 388 :primary)) 389 (%set-method-name! new name) 390 (set-instance-proc! new (method:compute-apply-method #f new)) 391 new)])) 392 393;;; These are the real versions of slot-ref and slot-set!. Because of the way 394;;; the new slot access protocol works, with no generic call in line, they can 395;;; be defined up front like this. Cool eh? 396 397;;>> (slot-ref obj slot) 398;;> Pull out the contents of the slot named `slot' in the given `obj'. 399;;> Note that slot names are usually symbols, but can be other values as 400;;> well. 401(define* (slot-ref object slot-name) 402 ((lookup-slot-info (class-of object) slot-name mcar) object)) 403(defsubst (%slot-ref object slot-name) 404 ((lookup-slot-info (class-of object) slot-name mcar) object)) 405 406;;>> (slot-set! obj slot new) 407;;> Change the contents of the `slot' slot of `obj' to the given `new' 408;;> value. 409(define* (slot-set! object slot-name new-value) 410 ((lookup-slot-info (class-of object) slot-name mcdr) object new-value)) 411(defsubst (%slot-set! object slot-name new-value) 412 ((lookup-slot-info (class-of object) slot-name mcdr) object new-value)) 413;;>> (set-slot-ref! obj slot new) 414;;> An alias for `slot-set!', to enable using `setf!' on it. 415(define* set-slot-ref! slot-set!) 416 417;; This is a utility that is used to make locked slots 418(define (make-setter-locked! g+s key error) 419 (let ([setter (mcdr g+s)]) 420 (set-mcdr! g+s 421 (lambda (o n) 422 (cond [(and (pair? n) (eq? key (car n)) (not (eq? key #t))) 423 (setter o (cdr n))] 424 [(eq? ??? ((mcar g+s) o)) (setter o n)] 425 [else (error)]))))) 426 427;;>> (slot-bound? object slot) 428;;> Checks if the given `slot' is bound in `object'. See also `???' 429;;> above. 430(define* (slot-bound? object slot-name) 431 (not (eq? ??? (%slot-ref object slot-name)))) 432 433(define (lookup-slot-info class slot-name selector) 434 (selector (cdr (or (assq slot-name 435 ;; no need to ground slot-ref any more! -- see below 436 ;; (if (eq? class <class>) 437 ;; ;;* This grounds out the slot-ref tower 438 ;; getters-n-setters-for-class 439 ;; (%class-getters-n-setters class)) 440 (%class-getters-n-setters class)) 441 (raise* make-exn:fail:contract 442 "slot-ref: no slot `~.s' in ~.s" 443 slot-name class))))) 444 445;;; These are for optimizations - works only for single inheritance! 446(define (%slot-getter class slot-name) 447 (lookup-slot-info class slot-name mcar)) 448(define (%slot-setter class slot-name) 449 (lookup-slot-info class slot-name mcdr)) 450 451;;>>... Singleton and Struct Specifiers 452 453;;; Singleton class. A hash-table is used so it is still possible to compare 454;;; classes with eq?. 455(define singleton-classes (make-hash-table 'weak)) 456;;>> (singleton x) 457;;> Returns a singleton specification. Singletons can be used as type 458;;> specifications that have only one element in them so you can 459;;> specialize methods on unique objects. 460;;> 461;;> This is actually just a list with the symbol `singleton' in its head 462;;> and the value, but this function uses a hash table to always return 463;;> the same object for the same value. For example: 464;;> => (singleton 1) 465;;> (singleton 1) 466;;> => (eq? (singleton 1) (singleton 1)) 467;;> #t 468;;> but if the input objects are not `eq?', the result isn't either: 469;;> => (eq? (singleton "1") (singleton "1")) 470;;> #f 471;;> Only `eq?' is used to compare objects. 472(define* (singleton x) 473 (or (hash-table-get singleton-classes x false-func) 474 (let ([c (list 'singleton x)]) 475 (hash-table-put! singleton-classes x c) 476 c))) 477;;>> (singleton? x) 478;;> Determines if something is a singleton specification (which is any 479;;> list with a head containing the symbol `singleton'). 480(define* (singleton? x) 481 (and (pair? x) (eq? (car x) 'singleton))) 482(defsubst (%singleton? x) 483 (and (pair? x) (eq? (car x) 'singleton))) 484;;>> (singleton-value x) 485;;> Pulls out the value of a singleton specification. 486(define* singleton-value cadr) 487 488;;>>... 489;;> Also note that Racket struct types are converted to appropriate 490;;> Swindle classes. This way, it is possible to have Swindle generic 491;;> functions that work with struct type specializers. 492 493;;>> (struct-type->class struct-type) 494;;> This function is used to convert a struct-type to a corresponding 495;;> Swindle subclass of `<struct>'. See the Racket manual for details 496;;> on struct types. 497(define struct-to-class-table (make-hash-table)) 498(define* (struct-type->class stype) 499 (hash-table-get 500 struct-to-class-table stype 501 (thunk 502 (let-values ([(name init-field-k auto-field-k accessor mutator 503 immutable-k-list super skipped?) 504 (struct-type-info stype)]) 505 (let* ([supers (list (cond [super (struct-type->class super)] 506 [skipped? <opaque-struct>] 507 [else <struct>]))] 508 [proc? (procedure-struct-type? stype)] 509 [supers (if proc? (cons <primitive-procedure> supers) supers)] 510 [this (parameterize ([*default-object-class* #f]) 511 (make (if proc? <procedure-class> <primitive-class>) 512 :name name :direct-supers supers))]) 513 (hash-table-put! struct-to-class-table stype this) 514 this))))) 515 516;;>>... 517;;> *** Common accessors 518 519;;; Given that the early version of MAKE is allowed to call accessors on class 520;;; metaobjects, the definitions for them come here, before the actual class 521;;; definitions, which are coming up right afterwards. 522;;>> (class-direct-slots class) 523;;>> (class-direct-supers class) 524;;>> (class-slots class) 525;;>> (class-cpl class) 526;;>> (class-name class) 527;;>> (class-initializers class) 528;;> Accessors for class objects (look better than using `slot-ref'). 529(define* (class-direct-slots c) (%slot-ref c 'direct-slots)) 530(define* (class-direct-supers c) (%slot-ref c 'direct-supers)) 531(define* (class-slots c) (%slot-ref c 'slots)) 532(define (class-nfields c) (%slot-ref c 'nfields)) 533(define (class-field-initializers c) (%slot-ref c 'field-initializers)) 534(define (class-getters-n-setters c) (%slot-ref c 'getters-n-setters)) 535(define* (class-cpl c) (%slot-ref c 'cpl)) 536(define* (class-name c) (%slot-ref c 'name)) 537(define* (class-initializers c) (%slot-ref c 'initializers)) 538(define (class-valid-initargs c) (%slot-ref c 'valid-initargs)) 539;;>> (generic-methods generic) 540;;>> (generic-arity generic) 541;;>> (generic-name generic) 542;;>> (generic-combination generic) 543;;> Accessors for generic function objects. 544(define* (generic-methods g) (%slot-ref g 'methods)) 545(define* (generic-arity g) (%slot-ref g 'arity)) 546(define* (generic-name g) (%slot-ref g 'name)) 547(define* (generic-combination g) (%slot-ref g 'combination)) 548;;>> (method-specializers method) 549;;>> (method-procedure method) 550;;>> (method-qualifier method) 551;;>> (method-name method) 552;;>> (method-arity method) 553;;> Accessors for method objects. `method-arity' is not really an 554;;> accessor, it is deduced from the arity of the procedure (minus one for 555;;> the `call-next-method' argument). 556(define* (method-specializers m) (%slot-ref m 'specializers)) 557(define* (method-procedure m) (%slot-ref m 'procedure)) 558(define* (method-qualifier m) (%slot-ref m 'qualifier)) 559(define* (method-name m) (%slot-ref m 'name)) 560(define* (method-arity m) 561 (let ([a (procedure-arity (%method-procedure m))]) 562 (cond [(integer? a) (sub1 a)] 563 [(arity-at-least? a) 564 (make-arity-at-least (sub1 (arity-at-least-value a)))] 565 [else (error 'method-arity "the procedure in ~.s has bad arity ~e" 566 m a)]))) 567 568;;; These versions will be optimized later. 569(define %class-direct-slots class-direct-slots) 570(define %class-direct-supers class-direct-supers) 571(define %class-slots class-slots) 572(define %class-nfields class-nfields) 573(define %class-field-initializers class-field-initializers) 574(define %class-getters-n-setters class-getters-n-setters) 575(define %class-cpl class-cpl) 576(define %class-name class-name) 577(define %class-initializers class-initializers) 578(define %class-valid-initargs class-valid-initargs) 579(define %generic-methods generic-methods) 580(define %generic-arity generic-arity) 581(define %generic-name generic-name) 582(define %generic-combination generic-combination) 583(define %method-specializers method-specializers) 584(define %method-procedure method-procedure) 585(define %method-qualifier method-qualifier) 586(define %method-name method-name) 587 588(define (%set-class-direct-slots! c x) (%slot-set! c 'direct-slots x)) 589(define (%set-class-direct-supers! c x) (%slot-set! c 'direct-supers x)) 590(define (%set-class-slots! c x) (%slot-set! c 'slots x)) 591(define (%set-class-nfields! c x) (%slot-set! c 'nfields x)) 592(define (%set-class-field-initializers! c x) 593 (%slot-set! c 'field-initializers x)) 594(define (%set-class-getters-n-setters! c x) 595 (%slot-set! c 'getters-n-setters x)) 596(define (%set-class-cpl! c x) (%slot-set! c 'cpl x)) 597(define (%set-class-name! c x) (%slot-set! c 'name x)) 598(define (%set-class-initializers! c x) (%slot-set! c 'initializers x)) 599(define (%set-class-valid-initargs! c x) (%slot-set! c 'valid-initargs x)) 600(define (%set-generic-methods! g x) (%slot-set! g 'methods x)) 601(define (%set-generic-arity! g x) (%slot-set! g 'arity x)) 602(define (%set-generic-name! g x) (%slot-set! g 'name x)) 603(define (%set-generic-combination! g x) (%slot-set! g 'combination x)) 604(define (%set-method-specializers! m x) (%slot-set! m 'specializers x)) 605(define (%set-method-procedure! m x) (%slot-set! m 'procedure x)) 606(define (%set-method-qualifier! m x) (%slot-set! m 'qualifier x)) 607(define (%set-method-name! m x) (%slot-set! m 'name x)) 608 609;;; These are used to access the two slots that optimize generic invocations. 610(define (%generic-app-cache g ) (%slot-ref g 'app-cache)) 611(define (%generic-singletons-list g ) (%slot-ref g 'singletons-list)) 612(define (%set-generic-app-cache! g x) (%slot-set! g 'app-cache x)) 613(define (%set-generic-singletons-list! g x) (%slot-set! g 'singletons-list x)) 614 615;;; The next 7 clusters define the 6 initial classes. It takes 7 to 6 because 616;;; the first and fourth both contribute to <class>. 617 618(define the-slots-of-a-class 619 '(direct-supers ; (class ...) 620 direct-slots ; ((name . options) ...) 621 cpl ; (class ...) 622 slots ; ((name . options) ...) 623 nfields ; an integer 624 field-initializers ; (proc ...) 625 getters-n-setters ; ((slot-name getter setter) ...) 626 name ; a symbol 627 initializers ; (proc ...) 628 valid-initargs)) ; (initarg ...) or #f 629(define getters-n-setters-for-class ; see lookup-slot-info 630 (map (lambda (s) 631 (let ([f (position-of s the-slots-of-a-class)]) 632 (cons s (mcons (lambda (o) (%instance-ref o f)) 633 (lambda (o n) (%instance-set! o f n)))))) 634 the-slots-of-a-class)) 635 636;;>>... 637;;> *** Basic classes 638 639;;>> <class> 640;;> This is the "mother of all classes": every Swindle class is an 641;;> instance of `<class>'. 642;;> Slots: 643;;> * direct-supers: direct superclasses 644;;> * direct-slots: direct slots, each a list of a name and options 645;;> * cpl: class precedence list (classes list this to <top>) 646;;> * slots: all slots (like direct slots) 647;;> * nfields: number of fields 648;;> * field-initializers: a list of functions to initialize slots 649;;> * getters-n-setters: an alist of slot-names, getters, and setters 650;;> * name: class name (usually the defined identifier) 651;;> * initializers: procedure list that perform additional initializing 652;;> See the `clos' documentation for available class and slot keyword 653;;> arguments and their effect. 654(define* <class> (%allocate-instance #f (length the-slots-of-a-class))) 655(set-instance-class-to-self! <class>) 656 657;; In the original tiny-clos, this block used to just set the getters-n-setters 658;; slot of a class to '() since it wasn't used anyway. In Swindle the MOP 659;; accessors are all optimized to directly get the vector element because the 660;; meta hierarchy is assumed to be single-inheritance only (allocation of more 661;; slots always come after the built in ones), so what I do here is set the 662;; slot value properly, and since `%class-getters-n-setters' accesses the 663;; vector directly it doesn't go through slot-ref, which means that the 664;; slot-ref definition above is fine. So, 665;; (%set-class-getters-n-setters! <class> getters-n-setters-for-class) 666;; translates into this: 667((mcdr (cdr (assq 'getters-n-setters getters-n-setters-for-class))) 668 <class> getters-n-setters-for-class) 669;; and now the direct `%class-getters-n-setters' version: 670(set! %class-getters-n-setters 671 ;; and (lookup-slot-info <class> 'getters-n-setters mcar) translates to: 672 (mcar (cdr (assq 'getters-n-setters getters-n-setters-for-class)))) 673 674;;>> <top> 675;;> This is the "mother of all values": every value is an instance of 676;;> `<top>' (including standard Scheme values). 677(define* <top> (make <class> :direct-supers '() 678 :direct-slots '() 679 :name '<top>)) 680 681;;>> <object> 682;;> This is the "mother of all objects": every Swindle object is an 683;;> instance of `<object>'. 684(define* <object> (make <class> :direct-supers (list <top>) 685 :direct-slots '() 686 :name '<object>)) 687 688;;; This cluster, together with the first cluster above that defines <class> 689;;; and sets its class, have the effect of: 690;;; (define <class> 691;;; (make <class> :direct-supers (list <object>) 692;;; :direct-slots '(direct-supers ...) 693;;; :name '<class>)) 694(%set-class-direct-supers! <class> (list <object>)) 695(%set-class-cpl! <class> (list <class> <object> <top>)) 696(%set-class-direct-slots! <class> (map list the-slots-of-a-class)) 697(%set-class-slots! <class> (map list the-slots-of-a-class)) 698(%set-class-nfields! <class> (length the-slots-of-a-class)) 699(%set-class-field-initializers! <class> (map (lambda (s) 700 unspecified-initializer) 701 the-slots-of-a-class)) 702(%set-class-name! <class> '<class>) 703(%set-class-initializers! <class> '()) 704(%set-class-valid-initargs! <class> #f) 705 706;;>> <procedure-class> 707;;> The class of all procedures classes, both standard Scheme procedures 708;;> classes and entity (Swindle procedure objects) classes. (Note that 709;;> this is a class of *classes*). 710(define* <procedure-class> 711 (make <class> :direct-supers (list <class>) 712 :direct-slots '() 713 :name '<procedure-class>)) 714 715;;>> <entity-class> 716;;> The class of entity classes -- generic functions and methods. An 717;;> entity is a procedural Swindle object, something that you can apply as 718;;> a function but it is still a Swindle object. Note that this is the 719;;> class of entity *classes* not of entities themselves. 720(define* <entity-class> 721 (make <class> :direct-supers (list <procedure-class>) 722 :direct-slots '() 723 :name '<entity-class>)) 724 725;;>> <function> 726;;> The class of all applicable values: methods, generic functions, and 727;;> standard closures. 728(define* <function> 729 (make <class> :direct-supers (list <top>) 730 :direct-slots '() 731 :name '<function>)) 732 733;;; The two extra slots below (app-cache and singletons-list) are used to 734;;; optimize generic invocations: app-cache holds an 'equal hash-table that 735;;; maps a list of classes to the lambda expression that holds the method call 736;;; (it used to be an l-hash-table, but 'equal is ok since we can't compare 737;;; swindleobj instances recursively -- which is also why tool.rkt needs to 738;;; redefine the `render-value/format' method). The contents of this slot is 739;;; reset whenever a method is added to the generic. Two problems make things 740;;; a little more complicated. First, if add-method is used to modify any of 741;;; the generic-invocation-generics then all of these caches should be flushed, 742;;; this is achieved by setting *generic-app-cache-tag* to a new [list] object 743;;; and the value of app-cache is a cons of that value and the actual hash 744;;; table - if we see that the car is not eq? to the current tag, then we flush 745;;; the cache. Second, singleton values might screw things up, so we hold in 746;;; singletons-list a list that has the same length as all method specializer 747;;; lists, each element contains a hash table with all singleton values that 748;;; appear in that place matched to #t, then when we try to see if we have a 749;;; cached function for a generic application, we scan the argument list 750;;; against this list, and any value that has a singleton with that value at 751;;; some method, is left in place for the app-cache lookup (it is used itself 752;;; rather than its class). This whole thing is a bit complicated but leads to 753;;; dramatic run-time improvement. 754;;>> <generic> 755;;> The class of generic functions: objects that contain method objects 756;;> and calls the appropriate ones when applied. 757;;> Slots: 758;;> * methods: a list of <method> objects 759;;> * arity: the generic arity (same for all of its methods) 760;;> * name: generic name 761;;> * combination: a method combination function or #f, see 762;;> `make-generic-combination' below for details 763(define* <generic> 764 (make <entity-class> :direct-supers (list <object> <function>) 765 :direct-slots '(methods arity name combination 766 app-cache singletons-list) ; see above 767 :name '<generic>)) 768 769;;>> <method> 770;;> The class of methods: objects that are similar to Scheme closures, 771;;> except that they have type specifiers attached. Note that in contrast 772;;> to Tiny CLOS, methods are applicable objects in Swindle -- they check 773;;> supplied argument types when applied. 774;;> Slots: 775;;> * specializers: a list of class (and singleton) specializers 776;;> * procedure: the function (never call directly!) 777;;> * qualifier: some qualifier tag, used when applying a generic 778;;> * name: method name 779(define* <method> 780 (make <entity-class> :direct-supers (list <object> <function>) 781 :direct-slots '(specializers procedure qualifier name) 782 :name '<method>)) 783;; Do this since compute-apply-method relies on them not changing, as well as a 784;; zillion other places. A method should be very similar to a lambda. 785(dolist [slot '(specializers procedure qualifier)] 786 (make-setter-locked! (lookup-slot-info <method> slot values) #t 787 (lambda () 788 (raise* make-exn:fail:contract 789 "slot-set!: slot `~.s' in <method> is locked" slot)))) 790 791;;>>... 792;;> *** Convenience functions 793;;> 794;;> These are some convenience functions -- no new syntax, just function 795;;> wrappers for `make' with some class and some slot values. See `clos' 796;;> for a more sophisticated (and convenient) approach. 797 798;;; These are the convenient syntax we expose to the base-level user. 799;;>> (make-class direct-supers direct slots) 800;;> Creates a class object -- an instance of <class>. 801(define* (make-class direct-supers direct-slots) 802 (make <class> :direct-supers direct-supers 803 :direct-slots direct-slots)) 804;;>> (make-generic-function [name/arity]) 805;;> Creates a generic function object -- an instance of <generic>. The 806;;> argument can specify name and/or arguments number. 807(define* (make-generic-function . name/arity) 808 (cond 809 [(null? name/arity) (make <generic>)] 810 [(null? (cdr name/arity)) 811 (let ([n/a (car name/arity)]) 812 (if (integer? n/a) 813 (make <generic> :arity n/a) (make <generic> :name n/a)))] 814 [else (make <generic> :name (car name/arity) :arity (cadr name/arity))])) 815;;>> (make-method specializers procedure) 816;;> Creates a method object -- an instance of <method>, using the given 817;;> specializer list and procedure. The procedure should have a first 818;;> argument which is being used to access a `call-next-method' call. 819(define* (make-method specializers procedure) 820 (make <method> :specializers specializers 821 :procedure procedure)) 822 823;;>> (no-next-method generic method [args ...]) 824;;>> (no-applicable-method generic [args ...]) 825;;> These two generic functions are equivalents to the ones in CL. The 826;;> first one is applied on a generic and a method in case there was no 827;;> next method and `call-next-method' was used. The second is used when 828;;> a generic was called but no matching primary methods were found. The 829;;> only difference is that in Swindle methods can be applied directly, 830;;> and if `call-next-method' is used, then `no-next-method' gets `#f' for 831;;> the generic argument. 832(define* no-next-method (make-generic-function 'no-next-method)) 833(define* no-applicable-method (make-generic-function 'no-applicable-method)) 834 835;;; Add possibility of generic-independent method application - this is the 836;;; instance-proc of methods, which is activated when you apply the object (in 837;;; the original, methods could not be applied). This is defined using this 838;;; name and arguments because it is later used directly by the generic 839;;; function (cannot use the generic in the initial make since methods need to 840;;; be created when the generics are constructed). 841(define (method:compute-apply-method call-next-method method) 842 (let* ([specializers (%method-specializers method)] 843 [*no-next-method* ; see the *no-next-method* trick below 844 (lambda args (no-next-method #f method . args))] 845 [proc (%method-procedure method)] 846 [arity (method-arity method)] 847 [exact? (integer? arity)] 848 [required ((if exact? identity arity-at-least-value) arity)]) 849 (when (and exact? (> (length specializers) required)) 850 (error 'compute-apply-method 851 "got ~e specializers for ~s - too much for procedure arity ~a" 852 (length specializers) (%method-name method) required)) 853 (lambda args 854 (cond [(if exact? 855 (not (= (length args) required)) (< (length args) required)) 856 (raise* make-exn:fail:contract:arity 857 "method ~a: expects ~a~e argument~a, given ~e~a" 858 (%method-name method) 859 (if exact? "" "at least ") required 860 (if (= 1 required) "" "s") (length args) 861 (if (null? args) "" (format ": ~e" args)))] 862 [(not (every instance-of? args specializers)) 863 (let loop ([args args] [specs specializers]) 864 (if (instance-of? (car args) (car specs)) 865 (loop (cdr args) (cdr specs)) 866 (raise* make-exn:fail:contract 867 "method ~a: expects argument of type ~a; given ~e" 868 (%method-name method) (%class-name (car specs)) 869 (car args))))] 870 [else (proc *no-next-method* . args)])))) 871 872;;>>... Generics in the instance initialization protocol 873;;> The following generic functions are used as part of the protocol of 874;;> instantiating an instance, and some are used specifically to instantiate 875;;> class objects. 876 877;;; The instance structure protocol. 878;;>> (allocate-instance class initargs) 879;;> This generic function is called to allocate an instance of a class. 880;;> It is applied on the class object, and is expected to return the new 881;;> instance object of that class. 882(define* allocate-instance 883 (make-generic-function 'allocate-instance)) 884;;>> (initialize instance initargs) 885;;> This generic is called to initialize an instance. It is applied on 886;;> the newly allocated object and the given initargs, and is not expected 887;;> to return any meaningful value -- only do some side effects on the 888;;> instance to initialize it. When overriding this for a some class, it 889;;> is not a good idea to skip `call-next-method' since it is responsible 890;;> for initializing slot values. 891(define* initialize 892 (make-generic-function 'initialize)) 893;;>> (compute-getter-and-setter class slot allocator) 894;;> This generic is used to get a getter and setter functions for a given 895;;> slot. It is passed the class object, the slot information (a list of 896;;> a slot name and options), and an allocator function. The allocator is 897;;> a function that gets an initializer function and returns an index 898;;> position for the new slot. The return value should be a list of two 899;;> elements -- a getter and a setter functions. 900(define* compute-getter-and-setter 901 (make-generic-function 'compute-getter-and-setter)) 902;;; The class initialization protocol. 903;;>> (compute-cpl class) 904;;> This generic is used to get the class-precedence-list for a class 905;;> object. The standard <class> object uses the `compute-std-cpl' (see 906;;> in the code) which flattens the class ancestors using a topological 907;;> sort that resolve ambiguities left-to-right. 908(define* compute-cpl 909 (make-generic-function 'compute-cpl)) 910;;>> (compute-slots class) 911;;> This generic is used to compute all slot information for a given 912;;> class, after its precedence list has been computed. The standard 913;;> <class> collects information from all preceding classes. 914(define* compute-slots 915 (make-generic-function 'compute-slots)) 916 917;;>> (compute-apply-method method) 918;;> This generic is used to compute the procedure that will get executed 919;;> when a method is applied directly. 920(define* compute-apply-method 921 (make-generic-function 'compute-apply-method)) 922 923;;>>... Generics in the generic invocation protocol 924;;> These generics are used for invocation of generic functions. See the 925;;> code to see how this circularity is achieved. 926 927;;>> ((compute-apply-generic generic) args ...) 928;;> This generic is used to compute the object (a closure) that is 929;;> actually applied to execute the generic call. The standard version 930;;> uses `compute-method' and `compute-apply-methods' below, and caches 931;;> the result. 932(define* compute-apply-generic 933 (make-generic-function 'compute-apply-generic)) 934;;>> (compute-methods generic args) 935;;> Computes the methods that should be applied for this generic 936;;> invocation with args. The standard code filters applicable methods 937;;> and sorts them according to their specificness. The return value is 938;;> expected to depend only on the types of the arguments (and values if 939;;> there are singleton specializers). 940(define* compute-methods 941 (make-generic-function 'compute-methods)) 942;;>> ((compute-method-more-specific? generic) mthd1 mthd2 args) 943;;> Get a generic and return a function that gets two methods and a list 944;;> of arguments and decide which of the two methods is more specific. 945;;> This decision should only be based on the argument types, or values 946;;> only in case of singletons. 947(define* compute-method-more-specific? 948 (make-generic-function 'compute-method-more-specific?)) 949;;>> ((compute-apply-methods generic methods) args ...) 950;;> Gets a generic and returns a function that gets the given arguments 951;;> for this call. This function which it returns is the combination of 952;;> all given methods. The standard one arranges them by default using 953;;> the `call-next-method' argument that methods have. Swindle extends 954;;> this with qualified methods and applies `before', `after', and 955;;> `around' methods in a similar way to CLOS: first the `around' methods 956;;> are applied (and they usually call their `call-next-method' to 957;;> continue but can return a different value), then all the `before' 958;;> methods are applied (with no `call-next-method'), then all `primary' 959;;> methods as usual (remembering the return value), and finally the 960;;> `after' methods (similar to the `before', but in reverse specificness 961;;> order). If the generic has a `combination' slot value, then it is a 962;;> procedure that is used to combine the primary methods, but the 963;;> auxiliary ones are still applied in the same way. This is unlike CLOS 964;;> where the standard combinations run only `around' methods, and there 965;;> is generally more control with method combinations, but in Swindle 966;;> `compute-apply-methods' should be overridden for this. See 967;;> `make-generic-combination' for details about method combinations. 968(define* compute-apply-methods 969 (make-generic-function 'compute-apply-methods)) 970 971;;; The next thing to do is bootstrap generic functions. 972 973(define generic-invocation-generics 974 (list compute-apply-generic compute-methods 975 compute-method-more-specific? compute-apply-methods)) 976 977;;; This is used to signal whenever all method caches are to be reset - so when 978;;; a method is added to generic-invocation-generics, this is set to some value 979;;; which is not eq? to the current one. 980(define *generic-app-cache-tag* #t) 981 982;;>> (add-method generic method) 983;;> This generic function is called to add a method to a generic function 984;;> object. This is an other change from the original Tiny CLOS where it 985;;> was a normal function. 986(define* (add-method generic method) 987 ;; add singleton specializer value (if any) to the corresponding hash table 988 ;; in singletons-list. 989 (define (add-to-singletons-list specs tables) 990 (cond 991 [(null? specs) null] 992 [(%singleton? (car specs)) 993 (let ([ht (or (car tables) 994 (make-hash-table 'weak))]) 995 (hash-table-put! ht (singleton-value (car specs)) #t) 996 (cons ht (add-to-singletons-list (cdr specs) (cdr tables))))] 997 [else 998 (cons (car tables) 999 (add-to-singletons-list (cdr specs) (cdr tables)))])) 1000 (define (n-falses n) 1001 (let loop ([n n] [r '()]) (if (zero? n) r (loop (sub1 n) (cons #f r))))) 1002 (let ([tables (%generic-singletons-list generic)] 1003 [specs (%method-specializers method)] 1004 [qualifier (%method-qualifier method)]) 1005 ;; make sure that tables always contain enough hash tables (or #f's) 1006 (cond [(eq? tables ???) 1007 (set! tables (n-falses (length specs)))] 1008 [(< (length tables) (length specs)) 1009 (set! tables (append 1010 tables 1011 (n-falses (- (length specs) (length tables)))))]) 1012 (set! tables (add-to-singletons-list specs tables)) 1013 (%set-generic-singletons-list! generic tables) 1014 (if (memq generic generic-invocation-generics) 1015 ;; reset all caches by changing the value of *generic-app-cache-tag* 1016 (set! *generic-app-cache-tag* (list #f)) 1017 ;; reset this generic app-cache 1018 (%set-generic-app-cache! generic ???)) 1019 (%set-generic-methods! 1020 generic 1021 (cons method 1022 (filter (lambda (m) 1023 (not (and (every eq? (method-specializers m) specs) 1024 (eq? (%method-qualifier m) qualifier)))) 1025 (%generic-methods generic)))) 1026 (set-instance-proc! generic (compute-apply-generic generic)))) 1027 1028;;; Adding a method calls COMPUTE-APPLY-GENERIC, the result of which calls the 1029;;; other generics in the generic invocation protocol. Two, related, problems 1030;;; come up. A chicken and egg problem and a infinite regress problem. 1031;;; In order to add our first method to COMPUTE-APPLY-GENERIC, we need 1032;;; something sitting there, so it can be called. The first definition below 1033;;; does that. 1034;;; Then, the second definition solves both the infinite regress and the not 1035;;; having enough of the protocol around to build itself problem the same way: 1036;;; it special cases invocation of generics in the invocation protocol. 1037 1038(set-instance-proc! compute-apply-generic 1039 (lambda (generic) 1040 ((%method-procedure (car (%generic-methods generic))) '() generic))) 1041 1042(add-method compute-apply-generic 1043 (make-method (list <generic>) 1044 (named-lambda method:compute-apply-generic (call-next-method generic) 1045 #| The code below is the original, then comes the optimized version below 1046 ;; see the definition of the <generic> class above. 1047 (lambda args 1048 (if (and (memq generic generic-invocation-generics) ;* Ground case 1049 (memq (car args) generic-invocation-generics)) 1050 (apply (%method-procedure (last (%generic-methods generic))) #f args) 1051 ((compute-apply-methods generic) 1052 (compute-methods generic args) . args))) 1053 |# 1054 ;; This function converts the list of arguments to a list of keys to look 1055 ;; for in the cache - use the argument's class except when there is a 1056 ;; corresponding singleton with the same value at the same position. 1057 (define (get-keys args tables) 1058 (let loop ([args args] [tables tables] [ks '()]) 1059 (if (or (null? tables) (null? args)) 1060 (reverse ks) 1061 (loop (cdr args) (cdr tables) 1062 (cons (if (and (car tables) 1063 (hash-table-get 1064 (car tables) (car args) false-func)) 1065 (car args) 1066 (class-of (car args))) 1067 ks))))) 1068 ;; This is the main function that brings the correct value from the 1069 ;; cache, or generates one and store it if there is no entry, or the 1070 ;; cache was reset. Finally, it is applied to the arguments as usual. 1071 ;; NOTE: This code is delicate! Handle with extreme care! 1072 (lambda args 1073 (let ([app-cache (%generic-app-cache generic)] 1074 [arity (%generic-arity generic)] 1075 [keys (get-keys args (%generic-singletons-list generic))] 1076 [ground? (and ;* Ground case 1077 (memq generic generic-invocation-generics) 1078 (pair? args) 1079 (memq (car args) generic-invocation-generics))]) 1080 ;; This function creates the cached closure -- the assumption is that 1081 ;; `keys' contain a specification that will identify all calls that 1082 ;; will have this exact same list. 1083 (define (compute-callable) 1084 (let ([c (if ground? 1085 (let ([m (%method-procedure 1086 (last (%generic-methods generic)))]) 1087 (lambda args (apply m #f args))) 1088 (compute-apply-methods 1089 generic (compute-methods generic args)))]) 1090 (hash-table-put! (cdr app-cache) keys c) 1091 c)) 1092 (when (cond [(not arity) #f] 1093 [(integer? arity) (not (= (length args) arity))] 1094 [else (< (length args) (arity-at-least-value arity))]) 1095 (let ([least (and (arity-at-least? arity) 1096 (arity-at-least-value arity))]) 1097 (raise* make-exn:fail:contract:arity 1098 "generic ~a: expects ~a~e argument~a, given ~e~a" 1099 (%generic-name generic) 1100 (if least "at least " "") (or least arity) 1101 (if (= 1 (or least arity)) "" "s") (length args) 1102 (if (null? args) "" (format ": ~e" args))))) 1103 (when (or (eq? app-cache ???) 1104 (not (eq? (car app-cache) *generic-app-cache-tag*))) 1105 (set! app-cache (cons *generic-app-cache-tag* 1106 (make-hash-table 'weak 'equal))) 1107 (%set-generic-app-cache! generic app-cache)) 1108 ((hash-table-get (cdr app-cache) keys compute-callable) 1109 . args)))))) 1110 1111(add-method compute-methods 1112 (make-method (list <generic>) 1113 (named-lambda method:compute-methods (call-next-method generic args) 1114 (let ([more-specific? (compute-method-more-specific? generic)]) 1115 (sort (filter 1116 (lambda (m) 1117 ;; Note that every only goes as far as the shortest list 1118 (every instance-of? args (%method-specializers m))) 1119 (%generic-methods generic)) 1120 (lambda (m1 m2) (more-specific? m1 m2 args))))))) 1121 1122(add-method compute-method-more-specific? 1123 (make-method (list <generic>) 1124 (named-lambda method:compute-method-more-specific? 1125 (call-next-method generic) 1126 (lambda (m1 m2 args) 1127 (let loop ([specls1 (%method-specializers m1)] 1128 [specls2 (%method-specializers m2)] 1129 [args args]) 1130 (cond [(and (null? specls1) (null? specls2)) 1131 (if (eq? (%method-qualifier m1) (%method-qualifier m2)) 1132 (error 'generic 1133 "two methods are equally specific in ~e" generic) 1134 #f)] 1135 ;; some methods in this file have less specializers than 1136 ;; others, for things like args -- so remove this, leave the 1137 ;; args check but treat the missing as if it's <top> 1138 ;; ((or (null? specls1) (null? specls2)) 1139 ;; (error 'generic 1140 ;; "two methods have different number of ~ 1141 ;; specializers in ~e" generic)) 1142 [(null? args) ; shouldn't happen 1143 (error 'generic 1144 "fewer arguments than specializers for ~e" generic)] 1145 [(null? specls1) ; see above -> treat this like <top> 1146 (if (eq? <top> (car specls2)) 1147 (loop specls1 (cdr specls2) (cdr args)) 1148 #f)] 1149 [(null? specls2) ; see above -> treat this like <top> 1150 (if (eq? <top> (car specls1)) 1151 (loop (cdr specls1) specls2 (cdr args)) 1152 #t)] 1153 [else (let ([c1 (car specls1)] [c2 (car specls2)]) 1154 (if (eq? c1 c2) 1155 (loop (cdr specls1) (cdr specls2) (cdr args)) 1156 (more-specific? c1 c2 (car args))))])))))) 1157 1158(add-method compute-apply-methods 1159 (make-method (list <generic>) 1160 (named-lambda method:compute-apply-methods 1161 (call-next-method generic methods) 1162 (let ([primaries '()] [arounds '()] [befores '()] [afters '()] 1163 [combination (%generic-combination generic)]) 1164 ;; *** Trick: this (and in <method> above) is the only code that is 1165 ;; supposed to ever apply a method procedure. So, the closure that 1166 ;; will invoke `no-next-method' is named `*no-next-method*' so it is 1167 ;; identifiable. The only way to break this would be to call the 1168 ;; method-procedure directly on an object with such a name. 1169 (define one-step 1170 (if combination 1171 (combination generic) 1172 (lambda (tail args) 1173 (lambda newargs 1174 ;; tail is never null: (null? (cdr tail)) below, and the fact 1175 ;; that this function is applied on the primaries which are 1176 ;; never null 1177 (let ([args (if (null? newargs) args newargs)]) 1178 ((cdar tail) 1179 (if (null? (cdr tail)) 1180 (named-lambda *no-next-method* args 1181 (no-next-method generic (caar tail) . args)) 1182 (one-step (cdr tail) args)) 1183 . args)))))) 1184 (define ((apply-before/after-method args) method) 1185 ((cdr method) 1186 (named-lambda *no-next-method* args 1187 (no-next-method generic (car method) . args)) 1188 . args)) 1189 (define ((call-before-primary-after args) . newargs) 1190 ;; could supply newargs below, but change before calling befores 1191 (let ([args (if (null? newargs) args newargs)]) 1192 (for-each (apply-before/after-method args) befores) 1193 (begin0 ((one-step primaries args)) 1194 (for-each (apply-before/after-method args) afters)))) 1195 (define (one-around-step tail args) 1196 (if (null? tail) 1197 (call-before-primary-after args) 1198 (lambda newargs 1199 (let ([args (if (null? newargs) args newargs)]) 1200 ((cdar tail) (one-around-step (cdr tail) args) . args))))) 1201 ;; first sort by qualifier and pull out method-procedures 1202 (let loop ([ms methods]) 1203 (unless (null? ms) 1204 (letsubst ([(push! p) 1205 (set! p (cons (cons (car ms) 1206 (%method-procedure (car ms))) 1207 p))]) 1208 (case (%method-qualifier (car ms)) 1209 [(:primary) (push! primaries)] 1210 [(:around) (push! arounds)] 1211 [(:before) (push! befores)] 1212 [(:after) (push! afters)] 1213 ;; ignore other qualifiers 1214 ;; [else (error 'compute-apply-methods 1215 ;; "a method ~e has an unexpected qualifier `~e'" 1216 ;; (car methods) 1217 ;; (%method-qualifier (car methods)))] 1218 ) 1219 (loop (cdr ms))))) 1220 (set! primaries (reverse primaries)) 1221 (set! arounds (reverse arounds)) 1222 (set! befores (reverse befores)) 1223 ;; no reverse for afters 1224 (cond [(null? primaries) 1225 (lambda args (no-applicable-method generic . args))] 1226 ;; optimize common case of only primaries 1227 [(and (null? befores) (null? afters) (null? arounds)) 1228 ;; args is initialized to () since if it is a generic of no 1229 ;; arguments then it will always stay so, otherwise, the first 1230 ;; call will have the real arguments anyway 1231 (one-step primaries '())] 1232 [else (one-around-step arounds '())]))))) 1233 1234;;>> (((make-generic-combination keys...) generic) tail args) 1235;;> This function can be used to construct simple method combinations that 1236;;> can be used with the `combination' slot of generic functions. The 1237;;> combination itself is a function that gets a generic and returns a 1238;;> function that gets a list of method/procedure pairs (for optimization 1239;;> the method-procedures are pre taken) and the arguments and performs 1240;;> the call -- but this is only interesting if there's any need to 1241;;> implement a method combination directly, otherwise, the 1242;;> `make-generic-combination' interface should allow enough freedom. 1243;;> Note that when a method combination is used, `around', `before', and 1244;;> `after' are called around the primary call as usual, but the primaries 1245;;> are never called with a valid `call-next-method' argument. 1246;;> 1247;;> The keyword arguments that can be taken determine the behavior of this 1248;;> combination. Overall, it is roughly like a customizable version of a 1249;;> fold operation on the method calls. 1250;;> * :init 1251;;> - The initial value for this computation. Defaults to null. 1252;;> * :combine 1253;;> - A function to be called on a method call result and the old value, 1254;;> and produces a new value. The default is `cons', which with an 1255;;> initial null value will collect the results into a reversed list. 1256;;> * :process-methods 1257;;> - A function that can be called on the initial list of 1258;;> method/procedure pairs to change it -- for example, it can be 1259;;> reversed to apply the methods from the least specific to the most 1260;;> specific. No default. 1261;;> * :process-result 1262;;> - A function that can be called on the final resulting value to 1263;;> produce the actual return value. For example, it can reverse back 1264;;> a list of accumulated values. No default. 1265;;> * :control 1266;;> - If this parameter is specified, then the `:combine' argument is 1267;;> ignored. The value given to `:control' should be a function of 1268;;> four arguments: 1269;;> 1. a `loop' function that should be called on some new value and 1270;;> some new tail; 1271;;> 2. a `val' argument that gets the current accumulated value; 1272;;> 3. a `this' thunk that can be called to apply the current method 1273;;> and return its result; 1274;;> 4. a `tail' value that holds the rest of the method/procedure list 1275;;> which can be sent to `loop'. 1276;;> It should be clear now, that a `:control' argument can have a lot 1277;;> of control on the computation, it can abort, change arbitrary 1278;;> values and skip calling methods. Note that if it won't call 1279;;> `loop' with an empty list, then a `:process-result' function will 1280;;> not be used as well. See the pre-defined combinations in the 1281;;> source code to see examples of using this function. 1282(define* (make-generic-combination 1283 &key [init '()] [combine cons] 1284 process-methods process-result control) 1285 (lambda (generic) 1286 (lambda (tail dummy-args) 1287 (let ([tail (if process-methods (process-methods tail) tail)]) 1288 (lambda args 1289 (let loop ([res init] [tail tail]) 1290 ;; see *no-next-method* trick above 1291 (let ([*no-next-method* 1292 (lambda args (no-next-method generic (caar tail) . args))]) 1293 (if (null? tail) 1294 (if process-result (process-result res) res) 1295 (if control 1296 (control loop res 1297 (lambda () ((cdar tail) *no-next-method* . args)) 1298 (cdr tail)) 1299 (loop (combine ((cdar tail) *no-next-method* . args) res) 1300 (cdr tail))))))))))) 1301 1302;;>> generic-+-combination 1303;;>> generic-list-combination 1304;;>> generic-min-combination 1305;;>> generic-max-combination 1306;;>> generic-append-combination 1307;;>> generic-append!-combination 1308;;>> generic-begin-combination 1309;;>> generic-and-combination 1310;;>> generic-or-combination 1311;;> These are all functions that can be used as a `combination' value for 1312;;> a generic function. They work in the same way as the standard method 1313;;> combinations of CL. Most of them do the obvious thing based on some 1314;;> function to combine the result. The `begin' combination simply 1315;;> executes all methods one by one and returns the last value, the `and' 1316;;> and `or' combinations will call them one by one until a false or true 1317;;> result is returned. The source of these can be used as templates for 1318;;> defining more combinations. 1319(define* generic-+-combination 1320 (make-generic-combination :init 0 :combine +)) 1321(define* generic-list-combination 1322 (make-generic-combination :process-result reverse)) 1323(define* generic-min-combination 1324 (make-generic-combination :process-result (lambda (r) (apply min r)))) 1325(define* generic-max-combination 1326 (make-generic-combination :process-result (lambda (r) (apply max r)))) 1327(define* generic-append-combination 1328 (make-generic-combination 1329 :process-result (lambda (r) (apply append (reverse r))))) 1330(define* generic-append!-combination 1331 (make-generic-combination 1332 :process-result (lambda (r) (apply append (reverse r))))) 1333(define* generic-begin-combination 1334 (make-generic-combination :init #f :combine (lambda (x y) x))) 1335(define* generic-and-combination 1336 (make-generic-combination 1337 :init #t 1338 :control (lambda (loop val this tail) (and val (loop (this) tail))))) 1339(define* generic-or-combination 1340 (make-generic-combination 1341 :init #f 1342 :control (lambda (loop val this tail) (or (this) (loop #f tail))))) 1343 1344;;>>... 1345;;> *** More class functionality 1346;;> (In the following, a `class' can be a class, a singleton specifier, or a 1347;;> struct type.) 1348 1349;; optimized helper 1350(defsubst (%struct->class c) 1351 (if (struct-type? c) (struct-type->class c) c)) 1352 1353;;>> (subclass? class1 class2) 1354;;> Is `class1' a subclass of `class2'? 1355(define* (subclass? c1 c2) 1356 (if (%singleton? c1) 1357 (if (%singleton? c2) 1358 (eq? (singleton-value c1) (singleton-value c2)) 1359 (instance-of? (singleton-value c1) (%struct->class c2))) 1360 (memq (%struct->class c2) (%class-cpl (%struct->class c1))))) 1361 1362;;>> (instance-of? x class) 1363;;> Checks if `x' is an instance of `class' (or one of its subclasses). 1364(define* (instance-of? x c) 1365 ;; efficiency: many cases use <top> (all untyped arguments) 1366 (or (eq? c <top>) 1367 (if (%singleton? c) 1368 ;; efficiency: similar to `subclass?' above 1369 (eq? (singleton-value c) x) 1370 (memq (%struct->class c) (%class-cpl (%struct->class (class-of x))))))) 1371 1372;;>> (class? x) 1373;;> Determines whether `x' is a class. 1374(define* (class? x) (instance-of? x <class>)) 1375(defsubst (%class? x) (instance-of? x <class>)) 1376 1377;;>> (specializer? x) 1378;;> Determines whether `x' is a class, a singleton, or a struct-type. 1379(define* (specializer? x) (or (class? x) (%singleton? x) (struct-type? x))) 1380 1381;;>> (more-specific? class1 class2 x) 1382;;> Is `class1' more specific than `class2' for the given value? 1383(define* (more-specific? c1 c2 arg) 1384 (if (%singleton? c1) 1385 (and (eq? (singleton-value c1) arg) 1386 (not (and (%singleton? c2) (eq? (singleton-value c1) arg)))) 1387 (let ([cc1 (memq (%struct->class c1) (%class-cpl (class-of arg)))]) 1388 (and cc1 (memq (%struct->class c2) (cdr cc1)))))) 1389 1390(add-method initialize 1391 (make-method (list <top>) 1392 (named-lambda method:initialize (call-next-method object initargs) 1393 (error 'initialize "can't initialize an instance of ~e" 1394 (class-of object))))) 1395 1396(add-method initialize 1397 (make-method (list <object>) 1398 (named-lambda method:initialize (call-next-method object initargs) 1399 (let* ([class (class-of object)] 1400 [field-initializers (%class-field-initializers class)]) 1401 (for-each (lambda (init) (init . initargs)) 1402 (%class-initializers class)) 1403 (let loop ([n 0] [inits field-initializers]) 1404 (when (pair? inits) 1405 (%instance-set! object n ((car inits) . initargs)) 1406 (loop (+ n 1) (cdr inits)))))))) 1407 1408(add-method initialize 1409 (make-method (list <class>) 1410 (named-lambda method:initialize (call-next-method class initargs) 1411 (call-next-method) 1412 (%set-class-direct-supers! 1413 class 1414 (let ([default (*default-object-class*)] 1415 [supers (getarg initargs :direct-supers)]) 1416 ;; check valid supers, and always have an object class 1417 (cond 1418 [(not default) supers] ; check disabled 1419 [(or (not supers) (null? supers)) (list default)] 1420 [(not (list? supers)) (error 'class "bad superclasses: ~e" supers)] 1421 [else (let ([c (find-if 1422 (lambda (c) 1423 (not (and (%class? c) (subclass? c default)))) 1424 supers)]) 1425 (if c 1426 (error 'class "cannot inherit from a ~a, ~e" 1427 (if (%class? c) "non-object class" "non-class") c) 1428 supers))]))) 1429 (%set-class-direct-slots! 1430 class 1431 (let ([autoinitargs (getarg initargs :autoinitargs)]) 1432 (map (lambda (s) 1433 (if (pair? s) 1434 (if (or (not autoinitargs) 1435 (getarg (cdr s) :initarg) 1436 (not (symbol? (car s)))) 1437 s 1438 (list* (car s) :initarg (string->symbol 1439 (string-append 1440 ":" (symbol->string (car s)))) 1441 (cdr s))) 1442 (list s))) 1443 (getarg initargs :direct-slots '())))) 1444 (%set-class-cpl! class (compute-cpl class)) 1445 (%set-class-slots! class (compute-slots class)) 1446 (%set-class-name! class (or (getarg initargs :name) '-anonymous-)) 1447 (let* ([nfields 0] 1448 [field-initializers '()] 1449 ;; allocator: give me an initializer function, get a slot number 1450 [allocator (lambda (init) 1451 (let ([f nfields]) 1452 (set! nfields (+ nfields 1)) 1453 (set! field-initializers 1454 (cons init field-initializers)) 1455 f))] 1456 [getters-n-setters (map (lambda (slot) 1457 (cons (car slot) 1458 (compute-getter-and-setter 1459 class slot allocator))) 1460 (%class-slots class))]) 1461 (%set-class-nfields! class nfields) 1462 (%set-class-field-initializers! class (reverse field-initializers)) 1463 (%set-class-getters-n-setters! class getters-n-setters)) 1464 (%set-class-initializers! 1465 class (reverse 1466 (mappend 1467 (lambda (c) 1468 (if (instance-of? c <class>) (%class-initializers c) '())) 1469 (cdr (%class-cpl class))))) 1470 (%set-class-valid-initargs! ; for sanity checks 1471 class (getarg initargs :valid-initargs 1472 (thunk (mappend (lambda (slot) 1473 (getargs (cdr slot) :initarg)) 1474 (%class-slots class)))))))) 1475 1476(add-method initialize 1477 (make-method (list <generic>) 1478 (named-lambda method:initialize (call-next-method generic initargs) 1479 (call-next-method) 1480 (%set-generic-methods! generic '()) 1481 (%set-generic-arity! generic (getarg initargs :arity #f)) 1482 (%set-generic-name! generic (or (getarg initargs :name) '-anonymous-)) 1483 (%set-generic-combination! generic (getarg initargs :combination)) 1484 (set-instance-proc! generic 1485 (lambda args 1486 (raise* make-exn:fail:contract 1487 "~s: no methods added yet" 1488 (%generic-name generic))))))) 1489 1490(add-method initialize 1491 (make-method (list <method>) 1492 (named-lambda method:initialize (call-next-method method initargs) 1493 (call-next-method) 1494 (%set-method-specializers! method 1495 (map (lambda (c) (%struct->class c)) 1496 (getarg initargs :specializers))) 1497 (%set-method-procedure! method (getarg initargs :procedure)) 1498 (%set-method-qualifier! method (or (getarg initargs :qualifier) 1499 :primary)) 1500 (%set-method-name! method (or (getarg initargs :name) 1501 '-anonymous-)) 1502 (set-instance-proc! method (compute-apply-method method))))) 1503 1504(add-method allocate-instance 1505 (make-method (list <class>) 1506 (named-lambda method:allocate-instance (call-next-method class initargs) 1507 (%allocate-instance class (length (%class-field-initializers class)))))) 1508 1509(add-method allocate-instance 1510 (make-method (list <entity-class>) 1511 (named-lambda method:allocate-instance (call-next-method class initargs) 1512 (%allocate-entity class (length (%class-field-initializers class)))))) 1513 1514(add-method compute-cpl 1515 (make-method (list <class>) 1516 (named-lambda method:compute-cpl (call-next-method class) 1517 (compute-std-cpl class %class-direct-supers)))) 1518 1519(add-method compute-slots 1520 (make-method (list <class>) 1521 (named-lambda method:compute-slots (call-next-method class) 1522 (let ([all-slots (map %class-direct-slots (%class-cpl class))] 1523 [final-slots #f]) 1524 (let collect ([to-process (apply append all-slots)] 1525 [result '()]) 1526 (if (null? to-process) 1527 (set! final-slots result) 1528 (let* ([name (caar to-process)] 1529 [others '()] 1530 [remaining-to-process 1531 (filter (lambda (o) 1532 (if (eq? (car o) name) 1533 (begin (set! others (cons (cdr o) others)) #f) 1534 #t)) 1535 to-process)]) 1536 (collect remaining-to-process 1537 (cons (cons name (apply append (reverse others))) 1538 result))))) 1539 ;; Sort the slots by order of appearance in cpl, makes them stay in the 1540 ;; same index, allowing optimizations for single-inheritance 1541 (let collect ([to-process (apply append (reverse all-slots))] 1542 [result '()]) 1543 (cond [(null? to-process) (reverse result)] 1544 [(assq (caar to-process) result) 1545 (collect (cdr to-process) result)] 1546 [else (collect (cdr to-process) 1547 (cons (assq (caar to-process) final-slots) 1548 result))])))))) 1549 1550(add-method compute-getter-and-setter 1551 (make-method (list <class>) 1552 (letrec ([nothing "nothing"] 1553 [l-getarg 1554 ;; apply getarg on a list of names until get a value 1555 (lambda (args initargs) 1556 ;; give priority to first initargs 1557 (if (null? initargs) 1558 nothing 1559 (let ([x (getarg args (car initargs) nothing)]) 1560 (if (eq? x nothing) (l-getarg args (cdr initargs)) x))))]) 1561 (named-lambda method:compute-getter-and-setter 1562 (call-next-method class slot allocator) 1563 (let ([initargs (getargs (cdr slot) :initarg)] 1564 [initializer (getarg (cdr slot) :initializer)] 1565 [initvalue (getarg (cdr slot) :initvalue ???)] 1566 [type (getarg (cdr slot) :type #f)] 1567 [allocation (getarg (cdr slot) :allocation :instance)] 1568 [lock (getarg (cdr slot) :lock #f)]) 1569 (define init 1570 (if initializer 1571 (if (eq? 0 (procedure-arity initializer)) 1572 (lambda args (initializer)) initializer) 1573 (lambda args initvalue))) 1574 (define (init-slot . args) 1575 (let ([result (l-getarg args initargs)]) 1576 (when (eq? result nothing) 1577 (set! result (apply init args))) 1578 (when (and type (not (eq? result ???)) 1579 (not (instance-of? result type))) 1580 (error 'class 1581 "bad initial value type for slot ~e in ~e (~e not a ~e)" 1582 (car slot) class result type)) 1583 result)) 1584 (when (and type (not (specializer? type))) 1585 (error 'class "bad type specifier for ~e: ~e" (car slot) type)) 1586 (case allocation 1587 [(:instance) 1588 (let* ([f (allocator init-slot)] 1589 [g+s (mcons (lambda (o) (%instance-ref o f)) 1590 (if (and type (not (eq? <top> type))) 1591 (lambda (o n) 1592 (if (instance-of? n type) 1593 (%instance-set! o f n) 1594 (raise* make-exn:fail:contract 1595 "slot-set!: wrong type for slot ~ 1596 `~.s' in ~e (~e not in ~e)" 1597 (car slot) class n type))) 1598 (lambda (o n) (%instance-set! o f n))))]) 1599 (when lock 1600 (make-setter-locked! g+s lock 1601 (lambda () 1602 (raise* make-exn:fail:contract 1603 "slot-set!: slot `~.s' in ~.s is locked" 1604 (car slot) (%class-name class))))) 1605 g+s)] 1606 [(:class) 1607 (unless (null? initargs) 1608 (let ([setter #f]) 1609 (%set-class-initializers! 1610 class 1611 (cons (lambda args 1612 (let ([result (l-getarg args initargs)]) 1613 ;; cache the setter 1614 (unless setter 1615 (set! setter 1616 (mcdr (cdr (assq (car slot) 1617 (%class-getters-n-setters 1618 class)))))) 1619 (unless (eq? result nothing) 1620 (setter #f result)))) 1621 (%class-initializers class))))) 1622 (if (and (assq (car slot) (%class-direct-slots class)) 1623 (getarg (cdr (assq (car slot) 1624 (%class-direct-slots class))) 1625 :allocation #f)) 1626 ;; the slot was declared as :class here 1627 (let* ([cell (init)] ; default value - no arguments 1628 [g+s (mcons (lambda (o) cell) 1629 (lambda (o n) 1630 (if (and type (not (instance-of? n type))) 1631 (raise* 1632 make-exn:fail:contract 1633 "slot-set!: wrong type for shared slot ~ 1634 `~.s' in ~e (~e not in ~e)" 1635 (car slot) class n type) 1636 (set! cell n))))]) 1637 (when lock 1638 (make-setter-locked! (car slot) g+s lock 1639 (lambda () 1640 (raise* make-exn:fail:contract 1641 "slot-set!: slot `~.s' in ~.s is locked" 1642 (car slot) (%class-name class))))) 1643 g+s) 1644 ;; the slot was inherited as :class - fetch its getters/setters 1645 (let loop ([cpl (cdr (%class-cpl class))]) 1646 (cond [(assq (car slot) (%class-getters-n-setters (car cpl))) 1647 => cdr] 1648 [else (loop (cdr cpl))])))] 1649 [else 1650 (error 'class 1651 "allocation for `~.s' must be :class or :instance, got ~e" 1652 (car slot) allocation)])))))) 1653 1654;;; Use the previous function when populating this generic. 1655(add-method compute-apply-method 1656 (make-method (list <method>) method:compute-apply-method)) 1657 1658(add-method no-next-method 1659 (make-method (list <generic> <method>) 1660 (lambda (call-next-method generic method . args) 1661 (raise* make-exn:fail:contract 1662 (concat "~s: no applicable next method to call" 1663 (case (%method-qualifier method) 1664 [(:before) " in a `before' method"] 1665 [(:after) " in an `after' method"] 1666 [else ""]) 1667 " with arguments: ~e") 1668 (%generic-name generic) args)))) 1669(add-method no-next-method 1670 (make-method (list (singleton #f) <method>) 1671 (lambda (call-next-method generic method . args) 1672 (raise* make-exn:fail:contract 1673 (concat "~s: no applicable next method in a direct method call" 1674 " with arguments: ~e") 1675 (%method-name method) args)))) 1676 1677(add-method no-applicable-method 1678 (make-method (list <generic>) 1679 (lambda (call-next-method generic . args) 1680 (raise* make-exn:fail:contract 1681 "~s: no applicable primary methods for arguments ~e, of types ~e" 1682 (%generic-name generic) args (map class-of args))))) 1683 1684;;; --------------------------------------------------------------------------- 1685;;; Customization variables 1686 1687;;>>... Swindle Customization Parameters 1688 1689;;>> *default-method-class* 1690;;>> *default-generic-class* 1691;;>> *default-class-class* 1692;;>> *default-entityclass-class* 1693;;> These parameters specify default classes for the many constructor 1694;;> macros in `clos'. 1695(define* *default-method-class* (make-parameter <method>)) 1696(define* *default-generic-class* (make-parameter <generic>)) 1697(define* *default-class-class* (make-parameter <class>)) 1698(define* *default-entityclass-class* (make-parameter <entity-class>)) 1699 1700;; an automatic superclass for all classes -- turned off for the builtins below 1701;;>> *default-object-class* 1702;;> This parameter contains a value which is automatically made a 1703;;> superclass for all classes. Defaults to `<object>'. 1704(define* *default-object-class* (make-parameter #f)) 1705 1706;;>> *make-safely* 1707;;> Setting this parameter to #t will make Swindle perform sanity checks 1708;;> on given initargs for creating an object. This will make things 1709;;> easier for debugging, but also slower. Defaults to `#f'. Note that 1710;;> the sanity checks are done in `initialize'. 1711;; This could be in `make', but `defclass' will call that with no slots to make 1712;; the object and then call `initialize' with all arguments to actually create 1713;; the class. 1714(define* *make-safely* (make-parameter #f)) 1715 1716(define (check-initargs class initargs) 1717 ;; sanity check - verify sensible keywords given 1718 (let ([valid-initargs (%class-valid-initargs class)]) 1719 (or (not valid-initargs) 1720 (let loop ([args initargs]) 1721 (cond [(null? args) #t] 1722 [(not (and (pair? args) (pair? (cdr args)))) 1723 (error 'make "error in initargs for ~e; arg list not balanced" 1724 class)] 1725 [(not (symbol? (car args))) 1726 (error 'make "error in initargs for ~e; ~e is not a keyword" 1727 class (car args))] 1728 [(not (memq (car args) valid-initargs)) 1729 (error 'make "error in initargs for ~e; unknown keyword: ~e" 1730 class (car args))] 1731 [else (loop (cddr args))]))))) 1732 1733;;; --------------------------------------------------------------------------- 1734;;; Make `make' a generic function 1735 1736;;>>... Creating Instances 1737 1738;;; Now everything works, both generic functions and classes, so we can turn on 1739;;; the real MAKE. 1740;;; ELI: This is turned into a generic function - do this carefully - first 1741;;; create the generic function and the method instances, then change make. 1742 1743;;>> (make class initargs ...) 1744;;> Create an instance of `class', which can be any Swindle class (except 1745;;> for some special top-level classes and built-in classes). 1746;;> 1747;;> See the `Object Initialization Protocol' below for a description of 1748;;> generic functions that are involved in creating a Swindle object. 1749(let ([m (make-method (list <class>) 1750 (named-lambda method:make (call-next-method class . initargs) 1751 (let ([instance (allocate-instance class initargs)]) 1752 (when (*make-safely*) (check-initargs class initargs)) 1753 (initialize instance initargs) 1754 instance)))] 1755 [g (make-generic-function 'make)]) 1756 (add-method g m) 1757 (set! make g)) 1758 1759;; The clean concept behind this is due to Joe Marshall. 1760 1761;;>> (rec-make (name class arg ...) ...) 1762;;> This is similar to: 1763;;> 1764;;> (letrec ([name (make class arg ...)] ...) 1765;;> (values name ...)) 1766;;> 1767;;> except that the names are first bound to allocated instances with no 1768;;> initargs, and then they are initialized with all these bindings. This 1769;;> is useful for situations where creating some instances needs other 1770;;> instances as values. One sample usage is the way `defclass' makes the 1771;;> class binding available for slot specifications like `:type'. Note 1772;;> that this is a special form, which invokes `allocate-instance' and 1773;;> `initialize' directly, so specializing `make' on some input will not 1774;;> change the way `rec-make' works. 1775(defsubst* (rec-make (name class arg ...) ...) 1776 (let ([name (allocate-instance class (list arg ...))] ...) 1777 (when (*make-safely*) (check-initargs class (list arg ...)) ...) 1778 (initialize name (list arg ...)) ... 1779 (values name ...))) 1780 1781;;; --------------------------------------------------------------------------- 1782;;; Make `add-method' a generic function 1783 1784;;; Use this to compute a name for the method. specs is a list of classes or 1785;;; class-names (in case of unnamed-methods in clos.rkt). 1786(define (compute-method-name specs generic-name) 1787 (define (spec-string spec) 1788 (cond [(%singleton? spec) (format "{~.s}" (singleton-value spec))] 1789 [(%class? spec) (symbol->string 1790 (%class-name (%struct->class spec)))] 1791 [else "???"])) 1792 (string->symbol 1793 (apply string-append 1794 (symbol->string generic-name) ":" 1795 (if (null? specs) 1796 '("()") 1797 (cons (spec-string (car specs)) 1798 (map (lambda (c) (string-append "," (spec-string c))) 1799 (cdr specs))))))) 1800 1801(let ([old-add-method add-method]) 1802 (set! add-method (make <generic> :name 'add-method :arity 2)) 1803 (old-add-method add-method 1804 (make-method (list <generic> <method>) 1805 (named-lambda method:add-method (call-next-method generic method) 1806 (let ([method-arity (method-arity method)] 1807 [generic-arity (%generic-arity generic)]) 1808 (cond 1809 [(not generic-arity) 1810 (%set-generic-arity! generic method-arity)] 1811 ;; note: equal? works on arity-at-least structs 1812 [(not (equal? generic-arity method-arity)) 1813 (error 'add-method 1814 "wrong arity for `~.s', expects ~a; given a method with ~a" 1815 (%generic-name generic) 1816 (if (integer? generic-arity) 1817 generic-arity 1818 (format "at-least-~a" 1819 (arity-at-least-value generic-arity))) 1820 (if (integer? method-arity) 1821 method-arity 1822 (format "at-least-~a" 1823 (arity-at-least-value method-arity))))]) 1824 ;; set a name for the method if none (when attached to a generic) 1825 (let ([n (%method-name method)]) 1826 (unless (and n (not (eq? n '-anonymous-))) 1827 (%set-method-name! 1828 method 1829 (let* ([psym (object-name (%method-procedure method))] 1830 [pstr (and psym (symbol->string psym))]) 1831 (if (or (not pstr) (regexp-match? #rx":[0-9]*:[0-9]*$" pstr)) 1832 (compute-method-name (%method-specializers method) 1833 (%generic-name generic)) 1834 psym))))) 1835 (old-add-method generic method)))))) 1836 1837;;; Optimized frequently used accessors: 1838;;; This is possible because of the ordering of the slots in compute-slots, 1839;;; works only for single-inheritance. Note that there is no type checking - 1840;;; it is unsafe, but makes things around 5-6 times faster! 1841(set! %class-direct-slots (%slot-getter <class> 'direct-slots)) 1842(set! %class-direct-supers (%slot-getter <class> 'direct-supers)) 1843(set! %class-slots (%slot-getter <class> 'slots)) 1844(set! %class-nfields (%slot-getter <class> 'nfields)) 1845(set! %class-field-initializers (%slot-getter <class> 'field-initializers)) 1846(set! %class-getters-n-setters (%slot-getter <class> 'getters-n-setters)) 1847(set! %class-cpl (%slot-getter <class> 'cpl)) 1848(set! %class-name (%slot-getter <class> 'name)) 1849(set! %class-initializers (%slot-getter <class> 'initializers)) 1850(set! %class-valid-initargs (%slot-getter <class> 'valid-initargs)) 1851(set! %generic-methods (%slot-getter <generic> 'methods)) 1852(set! %generic-arity (%slot-getter <generic> 'arity)) 1853(set! %generic-name (%slot-getter <generic> 'name)) 1854(set! %generic-combination (%slot-getter <generic> 'combination)) 1855(set! %method-specializers (%slot-getter <method> 'specializers)) 1856(set! %method-procedure (%slot-getter <method> 'procedure)) 1857(set! %method-qualifier (%slot-getter <method> 'qualifier)) 1858(set! %method-name (%slot-getter <method> 'name)) 1859(set! %set-class-direct-slots! (%slot-setter <class> 'direct-slots)) 1860(set! %set-class-direct-supers! (%slot-setter <class> 'direct-supers)) 1861(set! %set-class-slots! (%slot-setter <class> 'slots)) 1862(set! %set-class-nfields! (%slot-setter <class> 'nfields)) 1863(set! %set-class-field-initializers!(%slot-setter <class> 'field-initializers)) 1864(set! %set-class-getters-n-setters! (%slot-setter <class> 'getters-n-setters)) 1865(set! %set-class-cpl! (%slot-setter <class> 'cpl)) 1866(set! %set-class-name! (%slot-setter <class> 'name)) 1867(set! %set-class-initializers! (%slot-setter <class> 'initializers)) 1868(set! %set-class-valid-initargs! (%slot-setter <class> 'valid-initargs)) 1869(set! %set-generic-methods! (%slot-setter <generic> 'methods)) 1870(set! %set-generic-arity! (%slot-setter <generic> 'arity)) 1871(set! %set-generic-name! (%slot-setter <generic> 'name)) 1872(set! %set-generic-combination! (%slot-setter <generic> 'combination)) 1873(set! %set-method-specializers! (%slot-setter <method> 'specializers)) 1874(set! %set-method-procedure! (%slot-setter <method> 'procedure)) 1875(set! %set-method-qualifier! (%slot-setter <method> 'qualifier)) 1876(set! %set-method-name! (%slot-setter <method> 'name)) 1877;; Optimize these internal ones as well. 1878(set! %generic-app-cache (%slot-getter <generic> 'app-cache)) 1879(set! %generic-singletons-list (%slot-getter <generic> 'singletons-list)) 1880(set! %set-generic-app-cache! (%slot-setter <generic> 'app-cache)) 1881(set! %set-generic-singletons-list! (%slot-setter <generic> 'singletons-list)) 1882 1883;;; --------------------------------------------------------------------------- 1884;;; Built-in classes. 1885 1886;;>>... Built-in Classes 1887 1888;;>> <primitive-class> 1889;;> The class of all built-on classes. 1890(define* <primitive-class> 1891 (make <class> :direct-supers (list <class>) 1892 :direct-slots '() 1893 :name '<primitive-class> 1894 ;; needed so structs can turn to classes even if *make-safely* 1895 :valid-initargs #f)) 1896;; Normally, can't allocate these. 1897(add-method allocate-instance 1898 (make-method (list <primitive-class>) 1899 (named-lambda method:allocate-instance (call-next-method class initargs) 1900 (error 'allocate-instance "can't instantiate a primitive class ~e" 1901 class)))) 1902 1903;;>> <builtin> 1904;;> The superclass of all built-in classes. 1905(define* <builtin> 1906 (make <class> :direct-supers (list <top>) 1907 :direct-slots '() 1908 :name '<builtin>)) 1909(defsubst (defprimclass primclass) (defprimclass primclass <builtin>) 1910 (_ primclass supers ...) (define* primclass 1911 (make <primitive-class> 1912 :name 'primclass 1913 :direct-supers (list supers ...) 1914 :direct-slots '()))) 1915;;>> <sequence> 1916;;>> <mutable> 1917;;>> <immutable> 1918;;>> <pair> 1919;;>> <mutable-pair> 1920;;>> <mpair> 1921;;>> <immutable-pair> 1922;;>> <list> 1923;;>> <nonempty-list> 1924;;>> <null> 1925;;>> <vector> 1926;;>> <char> 1927;;>> <string-like> 1928;;>> <mutable-string-like> 1929;;>> <immutable-string-like> 1930;;>> <string> 1931;;>> <mutable-string> 1932;;>> <immutable-string> 1933;;>> <bytes> 1934;;>> <mutable-bytes> 1935;;>> <immutable-bytes> 1936;;>> <path> 1937;;>> <symbol> 1938;;>> <keyword> 1939;;>> <real-keyword> 1940;;>> <boolean> 1941;;>> <number> 1942;;>> <exact> 1943;;>> <inexact> 1944;;>> <complex> 1945;;>> <real> 1946;;>> <rational> 1947;;>> <integer> 1948;;>> <exact-complex> 1949;;>> <inexact-complex> 1950;;>> <exact-real> 1951;;>> <inexact-real> 1952;;>> <exact-rational> 1953;;>> <inexact-rational> 1954;;>> <exact-integer> 1955;;>> <inexact-integer> 1956;;>> <end-of-file> 1957;;>> <port> 1958;;>> <input-port> 1959;;>> <output-port> 1960;;>> <stream-port> 1961;;>> <input-stream-port> 1962;;>> <output-stream-port> 1963;;>> <void> 1964;;>> <box> 1965;;>> <weak-box> 1966;;>> <regexp> 1967;;>> <byte-regexp> 1968;;>> <parameter> 1969;;>> <promise> 1970;;>> <exn> 1971;;>> <exn:fail> 1972;;>> <exn:break> 1973;;>> <semaphore> 1974;;>> <hash-table> 1975;;>> <subprocess> 1976;;>> <thread> 1977;;>> <syntax> 1978;;>> <identifier-syntax> 1979;;>> <namespace> 1980;;>> <custodian> 1981;;>> <tcp-listener> 1982;;>> <security-guard> 1983;;>> <will-executor> 1984;;>> <struct-type> 1985;;>> <inspector> 1986;;>> <pseudo-random-generator> 1987;;>> <compiled-expression> 1988;;>> <unknown-primitive> 1989;;> These classes represent built-in objects. See the class hierarchy 1990;;> below for a complete description of the relations between these 1991;;> classes. 1992;;>> <struct> 1993;;>> <opaque-struct> 1994;;> These are also classes for built-in objects, but they are classes for 1995;;> Racket structs -- which can be used like Swindle classes since they 1996;;> will get converted to appropriate Swindle subclasses of `<struct>'. 1997;;> `<opaque-struct>' is a class of structs that are hidden -- see the 1998;;> documentation for `struct-info' and the `skipped?' result. Note that 1999;;> structs can be used as long as they can be inspected -- otherwise, we 2000;;> can't even know that they are structs with `struct?' (this means that 2001;;> <opaque-struct> can only appear in the cpl of a struct class that 2002;;> inherits from a struct which is not under the current inspector). 2003(defprimclass <sequence>) 2004(defprimclass <mutable>) 2005(defprimclass <immutable>) 2006(defprimclass <pair> <sequence>) 2007(defprimclass <mutable-pair> <pair> <mutable>) 2008(define* <mpair> <mutable-pair>) ; alias 2009(defprimclass <immutable-pair> <pair> <immutable>) 2010(defprimclass <list> <sequence>) 2011(defprimclass <nonempty-list> <pair> <list> <immutable>) 2012(defprimclass <null> <list>) 2013(defprimclass <vector> <sequence> <mutable>) 2014(defprimclass <char>) 2015(defprimclass <string-like> <sequence>) 2016(defprimclass <mutable-string-like> <string-like> <mutable>) 2017(defprimclass <immutable-string-like> <string-like> <immutable>) 2018(defprimclass <string> <string-like>) 2019(defprimclass <mutable-string> <string> <mutable-string-like>) 2020(defprimclass <immutable-string> <string> <immutable-string-like>) 2021(defprimclass <bytes> <string-like>) 2022(defprimclass <mutable-bytes> <bytes> <mutable-string-like>) 2023(defprimclass <immutable-bytes> <bytes> <immutable-string-like>) 2024(defprimclass <path> <immutable-string-like>) 2025(defprimclass <symbol>) 2026(defprimclass <keyword> <symbol>) 2027(defprimclass <real-keyword>) 2028(defprimclass <boolean>) 2029;; Have all possible number combinations in any case 2030(defprimclass <number>) 2031(defprimclass <exact> <number>) 2032(defprimclass <inexact> <number>) 2033(defprimclass <complex> <number>) 2034(defprimclass <real> <complex>) 2035(defprimclass <rational> <real>) 2036(defprimclass <integer> <rational>) 2037(defprimclass <exact-complex> <complex> <exact>) 2038(defprimclass <inexact-complex> <complex> <inexact>) 2039(defprimclass <exact-real> <real> <exact-complex>) 2040(defprimclass <inexact-real> <real> <inexact-complex>) 2041(defprimclass <exact-rational> <rational> <exact-real>) 2042(defprimclass <inexact-rational> <rational> <inexact-real>) 2043(defprimclass <exact-integer> <integer> <exact-rational>) 2044(defprimclass <inexact-integer> <integer> <inexact-rational>) 2045(defprimclass <end-of-file>) 2046(defprimclass <port>) 2047(defprimclass <input-port> <port>) 2048(defprimclass <output-port> <port>) 2049(defprimclass <stream-port> <port>) 2050;; Racket stuff 2051(defprimclass <input-stream-port> <input-port> <stream-port>) 2052(defprimclass <output-stream-port> <output-port> <stream-port>) 2053(defprimclass <void>) 2054(defprimclass <box> <mutable>) 2055(defprimclass <weak-box> <box>) 2056(defprimclass <regexp>) 2057(defprimclass <byte-regexp>) 2058(defprimclass <parameter>) 2059(defprimclass <promise>) 2060(defprimclass <exn>) 2061(defprimclass <exn:fail> <exn>) 2062(defprimclass <exn:break> <exn>) 2063;; make these classes used when we see exn structs 2064(let ([set-exn-class 2065 (lambda (class make-exn . xs) 2066 (hash-table-put! struct-to-class-table 2067 (let-values ([(e _) 2068 (struct-info 2069 (apply make-exn "foo" 2070 (current-continuation-marks) 2071 xs))]) 2072 e) 2073 class))]) 2074 (set-exn-class <exn> make-exn) 2075 (set-exn-class <exn:fail> make-exn:fail) 2076 (set-exn-class <exn:break> make-exn:break (let/ec e e))) 2077(defprimclass <semaphore>) 2078(defprimclass <hash-table>) 2079(defprimclass <subprocess>) 2080(defprimclass <thread>) 2081(defprimclass <syntax>) 2082(defprimclass <identifier-syntax> <syntax>) 2083(defprimclass <namespace>) 2084(defprimclass <custodian>) 2085(defprimclass <tcp-listener>) 2086(defprimclass <security-guard>) 2087(defprimclass <will-executor>) 2088(defprimclass <struct-type>) 2089(defprimclass <inspector>) 2090(defprimclass <pseudo-random-generator>) 2091(defprimclass <compiled-expression>) 2092(defprimclass <unknown-primitive>) 2093(defprimclass <struct>) 2094(defprimclass <opaque-struct> <struct>) 2095;;>> <procedure> 2096;;> The class of all Scheme procedures. 2097(define* <procedure> 2098 (make <procedure-class> :name '<procedure> 2099 :direct-supers (list <builtin> <function>) 2100 :direct-slots '())) 2101;;>> <primitive-procedure> 2102;;> The class of all primitive Racket procedures. 2103(define* <primitive-procedure> 2104 (make <procedure-class> 2105 :name '<primitive-procedure> 2106 :direct-supers (list <procedure>) 2107 :direct-slots '())) 2108 2109(*default-object-class* <object>) ; turn auto-superclass back on 2110 2111(set! class-of 2112 (lambda (x) 2113 ;; If all Schemes were IEEE compliant, the order of these wouldn't 2114 ;; matter? 2115 ;; ELI: changed the order so it fits better the expected results. 2116 (cond [(instance? x) (instance-class x)] 2117 [(struct? x) 2118 (let-values ([(type _) (struct-info x)]) 2119 (if type (struct-type->class type) <opaque-struct>))] 2120 [(procedure? x) (cond [(parameter? x) <parameter>] 2121 [(primitive? x) <primitive-procedure>] 2122 [else <procedure>])] 2123 [(string? x) (if (immutable? x) <immutable-string> <string>)] 2124 [(pair? x) (if (list? x) <nonempty-list> <immutable-pair>)] 2125 [(null? x) <null>] 2126 [(symbol? x) (if (keyword? x) <keyword> <symbol>)] 2127 [(number? x) 2128 (if (exact? x) 2129 (cond [(integer? x) <exact-integer>] 2130 [(rational? x) <exact-rational>] 2131 [(real? x) <exact-real>] 2132 [(complex? x) <exact-complex>] 2133 [else <exact>]) ; should not happen 2134 (cond [(integer? x) <inexact-integer>] 2135 [(rational? x) <inexact-rational>] 2136 [(real? x) <inexact-real>] 2137 [(complex? x) <inexact-complex>] 2138 [else <inexact>]))] ; should not happen 2139 [(boolean? x) <boolean>] 2140 [(char? x) <char>] 2141 [(bytes? x) (if (immutable? x) <immutable-bytes> <bytes>)] 2142 [(path? x) <path>] 2143 [(vector? x) <vector>] 2144 [(mpair? x) <mutable-pair>] 2145 [(eof-object? x) <end-of-file>] 2146 [(input-port? x) 2147 (if (file-stream-port? x) <input-stream-port> <input-port>)] 2148 [(output-port? x) 2149 (if (file-stream-port? x) <output-stream-port> <output-port>)] 2150 [(void? x) <void>] 2151 [(box? x) <box>] 2152 [(weak-box? x) <weak-box>] 2153 [(regexp? x) <regexp>] 2154 [(byte-regexp? x) <byte-regexp>] 2155 [(promise? x) <promise>] 2156 [(real-keyword? x) <real-keyword>] 2157 [(semaphore? x) <semaphore>] 2158 [(hash-table? x) <hash-table>] 2159 [(thread? x) <thread>] 2160 [(subprocess? x) <subprocess>] 2161 [(syntax? x) 2162 (if (identifier? x) <identifier-syntax> <syntax>)] 2163 [(namespace? x) <namespace>] 2164 [(custodian? x) <custodian>] 2165 [(tcp-listener? x) <tcp-listener>] 2166 [(security-guard? x) <security-guard>] 2167 [(will-executor? x) <will-executor>] 2168 [(struct-type? x) <struct-type>] 2169 [(inspector? x) <inspector>] 2170 [(pseudo-random-generator? x) <pseudo-random-generator>] 2171 [(compiled-expression? x) <compiled-expression>] 2172 [else <unknown-primitive>]))) 2173 2174;;; --------------------------------------------------------------------------- 2175;;; Some useful predicates. 2176 2177;;>> (builtin? x) 2178;;>> (function? x) 2179;;>> (generic? x) 2180;;>> (method? x) 2181;;> Predicates for instances of <builtin>, <function>, <generic>, and 2182;;> <method>. 2183(define* (builtin? x) (instance-of? x <builtin>)) 2184(define* (function? x) (instance-of? x <function>)) 2185(define* (generic? x) (instance-of? x <generic>)) 2186(define* (method? x) (instance-of? x <method>)) 2187 2188;;; --------------------------------------------------------------------------- 2189;;>>... Class Hierarchy 2190;;> 2191;;> In the following, every class's class is specified after a colon. Also, 2192;;> some classes appear in more than once place due to multiple-inheritance. 2193;;> 2194;;> <top> : <class> 2195;;> <object> : <class> 2196;;> <class> : <class> 2197;;> <procedure-class> : <class> 2198;;> <entity-class> : <class> 2199;;> <primitive-class> : <class> 2200;;> <generic> : <entity-class> 2201;;> <method> : <entity-class> 2202;;> <function> : <class> 2203;;> <generic> : <entity-class> 2204;;> <method> : <entity-class> 2205;;> <procedure> : <procedure-class> 2206;;> <primitive-procedure> : <procedure-class> 2207;;> <builtin> : <class> 2208;;> <sequence> : <primitive-class> 2209;;> <pair> : <primitive-class> 2210;;> <mutable-pair> : <primitive-class> 2211;;> <mpair> : <primitive-class> ; alias for <mutable-pair> 2212;;> <immutable-pair> : <primitive-class> 2213;;> <nonempty-list> : <primitive-class> 2214;;> <list> : <primitive-class> 2215;;> <nonempty-list> : <primitive-class> 2216;;> <null> : <primitive-class> 2217;;> <vector> : <primitive-class> 2218;;> <string-like> : <primitive-class> 2219;;> <string> : <primitive-class> 2220;;> <mutable-string> : <primitive-class> 2221;;> <immutable-string> : <primitive-class> 2222;;> <bytes> : <primitive-class> 2223;;> <mutable-bytes> : <primitive-class> 2224;;> <immutable-bytes> : <primitive-class> 2225;;> <path> : <primitive-class> 2226;;> <mutable> : <primitive-class> 2227;;> <mutable-pair> : <primitive-class> 2228;;> <mpair> : <primitive-class> ; alias for <mutable-pair> 2229;;> <mutable-string-like> : <primitive-class> 2230;;> <mutable-string> : <primitive-class> 2231;;> <mutable-bytes> : <primitive-class> 2232;;> <vector> 2233;;> <box> 2234;;> <immutable> : <primitive-class> 2235;;> <list> : <primitive-class> 2236;;> <pair> : <primitive-class> 2237;;> <immutable-string-like> : <primitive-class> 2238;;> <immutable-string> : <primitive-class> 2239;;> <immutable-bytes> : <primitive-class> 2240;;> <path> : <primitive-class> 2241;;> <char> : <primitive-class> 2242;;> <symbol> : <primitive-class> 2243;;> <keyword> : <primitive-class> 2244;;> <real-keyword> : <primitive-class> 2245;;> <boolean> : <primitive-class> 2246;;> <number> : <primitive-class> 2247;;> <complex> : <primitive-class> 2248;;> <exact-complex> : <primitive-class> 2249;;> <inexact-complex> : <primitive-class> 2250;;> <real> : <primitive-class> 2251;;> <exact-real> : <primitive-class> 2252;;> <inexact-real> : <primitive-class> 2253;;> <rational> : <primitive-class> 2254;;> <integer> : <primitive-class> 2255;;> <exact-rational> : <primitive-class> 2256;;> <inexact-rational> : <primitive-class> 2257;;> <exact-integer> : <primitive-class> 2258;;> <inexact-integer> : <primitive-class> 2259;;> <exact> : <primitive-class> 2260;;> <exact-complex> : <primitive-class> 2261;;> <exact-real> : <primitive-class> 2262;;> <exact-rational> : <primitive-class> 2263;;> <exact-integer> : <primitive-class> 2264;;> <inexact> : <primitive-class> 2265;;> <inexact-complex> : <primitive-class> 2266;;> <inexact-real> : <primitive-class> 2267;;> <inexact-rational> : <primitive-class> 2268;;> <inexact-integer> : <primitive-class> 2269;;> <end-of-file> : <primitive-class> 2270;;> <port> : <primitive-class> 2271;;> <input-port> : <primitive-class> 2272;;> <input-stream-port> : <primitive-class> 2273;;> <output-port> : <primitive-class> 2274;;> <output-stream-port> : <primitive-class> 2275;;> <stream-port> : <primitive-class> 2276;;> <input-stream-port> : <primitive-class> 2277;;> <output-stream-port> : <primitive-class> 2278;;> <void> : <primitive-class> 2279;;> <box> : <primitive-class> 2280;;> <weak-box> : <primitive-class> 2281;;> <regexp> : <primitive-class> 2282;;> <byte-regexp> : <primitive-class> 2283;;> <parameter> : <primitive-class> 2284;;> <promise> : <primitive-class> 2285;;> <exn> : <primitive-class> 2286;;> <exn:fail> : <primitive-class> 2287;;> <exn:break> : <primitive-class> 2288;;> <semaphore> : <primitive-class> 2289;;> <hash-table> : <primitive-class> 2290;;> <subprocess> : <primitive-class> 2291;;> <thread> : <primitive-class> 2292;;> <syntax> : <primitive-class> 2293;;> <identifier-syntax> : <primitive-class> 2294;;> <namespace> : <primitive-class> 2295;;> <custodian> : <primitive-class> 2296;;> <tcp-listener> : <primitive-class> 2297;;> <security-guard> : <primitive-class> 2298;;> <will-executor> : <primitive-class> 2299;;> <inspector> : <primitive-class> 2300;;> <pseudo-random-generator> : <primitive-class> 2301;;> <compiled-expression> : <primitive-class> 2302;;> <unknown-primitive> : <primitive-class> 2303;;> <procedure> : <procedure-class> 2304;;> <primitive-procedure> : <procedure-class> 2305;;> <struct> : <primitive-class> 2306;;> <opaque-struct> : <primitive-class> 2307;;> ... struct type classes ... 2308 2309;;>>... Object Initialization Protocol 2310;;> This is the initialization protocol. All of these are generic 2311;;> functions (unlike the original Tiny CLOS). See the individual 2312;;> descriptions above for more details. 2313;;> 2314;;> make 2315;;> allocate-instance 2316;;> initialize 2317;;> class initialization only: 2318;;> compute-cpl 2319;;> compute-slots 2320;;> compute-getter-and-setter 2321;;> method initialization only: 2322;;> compute-apply-method 2323;;> add-method 2324;;> compute-apply-generic 2325;;> compute-methods 2326;;> compute-method-more-specific? 2327;;> compute-apply-methods 2328