You can subscribe to this list here.
2002 
_{Jan}

_{Feb}

_{Mar}
(23) 
_{Apr}
(68) 
_{May}
(99) 
_{Jun}
(109) 
_{Jul}
(112) 
_{Aug}
(104) 
_{Sep}
(177) 
_{Oct}
(211) 
_{Nov}
(162) 
_{Dec}
(135) 

2003 
_{Jan}
(126) 
_{Feb}
(228) 
_{Mar}
(238) 
_{Apr}
(299) 
_{May}
(257) 
_{Jun}
(283) 
_{Jul}
(192) 
_{Aug}
(227) 
_{Sep}
(295) 
_{Oct}
(202) 
_{Nov}
(180) 
_{Dec}
(70) 
2004 
_{Jan}
(88) 
_{Feb}
(73) 
_{Mar}
(133) 
_{Apr}
(141) 
_{May}
(205) 
_{Jun}
(130) 
_{Jul}
(148) 
_{Aug}
(247) 
_{Sep}
(228) 
_{Oct}
(175) 
_{Nov}
(158) 
_{Dec}
(222) 
2005 
_{Jan}
(159) 
_{Feb}
(96) 
_{Mar}
(145) 
_{Apr}
(192) 
_{May}
(132) 
_{Jun}
(190) 
_{Jul}
(194) 
_{Aug}
(280) 
_{Sep}
(195) 
_{Oct}
(207) 
_{Nov}
(154) 
_{Dec}
(101) 
2006 
_{Jan}
(156) 
_{Feb}
(110) 
_{Mar}
(261) 
_{Apr}
(183) 
_{May}
(148) 
_{Jun}
(133) 
_{Jul}
(94) 
_{Aug}
(141) 
_{Sep}
(137) 
_{Oct}
(111) 
_{Nov}
(172) 
_{Dec}
(124) 
2007 
_{Jan}
(111) 
_{Feb}
(72) 
_{Mar}
(155) 
_{Apr}
(286) 
_{May}
(138) 
_{Jun}
(170) 
_{Jul}
(129) 
_{Aug}
(156) 
_{Sep}
(170) 
_{Oct}
(90) 
_{Nov}
(119) 
_{Dec}
(112) 
2008 
_{Jan}
(135) 
_{Feb}
(102) 
_{Mar}
(115) 
_{Apr}
(42) 
_{May}
(132) 
_{Jun}
(106) 
_{Jul}
(94) 
_{Aug}
(67) 
_{Sep}
(33) 
_{Oct}
(123) 
_{Nov}
(54) 
_{Dec}
(219) 
2009 
_{Jan}
(143) 
_{Feb}
(168) 
_{Mar}
(68) 
_{Apr}
(142) 
_{May}
(224) 
_{Jun}
(202) 
_{Jul}
(83) 
_{Aug}
(86) 
_{Sep}
(68) 
_{Oct}
(37) 
_{Nov}
(93) 
_{Dec}
(80) 
2010 
_{Jan}
(39) 
_{Feb}
(76) 
_{Mar}
(144) 
_{Apr}
(141) 
_{May}
(27) 
_{Jun}
(70) 
_{Jul}
(23) 
_{Aug}
(155) 
_{Sep}
(152) 
_{Oct}
(167) 
_{Nov}
(87) 
_{Dec}
(12) 
2011 
_{Jan}
(18) 
_{Feb}
(39) 
_{Mar}
(18) 
_{Apr}
(27) 
_{May}
(45) 
_{Jun}
(135) 
_{Jul}
(31) 
_{Aug}
(82) 
_{Sep}
(14) 
_{Oct}
(60) 
_{Nov}
(112) 
_{Dec}
(117) 
2012 
_{Jan}
(15) 
_{Feb}
(4) 
_{Mar}
(30) 
_{Apr}
(62) 
_{May}
(45) 
_{Jun}
(30) 
_{Jul}
(9) 
_{Aug}
(23) 
_{Sep}
(41) 
_{Oct}
(56) 
_{Nov}
(35) 
_{Dec}
(43) 
2013 
_{Jan}
(19) 
_{Feb}
(41) 
_{Mar}
(31) 
_{Apr}
(28) 
_{May}
(109) 
_{Jun}
(90) 
_{Jul}
(24) 
_{Aug}
(37) 
_{Sep}
(52) 
_{Oct}
(45) 
_{Nov}
(58) 
_{Dec}
(35) 
2014 
_{Jan}
(24) 
_{Feb}
(48) 
_{Mar}
(93) 
_{Apr}
(100) 
_{May}
(204) 
_{Jun}
(107) 
_{Jul}
(85) 
_{Aug}
(89) 
_{Sep}
(79) 
_{Oct}
(70) 
_{Nov}
(92) 
_{Dec}
(54) 
2015 
_{Jan}
(100) 
_{Feb}
(103) 
_{Mar}
(94) 
_{Apr}
(77) 
_{May}
(96) 
_{Jun}
(63) 
_{Jul}
(116) 
_{Aug}
(76) 
_{Sep}
(81) 
_{Oct}
(269) 
_{Nov}
(253) 
_{Dec}
(143) 
2016 
_{Jan}
(78) 
_{Feb}
(150) 
_{Mar}
(151) 
_{Apr}
(107) 
_{May}
(52) 
_{Jun}
(49) 
_{Jul}
(71) 
_{Aug}
(68) 
_{Sep}
(127) 
_{Oct}
(91) 
_{Nov}

_{Dec}

S  M  T  W  T  F  S 



1
(5) 
2
(1) 
3

4
(3) 
5
(1) 
6

7

8

9
(1) 
10

11

12
(1) 
13

14
(1) 
15

16
(3) 
17
(1) 
18

19

20
(3) 
21
(11) 
22
(3) 
23
(1) 
24

25
(2) 
26

27
(8) 
28

29

30

31



From: stassats <stassats@us...>  20120501 17:22:46

