#
# idol.icn -- core Idol-translator classes

$include "ytab_h.icn"

link getpaths
#
# global variables
#
global fin,fout,fName,fLine,alpha,alphadot,white,nonwhite,nonalpha,reserved
global classes,comp,exec,strict,links,imports,loud,compiles,ct,tmpcount

# classspec database (DBM) entry
record db_entry(dir, entry)

#
# Abstract class for objects resulting from parsing lines of the form
#   tag name ( field1 , field2, ... )
#
class declaration(name,fields,tag,lptoken,rptoken)
  method name()
    return self.name
  end

  method setname(s)
    self.name := s
  end
  #
  # parse a declaration string into its components
  #
  method Read(decl)
    decl ? (
      (tab(many(white)) | "") ,
      # get my tag
      (self.tag := =("procedure"|"class"|"method"|"record"|"package")) ,
      (tab(many(white)) | "") ,
      # get my name
      (self.name := tab(many(alpha))) ,
      # get my fields
      (tab(find("(")+1))\1,
      (tab(many(white)) | "") ,
      ((self.fields := classFields())$parse(tab(find(")")\1))),
      =")",
      (tab(many(white)) | ""),
      pos(0)
    ) | halt("declaration/read can't parse decl ",decl)
  end
  #
  # write a declaration
  #
  method Write(f)
      yyprint(tag)
      yyprint(name)
      yyprint(lptoken)
      yyprint(fields)
      yyprint(rptoken)
  end
  #
  # convert self to a string
  #
  method String()
    flds := (\(self.fields))$String() | ""
if / (self.tag) then {
   write("null tag in ", image(self.name), " object ", image(self))
}
    return self.tag || " " || self.name || "(" || flds || ")"
  end
initially
   tmpcount := 0
end

global imported

procedure import_class(node)
   local s, pack
   /imported := table()
   if type(node)=="treenode" & node.label=="implist" then {
      import_class(node.children[1])
      import_class(node.children[3])
      }
   else if node.tok = IDENT then {
      tempp := Package(node.s)
      if /tempp.dir then {
	 uni_error("Unable to import package " || node.s)
	 }
      tempp.add_imported()
      }
   else if node.tok = STRINGLIT then {
      node.s ? {
	  move(1)
	  pack := ""
	  while pack ||:= tab(upto('/\\')) do pack ||:= move(1)
	  if pack ||:= tab(find(".")) then {
	      move(1)
	      s := tab(-1)
	  }
	  else pack ||:= tab(-1)
      }

      tempp := Package(pack)
      if /tempp.dir then {
	 uni_error("Unable to import package " || node.s)
	 }
      tempp.add_imported(s)
      }
end

#
# a package is a virtual syntax construct; it does not appear in source
# code, but is stored in the database.  The "fields" in a package are
# the list of global symbols defined within that package.  The filelist
# is the list of source files that are linked in when that package is
# imported.
#
class Package : declaration(files, dir, classes)
   #
   # Add to the two global tables of imported symbols from this package's
   # set of symbols.  If sym is non-null, we are importing an individual
   # symbol (import "pack.symbol").
   #
   method add_imported(sym)
      local s, f

      if /dir then return
      
      f := open(dir || "/uniclass", "dr") |
	 stop("Couldn't re-open uniclass db in " || dir)
      every s := (if \sym then sym else fields.foreach()) do {
         if member(imported, s) then
             put(imported[s], self.name)
          else {
             imported[s] := [self.name]
          }

         if fetch(f, self.name || "__" || s) then {
            if member(imported_classes, s) then
               put(imported_classes[s], self.name)
            else {
               imported_classes[s] := [self.name]
            }
         }
      }
      close(f)
   end
   method Read(line)
      self$declaration.Read(line)
      self.files := idTaque(":")
      self.files$parse(line[find(":",line)+1:find("(",line)] | "")
   end
   method size()
      return fields$size()
   end
   method insertfname(filename)
      /files := idTaque(":")
      if files.insert(filename) then {
         write(filename, " is added to package ", name)
         writespec()
         }
      else write(filename, " is already in Package ", name)
   end
   method insertsym(sym, filename)
      if fields.insert(sym) then {
         write(sym, " added to package ", name)
         writespec()
         }
      else write(sym, " is already in Package ", name)
   end
   method containssym(sym)
       return \fields.lookup(sym)
   end
   method String()
      s := self$declaration.String()
      fs := files.String()
      if *fs > 0 then fs := " : " || fs
      s := s[1: (*tag + *name + 2)] || fs || s[*tag+*name+2:0]
      return s
   end
   method writespec()
   if \name & (f := open(env,"d")) then {
      insert(f, name, String())
      close(f)
      return
      }
   stop("can't write package spec for ", image(name))
   end
