path: root/ipl/packs/ibpag2/slrtbls.icn

############################################################################
#
#	Name:	 slrtbls.icn
#
#	Title:	 slr table generation routines
#
#	Author:	 Richard L. Goerwitz
#
#	Version: 1.20
#
############################################################################
#
#  Contains make_slr_tables(grammar, atbl, gtbl, noconflict,
#  like_yacc), where grammar is an ib_grammar record (as returned by
#  ibreader), where atbl and gtbl are initialized (default &null) hash
#  tables, and where noconflict is a switch that, if nonnull, directs
#  the resolver to abort on unresolvable conflicts.  Returns &null if
#  successful in filling out atbl and gtbl.  If likeyacc is nonnull,
#  make_slr_tables will resolve reduce/reduce conflicts by order of
#  occurrence in the grammar, just like YACC.  Shift/reduce conflicts
#  will be resolved in favor of shift.
#
#  The reason for the noconflict switch is that there are parsers that
#  can accept tables with multiple action entries, i.e.  parsers that
#  can use tables generated by ambiguous grammars.
#
#  In this routine's case, success is identified with creating a
#  standard SLR action and goto table.  Note that both tables end up
#  as tables of tables, with symbols being the primary or first key,
#  and state numbers being the second.  This is the reverse of the
#  usual arrangement, but turns out to save a lot of space.  Atbl
#  values are of the form "s2.3", "r4<A>10", "a", etc.  The string
#  "s2.3" means "shift the current lookahead token, and enter state 2
#  via rule 3."  By way of contrast, "r4<A>10" means "reduce by rule
#  number 4, which has A as its LHS symbol and 10 RHS symbols."  A
#  single "a" means "accept."

#  Atbl entries may contain more than one action.  The actions are
#  simply concatenated: "s2.3r4<A>10a".  Conflicts may be resolved
#  later by associativity or precedence, if available.  Unresolvable
#  conflicts only cause error termination if the 5th and final
#  argument is nonnull (see above on "noconflict").
#
#  Gtbl entries are simpler than atble entries, consisting of a single
#  integer.
#
############################################################################
#
#  Links: follow, slritems, iohno
#
############################################################################

# declared in ibreader.icn
# record ib_grammar(start, rules, tbl)

#link follow, slritems, iohno#, ximage

#
# make_slr_tables
#
procedure make_slr_tables(grammar, atbl, gtbl, noconflict, like_yacc)

    local start_symbol, st, C, i, augmented_start_symbol, item,
	symbol, new_item_list, j, action

    # Initialize start symbol and rule list/set (either is okay).
    start_symbol := grammar.start
    st := grammar.rules

    # Number the rules, and then construct the canonical LR(0) item sets.
    every i := 1 to *st do st[i].no := i
    C := make_slr_item_sets(start_symbol, st)

    # Now, go through each item in each item set in C filling out the
    # action (atbl) and goto table (gtbl) as we go.
    #
    augmented_start_symbol := "`_" || start_symbol || "_'"
    every i := 1 to *C do {
        every item := !C[i] do {
	    # if the dot's *not* at the end of the production...
	    if symbol := item.RHS[item.POS] then {
		# if were looking at a terminal, enter a shift action
		if type(symbol) == "integer" then {
		    if symbol = -2 then next   # Never shift epsilon!
		    new_item_list := slr_goto(C[i], symbol, st)
		    every j := 1 to *C do {
			if equivalent_item_lists(new_item_list, C[j]) then {
			    action := "s" || j || "." || item.no
			    resolve(st, atbl, symbol, i, action,
				    noconflict, like_yacc)
			    break next
			}
		    }
		# if we're looking at a nonterminal, add action to gtbl
		} else {
		    new_item_list := slr_goto(C[i], symbol, st)
		    every j := 1 to *C do {
			if equivalent_item_lists(new_item_list, C[j]) then {
			    /gtbl[symbol] := table()
			    /gtbl[symbol][i] := j |
				gtbl[symbol][i] =:= j |
				iohno(80, image(symbol), ".", image(i), ":", j)
			    break next
			}
		    }
		}
	    # ...else if the dot *is* at the end of the production
	    } else {
		if item.LHS == augmented_start_symbol then {
		    action := "a"
		    # 0 = EOF 
		    resolve(st, atbl, 0, i, action, noconflict, like_yacc)
		} else {
		    # add a reduce for every symbol in FOLLOW(item.LHS)
		    every symbol := !FOLLOW(start_symbol, st, item.LHS) do {
			# RHS size is 0 for epsilon.
			if item.RHS[1] === -2 then {
			    action := "r" || item.no || "<" || item.LHS ||
				">0"
			} else
			    action := "r" || item.no || "<" || item.LHS ||
			        ">" || *item.RHS
			resolve(st, atbl, symbol, i, action,
				noconflict, like_yacc)
		    }
		}
	    }
	}
    }

    return

