shithub: sl

--- a/boot/sl.boot

+++ b/boot/sl.boot

@@ -20,7 +20,8 @@

   :read-only))

                                                (name (:type 'vec)

                                                      (:named NIL named-supplied) (:constructor T)

-                                                     (:conc-name NIL) (:predicate T) . slots))  compare ((x

+                                                     (:conc-name NIL)

+                                                     (:predicate T predicate-supplied) . slots))  compare ((x

   y))  buffer (NIL)  num? ((v))  add-exit-hook ((fun))  rand-float (NIL)  builtin? ((v))  set-car! ((cell

   new-first))  cons? ((v))  doc-group ((group-name doc))  1+ ((n))  aref ((sequence subscript0 . rest))  zero? ((x))  vec (rest)  >= ((a . rest))  sym? ((v))  void? ((x))  length= ((seq

   n))  positive? ((x))  doc-for ((term . doc))  aset! ((sequence subscripts… new-value))  car ((lst))  <= ((a . rest))  str (term)  cons ((first

@@ -79,7 +80,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;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:" #(#(:constructor

+  "no help for " #fn(str) " " "" " (undefined)"))  defstruct #fn("O10005000*///z6W1000J7021?14W2000;J60q?24W3000J60D?34W4000J60q?44W5000;J60D?54IIb=228=230>1_5142224?>5147586518?<8?=268A5127288A528>8A51121C60D@C0129C60q@907:2;1528E3T08;S;J70482DQ360q@807:2<51;J404D@4082;36040e185DQ;3:042=02>52;J504858G;3L048F3708G@A08<3;07:2?51@30q8E3:02@0e2@7002Ae283DQ83;3\\0483H;3M0483DQ;3:042=2B052;J504838DP;J5048384;J:042C02D52II222E8E18F8K848<8G08A>9?M514222F8E108C8F>5?N5148@3G07G02H8@2I8MPe15252@30q42J2Ke18H3{02L8H2Me28E3E02N2O2Me22P8Ie2e3@V02Q2R2S2MEe32P0e2e32T2U2Me27V8B51e3e3e3@30qe18K3C02L8K<8N8K=51e3@30qe18E3U02W2P0e22P2Xe28J3808K<@808N8D51e4@30qe12Y7Z2[8=8D8C8L8E8H8I8F0>98B525165:" #(#(:constructor

   2 :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,7 +90,7 @@

   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@702992P933<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@30q95;39042<96e29798P578764:" #(#fn(str-find)

   "\n\n" #fn(str-sub) "" #fn(str) "\n\n    " #fn(append) defstruct :type :named :constructor

   :conc-name :predicate) fmt) #fn("n1200A3Y021Fe12223e2e12292e2e1247526q93535154@f0943S02127e12122e124945152e124935153@@02127e124935152e3:" #(λ

   #fn(nconc) quote %struct% #fn(copy-list) foldr #fn("n2202105201PP:" #(#fn(sym) ":")) list) make-constructor)

--- a/src/system.sl

+++ b/src/system.sl

@@ -1064,7 +1064,7 @@

                           (:named NIL named-supplied)

                           (:constructor T)

                           (:conc-name NIL)

-                          (:predicate T)

+                          (:predicate T predicate-supplied)

                      . slots)

   «Defines a structure type with a specific name and slots.

@@ -1155,12 +1155,14 @@

                          named)

                      (list name))]

          ; struct's predicate name

+         [predicate (or (and (eq? predicate T)

+                             (sym name #\?))

+                        predicate)]

          [is? (and predicate

-                   (if (eq? predicate T)

-                       (and named (sym name #\?)) ; FIXME(sigrid): need a "is set?" third arg

-                       (if named

-                           predicate

-                           (arg-error "predicate not possible unless the struct is :named T"))))]

+                   (if named

+                       predicate

+                       (when predicate-supplied

+                         (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)

@@ -1193,8 +1195,7 @@

                        (list :constructor constructor))

                      (when conc-name

                        (list :conc-name conc-name))

-                     (and (or (not predicate)

-                              (not (eq? predicate T)))

+                     (and predicate-supplied

                           (list :predicate predicate))

                      (cons name slots))

              tl)))

--- a/test/defstruct.sl

+++ b/test/defstruct.sl

@@ -3,6 +3,7 @@

 (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)))

@@ -70,6 +71,7 @@

 (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))

@@ -83,6 +85,7 @@

 (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))

@@ -91,3 +94,41 @@

   (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)))