ref: c6597f980b2cc154d807fffe9ed4e8e871319cca
parent: 1773b08f7d3860525f55398bf0de2b14bd0171ac
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Wed Apr 16 22:21:50 EDT 2025
defstruct: always keep a default constructor for vec structs
--- 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*///z6W1000J7021?14W2000;J60q?24W3000J60D?34W4000J60q?44W5000J60D?54IIb<228<230>1_5142224?=5147586518><8>=268@5127288@528=8@51121C60D@C0129C60q@907:2;1528D3T08;S;J70482DQ360q@807:2<51;J404D@4082;3404085;3Z0485DCC08E;3:042=02>52@B08EJ;07:2?51@40858D3:02@0e2@7002Ae283;3\\0483H;3M0483DQ;3:042=2B052;J504838CP;J5048384;J:042C02D52I222E8D18E8H848508@>8?J5148?3G07F02G8?2H8JPe15252@30q42I2Je18F3{02K8F2Le28D3E02M2N2Le22O8Ge2e3@V02P2Q2R2LEe32O0e2e32S2T2Le27U8A51e3e3e3@30qe18H3\xae08D3t02J2K8H2I1e12O2Ve2e12O0e2e12W7X2Yq8B535154e32Z2O0e22O2[e28H<e4e3@d02K8H8E3K02I29e12O8Ee2e12W8B5153@@02I29e12W8B5152e3@30qe12W7\\2]8<8C8B8I8D8F8G8E0>98A525164:" #(#(:constructor+ "no help for " #fn(str) " " "" " (undefined)")) defstruct #fn("O10005000*///z6W1000J7021?14W2000;J60q?24W3000J60D?34W4000J60q?44W5000J60D?54IIb<228<230>1_5142224?=5147586518><8>=268@5127288@528=8@51121C60D@C0129C60q@907:2;1528D3T08;S;J70482DQ360q@807:2<51;J404D@4082;36040e185;3Z0485DCC08E;3:042=02>52@B08E37085@807:2?518D3:02@0e2@7002Ae283DQ83;3\\0483H;3M0483DQ;3:042=2B052;J504838CP;J5048384;J:042C02D52II222E8D18E8I848508@>8?K514222F8D108B8E>5?L5148?3G07G02H8?2I8KPe15252@30q42J2Ke18F3{02L8F2Me28D3E02N2O2Me22P8Ge2e3@V02Q2R2S2MEe32P0e2e32T2U2Me27V8A51e3e3e3@30qe18I3C02L8I<8L8I=51e3@30qe18D3U02W2P0e22P2Xe28H3808I<@808L8C51e4@30qe12Y7Z2[8<8C8B8J8D8F8G8E0>98A525165:" #(#(: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)@@ -89,11 +89,12 @@
error "invalid slot name: " #fn(list*) #fn(sym) #\:))) tokw) separate-doc-from-body #fn(length)
#fn(map) #fn("n10B3500<:0:") list arg-error "invalid struct type: " "structs of type `vec` are always :named T"#fn(sym) #\? "predicate not possible unless the struct is :named T" struct … "make-" #fn(str) "-"
- #fn("n12002152853=0220E8553@300853<02208552@40232486252627e1A360q@7028Fe292360q@802992e2933<093DC60q@802:93e2943;02;94e2@30q95S;J80495DQS;39042<95e29697P578764:" #(#fn(str-find)+ #fn("n12002152853=0220E8553@300853<02208552@40232486252627e1A360q@7028Fe292360q@702992P933<093DC60q@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 equal?
- type-of quote and eq? aref = length 1+ %struct% #fn(copy-list) foldr #fn("n2202105201PP:" #(#fn(sym)- ":")) putprop constructor map-int #fn("n1A<70F05251709205221938652943<0r20i2KM@30022872324q25e3e3953K0269523e2272896e223e3e3@30q292:25e22;2397360K@30E88Me37<2=85523O02>2?2@2886e22A2898e22Be6e2@G02C2397360K@30E88M24e4e4e4:" #(list-ref+ :conc-name :predicate) fmt) #fn("n1200A3Y021Fe12223e2e12292e2e1247526q93535154@f0943S02127e12122e124945152e124935153@@02127e124935152e3:" #(λ+ #fn(nconc) quote %struct% #fn(copy-list) foldr #fn("n2202105201PP:" #(#fn(sym) ":")) list) make-constructor)+ sym-set-doc #fn(append) :doc-fmt #fn(nconc) begin def s equal? type-of quote and eq? aref =
+ length 1+ putprop constructor #fn(copy-list) map-int #fn("n1A<70F05251709205221938652943<0r20i2KM@30022872324q25e3e3953K0269523e2272896e223e3e3@30q292:25e22;2397360K@30E88Me37<2=85523O02>2?2@2886e22A2898e22Be6e2@G02C2397360K@30E88M24e4e4e4:" #(list-ref#fn(sym) def s v v-supplied? unless type-error quote if not 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--- a/src/system.sl
+++ b/src/system.sl
@@ -1148,19 +1148,20 @@
(arg-error "structs of type `vec` are always :named T"))
T)
named)
- name)]
+ (list name))]
; struct's predicate name
[is? (and predicate
(if (eq? predicate T)
(and named (sym name #\?)) ; FIXME(sigrid): need a "is set?" third arg
- (if (not named)
- (arg-error "predicate not possible unless the struct is :named T")
- predicate)))]
+ (if named
+ predicate
+ (arg-error "predicate not possible unless the struct is :named T"))))]
; what (type-of ...) should return if predicate is defined
[type-of-value (if isvec
(list 'struct name)
(list name '…))]
; constructor name and arguments
+ [constructor-default? (eq? constructor T)]
[constructor
(and constructor ; NIL means none to make at all
(or (and (atom? constructor) ; a single argument
@@ -1182,7 +1183,7 @@
(unless isvec
(list :type type))
(unless named
- (list :named named))
+ (cons :named named))
(unless (and constructor (eq? constructor T))
(list :constructor constructor))
(when conc-name
@@ -1192,6 +1193,16 @@
(list :predicate predicate))
(cons name slots))
tl)))
+ (def (make-constructor args)
+ `(λ ,args
+ ,(if isvec
+ `(,type '%struct%
+ ',name
+ ,@(foldr (λ (s z) (cons (sym ":" s) (cons s z)))
+ NIL
+ slots-car))
+ (if named `(list ',@named ,@slots-car)
+ `(list ,@slots-car)))))
(when docs
(sym-set-doc name (append docs (list (cons :doc-fmt fmt)))))
`(begin
@@ -1204,18 +1215,16 @@
[= (length s) ,(1+ num-slots)]))))
; constructor
,(when constructor
- (if isvec
- `(begin
- (def ,constructor
- (,type '%struct%
- ',name
- ,@(foldr (λ (s z) (cons (sym ":" s) (cons s z)))
- NIL
- slots-car)))
- (putprop ',name 'constructor ,(car constructor)))
- `(def ,constructor
- ,(if named `(list ',named ,@slots-car)
- `(list ,@slots-car)))))
+ `(def ,(car constructor) ,(make-constructor (cdr constructor))))
+
+ ; default constructor
+ ,(when isvec
+ `(putprop ',name
+ 'constructor
+ ,(if constructor-default?
+ (car constructor)
+ (make-constructor slots-kw))))
+
; accessor per slot
,@(map-int (λ (i) [let* {[opts (slot-opts (list-ref slots-kw i))][fld (list-ref slots-car i)]
--- a/test/defstruct.sl
+++ b/test/defstruct.sl
@@ -62,3 +62,32 @@
(assert (= (sln-c lx) 3))
(sl-a lx lx)
(assert (eq? (sl-a lx) lx))
+
+(defstruct ok :named T a)
+(assert-fail (macroexpand '(defstruct fail :named NIL a)))
+
+; custom constructor - renamed
+(defstruct scc :constructor scc_ a b (c 3))
+(assert (not (bound? 'make-scc)))
+(assert (bound? 'scc_))
+(def ccx (scc_ :a 1 :b 2))
+(assert (= (scc-a ccx) 1))
+(assert (= (scc-b ccx) 2))
+(assert (= (scc-c ccx) 3))
+(let ((b (buffer))) ; able to read the #S(...) form with a renamed constructor
+ (write ccx b)
+ (io-seek b 0)
+ (assert (equal? (read b) ccx)))
+
+; custom constructor - no keywords
+(defstruct scc2 :constructor (scc2 a b c) a b (c 3))
+(assert (not (bound? 'make-scc2)))
+(assert (bound? 'scc2))
+(def cc2x (scc2 1 2 4))
+(assert (= (scc2-a cc2x) 1))
+(assert (= (scc2-b cc2x) 2))
+(assert (= (scc2-c cc2x) 4))
+(let ((b (buffer))) ; able to read the #S(...) form with a custom constructor
+ (write cc2x b)
+ (io-seek b 0)
+ (assert (equal? (read b) cc2x)))