#  preprocessor.icn -- complete Icon preprocessor.

#
# Icon Preprocessor procedures
#
# Invocation:
#
#   preprocessor(fname,predefined_syms)
#
#       fname - the filename to preprocess
#
#       predefined_syms - (optional) a table of symbols & definitions to
#               serve as preprocessor "predefined" symbols
#

# This preprocessor comes to Unicon courtesy of Bob Alexander, its author.
# It was obtained from the Jcon distribution, with minimal edits.

#
# a_Global declarations of variables in the preprocessor "object"
#
global preproc_sym_table,preproc_if_stack,preproc_file_stack,preproc_if_state,
        preproc_file,preproc_filename,preproc_line,preproc_print_line,
        preproc_word_chars,preproc_nest_level,preproc_include_name,
        preproc_include_set,preproc_print_filename,preproc_command,
        preproc_err_count, preproc_dollar_or_pound

procedure predefs()
    local s, t

    t := table()

    # reverse engineer the predefined symbols list from our predefined symbols
    t["_V9"] := 1
    if comp === -1 then
    t["_NOLINK"] := 1
    else
    t["_LINK"] := 1

    every s := &features do {
        t[case s of {
# _CMS # gone
            "CMS": "_CMS"
            "MacOS":"_MACOS"
            "MS Windows NT":"_MS_WINDOWS_NT"
            "MS-DOS":"_MSDOS"
            "MVS":"_MVS"
# _PORT # in use
            "PORT":"_PORT"
            "UNIX":"_UNIX"
            "Solaris":"_SOLARIS"
            "POSIX":"_POSIX"
            "DBM":"_DBM"
            "VMS":"_VMS"
            "ASCII":"_ASCII"
            "EBCDIC":"_EBCDIC"
            "co-expressions":"_CO_EXPRESSIONS"
            "native coswitch":"_NATIVECOSWITCH"
            "concurrent threads":"_CONCURRENT"
            "concurrent threads, compiler subset":"_CONCURRENT"
            "console window":"_CONSOLE_WINDOW"
            "dynamic loading":"_DYNAMIC_LOADING"
# "" environment variables
            "event monitoring":"_EVENT_MONITOR"
            "external functions":"_EXTERNAL_FUNCTIONS"
            "keyboard functions":"_KEYBOARD_FUNCTIONS"
            "large integers":"_LARGE_INTEGERS"
            "multiple programs":"_MULTITASKING"
            "pattern type":"_PATTERNS"
            "pipes":"_PIPES"
            "pseudo terminals":"_PTY"
            "system function":"_SYSTEM_FUNCTION"
            "messaging":"_MESSAGING"
            "graphics":"_GRAPHICS"
            "3D graphics":"_3D_GRAPHICS"
            "X Windows":"_X_WINDOW_SYSTEM"
            "MS Windows":"_MS_WINDOWS"
            "Win32":"_WIN32"
            "MS-DOS extensions":"_DOS_FUNCTIONS"
            "libz file compression":"_LIBZ_COMPRESSION"
            "JPEG images":"_JPEG"
            "PNG images":"_PNG"
            "SQL via ODBC":"_SQL"
            "secure sockets layer encryption":"_SSL"
            "Audio":"_AUDIO"
            "Voice Over IP":"_VOIP"
            "operator overloading":"_OVLD"
            "developer mode":"_DEVMODE"
        }] := "1"
    }

    # there is no predefn for "environment variables" feature
    t["__DATE__"] := "\"" || &date || "\""
    t["__TIME__"] := "\"" || &clock || "\""

    # define a symbol that can be used to distinguish when iconc is available
$ifdef Uniconc
   t["UNICONC"] := "1"
$endif
    # predefine a symbol that can be used to distinguish when iconc is used.
    if \iconc then {
      t["COMPILER"] := "1"
#      t["_COMPILED"] := "1"  # see test preproc.icn
#       ^ requires &features to have "compiled" when a prog is compiled
      # at present, iconc implies various features will be absent...
      every delete(t, "_EVENT_MONITOR" | "_MULTITASKING"| "_OVLD")
      if NoConcurrentCOMPILER() then delete(t,"_CONCURRENT")
      if not member(fset,"l") then  delete(t,"_LARGE_INTEGERS") # no -fl
      }
    return t
