ref: 3511285638220ee9837a51b88468df52da52156e
parent: bfe38a2454609a60bffe2f59340b075faeca7c4d
author: Sigrid Solveig Haflínudóttir <sigrid@ftrv.se>
date: Sun Mar 9 23:39:44 EDT 2025
add an initial implementation of defstruct References: https://todo.sr.ht/~ft/sl/48
--- a/boot/sl.boot
+++ b/boot/sl.boot
@@ -14,9 +14,12 @@
NIL NIL NIL NIL NIL NIL NIL NIL #fn("z0700}2:" #(aref)) NIL NIL NIL)*properties* #table(*funvars* #table(*prompt* (NIL) lz-unpack ((data :to destination)
(data :size
- decompressed-bytes)) void? ((x)) >= ((a . rest)) help ((term)) length= ((lst
+ decompressed-bytes)) void? ((x)) >= ((a . rest)) defstruct ((name
+ doc options... (slot-1 DEFAULT) slot-2 (slot-3 :read-only))
+ (name (:type vector) (:named T) (:constructor NIL) (:conc-name NIL) (:predicate NIL) . slots)
+ (name doc options... (slot-1 DEFAULT) slot-2 (slot-3 :read-only))) help ((term)) length= ((lst
n)) __finish ((status)) doc-for ((term (doc NIL))) rand-u32 (NIL) = ((a . rest)) rand-u64 (NIL) car ((lst)) <= ((a . rest)) add-exit-hook ((fun)) /= ((a . rest)) lz-pack ((data
- (level 0))) rand (NIL) nan? ((x)) rand-float (NIL) void (rest) cons? ((value)) vm-stats (NIL) * ((number…)) rand-double (NIL) cdr ((lst)) + ((number…)) > ((a . rest))) *doc* #table(>= "Return T if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)." void? "Return T if x is #<void>, NIL otherwise." length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates." doc-for "Define documentation for a top level term.\nIf the optional doc argument is missing and the term is a function\nsignture, adds it to the documentation." car "Return the first element of a list or NIL if not available." *builtins* "VM instructions as closures." <= "Return T if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)." void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though T or NIL could\nbe returned instead, in case of #<void> alone, REPL will not print\nit." rand "Return a random non-negative fixnum on its maximum range." nan? "Return T if the argument is NaN, regardless of the sign." Instructions "VM instructions mapped to their encoded byte representation." rand-double "Return a random double on [0.0, 1.0] interval." > "Return T if the arguments are in strictly decreasing order (previous\none is greater than the next one)." cdr "Return the tail of a list or NIL if not available." + "Return sum of the numbers or 0 with no arguments." __finish "A function called right before exit by the VM." lz-unpack "Return decompressed data previously compressed using lz-pack.\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." help "Display documentation for the specified term, if available." rand-u32 "Return a random integer on [0, 2³²-1] interval." = "Return T if the arguments are equal." rand-u64 "Return a random integer on [0, 2⁶⁴-1] interval." add-exit-hook "Puts an one-argument function on top of the list of exit hooks.\nOn shutdown each exit hook is called with the exit status as a single\nargument, which is (usually) 0 on success and any other number on\nerror." /= "Return T if not all arguments are equal. Shorthand for (not (= …))." lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10. With level 0 a simple LZSS\nusing hashing will be performed. Levels between 1 and 9 offer a\ntrade-off between time/space and ratio. Level 10 is optimal but very\nslow." arg-counts "VM instructions mapped to their expected arguments count." rand-float "Return a random float on [0.0, 1.0] interval." *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"." cons? "Return T if the value is a cons cell." vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc." * "Return product of the numbers or 1 with no arguments." *properties* "All properties of symbols recorded with putprop are recorded in this table."))
+ (level 0))) rand (NIL) nan? ((x)) rand-float (NIL) void (rest) cons? ((value)) vm-stats (NIL) rand-double (NIL) * ((number…)) cdr ((lst)) + ((number…)) > ((a . rest))) *doc* #table(>= "Return T if the arguments are in non-increasing order (previous\none is greater than or equal to the next one)." void? "Return T if x is #<void>, NIL otherwise." length= "Bounded length test.\nUse this instead of (= (length lst) n), since it avoids unnecessary\nwork and always terminates." doc-for "Define documentation for a top level term.\nIf the optional doc argument is missing and the term is a function\nsignture, adds it to the documentation." car "Return the first element of a list or NIL if not available." *builtins* "VM instructions as closures." <= "Return T if the arguments are in non-decreasing order (previous\none is less than or equal to the next one)." void "Return the constant #<void> while ignoring any arguments.\n#<void> is mainly used when a function has side effects but does not\nproduce any meaningful value to return, so even though T or NIL could\nbe returned instead, in case of #<void> alone, REPL will not print\nit." rand "Return a random non-negative fixnum on its maximum range." nan? "Return T if the argument is NaN, regardless of the sign." Instructions "VM instructions mapped to their encoded byte representation." rand-double "Return a random double on [0.0, 1.0] interval." > "Return T if the arguments are in strictly decreasing order (previous\none is greater than the next one)." cdr "Return the tail of a list or NIL if not available." + "Return sum of the numbers or 0 with no arguments." __finish "A function called right before exit by the VM." lz-unpack "Return decompressed data previously compressed using lz-pack.\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." help "Display documentation for the specified term, if available." defstruct "Defines a structure type with a specific name and slots.\nThe default underlying type is a named vector, ie the first element is\nthe name of the structure type, the rest are the slot values.\n\nIf the name as the first element isn't required, \":named NIL\" should\nbe used.\n\nA list can be used instead of a vector, e.g.:\n (defstruct st :type list ...)\n\nThe option :conc-name specifies the slot accessor prefix, which\ndefaults to \"name-\".\n\nDefault predicate name (\"name?\") can be changed:\n (defstruct blah :predicate blargh? a b c)" rand-u32 "Return a random integer on [0, 2³²-1] interval." = "Return T if the arguments are equal." rand-u64 "Return a random integer on [0, 2⁶⁴-1] interval." add-exit-hook "Puts an one-argument function on top of the list of exit hooks.\nOn shutdown each exit hook is called with the exit status as a single\nargument, which is (usually) 0 on success and any other number on\nerror." /= "Return T if not all arguments are equal. Shorthand for (not (= …))." lz-pack "Return data compressed using Lempel-Ziv.\nThe data must be an array, returned value will have the same type.\nThe optional level is between 0 and 10. With level 0 a simple LZSS\nusing hashing will be performed. Levels between 1 and 9 offer a\ntrade-off between time/space and ratio. Level 10 is optimal but very\nslow." arg-counts "VM instructions mapped to their expected arguments count." rand-float "Return a random float on [0.0, 1.0] interval." *prompt* "Function called by REPL to signal the user input is required.\nDefault function prints \"#;> \"." cons? "Return T if the value is a cons cell." vm-stats "Print various VM-related information, such as the number of GC calls\nso far, heap and stack size, etc." * "Return product of the numbers or 1 with no arguments." *properties* "All properties of symbols recorded with putprop are recorded in this table."))
*syntax-environment* #table(bcode:nconst #fn("n1200r2e3:" #(aref)) doc-for #fn("\x8710002000W1000J60q?140B86;35040<;J404086;35040=863H020212287e212288e2e4e2:20212287e21e3e2:" #(void symbol-set-doc quote)) with-input-from #fn("z12021e1220e2e1e12315163:" #(#fn(nconc)with-bindings
@@ -34,7 +37,19 @@
#fn("n10B3500T:7060:" #(void)) letrec)) bcode:code #fn("n1200Ee3:" #(aref)) make-label #fn("n120e1:" #(gensym)) bcode:cenv #fn("n1200r3e3:" #(aref)) > #fn("z12021e12273151510e163:" #(#fn(nconc) < #fn(copy-list) reverse!)) when #fn("z1200211Pqe4:" #(if begin)) quasiquote #fn("n1700E62:" #(bq-process)) help #fn("n17002152853W072855147350424250>170026q535247350@B0722728051524735047960:" #(getprop *doc* princ newline #fn(for-each) #fn("n17050471A0P61:" #(newline print)) *funvars* "no help for "- #fn(string) void)) bcode:ctable #fn("n1200Ke3:" #(aref)) with-output-to #fn("z12021e1220e2e1e12315163:" #(#fn(nconc)+ #fn(string) void)) defstruct #fn("O10005000*///W1000J7071?14W2000J60D?24W3000J60q?34W4000J60q?44W5000J60q?54z6IIb;228;230>1_5142224?<5142586<51;360486<8=;360486=;J50486268>5127288>528<8>51292:12;525185;J>04292:02;525183;JB04292:2<052518Ae282;36040e184;J:042:02=522>502?2@e12A8C2Be22C8B2Be22D2E2F8Ee2e22G2H2BEe32F0e2e3e32I2J2Be2268E518?Me3e4e3e12K8=2L2F0e28=e3e3e12A8D2?1e12?2Fe12M8E5152e12M8@5153e3e12M7N2O8;8A8@8F8G8C8E0>88?525165:" #(#(NIL+ NIL :named 1 :conc-name 3 :type 0 NIL NIL NIL NIL NIL NIL :predicate 4 NIL NIL NIL NIL NIL NIL
+ :constructor 2) vector #0# #fn("n17005121220A>28552485:" #(cddr #fn(for-each)+ #fn("n17002152340q:722324A<25F2605661:" #(member+ (:read-only) error #fn(string) "invalid option in slot " " of struct " ": "))) slot-opts)
+ #fn("n17021062:" #(map! #fn("n10B;35040<85;J404085;35040=;J604qe186RS;J9042086513=071228652@30q4232425268652512087<51390q87P@408762:" #(#fn(keyword?)+ error "invalid slot name: " #fn(list*) #fn(symbol)
+ #fn(string) ":"))) tokw) #fn(string?) #fn(length)
+ #fn(map) #fn("n10B3500<:0:" #()) #fn(symbol) #fn(string) "?" "make-" "-" #fn(gensym)+ #fn(nconc) begin def s and or not quote eq? aref = length when symbol-set-doc #fn(copy-list)
+ map-int #fn("n1A<70F052517092052212293865251238724252694e2e2e3279524e2e22829252694e2e32:242;96510Me37<2=85523O02>2?2@2686e22A2697e22Be6e2@B02C242;96510M25e4e4e4:" #(list-ref+ #fn(symbol) #fn(string) def s v quote assert if eq? aref #fn(length) member :read-only error
+ string "slot " " in struct " " is :read-only" aset!)))) bcode:ctable #fn("n1200Ke3:" #(aref)) with-output-to #fn("z12021e1220e2e1e12315163:" #(#fn(nconc) with-bindings *output-stream* #fn(copy-list))) catch #fn("n22012122e123242522e2262722e22829e2e3262:22e20e3e42;22e22<22e2e4e3e3:" #(trycatch λ #:g347 if and cons? eq? car quote thrown-value cadr caddr raise)) let* #fn("z10H3E02021e1qe12215153e1:2021e173051e1e1220=B3H02024e10=e12215153e1@301515375051e2:" #(#fn(nconc) λ #fn(copy-list) caar let* cadar)) letrec #fn("z1202021e12273052e122240522515154e1227605262:" #(#fn(nconc)--- a/src/system.lsp
+++ b/src/system.lsp
@@ -845,6 +845,116 @@
(cdr strlist))
(iostream->string b))))
+;;; structs
+
+(defmacro (defstruct name (:type vector)
+ (:named T)
+ (:constructor NIL)
+ (:conc-name NIL)
+ (:predicate NIL)
+ . slots)
+ "Defines a structure type with a specific name and slots.
+The default underlying type is a named vector, ie the first element is
+the name of the structure type, the rest are the slot values.
+
+If the name as the first element isn't required, \":named NIL\" should
+be used.
+
+A list can be used instead of a vector, e.g.:
+ (defstruct st :type list ...)
+
+The option :conc-name specifies the slot accessor prefix, which
+defaults to \"name-\".
+
+Default predicate name (\"name?\") can be changed:
+ (defstruct blah :predicate blargh? 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))
+ (error (string "invalid option in slot " (car slot)
+ " of struct " name
+ ": " opt))))
+ 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))
+ (map! (λ (slot) (let* {[name-cons (and (cons? slot)+ (car slot))]
+ [name (or name-cons slot)]
+ [tail (or (and name-cons
+ (cdr slot))
+ (list nil))]}
+ (when (or (not (symbol? name))
+ (keyword? name))
+ (error "invalid slot name: " name))
+ (list* (symbol (string ":" name))
+ (if (keyword? (car tail))
+ (cons nil tail)
+ tail))))
+ slots))
+ (let* {; first element in slots may be the doc string+ [doc (and (string? (car slots))
+ (car slots))]
+ ; if it is, rid of it
+ [slots (or (and doc (cdr slots))
+ slots)]
+ [num-slots (length slots)]
+ ; list of slot names
+ [slots-car (map (λ (f) (if (cons? f) (car f) f))
+ slots)]
+ ; slots, but with default values added (if not set)
+ ; and keywords for names
+ [slots-kw (tokw slots)]
+ ; struct's underlying type predicate (either vector? or list?)
+ [type? (symbol (string type "?"))]
+ ; struct's predicate name
+ [is? (or predicate
+ (symbol (string name "?")))]
+ ; constructor name and arguments
+ [constructor (or constructor
+ (list (symbol (string "make-" name)) slots-kw))]
+ ; should the struct name appear as the first element?
+ [named (and named (list name))]
+ ; accessor prefix
+ [access (or conc-name
+ (string name "-"))]
+ ; FIXME(sigrid): this is only until defset! becomes supported:
+ ; use a gensym have a notion of "undefined" default
+ ; value in accessors
+ [undefined (gensym)]}
+ `(begin
+ ; predicate
+ (def (,is? s)
+ (and [,type? s]
+ [or (not ',named) (eq? (aref s 0) ',name)]
+ [= (length s) ,(+ (length named) num-slots)]))
+ ; documentation string
+ (when ,doc
+ (symbol-set-doc ',name ,doc))
+ ; constructor
+ (def ,constructor
+ (,type ',@named ,@slots-car))
+ ; accessor per slot
+ ,@(map-int (λ (i) [let* {[opts (slot-opts (list-ref slots-kw i))]+ [fld (list-ref slots-car i)]
+ [fun (symbol (string access fld))]}
+ `(def (,fun s (v ',undefined))
+ (assert (,is? s))
+ (if (eq? v ',undefined)
+ (aref s ,[+ (length named) i])
+ ,(if (member :read-only opts)
+ `(error (string "slot "
+ ',fld
+ " in struct "
+ ',name
+ " is :read-only"))
+ `(aset! s ,[+ (length named) i] v))))])
+ num-slots))))
+
+(doc-for (defstruct name doc options... (slot-1 DEFAULT) slot-2 (slot-3 :read-only)))
+
;;; toplevel
(def (macrocall? e) (and (symbol? (car e))