initially(name)
   if name[1] == name[-1] == "\"" then {
      name := name[2:-1]
      self.name := ""
      name ? {
	 if upto('/\\') then {
	    while self.name ||:= tab(upto('/\\')) do self.name ||:= move(1)
	    }
	 self.name ||:= tab(find(".")|0)
	 }
      }
   else {
      self.name := name
      }
   if dbe := fetchspec(self.name) then {
      Read(dbe.entry)
      self.dir := dbe.dir
      }
   /tag := "package"
   /fields := classFields()
end

# imethods and ifields are all lists of these:
record classident(Class,ident)

#
# Attributes and operations of classes
#
class Class : declaration (supers,
			   methods,
			   text,
			   imethods,
			   ifields,
			   glob,
			   linkfile,
			   dir,
			   unmangled_name,
			   supers_node)

  method ismethod(id)
     if \ (self.methods$lookup(id)) | (!\self.imethods).ident == id then
        return
  end

  method isfield(id)
     if \ (self.fields$lookup(id)) | (!\self.ifields).ident == id then
        return
  end

  method Read(line,L)
    self$declaration.Read(line)
    self.supers := idTaque(":")
    self.supers$parse(line[find(":",line)+1:find("(",line)] | "")
    self.methods:= taque()
    self$ReadBody(0, L)
  end
  method ReadBody(depth,L)
    while line  := pop(L) do {
      line ? {
	tab(many(white))
	if ="initially" then {
	    (cf := classFields())$parse("")
	    decl := Method(self.name,self.text,,cf,"method")
	    decl$setname("initially")
	    self.methods$insert(decl, "initially")
	} else if ="method" then {
	    decl := Method(self.name)
	    decl$Read(line,phase)
	    self.methods$insert(decl,decl$name())
	} else if ="end" & pos(0) then {
	    # "end" is tossed here. see "initially" above
	    return
	} else if ="procedure" then {
	    decl := Method("")
	    decl$Read(line,phase)
	    /self.glob := []
	    put(self.glob,decl)
	} else if ="global" then {
	    /self.glob := []
	    put(self.glob,vardecl(line))
	} else if ="record" then {
	    /self.glob := []
	    put(self.glob,declaration(line))
	} else if upto(nonwhite) then {
	    decl := Method(self.name)
	    decl$Read("method " || line || "()", phase)
	    self.methods$insert(decl,decl$name())
	}
      }
    }
    if depth = 0 then
       halt("class/read syntax error: eof inside a class definition")
  end

  #
  # Miscellaneous methods on classes
  #
  method has_initially()
    return (methods$foreach())$name() == "initially"
  end
  method ispublic(fieldname)
    if self.fields$ispublic(fieldname) then return fieldname
  end
  method foreachmethod()
    suspend methods$foreach()
  end
  method foreachsuper()
    suspend supers$foreach()
  end
  method foreachfield()
    suspend fields$foreach()
  end
  method isvarg(s)
    if self.fields$isvarg(s) then return s
  end
  method transitive_closure()
    count := supers$size()
    while count > 0 do {
	added := taque()
	every sc := supers$foreach() do {
	  if /(super := classes$lookup(sc)) then
	    halt("class/transitive_closure: couldn't find superclass ",sc)
	  every supersuper := super$foreachsuper() do {
	    if / self.supers$lookup(supersuper) &
		 /added$lookup(supersuper) then {
	      added$insert(supersuper)
	    }
	  }
	}
	count := added$size()
	every self.supers$insert(added$foreach())
    }
  end
  #
  # write the class declaration: if s is "class" write as a spec
  # otherwise, write as a constructor
  #
  method writedecl(f,s)
    writes(f, s," ",self.name)
    if s=="class" & ( *(superstr := self.supers$String()) > 0 ) then
	    writes(f," : ",superstr)
    writes(f,"(")

    if s~=="class" &
       ((("initially" == (m := (methods$foreach()))$name()) &
       (m.fields ~=== EmptyNode)) |
       (((mn := !(self.imethods)).ident == "initially") &
        (m := classes.lookup(mn.Class).methods.lookup("initially")) &
        (m.fields ~=== EmptyNode)) ) then {
       yyprint(m.fields)
       }
    else {
       rv := self.fields$String(s)
       if *rv > 0 then rv ||:= ","
       if s~=="class" & *(\self.ifields)>0 then	{	# inherited fields
	 every l := !self.ifields do {
	    lid := l.ident
	    if type(lid) == "string" then
	       rv := rv || lid || ","
	    else if type(lid)=="treenode" & lid.label == "arg3" then {
	       rv := rv || (lid.children[1].s)
	       if s=="class" then {
		  rv := rv || ":" || lid.children[3].s
		  }
	       rv := rv || ","
	       }
	    else stop("Write(): can't handle ", type(ifi))
	    }
	 # resolve the last field in order to see if it is a vararg
	 if /(superclass := classes$lookup(l.Class)) then
	    halt("class/resolve: couldn't find superclass ",sc)
	 if superclass$isvarg(l.ident) then rv := rv[1:-1]||"[],"
         }
       writes(f,rv[1:-1])
       }
    write(f,,")")
  end
  method WriteSpec() # write the specification of a class
    f := open(env,"d") | {
       write(&errout, "can't open class database to write spec for ",self.name)
       fail
       }

    nam := self.name
    s := fName || "\nclass " || nam
    if *(superstr := self.supers$String()) > 0 then {
       s ||:= " : "; s ||:= superstr
       }
    s ||:= "("
    rv := self.fields$String(s)
    if *rv > 0 then rv ||:= ","
    s ||:= rv[1:-1]
    s ||:= ")\n"
    every s ||:= (methods$foreach())$mkspec()
    s ||:= "end\n"
