;+
; NAME:
;   PROREND
;
; AUTHOR:
;   Craig B. Markwardt, NASA/GSFC Code 662, Greenbelt, MD 20770
;   craigm@lheamail.gsfc.nasa.gov
;
; PURPOSE:
;   Render a PRODIS abstract syntax tree into IDL Language Text
;
; CALLING SEQUENCE:
;   PROREND, TREE, TEXT, [ /INIT ]
;
; DESCRIPTION: 
;
;   PROREND converts an abstract syntax tree as returned by PRODIS,
;   into a human-readable form, written in the IDL programming
;   language.  The abstract syntax tree format is a set of linked data
;   structures, and is derived from the raw data on disk.  The human
;   readable form is returned as an array of strings that can be
;   printed to the console or a file.
;
;   The abstract syntax tree is generated by PRODIS, an external
;   procedure in the same library.  The standard approach is to use
;   the following steps:
;
;       1. Use PRODIS to convert raw bytes to abstract syntax tree
;       2. Use PROREND to convert abstract syntax tree to IDL language
;
;   The external routine PROTRANS does the end-to-end conversion steps
;   of both PRODIS and PROREND for you.
;
;   At the moment there is relatively little flexibility in how the
;   IDL code is rendered to text.  For example, all reserved keywords
;   and variables appear in upper-case letters, and array indexing
;   syntax is expressed with round ()'s instead of square []'s.
;   Suggestions on how to achieve this are solicited.
;
;   PROREND does not free the TREE structure.  The user is responsible
;   to do this using the PROFREE procedure.
;   
;
; COMPATIBILITY:
;
;   -- File Format --
;
;   PROREND accepts any tree provided by PRODIS.  PRODIS cannot
;   examine compressed save files.  It is able to read and translate
;   SAVE files produced by IDL 4, and IDL versions 5.0 through 5.5.
;   The output of PROREND should be compatible with IDL 4 and 5.
;
;   This procedure is part of the CMSVLIB SAVE library for IDL by
;   Craig Markwardt.  You must have the full CMSVLIB core package
;   installed in order for this procedure to function properly.
;
; INPUTS:
;
;   TREE - the abstract syntax tree, as returned by PRODIS.  This
;          structure is unmodified by PROREND.
;
;   TEXT - upon output, the IDL code is placed in as an array of
;          strings in TEXT.  By default, any new IDL code will be
;          *appended* to TEXT.  Use the /INIT keyword to overwrite the
;          existing contents of TEXT.
;
;
; KEYWORDS:
;
;   INIT - if set, then overwrite the TEXT array with the new IDL
;          code.  By default (INIT not set), any new IDL code is
;          *appended* to TEXT.
;  
; EXAMPLE:
;
;   This example compiles a test function, saves it to a file called
;   test_pro.sav, and then disassembles the save file into a syntax
;   tree using PRODIS.  Finally, the syntax tree is converted to IDL
;   text, which is printed to the console.
;
;     IDL> .comp 
;     - pro test_pro, x
;     -   x = x + 1
;     -   return
;     - end
;     % Compiled module: TEST_PRO.
;     IDL> save, 'test_pro', /routine, file='test_pro.sav'
;     IDL> prodis, 'test_pro.sav', prodecl, tree
;     IDL> prorend, tree, text
;     IDL> print, text, format='(A)'
;     PRO TEST_PRO, X
;       ;; Beginning of code
;       X = X+1
;       RETURN
;     END
;
;
; SEE ALSO:
;
;   PRODIS, PROREND, CMSAVEDIR, CMSVLIB
;
; MODIFICATION HISTORY:
;   Written, 2000-2002, CM
;   Documented, 19 Mar 2002, CM
;   Added PRN_STRCAT, to avoid an internal library function, 22 Mar
;     2002, CM
;   
;
; $Id: prorend.pro,v 1.13 2002/03/22 22:01:11 craigm Exp $
;
;-
; Copyright (C) 2000-2002, Craig Markwardt
; This software is provided as is without any warranty whatsoever.
; Permission to use, copy, modify, and distribute modified or
; unmodified copies is granted, provided this copyright and disclaimer
; are included unchanged.
;-