end

procedure preproc(dummy, args)
    suspend preprocessor(args[1], predefs())
end

#
# Preprocesses a file, generating output lines.
#
procedure preprocessor(fname,predefined_syms)
    local line, result, tmppos
    static nonpunctuation
    initial {
        nonpunctuation := &letters ++ &digits ++ ' \t\f\r'
    }

    preproc_new(fname,predefined_syms)

    while line := preproc_read() do line ? {
        preproc_space()
        if (preproc_dollar_or_pound := ="#") &
           tmppos := &pos & ="line" & tab(any(' \t')) then {
            &pos := tmppos
            suspend preproc_scan_directive()
        }
        if (preproc_dollar_or_pound := ="$") & any(nonpunctuation) then {
            suspend preproc_scan_directive()
        } else {
            &pos := 1
            suspend preproc_scan_text()
        }
    }
    preproc_line +:= 1
    suspend preproc_sync_lines()
    if type(fname) ~== "list" then
      close(preproc_file)
    preproc_done()
end

#
# a_Initializes the preprocessor "object".
#
procedure preproc_new(fname,predefined_syms)
   if type(fname) == "list" then {
      preproc_file := fname
      preproc_include_set := set([type(fname)])
      preproc_filename := preproc_include_name := type(fname)
      }
   else {
      if fname == "_stdin.icn" then
         preproc_file := &input
      else
      # Normal file execution
      preproc_file := open(fname) |
         stop(&progname, ": cannot open ", image(fname))

      preproc_include_set := set([fname])
      preproc_filename := preproc_include_name := fname
      }
   preproc_sym_table := copy(\predefined_syms) |table()
   preproc_if_stack := []
   preproc_file_stack := []
   preproc_if_state := &null
   preproc_word_chars := &letters ++ &digits ++ '_'
   preproc_line := preproc_print_line := 0
   preproc_print_filename := &null
   preproc_nest_level := 0
   preproc_err_count := 0
   return
end

#
# Clears the values of certain space-consuming variables.
#
procedure preproc_done()
    preproc_sym_table := preproc_if_stack := preproc_file_stack :=
            preproc_filename := preproc_print_filename :=
            preproc_file := preproc_include_set := &null
    return
end