#    if *(self.name) + *s > 1023 then { # need to compress s
#       f2 := open("gzip.out", "w")
#       writes(f2,s)
#       close(f2)
#       f2 := open("gzip -c gzip.out","p")
#       s := "\^z" || reads(f2,100000)
#       close(f2)
#       remove("gzip.out")
#       }

    insert(f, nam, s) |
       stop("...insert fails on ", image(nam), " value of size ", *s)
    close(f)
    f := open(env,"d") | stop("no check")
    s := fetch(f, nam) | stop("fetch(", image(nam),") fails")
    close(f)
  end

  #
  # write out the Icon code for this class' explicit methods
  # and its "nested global" declarations (procedures, records, etc.)
  #
  method writemethods(f)

    every (methods$foreach())$Write(f)

    if \self.glob & *self.glob>0 then {
	write(f,"#\n# globals declared within the class\n#")
	every i := 1 to *self.glob do
	   yyprint(glob[i])
	write(f)
    }
  end

  #
  # write - write an Icon implementation of a class to file f
  #
  method Write(f)

    nam := self.name
    yyprint("\n")
    writemethods(f)
    #
    # must have done inheritance computation to write things out
    #
    if /self.ifields then self$resolve()

    #
    # write a record containing the state variables
    #
    writes(f,"record ",nam,"__state(__s,__m") # reserved fields
    rv := ","
    rv ||:= self.fields$idTaque.String()		     # my fields
    if rv[-1] ~== "," then rv ||:= ","

    every ifi := (!self.ifields).ident do {
       if type(ifi) == "string" then
          rv := rv || ifi || "," # inherited fields
       else if type(ifi) == "treenode" & ifi.label == "arg3" then {
	    rv := rv || (ifi.children[1].s) || ","
	    }
       else stop("Write(): can't handle ", type(ifi))
       }

    yyprint(rv[1:-1] || ")\n")

    #
    # write a record containing the methods
    #
    writes(f,"record ",nam,"__methods(")
    rv := ""
    every s := (((methods$foreach())$name())	|	# my explicit methods
		(!self.imethods).ident		|	# my inherited methods
		supers$foreach()
		)				# super.method fields
	do rv := rv || s || ","

    if *rv>0 then rv[-1] := ""			# trim trailling ,
    yyprint(rv||")\n")

    #
    # write a global containing this classes' operation record
    # along with declarations for all superclasses op records
    #
    writes(f,"global ",nam,"__oprec")
    every writes(f,", ", supers$foreach(),"__oprec")
    yyprint("\n")

    #
    # write the constructor procedure.
    # This is a long involved process starting with writing the declaration.
    #
    self$writedecl(f,"procedure")
    yyprint("local self,clone\n")

    #
    # initialize operation records for this and superclasses
    #
    yyprint("initial {\n  if /"||nam||"__oprec then "||nam||"initialize()\n")
    if supers$size() > 0 then
	every (super <- supers$foreach()) ~== nam do
	    yyprint("  if /"||super||"__oprec then "||super||"initialize()\n"||
		    "  "||nam||"__oprec."||super||" := "|| super||"__oprec\n")
    yyprint("  }\n")


    #
    # If the class field list has or inherits defaults, write them out.
    #
    every fld := fields$foreach() do {
	if type(fld) == "treenode" & fld.label == "arg3" then {
	    writes(f,"/",fld.children[1].s, " := ")
	    yyprint(fld.children[3])
	    yyprint("\n")
	    }
	}
    every ifi := (!(self.ifields)).ident do {
       if type(ifi) == "treenode" & ifi.label == "arg3" then {
	  writes(f,"/",ifi.children[1].s, " := ")
	  yyprint(ifi.children[3])
	  yyprint("\n")
	  }
       }


    #
    # create self, initialize from constructor parameters if no initially parms
    #
    writes(f,"  self := ",nam,"__state(&null,",nam,"__oprec")

    if (("initially" == (m := (methods$foreach()))$name()) &
       (m.fields ~=== EmptyNode)) |
   (((mn := !(self.imethods)).ident == "initially") &
    (m := classes.lookup(mn.Class).methods.lookup("initially")) &
    (m.fields ~=== EmptyNode))
   then {
       yyprint(")\n  self.__s := self\n")
       if \ (m.fields.varg) then {
          m.fields.String()[1:-2] ? {
	     if find(",") then {
                 writes(f,"  self.__m.initially!([self,")
                 while writes(f,tab(find(","))) do {
		    move(1)   # if last was nonfinal write it
		    if find(",") then writes(f,",")
		    }
	         write(f, "]|||", tab(0),") | fail")
                 }
             else {
		write(f,"  self.__m.initially!(push(", tab(0), ",self)) | fail")
                  }
	     }
	  }
      else {
          writes(f,"  self.__m.initially(self,")
          yyprint(m.fields)
          yyprint(") | fail\n")
          }
       }
   else {
      every fld := fields$foreach() do {
	 if type(fld) == "treenode" then writes(f,",",fld.children[1].s)
	 else
	    writes(f,",",fld)
	 }
      if \self.ifields then
         every ifi := (!self.ifields).ident do {
	    if type(ifi) == "string" then writes(f,",",ifi)
	    else if type(ifi) == "treenode" & ifi.label == "arg3" then {
	       writes(f, ",", ifi.children[1].s)
	       }
	    else {
	       write(&errout, "unicon: system error inheriting ", type(ifi))
	       }
	    }
       yyprint(")\n  self.__s := self\n")
    if ((methods$foreach())$name()| (!self.imethods).ident) == "initially" then
	  yyprint("  self.__m.initially(self) | fail\n")
       }

    #
    # call my initially method, if any
    #

    #
    # by default, just return the self object we've constructed.
    #
    # In strict mode, return the pair that comprises the object:
    # a pointer to the instance (__mystate), and
    # a pointer to the class operation record
    #
    if \strict then
       yyprint("  return idol_object(self,"||self.name||"__oprec)\nend\n\n")
    else yyprint("  return self\nend\n\n")
  
    
    #
    # write out class initializer procedure to initialize my operation record
    #
    yyprint("procedure "||nam||"initialize()\n")
    writes(f,"  initial ",nam,"__oprec := ",nam,"__methods")
    rv := "("
    every s := (methods$foreach())$name() do {		# explicit methods
      if *rv>1 then rv ||:= ","
      rv := rv || nam || "_" || s
    }
    every l := !self.imethods do {			# inherited methods
      if *rv>1 then rv ||:= ","
      rv := rv || l.Class || "_" || l.ident
    }
    yyprint(rv||")\nend\n")
  end

  #
  # resolve -- primary inheritance resolution utility
  #
  method resolve()
    #
    # these are lists of [class , ident] records
    #
    self.imethods := []
    self.ifields := []
    ipublics := []
    addedfields := table()
    addedmethods := table()
    every sc := supers$foreach() do {
	if /(superclass := classes$lookup(sc)) then
	    halt("class/resolve: couldn't find superclass ",sc)
	every superclassfield := superclass$foreachfield() do {
	    if /self.fields$lookup(superclassfield) &
	       /addedfields[superclassfield] then {
		addedfields[superclassfield] := superclassfield
		put ( self.ifields , classident(sc,superclassfield) )
		if superclass$ispublic(superclassfield) then
		    put( ipublics, classident(sc,superclassfield) )
	    } else if \strict then {
		warn("class/resolve: '",sc,"' field '",superclassfield,
		     "' is redeclared in subclass ",self.name)
	    }
	}
	every superclassmethod := (superclass$foreachmethod())$name() do {
	    if /self.methods$lookup(superclassmethod) &
	       /addedmethods[superclassmethod] then {
		addedmethods[superclassmethod] := superclassmethod
		put ( self.imethods, classident(sc,superclassmethod) )
	    }
	}
	every public := (!ipublics) do {
	    if public.Class == sc then
		put (self.imethods, classident(sc,public.ident))
	}
    }
  end
