Chez Scheme: add C API functions for records and record types

pkgs/racket-doc/scribblings/inside/cs-values.scrbl

@@ -1,5 +1,7 @@
 #lang scribble/doc
-@(require "utils.rkt")
+@(require "utils.rkt"
+          (for-label racket/unsafe/ops
+                     ffi/unsafe))
 
 @title[#:tag "cs-values+types"]{Values and Types}
 
@@ -31,7 +33,7 @@ There are six global constants:
 
  @item{@cppdef{Snil} --- @racket[null]}
 
- @item{@cppdef{Seof-object} --- @racket[eof-object]}
+ @item{@cppdef{Seof_object} --- @racket[eof-object]}
 
  @item{@cppdef{Svoid} --- @racket[(void)]}
 
@@ -69,7 +71,7 @@ Many of these functions are actually macros.
              Srecordp)]{
 
 Predicates to recognize different kinds of Racket values, such as
-fixnums, characters, the empty list, etc. The @cpp{Srecord} predicate
+fixnums, characters, the empty list, etc. The @cpp{Srecordp} predicate
 recognizes structures, but some built-in Racket datatypes are also
 implemented as records.}
 
@@ -264,3 +266,42 @@ Extract the content of the box @var{bx}.}
 @function[(ptr Sset_box [ptr bx] [ptr v])]{
 
 Installs @var{v} as the content of the box @var{bx}.}
