mim/development/mim/vax/mimlib/debugr.mud

   1 ;"A SINGLE STEP DEBUGR FOR MIM"
   2
   3 <PACKAGE "DEBUGR">
   4
   5 <RENTRY EVAL-IN         ;"Atom used by interrupt"
   6         EVAL-OUT>       ;"Atom used by interrupt"
   7
   8 <ENTRY DEBUG            ;"Establishes interrupt and returns enabled interrupt"
   9        DEBUG-IN         ;"Last thing typed as about to be eval'ed"
  10        DEBUG-OUT        ;"Last result printed"
  11        STOP             ;"Disables interrupt"
  12        START            ;"Enables interrupt"
  13        HELP             ;"Prints from help file"
  14        DEB-LEVEL       ;"Maintains value of # of eval frames until top level"
  15        DEB-IN          ;"Value of expression during last EVAL-IN interrupt"
  16        DEB-OUT         ;"Value of expression during last EVAL-OUT interrupt"
  17        INDENT-INC       ;"Spaces to indent each new level"
  18        INDENT-DIF       ;"Free spaces to leave on each line"
  19        INDENT-MOD       ;"Number of levels before indents begin on new line"
  20        SELF-FAST        ;"If true doesn't stop for objects which evaluate to
  21                           themselves"
  22        FORM-FAST        ;"If true doesn't stop for simple forms: .FOO ,BAR
  23                           'BLETCH"
  24        OUT-FAST         ;"If true won't stop on eval out"
  25        OUT-UNIQUE>;"If true won't stop for two successive outs of the
  26                           same thing"
  27
  28 <GDECL (DEB-LEVEL) FIX>
  29
  30 <INCLUDE-WHEN <COMPILING? "DEBUGR"> "DEBUGRDEFS">
  31
  32 <USE "TTY">
  33
  34 <DEFINE DEBUG ("OPTIONAL" 'TODO "AUX" (OUTCHAN:CHANNEL ,DEBUG-CHANNEL))
  35         <SETG DEBSTATE ,OPHF>
  36         <COND (<GASSIGNED? DEB-HANDLER>
  37                <COND (<NOT <ASSIGNED? TODO>>
  38                       <PRINC "The Debugger is already loaded">
  39                       <CRLF>)>)
  40               (ELSE
  41                <INITIALIZE>
  42                <CLASS "EVAL" <SETG DEBUGR-INT-LEV <+ <INT-LEVEL> 1>>>
  43                <ON <SETG DEB-HANDLER
  44                          <HANDLER "EVAL" ,MAINLOOP>>>)>
  45         <SETG DEBSTATE ,NEXXT>
  46         <COND (<ASSIGNED? TODO>
  47                <START>
  48                <SET TODO <EVAL .TODO>>
  49                <STOP>
  50                .TODO)
  51               (ELSE ,NEXXT)>>
  52
  53 <DEFINE STOP ()
  54         <SETG DEBSTATE ,OPHF>               ;"Turns off one step state"
  55         <COND (<GASSIGNED? DEB-HANDLER> <OFF ,DEB-HANDLER>)>
  56         <DISABLE "EVAL">                   ;"Disables interrupt"
  57         "OFF">
  58
  59
  60 <DEFINE START ()
  61         #DECL ((VALUE) '1)
  62         <SET DEBUG-OUT <>>
  63         <SET DEBUG-IN <>>
  64         <COND (<NOT <GASSIGNED? DEB-HANDLER>>
  65                <DEBUG>)
  66               (<ON ,DEB-HANDLER>)>
  67         <ENABLE "EVAL">                   ;"Enables interrupt"
  68         <SETG DEBSTATE ,NEXXT>>            ;"Sets up one step state"
  69
  70 <SETG DEBUGR-HELP "DEBUGR.HELP">
  71
  72 <DEFINE HELP ("AUX" C (OUTCHAN:CHANNEL ,DEBUG-CHANNEL))
  73         <SETG DEBSTATE ,OPHF>
  74         <COND (<SET C <L-OPEN ,DEBUGR-HELP>>
  75                <FILECOPY .C .OUTCHAN>)
  76               (ELSE <PRINC "No help available?"> <CRLF>)>
  77         <SETG DEBSTATE ,NEXXT>>
  78
  79 <DEFINE MAINLOOP (SHIT TYP ARG "OPT" VAL FOO
  80                   "AUX" (OUTCHAN ,DEBUG-CHANNEL) "NAME" LERR!-INTERRUPTS)
  81         #DECL ((TYP) ATOM (ARG VAL) ANY (OUTCHAN) CHANNEL
  82                (LERR!-INTERRUPTS) <SPECIAL FRAME>)
  83         <COND (<==? ,DEBSTATE ,OPHF>) ;"Prevents stepping when not wanted"
  84               (<==? .TYP EVAL-IN>  ;"The following prevents stepper from
  85                                      stepping through part of itself"
  86                <COND (<OR <=? .ARG '<STOP>>
  87                           <=? .ARG '<SETG DEBSTATE ,OPHF>>
  88                           <=? .ARG '<HELP>>
  89                           <=? .ARG '<START>>
  90                           <=? .ARG '<DEBUG>>
  91                           <=? .ARG 'DEBSTATE>
  92                           <=? .ARG ',OPHF>>)
  93                      (ELSE <EVAL-IN-DISPATCH .ARG>)>)
  94               (<==? .TYP EVAL-OUT>
  95                <COND (<OR <=? .ARG '<SETG DEBSTATE ,NEXXT>>
  96                           <=? .ARG '<SETG DEBSTATE ,OPHF>>
  97                           <=? .ARG '<START>>
  98                           <=? .ARG '<DEBUG>>
  99                           <=? .ARG '<HELP>>
 100                           <=? .ARG '<STOP>>
 101                           <=? .ARG 'DEBSTATE>
 102                           <=? .ARG ',OPHF>>)
 103                      (ELSE <EVAL-OUT-DISPATCH .VAL>)>)
 104               (ELSE <PRINC "FOO!!!!">)>>   ;"Simple error checking, should never
 105                                              occur"
 106
 107 <DEFINE EVAL-IN-DISPATCH (EXPR "AUX" VAL)
 108         #DECL ((EXPR) ANY)
 109         <COND (<AND <STRUCTURED? ,DEB-IN>
 110                     <MEMQ .EXPR ,DEB-IN>>
 111                <SETG DEB-LEVEL <+ ,DEB-LEVEL 1>>)
 112               (ELSE <SETG DEB-LEVEL <FRAME-COUNT .LERR!-INTERRUPTS>>)>
 113         <SETG DEB-IN .EXPR>     ;"Binds check for user access"
 114         <COND (,MACRO-FLAG)
 115               (<AND <==? ,DEB-LEVEL ,MACRO-LEVEL>
 116                     <OR <==? ,DEBSTATE ,FAST>
 117                         <==? ,DEBSTATE ,WEER>>>
 118                <SETG MACRO-FLAG T>)
 119               (<==? ,DEBSTATE ,BODY>
 120                <COND (<G? ,DEB-LEVEL <1 ,INFO>>)
 121                      (<AND <==? ,DEB-LEVEL <1 ,INFO>>
 122                            <MEMBER .EXPR <2 ,INFO>>>
 123                       <INPRINTER .EXPR ,DEB-LEVEL>
 124                       (<EVAL .EXPR>))
 125                      (ELSE <SETG DEBSTATE ,NEXXT>
 126                       <INPUT-PRINT-BREAK .EXPR ,DEB-LEVEL>)>)
 127               (<AND <==? ,DEBSTATE ,PRED>
 128                     <EVAL ,PREDICATE>>
 129                <INPUT-PRINT-BREAK .EXPR ,DEB-LEVEL>)
 130               (<==? ,DEBSTATE ,WEER>
 131                <COND (<G? ,DEB-LEVEL <1 ,INFO>>)
 132                      (<OR <AND <==? ,DEB-LEVEL <1 ,INFO>>
 133                                <=? .EXPR <2 ,INFO>>>
 134                           <L? ,DEB-LEVEL <1 ,INFO>>>
 135                       <SETG DEBSTATE ,NEXXT>
 136                       <INPUT-PRINT-BREAK .EXPR ,DEB-LEVEL>)
 137                      (<==? ,DEB-LEVEL <1 ,INFO>>
 138                       <INPRINTER .EXPR ,DEB-LEVEL>
 139                       ; "Just eval the expression, without further formalities"
 140                         (<EVAL .EXPR>))>)
 141               (<==? ,DEBSTATE ,NEXXT>
 142                <INPUT-PRINT-BREAK .EXPR ,DEB-LEVEL>
 143                <COND (<==? ,DEBSTATE ,FAST>
 144                       <UNWIND <SET VAL <EVAL .EXPR>>
 145                               <PROG ()
 146                                  <SETG DEBSTATE ,NEXXT>
 147                                  <ENABLE "EVAL">
 148                                  <COND (<==? <INT-LEVEL> ,DEBUGR-INT-LEV>
 149                                         <INT-LEVEL <- ,DEBUGR-INT-LEV 1>>)>>>
 150                       <SETG DEBSTATE ,NEXXT>
 151                       (.VAL))
 152                      (<==? ,DEBSTATE ,FLUSH-STATE>
 153                       <SETG DEBSTATE ,NEXXT>
 154                       (<>))>)>>
 155
 156 <DEFINE EVAL-OUT-DISPATCH (EXPR)
 157         #DECL ((EXPR) ANY)
 158         <SETG DEB-LEVEL <FRAME-COUNT .LERR!-INTERRUPTS>>
 159         <SETG DEB-OUT .EXPR>   ;"Binds check for user access"
 160         <COND (<AND ,MACRO-FLAG <==? ,DEB-LEVEL ,MACRO-LEVEL>>
 161                <SETG MACRO-LEVEL -1>
 162                <SETG MACRO-FLAG <>>)
 163               (,MACRO-FLAG)
 164               (<OR <==? ,DEBSTATE ,NEXXT>
 165                    <AND <==? ,DEBSTATE ,BODY>       ;"The following are the"
 166                         <L? ,DEB-LEVEL <1 ,INFO>>>;"terminating conditions"
 167                    <AND <==? ,DEBSTATE ,FAST>      ;"for BODY, FAST, WEER"
 168                         <L=? ,DEB-LEVEL <1 ,INFO>>>;"and Predicate, in which"
 169                    <AND <==? ,DEBSTATE ,WEER>     ;"case state is changed"
 170                         <L? ,DEB-LEVEL <1 ,INFO>>>>
 171                <SETG DEBSTATE ,NEXXT>
 172                <OUTPUT-PRINT-BREAK .EXPR ,DEB-LEVEL>)
 173               (<AND <==? ,DEBSTATE ,PRED>
 174                     <EVAL ,PREDICATE>>
 175                <SETG LO LO>
 176                <OUTPUT-PRINT-BREAK .EXPR ,DEB-LEVEL>)
 177               (<AND <OR <==? ,DEBSTATE ,WEER>
 178                         <==? ,DEBSTATE ,BODY>>
 179                     <==? ,DEB-LEVEL <1 ,INFO>>
 180                     ,INFULL?>
 181                <OUTPRINTER .EXPR ,DEB-LEVEL>)>>
 182
 183 <DEFINE INPUT-PRINT-BREAK (EXPRESSION LEVEL "AUX" I/O-MODE)
 184         #DECL ((EXPRESSION) ANY (LEVEL) FIX)
 185         <COND (<AND <TYPE? .EXPRESSION ATOM>
 186                     <NOT ,INFULL?>
 187                     <N==? ,DEBSTATE ,PRED>>)
 188               (ELSE
 189                <SET DEBUG-IN .EXPRESSION>
 190                <INPRINTER .EXPRESSION .LEVEL>
 191                <SETG DEBSTATE <READER ,INFULL?>> ;"Reader returns explicit
 192                                              debug state"
 193                <COND (<==? ,DEBSTATE ,BODY>
 194                       <SETG INFO [<+ .LEVEL 1> .EXPRESSION]>
 195                       <SETG MACRO-LEVEL .LEVEL>)
 196                      (<OR <==? ,DEBSTATE ,FAST>
 197                           <==? ,DEBSTATE ,WEER>>
 198                       <SETG MACRO-LEVEL .LEVEL>
 199                       <SETG INFO [.LEVEL .EXPRESSION]>)>)>>
 200
 201 <DEFINE INPRINTER (EXPRESSION LEVEL "AUX" (OUTCHAN ,DEBUG-CHANNEL)
 202                    (INDENT <MIN <* ,INDENT-INC
 203                                    <MOD <MAX .LEVEL 1> ,INDENT-MOD>>
 204                                 <- <CHANNEL-OP .OUTCHAN PAGE-WIDTH>:FIX
 205                                    ,INDENT-DIF>>))
 206         #DECL ((LEVEL INDENT) FIX (VALUE) <OR FALSE 'T>
 207                (OUTCHAN) CHANNEL)
 208         <SETG LO LO>            ;"This is in so flush last out value"
 209         <INDENT-TO .INDENT .OUTCHAN>     ;"Pprints indent routine"
 210         <PRIN1 .LEVEL>
 211         <COND (<==? ,DEBSTATE ,PRED>
 212                <NORMAL-PRINTER .EXPRESSION>)
 213               (<AND ,FORM-FAST        ;"Checks for simple forms:"
 214                     <TYPE? .EXPRESSION FORM>>
 215                <COND (<OR <EMPTY? .EXPRESSION> ;"Like <>"
 216                           <==? <1 .EXPRESSION> FUNCTION>
 217                           <==? <1 .EXPRESSION> QUOTE> ;"Like 'BLETCH"
 218                           <AND <==? <LENGTH? .EXPRESSION 2> 2>
 219                                <OR <==? <1 .EXPRESSION> LVAL>  ;"Like .FOO"
 220                                    <==? <1 .EXPRESSION> GVAL>> ;"Like ,BAR"
 221                                <TYPE? <2 .EXPRESSION> ATOM>>>
 222                       <QUICK-PRINTER .EXPRESSION>)
 223                      (ELSE <NORMAL-PRINTER .EXPRESSION>)>)
 224               (<AND ,FORM-FAST
 225                     <TYPE? .EXPRESSION LVAL GVAL>> ;"Checks for simple forms like
 226                                                      .FOO ,BAR"
 227                <QUICK-PRINTER .EXPRESSION>)
 228               (<AND ,FORM-FAST
 229                     <TYPE? .EXPRESSION LIST>
 230                     <EMPTY? .EXPRESSION>>
 231                <QUICK-PRINTER .EXPRESSION>)
 232               (<AND ,SELF-FAST    ;"Checks for types evaluating to themselves"
 233                     <NOT <TYPE? .EXPRESSION LIST VECTOR UVECTOR FORM GVAL LVAL>>>
 234                <SELF-PRINTER .EXPRESSION>)
 235               (ELSE <NORMAL-PRINTER .EXPRESSION>)>>
 236
 237
 238 <DEFINE NORMAL-PRINTER (EXPRESSION "AUX" (OUTCHAN:CHANNEL ,DEBUG-CHANNEL))
 239    ;"Used to print arrow and value"
 240         #DECL ((EXPRESSION) ANY (VALUE) 'T)
 241         <PRINC "=> ">
 242         <&1 .EXPRESSION>
 243         <CRLF>
 244         <SETG INFULL? T>>  ;"Infull is a flag telling if the last printed was in
 245                              full or abbreviated"
 246
 247 <DEFINE QUICK-PRINTER (EXPRESSION "AUX" (OUTCHAN:CHANNEL ,DEBUG-CHANNEL))
 248         #DECL ((VALUE) FALSE (EXPRESSION) ANY)
 249         <PRINC ":  ">
 250         <&1 .EXPRESSION>
 251         <PRINC " = ">
 252         <SETG LO <EVAL .EXPRESSION>>
 253         <SET DEBUG-OUT ,LO>
 254         <&1 ,LO>
 255         <CRLF>
 256         <SETG INFULL? <>>>
 257
 258 <DEFINE SELF-PRINTER (EXPRESSION "AUX" (OUTCHAN:CHANNEL ,DEBUG-CHANNEL))
 259    ;"Prints types evaluating to themselves"
 260         #DECL ((VALUE) FALSE (EXPRESSION) ANY)
 261         <PRINC ":  ">
 262         <&1 .EXPRESSION>
 263         <SET DEBUG-OUT .EXPRESSION>
 264         <CRLF>
 265         <SETG INFULL? <>>>
 266
 267 <DEFINE OUTPUT-PRINT-BREAK (EXPRESSION LEVEL)
 268         #DECL ((EXPRESSION) ANY (LEVEL) FIX)
 269         <COND (,INFULL?
 270                <SET DEBUG-OUT .EXPRESSION>
 271                <OUTPRINTER .EXPRESSION .LEVEL>)
 272               (ELSE <SETG INFULL? T>)>>
 273
 274 <DEFINE OUTPRINTER (EXPRESSION LEVEL "AUX" (OUTCHAN ,DEBUG-CHANNEL) LO
 275                     (INDENT <MIN <* ,INDENT-INC <MOD <MAX .LEVEL>
 276                                                      ,INDENT-MOD>>
 277                                  <- <CHANNEL-OP .OUTCHAN PAGE-WIDTH>
 278                                     ,INDENT-DIF>>))
 279         #DECL ((INDENT LEVEL) FIX (OUTCHAN) CHANNEL (VALUE) ANY)
 280         <COND (<OR <NOT ,OUT-UNIQUE>
 281                    <N==? .EXPRESSION ,LO>> ;"Checks to see if same as last"
 282                <INDENT-TO .INDENT .OUTCHAN>;"Pprints indent routine"
 283                <PRIN1 .LEVEL>
 284                <PRINC "<= ">
 285                <&1 .EXPRESSION>
 286                <CRLF>
 287                <COND (<OR <AND <NOT ,OUT-FAST>
 288                                <==? ,DEBSTATE ,NEXXT>>
 289                           <==? ,DEBSTATE ,PRED>>
 290                       <SETG DEBSTATE <READER T>>)>
 291                <SETG LO <SET LO .EXPRESSION>>)>>
 292
 293 <DEFINE READER (ON?)         ;"On? is bound to INFULL?, return from printer
 294                                telling if a new value must be read or if
 295                                state is still the same"
 296   #DECL ((ON?) <OR FALSE 'T>)
 297   <COND (.ON?
 298          <COND (<L=? ,REPEAT-COUNT 0> <READ-INPUT>)> ;"Checks global repeat
 299                                                        count and reads if 0"
 300          <SETG REPEAT-COUNT <- ,REPEAT-COUNT 1>>     ;"Decrement repeat count"
 301          <COND (<==? ,DEBSTATE ,OPHF> ,OPHF)    ;"If off, stay that way"
 302                (<==? ,LAST-CHAR ,NEXXT-CHAR> ,NEXXT)   ;"Dispatch to return "
 303                (<==? ,LAST-CHAR ,BODY-CHAR> ,BODY)     ;"proper state"
 304                (<==? ,LAST-CHAR ,FAST-CHAR> ,FAST)
 305                (<==? ,LAST-CHAR ,WEER-CHAR> ,WEER)
 306                (<==? ,LAST-CHAR ,PRED-CHAR> ,PRED)
 307                (<==? ,LAST-CHAR ,FLUSH-CHAR> ,FLUSH-STATE)>)
 308         (ELSE ,DEBSTATE)>> ;"If reader wasn't on return previous state"
 309
 310 <SETG BUFFER <ISTRING 100>>
 311
 312 <DEFINE READ-INPUT ("AUX" (BUFFER ,BUFFER) (OUTCHAN:CHANNEL ,DEBUG-CHANNEL))
 313         #DECL ((BUFFER) STRING)
 314         <PROG (CT (TOT 0) NB PARSE-LIST FOO)
 315               #DECL ((CT TOT) FIX (NB) STRING (PARSE-LIST) LIST)
 316               <SET CT <READSTRING .BUFFER ,INCHAN ,CHAR-LIST 0 .TOT>>
 317               <COND (<AND <==? .CT <LENGTH .BUFFER>>
 318                           <NOT <MEMQ <NTH .BUFFER <LENGTH .BUFFER>>
 319                                      ,CHAR-LIST>>>
 320                      <SET TOT <+ .TOT .CT>>
 321                      <SET NB <ISTRING <+ <LENGTH .BUFFER> 100>>>
 322                      <SETG BUFFER .NB>
 323                      <SUBSTRUC .BUFFER 0 <LENGTH .BUFFER> .NB>
 324                      <SET BUFFER .NB>
 325                      <AGAIN>)>
 326               <SET TOT 0>
 327               <SETG LAST-CHAR <NTH .BUFFER .CT>>
 328               <COND (<G? .CT 1>
 329                      <SET FOO <LPARSE <SUBSTRUC .BUFFER 0 <- .CT 1>
 330                                                 <REST .BUFFER <- <LENGTH .BUFFER>
 331                                                                  .CT -1>>>>>)
 332                     (<SET FOO ()>)>
 333               <COND (<NOT <TYPE? .FOO LIST>>
 334                      <SET TOT .CT>
 335                      <AGAIN>)>
 336               <SET PARSE-LIST .FOO>
 337               <COND (<==? ,LAST-CHAR <ASCII 27>>
 338                      <CRLF>
 339                      <MAPF <>
 340                            <FUNCTION (X)
 341                                 <PRIN1 <SET LAST-OUT <EVAL .X>>>
 342                                 <CRLF>>
 343                            .PARSE-LIST>
 344                      <AGAIN>)
 345                     (T
 346                      <CHANNEL-OP .OUTCHAN HOR-POS-CURSOR
 347                                  <- <CHANNEL-OP .OUTCHAN PAGE-X> 2>>
 348                      <CHANNEL-OP .OUTCHAN CLEAR-EOL>
 349                      <COND
 350                       (<EMPTY? .PARSE-LIST>
 351                        <SETG REPEAT-COUNT 1>
 352                        <RETURN FOO>)
 353                       (<AND <LENGTH? .PARSE-LIST 1>
 354                             <TYPE? <1 .PARSE-LIST> FIX>>
 355                        <SETG REPEAT-COUNT <1 .PARSE-LIST>>
 356                        <RETURN FOO>)
 357                       (<==? ,LAST-CHAR ,PRED-CHAR>
 358                        <COND (<LENGTH? .PARSE-LIST 1>
 359                               <SETG PREDICATE <1 .PARSE-LIST>>
 360                               <SETG REPEAT-COUNT 1>
 361                               <RETURN FOO>)
 362                              (<AND <LENGTH? .PARSE-LIST 2>
 363                                    <TYPE? <1 .PARSE-LIST> FIX>>
 364                               <SETG REPEAT-COUNT <1 .PARSE-LIST>>
 365                               <SETG PREDICATE <2 .PARSE-LIST>>
 366                               <RETURN FOO>)
 367                              (ELSE
 368                               <PRINC "Too many arguments: ">
 369                               <PRIN1 .PARSE-LIST>
 370                               <PRINC  " try again">
 371                               <CRLF>
 372                               <AGAIN>)>)
 373                       (ELSE <PRINC "Unknown command: ">
 374                        <PRINC ,LAST-CHAR>
 375                        <PRINC " try again">
 376                        <CRLF>
 377                        <AGAIN>)>)>>>
 378
 379 ;"Just a kluge procedure which should be replaced"
 380
 381 <DEFINE FRAME-COUNT (FRM)     ;"Counts eval frames until listen"
 382         #DECL ((FRM) FRAME (VALUE) FIX)
 383         <REPEAT ((I 0))
 384                 #DECL ((VALUE I) FIX)
 385                 <COND (<==? <FUNCT .FRM> LISTEN>
 386                        <RETURN .I>)
 387                       (<==? <FUNCT .FRM> EVAL>
 388                        <SET I <+ .I 1>>)>
 389                 <SET FRM <FRAME .FRM>>>>
 390
 391
 392 ;"== INITIALIZATION =========================================================="
 393
 394 <SETG INDENT-INC 2>
 395 <SETG INDENT-MOD 10>
 396 <SETG INDENT-DIF 20>
 397 <SETG SELF-FAST T>
 398 <SETG FORM-FAST T>
 399 <SETG OUT-FAST T>
 400 <SETG OUT-UNIQUE T>
 401
 402 <DEFINE INITIALIZE ()
 403         <SETG DEB-LEVEL 0>
 404         <SETG INFO '[0 '()]>
 405         <SETG LO LO>
 406         <SETG DEB-OUT DEB-OUT>
 407         <SETG DEB-IN DEB-IN>
 408         <SETG DEBSTATE 0>
 409         <SETG PREDICATE T>
 410         <SETG MACRO-FLAG <>>
 411         <SETG MACRO-LEVEL -1>
 412         <SETG LAST-CHAR !\ >
 413         <SETG REPEAT-COUNT 0>
 414         <SETG INFULL? T>>
 415
 416 <ENDPACKAGE>