end

#
# a class defining operations on methods and procedures
#
class Method : declaration (Class, locals, initl, procbody, abstract_flag, firsttoken)
  method mkspec()
    decl := self$String()
    decl ?:= {
       ="method " | write("can't strip method")
       tab(0)
       }
    decl ?:= tab(find("("))
#    if s == "method" then decl[1:upto(white,decl)] := "method"
#    else {
#	decl[1:upto(white,decl)] := "procedure"
#	if *(self.Class)>0 then {
#	    decl[upto(white,decl)] ||:= self.Class||"_"
#	    i := find("(",decl)
#	    decl[i] ||:= "self" || (((decl[i+1] ~== ")"), ",") | "")
#	}
#    }
    return decl || "\n"
  end
  method islocal(id)
     if self.fields === &null then fail
     if x := \ (self.fields$lookup(id)) then return x
     return isloco( \ (self.locals), id)
#     if x := \ (self.text.vars) then
#	return x$lookup(id)
  end
  method Write(f, nam)
    yyprint("\n")

      if \firsttoken then {
	 if outfilename ~== firsttoken.filename |
	    outline ~= firsttoken.line then {
	    write(yyout,"\n#line ", firsttoken.line-1," \"",
		  firsttoken.filename,"\"")
	    outline := firsttoken.line
	    outcol := 1
	    outfilename := firsttoken.filename
	    }
	 }

    writes(f, "procedure ")
    writes(f, self.Class$name(), "_")
    yyprint(name)
    writes(f, "(self")
    if fields ~=== EmptyNode & fields$size()>0 then {
       writes(f,",")
       }
    yyprint(fields)
    yyprint(")\n")
    if /abstract_flag then {
       yyprint(locals)
       if exists_statlists(locals) then {
	  yyprint("\ninitial {")
          if initl ~=== EmptyNode then { # append into existing initial
	     yyprint(initl.children[2])
	     yyprint(";\n")
	     }
          yystalists(locals)
	  yyprint("\n}\n")
          }
       else
          yyprint(initl)
       (\fields).coercions()
       yyvarlists(locals)
       yyprint(procbody)
       if name=="initially" then
          writes(f, "\n      return")
       }
    else write(f, "   runerr(700, \"method " || name || "()\")")
    yyprint("\nend\n")
  end
