978 lines
47 KiB
Scheme
978 lines
47 KiB
Scheme
|
;;; Copyright 1984-2017 Cisco Systems, Inc.
|
||
|
|
;;;
|
||
|
|
;;; Licensed under the Apache License, Version 2.0 (the "License");
|
||
|
|
;;; you may not use this file except in compliance with the License.
|
||
|
|
;;; You may obtain a copy of the License at
|
||
|
|
;;;
|
||
|
|
;;; http://www.apache.org/licenses/LICENSE-2.0
|
||
|
|
;;;
|
||
|
|
;;; Unless required by applicable law or agreed to in writing, software
|
||
|
|
;;; distributed under the License is distributed on an "AS IS" BASIS,
|
||
|
|
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
|
||
|
|
;;; See the License for the specific language governing permissions and
|
||
|
|
;;; limitations under the License.
|
||
|
|
|
||
|
|
;;; cp0 is needed to optimize away run-time calls to record-constructor,
|
||
|
|
;;; record-predicate, etc., in define-record-type for rcd.
|
||
|
|
(eval-when (compile) (run-cp0 (default-run-cp0)))
|
||
|
|
|
||
|
|
;;; TODO:
|
||
|
|
;;; indirect flag for $record{,-ref,-set!}
|
||
|
|
;;; gc support for indirect records
|
||
|
|
;;; examples/foreign.ss support for (indirect) records
|
||
|
|
;;; support for more datatypes
|
||
|
|
;;; SWIG converter?
|
||
|
|
;;; include size of tag in record size OR don't include tag in record offsets
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (rtd-parent x) ($object-ref 'scheme-object x (constant record-type-parent-disp)))
|
||
|
|
(define (rtd-size x) ($object-ref 'scheme-object x (constant record-type-size-disp)))
|
||
|
|
(define (rtd-pm x) ($object-ref 'scheme-object x (constant record-type-pm-disp)))
|
||
|
|
(define (rtd-mpm x) ($object-ref 'scheme-object x (constant record-type-mpm-disp)))
|
||
|
|
(define (rtd-name x) ($object-ref 'scheme-object x (constant record-type-name-disp)))
|
||
|
|
(define (rtd-flds x) ($object-ref 'scheme-object x (constant record-type-flds-disp)))
|
||
|
|
(define (rtd-flags x) ($object-ref 'scheme-object x (constant record-type-flags-disp)))
|
||
|
|
(define (rtd-uid x) ($object-ref 'scheme-object x (constant record-type-uid-disp)))
|
||
|
|
|
||
|
|
(define (child-flds rtd)
|
||
|
|
(let ([flds (rtd-flds rtd)] [prtd (rtd-parent rtd)])
|
||
|
|
(if prtd
|
||
|
|
(list-tail flds (length (rtd-flds prtd)))
|
||
|
|
flds)))
|
||
|
|
|
||
|
|
; $record is hand-coded and is defined in prims.ss
|
||
|
|
|
||
|
|
(let ([addr? (constant-case ptr-bits
|
||
|
|
[(32) $integer-32?]
|
||
|
|
[(64) $integer-64?])])
|
||
|
|
(set-who! foreign-alloc
|
||
|
|
(let ([malloc (foreign-procedure "(cs)malloc" (fixnum) uptr)])
|
||
|
|
(lambda (n)
|
||
|
|
(unless (and (fixnum? n) (fx> n 0))
|
||
|
|
($oops who "~s is not a positive fixnum" n))
|
||
|
|
(malloc n))))
|
||
|
|
|
||
|
|
(set-who! foreign-free
|
||
|
|
(let ([free (foreign-procedure "(cs)free" (uptr) void)])
|
||
|
|
(lambda (addr)
|
||
|
|
(unless (addr? addr) ($oops who "invalid foreign address ~s" addr))
|
||
|
|
(free addr))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (check-args who ty addr offset)
|
||
|
|
(define-syntax check-ending-addr
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ type bytes pred)
|
||
|
|
(unless (addr? (+ addr offset (fx- bytes 1)))
|
||
|
|
($oops who "invalid effective address (+ ~s ~s) for ~s-byte type ~s" addr offset bytes 'type))]))
|
||
|
|
(unless (addr? addr) ($oops who "invalid address ~s" addr))
|
||
|
|
(unless (fixnum? offset) ($oops who "~s is not a fixnum" offset))
|
||
|
|
(unless (addr? (+ addr offset)) ($oops who "invalid effective address (+ ~s ~s)" addr offset))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) check-ending-addr
|
||
|
|
($oops who "unrecognized type ~s" ty)))
|
||
|
|
(set-who! foreign-ref ; checks ty, addr, and offset, but inherently unsafe
|
||
|
|
(lambda (ty addr offset)
|
||
|
|
(define-syntax ref
|
||
|
|
(syntax-rules (scheme-object char wchar boolean integer-64 unsigned-64)
|
||
|
|
[(_ scheme-object bytes pred) ($oops who "cannot load scheme pointers from foreign memory")]
|
||
|
|
[(_ char bytes pred) (integer->char (#3%foreign-ref 'unsigned-8 addr offset))]
|
||
|
|
[(_ wchar bytes pred)
|
||
|
|
(constant-case wchar-bits
|
||
|
|
[(16) (integer->char (#3%foreign-ref 'unsigned-16 addr offset))]
|
||
|
|
[(32) (integer->char (#3%foreign-ref 'unsigned-32 addr offset))])]
|
||
|
|
[(_ boolean bytes pred)
|
||
|
|
(constant-case int-bits
|
||
|
|
[(32) (not (eq? (#3%foreign-ref 'integer-32 addr offset) 0))]
|
||
|
|
[(64) (not (eq? (#3%foreign-ref 'integer-64 addr offset) 0))])]
|
||
|
|
[(_ integer-64 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(logor (ash (#3%foreign-ref 'integer-32 addr offset) 32)
|
||
|
|
(#3%foreign-ref 'unsigned-32 (+ addr 4) offset))]
|
||
|
|
[(little)
|
||
|
|
(logor (ash (#3%foreign-ref 'integer-32 (+ addr 4) offset) 32)
|
||
|
|
(#3%foreign-ref 'unsigned-32 addr offset))])]
|
||
|
|
[(_ unsigned-64 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(logor (ash (#3%foreign-ref 'unsigned-32 addr offset) 32)
|
||
|
|
(#3%foreign-ref 'unsigned-32 (+ addr 4) offset))]
|
||
|
|
[(little)
|
||
|
|
(logor (ash (#3%foreign-ref 'unsigned-32 (+ addr 4) offset) 32)
|
||
|
|
(#3%foreign-ref 'unsigned-32 addr offset))])]
|
||
|
|
[(_ type bytes pred) (#3%foreign-ref 'type addr offset)]))
|
||
|
|
(check-args who ty addr offset)
|
||
|
|
(record-datatype cases (filter-foreign-type ty) ref
|
||
|
|
($oops who "unrecognized type ~s" ty))))
|
||
|
|
|
||
|
|
(set-who! foreign-set! ; checks ty, addr, offset, and v, but inherently unsafe
|
||
|
|
(lambda (ty addr offset v)
|
||
|
|
(define (value-err x t) ($oops who "invalid value ~s for foreign type ~s" x t))
|
||
|
|
(define-syntax set
|
||
|
|
(syntax-rules (scheme-object char wchar boolean integer-40 unsigned-40 integer-48 unsigned-48
|
||
|
|
integer-56 unsigned-56 integer-64 unsigned-64)
|
||
|
|
[(_ scheme-object bytes pred) ($oops who "cannot store scheme pointers into foreign memory")]
|
||
|
|
[(_ char bytes pred)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(#3%foreign-set! 'unsigned-8 addr offset (char->integer v)))]
|
||
|
|
[(_ wchar bytes pred)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case wchar-bits
|
||
|
|
[(16) (#3%foreign-set! 'unsigned-16 addr offset (char->integer v))]
|
||
|
|
[(32) (#3%foreign-set! 'unsigned-32 addr offset (char->integer v))]))]
|
||
|
|
[(_ boolean bytes pred)
|
||
|
|
(constant-case int-bits
|
||
|
|
[(32) (#3%foreign-set! 'integer-32 addr offset (if v 1 0))]
|
||
|
|
[(64) (#3%foreign-set! 'integer-64 addr offset (if v 1 0))])]
|
||
|
|
[(_ integer-40 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 8))
|
||
|
|
(#3%foreign-set! 'unsigned-8 (+ addr 4) offset (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%foreign-set! 'integer-8 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ unsigned-40 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 8))
|
||
|
|
(#3%foreign-set! 'unsigned-8 (+ addr 4) offset (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%foreign-set! 'unsigned-8 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ integer-48 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 16))
|
||
|
|
(#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand v (- (expt 2 16) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%foreign-set! 'integer-16 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ unsigned-48 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 16))
|
||
|
|
(#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand v (- (expt 2 16) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%foreign-set! 'unsigned-16 (+ addr 4) offset (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ integer-56 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'integer-32 addr offset (bitwise-arithmetic-shift-right v 24))
|
||
|
|
(#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1)))
|
||
|
|
(#3%foreign-set! 'unsigned-8 (+ addr 6) offset (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%foreign-set! 'unsigned-16 (+ addr 4) offset (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1)))
|
||
|
|
(#3%foreign-set! 'integer-8 (+ addr 6) offset (bitwise-arithmetic-shift-right v 48))]))]
|
||
|
|
[(_ unsigned-56 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (bitwise-arithmetic-shift-right v 24))
|
||
|
|
(#3%foreign-set! 'unsigned-16 (+ addr 4) offset (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1)))
|
||
|
|
(#3%foreign-set! 'unsigned-8 (+ addr 6) offset (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%foreign-set! 'unsigned-16 (+ addr 4) offset (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1)))
|
||
|
|
(#3%foreign-set! 'unsigned-8 (+ addr 6) offset (bitwise-arithmetic-shift-right v 48))]))]
|
||
|
|
[(_ integer-64 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'integer-32 addr offset (ash v -32))
|
||
|
|
(#3%foreign-set! 'unsigned-32 (+ addr 4) offset (logand v (- (expt 2 32) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'integer-32 (+ addr 4) offset (ash v -32))
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))]))]
|
||
|
|
[(_ unsigned-64 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (ash v -32))
|
||
|
|
(#3%foreign-set! 'unsigned-32 (+ addr 4) offset (logand v (- (expt 2 32) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%foreign-set! 'unsigned-32 (+ addr 4) offset (ash v -32))
|
||
|
|
(#3%foreign-set! 'unsigned-32 addr offset (logand v (- (expt 2 32) 1)))]))]
|
||
|
|
[(_ type bytes pred)
|
||
|
|
(begin
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(#3%foreign-set! 'type addr offset v))]))
|
||
|
|
(check-args who ty addr offset)
|
||
|
|
(record-datatype cases (filter-foreign-type ty) set
|
||
|
|
($oops who "unrecognized type ~s" ty))))))
|
||
|
|
|
||
|
|
(set-who! $filter-foreign-type
|
||
|
|
; version that filters using host-machine information
|
||
|
|
(lambda (ty)
|
||
|
|
(filter-foreign-type ty)))
|
||
|
|
|
||
|
|
(set-who! $object-ref ; not safe, just handles non-constant types
|
||
|
|
(lambda (ty r offset)
|
||
|
|
(define-syntax ref
|
||
|
|
(syntax-rules (char wchar boolean integer-64 unsigned-64)
|
||
|
|
[(_ char bytes pred) (integer->char (#3%$object-ref 'unsigned-8 r offset))]
|
||
|
|
[(_ wchar bytes pred)
|
||
|
|
(constant-case wchar-bits
|
||
|
|
[(16) (integer->char (#3%$object-ref 'unsigned-16 r offset))]
|
||
|
|
[(32) (integer->char (#3%$object-ref 'unsigned-32 r offset))])]
|
||
|
|
[(_ boolean bytes pred)
|
||
|
|
(constant-case int-bits
|
||
|
|
[(32) (not (eq? (#3%$object-ref 'integer-32 r offset) 0))]
|
||
|
|
[(64) (not (eq? (#3%$object-ref 'integer-64 r offset) 0))])]
|
||
|
|
[(_ type bytes pred) (#3%$object-ref 'type r offset)]))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) ref
|
||
|
|
($oops who "unrecognized type ~s" ty))))
|
||
|
|
|
||
|
|
(set-who! $swap-object-ref ; not safe, just handles non-constant types
|
||
|
|
(lambda (ty r offset)
|
||
|
|
(define-syntax ref
|
||
|
|
(syntax-rules (char wchar boolean integer-64 unsigned-64)
|
||
|
|
[(_ char bytes pred) (integer->char (#3%$swap-object-ref 'unsigned-8 r offset))]
|
||
|
|
[(_ wchar bytes pred)
|
||
|
|
(constant-case wchar-bits
|
||
|
|
[(16) (integer->char (#3%$swap-object-ref 'unsigned-16 r offset))]
|
||
|
|
[(32) (integer->char (#3%$swap-object-ref 'unsigned-32 r offset))])]
|
||
|
|
[(_ boolean bytes pred)
|
||
|
|
(constant-case int-bits
|
||
|
|
[(32) (not (eq? (#3%$swap-object-ref 'integer-32 r offset) 0))]
|
||
|
|
[(64) (not (eq? (#3%$swap-object-ref 'integer-64 r offset) 0))])]
|
||
|
|
[(_ type bytes pred) (#3%$swap-object-ref 'type r offset)]))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) ref
|
||
|
|
($oops who "unrecognized type ~s" ty))))
|
||
|
|
|
||
|
|
(set-who! $object-set! ; not safe, just handles non-constant types
|
||
|
|
(lambda (ty r offset v)
|
||
|
|
(define-syntax set
|
||
|
|
(syntax-rules (char wchar boolean integer-40 unsigned-40 integer-48 unsigned-48
|
||
|
|
integer-56 unsigned-56 integer-64 unsigned-64)
|
||
|
|
[(_ char bytes pred)
|
||
|
|
(#3%$object-set! 'unsigned-8 r offset (char->integer v))]
|
||
|
|
[(_ wchar bytes pred)
|
||
|
|
(constant-case wchar-bits
|
||
|
|
[(16) (#3%$object-set! 'unsigned-16 r offset (char->integer v))]
|
||
|
|
[(32) (#3%$object-set! 'unsigned-32 r offset (char->integer v))])]
|
||
|
|
[(_ boolean bytes pred)
|
||
|
|
(constant-case int-bits
|
||
|
|
[(32) (#3%$object-set! 'integer-32 r offset (if v 1 0))]
|
||
|
|
[(64) (#3%$object-set! 'integer-64 r offset (if v 1 0))])]
|
||
|
|
[(_ integer-40 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 8))
|
||
|
|
(#3%$object-set! 'unsigned-8 r (fx+ offset 4) (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'integer-8 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ unsigned-40 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 8))
|
||
|
|
(#3%$object-set! 'unsigned-8 r (fx+ offset 4) (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-8 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ integer-48 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 16))
|
||
|
|
(#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand v (- (expt 2 16) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'integer-16 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ unsigned-48 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 16))
|
||
|
|
(#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand v (- (expt 2 16) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-16 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))]))]
|
||
|
|
[(_ integer-56 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 24))
|
||
|
|
(#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-8 r (fx+ offset 6) (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-16 r (fx+ offset 4) (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1)))
|
||
|
|
(#3%$object-set! 'integer-8 r (fx+ offset 6) (bitwise-arithmetic-shift-right v 48))]))]
|
||
|
|
[(_ unsigned-56 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(begin
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 24))
|
||
|
|
(#3%$object-set! 'unsigned-16 r (fx+ offset 4) (logand (bitwise-arithmetic-shift-right v 8) (- (expt 2 16) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-8 r (fx+ offset 6) (logand v (- (expt 2 8) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-16 r (fx+ offset 4) (fxlogand (bitwise-arithmetic-shift-right v 32) (- (expt 2 16) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-8 r (fx+ offset 6) (bitwise-arithmetic-shift-right v 48))]))]
|
||
|
|
[(_ integer-64 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'integer-32 r offset (bitwise-arithmetic-shift-right v 32))
|
||
|
|
(#3%$object-set! 'unsigned-32 r (fx+ offset 4) (logand v (- (expt 2 32) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'integer-32 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))])]
|
||
|
|
[(_ unsigned-64 bytes pred)
|
||
|
|
(< (constant ptr-bits) 64)
|
||
|
|
(constant-case native-endianness
|
||
|
|
[(big)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (bitwise-arithmetic-shift-right v 32))
|
||
|
|
(#3%$object-set! 'unsigned-32 r (fx+ offset 4) (logand v (- (expt 2 32) 1)))]
|
||
|
|
[(little)
|
||
|
|
(#3%$object-set! 'unsigned-32 r offset (logand v (- (expt 2 32) 1)))
|
||
|
|
(#3%$object-set! 'unsigned-32 r (fx+ offset 4) (bitwise-arithmetic-shift-right v 32))])]
|
||
|
|
[(_ type bytes pred) (#3%$object-set! 'type r offset v)]))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) set
|
||
|
|
($oops who "unrecognized type ~s" ty))))
|
||
|
|
|
||
|
|
(set-who! foreign-sizeof
|
||
|
|
(lambda (ty)
|
||
|
|
(define-syntax size
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ type bytes pred) bytes]))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) size
|
||
|
|
($oops who "invalid foreign type specifier ~s" ty))))
|
||
|
|
|
||
|
|
(set-who! #(csv7: record-type-descriptor)
|
||
|
|
(lambda (r)
|
||
|
|
(unless (record? r) ($oops who "~s is not a record" r))
|
||
|
|
(#3%record-rtd r)))
|
||
|
|
|
||
|
|
(set-who! record-rtd
|
||
|
|
(lambda (r)
|
||
|
|
(unless (record? r) ($oops who "~s is not a record" r))
|
||
|
|
(#3%record-rtd r)))
|
||
|
|
|
||
|
|
(set! record-predicate
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops 'record-predicate "~s is not a record type descriptor" rtd))
|
||
|
|
(if (record-type-sealed? rtd)
|
||
|
|
(rec predicate (lambda (x) ($sealed-record? x rtd)))
|
||
|
|
(rec predicate (lambda (x) (record? x rtd))))))
|
||
|
|
|
||
|
|
(let ((base-rtd #!base-rtd))
|
||
|
|
(define (make-flags uid sealed? opaque? parent)
|
||
|
|
(fxlogor
|
||
|
|
(if uid 0 (constant rtd-generative))
|
||
|
|
(if (or opaque? (and parent (record-type-opaque? parent)))
|
||
|
|
(constant rtd-opaque)
|
||
|
|
0)
|
||
|
|
(if sealed? (constant rtd-sealed) 0)))
|
||
|
|
(define ($mrt who base-rtd name parent uid flags fields extras)
|
||
|
|
(include "layout.ss")
|
||
|
|
(when (and parent (record-type-sealed? parent))
|
||
|
|
($oops who "cannot extend sealed record type ~s" parent))
|
||
|
|
(let ([parent-fields (if (not parent) '() (csv7:record-type-field-decls parent))]
|
||
|
|
[uid (or uid (gensym (symbol->string name)))])
|
||
|
|
; start base offset at rtd field
|
||
|
|
; synchronize with syntax.ss and front.ss
|
||
|
|
(let-values ([(pm mpm flds size)
|
||
|
|
(compute-field-offsets who
|
||
|
|
(constant record-type-disp)
|
||
|
|
; rtd must be immutable if we are ever to store records
|
||
|
|
; in space pure
|
||
|
|
(cons `(immutable scheme-object ,uid)
|
||
|
|
(append parent-fields fields)))])
|
||
|
|
(cond
|
||
|
|
[(and (not (fxlogtest flags (constant rtd-generative)))
|
||
|
|
(let ([x ($sgetprop uid '*rtd* #f)])
|
||
|
|
(and (record-type-descriptor? x) x))) =>
|
||
|
|
(lambda (rtd)
|
||
|
|
(define same-fields?
|
||
|
|
(lambda (flds1 flds2)
|
||
|
|
(define same-field?
|
||
|
|
(lambda (fld1 fld2) ; mutability checked separately
|
||
|
|
(and (eq? (fld-name fld1) (fld-name fld2))
|
||
|
|
; not using filter-foreign-type here. this makes the
|
||
|
|
; comparison faster and prevents unwanted machine-dependent
|
||
|
|
; matches like int and integer-32. it also prevents
|
||
|
|
; ptr and scheme-object from matching---c'est la vie.
|
||
|
|
(eq? (fld-type fld1) (fld-type fld2))
|
||
|
|
; following is paranoid; overall size
|
||
|
|
; check should suffice
|
||
|
|
#;(= (fld-byte fld1) (fld-byte fld2)))))
|
||
|
|
(and (= (length flds1) (length flds2))
|
||
|
|
(andmap same-field? flds1 flds2))))
|
||
|
|
; following assumes extras match
|
||
|
|
(let ()
|
||
|
|
(define (squawk what) ($oops who "incompatible record type ~s - ~a" name what))
|
||
|
|
(unless (eq? ($record-type-descriptor rtd) base-rtd) (squawk "different base rtd"))
|
||
|
|
(unless (eq? (rtd-parent rtd) parent) (squawk "different parent"))
|
||
|
|
(unless (same-fields? (rtd-flds rtd) (cdr flds)) (squawk "different fields"))
|
||
|
|
(unless (= (rtd-mpm rtd) mpm) (squawk "different mutability"))
|
||
|
|
(unless (fx= (rtd-flags rtd) flags) (squawk "different flags"))
|
||
|
|
(unless (eq? (rtd-size rtd) size) (squawk "different size")))
|
||
|
|
rtd)]
|
||
|
|
[else
|
||
|
|
(let ([rtd (apply #%$record base-rtd parent size pm mpm name
|
||
|
|
(cdr flds) flags uid #f extras)])
|
||
|
|
(with-tc-mutex ($sputprop uid '*rtd* rtd))
|
||
|
|
rtd)]))))
|
||
|
|
|
||
|
|
(set-who! $remake-rtd
|
||
|
|
(lambda (rtd compute-field-offsets)
|
||
|
|
(let ([key ($target-machine)] [uid (rtd-uid rtd)])
|
||
|
|
(assert (not (eq? key (machine-type))))
|
||
|
|
(or ($sgetprop uid key #f)
|
||
|
|
(let ([base-rtd ($record-type-descriptor rtd)]
|
||
|
|
[parent (rtd-parent rtd)]
|
||
|
|
[name (rtd-name rtd)]
|
||
|
|
[flags (rtd-flags rtd)]
|
||
|
|
[fields (csv7:record-type-field-decls rtd)])
|
||
|
|
(let-values ([(pm mpm flds size)
|
||
|
|
(compute-field-offsets who
|
||
|
|
(constant record-type-disp)
|
||
|
|
(cons `(immutable scheme-object ,uid) fields))])
|
||
|
|
(let ([rtd (apply #%$record base-rtd parent size pm mpm name (cdr flds) flags uid #f
|
||
|
|
(let* ([n (length (rtd-flds ($record-type-descriptor base-rtd)))]
|
||
|
|
[ls (list-tail (rtd-flds base-rtd) n)])
|
||
|
|
(let f ([n n] [ls ls])
|
||
|
|
(if (null? ls)
|
||
|
|
'()
|
||
|
|
(cons ((csv7:record-field-accessor base-rtd n) rtd)
|
||
|
|
(f (fx+ n 1) (cdr ls)))))))])
|
||
|
|
(with-tc-mutex ($sputprop uid key rtd))
|
||
|
|
rtd)))))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (mrt base-rtd parent name fields sealed? opaque? extras)
|
||
|
|
(cond
|
||
|
|
[(gensym? name)
|
||
|
|
($mrt 'make-record-type base-rtd
|
||
|
|
(string->symbol (symbol->string name)) parent name
|
||
|
|
(make-flags name sealed? opaque? parent)
|
||
|
|
fields extras)]
|
||
|
|
[(string? name)
|
||
|
|
($mrt 'make-record-type base-rtd
|
||
|
|
(string->symbol name) parent #f
|
||
|
|
(make-flags #f sealed? opaque? parent)
|
||
|
|
fields extras)]
|
||
|
|
[else ($oops 'make-record-type "invalid record name ~s" name)]))
|
||
|
|
|
||
|
|
(set-who! make-record-type
|
||
|
|
(rec make-record-type
|
||
|
|
(case-lambda
|
||
|
|
[(name fields)
|
||
|
|
(unless (list? fields)
|
||
|
|
($oops who "invalid field list ~s" fields))
|
||
|
|
(mrt base-rtd #f name fields #f #f '())]
|
||
|
|
[(parent name fields)
|
||
|
|
(unless (or (not parent) (record-type-descriptor? parent))
|
||
|
|
($oops who "~s is not a record type descriptor"
|
||
|
|
parent))
|
||
|
|
(unless (list? fields)
|
||
|
|
($oops who "invalid field list ~s" fields))
|
||
|
|
(mrt base-rtd parent name fields #f #f '())])))
|
||
|
|
|
||
|
|
(set! $make-record-type
|
||
|
|
(lambda (base-rtd parent name fields sealed? opaque? . extras)
|
||
|
|
(unless (record-type-descriptor? base-rtd)
|
||
|
|
($oops 'make-record-type "~s is not a record type descriptor"
|
||
|
|
base-rtd))
|
||
|
|
(unless (or (not parent) (record-type-descriptor? parent))
|
||
|
|
($oops 'make-record-type "~s is not a record type descriptor"
|
||
|
|
parent))
|
||
|
|
(unless (list? fields)
|
||
|
|
($oops 'make-record-type "invalid field list ~s" fields))
|
||
|
|
(mrt base-rtd parent name fields sealed? opaque? extras))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (mrtd base-rtd name parent uid sealed? opaque? fields who extras)
|
||
|
|
(unless (symbol? name)
|
||
|
|
($oops who "invalid record name ~s" name))
|
||
|
|
(unless (or (not parent) (record-type-descriptor? parent))
|
||
|
|
($oops who "invalid parent ~s" parent))
|
||
|
|
(unless (or (not uid) (symbol? uid))
|
||
|
|
($oops who "invalid uid ~s" uid))
|
||
|
|
(unless (vector? fields)
|
||
|
|
($oops who "invalid field vector ~s" fields))
|
||
|
|
($mrt who base-rtd name parent uid
|
||
|
|
(make-flags uid sealed? opaque? parent)
|
||
|
|
(let ([n (vector-length fields)])
|
||
|
|
(let f ([i 0])
|
||
|
|
(if (fx= i n)
|
||
|
|
'()
|
||
|
|
(let ([x (vector-ref fields i)])
|
||
|
|
(unless (and (pair? x)
|
||
|
|
(memq (car x) '(mutable immutable))
|
||
|
|
(let ([x (cdr x)])
|
||
|
|
(and (pair? x)
|
||
|
|
(symbol? (car x))
|
||
|
|
(null? (cdr x)))))
|
||
|
|
($oops who "invalid field specifier ~s" x))
|
||
|
|
(cons x (f (fx+ i 1)))))))
|
||
|
|
extras))
|
||
|
|
|
||
|
|
(set! $make-record-type-descriptor
|
||
|
|
(lambda (base-rtd name parent uid sealed? opaque? fields who . extras)
|
||
|
|
(unless (record-type-descriptor? base-rtd)
|
||
|
|
($oops who "invalid base rtd ~s" base-rtd))
|
||
|
|
(mrtd base-rtd name parent uid sealed? opaque? fields who extras)))
|
||
|
|
|
||
|
|
(set-who! make-record-type-descriptor
|
||
|
|
(lambda (name parent uid sealed? opaque? fields)
|
||
|
|
(mrtd base-rtd name parent uid sealed? opaque? fields who '()))))
|
||
|
|
|
||
|
|
(set! record-type-descriptor?
|
||
|
|
(lambda (x)
|
||
|
|
(#3%record? x base-rtd)))
|
||
|
|
|
||
|
|
(set! record?
|
||
|
|
(case-lambda
|
||
|
|
[(x) (#3%record? x)]
|
||
|
|
[(x rtd)
|
||
|
|
(unless (#3%record? rtd base-rtd)
|
||
|
|
($oops 'record? "~s is not a record type descriptor" rtd))
|
||
|
|
(#3%record? x rtd)])))
|
||
|
|
|
||
|
|
(set! r6rs:record?
|
||
|
|
(rec record?
|
||
|
|
(lambda (x)
|
||
|
|
(#3%r6rs:record? x))))
|
||
|
|
|
||
|
|
(set! record-type-parent
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops 'record-type-parent "~s is not a record type descriptor" rtd))
|
||
|
|
(rtd-parent rtd)))
|
||
|
|
|
||
|
|
(set-who! #(csv7: record-type-name)
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(symbol->string (rtd-name rtd))))
|
||
|
|
|
||
|
|
(set-who! record-type-name
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(rtd-name rtd)))
|
||
|
|
|
||
|
|
(set-who! #(csv7: record-type-symbol)
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(rtd-uid rtd)))
|
||
|
|
|
||
|
|
(set-who! record-type-uid
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(rtd-uid rtd)))
|
||
|
|
|
||
|
|
(set-who! #(csv7: record-type-field-names)
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(map (lambda (x) (fld-name x)) (rtd-flds rtd))))
|
||
|
|
|
||
|
|
(set-who! record-type-field-names
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(list->vector (map (lambda (x) (fld-name x)) (child-flds rtd)))))
|
||
|
|
|
||
|
|
(set-who! #(csv7: record-type-field-decls)
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(map (lambda (x)
|
||
|
|
`(,(if (fld-mutable? x) 'mutable 'immutable)
|
||
|
|
,(fld-type x)
|
||
|
|
,(fld-name x)))
|
||
|
|
(rtd-flds rtd))))
|
||
|
|
|
||
|
|
(set! $record-type-field-offsets
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops '$record-type-field-offsets "~s is not a record type descriptor" rtd))
|
||
|
|
(map (lambda (x) (fld-byte x)) (rtd-flds rtd))))
|
||
|
|
|
||
|
|
(set! record-type-opaque?
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops 'record-type-opaque? "~s is not a record type descriptor" rtd))
|
||
|
|
(#3%record-type-opaque? rtd)))
|
||
|
|
|
||
|
|
(set! record-type-sealed?
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops 'record-type-sealed? "~s is not a record type descriptor" rtd))
|
||
|
|
(#3%record-type-sealed? rtd)))
|
||
|
|
|
||
|
|
(set! record-type-generative?
|
||
|
|
(lambda (rtd)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops 'record-type-generative? "~s is not a record type descriptor" rtd))
|
||
|
|
(#3%record-type-generative? rtd)))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (find-fld who rtd field-spec)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(cond
|
||
|
|
[(symbol? field-spec)
|
||
|
|
; reverse order to check child's fields first
|
||
|
|
(let loop ((flds (reverse (rtd-flds rtd))))
|
||
|
|
(when (null? flds)
|
||
|
|
($oops who "unrecognized field name ~s for type ~s"
|
||
|
|
field-spec rtd))
|
||
|
|
(let ((fld (car flds)))
|
||
|
|
(if (eq? field-spec (fld-name fld))
|
||
|
|
fld
|
||
|
|
(loop (cdr flds)))))]
|
||
|
|
[(and (fixnum? field-spec) (fx>= field-spec 0))
|
||
|
|
(let ((flds (rtd-flds rtd)))
|
||
|
|
(when (fx>= field-spec (length flds))
|
||
|
|
($oops who "invalid field ordinal ~s for type ~s"
|
||
|
|
field-spec rtd))
|
||
|
|
(list-ref flds field-spec))]
|
||
|
|
[else ($oops who "invalid field specifier ~s" field-spec)]))
|
||
|
|
|
||
|
|
(define (r6rs:find-fld who rtd field-spec)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record type descriptor" rtd))
|
||
|
|
(cond
|
||
|
|
[(and (fixnum? field-spec) (fx>= field-spec 0))
|
||
|
|
(let ((flds (child-flds rtd)))
|
||
|
|
(when (fx>= field-spec (length flds))
|
||
|
|
($oops who "invalid field index ~s for type ~s"
|
||
|
|
field-spec rtd))
|
||
|
|
(list-ref flds field-spec))]
|
||
|
|
[else ($oops who "invalid field specifier ~s" field-spec)]))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (rfa who rtd fld)
|
||
|
|
(let ((record-err (lambda (x) ($record-oops #f x rtd)))
|
||
|
|
(offset (fld-byte fld))
|
||
|
|
(ty (fld-type fld)))
|
||
|
|
(define-syntax ref
|
||
|
|
(syntax-rules ()
|
||
|
|
[(_ type bytes pred)
|
||
|
|
(rec accessor
|
||
|
|
(lambda (x)
|
||
|
|
(unless (record? x rtd) (record-err x))
|
||
|
|
(#3%$object-ref 'type x offset)))]))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) ref
|
||
|
|
($oops who "unrecognized type ~s" ty))))
|
||
|
|
(set-who! #(csv7: record-field-accessor)
|
||
|
|
(lambda (rtd field-spec)
|
||
|
|
(rfa who rtd (find-fld who rtd field-spec))))
|
||
|
|
(set-who! record-accessor
|
||
|
|
(lambda (rtd field-spec)
|
||
|
|
(rfa who rtd (r6rs:find-fld who rtd field-spec)))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (rfm who rtd fld field-spec)
|
||
|
|
(if (fld-mutable? fld)
|
||
|
|
(let ((record-err (lambda (x t) ($record-oops #f x t)))
|
||
|
|
(value-err (lambda (x t) ($oops #f "invalid value ~s for foreign type ~s" x t)))
|
||
|
|
(offset (fld-byte fld))
|
||
|
|
(ty (fld-type fld)))
|
||
|
|
(define-syntax set
|
||
|
|
(syntax-rules (scheme-object)
|
||
|
|
[(_ scheme-object bytes pred)
|
||
|
|
(rec mutator
|
||
|
|
(lambda (x v)
|
||
|
|
(unless (record? x rtd) (record-err x rtd))
|
||
|
|
(#3%$object-set! 'scheme-object x offset v)))]
|
||
|
|
[(_ type bytes pred)
|
||
|
|
(rec mutator
|
||
|
|
(lambda (x v)
|
||
|
|
(unless (record? x rtd) (record-err x rtd))
|
||
|
|
(unless (pred v) (value-err v ty))
|
||
|
|
(#3%$object-set! 'type x offset v)))]))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) set
|
||
|
|
($oops who "unrecognized type ~s" ty)))
|
||
|
|
($oops who "field ~s of ~s is immutable"
|
||
|
|
field-spec rtd)))
|
||
|
|
(set-who! #(csv7: record-field-mutator)
|
||
|
|
(lambda (rtd field-spec)
|
||
|
|
(rfm who rtd (find-fld who rtd field-spec) field-spec)))
|
||
|
|
(set-who! record-mutator
|
||
|
|
(lambda (rtd field-spec)
|
||
|
|
(rfm who rtd (r6rs:find-fld who rtd field-spec) field-spec))))
|
||
|
|
|
||
|
|
(set-who! #(csv7: record-field-accessible?)
|
||
|
|
; if this is ever made to do anything reasonable, revisit handlers in
|
||
|
|
; cp0 and cp1in as well
|
||
|
|
(lambda (rtd field-spec)
|
||
|
|
(find-fld who rtd field-spec)
|
||
|
|
#t))
|
||
|
|
|
||
|
|
(set-who! #(csv7: record-field-mutable?)
|
||
|
|
(lambda (rtd field-spec)
|
||
|
|
(fld-mutable? (find-fld who rtd field-spec))))
|
||
|
|
|
||
|
|
(set-who! record-field-mutable?
|
||
|
|
(lambda (rtd field-spec)
|
||
|
|
(fld-mutable? (r6rs:find-fld who rtd field-spec)))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
; if you update this, also update duplicate in cp0.ss
|
||
|
|
(define-record-type rcd
|
||
|
|
(fields (immutable rtd) (immutable prcd) (immutable protocol))
|
||
|
|
(nongenerative #{rcd qh0yzh5qyrxmz2l-a})
|
||
|
|
(sealed #t))
|
||
|
|
|
||
|
|
(set! record-constructor-descriptor?
|
||
|
|
(lambda (x)
|
||
|
|
(rcd? x)))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (mrcd rtd prcd protocol who)
|
||
|
|
(unless (record-type-descriptor? rtd)
|
||
|
|
($oops who "~s is not a record-type descriptor" rtd))
|
||
|
|
(unless (or (not prcd) (rcd? prcd))
|
||
|
|
($oops who "invalid record constructor descriptor ~s" prcd))
|
||
|
|
(unless (or (not protocol) (procedure? protocol))
|
||
|
|
($oops who "invalid protocol ~s" protocol))
|
||
|
|
(unless (eqv? (rtd-pm rtd) -1) ; all pointers?
|
||
|
|
($oops who "cannot create constructor descriptor for record type with non-scheme-object fields"))
|
||
|
|
(let ([prtd (record-type-parent rtd)])
|
||
|
|
(when (and prcd (not prtd))
|
||
|
|
($oops who
|
||
|
|
"record constructor descriptor ~s specified for base record type ~s"
|
||
|
|
prcd rtd))
|
||
|
|
(when (and prcd prtd (not (eq? (rcd-rtd prcd) prtd)))
|
||
|
|
($oops who
|
||
|
|
"record constructor descriptor ~s is not for parent of record type ~s"
|
||
|
|
prcd rtd))
|
||
|
|
(when (and (not protocol) prcd (rcd-protocol prcd))
|
||
|
|
($oops who "no protocol specified, but parent ~s has protocol" prcd))
|
||
|
|
(make-rcd rtd prcd protocol)))
|
||
|
|
|
||
|
|
(set! $make-record-constructor-descriptor
|
||
|
|
(lambda (rtd prcd protocol who)
|
||
|
|
(mrcd rtd prcd protocol who)))
|
||
|
|
|
||
|
|
(set! make-record-constructor-descriptor
|
||
|
|
(lambda (rtd prcd protocol)
|
||
|
|
(mrcd rtd prcd protocol 'make-record-constructor-descriptor))))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define $rtd->record-constructor
|
||
|
|
(lambda (rtd)
|
||
|
|
(define type->pred
|
||
|
|
(lambda (ty)
|
||
|
|
(define-syntax ->pred
|
||
|
|
(syntax-rules () ((_ type bytes pred) 'pred)))
|
||
|
|
(record-datatype cases ty ->pred
|
||
|
|
($oops 'record-constructor "unrecognized type ~s" ty))))
|
||
|
|
(let* ((flds (rtd-flds rtd)) (nflds (length flds)))
|
||
|
|
(if (eqv? (rtd-pm rtd) -1) ; all pointers?
|
||
|
|
(let ()
|
||
|
|
(define-syntax nlambda
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
[(_ n)
|
||
|
|
(with-syntax (((t ...)
|
||
|
|
(generate-temporaries
|
||
|
|
(make-list
|
||
|
|
(datum n)))))
|
||
|
|
#'(rec constructor
|
||
|
|
(lambda (t ...) ($record rtd t ...))))])))
|
||
|
|
(case nflds
|
||
|
|
[(0) (nlambda 0)]
|
||
|
|
[(1) (nlambda 1)]
|
||
|
|
[(2) (nlambda 2)]
|
||
|
|
[(3) (nlambda 3)]
|
||
|
|
[(4) (nlambda 4)]
|
||
|
|
[(5) (nlambda 5)]
|
||
|
|
[(6) (nlambda 6)]
|
||
|
|
[else (rec constructor
|
||
|
|
(lambda xr
|
||
|
|
(unless (fx= (length xr) nflds)
|
||
|
|
($oops #f "incorrect number of arguments to ~s" constructor))
|
||
|
|
(apply $record rtd xr)))]))
|
||
|
|
(let* ([args (make-record-call-args flds (rtd-size rtd)
|
||
|
|
(map (lambda (x) 0) flds))]
|
||
|
|
[nargs (length args)]
|
||
|
|
[setters (map (lambda (fld)
|
||
|
|
(let ([byte (fld-byte fld)]
|
||
|
|
[ty (fld-type fld)])
|
||
|
|
(let ([msg (format "invalid value ~~s for foreign type ~s" ty)])
|
||
|
|
(define-syntax init
|
||
|
|
(syntax-rules (scheme-object)
|
||
|
|
[(_ scheme-object bytes pred)
|
||
|
|
(lambda (x v)
|
||
|
|
(#3%$object-set! 'scheme-object x byte v))]
|
||
|
|
[(_ type bytes pred)
|
||
|
|
(lambda (x v)
|
||
|
|
(unless (pred v) ($oops #f msg v))
|
||
|
|
(#3%$object-set! 'type x byte v))]))
|
||
|
|
(record-datatype cases (filter-foreign-type ty) init
|
||
|
|
($oops 'record-constructor "unrecognized type ~s" ty)))))
|
||
|
|
flds)])
|
||
|
|
(define-syntax nmlambda
|
||
|
|
(lambda (x)
|
||
|
|
(syntax-case x ()
|
||
|
|
[(_ n m)
|
||
|
|
(with-syntax ([(t ...) (generate-temporaries
|
||
|
|
(make-list (datum n)))]
|
||
|
|
[(z ...) (make-list (datum m) 0)])
|
||
|
|
(with-syntax ([(t! ...) (generate-temporaries #'(t ...))])
|
||
|
|
#'(apply
|
||
|
|
(lambda (t! ...)
|
||
|
|
(rec constructor
|
||
|
|
(lambda (t ...)
|
||
|
|
(let ([x ($record rtd z ...)])
|
||
|
|
(t! x t) ...
|
||
|
|
x))))
|
||
|
|
setters)))])))
|
||
|
|
(or (constant-case ptr-bits
|
||
|
|
[(64)
|
||
|
|
(case nflds
|
||
|
|
[(0) (and (= nargs 0) (nmlambda 0 0))]
|
||
|
|
[(1) (and (= nargs 1) (nmlambda 1 1))]
|
||
|
|
[(2) (case nargs
|
||
|
|
[(1) (nmlambda 2 1)]
|
||
|
|
[(2) (nmlambda 2 2)]
|
||
|
|
[else #f])]
|
||
|
|
[(3) (case nargs
|
||
|
|
[(1) (nmlambda 3 1)]
|
||
|
|
[(2) (nmlambda 3 2)]
|
||
|
|
[(3) (nmlambda 3 3)]
|
||
|
|
[else #f])]
|
||
|
|
[(4) (case nargs
|
||
|
|
[(1) (nmlambda 4 1)]
|
||
|
|
[(2) (nmlambda 4 2)]
|
||
|
|
[(3) (nmlambda 4 3)]
|
||
|
|
[(4) (nmlambda 4 4)]
|
||
|
|
[else #f])]
|
||
|
|
[else #f])]
|
||
|
|
[(32)
|
||
|
|
(case nflds
|
||
|
|
[(0) (nmlambda 0 0)]
|
||
|
|
[(1) (case nargs
|
||
|
|
[(1) (nmlambda 1 1)]
|
||
|
|
[(2) (nmlambda 1 2)]
|
||
|
|
[(3) (nmlambda 1 3)]
|
||
|
|
[else #f])]
|
||
|
|
[(2) (case nargs
|
||
|
|
[(1) (nmlambda 2 1)]
|
||
|
|
[(2) (nmlambda 2 2)]
|
||
|
|
[(3) (nmlambda 2 3)]
|
||
|
|
[(4) (nmlambda 2 4)]
|
||
|
|
[(5) (nmlambda 2 5)]
|
||
|
|
[else #f])]
|
||
|
|
[(3) (case nargs
|
||
|
|
[(1) (nmlambda 3 1)]
|
||
|
|
[(2) (nmlambda 3 2)]
|
||
|
|
[(3) (nmlambda 3 3)]
|
||
|
|
[(4) (nmlambda 3 4)]
|
||
|
|
[(5) (nmlambda 3 5)]
|
||
|
|
[(6) (nmlambda 3 6)]
|
||
|
|
[(7) (nmlambda 3 7)]
|
||
|
|
[else #f])]
|
||
|
|
[(4) (case nargs
|
||
|
|
[(1) (nmlambda 4 1)]
|
||
|
|
[(2) (nmlambda 4 2)]
|
||
|
|
[(3) (nmlambda 4 3)]
|
||
|
|
[(4) (nmlambda 4 4)]
|
||
|
|
[(5) (nmlambda 4 5)]
|
||
|
|
[(6) (nmlambda 4 6)]
|
||
|
|
[(7) (nmlambda 4 7)]
|
||
|
|
[(8) (nmlambda 4 8)]
|
||
|
|
[(9) (nmlambda 4 9)]
|
||
|
|
[else #f])]
|
||
|
|
[else #f])])
|
||
|
|
(rec constructor
|
||
|
|
(lambda xr
|
||
|
|
(unless (fx= (length xr) nflds)
|
||
|
|
($oops #f "incorrect number of arguments to ~s" constructor))
|
||
|
|
(let ([x (apply $record rtd args)])
|
||
|
|
(for-each (lambda (setter v) (setter x v)) setters xr)
|
||
|
|
x)))))))))
|
||
|
|
|
||
|
|
(define ($rcd->record-constructor rcd)
|
||
|
|
(let ([rtd (rcd-rtd rcd)] [protocol (rcd-protocol rcd)])
|
||
|
|
(let ([rc ($rtd->record-constructor rtd)])
|
||
|
|
(if protocol
|
||
|
|
(protocol
|
||
|
|
(cond
|
||
|
|
[(rtd-parent rtd) =>
|
||
|
|
(lambda (prtd)
|
||
|
|
(lambda pp-args
|
||
|
|
(lambda vals
|
||
|
|
(let f ([prcd (rcd-prcd rcd)] [prtd prtd] [pp-args pp-args] [vals vals])
|
||
|
|
(#2%apply
|
||
|
|
(cond
|
||
|
|
[(and prcd (rcd-protocol prcd)) =>
|
||
|
|
(lambda (protocol)
|
||
|
|
(protocol
|
||
|
|
(cond
|
||
|
|
[(rtd-parent prtd) =>
|
||
|
|
(lambda (prtd)
|
||
|
|
(lambda pp-args
|
||
|
|
(lambda new-vals
|
||
|
|
(f (rcd-prcd prcd) prtd pp-args
|
||
|
|
(append new-vals vals)))))]
|
||
|
|
[else
|
||
|
|
(lambda new-vals
|
||
|
|
(apply rc (append new-vals vals)))])))]
|
||
|
|
[else
|
||
|
|
(lambda new-vals
|
||
|
|
(apply rc (append new-vals vals)))])
|
||
|
|
pp-args)))))]
|
||
|
|
[else rc]))
|
||
|
|
rc))))
|
||
|
|
|
||
|
|
(set! record-constructor
|
||
|
|
(lambda (x)
|
||
|
|
(cond
|
||
|
|
[(record-type-descriptor? x) ($rtd->record-constructor x)]
|
||
|
|
[(record-constructor-descriptor? x) ($rcd->record-constructor x)]
|
||
|
|
[else ($oops 'record-constructor "~s is not a record type or constructor descriptor" x)])))
|
||
|
|
|
||
|
|
(set-who! #(r6rs: record-constructor)
|
||
|
|
(lambda (rcd)
|
||
|
|
(unless (rcd? rcd)
|
||
|
|
($oops who "~s is not a record constructor descriptor" rcd))
|
||
|
|
($rcd->record-constructor rcd)))))
|
||
|
|
)
|