;; Utility function: concatenate string array
function prn_strcat, strings, joinstring=joinstring

  if n_elements(strings) EQ 0 then return, ''
  if n_elements(strings) EQ 1 then return, strings(0)

  n_strings = n_elements(strings)
  
  fmt = '('+strtrim(n_strings,2)+'(A,:))'
  mystrings = strings
  if n_strings GT 1 AND n_elements(joinstring) EQ 1 then $
    mystrings(0:n_strings-2) = mystrings(0:n_strings-2) + joinstring(0)

  return, (string(mystrings, format=fmt))(0)
end

;; Utility function: push a value onto the stack
pro prn_push, stack, val, nstack=nstack, template=node0
  nvals = n_elements(val)
  if n_elements(nstack) EQ 0 then nstack = n_elements(stack)
  if n_elements(val) EQ 0 then return

  n2 = nvals + nstack
  if n_elements(stack) LT n2 then begin
      if n_elements(node0) EQ 0 then node0 = ''
      if n_elements(stack) EQ 0 then begin
          stack = replicate(node0(0), (n_elements(val)*2) > 10)
      endif else begin
          stack = [stack, replicate(node0(0),((n2-nstack)*5) > 10) ]
      endelse
  endif
  
  stack(nstack) = val
  nstack = n2
  return
end

;; Utility function: extract operand from tree
function prn_opn, prodecl, ptr, type=type, embed=embed, last_operation=lastop

  if n_elements(ptr) EQ 0 then return, ''

  sz = size(ptr)
  if sz(sz(0)+1) EQ 10 then begin
      if ptr_valid(ptr(0)) EQ 0 then return, ''
      x = *ptr
  endif else if sz(sz(0)+1) EQ 8 then begin
      x = ptr
  endif else begin
      return, ''
  endelse

  ntext1 = 0L
  prn_parse, prodecl, x, text1, nstack=ntext1, last_operation=lastop

  type = x(0).type
  op = text1(ntext1-1)

  if keyword_set(embed) then begin
      if (type AND 7) EQ 0 then op = '('+op+')'
  endif
    
  return, op
end

;; NODE: 'RETURN'
function prn_return, prodecl, tree

  str = 'RETURN'

  if ptr_valid(tree(0).operands(0)) then $
    str = str + ', ' + prn_opn(prodecl, tree(0).operands(0))
  
  return, str
end

;; NODE: 'UNOP' or 'BINOP'
function prn_ubop, prodecl, tree, binop=binop, unop=unop

  opn0 = prn_opn(prodecl, tree(0).operands(0), type=type0, /embed)
  op = tree(0).value

  ;; Spaces between operands and operation
  sp = ''
  b = (byte(op(0)))(0)
  ;; For alpha op, add space
  if b GE '41'xb AND b LE '7a'xb then sp = ' ' 

  if keyword_set(binop) then begin
      opn1 = prn_opn(prodecl, tree(0).operands(1), type=type1, /embed)

      if sp EQ '' AND (op EQ '+' OR op EQ '-') then begin
          l = strmid(opn0, strlen(opn0)-1, 1)
          ;; Trailing D or E must not be confused with coming + or -
          if l EQ 'D' OR l EQ 'E' then sp = ' '
      endif

      return, opn0+sp+op+sp+opn1
  endif else if keyword_set(unop) then begin
      return, op+sp+opn0
  endif

  return, ''
end

;; NODE: 'ASSIGN'
pro prn_assign, prodecl, tree, text, nstack=ntext, prefix=prefix
  if n_elements(prefix) EQ 0 then prefix = ''
  if (tree(0).type AND 8) NE 0 then pf = prefix else pf = ''

  opn0 = prn_opn(prodecl, tree(0).operands(0), type=type0)
  opn1 = prn_opn(prodecl, tree(0).operands(1), type=type1)

  ;; Nested assignments must be protected
  if (type1 AND 8) NE 0 then $
    opn1 = '('+opn1+')'

  prn_push, text, pf+opn0+' = '+opn1, nstack=ntext
  return
end