end

#
# a class corresponding to an Icon table, with special treatment of empties
#
class Table(t)
  method size()
    return (* \ self.t) | 0
  end
  method insert(x,key)
    /self.t := table()
    /key := x
    if (/ (self.t[key])) := x then return
  end
  method lookup(key)
    if tee := \self.t then return tee[key]
    return
  end
  method foreach()
    if tee := \self.t then every suspend !tee
  end
end

procedure methodstaque(node, cl, taq)
   /taq := taque()
   case type(node) of {
	 "treenode": {
	    if (node.label ~=== "global") & (node.label ~=== "record") then {
	       if *node.children > 0 then
		  every methodstaque(!node.children, cl, taq)
	       else write("leaf ", node.label)
	       }
	    else {
	       /(cl.glob) := []
	       put(cl.glob, node)
	       }
	    }
         "Method__state": {
	    node.Class := cl
	    if not (taq$insert(node, node$name())) then {
	       uni_error("method " || node$name() ||
		       " redeclared in " || cl.name)
	       }
	    }
	 "null": { }
	 "token": {
	    write("token ", tokenstr(node.tok), " line ", node.line, " file ", node.filename)
	    }
         "declaration__state" : {
            # Record declaration.
            /(cl.glob) := []
            put(cl.glob, node)
            }
	 default: {
	    write("methods Taque on ", type(node), " : ", image(node))
	    }
      }
   return taq
end
#
# tabular queues (taques):
# a class defining objects which maintain synchronized list and table reps
# Well, what is really provided are loosely-coordinated list/tables
#
class taque : Table (l)
  method insert(x,key)
    /self.l := []
    if self$Table.insert(x,key) then {
       put(self.l,x)
       return
       }
  end
  method Push(x,key)
    /self.l := []
    if self$Table.insert(x,key) then {
       push(self.l,x)
       return
       }
  end
  method Put(x,key)
    /self.l := []
    if self$Table.insert(x,key) then {
       put(self.l,x)
       return
       }
  end
  method foreach()
    if \self.l then every suspend !self.l
  end
  method insert_t(x,key)
    return self$Table.insert(x,key)
  end
  method foreach_t()
    suspend self$Table.foreach()
  end
end

#
# support for taques found as lists of ids separated by punctuation
# constructor called with (separation char, source string)
#
class idTaque : taque(punc)
  method parse(s)
  local name
    s ? {
      tab(many(white))
      while name := tab(find(self.punc)) do {
	self$insert(trim(name,white))
	move(1)
	tab(many(white))
      }
      if any(nonwhite) then {
	 self$insert(trim(tab(0),white))
	 }
    }
    return
  end
  method traverse(node)
      case type(node) of {
	 "treenode": {
	    if *node.children > 0 then {
		if node.label == ("arg2"|"arg3"|"arg4") then {
		    insert(node, node.children[1].s)
		    }
                else if node.label == "varlist2" then {
                    insert(node, node.children[1].s)
		    }
                else if node.label==("varlist3"|"varlist4") then {
                    traverse(node.children[1])
                    insert(node, node.children[3].s)
		    }
		else
		    every traverse(!node.children)
		}
	    else write("leaf ", node.label)
	    }
	 "token": {
	    if node.tok = IDENT then
	       insert(node.s)
	    }
	 "string": {
	    if node ~== self.punc then
	       write("idTaque on ", type(node), " : ", image(node))
	    }
	 "null": { }
	 default: {
	    write("idTaque on ", type(node), " : ", image(node))
	    }
	 }
    return
  end
  method String()
    if /self.l then return ""
    out := ""
    every id := !self.l do {
       if type(id) == "treenode" then id := id.children[1].s
       out := out || id || self.punc
       }
    return out[1:-1]
  end
