diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..e397539 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: + - package-ecosystem: "github-actions" + directory: "/.github/workflows/" + schedule: + interval: "weekly" diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml new file mode 100644 index 0000000..d3112c6 --- /dev/null +++ b/.github/workflows/test.yml @@ -0,0 +1,39 @@ +name: test + +on: + workflow_dispatch: + push: + branches: [ master ] + pull_request: + +jobs: + test: + name: ${{ matrix.lisp }} + defaults: + run: + shell: bash -l {0} + strategy: + fail-fast: false + matrix: + lisp: + - abcl + - acl + - ccl + - clasp + - cmucl + - ecl + - sbcl + runs-on: ubuntu-latest + container: + image: ghcr.io/yitzchak/archlinux-cl:latest + options: --security-opt seccomp:unconfined + steps: + - name: Checkout Repository + uses: actions/checkout@v4 + - name: Setup Lisp Environment + run: | + make-rc + asdf-add + - name: Run ANSI Tests + run: | + lisp -i ${{ matrix.lisp }} -e "(ql:quickload :constrictor-extrinsic/ansi-test)" -e "(constrictor-extrinsic/ansi-test:test :exit t)" diff --git a/Code/accessors.lisp b/Code/accessors.lisp index 5e9c51d..22d72b4 100644 --- a/Code/accessors.lisp +++ b/Code/accessors.lisp @@ -581,7 +581,7 @@ (defun (setf first) (new-value cons) (declare (inline rplaca cdr)) - (rplaca (cdr cons) new-value) + (rplaca cons new-value) new-value) (declaim (notinline (setf first))) diff --git a/Code/adjoin.lisp b/Code/adjoin.lisp index cedd439..f984827 100644 --- a/Code/adjoin.lisp +++ b/Code/adjoin.lisp @@ -7,12 +7,13 @@ (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (loop for remaining on list - when (apply-test item (apply-key (car remaining))) + when (apply-test (apply-key item) (apply-key (car remaining))) return list finally (if (null remaining) (return (cons item list)) - (error 'list-must-be-proper - :offending-list list)))))) + (error 'type-error + :datum list + :expected-type 'proper-list)))))) (declaim (notinline adjoin-core)) @@ -42,7 +43,7 @@ arguments (butlast lambda-list) '(adjoin-core - item alist + item list key key-supplied-p test test-supplied-p test-not test-not-supplied-p)))) diff --git a/Code/ansi-test/expected-failures.sexp b/Code/ansi-test/expected-failures.sexp new file mode 100644 index 0000000..7fc9aaf --- /dev/null +++ b/Code/ansi-test/expected-failures.sexp @@ -0,0 +1,4 @@ +#+(or clasp ecl sbcl) :NIL-VECTORS-ARE-STRINGS +#+(or clasp ecl) :ALLOW-NIL-ARRAYS +#+(or clasp ecl) :MAKE-CONDITION-WITH-COMPOUND-NAME +#+(or clasp ecl) :NO-FLOATING-POINT-UNDERFLOW-BY-DEFAULT diff --git a/Code/ansi-test/packages.lisp b/Code/ansi-test/packages.lisp new file mode 100644 index 0000000..805f892 --- /dev/null +++ b/Code/ansi-test/packages.lisp @@ -0,0 +1,5 @@ +(cl:in-package #:common-lisp-user) + +(defpackage #:constrictor-extrinsic/ansi-test + (:use #:cl) + (:export #:test)) diff --git a/Code/ansi-test/test.lisp b/Code/ansi-test/test.lisp new file mode 100644 index 0000000..4feb8ba --- /dev/null +++ b/Code/ansi-test/test.lisp @@ -0,0 +1,197 @@ +(cl:in-package #:constrictor-extrinsic/ansi-test) + +(defvar *tests* + '("ACONS." + "ADJOIN." + "APPEND." + "ASSOC-IF-NOT." + "ASSOC-IF." + "ASSOC." + "ATOM." + "BUTLAST." + "CAAAAR." + "CAAADR." + "CAAAR." + "CAADAR." + "CAADDR." + "CAADR." + "CAAR." + "CADAAR." + "CADADR." + "CADAR." + "CADDAR." + "CADDDR." + "CADDR." + "CADR." + "CAR-" + "CAR." + "CDAAAR." + "CDAADR." + "CDAAR." + "CDADAR." + "CDADDR." + "CDADR." + "CDAR." + "CDDAAR." + "CDDADR." + "CDDAR." + "CDDDAR." + "CDDDDR." + "CDDDR." + "CDDR." + "CDR." + "CONS-OF" + "CONS-WITH" + "CONS-EQ" + "CONS." + "CONSP." + "COPY-ALIST." + "COPY-LIST." + "COPY-TREE." + "ENDP-" + "ENDP." + "FIRST-ETC" + "GET-PROPERTIES." + "GETF." + "INCF-GETF." + "INTERSECTION." + "INTERSECTIONALLOW-OTHER-KEYS." + "LAST." + "LDIFF-" + "LDIFF." + "LIST*" + "LIST-LIST" + "LIST-LENGTH-" + "LIST-LENGTH." + "LIST." + "LISTP-" + "LISTP." + "MAKE-LIST-" + "MAKE-LIST." + "MAPC." + "MAPCAN." + "MAPCAR." + "MAPCON." + "MAPL." + "MAPLIST." + "MEMBER-IF-NOT." + "MEMBER-IF." + "MEMBER." + "NBUTLAST." + "NCONC." + "NINTERSECTION." + "NRECONC." + "NSET-DIFFERENCE." + "NSET-EXCLUSIVE-OR." + "NSET-EXCLUSIVE." + "NSUBLIS." + "NSUBST-IF-NOT." + "NSUBST-IF." + "NSUBST." + "NTH." + "NTHCDR." + "NUNION." + "PAIRLIS." + "POP." + "PUSH-GETF." + "PUSH." + "PUSHNEW." + "RANDOM-NSET-EXCLUSIVE-OR" + "RANDOM-SET-EXCLUSIVE-OR" + "RASSOC-IF-NOT." + "RASSOC-IF." + "RASSOC." + "RASSOCI." + "REMF." + "REST." + "REVAPPEND." + "RPLACA." + "RPLACD." + "SET-DIFFERENCE." + "SET-EXCLUSIVE-OR." + "SET-EXCLUSIVE." + "SETF-GETF." + "SUBLIS." + "SUBSETP." + "SUBST-IF-NOT." + "SUBST-IF." + "SUBST." + "TAILP." + "TREE-EQUAL." + "UNION-" + "UNION.")) + +(deftype constrictor:null + () + 'null) + +(deftype constrictor:list + () + 'list) + +(deftype constrictor:member + (&rest items) + `(member ,@items)) + +(defvar *extrinsic-symbols* + '(constrictor:caar constrictor:cadr constrictor:cdar constrictor:cddr + constrictor:caaar constrictor:caadr constrictor:cadar constrictor:caddr + constrictor:cdaar constrictor:cdadr constrictor:cddar constrictor:cdddr + constrictor:caaaar constrictor:caaadr constrictor:caadar constrictor:caaddr + constrictor:cadaar constrictor:cadadr constrictor:caddar constrictor:cadddr + constrictor:cdaaar constrictor:cdaadr constrictor:cdadar constrictor:cdaddr + constrictor:cddaar constrictor:cddadr constrictor:cdddar constrictor:cddddr + constrictor:first constrictor:second constrictor:third constrictor:fourth constrictor:fifth + constrictor:sixth constrictor:seventh constrictor:eighth constrictor:ninth constrictor:tenth + constrictor:nth constrictor:nthcdr + constrictor:null + constrictor:endp + constrictor:make-list + constrictor:copy-list + constrictor:list-length + constrictor:tree-equal + constrictor:copy-tree + constrictor:append + constrictor:nconc + constrictor:revappend + constrictor:nreconc + constrictor:copy-alist + constrictor:list constrictor:list* + constrictor:subst constrictor:subst-if constrictor:subst-if-not + constrictor:sublis constrictor:nsublis + constrictor:nsubst constrictor:nsubst-if constrictor:nsubst-if-not + constrictor:member constrictor:member-if constrictor:member-if-not + constrictor:assoc constrictor:assoc-if constrictor:assoc-if-not + constrictor:rassoc constrictor:rassoc-if constrictor:rassoc-if-not + constrictor:get-properties + constrictor:pairlis + constrictor:last constrictor:butlast constrictor:nbutlast + constrictor:acons + constrictor:mapcar constrictor:mapc constrictor:mapcan constrictor:maplist constrictor:mapl constrictor:mapcon + constrictor:tailp constrictor:ldiff + constrictor:push constrictor:pop + constrictor:getf + constrictor:remf + constrictor:adjoin + constrictor:pushnew + constrictor:intersection constrictor:nintersection + constrictor:set-difference constrictor:nset-difference + constrictor:union constrictor:nunion + constrictor:set-exclusive-or constrictor:nset-exclusive-or + constrictor:subsetp)) + +(defun test (&rest args) + (let ((system (asdf:find-system :constrictor-extrinsic/ansi-test))) + (apply #'ansi-test-harness:ansi-test + :directory (merge-pathnames + (make-pathname :directory '(:relative + "dependencies" + "ansi-test")) + (asdf:component-pathname system)) + :expected-failures (asdf:component-pathname + (asdf:find-component system + '("code" + "expected-failures.sexp"))) + :extrinsic-symbols *extrinsic-symbols* + :tests *tests* + args))) diff --git a/Code/append.lisp b/Code/append.lisp index 2a56d56..b56e584 100644 --- a/Code/append.lisp +++ b/Code/append.lisp @@ -9,21 +9,12 @@ (result (first reverse)) (remaining (cdr reverse))) (loop for object in remaining - do (cond ((null object) - nil) - ((atom object) - (error 'list-expected :datum object)) - (t - ;; At least we have a non-empty list. But it - ;; could be dotted. It could also be circular, - ;; but we don't check for that. - (multiple-value-bind (copy last) - (copy-list-and-last object) - (if (null (cdr last)) - (progn (rplacd last result) - (setq result copy)) - (error 'list-must-be-proper - :offending-list object)))))) + unless (null object) + do (assert-proper-list object) + (multiple-value-bind (copy last) + (copy-list-and-last object) + (rplacd last result) + (setq result copy))) result))) (declaim (notinline append)) @@ -43,16 +34,12 @@ (,second-form-variable ,(second list-forms))) (cond ((null ,first-form-variable) ,second-form-variable) - ((atom ,first-form-variable) - (error 'list-expected :datum ,first-form-variable)) (t + (assert-proper-list ,first-form-variable) (multiple-value-bind (,copy-variable ,last-variable) (copy-list-and-last ,first-form-variable) - (if (null (cdr ,last-variable)) - (progn (rplacd ,last-variable ,second-form-variable) - ,copy-variable) - (error 'list-must-be-proper - :offending-list ,first-form-variable)))))))) + (rplacd ,last-variable ,second-form-variable) + ,copy-variable)))))) (otherwise form))) (setf (documentation 'append 'function) diff --git a/Code/constrictor-extrinsic.asd b/Code/constrictor-extrinsic.asd index b8db3b7..72b9d00 100644 --- a/Code/constrictor-extrinsic.asd +++ b/Code/constrictor-extrinsic.asd @@ -3,3 +3,19 @@ :description "Implementation of the Conses dictionary, extrinsic system." :depends-on (#:constrictor-packages-extrinsic #:constrictor-common)) + +(asdf:defsystem "constrictor-extrinsic/ansi-test" + :description "ANSI Test system for Constrictor" + :license "BSD" + :author ("Robert Strandh" + "Tarn W. Burton") + :depends-on ("constrictor-extrinsic" + "ansi-test-harness") + :perform (asdf:test-op (op c) + (uiop:symbol-call :constrictor-extrinsic/ansi-test :test)) + :components ((:module code + :pathname "ansi-test/" + :serial t + :components ((:file "packages") + (:file "test") + (:static-file "expected-failures.sexp"))))) diff --git a/Code/copy-alist.lisp b/Code/copy-alist.lisp index 7f50cea..11b1a8e 100644 --- a/Code/copy-alist.lisp +++ b/Code/copy-alist.lisp @@ -4,7 +4,7 @@ (defun copy-alist (alist) (let ((reversed-result '())) - (with-alist-elements (element alist) + (with-alist-elements (element alist :preserve-nil t) (push (if (consp element) (cons (car element) (cdr element)) ;; The element is an atom only if the restart USE was diff --git a/Code/intersection.lisp b/Code/intersection.lisp index bf6ab95..3b889a3 100644 --- a/Code/intersection.lisp +++ b/Code/intersection.lisp @@ -4,8 +4,8 @@ (defun intersection-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (loop with result = '() @@ -13,7 +13,7 @@ do (loop for element-2 in list-2 when (apply-test (apply-key element-1) (apply-key element-2)) - do (push element-2 result)) + do (push element-1 result)) finally (return result))))) (declaim (notinline intersection-core)) diff --git a/Code/ldiff.lisp b/Code/ldiff.lisp index 6cbab90..d529d20 100644 --- a/Code/ldiff.lisp +++ b/Code/ldiff.lisp @@ -1,15 +1,15 @@ (cl:in-package #:constrictor) -(defun copy-front (list object) - (loop for tail on list - until (eq object tail) - collect (car tail))) - (defun ldiff (list object) + (check-type list list) (loop for tail on list - when (eq object tail) - return (copy-front list object) - finally (return (copy-list list)))) + until (eql object tail) + when (and (atom (cdr tail)) + (not (eql object (cdr tail)))) + nconc (cons (car tail) + (cdr tail)) + else + collect (car tail))) (setf (documentation 'ldiff 'function) (format nil diff --git a/Code/list-length.lisp b/Code/list-length.lisp index 310d526..1cb30b8 100644 --- a/Code/list-length.lisp +++ b/Code/list-length.lisp @@ -2,30 +2,21 @@ (declaim (inline list-length)) -(defun list-length (list) - (cond ((null list) - 0) - ((atom list) - (error 'list-must-be-proper-or-circular - :datum list)) - (t - (let ((fast list) - (slow list) - (count 0)) - (loop do (pop fast) - (incf count) - until (atom fast) - do (pop fast) - (incf count) - (pop slow) - until (or (atom fast) (eq fast slow)) - finally (cond ((null fast) - (return count)) - ((eq fast slow) - nil) - (t - (error 'list-must-be-proper-or-circular - :datum list)))))))) +(defun list-length (x) + (prog ((count 0) + (step2 x) + (step1 x)) + next + (when (endp step2) + (return count)) + (when (endp (cdr step2)) + (return (+ count 1))) + (incf count 2) + (setf step2 (cddr step2) + step1 (cdr step1)) + (unless (and (eq step2 step1) + (plusp count)) + (go next)))) (declaim (notinline list-length)) diff --git a/Code/mapcar.lisp b/Code/mapcar.lisp index 412d94d..42d0ec5 100644 --- a/Code/mapcar.lisp +++ b/Code/mapcar.lisp @@ -36,7 +36,7 @@ :datum rest1 :offending-list list1)) (unless (listp rest2) - (error 'list-must-not-be-dottes + (error 'list-must-not-be-dotted :datum rest2 :offending-list list2))))) (t @@ -48,9 +48,9 @@ finally (let ((position (position-if-not #'listp local-lists))) (unless (null position) - (error 'list-must-be-proper - :datum (find-if-not #'listp local-lists) - :offending-list (elt lists position)))))))))) + (error 'type-error + :datum (elt lists position) + :expected-type 'proper-list))))))))) (declaim (notinline mapcar)) diff --git a/Code/member-if-not.lisp b/Code/member-if-not.lisp index 063a719..4590b0f 100644 --- a/Code/member-if-not.lisp +++ b/Code/member-if-not.lisp @@ -13,7 +13,7 @@ (declaim (inline member-if-not)) (defun member-if-not (predicate list &key (key nil key-supplied-p)) - (member-core predicate list key key-supplied-p)) + (member-if-not-core predicate list key key-supplied-p)) (declaim (notinline member-if-not)) diff --git a/Code/member-if.lisp b/Code/member-if.lisp index 6114758..2ffa697 100644 --- a/Code/member-if.lisp +++ b/Code/member-if.lisp @@ -13,7 +13,7 @@ (declaim (inline member-if)) (defun member-if (predicate list &key (key nil key-supplied-p)) - (member-core predicate list key key-supplied-p)) + (member-if-core predicate list key key-supplied-p)) (declaim (notinline member-if)) diff --git a/Code/nintersection.lisp b/Code/nintersection.lisp index 7e1b29b..c0c2dde 100644 --- a/Code/nintersection.lisp +++ b/Code/nintersection.lisp @@ -4,8 +4,8 @@ (defun nintersection-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (when (null list-1) (return-from nintersection-core '())) (with-key (key key-supplied-p) diff --git a/Code/nset-difference.lisp b/Code/nset-difference.lisp index 80351be..1b0270e 100644 --- a/Code/nset-difference.lisp +++ b/Code/nset-difference.lisp @@ -4,8 +4,8 @@ (defun nset-difference-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (when (null list-1) (return-from nset-difference-core '())) (with-key (key key-supplied-p) diff --git a/Code/nset-exclusive-or.lisp b/Code/nset-exclusive-or.lisp index ddc712a..4282850 100644 --- a/Code/nset-exclusive-or.lisp +++ b/Code/nset-exclusive-or.lisp @@ -2,10 +2,12 @@ (declaim (inline nset-exclusive-or-core)) +;;; This is seriously broken. Until it is fixed we'll just use +;;; set-exclusive-or-core. (defun nset-exclusive-or-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (cond ((null list-1) list-2) ((null list-2) @@ -46,10 +48,10 @@ (key #'identity key-supplied-p) (test #'eql test-supplied-p) (test-not #'eql test-not-supplied-p)) - (nset-exclusive-or-core list-1 list-2 - key key-supplied-p - test test-supplied-p - test-not test-not-supplied-p)) + (set-exclusive-or-core list-1 list-2 + key key-supplied-p + test test-supplied-p + test-not test-not-supplied-p)) (define-compiler-macro nset-exclusive-or (&whole form &rest arguments) (let ((lambda-list @@ -65,7 +67,7 @@ (compute-compiler-macro-body arguments (butlast lambda-list) - '(nset-exclusive-or-core + '(set-exclusive-or-core list-1 list-2 key key-supplied-p test test-supplied-p diff --git a/Code/nsublis.lisp b/Code/nsublis.lisp index fd7068d..d4f0260 100644 --- a/Code/nsublis.lisp +++ b/Code/nsublis.lisp @@ -4,36 +4,21 @@ (defun nsublis-core (alist tree key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (labels ((nsublis-local (tree) - (let ((entry (assoc-core (car tree) alist - key key-supplied-p - test test-supplied-p - test-not test-not-supplied-p))) - (if (null entry) - (if (atom (car tree)) - nil - (nsublis-local (car tree))) - (rplaca tree (cdr entry)))) - (let ((entry (assoc-core (cdr tree) alist - key key-supplied-p - test test-supplied-p - test-not test-not-supplied-p))) - (if (null entry) - (if (atom (cdr tree)) - nil - (nsublis-local (cdr tree))) - (rplacd tree (cdr entry)))))) - (let ((entry (assoc-core tree alist - key key-supplied-p - test test-supplied-p - test-not test-not-supplied-p))) - (if (null entry) - (if (atom tree) - tree - (progn (nsublis-local (car tree)) - (nsublis-local (cdr tree)) - tree)) - (cdr entry))))) + (with-key (key key-supplied-p) + (labels ((nsublis-local (tree) + (let ((entry (assoc-core (apply-key tree) alist + nil nil + test test-supplied-p + test-not test-not-supplied-p))) + (cond ((consp entry) + (cdr entry)) + ((consp tree) + (rplaca tree (nsublis-local (car tree))) + (rplacd tree (nsublis-local (cdr tree))) + tree) + (t + tree))))) + (nsublis-local tree)))) (declaim (notinline nsublis-core)) diff --git a/Code/nsubst.lisp b/Code/nsubst.lisp index be83566..03db928 100644 --- a/Code/nsubst.lisp +++ b/Code/nsubst.lisp @@ -7,7 +7,7 @@ (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (labels ((nsubst-local (tree) - (cond ((apply-test (apply-key (car tree)) old) + (cond ((apply-test old (apply-key (car tree))) (rplaca tree new)) ((atom (car tree)) nil) diff --git a/Code/nth.lisp b/Code/nth.lisp index f587ab8..a9d61df 100644 --- a/Code/nth.lisp +++ b/Code/nth.lisp @@ -3,7 +3,7 @@ (declaim (inline nth)) (defun nth (n list) - (car (nthcr n list))) + (car (nthcdr n list))) (declaim (notinline nth)) diff --git a/Code/nthcdr.lisp b/Code/nthcdr.lisp index 6c4dac9..4eff167 100644 --- a/Code/nthcdr.lisp +++ b/Code/nthcdr.lisp @@ -3,6 +3,7 @@ (declaim (inline nthcdr)) (defun nthcdr (n list) + (check-type n (integer 0)) (unless (listp list) (error 'list-expected :datum list)) (loop for result = list then (cdr result) diff --git a/Code/nunion.lisp b/Code/nunion.lisp index be0381f..1e991fd 100644 --- a/Code/nunion.lisp +++ b/Code/nunion.lisp @@ -4,8 +4,8 @@ (defun nunion-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (loop with result = list-2 diff --git a/Code/pairlis.lisp b/Code/pairlis.lisp index 895a175..67c3ad6 100644 --- a/Code/pairlis.lisp +++ b/Code/pairlis.lisp @@ -10,11 +10,13 @@ do (push (cons (first rest-keys) (first rest-data)) result) finally (unless (listp rest-keys) - (error 'list-must-be-proper - :offending-list keys)) + (error 'type-error + :datum keys + :expected-type 'proper-list)) (unless (listp rest-data) - (error 'list-must-be-proper - :offending-list data)) + (error 'type-error + :datum data + :expected-type 'proper-list)) (unless (and (null rest-keys) (null rest-data)) (error 'keys-and-data-must-have-the-same-length :keys keys diff --git a/Code/pushnew.lisp b/Code/pushnew.lisp index 07387bc..07c4d14 100644 --- a/Code/pushnew.lisp +++ b/Code/pushnew.lisp @@ -3,21 +3,19 @@ (defmacro pushnew (item place &environment environment - &key - (key nil key-supplied-p) - (test nil test-supplied-p) - (test-not nil test-not-supplied-p)) + &rest rest + &key key (test nil test-supplied-p) (test-not nil test-not-supplied-p)) + (declare (ignore key test test-not)) (if (and test-supplied-p test-not-supplied-p) (progn (warn 'warn-both-test-and-test-not-given) `(error 'both-test-and-test-not-given)) - (multiple-value-bind (vars vals store-vars writer-form reader-form) - (get-setf-expansion place environment) - `(let (,@(mapcar #'list vars vals)) - (let ((,(car store-vars) - (adjoin-core ,item ,reader-form - ,key ,key-supplied-p - ,test ,test-supplied-p - ,test-not ,test-not-supplied-p))) + (let ((item-var (gensym))) + (multiple-value-bind (vars vals store-vars writer-form reader-form) + (get-setf-expansion place environment) + `(let* ((,item-var ,item) + ,@(mapcar #'list vars vals) + (,(car store-vars) + (adjoin ,item-var ,reader-form ,@rest))) ,writer-form))))) (setf (documentation 'pushnew 'function) diff --git a/Code/remf.lisp b/Code/remf.lisp index 485595d..c42d3a5 100644 --- a/Code/remf.lisp +++ b/Code/remf.lisp @@ -15,8 +15,8 @@ (store-var (car store-vars))) `(block nil (let ,(mapcar #'list vars vals) - (let* ((,store-var ,reader-form) - (,indicator-value-variable ,indicator)) + (let* ((,indicator-value-variable ,indicator) + (,store-var ,reader-form)) (when (null ,store-var) (return nil)) (maybe-error ,store-var consp list ,store-var) @@ -31,8 +31,8 @@ ;; There are no more pairs to test, so we are ;; done. (return nil)) - (maybe-error (cdr rest) atom list ,store-var) - (maybe-error (cddr rest) atom cons ,store-var) + ;(maybe-error (cdr rest) atom list ,store-var) + ;(maybe-error (cddr rest) atom cons ,store-var) (when (eq ,indicator-value-variable (cadr rest)) ;; We found a match. (setf (cdr rest) (cdddr rest)) diff --git a/Code/set-difference.lisp b/Code/set-difference.lisp index 8bd86bf..d511c4d 100644 --- a/Code/set-difference.lisp +++ b/Code/set-difference.lisp @@ -4,8 +4,8 @@ (defun set-difference-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (loop with result = '() diff --git a/Code/set-exclusive-or.lisp b/Code/set-exclusive-or.lisp index c519bb8..aba2555 100644 --- a/Code/set-exclusive-or.lisp +++ b/Code/set-exclusive-or.lisp @@ -4,8 +4,8 @@ (defun set-exclusive-or-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (let ((result '())) diff --git a/Code/sublis.lisp b/Code/sublis.lisp index fd868f7..45d1064 100644 --- a/Code/sublis.lisp +++ b/Code/sublis.lisp @@ -4,18 +4,19 @@ (defun sublis-core (alist tree key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (labels ((sublis-local (tree) - (let ((entry (assoc-core tree alist - key key-supplied-p - test test-supplied-p - test-not test-not-supplied-p))) - (if (null entry) - (if (atom tree) - tree - (cons (sublis-local (car tree)) - (sublis-local (cdr tree)))) - (cdr entry))))) - (sublis-local tree))) + (with-key (key key-supplied-p) + (labels ((sublis-local (tree) + (let ((entry (assoc-core (apply-key tree) alist + nil nil + test test-supplied-p + test-not test-not-supplied-p))) + (if (null entry) + (if (atom tree) + tree + (cons (sublis-local (car tree)) + (sublis-local (cdr tree)))) + (cdr entry))))) + (sublis-local tree)))) (declaim (notinline sublis-core)) diff --git a/Code/subsetp.lisp b/Code/subsetp.lisp index 6f1add2..d7a0497 100644 --- a/Code/subsetp.lisp +++ b/Code/subsetp.lisp @@ -4,14 +4,15 @@ (defun subsetp-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (loop for element-1 in list-1 - unless (member-core - element-1 list-2 - key key-supplied-p - test test-supplied-p - test-not test-not-supplied-p) - return nil - finally (return t))) + (with-key (key key-supplied-p) + (loop for element-1 in list-1 + unless (member-core + (apply-key element-1) list-2 + key key-supplied-p + test test-supplied-p + test-not test-not-supplied-p) + return nil + finally (return t)))) (declaim (notinline subsetp-core)) diff --git a/Code/subst.lisp b/Code/subst.lisp index 2b9703c..f6c0101 100644 --- a/Code/subst.lisp +++ b/Code/subst.lisp @@ -7,7 +7,7 @@ (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (labels ((subst-local (tree) - (cond ((apply-test (apply-key tree) old) + (cond ((apply-test old (apply-key tree)) new) ((atom tree) tree) (t (cons (subst-local (car tree)) diff --git a/Code/tailp.lisp b/Code/tailp.lisp index ef183b1..09d8277 100644 --- a/Code/tailp.lisp +++ b/Code/tailp.lisp @@ -2,9 +2,9 @@ (defun tailp (object list) (loop for tail on list - when (eq object tail) + when (eql object tail) return t - finally (return (eq object tail)))) + finally (return (eql object tail)))) (setf (documentation 'tailp 'function) (format nil diff --git a/Code/traversal-macros.lisp b/Code/traversal-macros.lisp index 437a24e..82e8dd3 100644 --- a/Code/traversal-macros.lisp +++ b/Code/traversal-macros.lisp @@ -21,8 +21,9 @@ until (atom ,rest-variable) do ,@body finally (unless (null ,rest-variable) - (error 'list-must-be-proper - :offending-list ,list-variable))))) + (error 'type-error + :datum ,list-variable + :expected-type 'proper-list))))) ;;; This macro can be used to traverse a list that must be a proper ;;; list, when each tail of the list must be examined. Client code @@ -37,8 +38,9 @@ until (atom ,rest-variable) do ,@body finally (unless (null ,rest-variable) - (error 'list-must-be-proper - :offending-list ,list-variable))))) + (error 'type-error + :datum ,list-variable + :expected-type 'proper-list))))) (defun read-new-cons () (format *query-io* @@ -46,7 +48,8 @@ (finish-output *query-io*) (list (read *query-io*))) -(defmacro with-alist-elements ((element-variable alist) &body body) +(defmacro with-alist-elements ((element-variable alist &key preserve-nil) + &body body) ;; We can use for ... on, because it uses atom to test the end ;; of the list (let ((rest-variable (gensym)) @@ -62,11 +65,12 @@ do (let ((,element-variable (car ,rest-variable))) #+sbcl (declare (sb-ext:muffle-conditions sb-ext:compiler-note)) - (cond ((null ,element-variable) - ;; The standard says that NIL in an association - ;; list is ignored. - nil) - ((consp ,element-variable) + (cond ,@(unless preserve-nil + `(((null ,element-variable) + ;; The standard says that NIL in an association + ;; list is ignored. + nil))) + ((listp ,element-variable) (progn ,@body)) (t (loop until (consp ,element-variable) @@ -142,7 +146,7 @@ ,@body)) (t (macrolet ((apply-test (form1 form2) - `(funcall ,',test ,form1 ,form2))) + `(values (funcall ,',test ,form1 ,form2)))) ,@body))) (cond ((or (eq ,test-not #'eql) (eq ,test-not 'eql)) diff --git a/Code/tree-equal.lisp b/Code/tree-equal.lisp index cc9e798..403411a 100644 --- a/Code/tree-equal.lisp +++ b/Code/tree-equal.lisp @@ -27,8 +27,7 @@ '((tree-1 tree-2) ; required () ; optional nil ; rest - ((:key key key-supplied-p) - (:test test test-supplied-p) + ((:test test test-supplied-p) (:test-not test-not test-not-supplied-p)) nil))) (unless (check-call-site arguments lambda-list) @@ -36,8 +35,7 @@ (compute-compiler-macro-body arguments (butlast lambda-list) - '(tree-equal-core-core + '(tree-equal-core tree-1 tree-2 - key key-supplied-p test test-supplied-p test-not test-not-supplied-p)))) diff --git a/Code/union.lisp b/Code/union.lisp index 1a37279..327930c 100644 --- a/Code/union.lisp +++ b/Code/union.lisp @@ -4,8 +4,8 @@ (defun union-core (list-1 list-2 key key-supplied-p test test-supplied-p test-not test-not-supplied-p) - (assert-proper-list list-1) - (assert-proper-list list-2) + (check-type list-1 proper-list) + (check-type list-2 proper-list) (with-key (key key-supplied-p) (with-test (test test-supplied-p test-not test-not-supplied-p) (loop with result = list-2 diff --git a/Code/utilities.lisp b/Code/utilities.lisp index 8795348..c5ea659 100644 --- a/Code/utilities.lisp +++ b/Code/utilities.lisp @@ -1,12 +1,36 @@ (cl:in-package #:constrictor) -(defun proper-list-p (list) - (numberp (ignore-errors (list-length list)))) +(defun proper-list-p (value) + (typecase value + (cl:null + t) + (cons + (prog ((step1 (cdr value)) + (step2 value)) + (unless (consp (cdr step2)) + (return (null (cdr step2)))) + (setf step2 (cddr step2)) + next + (unless (and (listp step2) + (consp (cdr step2))) + (return (and (listp step2) + (null (cdr step2))))) + (when (eq step2 step1) + (return nil)) + (setf step1 (cdr step1) + step2 (cddr step2)) + (go next))) + (t + nil))) + +(deftype proper-list () + `(satisfies proper-list-p)) (defun assert-proper-list (list) (unless (proper-list-p list) - (error 'list-must-be-proper - :offending-list list))) + (error 'type-error + :datum list + :expected-type 'proper-list))) (defun copy-list-and-last (list) (cond ((null list)