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