initially
   if type(\l) ~== "list" then {
      argtree := l
      l := []
      if type(argtree) == "token" then
	 insert(argtree.s)
      else
	 traverse(argtree)
      }
end

#
# parameter lists in which the final argument may have a trailing []
# The "[]" varg parameter is passed in by the parser if it is present.
#
class argList : idTaque(varg)
  method ispublic()
    fail
  end
  method isvarg(s)
    if s == \self.varg then return s
  end
  method coercions()
   local first
      every x := !\l do
         if type(x) == "treenode" then {
	    if /first := 1 then write(yyout)
	    v := x.children[1].s
	    if x.label == ("arg3" | "arg4") then
	      write(yyout, "/", v, " := ", x.children[-1].s)
	    if x.label == ("arg2" | "arg4") then {
	      case x.children[3].s of {
		  "integer"|"string"|"numeric"|"cset"|"real": {
		      writes(yyout, v, " := ", x.children[3].s, "(",  v, ") |")
		  }
		  default: {
		      writes(yyout, "(type(",v,")==\"",x.children[3].s,"\") |")
		  }
	      }
	      writes(yyout, " runerr(")
	      writes(yyout, case x.children[3].s of {
		"integer": 101
		"numeric": 102
		"string": 103
		"cset": 104
		"file": 105
		"list": 108
		"set": 119
		"table": 124
		"window": 140
		default: 123
	      })
	      write(yyout,", ", v, ")")
	      }
	    }
  end
  method String()
    return self$idTaque.String() || ((\self.varg & "[]") | "")
  end
  method Write(f)
     writes(f,String())
  end
initially
  self.punc := ","
  self$idTaque.initially() 
end

#
# Idol class field lists in which fields may be preceded by a "public" keyword
#
class classFields : argList(publics)
  method String(s)
    if *(rv := self$argList.String()) = 0 then return ""
    if /s | (s ~== "class") then return rv
    if self$ispublic(self.l[1]) then rv := "public "||rv
    every field:=self$foreachpublic() do rv[find(","||field,rv)] ||:= "public "
    return rv
  end
  method foreachpublic()
    if \self.publics then every suspend !self.publics
  end
  method ispublic(s)
    if \self.publics then every suspend !self.publics == s
  end
  method insert(s)
    s ? {
      if ="public" & tab(many(white)) then {
	s := tab(0)
	/self.publics := []
	put(self.publics,s)
      }
    }
    return self$argList.insert(s)
  end
end

#
# find a class specification, along the IPATH if necessary
#
procedure fetchspec(name)
   static white, nonwhite
   local basedir := "."
$ifdef _MS_WINDOWS_NT
   white := ' \t;'
   nonwhite := &cset -- ' \t;'
$else
   white := ' \t'
   nonwhite := &cset -- ' \t'
$endif
   name ? {
      while basedir ||:= tab(upto('\\/')) do {
	 basedir ||:= move(1)
	 }
      name := tab(0)
      # throw away initial "." and trailing "/"
      if basedir[-1] == ("\\"|"/") then basedir := basedir[2:-1]
      }
   if f := open(basedir || "/" || env,"dr") then {
      if s := fetch(f, name) then {
	 close(f)
#	 if s[1] == "\^z" then { # need to decompress s
#	    f2 := open("gzip.out", "pw")
#	    writes(f2, s[2:0])
#	    close(f2)
#	    f2 := open("gzip -d -c gzip.out")
#	    s := reads(f2, 100000)
##	    write(&errout, "decompressed to ", *s, " bytes")
#	    close(f2)
#	    remove("gzip.out")
#	    }
	 return db_entry(basedir, s)
	 }
      close(f)
      }

   if basedir ~== "." then fail # if it gave a path, don't search IPATH

   ipath := ipaths()

   if \ipath then {
      ipath ? {
         dir := ""
	 tab(many(white))
	 while dir ||:= tab(many(nonwhite)) do {
	    if *dir>0 & dir[1]=="\"" & dir[-1] ~== "\"" then {
		dir ||:= tab(many(white)) | { fail }
	       }
	    else {
		if dir[1]==dir[-1]=="\"" then dir := dir[2:-1]
		if f := open(dir || "/" || env, "dr") then {
		    if s := fetch(f, name) then {
			close(f); return db_entry(dir, s) }
		    close(f)
		}
		tab(many(white))
		dir := ""
	    }
	}
     }
  }
end

