PATCH: fix "~" reinterpretation bugs, preserve ACL command index

   The ilisp::ilisp-message function doesn't handle "~" chars in data
properly, interpreting them as formatting directives:

    XMLP(642): (format t "~A produces an error." "A random '~'")
    A random '~' produces an error.
    NIL
    XMLP(643): XMLP(643): (ilisp::ilisp-message t "~A produces an error." "A random '~'")
    Error: formatter found unsyntactic format string:
    Too many parameters
    ~&"ILISP: A random '~' produces an error."
			   |
    Restart actions (select using :continue):
     0: Return to Top Level (an "abort" restart).
     1: Abort entirely from this process.
    [1] XMLP(644): 

The patch below addresses this ilisp::ilisp-message problem, plus
another similar problem (passing data as a format string to error) in
ilisp::print-function-arglist.  (This is mostly cosmetic; I couldn't
figure out how to trigger this bug doing "normal" ILISP things.)

   In addition, I figured out how to preserve the ACL command index,
copying the CLISP hack with the right ACL variable.  But doesn't all
this stuff belong in ilisp::ilisp-restore instead?

   And, while I'm at it, does anybody understand the purpose of adding
the extra quotes when the stream is not null?  Because if the intent is
to make the resulting output Lisp-readable, it doesn't work:

    XMLP(651): XMLP(651): (ilisp::ilisp-message nil "Testing ~S with embedded \"'s." "stuff")
    "ILISP: Testing \"stuff\" with embedded \"'s."
    XMLP(652): XMLP(652): (ilisp::ilisp-message t "Testing ~S with embedded \"'s." "stuff")
    "ILISP: Testing "stuff" with embedded "'s."
    NIL
    XMLP(653): XMLP(653): 

The patch preserves this behavior, though.

					-- Bob Rogers
					   http://rgrjr.dyndns.org/

------------------------------------------------------------------------
Index: cl-ilisp.lisp
===================================================================
RCS file: /cvsroot/ilisp/ILISP/cl-ilisp.lisp,v
retrieving revision 1.15
diff -u -r1.15 cl-ilisp.lisp
--- cl-ilisp.lisp	10 Sep 2002 20:21:54 -0000	1.15
+++ cl-ilisp.lisp	27 Sep 2002 15:28:06 -0000
@@ -127,17 +127,20 @@
 ;;; ilisp-message was mostly set up because Clisp expects an
 ;;; ~& or ~% before the message-string, otherwise it does not display anything!"
 
-(defun ilisp-message (format-output-stream format-control-string &rest args)
-  "ilisp-message provides an interface to create 'special' ILISP messages, i.e. \"ILISP: ... \" in an uniform way."
-  (let* ((format-string (apply #'format nil " ~@?" format-control-string args))
-         (concat-string (if (equal (char format-string 0) #\")
-                            ""
-                          (if format-output-stream
-                              "\""
-                            ""))))
-    (format format-output-stream
-            (concatenate 'string "~&" concat-string *ilisp-message-addon-string* format-string concat-string))))
-
+(defun ilisp-message (output-stream format-control-string &rest args)
+  "ilisp-message provides an interface to create 'special' ILISP
+messages, i.e. \"ILISP: ... \" in an uniform way."
+  (let ((result-string (apply #'format nil format-control-string args)))
+    (format output-stream
+	    ;; [what are these quotes for, and why do we only want them
+	    ;; sometimes?  it doesn't make necessarily make the resulting output
+	    ;; readable, that i can see.  right now only ilisp-errors passes nil
+	    ;; for output-stream, btw.  -- rgr, 27-Sep-02.]
+	    (if (or (equal (char result-string 0) #\")
+		    (not output-stream))
+		"~&~A ~A"
+		"~&\"~A ~A\"")
+	    *ilisp-message-addon-string* result-string)))
 
 ;; MNA: ecl (ecls-0.5) still had special-form-p in COMMON-LISP,
 ;; which produced an error, when redefined.
@@ -193,7 +196,9 @@
      ;; a separate init file.
      #+:clisp
      (setq system::*command-index* (max 0 (- system::*command-index* 2)))
-
+     ;; [do the same gross hack for ACL.  -- rgr, 27-Sep-02.]
+     #+allegro (setq tpl::*this-command-number*
+		     (max 0 (- tpl::*this-command-number* 2)))
      (ilisp-handler-case
       ,form	
       (error (error)
@@ -437,9 +442,7 @@
 	      (if arglist
 		  (write arglist :case :downcase :escape nil)
 		  (write-string "()"))))
-      (t (error (ilisp-message nil
-			       "arglist doc very messed up [~S]."
-			       arglist-doc))))
+      (t (error "arglist doc very messed up [~S]." arglist-doc)))
     (terpri)
     (values)))
 


-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf