# drift --- sample compiler for VCG demonstration

define (GLOBAL_VARIABLES,"drift_com.r.i")

define (MAX_SYM_LEN, MAXLINE)
define (MEMSIZE, 4096)
define (SEMANTIC_STACK_SIZE, 100)
define (INTERNAL_FORM_MEMSIZE, 20000)
define (INBUFSIZE, 300)
define (PBLIMIT, 150)

define (UNDEFINED, 0)
define (DEFINED, 1)

define (ifpointer, integer)
define (unknown, integer)

# Types of internal form nodes:
define (ADD_NODE,1)
define (ARG_NODE,2)
define (ASSIGN_NODE,3)
define (CALL_NODE,4)
define (COND_NODE,5)
define (CONSTANT_NODE,6)
define (DECLARE_VAR_NODE,7)
define (DIVIDE_NODE,8)
define (FUNCTION_NODE,9)
define (IO_NODE,10)
define (LOOP_NODE,11)
define (MULTIPLY_NODE,12)
define (NULL_NODE,13)
define (PARAM_NODE,14)
define (SEQ_NODE,15)
define (SUBTRACT_NODE,16)
define (VAR_NODE,17)
define (LAST_NODE_TYPE,VAR_NODE)

# Elements of internal form records:
define (ARG_EXPR (n), Ifmem (n + 2))
define (ARG_LIST (n), Ifmem (n + 3))
define (COND (n), Ifmem (n + 2))
define (ELSE_PART (n), Ifmem (n + 4))
define (FUNC_BODY (n), Ifmem (n + 5))
define (LEFT (n), Ifmem (n + 2))
define (LINE_NUM (n), Ifmem (n + 1))
define (LOOP_BODY (n), Ifmem (n + 3))
define (NODE_TYPE (n), Ifmem (n))
define (NPARAMS (n), Ifmem (n + 4))
define (OBJ_ID (n), Ifmem (n + 2))
define (PARAM_LIST (n), Ifmem (n + 3))
define (RIGHT (n), Ifmem (n + 3))
define (THEN_PART (n), Ifmem (n + 3))
define (WORD1 (n), Ifmem (n + 2))
define (WORD2 (n), Ifmem (n + 3))

include "drift.stacc.defs"             # macro defns. produced by 'stacc'
include "/uc/allen/vcg/vcg_defs.r.i"   # macro defns. for IMF operators



   integer state

   call program (state)
   if (state ~= ACCEPT)
      call error ("syntactically incorrect program"p)
   stop
   end



include "drift.stacc.r"    # Ratfor source code produced by 'stacc'



# begin_function --- set up environment for compiling a function

   subroutine begin_function (name)
   character name (ARB)

   include GLOBAL_VARIABLES

   pointer mktabl

   integer info2 (2)
   integer lookup, gen_id

   ifpointer func_node
   ifpointer ialloc

   Next_ifmem = 1          # initialize internal form memory
   Locals = mktabl (1)     # initialize local variable symbol table
   Sp = 0                  # initialize semantic stack pointer

  # Place function name in 'Functions' table, if it's not already there
   if (lookup (name, info2, Functions) == YES)
      if (info2 (2) == DEFINED)
         call warning ("function *s multiply defined*n"p, name)
      else {
         info2 (2) = DEFINED
         call enter (name, info2, Functions)
         }
   else {
      info2 (1) = gen_id (1)
      info2 (2) = DEFINED
      call enter (name, info2, Functions)
      }

  # Output an entry point definition for the procedure:
   call emit (SEQ_OP, Ent_stream)
   call emit (info2 (1), Ent_stream)      # object id of function
   call emit_string (name, Ent_stream)    # function name

  # Put function node on semantic stack:
   func_node = ifalloc (FUNCTION_NODE)
   NPARAMS (func_node) = 0
   OBJ_ID (func_node) = info2 (1)
   call push (func_node)

   return
   end