#
# procedure to read a single Idol source file
#
procedure readspec(name)
   local s
   if not (dbe := fetchspec(name)) then
      stop("fatal: can't read spec for class ", name)

   s := dbe.entry
   fName := name
   fLine := 0
   if /s then write("fetchspec ", name, " returned null")
   s ? {
   L := []
   while line := tab(find("\n") | 0) do {
      put(L, line)
      move(1)
      if pos(0) then break
      }
   }
   fromfile := pop(L)
   while line := pop(L) do {
      line ? {
	 tab(many(white))
	 if ="class" then {
	    decl := Class()
            decl.dir := dbe.dir
	    decl.linkfile := fromfile
	    decl$Read(line,L)
	    #insert into table for lookup, but not into list for generation
	    classes$insert_t(decl,decl$name())
	    }
	 else if ="procedure" then {
	    if comp = 0 then comp := 1
	    decl := Method("")
	    decl$Read(line)
	    decl$Write(fout,"")
	    }
	 else if ="record" then {
	    if comp = 0 then comp := 1
	    decl := declaration(line)
	    decl$Write(fout,"")
	    }
	 else if =("global"|"link") then {
	    if comp = 0 then comp := 1
	    tab(many(white))
	    if pos(0) then line ||:= readln("wrap")
	    decl := vardecl(line)
	    decl$Write(fout,"")
	    }
	 else if ="const" then {
	    ct$append ( constdcl(line) )
	    }
	 else if ="method" then {
	    halt("readinput: method outside class")
	    }
	 else if upto(nonwhite) then {
	    halt("expected declaration on: ",line)
	    }
	 }
      if pos(0) then break
      }
end

#
# finds series of high-precedence expressions 
# preceding a $
#
procedure get_invoker()
    local id, rv
    rv := ""
    while any(alpha) | match(")"|"]"|"}") do {
	if id := tab(many(alpha)) then {
	   if find(" "||id||" ", reserved) then {
	      move(-*id)
	      break
	      }
	   rv ||:= id
	   if not ((tab(many(white))|"") & (rv ||:= =".")) then break
	   }
	else {
	    case &subject[&pos] of {
		")": {
		    if not (rv ||:= tab(&pos<bal(&cset,')','(')))
		    then halt("readln: can't bal ",&subject)
		}
		"]": {
		    if not (rv ||:= tab(&pos<bal(&cset,']','[')))
		    then halt("readln: can't bal ",&subject)
		}
		"}": { # deliberately use "" to keep code size smaller
		    if not (rv ||:= tab(&pos<bal(&cset,"}","{")))
		    then halt("readln: can't bal ",&subject)
		}
	    }
	}
    }
    return reverse(rv)
end

#
# filter the input translating $ references
# (also eats comments and HTML tags, and trims lines)
#
procedure readln(wrap,htmlfunc)
  /htmlfunc := dehtml
  prefix := ""
  while /finished do {

    if not (line := htmlfunc(read(fin))) then fail
    fLine +:= 1
    if line ? {
       (tab(many(white)) | "") &
	  match("$include"|"$define"|"$else"|"$endif")
       } then return line
    line ? {
       if  (tab(many(white)) | "") & tab(match("$ifdef"|"$ifndef")) then {
	  tab(many(white))
	  testedsym := tab(many(nonwhite))
	  if testedval := ct$eval(testedsym) then
	     line := "$define "|| testedsym ||" "|| testedval ||"\n"|| line
	  else
	     line := "$undef "|| testedsym ||"\n"|| line
	  return line
	  }
       }
    line[ 1(x<-find("#",line),notquote(line[1:x])) : 0] := ""
    line := trim(line,white)
#    line := selfdot(line)
    x := 1
    while ((x := find("$",line,x)) & notquote(line[1:x])) do {
      z := line[x+1:0] ||" "	     # " " is for bal()
      case line[x+1] of {
        #
        # IBM 370 digraphs
        #
        "(": line[x+:2] := "{"
        ")": line[x+:2] := "}"
        "<": line[x+:2] := "["
        ">": line[x+:2] := "]"
	#
	# $. used to be a syntax shorthand for self.
	#
	".": line[x] := "self"
        #
        # Invocation operators $! $* $@ $? (for $$ see below)
        #
        "!"|"*"|"@"|"?": {
          z ? {
	    move(1)
	    tab(many(white))
	    if not (id := tab(many(alphadot))) then {
	      if not match("(") then halt("readln can't parse ",line)
	      if not (id := tab(&pos<bal())) then
		  halt("readln: cant bal ",&subject)
	    }
	    Op := case line[x+1] of {
		"@": "activate"
		"*": "size"
		"!": "foreach"
		"?": "random"
	    }
	    if many(alpha,id) = *id + 1 then {
	       front := id || ".__m."
	       back := id
	       }
	    else {
	       tmpcount +:= 1
	       back := "__" || tmpcount
	       front := "(" || back || " := " || id || ").__m."
	       }
	    if \strict then back ||:= ".__s"
	    line[x:0] := front || Op || "(" || back || ")" || tab(0)
	  }
        }
	#
	# x $[ y ] shorthand for x$index(y)
	#
	"[": {
	    z ? {
		if not (middle := tab((&pos<bal(&cset,'[',']'))-1)[2:0]) then
		    halt("readln: can't bal([) ",&subject)
		="]"
		tail := tab(0)|""
		line := line[1:x]||"$index("||middle||")"||(tab(0)|"")||tail
	    }
	}
        default: {
	    #
	    # get the invoking object.
	    #
	    reverse(line[1:x])||" " ? {
	       tab(many(white))
	       id := get_invoker()
	       if *id = 0 then halt("readln: no invoking object precedes $")
	       objlen := &pos-1
	       }

	    if many(alpha, id) = *id + 1 then {
	       front := id||".__m."
	       back := id
	       }
	    else {
	       tmpcount +:= 1
	       back := "__"||tmpcount
	       front := "("||back||" := "||id||").__m."
	       }
	    if \strict then back ||:= ".__s"
	    #
	    # get the method name
	    #
	    z ? {
		="$"
		tab(many(white))
		if not (methodname := tab(many(alphadot))) then
		    halt("readln: expected a method name after $")
		tab(many(white))
		methodname ||:= "("
		if ="(" then {
		    tab(many(white))
		    afterlp := &subject[&pos]
		}
		else {
		    afterlp := ")"
		    back ||:= ")"
		}
		methlen := &pos-1
	    }
	    if line[x+1] == "$" then {
		c := if afterlp[1] ~== ")" then "" else "[]"
		methodname[-1] := "!("
		back := "["||back||"]|||"
	    } else {
		c := if (\afterlp)[1] == ")" then "" else ","
	    }
	    line[x-objlen : (((*line>=(x+methlen+1))|0)\1)] :=
		front || methodname || back || c
	}
      } # case
    } # while there's a $ to process
    if /wrap | (prefix==line=="") then finished := line
    else {
	prefix := prefix || line || " "			# " " is for bal()
	prefix ? {
	    # we are done if the line is balanced wrt parens and
	    # doesn't end in a continuation character (currently just ,)
	    if ((*prefix = bal()) & (not find(",",prefix[-2]))) then {
	        # add another condition or 3: we aren't done if we have
	        # a class|method|procedure declaration with no parens yet
	        if (tab(many(white)) | "") &
		   =("class"|"method"|"procedure"|"<h1>"|"<h2>") &
		   not find("(") &
		   not find("<dl>")
		then { }
		else {
		   finished := prefix[1:-1]
		   }
		}
	}
    }
  } # while / finished
  return ct$expand(finished)
