ref: 1905d7b14ebe2c8020b05d1a490bf0b6c6dbdb38
parent: b0802304ffe9bbfbb514c19fef9d721501604e7b
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Sun Apr 13 22:53:54 EDT 2025
defstruct: properly typed structures and printing/reading Use #S(..) syntax (as in CL). Use extra bits in vector size to define the "type" of the vector.
--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -78,7 +78,7 @@
#fn(get) *properties* :kind *doc-extra* filter #fn("n10<20Q:" #(:doc-fmt)) #fn("n10<20Q:" #(:doc-see)) princ foldl #fn("n20=161:") newline "See also:" #fn("n1A<0=700=21522263:" #(getprop *formals-list* " ")) "Members:" #fn("n1A<070021522263:" #(getprop *formals-list* " ")) void- "no help for " #fn(str) " " "" " (undefined)")) defstruct #fn("O10005000*///W1000J7071?14W2000J60q?24W3000J60D?34W4000J60q?44W5000J60D?54z6IIb;228;230>1_5142224?<5147586518=<8==268?5127288?528<8?512912:5285;3E0485DC<02902:52@408583;3\\0483H;3M0483DQ;3:04292;052;J504838BP;J5048382;J704171Q;3404084;J:042<02=52I222>18F8E848508?>7?H5148>3G07?02@8>2A8HPe15252@30q42B2Ce18D3\x8d02D8D2Ee22F8C2Ee22G2H2I8Fe2e22J2K2EEe32I0e2e3e32L2M2Ee22N360K@30E12OC708@@80r28@i2Me3e4e3@30qe18E3b02D8E2B1e12I8Fe2e12P12OC708A@;07Q2Rq8A535153e3@30qe12P7S2T8;8B8A8G18D8F0>88@525164:" #(#(:constructor+ "no help for " #fn(str) " " "" " (undefined)")) defstruct #fn("O10005000*///W1000J7071?14W2000J60q?24W3000J60D?34W4000J60q?44W5000J60D?54z6IIb;228;230>1_5142224?<5147586518=<8==268?5127288?528<8?51171Q85;3E0485DC<02902:52@408583;3\\0483H;3M0483DQ;3:04292;052;J504838BP;J5048382;J704171Q;3404084;J:042<02=52I222>18F8E848508?>7?H5148>3G07?02@8>2A8HPe15252@30q42B2Ce18D3\x9902D8D2Ee22F2G2H2Ee22I2J0e2e2e32K2L2I8Fe2e22M2N2EEe32I0e2e3e32O2P2Ee22Q360K@30E8C3;0r28@i2@408@Me3e4e3@30qe18E3\x8602C2D8E2B1e12R8C;37042Se1512I8Fe2e12R8C3>07T2Uq8A53@408A5154e32V2I0e22I2We28E<e4e3@30qe12R7X2Y8;8B8A8G8C8D8F0>88@525164:" #(#(:constructor2 :predicate 4 NIL NIL :type 0 :named 1 :conc-name 3 NIL NIL) vec #0#
#fn("n17005121220A>28552485:" #(cddr #fn(for-each) #fn("n17002152340q:722324A<25F2605661:" #(member (:read-only)@@ -88,11 +88,12 @@
error "invalid slot name: " #fn(list*) #fn(sym) #\:))) tokw) separate-doc-from-body #fn(length)
#fn(map) #fn("n10B3500<:0:") #fn(sym) #\? "make-" #fn(str) "-" #fn("n12002152853=0220E8553@300853<02208552@40232486252627e1A78C60q@7029Ae2F360q@702:Fe292360q@802;92e2933;02<93e2@30q94S;J80494DQS;39042=94e29596P578764:" #(#fn(str-find)"\n\n" #fn(str-sub) "" #fn(str) "\n\n " #fn(append) defstruct vec :type :named :constructor
- :conc-name :predicate) fmt) sym-set-doc #fn(append) :doc-fmt #fn(nconc) begin def s and or not
- quote eq? aref = length ,named list #fn(copy-list) foldr #fn("n2202105201PP:" #(#fn(sym) ":"))- map-int #fn("n1A<70F052517092052219386529422C600@90r20i2KM23872425Ie2e3953?0269524e2e2@30q272825e2292496360K@30E88Me37:2;85523O02<2=2>2?86e22@2?97e22Ae6e2@G02B2496360K@30E88M25e4e4e4:" #(list-ref- #fn(sym) list def s v assert if void? aref member :read-only error str "slot " quote " in struct "
- " is :read-only" aset!)))) bcode:ctable #fn("n1200Ke3:" #(aref)) with-output-to #fn("z12021e1220e2e1e12315163:" #(#fn(nconc)+ :conc-name :predicate) fmt) sym-set-doc #fn(append) :doc-fmt #fn(nconc) begin def s and equal?
+ typeof quote struct or not eq? aref = length ,named
+ #fn(copy-list) '%struct% foldr #fn("n2202105201PP:" #(#fn(sym) ":")) putprop constructor map-int+ #fn("n1A<70F05251709205221938652943<0r20i2KM@30022872324Ie2e3953?0259523e2e2@30q262724e2282396360K@30E88Me3792:85523O02;2<2=2>86e22?2>97e22@e6e2@G02A2396360K@30E88M24e4e4e4:" #(list-ref+ #fn(sym) def s v assert if void? aref member :read-only error str "slot " quote " in struct " " is :read-only"
+ aset!)))) bcode:ctable #fn("n1200Ke3:" #(aref)) with-output-to #fn("z12021e1220e2e1e12315163:" #(#fn(nconc) with-bindings *io-out* #fn(copy-list))) catch #fn("n22012122e123242522e2262722e22829e2e3262:22e20e3e42;22e22<22e2e4e3e3:" #(trycatch λ #:g429 if and cons? eq? car quote thrown-value cadr caddr raise)) let* #fn("z10H3E02021e1qe12215153e1:2021e173051e1e1220=B3H02024e10=e12215153e1@301515375051e2:" #(#fn(nconc) λ #fn(copy-list) caar let* cadar)) letrec #fn("z1202021e12273052e122240522515154e1227605262:" #(#fn(nconc)@@ -112,8 +113,8 @@
<= #fn("z1Ib6862086>1_486<^10162:" #(#fn("n21S;JL041<0L2;J5040V340q:A<1<1=62:")) <=) > #fn("z1Ib6862086>1_486<^10162:" #(#fn("n21S;JE041<0L2;3;04A<1<1=62:")) >) >= #fn("z1Ib6862086>1_486<^10162:" #(#fn("n21S;JL0401<L2;J5040V340q:A<1<1=62:")) >=)Instructions #table(call.l #u8(81) trycatch #u8(75) loadg.l #u8(68) aref2 #u8(23) box #u8(50) cadr #u8(36) argc #u8(62) setg #u8(71) load0 #u8(21) nan? #u8(38) fixnum? #u8(41) loadc0 #u8(17) loada0 #u8(0) div0 #u8(59) keyargs #u8(31) call #u8(5) loada.l #u8(69) num? #u8(40) sub2 #u8(78) add2 #u8(29) loadc.l #u8(70) loadc #u8(9) builtin? #u8(43) set-car! #u8(47) vargc.l #u8(80) vec #u8(63) ret #u8(10) loadi8 #u8(66) tapply #u8(77) loadvoid #u8(25) loada1 #u8(1) shift #u8(46) atom? #u8(24) cdr #u8(13) brne.l #u8(83) / #u8(58) equal? #u8(52) apply #u8(54) dup #u8(11) loadt #u8(20) jmp.l #u8(48) = #u8(60) not #u8(35) set-cdr! #u8(30) fn? #u8(44) eq? #u8(33) * #u8(57) load1 #u8(27) bound? #u8(42) box.l #u8(86) < #u8(28) brnn.l #u8(84) jmp #u8(16) loadv #u8(2) for #u8(76) dummy_eof #u8(88) + #u8(55) brne #u8(19) argc.l #u8(79) compare #u8(61) brn #u8(3) neg #u8(37) loadv.l #u8(67) vargc #u8(74) brbound #u8(39) loadc1 #u8(22) setg.l #u8(72) cons? #u8(18) aref #u8(85) sym? #u8(34) aset! #u8(64) car #u8(12) cons #u8(32) tcall.l #u8(82) - #u8(56) brn.l #u8(49) optargs #u8(87) closure #u8(14) vec? #u8(45) pop #u8(4) eqv? #u8(51) list #u8(53) seta #u8(15) seta.l #u8(73) brnn #u8(26) loadnil #u8(65) loadg #u8(7) loada #u8(8) tcall #u8(6))
- __finish #fn("n120210>17262:" #(#fn(for-each)- #fn("n10A61:") *exit-hooks*) __finish)+ S #fn("z170021521}2:" #(getprop constructor) S) __finish+ #fn("n120210>17262:" #(#fn(for-each) #fn("n10A61:") *exit-hooks*) __finish) __init_globals #fn("n07021d37022@402384w4^147025d;350426;J50427w8429w:4qw;47<w=47>w?47@wA:" #(*os-name* "macos" #fn("n0702161:" #(princ "\e[0m\e[1m#;> \e[0m")) #fn("n0702161:" #(princ "#;> ")) *prompt* "dos" "\\" "/" *directory-separator* "\n" *linefeed*--- a/src/cvalues.c
+++ b/src/cvalues.c
@@ -650,8 +650,10 @@
sl_v v = args[0];
argcount(nargs, 1);
switch(tag(v)){- case TAG_CONS: return sl_conssym;
- case TAG_FIXNUM: return sl_fixnumsym;
+ case TAG_CONS:
+ return sl_conssym;
+ case TAG_FIXNUM:
+ return sl_fixnumsym;
case TAG_UNBOXED:
if(isubnum(v))
return unboxedtypesyms[ubnumtype(v)];
@@ -658,8 +660,12 @@
if(isrune(v))
return sl_runesym;
abort();
- case TAG_SYM: return sl_symsym;
- case TAG_VEC:return sl_vecsym;
+ case TAG_SYM:
+ return sl_symsym;
+ case TAG_VEC:
+ if(isstruct(v))
+ return mk_list2(sl_structsym, vec_elt(v, 0));
+ return sl_vecsym;
case TAG_FN:
if(v == sl_t)
return sl_booleansym;
--- a/src/print.c
+++ b/src/print.c
@@ -491,7 +491,10 @@
if(!sl.print_princ && print_circle_prefix(f, v))
break;
if(isvec(v)){- outs(f, "#(");+ if(isstruct(v))
+ outs(f, "#S(");+ else
+ outs(f, "#(");int newindent = sl.hpos, est;
int i, sz = vec_size(v);
for(i = 0; i < sz; i++){--- a/src/read.c
+++ b/src/read.c
@@ -437,7 +437,7 @@
}
take(ctx);
if(i > 0)
- vec_setsize(v, i);
+ vec_setsize(v, i, 0);
return POP();
}
--- a/src/sl.c
+++ b/src/sl.c
@@ -20,7 +20,7 @@
sl_v sl_vtabsym, sl_pagesym, sl_returnsym, sl_escsym, sl_spacesym, sl_deletesym;
sl_v sl_errio, sl_errparse, sl_errtype, sl_errarg, sl_errmem, sl_errconst;
sl_v sl_errdiv0, sl_errbounds, sl_err, sl_errkey, sl_errunbound, sl_erroom;
-sl_v sl_emptyvec, sl_emptystr;
+sl_v sl_emptyvec, sl_emptystr, sl_vecstructsym, sl_structsym;
sl_v sl_printwidthsym, sl_printreadablysym, sl_printprettysym, sl_printlengthsym;
sl_v sl_printlevelsym;
@@ -363,7 +363,7 @@
return sl_emptyvec;
sl_v *c = alloc_words(n+1);
sl_v v = tagptr(c, TAG_VEC);
- vec_setsize(v, n);
+ vec_setsize(v, n, 0);
if(init){for(usize i = 0; i < n; i++)
vec_elt(v, i) = sl_void;
@@ -439,7 +439,7 @@
forward(v, nc);
}else{nc = tagptr(alloc_words(sz+1), TAG_VEC);
- vec_setsize(nc, sz);
+ vec_setsize(nc, sz, 0);
a = vec_elt(v, 0);
forward(v, nc);
if(sz > 0){@@ -1334,6 +1334,8 @@
sl_spacesym = mk_csym("space"); sl_deletesym = mk_csym("delete"); sl_newlinesym = mk_csym("newline");+ sl_vecstructsym = mk_csym("%struct%");+ sl_structsym = mk_csym("struct"); sl_builtinssym = mk_csym("*builtins*"); set(sl_printprettysym = mk_csym("*print-pretty*"), sl_t);@@ -1349,7 +1351,7 @@
}
sl_emptyvec = tagptr(alloc_words(1), TAG_VEC);
- vec_setsize(sl_emptyvec, 0);
+ vec_setsize(sl_emptyvec, 0, 0);
cvalues_init();
--- a/src/sl.h
+++ b/src/sl.h
@@ -153,10 +153,17 @@
*(sl_v*)ptr(v) = (sl_v)(to) | FWD_BIT; \
}while(0)
+enum {+ VEC_VEC,
+ VEC_STRUCT,
+};
#define vec_elt(v, i) (((sl_v*)ptr(v))[1+(i)])
#define vec_size(v) uintval(vec_elt((v), -1))
-#define vec_setsize(v, n) do{ vec_elt((v), -1) = fixnum(n); }while(0)+#define vec_setsize(v, n, type) do{ vec_elt((v), -1) = fixnum(n) | (type); }while(0)+#define vec_type(v) (vec_elt((v), -1) & ((1<<TAG_BITS)-1))
+#define isstruct(v) (vec_type(v) == VEC_STRUCT)
#define vec_grow_amt(x) ((x)<8 ? 5 : 6*((x)>>3))
+
// functions ending in _ are unsafe, faster versions
#define car_(v) (((sl_cons*)ptr(v))->car)
#define cdr_(v) (((sl_cons*)ptr(v))->cdr)
@@ -446,7 +453,7 @@
extern sl_v sl_iosym, sl_rdsym, sl_wrsym, sl_apsym, sl_crsym, sl_truncsym;
extern sl_v sl_s8sym, sl_u8sym, sl_s16sym, sl_u16sym, sl_s32sym, sl_u32sym;
extern sl_v sl_s64sym, sl_u64sym, sl_p32sym, sl_p64sym, sl_ptrsym, sl_bignumsym;
-extern sl_v sl_utf8sym, sl_runesym, sl_floatsym, sl_doublesym;
+extern sl_v sl_utf8sym, sl_runesym, sl_floatsym, sl_doublesym, sl_vecstructsym, sl_structsym;
extern sl_type *sl_bignumtype, *sl_builtintype;
extern sl_type *sl_s8type, *sl_u8type;
--- a/src/system.sl
+++ b/src/system.sl
@@ -1044,6 +1044,9 @@
;;; structs
+(def (S struct . rest)
+ (apply (getprop struct 'constructor) rest))
+
(defmacro (defstruct name (:type vec)
(:named NIL)
(:constructor T)
@@ -1124,8 +1127,8 @@
; slots, but with default values added (if not set)
; and keywords for names
[slots-kw (tokw slots)]
- ; struct's underlying type's predicate (either vec? or list?)
- [type? (sym type #\?)]
+ ; underlying type, either a vector or list
+ [isvec (eq? type vec)]
; struct's predicate name
[is? (and predicate
(if (eq? predicate T)
@@ -1166,25 +1169,28 @@
`(begin
; predicate
,(when is? `(def (,is? s)
- (and [,type? s]
+ (and [equal? (typeof s) '(struct ,name)]
[or (not ',named) (eq? (aref s 0) ',name)]
- [= (length s) ,(+ (if ',named 1 0) (if (eq? type 'list)
- num-slots
- (* 2 num-slots)))])))
+ [= (length s) ,(+ (if ',named 1 0) (if isvec
+ (* 2 num-slots)
+ num-slots))])))
; constructor
- ,(when constructor `(def ,constructor
- (,type
- ',named
- ,@(if (eq? type 'list)
- slots-car
- (foldr (λ (s z) (cons (sym ":" s) (cons s z)))
- NIL
- slots-car)))))
+ ,(when constructor
+ `(begin (def ,constructor
+ (,type
+ ,@(and isvec (list ''%struct%))
+ ',named
+ ,@(if isvec
+ (foldr (λ (s z) (cons (sym ":" s) (cons s z)))
+ NIL
+ slots-car)
+ slots-car)))
+ (putprop ',name 'constructor ,(car constructor))))
; accessor per slot
,@(map-int (λ (i) [let* {[opts (slot-opts (list-ref slots-kw i))][fld (list-ref slots-car i)]
[fun (sym access fld)]
- [iv (if (eq? type 'list) i (+ (* 2 i) 1))]}
+ [iv (if isvec (+ (* 2 i) 1) i)]}
`(def (,fun s (v #.(void)))
,(when is? `(assert (,is? s)))
(if (void? v)
--- a/src/vm.h
+++ b/src/vm.h
@@ -815,9 +815,23 @@
n = *ip++;
LABEL(apply_vec):;
sl.sp = sp;
- sl_v v = alloc_vec(n, 0);
- memcpy(&vec_elt(v, 0), sp-n, n*sizeof(sl_v));
+ int type = VEC_VEC;
sp -= n;
+ if(*sp == sl_vecstructsym){+ if(n < 2){+ *ipd = (uintptr)ip;
+ arity_error(n, 2);
+ }
+ sp++;
+ n--;
+ type = VEC_STRUCT;
+ }
+ sl_v v = alloc_vec(n, 0);
+ memcpy(&vec_elt(v, 0), sp, n*sizeof(sl_v));
+ if(type != VEC_VEC){+ sp--;
+ vec_setsize(v, vec_size(v), type);
+ }
*sp++ = v;
NEXT_OP;
}
@@ -866,7 +880,7 @@
}
OP(OP_VECP)
- sp[-1] = isvec(sp[-1]) ? sl_t : sl_nil;
+ sp[-1] = isvec(sp[-1]) && !isstruct(sp[-1]) ? sl_t : sl_nil;
NEXT_OP;
OP(OP_TRYCATCH) {