ref: dc6306e051c74dfa60865db0cc0bbf11b37aaecf
dir: /test/defstruct.sl/
(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))
(assert (bound? 'sa?))
(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) 3))
(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))
(sa-c ax 4)
(sa-b ax 5)
(sa-a ax 6)
(assert (= (sa-a ax) 6))
(assert (= (sa-b ax) 5))
(assert (= (sa-c ax) 4))
(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))
(sl-a lx lx)
(assert (eq? (sl-a lx) lx))
; 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))
(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_))
(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))
(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)))
; no predicate
(defstruct snp :predicate NIL x)
(assert (not (bound? 'snp?)))
(def snpv (make-snp :x 1))
(assert (= (snp-x snpv) 1))
(snp-x snpv 0)
(assert (= (snp-x snpv) 0))
; renamed predicate
(defstruct scp :predicate isit? x)
(assert (not (bound? 'scp?)))
(assert (bound? 'isit?))
(def scpv (make-scp :x 1))
(assert (isit? scpv))
(assert (not (isit? snpv)))
(assert (= (scp-x scpv) 1))
(snp-x scpv 0)
(assert (= (scp-x scpv) 0))
; unnamed, list - can't ask fot a predicate
(assert-fail (macroexpand '(defstruct fail :type list :predicate T a)))
(assert-fail (macroexpand '(defstruct fail :type list :predicate fail? a)))
; named list, no predicate
(defstruct lnp :named T :predicate NIL a)
(assert (not (bound? 'lnp?)))
(def lnpv (make-lnp :a 1))
(assert (= (lnp-a lnpv) 1))
; named list, renamed predicate
(defstruct lcp :named T :predicate eh? a)
(assert (not (bound? 'lcp?)))
(assert (bound? 'eh?))
(def lcpv (make-lcp :a 1))
(assert (= (lcp-a lcpv) 1))
(assert (eh? lcpv))
(assert (not (eh? lnpv)))
; renamed conc-name
(defstruct scn :conc-name scn/ a b)
(assert (bound? 'scn/a))
(assert (not (bound? 'scn-a)))
(assert (bound? 'scn/b))
(assert (not (bound? 'scn-b)))
(def scnv (make-scn :a 1 :b 2))
(assert (= (scn/a scnv) 1))
(assert (= (scn/b scnv) 2))
; nil conc-name
(defstruct sncn :conc-name NIL aaa bbb)
(assert (bound? 'aaa))
(assert (not (bound? 'sncn-a)))
(assert (bound? 'bbb))
(assert (not (bound? 'sncn-b)))
(def sncnv (make-sncn :aaa 2 :bbb 3))
(assert (= (aaa sncnv) 2))
(assert (= (bbb sncnv) 3))
; read-only slots
(defstruct sro (a NIL :read-only T) b)
(def srov (make-sro :a 1 :b 2))
(assert-fail (sro-a srov 2))
(assert (= (sro-a srov) 1))
(sro-b srov 1)
(assert (= (sro-b srov) 1))