commit 0b8e9e9a5fea1e7a28489feccb4f6b827be64292
parent c576c830a889502cf3a6ee0dfb510cbb21a02a26
Author: Ryan Sepassi <rsepassi@gmail.com>
Date: Sat, 25 Apr 2026 15:06:14 -0700
scheme1: match record api to r7rs
Diffstat:
2 files changed, 13 insertions(+), 168 deletions(-)
diff --git a/scheme1/scheme1.P1pp b/scheme1/scheme1.P1pp
@@ -2464,38 +2464,6 @@
%ret
%endscope
-# (record? x) -- #t iff x is HEAP-tagged with HDR.REC.
-:prim_recordq_entry
-%scope prim_recordq
- %car(t0, a0)
- %tagof(t1, t0)
- %li(t2, %TAG.HEAP)
- %li(a0, %imm_val(%IMM.FALSE))
- %bne(t1, t2, &::end)
- %hdr_type(t1, t0)
- %li(t2, %HDR.REC)
- %bne(t1, t2, &::end)
- %li(a0, %imm_val(%IMM.TRUE))
- ::end
- %ret
-%endscope
-
-# (record-type? x) -- #t iff x is HEAP-tagged with HDR.TD.
-:prim_record_typeq_entry
-%scope prim_record_typeq
- %car(t0, a0)
- %tagof(t1, t0)
- %li(t2, %TAG.HEAP)
- %li(a0, %imm_val(%IMM.FALSE))
- %bne(t1, t2, &::end)
- %hdr_type(t1, t0)
- %li(t2, %HDR.TD)
- %bne(t1, t2, &::end)
- %li(a0, %imm_val(%IMM.TRUE))
- ::end
- %ret
-%endscope
-
:prim_zeroq_entry
%scope prim_zeroq
%car(t0, a0)
@@ -3299,111 +3267,14 @@
%st(t1, a0, 13)
})
-# (%make-record-td name nfields) -- args = (name nfields).
-%fn(prim_make_record_td_entry, 16, {
- %st(a0, sp, 0)
- %li(a0, 24)
- %li(a1, %HDR.TD)
- %call(&alloc_hdr)
-
- %ld(t0, sp, 0)
- %car(t1, t0) ; name sym
- %st(t1, a0, 5)
- %cdr(t0, t0)
- %car(t0, t0)
- %sari(t0, t0, 3) ; raw nfields
- %st(t0, a0, 13)
-})
-
-# (%make-record td f0 f1 ...) -- args = (td . fields).
-%fn(prim_make_record_entry, 24, {
- %st(a0, sp, 0)
-
- # Count fields = length(args) - 1.
- %cdr(a0, a0)
- %call(&list_length)
- %shli(a0, a0, 3)
- %addi(a0, a0, 16)
- %li(a1, %HDR.REC)
- %call(&alloc_hdr)
- %st(a0, sp, 8)
-
- # td (offset +5) = car(args)
- %ld(t0, sp, 0)
- %car(t0, t0)
- %st(t0, a0, 5)
-
- # Walk fields, filling +13, +21, ...
- %ld(t0, sp, 0)
- %cdr(t0, t0)
- %addi(t1, a0, 13)
-
- ::fill_loop
- %if_nil(t2, t0, &::fill_done)
- %car(t2, t0)
- %st(t2, t1, 0)
- %addi(t1, t1, 8)
- %cdr(t0, t0)
- %b(&::fill_loop)
-
- ::fill_done
- %ld(a0, sp, 8)
-})
-
-# (%record-ref rec idx)
-:prim_record_ref_entry
- %car(t0, a0) ; rec
- %cdr(t1, a0)
- %car(t1, t1) ; tagged idx (= idx << 3)
- %addi(t1, t1, 13)
- %add(t1, t1, t0)
- %ld(a0, t1, 0)
- %ret
-
-# (%record-set! rec idx val)
-:prim_record_set_entry
-%scope prim_record_set
- %car(t0, a0)
- %cdr(t1, a0)
- %car(t2, t1) ; tagged idx
- %cdr(t1, t1)
- %car(t1, t1) ; val
- %addi(t2, t2, 13)
- %add(t2, t2, t0)
- %st(t1, t2, 0)
- %li(a0, %imm_val(%IMM.UNSPEC))
- %ret
-%endscope
-
-# (%record-is-a? rec td)
-:prim_record_is_a_entry
-%scope prim_record_is_a
- %car(t0, a0)
- %cdr(t1, a0)
- %car(t1, t1)
- %tagof(t2, t0)
- %li(a0, %imm_val(%IMM.FALSE))
- %li(a2, %TAG.HEAP)
- %bne(t2, a2, &::end)
- %hdr_type(t2, t0)
- %li(a2, %HDR.REC)
- %bne(t2, a2, &::end)
- %ld(t2, t0, 5)
- %bne(t2, t1, &::end)
- %li(a0, %imm_val(%IMM.TRUE))
- ::end
- %ret
-%endscope
-
-# (%record-td rec) -- returns rec's TD pointer.
-:prim_record_td_entry
- %car(t0, a0)
- %ld(a0, t0, 5)
- %ret
-
# Parameterized PRIM entries used by define-record-type. Each receives
# args in a0 and the prim itself in a1; the prim's data slot (offset 13
-# from tagged) holds either the TD or a tagged field index.
+# from tagged) holds either the TD or a tagged field index. The
+# constructor inlines record allocation; predicate / accessor / mutator
+# inline what would otherwise be %record-is-a? / %record-ref /
+# %record-set! bodies. None of these primitives are exposed at the
+# user level — R7RS define-record-type binds only ctor / pred /
+# accessor / mutator names.
# ctor: prim.data = TD (HEAP); args = (f0 f1 ...). Inlines the
# %make-record body so we don't have to cons (TD . args) first.
@@ -4489,8 +4360,6 @@
:name_booleanq "boolean?"
:name_integerq "integer?"
:name_procedureq "procedure?"
-:name_recordq "record?"
-:name_record_typeq "record-type?"
:name_zeroq "zero?"
:name_not "not"
:name_eqq "eq?"
@@ -4516,12 +4385,6 @@
:name_bv_copy "bytevector-copy"
:name_bv_copy_b "bytevector-copy!"
:name_bv_eq "bytevector=?"
-:name_make_rt "%make-record-td"
-:name_make_rec "%make-record"
-:name_record_ref "%record-ref"
-:name_record_set "%record-set!"
-:name_record_isa "%record-is-a?"
-:name_record_td "%record-td"
:name_sys_read "sys-read"
:name_sys_write "sys-write"
@@ -4576,8 +4439,6 @@
&name_booleanq %(0) $(8) &prim_booleanq_entry %(0)
&name_integerq %(0) $(8) &prim_integerq_entry %(0)
&name_procedureq %(0) $(10) &prim_procedureq_entry %(0)
-&name_recordq %(0) $(7) &prim_recordq_entry %(0)
-&name_record_typeq %(0) $(12) &prim_record_typeq_entry %(0)
&name_zeroq %(0) $(5) &prim_zeroq_entry %(0)
&name_not %(0) $(3) &prim_not_entry %(0)
&name_eqq %(0) $(3) &prim_eqq_entry %(0)
@@ -4603,12 +4464,6 @@
&name_bv_copy %(0) $(15) &prim_bv_copy_entry %(0)
&name_bv_copy_b %(0) $(16) &prim_bv_copy_bang_entry %(0)
&name_bv_eq %(0) $(12) &prim_bytevector_eq_entry %(0)
-&name_make_rt %(0) $(15) &prim_make_record_td_entry %(0)
-&name_make_rec %(0) $(12) &prim_make_record_entry %(0)
-&name_record_ref %(0) $(11) &prim_record_ref_entry %(0)
-&name_record_set %(0) $(12) &prim_record_set_entry %(0)
-&name_record_isa %(0) $(13) &prim_record_is_a_entry %(0)
-&name_record_td %(0) $(10) &prim_record_td_entry %(0)
&name_sys_read %(0) $(8) &prim_sys_read_entry %(0)
&name_sys_write %(0) $(9) &prim_sys_write_entry %(0)
&name_sys_close %(0) $(9) &prim_sys_close_entry %(0)
@@ -4640,6 +4495,8 @@
:msg_unterm_string "scheme1: unterminated string literal" '0a' '00'
:msg_bad_escape "scheme1: bad string escape" '0a' '00'
:msg_bad_char "scheme1: bad #\\ character literal" '0a' '00'
+:msg_bad_number "scheme1: bad number literal" '0a' '00'
+:msg_bad_ident "scheme1: bad identifier" '0a' '00'
:name_ch_tab "tab"
:name_ch_null "null"
diff --git a/tests/scheme1/70-type-predicates.scm b/tests/scheme1/70-type-predicates.scm
@@ -1,9 +1,8 @@
-; boolean?, integer?, procedure?, record?, record-type? — tag-checking
-; predicates. TDs are reached via %record-td (no surface name binding).
-
-(define-record-type point (make-point x y) point? (x point-x) (y point-y))
-(define p (make-point 1 2))
-(define td (%record-td p))
+; boolean?, integer?, procedure? — tag-checking predicates.
+;
+; Per R7RS-small, define-record-type does not expose the type
+; descriptor or any cross-type record predicate. record? /
+; record-type? are not part of the user-facing API.
; boolean? — only #t and #f
(if (boolean? #t) 0 (sys-exit 1))
@@ -28,15 +27,4 @@
(if (not (procedure? 'car)) 0 (sys-exit 16))
(if (not (procedure? '())) 0 (sys-exit 17))
-; record? — only HDR.REC heap objects
-(if (record? p) 0 (sys-exit 18))
-(if (not (record? td)) 0 (sys-exit 19))
-(if (not (record? 1)) 0 (sys-exit 20))
-(if (not (record? "abc")) 0 (sys-exit 21))
-
-; record-type? — only HDR.TD heap objects
-(if (record-type? td) 0 (sys-exit 22))
-(if (not (record-type? p)) 0 (sys-exit 23))
-(if (not (record-type? 0)) 0 (sys-exit 24))
-
(sys-exit 0)
