From 30b6ba59f0068dd1185d9115b1c09893cfefff4b Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Fri, 26 Jun 2026 11:06:44 +0200 Subject: [PATCH 1/5] fix tests broken in "make STRINGs start with alphanumeric chars" --- tables.lisp | 6 +++--- tests/extensions/tables.lisp | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/tables.lisp b/tables.lisp index 9c676c2..fe205be 100644 --- a/tables.lisp +++ b/tables.lisp @@ -159,13 +159,13 @@ :body (((td (:plain "col" " " (:code "3") " " "is") left) (td (:plain "some" " " "wordy" " " "text") center) - (td (:plain "$1600") right)) + (td (:plain "$" "1600") right)) ((td (:plain "col" " " "2" " " "is") left) (td (:plain "centered") center) - (td (:plain "$12") right)) + (td (:plain "$" "12") right)) ((td (:plain "zebra" " " "stripes") left) (td (:plain "are" " " "neat") center) - (td (:plain "$1") right))))) + (td (:plain "$" "1") right))))) (parse-doc " | Left-Aligned | Center Aligned | Right Aligned | | :------------ |:---------------:| -----:| diff --git a/tests/extensions/tables.lisp b/tests/extensions/tables.lisp index 87a655d..011e024 100644 --- a/tests/extensions/tables.lisp +++ b/tests/extensions/tables.lisp @@ -62,13 +62,13 @@ :BODY (((TD (:PLAIN "col" " " (:CODE "3") " " "is") LEFT) (TD (:PLAIN "some" " " "wordy" " " "text") CENTER) - (TD (:PLAIN "$1600") RIGHT)) + (TD (:PLAIN "$" "1600") RIGHT)) ((TD (:PLAIN "col" " " "2" " " "is") LEFT) (TD (:PLAIN "centered") CENTER) - (TD (:PLAIN "$12") RIGHT)) + (TD (:PLAIN "$" "12") RIGHT)) ((TD (:PLAIN "zebra" " " "stripes") LEFT) (TD (:PLAIN "are" " " "neat") CENTER) - (TD (:PLAIN "$1") RIGHT))))) + (TD (:PLAIN "$" "1") RIGHT))))) (3bmd-tests::def-grammar-test tables-4 From 50c3e65de0e9ae9f0b857c3bfab871974b6dd33c Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Fri, 3 Jul 2026 15:46:17 +0200 Subject: [PATCH 2/5] print a space if inline code starts or ends with a backtick --- markdown-printer.lisp | 18 +++++++++++++++++- tests/printing/inline.lisp | 15 +++++++++++++++ 2 files changed, 32 insertions(+), 1 deletion(-) diff --git a/markdown-printer.lisp b/markdown-printer.lisp index fcfba18..2a22faa 100644 --- a/markdown-printer.lisp +++ b/markdown-printer.lisp @@ -223,11 +223,27 @@ (foo parse-tree)) n)) +(defun starts-with-backtick-p (parse-tree) + (let ((a (first parse-tree))) + (and (stringp a) + (plusp (length a)) + (char= (aref a 0) #\`)))) + +(defun ends-with-backtick-p (parse-tree) + (let ((a (first (last parse-tree)))) + (and (stringp a) + (plusp (length a)) + (char= (aref a (1- (length a))) #\`)))) + (defmethod print-md-tagged-element ((tag (eql :code)) stream rest) (let ((n (max-n-consecutive-backticks rest))) (loop repeat (1+ n) do (write-char #\` stream)) (let ((*in-code* t)) - (dolist (a rest) (print-md-element a stream))) + (when (starts-with-backtick-p rest) + (write-char #\Space stream)) + (dolist (a rest) (print-md-element a stream)) + (when (ends-with-backtick-p rest) + (write-char #\Space stream))) (loop repeat (1+ n) do (write-char #\` stream)))) (defmacro define-smart-quote-md-translation (name replacement) diff --git a/tests/printing/inline.lisp b/tests/printing/inline.lisp index 5bd2a6e..6065d68 100644 --- a/tests/printing/inline.lisp +++ b/tests/printing/inline.lisp @@ -163,3 +163,18 @@ :format :markdown :text "" :expected "") + +(def-print-test print-code-with-backticks-1 + :format :markdown + :text "``a`b``" + :expected "``a`b``") + +(def-print-test print-code-with-backticks-2 + :format :markdown + :text "``a` ``" + :expected "``a` ``") + +(def-print-test print-code-with-backticks-3 + :format :markdown + :text "`` `b``" + :expected "`` `b``") From 3040036b55da010c1e357c3bae5942564a1ed951 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Sat, 11 Jul 2026 11:08:41 +0200 Subject: [PATCH 3/5] microoptimize rules Use CHARACTER-RANGES, :USE-CACHE NIL, add guards to CODE and RAW-HTML, and speed RAW-LINE by avoiding the backtracking operator in the common case. I measure this to be ~20% faster and to cons ~20% less. --- parser.lisp | 39 +++++++++++++++++++++------------------ 1 file changed, 21 insertions(+), 18 deletions(-) diff --git a/parser.lisp b/parser.lisp index cdd16db..6956924 100644 --- a/parser.lisp +++ b/parser.lisp @@ -46,19 +46,14 @@ (defrule non-space-char (and (! space-char) (! newline) character) (:text t)) -(defrule alphanumeric (alphanumericp character)) -(defrule dec-digit (or #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) +(defrule alphanumeric (alphanumericp character) + (:use-cache nil)) +(defrule dec-digit (character-ranges (#\0 #\9))) (defrule hex-digit (or dec-digit #\a #\A #\b #\B #\c #\C #\d #\D #\e #\E #\f #\F)) -(defun ascii-char-p (c) - (let ((c (char-code c))) - (or (<= (char-code #\a) c (char-code #\z)) - (<= (char-code #\A) c (char-code #\Z)) - (<= (char-code #\0) c (char-code #\9))))) -(defrule |A-Za-z| #.`(or ,@(coerce "ABCDEFGHIJKLMNOPQRSTUVWXYZ" 'list) - ,@(coerce "abcdefghijklmnopqrstuvwxyz" 'list))) -(defrule ascii-character (ascii-char-p character)) -(defrule alphanumeric-ascii (ascii-char-p character)) +(defrule |A-Za-z| (character-ranges (#\a #\z) (#\A #\Z))) +(defrule ascii-character (character-ranges (#\a #\z) (#\A #\Z) (#\0 #\9))) +(defrule alphanumeric-ascii ascii-character) (defrule doc (and (* %block) (* blank-line)) (:destructure (content blanks) @@ -101,11 +96,17 @@ collect %block while pos)) +(defun definitely-not-newline-p (char) + (not (or (char= char #\linefeed) (char= char #\return)))) + (defrule line raw-line (:text t)) -(defrule raw-line (or (and (* (and (! newline) character)) + +(defrule raw-line (or (and (* (or (definitely-not-newline-p character) + (and (! newline) character))) newline) (and (+ character) eof))) + (defrule optionally-indented-line (and (? indent) line) (:destructure (i l) (declare (ignore i)) @@ -623,15 +624,17 @@ (ticks-code ticks3 code3 "```") (ticks-code ticks4 code4 "````") (ticks-code ticks5 code5 "`````")) -(defrule code (or code1 code2 code3 code4 code5) - (:lambda (a) +(defrule code (and (& #\`) (or code1 code2 code3 code4 code5)) + (:destructure (guard a) + (declare (ignore guard)) (list :code a))) -(defrule raw-html (or html-comment - html-processing-instruction - html-tag) - (:lambda (a) +(defrule raw-html (and (& #\<) (or html-comment + html-processing-instruction + html-tag)) + (:destructure (guard a) + (declare (ignore guard)) (list :raw-html a))) (defrule html-comment (and "") character)) "-->") (:text t)) From f78c1b0394374f312f0f2ba05358ff1f81a7b94c Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Sat, 11 Jul 2026 11:13:36 +0200 Subject: [PATCH 4/5] optimize STRING rule ... by implementing it directly. - Also, no longer treat disabled extensions' special chars as special. - Rename it to the non-exported %STRING from CL:STRING. ~28% faster with ~40% less consing. --- extensions.lisp | 11 ++-- parser.lisp | 93 ++++++++++++++++++++++++++----- tests/extensions/tables.lisp | 6 +- tests/grammar/blocks/heading.lisp | 2 +- tests/grammar/inlines/link.lisp | 2 +- tests/grammar/inlines/string.lisp | 12 ++-- 6 files changed, 96 insertions(+), 30 deletions(-) diff --git a/extensions.lisp b/extensions.lisp index c044edb..f52299d 100644 --- a/extensions.lisp +++ b/extensions.lisp @@ -56,11 +56,12 @@ `((defrule ,(first characters) (or ,@(rest characters)) (:when ,extension-flag)) - (setf %extended-special-char-rules% - (add-expression-to-list ',(first characters) - %extended-special-char-rules%)) - (esrap:change-rule 'extended-special-char - (cons 'or %extended-special-char-rules%)))) + (if (assoc ',extension-flag %flag-to-extended-chars-alist%) + (setf (cdr (assoc ',extension-flag + %flag-to-extended-chars-alist%)) + ',(rest characters)) + (push '(,extension-flag ,@ (rest characters)) + %flag-to-extended-chars-alist%)))) ;; define a rule for escaped chars if any ,@ (when escapes `((defrule ,(first escapes) diff --git a/parser.lisp b/parser.lisp index 6956924..fe3656f 100644 --- a/parser.lisp +++ b/parser.lisp @@ -33,17 +33,37 @@ (defrule line-break (and " " normal-endline) (:constant '(:line-break))) (defrule endline (or line-break terminal-endline normal-endline)) -(defrule normal-char (and (! (or special-char space-char newline)) character) - (:text t)) -(defrule special-char (or #\* #\_ #\` #\& #\[ #\] #\< #\! #\# #\\ - extended-special-char) - (:text t)) (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter %extended-special-char-rules% nil)) -(defrule extended-special-char #.(cons 'or %extended-special-char-rules%) + (defparameter %standard-special-chars% + '(#\* #\_ #\` #\& #\[ #\] #\< #\! #\# #\\)) + ;; Elements like (*SMART-QUOTES* . ) where + ;; are from the corresponding :CHARACTER-RULE. + (defvar %flag-to-extended-chars-alist% ())) + +(declaim (inline extended-special-char-p)) +(defun extended-special-char-p (char) + (dolist (entry %flag-to-extended-chars-alist%) + (when (and (symbol-value (car entry)) + (member char (cdr entry))) + (return t)))) + +;;; A predicate equivalent to (AND (! (OR SPECIAL-CHAR SPACE-CHAR NEWLINE)). +(defun normal-char-p (char next-char) + (and (not (or (char= char #\space) + (char= char #\tab) + (special-char-p char) + (char= char #\linefeed) + (and (char= char #\return) + (eql next-char #\linefeed)))))) + +(defun special-char-p (char) + (declare (type character char)) + (or (find char #.(coerce %standard-special-chars% 'string)) + (extended-special-char-p char))) + +(defrule special-char (special-char-p character) (:text t)) - (defrule non-space-char (and (! space-char) (! newline) character) (:text t)) (defrule alphanumeric (alphanumericp character) @@ -447,7 +467,7 @@ (cons :plain a))) (eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter %inline-rules% '(string + (defparameter %inline-rules% '(%string endline ul-or-star-line %space @@ -470,11 +490,56 @@ (defrule maybe-alphanumeric (& alphanumeric) (:constant "")) -(defrule string (or (and alphanumeric (* (or normal-char - (and (+ #\_) maybe-alphanumeric)))) - ;; This could be (+ NORMAL-CHAR), but that's a bit slower. - normal-char) - (:text t)) + +;;; This function implements a much faster version of +;;; +;;; (or (and alphanumeric (* (or normal-char +;;; (and (+ #\_) maybe-alphanumeric)))) +;;; (+ normal-char)) +(defun parse-string (text position end) + (declare (type string text) + (type fixnum position end)) + (if (<= end position) + (values nil position) + (let ((c (aref text position))) + (cond ((alphanumericp c) + (let ((p (1+ position))) + (declare (type fixnum p)) + (loop while (< p end) + for char = (aref text p) + for next-char = (when (< (1+ p) end) + (aref text (1+ p))) + do (cond + ((normal-char-p char next-char) + (incf p)) + ((char= char #\_) + (let ((i p)) + (declare (type fixnum i)) + (loop while (and (< i end) + (char= (aref text i) #\_)) + do (incf i)) + (if (and (< i end) + (alphanumericp (aref text i))) + (setq p i) + (return)))) + (t + (return)))) + (values (subseq text position p) p))) + ((normal-char-p c (when (< (1+ position) end) + (aref text (1+ position)))) + (let ((p (1+ position))) + (declare (type fixnum p)) + (loop while (< p end) + for char = (aref text p) + for next-char = (when (< (1+ p) end) + (aref text (1+ p))) + do (if (normal-char-p char next-char) + (incf p) + (return))) + (values (subseq text position p) p))) + (t + (values nil position)))))) +(defrule %string (function parse-string)) (defrule maybe-space-char (& space-char) (:constant "")) diff --git a/tests/extensions/tables.lisp b/tests/extensions/tables.lisp index 011e024..87a655d 100644 --- a/tests/extensions/tables.lisp +++ b/tests/extensions/tables.lisp @@ -62,13 +62,13 @@ :BODY (((TD (:PLAIN "col" " " (:CODE "3") " " "is") LEFT) (TD (:PLAIN "some" " " "wordy" " " "text") CENTER) - (TD (:PLAIN "$" "1600") RIGHT)) + (TD (:PLAIN "$1600") RIGHT)) ((TD (:PLAIN "col" " " "2" " " "is") LEFT) (TD (:PLAIN "centered") CENTER) - (TD (:PLAIN "$" "12") RIGHT)) + (TD (:PLAIN "$12") RIGHT)) ((TD (:PLAIN "zebra" " " "stripes") LEFT) (TD (:PLAIN "are" " " "neat") CENTER) - (TD (:PLAIN "$" "1") RIGHT))))) + (TD (:PLAIN "$1") RIGHT))))) (3bmd-tests::def-grammar-test tables-4 diff --git a/tests/grammar/blocks/heading.lisp b/tests/grammar/blocks/heading.lisp index b2168da..75d14cd 100644 --- a/tests/grammar/blocks/heading.lisp +++ b/tests/grammar/blocks/heading.lisp @@ -71,7 +71,7 @@ World! (:LIST-ITEM (:PLAIN "First" " " "line"))) (:PLAIN " " "The" " " "header" " " - " " "=" "=" "=" "=" "=" "=" "=" "=" "=" "="))) + " " "=========="))) (def-grammar-test atx-heading-in-a-list ;; bug 35 ;;; marked bug as invalid, since original markdown is inconsistent diff --git a/tests/grammar/inlines/link.lisp b/tests/grammar/inlines/link.lisp index a20d221..27a1f1b 100644 --- a/tests/grammar/inlines/link.lisp +++ b/tests/grammar/inlines/link.lisp @@ -140,5 +140,5 @@ x" :expected '((:PARAGRAPH (:REFERENCE-LINK :LABEL ("link") :TAIL NIL)) (:PLAIN (:REFERENCE-LINK :LABEL ("link") :TAIL NIL) - ":" " " "http://example.com/" " " "\"" "title\"" " " + ":" " " "http://example.com/" " " "\"title\"" " " "junk"))) diff --git a/tests/grammar/inlines/string.lisp b/tests/grammar/inlines/string.lisp index f311029..6aac1e7 100644 --- a/tests/grammar/inlines/string.lisp +++ b/tests/grammar/inlines/string.lisp @@ -2,25 +2,25 @@ (def-grammar-test string-test-1 - :rule 3bmd-grammar::string + :rule 3bmd-grammar::%string :text "Some string with spaces." :expected "Some" :remaining-text " string with spaces.") (def-grammar-test string-test-2 - :rule 3bmd-grammar::string + :rule 3bmd-grammar::%string :text "100500 string with spaces." :expected "100500" :remaining-text " string with spaces.") (def-grammar-test string-test-3 - :rule 3bmd-grammar::string + :rule 3bmd-grammar::%string :text "@a_symbol@ string with spaces." - :expected "@" - :remaining-text "a_symbol@ string with spaces.") + :expected "@a" + :remaining-text "_symbol@ string with spaces.") (def-grammar-test string-test-4 - :rule 3bmd-grammar::string + :rule 3bmd-grammar::%string :text "*a_symbol* string with spaces." ;; TODO: Probably this is not an error, because * surrounds ;; emphasised text. From ce82c6dbf92916a1350eea884aa78d238aee2cd8 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Tue, 4 Aug 2026 10:15:03 +0200 Subject: [PATCH 5/5] optimize RAW-LINE ~3% faster, ~7% less consing --- parser.lisp | 42 +++++++++++++++++++++++++++++++----------- 1 file changed, 31 insertions(+), 11 deletions(-) diff --git a/parser.lisp b/parser.lisp index fe3656f..98bd603 100644 --- a/parser.lisp +++ b/parser.lisp @@ -48,14 +48,18 @@ (member char (cdr entry))) (return t)))) +(declaim (inline newlinep)) +(defun newlinep (char next-char) + (or (char= char #\linefeed) + (and (char= char #\return) + (eql next-char #\linefeed)))) + ;;; A predicate equivalent to (AND (! (OR SPECIAL-CHAR SPACE-CHAR NEWLINE)). (defun normal-char-p (char next-char) (and (not (or (char= char #\space) (char= char #\tab) (special-char-p char) - (char= char #\linefeed) - (and (char= char #\return) - (eql next-char #\linefeed)))))) + (newlinep char next-char))))) (defun special-char-p (char) (declare (type character char)) @@ -116,16 +120,32 @@ collect %block while pos)) -(defun definitely-not-newline-p (char) - (not (or (char= char #\linefeed) (char= char #\return)))) - (defrule line raw-line (:text t)) -(defrule raw-line (or (and (* (or (definitely-not-newline-p character) - (and (! newline) character))) - newline) - (and (+ character) eof))) +;;; This function is an optimized version of the rule +;;; +;;; (or (and (* (and (! newline) character)) newline) +;;; (and (+ character) eof)) +(defun parse-raw-line (text position end) + (declare (type string text) + (type fixnum position end)) + (if (>= position end) + (values nil position) + (let ((p position)) + (declare (type fixnum p)) + (let ((pos (loop while (< p end) + for char = (aref text p) + do (when (char= char #\linefeed) + (return (1+ p))) + (when (and (char= char #\return) + (< (1+ p) end) + (char= (aref text (1+ p)) #\linefeed)) + (return (+ p 2))) + (incf p) + finally (return p)))) + (values (subseq text position pos) pos))))) +(defrule raw-line (function parse-raw-line)) (defrule optionally-indented-line (and (? indent) line) (:destructure (i l) @@ -491,7 +511,7 @@ (defrule maybe-alphanumeric (& alphanumeric) (:constant "")) -;;; This function implements a much faster version of +;;; This function is an optimized version of the rule ;;; ;;; (or (and alphanumeric (* (or normal-char ;;; (and (+ #\_) maybe-alphanumeric))))