;; NODE: 'SUBSCRIPT' (subscripted variable)
function prn_subscript, prodecl, tree, text, nstack=ntext
  lval = prn_opn(prodecl, tree(0).operands(0), type=type0, /embed)
  ;; Protect against functions being subscripted
  if (type0 AND 4) NE 0 then lval = '('+lval+')'

  ndims = long(tree(0).value)
  dims = *(tree(0).operands(1))

  dimstr = strarr(ndims)

  for i = 0, ndims-1 do begin
      v = dims(i).value
      case dims(i).op of
          'SUB': begin      ;; Single value '*'
              if v EQ 'ALL' then dimstr(i) = '*'
          end
          'SUBRANGE': begin ;; Range of values, either A:B or A:*
              opn1 = prn_opn(prodecl, dims(i).operands(0))
              if (*dims(i).operands(1)).value EQ 'END' then $
                opn2 = '*' $
              else $
                opn2 = prn_opn(prodecl, dims(i).operands(1))
              dimstr(i) = opn1+':'+opn2
          end
          ELSE: begin       ;; Single value A
              dimstr(i) = prn_opn(prodecl, dims(i))
          end
      endcase
  endfor

  ;; Compose lval with dimensions
  return, lval+'('+prn_strcat(dimstr, join=',')+')'
end

;; NODE: 'PROCALL' or 'METHCALL'
pro prn_procall, prodecl, tree, text, nstack=ntext, prefix=prefix, $
                 method=meth, funct=funct, statement=stmt

  if n_elements(prefix) EQ 0 then prefix = ''

  ;; Basics about the function or procedure
  proname = tree(0).value
  protype = tree(0).type
  funct = (protype AND 4) NE 0
  stmt = (funct EQ 0)

  ;; Handle case of a class method
  if keyword_set(meth) then begin
      dest = prn_opn(prodecl, tree(0).operands(0), type=dtype)
      if (dtype AND 3) EQ 0 then dest = '('+dest+')'
      proname = dest + '->' + proname
      args = tree(0).operands(1)
  endif else begin
      args = tree(0).operands(0)
  endelse

  ;; Append arguments, both positional and keyword ones
  argstr = ''
  nargs = n_elements(*(args))
  if nargs GT 0 then begin
      args = *(args)
      argstr = strarr(nargs)
      for i = 0, nargs-1 do begin
          if args(i).op EQ 'KEYWORD' then begin
              kword = args(i).value
              argstr(i) = kword+'='+prn_opn(prodecl, args(i).operands(0))
          endif else begin
              argstr(i) = prn_opn(prodecl, args(i))
          endelse
      endfor
      argstr = prn_strcat(argstr, join=', ')
  endif

  ;; Express as the form as a function or a procedure
  if funct then begin
      proval = proname+'('+argstr+')'
  endif else begin
      if argstr EQ '' then $
        proval = proname $
      else $
        proval = proname+', '+argstr
  endelse

  if stmt then proval = prefix+proval
  prn_push, text, proval, nstack=ntext
end

;; NODE: 'ARRAY'  (square-brackets style array)
function prn_array, prodecl, tree
  elts = tree(0).operands(0)
  if n_elements(*elts) EQ 0 then return, '[]'
  nelts = n_elements(*elts)
  elts = *elts
  eltstr = strarr(nelts)
  
  for i = 0, nelts-1 do begin
      eltstr(i) = prn_opn(prodecl, elts(i))
  endfor

  return, '['+prn_strcat(eltstr,join=', ')+']'
end

;; NODE: 'PDEREF' (pointer dereference)
function prn_pderef, prodecl, tree
  opn = prn_opn(prodecl, tree(0).operands(0), type=type0)
  if (type0 AND 2) EQ 0 then opn = '('+opn+')'
  return, '*'+opn
end

