New patches: [alexandria-improper-sequences.diff Tobias C. Rittweiler **20080310215714 * package.lisp: Export DO-PROPER-LIST, PROPER-LIST-LENGTH. * lists.lisp (DO-PROPER-LIST): New Function. Signals error on dotted and circular lists. (PROPER-LIST-LENGTH): New Function. Signals error on dotted and circular lists. (PROPER-LIST-P, LASTCAR, (SETF LASTCAR)): Rewritten to use DO-PROPER-LIST. * sequences.lisp (ROTATE, SHUFFLE, RANDOM-ELT): Improve guard against dotted and circular lists. * tests.lisp (masstest.passing-improper-lists): Test case to test a bunch of sequence / list function for properly signalling an error when receiving a circular, or a dotted list. ] { hunk ./lists.lisp 103 -(defun proper-list-p (object) - "Returns true if OBJECT is a proper list." - (cond ((not object) - t) - ((consp object) - (do ((fast object (cddr fast)) - (slow (cons (car object) (cdr object)) (cdr slow))) - (nil) - (unless (and (listp fast) (consp (cdr fast))) - (return (and (listp fast) (not (cdr fast))))) - (when (eq fast slow) - (return nil)))) - (t - nil))) + +(defun signal-improper-list-error (datum) + (error 'type-error + :datum datum + :expected-type 'proper-list)) + +(defmacro do-proper-list ((var list &optional result successive-tails-p) &body body) + "Like CL:DOLIST except that a type-error is signalled if LIST is a +dotted list or a circular list. + +If SUCCESSIVE-TAILS-P is non-NIL, VAR is bound to successive tails of LIST. +Only the CAR of these tails may be modified, as per CLHS 3.6." + (let ((glist (gensym "LIST+")) + (gfast (gensym "FASTPTR+")) + (gslow (gensym "SLOWPTR+"))) + (multiple-value-bind (body decls) + (parse-body body :documentation nil) + `(do* ((,var nil) + (,glist ,list) + (,gslow ,glist (cdr ,gslow)) + (,gfast (cdr ,glist) (cddr ,gfast))) + (nil) + ,@decls + (cond ((null ,gslow) (return ,result)) + ((not (listp ,gslow)) (signal-improper-list-error ,glist)) + ((not (listp ,gfast)) (signal-improper-list-error ,glist)) + ((not (listp (cdr ,gfast))) (signal-improper-list-error ,glist)) + ((eq ,gslow ,gfast) (signal-improper-list-error ,glist)) + (t (setq ,var + (if ,successive-tails-p + ,gslow + (car ,gslow))) ; at this point, taking CAR is safe. + ,@body)))))) + +(defun proper-list-p (thing) + "Returns true if THING is a proper list." + (and (listp thing) + (listp (cdr thing)) + (values (ignore-errors (do-proper-list (x thing t)))))) hunk ./lists.lisp 149 +(defun proper-list-length (list) + "Like CL:LIST-LENGTH, except that a type-error is signalled on +dotted as well as circular lists." + ;; We don't use CL:LIST-LENGTH as that doesn't signal our error + ;; on dotted lists. + (let ((count 0)) + (do-proper-list (x list count) + (incf count)))) + hunk ./lists.lisp 161 - (do ((last list fast) - (fast list (cddr fast)) - (slow (cons (car list) (cdr list)) (cdr slow))) - (nil) - (when (endp fast) - (return (cadr last))) - (when (endp (cdr fast)) - (return (car fast))) - (when (eq fast slow) - (error 'type-error - :datum list - :expected-type '(and list (not circular-list)))))) + (let ((last nil)) + (do-proper-list (element list last) + (setq last element)))) hunk ./lists.lisp 168 - (do ((last list fast) - (fast list (cddr fast)) - (slow (cons (car list) (cdr list)) (cdr slow))) - (nil) - (when (endp fast) - (return (setf (cadr last) object))) - (when (endp (cdr fast)) - (return (setf (car fast) object))) - (when (eq fast slow) - (error 'type-error - :datum list - :expected-type '(and list (not circular-list)))))) + (let ((last nil)) + (do-proper-list (tail list nil t) + (setq last tail)) + (setf (car last) object))) hunk ./lists.lisp 214 - unless (member key keys :test #'eq) - collect key - and do (assert (cdr cell) () "Not a proper plist") - and collect (cadr cell))) + unless (member key keys :test #'eq) + collect key + and do (assert (cdr cell) () "Not a proper plist") + and collect (cadr cell))) hunk ./package.lisp 59 + #:do-proper-list + #:proper-list-length hunk ./sequences.lisp 6 - (let ((m (mod n (list-length sequence)))) - (if (null (cdr sequence)) - sequence - (let* ((tail (last sequence (+ m 1))) - (last (cdr tail))) - (setf (cdr tail) nil) - (nconc last sequence)))) + (let ((m (mod n (proper-list-length sequence)))) + (if (null (cdr sequence)) + sequence + (let* ((tail (last sequence (+ m 1))) + (last (cdr tail))) + (setf (cdr tail) nil) + (nconc last sequence)))) hunk ./sequences.lisp 23 - (let ((m (mod (1- n) (list-length sequence)))) - (if (null (cdr sequence)) - sequence - (let* ((headtail (nthcdr m sequence)) - (tail (cdr headtail))) - (setf (cdr headtail) nil) - (nconc tail sequence)))) + (let ((m (mod (1- n) (proper-list-length sequence)))) + (if (null (cdr sequence)) + sequence + (let* ((headtail (nthcdr m sequence)) + (tail (cdr headtail))) + (setf (cdr headtail) nil) + (nconc tail sequence)))) hunk ./sequences.lisp 59 - (let* ((end (or end (list-length sequence))) - (n (- end start))) + (let* ((end (or end (proper-list-length sequence))) + (n (- end start))) hunk ./sequences.lisp 62 - ((zerop n)) - (rotatef (car tail) (car (nthcdr (random n) tail))) - (decf n)))) + ((zerop n)) + (rotatef (car tail) (car (nthcdr (random n) tail))) + (decf n)))) hunk ./sequences.lisp 79 - (let ((i (+ start (random (- (or end (if (listp sequence) - (list-length sequence) - (length sequence))) - start))))) - (elt sequence i))) + (let ((length (if (listp sequence) + (proper-list-length sequence) + (length sequence)))) + (let ((i (+ start (random (- (or end length) start))))) + (elt sequence i)))) hunk ./sequences.lisp 103 + hunk ./sequences.lisp 271 - "Calls FUNCTION with each combination of LENGTH constructable from the -elements of the subsequence of SEQUENCE delimited by START and END. START + "Calls FUNCTION with each combination of LENGTH elements constructable from +the elements of the subsequence of SEQUENCE delimited by START and END. START hunk ./sequences.lisp 275 -combination, which has the same elements as the delimited subsequence.) If -COPY is true (the default) each combination is freshly allocated. If COPY is -false all combinations are EQ to each other, in which case consequences are -specified if a combination is modified by FUNCTION." +combination, which has the same elements as the delimited subsequence.) If COPY +is true (the default) each combination is freshly allocated. If COPY is false +all combinations are EQ to each other, in which case consequences are specified +if a combination is modified by FUNCTION." hunk ./tests.lisp 1432 +(defmacro cut (fn &rest args) + (let ((gensym (gensym "ARG+"))) + `(lambda (,gensym) + (apply ,fn (list ,@(substitute gensym '_ args)))))) + + +(deftest masstest.passing-improper-lists + (macrolet ((signals-error-p (form) + `(handler-case ,form + (error (e) + (search "proper" (let ((*print-circle* t)) + (princ-to-string e)) + :test #'string-equal) + )))) + (let ((circular-list (make-circular-list 5 :initial-element :foo)) + (dotted-list (list* 'a 'b 'c 'd))) + (loop for nth from 0 + for fn in (list + (cut #'lastcar _) + (cut #'rotate _ 3) + (cut #'rotate _ -3) + (cut #'shuffle _) + (cut #'random-elt _) + (cut #'last-elt _) + (cut #'ends-with :foo _) + ) + nconcing + (let ((on-circular-p (signals-error-p (funcall fn circular-list))) + (on-dotted-p (signals-error-p (funcall fn dotted-list)))) + (when (or (not on-circular-p) (not on-dotted-p)) + (append + (unless on-circular-p + (let ((*print-circle* t)) + (list + (format nil + "No appropriate error signalled when passing ~S to ~Ath entry." + circular-list nth)))) + (unless on-dotted-p + (list + (format nil + "No appropriate error signalled when passing ~S to ~Ath entry." + dotted-list nth))))))))) + nil) } Context: [Extract the body of define-constant macro into a function to avoid some warnings. attila.lendvai@gmail.com**20080310134214 (Based on patch by Tobias C. Rittweiler) ] [Fix autodoc argument list of remove-from-plistf and delete-from-plistf. attila.lendvai@gmail.com**20080301111034 Patch by Michael Weber. ] [FEATUREP accept any compound test specifier, not just the keywords :AND, :OR and :NOT. attila.lendvai@gmail.com**20080301105651 Patch by Stelian Ionescu. ] [Fix file dependencies in the .asd attila.lendvai@gmail.com**20080301105628] [Added an almost full implementation of CDR5 attila.lendvai@gmail.com**20080301100637] [fix removef and deletef not to use an inline lambda nikodemus@random-state.net**20080223171025 CLHS says the third argument to DEFINE-MODIFY-MACRO must be a symbol. Reported by Chun Tian. ] [fix WHICHEVER Nikodemus Siivola **20080217071955 * More efficient with constant arguments. * Respect lexical environment with non-constant arguments. ] [extended ONCE-ONLY Nikodemus Siivola **20080217071829 * Support (once-only ((nx x)) ...) style also. ] [new macro: DOPLIST Nikodemus Siivola **20080217071024 * Like DOLIST, but iterates over plists. ] [fix tests: DELETEF.1 modified constant data Nikodemus Siivola **20080217070803 * ...so that running tests multiple times caused unrelated tests to fail due to coalesced constants being frobbed. Gah. ] [Extract the function name of KEY too, not just TEST in GENERATE-SWITCH-BODY. attila.lendvai@gmail.com**20080209201446 Patch by Stelian Ionescu. ] [fix dependency: macros.lisp is using MAKE-GENSYM-LIST from symbols.lisp attila.lendvai@gmail.com**20071221100634] [NTH-VALUE-OR Nikodemus Siivola **20071219132132 * Thanks to Andreas Fuchs -- I only took the liberty of changing the name from MULTIPLE-VALUE-OR to NTH-VALUE-OR. ] [fix SANS -> REMOVE-FROM-PLIST in tests Nikodemus Siivola **20071219130641 * So SANS is now REMOVE-FROM-PLIST. ...I have to say that I'm still not sure I like this: (remove-from-plist x y) ; which is the plist? The common usage in REMOVE &co is to put the element designators first. This is confusing. Maybe we really want both: function SANS plist &rest keys function REMOVE-FROM-PLIST keys plist ] [fix MAKE-GENSYM-LIST when called without the second argument Nikodemus Siivola **20071219130559 * plus a test-case ] [better SHUFFLE Nikodemus Siivola **20071219125911 * Thanks to Sean Ross: implement the Fisher/Yates/Knuth algorithm correctly. * As penance, specialize for lists as well: travel along the list, swapping towards the end -- marginally more efficient then swapping along the whole length. ] [ENSURE-GETHASH Nikodemus Siivola **20071219125800 * new function: like GETHASH, but saves the default value in table if key is not found.* ] [fixed and robustified tests Nikodemus Siivola **20071219125512] [Switch the argument order of STARTS/ENDS-WITH-SUBSEQ to that it matches STARTS/ENDS-WITH. attila.lendvai@gmail.com**20071126135259] [Fix map-permutations typo. levente.meszaros@gmail.com**20071102163851] [fix: darcs merge conflict was recorded into package.lisp attila.lendvai@gmail.com**20071031173831] [Merge conflicts around the conditions attila.lendvai@gmail.com**20071001122707] [Simplify IGNORE-SOME-CONDITIONS's docstring. Luis Oliveira **20070823040556] [New macro: IGNORE-SOME-CONDITIONS Luis Oliveira **20070726171110] [New macro: NCONCF Luis Oliveira **20070720003523 - Added respective documentation to the manual. - New test: NCONCF.1 ] [New function: FEATUREP Luis Oliveira **20070720003420 Added respective documentation in manual as well. ] [New macro: COERCEF Luis Oliveira **20070720003607 Added respective documentation to the manual. ] [Small fix to REQUIRED-ARGUMENT's control string. Luis Oliveira **20070823040500] [Fix some type declarations for CLISP-compatibility. Stelian Ionescu **20070806160206 Type declareations like ((or fixnum null) bar) or (unsigned-byte foo) don't work on CLISP. Must use (type unsigned-byte foo) instead. ] [Remove trailing whitespace in source code Luis Oliveira **20070711140350] [Renamed errors.lisp to conditions.lisp attila.lendvai@gmail.com**20070827161429] [Added simple-style-warning function and condition. attila.lendvai@gmail.com**20070827005343] [sane named-lambda Nikodemus Siivola **20070809171107] [Use a shared expander for the SWITCH macros attila.lendvai@gmail.com**20070802120334 - support #'eq and 'eq style :test arg - support T and OTHERWISE clause instead of the :default keyword arg ] [Make define-constant understand :test 'string= and #'string=. Feel free to 'darcs undo' it if it's considered too dwim'y. attila.lendvai@gmail.com**20070706215246] [DECLAIM, not DECLARE. Nikodemus Siivola **20070703103139] [Combinations, permutations, and derangements Nikodemus Siivola **20070701122604] [Factorial, binomial-coefficient, subfactorial, and count-permutations. Nikodemus Siivola **20070701122419] [Compiler-macro for OF-TYPE Nikodemus Siivola **20070701122227] [ENSURE-CAR Nikodemus Siivola **20070701122110] [ENSURE-FUNCTION Nikodemus Siivola **20070701121903] [Documentation and comment tweaks Nikodemus Siivola **20070701121316] [deftype for ARRAY-LENGTH Nikodemus Siivola **20070701120827] [Added starts-with-subseq and ends-with-subseq attila.lendvai@gmail.com**20070625193029] [Added delete-from-plist, delete-from-plistf, remove-from-plistf. attila.lendvai@gmail.com**20070625191357] [MAP-IOTA, misc. fixes, and tests up to 100% coverage Nikodemus Siivola **20070601143059] [Nothing Can Stop The Progressive Revolution Nikodemus Siivola **20070601123336 Added: * XOR * WHICHEVER * SWITCH, ESWITCH, CSWItCH * UNIONF, NUNIONF * ALIST-PLIST, PLIST-ALIST * ENSURE-CONS * NAMED-LAMDBA * DEFINE-CONSTANT * STRING-DESIGNATOR Note: Documentation strings of many new operators are sorely lacking, particularly NAMED-LAMBDA and *SWITCH. ] [Added a faster loop based remove-from-plist attila.lendvai@gmail.com**20070501144915] [Added a REMOVE-FROM-PLIST (same as SANS) attila.lendvai@gmail.com**20070501143706] [Docstring typo attila.lendvai@gmail.com**20070501143516] [Fix when-let documentation string. langstefan@gmx.at**20070318132238] [Patch by Tayssin John Gabbour, fixing two typos. Nikodemus Siivola **20070318015005] [with-gensyms Nikodemus Siivola **20070225160042] [required-argument Nikodemus Siivola **20070225160010] [IF-LET, IF-LET*, WHEN-LET, and WHEN-LET* Nikodemus Siivola **20061107104944] [Extended parse-body with a :whole arg, report multiple docstring error. attila.lendvai@gmail.com**20061022105744] [Added (declare (ignore sub)) for type= attila.lendvai@gmail.com**20061017155937] [SETF-functions for lastcar, first-elt, and last-elt. :KEY and :TEST for starts-with and ends-with Nikodemus Siivola **20061017155126] [new: flatten, map-product, setp. fixed: set-equal Nikodemus Siivola **20061016150600] [REMOVE-KEYS renamed to SANS, with new --arguably better-- argument order Nikodemus Siivola **20061016125413] [ROTATE-RIGHT and ROTATE-LEFT replaced by a single function ROTATE Nikodemus Siivola **20061016123238] [variance and standard-deviation biased by default, documentation fixes for both Nikodemus Siivola **20061016114618] [documentation Nikodemus Siivola **20061015215052] [Added .boring and added public_html to it, so you can darcs get it into your local alexandria repo attila.lendvai@gmail.com**20061015170133] [tests passing Nikodemus Siivola **20061015160607] [initial version Nikodemus Siivola **20061015154202] Patch bundle hash: 738579ed18a0492b17e799912705edb60ffbc56f