home *** CD-ROM | disk | FTP | other *** search
/ ftp.cs.arizona.edu / ftp.cs.arizona.edu.tar / ftp.cs.arizona.edu / icon / historic / v941.tgz / icon.v941src.tar / icon.v941src / ipl / packs / itweak / itweak.icn < prev    next >
Text File  |  2000-07-29  |  26KB  |  831 lines
  1. ############################################################################
  2. #
  3. #    File:     itweak.icn
  4. #
  5. #    Subject:  Icon interactive debugging.
  6. #          Tweaks a ucode file ('.u1') to invoke a debugging procedure.
  7. #
  8. #    Author:   Hakan Soderstrom
  9. #
  10. #    Revision: $Revision: 2.21 $
  11. #
  12. ###########################################################################
  13. #
  14. # Copyright (c) 1994 Hakan Soderstrom and
  15. # Soderstrom Programvaruverkstad AB, Sweden
  16. # 
  17. # Permission to use, copy, modify, distribute, and sell this software
  18. # and its documentation for any purpose is hereby granted without fee,
  19. # provided that the above copyright notice and this permission notice
  20. # appear in all copies of the software and related documentation.
  21. # 
  22. # THE SOFTWARE IS PROVIDED "AS-IS" AND WITHOUT WARRANTY OF ANY KIND,
  23. # EXPRESS, IMPLIED OR OTHERWISE, INCLUDING WITHOUT LIMITATION, ANY
  24. # WARRANTY OF MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE.
  25. #
  26. # IN NO EVENT SHALL HAKAN SODERSTROM OR SODERSTROM PROGRAMVARUVERKSTAD
  27. # AB BE LIABLE FOR ANY SPECIAL, INCIDENTAL, INDIRECT OR CONSEQUENTIAL
  28. # DAMAGES OF ANY KIND, OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
  29. # OF USE, DATA OR PROFITS, WHETHER OR NOT ADVISED OF THE POSSIBILITY
  30. # OF DAMAGE, AND ON ANY THEORY OF LIABILITY, ARISING OUT OF OR IN
  31. # CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
  32. #
  33. ###########################################################################
  34.  
  35. #
  36. #-------- Record types --------
  37. #
  38.  
  39. record l_decl (d_type, d_serial, d_code, d_name, d_displ, ld_cserial, ld_dbg)
  40. # Holds a 'local' declaration.
  41. # 'd_type' must be the declaration type (integer), in this case,
  42. $define D_LOCAL        1
  43. # 'd_serial' must be the serial number of the declaration (integer).
  44. # 'd_code' must be the bitfield that further characterizes the declaration.
  45. # It is stored as the integer obtained by interpreting the octal coded
  46. # bitfield as a decimal number.
  47. # 'd_name' must be the source name of the declared entity.
  48. # 'd_displ' must be non-null to indicate that this declaration is to be
  49. # passed to the debug procedure.
  50. # 'ld_cserial' may be a constant serial number (integer), or null.
  51. # If integer then the name of this local exists as a constant in the current
  52. # procedure, which means we include it among the visible variables.
  53. # 'ld_dbg' is non-null if the declaration has been added by this program.
  54.  
  55. record c_decl (d_type, d_serial, d_code, d_name, d_displ)
  56. # Holds a constant declaration added by the program.
  57. # Like 'l_decl', except 'd_type' must be
  58. $define D_CONST        2
  59.  
  60. record fmap (fm_ucode, fm_source)
  61. # Holds the mapping between an ucode file name and a source file name.
  62. # 'fm_ucode' must be the root of an ucode file name (string).
  63. # I.e. the file name without the trailing '.u?'.
  64. # 'fm_source' must be the name of the source file from which the ucode
  65. # file originates (string).
  66.  
  67. global file_map
  68. # Set containing mapping between ucode and source files (set of record fmap).
  69.  
  70. global file_root, uin, uout, ulno
  71. # The current root file name (i.e. file name without '.u?').
  72. # The current ucode input file.
  73. # The current ucode output file.
  74. # The current line number in the current ucode input file.
  75.  
  76. global init_file
  77. # Output file name: init file.
  78.  
  79. global msgout
  80. # Message output file.
  81.  
  82. global proc_hil
  83. # Table containing the "high label" of each procedure in a ucode file.
  84. # Entry key is a procedure name (string).
  85. # Entry value is the numeric part of the highest existing label before
  86. # debugification (integer).
  87.  
  88. global white
  89. # This program's definition of white space.
  90.  
  91. #
  92. #-------- Constants --------
  93. #
  94.  
  95. # Version of this program, variable for holding it.
  96. $define PROGRAM_VERSION    "$Revision: 2.21 $"
  97. $define PROG_VERSION_VAR "__dbg_itweak_ver"
  98.  
  99. # DEBUGGING IDENTIFIERS.
  100. # List holding breakpoints for one source file; two parts.
  101. # The root file name should be spliced in between.
  102. $define DBG_BRKP1    "__dbg_file_"
  103. $define DBG_BRKP2    "_brkp"
  104. # Global variable holding source/ucode file map.
  105. # Note: any change affects 'dbg.icn' as well.
  106. $define DBG_FILE_MAP    "__dbg_file_map"
  107. # Procedure for initializing debugging globals.
  108. $define DBG_INIT    "__dbg_init"
  109. # Local variable: trapped line number.
  110. $define DBG_LINE    "__dbg_line"
  111. # List containing names of interesting local variables.
  112. $define DBG_NAME    "__dbg_name"
  113. # Procedure to call on break.
  114. $define DBG_PROC    "__dbg_proc"
  115. # Procedure deciding on break.
  116. $define DBG_TEST    "__dbg_test"
  117.  
  118. # Name of variable whose presence is taken as assurance that an ucode
  119. # file has been tweaked.
  120. $define DBG_SENTINEL    DBG_LINE
  121.  
  122. # Default file name for writing the debug initialization code.
  123. $define DBG_INIT_FILE    "dbg_init.icn"
  124.  
  125. # File name for the debugging run-time.
  126. $define DBG_RUN_TIME    "dbg_run.u1"
  127.  
  128. # Ucode 'codes' (bitfields) for local declarations.
  129. # The values are the octal coded bitfield interpreted as decimal.
  130. $define LD_GLOBAL    0
  131. $define LD_LOCAL    20
  132. $define LD_PARM        1000
  133. $define LD_STATIC    40
  134.  
  135. # Ucode 'codes' (bitfields) for constant declarations.
  136. $define CD_INT        2000
  137. $define CD_STRING    10000
  138.  
  139. # Various ucode op-codes.
  140. $define OP_CONST    "con"
  141. $define OP_DEND        "declend"
  142. $define OP_END        "end"
  143. $define OP_FILEN    "filen"
  144. $define OP_LABEL    "lab"
  145. $define OP_LINE        "line"
  146. $define OP_LOCAL    "local"
  147. $define OP_PROC        "proc"
  148.  
  149. # Op-codes in the '.u2' file.
  150. $define OP_VERSION    "version"
  151. $define OP_LINK        "link"
  152. $define OP_GLOBAL    "global"
  153.  
  154. # Icon versions for which the program has been tested.
  155. $define ICON_VER_LO    "U8.10.00"
  156. $define ICON_VER_HI    "U9.0.00"
  157.  
  158. # Prefix used for labels.
  159. $define ULAB_PREF    "L"
  160.  
  161. $define NALN        -1
  162. # Not A Line Number.
  163.  
  164. $define PROGNAME    "itweak"
  165. # The name by which the user knows this program.
  166.  
  167. $define U1    ".u1"
  168. $define U2    ".u2"
  169. # Standard ucode file name suffix.
  170.  
  171. $define U1TMP    ".uA"
  172. $define U2TMP    ".uB"
  173. # Suffix of temporary ucode file.
  174.  
  175. $define U1OLD    ".u1~"
  176. $define U2OLD    ".u2~"
  177. # Suffix of renamed, original ucode file.
  178.  
  179. #
  180. #-------- Main --------
  181. #
  182.  
  183. procedure main (argv)
  184. local file_names, iout, u2count
  185.     # Initialize globals.
  186.     file_map := set ()
  187.     msgout := &errout
  188.     white := '\t '
  189.     # Process command line options; leave a list of file names.
  190.     if argv[1] == "-o" then {
  191.         get (argv)
  192.         (init_file := get (argv)) |
  193.         confl ("'-o' requires a file name")
  194.         }
  195.     else
  196.         init_file := DBG_INIT_FILE
  197.     file_names := copy (argv)
  198.     # The number of tweaked '.u2' files.
  199.     u2count := 0
  200.     # Do two passes on each file.
  201.     every file_root := !file_names do {
  202.         # Allow for 'file.u1' and 'file.u'.
  203.         file_root := if file_root[-3:0] == ".u1" then
  204.             file_root[1:-3] else if file_root[-2:0] == ".u" then
  205.             file_root[1:-2]
  206.         # Pass 1.
  207.         (uin := open (file_root || U1, "r")) |
  208.         confl ("Cannot open '%1%2' for input.", file_root, U1)
  209.         uout := &null
  210.         if pass1 () then {
  211.             close (uin)
  212.             # Tweak at most one '.u2' file.
  213.             if u2count = 0 then {
  214.                 (uin := open (file_root || U2, "r")) |
  215.                 confl ("Cannot open '%1%2' for input.", file_root, U2)
  216.                 (uout := open (file_root || U2TMP, "w")) |
  217.                 confl ("Cannot open '%1%2' for output.", file_root,
  218.                     U2TMP)
  219.                 u2tweak ()
  220.                 close (uin)
  221.                 close (uout)
  222.                 u2count +:= 1
  223.                 # Make way for the following rename.
  224.                 remove (file_root || U2OLD)
  225.                 rename (file_root || U2, file_root || U2OLD) |
  226.                 confl ("Cannot rename '%1%2' to '%1%3'.", file_root,
  227.                     U2, U2OLD)
  228.                 rename (file_root || U2TMP, file_root || U2) |
  229.                 confl ("Cannot rename '%1%2' to '%1%3'.", file_root,
  230.                     U2TMP, U2)
  231.                 }
  232.             # Pass 2.
  233.             (uin := open (file_root || U1, "r")) |
  234.             confl ("Cannot open '%1%2' for input.", file_root, U1)
  235.             (uout := open (file_root || U1TMP, "w")) |
  236.             confl ("Cannot open '%1%2' for output.", file_root, U1TMP)
  237.             pass2 ()
  238.             close (uin)
  239.             close (uout)
  240.             # Make way for the following rename.
  241.             remove (file_root || U1OLD)
  242.             rename (file_root || U1, file_root || U1OLD) |
  243.             confl ("Cannot rename '%1%2' to '%1%3'.", file_root, U1, U1OLD)
  244.             rename (file_root || U1TMP, file_root || U1) |
  245.             confl ("Cannot rename '%1%2' to '%1%3'.", file_root, U1TMP, U1)
  246.             }
  247.         else {
  248.             close (uin)
  249.             note ("'%1%2' seems to be tweaked already; left untouched.",
  250.                 file_root, U1)
  251.             }
  252.         }
  253.     # Write initialization code.
  254.     (iout := open (init_file, "w")) |
  255.     confl ("Cannot open '%1' for output.", init_file)
  256.     cre_init (iout)
  257.     note ("Initialization code written to '%1'.", init_file)
  258. end
  259.  
  260. #
  261. #-------- Pass 1 procedures --------
  262. #
  263.  
  264. procedure pass1 ()
  265. # Performs a first pass over a ucode file, collecting label statistics.
  266. # RETURNS null normally.
  267. # FAILS if the first procedure has a local declaration containing the sentinel
  268. # variable.
  269. # This is taken to imply that the ucode file is already tweaked.
  270. # SIDE EFFECT: Updates glocal 'proc_hil' (max labels per proc).
  271. # Updates 'file_map' (source file name ~ ucode file name).
  272. local cur_high, cur_proc, labint, line, loc, op, proc_no
  273. static fn_instr, lc_decl
  274. initial {
  275.     fn_instr := [OP_FILEN, OP_LINE, OP_LABEL]
  276.     lc_decl := [OP_LOCAL, OP_CONST, OP_DEND]
  277.     }
  278.     proc_hil := table ()
  279.     loc := table ()
  280.     proc_no := 0
  281.     while op := p1_proclab () do if op[1] == "proc" then {
  282.         if \cur_proc then {
  283.             (/proc_hil[cur_proc] := cur_high) |
  284.             confl ("%1: occurs twice; confusing.", cur_proc)
  285.             }
  286.         cur_proc := op[2]
  287.         cur_high := -1
  288.  
  289.         # Special treatment of the first procedure in every file.
  290.         if (proc_no +:= 1) = 1 then {
  291.             # Borrow some pass 2 code to collect the local declarations.
  292.             while (op := p2_upto (lc_decl))[1] == OP_LOCAL do
  293.                 p2_getlocal (loc, op[2])
  294.             # Look for source file name.
  295.             repeat if (op := p2_upto (fn_instr))[1] == OP_FILEN then {
  296.                 insert (file_map, fmap (file_root, op[2]))
  297.                 break
  298.                 }
  299.             else if op[1] == OP_LABEL then
  300.                 cur_high <:= integer (op[2][2:0])
  301.             # Flush buffers.
  302.             p2_upto ()
  303.             # Fail if the sentinel is present.
  304.             if \loc[DBG_SENTINEL] then
  305.                 fail
  306.             }
  307.         }
  308.     else if op[1] == "lab" then {
  309.         # ASSUME the label consists of one character followed by an integer.
  310.         (labint := integer (op[2][2:0])) |
  311.         intern ("pass1: Problem parsing label %1.", image (op[2]))
  312.         cur_high <:= labint
  313.         }
  314.     if \cur_proc then {
  315.         (/proc_hil[cur_proc] := cur_high) |
  316.         confl ("%1: occurs twice; confusing.", cur_proc)
  317.         }
  318.     else
  319.         intern ("pass1: No proc found.")
  320.     return &null
  321. end
  322.  
  323. procedure p1_proclab ()
  324. # Returns the next ucode line containing a "proc" or "lab" instruction.
  325. # If a matching line is found, RETURNS a two-component list.
  326. # The first element contains the instruction found (string).
  327. # The second element contains the second word on the line.
  328. # FAILS on end-of-file.
  329. local line, opcode, tail
  330. static opchar
  331. initial opchar := &lcase
  332.     while line := read (uin) do line ? {
  333.         if (opcode := tab (many (opchar))) == ("proc" | "lab") then {
  334.             tab (many (white))
  335.             tail := tab (upto (white) | 0)
  336.             break
  337.             }
  338.         }
  339.     return [opcode, \tail]
  340. end
  341.  
  342. #
  343. #-------- Pass 2 procedures --------
  344. #
  345.  
  346. procedure pass2 ()
  347. # Performs a second pass over the ucode file, doing the actual tweaking.
  348. # Writes the new ucode to 'uout'.
  349. local counter, op
  350.     counter := 0
  351.     while op := p2_upto ([OP_PROC]) do
  352.         p2_proc (trim (op[2]), counter +:= 1)
  353. end
  354.  
  355. procedure p2_addbrkp (line, last_lab, dbg_brkp, dbg_label, dbg_line, dbg_test)
  356. # Adds code for breakpoint testing.
  357. # 'line' should be the line number associated with the current ucode 'line'
  358. # instruction.
  359. # 'ltab' must be a table containing declarations of the current procedure.
  360. # 'last_lab' must be the previous highest label serial (integer).
  361. # RETURNS the new highest label serial.
  362.     write (uout,
  363.         "\tmark\t", ULAB_PREF, last_lab +:= 1,
  364.         "\n\tpnull",
  365.         "\n\tvar\t", dbg_line,
  366.         "\n\tvar\t", dbg_test,
  367.         "\n\tvar\t", dbg_brkp,
  368.         "\n\tkeywd\tline\n\tinvoke\t2\n\tasgn\n\tgoto\t", dbg_label,
  369.         "\n\tunmark\nlab ", ULAB_PREF, last_lab)
  370.     return last_lab
  371. end
  372.  
  373. procedure p2_addcall (ltab, dbg_label, init_label, end_label, dbg_line, dbg_name,
  374.     dbg_proc, pname_decl)
  375. # Adds code for invoking the debug procedure.
  376. local decl, pname_var, vlist
  377.     # Make vlist an alphabetically sorted list of identifiers: the names of
  378.     # the variables which should be passed to the debugging procedure.
  379.     vlist := []
  380.     every \(decl := !ltab).d_displ do
  381.         put (vlist, decl.d_name)
  382.     vlist := sort (vlist)
  383.     # Begin writing the code.
  384.     write (uout,
  385.         "\tgoto\t", end_label,
  386.         "\nlab ", dbg_label,
  387.         "\n\tinit\t", init_label,
  388.         "\n\tmark\t", init_label,
  389.         "\n\tpnull\n\tvar\t", dbg_name,
  390.         "\n\tpnull")
  391.     every write (uout, "\tstr\t", (ltab[!vlist]).ld_cserial)
  392.     pname_var := if pname_decl.d_type = D_LOCAL then
  393.         pname_decl.ld_cserial else pname_decl.d_serial
  394.     write (uout,
  395.         "\tllist\t", *vlist,
  396.         "\n\tasgn\n\tunmark\nlab ", init_label,
  397.         "\n\tmark0\n\tvar\t", dbg_proc,
  398.         "\n\tkeywd\tfile\n\tvar\t", dbg_line,
  399.         "\n\tstr\t", pname_var,
  400.         "\n\tvar\t", dbg_name)
  401.     every write (uout, "\tvar\t", (ltab[!vlist]).d_serial)
  402.     write (uout,
  403.         "\tinvoke\t", 4 + *vlist,
  404.         "\n\tunmark\nlab ", end_label,
  405.         "\n\tpfail")
  406. end
  407.  
  408. procedure p2_addconst (decl, last_ser)
  409. # Adds a string constant declaration containing the name of a local or constant
  410. # declaration.
  411. # 'decl' must be the declaration (record l_decl or c_decl).
  412. # 'last_ser' must be the previous highest constant serial in this procedure.
  413. # RETURNS the serial of the new constant.
  414. # SIDE EFFECT: Updates 'decl'.
  415. # Writes the new constant to the ucode output file.
  416. # NOTE: This version does not add the name if the declaration is a global and
  417. # is known to be a procedure.
  418. local serial
  419.     # Omit variables which have been added by this program.
  420.     (decl.d_type = D_CONST) | (/decl.ld_dbg & decl.d_code ~= LD_GLOBAL) |
  421.         fail
  422.     (decl.d_type = D_CONST) | (decl.d_displ := 1)
  423.     serial := last_ser + 1
  424.     if decl.d_type = D_LOCAL then
  425.         decl.ld_cserial := serial
  426.     else
  427.         decl.d_serial := serial
  428.     writes (uout, "\tcon\t", serial, ",",
  429.         right (CD_STRING, 6, "0"), ",", *decl.d_name)
  430.     every writes (uout, ",", octal (ord (!decl.d_name)))
  431.     write (uout)
  432.     return serial
  433. end
  434.  
  435. procedure p2_addinit (ltab, init_label)
  436.     write (uout,
  437.         "\tinit\t", init_label,
  438.         "\n\tmark\t", init_label,
  439.         "\n\tvar\t", ltab[DBG_INIT].d_serial,
  440.         "\n\tinvoke\t0\n\tunmark\nlab ", init_label)
  441. end
  442.  
  443. procedure p2_addlocal (pname, ltab, serial, code, name, dbg)
  444. # Adds a local declaration to a table.
  445. # 'pname' must be the current procedure name.
  446. # 'ltab' must be the table where the new declaration is stored.
  447. # See 'p2_getlocal' for details.
  448. # 'serial' must be the serial to assign to the new declaration.
  449. # 'code' must be the code,
  450. # 'name' must be the name of the new declaration.
  451. # 'dbg' may be non-null to indicate something different from a normal variable
  452. # declaration.
  453. # RETURNS the new declaration (record l_decl).
  454. # SIDE EFFECT: Writes code for the new declaration to the ucode output file.
  455. # Creates a new entry in 'ltab'.
  456. local decl, old_d
  457.     # Check if the declaration already is there.
  458.     if old_d := \ltab[name] then {
  459.         # Check that the existing declaration is equivalent to the new.
  460.         (old_d.d_code = code) |
  461.         confl ("%1: conflicting declarations in procedure %2.", name, pname)
  462.         return old_d
  463.         }
  464.     decl := l_decl (D_LOCAL)
  465.     decl.d_serial := serial
  466.     decl.d_code := code
  467.     decl.ld_dbg := 1
  468.     ltab[decl.d_name := name] := decl
  469.     write (uout, "\tlocal\t", serial, ",", right (code, 6, "0"), ",", name)
  470.     return decl
  471. end
  472.  
  473. procedure p2_brkp ()
  474. # Scans the ucode input file for the next breakpoint location.
  475. # Ucode 'line' instructions are considered suitable breakpoint locations.
  476. # If there are several 'line' instructions with the same line number only the
  477. # last one is considered suitable.
  478. # If a location is found, RETURNS the line number of the current location.
  479. # FAILS if no suitable location is found.
  480. # This means that an 'end' instruction has been reached
  481. # When the procedure returns the 'line' instruction has been copied to the ucode
  482. # output file.
  483. # When the procedure encounters an 'end' instruction this instruction is not
  484. # copied to the ucode output file.
  485. local last_lno, line, opcode
  486. static cur_lno, opchar
  487. initial {
  488.     cur_lno := NALN
  489.     opchar := &lcase ++ '01'
  490.     }
  491.     repeat {
  492.         # Read and copy until the next 'line' or 'end' instruction is found.
  493.         repeat {
  494.             (line := read (uin)) |
  495.             intern ("p2_brkp: unexpected end of file.")
  496.             line ? if tab (many (white)) &
  497.                 (opcode := tab (many (opchar))) then {
  498.                 (opcode ~== OP_END) | {
  499.                     last_lno := NALN
  500.                     break
  501.                     }
  502.                 write (uout, line)
  503.                 (opcode ~== OP_LINE) | {
  504.                     last_lno := integer (tab (0))
  505.                     break
  506.                     }
  507.                 }
  508.             else
  509.                 write (uout, line)
  510.             }
  511.         if last_lno = NALN then
  512.             break
  513.         else case cur_lno of {
  514.             # Still the same line, try another one.
  515.             last_lno:    next # a little unstructured ...
  516.             # First line found.
  517.             NALN:        cur_lno := last_lno
  518.             # OK, this is it, stop here.
  519.             default:    break
  520.             }
  521.         }
  522.     if last_lno = NALN then
  523.         fail
  524.     else
  525.         return cur_lno :=: last_lno
  526. end
  527.  
  528. procedure p2_getlocal (ltab, dstring)
  529. # Gets a local declaration from ucode representation; adds it to a table.
  530. # 'ltab' must be a table storing declarations.
  531. # Entry key is the variable name.
  532. # Entry value is an 'l_decl' record.
  533. # 'dstring' must be the ucode string defining the local.
  534. # RETURNS the serial number of the new declaration.
  535. # SIDE EFFECT: Adds an entry to 'ltab'.
  536. local decl
  537.     decl := l_decl (D_LOCAL)
  538.     dstring ? {
  539.         decl.d_serial := integer (tab (many (&digits)))
  540.         =","
  541.         decl.d_code := integer (tab (many (&digits)))
  542.         =","
  543.         decl.d_name := tab (upto (white) | 0)
  544.         }
  545.     ltab[decl.d_name] := decl
  546.     return decl.d_serial
  547. end
  548.  
  549. procedure p2_newlocals (pname, ltab, last_ser, main_flag)
  550. # Adds debugging local declarations to a procedure.
  551. # 'pname' must be the procedure name (string).
  552. # 'ltab' must be a table holding local declarations; see 'p2_getlocal'.
  553. # 'last_ser' must be the last (highest) serial previously assigned.
  554. # 'main_flag' must be non-null if the current procedure is 'main'.
  555. # This will add the DBG_INIT procedure.
  556. # RETURNS the last local declaration serial.
  557. # SIDE EFFECT: Writes the new declarations to the ucode output file.
  558. # Adds the new declarations to 'ltab'.
  559.     # Add the debugging init procedure if this is 'main'.
  560.     /main_flag |
  561.     p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL, DBG_INIT)
  562.     p2_addlocal (pname, ltab, last_ser +:= 1, LD_LOCAL, DBG_LINE)
  563.     p2_addlocal (pname, ltab, last_ser +:= 1, LD_STATIC, DBG_NAME)
  564.     p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL, DBG_PROC)
  565.     p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL, DBG_TEST)
  566.     p2_addlocal (pname, ltab, last_ser +:= 1, LD_GLOBAL,
  567.         make_brkp_idf (file_root))
  568.     return last_ser
  569. end
  570.     
  571. procedure p2_proc (pname)
  572. # Tweaks the ucode of a single procedure.
  573. # 'pname' must be the name of the procedure.
  574. # SIDE EFFECT: Writes tweaked ucode to the ucode output file.
  575. local dbg_brkp, dbg_label, dbg_line, dbg_name, dbg_proc, dbg_test
  576. local init_label, end_label, pname_decl
  577. local loc, first_new_const, last_conser, last_label, last_locser, line
  578. local main_flag, op
  579. static con_decl, lc_decl
  580. initial {
  581.     # This is just a piece of hand optimization.
  582.     con_decl := [OP_CONST, OP_DEND]
  583.     lc_decl := [OP_LOCAL, OP_CONST, OP_DEND]
  584.     }
  585.     main_flag := pname == "main"
  586.     # Go through local declarations; add some new.
  587.     # See 'p2_getlocal' for documentation of the 'loc' table.
  588.     loc := table ()
  589.     last_locser := -1
  590.     while (op := p2_upto (lc_decl))[1] == OP_LOCAL do {
  591.         last_locser <:= p2_getlocal (loc, op[2])
  592.         }
  593.     # Add our own locals, write them to the ucode output file.
  594.     last_locser := p2_newlocals (pname, loc, last_locser, main_flag)
  595.     # Go through constant declarations in order to find the maximum serial.
  596.     last_conser := -1
  597.     repeat {
  598.         if op[1] == OP_CONST then
  599.             last_conser <:= (op[2] ? integer (tab (many (&digits))))
  600.         else
  601.             break
  602.         (op := p2_upto (con_decl)) | break
  603.         }
  604.     # Declare a constant for the procedure name.
  605.     # Note that the procedure name may be hidden by a local!
  606.     /loc[pname] := c_decl (D_CONST, , CD_STRING, pname)
  607.     # Add new constant declarations to the ucode file.
  608.     first_new_const := last_conser + 1
  609.     every last_conser := p2_addconst (!loc, last_conser)
  610.     # We will soon need a new label.
  611.     last_label := proc_hil[pname]
  612.     # Flush the 'p2_upto' buffer, normally the 'declend' instruction.
  613.     p2_upto ()
  614.     # If this is the 'main' procedure insert code for invoking the
  615.     # initialization procedure.
  616.     if \main_flag then
  617.         p2_addinit (loc, ULAB_PREF || (last_label +:= 1))
  618.     # Insert breakpoint testing code.
  619.     dbg_brkp := loc[make_brkp_idf (file_root)].d_serial
  620.     dbg_label := ULAB_PREF || (last_label +:= 1)
  621.     dbg_line := loc[DBG_LINE].d_serial
  622.     dbg_test := loc[DBG_TEST].d_serial
  623.     while last_label := p2_addbrkp (p2_brkp (), last_label,
  624.         dbg_brkp, dbg_label, dbg_line, dbg_test)
  625.     # Write the debug invocation code.
  626.     init_label := ULAB_PREF || (last_label +:= 1)
  627.     end_label := ULAB_PREF || (last_label +:= 1)
  628.     dbg_name := loc[DBG_NAME].d_serial
  629.     dbg_proc := loc[DBG_PROC].d_serial
  630.     pname_decl := loc[pname]
  631.     p2_addcall (loc, dbg_label, init_label, end_label, dbg_line, dbg_name,
  632.         dbg_proc, pname_decl)
  633.     # Add an 'end' instruction swallowed by 'p2_brkp'.
  634.     write (uout, "\t", OP_END)
  635. end
  636.  
  637. procedure p2_upto (op)
  638. # Scans the ucode file, looking for the next line containing an interesting
  639. # op-code.
  640. # Copies non-matching lines to the new ucode file (if non-null)
  641. # 'op' must be a list of the interesting op-code(s), or null.
  642. # If a matching line is found, RETURNS a list of two elements.
  643. # The first element contains the op-code, the second element the tail of the
  644. # instruction (excluding any leading white space).
  645. # FAILS on end-of-file.
  646. # FLUSHING THE BUFFER:
  647. # If the procedure is invoked with null 'op' any uncopied lines are written to
  648. # the ucode output file; the procedure fails.
  649. # NOTE: The procedure is used occasionally in pass 1, where there is no 'uout'
  650. # file.
  651. # This is the reason 'uout' is checked for existence (otherwise ucode will
  652. # appear on standard output).
  653. local opcode, tail
  654. static new_line, opchar, old_line
  655. initial opchar := &lcase ++ '01'
  656.     write (\uout, \new_line)
  657.     new_line := &null
  658.     \op | fail
  659.     repeat {
  660.         old_line := new_line
  661.         (new_line := read (uin)) | fail
  662.         new_line ? {
  663.             tab (many (white))
  664.             if (opcode := tab (many (opchar))) == !op then {
  665.                 tab (many (white))
  666.                 tail := tab (0)
  667.                 break
  668.                 }
  669.             else
  670.                 write (\uout, new_line)
  671.             }
  672.         }
  673.     return [opcode, tail]
  674. end
  675.  
  676. #
  677. #-------- '.u2' tweaking -----------
  678. #
  679.  
  680. procedure u2tweak ()
  681. # Tweaks a '.u2' file, which means:
  682. # Check the Icon version number;
  683. # insert 'link' commands to the debugging run-time and to the init procedure.
  684. local hitcount, op
  685.     (op := p2_upto ([OP_VERSION])) | {
  686.         note ("Surprising absence of 'version' in .u2 file...")
  687.         fail
  688.         }
  689.     (ICON_VER_LO <<= op[2] <<= ICON_VER_HI) |
  690.     note ("WARNING: %1 is tested only for Icon versions '%2'-'%3', found '%4'.",
  691.             PROGNAME, ICON_VER_LO, ICON_VER_HI, op[2])
  692.     hitcount := 0
  693.     while (op := p2_upto ([OP_LINK, OP_GLOBAL]))[1] == OP_LINK do
  694.         if op[2] == DBG_RUN_TIME then
  695.             hitcount +:= 1
  696.     if hitcount = 0 then {
  697.         write (uout, OP_LINK, "\t", DBG_RUN_TIME)
  698.         write (uout, OP_LINK, "\t", init_file)
  699.         }
  700.     p2_upto ()
  701.     while write (uout, read (uin))
  702. end
  703.  
  704. #
  705. #-------- General message handling and other utilities --------
  706. #
  707.  
  708. procedure confl (msg, parm[])
  709. # Writes a conflict message and stops the program with nonzero exit code.
  710.     message ("[CONFLICT] ", subst (msg, parm))
  711.     message ("*** ", PROGNAME, " stops with failure.")
  712.     stop ()
  713. end
  714.  
  715. procedure cre_init (f)
  716. # Creates initialization code.
  717. # 'f' must be a file open for output.
  718. local map, version
  719.     version := (PROGRAM_VERSION ? (tab (upto (&digits)),
  720.         tab (many (&digits++'.'))))
  721.     every write (f, "global ", (PROG_VERSION_VAR | DBG_TEST | DBG_FILE_MAP))
  722.     every write (f, "global ", make_brkp_idf ((!file_map).fm_ucode))
  723.     write (f,
  724.         "\nprocedure ", DBG_INIT, " ()\n\t",
  725.         PROG_VERSION_VAR, " := \"", version, "\"\n\t",
  726.         DBG_TEST, " := member")
  727.     every write (f,
  728.         "\t", make_brkp_idf ((!file_map).fm_ucode), " := set ()")
  729.     write (f, "\t", DBG_FILE_MAP, " := table ()")
  730.     every map := !file_map do
  731.         write (f, "\t",
  732.             DBG_FILE_MAP, "[\"", map.fm_source, "\"] := ",
  733.             make_brkp_idf (map.fm_ucode))
  734.     write (f, "\t", DBG_PROC, " ()\nend")
  735. end
  736.  
  737. procedure fld_adj (str)
  738. # Part of 'subst' format string parsing.
  739. # 'str' must be a parameter string identified by the beginning part of a
  740. # placeholder ('%n').
  741. # This procedure checks if the placeholder contains a fixed field width
  742. # specifier.
  743. # A fixed field specifier begins with '<' or '<' and continues with the field
  744. # width expressed as a decimal literal.
  745. # RETURNS 'str' possibly inserted in a fixed width field.
  746. local just, init_p, res, wid
  747. static fwf
  748. initial fwf := '<>'
  749.     init_p := &pos
  750.     if (just := if ="<" then left else if =">" then right) &
  751.         (wid := integer (tab (many (&digits)))) then
  752.         res := just (str, wid)
  753.     else {
  754.         res := str
  755.         &pos := init_p
  756.         }
  757.     return res
  758. end
  759.  
  760. procedure intern (msg, parm[])
  761. # Writes an internal conflict message and stops the program with nonzero exit
  762. # code.
  763.     message ("*** INTERNAL: ", subst (msg, parm))
  764.     message ("*** ", PROGNAME, " stops with failure.")
  765.     stop ()
  766. end
  767.  
  768. procedure make_brkp_idf (ucode_root)
  769. # RETURNS an identifier which should be used to hold the breakpoints of an
  770. # ucode file whose root name is 'ucode_root'.
  771.     return DBG_BRKP1 || ucode_root || DBG_BRKP2
  772. end
  773.  
  774. procedure message (parm[])
  775. # Writes any number of strings to the message file.
  776.     every writes (msgout, !parm)
  777.     write (msgout)
  778. end
  779.  
  780. procedure note (msg, parm[])
  781. # Writes a note message.
  782.     message ("[NOTE] ", subst (msg, parm))
  783. end
  784.  
  785. procedure octal (i)
  786. # RETURNS the 'i' integer in the form of an octal literal.
  787.    static digits
  788.    local s, d
  789.    initial digits := string (&digits)
  790.    if i = 0 then return "0"
  791.    s := ""
  792.    while i > 0 do {
  793.       d := i % 8
  794.       if d > 9 then d := digits[d + 1]
  795.       s := d || s
  796.       i /:= 8
  797.       }
  798.    return s
  799. end
  800.  
  801. procedure subst (msg, parm)
  802. # Substitutes parameters in a message template.
  803. # 'msg' must be a message template (string).
  804. # 'parm' must be a list of parameters (list of string-convertible), or null.
  805. # It may also be a string.
  806. local esc, res, sub
  807. static p_digit
  808. initial p_digit := '123456789'
  809.     \parm | return msg
  810.     parm := [string (parm)]
  811.     res := ""
  812.     msg ? until pos (0) do {
  813.         res ||:= tab (upto ('%\\') | 0)
  814.         if ="%" then res ||:= {
  815.             if any (p_digit) then {
  816.                 sub := (\parm[integer (move (1))] | "")
  817.                 fld_adj (sub)    
  818.                 }
  819.             else if any ('%') then
  820.                 move (1)
  821.             else ""
  822.             }
  823.         else if ="\\" then res ||:= case esc := move (1) of {
  824.             "n": "\n"
  825.             "t": "\t"
  826.             default: esc
  827.             }
  828.         }
  829.     return res
  830. end
  831.