Merge pull request #4 from s-expressionists/extension

Add client specialization during parsing
s-expressionists · Oct 18, 2023 · cbe0d6f · cbe0d6f
2 parents e0d2d3d + c8556c0
commit cbe0d6f
Show file tree

Hide file tree

Showing 26 changed files with 1,400 additions and 1,291 deletions.
diff --git a/LICENSE.md b/LICENSE.md
@@ -1,8 +1,4 @@
-Copyright (c) 2010 - 2022
-
-Robert Strandh (robert.strandh@gmail.com)
-
-All rights reserved.
+Copyright 2010-2023 Robert Strandh (robert.strandh@gmail.com)
 
 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions are
@@ -13,10 +9,11 @@ met:
 
 2. Redistributions in binary form must reproduce the above copyright
    notice, this list of conditions and the following disclaimer in the
-   documentation and/or other materials provided with the distribution.
+   documentation and/or other materials provided with the
+   distribution.
 
 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+“AS IS” AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
 A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
 HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

diff --git a/code/basic-output.lisp b/code/basic-output.lisp
@@ -8,15 +8,24 @@
 ;;;
 ;;; 22.3.1.1 ~c Character
 
-(define-directive #\c c-directive nil (named-parameters-directive) ())
-
-(define-format-directive-interpreter c-directive
-  (let ((char (consume-next-argument 'character)))
-    (cond ((and (not colonp) (not at-signp))
+(defclass c-directive (directive)
+  ())
+
+(defmethod specialize-directive
+    (client (char (eql #\C)) directive end-directive)
+  (declare (ignore client end-directive))
+  (change-class directive 'c-directive))
+
+(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-signp)
+          ((not at-sign-p)
            ;; We have only a colon modifier.
            ;; The HyperSpec says to do what WRITE-CHAR does for
            ;; printing characters, and what char-name does otherwise.
@@ -25,7 +34,7 @@
            (if (and (graphic-char-p char) (not (eql char #\Space)))
                (write-char char *destination*)
                (write-string (char-name char) *destination*)))
-          ((not colonp)
+          ((not colon-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".
@@ -43,114 +52,156 @@
                (write-char char *destination*)
                (write-string (char-name char) *destination*))))))
 
-(define-format-directive-compiler c-directive
-  `((let ((char (consume-next-argument 'character)))
-      ,(cond ((and (not colonp) (not at-signp))
-              `(write-char char *destination*))
-             ((not at-signp)
-              `(if (and (graphic-char-p char) (not (eql char #\Space)))
-                   (write-char char *destination*)
-                   (write-string (char-name char) *destination*)))
-             ((not colonp)
-              `(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*)))))))
+(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*))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; 22.3.1.2 ~% Newline.
 
-(define-directive #\% percent-directive nil (named-parameters-directive no-modifiers-mixin)
-    ((how-many :type (integer 0) :default-value 1)))
+(defclass percent-directive (directive no-modifiers-mixin)
+  ())
+
+(defmethod specialize-directive
+    (client (char (eql #\%)) directive end-directive)
+  (declare (ignore client end-directive))
+  (change-class directive 'percent-directive))
+
+(defmethod parameter-specifications (client (directive percent-directive))
+  (declare (ignore client))
+  '((:type (integer 0) :default 1)))
 
-(define-format-directive-interpreter percent-directive
-  (loop repeat how-many
+(defmethod interpret-item (client (directive percent-directive) &optional parameters)
+  (loop repeat (car parameters)
         do (terpri *destination*)))
 
-(define-format-directive-compiler percent-directive
-  (let ((how-many (compile-time-value directive 'how-many)))
-    (case how-many
-      (0 '())
-      (1 '((terpri *destination*)))
-      (2 '((terpri *destination*)
-           (terpri *destination*)))
-      (otherwise
-        `((loop repeat how-many
-                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*))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; 22.3.1.3 ~& Fresh line and newlines.
 
-(define-directive #\& ampersand-directive nil (named-parameters-directive no-modifiers-mixin)
-    ((how-many :type (integer 0) :default-value 1)))
+(defclass ampersand-directive (directive no-modifiers-mixin)
+  ())
 
-(define-format-directive-interpreter ampersand-directive
-  (unless (zerop how-many)
-    (fresh-line *destination*)
-    (loop repeat (1- how-many)
-          do (terpri *destination*))))
+(defmethod specialize-directive
+    (client (char (eql #\&)) directive end-directive)
+  (declare (ignore client end-directive))
+  (change-class directive 'ampersand-directive))
 
-(define-format-directive-compiler ampersand-directive
-  (let ((how-many (compile-time-value directive 'how-many)))
+(defmethod parameter-specifications
+    (client (directive ampersand-directive))
+  (declare (ignore client))
+  '((:type (integer 0) :default 1)))
+
+(defmethod interpret-item (client (item ampersand-directive) &optional parameters)
+  (let ((how-many (car parameters)))
+    (unless (zerop how-many)
+      (fresh-line *destination*)
+      (loop repeat (1- how-many)
+            do (terpri *destination*)))))
+
+(defmethod compile-item (client (item ampersand-directive) &optional parameters)
+  (let ((how-many (car parameters)))
     (case how-many
-      ((:argument-reference :remaining-argument-count)
-       `((unless (zerop how-many)
-           (fresh-line *destination*)
-           (loop repeat (1- how-many)
-                 do (terpri *destination*)))))
       (0 nil)
       (1 `((fresh-line *destination*)))
       (2 `((fresh-line *destination*)
            (terpri *destination*)))
       (otherwise
-       `((fresh-line *destination*)
-         (loop repeat ,(1- how-many)
-               do (terpri *destination*)))))))
+       (if (numberp how-many)
+           `((fresh-line *destination*)
+             (loop repeat ,(1- how-many)
+                   do (terpri *destination*)))
+           `((let ((how-many ,how-many))
+               (unless (zerop how-many)
+                 (fresh-line *destination*)
+                 (loop repeat (1- how-many)
+                       do (terpri *destination*))))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; 22.3.1.4 ~| Page separators.
 
-(define-directive #\| vertical-bar-directive nil (named-parameters-directive no-modifiers-mixin)
-    ((how-many :type (integer 0) :default-value 1)))
+(defclass vertical-bar-directive (directive no-modifiers-mixin)
+  ())
+
+(defmethod specialize-directive
+    (client (char (eql #\|)) directive end-directive)
+  (declare (ignore client end-directive))
+  (change-class directive 'vertical-bar-directive))
 
-(define-format-directive-interpreter vertical-bar-directive
-  (loop repeat how-many
+(defmethod parameter-specifications
+    (client (directive vertical-bar-directive))
+  (declare (ignore client))
+  '((:type (integer 0) :default 1)))
+
+(defmethod interpret-item (client (directive vertical-bar-directive) &optional parameters)
+  (loop repeat (car parameters)
         do (write-char #\Page *destination*)))
 
-(define-format-directive-compiler vertical-bar-directive
-  (let ((how-many (compile-time-value directive 'how-many)))
+(defmethod compile-item (client (directive vertical-bar-directive) &optional parameters)
+  (let ((how-many (car parameters)))
     (case how-many
       (0 nil)
       (1 `((write-char #\Page *destination*)))
       (2 `((write-char #\Page *destination*)
            (write-char #\Page *destination*)))
       (otherwise
-       `((loop repeat how-many
+       `((loop repeat ,how-many
                do (write-char #\Page *destination*)))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
 ;;; 22.3.1.5 ~~ Tildes.
 
-(define-directive #\~ tilde-directive nil (named-parameters-directive no-modifiers-mixin)
-    ((how-many :type (integer 0) :default-value 1)))
+(defclass tilde-directive (directive no-modifiers-mixin)
+  ())
+
+(defmethod specialize-directive
+    (client (char (eql #\~)) directive end-directive)
+  (declare (ignore client end-directive))
+  (change-class directive 'tilde-directive))
+
+(defmethod parameter-specifications (client (directive tilde-directive))
+  (declare (ignore client))
+  '((:type (integer 0) :default 1)))
 
-(define-format-directive-interpreter tilde-directive
-  (loop repeat how-many
+(defmethod interpret-item (client (directive tilde-directive) &optional parameters)
+  (loop repeat (car parameters)
         do (write-char #\~ *destination*)))
 
-(define-format-directive-compiler tilde-directive
-  (let ((how-many (compile-time-value directive 'how-many)))
+(defmethod compile-item (client (directive tilde-directive) &optional parameters)
+  (let ((how-many (car parameters)))
     (case how-many
       (0 nil)
       (1 `((write-char #\~ *destination*)))
       (2 `((write-char #\~ *destination*)
            (write-char #\~ *destination*)))
       (otherwise
-       `((loop repeat how-many
+       `((loop repeat ,how-many
                do (write-char #\~ *destination*)))))))