From 8c7cd8b5a3a7c1e25c2bfbfa7f09e6eae81d4c33 Mon Sep 17 00:00:00 2001
From: jgarcia <jgarcia>
Date: Sun, 3 Feb 2008 19:37:45 +0000
Subject: [PATCH] Activate CMUCL's formatter

---
 src/CHANGELOG         |  4 ++++
 src/lsp/config.lsp.in |  2 +-
 src/lsp/format.lsp    | 40 ++++++++++++++++++----------------------
 3 files changed, 23 insertions(+), 23 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index 398952337..d33f5a01b 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -43,6 +43,10 @@ ECL 0.9k:
 
  - ECL ships with ASDF v1.111
 
+ - We now activate CMUCL's implementation of FORMATTER, which compiles format
+   strings into lisp functions, instead of a dummy function that calls
+   FORMAT. This leads to some speedup when pretty-printing.
+
 * CLOS:
 
  - When caching generic function calls, ECL now uses a thread-local hash table
diff --git a/src/lsp/config.lsp.in b/src/lsp/config.lsp.in
index 374f7fc47..6f2719b27 100644
--- a/src/lsp/config.lsp.in
+++ b/src/lsp/config.lsp.in
@@ -24,7 +24,7 @@ Returns, as a string, the location of the machine on which ECL runs."
 (defun lisp-implementation-version ()
   "Args:()
 Returns the version of your ECL as a string."
-  "@PACKAGE_VERSION@ (CVS 2008-02-03 13:04)")
+  "@PACKAGE_VERSION@ (CVS 2008-02-03 20:37)")
 
 (defun machine-type ()
   "Args: ()
diff --git a/src/lsp/format.lsp b/src/lsp/format.lsp
index f627fac46..d2b86cd73 100644
--- a/src/lsp/format.lsp
+++ b/src/lsp/format.lsp
@@ -17,6 +17,8 @@
 
 (in-package "SYS")
 
+(push :formatter *features*)
+
 ;;;; Float printing.
 
 ;;;
@@ -278,6 +280,8 @@
   (atsignp nil :type (member t nil))
   (params nil :type list))
 
+(deftype format-directive () 'vector)
+
 #-ecl
 (defun %print-format-directive (struct stream depth)
   (declare (ignore depth))
@@ -614,6 +618,9 @@
 (defun expand-directive (directive more-directives)
   (declare (si::c-local))
   (etypecase directive
+    (simple-string
+     (values `(write-string ,directive stream)
+	     more-directives))
     (format-directive
      (let ((expander
 	    (aref *format-directive-expanders*
@@ -623,10 +630,7 @@
        (if expander
 	   (funcall expander directive more-directives)
 	   (error 'format-error
-		  :complaint "Unknown directive."))))
-    (simple-string
-     (values `(write-string ,directive stream)
-	     more-directives))))
+		  :complaint "Unknown directive."))))))
 
 (defun expand-next-arg (&optional offset)
   (declare (si::c-local))
@@ -685,8 +689,6 @@
      (pop args)))
 
 (defmacro def-complex-format-directive (char lambda-list &body body)
-  #-formatter
-  nil
   #+formatter
   (let ((directive (gensym))
 	(directives (if lambda-list (car (last lambda-list)) (gensym))))
@@ -707,8 +709,6 @@
 		 ,@body))))))
 
 (defmacro def-format-directive (char lambda-list &body body)
-  #-formatter
-  nil
   #+formatter
   (let ((directives (gensym))
 	(declarations nil)
@@ -2068,7 +2068,6 @@
 ;;;; Conditionals
 
 (defun parse-conditional-directive (directives)
-  #-formatter
   (declare (si::c-local))
   (let ((sublists nil)
 	(last-semi-with-colon-p nil)
@@ -2111,9 +2110,10 @@
 		 (error 'format-error
 			:complaint
 			"Must specify exactly two sections."))
-	     (expand-bind-defaults ((index (expand-next-arg))) params
+	     (expand-bind-defaults ((index nil)) params
 	       (setf *only-simple-args* nil)
-	       (let ((clauses nil))
+	       (let* ((clauses nil)
+		      (case `(or ,index ,(expand-next-arg))))
 		 (when last-semi-with-colon-p
 		   (push `(t ,@(expand-directive-list (pop sublists)))
 			 clauses))
@@ -2122,7 +2122,7 @@
 		     (push `(,(decf count)
 			     ,@(expand-directive-list sublist))
 			   clauses)))
-		 `(case ,index ,@clauses)))))
+		 `(case ,case ,@clauses)))))
      remaining)))
 
 #+formatter
@@ -2278,11 +2278,11 @@
 	   :complaint "Attempt to use ~~:^ outside a ~~:{...~~} construct."))
   `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params
 	    (setf *only-simple-args* nil)
-	    `(cond (arg3 (<= arg1 arg2 arg3))
-		(arg2 (equal arg1 arg2))
-		(arg1 (equal arg1 0))
-		(,colonp (null outside-args))
-		(t (null args))))
+	    `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3))
+		   (,arg2 (equal ,arg1 ,arg2))
+		   (,arg1 (equal ,arg1 0))
+		   (,colonp (null outside-args))
+		   (t (null args))))
      ,(if colonp
 	  '(return-from outside-loop nil)
 	  '(return))))
@@ -2532,7 +2532,6 @@
     remaining))
 
 (defun parse-format-justification (directives)
-  #-formatter
   (declare (si::c-local))
   (let ((first-semi nil)
 	(close nil)
@@ -2594,7 +2593,6 @@
 
 (defun interpret-format-justification
        (stream orig-args args segments colonp atsignp first-semi params)
-  #-formatter
   (declare (si::c-local))
   (interpret-bind-defaults
       ((mincol 0) (colinc 1) (minpad 0) (padchar #\space))
@@ -2676,7 +2674,6 @@
 
 (defun parse-format-logical-block
        (segments colonp first-semi close params string end)
-  #-formatter
   (declare (si::c-local))
   (check-output-layout-mode 1)
   (when params
@@ -2721,6 +2718,7 @@
 	    suffix)))
 
 (defun add-fill-style-newlines (list string offset)
+  (declare (si::c-local))
   (if list
       (let ((directive (car list)))
 	(if (simple-string-p directive)
@@ -2779,7 +2777,6 @@
 
 (defun interpret-format-logical-block
        (stream orig-args args prefix per-line-p insides suffix atsignp)
-  #-formatter
   (declare (si::c-local))
   (let ((arg (if atsignp args (next-arg))))
     (if per-line-p
@@ -2833,7 +2830,6 @@
       (apply (fdefinition symbol) stream (next-arg) colonp atsignp (args)))))
 
 (defun extract-user-function-name (string start end)
-  #-formatter
   (declare (si::c-local))
   (let ((slash (position #\/ string :start start :end (1- end)
 			 :from-end t)))