Uranus/stepper.lisp at master · g000001/Uranus · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
;;; -*- Mode:Lisp; Syntax: Common-lisp; Package: URA; -*-
;;; This file is "Stepper.lisp".
;;; Uranus Stepper
;;; 1984/05/11
;;; by Hideyuki Nakashima

(in-package :uranus)

#+symbolics
(DEFUN URANUS-STEP NIL
   (COND ((or @attention @error-or-attention
	      (AND (OR @STEP (MEMQ (CAR @FORM) @SELECTSTEP))
		   (>= @STEPLEVEL @LEVEL)))
          (SETQ @STEPLEVEL 99999.)
          (TRACE-entry @FORM @OLD-SUBST @LEVEL)
          (DO nil
              (NIL)
	    (case (zl:fquery
		     '(:list-choices nil
		       :fresh-line nil
		       :choices
		       (((all "All") #\a)
			((bt  "Back trace") #\b)
			((continue "Continue") #\c #\ ) ;change sp to " " for kcl
			((finish "Finish") #\f)
			((go "Go") #\g)
			((level "Level of printing: ") #\l)
			((next "Next alternative") #\n)
			((pp "Pretty print the goal") #\p)
			((quit "Quit") #\q)
			((select "Select step ") #\s)
			((up "Up") #\u)
			((execute "Execute: ") #\x)
			((lparen "Predicate: ") #\())
		       :help-function  step@help)
		     " S: ")
	      (all (SETQ @STEP T @debug t))
	      (bt (PPRINT (p@BACKTRACE @PRINTLEVEL)))
	      (continue (RETURN NIL))
	      (finish (RETURN (SETQ @STEP NIL @debug (or @step @trace @traceall))))
	      (go  (RETURN (SETQ @STEPLEVEL @LEVEL)))
	      (level (SETQ @PRINTLEVEL (Read)))
	      (next (return (r@fail)))
	      (pp (PPRINT (Trace-fetch-value @FORM @OLD-SUBST)))
	      (quit (THROW :URANUSLOOP NIL))
	      (select (SETQ @STEP NIL)
		(PUSH (RIND "Predicate-name:") @SELECTSTEP))
	      (up  (RETURN (SETQ @STEPLEVEL (1- @LEVEL))))
	      (execute (LET ((@SELECTSTEP NIL) (@STEP NIL))
		      (EXECUTE (Read))))
	      (lparen (LET ((@SELECTSTEP NIL) (@STEP NIL))
			(funcall standard-input ':untyi #\()
			(EXECUTE (read nil)))))))))

#-symbolics
(DEFUN URANUS-STEP NIL
  (COND ((or @attention @error-or-attention
	      (AND (OR @STEP (MEMQ (CAR @FORM) @SELECTSTEP))
		   (>= @STEPLEVEL @LEVEL)))
          (SETQ @STEPLEVEL 99999.)
          (TRACE-entry @FORM @OLD-SUBST @LEVEL)
          (DO ((key (read-from-window #\-) (read-from-window #\-)))
              (NIL)
	    (case key
	      (uranus-user::? (step@help *terminal-io*))
	      (uranus-user::a (SETQ @STEP T @debug t))
	      (uranus-user::b (PPRINT (p@BACKTRACE @PRINTLEVEL)))
	      (uranus-user::c (RETURN NIL))
	      (uranus-user::f (RETURN (SETQ @STEP NIL @debug (or @step @trace @traceall))))
	      (uranus-user::g (RETURN (SETQ @STEPLEVEL @LEVEL)))
	      (uranus-user::l (SETQ @PRINTLEVEL (Read *terminal-io*)))
	      (uranus-user::n (return (r@fail)))
	      (uranus-user::p (PPRINT (Trace-fetch-value @FORM @OLD-SUBST)))
	      (uranus-user::q (THROW :URANUSLOOP NIL))
	      (uranus-user::s (SETQ @STEP NIL)
		(PUSH (RIND "Predicate-name:") @SELECTSTEP))
	      (uranus-user::u (RETURN (SETQ @STEPLEVEL (1- @LEVEL))))
	      (uranus-user::x (LET ((@SELECTSTEP NIL) (@STEP NIL))
		      (EXECUTE (Read *terminal-io*))))
	      (t (cond ((or (consp key) (td-p key))
			(let ((@selectstep nil) (@step nil))
			  (execute key)))
			    (t (format t "Unknown command.  Try ?~%"))))
		      )))))

(defun step@help (stream)
       (format stream
	       "~%The commands are one of the following characters:
A: Stop at all predicates;
B: Back trace (effective only in the debugging mode);
C: Continue one step (a space will do);
F: Finish without stopping;
G: Go (execute this goal only);
L: change the Level of printing;
N: fail this goal and try the Next alternative;
P: Pretty print the current goal;
Q: Quit;
S: Select predicates to stop;
U: Up one level;
X: eXecute a predicate; or
(pred ...).~%"))