#
# a_Scans a preprocessor directive.
#
procedure preproc_scan_directive()
   local sym,value,new_file,new_filename,new_line,path_list,old
   local cincludes, line, Cend, stub
   preproc_space()
   preproc_command := preproc_word()
   if \preproc_if_state then {
      if match("if",preproc_command) then {
         preproc_command := "$if"
         }
      }
   preproc_space()
   case preproc_command of {
      "define": {
         if /preproc_if_state then {
            if sym := preproc_word() then {
               if value := preproc_scan_define_value() then {
                  if \(old := preproc_sym_table[sym]) ~=== value then {
                     preproc_error("redefinition of " || sym || " = " ||
                                   old)
                     }
                  else {
                     preproc_sym_table[sym] := value
                     }
                  }
               }
            else {
               preproc_error()
               }
            }
        }
        "undef": {
            if /preproc_if_state then {
                if sym := preproc_word() &
                        preproc_at_end() then {
                    delete(preproc_sym_table,sym)
                } else {
                    preproc_error()
                }
            }
        }
        "ifdef" | "ifndef": {
            push(preproc_if_stack,preproc_if_state)
            if sym := preproc_word() &
                    preproc_at_end() then {
                if /preproc_if_state then {
                    value := (\preproc_sym_table[sym] & &null) | "false"
                    if match("n",preproc_command,3) then {
                        value := (\value & &null) | "false"
                    }
                    preproc_if_state := value
                } else {
                    preproc_if_state := "off"
                }
            } else {
                preproc_if_state := "off"
                preproc_error()
            }
        }
        "$if": {    # handles if... command in "if'd-out" code
                push(preproc_if_stack,preproc_if_state)
                preproc_if_state := "off"
        }
        "else": {
            if preproc_at_end() then {
                if *preproc_if_stack <= preproc_nest_level then {
                    preproc_error("no corresponding $if...")
                } else {
                    #preproc_if_state := (\preproc_if_state & &null) | "done"
                    preproc_if_state := {
                        case preproc_if_state of {
                            "false": &null
                            "off": "off"
                            default: "false"
                        }
                    }
                }
            } else {
                preproc_error()
            }
        }
        "endif": {
            if preproc_at_end() then {
                (*preproc_if_stack >= preproc_nest_level &
                        preproc_if_state := pop(preproc_if_stack)) |
                        preproc_error("no corresponding $if...")
            } else {
                *preproc_if_stack >= preproc_nest_level &
                        preproc_if_state := pop(preproc_if_stack)
                preproc_error()
            }
        }
        "include": {
            if /preproc_if_state then {
                path_list := lpaths_get()
                if sym := preproc_qword() & *sym > 0 &
                        preproc_at_end() then {
                    if member(preproc_include_set,sym) then {
                        preproc_error("circular reference to " || image(sym))
                    } else {
                        if new_file := open(
                              new_filename := sym | (!path_list || "/" || sym))
                              then {
                            push(preproc_file_stack,
                                 preproc_file,preproc_filename,
                                 preproc_include_name,preproc_line,
                                 preproc_nest_level)
                            preproc_filename := new_filename
                            preproc_include_name := sym
                            preproc_file := new_file
                            preproc_line := 0
                            preproc_nest_level := *preproc_if_stack
                            insert(preproc_include_set,sym)
                        } else {
                            preproc_error("cannot open " || image(sym))
                        }
                    }
                } else {
                    preproc_error()
                }
            }
        }
        "line": {
            #if /preproc_if_state then {
                new_line := new_filename := &null
                if new_line := integer(tab(many(&digits))) &
                        preproc_opt_space() &
                        (new_filename := preproc_qword() | &null) \ 1 &
                        (/new_filename | *new_filename > 0) \ 1 &
                        preproc_at_end() then {
                    preproc_filename := \new_filename
                    preproc_line := new_line
                } else {
                   if \preproc_dollar_or_pound == "$" then {
                       if /new_line then
                           preproc_error("$line: expected a line number.")
                       else preproc_error("$line: expected only \"file\" after line number.")
                   }
                   else # it was just a comment beginning with #line
                      tab(find("\n") | 0)
                }
            #}
        }
        "error": {
            if /preproc_if_state then {
                preproc_space()
                preproc_error(trim(tab(find("#") | 0),' \t\f\r'))
            }
        }
        "ITRACE": {
            if /preproc_if_state then {
                if value := integer(tab(many(&digits ++ '-'))) &
                        preproc_at_end() then {
                    &trace := value
                } else {
                    preproc_error()
                }
            }
        }
        "C":{
           if /preproc_if_state then {
               cincludes := ""
               while line := preproc_read() do {
                   if match("$Cend", line) then {Cend := "yes"; break}
                   cincludes ||:= line
               }
               if /Cend then {
                   preproc_error("unfinished C code block")
               }
               stub := CIncludesParser(cincludes)
               # write("------ stub ------"); write(stub); write(repl("-",19))
               return stub
           }
       }
    default: {
            if /preproc_if_state then {
                preproc_error("unknown preprocessor directive")
            }
        }
    }
    preproc_command := &null
end