# begin_program --- do pre-program initialization

   subroutine begin_program

   include GLOBAL_VARIABLES

   pointer mktabl

   filedes create, open

   character infile (MAXARG)

   integer getarg, gen_id

   call dsinit (MEMSIZE)      # init. dynamic storage
   Functions = mktabl (2)     # symbol table for function names
   Globals = mktabl (1)       # symbol table for global variables
   Reserved_words = mktabl (1)   # symbol table for reserved words
   Next_obj_id = 1            # for object id generator
   Error_count = 0
   Ibp = 1                    # buffer pointer...
   Inbuf (Ibp) = EOS          # ...and input buffer used by lexer
   Current_line = 0

  # open input file specified on command line:
   if (getarg (1, infile, MAXARG) == EOF)
      In_stream = STDIN
   else {
      In_stream = open (infile, READ)
      if (In_stream == ERR)
         call cant (infile)
      }

  # create temporary files for passing the IMF to the code generator:
   Ent_stream = create ("_drift_.ct1"s, READWRITE)
   Data_stream = create ("_drift_.ct2"s, READWRITE)
   Code_stream = create ("_drift_.ct3"s, READWRITE)
   if (Ent_stream == ERR || Data_stream == ERR || Code_stream == ERR)
      call error ("can't open temporary files _drift_.ct[1-3]"p)

   call emit (MODULE_OP, Ent_stream)
   call emit (MODULE_OP, Data_stream)
   call emit (MODULE_OP, Code_stream)

  # define object id's for the two run-time routines we'll need:
   Ex$in_id = gen_id (1)            # run-time routine for input
   call emit (SEQ_OP, Data_stream)
   call emit (DECLARE_STAT_OP, Data_stream)
   call emit (Ex$in_id, Data_stream)
   call emit_string ("EX$IN"s, Data_stream)

   Ex$out_id = gen_id (1)           # run-time routine for output
   call emit (SEQ_OP, Data_stream)
   call emit (DECLARE_STAT_OP, Data_stream)
   call emit (Ex$out_id, Data_stream)
   call emit_string ("EX$OUT"s, Data_stream)

  # build the reserved-word table used by the lexical analyzer:
   call enter ("do"s, DO_SYM, Reserved_words)
   call enter ("else"s, ELSE_SYM, Reserved_words)
   call enter ("end_function"s, END_FUNCTION_SYM, Reserved_words)
   call enter ("fi"s, FI_SYM, Reserved_words)
   call enter ("float"s, FLOAT_SYM, Reserved_words)
   call enter ("function"s, FUNCTION_SYM, Reserved_words)
   call enter ("if"s, IF_SYM, Reserved_words)
   call enter ("null"s, NULL_SYM, Reserved_words)
   call enter ("od"s, OD_SYM, Reserved_words)
   call enter ("then"s, THEN_SYM, Reserved_words)
   call enter ("while"s, WHILE_SYM, Reserved_words)

  # fire up lexical analysis:
   call getsym

   return
   end



# declare_formal_parameter --- put formal param name in table, assign obj id

   subroutine declare_formal_parameter (name)
   character name (ARB)

   include GLOBAL_VARIABLES

   integer obj_id
   integer lookup, gen_id

   ifpointer param_node
   ifpointer ifalloc

   if (lookup (name, obj_id, Locals) == YES) {
      call warning ("*s:  multiply declared*n"p, name)
      return
      }

   obj_id = gen_id (1)
   call enter (name, obj_id, Locals)

  # create new parameter node and combine it with previous sequence
  #   on the semantic stack:
   param_node = ifalloc (PARAM_NODE)
   OBJ_ID (param_node) = obj_id
   call push (param_node)
   call sequentialize
   NPARAMS (Stack (Sp - 1)) += 1

   return
   end



# declare_global_variable --- put name in global table, assign object id

   subroutine declare_global_variable (name)
   character name (ARB)

   include GLOBAL_VARIABLES

   integer obj_id
   integer lookup, gen_id

   if (lookup (name, obj_id, Globals) == YES) {
      call warning ("*s:  multiply declared*n"p, name)
      return
      }

   obj_id = gen_id (1)
   call enter (name, obj_id, Globals)

  # go ahead and reserve space in the static data storage area for
  #   the variable we just declared:
   call emit (SEQ_OP, Data_stream)
   call emit (DEFINE_STAT_OP, Data_stream)
   call emit (obj_id, Data_stream)
   call emit (NULL_OP, Data_stream)    # no initializers
   call emit (2, Data_stream)          # 2 words for a floating object

   return
   end