;; NODE: 'FOR' (for-loop construct)
pro prn_for, prodecl, tree, text, nstack=ntext, prefix=prefix
  if n_elements(prefix) EQ 0 then prefix = ''
  
  lval = prn_opn(prodecl, tree(0).operands(0))

  ;; Parse START, STOP, STEP range values
  rng  = *(tree(0).operands(1))
  nrng = n_elements(rng)
  rngstr = strarr(nrng)
  for i = 0, nrng-1 do $
    rngstr(i) = prn_opn(prodecl, rng(i))
  rngstr = prn_strcat(rngstr, join=', ')

  ;; Parse body of FOR loop
  body = *(tree(0).operands(2))
  prn_parse, prodecl, body, bodytext, nstack=nbodytext, prefix=''

  ;; Choose long or short form for FOR loop
  if nbodytext EQ 1 then begin
      prn_push, text, nstack=ntext, $
        prefix+'FOR '+lval+' = '+rngstr+' DO '+bodytext(0)
  endif else begin
      prn_push, text, nstack=ntext, $
        prefix+'FOR '+lval+' = '+rngstr+' DO BEGIN'
      if nbodytext GT 0 then $
        prn_push, text, nstack=ntext, $
        prefix+'    '+bodytext(0:nbodytext-1)
      prn_push, text, nstack=ntext, $
        prefix+'ENDFOR'
  endelse
      
  return
end

;; NODE: 'IF' (if-then-else construct)
pro prn_if, prodecl, tree, text, nstack=ntext, prefix=prefix
  if n_elements(prefix) EQ 0 then prefix = ''
  expr = prn_opn(prodecl, tree(0).operands(0))

  ;; Extract body of the IF clause
  if ptr_valid(tree(0).operands(1)) GT 0 then begin
      if n_elements(*(tree(0).operands(1))) EQ 0 then $
        goto, NOIFBODY
      ifbody = *(tree(0).operands(1))
      prn_parse, prodecl, ifbody, ifbodytext, nstack=nifbodytext, prefix=''
  endif else begin
      NOIFBODY:
      ifbodytext = ''
      nifbodytext = 0L
  endelse

  ;; Extract body of the ELSE clause
  if ptr_valid(tree(0).operands(2)) GT 0 then begin
      if n_elements(*(tree(0).operands(2))) EQ 0 then $
        goto, NOELBODY
      elbody = *(tree(0).operands(2))
      prn_parse, prodecl, elbody, elbodytext, nstack=nelbodytext, prefix=''
  endif else begin
      NOELBODY:
      elbodytext = ''
      nelbodytext = 0L
  endelse

  if nifbodytext EQ 1 AND nelbodytext LE 1 then begin
      ;; Case of "IF expr THEN stmt ELSE stmt"
      ifstr = 'IF '+expr+' THEN '+ifbodytext(0)
      if nelbodytext GT 0 then $
        ifstr = ifstr + '   ELSE   '+elbodytext(0)
      prn_push, text, nstack=ntext, $
        prefix+ifstr
  endif else begin
      ;; Case of "IF epxr THEN BEGIN & stmts & ENDIF ..."
      prn_push, text, nstack=ntext, $
        prefix+'IF '+expr+' THEN BEGIN'
      if nifbodytext GT 0 then $
        prn_push, text, nstack=ntext, $
        prefix+'    '+ifbodytext(0:nifbodytext-1)
      if nelbodytext EQ 0 then begin
          prn_push, text, nstack=ntext, $
            prefix+'ENDIF'
      endif else begin
          ;; "... ELSE BEGIN & stmts & ENDELSE"
          prn_push, text, nstack=ntext, $
            prefix+'ENDIF ELSE BEGIN'
          prn_push, text, nstack=ntext, $
            prefix+'    '+elbodytext(0:nelbodytext-1)
          prn_push, text, nstack=ntext, $
            prefix+'ENDELSE'
      endelse
  endelse          

  return
end

;; NODE: 'WHILE' (while-loop construct)
pro prn_while, prodecl, tree, text, nstack=ntext, prefix=prefix
  if n_elements(prefix) EQ 0 then prefix = ''
  expr = prn_opn(prodecl, tree(0).operands(0))

  ;; Parse body of WHILE loop
  body = *(tree(0).operands(1))
  prn_parse, prodecl, body, bodytext, nstack=nbodytext, prefix=''

  ;; Choose either long or short form for the WHILE loop
  if nbodytext EQ 1 then begin
      prn_push, text, nstack=ntext, $
        prefix+'WHILE '+expr+' DO '+bodytext(0)
  endif else begin
      prn_push, text, nstack=ntext, $
        prefix+'WHILE '+expr+' DO BEGIN'
      if nbodytext GT 0 then $
        prn_push, text, nstack=ntext, $
        prefix+'    '+bodytext(0:nbodytext-1)
      prn_push, text, nstack=ntext, $
        prefix+'ENDWHILE'
  endelse

  return