#
# a_Scans and make substitutions in a text line.
#
procedure preproc_scan_text(done_set)
    local q,result,p,interesting_in_quotes,ident,value
    static interesting_chars
    initial {
        interesting_chars := '#"\'_' ++ &letters
    }
    if /preproc_if_state then {
        if *preproc_sym_table > 0 then {
            &pos := q := 1
            result := ""
            while tab(upto(interesting_chars)) do {
                case move(1) of {
                    "#": {
                        move(-1)
                        tab(0)
                    }
                    "\"" | "'": {
                        interesting_in_quotes := '\\' ++ &subject[&pos - 1]
                        repeat {
                            while tab(upto(interesting_in_quotes)) do {
                                case move(1) of {
                                    "\\": {
                                       # backslash can eat multiple chars;
                                       # may need more than this
                                       case move(1) of {
                                          "^": move(1)
                                          }
                                       }
                                    default: {
                                        break break
                                    }
                                }
                            }
                            suspend preproc_sync_lines()
                            suspend if q = 1 then .&subject else
                                    result || &subject[q:0]
                            if not match("_",trim(&subject),-1) then {
                                break
                            }
                            &subject := preproc_read() | fail
                            # we have just read the next line and incremented
                            # preproc_line; treat previous line as if already
                            # printed.
                            preproc_print_line := preproc_line-1
                            # preproc_line +:= 1 # already incr'd by pp_read
                            result := ""
                        }
                    }
                    default: {
                        move(-1)
                        p := &pos
                        ident := tab(many(preproc_word_chars))
                        if value := \preproc_sym_table[ident] then {
                            if /done_set |
                                    {type(done_set) == "string" &
                                        done_set := set([done_set])
                                    not member(done_set,ident)} then {
                                value ? value :=
                                    preproc_scan_text(insert(copy(\done_set),
                                                             ident) | ident)
                                result ||:= &subject[q:p] || value
                                q := &pos
                            }
                        }
                    }
                }
            }
            if /done_set then {
                suspend preproc_sync_lines()
            }
            suspend if q = 1 then .&subject else result || &subject[q:0]
        }
        else {
            suspend preproc_sync_lines()
            suspend .&subject
            #suspend image(preproc_filename) || ":" ||
            #        preproc_line || " " || &subject
        }
        preproc_print_line := preproc_line
    }
end

#
# Reads an input line.  Manages end-of-file and reverting to including
# file if appropriate, failing at end-of-input.
#
procedure preproc_read()
   local result
   until result := preproc_read_result() do {
      if *preproc_if_stack ~= preproc_nest_level then {
         preproc_error("$if(s) without $endif(s): " ||
                       *preproc_if_stack - preproc_nest_level)
         until *preproc_if_stack <= preproc_nest_level do
            preproc_if_state := pop(preproc_if_stack)
         }
      if type(preproc_file) ~== "list" & preproc_file ~=== &input then
         close(preproc_file)
      delete(preproc_include_set,preproc_include_name)
      (preproc_nest_level := pop(preproc_file_stack) &
       preproc_line := pop(preproc_file_stack) &
       preproc_include_name := pop(preproc_file_stack) &
       preproc_filename := pop(preproc_file_stack) &
       preproc_file := pop(preproc_file_stack)) | fail
      }
   preproc_line +:= 1
   return result
end

# Auxiliary read method; "reads" from a file or an in-memory list of strings.
procedure preproc_read_result( )
   if type(preproc_file) == "list" then
      return pop(preproc_file)
   else
      return read(preproc_file)
end

#
# a_Scans an identifier.
#
procedure preproc_word()
    static word_starters
    initial {
        word_starters := &letters ++ '_'
    }
    suspend any(word_starters) & tab(many(preproc_word_chars))
end

#
# a_Scans a possibly-quoted word (e.g. a file name).
#
procedure preproc_qword()
    local result
    suspend (="\"" &
        result := tab(find("\"")) &
        not match("\\",,&pos - 1) &
        move(1) & preproc_istring(result)) |
        preproc_word()
end

