1; ************************************************************************* 2; Copyright (c) 1992 Xerox Corporation. 3; All Rights Reserved. 4; 5; Use, reproduction, and preparation of derivative works are permitted. 6; Any copy of this software or of any derivative work must include the 7; above copyright notice of Xerox Corporation, this paragraph and the 8; one after it. Any distribution of this software or derivative works 9; must comply with all applicable United States export control laws. 10; 11; This software is made available AS IS, and XEROX CORPORATION DISCLAIMS 12; ALL WARRANTIES, EXPRESS OR IMPLIED, INCLUDING WITHOUT LIMITATION THE 13; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 14; PURPOSE, AND NOTWITHSTANDING ANY OTHER PROVISION CONTAINED HEREIN, ANY 15; LIABILITY FOR DAMAGES RESULTING FROM THE SOFTWARE OR ITS USE IS 16; EXPRESSLY DISCLAIMED, WHETHER ARISING IN CONTRACT, TORT (INCLUDING 17; NEGLIGENCE) OR STRICT LIABILITY, EVEN IF XEROX CORPORATION IS ADVISED 18; OF THE POSSIBILITY OF SUCH DAMAGES. 19; ************************************************************************* 20; 21; port to R6RS -- 2007 Christian Sloma 22; 23 24(library (clos bootstrap generic-functions) 25 26 (export make 27 initialize 28 allocate-instance 29 compute-getter-and-setter 30 compute-precedence-list 31 compute-slots 32 add-method 33 compute-apply-generic 34 compute-methods 35 compute-method-more-specific? 36 compute-apply-methods 37 print-object) 38 39 (import (only (rnrs) define quote list lambda car cdr begin let cond eq? else error) 40 (only (clos bootstrap standard-classes) bootstrap-make <method> <class> <entity-class> <object> 41 <generic>) 42 (only (clos private allocation) set-instance-printer!) 43 (only (clos introspection) class-of) 44 (only (clos std-protocols make) class-make) 45 (only (clos std-protocols allocate-instance) class-allocate-instance entity-class-allocate-instance) 46 (only (clos std-protocols initialize) class-initialize generic-initialize method-initialize) 47 (only (clos std-protocols class-initialization) class-compute-precedence-list class-compute-slots class-compute-getter-and-setter) 48 (only (clos std-protocols add-method) generic-add-method) 49 (only (clos std-protocols generic-invocation) generic-compute-methods generic-compute-apply-generic generic-compute-method-more-specific? 50 generic-compute-apply-methods register-generic-invocation-generics!) 51 (only (clos std-protocols print-object) object-print-object)) 52 53 (define make 54 (bootstrap-make <generic> 55 'definition-name 'make)) 56 57 (define initialize 58 (bootstrap-make <generic> 59 'definition-name 'initialize)) 60 61 (define allocate-instance 62 (bootstrap-make <generic> 63 'definition-name 'allocate-instance)) 64 65 (define compute-getter-and-setter 66 (bootstrap-make <generic> 67 'definition-name 'compute-getter-and-setter)) 68 69 (define compute-precedence-list 70 (bootstrap-make <generic> 71 'definition-name 'compute-precedence-list)) 72 73 (define compute-slots 74 (bootstrap-make <generic> 75 'definition-name 'compute-slots)) 76 77 (define add-method 78 (bootstrap-make <generic> 79 'definition-name 'add-method)) 80 81 (define compute-apply-generic 82 (bootstrap-make <generic> 83 'definition-name 'compute-apply-generic)) 84 85 (define compute-methods 86 (bootstrap-make <generic> 87 'definition-name 'compute-methods)) 88 89 (define compute-method-more-specific? 90 (bootstrap-make <generic> 91 'definition-name 'compute-method-more-specific?)) 92 93 (define compute-apply-methods 94 (bootstrap-make <generic> 95 'definition-name 'compute-apply-methods)) 96 97 (define print-object 98 (bootstrap-make <generic> 99 'definition-name 'print-object)) 100 101 (define bootstrap-add-method 102 (begin 103 104 (register-generic-invocation-generics! 105 compute-apply-generic 106 compute-apply-methods 107 compute-methods 108 compute-method-more-specific?) 109 110 (lambda (entity method) 111 (let ((class (class-of entity))) 112 (cond 113 ((eq? class <generic>) 114 (generic-add-method entity method generic-compute-apply-generic)) 115 (else 116 (error 'bootstrap-add-method 117 "cannot add method to instance of class ~a" class))))))) 118 119 (bootstrap-add-method make 120 (bootstrap-make <method> 121 'specializers (list <class>) 122 'procedure (lambda (%generic %next-methods class . init-args) 123 (class-make class init-args 124 allocate-instance initialize)))) 125 126 (bootstrap-add-method allocate-instance 127 (bootstrap-make <method> 128 'specializers (list <class>) 129 'procedure (lambda (%generic %next-methods class) 130 (class-allocate-instance class)))) 131 132 (bootstrap-add-method allocate-instance 133 (bootstrap-make <method> 134 'specializers (list <entity-class>) 135 'procedure (lambda (%generic %next-methods entity-class) 136 (entity-class-allocate-instance entity-class)))) 137 138 (bootstrap-add-method initialize 139 (bootstrap-make <method> 140 'specializers (list <object>) 141 'procedure (lambda (%generic %next-methods object init-args) object))) 142 143 (bootstrap-add-method initialize 144 (bootstrap-make <method> 145 'specializers (list <class>) 146 'procedure (lambda (%generic %next-methods class-inst init-args) 147 ;; call-next-method, the hard way ... 148 ((car %next-methods) %generic (cdr %next-methods) class-inst init-args) 149 (class-initialize class-inst init-args 150 compute-precedence-list 151 compute-slots 152 compute-getter-and-setter)))) 153 154 (bootstrap-add-method initialize 155 (bootstrap-make <method> 156 'specializers (list <generic>) 157 'procedure (lambda (%generic %next-methods generic-inst init-args) 158 ;; call-next-method, the hard way ... 159 ((car %next-methods) %generic (cdr %next-methods) generic-inst init-args) 160 (generic-initialize generic-inst init-args)))) 161 162 (bootstrap-add-method initialize 163 (bootstrap-make <method> 164 'specializers (list <method>) 165 'procedure (lambda (%generic %next-methods method-inst init-args) 166 ;; call-next-method, the hard way ... 167 ((car %next-methods) %generic (cdr %next-methods) method-inst init-args) 168 (method-initialize method-inst init-args)))) 169 170 (bootstrap-add-method compute-precedence-list 171 (bootstrap-make <method> 172 'specializers (list <class>) 173 'procedure (lambda (%generic %next-methods class) 174 (class-compute-precedence-list class)))) 175 176 (bootstrap-add-method compute-slots 177 (bootstrap-make <method> 178 'specializers (list <class>) 179 'procedure (lambda (%generic %next-methods class) 180 (class-compute-slots class)))) 181 182 (bootstrap-add-method compute-getter-and-setter 183 (bootstrap-make <method> 184 'specializers (list <class>) 185 'procedure (lambda (%generic %next-methods class slot allocator) 186 (class-compute-getter-and-setter class slot allocator)))) 187 188 (bootstrap-add-method add-method 189 (bootstrap-make <method> 190 'specializers (list <generic>) 191 'procedure (lambda (%generic %next-methods entity method) 192 (generic-add-method entity method compute-apply-generic)))) 193 194 (bootstrap-add-method compute-apply-generic 195 (bootstrap-make <method> 196 'specializers (list <generic>) 197 'procedure (lambda (%generic %next-methods generic) 198 (generic-compute-apply-generic generic)))) 199 200 (bootstrap-add-method compute-methods 201 (bootstrap-make <method> 202 'specializers (list <generic>) 203 'procedure (lambda (%generic %next-methods generic args) 204 (generic-compute-methods generic args)))) 205 206 (bootstrap-add-method compute-method-more-specific? 207 (bootstrap-make <method> 208 'specializers (list <generic>) 209 'procedure (lambda (%generic %next-methods generic args) 210 (generic-compute-method-more-specific? generic args)))) 211 212 (bootstrap-add-method compute-apply-methods 213 (bootstrap-make <method> 214 'specializers (list <generic>) 215 'procedure (lambda (%generic %next-methods generic methods) 216 (generic-compute-apply-methods generic methods)))) 217 218 (bootstrap-add-method print-object 219 (bootstrap-make <method> 220 'specializers (list <object>) 221 'procedure (lambda (%generic %next-methods object port) 222 (object-print-object object port)))) 223 224 (set-instance-printer! print-object) 225 226 ) ;; library (clos bootstrap generic-functions) 227