add $record-type-field-count

This is a `$` function because it is defined only for record types
that have pointer-sized fields (i.e., the normal case).

original commit: 47213a7c8450aa52bd18e8f605c02b6c1081eadf
This commit is contained in:
Matthew Flatt 2020-01-31 11:17:04 -07:00
parent fd1745c628
commit 40c407e1c2
5 changed files with 14 additions and 2 deletions

View File

@ -62,7 +62,7 @@ InstallLZ4Target=
# no changes should be needed below this point #
###############################################################################
Version=csv9.5.3.16
Version=csv9.5.3.17
Include=boot/$m
PetiteBoot=boot/$m/petite.boot
SchemeBoot=boot/$m/scheme.boot

View File

@ -328,7 +328,7 @@
[(_ foo e1 e2) e1] ...
[(_ bar e1 e2) e2]))))])))
(define-constant scheme-version #x09050310)
(define-constant scheme-version #x09050311)
(define-syntax define-machine-types
(lambda (x)

View File

@ -9716,6 +9716,11 @@
[else #f])])
(define-inline 2 $sealed-record?
[(e e-rtd) (build-sealed-isa? e e-rtd)])
(define-inline 3 $record-type-field-count
[(e) (%inline srl ,(%inline - ,(%mref ,e ,(constant record-type-size-disp))
(immediate ,(fxsll (fx- (constant record-data-disp) (constant record-type-disp))
(constant fixnum-offset))))
,(%constant log2-ptr-bytes))])
(define-inline 2 eq-hashtable?
[(e) (let ([rtd (let () (include "hashtable-types.ss") (record-type-descriptor eq-ht))])
(let ([e-rtd `(quote ,rtd)])

View File

@ -2236,6 +2236,7 @@
($record-set! [sig [(ptr sub-index ptr) -> (void)]] [flags true])
($record-type-descriptor [flags single-valued pure mifoldable discard true])
($record-type-field-offsets [flags single-valued pure mifoldable discard true])
($record-type-field-count [sig [(ptr) -> (fixnum)]] [flags single-valued pure mifoldable discard true])
($reloc [flags single-valued])
($remake-rtd [flags single-valued])
($report-string [flags single-valued])

View File

@ -2054,6 +2054,12 @@
(unless ($record? r) ($oops who "~s is not a record" r))
(#3%$record-type-descriptor r))
;; Assumes that the record that has only pointer fields:
(define-who ($record-type-field-count rtd)
(unless (record-type-descriptor? rtd)
($oops who "~s is not a record type descriptor" rtd))
($record-type-field-count rtd))
(define-who utf8->string
(let ()
(define slurp