1;;; Copyright 1984-2017 Cisco Systems, Inc. 2;;; 3;;; Licensed under the Apache License, Version 2.0 (the "License"); 4;;; you may not use this file except in compliance with the License. 5;;; You may obtain a copy of the License at 6;;; 7;;; http://www.apache.org/licenses/LICENSE-2.0 8;;; 9;;; Unless required by applicable law or agreed to in writing, software 10;;; distributed under the License is distributed on an "AS IS" BASIS, 11;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12;;; See the License for the specific language governing permissions and 13;;; limitations under the License. 14 15;;; cp0 is needed to optimize away run-time calls to record-constructor, 16;;; record-predicate, etc., in define-record-type for rcd. 17(eval-when (compile) (run-cp0 (default-run-cp0))) 18 19;;; TODO: 20;;; indirect flag for $record{,-ref,-set!} 21;;; gc support for indirect records 22;;; examples/foreign.ss support for (indirect) records 23;;; support for more datatypes 24;;; SWIG converter? 25;;; include size of tag in record size OR don't include tag in record offsets 26 27(let () 28 (define (rtd-parent x) ($object-ref 'scheme-object x (constant record-type-parent-disp))) 29 (define (rtd-size x) ($object-ref 'scheme-object x (constant record-type-size-disp))) 30 (define (rtd-pm x) ($object-ref 'scheme-object x (constant record-type-pm-disp))) 31 (define (rtd-mpm x) ($object-ref 'scheme-object x (constant record-type-mpm-disp))) 32 (define (rtd-name x) ($object-ref 'scheme-object x (constant record-type-name-disp))) 33 (define (rtd-flds x) ($object-ref 'scheme-object x (constant record-type-flds-disp))) 34 (define (rtd-flags x) ($object-ref 'scheme-object x (constant record-type-flags-disp))) 35 (define (rtd-uid x) ($object-ref 'scheme-object x (constant record-type-uid-disp))) 36 37 (define (child-flds rtd) 38 (let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)]) 39 (if prtd 40 (list-tail flds (length (rtd-flds prtd))) 41 flds))) 42 43 ; $record is hand-coded and is defined in prims.ss 44 45 (let ([addr? (constant-case ptr-bits 46 [(32) $integer-32?] 47 [(64) $integer-64?])]) 48 (set-who! foreign-alloc 49 (let ([malloc (foreign-procedure "(cs)malloc" (fixnum) uptr)]) 50 (lambda (n) 51 (unless (and (fixnum? n) (fx> n 0)) 52 ($oops who "~s is not a positive fixnum" n)) 53 (malloc n)))) 54 55 (set-who! foreign-free 56 (let ([free (foreign-procedure "(cs)free" (uptr) void)]) 57 (lambda (addr) 58 (unless (addr? addr) ($oops who "invalid foreign address ~s" addr)) 59 (free addr)))) 60 61 (let () 62 (define (check-args who ty addr offset) 63 (define-syntax check-ending-addr 64 (syntax-rules () 65 [(_ type bytes pred) 66 (unless (addr? (+ addr offset (fx- bytes 1))) 67 ($oops who "invalid effective address (+ ~s ~s) for ~s-byte type ~s" addr offset bytes 'type))])) 68 (unless (addr? addr) ($oops who "invalid address ~s" addr)) 69 (unless (fixnum? offset) ($oops who "~s is not a fixnum" offset)) 70 (unless (addr? (+ addr offset)) ($oops who "invalid effective address (+ ~s ~s)" addr offset)) 71 (record-datatype cases (filter-foreign-type ty) check-ending-addr 72 ($oops who "unrecognized type ~s" ty))) 73 (set-who! foreign-ref ; checks ty, addr, and offset, but inherently unsafe 74 (lambda (ty addr offset) 75 (define-syntax ref 76 (syntax-rules (scheme-object char wchar boolean integer-64 unsigned-64) 77 [(_ scheme-object bytes pred) ($oops who "cannot load scheme pointers from foreign memory")] 78 [(_ char bytes pred) (integer->char (#3%foreign-ref 'unsigned-8 addr offset))] 79 [(_ wchar bytes pred) 80 (constant-case wchar-bits 81 [(16) (integer->char (#3%foreign-ref 'unsigned-16 addr offset))] 82 [(32) (integer->char (#3%foreign-ref 'unsigned-32 addr offset))])] 83 [(_ boolean bytes pred) 84 (constant-case int-bits 85 [(32) (not (eq? (#3%foreign-ref 'integer-32 addr offset) 0))] 86 [(64) (not (eq? (#3%foreign-ref 'integer-64 addr offset) 0))])] 87 [(_ integer-64 bytes pred) 88 (< (constant ptr-bits) 64) 89 (constant-case native-endianness 90 [(big) 91 (logor (ash (#3%foreign-ref 'integer-32 addr offset) 32) 92 (#3%foreign-ref 'unsigned-32 (+ addr 4) offset))] 93 [(little) 94 (logor (ash (#3%foreign-ref 'integer-32 (+ addr 4) offset) 32) 95 (#3%foreign-ref 'unsigned-32 addr offset))])] 96 [(_ unsigned-64 bytes pred) 97 (< (constant ptr-bits) 64) 98 (constant-case native-endianness 99 [(big) 100 (logor (ash (#3%foreign-ref 'unsigned-32 addr offset) 32) 101 (#3%foreign-ref 'unsigned-32 (+ addr 4) offset))] 102 [(little) 103 (logor (ash (#3%foreign-ref 'unsigned-32 (+ addr 4) offset) 32) 104 (#3%foreign-ref 'unsigned-32 addr offset))])] 105 [(_ type bytes pred) (#3%foreign-ref 'type addr offset)])) 106 (check-args who ty addr offset) 107 (record-datatype cases (filter-foreign-type ty) ref 108 ($oops who "unrecognized type ~s" ty)))) 109 110 (set-who! foreign-set! ; checks ty, addr, offset, and v, but inherently unsafe 111 (lambda (ty addr offset v) 112 (define (value-err x t) ($oops who "invalid value ~s for foreign type ~s" x t)) 113 (define-syntax set 114 (syntax-rules (scheme-object char wchar boolean integer-40 unsigned-40 integer-48 unsigned-48 115 integer-56 unsigned-56 integer-64 unsigned-64) 116 [(_ scheme-object bytes pred) ($oops who "cannot store scheme pointers into foreign memory")] 117 [(_ char bytes pred) 118 (begin 119 (unless (pred v) (value-err v ty)) 120 (#3%foreign-set! 'unsigned-8 addr offset (char->integer v)))] 121 [(_ wchar bytes pred) 122 (begin 123 (unless (pred v) (value-err v ty)) 124 (constant-case wchar-bits 125 [(16) (#3%foreign-set! 'unsigned-16 addr offset (char->integer v))] 126 [(32) (#3%foreign-set! 'unsigned-32 addr offset (char->integer v))]))] 127 [(_ boolean bytes pred) 128 (constant-case int-bits 129 [(32) (#3%foreign-set! 'integer-32 addr offset (if v 1 0))] 130 [(64) (#3%foreign-set! 'integer-64 addr offset (if v 1 0))])] 131 [(_ integer-40 bytes pred) 132 (< (constant ptr-bits) 64) 133 (begin 134 (unless (pred v) (value-err v ty)) 135 (constant-case native-endianness 136 [(big) 137 (#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 8)) 138 (#3%foreign-set! 'unsigned-8 (+ addr 4) offset (logand v (- (expt 2 8) 1)))] 139 [(little) 140 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) 141 (#3%foreign-set! 'integer-8 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] 142 [(_ unsigned-40 bytes pred) 143 (< (constant ptr-bits) 64) 144 (begin 145 (unless (pred v) (value-err v ty)) 146 (constant-case native-endianness 147 [(big) 148 (#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 8)) 149 (#3%foreign-set! 'unsigned-8 (+ addr 4) offset (logand v (- (expt 2 8) 1)))] 150 [(little) 151 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) 152 (#3%foreign-set! 'unsigned-8 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] 153 [(_ integer-48 bytes pred) 154 (< (constant ptr-bits) 64) 155 (begin 156 (unless (pred v) (value-err v ty)) 157 (constant-case native-endianness 158 [(big) 159 (#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 16)) 160 (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand v (- (expt 2 16) 1)))] 161 [(little) 162 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) 163 (#3%foreign-set! 'integer-16 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] 164 [(_ unsigned-48 bytes pred) 165 (< (constant ptr-bits) 64) 166 (begin 167 (unless (pred v) (value-err v ty)) 168 (constant-case native-endianness 169 [(big) 170 (#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 16)) 171 (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand v (- (expt 2 16) 1)))] 172 [(little) 173 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) 174 (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))] 175 [(_ integer-56 bytes pred) 176 (< (constant ptr-bits) 64) 177 (begin 178 (unless (pred v) (value-err v ty)) 179 (constant-case native-endianness 180 [(big) 181 (#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 24)) 182 (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) 183 (#3%foreign-set! 'unsigned-8 (+ addr 6) offset (logand v (- (expt 2 8) 1)))] 184 [(little) 185 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) 186 (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) 187 (#3%foreign-set! 'integer-8 (+ addr 6) offset (bitwise-arithmetic-shift-right v 48))]))] 188 [(_ unsigned-56 bytes pred) 189 (< (constant ptr-bits) 64) 190 (begin 191 (unless (pred v) (value-err v ty)) 192 (constant-case native-endianness 193 [(big) 194 (#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 24)) 195 (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) 196 (#3%foreign-set! 'unsigned-8 (+ addr 6) offset (logand v (- (expt 2 8) 1)))] 197 [(little) 198 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1))) 199 (#3%foreign-set! 'unsigned-16 (+ addr 4) offset (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) 200 (#3%foreign-set! 'unsigned-8 (+ addr 6) offset (bitwise-arithmetic-shift-right v 48))]))] 201 [(_ integer-64 bytes pred) 202 (< (constant ptr-bits) 64) 203 (begin 204 (unless (pred v) (value-err v ty)) 205 (constant-case native-endianness 206 [(big) 207 (#3%foreign-set! 'integer-32 addr offset (ash v -32)) 208 (#3%foreign-set! 'unsigned-32 (+ addr 4) offset (logand v (- (expt 2 32) 1)))] 209 [(little) 210 (#3%foreign-set! 'integer-32 (+ addr 4) offset (ash v -32)) 211 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))]))] 212 [(_ unsigned-64 bytes pred) 213 (< (constant ptr-bits) 64) 214 (begin 215 (unless (pred v) (value-err v ty)) 216 (constant-case native-endianness 217 [(big) 218 (#3%foreign-set! 'unsigned-32 addr offset (ash v -32)) 219 (#3%foreign-set! 'unsigned-32 (+ addr 4) offset (logand v (- (expt 2 32) 1)))] 220 [(little) 221 (#3%foreign-set! 'unsigned-32 (+ addr 4) offset (ash v -32)) 222 (#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))]))] 223 [(_ type bytes pred) 224 (begin 225 (unless (pred v) (value-err v ty)) 226 (#3%foreign-set! 'type addr offset v))])) 227 (check-args who ty addr offset) 228 (record-datatype cases (filter-foreign-type ty) set 229 ($oops who "unrecognized type ~s" ty)))))) 230 231 (set-who! $filter-foreign-type 232 ; version that filters using host-machine information 233 (lambda (ty) 234 (filter-foreign-type ty))) 235 236 (set-who! $object-ref ; not safe, just handles non-constant types 237 (lambda (ty r offset) 238 (define-syntax ref 239 (syntax-rules (char wchar boolean integer-64 unsigned-64) 240 [(_ char bytes pred) (integer->char (#3%$object-ref 'unsigned-8 r offset))] 241 [(_ wchar bytes pred) 242 (constant-case wchar-bits 243 [(16) (integer->char (#3%$object-ref 'unsigned-16 r offset))] 244 [(32) (integer->char (#3%$object-ref 'unsigned-32 r offset))])] 245 [(_ boolean bytes pred) 246 (constant-case int-bits 247 [(32) (not (eq? (#3%$object-ref 'integer-32 r offset) 0))] 248 [(64) (not (eq? (#3%$object-ref 'integer-64 r offset) 0))])] 249 [(_ type bytes pred) (#3%$object-ref 'type r offset)])) 250 (record-datatype cases (filter-foreign-type ty) ref 251 ($oops who "unrecognized type ~s" ty)))) 252 253 (set-who! $swap-object-ref ; not safe, just handles non-constant types 254 (lambda (ty r offset) 255 (define-syntax ref 256 (syntax-rules (char wchar boolean integer-64 unsigned-64) 257 [(_ char bytes pred) (integer->char (#3%$swap-object-ref 'unsigned-8 r offset))] 258 [(_ wchar bytes pred) 259 (constant-case wchar-bits 260 [(16) (integer->char (#3%$swap-object-ref 'unsigned-16 r offset))] 261 [(32) (integer->char (#3%$swap-object-ref 'unsigned-32 r offset))])] 262 [(_ boolean bytes pred) 263 (constant-case int-bits 264 [(32) (not (eq? (#3%$swap-object-ref 'integer-32 r offset) 0))] 265 [(64) (not (eq? (#3%$swap-object-ref 'integer-64 r offset) 0))])] 266 [(_ type bytes pred) (#3%$swap-object-ref 'type r offset)])) 267 (record-datatype cases (filter-foreign-type ty) ref 268 ($oops who "unrecognized type ~s" ty)))) 269 270 (set-who! $object-set! ; not safe, just handles non-constant types 271 (lambda (ty r offset v) 272 (define-syntax set 273 (syntax-rules (char wchar boolean integer-40 unsigned-40 integer-48 unsigned-48 274 integer-56 unsigned-56 integer-64 unsigned-64) 275 [(_ char bytes pred) 276 (#3%$object-set! 'unsigned-8 r offset (char->integer v))] 277 [(_ wchar bytes pred) 278 (constant-case wchar-bits 279 [(16) (#3%$object-set! 'unsigned-16 r offset (char->integer v))] 280 [(32) (#3%$object-set! 'unsigned-32 r offset (char->integer v))])] 281 [(_ boolean bytes pred) 282 (constant-case int-bits 283 [(32) (#3%$object-set! 'integer-32 r offset (if v 1 0))] 284 [(64) (#3%$object-set! 'integer-64 r offset (if v 1 0))])] 285 [(_ integer-40 bytes pred) 286 (< (constant ptr-bits) 64) 287 (begin 288 (constant-case native-endianness 289 [(big) 290 (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 8)) 291 (#3%$object-set! 'unsigned-8 r (fx+ offset 4) (logand v (- (expt 2 8) 1)))] 292 [(little) 293 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 294 (#3%$object-set! 'integer-8 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] 295 [(_ unsigned-40 bytes pred) 296 (< (constant ptr-bits) 64) 297 (begin 298 (constant-case native-endianness 299 [(big) 300 (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 8)) 301 (#3%$object-set! 'unsigned-8 r (fx+ offset 4) (logand v (- (expt 2 8) 1)))] 302 [(little) 303 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 304 (#3%$object-set! 'unsigned-8 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] 305 [(_ integer-48 bytes pred) 306 (< (constant ptr-bits) 64) 307 (begin 308 (constant-case native-endianness 309 [(big) 310 (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 16)) 311 (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand v (- (expt 2 16) 1)))] 312 [(little) 313 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 314 (#3%$object-set! 'integer-16 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] 315 [(_ unsigned-48 bytes pred) 316 (< (constant ptr-bits) 64) 317 (begin 318 (constant-case native-endianness 319 [(big) 320 (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 16)) 321 (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand v (- (expt 2 16) 1)))] 322 [(little) 323 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 324 (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))] 325 [(_ integer-56 bytes pred) 326 (< (constant ptr-bits) 64) 327 (begin 328 (constant-case native-endianness 329 [(big) 330 (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 24)) 331 (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) 332 (#3%$object-set! 'unsigned-8 r (fx+ offset 6) (logand v (- (expt 2 8) 1)))] 333 [(little) 334 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 335 (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) 336 (#3%$object-set! 'integer-8 r (fx+ offset 6) (bitwise-arithmetic-shift-right v 48))]))] 337 [(_ unsigned-56 bytes pred) 338 (< (constant ptr-bits) 64) 339 (begin 340 (constant-case native-endianness 341 [(big) 342 (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 24)) 343 (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1))) 344 (#3%$object-set! 'unsigned-8 r (fx+ offset 6) (logand v (- (expt 2 8) 1)))] 345 [(little) 346 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 347 (#3%$object-set! 'unsigned-16 r (fx+ offset 4) (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1))) 348 (#3%$object-set! 'unsigned-8 r (fx+ offset 6) (bitwise-arithmetic-shift-right v 48))]))] 349 [(_ integer-64 bytes pred) 350 (< (constant ptr-bits) 64) 351 (constant-case native-endianness 352 [(big) 353 (#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 32)) 354 (#3%$object-set! 'unsigned-32 r (fx+ offset 4) (logand v (- (expt 2 32) 1)))] 355 [(little) 356 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 357 (#3%$object-set! 'integer-32 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))])] 358 [(_ unsigned-64 bytes pred) 359 (< (constant ptr-bits) 64) 360 (constant-case native-endianness 361 [(big) 362 (#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 32)) 363 (#3%$object-set! 'unsigned-32 r (fx+ offset 4) (logand v (- (expt 2 32) 1)))] 364 [(little) 365 (#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1))) 366 (#3%$object-set! 'unsigned-32 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))])] 367 [(_ type bytes pred) (#3%$object-set! 'type r offset v)])) 368 (record-datatype cases (filter-foreign-type ty) set 369 ($oops who "unrecognized type ~s" ty)))) 370 371 (set-who! foreign-sizeof 372 (lambda (ty) 373 (define-syntax size 374 (syntax-rules () 375 [(_ type bytes pred) bytes])) 376 (record-datatype cases (filter-foreign-type ty) size 377 ($oops who "invalid foreign type specifier ~s" ty)))) 378 379 (set-who! #(csv7: record-type-descriptor) 380 (lambda (r) 381 (unless (record? r) ($oops who "~s is not a record" r)) 382 (#3%record-rtd r))) 383 384 (set-who! record-rtd 385 (lambda (r) 386 (unless (record? r) ($oops who "~s is not a record" r)) 387 (#3%record-rtd r))) 388 389 (set! record-predicate 390 (lambda (rtd) 391 (unless (record-type-descriptor? rtd) 392 ($oops 'record-predicate "~s is not a record type descriptor" rtd)) 393 (if (record-type-sealed? rtd) 394 (rec predicate (lambda (x) ($sealed-record? x rtd))) 395 (rec predicate (lambda (x) (record? x rtd)))))) 396 397 (let ((base-rtd #!base-rtd)) 398 (define (make-flags uid sealed? opaque? parent) 399 (fxlogor 400 (if uid 0 (constant rtd-generative)) 401 (if (or opaque? (and parent (record-type-opaque? parent))) 402 (constant rtd-opaque) 403 0) 404 (if sealed? (constant rtd-sealed) 0))) 405 (define ($mrt who base-rtd name parent uid flags fields extras) 406 (include "layout.ss") 407 (when (and parent (record-type-sealed? parent)) 408 ($oops who "cannot extend sealed record type ~s" parent)) 409 (let ([parent-fields (if (not parent) '() (csv7:record-type-field-decls parent))] 410 [uid (or uid (gensym (symbol->string name)))]) 411 ; start base offset at rtd field 412 ; synchronize with syntax.ss and front.ss 413 (let-values ([(pm mpm flds size) 414 (compute-field-offsets who 415 (constant record-type-disp) 416 ; rtd must be immutable if we are ever to store records 417 ; in space pure 418 (cons `(immutable scheme-object ,uid) 419 (append parent-fields fields)))]) 420 (cond 421 [(and (not (fxlogtest flags (constant rtd-generative))) 422 (let ([x ($sgetprop uid '*rtd* #f)]) 423 (and (record-type-descriptor? x) x))) => 424 (lambda (rtd) 425 (define same-fields? 426 (lambda (flds1 flds2) 427 (define same-field? 428 (lambda (fld1 fld2) ; mutability checked separately 429 (and (eq? (fld-name fld1) (fld-name fld2)) 430 ; not using filter-foreign-type here. this makes the 431 ; comparison faster and prevents unwanted machine-dependent 432 ; matches like int and integer-32. it also prevents 433 ; ptr and scheme-object from matching---c'est la vie. 434 (eq? (fld-type fld1) (fld-type fld2)) 435 ; following is paranoid; overall size 436 ; check should suffice 437 #;(= (fld-byte fld1) (fld-byte fld2))))) 438 (and (= (length flds1) (length flds2)) 439 (andmap same-field? flds1 flds2)))) 440 ; following assumes extras match 441 (let () 442 (define (squawk what) ($oops who "incompatible record type ~s - ~a" name what)) 443 (unless (eq? ($record-type-descriptor rtd) base-rtd) (squawk "different base rtd")) 444 (unless (eq? (rtd-parent rtd) parent) (squawk "different parent")) 445 (unless (same-fields? (rtd-flds rtd) (cdr flds)) (squawk "different fields")) 446 (unless (= (rtd-mpm rtd) mpm) (squawk "different mutability")) 447 (unless (fx= (rtd-flags rtd) flags) (squawk "different flags")) 448 (unless (eq? (rtd-size rtd) size) (squawk "different size"))) 449 rtd)] 450 [else 451 (let ([rtd (apply #%$record base-rtd parent size pm mpm name 452 (cdr flds) flags uid #f extras)]) 453 (with-tc-mutex ($sputprop uid '*rtd* rtd)) 454 rtd)])))) 455 456 (set-who! $remake-rtd 457 (lambda (rtd compute-field-offsets) 458 (let ([key ($target-machine)] [uid (rtd-uid rtd)]) 459 (assert (not (eq? key (machine-type)))) 460 (or ($sgetprop uid key #f) 461 (let ([base-rtd ($record-type-descriptor rtd)] 462 [parent (rtd-parent rtd)] 463 [name (rtd-name rtd)] 464 [flags (rtd-flags rtd)] 465 [fields (csv7:record-type-field-decls rtd)]) 466 (let-values ([(pm mpm flds size) 467 (compute-field-offsets who 468 (constant record-type-disp) 469 (cons `(immutable scheme-object ,uid) fields))]) 470 (let ([rtd (apply #%$record base-rtd parent size pm mpm name (cdr flds) flags uid #f 471 (let* ([n (length (rtd-flds ($record-type-descriptor base-rtd)))] 472 [ls (list-tail (rtd-flds base-rtd) n)]) 473 (let f ([n n] [ls ls]) 474 (if (null? ls) 475 '() 476 (cons ((csv7:record-field-accessor base-rtd n) rtd) 477 (f (fx+ n 1) (cdr ls)))))))]) 478 (with-tc-mutex ($sputprop uid key rtd)) 479 rtd))))))) 480 481 (let () 482 (define (mrt base-rtd parent name fields sealed? opaque? extras) 483 (cond 484 [(gensym? name) 485 ($mrt 'make-record-type base-rtd 486 (string->symbol (symbol->string name)) parent name 487 (make-flags name sealed? opaque? parent) 488 fields extras)] 489 [(string? name) 490 ($mrt 'make-record-type base-rtd 491 (string->symbol name) parent #f 492 (make-flags #f sealed? opaque? parent) 493 fields extras)] 494 [else ($oops 'make-record-type "invalid record name ~s" name)])) 495 496 (set-who! make-record-type 497 (rec make-record-type 498 (case-lambda 499 [(name fields) 500 (unless (list? fields) 501 ($oops who "invalid field list ~s" fields)) 502 (mrt base-rtd #f name fields #f #f '())] 503 [(parent name fields) 504 (unless (or (not parent) (record-type-descriptor? parent)) 505 ($oops who "~s is not a record type descriptor" 506 parent)) 507 (unless (list? fields) 508 ($oops who "invalid field list ~s" fields)) 509 (mrt base-rtd parent name fields #f #f '())]))) 510 511 (set! $make-record-type 512 (lambda (base-rtd parent name fields sealed? opaque? . extras) 513 (unless (record-type-descriptor? base-rtd) 514 ($oops 'make-record-type "~s is not a record type descriptor" 515 base-rtd)) 516 (unless (or (not parent) (record-type-descriptor? parent)) 517 ($oops 'make-record-type "~s is not a record type descriptor" 518 parent)) 519 (unless (list? fields) 520 ($oops 'make-record-type "invalid field list ~s" fields)) 521 (mrt base-rtd parent name fields sealed? opaque? extras)))) 522 523 (let () 524 (define (mrtd base-rtd name parent uid sealed? opaque? fields who extras) 525 (unless (symbol? name) 526 ($oops who "invalid record name ~s" name)) 527 (unless (or (not parent) (record-type-descriptor? parent)) 528 ($oops who "invalid parent ~s" parent)) 529 (unless (or (not uid) (symbol? uid)) 530 ($oops who "invalid uid ~s" uid)) 531 (unless (vector? fields) 532 ($oops who "invalid field vector ~s" fields)) 533 ($mrt who base-rtd name parent uid 534 (make-flags uid sealed? opaque? parent) 535 (let ([n (vector-length fields)]) 536 (let f ([i 0]) 537 (if (fx= i n) 538 '() 539 (let ([x (vector-ref fields i)]) 540 (unless (and (pair? x) 541 (memq (car x) '(mutable immutable)) 542 (let ([x (cdr x)]) 543 (and (pair? x) 544 (symbol? (car x)) 545 (null? (cdr x))))) 546 ($oops who "invalid field specifier ~s" x)) 547 (cons x (f (fx+ i 1))))))) 548 extras)) 549 550 (set! $make-record-type-descriptor 551 (lambda (base-rtd name parent uid sealed? opaque? fields who . extras) 552 (unless (record-type-descriptor? base-rtd) 553 ($oops who "invalid base rtd ~s" base-rtd)) 554 (mrtd base-rtd name parent uid sealed? opaque? fields who extras))) 555 556 (set-who! make-record-type-descriptor 557 (lambda (name parent uid sealed? opaque? fields) 558 (mrtd base-rtd name parent uid sealed? opaque? fields who '())))) 559 560 (set! record-type-descriptor? 561 (lambda (x) 562 (#3%record? x base-rtd))) 563 564 (set! record? 565 (case-lambda 566 [(x) (#3%record? x)] 567 [(x rtd) 568 (unless (#3%record? rtd base-rtd) 569 ($oops 'record? "~s is not a record type descriptor" rtd)) 570 (#3%record? x rtd)]))) 571 572 (set! r6rs:record? 573 (rec record? 574 (lambda (x) 575 (#3%r6rs:record? x)))) 576 577 (set! record-type-parent 578 (lambda (rtd) 579 (unless (record-type-descriptor? rtd) 580 ($oops 'record-type-parent "~s is not a record type descriptor" rtd)) 581 (rtd-parent rtd))) 582 583 (set-who! #(csv7: record-type-name) 584 (lambda (rtd) 585 (unless (record-type-descriptor? rtd) 586 ($oops who "~s is not a record type descriptor" rtd)) 587 (symbol->string (rtd-name rtd)))) 588 589 (set-who! record-type-name 590 (lambda (rtd) 591 (unless (record-type-descriptor? rtd) 592 ($oops who "~s is not a record type descriptor" rtd)) 593 (rtd-name rtd))) 594 595 (set-who! #(csv7: record-type-symbol) 596 (lambda (rtd) 597 (unless (record-type-descriptor? rtd) 598 ($oops who "~s is not a record type descriptor" rtd)) 599 (rtd-uid rtd))) 600 601 (set-who! record-type-uid 602 (lambda (rtd) 603 (unless (record-type-descriptor? rtd) 604 ($oops who "~s is not a record type descriptor" rtd)) 605 (rtd-uid rtd))) 606 607 (set-who! #(csv7: record-type-field-names) 608 (lambda (rtd) 609 (unless (record-type-descriptor? rtd) 610 ($oops who "~s is not a record type descriptor" rtd)) 611 (map (lambda (x) (fld-name x)) (rtd-flds rtd)))) 612 613 (set-who! record-type-field-names 614 (lambda (rtd) 615 (unless (record-type-descriptor? rtd) 616 ($oops who "~s is not a record type descriptor" rtd)) 617 (list->vector (map (lambda (x) (fld-name x)) (child-flds rtd))))) 618 619 (set-who! #(csv7: record-type-field-decls) 620 (lambda (rtd) 621 (unless (record-type-descriptor? rtd) 622 ($oops who "~s is not a record type descriptor" rtd)) 623 (map (lambda (x) 624 `(,(if (fld-mutable? x) 'mutable 'immutable) 625 ,(fld-type x) 626 ,(fld-name x))) 627 (rtd-flds rtd)))) 628 629 (set! $record-type-field-offsets 630 (lambda (rtd) 631 (unless (record-type-descriptor? rtd) 632 ($oops '$record-type-field-offsets "~s is not a record type descriptor" rtd)) 633 (map (lambda (x) (fld-byte x)) (rtd-flds rtd)))) 634 635 (set! record-type-opaque? 636 (lambda (rtd) 637 (unless (record-type-descriptor? rtd) 638 ($oops 'record-type-opaque? "~s is not a record type descriptor" rtd)) 639 (#3%record-type-opaque? rtd))) 640 641 (set! record-type-sealed? 642 (lambda (rtd) 643 (unless (record-type-descriptor? rtd) 644 ($oops 'record-type-sealed? "~s is not a record type descriptor" rtd)) 645 (#3%record-type-sealed? rtd))) 646 647 (set! record-type-generative? 648 (lambda (rtd) 649 (unless (record-type-descriptor? rtd) 650 ($oops 'record-type-generative? "~s is not a record type descriptor" rtd)) 651 (#3%record-type-generative? rtd))) 652 653 (let () 654 (define (find-fld who rtd field-spec) 655 (unless (record-type-descriptor? rtd) 656 ($oops who "~s is not a record type descriptor" rtd)) 657 (cond 658 [(symbol? field-spec) 659 ; reverse order to check child's fields first 660 (let loop ((flds (reverse (rtd-flds rtd)))) 661 (when (null? flds) 662 ($oops who "unrecognized field name ~s for type ~s" 663 field-spec rtd)) 664 (let ((fld (car flds))) 665 (if (eq? field-spec (fld-name fld)) 666 fld 667 (loop (cdr flds)))))] 668 [(and (fixnum? field-spec) (fx>= field-spec 0)) 669 (let ((flds (rtd-flds rtd))) 670 (when (fx>= field-spec (length flds)) 671 ($oops who "invalid field ordinal ~s for type ~s" 672 field-spec rtd)) 673 (list-ref flds field-spec))] 674 [else ($oops who "invalid field specifier ~s" field-spec)])) 675 676 (define (r6rs:find-fld who rtd field-spec) 677 (unless (record-type-descriptor? rtd) 678 ($oops who "~s is not a record type descriptor" rtd)) 679 (cond 680 [(and (fixnum? field-spec) (fx>= field-spec 0)) 681 (let ((flds (child-flds rtd))) 682 (when (fx>= field-spec (length flds)) 683 ($oops who "invalid field index ~s for type ~s" 684 field-spec rtd)) 685 (list-ref flds field-spec))] 686 [else ($oops who "invalid field specifier ~s" field-spec)])) 687 688 (let () 689 (define (rfa who rtd fld) 690 (let ((record-err (lambda (x) ($record-oops #f x rtd))) 691 (offset (fld-byte fld)) 692 (ty (fld-type fld))) 693 (define-syntax ref 694 (syntax-rules () 695 [(_ type bytes pred) 696 (rec accessor 697 (lambda (x) 698 (unless (record? x rtd) (record-err x)) 699 (#3%$object-ref 'type x offset)))])) 700 (record-datatype cases (filter-foreign-type ty) ref 701 ($oops who "unrecognized type ~s" ty)))) 702 (set-who! #(csv7: record-field-accessor) 703 (lambda (rtd field-spec) 704 (rfa who rtd (find-fld who rtd field-spec)))) 705 (set-who! record-accessor 706 (lambda (rtd field-spec) 707 (rfa who rtd (r6rs:find-fld who rtd field-spec))))) 708 709 (let () 710 (define (rfm who rtd fld field-spec) 711 (if (fld-mutable? fld) 712 (let ((record-err (lambda (x t) ($record-oops #f x t))) 713 (value-err (lambda (x t) ($oops #f "invalid value ~s for foreign type ~s" x t))) 714 (offset (fld-byte fld)) 715 (ty (fld-type fld))) 716 (define-syntax set 717 (syntax-rules (scheme-object) 718 [(_ scheme-object bytes pred) 719 (rec mutator 720 (lambda (x v) 721 (unless (record? x rtd) (record-err x rtd)) 722 (#3%$object-set! 'scheme-object x offset v)))] 723 [(_ type bytes pred) 724 (rec mutator 725 (lambda (x v) 726 (unless (record? x rtd) (record-err x rtd)) 727 (unless (pred v) (value-err v ty)) 728 (#3%$object-set! 'type x offset v)))])) 729 (record-datatype cases (filter-foreign-type ty) set 730 ($oops who "unrecognized type ~s" ty))) 731 ($oops who "field ~s of ~s is immutable" 732 field-spec rtd))) 733 (set-who! #(csv7: record-field-mutator) 734 (lambda (rtd field-spec) 735 (rfm who rtd (find-fld who rtd field-spec) field-spec))) 736 (set-who! record-mutator 737 (lambda (rtd field-spec) 738 (rfm who rtd (r6rs:find-fld who rtd field-spec) field-spec)))) 739 740 (set-who! #(csv7: record-field-accessible?) 741 ; if this is ever made to do anything reasonable, revisit handlers in 742 ; cp0 and cp1in as well 743 (lambda (rtd field-spec) 744 (find-fld who rtd field-spec) 745 #t)) 746 747 (set-who! #(csv7: record-field-mutable?) 748 (lambda (rtd field-spec) 749 (fld-mutable? (find-fld who rtd field-spec)))) 750 751 (set-who! record-field-mutable? 752 (lambda (rtd field-spec) 753 (fld-mutable? (r6rs:find-fld who rtd field-spec))))) 754 755 (let () 756 ; if you update this, also update duplicate in cp0.ss 757 (define-record-type rcd 758 (fields (immutable rtd) (immutable prcd) (immutable protocol)) 759 (nongenerative #{rcd qh0yzh5qyrxmz2l-a}) 760 (sealed #t)) 761 762 (set! record-constructor-descriptor? 763 (lambda (x) 764 (rcd? x))) 765 766 (let () 767 (define (mrcd rtd prcd protocol who) 768 (unless (record-type-descriptor? rtd) 769 ($oops who "~s is not a record-type descriptor" rtd)) 770 (unless (or (not prcd) (rcd? prcd)) 771 ($oops who "invalid record constructor descriptor ~s" prcd)) 772 (unless (or (not protocol) (procedure? protocol)) 773 ($oops who "invalid protocol ~s" protocol)) 774 (unless (eqv? (rtd-pm rtd) -1) ; all pointers? 775 ($oops who "cannot create constructor descriptor for record type with non-scheme-object fields")) 776 (let ([prtd (record-type-parent rtd)]) 777 (when (and prcd (not prtd)) 778 ($oops who 779 "record constructor descriptor ~s specified for base record type ~s" 780 prcd rtd)) 781 (when (and prcd prtd (not (eq? (rcd-rtd prcd) prtd))) 782 ($oops who 783 "record constructor descriptor ~s is not for parent of record type ~s" 784 prcd rtd)) 785 (when (and (not protocol) prcd (rcd-protocol prcd)) 786 ($oops who "no protocol specified, but parent ~s has protocol" prcd)) 787 (make-rcd rtd prcd protocol))) 788 789 (set! $make-record-constructor-descriptor 790 (lambda (rtd prcd protocol who) 791 (mrcd rtd prcd protocol who))) 792 793 (set! make-record-constructor-descriptor 794 (lambda (rtd prcd protocol) 795 (mrcd rtd prcd protocol 'make-record-constructor-descriptor)))) 796 797 (let () 798 (define $rtd->record-constructor 799 (lambda (rtd) 800 (define type->pred 801 (lambda (ty) 802 (define-syntax ->pred 803 (syntax-rules () ((_ type bytes pred) 'pred))) 804 (record-datatype cases ty ->pred 805 ($oops 'record-constructor "unrecognized type ~s" ty)))) 806 (let* ((flds (rtd-flds rtd)) (nflds (length flds))) 807 (if (eqv? (rtd-pm rtd) -1) ; all pointers? 808 (let () 809 (define-syntax nlambda 810 (lambda (x) 811 (syntax-case x () 812 [(_ n) 813 (with-syntax (((t ...) 814 (generate-temporaries 815 (make-list 816 (datum n))))) 817 #'(rec constructor 818 (lambda (t ...) ($record rtd t ...))))]))) 819 (case nflds 820 [(0) (nlambda 0)] 821 [(1) (nlambda 1)] 822 [(2) (nlambda 2)] 823 [(3) (nlambda 3)] 824 [(4) (nlambda 4)] 825 [(5) (nlambda 5)] 826 [(6) (nlambda 6)] 827 [else (rec constructor 828 (lambda xr 829 (unless (fx= (length xr) nflds) 830 ($oops #f "incorrect number of arguments to ~s" constructor)) 831 (apply $record rtd xr)))])) 832 (let* ([args (make-record-call-args flds (rtd-size rtd) 833 (map (lambda (x) 0) flds))] 834 [nargs (length args)] 835 [setters (map (lambda (fld) 836 (let ([byte (fld-byte fld)] 837 [ty (fld-type fld)]) 838 (let ([msg (format "invalid value ~~s for foreign type ~s" ty)]) 839 (define-syntax init 840 (syntax-rules (scheme-object) 841 [(_ scheme-object bytes pred) 842 (lambda (x v) 843 (#3%$object-set! 'scheme-object x byte v))] 844 [(_ type bytes pred) 845 (lambda (x v) 846 (unless (pred v) ($oops #f msg v)) 847 (#3%$object-set! 'type x byte v))])) 848 (record-datatype cases (filter-foreign-type ty) init 849 ($oops 'record-constructor "unrecognized type ~s" ty))))) 850 flds)]) 851 (define-syntax nmlambda 852 (lambda (x) 853 (syntax-case x () 854 [(_ n m) 855 (with-syntax ([(t ...) (generate-temporaries 856 (make-list (datum n)))] 857 [(z ...) (make-list (datum m) 0)]) 858 (with-syntax ([(t! ...) (generate-temporaries #'(t ...))]) 859 #'(apply 860 (lambda (t! ...) 861 (rec constructor 862 (lambda (t ...) 863 (let ([x ($record rtd z ...)]) 864 (t! x t) ... 865 x)))) 866 setters)))]))) 867 (or (constant-case ptr-bits 868 [(64) 869 (case nflds 870 [(0) (and (= nargs 0) (nmlambda 0 0))] 871 [(1) (and (= nargs 1) (nmlambda 1 1))] 872 [(2) (case nargs 873 [(1) (nmlambda 2 1)] 874 [(2) (nmlambda 2 2)] 875 [else #f])] 876 [(3) (case nargs 877 [(1) (nmlambda 3 1)] 878 [(2) (nmlambda 3 2)] 879 [(3) (nmlambda 3 3)] 880 [else #f])] 881 [(4) (case nargs 882 [(1) (nmlambda 4 1)] 883 [(2) (nmlambda 4 2)] 884 [(3) (nmlambda 4 3)] 885 [(4) (nmlambda 4 4)] 886 [else #f])] 887 [else #f])] 888 [(32) 889 (case nflds 890 [(0) (nmlambda 0 0)] 891 [(1) (case nargs 892 [(1) (nmlambda 1 1)] 893 [(2) (nmlambda 1 2)] 894 [(3) (nmlambda 1 3)] 895 [else #f])] 896 [(2) (case nargs 897 [(1) (nmlambda 2 1)] 898 [(2) (nmlambda 2 2)] 899 [(3) (nmlambda 2 3)] 900 [(4) (nmlambda 2 4)] 901 [(5) (nmlambda 2 5)] 902 [else #f])] 903 [(3) (case nargs 904 [(1) (nmlambda 3 1)] 905 [(2) (nmlambda 3 2)] 906 [(3) (nmlambda 3 3)] 907 [(4) (nmlambda 3 4)] 908 [(5) (nmlambda 3 5)] 909 [(6) (nmlambda 3 6)] 910 [(7) (nmlambda 3 7)] 911 [else #f])] 912 [(4) (case nargs 913 [(1) (nmlambda 4 1)] 914 [(2) (nmlambda 4 2)] 915 [(3) (nmlambda 4 3)] 916 [(4) (nmlambda 4 4)] 917 [(5) (nmlambda 4 5)] 918 [(6) (nmlambda 4 6)] 919 [(7) (nmlambda 4 7)] 920 [(8) (nmlambda 4 8)] 921 [(9) (nmlambda 4 9)] 922 [else #f])] 923 [else #f])]) 924 (rec constructor 925 (lambda xr 926 (unless (fx= (length xr) nflds) 927 ($oops #f "incorrect number of arguments to ~s" constructor)) 928 (let ([x (apply $record rtd args)]) 929 (for-each (lambda (setter v) (setter x v)) setters xr) 930 x))))))))) 931 932 (define ($rcd->record-constructor rcd) 933 (let ([rtd (rcd-rtd rcd)] [protocol (rcd-protocol rcd)]) 934 (let ([rc ($rtd->record-constructor rtd)]) 935 (if protocol 936 (protocol 937 (cond 938 [(rtd-parent rtd) => 939 (lambda (prtd) 940 (lambda pp-args 941 (lambda vals 942 (let f ([prcd (rcd-prcd rcd)] [prtd prtd] [pp-args pp-args] [vals vals]) 943 (#2%apply 944 (cond 945 [(and prcd (rcd-protocol prcd)) => 946 (lambda (protocol) 947 (protocol 948 (cond 949 [(rtd-parent prtd) => 950 (lambda (prtd) 951 (lambda pp-args 952 (lambda new-vals 953 (f (rcd-prcd prcd) prtd pp-args 954 (append new-vals vals)))))] 955 [else 956 (lambda new-vals 957 (apply rc (append new-vals vals)))])))] 958 [else 959 (lambda new-vals 960 (apply rc (append new-vals vals)))]) 961 pp-args)))))] 962 [else rc])) 963 rc)))) 964 965 (set! record-constructor 966 (lambda (x) 967 (cond 968 [(record-type-descriptor? x) ($rtd->record-constructor x)] 969 [(record-constructor-descriptor? x) ($rcd->record-constructor x)] 970 [else ($oops 'record-constructor "~s is not a record type or constructor descriptor" x)]))) 971 972 (set-who! #(r6rs: record-constructor) 973 (lambda (rcd) 974 (unless (rcd? rcd) 975 ($oops who "~s is not a record constructor descriptor" rcd)) 976 ($rcd->record-constructor rcd))))) 977) 978