# declare_local_variable --- enter name in local table, assign object id

   subroutine declare_local_variable (name)
   character name (ARB)

   include GLOBAL_VARIABLES

   integer obj_id
   integer lookup, gen_id

   ifpointer decl_var_node
   ifpointer ifalloc

   if (lookup (name, obj_id, Locals) == YES) {
      call warning ("*s:  multiply declared*n"p, name)
      return
      }

   obj_id = gen_id (1)
   call enter (name, obj_id, Locals)

  # make new variable declaration node and put it into a sequence
  #   following all previously declared variables:
   decl_var_node = ifalloc (DECLARE_VAR_NODE)
   OBJ_ID (decl_var_node) = obj_id
   call push (decl_var_node)
   call sequentialize

   return
   end



# emit --- place value on an output stream

   subroutine emit (val, stream)
   integer val
   filedes stream

   call print (stream, "*i*n"s, val)

   return
   end



# emit_string --- place length of string and string on an output stream

   subroutine emit_string (str, stream)
   character str (ARB)
   filedes stream

   integer i
   integer length

   call emit (length (str), stream)
   for (i = 1; str (i) ~= EOS; i += 1)
      call emit (str (i), stream)

   return
   end



# end_function --- clean up after parse of a function is completed

   subroutine end_function

   include GLOBAL_VARIABLES

   call semantic_analysis (Stack (Sp))
   call rmtabl (Locals)    # get rid of all local variable information

   return
   end



# end_program --- clean up after the entire program is parsed

   subroutine end_program

   include GLOBAL_VARIABLES

   pointer position

   integer info2 (2)
   integer sctabl

   character sym (MAX_SYM_LEN)

   logical first

   call close (In_stream)

  # terminate IMF streams by ending sequence of definitions, then
  #   ending sequence of modules:
   call emit (NULL_OP, Ent_stream);  call emit (NULL_OP, Ent_stream)
   call emit (NULL_OP, Data_stream); call emit (NULL_OP, Data_stream)
   call emit (NULL_OP, Code_stream); call emit (NULL_OP, Code_stream)

   call close (Ent_stream)
   call close (Data_stream)
   call close (Code_stream)

  # check function table for names that were referenced but not
  #   declared; presumably these are externally compiled
   first = TRUE
   position = 0
   while (sctabl (Functions, sym, info2, position) ~= EOF)
      if (info2 (2) == UNDEFINED) {
         if (first) {
            call print (STDOUT, "External symbols:*n"p)
            first = FALSE
            }
         call print (STDOUT, "*s*n"p, sym)
         }

   return
   end



# gen_id --- generate new object identifiers

   integer function gen_id (num_ids)
   integer num_ids

   include GLOBAL_VARIABLES

   gen_id = Next_obj_id
   Next_obj_id += num_ids

   return
   end



# getsym --- get next symbol from input stream

   subroutine getsym

   include GLOBAL_VARIABLES

   procedure getchar forward
   procedure putback (c) forward
   procedure empty_buffer forward

   character c

   integer i
   integer getlin, lookup

   real ctor

   logical too_long, continuation

   continuation = FALSE    # true if we want to ignore a line boundary
   repeat { # until we find a legal symbol

      repeat
         getchar
         until (c ~= ' 'c)

      select (c)

         when (NEWLINE) {
            Current_line += 1
            Symbol = NEWLINE
            if (~continuation)
               break
            }

         when (';'c) {
            Symbol = NEWLINE     # but no line number advance
            if (~continuation)
               break
            }

         when ('-'c) {
            getchar
            if (c == '-'c) {     # -- begins comments
               empty_buffer
               Current_line += 1
               Symbol = NEWLINE
               if (~continuation)
                  break
               }
            else {
               putback (c)
               Symbol = '-'c
               break
               }
            }

         when ('&'c)
            continuation = TRUE

         when ('+'c, '*'c, '/'c, '#'c, '('c, ')'c, ','c, '='c, EOF) {
            Symbol = c
            break
            }

         when (SET_OF_LETTERS) {    # a-z or A-Z; starting an identifier
            too_long = FALSE
            i = 1
            while (IS_LETTER (c) || IS_DIGIT (c) || c == '_'c) {
               Symtext (i) = c
               i += 1
               if (i > MAX_SYM_LEN) {
                  i -= 1
                  too_long = TRUE
                  }
               getchar
               }
            putback (c)
            Symtext (i) = EOS
            if (too_long)
               call warning ("symbol beginning *s is too long*n"p, Symtext)
            if (lookup (Symtext, Symbol, Reserved_words) == NO)
               Symbol = ID_SYM
            break
            }

         when ('.'c, SET_OF_DIGITS) {
            putback (c)
            Symval = ctor (Inbuf, Ibp)    # advances Ibp
            Symbol = NUMBER_SYM
            break
            }

      else
         call warning ("'*c':  unrecognized character*n"p, c)

      }  # repeat until a valid symbol is found

   return


   # getchar --- get the next character from the input stream

      procedure getchar {

         if (Inbuf (Ibp) == EOS)       # time to read a new buffer?
            if (getlin (Inbuf (PBLIMIT), In_stream) == EOF)
               c = EOF
            else {
               c = Inbuf (PBLIMIT)     # pick up the first char read
               Ibp = PBLIMIT + 1
               }
         else {                        # text was already available
            c = Inbuf (Ibp)
            Ibp += 1
            }

         }


   # putback --- push a character back onto the input stream

      procedure putback (c) {
         character c

         if (Ibp <= 1)
            call error ("too many characters pushed back"p)
         else {
            Ibp -= 1
            Inbuf (Ibp) = c
            }

         }


   # empty_buffer --- kill remainder of line in input buffer

      procedure empty_buffer {

         Inbuf (Ibp) = EOS          # will force a read in 'getchar'

         }

   end