end


#
# resolve: list|set x table x string|integer, integer, anything, anything
#	      						-> string
#          (st, tbl, symbol, state, action, noconflict, like_yacc)
#							-> new_action_list
#
#     Add action to action table, resolving conflicts by precedence
#     and associativity, if need be.  If noconflict is nonnull, abort
#     on unresolvable conflicts.  Fails on shift/shift "conflicts," or
#     if an identical action is already present in the table entry to
#     be modified.  If like_yacc is nonnull, resolve reduce/reduce
#     conflicts by their order of occurrence in the grammar; resolve
#     shift/reduce conflicts in favor of shift.
#
procedure resolve(st, tbl, symbol, state, action, noconflict, like_yacc)

    local actions, chr, a, ruleno, p, newp

    /tbl[symbol] := table()
    /tbl[symbol][state] := ""
    
    # If this action is already present, then don't re-enter it.  Just
    # fail.
    #
    tbl[symbol][state] ? {
	while a := tab(any('sra')) do {
	    a ||:= tab(upto('.<'))
	    a ||:= { (="<" || tab(find(">")+1)) | ="." }
	    a ||:= tab(many(&digits))
	    if a == action then fail
	}
    }

    # Get rule number for the new action specified as arg 5, and
    # fetch its source production.
    action ? {
	case move(1) of {
	    "s": ruleno := (tab(find(".")+1), tab(many(&digits)))
	    "r": ruleno := 1(tab(find("<")), move(1))
	    "a": return tbl[symbol][state] := action || tbl[symbol][state]
	} | iohno(70, tbl[symbol][state])
	(newp := !st).no = ruleno |
	    iohno(72, tbl[symbol][state])
    }

    # Resolve any conflicts that might be present.
    #
    actions := ""
    tbl[symbol][state] ? {
	while a := tab(any('sra')) do {
	    # Snip out the old action, and put it into a.
	    a ||:= tab(upto('.<'))
	    a ||:= { (="<" || tab(find(">")+1)) | ="." }
	    a ||:= tab(many(&digits))
	    #
	    # Get the old action's rule number, and use it to fetch
	    # the full production that it is keyed to.
	    #
	    a ? {
		case move(1) of {
		    "s": ruleno := (tab(find(".")+1), tab(many(&digits)))
		    "r": ruleno := 1(tab(find("<")), move(1))
		    "a": return tbl[symbol][state] := a || actions || action
		} | iohno(70, tbl[symbol][state])
		# Go through rule list; find the one whose number is ruleno.
		(p := !st).no = ruleno |
		    iohno(71, tbl[symbol][state])
	    }

	    # Check precedences to see if we can resolve the conflict
	    # this way.
	    #
	    if \newp.prec > \p.prec then
		# discard the old action, a
		return tbl[symbol][state] := actions || action || tab(0)
	    else if \newp.prec < \p.prec then
		# discard the new action, action
		return tbl[symbol][state] := actions || a || tab(0)
	    else {
		#
		# If, however, both precedences are the same (i.e.
		# newp.prec === p.prec), then we must check the
		# associativities.  Right implies shift; left, reduce.
		# If there is no associativity, then we have a
		# conflict.  Nonassociative ("n") implies error.
		#
		case action[1] of {
		    default: iohno(70, tbl[symbol][state])	
		    # case "a" is handled above; look for "s" & "r"
		    "s" : {
			if a[1] == "s" then fail  # no shift/shift "conflict"
			else if a[1] == "r" then {
			    newp.assoc === p.assoc | {
				iohno(40, "state " || state || "; token " ||
				      symbol || "; rules " || newp.no ||
				      "," || p.no)
			    }
			    case newp.assoc of {
				"n"  : iohno(41, production_2_string(newp))
				&null: { # no associativity given
				    if \noconflict & /like_yacc then
					iohno(46, "state " || state ||
					      "; token " || symbol ||
					      "; rules " || newp.no ||
					      "," || p.no)
				    else {
					write(&errout, "warning: shift/reduce",
					      " conflict in state " || state ||
					      "; token " || symbol ||
					      "; rules " || newp.no ||
					      "," || p.no)
					if \like_yacc then {
					    write(&errout, "resolving in _
						            favor of shift.")
					    return tbl[symbol][state] :=
					       actions || action || tab(0)
					} else {
					    write(&errout, "creating multi-_
							action table entry")
					    return tbl[symbol][state] :=
					       actions || action || a || tab(0)
					}
				    }
				}
				"l"  : { # left associative
				    # discard new action, action
				    return tbl[symbol][state] := 
					actions || a || tab(0)
				}
				"r"  : { # right associative
				    # remove old action, a
				    return tbl[symbol][state] := 
					actions || action || tab(0)
				}
			    }
			}
		    }
		    "r" : {
			if a[1] == "r" then {
			    #
			    # If conflicts in general, and reduce-reduce
			    # conflicts in specific are not okay...
			    #
			    if \noconflict & /like_yacc then {
				# ...abort, otherwise...
				iohno(42, "state " || state || "; token " ||
				      symbol || "; " || "; rules " ||
				      newp.no || "," || p.no)
			    } else {
				#
				# ...flag reduce-reduce conficts, and
				# then resolve them by their order of
				# occurrence in the grammar.
				#
				write(&errout, "warning: reduce/reduce",
				      " conflict in state ", state,
				      "; token ", symbol, "; rules ",
				      newp.no, ",", p.no)
				if \like_yacc then {
				    write(&errout, "resolving by order of _
				          occurrence in the grammar")
				    if newp.no > p.no
				    # discard later production (newp)
				    then return return tbl[symbol][state] := 
					actions || a || tab(0)
				    # discard later production (old p)
				    else return tbl[symbol][state] := 
					actions || action || tab(0)
				} else {
				    #
				    # If conflicts ok, but we aren't supposed
				    # to resolve reduce-reduce conflicts by
				    # order of rule occurrence:
				    #
				    write(&errout, "creating multi-action _
					table entry")
				    return tbl[symbol][state] :=
					actions || action || a || tab(0)
				}
			    }
			} else {
			    # associativities must be the same for both rules:
			    newp.assoc === p.assoc | {
				iohno(40, "state " || state || "; token " ||
				      symbol || "; rules " || newp.no ||
				      "," || p.no)
			    }
			    case newp.assoc of {
				"n"  : iohno(41, production_2_string(newp))
				&null: {
				    if \noconflict & /like_yacc then
					iohno(46, "state " || state ||
					      "; token " || symbol ||
					      "; rules " || newp.no ||
					      "," || p.no)
				    else {
					write(&errout, "warning: shift/reduce",
					      " conflict in state " || state ||
					      "; token " || symbol ||
					      "; rules " || newp.no ||
					      "," || p.no)
					if \like_yacc then {
					    write(&errout, "resolving in _
						            favor of shift.")
					    return tbl[symbol][state] :=
					       actions || a || tab(0)
					} else {
					    write(&errout, "creating multi-_
							action table entry")
					    return tbl[symbol][state] :=
					       actions || action || a || tab(0)
					}
				    }
				}
				"r"  : {
				    # discard new action, action
				    return tbl[symbol][state] :=
					actions || a || tab(0)
				}
				"l"  : {
				    # remove old action, a
				    return tbl[symbol][state] :=
					actions || action || tab(0)
				}
			    }
			}
		    }
		}
	    }
	}
    }

    return tbl[symbol][state] ||:= action

end