[cmucl-help] Re : Re : Disabling the automated code deletion when compiling.

[Rémy]

The code comes from a quite old theorem prover (TPS) at CMU. I am not its 
creator but am asked to adapt it to the newest version of cmu-cc, among other 
things. This project is/was pretty huge and I am afraid that correcting these 
types errors is not a priority (the system is usually compiled with allegro and 
seems to work fine).

The more I read the compilation logs for various versions of cmu-cl, the more I 
think the deletion problem may not be the cause of my loss of features (which, 
even if they only live in my eyes, are still absent from my interface 
unfortunately). So, you don't have to waste your time tracking down this 
symbol/string type error for me. I'd just like to test my hypothesis before 
giving it up, by trying to disable the code deletion, if possible. If my 
hypothesis appears be wrong, I will check the release notes more carefully and 
hope to find out something interesting.

Nevertheless, here are query and prompt-read. You will probably need to see many 
other ones. Please don't bother if the code is too dense. Just give me some 
trails I can investigate (if you have some).

Thank you very much,

Remy

---- QUERY
(defmacro query (message default)
  `(let ((var nil))
       (prompt-read var nil
       (msgf ,message) 'yesno ,default ((? (mhelp 'yesno))))
     var))

---- PROMPT-READ
(defmacro prompt-read (internal-var external-var initial-message
                    argument-type default-value
                    special-response-list)
  (declare (special *using-interface* *simple-interface-prompts*))
  `(if (and *using-interface* (not *simple-interface-prompts*) (not 
*executing*))
       (setq ,internal-var
         (do ((response nil))
         (nil)
           (let ((prompt-sym (intern (gensym "PROMPT"))))
         (start-prompt-msg)
         ,initial-message
         (start-prompt-name)
         (write-string (format nil "~d" prompt-sym))
         (start-prompt-argtyp)
         (write-string (format nil "~d" ,argument-type))
         (start-prompt-help)
         (let ((*using-interface* NIL) ; set to nil so the help is just text
               (style 'GENERIC))
           (declare (special *using-interface* style))
           (dolist (sr ',special-response-list) ; help info
             (when (or (eq (car sr) '?) (eq (car sr) '??))
               (terpri)
               (case (car sr)
             , at special-response-list))))
         (start-prompt-default)
         (unless (equal ,default-value '$) 
           (funcall (get ,argument-type 'printfn)
                ,default-value))
         (end-prompt)
         (setq response (let ((command-completion nil))
                  (declare (special command-completion))
                  (linereadpp " " nil nil t nil t prompt-sym))))
           (cond ((null response)
              (cond ((equal ,default-value '$)
                 (complain f "There is no default for this argument."))
                (t ,@(if external-var `((setq ,external-var '$)) nil)
                   (return ,default-value))))
             (t (if (null (cdr response))
                (setq response (car response)))
            ,@(if external-var `((setq ,external-var response)) nil)
            (if (symbolp response)
                ;; added check for ABORT to allow user to quit
                ;; in middle of a command without going into
                ;; the debugger, especially commands like
                ;; use-tactic and go.  13FEB91 DAN
                (if (string-equal response "ABORT")
                (throwfail "Aborting by user request.")
                  (if (string-equal response "PAUSE")
                  (pause)
                (if (string-equal response "PUSH")
                    (top)
                  (case response
                    , at special-response-list
                    (t
                     (%catch% (return 
                           (gettype ,argument-type response))
                          (fail 
                           (complain f expand-catch-throw))))))))
              (%catch% (return (gettype ,argument-type response))
                   (fail (complain f
                           expand-catch-throw))))))))
     (setq ,internal-var
       (do ((response nil))
           (nil)
         ,initial-message
         (msg " [")
         (if (equal ,default-value '$) 
         (msg "No Default")
           (funcall (get ,argument-type 'printfn)
            ,default-value))
         (msg "]")
         (setq response (let ((command-completion nil))
                  (declare (special command-completion))
                  (if (and *using-interface* (not *executing*))
                  (linereadpp '> nil nil t nil t 'COMMAND)
                (linereadpp '>))))
         (cond ((null response)
            (cond ((equal ,default-value '$)
               (complain f "There is no default for this argument."))
              (t ,@(if external-var `((setq ,external-var '$)) nil)
                 (return ,default-value))))
           (t (if (null (cdr response))
              (setq response (car response)))
              ,@(if external-var `((setq ,external-var response)) nil)
              (if (symbolp response)
              ;; added check for ABORT to allow user to quit
              ;; in middle of a command without going into
              ;; the debugger, especially commands like
              ;; use-tactic and go.  13FEB91 DAN
              (if (string-equal response "ABORT")
                  (throwfail "Aborting by user request.")
                (if (string-equal response "PAUSE")
                (pause)
                  (if (string-equal response "PUSH")
                  (top)
                (case response
                  , at special-response-list
                  (t
                   (%catch% (return 
                         (gettype ,argument-type response))
                        (fail 
                         (complain f expand-catch-throw))))))))
            (%catch% (return (gettype ,argument-type response))
                 (fail (complain f
                         expand-catch-throw))))))))))



----- Message d'origine ----
De : Raymond Toy <toy.raymond at gmail.com>
À : Rémy <remy_chretien at yahoo.fr>
Cc : cmucl-help at cmucl.cons.org
Envoyé le : Mer 3 novembre 2010, 10h 55min 45s
Objet : Re: [cmucl-help] Re : Disabling the automated code deletion when 
compiling.

On 11/2/10 3:13 PM, Rémy wrote:
> I am afraid that snippets from code and logs will not be very efficient to 
>track 
>
>
> down the problem. The disappearance of important features of the program is 
> quite ubiquitous and the code itself is very dense. Anyway, here is an example 

> of an 'unfortunate' code deletion.

To understand what's going on, I would need to see query and
prompt-read.  It seems prompt-read is creating a symbol where a string
was expected.  It also seems as if prompt-read and/or query are
inlined.  That seems unnecessary for functions that appear to wait for
user input.

It would certainly help in figuring this out if you looked at the notes
to see what the problem really is.  They seem rather serious if you're
feeding a symbol where a string is expected.
>
> If my hypothesis of type errors causing inappropriate code deletion was wrong, 

> what could in your opinion cause the software to progressively lose its 
> features, from cmucl 18c to 20b?
Loss of features is in the eye of the beholder. :-)
> Extra question: I try to compile with various version, to determine when the 
> features exactly start to fade, and the following happens (with version <19):
> I use a Makefile, with this instruction:
>
> tps_compile:    bin lisp tps-compile.lisp make_tps_sys 
>     @date
>     @/bin/sh -ec 'echo "(load \"../tps-compile.lisp\") (core:exit-from-lisp)"' 
>| 
>
> (cd bin; $(lisp))
>
> and then a Segmentation Fault Occur, while writing this line in the shell does 

> work properly.
>
> /bin/sh: line 1: 11953 Segmentation fault      cmucl18
> make: *** [tps_compile] Error 139
>
> Do you have a clue of what the problem is?
No clue.  I tried a simple makefile and it works for me with 18c.

Ray