ref: b5b33166330da21373c6269681aa52fdc0291c39
parent: 2178c49affd1819165ac3054f5be6f211efff19b
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Thu Apr 17 19:14:49 EDT 2025
defstruct: rework slot options handling Always require the default value before options so that it's possible to have it a keyword (don't treat a random keyword value as an option itself). Also, always require the value to be passed to the option keyword. References: https://todo.sr.ht/~ft/sl/48
--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -16,8 +16,7 @@
doc-seq . formals-list)) io-eof? ((io)) < ((a . rest)) cadr ((cell)) sym (term) nan? ((v)) for ((min
max fn)) fixnum? ((v)) exit (((status NIL))) > ((a . rest)) + (rest) div0 ((a b)) __finish ((status)) lz-unpack ((data
:to destination)
- (data :size decompressed-bytes)) defstruct ((name doc options… (slot-1 DEFAULT) slot-2 (slot-3
- :read-only))
+ (data :size decompressed-bytes)) defstruct ((name docs… options… (slot-1 DEFAULT) slot-2 slot-3)
(name (:type 'vec) (:named T) (:constructor T) (:conc-name
T)
(:predicate T) . slots)) compare ((x y)) buffer (NIL) num? ((v)) add-exit-hook ((fun)) rand-float (NIL) builtin? ((v)) set-car! ((cell
@@ -34,7 +33,7 @@
group io) "I/O functionality." < "Return `T` if the arguments are in strictly increasing order (next\none is greater than the previous one). With a single argument\nthe result is always `T`." cadr "Shorthand for `(car (cdr cell))`, that is, _first element of the\nsecond element_.\n\nExamples:\n\n (cadr '(1 2 3)) → 2\n (cadr '(1)) → NIL\n (cadr NIL) → NIL" (doc
group builtin) "Built-in operators." nan? "Return `T` if `v` is a floating point representation of NaN, either\nnegative or positive, `NIL` otherwise." NIL "An empty list. Can be used as the opposite of T in boolean\nexpressions.\n\nExamples:\n\n (not NIL) → T\n (if NIL 'yes 'no) → no\n (car NIL) → NIL\n (cdr NIL) → NIL" for "Call the function `fn` with a single integer argument, starting from\n`min` and ending with `max`.\n\nExamples:\n\n (for 0 2 (λ (i) (print (- 2 i)))) → 210" (doc
group vm) "VM-related functions." exit "Terminate the process with the specified status. Does not return.\nThe status is expected to be a string in case of an error.\n\nExamples:\n\n (exit) ; exit with status 0 (nil on Plan 9)\n (exit \"error\") ; exit with status 1 (\"error\" on Plan 9)" fixnum? "Return `T` if `v` is of a fixnum type, `NIL` otherwise." > "Return `T` if the arguments are in strictly decreasing order (previous\none is greater than the next one)." + "Return sum of the arguments or `0` when none specified." div0 "Return the quotient of two numbers. For non-integers this is\nequivalent to `(div0 (floor a) (floor b))`. The result is always an\ninteger.\n\nExamples:\n\n (div0 7 2) → 3\n (div0 10 -2) → -5\n (div0 6.9 1.9) → 6" (doc
- group prop) "Dealing with symbols' properties." lz-unpack "Return decompressed data previously compressed using lz-pack.\n\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified. In the latter case a new\narray is allocated." __finish "A function called right before exit by the VM." defstruct "Defines a structure type with a specific name and slots.\n\nThe default underlying type is a \"named\" vector (`:type vec`), where\nthe first element is the name of the structure's type, the rest are\nthe keyworded slot values. A list with slot values alone can be used\ninstead by adding `:type list` option. The list will not contain the\nname of the struct by default, which can be enabled with `:named T`\noption.\n\nAs an example, the following declaration\n\n (defstruct blah \"Return stuff.\" :doc-group stuff a b (c 1))\n\nGenerates the default constructor definition and accessors:\n\n (make-blah (:a NIL) (:b NIL) (:c 1))\n (blah-a s)\n (blah-b s)\n (blah-c s)\n\nThe constructor can be changed in several ways:\n\n ; disable the constructor altogether\n (defstruct blah :constructor NIL a b c)\n ; only change its name\n (defstruct blah :constructor blargh a b c)\n ; rename AND avoid using keywords\n (defstruct blah :constructor (blah a b c) a b c)\n\nThe option `:conc-name` specifies the slot accessor prefix, which\ndefaults to `structname-`. Prefix can be disabled entirely with\n`:conc-name NIL`.\n\nDefault predicate can be disabled or its name, which defaults to\n`structname?`, changed:\n\n ; use \"blargh?\" instead of \"blah?\"\n (defstruct blah :predicate blargh? a b c)\n ; without predicate\n (defstruct blah :predicate NIL a b c)" (doc
+ group prop) "Dealing with symbols' properties." lz-unpack "Return decompressed data previously compressed using lz-pack.\n\nEither destination for the decompressed data or the expected size of\nthe decompressed data must be specified. In the latter case a new\narray is allocated." __finish "A function called right before exit by the VM." defstruct "Defines a structure type with a specific name and slots.\n\nThe default underlying type is a \"named\" vector (`:type vec`), where\nthe first element is the name of the structure's type, the rest are\nthe keyworded slot values. A list with slot values alone can be used\ninstead by adding `:type list` option. The list will not contain the\nname of the struct by default, which can be enabled with `:named T`\noption.\n\nAs an example, the following declaration\n\n (defstruct blah \"Return stuff.\" :doc-group stuff a b (c 1 :read-only T))\n\nGenerates the default constructor for a structure of three slots, with\nthe third (`c`) having a specific default value and being read-only.\n\n (make-blah (:a NIL) (:b NIL) (:c 1))\n (blah-a s)\n (blah-b s)\n (blah-c s)\n\nSlot's options, if any, should be specified after its default value.\nSupported options are:\n\n ; mark the slot as read-only\n ; its value can be read, but trying to modify it will throw an error\n … :read-only T\n\nThe constructor can be changed in several ways:\n\n ; disable the constructor altogether\n (defstruct blah :constructor NIL a b c)\n ; only change its name\n (defstruct blah :constructor blargh a b c)\n ; rename AND avoid using keywords\n (defstruct blah :constructor (blah a b c) a b c)\n\nThe option `:conc-name` specifies the slot accessor prefix, which\ndefaults to `structname-`. Prefix can be disabled entirely with\n`:conc-name NIL`.\n\nDefault predicate can be disabled or its name, which defaults to\n`structname?`, changed:\n\n ; use \"blargh?\" instead of \"blah?\"\n (defstruct blah :predicate blargh? a b c)\n ; without predicate\n (defstruct blah :predicate NIL a b c)" (doc
group rand) "Random numbers generation." (doc group compare) "Comparison operators." compare "Return -1 if `x` is less than `y`, 0 if equal, and `1` if `y` is\ngreater than `x`.\n\nExamples:\n\n (compare 'a 'b) → -1\n (compare 1 1) → 0\n (compare \"b\" \"a\") → 1" buffer "Return an in-memory buffer for I/O, of `io` type.\n\nA buffer can be used for both reading and writing at the same\ntime." num? "Return `T` if `v` is of a numerical type, `NIL` otherwise.\n\nNumerical types include floating point, fixnum, bignum, etc.\nNote: ironically, a NaN value is considered a number by this function\nsince it's only testing the _type_ of the value." add-exit-hook "Puts an one-argument function on top of the list of exit hooks.\n\nOn shutdown each exit hook is called with the exit status as a single\nargument, which is (usually) `NIL` on success and a string describing\nan error otherwise." rand-float "Return a random float on [0.0, 1.0] interval." builtin? "Return `T` if `v` is a built-in function implemented in C, `NIL`\notherwise.\n\nExamples:\n\n (builtin? map) → T\n (builtin? macroexpand) → NIL" set-car! "Modify a cons cell (a list) in-place by putting `new-first` as its\nfirst element (head of the list). Return the modified cons\ncell (list).\n\nExamples:\n\n (def q '(1 2 3 4 5))\n (set-car! q 0) → (0 6 7)\n q → (0 6 7)" doc-group "Define documentation for a group." cons? "Return `T` if `v` is a cons cell, `NIL` otherwise.\n\nExamples:\n\n (cons? 0) → NIL\n (cons? NIL) → NIL\n (cons? '(1)) → T" 1+ "Equivalent to `(+ n 1)`." aref "Return the sequence element specified by the subscripts. The sequence\ncan be an array, vector, a list. Multi-dimensional sequences\nof variating types are also supported.\n\nExamples:\n\n (def a '((1 #(2 (3)) 4)))\n (aref a 0) → (1 (2 (3)) 4)\n (aref a 1) → index 1 out of bounds\n (aref a 0 0) → 1\n (aref a 0 1 0) → 2\n (aref a 0 2) → 4" *properties* "All properties of symbols recorded with `putprop` are recorded in this\ntable." vec "Return a vector constructed of the arguments.\n\nExamples:\n\n (vec) → #() ; empty vector\n (vec 1 2.5 \"a\" 'b) → #(1 2.5 \"a\" b)" >= "Return `T` if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)." sym? "Return `T` if `v` is a symbol, `NIL` otherwise." void? "Return `T` if `x` is `#<void>`, `NIL` otherwise." zero? "Return `T` if `x` is zero." length= "Perform a bounded length test.\n\nUse this instead of `(= (length seq) n)`, since it avoids unnecessary\nwork and always terminates." positive? "Return `T` if `x` is greater than zero." doc-for "Define documentation for a top level term.\n\nIf `term` is a function signature and `doc` is not specified, just\nthe signature will be included in the documentation, without\nreplacing any previously defined.\n\nFirst `doc` argument is supposed to be a string with the description\nof the term. The following arguments are expected to be optional tag\npairings that provide grouping for multiple symbols and \"see also\"\nreferences.\n\nUseful in cases where setting the documentation for a term can't\n(or not preferred to) be made during the definition of said term.\nOne of those reasons is that the term is a built-in function\nimplemented in C.\n\nExamples:\n\n (doc-for (func arg (arg2 0))\n \"Return something about the `arg` and `arg2`. This is a short\n description.\n\n This is the longer description, following the short one.\n\n Examples:\n\n (func 0) → T\n (func 1 3) → NIL\"\n :doc-group stuff\n :doc-see func2)\n (doc-for (func arg (:another-variant NIL)))" aset! "Modify the sequence element specified by the subscripts and return the\nnew value. The sequence can be an array, vector, a list.\nMulti-dimensional sequences of variating types are also supported.\n\nExamples:\n\n (def a '((1 #(2 (3)) 4)))\n (aset! a 1 'x) → index 1
\ No newline at end of file
group list) "Working with lists." Instructions "VM instructions mapped to their encoded byte representation." file "Open a file for I/O.\n\nAn `io` object is returned. Without any modes specified the file\nis opened in read-only mode." rand-double "Return a random double on interval [0.0, 1.0]." 1- "Equivalent to `(- n 1)`." cdr "Return the second element of a cons cell (tail of a list) or `NIL` if\nnot available.\n\nExamples:\n\n (cdr NIL) → NIL\n (cdr '(1 2 3)) → (2 3)\n (cdr '(1 . 2)) → 2" (doc
group string) "String-related functionality." atom? "Return `T` if `v` is a _not_ a cons cell, `NIL` otherwise. This is\nthe opposite of `cons?`.\n\nThe term \"atom\" comes from the idea of being indivisible.\n\nExamples:\n\n (atom? \"a\") → T\n (atom? NIL) → T\n (atom? '(1)) → NIL" vec? "Return `T` if `v` is a vector, `NIL` otherwise." equal? "Return `T` if both `a` and `b` are of the same value. For non-leaf\ntypes (cons cell and vector), the equality test is performed\nthroughout the whole structure of the values.\n\nExamples:\n\n (equal? 0.0 0) → NIL\n (equal? 0 0) → T\n (def a \"1\")\n (def b \"1\")\n (equal? a b) → T\n (def a '(1))\n (def b '(1))\n (equal? a b) → T" / "Return the division of the arguments. With only one argument the\nresult of `1/x` is returned. If the result is integer-valued, it is\nreturned as an integer.\n\nExamples:\n\n (/ 2) → 0.5\n (/ 7 2 2) → 1.75\n (/ 10 -2) → -5 ; a fixnum\n (/ 6.9 1.9) → 3.6315…" eqv? "Return `T` if both `a` and `b` are of the same value and primitive\n(leaf) type, `NIL` otherwise. Neither cons cell nor vector are not\nconsidered primitive types as they may define deep structures.\n\nExamples:\n\n (eqv? 0.0 0) → NIL\n (eqv? 0 0) → T\n (def a \"1\")\n (def b \"1\")\n (eqv? a b) → T\n (def a '(1))\n (def b '(1))\n (eqv? a b) → NIL" io? "Return `T` if `term` is of `io` type, `NIL` otherwise." eof-object? "Return `T` if `term` is `#<eof>`, `NIL` otherwise.\n\nThis object is returned by I/O functions to signal end of file,\nwhere applicable." list "Return a list constructed of the arguments.\n\nExamples:\n\n (list) → NIL ; empty list\n (list 1 2.5 \"a\" 'b) → (1 2.5 \"a\" b)" apply "Return the result of applying a function to a list of arguments.\n\nThe last argument must always be a list which gets spliced as\narguments to the function.\n\nExamples:\n\n (apply + 1 2 '(3 4 5)) → 15\n (apply vec '(1 2 3)) → #(3 4 5)\n (apply arr 'u8 '(3 4 5)) → #vu8(3 4 5)" help "Display documentation the specified term, if available.\n\nThe optional parameter `kind` can be set to `group` to show\ndocumentation for the specified group instead of a single term.\nAll available documentation groups can be displayed with `(help\ngroups)`." (doc
@@ -56,10 +55,10 @@
ng)) cons ((:doc-group . list)
(:doc-group . builtin)) - ((:doc-group . builtin)) remprop ((:doc-group . prop)) <= ((:doc-group . compare)) rand ((:doc-group . rand)) negative? ((:doc-group . compare)) Instructions ((:doc-group . builtin)) file ((:doc-group . io)) rand-double ((:doc-group . rand)) cdr ((:doc-group . list)
(:doc-group . builtin)) atom? ((:doc-group . builtin)) vec? ((:doc-group . builtin)) / ((:doc-group . builtin)) equal? ((:doc-group . compare)
-oup . builtin)) vec? ((:doc-group . builtin)) / ((:doc-group . builtin)) equal? ((:doc-group . compare)
+oup . builtin)) vec? ((:doc-group . builtin)) / ((:doc-group . builtin)) equal? ((:doc-group . compare)
((: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)
-p . list)
+p . list)
: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)
(:doc-see . getprop)) io->str ((:doc-group . io))))
@@ -79,14 +78,13 @@
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)+#fn("n1700E62:" #(bq-process)) > #fn("z12021e1721510e163:" #(#fn(nconc)4061:" #(#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)+"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?) tra* 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@@ -94,11 +92,11 @@
:2;1528E3B082;J9047:2<51@;082;35048;;36040e185DQ;3:042=02>52;J504858G;3L048F3708G@A08<3;07:2?51@30q8E3:02@0e2@7002Ae283DQ83;3\\0483H;3M0483DQ;3:042=2B052;J504838DP;J5048384DQ;3:042C02D52;J50484II222E8E18F8K848<8G08A>9?M514222F8E108C8F>5?N5148@3G07G02H8@2I8MPe15252@30q42J2Ke18H3{02L8H2Me28E3E02N2O2Me22P8Ie2e3@V02Q2R2S2MEe32P0e2e32T2U2Me27V8B51e3e3e3@30qe18K3C02L8K<8N8K=51e3@30qe18E3U02W2P0e22P2Xe28J3808K<@808N8D51e4@30qe12Y7Z2[8=8D8C8L8E8H8I8F0>98B525165:" #(#(:constructor2 :predicate 4 NIL NIL :type 0 :named 1 :conc-name 3 NIL NIL) vec #0#
#fn("n17005121220A>28552485:" #(cddr #fn(for-each)-@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#
+C8G>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#
error #fn(str) "invalid option in slot "
" of struct " ": "))) slot-opts)
-RS;J9042086513=071228652@30q423242586522087<51390q87P@408762:" #(#fn(keyword?)
+5;J404085;35040=;J604qe186RS;J9042086513=071228652@30q42324865287B38087<@30qe2:" #(#fn(keyword?)
n(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@30q95;39042<96e29798P578764:" #(#fn(str-find)@@ -109,7 +107,7 @@
) :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<70F052517092052933=021938652@4086943<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 "
-r quote if not aref member :read-only error str "slot "
+ror quote if not aref assv :read-only error str "slot "
ode: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 λ #:g435 if and cons? eq? car quote thrown-value cadr caddr raise)) let* #fn("z10H3E02021e1qe12215153e1:2021e173051e1e1220=B3H02024e10=e12215153e1@301515375051e2:" #(#fn(nconc)@@ -138,11 +136,11 @@
#fn("n10A61:")) __finish) __init_globals #fn("n07021d37022@402384w4^147025d;350426;J50427w8429w:4qw;47<w=47>w?47@wA:" #(*os-name* "macos" #fn("n0702161:" #(princ "\e[0m\e[1m#;> \e[0m"))-*linefeed*
- *exit-hooks* *stdout* *io-out* *stdin* *io-in* *stderr* *io-err*) __init_globals)
- __rcscript #fn("n0708421c360q@T08422c37023@G08424c3=07526514q@4027^184;3904288451708622c37029@402:^185;3=042;857<865387;3D042=8751;39047>8761:" #(*os-name*- "unknown" "plan9" "home" "macos" princ "\e]0;StreetLISP v0.999\a" "HOME" #fn(os-getenv) "lib/slrc"
- ".slrc" #fn(str) *directory-separator* #fn(path-exists?) load) __rcscript)
+*linefeed*
+ *exit-hooks* *stdout* *io-out* *stdin* *io-in* *stderr* *io-err*) __init_globals)
+ __rcscript #fn("n0708421c360q@T08422c37023@G08424c3=07526514q@4027^184;3904288451708622c37029@402:^185;3=042;857<865387;3D042=8751;39047>8761:" #(*os-name*+ "unknown" "plan9" "home" "macos" princ "\e]0;StreetLISP v0.999\a" "HOME" #fn(os-getenv) "lib/slrc"
+ ".slrc" #fn(str) *directory-separator* #fn(path-exists?) load) __rcscript)
cscript)
__script #fn("n1200>121{:" #(#fn("n070A61:" #(load)) #fn("n1700514212205161:" #(top-level-exception-handler@@ -503,7 +501,7 @@
A<0=51P:" #(length> list-head) formals-clean)
#fn(str?) #fn(map) str-join #fn(str-split) "\n" any #fn("n1E20051L2;3B04210E5222Q;34040:" #(#fn(str-length) #fn(str-rune) #\space)) #fn(length) str-trim " " "" #fn("n170A2105152390220A62:0:" #(<= #fn(length)-(str-sub)))
+(str-sub)))
))
#fn(append) void) sym-set-doc)
table-clone #fn("n12050212285>1q053485:" #(#fn(table)--- a/src/system.sl
+++ b/src/system.sl
@@ -299,6 +299,12 @@
(cond ((eqv? (car lst) item) lst)
(lst (memv item (cdr lst)))))
+(def (assoc-list . lst)
+ (let ((s (cdr lst)))
+ (when (cons? s)
+ (cons (cons (car lst) (car s))
+ (assoc-list (cdr s))))))
+
(def (assoc item lst)
(cond ((equal? (caar lst) item) (car lst))
(lst (assoc item (cdr lst)))))
@@ -1057,6 +1063,13 @@
(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 name (:type 'vec)
(:named T named-supplied)
(:constructor T)
@@ -1074,9 +1087,10 @@
As an example, the following declaration
- (defstruct blah "Return stuff." :doc-group stuff a b (c 1))
+ (defstruct blah "Return stuff." :doc-group stuff a b (c 1 :read-only T))
- Generates the default constructor definition and accessors:
+ 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)
@@ -1083,6 +1097,13 @@
(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
@@ -1104,9 +1125,13 @@
; without predicate
(defstruct blah :predicate NIL a b c)»
(def (slot-opts slot)
- ; check whether slot options, if any, are valid
- (let ((opts (cddr slot)))
- (for-each (λ (opt) (unless (member opt '(:read-only))
+ ; transform slot description to slot options assoc list
+ ; eg: (a NIL :read-only T) → ((:read-only . T))
+ (when (atom? slot)
+ (return NIL))
+ (let {[valid-keys '(:read-only)]+ [opts (apply assoc-list (cddr slot))]}
+ (for-each (λ (opt) (unless (member (car opt) valid-keys)
(error (str "invalid option in slot " (car slot)
" of struct " name
": " opt))))
@@ -1113,8 +1138,8 @@
opts)
opts))
(def (tokw slots)
- ; transform args list to keyworded variant.
- ; eg: (a (b 1) (c :read-only)) → ((:a NIL) (:b 1) (:c NIL :read-only))
+ ; transform slots descriptions to keyworded arguments
+ ; eg: (a (b 1) (c NIL :read-only T)) → ((:a NIL) (:b 1) (:c NIL))
(map (λ (slot) (let* {[name-cons (and (cons? slot)(car slot))]
[name (or name-cons slot)]
@@ -1124,10 +1149,10 @@
(when (or (not (sym? name))
(keyword? name))
(error "invalid slot name: " name))
- (list* (sym #\: name)
- (if (keyword? (car tail))
- (cons NIL tail)
- tail))))
+ (list (sym #\: name)
+ (if (cons? tail)
+ (car tail)
+ NIL))))
slots))
(let* {; first element in slots may be the doc string[docs+slots (separate-doc-from-body slots)]
@@ -1140,6 +1165,8 @@
; slots, but with default values added (if not set)
; and keywords for names
[slots-kw (tokw slots)]
+ ; slot options
+ [slots-opts (map slot-opts slots)]
; underlying type, either vector or list
[isvec (if (eq? type 'vec)
T
@@ -1229,7 +1256,7 @@
(make-constructor slots-kw))))
; accessor per slot
- ,@(map-int (λ (i) [let* {[opts (slot-opts (list-ref slots-kw i))]+ ,@(map-int (λ (i) [let* {[opts (list-ref slots-opts i)][fld (list-ref slots-car i)]
[fun (if access (sym access fld) fld)]
[iv (if isvec (+ (* 2 i) 1) i)]}
@@ -1239,17 +1266,10 @@
(type-error ',type-of-value s)))
(if (not v-supplied?)
(aref s ,[+ (if named 1 0) iv])
- ,(if (member :read-only opts)
+ ,(if (assv :read-only opts)
`(error (str "slot " ',fld " in struct " ',name " is :read-only"))
`(aset! s ,[+ (if named 1 0) iv] v))))])
num-slots))))
-
-(doc-for (defstruct name
- doc
- options…
- (slot-1 DEFAULT)
- slot-2
- (slot-3 :read-only)))
;;; toplevel
--- a/test/defstruct.sl
+++ b/test/defstruct.sl
@@ -152,3 +152,11 @@
(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))