# ifalloc --- allocate space for a particular type node in internal form memory

   ifpointer function ifalloc (node_type)
   integer node_type

   include GLOBAL_VARIABLES

  # These declarations assume that the internal form node types form
  #   a dense ascending sequence of integers from 1 to LAST_NODE_TYPE:
   integer sizeof (LAST_NODE_TYPE)
   data sizeof / _
      4,    # ADD_NODE
      3,    # ARG_NODE
      4,    # ASSIGN_NODE
      4,    # CALL_NODE
      5,    # COND_NODE
      4,    # CONSTANT_NODE
      3,    # DECLARE_VAR_NODE
      4,    # DIVIDE_NODE
      6,    # FUNCTION_NODE
      2,    # IO_NODE
      4,    # LOOP_NODE
      4,    # MULTIPLY_NODE
      2,    # NULL_NODE
      3,    # PARAM_NODE
      4,    # SEQ_NODE
      4,    # SUBTRACT_NODE
      3 _   # VAR_NODE
      /

   if (node_type < 1 || node_type > LAST_NODE_TYPE)
      call error ("ifalloc received bad node type"p)

   if (Next_ifmem + sizeof (node_type) > INTERNAL_FORM_MEMSIZE)
      call error ("insufficient internal form memory"p)

   ifalloc = Next_ifmem
   Next_ifmem += sizeof (node_type)

   NODE_TYPE (ifalloc) = node_type
   LINE_NUM (ifalloc) = Current_line

   return
   end



