ref: 00a2515e23e2add42f9ac4f73a216649568e74e3
parent: 3a8bdb23e6e77de10f1fcede655dd5324e94a29e
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Thu Apr 17 22:00:39 EDT 2025
defstruct: split the macro into two to capture the form The form is used for the documentation purposes, which is easier to capture using an extra macro rather than trying to rebuild in the same manner manually. Move defstruct docstring to docs.sl
--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -58,11 +58,25 @@
-group . compare)
(:doc-group . builtin)) eqv? ((:doc-group . compare) (:doc-group . builtin)) io? ((:doc-group . io)) eof-object? ((:doc-group . io)) list ((:doc-group . builtin)) apply ((:doc-group . builtin)) help ((:doc-group . doc)) rand-u32 ((:doc-group . rand)) = ((:doc-group . compare)
(:doc-group . builtin)) rand-u64 ((:doc-group . rand)) not ((:doc-group . builtin)) separate-doc-from-body ((:doc-group . doc)) set-cdr! ((:doc-group . list)
-ss)) arg-counts ((:doc-group . builtin)) eq? ((:doc-group . compare)
+ss)) arg-counts ((:doc-group . builtin)) eq? ((:doc-group . compare)
+ (:doc-group . builtin)) getprop ((:doc-group . prop) (:doc-see . putprop)) vm-stats ((:doc-group . vm)) * ((:doc-group . builtin)) putprop ((:doc-group . prop)
p . vm)) * ((:doc-group . builtin)) putprop ((:doc-group . prop)
-ee . getprop)) io->str ((:doc-group . io))))
- *syntax-environment* #table(bcode:nconst #fn("n1200r2e3:" #(aref)) doc-for #fn("z10B86;35040<;J404086;35040=70211225251<863I0232487e22489e22488e2e4:232487e22489e2e3:" #(separate-doc-from-body- #fn(append) (NIL) sym-set-doc quote)) with-input-from #fn("z12021e1220e2e1e12315163:" #(#fn(nconc)+te-doc-from-body
+ #fn(append) (NIL) sym-set-doc quote)) with-input-from #fn("z12021e1220e2e1e12315163:" #(#fn(nconc)+ with-bindings *io-in* #fn(copy-list))) unless #fn("z1200q211Pe4:" #(if begin)) defmacro #fn("z17015186<86=873?0710<870=53@30q42223240<e22526e10=e127885153e3e2:" #(separate-doc-from-body+ sym-set-doc void set-syntax! quote #fn(nconc) λ #fn(copy-list))) time #fn("n1202122e1e2e123024252622e121e32728e5e3e3:" #(let+ #:g446 time-now prog1 princ "Elapsed time: " - " seconds" *linefeed*)) cond #fn("z0Ib520852185>1_51485<061:" #(#0=#fn("z0I:" #() void)+ #fn("n10H340q:0<85<20Q;J80485<DQ3C085=J6085<:2185=P:85=J@02285<A<0=51e3:85T23C\x94074758551513c07675855151278685<e2e12886217975855151PA<0=51e4e3:272:85<e2e1282:7585512:e2A<0=51e4e3:2885<2185=PA<0=51e4:" #(else+ begin or => 1arg-lambda? caddr caadr let if cddr #:g19) cond-clauses->if))) do #fn("z21<2071052207205220230522425268827872829e12:1=51522829e12:82512825e18:52e153e4e3e2e12825e18952e3:" #(#fn(map)+ car cadr #fn("n170051B38071061:0<:" #(cddr caddr)) letrec #:g415 λ if #fn(nconc) begin #fn(copy-list))) assert-fail #fn("z12021220qe32324e113E0252624e2271<e2e3@30De3e3e2:" #(assert+ trycatch begin λ e eq? car quote)) bcode:code #fn("n1200Ee3:" #(aref)) let #fn("z1q0R3B00?641<?041=?1@30q42021e12223052e124151532225052863C0268687e2e186e3@408788P:" #(#fn(nconc)+ λ #fn(map) #fn("n10B3500<:0:") #fn(copy-list) #fn("n10B3500T:7060:" #(void)) letrec)) with-bindings #fn("z12071052207205220230522425e12076888653e12720288687535129242:e12715152242:e127202;8688535152e3e164:" #(#fn(map)+ car cadr #fn("n12060:" #(#fn(gensym))) #fn(nconc) let list #fn(copy-list)+ #fn("n22001e3:" #(set!)) unwind-protect begin #fn("n22001e3:" #(set!)))) %defstruct% #fn("O10005000*///z6W1000J7021?14W2000;J60D?24W3000;J60D?34W4000;J60D?44W5000;J60D?54II22230>1??5142224?@514258651262786528@8651268?8652121C60D@C0128C60q@90792:1528E3B082;J904792;51@;082;35048;;36040e185DQ;3:042<02=52;J504858G;3L048F3708G@A08>3;0792>51@30q8E3:02?0e2@7002@e283DQ83;3\\0483H;3M0483DQ;3:042<2A052;J504838CP;J5048384DQ;3:042B02C52;J50484I222D8E108B8F>5?M5142E2Fe18H3{02G8H2He28E3E02I2J2He22K8Ie2e3@V02L2M2N2HEe32K0e2e32O2P2He27Q8A51e3e3e3@30qe18K3C02G8K<8M8K=51e3@30qe18E3U02R2K0e22K2Se28J3808K<@808M8C51e4@30qe12T7U2V8D8B8L8E8H8I8F0>88A525165:" #(#(:constructor+ 2 :predicate 4 NIL NIL :type 0 :named 1 :conc-name 3 NIL NIL) vec #0#
+ #fn("n10H370q:@30q4207172051f22324850A>38652486:" #((:read-only) assoc-list cddr #fn(for-each)+ #fn("n1700<A52340q:712223F<24922505661:" #(member+ error #fn(str) "invalid option in slot " " of struct " ": "))) slot-opts)
te-doc-from-body
sym-set-doc void set-syntax! quote #fn(nconc) λ #fn(copy-list))) time #fn("n1202122e1e2e123024252622e121e32728e5e3e3:" #(let #:g446 time-now prog1 princ "Elapsed time: " - " seconds" *linefeed*)) cond #fn("z0Ib520852185>1_51485<061:" #(#0=#fn("z0I:" #() void)@@ -77,23 +91,10 @@
8788P:" #(#fn(nconc)
λ #fn(map) #fn("n10B3500<:0:") #fn(copy-list) #fn("n10B3500T:7060:" #(void)) letrec)) bcode:code #fn("n1200Ee3:" #(aref)) make-label #fn("n120e1:" #(gensym)) mark-label #fn("n22002122e21e4:" #(emit quote label)) bcode:cenv #fn("n1200r3e3:" #(aref)) quasiquote #fn("n1700E62:" #(bq-process)) > #fn("z12021e1721510e163:" #(#fn(nconc)-#fn("n1700E62:" #(bq-process)) > #fn("z12021e1721510e163:" #(#fn(nconc)- < reverse)) when #fn("z1200211Pqe4:" #(if begin)) help #fn("O100010003000W1000J60q?14W2000J7071?241;3<0422231520P13;02410e3@3007588265275882752IIIIIb;b<288;29_514288<2:_514282;?=514282<87>1?>514282=??51402>CM02?2@8<>18?2A7B26528=5252@$089;J5048:3\xe3082888:2C154475882D527E2F8@527E2G8@52893H07H7I2J898A535147K50@30q48B3W07K5047H2L5147K5042?2M8;>18B5247K50@30q^1^1^1413c07K5047H2N5147K5042?2O8;>18?2A7B26528>525247K50@30q47P50@g07H2Q13<02R12S52@402T05341JE00R3@00ZJ;07H2U51@30q47K5047P60:" #(#(:print-header- 0) help-print-header #fn(sym) ":doc-" doc getprop *doc* *formals-list* #0#
- #fn("n313?02021820>2162:72504738251474061:" #(#fn(for-each)- #fn("n17050471A51472F0P61:" #(newline princ print))- newline princ print) print-sig)
- #fn("n12002152853;0220E8563:0:" #(#fn(str-find) "\n" #fn(str-sub)) first-line)- #fn("n10B;3B040<20Q;38040T21Q:" #(doc group) doc-group?)- #fn("n10H;3?0470A710225262:" #(member getprop *doc-extra*) doc-extra-term?)- #fn("n27021221>1q0537362:" #(sort #fn(table-foldl)- #fn("n3A051370082P:82:") <) table-keys-filter-sort) groups #fn(for-each)- #fn("n1707105122A<7302452515347560:" #(princ caddr ": " getprop *doc* newline))- #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;J60D?24W3000J60D?34W4000J60D?44W5000;J60D?54II22230>1?=5142224?>5147586518?<8?=268A5127288A528>8A51278=8A52121C60D@C0129C60q@907:2;1528F3B082;J9047:2<51@;082;35048;;36040e185DQ;3:042=02>52;J504858H;3L048G3708H@A08<3;07:2?51@30q8F3:02@0e2@7002Ae283DQ83;3\\0483H;3M0483DQ;3:042=2B052;J504838DP;J5048384DQ;3:042C02D52;J50484II222E8F18G8L848<8H08A>9?N514222F8F108C8G>5?O5148@3G07G02H8@2I8NPe15252@30q42J2Ke18I3{02L8I2Me28F3E02N2O2Me22P8Je2e3@V02Q2R2S2MEe32P0e2e32T2U2Me27V8B51e3e3e3@30qe18L3C02L8L<8O8L=51e3@30qe18F3U02W2P0e22P2Xe28K3808L<@808O8D51e4@30qe12Y7Z2[8E8C8M8F8I8J8G0>88B525165:" #(#(:constructor- 2 :predicate 4 NIL NIL :type 0 :named 1 :conc-name 3 NIL NIL) vec #0#
+#fn("n1700E62:" #(bq-process)) > #fn("z12021e1721510e163:" #(#fn(nconc)+ < reverse)) when #fn("z1200211Pqe4:" #(if begin)) help #fn("O100010003000W1000J60q?14W2000J7071?241;3<0422231520P13;02410e3@3007588265275882752IIIIIb;b<288;29_514288<2:_514282;?=514282<87>1?>514282=??51402>CM02?2@8<>18?2A7B26528=5252@$089;J5048:3\xe3082888:2C154475882D527E2F8@527E2G8@52893H07H7I2J898A535147K50@30q48B3W07K5047H2L5147K5042?2M8;>18B5247K50@30q^1^1^1413c07K5047H2N5147K5042?2O8;>18?2A7B26528>525247K50@30q47P50@g07H2Q13<02R12S52@402T05341JE00R3@00ZJ;07H2U51@30q47K5047P60:" #(#(:print-header+ 0) help-print-header #fn(sym) ":doc-" doc getprop *doc* *formals-list* #0#
+ #fn("n313?02021820>2162:72504738251474061:" #(#fn(for-each)1:" #(member
error #fn(str) "invalid option in slot " " of struct " ": "))) slot-opts)
#fn("n12021062:" #(#fn(map) #fn("n10B;35040<85;J404085;35040=;J604qe186RS;J9042086513=071228652@30q42324865287B38087<@30qe2:" #(#fn(keyword?)--- a/src/docs.sl
+++ b/src/docs.sl
@@ -203,3 +203,66 @@
Examples:
(sym "a" 'b 1) → ab1»)
+
+(doc-for (defstruct name
+ docs…
+ options…
+ (slot-1 DEFAULT)
+ slot-2
+ slot-3))
+ ',sym ',doc ',callvars
+
+(doc-for (defstruct name (:type 'vec)
+ (:named T named-supplied)
+ (:constructor T constructor-supplied)
+ (:conc-name T conc-name-supplied)
+ (:predicate T predicate-supplied)
+ . slots)
+ «Defines a structure type with a specific name and slots.
+
+ The default underlying type is a "named" vector (`:type vec`), where
+ the first element is the name of the structure's type, the rest are
+ the keyworded slot values. A list with slot values alone can be used
+ instead by adding `:type list` option. The list will not contain the
+ name of the struct by default, which can be enabled with `:named T`
+ option.
+
+ As an example, the following declaration
+
+ (defstruct blah "Return stuff." :doc-group stuff a b (c 1 :read-only T))
+
+ Generates the default constructor for a structure of three slots, with
+ the third (`c`) having a specific default value and being read-only.
+
+ (make-blah (:a NIL) (:b NIL) (:c 1))
+ (blah-a s)
+ (blah-b s)
+ (blah-c s)
+
+ Slot's options, if any, should be specified after its default value.
+ Supported options are:
+
+ ; mark the slot as read-only
+ ; its value can be read, but trying to modify it will throw an error
+ … :read-only T
+
+ The constructor can be changed in several ways:
+
+ ; disable the constructor altogether
+ (defstruct blah :constructor NIL a b c)
+ ; only change its name
+ (defstruct blah :constructor blargh a b c)
+ ; rename AND avoid using keywords
+ (defstruct blah :constructor (blah a b c) a b c)
+
+ The option `:conc-name` specifies the slot accessor prefix, which
+ defaults to `structname-`. Prefix can be disabled entirely with
+ `:conc-name NIL`.
+
+ Default predicate can be disabled or its name, which defaults to
+ `structname?`, changed:
+
+ ; use "blargh?" instead of "blah?"
+ (defstruct blah :predicate blargh? a b c)
+ ; without predicate
+ (defstruct blah :predicate NIL a b c)»)
--- a/src/system.sl
+++ b/src/system.sl
@@ -1063,67 +1063,31 @@
(apply constructor rest)
(error "no default constructor for struct: " struct))))
-(doc-for (defstruct name
- docs…
- options…
- (slot-1 DEFAULT)
- slot-2
- slot-3))
+(defmacro (defstruct . rest)
+ (let* {[docs+rest (separate-doc-from-body (cdr rest))]+ [docs (car docs+rest)]
+ [def (cdr docs+rest)]
+ [name (car rest)]}
+ (def (fmt doc)
+ (let* {[cut (str-find doc "\n\n")]+ [hd (if cut (str-sub doc 0 cut) doc)]
+ [tl (if cut (str-sub doc cut) "")]
+ [def (str-split (print-to-str (list* 'defstruct name def)) "\n")]}
+ (str hd
+ "\n\n "
+ (str-join def "\n ")
+ tl)))
+ (when docs
+ (sym-set-doc name (append docs (list (cons :doc-fmt fmt)))))
+ `(%defstruct% ,name ,@def)))
-(defmacro (defstruct name (:type 'vec)
- (:named T named-supplied)
- (:constructor T)
- (:conc-name T)
- (:predicate T predicate-supplied)
- . slots)
- «Defines a structure type with a specific name and slots.
-
- The default underlying type is a "named" vector (`:type vec`), where
- the first element is the name of the structure's type, the rest are
- the keyworded slot values. A list with slot values alone can be used
- instead by adding `:type list` option. The list will not contain the
- name of the struct by default, which can be enabled with `:named T`
- option.
-
- As an example, the following declaration
-
- (defstruct blah "Return stuff." :doc-group stuff a b (c 1 :read-only T))
-
- Generates the default constructor for a structure of three slots, with
- the third (`c`) having a specific default value and being read-only.
-
- (make-blah (:a NIL) (:b NIL) (:c 1))
- (blah-a s)
- (blah-b s)
- (blah-c s)
-
- Slot's options, if any, should be specified after its default value.
- Supported options are:
-
- ; mark the slot as read-only
- ; its value can be read, but trying to modify it will throw an error
- … :read-only T
-
- The constructor can be changed in several ways:
-
- ; disable the constructor altogether
- (defstruct blah :constructor NIL a b c)
- ; only change its name
- (defstruct blah :constructor blargh a b c)
- ; rename AND avoid using keywords
- (defstruct blah :constructor (blah a b c) a b c)
-
- The option `:conc-name` specifies the slot accessor prefix, which
- defaults to `structname-`. Prefix can be disabled entirely with
- `:conc-name NIL`.
-
- Default predicate can be disabled or its name, which defaults to
- `structname?`, changed:
-
- ; use "blargh?" instead of "blah?"
- (defstruct blah :predicate blargh? a b c)
- ; without predicate
- (defstruct blah :predicate NIL a b c)»
+(defmacro (%defstruct% name
+ (:type 'vec)
+ (:named T named-supplied)
+ (:constructor T constructor-supplied)
+ (:conc-name T conc-name-supplied)
+ (:predicate T predicate-supplied)
+ . slots)
(def (slot-opts slot)
; transform slot description to slot options assoc list
; eg: (a NIL :read-only T) → ((:read-only . T))
@@ -1154,11 +1118,7 @@
(car tail)
NIL))))
slots))
- (let* {; first element in slots may be the doc string- [docs+slots (separate-doc-from-body slots)]
- [docs (car docs+slots)]
- [slots (cdr docs+slots)]
- [num-slots (length slots)]
+ (let* {[num-slots (length slots)]; list of slot names
[slots-car (map (λ (f) (if (cons? f) (car f) f))
slots)]
@@ -1204,25 +1164,6 @@
[access (or (and (eq? conc-name T)
(str name "-"))
conc-name)]}
- (def (fmt doc)
- (let* {[cut (str-find doc "\n\n")]- [hd (if cut (str-sub doc 0 cut) doc)]
- [tl (if cut (str-sub doc cut) "")]}
- (str hd
- "\n\n "
- (append (list 'defstruct)
- (unless isvec
- (list :type type))
- (unless named
- (cons :named named))
- (unless (and constructor (eq? constructor T))
- (list :constructor constructor))
- (when conc-name
- (list :conc-name conc-name))
- (and predicate-supplied
- (list :predicate predicate))
- (cons name slots))
- tl)))
(def (make-constructor args)
`(λ ,args
,(if isvec
@@ -1233,8 +1174,6 @@
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
; predicate
,(when is?
--
⑨