Merge branch 'master' of github.com:robert-strandh/Constrictor

.github/dependabot.yml

@@ -0,0 +1,6 @@
+version: 2
+updates:
+  - package-ecosystem: "github-actions"
+    directory: "/.github/workflows/"
+    schedule:
+      interval: "weekly"

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

Code/accessors.lisp

@@ -572,7 +572,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)))

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

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

Code/ansi-test/packages.lisp

@@ -0,0 +1,5 @@
+(cl:in-package #:common-lisp-user)
+
+(defpackage #:constrictor-extrinsic/ansi-test
+  (:use #:cl)
+  (:export #:test))

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

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)

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")))))

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

Code/intersection.lisp

@@ -4,16 +4,16 @@
 
 (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 = '()
             for element-1 in list-1
             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))