+
+@together[(
+@function[(ptr Srecord_type [ptr rec])]
+@function[(ptr Srecord_type_parent [ptr rtd])]
+@function[(uptr Srecord_type_size [ptr rtd])]
+@function[(int Srecord_type_uniformp [ptr rtd])]
+@function[(ptr Srecord_uniform_ref [ptr rec][iptr i])]
+)]{
+
+Accesses record information, where Racket structures are implemented
+as records. The @cpp{Srecord_type} returns a value representing a
+record's type (so, a structure type). Given a record type,
+@cpp{Srecord_type_parent} returns its supertype or @cpp{Sfalse},
+@cpp{Srecord_type_size} returns the allocation size of a record in
+bytes, and @cpp{Srecord_type_uniformp} indicates whether all of the
+record fields are Scheme values --- which is always true for a Racket
+structure. When a record has all Scheme-valued fields, the allocation
+size is the number of fields plus one times the size of a pointer in
+bytes.
+
+When a record has all Scheme fields (which is the case for all Racket
+structures), @cpp{Srecord_uniform_ref} accesses a field value in the
+same way as @racket[unsafe-struct*-ref].}
+
+@together[(
+@function[(void* racket_cpointer_address [ptr cptr])]
+@function[(void* racket_cpointer_base_address [ptr cptr])]
+@function[(iptr racket_cpointer_offset [ptr cptr])]
+)]{
+
+Extracts an address and offset from a C-pointer object in the sense of
+@racket[cpointer?], but only for values using the predefined representation
+that is not a byte string, @racket[#f], or implemented by a new
+structure type with @racket[prop:cpointer].
+
+The result of @cpp{racket_cpointer_address} is the same as
+@cpp{racket_cpointer_base_address} plus @cpp{racket_cpointer_offset},
+where @cpp{racket_cpointer_offset} is non-zero for C-pointer values
+created by @racket[ptr-add].}

racket/src/ChezScheme/c/alloc.c

@@ -775,6 +775,22 @@ ptr S_record(n) iptr n; {
     return p;
 }
 
+ptr Srecord_type(ptr r) {
+  return RECORDINSTTYPE(r);
+}
+
+ptr Srecord_type_parent(ptr rtd) {
+  return RECORDDESCPARENT(rtd);
+}
+
+uptr Srecord_type_size(ptr rtd) {
+  return UNFIX(RECORDDESCSIZE(rtd));
+}
+
+int Srecord_type_uniformp(ptr rtd) {
+  return RECORDDESCPM(rtd) == FIX(-1);
+}
+
 ptr S_closure(cod, n) ptr cod; iptr n; {
     ptr tc = get_thread_context();
     ptr p; iptr d;

racket/src/ChezScheme/configure

@@ -490,6 +490,15 @@ else
   exit 1
 fi
 
+case "$srcdir" in
+    /*)
+        upsrcdir=$srcdir
+        ;;
+    *)
+        upsrcdir=../$srcdir
+        ;;
+esac
+
 "$srcdir"/workarea $m $w $mpbhost
 
 sed -e 's/$(m)/'$m'/g'\
@@ -498,6 +507,7 @@ sed -e 's/$(m)/'$m'/g'\
 
 mkdir -p csug
 sed -e 's/$(m)/'$m'/g'\
+    -e "s;^srcdir = .*\$;srcdir = $upsrcdir/csug;"\
     "$srcdir"/makefiles//Makefile-csug.in > csug/Makefile
 
 mkdir -p release_notes

racket/src/ChezScheme/csug/foreign.stex

@@ -3049,6 +3049,20 @@ the pointer points and may copy other data over the object.
 \cmacro{octet *}{Sbytevector_data}{ptr \var{bytevec}}
 \end{flushleft}
 
+\begin{flushleft}
+\cfunction{ptr}{Srecord_type}{ptr \var{rec}}
+\cfunction{ptr}{Srecord_type_parent}{ptr \var{rtd}}
+\cfunction{uptr}{Srecord_type_size}{ptr \var{rtd}}
+\cfunction{int}{Srecord_type_uniformp}{ptr \var{rtd}}
+\cmacro{ptr}{Srecord_uniform_ref}{ptr \var{rec}, iptr \var{i}}
+\end{flushleft}
+
+\noindent
+The \scheme{Srecord_uniform_ref} accessor should be used only on
+records whose fields are all Scheme values, which is a record
+for which \scheme{Srecord_type_uniformp} composed with
+\scheme{Srecord_type} returns true.
+
 \parheader{Mutators}
 Changes to mutable objects that contain pointers, such as pairs and
 vectors, must be tracked on behalf of the storage

racket/src/ChezScheme/csug/priminfo.ss

@@ -58,5 +58,5 @@
                       #'(put-priminfo! 'prim '(lib ...))])))
                #`(begin #,@(map do-entry #'(entry ...)))))])))
 
-  (include "../s/primdata.ss")
+  (include "primdata.ss")
 )

racket/src/ChezScheme/makefiles/Makefile-csug.in

@@ -1,6 +1,7 @@
+srcdir = $(srcdir)
 m = $(m)
 Scheme=../$m/bin/$m/scheme -b ../$m/boot/$m/petite.boot -b ../$m/boot/$m/scheme.boot
-STEXLIB=../stex
+STEXLIB=$(srcdir)/../stex
 installdir=/tmp/csug9.5
 INSTALL=../$m/installsh
 
@@ -9,10 +10,10 @@ latex = pdflatex
 stexmacrofiles = tspl4-prep
 bib = $(x).bib
 index=yes
-TSPL=tspl4
+TSPL=$(srcdir)/tspl4
 DIR=$(shell basename `pwd`)
 
-target: logcheck1 logcheck2 checklibs $(x).html $(x).pdf
+target: canned logcheck1 logcheck2 checklibs $(x).html $(x).pdf
 
 install: target
 	$(INSTALL) -m 2755 -d $(installdir)
@@ -54,16 +55,42 @@ stexsrc = csug.stex title.stex copyright.stex contents.stex\
  compat.stex bibliography.stex summary.stex
 texsrc = ${stexsrc:%.stex=%.tex}
 
-title.tex contents.tex bibliography.tex:
+moresrc = tspl4-prep.stex priminfo.ss docond.ss csug8.cls csug810.clo scheme.sty csug.bib \
+ setup.ss summary.ss tspl.bst
+
+$(stexsrc) $(moresrc):
+ifeq ($(OS),Windows_NT)
+	cp -p "${srcdir}"/$@ $@
+else
+	ln -s "${srcdir}"/$@ $@
+endif
+
+primdata.ss:
+ifeq ($(OS),Windows_NT)
+	cp -p "${srcdir}"/../s/$@ $@
+else
+	ln -s "${srcdir}"/../s/$@ $@
+endif
+
+canned:
+ifeq ($(OS),Windows_NT)
+	cp -r "${srcdir}"/$@ $@
+else
+	ln -s "${srcdir}"/$@ $@
+endif
+
+$(texsrc): $(moresrc)
+
+$(srcdir)/title.tex $(srcdir)/contents.tex $(srcdir)/bibliography.tex:
 	/bin/rm -f $*.tex
 	echo "%%% DO NOT EDIT THIS FILE" > $*.tex
 	echo "%%% Edit the .stex version instead" >> $*.tex
 	echo "" >> $*.tex
-	cat $*.stex >> $*.tex
+	cat $(srcdir)/$*.stex >> $*.tex
 	chmod -w $*.tex
-title.tex: title.stex
+title.tex: $(srcdir)/title.stex
-contents.tex: contents.stex
+contents.tex: $(srcdir)/contents.stex
-bibliography.tex: bibliography.stex
+bibliography.tex: $(srcdir)/bibliography.stex
 
 $(x).firstrun: $(x).prefirstrun
 $(x).prefirstrun: tspl.aux tspl.rfm tspl.idx
@@ -74,7 +101,7 @@ $(x).prefirstrun: tspl.aux tspl.rfm tspl.idx
 	touch $(x).prefirstrun
 
 $(x).secondrun: $(x).presecondrun
-$(x).presecondrun: $(x).firstrun
+$(x).presecondrun: $(x).firstrun setup.ss summary.ss tspl.bst
 	cat tspl.aux >> $x.aux
 	cat tspl.rfm >> $x.rfm
 	echo '(summary-make "$x")' | $(Scheme) setup.ss summary.ss
@@ -135,7 +162,7 @@ in.hidx: ${TSPL}/out.hidx
 	sed -e 's;"\(.*\)\.html#;"http://scheme.com/${TSPL}/\1.html#;' ${TSPL}/out.hidx | \
          sed -e 's/"")$$/"t")/' > in.hidx
 
-$(texsrc): tspl4-prep.stex priminfo.ss ../s/primdata.ss
+$(texsrc): tspl4-prep.stex priminfo.ss primdata.ss
 
 checklibs: $(x).thirdrun
 	sort libsrecorded | uniq > libsrecorded.sort

racket/src/ChezScheme/s/mkheader.ss

@@ -383,7 +383,14 @@
         (export "ptr" "Sunsigned32" (format "(~a)" (constant typedef-u32)))
         (export "ptr" "Sinteger64" (format "(~a)" (constant typedef-i64)))
         (export "ptr" "Sunsigned64" (format "(~a)" (constant typedef-u64)))
-  
+
+        (nl) (comment "Records")
+        (defref Srecord_uniform_ref record data)
+        (export "ptr" "Srecord_type" "(ptr)")
+        (export "ptr" "Srecord_type_parent" "(ptr)")
+        (export "int" "Srecord_type_uniformp" "(ptr)")
+        (export "uptr" "Srecord_type_size" "(ptr)")
+
         (nl) (comment "Miscellaneous")
         (export "ptr" "Stop_level_value" "(ptr)")
         (export "void" "Sset_top_level_value" "(ptr, ptr)")

racket/src/cs/c/api.h

@@ -24,4 +24,8 @@ RACKET_API_EXTERN void racket_embedded_load_bytes(const char *code, uptr len, in
 RACKET_API_EXTERN void racket_embedded_load_file(const char *path, int as_predefined);
 RACKET_API_EXTERN void racket_embedded_load_file_region(const char *path, uptr start, uptr end, int as_predefined);
 
+RACKET_API_EXTERN void *racket_cpointer_address(ptr cptr);
+RACKET_API_EXTERN void *racket_cpointer_base_address(ptr cptr);
+RACKET_API_EXTERN iptr racket_cpointer_offset(ptr cptr);
+
 #endif

racket/src/cs/c/boot.c

@@ -281,3 +281,37 @@ void racket_embedded_load_file_region(const char *path, uptr start, uptr end, in
 {
   embedded_load(Sbytevector((char *)path), Sfixnum(start), Sfixnum(end), Sfalse, as_predefined);
 }
+
+void *racket_cpointer_address(ptr cptr) {
+  void *p;
+  iptr offset;
+  p = racket_cpointer_base_address(cptr);
+  offset = racket_cpointer_offset(cptr);
+  return (char *)p + offset;
+}
+
+void *racket_cpointer_base_address(ptr cptr) {
+  if (Srecordp(cptr)) {
+    cptr = Srecord_uniform_ref(cptr, 0);
+
+    if (Sbytevectorp(cptr))
+      return &Sbytevector_u8_ref(cptr, 0);
+    else if (Svectorp(cptr))
+      return &Svector_ref(cptr, 0);
+    else if (Sfixnump(cptr) || Sbignump(cptr))
+      return TO_VOIDP(Sinteger_value(cptr));
+  }
+
+  return NULL;
+}
+
+iptr racket_cpointer_offset(ptr cptr) {
+  if (Srecordp(cptr)) {
+    if (Srecord_type_parent(Srecord_type(cptr)) != Sfalse) {
+      /* assume that it's a cpointer+offset */
+      return Sinteger_value(Srecord_uniform_ref(cptr, 1));
+    }
+  }
+
+  return 0;
+}