home *** CD-ROM | disk | FTP | other *** search
/ Amiga MA Magazine 1998 #6 / amigamamagazinepolishissue1998.iso / coders / jËzyki_programowania / clisp / src / archive / clisp.faslsp.lha / user1.lsp < prev    next >
Lisp/Scheme  |  1996-08-07  |  30KB  |  839 lines
  1. ;;;; User-Interface, Teil 1
  2. ;;;; Eval-Env, Debugger, Stepper, Errors, Query-User
  3. ;;;; Bruno Haible 4.2.1990, 4.11.1991
  4.  
  5. (in-package "LISP")
  6. (export '(eval-env with-keyboard *keyboard-input*))
  7. (in-package "SYSTEM")
  8.  
  9. ;-------------------------------------------------------------------------------
  10. ;;                                 EVAL-ENV
  11.  
  12. ; Das Toplevel-Environment
  13. (defparameter *toplevel-environment* (eval '(the-environment)))
  14. (defparameter *toplevel-denv* (svref *toplevel-environment* 4))
  15.  
  16. ; Evaluiert eine Form in einem Environment
  17. (defun eval-env (form &optional (env *toplevel-environment*))
  18.   (evalhook form nil nil env)
  19. )
  20.  
  21. ;-------------------------------------------------------------------------------
  22. ;;                                 Debugger
  23.  
  24. (defvar *break-count* 0) ; Anzahl der aktiven Break-Schleifen (Fixnum >=0)
  25.  
  26. ; Zähler zum Vermeiden von Endlosrekursionen wegen *error-output*
  27. (defvar *recurse-count-error-output* 0)
  28.  
  29. ; Hauptschleife:
  30. ; (driver
  31. ;   #'(lambda () (read-eval-print "> "))
  32. ; )
  33.  
  34. (defvar *prompt-with-package* nil)
  35. (defun prompt-string-package ()
  36.   (if (and (packagep *package*) (package-name *package*))
  37.     (if (or *prompt-with-package*
  38.             (not (find-symbol "T" *package*)) ; Ist *package* eine Package ohne Lisp-Syntax?
  39.         )
  40.       (string-concat "[" (package-name *package*) "]")
  41.       ""
  42.     )
  43.     #L{
  44.     DEUTSCH "[*package* ungültig]"
  45.     ENGLISH "[*package* invalid]"
  46.     FRANCAIS "[*package* invalide]"
  47.     }
  48. ) )
  49. ; Vom Prompt der erste Teil:
  50. (defun prompt-string1 () "")
  51. ; Vom Prompt der zweite Teil:
  52. (defun prompt-string2 () (prompt-string-package))
  53. ; Vom Prompt der letzte Teil:
  54. (defun prompt-string3 () "> ")
  55.  
  56. ; Help-Funktion:
  57. (defvar *key-bindings* nil) ; Liste von Tasten-Bindungen und Helpstrings
  58. (defun help ()
  59.   (dolist (s (reverse (remove-if-not #'stringp *key-bindings*)))
  60.     (write-string s #|*debug-io*|#)
  61. ) )
  62.  
  63. ; Bausteine der Break-Schleife:
  64. (defvar *debug-frame*)
  65. (defvar *debug-mode*)
  66. (defvar *frame-limit1* nil) ; untere Grenze für frame-down und frame-down-1
  67. (defvar *frame-limit2* nil) ; obere Grenze für frame-up und frame-up-1
  68. (defun frame-limit1 (frames-to-skip)
  69.   (let ((frame (the-frame)))
  70.     (let ((*frame-limit1* nil)
  71.           (*frame-limit2* nil))
  72.       (dotimes (i frames-to-skip) (setq frame (frame-up-1 frame 1)))
  73.     )
  74.     frame
  75. ) )
  76. (defun frame-limit2 ()
  77.   (let ((frame (the-frame)))
  78.     (let ((*frame-limit1* nil)
  79.           (*frame-limit2* nil))
  80.       (loop
  81.         (let ((nextframe (frame-up-1 frame 1)))
  82.           (when (or (eq nextframe frame) (driver-frame-p nextframe)) (return))
  83.           (setq frame nextframe)
  84.       ) )
  85.       (dotimes (i 2) (setq frame (frame-down-1 frame 1)))
  86.     )
  87.     frame
  88. ) )
  89. (defun debug-help () (help) (throw 'debug 'continue))
  90. (defun debug-unwind () (throw 'debug 'unwind))
  91. (defun debug-mode-1 () (setq *debug-mode* 1) (throw 'debug 'continue))
  92. (defun debug-mode-2 () (setq *debug-mode* 2) (throw 'debug 'continue))
  93. (defun debug-mode-3 () (setq *debug-mode* 3) (throw 'debug 'continue))
  94. (defun debug-mode-4 () (setq *debug-mode* 4) (throw 'debug 'continue))
  95. (defun debug-mode-5 () (setq *debug-mode* 5) (throw 'debug 'continue))
  96. (defun debug-where ()
  97.   (describe-frame *standard-output* *debug-frame*)
  98.   (throw 'debug 'continue)
  99. )
  100. (defun debug-up ()
  101.   (describe-frame *standard-output*
  102.     (setq *debug-frame* (frame-up-1 *debug-frame* *debug-mode*))
  103.   )
  104.   (throw 'debug 'continue)
  105. )
  106. (defun debug-top ()
  107.   (describe-frame *standard-output*
  108.     (setq *debug-frame* (frame-up *debug-frame* *debug-mode*))
  109.   )
  110.   (throw 'debug 'continue)
  111. )
  112. (defun debug-down ()
  113.   (describe-frame *standard-output*
  114.     (setq *debug-frame* (frame-down-1 *debug-frame* *debug-mode*))
  115.   )
  116.   (throw 'debug 'continue)
  117. )
  118. (defun debug-bottom ()
  119.   (describe-frame *standard-output*
  120.     (setq *debug-frame* (frame-down *debug-frame* *debug-mode*))
  121.   )
  122.   (throw 'debug 'continue)
  123. )
  124. (defun debug-backtrace (&optional (mode *debug-mode*))
  125.   (let ((frame (frame-down-1 (frame-up-1 *frame-limit1* mode) mode)))
  126.     (loop
  127.       (describe-frame *standard-output* frame)
  128.       (when (eq frame (setq frame (frame-up-1 frame mode))) (return))
  129.   ) )
  130.   (throw 'debug 'continue)
  131. )
  132. (defun debug-backtrace-1 () (debug-backtrace 1))
  133. (defun debug-backtrace-2 () (debug-backtrace 2))
  134. (defun debug-backtrace-3 () (debug-backtrace 3))
  135. (defun debug-backtrace-4 () (debug-backtrace 4))
  136. (defun debug-backtrace-5 () (debug-backtrace 5))
  137. (defun debug-trap-on ()
  138.   (trap-eval-frame *debug-frame* t)
  139.   (throw 'debug 'continue)
  140. )
  141. (defun debug-trap-off ()
  142.   (trap-eval-frame *debug-frame* nil)
  143.   (throw 'debug 'continue)
  144. )
  145. (defun debug-redo ()
  146.   (redo-eval-frame *debug-frame*)
  147.   (throw 'debug 'continue)
  148. )
  149. (defun debug-return ()
  150.   (return-from-eval-frame *debug-frame*
  151.     (read-form
  152.      #L{
  153.      DEUTSCH "Werte: "
  154.      ENGLISH "values: "
  155.      FRANCAIS "Valeurs : "
  156.      }
  157.   ) )
  158.   (throw 'debug 'continue)
  159. )
  160. (defun debug-continue () (throw 'debug 'quit))
  161.  
  162. (defun commands0 ()
  163.              (list
  164.                #L{
  165.                 DEUTSCH "
  166. Help = diese Liste
  167. Benutzen Sie die üblichen Editiermöglichkeiten."
  168.                 ENGLISH "
  169. Help = this list
  170. Use the usual editing capabilities."
  171.                 FRANCAIS "
  172. Help = cette liste
  173. Éditez de la façon habituelle."
  174.                }
  175.                (cons "Help"   #'debug-help  )
  176. )            )
  177. (defun commands1 ()
  178.   (list
  179.     #L{
  180.        DEUTSCH "
  181. Help   = dieses Menü
  182. Abort  = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  183. Unwind = Abbruch, Rücksprung zur nächsthöheren Eingabeschleife
  184. Mode-1 = alle Stack-Elemente inspizieren
  185. Mode-2 = alle Frames inspizieren
  186. Mode-3 = nur lexikalische Frames inspizieren
  187. Mode-4 = nur EVAL- und APPLY-Frames inspizieren (Default)
  188. Mode-5 = nur APPLY-Frames inspizieren
  189. Where  = diesen Frame inspizieren
  190. Up     = nächsthöheren Frame inspizieren
  191. Top    = obersten Frame inspizieren
  192. Down   = nächstneueren Frame inspizieren
  193. Bottom = neuesten Frame inspizieren
  194. Backtrace-1 = alle Stack-Elemente auflisten
  195. Backtrace-2 = alle Frames auflisten
  196. Backtrace-3 = alle lexikalische Frames auflisten
  197. Backtrace-4 = alle EVAL- und APPLY-Frames auflisten
  198. Backtrace-5 = alle APPLY-Frames auflisten
  199. Backtrace   = Stack auflisten im aktuellen Mode
  200. Break+ = Breakpoint im EVAL-Frame setzen
  201. Break- = Breakpoint im EVAL-Frame löschen
  202. Redo   = Form im EVAL-Frame erneut auswerten
  203. Return = EVAL-Frame mit gegebenen Werten verlassen"
  204.        ENGLISH "
  205. Help   = this command list
  206. Abort  = abort to the next recent input loop
  207. Unwind = abort to the next recent input loop
  208. Mode-1 = inspect all the stack elements
  209. Mode-2 = inspect all the frames
  210. Mode-3 = inspect only lexical frames
  211. Mode-4 = inspect only EVAL and APPLY frames (default)
  212. Mode-5 = inspect only APPLY frames
  213. Where  = inspect this frame
  214. Up     = go up one frame, inspect it
  215. Top    = go to top frame, inspect it
  216. Down   = go down one frame, inspect it
  217. Bottom = go to bottom (most recent) frame, inspect it
  218. Backtrace-1 = list all stack elements
  219. Backtrace-2 = list all frames
  220. Backtrace-3 = list all lexical frames
  221. Backtrace-4 = list all EVAL and APPLY frames
  222. Backtrace-5 = list all APPLY frames
  223. Backtrace   = list stack in current mode
  224. Break+ = set breakpoint in EVAL frame
  225. Break- = disable breakpoint in EVAL frame
  226. Redo   = re-evaluate form in EVAL frame
  227. Return = leave EVAL frame, prescribing the return values"
  228.        FRANCAIS "
  229. Help   = ce menu-ci
  230. Abort  = arrêt, retour au niveau supérieur
  231. Unwind = arrêt, retour au niveau supérieur
  232. Mode-1 = examiner tous les éléments de la pile
  233. Mode-2 = examiner tous les «frames»
  234. Mode-3 = examiner uniquement les «frames» lexicaux
  235. Mode-4 = examiner uniquement les «frames» EVAL et APPLY (par défaut)
  236. Mode-5 = examiner uniquement les «frames» APPLY
  237. Where  = examiner ce «frame»
  238. Up     = examiner un «frame» supérieur
  239. Top    = examiner le «frame» le plus élevé
  240. Down   = examiner un prochain «frame» plus récent (inférieur)
  241. Bottom = examiner le «frame» le plus récent (le plus bas)
  242. Backtrace-1 = montrer tous les éléments de la pile
  243. Backtrace-2 = montrer tous les «frames»
  244. Backtrace-3 = montrer tous les «frames» lexicaux
  245. Backtrace-4 = montrer tous les «frames» EVAL et APPLY
  246. Backtrace-5 = montrer tous les «frames» APPLY
  247. Backtrace   = montrer la pile en mode actuel
  248. Break+ = placer un point d'interception dans le «frame» EVAL
  249. Break- = enlever le point d'interception du «frame» EVAL
  250. Redo   = réévaluer la forme dans le «frame» EVAL
  251. Return = quitter le «frame» EVAL avec certaines valeurs"
  252.       }
  253.     (cons "Help"   #'debug-help  )
  254.     (cons "?"      #'debug-help  )
  255.     (cons "Abort"  #'debug-unwind)
  256.     (cons "Unwind" #'debug-unwind)
  257.     (cons "Mode-1" #'debug-mode-1)
  258.     (cons "Mode-2" #'debug-mode-2)
  259.     (cons "Mode-3" #'debug-mode-3)
  260.     (cons "Mode-4" #'debug-mode-4)
  261.     (cons "Mode-5" #'debug-mode-5)
  262.     (cons "Where"  #'debug-where )
  263.     (cons "Up"     #'debug-up    )
  264.     (cons "Top"    #'debug-top   )
  265.     (cons "Down"   #'debug-down  )
  266.     (cons "Bottom" #'debug-bottom)
  267.     (cons "Backtrace-1" #'debug-backtrace-1)
  268.     (cons "Backtrace-2" #'debug-backtrace-2)
  269.     (cons "Backtrace-3" #'debug-backtrace-3)
  270.     (cons "Backtrace-4" #'debug-backtrace-4)
  271.     (cons "Backtrace-5" #'debug-backtrace-5)
  272.     (cons "Backtrace"   #'debug-backtrace  )
  273. ) )
  274. (defun commands2 ()
  275.              (list
  276.                (cons "Break+" #'debug-trap-on )
  277.                (cons "Break-" #'debug-trap-off)
  278.                (cons "Redo"   #'debug-redo  )
  279.                (cons "Return" #'debug-return)
  280. )            )
  281. (defun commands3 ()
  282.              (list
  283.                 #L{
  284.                 DEUTSCH "
  285. Continue = Rest weiter abarbeiten"
  286.                 ENGLISH "
  287. Continue = continue evaluation"
  288.                 FRANCAIS "
  289. Continue = continuer l'évaluation"
  290.                }
  291.                (cons "Continue" #'debug-continue)
  292. )            )
  293.  
  294.  
  295. ;; um Help-Kommando erweiterte Hauptschleife.
  296. (defun main-loop ()
  297.   (setq *break-count* 0)
  298.   (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausführen:
  299.     #'(lambda ()
  300.         (catch 'debug ; die (throw 'debug ...) abfangen
  301.           (if ; Eingabezeile verlangen
  302.               (read-eval-print (string-concat (prompt-string1) (prompt-string2) (prompt-string3))
  303.                                (copy-list (commands0))
  304.               )
  305.             ; T -> #<EOF>
  306.             (exit)
  307.             ; NIL -> Form bereits ausgewertet und ausgegeben
  308. ) )   ) ) )
  309. (setq *driver* #'main-loop)
  310.  
  311. ;; komfortable Break-Schleife. (Läuft nur in compiliertem Zustand!)
  312. (defun break-loop (continuable &optional (condition nil) (print-it nil)
  313.                    &aux (may-continue
  314.                           (or continuable
  315.                               (and condition (find-restart 'continue condition))
  316.                         ) )
  317.                         (interactive-p (interactive-stream-p *debug-io*))
  318.                         (commandsr '())
  319.                   )
  320.   (when (and print-it (typep condition (clos:find-class 'condition)))
  321.     (symbol-stream '*error-output* :output)
  322.     ; Ein Zeichen auf *error-output* ausgeben, mit Abfangen von Endlosrekursion:
  323.     (let ((*recurse-count-error-output* (1+ *recurse-count-error-output*)))
  324.       (when (> *recurse-count-error-output* 3)
  325.         (setq *recurse-count-error-output* 0)
  326.         (close *error-output*) (symbol-stream '*error-output* :output)
  327.       )
  328.       (terpri *error-output*)
  329.     )
  330.     (if may-continue
  331.       (progn (write-string "** - Continuable Error" *error-output*) (terpri *error-output*))
  332.       (write-string "*** - " *error-output*)
  333.     )
  334.     ;; Output the error message, but don't trap into recursive errors.
  335.     (let ((*recursive-error-count* (1+ *recursive-error-count*)))
  336.       (if (> *recursive-error-count* 3)
  337.         (progn
  338.           (setq *recursive-error-count* 0)
  339.           (write-string
  340.             #L{
  341.                DEUTSCH "Unausgebbare Fehlermeldung"
  342.                ENGLISH "Unprintable error message"
  343.                FRANCAIS "Message inimprimable"
  344.               }
  345.             *error-output*
  346.         ) )
  347.         (sys::print-condition condition *error-output*)
  348.     ) )
  349.     (symbol-stream '*debug-io* :io)
  350.     (when may-continue
  351.       (if continuable
  352.         (when interactive-p
  353.           (terpri *debug-io*)
  354.           (write-string
  355.                    #L{
  356.                    DEUTSCH "Sie können (mit Continue) fortfahren."
  357.                    ENGLISH "You can continue (by typing 'continue')."
  358.                    FRANCAIS "Vous pouvez continuer (tapez «continue» pour cela)."
  359.                    }
  360.                    *debug-io*
  361.                   )
  362.         )
  363.         (progn
  364.           (terpri *debug-io*)
  365.           (when interactive-p
  366.              (write-string
  367.                      #L{
  368.                      DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
  369.                      ENGLISH "If you continue (by typing 'continue'): "
  370.                      FRANCAIS "Si vous continuez (en tapant «continue»): "
  371.                      }
  372.                      *debug-io*
  373.                     )
  374.           )
  375.           (princ may-continue *debug-io*)
  376.   ) ) ) )
  377.   (when condition
  378.     (let ((restarts (remove may-continue (compute-restarts condition))))
  379.       (when restarts
  380.         (when interactive-p
  381.           (terpri *debug-io*)
  382.           (write-string (if may-continue
  383.                             #L{
  384.                             DEUTSCH "Weitere mögliche Optionen:"
  385.                             ENGLISH "The following restarts are available too:"
  386.                             FRANCAIS "D'autres rentrées possibles:"
  387.                             }
  388.                             #L{
  389.                             DEUTSCH "Mögliche Optionen:"
  390.                             ENGLISH "The following restarts are available:"
  391.                             FRANCAIS "Rentrées possibles:"
  392.                             }
  393.                         )
  394.                         *debug-io*
  395.         ) )
  396.         (let ((counter 0))
  397.           (dolist (restart restarts)
  398.             (let* ((command (string-concat "R" (sys::decimal-string (incf counter))))
  399.                    (helpstring (string-concat "
  400. " command " = " (princ-to-string restart))))
  401.               ; Restart-Möglichkeit ausgeben:
  402.               (when interactive-p
  403.                 (write-string helpstring *debug-io*)
  404.               )
  405.               (push helpstring commandsr)
  406.               ; und in die Liste commandsr aufnehmen:
  407.               (push (cons command
  408.                           (let ((restart restart))
  409.                             #'(lambda () (invoke-restart-interactively restart))
  410.                     )     )
  411.                     commandsr
  412.           ) ) )
  413.           (setq commandsr (nreverse commandsr))
  414.   ) ) ) )
  415.   (tagbody
  416.     (let* ((*break-count* (1+ *break-count*))
  417.            (stream (make-synonym-stream '*debug-io*))
  418.            (*standard-input* stream)
  419.            (*standard-output* stream)
  420.            (prompt (with-output-to-string (s)
  421.                       (write-string (prompt-string1) s)
  422.                       (write *break-count* :stream s)
  423.                       (write-string ". Break" s)
  424.                       (write-string (prompt-string2) s)
  425.                       (write-string (prompt-string3) s)
  426.            )       )
  427.            (*frame-limit1* (frame-limit1 13))
  428.            (*frame-limit2* (frame-limit2))
  429.            (*debug-mode* 4)
  430.            (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  431.           )
  432.       (driver ; Driver-Frame aufbauen und folgende Funktion (endlos) ausführen:
  433.         #'(lambda ()
  434.             (case
  435.                 (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  436.                   (same-env-as *debug-frame* ; bei *debug-frame* gültiges Environment aufbauen
  437.                     #'(lambda ()
  438.                         (if ; Eingabezeile verlangen
  439.                             (read-eval-print prompt
  440.                               (nconc (copy-list (commands1))
  441.                                      (when (eval-frame-p *debug-frame*) (copy-list (commands2)))
  442.                                      (when may-continue (copy-list (commands3)))
  443.                                      commandsr
  444.                             ) )
  445.                           ; T -> #<EOF>
  446.                           (throw 'debug (if may-continue 'quit 'unwind))
  447.                           ; NIL -> Form bereits ausgewertet und ausgegeben
  448.                           #|(throw 'debug 'continue)|#
  449.                 ) )   ) )
  450.               (unwind (go unwind))
  451.               (quit ; nur erreicht, falls may-continue
  452.                 (if continuable
  453.                   (go quit)
  454.                   (invoke-restart-interactively may-continue)
  455.               ) )
  456.               (t ) ; alles andere, insbesondere continue
  457.     ) )   ) )
  458.     unwind (unwind-to-driver)
  459.     quit
  460. ) )
  461. (setq *break-driver* #'break-loop)
  462.  
  463. ;-------------------------------------------------------------------------------
  464. ;;        komfortabler Stepper. (Läuft nur in compiliertem Zustand!)
  465.  
  466. (defvar *step-level* 0) ; momentane Step-Tiefe
  467. (defvar *step-quit* most-positive-fixnum) ; kritische Step-Tiefe:
  468.   ; sobald diese unterschritten wird, wacht der Stepper wieder auf.
  469. (defvar *step-watch* nil) ; Abbruchbedingung
  470.  
  471. ; (STEP form), CLTL S. 441
  472. (defmacro step (form)
  473.   `(let* ((*step-level* 0)
  474.           (*step-quit* most-positive-fixnum)
  475.           (*step-watch* nil)
  476.           (*evalhook* #'step-hook-fn))
  477.      ,form
  478.    )
  479. )
  480.  
  481. (defun commands4 ()
  482.              (list
  483.                 #L{
  484.                 DEUTSCH "
  485. Step     = Step into form: diese Form im Einzelschrittmodus ausführen
  486. Next     = Step over form: diese Form auf einmal ausführen
  487. Over     = Step over this level: bis zum Aufrufer auf einmal ausführen
  488. Continue = Einzelschrittmodus abschalten, Rest ausführen
  489. Step-until, Next-until, Over-until, Continue-until:
  490.            dito, jedoch mit Angabe einer Abbruchbedingung"
  491.                 ENGLISH "
  492. Step     = step into form: evaluate this form in single step mode
  493. Next     = step over form: evaluate this form at once
  494. Over     = step over this level: evaluate at once up to the next return
  495. Continue = switch off single step mode, continue evaluation
  496. Step-until, Next-until, Over-until, Continue-until:
  497.            same as above, specify a condition when to stop"
  498.                 FRANCAIS "
  499. Step     = step into form: évaluer cette forme petit à petit
  500. Next     = step over form: évaluer cette forme en bloc
  501. Over     = step over this level: évaluer tout le reste jusqu'au prochain retour
  502. Continue = continue: évaluer tout le reste en bloc
  503. Step-until, Next-until, Over-until, Continue-until:
  504.            de même, avec spécification d'une condition d'arrêt"
  505.                }
  506.                (cons "Step"     #'(lambda () (throw 'stepper 'into)))
  507.                (cons "Next"     #'(lambda () (throw 'stepper 'over)))
  508.                (cons "Over"     #'(lambda () (throw 'stepper 'over-this-level)))
  509.                (cons "Continue" #'(lambda () (throw 'stepper 'continue)))
  510.                (cons "Step-until"     #'(lambda () (throw 'stepper (values 'into t))))
  511.                (cons "Next-until"     #'(lambda () (throw 'stepper (values 'over t))))
  512.                (cons "Over-until"     #'(lambda () (throw 'stepper (values 'over-this-level t))))
  513.                (cons "Continue-until" #'(lambda () (throw 'stepper (values 'continue t))))
  514. )            )
  515.  
  516. (defun step-values (values)
  517.   (let ((*standard-output* *debug-io*))
  518.     (terpri #|*debug-io*|#)
  519.     (write-string
  520.      #L{
  521.      DEUTSCH "Step "
  522.      ENGLISH "step "
  523.      FRANCAIS "Step "
  524.      }
  525.      #|*debug-io*|#
  526.     )
  527.     (write *step-level* #|:stream *debug-io*|#)
  528.     (write-string " ==> " #|*debug-io*|#)
  529.     (case (length values)
  530.       (0 (write-string
  531.           #L{
  532.           DEUTSCH "Keine Werte"
  533.           ENGLISH "no values"
  534.           FRANCAIS "Aucune valeur"
  535.           }
  536.           #|*debug-io*|#
  537.       )  )
  538.       (1 (write-string
  539.           #L{
  540.           DEUTSCH "Wert: "
  541.           ENGLISH "value: "
  542.           FRANCAIS "Valeur : "
  543.           }
  544.           #|*debug-io*|#
  545.          )
  546.          (write (car values) #|:stream *debug-io*|#)
  547.       )
  548.       (t (write (length values) #|:stream *debug-io*|#)
  549.          (write-string
  550.           #L{
  551.           DEUTSCH " Werte: "
  552.           ENGLISH " values: "
  553.           FRANCAIS " Valeurs : "
  554.           }
  555.           #|*debug-io*|#
  556.          )
  557.          (do ((L values))
  558.              ((endp L))
  559.            (write (pop L) #|:stream *debug-io*|#)
  560.            (unless (endp L) (write-string ", " #|*debug-io*|#))
  561.       )  )
  562.   ) )
  563.   (values-list values)
  564. )
  565.  
  566. (defun step-hook-fn (form &optional (env *toplevel-environment*))
  567.   (let ((*step-level* (1+ *step-level*)))
  568.     (when (>= *step-level* *step-quit*) ; Solange *step-level* >= *step-quit*
  569.       (if (and *step-watch* (funcall *step-watch*)) ; und kein Breakpoint,
  570.         (setq *step-quit* most-positive-fixnum)
  571.         (return-from step-hook-fn ; ist der Stepper passiv
  572.           (evalhook form nil nil env) ; (d.h. er evaluiert die Form einfach)
  573.     ) ) )
  574.     (tagbody
  575.       (let* ((stream (make-synonym-stream '*debug-io*))
  576.              (*standard-input* stream)
  577.              (*standard-output* stream)
  578.              (prompt (with-output-to-string (s)
  579.                        (write-string (prompt-string1) s)
  580.                        (write-string "Step " s)
  581.                        (write *step-level* :stream s)
  582.                        (write-string (prompt-string2) s)
  583.                        (write-string (prompt-string3) s)
  584.              )       )
  585.              (*frame-limit1* (frame-limit1 11))
  586.              (*frame-limit2* (frame-limit2))
  587.              (*debug-mode* 4)
  588.              (*debug-frame* (frame-down-1 (frame-up-1 *frame-limit1* *debug-mode*) *debug-mode*))
  589.             )
  590.         (fresh-line #|*debug-io*|#)
  591.         (write-string
  592.          #L{
  593.          DEUTSCH "Step "
  594.          ENGLISH "step "
  595.          FRANCAIS "Step "
  596.          }
  597.          #|*debug-io*|#
  598.         )
  599.         (write *step-level* #|:stream *debug-io*|#)
  600.         (write-string " --> " #|*debug-io*|#)
  601.         (write form #|:stream *debug-io*|# :length 4 :level 3)
  602.         (loop
  603.           (multiple-value-bind (what watchp)
  604.             (catch 'stepper ; die (throw 'stepper ...) abfangen und analysieren
  605.               (driver ; Driver-Frame aufbauen und folgende Funktion endlos ausführen:
  606.                 #'(lambda ()
  607.                     (case
  608.                         (catch 'debug ; die (throw 'debug ...) abfangen und analysieren
  609.                           (same-env-as *debug-frame* ; bei *debug-frame* gültiges Environment aufbauen
  610.                             #'(lambda ()
  611.                                 (if ; Eingabezeile verlangen
  612.                                     (read-eval-print prompt
  613.                                       (nconc (copy-list (commands1))
  614.                                              (when (eval-frame-p *debug-frame*) (copy-list (commands2)))
  615.                                              (copy-list (commands4))
  616.                                     ) )
  617.                                   ; T -> #<EOF>
  618.                                   (go continue)
  619.                                   ; NIL -> Form bereits ausgewertet und ausgegeben
  620.                                   #|(throw 'debug 'continue)|#
  621.                         ) )   ) )
  622.                       (unwind (go unwind))
  623.                       (t ) ; alles andere, insbesondere continue
  624.             ) )   ) )
  625.             (when watchp
  626.               (let ((form (read-form
  627.                            #L{
  628.                            DEUTSCH "Abbruchbedingung: "
  629.                            ENGLISH "condition when to stop: "
  630.                            FRANCAIS "condition d'arrêt : "
  631.                            }
  632.                    ))     )
  633.                 (setq *step-watch* ; Funktion, die 'form' bei *debug-frame* auswertet
  634.                   (eval-at *debug-frame* `(function (lambda () ,form)))
  635.             ) ) )
  636.             (case what
  637.               (into (go into))
  638.               (over (go over))
  639.               (over-this-level (go over-this-level))
  640.               (continue (go continue))
  641.             )
  642.       ) ) )
  643.       unwind
  644.         (unwind-to-driver)
  645.       into
  646.         (return-from step-hook-fn
  647.           (step-values
  648.             (multiple-value-list (evalhook form #'step-hook-fn nil env))
  649.         ) )
  650.       over-this-level
  651.         (setq *step-quit* *step-level*) ; Stepper in Schlafzustand schalten
  652.       over
  653.         (return-from step-hook-fn
  654.           (step-values
  655.             (multiple-value-list (evalhook form nil nil env))
  656.         ) )
  657.       continue
  658.         (setq *step-quit* 0)
  659.         (go over)
  660. ) ) )
  661.  
  662. ;-------------------------------------------------------------------------------
  663. ;;                                  Errors
  664.  
  665. ; *ERROR-HANDLER* sollte NIL oder eine Funktion sein, die übergeben bekommt:
  666. ; - NIL (bei ERROR) bzw. continue-format-string (bei CERROR),
  667. ; - error-format-string,
  668. ; - Argumente dazu,
  669. ; und die nur zurückkehren sollte, falls das erstere /=NIL ist.
  670. (defvar *error-handler* nil)
  671.  
  672. ; (CERROR continue-format-string error-format-string {arg}*), CLTL S. 430
  673. (defun cerror (continue-format-string error-format-string &rest args)
  674.   (if *error-handler*
  675.     (apply *error-handler*
  676.            (or continue-format-string t) error-format-string args
  677.     )
  678.     (progn
  679.       (terpri *error-output*)
  680.       (write-string "** - Continuable Error" *error-output*)
  681.       (terpri *error-output*)
  682.       (apply #'format *error-output* error-format-string args)
  683.       (terpri *debug-io*)
  684.       (if (interactive-stream-p *debug-io*)
  685.         (progn
  686.           (write-string
  687.                    #L{
  688.                    DEUTSCH "Wenn Sie (mit Continue) fortfahren: "
  689.                    ENGLISH "If you continue (by typing 'continue'): "
  690.                    FRANCAIS "Si vous continuez (en tapant «continue»): "
  691.                    }
  692.                    *debug-io*
  693.                   )
  694.           (apply #'format *debug-io* continue-format-string args)
  695.           (funcall *break-driver* t)
  696.         )
  697.         (apply #'format *debug-io* continue-format-string args)
  698.   ) ) )
  699.   nil
  700. )
  701.  
  702. (defvar *break-on-warnings* nil)
  703. ; (WARN format-string {arg}*), CLTL S. 432
  704. (defun warn (format-string &rest args)
  705.   (terpri *error-output*)
  706.   (write-string
  707.    #L{
  708.    DEUTSCH "WARNUNG:"
  709.    ENGLISH "WARNING:"
  710.    FRANCAIS "AVERTISSEMENT :"
  711.    }
  712.    *error-output*
  713.   )
  714.   (terpri *error-output*)
  715.   (apply #'format *error-output* format-string args)
  716.   (when *break-on-warnings* (funcall *break-driver* t))
  717.   nil
  718. )
  719.  
  720. ; (BREAK [format-string {arg}*]), CLTL S. 432
  721. (defun break (&optional (format-string "*** - Break") &rest args)
  722.   (terpri *error-output*)
  723.   (apply #'format *error-output* format-string args)
  724.   (funcall *break-driver* t)
  725.   nil
  726. )
  727.  
  728. ; (SYSTEM::BATCHMODE-ERRORS {form}*) executes the forms, but handles errors
  729. ; just as a batch program should do: continuable errors are signalled as
  730. ; warnings, non-continuable errors cause Lisp to exit.
  731. (defmacro batchmode-errors (&body body)
  732.   `(LET ((*ERROR-HANDLER* #'BATCHMODE-ERROR-HANDLER))
  733.      (PROGN ,@body)
  734.    )
  735. )
  736. (defun batchmode-error-handler (continue errorstring &rest args)
  737.   (if continue
  738.     (warn "~A~%~A" (apply #'format nil errorstring args)
  739.                    (apply #'format nil continue args)
  740.     )
  741.     (progn
  742.       (terpri *error-output*)
  743.       (write-string "*** - " *error-output*)
  744.       (apply #'format *error-output* errorstring args)
  745.       (exit t) ; exit Lisp with error
  746. ) ) )
  747.  
  748. ;-------------------------------------------------------------------------------
  749. ;;                            Querying the user
  750.  
  751. ; (Y-OR-N-P [format-string {arg}*]), CLTL S. 407
  752. (defun y-or-n-p (&optional format-string &rest args)
  753.   (when format-string
  754.     (fresh-line *query-io*)
  755.     (apply #'format *query-io* format-string args)
  756.     (write-string
  757.      #L{
  758.      DEUTSCH " (j/n) "
  759.      ENGLISH " (y/n) "
  760.      FRANCAIS " (o/n) "
  761.      }
  762.      *query-io*
  763.   ) )
  764.   (loop
  765.     (let ((line (string-left-trim " " (read-line *query-io*))))
  766.       (when (plusp (length line))
  767.         (case (char-upcase (char line 0))
  768.           (#\N (return nil))
  769.           ((#\J #\Y #\O) (return t))
  770.     ) ) )
  771.     (terpri *query-io*)
  772.     (write-string
  773.      #L{
  774.      DEUTSCH "Bitte mit j oder n antworten: "
  775.      ENGLISH "Please answer with y or n : "
  776.      FRANCAIS "Répondez par o ou n : "
  777.      }
  778.      *query-io*
  779. ) ) )
  780.  
  781. ; (YES-OR-NO-P [format-string {arg}*]), CLTL S. 408
  782. (defun yes-or-no-p (&optional format-string &rest args)
  783.   (when format-string
  784.     (fresh-line *query-io*)
  785.     (apply #'format *query-io* format-string args)
  786.     (write-string
  787.      #L{
  788.      DEUTSCH " (ja/nein) "
  789.      ENGLISH " (yes/no) "
  790.      FRANCAIS " (oui/non) "
  791.      }
  792.      *query-io*
  793.   ) )
  794.   (loop
  795.     (clear-input *query-io*)
  796.     (let* ((line (string-trim " " (read-line *query-io*)))
  797.            (h (assoc line '(("ja" . t) ("nein" . nil)
  798.                             ("yes" . t) ("no" . nil)
  799.                             ("oui" . t) ("non" . nil)
  800.                            )
  801.                           :test #'string-equal
  802.           ))  )
  803.       (when h (return (cdr h)))
  804.     )
  805.     (terpri *query-io*)
  806.     (write-string
  807.      #L{
  808.      DEUTSCH "Bitte mit ja oder nein antworten: "
  809.      ENGLISH "Please answer with yes or no : "
  810.      FRANCAIS "Répondez par oui ou non : "
  811.      }
  812.      *query-io*
  813. ) ) )
  814.  
  815. (defvar *keyboard-input*)
  816. #+AMIGA
  817. (defun do-with-keyboard (fn)
  818.   ;; Funktion wird umdefiniert falls SCREEN geladen ist
  819.   (unwind-protect
  820.     (progn
  821.       (sys::terminal-raw *terminal-io* t)
  822.       (funcall fn))
  823.     (sys::terminal-raw *terminal-io* nil)))
  824. (defmacro with-keyboard (&body body)
  825.   #+(or DOS OS/2 WIN32-DOS) ; *keyboard-input* existiert schon
  826.     `(LET () (PROGN ,@body))
  827.   #+(or UNIX ACORN-RISCOS WIN32-UNIX)
  828.     (let ((mode (gensym)))
  829.       `(LET ((,mode NIL))
  830.          (UNWIND-PROTECT
  831.            (PROGN (SETQ ,mode (SYS::TERMINAL-RAW *TERMINAL-IO* T)) ,@body)
  832.            (SYS::TERMINAL-RAW *TERMINAL-IO* ,mode)
  833.        ) )
  834.     )
  835.   #+AMIGA
  836.     `(DO-WITH-KEYBOARD (FUNCTION (LAMBDA () ,@body)))
  837. )
  838.  
  839.