The branch "master" has been updated in SBCL: via 2bfd703aaa0a56039b2831fcbc8f11739dc158b7 (commit) from 436b2ab0276f547e8537b6c1fb52b11fa1f53975 (commit)  Log  commit 2bfd703aaa0a56039b2831fcbc8f11739dc158b7 Author: Stas Boukarev <stassats@...> Date: Tue May 1 20:42:34 2012 +0400 runtime clean up. coreparse.c: Move #define _BSD_SOURCE up, so that it won't conflict with subsequent files, and #undef it after it's used to include sys/mman.h search.c(search_for_type): Remove unused variable addr. interrupt.c: Remove double parentheses in if((x==y)). runprogram.c: Include sys/wait.h  src/runtime/coreparse.c  19 +++++++++++ src/runtime/interrupt.c  2 + src/runtime/runprogram.c  2 + src/runtime/search.c  3 + 4 files changed, 14 insertions(+), 12 deletions() diff git a/src/runtime/coreparse.c b/src/runtime/coreparse.c index 28a08af..d3fa306 100644  a/src/runtime/coreparse.c +++ b/src/runtime/coreparse.c @@ 14,6 +14,17 @@ * files for more information. */ +#ifndef LISP_FEATURE_WIN32 +#ifdef LISP_FEATURE_LINUX +/* For madvise */ +#define _BSD_SOURCE +#include <sys/mman.h> +#undef _BSD_SOURCE +#else +#include <sys/mman.h> +#endif +#endif + #include <stdio.h> #include <stdlib.h> #include <string.h> @@ 25,14 +36,6 @@ #include "sbcl.h" #ifndef LISP_FEATURE_WIN32 #ifdef LISP_FEATURE_LINUX /* For madvise */ # define _BSD_SOURCE #endif #include <sys/mman.h> #endif  #include "os.h" #include "runtime.h" #include "globals.h" diff git a/src/runtime/interrupt.c b/src/runtime/interrupt.c index 2e31562..6eccb2d 100644  a/src/runtime/interrupt.c +++ b/src/runtime/interrupt.c @@ 1754,7 +1754,7 @@ undoably_install_low_level_interrupt_handler (int signal, sa.sa_flags = SA_SIGINFO  SA_RESTART  (sigaction_nodefer_works ? SA_NODEFER : 0); #ifdef LISP_FEATURE_C_STACK_IS_CONTROL_STACK  if((signal==SIG_MEMORY_FAULT)) + if(signal==SIG_MEMORY_FAULT) sa.sa_flags = SA_ONSTACK; #endif diff git a/src/runtime/runprogram.c b/src/runtime/runprogram.c index 00692b7..c911074 100644  a/src/runtime/runprogram.c +++ b/src/runtime/runprogram.c @@ 25,7 +25,7 @@ #include <fcntl.h> #include <sys/ioctl.h> #include <unistd.h>  +#include <sys/wait.h> #include <sys/ioctl.h> #include <termios.h> #include <errno.h> diff git a/src/runtime/search.c b/src/runtime/search.c index 4bf6b50..12e1c61 100644  a/src/runtime/search.c +++ b/src/runtime/search.c @@ 20,12 +20,11 @@ boolean search_for_type(int type, lispobj **start, int *count) {  lispobj obj, *addr; + lispobj obj; while ((*count == 1  (*count > 0)) && is_valid_lisp_addr((os_vm_address_t)*start)) { obj = **start;  addr = *start; if (*count != 1) *count = 2;  hooks/postreceive  SBCL 
From: Lutz Euler <leuler@us...>  20120501 17:00:24