end

# suspend all the HTML (4.0, at the moment) tags
procedure htmltags()
   suspend ("EM"|"STRONG"|"BLOCKQUOTE"|"Q"|"SUP"|"SUB"|
	    "H1"|"H2"|"H3"|"H4"|"H5"|"H6"|
	    "BR"|"PRE"|"INS"|"DEL"|"UL"|"OL"|"DL"|"DT"|"DD"|
	    "DIR"|"MENU"|"TABLE"|"CAPTION"|"THEAD"|"TFOOT"|"TBODY"|
	    "COLGROUP"|"COL"|"TR"|"TH"|"TD"|"LINK"|
	    "IMG"|"OBJECT"|"PARAM"|"APPLET"|"MAP"|"AREA"|"STYLE"|
	    "TT"|"BIG"|"SMALL"|"STRIKE"|"U"|"FONT"|
	    "HTML"|"HEAD"|"META"|"BODY"|
	    "BASEFONT"|"HR"|"FRAMESET"|"FRAME"|"NOFRAMES"|"IFRAME"|
	    "FORM"|"INPUT"|"BUTTON"|"SELECT"|"OPTGROUP"|"OPTION"|
	    "TEXTAREA"|"ISINDEX"|"LABEL"|"FIELDSET"|"LEGEND"|
	    "SCRIPT"|"NOSCRIPT"|"P"|"B"|"LI"|"A"|"BASE"|"I"|"S")
end

#
# Strip HTML tags.  Trivial/inefficient implementation at first, tune later.
# May someday also translate some tags into syntactic constructs; make the
# punctuation disappear in favor of WYSIWYG formatting.
# Tags are not recognized if white space occurs between the < and the tagname,
# so as to avoid conflicts with legitemate expressions that look like tags.
#
procedure dehtml(line)
   static lasttag
   rv := ""
   while line[1(x<-find("&nbsp;", line), notquote(line[1:x])) +: 6] := ""
   line ? {
      while rv ||:= tab(find("<")) do {
	 if notquote(line[1:&pos]) then {
	    tmps := move(1)
	    tmps ||:= ="/"
	    if tag := =(htmltags() | map(htmltags())) then {
	       if (attrs := tab(find(">")) & notquote(line[1:&pos])) then {
                  move(1) # throw away >
                  attrs ? {
                     if tab(find("idol=")+5) then {
                        if ="\"" then rv ||:= " " || tab(find("\"")) || " "
                        else rv ||:= " " || tab(upto(white)|0) || " "
                        }
                     }
		  }
	       else {
		  rv ||:= tmps
		  rv ||:= tag
		  }
	       }
	    else {
	       rv ||:= tmps # not a tag, move on
	       }
	    }
	 else rv ||:= move(1)
         }
      rv ||:= tab(0)
      }

   return rv
end