Usenet 1994 October/usenetsourcesnewsgroupsinfomagicoctober1994disk1.iso/altsrc/articles/11185

Text File | 1994-08-27 | 32KB | 1,253 lines

Newsgroups: alt.sources
Path: wupost!howland.reston.ans.net!vixen.cso.uiuc.edu!uchinews!quads!goer
From: [e-mail] (Richard L. Goerwitz)
Subject: IBPAG2, part 06
Message-ID: <[e-mail]>
Sender: [e-mail] (News System)
Reply-To: [e-mail]
Organization: University of Chicago
References: <[e-mail]>
Date: Sun, 28 Aug 1994 04:21:30 GMT
Lines: 1240

#!/bin/sh
# this is part 6 of a multipart archive
# do not concatenate these parts, unpack them in order with /bin/sh
# file iiglrpar.lib continued
#
CurArch=6
if test ! -r s2_seq_.tmp
then echo "Please unpack part 1 first!"
     exit 1; fi
( read Scheck
  if test "$Scheck" != $CurArch
  then echo "Please unpack part $Scheck next!"
       exit 1;
  else exit 0; fi
) < s2_seq_.tmp || exit 1
sed 's/^X//' << 'SHAR_EOF' >> iiglrpar.lib
X            }
X            if find("isolate", tmp) then {
X                # Prune all but the current parser.
X            $$ifdef IIDEBUG
X                write(&errout, "+++ isolating by pruning")
X                while p := pop(actives) do
X                $iidebug("p", token, ruleno, p)
X                while p := pop(reducers) do
X                $iidebug("p", token, ruleno, p)
X                while p := pop(shifters) do
X                $iidebug("p", token, ruleno, p)
X                while p := pop(barfers) do
X                $iidebug("p", token, ruleno, p)
X            $$else
X                while pop(actives)
X                while pop(reducers)
X                while pop(shifters)
X                while pop(barfers)
X            $$endif    #IIDEBUG
X            }
X            if find("accept", tmp) then {
X                $iidebug("a", token, ruleno, parser)
X                suspend arglist[-1] | &null
X                next
X            }
X            }
X            # Finally, push the result!
X            result := arglist[-1] | &null
X            push(parser.value_stack, result)
X            $iidebug("r", token, ruleno, parser)
X            put(actives, parser)
X        }
X        }
X        # If there is no action code for this rule...
X        else {
X        # ...push the value of the last RHS arg.
X        # For 0-length e-productions, push &null.
X        result := arglist[-1] | &null
X        push(parser.value_stack, result)
X        $iidebug("r", token, ruleno, parser)
X        put(actives, parser)
X        }
X    }
X    }
X
Xend
X
X
X#
X# perform_shifts
X#
Xprocedure $perform_shifts(token, actives, shifters)
X
X    local parser, ruleno
X
X    *shifters = 0 & fail
X
X    while parser := pop(shifters) do {
X    #
X    # One of the iidirectives is iiclearin, i.e. clear the input
X    # token and try again on the next token.
X    #
X    \parser.clearin := &null & {
X        put(actives, parser)
X        next
X    }
X    parser.action ? {
X        #
X            # Shift action format, e.g. s2.1 = shift and go to state 2
X        # by rule 1.
X            #
X        move(1)
X        push(parser.state_stack, integer(tab(find("."))))
X        push(parser.value_stack, $iilval)
X        ="."; ruleno := integer(tab(many(&digits)))
X        pos(0) | stop("malformed action:  ", act)
X        #
X        # If, while recovering, we can manage to shift 3 tokens,
X        # then we consider ourselves resynchronized.  Don't count
X        # the error token (-1).
X        #
X        if token ~= -1 then {
X        if \parser.recover_shifts +:= 1 then {
X            # 3 shifts make a successful recovery
X            if parser.recover_shifts > 4 then {
X            parser.recover_shifts := &null
X            parser.discards := 0
X            }
X        }
X        }
X        $iidebug("s", token, ruleno, parser)
X    }
X    put(actives, parser)
X    }
X
X    return
X
Xend
X
X
X#
X# perform_barfs
X#
Xprocedure $perform_barfs(atbl, token, actives, barfers, fail_on_error)
X
X    #
X    # Note how this procedure has its own local reducers and shifters
X    # list.  These are *not* passed from the parent environment!
X    #
X    local parser, count, reducers, shifters, recoverers
X
X    # To hold the list of parsers that need to shift error (-1).
X    recoverers := list()
X
X    count := 0
X    while parser := pop(barfers) do {
X    count +:= 1
X    if \parser.recover_shifts := 0 then {
X        #
X        # If we're already in an error state, discard the
X        # current token, and increment the number of discards
X        # we have made.  500 is too many; abort.
X        #
X        if (parser.discards +:= 1) > 500 then {
X        if proc($iierror)
X        then $iierror("fatal error: can't resynchronize")
X        else write(&errout, "fatal error: can't resynchronize")
X        if \fail_on_error then fail
X        else stop()
X        }
X        # try again on this one with the next token
X        put(actives, parser)
X    } else {
X        parser.errors +:= 1 # error count for this parser
X        parser.discards := parser.recover_shifts := 0
X        # If this is our first erroneous parser, print a message.
X        if count = 1 then {
X        if proc($iierror)
X        then $iierror(image(\$ttbl[token]) | image(token))
X        else write(&errout, "parse error")
X        }
X        #
X        # If error appears in a RHS, pop states until we get to a
X        # spot where error (-1) is a valid lookahead token:
X        #
X        if \$ttbl[-1] then {
X        until *parser.state_stack = 0 do {
X            if \atbl[-1][parser.state_stack[1]] then {
X            put(recoverers, parser)
X            break next
X            } else pop(parser.state_stack) & pop(parser.value_stack)
X        }
X        }
X        # If we get past here, the stack is now empty or there
X        # are no error productions.  Abandon this parser.
X        $iidebug("p", token, &null, parser)
X    }
X    }
X
X    # Parsers still recovering are in the actives list; those that
X    # need to shift error (-1) are in the recoverers list.  The
X    # following turns recoverers into actives:
X    #
X    if *recoverers > 0 then {
X    reducers := list()    # a scratch list
X    shifters := list()    # ditto
X    until *recoverers = *reducers = 0 do {
X        $$ifdef AUTO_PRUNE
X        auto_prune(actives)
X        $$endif
X        suspend $ib_action(atbl, -1, recoverers, shifters,
X                   reducers, barfers)
X        suspend $perform_reductions(-1, recoverers, shifters,
X                    reducers, barfers)
X    }
X    $perform_shifts(-1, recoverers, shifters)
X    every put(actives, !recoverers)
X    }
X    #
X    # If there were no recoverers, we've already shifted the error
X    # token, and are discarding tokens from the input stream.  Note
X    # that if one parser was recovering, they *all* should be
X    # recovering, since if one was not recovering, it the erroneous
X    # parsers should all have been discarded by the calling proc.
X    #
X    else
X    $discard_token := 1
X
Xend
X
X
X$$ifdef IIDEBUG
X
Xrecord production(LHS, RHS, POS, LOOK, no, prec, assoc)
X#
X# iidebug
X#
Xprocedure $iidebug(action, token, ruleno, parser)
X
X    local p, t, state
X    static rule_list
X    initial {
X    rule_list := $rule_list_insertion_point
X    $$line 693 "iiglrpar.lib"
X    }
X
X    write(&errout, "---  In parser ", image(parser), ":")
X    case action of {
X    "a"     : writes(&errout, "accepting ")    &
X        state := parser.state_stack[1]
X    "e"     : writes(&errout, "***ERROR***\n") &
X          write(&errout, "recover shifts = ",
X             parser.recover_shifts) &
X          write(&errout, "discarded tokens = ",
X             parser.discards) &
X              writes(&errout, "error action ") &
X        state := parser.state_stack[1]
X    "p"     : writes(&errout, "***PRUNING***\n") &
X              writes(&errout, "prune action ") &
X        state := parser.state_stack[1]
X    "r"     : writes(&errout, "reducing ")     &
X        state := parser.state_stack[2]
X    "s"     : writes(&errout, "shifting ")     &
X        state := parser.state_stack[2]
X    default : stop("malformed action argument to iidebug")
X    }
X
X    t := image(token) || (" (" || (\$ttbl[token] | "unknown") || ")")
X    writes(&errout, "on lookahead ", t, ", in state ", state)
X    if \ruleno then {
X    (p := !rule_list).no === ruleno &
X        write(&errout, "; rule ", $production_2_string(p, $ttbl))
X    }
X    # for errors, ruleno is null
X    else write(&errout)
X
X    write(&errout, "    state stack now: ")
X    every write(&errout, "\t", image(!parser.state_stack))
X    write(&errout, "    value stack now: ")
X    if *parser.value_stack > 0
X    then every write(&errout, "\t", image(!parser.value_stack))
X    else write(&errout, "\t(empty)")
X
X    return
X
Xend
X
X
X#
X# production_2_string:  production record -> string
X#                       p                 -> s
X#
X#     Stringizes an image of the LHS and RHS of production p in
X#     human-readable form.
X#
Xprocedure $production_2_string(p, ibtoktbl)
X
X    local s, m, t
X
X    s := image(p.LHS) || " -> "
X    every m := !p.RHS do {
X    if t := \ (\ibtoktbl)[m]
X    then s ||:= t || " "
X    else s ||:= image(m) || " "
X    }
X    # if the POS field is nonnull, print it
X    s ||:= "(POS = " || image(\p.POS) || ") "
X    # if the LOOK field is nonnull, print it, too
X    s ||:= "lookahead = " || image(\p.LOOK)
X
X    return trim(s)
X
Xend
X
X#
X# show_new_forest
X#
Xprocedure show_new_forest(msg, actives, shifters, reducers, barfers, parser)
X    write(&errout, msg)
X    write(&errout, "    List of active parsers:")
X    every write(&errout, "\t", image(!actives))
X    every write(&errout, "\t", image(!shifters))
X    every write(&errout, "\t", image(!reducers))
X    every write(&errout, "\t", image(!barfers), " (error)")
X    write(&errout, "\tnew -> ", image(parser))
Xend
X$$endif                # IIDEBUG
X
X
X$$ifdef COMPRESSED_TABLES
X
X#
X# uncompress_action
X#
Xprocedure $uncompress_action()
X
X    local next_chunk, full_action
X
X    next_chunk := create ord(!&subject[&pos:0])
X    case $in_ib_bits(next_chunk, 2) of {
X    0: {
X        full_action := "s"
X        full_action ||:= $in_ib_bits(next_chunk, 11)
X        full_action ||:= "."
X        full_action ||:= $in_ib_bits(next_chunk, 11)
X        move(3)
X    }
X    1: {
X        full_action := "r"
X        full_action ||:= $in_ib_bits(next_chunk, 11)
X        full_action ||:= "<"
X        full_action ||:= $in_ib_bits(next_chunk, 11)
X        full_action ||:= ">"
X        full_action ||:= $in_ib_bits(next_chunk, 8)
X        move(4)
X    }
X        2: {
X        full_action := "a"
X        move(1)
X    }
X    } | fail
X
X    return full_action
X
Xend
X
X
X#
X# in_ib_bits:  like inbits (IPL), but with coexpression for file
X#
Xprocedure $in_ib_bits(next_chunk, len)
X
X    local i, byte, old_byte_mask
X    static old_byte, old_len, byte_length
X    initial {
X    old_byte := old_len := 0
X    byte_length := 8
X    }
X
X    old_byte_mask := (0 < 2^old_len - 1) | 0
X    old_byte := iand(old_byte, old_byte_mask)
X    i := ishift(old_byte, len-old_len)
X
X    len -:= (len > old_len) | {
X    old_len -:= len
X    return i
X    }
X
X    while byte := @next_chunk do {
X    i := ior(i, ishift(byte, len-byte_length))
X    len -:= (len > byte_length) | {
X        old_len := byte_length-len
X        old_byte := byte
X        return i
X    }
X    }
X
Xend
X
X$$endif                # COMPRESSED_TABLES
X
X#
X# fullcopy:  make full recursive copy of object obj
X#
Xprocedure $fullcopy(obj)
X
X    local retval, i, k
X
X    case type(obj) of {
X        "co-expression"  : return obj
X        "cset"           : return obj
X        "file"           : return obj
X        "integer"        : return obj
X        "list"           : {
X            retval := list(*obj)
X            every i := 1 to *obj do
X                retval[i] := $fullcopy(obj[i])
X            return retval
X        }
X        "null"           :  return &null
X        "procedure"      :  return obj
X        "real"           :  return obj
X        "set"            :  {
X            retval := set()
X            every insert(retval, $fullcopy(!obj))
X            return retval
X        }
X        "string"         :  return obj
X        "table"          :  {
X            retval := table(obj[[]])
X            every k := key(obj) do
X                insert(retval, $fullcopy(k), $fullcopy(obj[k]))
X            return retval
X        }
X        # probably a record; if not, we're dealing with a new
X        # version of Icon or a nonstandard implementation, and
X    # we're screwed
X        default          :  {
X            retval := copy(obj)
X            every i := 1 to *obj do
X                retval[i] := $fullcopy(obj[i])
X            return retval
X        }
X    }
X
Xend
X
X
X$$ifdef AUTO_PRUNE
Xprocedure auto_prune(actives)
X
X    new_actives := []
X    while parser1 := pop(actives) do {
X    every parser2 := actives[j := 1 to *actives] do {
X        parser1.state_stack[1] = parser2.state_stack[1] | next
X        *parser1.value_stack   = *parser2.value_stack   | next
X        every i := 1 to *parser1.value_stack do {
X        parser1.value_stack[i] === parser2.value_stack[i] |
X            break next
X        }
X        if parser1.errors < parser2.errors then
X        actives[j] := parser1
X        break next
X    }
X    put(new_actives, parser1)
X    }
X
X    every put(actives, !new_actives)
X    return &null
X
Xend
X$$endif                # AUTO_PRUNE
SHAR_EOF
chmod 0444 iiglrpar.lib || echo "restore of iiglrpar.lib fails"
sed 's/^X//' << 'SHAR_EOF' > sample.ibp &&
X#
X# Sample Ibpag2 grammar file.  Don't forget to compile me with string
X# invocation enabled under version 9 (icont -f s).
X#
X
X#
X# The code between %{ and %} gets copied directly.  Note the Iconish
X# comment syntax.
X#
X%{
X
X# Note:  If IIDEBUG is defined in the output file, debugging messages
X# about the stacks and actions get displayed.
X#
X$define IIDEBUG 1
X
X%}
X
X#
X# Here we declare the tokens returned by the lexical analyzer.
X# Precedences increase as we go on.  Note how (unlike YACC), tokens
X# are separated by commas.  Note also how UMINUS is used only for its
X# %prec later.
X#
X%token NUMBER
X%left '+', '-'
X%left '*', '/'
X%right UMINUS
X
X%%
X
X#
X# After this point, and up to the next %%, we have the grammar itself.
X# By default, the start symbol is the left-hand side of the first
X# rule.
X#
X
Xlines    :    lines, expr, '\n'    { write($2) }
X    |    lines, '\n'
X    |    epsilon     # Note use of epsilon/error tokens.
X    |    error, '\n'        {
X                      write("syntax error; try again:")
X                      # like YACC's yyerrok macro
X                      iierrok
X                    }
X    ;
X
Xexpr    :    expr, '+', expr    { return $1 + $3 }
X    |    expr, '-', expr    { return $1 - $3 }
X    |    expr, '*', expr    { return $1 * $3 }
X    |    expr, '/', expr    { return $1 / $3 }
X    |    '(', expr, ')'    { return $2 }
X    |    '-', expr %prec UMINUS    { return -$2 }
X    |    NUMBER        { return $1 }
X    ;
X
X%%
X
X#
X# From here on, code gets copied directly to the output file.  We are
X# no longer in the grammar proper.
X#
X
X#
X# The lexical analyzer must be called iilex, with the module name
X# appended (if there is one).  It must take one argument, infile (an
X# input stream).  It must be a generator, and fail on EOF (not return
X# something <= 0, as is the case for YACC + Lex).  Iilval holds the
X# literal string value of the token just suspended by iilex().
X#
Xprocedure iilex(infile)
X
X    local nextchar, c, num
X    initial {
X    # Here's where you'd initialize any %{ globals %} declared
X    # above.
X    }
X
X    nextchar := create !(!infile || "\n" || "\n")
X
X    c := @nextchar | fail
X    repeat {
X    if any(&digits, c) then {
X        if not (\num ||:= c) then
X        num := c
X    } else {
X        if iilval := \num then {
X        suspend NUMBER
X        num := &null
X        }
X        if any('+-*/()\n', c) then {
X        iilval := c
X        suspend ord(c)
X        } else {
X        if not any(' \t', c) then {
X            # deliberate error - will be handled later
X            suspend &null
X        }
X        }
X    }
X    c := @nextchar | break
X    }
X    if iilval := \num then {
X    return NUMBER
X    num := &null
X    }
X
Xend
X
Xprocedure main()
X    return iiparse(&input, 1)
Xend
SHAR_EOF
chmod 0444 sample.ibp || echo "restore of sample.ibp fails"
sed 's/^X//' << 'SHAR_EOF' > beta2ref.ibp &&
X#
X# Ibpag2 source file for OT betacode-to-English converter.
X#
X# "Betacode" is the name used for the markers that the Thesaurus
X# Linguae Graecae uses to segment texts into works, books, chapters,
X# verses, etc.  The Michigan-Claremont scan of the Hebrew OT (BHS)
X# uses a subset of the betacode "language."  This file contains a
X# parser for that language that converts it into human readable form.
X#
X# Reads the standard input.  Sends the original text, with betacode
X# markers converted to human-readable form, to the standard output.
X#
X
X%{
X
X# These need to be global, because all of the actions modify them.
X# Remember that the default scope for a variable used in an action is
X# that action.
X#
Xglobal betavals, blev
X
X%}
X
X%token INTVAL, STRVAL, LINE
X
X%%
X
Xbetalines    : betalines, betaline
X        | epsilon
X        ;
X
Xbetaline    : '~', cvalue, xvalue, yvalue, '\n'
X                    { if integer(betavals[2]) then {
X                          write(betavals[1], " ",
X                            betavals[2], ":",
X                            betavals[3])
X                      }
X                      blev := 4 # global
X                    }
X        | LINE, '\n'        { write($1) }
X        ;
X
Xcvalue        : 'a', value, 'b', value, 'c', value
X                    { betavals[blev := 1] := $6 }
X        | 'c', value        { betavals[blev := 1] := $2 }
X        | epsilon
X        ;
X
Xxvalue        : 'x', value        { betavals[blev := 2] := $2 }
X        | 'x'            { if integer(betavals[2])
X                      then betavals[blev := 2] +:= 1
X                      else betavals[blev := 2]  := 1
X                    }
X        | epsilon        { if blev < 2 then
X                          betavals[2] := 1
X                    }
X        ;
X
Xyvalue        : 'y', value        { betavals[blev := 3] := $2 }
X        | 'y'            { betavals[blev := 3] +:= 1 }
X        | epsilon        { if blev < 3 then
X                          betavals[3] := 1
X                    }
X        ;
X
Xvalue        : INTVAL        { return $1 }
X        | STRVAL        { return $1 }
X        ;
X
X
X%%
X
X
Xprocedure iilex(infile)
X
X    local line
X    # betavals is global
X    initial betavals := ["", 0, 0]
X
X    while line := read(infile) do {
X    line ? {
X        if ="~" then {
X        suspend ord("~")
X        until pos(0) do {
X            case move(1) of {
X            "a"     : suspend ord("a")
X            "b"     : suspend ord("b")
X            "c"     : suspend ord("c")
X            "x"     : suspend ord("x")
X            "y"     : suspend ord("y")
X            default : stop("betacode error:  ", line)
X            }
X            if ="\"" then {
X            iilval := tab(find("\""))
X            suspend STRVAL
X            move(1)
X            } else {
X            if iilval := integer(tab(many(&digits)))
X            then suspend INTVAL
X            }
X        }
X        suspend ord("\n")
X        }
X        else {
X        iilval := line
X        suspend LINE
X        suspend ord("\n")
X        }
X    }
X    }
X
Xend
X
X
Xprocedure main()
X    return iiparse(&input)
Xend
SHAR_EOF
chmod 0644 beta2ref.ibp || echo "restore of beta2ref.ibp fails"
sed 's/^X//' << 'SHAR_EOF' > iacc.ibp &&
X############################################################################
X#
X#    Name:     iacc.ibp
X#
X#    Title:     YACC-like front-end for Ibpag2 (experimental)
X#
X#    Author:     Richard L. Goerwitz
X#
X#    $Revision: 1.7 $
X#
X############################################################################
X#
X#  Summary:
X#
X#      Iacc is a YACC-like Ibpag2 preprocessor (very experimental).
X#  Iacc simply reads &input (assumed to be a YACC file, but with Icon
X#  code in the action fields), and writes an Ibpag2 file to &output.
X#
X############################################################################
X#
X#  Installation:
X#
X#      This file is not an Icon file, but rather an Ibpag2 file.  You
X#  must have Ibpag2 installed in order to run it.  To create the iacc
X#  executable, first create iacc.icn by typing "ibpag2 -f iacc.ibp -o
X#  iacc.icn," then compile iacc.icn as you would any other Icon file
X#  to create iacc (or on systems without direct execution, iacc.icx).
X#  Put more simply, iacc.ibp not only outputs Ibpag2 files, but is
X#  itself generated using Ibpag2 + icon{t,c}.  Note that when you com-
X#  pile iacc.icn under Icon version 9.0 or better you must enable
X#  string invocation (icont -f s).
X#
X############################################################################
X#
X#  Implementation notes:
X#
X#      Iacc uses an YACC grammar that is actually LR(2), and not
X#  LR(1), as Ipbag2 would normally require in standard mode.  Iacc
X#  obtains the additional token lookahead via the lexical analyzer.
X#  The place it uses that lookahead is when it sees an identifier.  If
X#  the next token is a colon, then it is the LHS of a rule (C_IDENT
X#  below); otherwise it's an IDENT in the RHS of some rule.  Crafting
X#  the lexical analyzer in this fashion makes semicolons totally
X#  superfluous (good riddance!), but it makes it necessary for the
X#  lexical analyzer to suspend some dummy tokens whose only purpose is
X#  to make sure that it doesn't eat up C or Icon action code while
X#  trying to satisfy the grammar's two-token lookahead requirements
X#  (see how RCURL and '}' are used below in the cdef and act
X#  productions).
X#
X#      Iacc does its work by making six basic changes to the input
X#  stream: 1) puts commas between tokens and symbols in rules, 2)
X#  removes superfluous union and type declarations/tags, 3) inserts
X#  "epsilon" into the RHS of empty rules, 4) turns "$$ = x" into
X#  "return x", 5) rewrites rules so that all actions appear at the end
X#  of a production, and 6) strips all comments.
X#
X#      Although Iacc is really meant for grammars with Icon action
X#  code, Iacc can, in fact, accept straight YACC files, with C action
X#  code.  There isn't much point to using it this way, though, since
X#  its output is not meant to be human readable.  Rather, it is to be
X#  passed directly to Ibpag2 for processing.  Iacc is simply a YACCish
X#  front end.  Its output can be piped directly to Ibpag2 in most
X#  cases:  iacc < infile.iac | ibpag2 > infile.icn.
X#
X############################################################################
X#
X#  Links: longstr, strings
X#  See also: ibpag2
X#
X############################################################################
X
X%{
X
Xlink strings, longstr
Xglobal newrules, lval, symbol_no
X
X%}
X
X# basic entities
X%token C_IDENT, IDENT    # identifiers and literals
X%token NUMBER            # [0-9]+
X
X# reserved words:  %type -> TYPE, %left -> LEFT, etc.
X%token LEFT, RIGHT, NONASSOC, TOKEN, PREC, TYPE, START, UNION
X
X# miscellaneous
X%token MARK   # %%
X%token LCURL  # %{
X%token RCURL  # dummy token used to start processing of C code
X
X%start yaccf
X
X%%
X
Xyaccf    : front, back
Xfront    : defs, MARK        { write(arg2) }
Xback    : rules, tail        {
X                  every write(!\newrules)
X                  if write(\arg2) then
X                      every write(!&input)
X                }
Xtail    : epsilon        { return &null }
X    | MARK            { return arg1 }
X
Xdefs    : epsilon
X    | defs, def        { write(\arg2) }
X    | defs, cdef        { write(\arg2) }
X
Xdef    : START, IDENT        { return arg1 || " " || arg2 }
X    | rword, tag, nlist    {
X                  if arg1 == "%type"
X                  then return &null
X                  else return arg1 || " " || arg3
X                }
Xcdef    : stuff, RCURL, RCURL    { return arg1 }
Xstuff    : UNION            { get_icon_code("%}"); return &null }
X    | LCURL            { return "%{ " || get_icon_code("%}") }
X
Xrword    : TOKEN    | LEFT | RIGHT | NONASSOC | TYPE
X
Xtag    : epsilon        { return &null }
X    | '<', IDENT, '>'    { return "<" || arg2 || ">" }
X
Xnlist    : nmno            { return arg1 }
X    | nlist, nmno        { return arg1 || ", " || arg2 }
X    | nlist, ',', nmno    { return arg1 || ", " || arg3 }
X
Xnmno    : IDENT            { return arg1 }
X    | IDENT, NUMBER        { return arg1 }
X
Xrules    : LHS, ':', RHS        { write(arg1, "\t: ", arg3) }
X    | rules, rule        { write(arg2) }
X
XRHS    : rbody, prec        { return arg1 || " " || arg2 }
X
Xrule    : LHS, '|', RHS        { return "\t| " || arg3 }
X    | LHS, ':', RHS        { return arg1 || "\t: " || arg3 }
X
XLHS    : C_IDENT        { symbol_no := 0 ; return arg1 }
X    | epsilon        { symbol_no := 0 }
X
Xrbody    : IDENT            { symbol_no +:= 1; return arg1 }
X    | act            { return "epsilon " || arg1 }
X    | middle, IDENT        { return arg1 || ", " || arg2 }
X    | middle, act        { return arg1 || " "  || arg2 }
X    | middle, ',', IDENT    { return arg1 || ", " || arg3 }
X    | epsilon        { return "epsilon" }
X
Xmiddle    : IDENT            { symbol_no +:= 1; return arg1 }
X    | act            { symbol_no +:= 1; return arg1 }
X    | middle, IDENT        { symbol_no +:= 1; return arg1 || ", "||arg2 }
X    | middle, ',', IDENT    { symbol_no +:= 1; return arg1 || ", "||arg3 }
X    | middle, act        {
X                  local i, l1, l2
X                  static actno
X                  initial { actno := 0; newrules := [] }
X                  actno +:= 1
X                  l1 := []; l2 := []
X                  every i := 1 to symbol_no do {
X                      every put(l1, ("arg"|"$") || i)
X                      if symbol_no-i = 0 then i := "0"
X                      else i := "-" || symbol_no - i
X                      every put(l2, ("$"|"$") || i)
X                  }
X                  put(newrules, "ACT_"|| actno ||
X                    "\t: epsilon "|| mapargs(arg2, l1, l2))
X                  symbol_no +:= 1
X                  return arg1 || ", " || "ACT_" || actno
X                }
X
Xact    : '{', cstuff, '}', '}'    { return "{" || arg2 }
Xcstuff    : epsilon        { return get_icon_code("}") }
X
Xprec    : epsilon        { return "" }
X    | PREC, IDENT        { return arg1 || arg2 }
X    | PREC, IDENT, act    { return arg1 || arg2 || arg3 }
X
X
X%%
X
X
Xprocedure iilex()
X
X    local t
X    static last_token, last_lval, colon
X    initial colon := ord(":")
X
X    every t := next_token() do {
X    iilval := last_lval
X    if \last_token then {
X        if t = colon then {
X        if last_token = IDENT
X        then suspend C_IDENT
X        else suspend last_token
X        } else
X        suspend last_token
X    }
X    last_token := t
X    last_lval := lval
X    }
X    iilval := last_lval
X    suspend \last_token
X
Xend
X
X
Xprocedure next_token()
X
X    local reserveds, UNreserveds, c, idchars, marks
X
X    reserveds := ["break","by","case","create","default","do",
X          "else","end","every","fail","global","if",
X          "initial","invocable","link","local","next",
X          "not","of","procedure","record","repeat",
X          "return","static","suspend","then","to","until",
X          "while"]
X
X    UNreserveds := ["break_","by_","case_","create_","default_","do_",
X            "else_","end_","every_","fail_","global_","if_",
X            "initial_","invocable_","link_","local_","next_",
X            "not_","of_","procedure_","record_","repeat_",
X            "return_","static_","suspend_","then_","to_",
X            "until_","while_"]
X
X    idchars := &letters ++ '._'
X    marks := 0
X
X    c := reads()
X    repeat {
X    lval := &null
X    case c of {
X        "#" : { do_icon_comment(); c := reads() | break }
X        "<" : { suspend ord(c); c := reads() | break }
X        ">" : { suspend ord(c); c := reads() | break }
X        ":" : { suspend ord(c); c := reads() | break }
X        "|" : { suspend ord(c); c := reads() | break }
X        "," : { suspend ord(c); c := reads() | break }
X        "{" : { suspend ord(c | "}" | "}"); c := reads() }
X        "/" : {
X        reads() == "*" | stop("unknown YACC operator, \"/\"")
X        do_c_comment()
X        c := reads() | break
X        }
X        "'" : {
X        lval := "'"
X        while lval ||:= (c := reads()) do {
X            if c == "\\"
X            then lval ||:= reads()
X            else if c == "'" then {
X            suspend IDENT
X            break
X            }
X        }
X        c := reads() | break
X        }
X        "%" : {
X        lval := "%"
X        while any(&letters, c := reads()) do
X            lval ||:= c
X        if *lval = 1 then {
X            if c == "%" then {
X            lval := "%%"
X            suspend MARK
X            if (marks +:= 1) > 1 then
X                fail
X            } else {
X            if c == "{" then {
X                lval := "%{"
X                suspend LCURL | RCURL | RCURL
X            }
X            else stop("malformed %declaration")
X            }
X            c := reads() | break
X        } else {
X            case lval of {
X            "%prec"     : suspend PREC
X            "%left"     : suspend LEFT
X            "%token"    : suspend TOKEN
X            "%right"    : suspend RIGHT
X            "%type"     : suspend TYPE
X            "%start"    : suspend START
X            "%union"    : suspend UNION | RCURL | RCURL
X            "%nonassoc" : suspend NONASSOC
X            default    : stop("unknown % code in def section")
X            }
X        }
X        }
X        default : {
X        if any(&digits, c) then {
X            lval := c
X            while any(&digits, c := reads()) do
X            lval ||:= c
X            suspend NUMBER
X        }
X        else {
X            if any(idchars, c) then {
X            lval := c
X            while any(&digits ++ idchars, c := reads()) do
X                lval ||:= c
X            lval := mapargs(lval, reserveds, UNreserveds)
X            suspend IDENT
X            }
X            else {
X            # whitespace
X            c := reads() | break
X            }
X        }
X        }
X    }
X    }
X
X
Xend
X
X
Xprocedure get_icon_code(endmark, comment)
X
X    local yaccwords, ibpagwords, count, c, c2, s
X
X    yaccwords := ["YYDEBUG", "YYACCEPT", "YYERROR", "yyclearin", "yyerrok"]
X    ibpagwords := ["IIDEBUG", "IIACCEPT", "IIERROR", "iiclearin", "iierrok"]
X
X    s := ""
X    count := 1
X    c := reads()
X
X    repeat {
X    case c of {
X        "\""    :  s ||:= c || do_string()
X        "'"     :  s ||:= c || do_charlit()
X        "$"     :  {
X        c2 := reads() | break
X        if c2 == "$" then {
X            until (c := reads()) == "="
X            s ||:= "return "
X        } else {
X            s ||:= c
X            c := c2
X            next
X        }
X        }
X        "#"     :  {
X        if s[-1] == "\n"
X        then s[-1] := ""
X        do_icon_comment()
X        }
X        "/" : {
X        c := reads() | break
X        if c == "*" then
X            do_c_comment()
X        else {
X            s ||:= c
X            next
X        }
X        }
X        "{"     :  {
X        s ||:= c
X        if endmark == "}" then
X            count +:= 1
X        }
X        "}"     :  {
X        s ||:= c
X        if endmark == "}" then {
X            count -:= 1
X            count = 0 & (return mapargs(s, yaccwords, ibpagwords))
X        }
X        }
X        "%"     :  {
X        s ||:= c
X        if endmark == "%}" then {
X            if (c := reads()) == "}"
X            then return mapargs(s || c, yaccwords, ibpagwords)
X            else next
X        }
X        }
X        default : s ||:= c
X    }
X    c := reads() | break
X    }
X
X    # if there is no endmark, just go to EOF
X    if \endmark
X    then stop("input file has mis-braced { code }")
X    else return mapargs(s, yaccwords, ibpagwords)
X
Xend
X
X
Xprocedure do_string()
X
X    local c, s
X
X    s := ""
X    while c := reads() do {
X    case c of {
X        "\\"    : s ||:= c || reads()
X        "\""    : return s || c || reads()
X        default : s ||:= c
X    }
X    }
X
X    stop("malformed string literal")
X
Xend
X
X
Xprocedure do_charlit()
X
X    local c, s
X
X    s := ""
X    while c := reads() do {
X    case c of {
X        "\\"    : s ||:= c || reads()
X        "'"     : return s || c || reads()
X        default : s ||:= c
X    }
X    }
X
X    stop("malformed character literal")
X
Xend
X
X
Xprocedure do_c_comment()
X
X    local c, s
X
X    s := c := reads() |
X    stop("malformed C-style /* comment */")
X
X    repeat {
X    if c == "*" then {
X        s ||:= (c := reads() | break)
X        if c == "/" then
X        return s
X    }
X    else s ||:= (c := reads() | break)
X    }
X
X    return s            # EOF okay
X
Xend
X
X
Xprocedure do_icon_comment()
X
X    local c, s
X
X    s := ""
X    while c := reads() do {
X    case c of {
X        "\\"    : s ||:= c || (reads() | break)
X        "\n"    : return s
X        default : s ||:= c
X    }
X    }
X
X    return s            # EOF okay
X
Xend
X
X
Xprocedure mapargs(s, l1, l2)
X
X    local i, s2
X    static cs, tbl, last_l1, last_l2
X
X    if /l1 | *l1 = 0 then return s
X
X    if not (last_l1 === l1, last_l2 === l2) then {
X    cs := ''
X    every cs ++:= (!l1)[1]
X    tbl := table()
X    every i := 1 to *l1 do
X        insert(tbl, l1[i], (\l2)[i] | "")
X    }
X
X    s2 := ""
X    s ? {
X    while s2 ||:= tab(upto(cs)) do {
X        (s2 <- (s2 || tbl[tab(longstr(l1))]),
X            not any(&letters++&digits++'_')) |
X            (s2 ||:= move(1))
X    }
X    s2 ||:= tab(0)
X    }
X
X    return s2
X
Xend
X
X
Xprocedure main()
X    iiparse()
Xend
SHAR_EOF
chmod 0444 iacc.ibp || echo "restore of iacc.ibp fails"
sed 's/^X//' << 'SHAR_EOF' > Makefile.dist &&
X##########################################################################
X#
X   PROGNAME = ibpag2
X#
X##########################################################################
X#
X#  User-modifiable section.  Read carefully!  You will almost
X#  certainly have to change some settings here.
X#
X
X#
X# Destination directory for binaries files.  Owner and group for
X# public executables.  Leave the trailing slash off of directory
X# names.
X#
XOWNER = richard # root
XGROUP = group   # root
XDESTDIR = /usr/local/bin
X# Put this path into your LPATH variable (on which, see the Icon
X# documentation).  Make sure that the directory exists.
XLIBDIR = /usr/lib/icon/data
X
X#
X# Name of your icon compiler and compiler flags.
X#
XICONC = /usr/icon/v9/bin/icont
XIFLAGS = -u #-Sc 400 -Sg 400 -Si 2000 -Sn 4000 -SF 40
X
XSHELL = /bin/sh
XSHAR = /usr/bin/shar
XCOMPRESS = /usr/bin/compress
X# COMPRESS = /usr/local/bin/gzip
X
X###########################################################################
X#
X#  Don't change anything below this line unless you're really sure of
X#  what you're doing.
X#
X
XAUX = slshupto.icn rewrap.icn outbits.icn sortff.icn itokens.icn
XSRC = $(PROGNAME).icn $(AUX) slrtbls.icn slritems.icn follow.icn \
X    ibutil.icn iohno.icn ibreader.icn ibwriter.icn shrnktbl.icn \
X    version.icn
XPARSER = iiparse.lib
XGLRPARSER = iiglrpar.lib
XSHARFILES = $(SRC) $(PARSER) $(GLRPARSER) sample.ibp beta2ref.ibp \
SHAR_EOF
echo "End of part 6, continue with part 7"
echo "7" > s2_seq_.tmp
exit 0
--

   -Richard L. Goerwitz              [e-mail]
   [e-mail]          rutgers!oddjob!ellis!goer