C	GETTOKEN.FOR
C
C**************************************************************************
C
C	GET_TOKEN is the lexical scanner routine.  It returns the
C	next token from the command input stream.
C
C**************************************************************************
C
	subroutine  get_token

	implicit integer (a-z)

	include		'TOKDEF/NOLIST'

	parameter	STACK_MAX	= 5
	parameter	MAXSYM		= 15
	parameter	MAXID		= 40

	character	ch, lc *(*)
	logical		offlag
	integer		tok_stack  (STACK_MAX), old_token (STACK_MAX)
	integer		val_stack  (STACK_MAX), old_val   (STACK_MAX)
	character	lc_stack   (STACK_MAX) * (MAXCHAR)
	character	old_lc     (STACK_MAX) * (MAXCHAR)
	integer		len_stack  (STACK_MAX), old_len (STACK_MAX)
	character	ident_char*(MAXID),  ident_ch (numch)
	character	sym_char   (MAXSYM), sym_ch   (numwds)
	integer		sym_token  (MAXSYM), sym_tok  (numwds)

	integer		stack_pntr	/0/
	integer		num_sym		/0/
	integer		num_id		/0/
	integer		old_pntr	/0/
	common /gettokeni/ stack_pntr, num_sym, num_id, old_pntr
	common /gettokenc/ EOL, EOF, NULL, COMMENT, TAB, BLANK
	character	EOL	/13/
	character	EOF	/26/
	character	NULL	/'\'/
	character	COMMENT	/'!'/
	character	TAB	/ 9 /
	character	BLANK	/' '/

	old_pntr = old_pntr + 1
	if (old_pntr .gt. STACK_MAX) old_pntr = 1
	old_token (old_pntr) = token
	old_lc    (old_pntr) = t_lc_sym
	old_len   (old_pntr) = t_length
	old_val   (old_pntr) = t_value

	if (stack_pntr .gt. 0) then					! pop off stack
	    token    = tok_stack (stack_pntr)
	    t_lc_sym = lc_stack  (stack_pntr)
	    call str$upcase (t_symbol, lc_stack (stack_pntr))
	    t_length = len_stack (stack_pntr)
	    t_value  = val_stack (stack_pntr)
	    stack_pntr = stack_pntr - 1
	    go to 800
	endif

	t_symbol = BLANK
	t_lc_sym = BLANK
	t_length = 0
	t_value  = 0
	call getch (ch)

	do while (ch .eq. BLANK .or. ch .eq. TAB)			! toss blanks and tabs
	    call getch (ch)
	enddo

	if (ch .eq. EOL) then						! end of line
	    token = NEWLINE
	    ch = BLANK

	else if (ch .ge. 'A' .and. ch .le. 'Z' .or.			! identifier
     .		 ch .ge. 'a' .and. ch .le. 'z' .or.
     .		 ch .ge. '0' .and. ch .le. '9') then
	    offlag = .TRUE.
	    do while (index (ident_char (1:num_id), ch) .eq. 0)
		if (offlag) then
		    if (t_length .ge. MAXCHAR) then
			type *,'string length too long'
			offlag = .FALSE.
		    else
			t_length = t_length + 1
			t_lc_sym (t_length:t_length) = ch
		    endif
		endif
		call getch (ch)
	    enddo

	    call put_back (ch)
	    token = IDENT
	    call str$upcase (t_symbol, t_lc_sym)
	    call keyword (token, t_symbol, t_length, t_value)

	else if (ch .eq. NULL) then					! \
	    t_length = 1
	    token = TNULL

	else if (ch .eq. COMMENT) then					! comment
	    do while (ch .ne. EOL)
		call getch (ch)
	    enddo
	    ch = BLANK
	    token = NEWLINE

	else								! anything else
	    t_length = 1
	    t_symbol(1:1) = ch
	    t_lc_sym(1:1) = ch
	    token = MISC
	    do i = 1, num_sym
		if (ch .eq. sym_char (i)) then
		    token = sym_token (i)
		    go to 200
		endif
	    enddo

200	endif

800	return
C
C**************************************************************************
C
C	PUSH_TOKEN pushes a token back on a stack for the next call to 
C	get_token.
C
C**************************************************************************
C
	entry  push_token (tok, lc, tlen)

	if (stack_pntr .lt. STACK_MAX) then
	    stack_pntr = stack_pntr + 1
	    tok_stack (stack_pntr) = tok
	    lc_stack  (stack_pntr) = lc
	    len_stack (stack_pntr) = tlen
	else
	    type *,'Token Stack Overflow Fatal Error'
	endif

	return
C
C**************************************************************************
C
C	BACKUP_TOKEN gets the previous token.
C
C**************************************************************************
C
	entry  backup_token

	if (stack_pntr .lt. STACK_MAX) then
	    stack_pntr = stack_pntr + 1
	    tok_stack (stack_pntr) = token
	    lc_stack  (stack_pntr) = t_lc_sym
	    len_stack (stack_pntr) = t_length
	    val_stack (stack_pntr) = t_value
	else
	    type *,'Token Stack Overflow Fatal Error'
	endif

	token = old_token (old_pntr)
	t_length = old_len (old_pntr)
	t_lc_sym = old_lc (old_pntr)
	call str$upcase (t_symbol, old_lc (old_pntr))
	t_value = old_val (old_pntr)
	old_pntr = old_pntr - 1
	if (old_pntr .lt. 1)  old_pntr = STACK_MAX

	return

C
C**************************************************************************
C
C	LOAD_SYM loads the lexical analyzer special symbol table.
C
C**************************************************************************
C
	entry  load_sym (sym_ch, sym_tok, numwds, ident_ch, numch)

	do i = 1, numwds
	    num_sym = num_sym + 1
	    sym_char  (num_sym) = sym_ch (i)
	    sym_token (num_sym) = sym_tok (i)
	enddo

	do i = 1, numch
	    num_id = num_id + 1
	    ident_char(num_id:num_id) = ident_ch (i)
	enddo

	return
	end