The branch "master" has been updated in SBCL: via 436b2ab0276f547e8537b6c1fb52b11fa1f53975 (commit) from fa1f8141814d146ed69630dcd08a749058ef5119 (commit)  Log  commit 436b2ab0276f547e8537b6c1fb52b11fa1f53975 Author: Lutz Euler <lutz.euler@...> Date: Tue May 1 18:59:12 2012 +0200 Better equidistributed and faster/less consing integer RANDOM. Up to now the implementation of RANDOM with an integer argument just generated a few more random bits than the length of the argument and took this value MOD the argument. This led to a slightly uneven distribution of the possible values unless the argument was a power of two. Moreover, for bignums, the algorithm was quadratic both in time and space dependent on the number of bits of the argument. Instead generate random integers using an acceptreject loop and change the bignum implementation to an algorithm that is linear in time and space. I took some inspiration from WHN's attempt at an acceptreject loop implementation in commit 0a7604d54581d2c846838c26ce6a7993629586fa and following. Thanks to Christophe Rhodes for reviewing this patch! Some details: The implementation works correctly with both a random chunk size equal to the word size and equal to half the word size. This is currently necessary as a 32bit pseudo random generator is used both under 32 and under 64 bit word size. In the generic RANDOM case, fixnum and bignum limits are differentiated: With a fixnum limit an acceptreject loop on a masked random chunk is always used. Under 64 bit word size two random chunks are used only if the limit is so large that one doesn't suffice. This never conses. With a bignum limit four cases are differentiated to minimize consing. If just one random chunk is needed to supply a sufficient number of bits the implementation only conses if the result is indeed a bignum: * If the limit is a power of two, a chunk is generated and shifted to get the correct number of bits. * If the limit is not a power of two an acceptreject loop with shifting is used. If more than one random chunk is needed, a bignum is always consed even if it happens to normalize to a fixnum: * If the limit is a power of two a straightforward algorithm is used to fill a newly created bignum with random bits. * If the limit is not a power of two an acceptreject loop is used that detects rejection early by starting from the most significant bits, thus generating on the average only one random chunk more than needed to fill the result once. The test for power of two is nonconsing, too. In the case of a compiletime constant integer argument (of at most word size) a DEFTRANSFORM triggers, that, in the general case, compiles an acceptreject loop. For values of the limit where this sufficiently reduces the rejection probability the largest multiple of the limit fitting in one or two random chunks is used instead inside the loop. To bring the result in the correct range a division is then necessary (which the compiler converts into a multiplication). Powers of two are optimized by leaving out the rejection test. In those cases where a word has more bits than a random chunk, the generated expression uses two chunks only if necessary.  NEWS  13 +++ buildorder.lispexpr  2 + packagedatalist.lispexpr  5 + src/code/bignumrandom.lisp  183 ++++++++++++++++++++++++++++++++++++++++++ src/code/random.lisp  14 + src/code/targetrandom.lisp  65 ++++++++++ src/compiler/floattran.lisp  124 ++++++++++++++++ tests/random.pure.lisp  4 + 8 files changed, 318 insertions(+), 92 deletions() diff git a/NEWS b/NEWS index 86d8250..5b4ac62 100644  a/NEWS +++ b/NEWS @@ 1,5 +1,18 @@ ;;;; * coding: utf8; fillcolumn: 78 * changes relative to sbcl1.0.56: + * RANDOM enhancements and bug fixes: + ** bug fix: the range and distribution of random integers could be + catastrophically wrong when the compiler derived the type of its + argument as a disjoint set of small integers. + ** bug fix: the distribution of random integers is now completely + uniform even when the specified limit is not a power of two. + (Previously some values could be about 0.1 % more probable than + others in the worst case.) + ** RANDOM on large integer arguments is generally faster and conses + less than before; this is visible for fixnums above a length of + about 24 bits, but extremely so for bignums: the old implementation + used time and space quadratical in the size of the argument there, + the new one is linear. * enhancement: redesigned protocol for quitting SBCL. SBEXT:EXIT is the new main entry point, SBEXT:QUIT is deprecated. * enhancement: additions to the SBTHREAD API: RETURNFROMTHREAD, diff git a/buildorder.lispexpr b/buildorder.lispexpr index e2ec49c..c31d518 100644  a/buildorder.lispexpr +++ b/buildorder.lispexpr @@ 656,6 +656,8 @@ ("src/code/targetsap" :nothost) ; uses SAPINT type ("src/code/targetpackage" :nothost) ; needs "code/package" ("src/code/targetrandom" :nothost) ; needs "code/random" + ("src/code/bignumrandom" :nothost) ; needs "code/random" and + ; "code/bignum" ("src/code/targethashtable" :nothost) ; needs "code/hashtable" ("src/code/reader" :nothost) ; needs "code/readtable" ("src/code/targetstream" :nothost) ; needs WHITESPACEP from "code/reader" diff git a/packagedatalist.lispexpr b/packagedatalist.lispexpr index cbc0b4a..13ede30 100644  a/packagedatalist.lispexpr +++ b/packagedatalist.lispexpr @@ 180,7 +180,7 @@ of SBCL which maintained the CMUCLstyle split into two packages.)" "FLOATBIGNUMRATIO" "MAKESMALLBIGNUM" "MULTIPLYBIGNUMANDFIXNUM" "MULTIPLYBIGNUMS" "MULTIPLYFIXNUMS" "NEGATEBIGNUM"  "SUBTRACTBIGNUM" "SXHASHBIGNUM")) + "%RANDOMBIGNUM" "SUBTRACTBIGNUM" "SXHASHBIGNUM")) #s(sbcold:packagedata :name "SB!C" @@ 1865,6 +1865,7 @@ is a good idea, but see SBSYS re. blurring of boundaries." #!+longfloat "%RANDOMLONGFLOAT" "%RANDOMSINGLEFLOAT" "STATICCLASSOID" "%FUNCALLABLEINSTANCEINFO" "RANDOMCHUNK" "BIGRANDOMCHUNK" + "NRANDOMCHUNKBITS" "LAYOUTCLOSHASHLIMIT" "BUILTINCLASSOIDDIRECTSUPERCLASSES" "BUILTINCLASSOIDTRANSLATION" "RANDOMLAYOUTCLOSHASH" @@ 1873,7 +1874,7 @@ is a good idea, but see SBSYS re. blurring of boundaries." "%SETFUNCALLABLEINSTANCELAYOUT" "BASICSTRUCTURECLASSOID" "REGISTERLAYOUT"  "FUNCALLABLEINSTANCE" "RANDOMFIXNUMMAX" + "FUNCALLABLEINSTANCE" "MAKESTATICCLASSOID" "%MAKESYMBOL" "%FUNCALLABLEINSTANCEFUNCTION" "SYMBOLHASH" diff git a/src/code/bignumrandom.lisp b/src/code/bignumrandom.lisp new file mode 100644 index 0000000..821d4a7  /dev/null +++ b/src/code/bignumrandom.lisp @@ 0,0 +1,183 @@ +;;;; generation of random bignums +;;;; +;;;; The implementation assumes that the random chunk size is either +;;;; equal to the word size or equal to half the word size. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(inpackage "SB!BIGNUM") + +;;; Return T if the least significant NBITS bits of BIGNUM are all +;;; zero, else NIL. If the integerlength of BIGNUM is less than NBITS, +;;; the result is NIL, too. +(declaim (inline bignumlowerbitszerop)) +(defun bignumlowerbitszerop (bignum nbits) + (declare (type bignumtype bignum) + (type bitindex nbits)) + (multiplevaluebind (nfulldigits nbitspartialdigit) + (floor nbits digitsize) + (declare (type bignumindex nfulldigits)) + (when (> (%bignumlength bignum) nfulldigits) + (dotimes (index nfulldigits) + (declare (type bignumindex index)) + (unless (zerop (%bignumref bignum index)) + (returnfrom bignumlowerbitszerop nil))) + (zerop (logand (1 (ash 1 nbitspartialdigit)) + (%bignumref bignum nfulldigits)))))) + +;;; Return a nonnegative integer of DIGITSIZE many pseudo random bits. +(declaim (inline randombignumdigit)) +(defun randombignumdigit (state) + (if (= nrandomchunkbits digitsize) + (randomchunk state) + (bigrandomchunk state))) + +;;; Return a nonnegative integer of NBITS many pseudo random bits. +;;; NBITS must be nonnegative and less than DIGITSIZE. +(declaim (inline randombignumpartialdigit)) +(defun randombignumpartialdigit (nbits state) + (declare (type (integer 0 #.(1 digitsize)) nbits) + (type randomstate state)) + (logand (1 (ash 1 nbits)) + (if (<= nbits nrandomchunkbits) + (randomchunk state) + (bigrandomchunk state)))) + +;;; Create a (nonnegative) bignum by concatenating RANDOMCHUNK and +;;; BITCOUNT many pseudo random bits, normalise and return it. +;;; RANDOMCHUNK must fit into a bignum digit. +(declaim (inline concatenaterandombignum)) +(defun concatenaterandombignum (randomchunk bitcount state) + (declare (type bignumelementtype randomchunk) + (type (integer 0 #.sb!xc:mostpositivefixnum) bitcount) + (type randomstate state)) + (let* ((ntotalbits (+ 1 nrandomchunkbits bitcount)) ; sign bit + (length (ceiling ntotalbits digitsize)) + (bignum (%allocatebignum length))) + (multiplevaluebind (nrandomdigits nrandombits) + (floor bitcount digitsize) + (declare (type bignumindex nrandomdigits)) + (dotimes (index nrandomdigits) + (setf (%bignumref bignum index) + (randombignumdigit state))) + (if (zerop nrandombits) + (setf (%bignumref bignum nrandomdigits) randomchunk) + (progn + (setf (%bignumref bignum nrandomdigits) + (%logior (randombignumpartialdigit nrandombits + state) + (%ashl randomchunk nrandombits))) + (let ((shift ( digitsize nrandombits))) + (when (< shift nrandomchunkbits) + (setf (%bignumref bignum (1+ nrandomdigits)) + (%digitlogicalshiftright randomchunk shift))))))) + (%normalizebignum bignum length))) + +;;; Create and return a (nonnegative) bignum of NBITS many pseudo +;;; random bits. The result is normalised, so may be a fixnum, too. +(declaim (inline makerandombignum)) +(defun makerandombignum (nbits state) + (declare (type (and fixnum (integer 0)) nbits) + (type randomstate state)) + (let* ((ntotalbits (1+ nbits)) ; sign bit + (length (ceiling ntotalbits digitsize)) + (bignum (%allocatebignum length))) + (declare (type bignumindex length)) + (multiplevaluebind (ndigits nbitspartialdigit) + (floor nbits digitsize) + (declare (type bignumindex ndigits)) + (dotimes (index ndigits) + (setf (%bignumref bignum index) + (randombignumdigit state))) + (unless (zerop nbitspartialdigit) + (setf (%bignumref bignum ndigits) + (randombignumpartialdigit nbitspartialdigit state)))) + (%normalizebignum bignum length))) + +;;; Create and return a pseudo random bignum less than ARG. The result +;;; is normalised, so may be a fixnum, too. We try to keep the number of +;;; times RANDOMCHUNK is called and the amount of storage consed to a +;;; minimum. +;;; Four cases are differentiated: +;;; * If ARG is a power of two and only one random chunk is needed to +;;; supply a sufficient number of bits, a chunk is generated and +;;; shifted to get the correct number of bits. This only conses if the +;;; result is indeed a bignum. This case can only occur if the size of +;;; the random chunks is equal to the word size. +;;; * If ARG is a power of two and multiple chunks are needed, we call +;;; MAKERANDOMBIGNUM. Here a bignum is always consed even if it +;;; happens to normalize to a fixnum, which can't be avoided. +;;; * If ARG is not a power of two but one random chunk suffices an +;;; acceptreject loop is used. Each time through the loop a chunk is +;;; generated and shifted to get the correct number of bits. This only +;;; conses if the final accepted result is indeed a bignum. This case +;;; too can only occur if the size of the random chunks is equal to the +;;; word size. +;;; * If ARG is not a power of two and multiple chunks are needed an +;;; acceptreject loop is used that detects rejection early by +;;; starting the generation with a random chunk aligned to the most +;;; significant bits of ARG. If the random value is larger than the +;;; corresponding chunk of ARG we don't need to generate the full +;;; amount of random bits but can retry immediately. If the random +;;; value is smaller than the ARG chunk we know already that the +;;; result will be accepted independently of what the remaining random +;;; bits will be, so we generate them and return. Only in the rare +;;; case that the random value and the ARG chunk are equal we need to +;;; generate and compare the complete random number and risk to reject +;;; it. +(defun %randombignum (arg state) + (declare (type (integer #.(1+ sb!xc:mostpositivefixnum)) arg) + (type randomstate state) + (inline bignumlowerbitszerop)) + (let ((nbits (bignumintegerlength arg))) + (declare (type (integer #.sb!vm:nfixnumbits) nbits)) + ;; Don't use (ZEROP (LOGAND ARG (1 ARG))) to test if ARG is a power + ;; of two as that would cons. + (cond ((bignumlowerbitszerop arg (1 nbits)) + ;; ARG is a power of two. We need one bit less than its + ;; INTEGERLENGTH. Not using (DECF NBITS) here allows the + ;; compiler to make optimal use of the type declaration for + ;; NBITS above. + (let ((nbits (1 nbits))) + (if (<= nbits nrandomchunkbits) + (%digitlogicalshiftright (randomchunk state) + ( nrandomchunkbits nbits)) + (makerandombignum nbits state)))) + ((<= nbits nrandomchunkbits) + (let ((shift ( nrandomchunkbits nbits)) + (arg (%bignumref arg 0))) + (loop + (let ((bits (%digitlogicalshiftright (randomchunk state) + shift))) + (when (< bits arg) + (return bits)))))) + (t + ;; ARG is not a power of two and we need more than one random + ;; chunk. + (let* ((shift ( nbits nrandomchunkbits)) + (argfirstchunk (ldb (byte nrandomchunkbits shift) + arg))) + (loop + (let ((randomchunk (randomchunk state))) + ;; If the random value is larger than the corresponding + ;; chunk from the most significant bits of ARG we can + ;; retry immediately; no need to generate the remaining + ;; random bits. + (unless (> randomchunk argfirstchunk) + ;; We need to generate the complete random number. + (let ((bits (concatenaterandombignum randomchunk + shift state))) + ;; While the second comparison below subsumes the + ;; first, the first is faster and will nearly + ;; always be true, so it's worth it to try it + ;; first. + (when (or (< randomchunk argfirstchunk) + (< bits arg)) + (return bits))))))))))) diff git a/src/code/random.lisp b/src/code/random.lisp index 373a3b2..cfcc7fc 100644  a/src/code/random.lisp +++ b/src/code/random.lisp @@ 10,19 +10,7 @@ (inpackage "SB!KERNEL") ;;; the size of the chunks returned by RANDOMCHUNK (def!constant randomchunklength 32)  ;;; the amount that we overlap chunks by when building a large integer ;;; to make up for the loss of randomness in the low bits (def!constant randomintegeroverlap 3)  ;;; extra bits of randomness that we generate before taking the value MOD the ;;; limit, to avoid loss of randomness near the limit (def!constant randomintegerextrabits 10)  ;;; the largest fixnum we can compute from one chunk of bits (def!constant randomfixnummax  (1 (ash 1 ( randomchunklength randomintegerextrabits)))) +(def!constant nrandomchunkbits 32) (sb!xc:defstruct (randomstate (:constructor %makerandomstate) (:copier nil)) ; since shallow copy is wrong diff git a/src/code/targetrandom.lisp b/src/code/targetrandom.lisp index 57c57a7..b4cb278 100644  a/src/code/targetrandom.lisp +++ b/src/code/targetrandom.lisp @@ 292,9 +292,8 @@ #!sbfluid (declaim (inline bigrandomchunk)) (defun bigrandomchunk (state) (declare (type randomstate state))  (logand (1 (expt 2 64))  (logior (ash (randomchunk state) 32)  (randomchunk state)))) + (logior (ash (randomchunk state) 32) + (randomchunk state))) ;;; Handle the single or double float case of RANDOM. We generate a ;;; float between 0.0 and 1.0 by clobbering the significand of 1.0 @@ 310,7 +309,7 @@ (* arg ( (makesinglefloat (dpb (ash (randomchunk state)  ( sb!vm:singlefloatdigits randomchunklength)) + ( sb!vm:singlefloatdigits nrandomchunkbits)) sb!vm:singlefloatsignificandbyte (singlefloatbits 1.0))) 1.0))) @@ 333,7 +332,7 @@ (* arg ( (sb!impl::makedoublefloat (dpb (ash (randomchunk state)  ( sb!vm:doublefloatdigits randomchunklength 32)) + ( sb!vm:doublefloatdigits nrandomchunkbits 32)) sb!vm:doublefloatsignificandbyte (sb!impl::doublefloathighbits 1d0)) (randomchunk state)) @@ 348,7 +347,7 @@ (* arg ( (sb!impl::makedoublefloat (dpb (ash (sb!vm::randommt19937 statevector)  ( sb!vm:doublefloatdigits randomchunklength + ( sb!vm:doublefloatdigits nrandomchunkbits sb!vm:nwordbits)) sb!vm:doublefloatsignificandbyte (sb!impl::doublefloathighbits 1d0)) @@ 356,26 +355,46 @@ 1d0)))) ;;;; random integers +;;;; random fixnums (defun %randominteger (arg state)  (declare (type (integer 1) arg) (type randomstate state))  (let ((shift ( randomchunklength randomintegeroverlap)))  (do ((bits (randomchunk state)  (logxor (ash bits shift) (randomchunk state)))  (count (+ (integerlength arg)  ( randomintegerextrabits shift))  ( count shift)))  ((minusp count)  (rem bits arg))  (declare (fixnum count))))) +;;; Generate and return a pseudo random fixnum less than ARG. To achieve +;;; equidistribution an acceptreject loop is used. +;;; No extra effort is made to detect the case of ARG being a power of +;;; two where rejection is not possible, as the cost of checking for +;;; this case is the same as doing the rejection test. When ARG is +;;; larger than (expt 2 NRANDOMCHUNKBITS), which can only happen if +;;; the random chunk size is half the word size, two random chunks are +;;; used in each loop iteration, otherwise only one. Finally, the +;;; rejection probability could often be reduced by not masking the +;;; chunk but rejecting only values as least as large as the largest +;;; multiple of ARG that fits in a chunk (or two), but this is not done +;;; as the speed gains due to needing fewer loop iterations are by far +;;; outweighted by the cost of the two divisions required (one to find +;;; the multiplier and one to bring the result into the correct range). +#!sbfluid (declaim (inline %randomfixnum)) +(defun %randomfixnum (arg state) + (declare (type (integer 1 #.sb!xc:mostpositivefixnum) arg) + (type randomstate state)) + (if (= arg 1) + 0 + (let* ((nbits (integerlength (1 arg))) + (mask (1 (ash 1 nbits)))) + (macrolet ((acceptrejectloop (generator) + `(loop + (let ((bits (logand mask (,generator state)))) + (when (< bits arg) + (return bits)))))) + (assert (<= nbits (* 2 nrandomchunkbits))) + (if (<= nbits nrandomchunkbits) + (acceptrejectloop randomchunk) + (acceptrejectloop bigrandomchunk)))))) (defun random (arg &optional (state *randomstate*))  (declare (inline %randomsinglefloat %randomdoublefloat + (declare (inline %randomfixnum %randomsinglefloat %randomdoublefloat #!+longfloat %randomlongfloat)) (cond  ((and (fixnump arg) (<= arg randomfixnummax) (> arg 0))  (rem (randomchunk state) arg)) + ((and (fixnump arg) (> arg 0)) + (%randomfixnum arg state)) ((and (typep arg 'singlefloat) (> arg 0.0f0)) (%randomsinglefloat arg state)) ((and (typep arg 'doublefloat) (> arg 0.0d0)) @@ 383,8 +402,8 @@ #!+longfloat ((and (typep arg 'longfloat) (> arg 0.0l0)) (%randomlongfloat arg state))  ((and (integerp arg) (> arg 0))  (%randominteger arg state)) + ((and (bignump arg) (> arg 0)) + (%randombignum arg state)) (t (error 'simpletypeerror :expectedtype '(or (integer 1) (float (0))) :datum arg diff git a/src/compiler/floattran.lisp b/src/compiler/floattran.lisp index 8d2eaed..b5cd536 100644  a/src/compiler/floattran.lisp +++ b/src/compiler/floattran.lisp @@ 46,59 +46,79 @@ (frob %randomsinglefloat singlefloat) (frob %randomdoublefloat doublefloat)) ;;; Mersenne Twister RNG ;;; ;;; FIXME: It's unpleasant to have RANDOM functionality scattered ;;; through the code this way. It would be nice to move this into the ;;; same file as the other RANDOM definitions. +;;; Return an expression to generate an integer of NBITS many random +;;; bits, using the minimal number of random chunks possible. +(defun generaterandomexprforpowerof2 (nbits state) + (declare (type (integer 1 #.sb!vm:nwordbits) nbits)) + (multiplevaluebind (nchunkbits chunkexpr) + (cond ((<= nbits nrandomchunkbits) + (values nrandomchunkbits `(randomchunk ,state))) + ((<= nbits (* 2 nrandomchunkbits)) + (values (* 2 nrandomchunkbits) `(bigrandomchunk ,state))) + (t + (error "Unexpectedly small NRANDOMCHUNKBITS"))) + (if (< nbits nchunkbits) + `(logand ,(1 (ash 1 nbits)) ,chunkexpr) + chunkexpr))) + +;;; This transform for compiletime constant wordsized integers +;;; generates an acceptreject loop to achieve equidistribution of the +;;; returned values. Several optimizations are done: If NUM is a power +;;; of two no loop is needed. If the random chunk size is half the word +;;; size only one chunk is used where sufficient. For values of NUM +;;; where it is possible and results in faster code, the rejection +;;; probability is reduced by accepting all values below the largest +;;; multiple of the limit that fits into one or two chunks and and doing +;;; a division to get the random value into the desired range. (deftransform random ((num &optional state)  ((integer 1 #.(expt 2 sb!vm::nwordbits)) &optional *))  ;; FIXME: I almost conditionalized this as #!+sbdoc. Find some way  ;; of automatically finding #!+sbdoc in proximity to DEFTRANSFORM  ;; to let me scan for places that I made this mistake and didn't  ;; catch myself.  "use inline (UNSIGNEDBYTE 32) operations"  (let ((type (lvartype num))  (limit (expt 2 sb!vm::nwordbits))  (randomchunk (ecase sb!vm::nwordbits  (32 'randomchunk)  (64 'sb!kernel::bigrandomchunk))))  (if (numerictypep type)  (let ((numhigh (numerictypehigh (lvartype num))))  (aver numhigh)  (cond ((constantlvarp num)  ;; Check the worst case sum absolute error for the  ;; random number expectations.  (let ((rem (rem limit numhigh)))  (unless (< (/ (* 2 rem ( numhigh rem))  numhigh limit)  (expt 2 ( sb!kernel::randomintegerextrabits)))  (giveupir1transform  "The random number expectations are inaccurate."))  (if (= numhigh limit)  `(,randomchunk (or state *randomstate*))  #!(or x86 x8664)  `(rem (,randomchunk (or state *randomstate*)) num)  #!+(or x86 x8664)  ;; Use multiplication, which is faster.  `(values (sb!bignum::%multiply  (,randomchunk (or state *randomstate*))  num)))))  ((> numhigh randomfixnummax)  (giveupir1transform  "The range is too large to ensure an accurate result."))  #!+(or x86 x8664)  ((< numhigh limit)  `(values (sb!bignum::%multiply  (,randomchunk (or state *randomstate*))  num)))  (t  `(rem (,randomchunk (or state *randomstate*)) num))))  ;; KLUDGE: a relatively conservative treatment, but better  ;; than a bug (reported by PFD sbcldevel towards the end of  ;; 200411.  (giveupir1transform  "Argument type is too complex to optimize for.")))) + ((constantarg (integer 1 #.(expt 2 sb!vm:nwordbits))) + &optional *) + * + :policy (and (> speed compilationspeed) + (> speed space))) + "optimize to inlined RANDOMCHUNK operations" + (let ((num (lvarvalue num))) + (if (= num 1) + 0 + (flet ((chunknbitsandexpr (nbits) + (cond ((<= nbits nrandomchunkbits) + (values nrandomchunkbits + '(randomchunk (or state *randomstate*)))) + ((<= nbits (* 2 nrandomchunkbits)) + (values (* 2 nrandomchunkbits) + '(bigrandomchunk (or state *randomstate*)))) + (t + (error "Unexpectedly small NRANDOMCHUNKBITS"))))) + (if (zerop (logand num (1 num))) + ;; NUM is a power of 2. + (let ((nbits (integerlength (1 num)))) + (multiplevaluebind (nchunkbits chunkexpr) + (chunknbitsandexpr nbits) + (if (< nbits nchunkbits) + `(logand ,(1 (ash 1 nbits)) ,chunkexpr) + chunkexpr))) + ;; Generate an acceptreject loop. + (let ((nbits (integerlength num))) + (multiplevaluebind (nchunkbits chunkexpr) + (chunknbitsandexpr nbits) + (if (or (> (* num 3) (expt 2 nchunkbits)) + (logbitp ( nbits 2) num)) + ;; Division can't help as the quotient is below 3, + ;; or is too costly as the rejection probability + ;; without it is already small (namely at most 1/4 + ;; with the given test, which is experimentally a + ;; reasonable threshold and cheap to test for). + `(loop + (let ((bits ,(generaterandomexprforpowerof2 + nbits '(or state *randomstate*)))) + (when (< bits num) + (return bits)))) + (let ((d (truncate (expt 2 nchunkbits) num))) + `(loop + (let ((bits ,chunkexpr)) + (when (< bits ,(* num d)) + (return (values (truncate bits ,d))))))))))))))) + ;;;; float accessors diff git a/tests/random.pure.lisp b/tests/random.pure.lisp index 101333e..829ff4d 100644  a/tests/random.pure.lisp +++ b/tests/random.pure.lisp @@ 114,8 +114,8 @@ nconc (list (1 (expt 2 i)) (expt 2 i) (1+ (expt 2 i))))  ,@(loop for i from (1 sbkernel::randomchunklength)  to (* sbkernel::randomchunklength 4) + ,@(loop for i from (1 sbkernel::nrandomchunkbits) + to (* sbkernel::nrandomchunkbits 4) collect (* 3 (expt 2 i))) ,@(loop for i from 2 to sbvm:nwordbits for n = (expt 16 i)  hooks/postreceive  SBCL 
From: Lutz Euler <leuler@us...>  20120501 16:08:13

