home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume44 / ibpag2 / part02 / itokens.icn < prev    next >
Text File  |  1994-09-25  |  30KB  |  926 lines
  1. ############################################################################
  2. #
  3. #    Name:     itokens.icn
  4. #
  5. #    Title:     itokens (Icon source-file tokenizer)
  6. #
  7. #    Author:     Richard L. Goerwitz
  8. #
  9. #    $Revision: 1.11 $
  10. #
  11. ############################################################################
  12. #
  13. #  This file contains itokens() - a utility for breaking Icon source
  14. #  files up into individual tokens.  This is the sort of routine one
  15. #  needs to have around when implementing things like pretty printers,
  16. #  preprocessors, code obfuscators, etc.  It would also be useful for
  17. #  implementing cut-down implementations of Icon written in Icon - the
  18. #  sort of thing one might use in an interactive tutorial.
  19. #
  20. #  Itokens(f, x) takes, as its first argument, f, an open file, and
  21. #  suspends successive TOK records.  TOK records contain two fields.
  22. #  The first field, sym, contains a string that represents the name of
  23. #  the next token (e.g. "CSET", "STRING", etc.).  The second field,
  24. #  str, gives that token's literal value.  E.g. the TOK for a literal
  25. #  semicolon is TOK("SEMICOL", ";").  For a mandatory newline, itokens
  26. #  would suspend TOK("SEMICOL", "\n").
  27. #
  28. #  Unlike Icon's own tokenizer, itokens() does not return an EOFX
  29. #  token on end-of-file, but rather simply fails.  It also can be
  30. #  instructed to return syntactically meaningless newlines by passing
  31. #  it a nonnull second argument (e.g. itokens(infile, 1)).  These
  32. #  meaningless newlines are returned as TOK records with a null sym
  33. #  field (i.e. TOK(&null, "\n")).
  34. #
  35. #  NOTE WELL: If new reserved words or operators are added to a given
  36. #  implementation, the tables below will have to be altered.  Note
  37. #  also that &keywords should be implemented on the syntactic level -
  38. #  not on the lexical one.  As a result, a keyword like &features will
  39. #  be suspended as TOK("CONJUNC", "&") and TOK("IDENT", "features").
  40. #
  41. ############################################################################
  42. #
  43. #  Links: slshupto
  44. #
  45. #  Requires: coexpressions
  46. #
  47. ############################################################################
  48.  
  49. #link ximage, slshupto
  50. link slshupto #make sure you have version 1.2 or above
  51.  
  52. global next_c, line_number
  53. record TOK(sym, str)
  54.  
  55. #
  56. # main:  an Icon source code uglifier
  57. #
  58. #     Stub main for testing; uncomment & compile.  The resulting
  59. #     executable will act as an Icon file compressor, taking the
  60. #     standard input and outputting Icon code stripped of all
  61. #     unnecessary whitespace.  Guaranteed to make the code a visual
  62. #     mess :-).
  63. #
  64. #procedure main()
  65. #
  66. #    local separator, T
  67. #    separator := ""
  68. #    every T := itokens(&input) do {
  69. #    if any(&digits ++ &letters ++ '_.', \T.str, 1, 2) & \T.sym ~== "DOT"
  70. #    then writes(separator)
  71. #    if T.sym == "SEMICOL" then writes(";") else writes(T.str)
  72. #    if any(&digits ++ &letters ++ '_.', \T.str, -1, 0) & \T.sym ~== "DOT"
  73. #    then separator := " " else separator := ""
  74. #    }
  75. #
  76. #end
  77.  
  78.  
  79. #
  80. # itokens:  file x anything    -> TOK records (a generator)
  81. #           (stream, nostrip)  -> Rs
  82. #
  83. #     Where stream is an open file, anything is any object (it only
  84. #     matters whether it is null or not), and Rs are TOK records.
  85. #     Note that itokens strips out useless newlines.  If the second
  86. #     argument is nonnull, itokens does not strip out superfluous
  87. #     newlines.  It may be useful to keep them when the original line
  88. #     structure of the input file must be maintained.
  89. #
  90. procedure itokens(stream, nostrip)
  91.  
  92.     local T, last_token
  93.  
  94.     # initialize to some meaningless value
  95.     last_token := TOK()
  96.  
  97.     every T := \iparse_tokens(stream) do {
  98.     if \T.sym then {
  99.         if T.sym == "EOFX" then fail
  100.         else {
  101.         #
  102.         # If the last token was a semicolon, then interpret
  103.         # all ambiguously unary/binary sequences like "**" as
  104.         # beginners (** could be two unary stars or the [c]set
  105.         # intersection operator).
  106.         #
  107.         if \last_token.sym == "SEMICOL"
  108.         then suspend last_token := expand_fake_beginner(T)
  109.         else suspend last_token := T
  110.         }
  111.     } else {
  112.         if \nostrip
  113.         then suspend last_token := T
  114.     }
  115.     }
  116.  
  117. end
  118.  
  119.  
  120. #
  121. # expand_fake_beginner: TOK record -> TOK records
  122. #
  123. #     Some "beginner" tokens aren't really beginners.  They are token
  124. #     sequences that could be either a single binary operator or a
  125. #     series of unary operators.  The tokenizer's job is just to snap
  126. #     up as many characters as could logically constitute an operator.
  127. #     Here is where we decide whether to break the sequence up into
  128. #     more than one op or not.
  129. #
  130. procedure expand_fake_beginner(next_token)
  131.  
  132.     static exptbl
  133.     initial {
  134.     exptbl := table()
  135.     insert(exptbl, "CONCAT",  [TOK("BAR", "|"),   TOK("BAR", "|")])
  136.     insert(exptbl, "DIFF",    [TOK("MINUS", "-"), TOK("MINUS", "-")])
  137.      insert(exptbl, "EQUIV",   [TOK("NUMEQ", "="), TOK("NUMEQ", "="),
  138.                    TOK("NUMEQ", "=")])
  139.     insert(exptbl, "INTER",   [TOK("STAR", "*"),  TOK("STAR", "*")])
  140.     insert(exptbl, "LCONCAT", [TOK("BAR", "|"),   TOK("BAR", "|"),
  141.                    TOK("BAR", "|")])
  142.     insert(exptbl, "LEXEQ",   [TOK("NUMEQ", "="), TOK("NUMEQ", "=")])
  143.     insert(exptbl, "LEXNE",   [TOK("TILDE", "~"), TOK("NUMEQ", "="),
  144.                    TOK("NUMEQ", "=")])
  145.     insert(exptbl, "NOTEQUIV",[TOK("TILDE", "~"), TOK("NUMEQ","="),
  146.                    TOK("NUMEQ", "="), TOK("NUMEQ", "=")])
  147.     insert(exptbl, "NUMNE",   [TOK("TILDE", "~"), TOK("NUMEQ","=")])
  148.     insert(exptbl, "UNION",   [TOK("PLUS", "+"),  TOK("PLUS", "+")])
  149.     }
  150.  
  151.     if \exptbl[next_token.sym]
  152.     then suspend !exptbl[next_token.sym]
  153.     else return next_token
  154.  
  155. end
  156.  
  157.  
  158. #
  159. # iparse_tokens:  file     -> TOK records (a generator)
  160. #                 (stream) -> tokens
  161. #
  162. #     Where file is an open input stream, and tokens are TOK records
  163. #     holding both the token type and actual token text.
  164. #
  165. #     TOK records contain two parts, a preterminal symbol (the first
  166. #     "sym" field), and the actual text of the token ("str").  The
  167. #     parser only pays attention to the sym field, although the
  168. #     strings themselves get pushed onto the value stack.
  169. #
  170. #     Note the following kludge:  Unlike real Icon tokenizers, this
  171. #     procedure returns syntactially meaningless newlines as TOK
  172. #     records with a null sym field.  Normally they would be ignored.
  173. #     I wanted to return them so they could be printed on the output
  174. #     stream, thus preserving the line structure of the original
  175. #     file, and making later diagnostic messages more usable.
  176. #
  177. procedure iparse_tokens(stream, getchar)
  178.  
  179.     local elem, whitespace, token, last_token, primitives, reserveds
  180.     static be_tbl, reserved_tbl, operators
  181.     initial {
  182.  
  183.     #  Primitive Tokens
  184.     #
  185.     primitives := [
  186.                ["identifier",      "IDENT",     "be"],
  187.                ["integer-literal", "INTLIT",    "be"],
  188.                ["real-literal",    "REALLIT",   "be"],
  189.                ["string-literal",  "STRINGLIT", "be"],
  190.                ["cset-literal",    "CSETLIT",   "be"],
  191.                ["end-of-file",     "EOFX",      "" ]]
  192.  
  193.     # Reserved Words
  194.     #
  195.     reserveds  := [
  196.                ["break",           "BREAK",     "be"],
  197.                ["by",              "BY",        ""  ],
  198.                ["case",            "CASE",      "b" ],
  199.                ["create",          "CREATE",    "b" ],
  200.                ["default",         "DEFAULT",   "b" ],
  201.                ["do",              "DO",        ""  ],
  202.                        ["else",            "ELSE",      ""  ],
  203.                ["end",             "END",       "b" ],
  204.                ["every",           "EVERY",     "b" ],
  205.                ["fail",            "FAIL",      "be"],
  206.                ["global",          "GLOBAL",    ""  ],
  207.                ["if",              "IF",        "b" ],
  208.                ["initial",         "INITIAL",   "b" ],
  209.                ["invocable",       "INVOCABLE", ""  ],
  210.                ["link",            "LINK",      ""  ],
  211.                ["local",           "LOCAL",     "b" ],
  212.                ["next",            "NEXT",      "be"],
  213.                ["not",             "NOT",       "b" ],
  214.                ["of",              "OF",        ""  ],
  215.                ["procedure",       "PROCEDURE", ""  ],
  216.                ["record",          "RECORD",    ""  ],
  217.                ["repeat",          "REPEAT",    "b" ],
  218.                ["return",          "RETURN",    "be"],
  219.                ["static",          "STATIC",    "b" ],
  220.                ["suspend",         "SUSPEND",   "be"],
  221.                ["then",            "THEN",      ""  ],
  222.                ["to",              "TO",        ""  ],
  223.                ["until",           "UNTIL",     "b" ],
  224.                ["while",           "WHILE",     "b" ]]
  225.  
  226.     # Operators
  227.     #
  228.     operators  := [
  229.                [":=",              "ASSIGN",    ""  ],
  230.                ["@",               "AT",        "b" ],
  231.                ["@:=",             "AUGACT",    ""  ],
  232.                ["&:=",             "AUGAND",    ""  ],
  233.                ["=:=",             "AUGEQ",     ""  ],
  234.                ["===:=",           "AUGEQV",    ""  ],
  235.                [">=:=",            "AUGGE",     ""  ],
  236.                [">:=",             "AUGGT",     ""  ],
  237.                ["<=:=",            "AUGLE",     ""  ],
  238.                ["<:=",             "AUGLT",     ""  ],
  239.                ["~=:=",            "AUGNE",     ""  ],
  240.                ["~===:=",          "AUGNEQV",   ""  ],
  241.                ["==:=",            "AUGSEQ",    ""  ],
  242.                [">>=:=",           "AUGSGE",    ""  ],
  243.                [">>:=",            "AUGSGT",    ""  ],
  244.                ["<<=:=",           "AUGSLE",    ""  ],
  245.                ["<<:=",            "AUGSLT",    ""  ],
  246.                ["~==:=",           "AUGSNE",    ""  ],
  247.                ["\\",              "BACKSLASH", "b" ],
  248.                ["!",               "BANG",      "b" ],
  249.                ["|",               "BAR",       "b" ],
  250.                ["^",               "CARET",     "b" ],
  251.                ["^:=",             "CARETASGN", "b" ],
  252.                [":",               "COLON",     ""  ],
  253.                [",",               "COMMA",     ""  ],
  254.                ["||",              "CONCAT",    "b" ],
  255.                        ["||:=",            "CONCATASGN",""  ],
  256.                ["&",               "CONJUNC",   "b" ],
  257.                [".",               "DOT",       "b" ],
  258.                ["--",              "DIFF",      "b" ],
  259.                ["--:=",            "DIFFASGN",  ""  ],
  260.                ["===",             "EQUIV",     "b" ],
  261.                ["**",              "INTER",     "b" ],
  262.                ["**:=",            "INTERASGN", ""  ],
  263.                ["{",               "LBRACE",    "b" ],
  264.                ["[",               "LBRACK",    "b" ],
  265.                ["|||",             "LCONCAT",   "b" ],
  266.                ["|||:=",           "LCONCATASGN","" ],
  267.                ["==",              "LEXEQ",     "b" ],
  268.                [">>=",             "LEXGE",     ""  ],
  269.                [">>",              "LEXGT",     ""  ],
  270.                ["<<=",             "LEXLE",     ""  ],
  271.                ["<<",              "LEXLT",     ""  ],
  272.                ["~==",             "LEXNE",     "b" ],
  273.                ["(",               "LPAREN",    "b" ],
  274.                ["-:",              "MCOLON",    ""  ],
  275.                ["-",               "MINUS",     "b" ],
  276.                ["-:=",             "MINUSASGN", ""  ],
  277.                ["%",               "MOD",       ""  ],
  278.                ["%:=",             "MODASGN",   ""  ],
  279.                ["~===",            "NOTEQUIV",  "b" ],
  280.                ["=",               "NUMEQ",     "b" ],
  281.                [">=",              "NUMGE",     ""  ],
  282.                [">",               "NUMGT",     ""  ],
  283.                ["<=",              "NUMLE",     ""  ],
  284.                ["<",               "NUMLT",     ""  ],
  285.                ["~=",              "NUMNE",     "b" ],
  286.                ["+:",              "PCOLON",    ""  ],
  287.                ["+",               "PLUS",      "b" ],
  288.                ["+:=",             "PLUSASGN",  ""  ],
  289.                ["?",               "QMARK",     "b" ],
  290.                ["<-",              "REVASSIGN", ""  ],
  291.                ["<->",             "REVSWAP",   ""  ],
  292.                ["}",               "RBRACE",    "e" ],
  293.                ["]",               "RBRACK",    "e" ],
  294.                [")",               "RPAREN",    "e" ],
  295.                [";",               "SEMICOL",   ""  ],
  296.                ["?:=",             "SCANASGN",  ""  ],
  297.                ["/",               "SLASH",     "b" ],
  298.                ["/:=",             "SLASHASGN", ""  ],
  299.                ["*",               "STAR",      "b" ],
  300.                ["*:=",             "STARASGN",  ""  ],
  301.                [":=:",             "SWAP",      ""  ],
  302.                ["~",               "TILDE",     "b" ],
  303.                ["++",              "UNION",     "b" ],
  304.                ["++:=",            "UNIONASGN", ""  ],
  305.                ["$(",              "LBRACE",    "b" ],
  306.                ["$)",              "RBRACE",    "e" ],
  307.                ["$<",              "LBRACK",    "b" ],
  308.                ["$>",              "RBRACK",    "e" ],
  309.                ["$",               "RHSARG",    "b" ],
  310.                ["%$(",             "BEGGLOB",   "b" ],
  311.                ["%$)",             "ENDGLOB",   "e" ],
  312.                ["%{",              "BEGGLOB",   "b" ],
  313.                ["%}",              "ENDGLOB",   "e" ],
  314.                ["%%",              "NEWSECT",   "be"]]
  315.  
  316.     # static be_tbl, reserved_tbl
  317.     reserved_tbl := table()
  318.     every elem := !reserveds do
  319.         insert(reserved_tbl, elem[1], elem[2])
  320.     be_tbl := table()
  321.     every elem := !primitives | !reserveds | !operators do {
  322.         insert(be_tbl, elem[2], elem[3])
  323.     }
  324.     }
  325.  
  326.     /getchar   := create {
  327.     line_number := 0
  328.     ! ( 1(!stream, line_number +:=1) || "\n" )
  329.     }
  330.     whitespace := ' \t'
  331.     /next_c    := @getchar | {
  332.     if \stream then
  333.         return TOK("EOFX")
  334.     else fail
  335.     }
  336.  
  337.     repeat {
  338.     case next_c of {
  339.  
  340.         "."      : {
  341.         # Could be a real literal *or* a dot operator.  Check
  342.         # following character to see if it's a digit.  If so,
  343.         # it's a real literal.  We can only get away with
  344.         # doing the dot here because it is not a substring of
  345.         # any longer identifier.  If this gets changed, we'll
  346.         # have to move this code into do_operator().
  347.         #
  348.         last_token := do_dot(getchar)
  349.         suspend last_token
  350. #        write(&errout, "next_c == ", image(next_c))
  351.         next
  352.         }
  353.  
  354.         "\n"     : {
  355.         # If do_newline fails, it means we're at the end of
  356.         # the input stream, and we should break out of the
  357.         # repeat loop.
  358.         #
  359.         every last_token := do_newline(getchar, last_token, be_tbl)
  360.         do suspend last_token
  361.         if next_c === &null then break
  362.         next
  363.         }
  364.  
  365.         "\#"     : {
  366.         # Just a comment.  Strip it by reading every character
  367.         # up to the next newline.  The global var next_c
  368.         # should *always* == "\n" when this is done.
  369.         #
  370.         do_number_sign(getchar)
  371. #        write(&errout, "next_c == ", image(next_c))
  372.         next
  373.         }
  374.  
  375.         "\""    : {
  376.         # Suspend as STRINGLIT everything from here up to the
  377.         # next non-backslashed quotation mark, inclusive
  378.         # (accounting for the _ line-continuation convention).
  379.         #
  380.         last_token := do_quotation_mark(getchar)
  381.         suspend last_token
  382. #        write(&errout, "next_c == ", image(next_c))
  383.         next
  384.         }
  385.  
  386.         "'"     : {
  387.         # Suspend as CSETLIT everything from here up to the
  388.         # next non-backslashed apostrophe, inclusive.
  389.         #
  390.         last_token := do_apostrophe(getchar)
  391.         suspend last_token
  392. #        write(&errout, "next_c == ", image(next_c))
  393.         next
  394.         }
  395.  
  396.         &null   : stop("iparse_tokens (lexer):  unexpected EOF")
  397.  
  398.         default : {
  399.         # If we get to here, we have either whitespace, an
  400.         # integer or real literal, an identifier or reserved
  401.         # word (both get handled by do_identifier), or an
  402.         # operator.  The question of which we have can be
  403.         # determined by checking the first character.
  404.         #
  405.         if any(whitespace, next_c) then {
  406.             # Like all of the TOK forming procedures,
  407.             # do_whitespace resets next_c.
  408.             do_whitespace(getchar, whitespace)
  409.             # don't suspend any tokens
  410.             next
  411.         }
  412.         if any(&digits, next_c) then {
  413.             last_token := do_digits(getchar)
  414.             suspend last_token
  415.             next
  416.         }
  417.         if any(&letters ++ '_', next_c) then {
  418.             last_token := do_identifier(getchar, reserved_tbl)
  419.             suspend last_token
  420.             next
  421.         }
  422. #        write(&errout, "it's an operator")
  423.         last_token := do_operator(getchar, operators)
  424.         suspend last_token
  425.         next
  426.         }
  427.     }
  428.     }
  429.  
  430.     # If stream argument is nonnull, then we are in the top-level
  431.     # iparse_tokens().  If not, then we are in a recursive call, and
  432.     # we should not emit all this end-of-file crap.
  433.     #
  434.     if \stream then {
  435.     return TOK("EOFX")
  436.     }
  437.     else fail
  438.  
  439. end
  440.  
  441.  
  442. #
  443. #  do_dot:  coexpression -> TOK record
  444. #           getchar      -> t
  445. #
  446. #      Where getchar is the coexpression that produces the next
  447. #      character from the input stream and t is a token record whose
  448. #      sym field contains either "REALLIT" or "DOT".  Essentially,
  449. #      do_dot checks the next char on the input stream to see if it's
  450. #      an integer.  Since the preceding char was a dot, an integer
  451. #      tips us off that we have a real literal.  Otherwise, it's just
  452. #      a dot operator.  Note that do_dot resets next_c for the next
  453. #      cycle through the main case loop in the calling procedure.
  454. #
  455. procedure do_dot(getchar)
  456.  
  457.     local token
  458.     # global next_c
  459.  
  460. #    write(&errout, "it's a dot")
  461.  
  462.     # If dot's followed by a digit, then we have a real literal.
  463.     #
  464.     if any(&digits, next_c := @getchar) then {
  465. #    write(&errout, "dot -> it's a real literal")
  466.     token := "." || next_c
  467.     while any(&digits, next_c := @getchar) do
  468.         token ||:= next_c
  469.     if token ||:= (next_c == ("e"|"E")) then {
  470.         while (next_c := @getchar) == "0"
  471.         while any(&digits, next_c) do {
  472.         token ||:= next_c
  473.         next_c = @getchar
  474.         }
  475.     }
  476.     return TOK("REALLIT", token)
  477.     }
  478.  
  479.     # Dot not followed by an integer; so we just have a dot operator,
  480.     # and not a real literal.
  481.     #
  482. #    write(&errout, "dot -> just a plain dot")
  483.     return TOK("DOT", ".")
  484.     
  485. end
  486.  
  487.  
  488. #
  489. #  do_newline:  coexpression x TOK record x table -> TOK records
  490. #               (getchar, last_token, be_tbl)     -> Ts (a generator)
  491. #
  492. #      Where getchar is the coexpression that returns the next
  493. #      character from the input stream, last_token is the last TOK
  494. #      record suspended by the calling procedure, be_tbl is a table of
  495. #      tokens and their "beginner/ender" status, and Ts are TOK
  496. #      records.  Note that do_newline resets next_c.  Do_newline is a
  497. #      mess.  What it does is check the last token suspended by the
  498. #      calling procedure to see if it was a beginner or ender.  It
  499. #      then gets the next token by calling iparse_tokens again.  If
  500. #      the next token is a beginner and the last token is an ender,
  501. #      then we have to suspend a SEMICOL token.  In either event, both
  502. #      the last and next token are suspended.
  503. #
  504. procedure do_newline(getchar, last_token, be_tbl)
  505.  
  506.     local next_token
  507.     # global next_c
  508.  
  509. #    write(&errout, "it's a newline")
  510.  
  511.     # Go past any additional newlines.
  512.     #
  513.     while next_c == "\n" do {
  514.         # NL can be the last char in the getchar stream; if it *is*,
  515.     # then signal that it's time to break out of the repeat loop
  516.     # in the calling procedure.
  517.     #
  518.     next_c := @getchar | {
  519.         next_c := &null
  520.         fail
  521.     }
  522.     suspend TOK(&null, next_c == "\n")
  523.     }
  524.  
  525.     # If there was a last token (i.e. if a newline wasn't the first
  526.     # character of significance in the input stream), then check to
  527.     # see if it was an ender.  If so, then check to see if the next
  528.     # token is a beginner.  If so, then suspend a TOK("SEMICOL")
  529.     # record before suspending the next token.
  530.     #
  531.     if find("e", be_tbl[(\last_token).sym]) then {
  532. #    write(&errout, "calling iparse_tokens via do_newline")
  533. #    &trace := -1
  534.     # First arg to iparse_tokens can be null here.
  535.     \ (next_token := iparse_tokens(&null, getchar)).sym
  536.     if \next_token then {
  537. #        write(&errout, "call of iparse_tokens via do_newline yields ",
  538. #          ximage(next_token))
  539.         if find("b", be_tbl[next_token.sym])
  540.         then suspend TOK("SEMICOL", "\n")
  541.         #
  542.         # See below.  If this were like the real Icon parser,
  543.         # the following line would be commented out.
  544.         #
  545.         else suspend TOK(&null, "\n")
  546.         return next_token
  547.     }
  548.     else {
  549.         #
  550.         # If this were a *real* Icon tokenizer, it would not emit
  551.         # any record here, but would simply fail.  Instead, we'll
  552.         # emit a dummy record with a null sym field.
  553.         #
  554.         return TOK(&null, "\n")
  555. #           &trace := 0
  556. #        fail
  557.     }
  558.     }
  559.  
  560.     # See above.  Again, if this were like Icon's own tokenizer, we
  561.     # would just fail here, and not return any TOK record.
  562.     #
  563. #   &trace := 0
  564.     return TOK(&null, "\n")
  565. #   fail
  566.  
  567. end
  568.  
  569.  
  570. #
  571. #  do_number_sign:  coexpression -> &null
  572. #                   getchar      -> 
  573. #
  574. #      Where getchar is the coexpression that pops characters off the
  575. #      main input stream.  Sets the global variable next_c.  This
  576. #      procedure simply reads characters until it gets a newline, then
  577. #      returns with next_c == "\n".  Since the starting character was
  578. #      a number sign, this has the effect of stripping comments.
  579. #
  580. procedure do_number_sign(getchar)
  581.  
  582.     # global next_c
  583.  
  584. #    write(&errout, "it's a number sign")
  585.     while next_c ~== "\n" do {
  586.     next_c := @getchar
  587.     }
  588.  
  589.     # Return to calling procedure to cycle around again with the new
  590.     # next_c already set.  Next_c should always be "\n" at this point.
  591.     return
  592.  
  593. end
  594.  
  595.  
  596. #
  597. #  do_quotation_mark:  coexpression -> TOK record
  598. #                      getchar      -> t
  599. #
  600. #      Where getchar is the coexpression that yields another character
  601. #      from the input stream, and t is a TOK record with "STRINGLIT"
  602. #      as its sym field.  Puts everything upto and including the next
  603. #      non-backslashed quotation mark into the str field.  Handles the
  604. #      underscore continuation convention.
  605. #
  606. procedure do_quotation_mark(getchar)
  607.  
  608.     local token
  609.     # global next_c
  610.  
  611.     # write(&errout, "it's a string literal")
  612.     token := "\""
  613.     next_c := @getchar
  614.     repeat {
  615.     if next_c == "\n" & token[-1] == "_" then {
  616.         token := token[1:-1]
  617.         while any('\t ', next_c := @getchar)
  618.         next
  619.     } else {
  620.         if slshupto('"', token ||:= next_c, 2)
  621.         then {
  622.         next_c := @getchar
  623.         # resume outermost (repeat) loop in calling procedure,
  624.         # with the new (here explicitly set) next_c
  625.         return TOK("STRINGLIT", token)
  626.         }
  627.         next_c := @getchar
  628.     }
  629.     }
  630.  
  631. end
  632.  
  633.  
  634. #
  635. #  do_apostrophe:  coexpression -> TOK record
  636. #                  getchar      -> t
  637. #
  638. #      Where getchar is the coexpression that yields another character
  639. #      from the input stream, and t is a TOK record with "CSETLIT"
  640. #      as its sym field.  Puts everything upto and including the next
  641. #      non-backslashed apostrope into the str field.
  642. #
  643. procedure do_apostrophe(getchar)
  644.  
  645.     local token
  646.     # global next_c
  647.  
  648. #   write(&errout, "it's a cset literal")
  649.     token := "'"
  650.     next_c := @getchar
  651.     repeat {
  652.     if next_c == "\n" & token[-1] == "_" then {
  653.         token := token[1:-1]
  654.         while any('\t ', next_c := @getchar)
  655.         next
  656.     } else {
  657.         if slshupto("'", token ||:= next_c, 2)
  658.         then {
  659.         next_c := @getchar
  660.         # Return & resume outermost containing loop in calling
  661.         # procedure w/ new next_c.
  662.         return TOK("CSETLIT", token)
  663.         }
  664.         next_c := @getchar
  665.     }
  666.     }
  667.  
  668. end
  669.  
  670.  
  671. #
  672. #  do_digits:  coexpression -> TOK record
  673. #              getchar      -> t
  674. #
  675. #      Where getchar is the coexpression that produces the next char
  676. #      on the input stream, and where t is a TOK record containing
  677. #      either "REALLIT" or "INTLIT" in its sym field, and the text of
  678. #      the numeric literal in its str field.
  679. #
  680. procedure do_digits(getchar)
  681.  
  682.     local token, tok_record, extras, digits, over
  683.     # global next_c
  684.  
  685.     # For bases > 16
  686.     extras := "AaBbCcDdEeFfGgHhIiJjKkLlMmNnOoPpQqRrSsTtUuVvWwXxYyZz"
  687.     # Assume integer literal until proven otherwise....
  688.     tok_record := TOK("INTLIT")
  689.  
  690. #   write(&errout, "it's an integer or real literal")
  691.     token := ("0" ~== next_c) | ""
  692.     while any(&digits, next_c := @getchar) do
  693.     token ||:= next_c
  694.     if token ||:= (next_c == ("R"|"r")) then {
  695.     digits := &digits
  696.     if over := ((10 < token[1:-1]) - 10) * 2 then
  697.         digits ++:= extras[1:over+1] | extras
  698.     next_c := @getchar
  699.     if next_c == "-" then {
  700.         token ||:= next_c
  701.         next_c := @getchar
  702.     }
  703.     while any(digits, next_c) do {
  704.         token ||:= next_c
  705.         next_c := @getchar
  706.     }
  707.     } else {
  708.     if token ||:= (next_c == ".") then {
  709.         while any(&digits, next_c := @getchar) do
  710.         token ||:= next_c
  711.         tok_record := TOK("REALLIT")
  712.     }
  713.     if token ||:= (next_c == ("e"|"E")) then {
  714.         next_c := @getchar
  715.         if next_c == "-" then {
  716.         token ||:= next_c
  717.         next_c := @getchar
  718.         }
  719.         while any(&digits, next_c) do {
  720.         token ||:= next_c
  721.         next_c := @getchar
  722.         }
  723.         tok_record := TOK("REALLIT")
  724.     }
  725.     }
  726.     tok_record.str := ("" ~== token) | "0"
  727.     return tok_record
  728.     
  729. end
  730.  
  731.  
  732. #
  733. #  do_whitespace:  coexpression x cset  -> &null
  734. #                  getchar x whitespace -> &null
  735. #
  736. #      Where getchar is the coexpression producing the next char on
  737. #      the input stream.  Do_whitespace just repeats until it finds a
  738. #      non-whitespace character, whitespace being defined as
  739. #      membership of a given character in the whitespace argument (a
  740. #      cset). 
  741. #
  742. procedure do_whitespace(getchar, whitespace)
  743.  
  744. #   write(&errout, "it's junk")
  745.     while any(whitespace, next_c) do
  746.     next_c := @getchar
  747.     return
  748.  
  749. end
  750.  
  751.  
  752. #
  753. #  do_identifier:  coexpression x table    -> TOK record
  754. #                  (getchar, reserved_tbl) -> t
  755. #
  756. #      Where getchar is the coexpression that pops off characters from
  757. #      the input stream, reserved_tbl is a table of reserved words
  758. #      (keys = the string values, values = the names qua symbols in
  759. #      the grammar), and t is a TOK record containing all subsequent
  760. #      letters, digits, or underscores after next_c (which must be a
  761. #      letter or underscore).  Note that next_c is global and gets
  762. #      reset by do_identifier.
  763. #
  764. procedure do_identifier(getchar, reserved_tbl)
  765.  
  766.     local token
  767.     # global next_c
  768.  
  769. #   write(&errout, "it's an indentifier")
  770.     token := next_c
  771.     while any(&letters ++ &digits ++ '_', next_c := @getchar)
  772.     do token ||:= next_c
  773.     return TOK(\reserved_tbl[token], token) | TOK("IDENT", token)
  774.     
  775. end
  776.  
  777.  
  778. #
  779. #  do_operator:  coexpression x list  -> TOK record
  780. #                (getchar, operators) -> t
  781. #
  782. #     Where getchar is the coexpression that produces the next
  783. #     character on the input stream, operators is the operator list,
  784. #     and where t is a TOK record describing the operator just
  785. #     scanned.  Calls recognop, which creates a DFSA to recognize
  786. #     valid Icon operators.  Arg2 (operators) is the list of lists
  787. #     containing valid Icon operator string values and names (see
  788. #     above).
  789. #
  790. procedure do_operator(getchar, operators)
  791.  
  792.     local token, elem
  793.  
  794.     token := next_c
  795.  
  796.     # Go until recognop fails.
  797.     while elem := recognop(operators, token, 1) do
  798.     token ||:= (next_c := @getchar)
  799. #   write(&errout, ximage(elem))
  800.     if *\elem = 1 then
  801.     return TOK(elem[1][2], elem[1][1])
  802.     else fail
  803.  
  804. end
  805.  
  806.  
  807. record dfstn_state(b, e, tbl)
  808. record start_state(b, e, tbl, master_list)
  809. #
  810. #  recognop: list x string x integer -> list
  811. #            (l, s, i)               -> l2
  812. #
  813. #     Where l is the list of lists created by the calling procedure
  814. #     (each element contains a token string value, name, and
  815. #     beginner/ender string), where s is a string possibly
  816. #     corresponding to a token in the list, where i is the position in
  817. #     the elements of l where the operator string values are recorded,
  818. #     and where l2 is a list of elements from l that contain operators
  819. #     for which string s is an exact match.  Fails if there are no
  820. #     operators that s is a prefix of, but returns an empty list if
  821. #     there just aren't any that happen to match exactly.
  822. #
  823. #      What this does is let the calling procedure just keep adding
  824. #      characters to s until recognop fails, then check the last list
  825. #      it returned to see if it is of length 1.  If it is, then it
  826. #      contains list with the vital stats for the operator last
  827. #      recognized.  If it is of length 0, then string s did not
  828. #      contain any recognizable operator.
  829. #
  830. procedure recognop(l, s, i)
  831.  
  832.     local   current_state, master_list, c, result, j
  833.     static  dfstn_table
  834.     initial dfstn_table := table()
  835.  
  836.     /i := 1
  837.     # See if we've created an automaton for l already.
  838.     /dfstn_table[l] := start_state(1, *l, &null, &null) & {
  839.     dfstn_table[l].master_list := sortf(l, i)
  840.     }
  841.  
  842.     current_state := dfstn_table[l]
  843.     # Save master_list, as current_state will change later on.
  844.     master_list   := current_state.master_list
  845.  
  846.     s ? {
  847.     while c := move(1) do {
  848.  
  849.         # Null means that this part of the automaton isn't
  850.         # complete.
  851.         #
  852.         if /current_state.tbl then
  853.         create_arcs(master_list, i, current_state, &pos)
  854.  
  855.         # If the table has been clobbered, then there are no arcs
  856.         # leading out of the current state.  Fail.
  857.         #
  858.         if current_state.tbl === 0 then
  859.         fail
  860.         
  861. #        write(&errout, "c = ", image(c))
  862. #        write(&errout, "table for current state = ", 
  863. #          ximage(current_state.tbl))
  864.  
  865.         # If we get to here, the current state has arcs leading
  866.         # out of it.  See if c is one of them.  If so, make the
  867.         # node to which arc c is connected the current state.
  868.         # Otherwise fail.
  869.         #
  870.         current_state := \current_state.tbl[c] | fail
  871.     }
  872.     }
  873.  
  874.     # Return possible completions.
  875.     #
  876.     result := list()
  877.     every j := current_state.b to current_state.e do {
  878.     if *master_list[j][i] = *s then
  879.         put(result, master_list[j])
  880.     }
  881.     # return empty list if nothing the right length is found
  882.     return result
  883.  
  884. end
  885.  
  886.  
  887. #
  888. #  create_arcs:  fill out a table of arcs leading out of the current
  889. #                state, and place that table in the tbl field for
  890. #                current_state
  891. #
  892. procedure create_arcs(master_list, field, current_state, POS)
  893.  
  894.     local elem, i, first_char, old_first_char
  895.  
  896.     current_state.tbl := table()
  897.     old_first_char := ""
  898.     
  899.     every elem := master_list[i := current_state.b to current_state.e][field]
  900.     do {
  901.     
  902.     # Get the first character for the current position (note that
  903.     # we're one character behind the calling routine; hence
  904.     # POS-1).
  905.     #
  906.     first_char := elem[POS-1] | next
  907.     
  908.     # If we have a new first character, create a new arc out of
  909.     # the current state.
  910.     #
  911.     if first_char ~== old_first_char then {
  912.         # Store the start position for the current character.
  913.         current_state.tbl[first_char] := dfstn_state(i)
  914.         # Store the end position for the old character.
  915.         (\current_state.tbl[old_first_char]).e := i-1
  916.         old_first_char := first_char
  917.     }
  918.     }
  919.     (\current_state.tbl[old_first_char]).e := i
  920.  
  921.     # Clobber table with 0 if no arcs were added.
  922.     current_state.tbl := (*current_state.tbl = 0)
  923.     return current_state
  924.  
  925. end
  926.