File ‹tools/mlyacc/src/mkprstruct.ML›

(* SPDX-License-Identifier: SMLNJ *)
(* SPDX-FileCopyrightText: 1989 Andrew W. Appel, David R. Tarditi *)

(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi
 *
 * $Log$
 * Revision 1.1  2006/06/22 07:40:27  michaeln
 * Add a MoscowML compilable implementation of MLyacc, using the MLton sources
 * as the base.
 *
 * Revision 1.1.1.1  1997/01/14 01:38:06  george
 *   Version 109.24
 *
 * Revision 1.2  1996/02/26  15:02:37  george
 *    print no longer overloaded.
 *    use of makestring has been removed and replaced with Int.toString ..
 *    use of IO replaced with TextIO
 *
 * Revision 1.1.1.1  1996/01/31  16:01:46  george
 * Version 109
 *
 *)

functor mkPrintStruct(structure LrTable : LR_TABLE
                      structure ShrinkLrTable : SHRINK_LR_TABLE
                      sharing LrTable = ShrinkLrTable.LrTable):PRINT_STRUCT =
   struct
      open Array List
      infix 9 sub
      structure LrTable = LrTable
      open ShrinkLrTable LrTable


      (* lineLength = approximately the largest number of characters to allow
         on a line when printing out an encode string *)

      val lineLength = 72

      (* maxLength = length of a table entry.  All table entries are encoded
         using two 16-bit integers, one for the terminal number and the other
         for the entry.  Each integer is printed as two characters (low byte,
         high byte), using the ML ascii escape sequence.  We need 4
         characters for each escape sequence and 16 characters for each entry
      *)

      val maxLength =  16

      (* number of entries we can fit on a row *)

      val numEntries = lineLength div maxLength

      (* convert integer between 0 and 255 to the three character ascii
         decimal escape sequence for it *)

      val chr =
        let val lookup = Array.array(256,"\000")
            val intToString = fn i =>
                if i>=100 then "\\" ^ (Int.toString i)
                else if i>=10 then "\\0" ^ (Int.toString i)
                else  "\\00" ^ (Int.toString i)
            fun loop n = if n=256 then ()
                         else (Array.update(lookup,n,intToString n); loop (n+1))
        in loop 0; fn i => lookup sub i
        end

      val makeStruct = fn {table,name,print,verbose} =>
       let
         val states = numStates table
         val rules = numRules table
         fun printPairList (prEntry : 'a * 'b -> unit) l =
               let fun f (EMPTY,_) = ()
                     | f (PAIR(a,b,r),count) =
                            if count >= numEntries then
                               (print "\\\n\\"; prEntry(a,b); f(r,1))
                            else (prEntry(a,b); f(r,(count+1)))
               in f(l,0)
               end
         val printList : ('a -> unit) -> 'a list -> unit =
           fn prEntry => fn l =>
                let fun f (nil,_) = ()
                      | f (a :: r,count) =
                             if count >= numEntries then
                                 (print "\\\n\\"; prEntry a; f(r,1))
                                else (prEntry a; f(r,count+1))
                in f(l,0)
                end
         val prEnd = fn _ => print "\\000\\000\\\n\\"
         fun printPairRow prEntry =
               let val printEntries = printPairList prEntry
               in fn l => (printEntries l; prEnd())
               end
         fun printPairRowWithDefault (prEntry,prDefault) =
               let val f = printPairRow prEntry
               in fn (l,default) => (prDefault default; f l)
               end
         fun printTable (printRow,count) =
               (print "\"\\\n\\";
                let fun f i = if i=count then ()
                               else (printRow i; f (i+1))
                in f 0
                end;
                print"\"\n")
         val printChar = print o chr

          (* print an integer between 0 and 2^16-1 as a 2-byte character,
             with the low byte first *)

         val printInt = fn i => (printChar (i mod 256);
                                  printChar (i div 256))

         (* encode actions as integers:

                ACCEPT => 0
                ERROR => 1
                SHIFT i => 2 + i
                REDUCE rulenum => numstates+2+rulenum
         *)

         val printAction =
              fn (REDUCE rulenum) => printInt (rulenum+states+2)
                 | (SHIFT (STATE i)) => printInt (i+2)
                 | ACCEPT => printInt 0
                 | ERROR => printInt 1

         val printTermAction = fn (T t,action) =>
                (printInt (t+1); printAction action)

         val printGoto = fn (NT n,STATE s) => (printInt (n+1); printInt s)

         val ((rowCount,rowNumbers,actionRows),entries)=
                   shrinkActionList(table,verbose)
         val getActionRow = let val a = Array.fromList actionRows
                            in fn i => a sub i
                            end
         val printGotoRow : int -> unit =
               let val f = printPairRow printGoto
                   val g = describeGoto table
               in fn i => f (g (STATE i))
               end
        val printActionRow =
              let val f = printPairRowWithDefault(printTermAction,printAction)
              in fn i => f (getActionRow i)
              end
        in print "val ";
           print name;
           print "=";
           print "let val actionRows =\n";
           printTable(printActionRow,rowCount);
           print "val actionRowNumbers =\n\"";
           printList (fn i => printInt i) rowNumbers;
           print "\"\n";
           print "val gotoT =\n";
           printTable(printGotoRow,states);
           print "val numstates = ";
           print (Int.toString states);
           print "\nval numrules = ";
           print (Int.toString rules);
           print "\n\
\val s = ref \"\" and index = ref 0\n\
\val string_to_int = fn () => \n\
\let val i = !index\n\
\in index := i+2; Char.ord(String.sub(!s,i)) + Char.ord(String.sub(!s,i+1)) * 256\n\
\end\n\
\val string_to_list = fn s' =>\n\
\    let val len = String.size s'\n\
\        fun f () =\n\
\           if !index < len then string_to_int() :: f()\n\
\           else nil\n\
\   in index := 0; s := s'; f ()\n\
\   end\n\
\val string_to_pairlist = fn (conv_key,conv_entry) =>\n\
\     let fun f () =\n\
\         case string_to_int()\n\
\         of 0 => EMPTY\n\
\          | n => PAIR(conv_key (n-1),conv_entry (string_to_int()),f())\n\
\     in f\n\
\     end\n\
\val string_to_pairlist_default = fn (conv_key,conv_entry) =>\n\
\    let val conv_row = string_to_pairlist(conv_key,conv_entry)\n\
\    in fn () =>\n\
\       let val default = conv_entry(string_to_int())\n\
\           val row = conv_row()\n\
\       in (row,default)\n\
\       end\n\
\   end\n\
\val string_to_table = fn (convert_row,s') =>\n\
\    let val len = String.size s'\n\
\        fun f ()=\n\
\           if !index < len then convert_row() :: f()\n\
\           else nil\n\
\     in (s := s'; index := 0; f ())\n\
\     end\n\
\local\n\
\  val memo = Array.array(numstates+numrules,ERROR)\n\
\  val _ =let fun g i=(Array.update(memo,i,REDUCE(i-numstates)); g(i+1))\n\
\       fun f i =\n\
\            if i=numstates then g i\n\
\            else (Array.update(memo,i,SHIFT (STATE i)); f (i+1))\n\
\          in f 0 handle Subscript => ()\n\
\          end\n\
\in\n\
\val entry_to_action = fn 0 => ACCEPT | 1 => ERROR | j => Array.sub(memo,(j-2))\n\
\end\n\
\val gotoT=Array.fromList(string_to_table(string_to_pairlist(NT,STATE),gotoT))\n\
\val actionRows=string_to_table(string_to_pairlist_default(T,entry_to_action),actionRows)\n\
\val actionRowNumbers = string_to_list actionRowNumbers\n\
\val actionT = let val actionRowLookUp=\n\
\let val a=Array.fromList(actionRows) in fn i=>Array.sub(a,i) end\n\
\in Array.fromList(map actionRowLookUp actionRowNumbers)\n\
\end\n\
\in LrTable.mkLrTable {actions=actionT,gotos=gotoT,numRules=numrules,\n\
\numStates=numstates,initialState=STATE ";
print (Int.toString ((fn (STATE i) => i) (initialState table)));
print "}\nend\n";
      entries
      end
end;