end

;; NODE: 'TRICOND' (triple condition of the form TEST ? A : B)
function prn_tricond, prodecl, tree
  expr   = prn_opn(prodecl, tree(0).operands(0), type=type0, /embed)
  ifstmt = prn_opn(prodecl, tree(0).operands(1), type=type1, /embed)
  elstmt = prn_opn(prodecl, tree(0).operands(2), type=type2, /embed)

  return, expr+'?'+ifstmt+':'+elstmt
end

;; NODE: 'ON_IOERROR'
function prn_onioerror, prodecl, tree
  mark = 'MARK$'+strtrim(tree(0).value)
  if tree(0).value EQ '0' then mark = 'NULL'
  return, 'ON_IOERROR, '+mark
end

;; NODE: 'STRUCTREF' (reference to a structure
function prn_structref, prodecl, tree
  lval = prn_opn(prodecl, tree(0).operands(0), type=type0, /embed)
  ;; Protect against functions being structref'd
  if (type0 AND 4) NE 0 then lval = '('+lval+')'

  ;; Error checking
  tags = tree(0).operands(1)
  if ptr_valid(tags) EQ 0 then return, lval
  if n_elements(*tags) EQ 0 then return, lval

  ;; Chain the structure references together, using PRN_OPN to
  ;; recurse.
  ntags = long(tree(0).value)
  tags = *tags
  tagstr = strarr(ntags)
  for i = 0, ntags-1 do begin
      tag = tags(i)
      tagval = prn_opn(prodecl, tags(i), last_op=lastop)
      if lastop NE 'TAGNAME' AND lastop NE 'TAGSUBSCRIPT' then $
        tagval = '('+tagval+')'

      tagstr(i) = tagval
  endfor

  return, prn_strcat([lval, tagstr], join='.')
end

;; NODE: 'STRUCT' (structure definition)
function prn_struct, prodecl, tree

  ;; Extract the tree associated with this structure definition
  if ptr_valid(tree(0).operands(0)) then $
    if n_elements(*tree(0).operands(0)) GT 0 then begin
      tagvals = *tree(0).operands(0)
      ntags = n_elements(tagvals)

      ;; Scan through the branches of the tree, looking for the three
      ;; kinds.
      sstr = strarr(ntags)
      for i = 0, ntags-1 do begin
          case tagvals(i).op of
              'TAGNAME': sstr(i) = tagvals(i).value+':'
              'TAGVAL': begin
                  if tagvals(i).value NE '' then $
                    sstr(i) = tagvals(i).value+': '
                  sstr(i) = sstr(i) + prn_opn(prodecl, tagvals(i).operands(0))
              end
              'INHERITS': sstr(i) = 'INHERITS '+tagvals(i).value
          endcase
      endfor
  endif

  ;; Add the structure name if it is not an anonymous structure
  if tree(0).value NE '' then begin
      if n_elements(sstr) GT 0 then begin
          sstr = [tree(0).value, sstr]
      endif else begin
          sstr = [tree(0).value]
      endelse
  endif
  if n_elements(sstr) EQ 0 then sstr = ''

  return, '{'+prn_strcat(sstr, join=', ')+'}'
end

;; NODE: 'CASE' (case-of construct)
pro prn_case, prodecl, tree, text, nstack=ntext, prefix=prefix
  if n_elements(prefix) EQ 0 then prefix = ''

  ;; Extract test expression
  expr = prn_opn(prodecl, tree(0).operands(0), /embed)
  prn_push, text, nstack=ntext, $
    prefix+'CASE '+expr+' OF'

  ;; Scan through possible branches of the CASE statement
  ncases = long(tree(0).value)
  if ncases GT 0 AND ptr_valid(tree(0).operands(1)) EQ 1 then begin
      cases = *(tree(0).operands(1))
      for i = 0, ncases-1 do begin

          nbodytext = 0L
          ibody = 1L
          if cases(i).op EQ 'CASEVAL' then begin
              ;; Standard branch
              caseval  = prn_opn(prodecl, cases(i).operands(0), /embed)
          endif else if cases(i).op EQ 'CASEELSE' then begin
              ;; The ELSE (default) branch
              caseval = 'ELSE'
              ibody = 0
          endif else begin
              caseval = ''
          endelse

          ;; Extract the block of code associated with this branch
          if ptr_valid(cases(i).operands(ibody)) then $
            if n_elements(*cases(i).operands(ibody)) GT 0 then $
            prn_parse, prodecl, *cases(i).operands(ibody), $
            bodytext, nstack=nbodytext, prefix=''
          if nbodytext EQ 0 then bodytext = ''

          ;; Render the text
          if nbodytext GT 1 then begin
              prn_push, text, nstack=ntext, $
                prefix+'  '+caseval+': BEGIN'
              prn_push, text, nstack=ntext, $
                prefix+'    '+bodytext(0:nbodytext-1)
              prn_push, text, nstack=ntext, $
                prefix+'  END'
          endif else begin
              prn_push, text, nstack=ntext, $
                prefix+'  '+caseval+': '+bodytext(0)
          endelse
      endfor
  endif

  prn_push, text, nstack=ntext, $
    prefix+'ENDCASE'

  return              
end

;; Main parse loop of PROREND (called recursively!)
pro prn_parse, prodecl, tree, text, nstack=ntext, prefix=prefix, $
               last_operation=lastop
  if n_elements(prefix) EQ 0 then prefix = ''

  lastop = ''
  for i = 0L, n_elements(tree)-1 do begin
      case tree(i).op of
          'ARRAY': prn_push, text, nstack=ntext, $
            prn_array(prodecl, tree(i))
          'ASSIGN': prn_assign, prodecl, tree(i), text, nstack=ntext, $
            prefix=prefix
          'BINOP': prn_push, text, nstack=ntext, $
            prn_ubop(prodecl, tree(i), /binop)
          'CASE': prn_case, prodecl, tree(i), text, nstack=ntext, prefix=prefix
          'FOR': prn_for, prodecl, tree(i), text, nstack=ntext, prefix=prefix
          'GOTO': prn_push, text, nstack=ntext, $
            prefix+'GOTO, MARK$'+strtrim(tree(i).value)
          'IF': prn_if, prodecl, tree(i), text, nstack=ntext, prefix=prefix
          'IMM': prn_push, text, tree(i).value, nstack=ntext
          'LINE': 
          'LVAL': prn_push, text, tree(i).value, nstack=ntext
          'MARK': prn_push, text, nstack=ntext, $
            strmid(prefix,0,strlen(prefix)-1)+'MARK$'+tree(i).value+':'
          'METHCALL': prn_procall, prodecl, tree(i), text, nstack=ntext, $
            prefix=prefix, /method
          'ON_IOERROR': prn_push, text, nstack=ntext, $
            prefix+prn_onioerror(prodecl, tree(i))
          'PDEREF': prn_push, text, nstack=ntext, $
            prn_pderef(prodecl, tree(i))
          'PROCALL': prn_procall, prodecl, tree(i), text, nstack=ntext, $
            prefix=prefix
          'RETURN': prn_push, text, nstack=ntext, $
            prefix+prn_return(prodecl, tree(i))
          'STOP': prn_push, text, prefix+'STOP', nstack=ntext
          'STRUCT': prn_push, text, nstack=ntext, $
            prn_struct(prodecl, tree(i))
          'STRUCTREF': prn_push, text, nstack=ntext, $
            prn_structref(prodecl, tree(i))
          'SUBSCRIPT': prn_push, text, nstack=ntext, $
            prn_subscript(prodecl, tree(i))
          'TAGNAME': prn_push, text, tree(i).value, nstack=ntext
          'TAGSUBSCRIPT': prn_push, text, nstack=ntext, $
            prn_subscript(prodecl, tree(i))
          'TRICOND': prn_push, text, nstack=ntext, $
            prn_tricond(prodecl, tree(i))
          'UNOP': prn_push, text, nstack=ntext, $
            prn_ubop(prodecl, tree(i), /unop)
          'WHILE': prn_while, prodecl, tree(i), text, nstack=ntext, $
            prefix=prefix
          ELSE: print, 'WARNING: unknown type '+tree(i).op
      endcase
      lastop = tree(i).op
  endfor
end

;; Entry point for PROREND
pro prorend, tree0, text, init=init, mangle=mangle
  if n_params() EQ 0 then begin
      message, 'USAGE:', /info
      message, '  PROREND, TREE, TEXT, /INIT', /info
      return
  endif

  if keyword_set(init) then begin
      text = 0 & dummy = temporary(text)
  endif

  ;; Error checking
  if tag_names(tree0, /structure_name) NE 'PDS_NODE' then begin
      message, 'ERROR: TREE must be an abstract syntax tree'
      return
  endif

  if tree0.op NE 'PRODEF' then begin
      message, 'ERROR: head of TREE must be PRODEF node'
      return
  endif

  pnode = *(tree0.operands(0))
  if pnode.op NE 'PRODECL' then begin
      NO_PRODECL:
      message, 'ERROR: TREE has no PRODECL node'
      return
  endif

  if ptr_valid(pnode.operands(0)) then $
    if n_elements(*(pnode.operands(0))) GT 0 then $
    prodecl = *(pnode.operands(0))
  if n_elements(prodecl) EQ 0 then goto, NO_PRODECL

  ;; Assume everything is hunky-dorey from here on out
  tree = *(tree0.operands(1))

  ntext = n_elements(text)
  n_symbols = prodecl.n_syms
  n_args = prodecl.n_args

  if n_symbols GT 0 then symbols = prodecl.symbols

  ;; Generate the declaration of the procedure
  if keyword_set(mangle) then mang_str = '_' else mang_str = ''
  decl = prodecl.type + mang_str + ' ' + prodecl.proname
  if n_args GT 0 then begin
      args = prodecl.args
      
      ;; Positional arguments
      wh = where(args EQ '', n_pos)
      if n_pos GT 0 AND prodecl.is_method AND $
        symbols(wh(0)>0).name EQ 'SELF' then begin
          ;; Methods have a hidden argument named SELF
          n_pos = n_pos - 1
          if n_pos GT 0 then wh = wh(1:*)
      endif
      if n_pos GT 0 then begin
          decl = decl + ', '
          fmt = '('+strtrim(n_pos,2)+'(A,:,", "))'
          decl = decl + string(symbols(wh).name, format=fmt)
      endif

      ;; Keyword arguments
      wh = where(args NE '', n_key)
      if n_key GT 0 then begin
          decl = decl + ', '
          fmt = '('+strtrim(n_key,2)+'(A,:,", "))'
          decl = decl + string(args(wh)+'='+symbols(wh).name, format=fmt)
      endif
  endif
  prn_push, text, decl, nstack=ntext

  ;; Declare any common blocks to be used
  if prodecl.n_commons GT 0 then begin
      comstr = strarr(prodecl.n_commons)
      for i = 0L, prodecl.n_commons-1 do begin
          wh = where(symbols.values(0) EQ (i+1),ct)
          if ct GT 0 then begin
              ss = sort(symbols(wh).values(2))
              cnames = symbols(wh(ss)).name
              comstr(i) = '  COMMON ' + prodecl.commons(i).name + ', ' + $
                prn_strcat(cnames, join=',')
          endif
      endfor
      comstr = ['','  ;; Declaration of common blocks',comstr,'']
  endif

  prn_push, text, comstr, nstack=ntext
  prn_push, text, '  ;; Beginning of code', nstack=ntext
  prn_parse, prodecl, tree, text, nstack=ntext, prefix='  '
  prn_push, text, 'END', nstack=ntext

  text = text(0:ntext-1)
  return
end