ref: a59bc25e1bee94d891bccf1e6330bb271a20aacb
parent: ef35a8760cdd0e4dfb28c4119fc14f271f0e7090
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Mon Apr 14 16:11:56 EDT 2025
add initial defstruct tests, fix the bugs found, tweak errors thrown
--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -79,7 +79,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*///W1000J7021?14W2000J60q?24W3000J60D?34W4000J60q?44W5000J60D?54z6IIb;228;230>1_5142224?<5147586518=<8==268?5127288?528<8?51121Q85;3E0485DC<02902:52@408583;3\\0483H;3M0483DQ;3:04292;052;J504838BP;J5048382;J5048C;3404084;J:042<02=52I222>8C18F8E848508?>8?H5148>3G07?02@8>2A8HPe15252@30q42B2Ce18D3\x9902D8D2Ee22F2G2H2Ee22I2J0e2e2e32K2L2I8Fe2e22M2N2EEe32I0e2e3e32O2P2Ee28F360K@30E8C3;0r28@i2@408@Me3e4e3@30qe18E3\xae08C3t02C2D8E2B1e12I2Qe2e12I0e2e12R7S2Tq8A535154e32U2I0e22I2Ve28E<e4e3@d02D8E8F3K02B2We12I8Fe2e12R8A5153@@02B2We12R8A5152e3@30qe12R7X2Y8;8B8A8G8C8D8F0>88@525164:" #(#(:constructor+ "no help for " #fn(str) " " "" " (undefined)")) defstruct #fn("O10005000*///W1000J7021?14W2000J60q?24W3000J60D?34W4000J60q?44W5000J60D?54z6IIb;228;230>1_5142224?<5147586518=<8==268?5127288?528<8?51121Q82;J5048C;3404085;3\\0485DCC08D;3:042902:52@D08DJ=02;2<2=52@40858C3:02>0e2@7002?e283;3\\0483H;3M0483DQ;3:04292@052;J504838BP;J5048384;J:042A02B52I222C8C18D8G848508?>8?I5148>3G07D02E8>2F8IPe15252@30q42G2He18E3{02I8E2Je28C3E02K2L2Je22M8Fe2e3@V02N2O2P2JEe32M0e2e32Q2R2Je27S8@51e3e3e3@30qe18G3\xae08C3t02H2I8G2G1e12M2Te2e12M0e2e12U7V2Wq8A535154e32X2M0e22M2Ye28G<e4e3@d02I8G8D3K02G2Ze12M8De2e12U8A5153@@02G2Ze12U8A5152e3@30qe12U7[2\\8;8B8A8H8C8E8F8D0>98@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)@@ -87,13 +87,14 @@
" of struct " ": "))) slot-opts)
#fn("n12021062:" #(#fn(map) #fn("n10B;35040<85;J404085;35040=;J604qe186RS;J9042086513=071228652@30q423242586522087<51390q87P@408762:" #(#fn(keyword?)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@40232486252627e1A360q@7028Fe292360q@802992e293360q@802:93e2943;02;94e2@30q95S;J80495DQS;39042<95e29697P578764:" #(#fn(str-find)+ #fn(map) #fn("n10B3500<:0:") #fn(sym) #\? #fn(raise) arg-error ("predicate not possible unless the struct is :named")+ struct … "make-" #fn(str) "-" #fn("n12002152853=0220E8553@300853<02208552@40232486252627e1A360q@7028Fe292360q@802992e293360q@802:93e2943;02;94e2@30q95S;J80495DQS;39042<95e29697P578764:" #(#fn(str-find)"\n\n" #fn(str-sub) "" #fn(str) "\n\n " #fn(append) defstruct :type :named :constructor
- :conc-name :predicate) fmt) sym-set-doc #fn(append) :doc-fmt #fn(nconc) begin def s and equal?
- type-of quote struct or not eq? aref = length %struct% #fn(copy-list) foldr #fn("n2202105201PP:" #(#fn(sym)- ":")) putprop constructor list 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)+ :conc-name :predicate) fmt) sym-set-doc #fn(append) :doc-fmt #fn(nconc) begin def s equal?
+ type-of quote and eq? aref = length 1+ %struct% #fn(copy-list) foldr #fn("n2202105201PP:" #(#fn(sym)+ ":")) putprop constructor list map-int #fn("n1A<70F05251709205221938652943<0r20i2KM@30022872324Ie2e3953U0259523e226272829e22896e223e4e2e3@30q2:2;24e22<2397360K@30E88Me37=2>85523O02?2@2A2886e22B2898e22Ce6e2@G02D2397360K@30E88M24e4e4e4:" #(list-ref+ #fn(sym) def s v unless raise list quote type-error if void? aref member :read-only error str "slot "
+ " 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)--- a/meson.build
+++ b/meson.build
@@ -394,6 +394,7 @@
test('torture.sl', sl, args: ['-S', '8m', 'torture.sl'], workdir: tests_dir, timeout: -1) test('torus.sl', sl, args: ['torus.sl'], workdir: tests_dir) test('unit.sl', sl, args: ['-S', '1m', 'unittest.sl'], workdir: tests_dir)+test('defstruct.sl', sl, args: ['defstruct.sl'], workdir: tests_dir)bootstrap = find_program(
'bootstrap.sh',
--- a/src/system.sl
+++ b/src/system.sl
@@ -1135,11 +1135,19 @@
[slots-kw (tokw slots)]
; underlying type, either a vector or list
[isvec (eq? type 'vec)]
+ ; should the struct name appear as the first element?
+ [named (and (or named isvec) name)]
; struct's predicate name
[is? (and predicate
(if (eq? predicate T)
- (sym name #\?)
- predicate))]
+ (and named (sym name #\?)) ; FIXME(sigrid): need a "is set?" third arg
+ (if (not named)
+ (raise 'arg-error '("predicate not possible unless the struct is :named"))+ predicate)))]
+ ; what (type-of ...) should return if predicate is defined
+ [type-of-value (if isvec
+ (list 'struct name)
+ (list name '…))]
; constructor name and arguments
[constructor
(and constructor ; NIL means none to make at all
@@ -1149,8 +1157,6 @@
constructor) ; else a custom name
slots-kw))
constructor))] ; anything else means custom name and args
- ; should the struct name appear as the first element?
- [named (and (or named isvec) name)]
; accessor prefix
[access (or conc-name
(str name "-"))]}
@@ -1174,12 +1180,12 @@
(sym-set-doc name (append docs (list (cons :doc-fmt fmt)))))
`(begin
; predicate
- ,(when is? `(def (,is? s)
- (and [equal? (type-of s) '(struct ,name)]
- [or (not ',named) (eq? (aref s 0) ',name)]
- [= (length s) ,(+ (if named 1 0) (if isvec
- (* 2 num-slots)
- num-slots))])))
+ ,(when is?
+ `(def (,is? s)
+ ,(if isvec
+ `(equal? (type-of s) ',type-of-value)
+ `(and [eq? (aref s 0) ',name]
+ [= (length s) ,(1+ num-slots)]))))
; constructor
,(when constructor
(if isvec
@@ -1200,7 +1206,9 @@
[fun (sym access fld)]
[iv (if isvec (+ (* 2 i) 1) i)]}
`(def (,fun s (v #.(void)))
- ,(when is? `(assert (,is? s)))
+ ,(when is?
+ `(unless (,is? s)
+ (raise (list 'type-error ',type-of-value s))))
(if (void? v)
(aref s ,[+ (if named 1 0) iv])
,(if (member :read-only opts)
--- /dev/null
+++ b/test/defstruct.sl
@@ -1,0 +1,54 @@
+(defstruct sa a b (c 3))
+(assert (bound? 'make-sa)) ; default constructor is defined
+(assert (bound? 'sa-a)) ; slot accessors are defined
+(assert (bound? 'sa-b))
+(assert (bound? 'sa-c))
+(def ax (make-sa))
+(assert (sa? ax))
+(assert (not (vec? ax)))
+(assert (not (cons? ax)))
+(assert (equal? (type-of ax) '(struct sa)))
+(assert (not (equal? #('sa :a NIL :b NIL :c 3) ax)))+(assert (not (eqv? #('sa :a NIL :b NIL :c 3) ax)))+(assert (not (sa-a ax))) ; a defaults to NIL
+(assert (not (sa-b ax))) ; so is b
+(assert (= (sa-c ax)))
+(def ax (make-sa :a 1 :b 2))
+(assert (sa? ax))
+(assert (= (sa-a ax) 1))
+(assert (= (sa-b ax) 2))
+(assert (= (sa-c ax) 3))
+(def ax (make-sa :c 0))
+(assert (sa? ax))
+(assert (not (sa-a ax)))
+(assert (not (sa-b ax)))
+(assert (= (sa-c ax) 0))
+
+; same struct, different name
+(defstruct sb a b (c 3))
+(def bx (make-sb))
+(assert (sb? bx))
+(assert (not (sa? bx)))
+(assert (not (vec? bx)))
+(assert (not (cons? bx)))
+(assert (equal? (type-of bx) '(struct sb)))
+
+; struct as a list, NOT named
+(defstruct sl :type list a b (c 3))
+(def lx (make-sl))
+(assert (not (bound? 'sl?))) ; not :named, should not have a predicate
+(assert (cons? lx))
+(assert (length= lx 3)) ; 3 slots, not named by default
+(assert (not (sl-a lx)))
+(assert (not (sl-b lx)))
+(assert (= (sl-c lx) 3))
+
+; struct as a list, named
+(defstruct sln :type list :named T a b (c 3))
+(def lx (make-sln))
+(assert (bound? 'sln?)) ; :named, should have a predicate defined
+(assert (cons? lx))
+(assert (length= lx 4)) ; 4 slots (with the name)
+(assert (not (sln-a lx)))
+(assert (not (sln-b lx)))
+(assert (= (sln-c lx) 3))
--- a/test/mkfile
+++ b/test/mkfile
@@ -1,6 +1,7 @@
TESTS=\
100x100.sl\
unittest.sl\
+ defstruct.sl\
argv.sl\
bench.sl\
exit0.sl\
--- a/test/unittest.sl
+++ b/test/unittest.sl
@@ -775,4 +775,3 @@
`(let ((a# 2)) (list a# ,x)))
(assert (equal? '(1 (2 3)) (f (g 3))))
-
--
⑨