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 / src / common / mktoktab.icn < prev    next >
Text File  |  2002-01-18  |  15KB  |  508 lines
  1. # Build the files:
  2. #    lextab.h - token tables and operator recognizer
  3. #    yacctok.h - %token declarations for YACC
  4. # from token description file "tokens.txt" and operator description
  5. # file "op.txt".
  6.  
  7. global token, tokval, bflag, eflag, head, oper, tail, count
  8. global restable, flagtable, op_lst, asgn_loc, semicol_loc, plus_loc, minus_loc
  9. global white_sp, unary_set
  10. global tokfile, opfile, toktab, tok_dot_h
  11.  
  12. record op_sym(op, aug, tokval, unary, binary)
  13. record association(op, n)
  14. record trie(by_1st_c, dflt)
  15.  
  16. procedure tokpat()
  17.    if tab(many(white_sp)) & (token := tab(upto(white_sp))) &
  18.       tab(many(white_sp)) & (tokval := (tab(upto(white_sp) | 0)))
  19.    then return (tab(upto('b')) & (bflag := move(1))) | (bflag := "") &
  20.       ((tab(upto('e')) & (eflag := move(1))) | (eflag := "")) & pos(0)
  21. end
  22.  
  23. procedure main()
  24.    local line, letter, lastletter
  25.    local s, op, aug, tok, unary, binary, tok_chars, sym, op_trie
  26.    local prognm, tokfnm, opfnm, toktbnm, dothnm, op_linenum
  27.  
  28.    white_sp := ' \t'
  29.  
  30.    prognm := "mktoktab"
  31.    tokfnm := "tokens.txt"
  32.    opfnm := "op.txt"
  33.    toktbnm := "lextab.h"
  34.    dothnm := "yacctok.h"
  35.  
  36.    restable := table()
  37.    flagtable := table("")
  38.    flagtable[""] := "0"
  39.    flagtable["b"] := "Beginner"
  40.    flagtable["e"] := "Ender"
  41.    flagtable["be"] := "Beginner+Ender"
  42.    count := 0
  43.    lastletter := ""
  44.  
  45.    tokfile := open(tokfnm) | stop("unable to open \"", tokfnm, "\"")
  46.    opfile := open(opfnm) | stop("unable to open \"", opfnm, "\"")
  47.    toktab := open(toktbnm,"w") | stop("unable to create \"", toktbnm, "\"")
  48.    tok_dot_h := open(dothnm,"w") | stop("unable to create \"", dothnm, "\"")
  49.    write("  writing ", tokfnm, " and ", dothnm)
  50.  
  51. # Output header for token table
  52.    write(toktab,"/*")
  53.    write(toktab," * NOTE: this file is generated automatically by ", prognm)
  54.    write(toktab," *  from ", tokfnm, " and ", opfnm, ".")
  55.    write(toktab," */")
  56.    write(toktab)
  57.    write(toktab,"/*")
  58.    write(toktab," * Token table - contains an entry for each token type")
  59.    write(toktab," * with printable name of token, token type, and flags")
  60.    write(toktab," * for semicolon insertion.")
  61.    write(toktab," */")
  62.    write(toktab)
  63.    write(toktab,"struct toktab toktab[] = {")
  64.    write(toktab,"/*  token\t\ttoken type\tflags */")
  65.    write(toktab)
  66.    write(toktab,"   /* primitives */")
  67.  
  68. # output header for token include file
  69.    write(tok_dot_h,"/*")
  70.    write(tok_dot_h," * NOTE: these %token declarations are generated")
  71.    write(tok_dot_h," *  automatically by ", prognm, " from ", tokfnm, " and ")
  72.    write(tok_dot_h," *  ", opfnm, ".")
  73.    write(tok_dot_h," */")
  74.    write(tok_dot_h)
  75.    write(tok_dot_h, "/* primitive tokens */")
  76.    write(tok_dot_h)
  77.  
  78.  
  79. # Skip the first few (non-informative) lines of "tokens.txt"
  80.  
  81.    garbage()
  82.  
  83. # Read primitive tokens
  84.  
  85.    repeat {
  86.       write(toktab,makeline(token,tokval,bflag || eflag,count))
  87.       wrt_tok_def(tokval)
  88.       count +:= 1
  89.       line := read(tokfile) | stop("premature end-of-file")
  90.       line ? tokpat() | break
  91.          }
  92.  
  93. # Skip some more garbage lines
  94.  
  95.    garbage()
  96.  
  97. # Output some more comments
  98.  
  99.    write(toktab)
  100.    write(toktab,"   /* reserved words */")
  101.    write(tok_dot_h)
  102.    write(tok_dot_h, "/* reserved words */")
  103.    write(tok_dot_h)
  104.  
  105. # Read in reserved words, output them,
  106. # and build table of first letters.
  107.  
  108.    repeat {
  109.       write(toktab,makeline(token,tokval,bflag || eflag,count))
  110.       wrt_tok_def(tokval, token)
  111.       letter := token[1]
  112.       if letter ~== lastletter then {
  113.          lastletter := letter
  114.          restable[letter] := count
  115.         }
  116.    count +:= 1
  117.    line := read(tokfile) | stop("premature end-of-file")
  118.    if line ? tokpat() then next else break
  119.    }
  120.  
  121. # output end of token table and reserveed word first-letter index.
  122.  
  123.    write(toktab,makeline("end-of-file","0","",""))
  124.    write(toktab,"   };")
  125.    write(toktab)
  126.    write(toktab,"/*")
  127.    write(toktab," * restab[c] points to the first reserved word in toktab which")
  128.    write(toktab," * begins with the letter c.")
  129.    write(toktab," */")
  130.    write(toktab)
  131.    write(toktab,"struct toktab *restab[] = {")
  132.    write(toktab,makeres("abcd", 16r61))
  133.    write(toktab,makeres("efgh"))
  134.    write(toktab,makeres("ijkl"))
  135.    write(toktab,makeres("mnop"))
  136.    write(toktab,makeres("qrst"))
  137.    write(toktab,makeres("uvwx"))
  138.    write(toktab,makeres("yz"))
  139.    write(toktab,"   };")
  140.  
  141. # Another comment
  142.  
  143.    write(toktab)
  144.    write(toktab,"/*")
  145.    write(toktab," * The operator table acts to extend the token table, it")
  146.    write(toktab," *  indicates what implementations are expected from rtt,")
  147.    write(toktab," *  and it has pointers for the implementation information.")
  148.    write(toktab," */")
  149.    write(toktab)
  150.    write(toktab, "struct optab optab[] = {")
  151.    write(tok_dot_h)
  152.    write(tok_dot_h, "/* operators */")
  153.    write(tok_dot_h)
  154.  
  155. # read operator file
  156.  
  157.    tok_chars := &lcase ++ &ucase ++ '_'
  158.  
  159.    op_linenum := 0
  160.    unary_set := set()
  161.    ops := table()
  162.    op_lst := []
  163.    
  164.    while s := read(opfile) do {
  165.       op_linenum +:= 1
  166.       s ? {
  167.          tab(many(white_sp))
  168.          if pos(0) | = "#" then
  169.             next
  170.          op := tab(upto(white_sp)) | err(opfnm, op_linenum,
  171.             "unexpected end of line")
  172.          tab(many(white_sp))
  173.          if ="(:=" then {
  174.             tab(many(white_sp))
  175.             if not ="AUG)" then
  176.                err(opfnm, op_linenum, "invalid augmented indication")
  177.             tab(many(white_sp))
  178.             aug := 1
  179.             }
  180.          else
  181.             aug := &null
  182.          tok := tab(many(tok_chars)) | err(opfnm, op_linenum, "invalid token")
  183.          tab(many(white_sp))
  184.          unary := tab(any('_us')) | err(opfnm,op_linenum,"invalid unary flag")
  185.          tab(many(white_sp))
  186.          binary := tab(any('_bs')) | err(opfnm,op_linenum,"invalid binary flag")
  187.          if unary == "_" & binary == "_" then
  188.             err(opfnm, op_linenum, "either unary or binary flag must be set")
  189.          if unary ~== "_" then {
  190.             if *op ~= 1 then
  191.                err(opfnm, op_linenum,
  192.                   "unary operators must be single characters: " || op);
  193.             insert(unary_set, op)
  194.             }
  195.          if \aug & binary == "_" then
  196.             err(opfnm, op_linenum,
  197.               "binary flag must be set for augmented assignment")
  198.  
  199.          ops[op] := op_sym(op, aug, tok, unary, binary)
  200.          }
  201.       }
  202.  
  203.    ops := sort(ops, 3)
  204.    while get(ops) & sym := get(ops) do
  205.      op_out(sym.op, sym.aug, sym.tokval, sym.unary, sym.binary)
  206.  
  207. # Skip more garbage
  208.  
  209.    garbage()
  210.  
  211. repeat {
  212.    wrt_op(token, tokval, bflag || eflag, 0, 1)
  213.    line := read(tokfile) | stop("premature end-of-file")
  214.    line ? tokpat() | break
  215.    }
  216.  
  217. # Skip more garbage
  218.  
  219.    garbage()
  220.  
  221. repeat {
  222.    wrt_op(token, tokval, bflag || eflag, 0, &null)
  223.    line := read(tokfile) | stop("premature end-of-file")
  224.    line ? tokpat() | break
  225.    }
  226.    write(toktab,
  227.       "   {{NULL,          0,     0},        0,              NULL, NULL}")
  228.    write(toktab, "   };")
  229.  
  230.    write(toktab)
  231.    if /asgn_loc then
  232.       stop(opfnm, " does not contain a definition for ':='")
  233.    if /semicol_loc then
  234.       stop(tokfnm, " does not contain a definition for ';'")
  235.    if /plus_loc then
  236.       stop(tokfnm, " does not contain a definition for '+'")
  237.    if /minus_loc then
  238.       stop(tokfnm, " does not contain a definition for '-'")
  239.    write(toktab, "int asgn_loc = ", asgn_loc, ";")
  240.    write(toktab, "int semicol_loc = ", semicol_loc, ";")
  241.    write(toktab, "int plus_loc = ", plus_loc, ";")
  242.    write(toktab, "int minus_loc = ", minus_loc, ";")
  243.  
  244.    op_trie := build_trie(op_lst)
  245.  
  246.    write(toktab);
  247.    wrt(toktab, 0, "/*")
  248.    wrt(toktab, 0, " * getopr - find the longest legal operator and return the")
  249.    wrt(toktab, 0, " *  index to its entry in the operator table.")
  250.    wrt(toktab, 0, " */\n")
  251.    wrt(toktab, 0, "int getopr(ac, cc)")
  252.    wrt(toktab, 0, "int ac;")
  253.    wrt(toktab, 0, "int *cc;")
  254.    wrt(toktab, 1, "{")
  255.    wrt(toktab, 1, "register char c;\n")
  256.    wrt(toktab, 1, "*cc = ' ';")
  257.    bld_slct(op_trie, "", "ac", toktab, 1)
  258.    wrt(toktab, 1, "tfatal(\"invalid character\", (char *)NULL);")
  259.    wrt(toktab, 1, "return -1;")
  260.    wrt(toktab, 1, "}")
  261. end
  262.  
  263. procedure makeline(token,tokval,flag,count)    # build an output line for token table.
  264.    local line
  265.    line := left("   \"" || token || "\",",22) || left(tokval ||  ",",15)
  266.    flag := flagtable[flag] || ","
  267.    if count ~=== "" then flag := left(flag,19)
  268.    line ||:= flag
  269.    if count ~=== "" then line ||:= "/* " || right(count,3) || " */"
  270.    return line
  271. end
  272.  
  273. # makeres - build an output line for reserved word index.
  274. #
  275. procedure makeres(lets, strt_repr)
  276.    local let, letters, line
  277.    static repr
  278.  
  279.    repr := \strt_repr
  280.  
  281.    line := "   "
  282.    letters := lets
  283.    every let := !lets do
  284.       if let ~== "." & \restable[let] then {
  285.          line ||:= "&toktab[" || right(restable[let],2) || "], "
  286.          }
  287.       else line ||:= "NULL,        "
  288.    line := left(line,55) || "/* " 
  289.    if integer(repr) then
  290.       line ||:= hex(repr) || "-" || hex((repr +:= *lets) - 1) || " "
  291.    return line || letters || " */"
  292. end
  293.  
  294. procedure garbage()
  295.    local line
  296.    while line := read(tokfile) | stop("premature end-of-file") do
  297.       if line ? tokpat() then return
  298. end
  299.  
  300. procedure hex(n)
  301.    local s
  302.    static hexdig
  303.  
  304.    initial hexdig := "0123456789ABCDEF"
  305.  
  306.    s := ""
  307.    while n > 0 do {
  308.       s := hexdig[n % 16 + 1] || s
  309.       n := n / 16
  310.       }
  311.    return s
  312. end
  313.  
  314. procedure op_out(op, aug, tokval, unary, binary)
  315.    local flag, arity
  316.  
  317.    if unary_str(op) then
  318.       flag := "b"
  319.    else
  320.       flag := ""
  321.    if unary == "u" then
  322.       arity := "Unary"
  323.    if binary == "b" then
  324.       if /arity then
  325.          arity := "Binary"
  326.       else
  327.          arity ||:= " | Binary"
  328.    /arity := "0"
  329.    wrt_op(op, tokval, flag, arity, 1)
  330.    if \aug then
  331.       wrt_op(op || ":=", "AUG" || tokval, "", "0", 1)
  332. end
  333.  
  334. procedure wrt_op(op, tokval, flag, arity, define)
  335.    static cnt
  336.  
  337.    initial cnt := 0;
  338.  
  339.    flag := flagtable[flag]
  340.    writes(toktab, "   {{\"", left(esc(op) || "\",", 9))
  341.    writes(toktab, left(tokval || ",", 12))
  342.    writes(toktab, left(flag || "},", 11))
  343.    writes(toktab, left(arity|| ",", 16))
  344.    write(toktab, "NULL, NULL}, /* ", cnt, " */")
  345.    if \define then
  346.       wrt_tok_def(tokval, op)
  347.    if op == ":=" then
  348.       asgn_loc := cnt
  349.    else if op == ";" then
  350.       semicol_loc := cnt
  351.    else if op == "+" then
  352.       plus_loc := cnt
  353.    else if op == "-" then
  354.       minus_loc := cnt
  355.    put(op_lst, association(op, cnt))
  356.    cnt +:= 1
  357. end
  358.  
  359. procedure wrt_tok_def(tokval, tok)
  360.    if \tok then
  361.       write(tok_dot_h, "%token\t", left(tokval, 12), "/* ", left(tok, 9),
  362.          " */")
  363.    else
  364.       write(tok_dot_h, "%token\t", tokval);
  365. end
  366.  
  367. procedure unary_str(op)
  368.    if op == "" then
  369.       return
  370.    if member(unary_set, op[1]) then
  371.       return unary_str(op[2:0])
  372. end
  373.  
  374. procedure err(file, line, msg)
  375.    stop(&errout, "file: ", file, ", line: ", line, " - ", msg)
  376. end
  377.  
  378. procedure build_trie(ops)
  379.    local by_1st_c, dflt, asc, c, c_ops
  380.  
  381.    by_1st_c := table()
  382.    every asc := !ops do {
  383.       #
  384.       # See if there are more characters in this operator.
  385.       #
  386.       if c := asc.op[1] then {
  387.           /by_1st_c[c] := []
  388.           put(by_1st_c[c], association(asc.op[2:0], asc.n))
  389.           }
  390.       else 
  391.           dflt := asc.n
  392.       }
  393.    by_1st_c := sort(by_1st_c)
  394.    every c_ops := !by_1st_c do
  395.       c_ops[2] := build_trie(c_ops[2])
  396.    return trie(by_1st_c, dflt)
  397. end
  398.  
  399.  
  400. # bld_slct - output selection code which will recongize operators
  401. #   represented by the given trie. Code has already been generated
  402. #   to recognize the string in prefix.
  403. procedure bld_slct(op_trie, prefix, char_src, f, indent)
  404.    local fall_through, by_1st_c, dflt, char, trie_1, a, ft
  405.  
  406.    by_1st_c := op_trie.by_1st_c
  407.    dflt := op_trie.dflt
  408.  
  409.    case *by_1st_c of {
  410.       0:
  411.          #
  412.          # There are no more characters to check. When execution gets
  413.          #  here in the generated code we have found a longest possible
  414.          #  operator: the one contained in prefix.
  415.          #
  416.          wrt(f, indent, "return " , dflt, ";   /* ", prefix, " */")
  417.       1: {
  418.          #
  419.          # If there is only one valid character to check for, generate an
  420.          #  if statement rather than a switch statement. If the character
  421.          #  is not next in the input, either we are already at the end of
  422.          #  a valid operator (in which case, the generated code must
  423.          #  must save the one-character look ahead) or the generated
  424.          #  code will fall through to an error message at the end of the
  425.          #  function.
  426.          #
  427.          char := by_1st_c[1][1]
  428.          trie_1 := by_1st_c[1][2]
  429.          wrt(f, indent, "if ((c = ", char_src, ") == '", esc(char), "') {")
  430.          fall_through := bld_slct(trie_1, prefix || char, "NextChar", f,
  431.             indent + 1)
  432.          wrt(f, indent + 1, "}")
  433.          if \dflt then {
  434.             wrt(f, indent, "else {")
  435.             wrt(f, indent + 1, "*cc = c;")
  436.             wrt(f, indent + 1, "return " , dflt, ";   /* ", prefix, " */")
  437.             wrt(f, indent + 1, "}")
  438.             }
  439.          else
  440.             fall_through := 1
  441.          }
  442.       default: {
  443.          #
  444.          # There are several possible next characters. Produce a switch
  445.          #  statement to check for them.
  446.          #
  447.          wrt(f, indent, "switch (c = ", char_src, ") {")
  448.          every a := !by_1st_c do {
  449.             char := a[1]
  450.             trie_1 := a[2]
  451.             wrt(f, indent + 1, "case '", esc(char), "':")
  452.             ft := bld_slct(trie_1, prefix || char, "NextChar", f, indent + 2)
  453.             if \ft then {
  454.                wrt(f, indent + 2, "break;")
  455.                fall_through := 1
  456.                }
  457.            }
  458.          if \dflt then {
  459.             wrt(f, indent + 1, "default:")
  460.             wrt(f, indent + 2, "*cc = c;")
  461.             wrt(f, indent + 2, "return " , dflt, ";   /* ", prefix, " */")
  462.             }
  463.          else
  464.             fall_through := 1
  465.          wrt(f, indent + 1, "}")
  466.          }
  467.       }
  468.  
  469.    return fall_through
  470. end
  471.  
  472. procedure wrt(f, indent, slst[])
  473.    local s1, i, exp_indent
  474.  
  475.    exp_indent := indent * 3;
  476.    s1 := repl(" ", exp_indent)
  477.    while s1 ||:= get(slst) 
  478.    if (*s1 > 80) then {
  479.       #
  480.       # line too long, find first space before 80th column, and
  481.       #  break there. note, this will not work in general. it may
  482.       #  break a line within a string.
  483.       #
  484.       every i := 80 to 1 by -1 do
  485.          if s1[i] == " " then
  486.             if i <= exp_indent then {
  487.                #
  488.                # we have indented too far
  489.                #
  490.                wrt(f, indent - 1, s1[exp_indent+1:0])
  491.                return
  492.                }
  493.             else {
  494.                write(f, s1[1:i])
  495.                wrt(f, indent, s1[i+1:0])
  496.                return
  497.                }
  498.       }
  499.    write(f, s1)
  500. end
  501.  
  502. procedure esc(c)
  503.    if c == "\\" then
  504.       return "\\\\"
  505.    else
  506.       return c
  507. end
  508.