The branch "master" has been updated in SBCL: via fa1f8141814d146ed69630dcd08a749058ef5119 (commit) from 18911695a5625fc908b8c07e97d33bf54749a962 (commit)  Log  commit fa1f8141814d146ed69630dcd08a749058ef5119 Author: Lutz Euler <lutz.euler@...> Date: Tue May 1 18:07:14 2012 +0200 Add some tests for basic RANDOM functionality. There are currently few, if any, such tests, so ahead of profound changes to integer RANDOM add some. They are neither systematic nor comprehensive but should be better than nothing.  tests/random.pure.lisp  90 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 files changed, 90 insertions(+), 0 deletions() diff git a/tests/random.pure.lisp b/tests/random.pure.lisp index ef0f398..101333e 100644  a/tests/random.pure.lisp +++ b/tests/random.pure.lisp @@ 60,3 +60,93 @@ ;; with a probability of 1 minus approximately (expt 2 194). (unless (= x (1 high)) (error "bad RANDOM distribution: ~16,16,'0r" x)))) + +;;; Some tests for basic integer RANDOM functionality. + +(withtest (:name (:random :integer :errorifinvalidrandomstate)) + (dolist (optimize '(((speed 0) (compilationspeed 3)) + ((speed 3) (compilationspeed 0) (space 0)))) + (dolist (expr `((lambda (x state) + (declare (optimize ,@optimize)) + (random x state)) + (lambda (x state) + (declare (optimize ,@optimize)) + (declare (type integer x)) + (random x state)) + (lambda (x state) + (declare (optimize ,@optimize)) + (declare (type (integer 100 200) x)) + (random x state)) + (lambda (x state) + (declare (optimize ,@optimize)) + (random (if x 10 20) state)))) + (let ((fun (compile nil expr))) + (assert (raiseserror? (funcall fun 150 nil) typeerror)))))) + +(withtest (:name (:random :integer :distribution)) + (let ((genericrandom (compile nil '(lambda (x) + (random x))))) + ;; Check powers of two: Every bit in the output should be sometimes + ;; 0, sometimes 1. + (dotimes (e 200) + (let* ((number (expt 2 e)) + (foo (lambda () + (funcall genericrandom number))) + (bar (compile nil `(lambda () + (declare (optimize speed)) + (random ,number))))) + (flet ((test (fun) + (let ((xand (funcall fun)) + (xior (funcall fun))) + (dotimes (i 199) + (setf xand (logand xand (funcall fun)) + xior (logior xior (funcall fun)))) + (assert (= xand 0)) + (assert (= xior (1 number)))))) + (test foo) + (test bar)))) + ;; Test a collection of fixnums and bignums, powers of two and + ;; numbers just below and above powers of two, numbers needing one, + ;; two or more random chunks etc. + (dolist (number (removeduplicates + `(,@(loop for i from 2 to 11 collect i) + ,@(loop for i in '(29 30 31 32 33 60 61 62 63 64 65) + nconc (list (1 (expt 2 i)) + (expt 2 i) + (1+ (expt 2 i)))) + ,@(loop for i from (1 sbkernel::randomchunklength) + to (* sbkernel::randomchunklength 4) + collect (* 3 (expt 2 i))) + ,@(loop for i from 2 to sbvm:nwordbits + for n = (expt 16 i) + for r = (+ n (random n)) + collect r)))) + (let ((foo (lambda () + (funcall genericrandom number))) + (bar (compile nil `(lambda () + (declare (optimize speed)) + (random ,number))))) + (flet ((test (fun) + (let* ((min (funcall fun)) + (max min)) + (dotimes (i 9999) + (let ((r (funcall fun))) + (when (< r min) + (setf min r)) + (when (> r max) + (setf max r)))) + ;; With 10000 trials and an argument of RANDOM below + ;; 70 the probability of the minimum not being 0 is + ;; less than (expt 10 60), so we can test for that; + ;; correspondingly with the maximum. For larger + ;; arguments we can only test that all results are + ;; in range. + (if (< number 70) + (progn + (assert (= min 0)) + (assert (= max (1 number)))) + (progn + (assert (>= min 0)) + (assert (< max number))))))) + (test foo) + (test bar))))))  hooks/postreceive  SBCL 
From: Lutz Euler <leuler@us...>  20120501 13:58:48

The branch "master" has been updated in SBCL: via 18911695a5625fc908b8c07e97d33bf54749a962 (commit) from ef61e6c46ca429b84a61e90efcd7ac11261f92c7 (commit)  Log  commit 18911695a5625fc908b8c07e97d33bf54749a962 Author: Lutz Euler <lutz.euler@...> Date: Tue May 1 15:57:03 2012 +0200 Fix the DEFTRANSFORM of RANDOM for hairy integer types. With integer types that are neither an interval nor a single known value the DEFTRANSFORM used to generate an expression that had two problems: First, it yielded very uneven distributions of random values for most arguments to RANDOM that are not very small. Second, it used a too small RANDOMCHUNK under 64 bits word size thus never generating numbers larger than (1 (EXPT 2 32)) even if RANDOM's argument was larger than (EXPT 2 32). Fix this by giving up the transform in these cases. Add a new file "tests/random.pure.lisp" containing tests for this.  src/compiler/floattran.lisp  3 + tests/random.pure.lisp  62 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 64 insertions(+), 1 deletions() diff git a/src/compiler/floattran.lisp b/src/compiler/floattran.lisp index 3efdaa1..8d2eaed 100644  a/src/compiler/floattran.lisp +++ b/src/compiler/floattran.lisp @@ 97,7 +97,8 @@ ;; KLUDGE: a relatively conservative treatment, but better ;; than a bug (reported by PFD sbcldevel towards the end of ;; 200411.  '(rem (randomchunk (or state *randomstate*)) num)))) + (giveupir1transform + "Argument type is too complex to optimize for.")))) ;;;; float accessors diff git a/tests/random.pure.lisp b/tests/random.pure.lisp new file mode 100644 index 0000000..ef0f398  /dev/null +++ b/tests/random.pure.lisp @@ 0,0 +1,62 @@ +;;;; various RANDOM tests without side effects + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(inpackage :cluser) + +;;; Tests in this file that rely on properties of the distribution of +;;; the random numbers are designed to be fast and have a very low +;;; probability of false positives, generally of the order of (expt 10 60). +;;; These tests are not intended to assure the statistical qualities of the +;;; pseudo random number generator but to help find bugs in its and RANDOM's +;;; implementation. + +;; When the type of the argument of RANDOM is a set of integers, a +;; DEFTRANSFORM triggered that simply generated (REM (RANDOMCHUNK) NUM), +;; which has two severe problems: The resulting distribution is very uneven +;; for most arguments of RANDOM near the size of a random chunk and the +;; RANDOMCHUNK used was always 32 bits, even under 64 bit wordsize which +;; yields even more disastrous distributions. +(withtest (:name (:random :integer :setofintegers :distribution)) + (let* ((high (floor (expt 2 33) 3)) + (mid (floor high 2)) + (fun (compile nil `(lambda (x) + (random (if x ,high 10))))) + (n1 0) + (n 10000)) + (dotimes (i n) + (when (>= (funcall fun t) mid) + (incf n1))) + ;; Half of the values of (RANDOM HIGH) should be >= MID, so we expect + ;; N1 to be binomially distributed such that this distribution can be + ;; approximated by a normal distribution with mean (/ N 2) and standard + ;; deviation (* (sqrt N) 1/2). The broken RANDOM we are testing here for + ;; yields (/ N 3) and (* (sqrt N) (sqrt 2/9)), respectively. We test if + ;; N1 is below the average of (/ N 3) and (/ N 2). With a value of N of + ;; 10000 this is more than 16 standard deviations away from the expected + ;; mean, which has a probability of occurring by chance of below + ;; (expt 10 60). + (when (< n1 (* n 5/12)) + (error "bad RANDOM distribution: expected ~d, got ~d" (/ n 2) n1)))) + +(withtest (:name (:random :integer :setofintegers :chunksize)) + (let* ((high (expt 2 64)) + (fun (compile nil `(lambda (x) + (random (if x ,high 10))))) + (n 200) + (x 0)) + (dotimes (i n) + (setf x (logior x (funcall fun t)))) + ;; If RANDOM works correctly, x should be #b111...111 (64 ones) + ;; with a probability of 1 minus approximately (expt 2 194). + (unless (= x (1 high)) + (error "bad RANDOM distribution: ~16,16,'0r" x))))  hooks/postreceive  SBCL 
From: Nikodemus Siivola <demoss@us...>  20120501 12:39:35

The branch "master" has been updated in SBCL: via ef61e6c46ca429b84a61e90efcd7ac11261f92c7 (commit) from f0da2f63aa0b4e6d4dbf884854a4bf2dfdd01fc0 (commit)  Log  commit ef61e6c46ca429b84a61e90efcd7ac11261f92c7 Author: Nikodemus Siivola <nikodemus@...> Date: Tue May 1 14:30:55 2012 +0300 add SBUNIX:UNIXEXIT back, use the deprecation framwork for it and SBEXT:QUIT Also extend the deprecation framwork to support multiple replacements: SBEXT:QUIT should be replaced either by SBEXT:EXIT or SBEXT:ABORTTHREAD, depending on the way it was being used.  packagedatalist.lispexpr  4 ++ src/code/coldinit.lisp  6 + src/code/condition.lisp  19 +++++++++ src/code/earlyextensions.lisp  57 +++++++++++++++++++++++ src/code/unix.lisp  6 ++++ 5 files changed, 58 insertions(+), 34 deletions() diff git a/packagedatalist.lispexpr b/packagedatalist.lispexpr index 3a6b84a..cbc0b4a 100644  a/packagedatalist.lispexpr +++ b/packagedatalist.lispexpr @@ 2469,7 +2469,9 @@ no guarantees of interface stability." "UNIXCLOSEDIR" "UNIXDIRENTNAME" "UNIXDUP" "UNIXFILEMODE" "UNIXFSTAT" "UNIXGETHOSTNAME" "UNIXGETPID" "UNIXGETRUSAGE"  "UNIXGETTIMEOFDAY" "UNIXGETUID" "UNIXGID" "UNIXIOCTL" + "UNIXGETTIMEOFDAY" "UNIXGETUID" "UNIXGID" + "UNIXEXIT" + "UNIXIOCTL" "UNIXISATTY" "UNIXLSEEK" "UNIXLSTAT" "UNIXMKDIR" "UNIXOPEN" "UNIXOPENDIR" "UNIXPATHNAME" "UNIXPID" "UNIXPIPE" "UNIXSIMPLEPOLL" "UNIXREAD" "UNIXREADDIR" "UNIXREADLINK" "UNIXREALPATH" diff git a/src/code/coldinit.lisp b/src/code/coldinit.lisp index df0c1ce..28ee7a8 100644  a/src/code/coldinit.lisp +++ b/src/code/coldinit.lisp @@ 274,10 +274,8 @@ (toplevelinit) (criticallyunreachable "after TOPLEVELINIT"))) (defun quit (&key recklesslyp (unixstatus 0))  #!+sbdoc  "Deprecated. See: SBEXT:EXIT, SBTHREAD:RETURNFROMTHREAD, SBTHREAD:ABORTTHREAD." +(definedeprecatedfunction :early "1.0.56.55" quit (exit sb!thread:abortthread) + (&key recklesslyp (unixstatus 0)) (if (or recklesslyp (sb!thread:mainthreadp)) (exit :code unixstatus :abort recklesslyp) (sb!thread:abortthread)) diff git a/src/code/condition.lisp b/src/code/condition.lisp index bbeac70..3e7e84e 100644  a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ 1614,7 +1614,7 @@ the usual naming convention (names like *FOO*) for special variables" (definecondition deprecationcondition () ((name :initarg :name :reader deprecatedname)  (replacement :initarg :replacement :reader deprecatednamereplacement) + (replacements :initarg :replacements :reader deprecatednamereplacements) (since :initarg :since :reader deprecatedsince) (runtimeerror :initarg :runtimeerror :reader deprecatednameruntimeerror))) @@ 1622,14 +1622,21 @@ the usual naming convention (names like *FOO*) for special variables" (let ((*package* (findpackage :keyword))) (if *printescape* (printunreadableobject (condition stream :type t)  (format stream "~S is deprecated~@[, use ~S~]" + (apply #'format + stream "~S is deprecated.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~} instead.~]" (deprecatedname condition)  (deprecatednamereplacement condition)))  (format stream "~@<~S has been deprecated as of SBCL ~A~  ~@[, use ~S instead~].~:@>" + (deprecatednamereplacements condition))) + (apply #'format + stream "~@<~S has been deprecated as of SBCL ~A.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~:_~} instead.~]~:@>" (deprecatedname condition) (deprecatedsince condition)  (deprecatednamereplacement condition))))) + (deprecatednamereplacements condition))))) (definecondition earlydeprecationwarning (stylewarning deprecationcondition) ()) diff git a/src/code/earlyextensions.lisp b/src/code/earlyextensions.lisp index 0927619..1d297c3 100644  a/src/code/earlyextensions.lisp +++ b/src/code/earlyextensions.lisp @@ 1089,52 +1089,63 @@ ;;;; Deprecating stuff (defun deprecationerror (since name replacement) +(defun normalizedeprecationreplacements (replacements) + (if (or (not (listp replacements)) + (eq 'setf (car replacements))) + (list replacements) + replacements)) + +(defun deprecationerror (since name replacements) (error 'deprecationerror :name name  :replacement replacement + :replacements (normalizedeprecationreplacements replacements) :since since)) (defun deprecationwarning (state since name replacement +(defun deprecationwarning (state since name replacements &key (runtimeerror (neq :early state))) (warn (ecase state (:early 'earlydeprecationwarning) (:late 'latedeprecationwarning) (:final 'finaldeprecationwarning)) :name name  :replacement replacement + :replacements (normalizedeprecationreplacements replacements) :since since :runtimeerror runtimeerror)) (defun deprecatedfunction (since name replacement) +(defun deprecatedfunction (since name replacements) (lambda (&rest deprecatedfunctionargs) (declare (ignore deprecatedfunctionargs))  (deprecationerror since name replacement))) + (deprecationerror since name replacements))) (defun deprecationcompilermacro (state since name replacement) +(defun deprecationcompilermacro (state since name replacements) (lambda (form env) (declare (ignore env))  (deprecationwarning state since name replacement) + (deprecationwarning state since name replacements) form)) (defmacro definedeprecatedfunction (state since name replacement lambdalist &body body)  (let ((doc (let ((*package* (findpackage :keyword)))  (format nil "~@<~S has been deprecated as of SBCL ~A~@[, use ~S instead~].~:>"  name since replacement)))) +(defmacro definedeprecatedfunction (state since name replacements lambdalist &body body) + (let* ((replacements (normalizedeprecationreplacements replacements)) + (doc (let ((*package* (findpackage :keyword))) + (apply #'format nil + "~@<~S has been deprecated as of SBCL ~A.~ + ~#[~; Use ~S instead.~; ~ + Use ~S or ~S instead.~:; ~ + Use~@{~#[~; or~] ~S~^,~} instead.~]~@:>" + name since replacements)))) `(progn ,(ecase state  ((:early :late)  `(defun ,name ,lambdalist  ,doc  ,@body))  ((:final)  `(progn  (declaim (ftype (function * nil) ,name))  (setf (fdefinition ',name)  (deprecatedfunction ',name ',replacement ,since))  (setf (documentation ',name 'function) ,doc)))) + ((:early :late) + `(defun ,name ,lambdalist + ,doc + ,@body)) + ((:final) + `(progn + (declaim (ftype (function * nil) ,name)) + (setf (fdefinition ',name) + (deprecatedfunction ',name ',replacements ,since)) + (setf (documentation ',name 'function) ,doc)))) (setf (compilermacrofunction ',name)  (deprecationcompilermacro ,state ,since ',name ',replacement))))) + (deprecationcompilermacro ,state ,since ',name ',replacements))))) ;;; Anaphoric macros (defmacro awhen (test &body body) diff git a/src/code/unix.lisp b/src/code/unix.lisp index 2373feb..7a1a628 100644  a/src/code/unix.lisp +++ b/src/code/unix.lisp @@ 430,12 +430,18 @@ corresponds to NAME, or NIL if there is none." (deftype exitcode () `(signedbyte 32)) (defun osexit (code &key abort) + #!+sbdoc + "Exit the process with CODE. If ABORT is true, exit is performed using _exit(2), +avoiding atexit(3) hooks, etc. Otherwise exit(2) is called." (unless (typep code 'exitcode) (setf code (if abort 1 0))) (if abort (voidsyscall ("_exit" int) code) (voidsyscall ("exit" int) code))) +(definedeprecatedfunction :early "1.0.56.55" unixexit osexit (code) + (osexit code)) + ;;; Return the process id of the current process. (definealienroutine ("getpid" unixgetpid) int)  hooks/postreceive  SBCL 