1 /* ***********************************************************
   2    *                                                         *
   3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
   4    *                                                         *
   5    * Copyright (c) 1972 by Massachusetts Institute of        *
   6    * Technology and Honeywell Information Systems, Inc.      *
   7    *                                                         *
   8    *********************************************************** */
   9 
  10 
  11 db_regs:  procedure;
  12 
  13 
  14 
  15 /*        This procedure is used to print, get, or assign the values of the  debug  or  user
  16 *         defined data registers.  There is an entry provided for each of these three
  17 *         functions.   The  debug data registers  are really data fields in the machine
  18 *         conditions and are referenced via pre-defined names.
  19 *
  20 *         Rewritten  Nov 72  for the  6180  by  Bill Silver.
  21 */
  22 
  23 
  24 
  25 /*                  PARAMETER  DATA               */
  26 
  27 dcl       db_mc_ptr ptr,                /* Pointer to the current machine conditions.  All debug keeps
  28                                         *  is a pointer to the machine conditions which are in the stack.
  29                                         *  If this pointer is null then we don't have any machine
  30                                         *  registers to play with.  Note, the user defined registers
  31                                         *  are always available.      */
  32 
  33           name      char(4) aligned,    /* The name of the data item that is to be processed.  It is
  34                                         *  either a predefined debug data name or the name of a
  35                                         *  user defined register.     */
  36 
  37           print_mode          fixed bin,          /* 0 => BRIEF,  1 => LONG.  */
  38 
  39           value     bit(72) aligned;    /* Used to assign or get the value of one debug data item.
  40                                         *  Its contents are always right justified.       */
  41 
  42 
  43 
  44 
  45 
  46 /*                  AUTOMATIC  DATA               */
  47 
  48 
  49 /*        These  data items are used as work variables.  */
  50 
  51 dcl       block_ptr           ptr,      /* Pointer to a block of 8 words to be printed. */
  52 
  53 
  54           work_ptr            ptr;      /* Just a temporary pointer. */
  55 
  56 dcl       indp                ptr;      /* pointer to indicator reg. in scu */
  57 
  58 dcl       delim               char(2);  /* comma or blank for indicator list */
  59 
  60 dcl       namex     fixed bin,          /* The index of the db_data$names table. */
  61 
  62           userx     fixed bin,          /* The index of both the user_reg_names and
  63                                         *  user_reg_values  table. */
  64 
  65           i         fixed bin;          /* Just a work varaible. */
  66 
  67 dcl       len       fixed bin;          /* Another work variable. */
  68 
  69 
  70 /*        This variable is used to obtain a printable string of information about
  71 *         an instruction from the  print_text_$format procedure.
  72 */
  73 
  74 dcl       source_string       char (72) varying;
  75 
  76 
  77 
  78 
  79 /*        These words are used to print data items in octal via calls to  "ioa_".   They
  80 *         are needed to correctly print, for example, a 3 octal digit number since the
  81 *         number must be right justified in a 36 bit word and all but the 3 digits to be
  82 *         printed must be zero.
  83 */
  84 
  85 dcl       ( print_word1, print_word2, print_word3, print_word4 )
  86           bit(36)   init( "0"b );
  87 
  88 
  89 
  90 
  91 /*        This word is used in printing out the value of the eaq in floating format */
  92 
  93 dcl       float_val float bin(63);
  94 
  95 
  96 dcl       print_request bit (1) init ("0"b);      /* ON if entry by db_regs$print  */
  97 
  98 
  99 
 100 
 101 /*                  BASED  DECLARATIONS           */
 102 
 103 
 104 /*        Used to overlay floating value for eaq output */
 105 
 106 dcl       1 float_overlay     aligned based(addr(float_val)),
 107           2 exponent          unal bit(8),
 108           2 a_part            unal bit(36),
 109           2 q_part            unal bit(27);
 110 
 111 
 112 /*        Used to print out a block of  8  words.  */
 113 
 114 dcl       block (0:7)  bit(36)  based;
 115 dcl       eight_words bit(288) based aligned;
 116 
 117 
 118 /*        Used to reference a pointer as a bit string.  */
 119 
 120 dcl       ptr_bit_string      bit(72)   based;
 121 
 122 dcl       based_ptr           ptr   based;
 123 
 124 dcl       ind_bits            bit(14) based(indp);          /* indicators */
 125 
 126 
 127 
 128 /*                  INTERNAL  STATIC  DATA            */
 129 
 130 
 131 
 132 /*        The following two tables are used to convert an index of a debug data name into
 133 *         an index of a label constant array.  Except for the first and the last entries
 134 *         all of the entries of these two tables correspond to a debug data name as defined
 135 *         in the  db_data$names array.  The first entry (-1) is used when there is no room
 136 *         left for another user register.  The last entry is used for  user defined registers.
 137 *         The value of each entry is an index into the label array which corresponds to each.
 138 *         of these tables.  Note, the  get_ass_label_table  is used for both the
 139 *         get_label array  and the  assign_label array.   The entries in the label arrays
 140 *         are used to transfer the routine which can process this type of data.
 141 */
 142 
 143 
 144 
 145 dcl       print_label_table ( -1:33 )   fixed bin   internal  static
 146 
 147 /*                                DATA NAME       PRINT ROUTINE       */
 148 
 149           init (        0,    /*                  return              */
 150                     (8) 6,    /* pointer regs     print_pr            */
 151                     (8) 7,    /* index regs       print_xreg          */
 152                         9,    /*   aq             print_aq            */
 153                         1,    /*   all            print_all           */
 154                         2,    /*   prs            print_prs           */
 155                         3,    /*   regs           print_regs          */
 156                         4,    /*   scu            print_scu           */
 157                         5,    /*   user           print_user_regs     */
 158                        10,    /*   a              print_a             */
 159                        11,    /*   q              print_q             */
 160                        12,    /*   exp            print_exp           */
 161                        13,    /*   tr             print_tr            */
 162                        14,    /*   ralr           print_ralr          */
 163                        15,    /*   ppr            print_ppr           */
 164                        16,    /*   tpr            print_tpr           */
 165                        17,    /*   even           print_even          */
 166                        18,    /*   odd            print_odd           */
 167                        19,    /*   ind            print_indicators    */
 168                        20,    /*   eaq            print_floating_eaq  */
 169                         8);   /*                  print_user_reg      */
 170 
 171 
 172 
 173 dcl       get_ass_label_table ( -1:33 ) fixed bin   internal  static
 174 
 175 /*                                DATA NAME       GET/ASSIGN ROUTINE  */
 176 
 177           init (        0,    /*                  return              */
 178                     (8) 2,    /* pointer regs     get/assign_pr       */
 179                     (8) 3,    /* index regs       get/assign_xreg     */
 180                         5,    /*   aq             get/assign_aq       */
 181                         1,    /*   all            get/assign_illegal  */
 182                         1,    /*   prs            get/assign_illegal  */
 183                         1,    /*   regs           get/assign_illegal  */
 184                         1,    /*   scu            get/assign_illegal  */
 185                         1,    /*   user           get/assign_illegal  */
 186                         6,    /*   a              get/assign_a        */
 187                         7,    /*   q              get/assign_q        */
 188                         8,    /*   exp            get/assign_exp      */
 189                         9,    /*   tr             get/assign_tr       */
 190                        10,    /*   ralr           get/assign_ralr     */
 191                        11,    /*   ppr            get/assign_ppr      */
 192                        12,    /*   tpr            get/assign_tpr      */
 193                        13,    /*   even           get/assign_even     */
 194                        14,    /*   odd            get/assign_odd      */
 195                         1,    /*   ind            get/assign_illegal  */
 196                         1,    /*   eaq            get/assign_illegal  */
 197                         4);   /*                  get/assign_user_reg */
 198 
 199 
 200 /*        The following table contains the names to be associated with
 201 *         each bit of the Indicators register.
 202 */
 203 
 204 dcl       ind_names (14) char(4)        int static initial
 205           ("zero",
 206            "neg ",
 207            "cary",
 208            "ovfl",
 209            "eovf",
 210            "eufl",
 211            "oflm",
 212            "tro ",
 213            "par ",
 214            "parm",
 215            "^bar",
 216            "tru ",
 217            "mif ",
 218            "abs ");
 219 
 220 
 221 
 222 
 223 /*        These tables contain the user defined registers.  The maximum number that may
 224 *         be defined is  16.   The corresponding entries of the two tables define the
 225 *         name and the value of each register.  Note, these registers are defied as
 226 *         INTERNAL STATIC and thus will remain unchanged for recursive calls to  debug.
 227 *         This is not true for the debug machine condition data.
 228 */
 229 
 230 /*        These variables contain the number of user defined registers which have actually
 231 *         been defined  and the  maximum number which may be defined.
 232 */
 233 
 234 dcl      (num_user_regs       fixed bin    init(0),
 235 
 236           max_num_user_regs   fixed bin    init(16) )    internal static;
 237 
 238 
 239 dcl       user_reg_names(16)  char(4)   internal  static;
 240 
 241 dcl       user_reg_values(16) bit(36)   internal static;
 242 
 243 
 244 
 245 
 246 
 247 /*                  EXTERNAL  and  BUILTIN  DATA            */
 248 
 249 
 250 /*        These are the external procedures called by  db_regs.  */
 251 
 252 %include db_ext_stat_;
 253 
 254 dcl       print_text_$format  ext    entry        ( ptr, char(*) var ),
 255 
 256           ioa_$ioa_stream     ext    entry        options(variable);
 257 
 258 dcl       ioa_$rsnnl          ext    entry        options(variable);
 259 
 260 
 261 
 262 dcl       ( addr, substr )    builtin;
 263 /*^L*/
 264 % include db_data_map;
 265 /*^L*/
 266 % include its;
 267 % include mc;
 268 /*^L*/
 269 
 270 
 271 print:    entry  ( db_mc_ptr, name, print_mode );
 272 
 273           print_request = "1"b;                   /* Set so we won't create if not found */
 274 
 275           call      get_namex;                    /* Get the index of this name. */
 276 
 277 
 278 /*        This index is used to reference the label table which then gives us the index
 279 *         of the label constant that we want to  goto.
 280 */
 281 
 282           goto      print_label( print_label_table(namex) );
 283 
 284 
 285 
 286 
 287 
 288 
 289 get:      entry  ( db_mc_ptr, name, value, print_mode );
 290 
 291 
 292           call      get_namex;
 293 
 294 
 295           value  =  "0"b;               /* Initially set the return value to zero.  */
 296 
 297 
 298           goto      get_label( get_ass_label_table(namex) );
 299 
 300 
 301 
 302 
 303 
 304 
 305 assign:   entry  ( db_mc_ptr, name, value, print_mode );
 306 
 307 
 308           call      get_namex;
 309 
 310 
 311           print_word1  =  substr( value, 1,36);   /* Break up the input value into two words */
 312           print_word2  =  substr( value,37,36);   /* so it can be more easily printed
 313                                                   *  via  ioa_.  */
 314 
 315 
 316           goto      assign_label( get_ass_label_table(namex) );
 317 
 318 
 319 
 320 
 321 
 322 /*        We come here if  "namex"  =  -1  which implies that there was no room for another
 323 *         user defined register.  We will simply return.
 324 */
 325 
 326 print_label(0):
 327 get_label(0):
 328 assign_label(0):
 329 
 330           return;
 331 
 332 
 333 
 334 
 335 /*        This label is called from  get_namex  when the pointer to the machine conditions is
 336 *         null.  Since there is no register data to work with we will just return.
 337 */
 338 
 339 no_mc_data:
 340 
 341           if        print_mode  =  0                        /* BRIEF  or  LONG  */
 342 
 343                     then      call    ioa_$ioa_stream (debug_output, "No  mc  data.");
 344 
 345 
 346                     else  do;                               /* LONG. */
 347                     call    ioa_$ioa_stream (debug_output, "No fault frame found in stack trace.");
 348                     end;
 349 
 350 
 351           return;
 352 /*^L*/
 353 get_namex:          procedure;
 354 
 355 
 356 /*        This procedure is called to set  "namex"  to the number which corresponds to the data
 357 *         name passed to  db_regs  in  "name".   If it is a standard pre-defined debug data
 358 *         name then  "namex"  will be simply the index of the   db_data$names array entry
 359 *         which contains this name.  Otherwise it will be a user defined register name and "namex"
 360 *         will be equal to a number one greater than the highest valid index to  db_data$names.
 361 *         The index of the user register is set in  "userx".   If there is no room to allocate
 362 *         a new user register then  "namex"  will be set to  -1.
 363 */
 364 
 365 
 366 
 367           mcp  =  db_mc_ptr;            /* Copy the parameter which points to the area where
 368                                         *  debug's  copy of the machine conditions are saved.  */
 369 
 370 
 371 /*        See if this name is one of the standard debug data names.  If it is then  "namex"
 372 *         is equal to the index of the db_data$names entry which contains this name.
 373 *         If it is one of the standard register names then we will check the pointer to the
 374 *         machine conditions that we were passed.  If it is  null  then we can't do anything
 375 *         with this register since as far as we are conserned it doesn't exist.
 376 */
 377 
 378           do    namex  =  0  to  db_data$n_regs;
 379 
 380           if    name  =  db_data$names(namex)               /* Is it one of the standard machine
 381                                                             *  condition type register names? */
 382 
 383                     then    if    db_mc_ptr  =  null()      /* YES it is - do we have a pointer
 384                                                             *  to it?  */
 385 
 386                               then  goto  no_mc_data;       /* NO. */
 387 
 388                               else  do;                     /* YES, return with namex. */
 389                               scup  =  addr( mcp -> mc.scu );
 390                               return;
 391                               end;
 392 
 393           end;
 394 
 395 
 396 /*        This name is not one of the standard names.  It must be the name of a user defined
 397 *         register.  "namex"  is set correctly.  It came out of the  do loop  one greater
 398 *         than the number of standard names.  We will now see if this user name is allready
 399 *         defined.  If it is we will just return with  "userx"  set correctly.
 400 */
 401 
 402           do    userx  =  1  to  num_user_regs;
 403 
 404           if    name   =  user_reg_names(userx)    then  return;
 405 
 406           end;
 407 
 408 
 409 /*        This is a new user register name.  Do we have another slot in the user register
 410 *         tables for it?  If not we will tell the user and  "namex"  will be set to -1.
 411 *         The register will not be created for a print request.
 412 */
 413 
 414 
 415           if print_request then do;
 416                call ioa_$ioa_stream (debug_output, "User register not defined.  ^a", name);
 417                namex = -1;
 418                return;
 419           end;
 420           if        userx  >  max_num_user_regs
 421 
 422                     then  do;
 423                     call  ioa_$ioa_stream (debug_output, "User register  ^a  not initialized - max number exceded",name);
 424                     namex  =  -1;
 425                     return;
 426                     end;
 427 
 428 
 429 /*        There is room for this new user register so lets initialize it.
 430 */
 431 
 432           num_user_regs  =  userx;                /* Reset the count of active user registers
 433                                                   *  to reflect this new register.  */
 434 
 435           user_reg_names(userx)   =  name;        /* Remember its name. */
 436 
 437           user_reg_values(userx)  =  "0"b;        /* Initialize its value to zero. */
 438 
 439 /*        If we are in LONG mode then we will tell the user that he has just created
 440 *         a new user register.  */
 441 
 442           if        print_mode  ^=  0
 443 
 444                     then    call    ioa_$ioa_stream (debug_output, "Creating new user register  ^a", name );
 445 
 446 
 447           end       get_namex;
 448 /*^L*/
 449 /*        These are the routines called via the  print_label  array.   Each little piece
 450 *         of code  PRINTS  some of the debug machine conditions data.
 451 */
 452 
 453 
 454 /*        Print all of the machine conditions data.  Also print the user defined
 455 *         registers.
 456 */
 457 
 458 print_label(1):                         /*        print_all           */
 459 
 460           if        print_mode  ^=  0
 461                     then    call    ioa_$ioa_stream (debug_output, "All  ""machine conditions""  data.");
 462 
 463           call      print_prs;
 464 
 465           call      print_regs;
 466 
 467           call      print_scu;
 468 
 469           if        print_mode  ^=  0
 470                     then    call  ioa_$ioa_stream (debug_output, "^/The  8  words after the  SCU  data");
 471           block_ptr  =  addr( mcp -> mc.mask );
 472           call      print_block;
 473 
 474           block_ptr  =  addr( mcp -> mc.eis_info );
 475           if block_ptr -> eight_words ^= "0"b then do;
 476                     if        print_mode  ^=  0
 477                     then    call  ioa_$ioa_stream (debug_output, "^/EIS  info");
 478                     call      print_block;
 479           end;
 480 
 481           call      print_user_regs;
 482 
 483           return;
 484 
 485 
 486 
 487 
 488 
 489 /*        Print  all  of the  pointer registers.  */
 490 
 491 print_label(2):
 492 
 493           call      print_prs;
 494           return;
 495 
 496 
 497 print_prs:          procedure;
 498 
 499           call      ioa_$ioa_stream (debug_output, "^/Pointer Registers");
 500 
 501           do    i  =  0  to  7;
 502           call      ioa_$ioa_stream (debug_output, "^a^-^p",db_data$names(i), mcp->mc.prs(i));
 503           end;
 504 
 505           end       print_prs;
 506 
 507 
 508 
 509 
 510 
 511 /*        Print all of the registers: index registers, A,Q,Exp,Timer Register and
 512 *         Ring Alarm Register.
 513 */
 514 
 515 print_label(3):
 516 
 517           call      print_regs;
 518           return;
 519 
 520 
 521 print_regs:         procedure;
 522 
 523           if        print_mode  ^=  0
 524 
 525                     then  do;
 526 
 527                     call  ioa_$ioa_stream (debug_output, "^/Index  and other  Registers");
 528 
 529                     do    i  =  0  to  7;
 530                     call      ioa_$ioa_stream (debug_output, "^a^-^.3b", db_data$names(i+8), mcp->mc.regs.x(i));
 531                     end;
 532                     end;
 533 
 534 
 535                     else  do;                     /* BRIEF  mode.  */
 536 
 537                     call    ioa_$ioa_stream (debug_output, "^-^.3b  ^.3b  ^.3b  ^.3b",
 538                               mc.regs.x(0), mc.regs.x(1), mc.regs.x(2), mc.regs.x(3));
 539                     call    ioa_$ioa_stream (debug_output, "^-^.3b  ^.3b  ^.3b  ^.3b",
 540                               mc.regs.x(4), mc.regs.x(5), mc.regs.x(6), mc.regs.x(7));
 541 
 542                     end;
 543           call      ioa_$ioa_stream (debug_output, "a^-^w^/q^-^w", mcp->mc.regs.a, mcp->mc.regs.q);
 544 
 545           call      print_exp;
 546           call      print_tr;
 547           call      print_ralr;
 548 
 549           end       print_regs;
 550 
 551 
 552 
 553 
 554 
 555 /*        Print the SCU data.  We will print out the  PPR, TPR and the EVEN and ODD
 556 *         instructions.  Then we will print out the  SCU  data as a block.
 557 */
 558 
 559 print_label(4):
 560 
 561           call      print_scu;
 562           return;
 563 
 564 
 565 print_scu:          procedure;
 566 
 567           if        print_mode  ^=  0
 568 
 569                     then  do;
 570                     call      ioa_$ioa_stream (debug_output, "^/SCU  data");
 571                     call      print_ppr;
 572                     call      print_tpr;
 573                     call      ioa_$ioa_stream (debug_output, "^/");
 574                     call      print_even;
 575                     call      print_odd;
 576                     call      print_ind;
 577                     call      ioa_$ioa_stream (debug_output, "The  SCU  data as a block");
 578                     end;
 579 
 580           block_ptr  =  scup;
 581           call      print_block;
 582 
 583           end       print_scu;
 584 
 585 
 586 
 587 
 588 
 589 /*        Print out all of the user defined registers.  */
 590 
 591 print_label(5):
 592 
 593           call      print_user_regs;
 594           return;
 595 
 596 
 597 print_user_regs:    procedure;
 598 
 599           if        num_user_regs  =  0
 600 
 601                     then  do;
 602                     if        print_mode  ^=  0
 603                               then    call  ioa_$ioa_stream (debug_output, "^/No user defined registers");
 604                     return;
 605                     end;
 606 
 607           if        print_mode  ^=  0
 608                     then    call  ioa_$ioa_stream (debug_output, "^/User defined registers");
 609 
 610           do    i  =  1  to  num_user_regs;
 611           call      ioa_$ioa_stream (debug_output, "^a^-^w", user_reg_names(i), user_reg_values(i));
 612           end;
 613 
 614           end       print_user_regs;
 615 
 616 
 617 
 618 
 619 
 620 /*        Print out  one  pointer register.  */
 621 
 622 print_label(6):                         /*        print_pr            */
 623 
 624           call      ioa_$ioa_stream (debug_output, "^a^-^p",db_data$names(namex), mcp->mc.prs(namex));
 625           return;
 626 
 627 
 628 
 629 
 630 
 631 /*        Print out  one  index register.  */
 632 
 633 print_label(7):                         /*        print_xreg          */
 634 
 635           call      ioa_$ioa_stream (debug_output, "^a^-^.3b", db_data$names(namex), mcp->mc.regs.x(namex-8) );
 636           return;
 637 
 638 
 639 
 640 
 641 
 642 /*        Print out  one  user defined register.  */
 643 
 644 print_label(8):                         /*        print_user_reg      */
 645 
 646           call      ioa_$ioa_stream (debug_output, "^a^-^w", user_reg_names(userx), user_reg_values(userx));
 647           return;
 648 
 649 
 650 
 651 
 652 
 653 /*        Print the  AQ  as a combined register  or  print the  A  or  the  Q.  */
 654 
 655 print_label(9):                         /*        print_aq            */
 656 
 657           call      ioa_$ioa_stream (debug_output, "aq^-^w ^w", mcp -> mc.regs.a, mcp -> mc.regs.q);
 658           return;
 659 
 660 
 661 print_label(10):                        /*        print_a             */
 662 
 663           call      ioa_$ioa_stream (debug_output, "a^-^w", mcp->mc.regs.a);
 664           return;
 665 
 666 
 667 
 668 print_label(11):                        /*        print_q             */
 669 
 670           call      ioa_$ioa_stream (debug_output, "q^-^w", mcp->mc.regs.q);
 671           return;
 672 
 673 
 674 
 675 
 676 
 677 /*        Print the  Exponent register.  */
 678 
 679 print_label(12):
 680 
 681           call      print_exp;
 682           return;
 683 
 684 print_exp:          procedure;
 685 
 686           call      ioa_$ioa_stream (debug_output, "exp^-^.3b", "0"b || mc.regs.e);
 687 
 688           end       print_exp;
 689 
 690 
 691 
 692 
 693 
 694 
 695 /*        Print the  Timer Register.  */
 696 
 697 print_label(13):
 698 
 699           call      print_tr;
 700           return;
 701 
 702 
 703 print_tr:           procedure;
 704 
 705           call      ioa_$ioa_stream (debug_output, "tr^-^.3b", mcp->mc.regs.t);
 706 
 707           end       print_tr;
 708 
 709 
 710 
 711 
 712 
 713 /*        Print the  Ring Alarm Register.  */
 714 
 715 print_label(14):
 716 
 717           call      print_ralr;
 718           return;
 719 
 720 
 721 print_ralr:         procedure;
 722 
 723           call      ioa_$ioa_stream (debug_output, "ralr^-^.3b", mc.regs.ralr);
 724 
 725           end       print_ralr;
 726 
 727 
 728 
 729 
 730 /*        Print the  PPR.  */
 731 
 732 print_label(15):
 733 
 734           call      print_ppr;
 735           return;
 736 
 737 
 738 print_ppr:          procedure;
 739 
 740           if        print_mode  ^=  0
 741                     then    call  ioa_$ioa_stream (debug_output, "^/ppr:^-prr  psr   p    ic");
 742 
 743           call      ioa_$ioa_stream (debug_output, "^- ^.3b  ^.3b  ^.1b  ^.3b", scu.ppr.prr,
 744                          scu.ppr.psr, scu.ppr.p, scu.ilc);
 745 
 746           end       print_ppr;
 747 
 748 
 749 
 750 
 751 
 752 /*        Print  the  TPR.  */
 753 
 754 print_label(16):
 755 
 756           call      print_tpr;
 757           return;
 758 
 759 
 760 print_tpr:          procedure;
 761 
 762           if        print_mode  ^=  0
 763                     then    call  ioa_$ioa_stream (debug_output, "^/tpr:^-trr  tsr   tbr   ca");
 764 
 765           call      ioa_$ioa_stream (debug_output, "^- ^.3b  ^.3b  ^.3b  ^.3b",  scu.tpr.trr,
 766                          scu.tpr.tsr, scu.tpr_tbr, scu.ca);
 767 
 768           end       print_tpr;
 769 
 770 
 771 
 772 
 773 
 774 /*        Print out the  EVEN  or  the  ODD  instruction.  */
 775 
 776 print_label(17):
 777 
 778           call      print_even;
 779           return;
 780 
 781 print_even:         procedure;
 782 
 783           call      print_text_$format( addr( scup -> scu.even_inst), source_string);
 784 
 785           call      ioa_$ioa_stream (debug_output, "even^-^a", source_string );
 786 
 787           end       print_even;
 788 
 789 
 790 
 791 print_label(18):
 792 
 793           call      print_odd;
 794           return;
 795 
 796 
 797 print_odd:          procedure;
 798 
 799           call      print_text_$format( addr( scup -> scu.odd_inst), source_string);
 800 
 801           call      ioa_$ioa_stream (debug_output, "odd^-^a", source_string);
 802 
 803           end       print_odd;
 804 
 805 
 806 
 807 print_label(19):
 808 
 809           call      print_ind;
 810           return;
 811 
 812 /*        Print out eaq in exponential format */
 813 
 814 print_label(20):
 815 
 816           float_overlay.exponent = mc.e;
 817           float_overlay.a_part = mc.a;
 818           float_overlay.q_part = mc.q;
 819 
 820           call ioa_$ioa_stream (debug_output, "eaq^-^e",float_val);
 821           return;
 822 
 823 
 824 print_ind:          procedure;
 825 
 826           indp = addr(scup -> scu.ir);  /* point to indicator bits */
 827 
 828           delim = "";                             /* initialize */
 829           source_string = "";
 830 
 831           if indp -> ind_bits = (14)"0"b
 832           then source_string = "none";            /* no point if they're all off */
 833 
 834           else
 835           do i = 1 to 14;
 836                if substr (indp -> ind_bits, i, 1)
 837                then do;
 838 
 839                     call ioa_$rsnnl ("^a^a^a", source_string, len, source_string,
 840                               delim, ind_names(i) );
 841                     delim = ", ";                 /* in case it was first one */
 842                end;
 843           end;
 844 
 845           call ioa_$ioa_stream (debug_output, "indicators: ^a", source_string);
 846 
 847           end       print_ind;
 848 
 849 
 850 
 851 
 852 
 853 
 854 
 855 
 856 /*        This procedure prints out a block of  8  octal words.  It must be passed
 857 *         a pointer to the block of wors to be printed.
 858 */
 859 
 860 print_block:        procedure;
 861 
 862           call      ioa_$ioa_stream (debug_output, "^/^-^w  ^w  ^w  ^w",
 863                     block_ptr->block(0), block_ptr->block(1), block_ptr->block(2), block_ptr->block(3));
 864 
 865           call      ioa_$ioa_stream (debug_output, "^-^w  ^w  ^w  ^w",
 866                     block_ptr->block(4), block_ptr->block(5), block_ptr->block(6), block_ptr->block(7));
 867 
 868           end       print_block;
 869 /*^L*/
 870 /*        These are the routines called via the  get_label  array.  note, the value returned
 871 *         will always be  RIGHT  justified with leading zeros.
 872 */
 873 
 874 
 875 
 876 
 877 /*        The names used to print multiple data items cannot be used to retrieve data.
 878 *         A zero will be returned.
 879 */
 880 
 881 get_label(1):                           /*        get_illegal         */
 882 
 883           return;                       /* value is allready zero.  */
 884 
 885 
 886 
 887 
 888 get_label(2):                           /*        get_pr              */
 889 
 890           value  =  addr( mcp -> mc.prs(namex)) -> ptr_bit_string;
 891           return;
 892 
 893 
 894 
 895 
 896 get_label(3):                           /*        get_xreg            */
 897 
 898           substr( value, 55, 18 )  =  mcp -> mc.regs.x(namex-8);
 899           return;
 900 
 901 
 902 
 903 get_label(4):                           /*        get_user_reg        */
 904 
 905           substr( value, 37, 36 )  =  user_reg_values(userx);
 906           return;
 907 
 908 
 909 
 910 
 911 get_label(5):                           /*        get_aq              */
 912 
 913           substr( value, 1, 36 )   =  mcp -> mc.regs.a;
 914           substr( value, 37, 36 )  =  mcp -> mc.regs.q;
 915           return;
 916 
 917 
 918 
 919 
 920 get_label(6):                           /*        get_a               */
 921 
 922           substr( value, 37, 36 )  =  mcp -> mc.regs.a;
 923           return;
 924 
 925 
 926 
 927 
 928 get_label(7):                           /*        get_q               */
 929 
 930           substr( value, 37, 36 )  =  mcp -> regs.q;
 931           return;
 932 
 933 
 934 
 935 
 936 get_label(8):                           /*        get_exp             */
 937 
 938           substr( value, 65, 8 )  =  mcp -> mc.regs.e;
 939           return;
 940 
 941 
 942 
 943 get_label(9):                           /*        get_tr              */
 944 
 945           substr( value, 46, 27 )  =  mcp -> mc.regs.t;
 946           return;
 947 
 948 
 949 
 950 
 951 get_label(10):                          /*        get_ralr            */
 952 
 953           substr( value, 70, 3 )  =  mcp -> mc.regs.ralr;
 954           return;
 955 
 956 
 957 
 958 
 959 get_label(11):                          /*        get_ppr             */
 960 
 961           work_ptr  =  addr( value );
 962           work_ptr -> its.segno  =  scup -> scu.ppr.psr;
 963           work_ptr -> its.ringno =  scup -> scu.ppr.prr;
 964           substr( value, 3, 1 )  =  scup -> scu.ppr.p;      /* Normal its pointers have no p bit. */
 965           work_ptr -> its.offset =  scup -> scu.ilc;
 966           return;
 967 
 968 
 969 
 970 
 971 get_label(12):                          /*        get_tpr             */
 972 
 973           work_ptr  =  addr( value );
 974           work_ptr -> its.segno  =  scup -> scu.tpr.tsr;
 975           work_ptr -> its.ringno =  scup -> scu.tpr.trr;
 976           work_ptr -> its.bit_offset  =  scup -> scu.tpr_tbr;
 977           work_ptr -> its.offset =  scup -> scu.ca;
 978           return;
 979 
 980 
 981 
 982 
 983 get_label(13):                          /*        get_even            */
 984 
 985           substr( value, 37, 36 )  =  scup -> scu.even_inst;
 986           return;
 987 
 988 
 989 
 990 
 991 get_label(14):                          /*        get_odd             */
 992 
 993           substr( value, 37, 36 )  =  scup -> scu.odd_inst;
 994           return;
 995 /*^L*/
 996 /*        These routines are called via the assign_label array.  note, the value to be
 997 *         assigned is always assumed to be a  RIGHT  justified  BIT  string.
 998 *         Note, if the print mode is  LONG  we will print out the value of the data item
 999 *         before it is changed and after the assignment.  If we are in  BRIEF  mode we will
1000 *         just make the assignment without telling the user anything.
1001 */
1002 
1003 
1004 
1005 /*        The name used to print multiple data items cannot be used to assign values.
1006 *         Each assignment must be made to a specific register.
1007 */
1008 
1009 assign_label(1):                        /*        assign_illegal      */
1010 
1011           call      ioa_$ioa_stream (debug_output, "The  debug  name  ^a  cannot be used in an assignment command.",
1012                           db_data$names(namex));
1013           return;
1014 
1015 assign_label(2):                        /*        assign_pr           */
1016 
1017           if        print_mode  =  1
1018 
1019                     then      call      ioa_$ioa_stream (debug_output, "^a  changed from  ^p  to  ^p",
1020                                         db_data$names(namex), mcp -> mc.prs(namex), addr(value) -> based_ptr);
1021 
1022           addr( mcp -> mc.prs(namex)) -> ptr_bit_string  =  value;
1023 
1024           return;
1025 
1026 assign_label(3):                        /*        assign_xreg         */
1027 
1028           if        print_mode  =  1
1029                     then  do;
1030                     call      ioa_$ioa_stream (debug_output, "^a  changed from  ^.3b  to  ^.3b",
1031                               db_data$names(namex), mc.regs.x(namex-8), substr(print_word2, 19, 18));
1032                     end;
1033 
1034           mcp -> mc.regs.x(namex-8)  =  substr( print_word2, 19, 18 );
1035 
1036           return;
1037 
1038 assign_label(4):                        /*        assign_user_reg     */
1039 
1040           if        print_mode  =  1
1041 
1042                     then      call      ioa_$ioa_stream (debug_output, "^a  changed from  ^w  to  ^w",
1043                                         user_reg_names(userx), user_reg_values(userx), print_word2);
1044 
1045           user_reg_values(userx)  =  print_word2;
1046 
1047           return;
1048 
1049 assign_label(5):                        /*        assign_aq           */
1050 
1051           if        print_mode  =  1
1052 
1053                     then      call      ioa_$ioa_stream (debug_output, "aq    changed from  ^w^w  to  ^w^w",
1054                                         mcp -> mc.regs.a, mcp -> mc.regs.q, print_word1, print_word2);
1055 
1056           mcp -> mc.regs.a  =  print_word1;
1057           mcp -> mc.regs.q  =  print_word2;
1058 
1059           return;
1060 
1061 assign_label(6):                        /*        assign_a            */
1062 
1063           if        print_mode  =  1
1064 
1065                     then      call      ioa_$ioa_stream (debug_output, "a     changed from  ^w  to  ^w",
1066                                         mcp -> mc.regs.a, print_word2);
1067 
1068           mcp -> mc.regs.a  =  print_word2;
1069 
1070           return;
1071 
1072 assign_label(7):                        /*        assign_q            */
1073 
1074           if print_mode = 1 then
1075           call      ioa_$ioa_stream (debug_output, "q     changed from  ^w  to  ^w",
1076                                         mcp -> mc.regs.q, print_word2);
1077 
1078           mcp -> mc.regs.q  =  print_word2;
1079 
1080           return;
1081 
1082 assign_label(8):                        /*        assign_exp          */
1083 
1084           if        print_mode  =  1
1085                     then  do;
1086                     call      ioa_$ioa_stream (debug_output, "exp   changed from  ^.3b  to  ^.3b",
1087                                    "0"b || mc.regs.e, "0"b || substr(print_word2, 29, 8));
1088                     end;
1089 
1090           mcp -> mc.regs.e  =  substr( print_word2, 29, 8 );
1091 
1092           return;
1093 
1094 assign_label(9):                        /*        assign_tr           */
1095 
1096           if        print_mode  =  1
1097                     then  do;
1098                     call      ioa_$ioa_stream (debug_output, "tr    changed from  ^.3b  to  ^.3b",
1099                                    mc.regs.t, substr(print_word2, 10, 27));
1100                     end;
1101 
1102           mcp -> mc.regs.t  =  substr( print_word2, 10, 27 );
1103 
1104           return;
1105 
1106 assign_label(10):                       /*        assign_ralr         */
1107 
1108           if        print_mode  =  1
1109                     then  do;
1110                     call      ioa_$ioa_stream (debug_output, "ralr  changed from  ^.3b  to  ^.3b",
1111                                    mc.regs.ralr, substr(print_word2, 34, 3));
1112                     end;
1113 
1114           mcp -> mc.regs.ralr  =  substr( print_word2, 34, 3 );
1115 
1116           return;
1117 
1118 assign_label(11):                       /*        assign_ppr          */
1119 
1120           work_ptr  =  addr( value );
1121 
1122           if        print_mode  =  1
1123 
1124                     then  do;
1125                     call      ioa_$ioa_stream (debug_output, "Old  ppr");
1126                     call      print_ppr;
1127                     end;
1128 
1129           scup -> scu.ppr.psr  =  work_ptr -> its.segno;
1130           scup -> scu.ppr.prr  =  work_ptr -> its.ringno;
1131           scup -> scu.ppr.p  =  substr( value, 3,1 );
1132           scup -> scu.ilc  =  work_ptr -> its.offset;
1133 
1134           if        print_mode  =  1
1135 
1136                     then  do;
1137                     call      ioa_$ioa_stream (debug_output, "New  ppr");
1138                     call      print_ppr;
1139                     end;
1140 
1141           return;
1142 
1143 assign_label(12):                       /*        assign_tpr          */
1144 
1145           work_ptr  =  addr( value );
1146 
1147           if        print_mode  =  1
1148 
1149                     then  do;
1150                     call      ioa_$ioa_stream (debug_output, "Old  tpr");
1151                     call      print_tpr;
1152                     end;
1153 
1154           scup -> scu.tpr.tsr  =  work_ptr -> its.segno;
1155           scup -> scu.tpr.trr  =  work_ptr -> its.ringno;
1156           scup -> scu.tpr_tbr  =  work_ptr -> its.bit_offset;
1157           scup -> scu.ca  =  work_ptr -> its.offset;
1158 
1159           if        print_mode  =  1
1160 
1161                     then  do;
1162                     call      ioa_$ioa_stream (debug_output, "New  tpr");
1163                     call      print_tpr;
1164                     end;
1165 
1166           return;
1167 
1168 assign_label(13):                       /*        assign_even         */
1169 
1170           if        print_mode  =  1
1171 
1172                     then  do;
1173                     call      print_text_$format( addr( scup -> scu.even_inst), source_string);
1174                     call      ioa_$ioa_stream (debug_output, "Old  even instruction:  ^a", source_string);
1175                     end;
1176 
1177           scup -> scu.even_inst  =  print_word2;
1178 
1179           if        print_mode  =  1
1180 
1181                     then  do;
1182                     call      print_text_$format( addr( scup -> scu.even_inst), source_string);
1183                     call      ioa_$ioa_stream (debug_output, "New  even instruction:  ^a", source_string);
1184                     end;
1185 
1186           return;
1187 
1188 assign_label(14):                       /*        assign_odd          */
1189 
1190           if        print_mode  =  1
1191 
1192                     then  do;
1193                     call      print_text_$format( addr( scup -> scu.odd_inst), source_string);
1194                     call      ioa_$ioa_stream (debug_output, "Old  odd instruction:  ^a", source_string);
1195                     end;
1196 
1197           scup -> scu.odd_inst  =  print_word2;
1198 
1199           if        print_mode  =  1
1200 
1201                     then  do;
1202                     call      print_text_$format( addr( scup -> scu.odd_inst), source_string);
1203                     call      ioa_$ioa_stream (debug_output, "New  odd instruction:  ^a", source_string);
1204                     end;
1205 
1206           return;
1207 
1208           end       db_regs;