Improve compile expansions

Also add more implementations to CI
s-expressionists · May 29, 2024 · ec0d67d · ec0d67d
1 parent e4df5cc
commit ec0d67d
Show file tree

Hide file tree

Showing 20 changed files with 600 additions and 469 deletions.
diff --git a/.github/workflows/test.yml b/.github/workflows/test.yml
@@ -16,11 +16,17 @@ jobs:
       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 nontrivial-gray-streams
       uses: actions/checkout@v4

diff --git a/code/basic-output.lisp b/code/basic-output.lisp
@@ -18,58 +18,52 @@
 
 (defmethod interpret-item (client (directive c-directive) &optional parameters)
   (declare (ignore parameters))
-  (let ((char (consume-next-argument 'character))
-        (colon-p (colon-p directive))
-        (at-sign-p (at-sign-p directive)))
-    (cond ((and (not colon-p) (not at-sign-p))
-           ;; Neither colon nor at-sign.
-           ;; The HyperSpec says to do what WRITE-CHAR does.
-           (write-char char *destination*))
-          ((not at-sign-p)
-           ;; We have only a colon modifier.
+  (with-accessors ((colon-p colon-p)
+                   (at-sign-p at-sign-p))
+      directive
+  (let ((char (pop-argument 'character)))
+    (cond (colon-p
+           ;; We have a colon modifier.
            ;; The HyperSpec says to do what WRITE-CHAR does for
            ;; printing characters, and what char-name does otherwise.
            ;; The definition of "printing char" is a graphic character
            ;; other than space.
            (if (and (graphic-char-p char) (not (eql char #\Space)))
                (write-char char *destination*)
-               (write-string (char-name char) *destination*)))
-          ((not colon-p)
+               (write-string (char-name char) *destination*))
+           (when at-sign-p
+             ;; Allow client specific key sequence for at sign modifier.
+             (print-key-sequence client char *destination*)))
+          (at-sign-p
            ;; We have only an at-sign modifier.
            ;; The HyperSpec says to print it the way the Lisp
            ;; reader can understand, which I take to mean "use PRIN1".
            ;; It also says to bind *PRINT-ESCAPE* to t.
            (let ((*print-escape* t))
              (incless:write-object client char *destination*)))
           (t
-           ;; We have both a colon and and at-sign.
-           ;; The HyperSpec says to do what ~:C does, but
-           ;; also to mention unusual shift keys on the
-           ;; keyboard required to type the character.
-           ;; I don't see how to do that, so we do the same
-           ;; as for ~:C.
-           (if (and (graphic-char-p char) (not (eql char #\Space)))
-               (write-char char *destination*)
-               (write-string (char-name char) *destination*))))))
+           ;; Neither colon nor at-sign.
+           ;; The HyperSpec says to do what WRITE-CHAR does.
+           (write-char char *destination*))))))
 
 (defmethod compile-item (client (directive c-directive) &optional parameters)
   (declare (ignore parameters))
-  (let ((colon-p (colon-p directive))
-        (at-sign-p (at-sign-p directive)))
-    `((let ((char (consume-next-argument 'character)))
-        ,(cond ((and (not colon-p) (not at-sign-p))
-                `(write-char char *destination*))
-               ((not at-sign-p)
-                `(if (and (graphic-char-p char) (not (eql char #\Space)))
-                     (write-char char *destination*)
-                     (write-string (char-name char) *destination*)))
-               ((not colon-p)
-                `(let ((*print-escape* t))
-                   (incless:write-object ,(incless:client-form client) char *destination*)))
-               (t
-                `(if (and (graphic-char-p char) (not (eql char #\Space)))
-                     (write-char char *destination*)
-                     (write-string (char-name char) *destination*))))))))
+  (with-accessors ((at-sign-p at-sign-p)
+                   (colon-p colon-p))
+      directive
+    (cond (colon-p
+           `((let ((char (pop-argument 'character)))
+               (if (and (graphic-char-p char) (not (eql char #\Space)))
+                   (write-char char *destination*)
+                   (write-string (char-name char) *destination*))
+               ,@(when at-sign-p
+                   `((print-key-sequence ,(incless:client-form client) char
+                                         *destination*))))))
+          (at-sign-p
+           `((let ((*print-escape* t))
+               (incless:write-object ,(incless:client-form client) (pop-argument 'character) *destination*))))
+          (t
+           `((write-char (pop-argument 'character) *destination*))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -85,21 +79,25 @@
 
 (defmethod parameter-specifications (client (directive percent-directive))
   (declare (ignore client))
-  '((:type (integer 0) :default 1)))
+  '((:name n
+     :type (integer 0)
+     :bind nil
+     :default 1)))
 
 (defmethod interpret-item (client (directive percent-directive) &optional parameters)
   (loop repeat (car parameters)
         do (terpri *destination*)))
 
 (defmethod compile-item (client (directive percent-directive) &optional parameters)
-  (case (car parameters)
-    (0 '())
-    (1 '((terpri *destination*)))
-    (2 '((terpri *destination*)
-         (terpri *destination*)))
-    (otherwise
-     `((loop repeat ,(car parameters)
-             do (terpri *destination*))))))
+  (let ((n (car parameters)))
+    (case n
+      (0 '())
+      (1 '((terpri *destination*)))
+      (2 '((terpri *destination*)
+           (terpri *destination*)))
+      (otherwise
+       `((loop repeat ,n
+               do (terpri *destination*)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -116,7 +114,9 @@
 (defmethod parameter-specifications
     (client (directive ampersand-directive))
   (declare (ignore client))
-  '((:type (integer 0) :default 1)))
+  '((:name n
+     :type (integer 0)
+     :default 1)))
 
 (defmethod interpret-item (client (item ampersand-directive) &optional parameters)
   (let ((how-many (car parameters)))
@@ -126,22 +126,21 @@
             do (terpri *destination*)))))
 
 (defmethod compile-item (client (item ampersand-directive) &optional parameters)
-  (let ((how-many (car parameters)))
-    (case how-many
+  (let ((n (car parameters)))
+    (case n
       (0 nil)
       (1 `((fresh-line *destination*)))
       (2 `((fresh-line *destination*)
            (terpri *destination*)))
       (otherwise
-       (if (numberp how-many)
+       (if (numberp n)
            `((fresh-line *destination*)
-             (loop repeat ,(1- how-many)
+             (loop repeat ,(1- n)
                    do (terpri *destination*)))
-           `((let ((how-many ,how-many))
-               (unless (zerop how-many)
-                 (fresh-line *destination*)
-                 (loop repeat (1- how-many)
-                       do (terpri *destination*))))))))))
+           `((unless (zerop ,n)
+               (fresh-line *destination*)
+               (loop repeat (1- ,n)
+                     do (terpri *destination*)))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -158,21 +157,24 @@
 (defmethod parameter-specifications
     (client (directive vertical-bar-directive))
   (declare (ignore client))
-  '((:type (integer 0) :default 1)))
+  '((:name n
+     :type (integer 0)
+     :bind nil
+     :default 1)))
 
 (defmethod interpret-item (client (directive vertical-bar-directive) &optional parameters)
   (loop repeat (car parameters)
         do (write-char #\Page *destination*)))
 
 (defmethod compile-item (client (directive vertical-bar-directive) &optional parameters)
-  (let ((how-many (car parameters)))
-    (case how-many
+  (let ((n (car parameters)))
+    (case n
       (0 nil)
       (1 `((write-char #\Page *destination*)))
       (2 `((write-char #\Page *destination*)
            (write-char #\Page *destination*)))
       (otherwise
-       `((loop repeat ,how-many
+       `((loop repeat ,n
                do (write-char #\Page *destination*)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -189,19 +191,22 @@
 
 (defmethod parameter-specifications (client (directive tilde-directive))
   (declare (ignore client))
-  '((:type (integer 0) :default 1)))
+  '((:name n
+     :type (integer 0)
+     :bind nil
+     :default 1)))
 
 (defmethod interpret-item (client (directive tilde-directive) &optional parameters)
   (loop repeat (car parameters)
         do (write-char #\~ *destination*)))
 
 (defmethod compile-item (client (directive tilde-directive) &optional parameters)
-  (let ((how-many (car parameters)))
-    (case how-many
+  (let ((n (car parameters)))
+    (case n
       (0 nil)
       (1 `((write-char #\~ *destination*)))
       (2 `((write-char #\~ *destination*)
            (write-char #\~ *destination*)))
       (otherwise
-       `((loop repeat ,how-many
+       `((loop repeat ,n
                do (write-char #\~ *destination*)))))))