# lvalue_context --- generate VCG code for constructs used as lvalues
#     (assumes I/O quads have already been eliminated from LHS's)

   subroutine lvalue_context (node)
   ifpointer node

   include GLOBAL_VARIABLES

   select (NODE_TYPE (node))

      when (VAR_NODE) {
         call emit (OBJECT_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call emit (OBJ_ID (node), Code_stream)
         }

      when (SEQ_NODE) {
         if (NODE_TYPE (RIGHT (node)) == NULL_NODE)
            call lvalue_context (LEFT (node))
         else {
            call emit (SEQ_OP, Code_stream)
            call void_context (LEFT (node))
            call lvalue_context (RIGHT (node))
            }
         }

   else
      call warning ("assignment on line *i has an illegal left side*n"p,
         LINE_NUM (node))

   return
   end



# make_actual_parameter --- link actual parameter expression to list

   subroutine make_actual_parameter

   include GLOBAL_VARIABLES

   ifpointer act_param
   ifpointer ifalloc, pop

   act_param = ifalloc (ARG_NODE)
   ARG_EXPR (act_param) = pop (0)
   call push (act_param)
   call sequentialize

   return
   end



# make_call --- generate a call to a function

   subroutine make_call (name)
   character name (ARB)

   include GLOBAL_VARIABLES

   integer info2 (2)
   integer lookup, gen_id

   ifpointer call_node
   ifpointer ifalloc, pop

  # if function name is in Functions table, all is well; if not,
  #   we add it provisionally (it may be defined later).
   if (lookup (name, info2, Functions) == NO) {
      info2 (1) = gen_id (1)
      info2 (2) = UNDEFINED
      call enter (name, info2, Functions)
      }

   call_node = ifalloc (CALL_NODE)
   OBJ_ID (call_node) = info2 (1)
   ARG_LIST (call_node) = pop (0)
   call push (call_node)

   return
   end



# make_conditional --- make conditional (if-then-else-fi) node

   subroutine make_conditional

   include GLOBAL_VARIABLES

   ifpointer cond
   ifpointer if_alloc, pop

   cond = if_alloc (COND_NODE)
   ELSE_PART (cond) = pop (0)
   THEN_PART (cond) = pop (0)
   COND (cond) = pop (0)

   call push (cond)
   return
   end



# make_constant --- make constant node from given value

   subroutine make_constant (val)
   real val

   include GLOBAL_VARIABLES

   real rkluge
   integer ikluge (2)
   equivalence (rkluge, ikluge)  # used to unpack floating point constants

   ifpointer cnode
   ifpointer ifalloc

   cnode = ifalloc (CONSTANT_NODE)
   rkluge = val
   WORD1 (cnode) = ikluge (1)
   WORD2 (cnode) = ikluge (2)

   call push (cnode)
   return
   end



# make_dyad --- make node for a dyadic operator (=, +, -, *, /)

   subroutine make_dyad (node_type)
   integer node_type

   include GLOBAL_VARIABLES

   ifpointer node
   ifpointer ifalloc, pop

   node = ifalloc (node_type)
   RIGHT (node) = pop (0)
   LEFT (node) = pop (0)
   call push (node)

   return
   end



# make_function_body --- add function body to function definition node

   subroutine make_function_body

   include GLOBAL_VARIABLES

   ifpointer body
   ifpointer pop

   call sequentialize      # combine declarations and code
   body = pop (0)          # note deep-stack addressing makes sequencing
   FUNC_BODY (Stack (Sp)) = body       # necessary...

   return
   end



# make_function_parameters --- add params to function definition node

   subroutine make_function_parameters

   include GLOBAL_VARIABLES

   ifpointer params
   ifpointer pop

   params = pop (0)     # note:  deep-stack addressing makes use of
   PARAM_LIST (Stack (Sp)) = params    # a particular sequence necessary

   return
   end



# make_loop --- pop cond and body off stack, generate a loop node

   subroutine make_loop

   include GLOBAL_VARIABLES

   ifpointer loop
   ifpointer ifalloc, pop

   loop = ifalloc (LOOP_NODE)
   LOOP_BODY (loop) = pop (0)
   COND (loop) = pop (0)
   call push (loop)

   return
   end



# make_null --- push new "null operator" node on stack

   subroutine make_null

   include GLOBAL_VARIABLES

   ifpointer ifalloc

   call push (ifalloc (NULL_NODE))

   return
   end



# make_object --- push node referencing a variable on the stack

   subroutine make_object (name)
   character name (ARB)

   include GLOBAL_VARIABLES

   ifpointer node
   ifpointer ifalloc

   integer obj_id
   integer lookup

   node = ifalloc (VAR_NODE)

   if (lookup (name, obj_id, Locals) == NO
     && lookup (name, obj_id, Globals) == NO) {
      call warning ("*s:  undeclared identifier*n"p, name)
      obj_id = 0
      }

   OBJ_ID (node) = obj_id
   call push (node)

   return
   end



# make_quad --- generate an input/output operation node

   subroutine make_quad

   include GLOBAL_VARIABLES

   ifpointer ifalloc

   call push (ifalloc (IO_NODE))

   return
   end



# output_arguments --- output IMF for procedure call arguments

   subroutine output_arguments (arg_node)
   ifpointer arg_node

   include GLOBAL_VARIABLES

   select (NODE_TYPE (arg_node))

      when (ARG_NODE) {
         call emit (PROC_CALL_ARG_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call rvalue_context (ARG_EXPR (arg_node))
         }

      when (NULL_NODE)
         ;

      when (SEQ_NODE) {
         call output_arguments (LEFT (arg_node))
         call output_arguments (RIGHT (arg_node))
         }

   else
      call error ("in output_argument:  shouldn't happen"p)

   return
   end



# output_params --- output IMF for procedure formal parameter definitions

   subroutine output_params (param_node)
   ifpointer param_node

   include GLOBAL_VARIABLES

   select (NODE_TYPE (param_node))

      when (PARAM_NODE) {
         call emit (PROC_DEFN_ARG_OP, Code_stream)
         call emit (OBJ_ID (param_node), Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call emit (VALUE_DISP, Code_stream)
         call emit (2, Code_stream) # FLOATs are 2 words long
         }

      when (NULL_NODE)
         ;

      when (SEQ_NODE) {
         call output_params (LEFT (param_node))
         call output_params (RIGHT (param_node))
         }

   else
      call error ("in output_param:  shouldn't happen"p)

   return
   end



# pmr --- panic mode recovery for parser

   subroutine pmr (message, state)
   character message (ARB)
   integer state

   include GLOBAL_VARIABLES

   call warning (message)
   state = ACCEPT

   while (Symbol ~= EOF && Symbol ~= ')'c && Symbol ~= NEWLINE
     && Symbol ~= END_FUNCTION_SYM && Symbol ~= THEN_SYM
     && Symbol ~= ELSE_SYM && Symbol ~= FI_SYM && Symbol ~= DO_SYM
     && Symbol ~= OD_SYM && Symbol ~= ','c)
      call getsym

   return
   end



# pop --- pop a node pointer off the semantic stack

   ifpointer function pop (dummy)
   integer dummy     # needed to satisfy FORTRAN syntax requirements

   include GLOBAL_VARIABLES

   if (Sp < 1)
      call error ("semantic stack underflow"p)

   pop = Stack (Sp)
   Sp -= 1

   return
   end



# push --- push a node pointer onto the semantic stack

   subroutine push (node)
   ifpointer node

   include GLOBAL_VARIABLES

   if (Sp >= SEMANTIC_STACK_SIZE)
      call error ("semantic stack overflow"p)

   Sp += 1
   Stack (Sp) = node

   return
   end



# rvalue_context --- generate VCG code for constructs used as rvalues

   subroutine rvalue_context (node)
   ifpointer node

   include GLOBAL_VARIABLES

   select (NODE_TYPE (node))

      when (ADD_NODE, SUBTRACT_NODE, MULTIPLY_NODE, DIVIDE_NODE) {
         select (NODE_TYPE (node))
            when (ADD_NODE)
               call emit (ADD_OP, Code_stream)
            when (SUBTRACT_NODE)
               call emit (SUB_OP, Code_stream)
            when (MULTIPLY_NODE)
               call emit (MUL_OP, Code_stream)
            when (DIVIDE_NODE)
               call emit (DIV_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call rvalue_context (LEFT (node))
         call rvalue_context (RIGHT (node))
         }

      when (ASSIGN_NODE) {
         if (NODE_TYPE (LEFT (node)) == IO_NODE) {
           # fake up output by calling 'ex$out' at run time:
            call emit (PROC_CALL_OP, Code_stream)
            call emit (FLOAT_MODE, Code_stream)
            call emit (OBJECT_OP, Code_stream)
            call emit (STOWED_MODE, Code_stream)
            call emit (Ex$out_id, Code_stream)
            call emit (PROC_CALL_ARG_OP, Code_stream)
            call emit (FLOAT_MODE, Code_stream)
            call rvalue_context (RIGHT (node))
            call emit (NULL_OP, Code_stream)
            }
         else {
            call emit (ASSIGN_OP, Code_stream)
            call emit (FLOAT_MODE, Code_stream)
            call lvalue_context (LEFT (node))
            call rvalue_context (RIGHT (node))
            call emit (2, Code_stream)    # assign 2 words
            }
         }

      when (CALL_NODE) {
         call emit (PROC_CALL_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call emit (OBJECT_OP, Code_stream)
         call emit (STOWED_MODE, Code_stream)
         call emit (OBJ_ID (node), Code_stream)
         call output_arguments (ARG_LIST (node))
         call emit (NULL_OP, Code_stream)
         }

      when (COND_NODE) {
         call emit (IF_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call rvalue_context (COND (node))
         call rvalue_context (THEN_PART (node))
         if (NODE_TYPE (ELSE_PART (node)) == NULL_NODE)
            call warning ("'if' on line *i needs an 'else' part*n"p,
               LINE_NUM (node))
         call rvalue_context (ELSE_PART (node))
         }

      when (CONSTANT_NODE) {
         call emit (CONST_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call emit (2, Code_stream)    # 2-word floats
         call emit (WORD1 (node), Code_stream)
         call emit (WORD2 (node), Code_stream)
         }

      when (DECLARE_VAR_NODE) {
         call emit (DEFINE_DYNM_OP, Code_stream)
         call emit (OBJ_ID (node), Code_stream)
         call emit (NULL_OP, Code_stream)    # no initializers
         call emit (2, Code_stream)    # size is 2 words
         }

      when (IO_NODE) {
        # fake up input by calling 'ex$in' at run time:
         call emit (PROC_CALL_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call emit (OBJECT_OP, Code_stream)
         call emit (STOWED_MODE, Code_stream)
         call emit (Ex$in_id, Code_stream)
         call emit (NULL_OP, Code_stream)    # no arguments
         }

      when (LOOP_NODE)
         call warning ("while-loop at line *i is used as an rvalue*n"p,
            LINE_NUM (node))

      when (NULL_NODE)
         call emit (NULL_OP, Code_stream)

      when (SEQ_NODE) {
         if (NODE_TYPE (RIGHT (node)) == NULL_NODE)
            call rvalue_context (LEFT (node))
         else {
            call emit (SEQ_OP, Code_stream)
            call void_context (LEFT (node))  # can never yield a value
            call rvalue_context (RIGHT (node))
            }
         }

      when (VAR_NODE) {
         call emit (OBJECT_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call emit (OBJ_ID (node), Code_stream)
         }

   else
      call error ("in rvalue_context:  shouldn't happen"p)

   return
   end



# semantic_analysis --- check function and output VCG code for it

   subroutine semantic_analysis (func)
   ifpointer func

   include GLOBAL_VARIABLES

  # output the procedure definition node:
   call emit (SEQ_OP, Code_stream)
   call emit (PROC_DEFN_OP, Code_stream)
   call emit (OBJ_ID (func), Code_stream)
   call emit (NPARAMS (func), Code_stream)
   call emit_string (EOS, Code_stream) # we'll ignore this for now

  # take care of the formal parameter declarations:
   call output_params (ARG_LIST (func))
   call emit (NULL_OP, Code_stream)

  # finally, take care of local variables and the function code:
   call rvalue_context (FUNC_BODY (func))

   return
   end



# sequentialize --- combine two nodes with a "sequence" node

   subroutine sequentialize

   include GLOBAL_VARIABLES

   ifpointer seq_node
   ifpointer ifalloc, pop

   seq_node = ifalloc (SEQ_NODE)
   RIGHT (seq_node) = pop (0)
   LEFT (seq_node) = pop (0)
   call push (seq_node)

   return
   end



# void_context --- generate VCG code for constructs that yield no value

   subroutine void_context (node)
   ifpointer node

   include GLOBAL_VARIABLES

   select (NODE_TYPE (node))

      when (COND_NODE) {      # an 'if' used as a statement
         call emit (IF_OP, Code_stream)
         call emit (FLOAT_MODE, Code_stream)
         call rvalue_context (COND (node))
         call void_context (THEN_PART (node))
         call void_context (ELSE_PART (node))
         }

      when (LOOP_NODE) {
         call emit (WHILE_LOOP_OP, Code_stream)
         call rvalue_context (COND (node))
         call void_context (LOOP_BODY (node))
         }

      when (SEQ_NODE) {
         call emit (SEQ_OP, Code_stream)
         call void_context (LEFT (node))
         call void_context (RIGHT (node))
         }

   else
      call rvalue_context (node)

   return
   end



# warning --- print warning message

   subroutine warning (format, a1, a2, a3, a4, a5, a6, a7, a8, a9)
   character format (ARB)
   unknown a1, a2, a3, a4, a5, a6, a7, a8, a9

   include GLOBAL_VARIABLES

   call print (ERROUT, "*i:  "s, Current_line)
   call print (ERROUT, format, a1, a2, a3, a4, a5, a6, a7, a8, a9)
   Error_count += 1

   return
   end