#
# a_Scans the value of a $define.
#
procedure preproc_scan_define_value()
   local q,interesting_in_quotes
   static interesting_chars
   initial interesting_chars := '#"\''

   if ="(" then {
      preproc_error("no space before (; args are not supported.")
      fail      # "$define name(" is specifically prohibited; needs whitespace
      }
    preproc_space()
    q := &pos
    (while tab(upto(interesting_chars)) do {
        case move(1) of {
            "#": {
                move(-1)
                break
            }
            default: {
                interesting_in_quotes := '\\' ++ &subject[&pos - 1]
                repeat {
                    while tab(upto(interesting_in_quotes)) do {
                        case move(1) of {
                            "\\": move(1)
                            default: {
                                break break
                            }
                        }
                    }
                    preproc_error("unterminated string in $define")
                    fail # end of line inside quotes!!
                }
            }
        }
    }) | tab(0)
    return trim(&subject[q:&pos],' \t\f\r')
end

#
# a_Scans white space.
#
procedure preproc_space()
    suspend tab(many(' \t\f\r'))
end

#
# a_Scans optional white space.
#
procedure preproc_opt_space()
    local i
    suspend if i := many(' \t\f\r') then tab(i) else ""
end

#
# Tests for &pos at the logical end of a preprocessor directive.
#
procedure preproc_at_end()
    preproc_space()
    return pos(0) | match("#")
end

#
# Outputs an error message.
#
procedure preproc_error(msg)
    local filename, outTxt
    static non_shell_word_chars
    initial non_shell_word_chars := ~(&letters ++ &digits ++ '_.-')
    /msg := "syntax error"
    filename := preproc_filename
    if upto(non_shell_word_chars,filename) then {
        filename := image(filename)
    }
    outTxt := "File " || filename || "; Line " || preproc_line || " # " ||
        (("$" || \preproc_command || ": ") | "") || msg
    preproc_err_count +:= 1
    /parsingErrors := []
    push( parsingErrors, ParseError( preproc_line, outTxt))
    return
end

#
# Determines if a "#lines" is called for and generates one if so.
#
procedure preproc_sync_lines()
    local delta
    if preproc_filename ~=== preproc_print_filename then {
        suspend "#line " || preproc_line - 1 || "\"" || preproc_filename || "\""
        preproc_print_filename := preproc_filename
    }
    else {
        delta := preproc_line - preproc_print_line
        #write(&errout,"+++++ preproc_line = ",image(preproc_line),
        #   "; preproc_print_line = ",image(preproc_print_line),
        #   "; delta = ",image(delta))
        if delta ~= 1 then {
            if 1 < delta < 20 then {
                suspend 2 to delta & ""
            } else {
                suspend "#line " || preproc_line - 1 || "\"" || preproc_filename || "\""
            }
        }
    }
    preproc_print_line := preproc_line
end

#
# Makes escape-sequence substitutions in an Icon-type string literal.
#
procedure preproc_istring(s)
    local r,c
    r := ""
    s ? {
        while r ||:= tab(upto('\\')) do {
            move(1)
            r ||:= case c := map(move(1)) of {
                "b": "\b"       # backspace
                "d": "\d"       # delete (rubout)
                "e": "\e"       # escape (altmode)
                "f": "\f"       # formfeed
                "l": "\l"       # linefeed (newline)
                "n": "\n"       # newline (linefeed)
                "r": "\r"       # carriage return
                "t": "\t"       # horizontal tab
                "v": "\v"       # vertical tab
                "x": preproc_istring_radix(16,2)# hexadecimal code
                "^": char(ord(move(1)) % 32) | break # control code
                default: {      # either octal code or non-escaped character
                    if any('01234567',c) then { # if octal digit
                        move(-1)
                        preproc_istring_radix(8,3)
                    }
                    else c          # else non-escaped character
                } | break
            }
        }
        r ||:= tab(0)
    }
    return r
end

#
# Handles character-code specification in string literal.
#
procedure preproc_istring_radix(r,max)
  local n,d,i,c
  d := "0123456789abcdef"[1:r + 1]
  n := 0
  every 1 to max do {
      c := move(1) | break
      if not (i := find(map(c),d) - 1) then {
          move(-1)
          break
      }
      n := n * r + i
  }
  return char(n)
end
