shithub: sl

--- a/boot/sl.boot

+++ b/boot/sl.boot

@@ -16,10 +16,10 @@

 									    (data :size

 										  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 (:type vector) (:named T) (:constructor T) (: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)  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."))

+  (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.  If the\nname as the first element isn't required, \":named NIL\" should be\nused.  A list can be used instead of a vector by adding \":type list\"\noption.\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

@@ -37,7 +37,7 @@

   #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))  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;JA04292:2<052518AP82;36040e184;J:042:02=522>2?e12@8C2Ae22B8B2Ae22C2D2E8Ee2e22F2G2AEe32E0e2e3e32H2I2Ae2268E518?Me3e4e3e12J8=2K2E0e28=e3e3e12@8D2>1e12>2Ee12L8E5152e12L8@5153e3e12L7M2N8;8A8@8F8C8E0>78?525165:" #(#(NIL

+  #fn(string) void))  defstruct #fn("O10005000*///W1000J7071?14W2000J60D?24W3000J60D?34W4000J60q?44W5000J60q?54z6IIb;228;230>1_5142224?<5142586<51;360486<8=;360486=;J50486268>5127288>528<8>51292:12;525185;J>04292:02;525183;3`0483H;3Q0483DQ;3>04292:2<05251;J504838AP;J5048382;36040e184;J:042:02=522>2?e12@8C2Ae22B8B2Ae22C2D2E8Ee2e22F2G2AEe32E0e2e3e32H2I2Ae2268E518?Me3e4e3e12J8=2K2E0e28=e3e3e18D3X02@8D2>1e12>2Ee12L8E5152e12L8@5153e3@30qe12L7M2N8;8A8@8F8C8E0>78?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

--- a/src/system.lsp

+++ b/src/system.lsp

@@ -857,20 +857,17 @@

 (defmacro (defstruct name (:type vector)

                           (:named T)

-                          (:constructor NIL)

+                          (:constructor T)

                           (: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.

+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 by adding \":type list\"

+option.

-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-\".

@@ -915,14 +912,20 @@

          ; 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?)

+         ; struct's underlying type's 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

-                          (cons (symbol (string "make-" name)) slots-kw))]

+         [constructor

+           (and constructor ; NIL means none to make at all

+                (or (and (atom? constructor) ; a single argument

+                         (cons (or (and (eq? constructor T) ; T means the defaults

+                                        (symbol (string "make-" name)))

+                                   constructor) ; else a custom name

+                               slots-kw))

+                    constructor))] ; anything else means custom name and args

          ; should the struct name appear as the first element?

          [named (and named (list name))]

          ; accessor prefix

@@ -938,8 +941,8 @@

       (when ,doc

         (symbol-set-doc ',name ,doc))

       ; constructor

-      (def ,constructor

-        (,type ',@named ,@slots-car))

+      ,(when 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)]