* ICOMP
* I-type compiler
* Copyright (c) 2007 Ladybridge Systems, All Rights Reserved
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2, or (at your option)
* any later version.
* 
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
* GNU General Public License for more details.
* 
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software Foundation,
* Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
* 
* Ladybridge Systems can be contacted via the www.openqm.com web site.
* 
* START-HISTORY:
* 07 Aug 07  2.5-7 Added @GID and @UID.
* 11 Apr 07  2.5-2 Added ENCRYPT() and DECRYPT().
* 02 Nov 06  2.4-15 Dictionary record types now case insensitive.
* 07 Jul 06  2.4-9 Added three argument variant of FOLD().
* 15 Jun 06  2.4-5 Allow a parenthesised expression as the third argument to
*                  TRANS() for calculated return field positions.
* 12 May 06  2.4-4 Added CSVDQ().
* 18 Apr 06  2.4-1 0476 Source text was treated as case insensitive which made
*                  it impossible to access non-uppercase dictionary items.
* 07 Apr 06  2.4-1 Added RTRANS().
* 21 Mar 06  2.3-9 Added XLATE() as a synonym for TRANS().
* 21 Feb 06  2.3-6 Added @USER as a synonym for @LOGNAME.
* 20 Oct 05  2.2-15 Added LISTINDEX.
* 28 Sep 05  2.2-13 Added OUTERJOIN().
* 24 Aug 05  2.2-8 Added hex numeric constants.
* 10 Aug 05  2.2-7 0388 Treat all intrinsic functions as potentially
*                  variable.
* 06 May 05  2.1-13 Added SWAP() and a synonym for CHANGE().
* 11 Apr 05  2.1-12 0342 Check parenthesis depth in is.field.ref when deciding
*                   what to do with AND/OR/THEN element.
* 28 Mar 05  2.1-11 Added SUBSTITUTE().
* 07 Mar 05  2.1-8 0322 Allocate SUBR() result variables dynamically.
* 04 Mar 05  2.1-8 0320 Need to be consistent about the state of NUM.TOKENS
*                  when calling expand.token.tables.
* 11 Jan 05  2.1-0 Emit object header in machine byte ordering.
* 02 Jan 05  2.1-0 Added @HOSTNAME.
* 27 Dec 04  2.1-0 Added support for nested A/C/S type items.
* 24 Dec 04  2.1-0 Use emit.simple from bcomp for multibyte opcodes.
* 17 Dec 04  2.1-0 Added PROC @variables.
* 07 Dec 04  2.1-0 Set up @ANS
* 16 Nov 04  2.0-10 0286 Use of @xxx other than @RECORD failed.
* 14 Nov 04  2.0-10 Use IFL rather than IF conversion for LDFLOAT.
* 13 Oct 04  2.0-5 Use message handler.
* 21 Sep 04  2.0-2 0253 "IF xx THEN xx ELSE xx" was using JZE, not JFALSE which
*                  caused it to fail if the data was not numeric.
* 16 Sep 04  2.0-1 Added MAX() and MIN(). Also BITRESET() and BITSET().
* 16 Sep 04  2.0-1 OpenQM launch. Earlier history details suppressed.
* END-HISTORY
*
* START-DESCRIPTION:
*
* CALL $ICOMP(dict.file, source, object, format, conversion, sm, assoc,
*             constant, depth)
*
*    dict.file  = file variable of dictionary file
*    source     = I-type expression source
*    object     = compiled I-type (output)
*    format     = format of first field from dictionary
*    conversion = conversion of first field from dictionary
*    sm         = single/multi-value flag from dictionary
*    assoc      = association name from dictionary
*    constant   = true if I-type evaluates to a constant
*    depth      = depth of recursive compilation for TRANS() of I-type.
*
* format, conversion, sm and association are set to the attributes of the
* first field referenced in the I-type.  If no fields are referenced, they are
* unchanged.
*
* An I-type evaluates to a constant if it references no fields, functions or
* @-variables that are considered as variable (DATE() and TIME() for example
* are considered constant). This information is used only by QPROC to identify
* evaluated constants.
*
* GPL developers should see the notes at the head of the BASIC compiler as
* this one uses many of the same concepts.
*
* END-DESCRIPTION
*
* START-CODE

$internal
subroutine $icomp(dict.file, source, object, format, conversion,
                  sm, assoc, constant, depth)
$catalog $icomp

print.code = @false                ;* Expanded listing control

$include syscom.h
$include tokens.h
$include opcodes.h
$include header.h
$include int$keys.h
$include dictdict.h

$include keys.h
$include err.h

$define TKN.NEST        998
$define TKN.UNNEST      999

*****************************************************************************


   icomp = '$ICOMP'

   if depth > 9 then
      err.msg = sysmsg(2999) ;* TRANS() of I-types nested too deeply
      goto error
   end


   object = ''

   i = kernel(k$case.sensitive, @true)   ;* 0476

* Initialise constant data

   max.tokens = 200

   dim op(tkn.high.operator)          ;* Operator token / opcodes relationship
   dim op.priority(tkn.high.operator) ;* Operator priorities.  Operators with
                                       * low priority values are applied first.
                                       * Values are (N * 10) + 1 where N is the
                                       * priority as shown in the user
                                       * documentation.  The + 1 is used to
                                       * allow the ** operator to be treated
                                       * as a special case in EXPR.

   op(tkn.pwr) = op.pwr         ;   op.priority(tkn.pwr) = 21
   op(tkn.div) = op.div         ;   op.priority(tkn.div) = 31
   op(tkn.idiv) = op.idiv       ;   op.priority(tkn.idiv) = 31
   op(tkn.mult) = op.mul        ;   op.priority(tkn.mult) = 31
   op(tkn.plus) = op.add        ;   op.priority(tkn.plus) = 41
   op(tkn.minus) = op.sub       ;   op.priority(tkn.minus) = 41
   op(tkn.fmt) = op.fmt         ;   op.priority(tkn.fmt) = 51
   op(tkn.colon) = op.cat       ;   op.priority(tkn.colon) = 61
   op(tkn.matches) = op.matches ;   op.priority(tkn.matches) = 71
   op(tkn.lt) = op.lt           ;   op.priority(tkn.lt) = 71
   op(tkn.ltx) = op.lt          ;   op.priority(tkn.ltx) = 71
   op(tkn.gt) = op.gt           ;   op.priority(tkn.gt) = 71
   op(tkn.gtx) = op.gt          ;   op.priority(tkn.gtx) = 71
   op(tkn.eq) = op.eq           ;   op.priority(tkn.eq) = 71
   op(tkn.ne) = op.ne           ;   op.priority(tkn.ne) = 71
   op(tkn.nex) = op.ne          ;   op.priority(tkn.nex) = 71
   op(tkn.le) = op.le           ;   op.priority(tkn.le) = 71   
   op(tkn.ge) = op.ge           ;   op.priority(tkn.ge) = 71
   op(tkn.gex) = op.ge          ;   op.priority(tkn.gex) = 71
   op(tkn.and) = op.and         ;   op.priority(tkn.and) = 81
   op(tkn.or) = op.or           ;   op.priority(tkn.or) = 81

   n = idiv(max.tokens, 2)      ;* Worst possible case
   dim operator.stack(n)        ;* Infix - postfix operator stack...
   dim priority.stack(n)        ;* ...and associated priority stack
$define STACK.MARK 9999         ;* Marks start of sub-expression
   priority.stack(0) = STACK.MARK


   * Source parsing

   dim tokens(max.tokens)
   tokens(0) = 0
   dim token.strings(max.tokens)
   dim u.token.strings(max.tokens)

   mark.chars = @fm:@vm:@sm:@tm:@im:@fm:@sm ;* See EMIT.AT.VAR.LOAD for use

   * The AT.CONSTANTS list holds @ variables which are either constants or
   * have special code to produce the values.

* !!ATVAR!!
   at.constants = "FM":@fm:"VM":@fm:"SM":@fm:"TM":@fm:"IM":@fm:"AM":@fm:"SVM"
   at.constants := @fm:"FALSE":@fm:"TRUE":@fm:"USERNO":@fm:"USER.NO"
   at.constants := @fm:"DAY":@fm:"MONTH":@fm:"YEAR":@fm:"YEAR4"
   at.constants := @fm:"TERM.TYPE":@fm:"TRANSACTION.ID":@fm:"TRANSACTION.LEVEL"
   at.constants := @fm:"IP.ADDR":@fm:"HOSTNAME":@fm:"GID":@fm:"UID"


   * AT.VARS     is a list of SYSCOM variables.
   * AT.OFFSETS  holds the SYSCOM offsets of the variables.
   *             A negative offset indicates a "constant" that can be evaluated
   *             just once in the query processor.
   *             A suffix of .n on an offset indicates that this addresses
   *             element n of an array.

   at.vars = "ABORT.CODE"              ; at.offsets = SYSCOM.ABORT.CODE
   at.vars<-1> = "ABORT.MESSAGE"       ; at.offsets<-1> = SYSCOM.ABORT.MESSAGE
   at.vars<-1> = "ANS"                 ; at.offsets<-1> = SYSCOM.AT.ANS
   at.vars<-1> = "COMMAND"             ; at.offsets<-1> = SYSCOM.COMMAND
   at.vars<-1> = "COMMAND.STACK"       ; at.offsets<-1> = SYSCOM.COMMAND.STACK
   at.vars<-1> = "CONV"                ; at.offsets<-1> = SYSCOM.CONV
   at.vars<-1> = "DATA.PENDING"        ; at.offsets<-1> = SYSCOM.DATA.QUEUE
   at.vars<-1> = "DATE"                ; at.offsets<-1> = -SYSCOM.CPROC.DATE
   at.vars<-1> = "DS"                  ; at.offsets<-1> = SYSCOM.DS
   at.vars<-1> = "FILE.NAME"           ; at.offsets<-1> = -SYSCOM.QPROC.FILE.NAME
   at.vars<-1> = "ID"                  ; at.offsets<-1> = SYSCOM.QPROC.ID
   at.vars<-1> = "ITYPE.MODE"          ; at.offsets<-1> = SYSCOM.ITYPE.MODE
   at.vars<-1> = "LOGNAME"             ; at.offsets<-1> = SYSCOM.LOGNAME
   at.vars<-1> = "LPV"                 ; at.offsets<-1> = SYSCOM.QPROC.LPV
   at.vars<-1> = "NB"                  ; at.offsets<-1> = SYSCOM.QPROC.BREAK.LEVEL
   at.vars<-1> = "ND"                  ; at.offsets<-1> = SYSCOM.QPROC.ND
   at.vars<-1> = "NI"                  ; at.offsets<-1> = SYSCOM.QPROC.NI
   at.vars<-1> = "NV"                  ; at.offsets<-1> = SYSCOM.QPROC.NV
   at.vars<-1> = "NS"                  ; at.offsets<-1> = SYSCOM.QPROC.NS
   at.vars<-1> = "SENTENCE"            ; at.offsets<-1> = SYSCOM.SENTENCE
   at.vars<-1> = "PARASENTENCE"        ; at.offsets<-1> = SYSCOM.PARASENTENCE
   at.vars<-1> = "PATH"                ; at.offsets<-1> = SYSCOM.ACCOUNT.PATH
   at.vars<-1> = "PIB"                 ; at.offsets<-1> = SYSCOM.PROC.IBUF:'.0'
   at.vars<-1> = "POB"                 ; at.offsets<-1> = SYSCOM.PROC.OBUF:'.0'
   at.vars<-1> = "RECORD"              ; at.offsets<-1> = SYSCOM.QPROC.RECORD
   at.vars<-1> = "SELECTED"            ; at.offsets<-1> = SYSCOM.SELECTED
   at.vars<-1> = "SIB"                 ; at.offsets<-1> = SYSCOM.PROC.IBUF:'.1'
   at.vars<-1> = "SOB"                 ; at.offsets<-1> = SYSCOM.PROC.OBUF:'.1'
   at.vars<-1> = "SYSTEM.RETURN.CODE"  ; at.offsets<-1> = SYSCOM.SYSTEM.RETURN.CODE
   at.vars<-1> = "SYSTEM.SET"          ; at.offsets<-1> = SYSCOM.SYSTEM.RETURN.CODE
   at.vars<-1> = "SYS.BELL"            ; at.offsets<-1> = SYSCOM.BELL
   at.vars<-1> = "TIME"                ; at.offsets<-1> = -SYSCOM.CPROC.TIME
   at.vars<-1> = "TRIGGER.RETURN.CODE" ; at.offsets<-1> = SYSCOM.TRIGGER.RETURN.CODE
   at.vars<-1> = "TTY"                 ; at.offsets<-1> = SYSCOM.TTY
   at.vars<-1> = "USER"                ; at.offsets<-1> = SYSCOM.LOGNAME
   at.vars<-1> = "USER0"               ; at.offsets<-1> = SYSCOM.USER0
   at.vars<-1> = "USER1"               ; at.offsets<-1> = SYSCOM.USER1
   at.vars<-1> = "USER2"               ; at.offsets<-1> = SYSCOM.USER2
   at.vars<-1> = "USER3"               ; at.offsets<-1> = SYSCOM.USER3
   at.vars<-1> = "USER4"               ; at.offsets<-1> = SYSCOM.USER4
   at.vars<-1> = "USER.RETURN.CODE"    ; at.offsets<-1> = SYSCOM.USER.RETURN.CODE
   at.vars<-1> = "VOC"                 ; at.offsets<-1> = SYSCOM.VOC
   at.vars<-1> = "WHO"                 ; at.offsets<-1> = SYSCOM.WHO


   * Reserved names

   reserved.names = "THEN":@fm:"ELSE"

   * Intrinsic function names and associated opcodes

   intrinsics = "ABS"                 ; intrinsic.opcodes = op.abs
   intrinsics<-1> = "ABSS"            ; intrinsic.opcodes<-1> = op.abss
   intrinsics<-1> = "ACOS"            ; intrinsic.opcodes<-1> = op.acos
   intrinsics<-1> = "ALPHA"           ; intrinsic.opcodes<-1> = op.alpha
   intrinsics<-1> = "ANDS"            ; intrinsic.opcodes<-1> = op.ands
   intrinsics<-1> = "ASCII"           ; intrinsic.opcodes<-1> = op.ascii
   intrinsics<-1> = "ASIN"            ; intrinsic.opcodes<-1> = op.asin
   intrinsics<-1> = "ATAN"            ; intrinsic.opcodes<-1> = op.atan
   intrinsics<-1> = "BITAND"          ; intrinsic.opcodes<-1> = op.bitand
   intrinsics<-1> = "BITNOT"          ; intrinsic.opcodes<-1> = op.bitnot
   intrinsics<-1> = "BITOR"           ; intrinsic.opcodes<-1> = op.bitor
   intrinsics<-1> = "BITRESET"        ; intrinsic.opcodes<-1> = op.bitreset
   intrinsics<-1> = "BITSET"          ; intrinsic.opcodes<-1> = op.bitset
   intrinsics<-1> = "BITTEST"         ; intrinsic.opcodes<-1> = op.bittest
   intrinsics<-1> = "BITXOR"          ; intrinsic.opcodes<-1> = op.bitxor
   intrinsics<-1> = "CATS"            ; intrinsic.opcodes<-1> = op.cats
   intrinsics<-1> = "CHANGE"          ; intrinsic.opcodes<-1> = op.change
   intrinsics<-1> = "CHAR"            ; intrinsic.opcodes<-1> = op.char
   intrinsics<-1> = "CHECKSUM"        ; intrinsic.opcodes<-1> = op.checksum
   intrinsics<-1> = "COL1"            ; intrinsic.opcodes<-1> = op.col1
   intrinsics<-1> = "COL2"            ; intrinsic.opcodes<-1> = op.col2
   intrinsics<-1> = "COMPARE"         ; intrinsic.opcodes<-1> = op.compare
   intrinsics<-1> = "CONVERT"         ; intrinsic.opcodes<-1> = op.fconvert
   intrinsics<-1> = "COS"             ; intrinsic.opcodes<-1> = op.cos
   intrinsics<-1> = "COUNT"           ; intrinsic.opcodes<-1> = op.count
   intrinsics<-1> = "COUNTS"          ; intrinsic.opcodes<-1> = op.counts
   intrinsics<-1> = "CROP"            ; intrinsic.opcodes<-1> = op.crop
   intrinsics<-1> = "CSVDQ"           ; intrinsic.opcodes<-1> = op.csvdq
   intrinsics<-1> = "DATE"            ; intrinsic.opcodes<-1> = op.date
   intrinsics<-1> = "DCOUNT"          ; intrinsic.opcodes<-1> = op.dcount
   intrinsics<-1> = "DECRYPT"         ; intrinsic.opcodes<-1> = op.decrypt
   intrinsics<-1> = "DELETE"          ; intrinsic.opcodes<-1> = op.del
   intrinsics<-1> = "DIR"             ; intrinsic.opcodes<-1> = op.dir
   intrinsics<-1> = "DIV"             ; intrinsic.opcodes<-1> = op.quotient
   intrinsics<-1> = "DOWNCASE"        ; intrinsic.opcodes<-1> = op.dncase
   intrinsics<-1> = "DQUOTE"          ; intrinsic.opcodes<-1> = op.quote
   intrinsics<-1> = "DTX"             ; intrinsic.opcodes<-1> = op.dtx
   intrinsics<-1> = "EBCDIC"          ; intrinsic.opcodes<-1> = op.ebcdic
   intrinsics<-1> = "ENCRYPT"         ; intrinsic.opcodes<-1> = op.encrypt
   intrinsics<-1> = "ENV"             ; intrinsic.opcodes<-1> = op.env
   intrinsics<-1> = "EQS"             ; intrinsic.opcodes<-1> = op.eqs
   intrinsics<-1> = "EXP"             ; intrinsic.opcodes<-1> = op.exp
   intrinsics<-1> = "EXTRACT"         ; intrinsic.opcodes<-1> = op.extract
   intrinsics<-1> = "FIELD"           ; intrinsic.opcodes<-1> = op.field
   intrinsics<-1> = "FIELDS"          ; intrinsic.opcodes<-1> = op.fields
   intrinsics<-1> = "FMT"             ; intrinsic.opcodes<-1> = op.fmt
   intrinsics<-1> = "FMTS"            ; intrinsic.opcodes<-1> = op.fmts
   intrinsics<-1> = "FOLD"            ; intrinsic.opcodes<-1> = op.fold
   intrinsics<-1> = "FOLDS"           ; intrinsic.opcodes<-1> = op.folds
   intrinsics<-1> = "GES"             ; intrinsic.opcodes<-1> = op.ges
   intrinsics<-1> = "GTS"             ; intrinsic.opcodes<-1> = op.gts
   intrinsics<-1> = "ICONV"           ; intrinsic.opcodes<-1> = op.iconv
   intrinsics<-1> = "ICONVS"          ; intrinsic.opcodes<-1> = op.iconvs
   intrinsics<-1> = "IDIV"            ; intrinsic.opcodes<-1> = op.idiv
   intrinsics<-1> = "IFS"             ; intrinsic.opcodes<-1> = op.ifs
   intrinsics<-1> = "INDEX"           ; intrinsic.opcodes<-1> = op.index
   intrinsics<-1> = "INDEXS"          ; intrinsic.opcodes<-1> = op.indexs
   intrinsics<-1> = "INSERT"          ; intrinsic.opcodes<-1> = op.insert
   intrinsics<-1> = "INT"             ; intrinsic.opcodes<-1> = op.int
   intrinsics<-1> = "LEN"             ; intrinsic.opcodes<-1> = op.len
   intrinsics<-1> = "LENS"            ; intrinsic.opcodes<-1> = op.lens
   intrinsics<-1> = "LES"             ; intrinsic.opcodes<-1> = op.les
   intrinsics<-1> = "LISTINDEX"       ; intrinsic.opcodes<-1> = op.listindx
   intrinsics<-1> = "LN"              ; intrinsic.opcodes<-1> = op.ln
   intrinsics<-1> = "LOCATE"          ; intrinsic.opcodes<-1> = op.locatef
   intrinsics<-1> = "LOWER"           ; intrinsic.opcodes<-1> = op.lower
   intrinsics<-1> = "LTS"             ; intrinsic.opcodes<-1> = op.lts
   intrinsics<-1> = "MATCHFIELD"      ; intrinsic.opcodes<-1> = op.matchfld
   intrinsics<-1> = "MAX"             ; intrinsic.opcodes<-1> = op.max
   intrinsics<-1> = "MAXIMUM"         ; intrinsic.opcodes<-1> = op.maximum
   intrinsics<-1> = "MIN"             ; intrinsic.opcodes<-1> = op.min
   intrinsics<-1> = "MINIMUM"         ; intrinsic.opcodes<-1> = op.minimum
   intrinsics<-1> = "MOD"             ; intrinsic.opcodes<-1> = op.mod
   intrinsics<-1> = "MODS"            ; intrinsic.opcodes<-1> = op.mods
   intrinsics<-1> = "NEG"             ; intrinsic.opcodes<-1> = op.neg
   intrinsics<-1> = "NEGS"            ; intrinsic.opcodes<-1> = op.negs
   intrinsics<-1> = "NES"             ; intrinsic.opcodes<-1> = op.nes
   intrinsics<-1> = "NOT"             ; intrinsic.opcodes<-1> = op.not
   intrinsics<-1> = "NOTS"            ; intrinsic.opcodes<-1> = op.nots
   intrinsics<-1> = "NUM"             ; intrinsic.opcodes<-1> = op.num
   intrinsics<-1> = "NUMS"            ; intrinsic.opcodes<-1> = op.nums
   intrinsics<-1> = "OCONV"           ; intrinsic.opcodes<-1> = op.oconv
   intrinsics<-1> = "OCONVS"          ; intrinsic.opcodes<-1> = op.oconvs
   intrinsics<-1> = "ORS"             ; intrinsic.opcodes<-1> = op.ors
   intrinsics<-1> = "OUTERJOIN"       ; intrinsic.opcodes<-1> = op.ojoin
   intrinsics<-1> = "PWR"             ; intrinsic.opcodes<-1> = op.pwr
   intrinsics<-1> = "QUOTE"           ; intrinsic.opcodes<-1> = op.quote
   intrinsics<-1> = "RAISE"           ; intrinsic.opcodes<-1> = op.raise
   intrinsics<-1> = "RDIV"            ; intrinsic.opcodes<-1> = op.rdiv
   intrinsics<-1> = "REM"             ; intrinsic.opcodes<-1> = op.rem
   intrinsics<-1> = "REPLACE"         ; intrinsic.opcodes<-1> = op.replace
   intrinsics<-1> = "REUSE"           ; intrinsic.opcodes<-1> = op.reuse
   intrinsics<-1> = "RND"             ; intrinsic.opcodes<-1> = op.rnd
   intrinsics<-1> = "RTRANS"          ; intrinsic.opcodes<-1> = op.rtrans
   intrinsics<-1> = "SEQ"             ; intrinsic.opcodes<-1> = op.seq
   intrinsics<-1> = "SHIFT"           ; intrinsic.opcodes<-1> = op.shift
   intrinsics<-1> = "SIN"             ; intrinsic.opcodes<-1> = op.sin
   intrinsics<-1> = "SOUNDEX"         ; intrinsic.opcodes<-1> = op.soundex
   intrinsics<-1> = "SOUNDEXS"        ; intrinsic.opcodes<-1> = op.soundexs
   intrinsics<-1> = "SPACE"           ; intrinsic.opcodes<-1> = op.space
   intrinsics<-1> = "SPACES"          ; intrinsic.opcodes<-1> = op.spaces
   intrinsics<-1> = "SPLICE"          ; intrinsic.opcodes<-1> = op.splice
   intrinsics<-1> = "SQRT"            ; intrinsic.opcodes<-1> = op.sqrt
   intrinsics<-1> = "SQUOTE"          ; intrinsic.opcodes<-1> = op.squote
   intrinsics<-1> = "STATUS"          ; intrinsic.opcodes<-1> = op.status
   intrinsics<-1> = "STR"             ; intrinsic.opcodes<-1> = op.str
   intrinsics<-1> = "STRS"            ; intrinsic.opcodes<-1> = op.strs
   intrinsics<-1> = "SUBR"            ; intrinsic.opcodes<-1> = ''
   intrinsics<-1> = "SUBSTITUTE"      ; intrinsic.opcodes<-1> = op.subst
   intrinsics<-1> = "SUBSTRINGS"      ; intrinsic.opcodes<-1> = op.substrng
   intrinsics<-1> = "SUM"             ; intrinsic.opcodes<-1> = op.sum
   intrinsics<-1> = "SUMMATION"       ; intrinsic.opcodes<-1> = op.summation
   intrinsics<-1> = "SWAP"            ; intrinsic.opcodes<-1> = op.change
   intrinsics<-1> = "SWAPCASE"        ; intrinsic.opcodes<-1> = op.swapcase
   intrinsics<-1> = "SYSTEM"          ; intrinsic.opcodes<-1> = op.system
   intrinsics<-1> = "TAN"             ; intrinsic.opcodes<-1> = op.tan
   intrinsics<-1> = "TIME"            ; intrinsic.opcodes<-1> = op.time
   intrinsics<-1> = "TIMEDATE"        ; intrinsic.opcodes<-1> = op.timedate
   intrinsics<-1> = "TOTAL"           ; intrinsic.opcodes<-1> = op.total
   intrinsics<-1> = "TRANS"           ; intrinsic.opcodes<-1> = op.trans
   intrinsics<-1> = "TRIM"            ; intrinsic.opcodes<-1> = op.trim
   intrinsics<-1> = "TRIMB"           ; intrinsic.opcodes<-1> = op.trimb
   intrinsics<-1> = "TRIMBS"          ; intrinsic.opcodes<-1> = op.trimbs
   intrinsics<-1> = "TRIMF"           ; intrinsic.opcodes<-1> = op.trimf
   intrinsics<-1> = "TRIMFS"          ; intrinsic.opcodes<-1> = op.trimfs
   intrinsics<-1> = "TRIMS"           ; intrinsic.opcodes<-1> = op.trims
   intrinsics<-1> = "UPCASE"          ; intrinsic.opcodes<-1> = op.upcase
   intrinsics<-1> = "VSLICE"          ; intrinsic.opcodes<-1> = op.vslice
   intrinsics<-1> = "XLATE"           ; intrinsic.opcodes<-1> = op.trans
   intrinsics<-1> = "XTD"             ; intrinsic.opcodes<-1> = op.xtd


   intrinsic.stack = ""
   subr.stack = ''         ;* V1 = var no; V2 = arg count
   total.index = 0

   ascending.left = "AL"

   * Object header information

   header.flags = HDR.ITYPE         ;* Option flags
   greatest.call.arg.count = 0

   * Expression processing

   op.stack.depth = 0
   unary.minus = @false

   trans.stack = ""

   * Label table and jump opcode control data
   * _Tn = skip label for TOTAL() function

   label.names = ""
   label.addrs = ""

   jump.no = 0          ;* Next available jump number
   jump.stack = ""      ;* Nested construct stack. Contains jump numbers.

   * Code generation control

   code.image = str(char(0), 32768)  ;* Final code image
   pc = 0                            ;* PC of next byte to emit

   arg.count.stack = ""

   no.vars = 0                       ;* Running counter of number of variables
   expr.no = 1                       ;* Current expression number

   embedded.objects = ''
   embedded.object.vars = ''

   expr.var.base = no.vars           ;* Var no of @1 for this expression
   nested.itype.stack = ''           ;* V1 = expr.var.base } Stacked at nested
                                      * V2 = expr.no       } I-type entry

   first.field = @true
   constant = @true              ;* Evaluated constant until we know otherwise

*****************************************************************************

   if source[1,1] = "!"  & kernel(K$INTERNAL, -1) then
      source = source[2,999999]
      print.code = @true
   end

   if print.code then print source

   * Emit skeleton object header

   opcode.byte = 0
   loop
   until pc = itype.object.header.size
      gosub emit
   repeat

   start.pc = pc    ;* Default start location

   * Parse source record into tokens, counting expressions as we go

   num.tokens = 0
   expr.count = 1
   loop
      remove.token s from source setting i
      if i = TKN.UNCLOSED then
         err.msg = sysmsg(2977) ;* Unclosed string
         goto error
      end

      if num.tokens >= max.tokens then  ;* Must expand tables
         max.tokens += 100
         gosub expand.token.tables
      end
      num.tokens += 1     ;* 0320 moved

      token.strings(num.tokens) = s
      u.token.strings(num.tokens) = upcase(s)
      tokens(num.tokens) = i
      if i = TKN.SEMICOLON then expr.count += 1
   while i
   repeat

   look.ahead.token = tokens(1)
   look.ahead.token.string = token.strings(1)
   u.look.ahead.token.string = u.token.strings(1)
   token.index = 1

   no.vars += expr.count
   final.var = no.vars - 1

   * Process source

   loop
      n = expr.var.base + expr.no - 1
      gosub emit.var.load

      gosub expr

      opcode.byte = op.stor
      gosub emit.simple

   while look.ahead.token = tkn.semicolon
   
      gosub get.token                      ;* Skip semicolon

      expr.no += 1
   repeat

   if look.ahead.token # tkn.end then
      err.msg = sysmsg(2978) ;* Unexpected source text
      goto error
   end

   * Copy result to @ANS

   n = syscom.at.ans
   gosub emit.ldsys

   n = final.var
   gosub emit.var.load       ;* LDLCL of final @n variable

   opcode.byte = op.stor
   gosub emit.simple

   * Emit code to leave result on stack and a RETURN opcode

   n = final.var
   gosub emit.var.load       ;* LDLCL of final @n variable

   opcode.byte = op.value    ;* Place actual value on stack
   gosub emit.simple

   opcode.byte = op.return
   gosub emit.simple


   * Generate prelude if we need to pre-load any embedded code

   if embedded.objects # '' then
      start.pc = pc
      loop
         remove s from embedded.objects setting more
         read embed.rec from dict.file, s else
            err.msg = sysmsg(3400, s) ;* Unable to load embedded object code for %1
            goto error
         end

         remove n from embedded.object.vars setting i
         gosub emit.var.load

         opcode.string = field(embed.rec, @fm, DICT.ITYPE.OBJECT)
         gosub emit.string.load

         opcode.byte = OP.STOR
         gosub emit.simple
      while more
      repeat

      * Generate a jump to the original entry point of the program

      opcode.byte = op.jmp
      if print.code then
         * Show the code to be generated
         s = fmt(opcodes<1,opcode.byte + 1>, "9L"):oconv(itype.object.header.size, "MX")
         gosub show.code
      end
      gosub emit
      code.value = itype.object.header.size
      code.bytes = 3
      gosub emit.multibyte.value
   end

   * Check for unclosed constructs - can only be IF/THEN/ELSE

   if jump.stack # "" then
      err.msg = sysmsg(2979) ;* Structural error in IF/THEN/ELSE
      goto error
   end

   * Check for undefined labels

   i = 1

   if label.addrs # '' then
      label.addrs = label.addrs
      loop
         remove s from label.addrs setting j
         if s < 0 then
            err.msg = sysmsg(2980, label.names<i>)
            * Internal error: Label xx referenced but not defined
            goto error
         end
      while j
         i += 1
      repeat
   end

   * Save the final code page

   * Go back and fill in the object header

   * Magic number. Offset 0, 1 byte
   i = if system(1009) then HDR.MAGIC.NO.B else HDR.MAGIC.NO.L
   code.image[HDR.MAGIC,1] = char(i)

   * Object revision. 1 byte
   code.image[HDR.REV,1] = char(HDR.REVISION)

   * Start PC. 4 bytes
   code.image[HDR.START.OFFSET,4] = iconv(start.pc, 'IL')

   * Local variable count. 2 bytes
   code.image[HDR.NO.VARS,2] = iconv(no.vars, 'IS')

   * Stack depth. 2 bytes
   i = 100 + greatest.call.arg.count
   code.image[HDR.STACK.DEPTH,2] = iconv(i, 'IS')

   * Object size. 4 bytes
   code.image[HDR.OBJECT.SIZE,4] = iconv(pc, 'IL')

   * Flags. 2 bytes
   code.image[HDR.FLAGS,2] = iconv(header.flags, 'IS')

   * Compile time. 2 bytes
   code.image[HDR.COMPILE.TIME,4] = iconv(system(1005), 'IL')

   * Number of TOTAL() functions. 1 byte
   code.image[HDR.TOTALS,1] = char(total.index)

   if print.code then gosub display.code

   * Pass object code back via call argument
 
   object = code.image[1,pc]

   @system.return.code = 0

   return

*****************************************************************************
* GET.TOKEN  -  Get next token from pre-parsed source token array

get.token:
   token = look.ahead.token
   token.string = look.ahead.token.string
   u.token.string = u.look.ahead.token.string

   if token # tkn.end then
      token.index += 1
      look.ahead.token = tokens(token.index)
      look.ahead.token.string = token.strings(token.index)
      u.look.ahead.token.string = u.token.strings(token.index)
   end

   return

* ======================================================================
* EMIT.FIELD.LOAD  -  Load a field from the current record
* fno = field number

emit.field.load:
   begin case
      case fno = 0
         n = SYSCOM.QPROC.ID      ; gosub emit.ldsys

      case fno = 9998
         n = SYSCOM.QPROC.NI      ; gosub emit.ldsys

      case fno = 9999
         n = SYSCOM.QPROC.RECORD  ; gosub emit.ldsys
         opcode.byte = OP.LEN     ; gosub emit.simple

      case 1
         n = SYSCOM.QPROC.RECORD  ; gosub emit.ldsys
         n = fno                  ; gosub emit.numeric.load
         n = 0                    ; gosub emit.numeric.load
         n = 0                    ; gosub emit.numeric.load
         opcode.byte = OP.EXTRACT ; gosub emit.simple
   end case

   return

*****************************************************************************
* EMIT.VAR.LOAD  -  Emit LDLCL for var N

emit.var.load:
   if n < 256 then       ;* Use LDSLCL
      if print.code then
         s = "LDSLCL   " : n
         gosub show.code
      end

      opcode.byte = op.ldslcl
      gosub emit
      opcode.byte = n
      gosub emit
   end
   else                              ;* Use LDLCL
      if print.code then
         s = "LDLCL    " : n
         gosub show.code
      end

      opcode.byte = op.ldlcl
      gosub emit
      code.value = n
      code.bytes = 2
      gosub emit.multibyte.value
   end

   return

*****************************************************************************
* EMIT.AT.VAR.LOAD  -  Emit code to load an @variable

emit.at.var.load:
   gosub get.token

   locate u.token.string in at.constants<1> setting i then
      on i goto at.mark,at.mark,at.mark,at.mark,at.mark,at.mark,at.mark,
           at.false,
           at.true,
           at.userno,
           at.userno,
           at.day,
           at.month,
           at.year,
           at.year4,
           at.term.type,
           at.transaction.id,
           at.transaction.level,
           at.ip.addr,
           at.hostname,
           at.gid,
           at.uid
               
at.mark:                                    ;* FM, VM, SM, TM, IM, AM, SVM
      opcode.string = mark.chars[i,1] ; gosub emit.string.load
      return

at.false:
      n = 0 ; gosub emit.numeric.load
      return

at.true:
      n = 1 ; gosub emit.numeric.load
      return

at.userno:                                  ;* @USERNO
      opcode.byte = op.userno ; gosub emit.simple
      return

at.day:                                     ;* @DAY
      n = syscom.cproc.date ; gosub emit.ldsys
      opcode.string = "DD" ; gosub emit.string.load
      opcode.byte = op.oconv ; gosub emit.simple
      return

at.month:                                   ;* @MONTH
      n = syscom.cproc.date ; gosub emit.ldsys
      opcode.string = "DM[2]" ; gosub emit.string.load
      opcode.byte = op.oconv ; gosub emit.simple
      return

at.year:                                    ;* @YEAR
      n = syscom.cproc.date ; gosub emit.ldsys
      opcode.string = "D2Y" ; gosub emit.string.load
      opcode.byte = op.oconv ; gosub emit.simple
      return

at.year4:                                   ;* @YEAR4
      n = syscom.cproc.date ; gosub emit.ldsys
      opcode.string = "D4Y" ; gosub emit.string.load
      opcode.byte = op.oconv ; gosub emit.simple
      return

at.term.type:
      n = K$TERM.TYPE ; gosub emit.numeric.load
      opcode.byte = op.ldnull ; gosub emit.simple
      opcode.byte = op.kernel ; gosub emit.simple
      return

at.transaction.id:
      n = 1007 ; gosub emit.numeric.load
      opcode.byte = op.system ; gosub emit.simple
      return

at.transaction.level:
      n = 1008 ; gosub emit.numeric.load
      opcode.byte = op.system ; gosub emit.simple
      return

at.ip.addr:
      n = 42 ; gosub emit.numeric.load
      opcode.byte = op.system ; gosub emit.simple
      return

at.hostname:
      n = 1015 ; gosub emit.numeric.load
      opcode.byte = op.system ; gosub emit.simple
      return

at.gid:
      n = 29 ; gosub emit.numeric.load
      opcode.byte = OP.SYSTEM ; gosub emit.simple
      return

at.uid:
      n = 27 ; gosub emit.numeric.load
      opcode.byte = OP.SYSTEM ; gosub emit.simple
      return
   end

   * Try the SYSCOM variables.

   locate u.token.string in at.vars<1> setting i then
      n = at.offsets<i>
      sysv.index = field(n, '.', 2)
      n = field(n, '.', 1)
      if n > 0 then constant = @false
      else n = -n
      gosub emit.ldsys

      * Is this a reference to an array element?

      if sysv.index # '' then
         n = sysv.index ; gosub emit.numeric.load
         opcode.byte = op.indx1 ; gosub emit.simple
      end
   end else
      err.msg = sysmsg(2967) ;* Unrecognised @ variable
      goto error
   end

   return

****************************************************
* Emit an LDSYS opcode. Offset is in N

emit.ldsys:
   if print.code then
      s = "LDSYS    " : n
      gosub show.code
   end

   opcode.byte = op.ldsys
   gosub emit

   opcode.byte = n
   gosub emit

   return

*****************************************************************************
* EMIT.NUMERIC.LOAD  -  Emit LDSINT, LDLINT or LDFLOAT
* Value to load is in N

emit.numeric.load:
   if vartype(n) = V$FLOATNUM then  ;* 0087
      if print.code then
         * Show the code to be generated
         s = "LDFLOAT  ":n
         gosub show.code
      end

      * Emit LDFLOAT opcode
      opcode.byte = op.ldfloat
      gosub emit
      code.image[pc+1, 8] = iconv(n, 'IFL')
      pc += 8

      return
   end

   if (n > -129) and (n < 128) then     ;* Use LDSINT or LD0/LD1
      if n = 0 then
         opcode.byte = op.ld0
         gosub emit.simple
         return
      end

      if n = 1 then
         opcode.byte = op.ld1
         gosub emit.simple
         return
      end

      if print.code then
         * Show the code to be generated
         s = "LDSINT   ":n
         gosub show.code
      end

      * Emit LDSINT opcode
      opcode.byte = op.ldsint
      gosub emit
      opcode.byte = n
      gosub emit
   end else                           ;* Use LDLINT
      if print.code then
         * Show the code to be generated
         s = "LDLINT   ":n
         gosub show.code
      end

      * Emit LDLINT opcode
      opcode.byte = op.ldlint
      gosub emit
      code.value = n
      code.bytes = 4
      gosub emit.multibyte.value
   end

  return

*****************************************************************************
* EMIT.STRING.LOAD  -  Emit string in OPCODE.STRING

emit.string.load:
*     If the string is less than 256 characters long we can load it in
*     one go. Otherwise we must concatenate short chunks.

   k = @false           ;* K is true for second and subsequent fragments
   loop
      n = len(opcode.string)
      if n > 255 then n = 255
      if print.code then
         s = 'LDSTR    "' : opcode.string[1, 60]
         if n <= 60 then s := '"'
         gosub show.code
      end

      opcode.byte = op.ldstr
      gosub emit
      opcode.byte = n
      gosub emit
      code.image[pc+1, n] = opcode.string
      pc += n
      if k then
         * Emit a CAT opcode
         opcode.byte = op.cat
         gosub emit.simple
      end
      k = @true
      opcode.string = opcode.string[n + 1, len(opcode.string)]
   while len(opcode.string) > 0
   repeat

   return

*****************************************************************************
* SET.LABEL  -  Generate source label

set.label:
   if print.code then
      print "       ":fmt(oconv(pc, "MX"), "6'0'R"):": ":label.name
   end

   * Search label table for this label name
   locate label.name in label.names<1> setting i then

      * We have found the label in the label table.

      jump.addr = label.addrs<i>
      if jump.addr < 0 then       ;* It is a forward reference
         update.addr = -jump.addr
         label.addrs<i> = pc      ;* Correct the label table entry.

         * Go back and fill in the jump chain.

         loop
            * Fetch next jump chain address from jump opcode, replacing by
            * actual address as we go.

            code.value = pc
            code.bytes = 3
            jump.addr = 0
            byte.scale = 1

            loop
               byte.value = char(bitand(code.value, 255))
               code.value = shift(code.value, 8)
               jump.addr += seq(code.image[update.addr + 1, 1]) * byte.scale
               code.image[update.addr + 1, 1] = byte.value

               update.addr += 1
               code.bytes -= 1
            until code.bytes = 0
               byte.scale = shift(byte.scale, -8)
            repeat
         while jump.addr # 0
            update.addr = jump.addr
         repeat

      end
      else
         * It is not a forward reference. Flag an error.
         err.msg = sysmsg(2981) ;* Internal error: Duplicate label
         goto error
      end
   end
   else
      * Add new entry to the label table

      ins label.name before label.names<1>
      ins pc before label.addrs<1>
   end

   return
              
*****************************************************************************
* EMIT.JUMP  -  Emit a jump opcode
* OPCODE.BYTE holds jump opcode
* LABEL.NAME holds target label

emit.jump:
   if print.code then
      * Show the code to be generated
      s = fmt(opcodes<1,opcode.byte + 1>, "9L"):label.name
      gosub show.code
   end

   * Emit the jump opcode
   gosub emit
   gosub emit.jump.addr

   return

**********************************************************************
* EMIT.JUMP.ADDR  -  Emit 3 byte jump address
* LABEL.NAME contains target label

emit.jump.addr:
   * Find label in symbol table

   locate label.name in label.names<1> setting i then
      jump.addr = label.addrs<i>
      if jump.addr < 0 then
         * This is a forward reference. Update the label table to point to
         * this jump to build a chain through all forward references.

         label.addrs<i> = -pc
         jump.addr = - jump.addr
      end
   end
   else
      * Label is not in symbol table. Make a forward reference entry

      ins label.name before label.names<1>
      ins -pc before label.addrs<1>
      jump.addr = 0
   end

   * Emit the jump address
   code.value = jump.addr
   code.bytes = 3
   gosub emit.multibyte.value

   return

*****************************************************************************
* EMIT.SIMPLE - Emit a simple single byte opcode
* Opcode is in OPCODE.BYTE

emit.simple:
   if opcode.byte > 256 then
      prefixed.opcode = opcode.byte

      if print.code then
         * Show the code to be generated

         locate prefixed.opcode in prefixed.opcode.values<1,1> setting ppos then
            s = prefixed.opcodes<1,ppos>
         end else
            s = 'OP_' : oconv(prefixed.opcode, 'MX')
         end
         gosub show.code
      end

      opcode.byte = shift(prefixed.opcode, 8)
      gosub emit

      opcode.byte = bitand(prefixed.opcode, 255)
      gosub emit

      return
   end

   if print.code then
      * Show the code to be generated
      s = opcodes<1,opcode.byte + 1>
      gosub show.code
   end

*********************************************
***** FALL THROUGH FROM ABOVE INTO EMIT *****
*********************************************

**********************************************************************
* EMIT  -  Emit byte from OPCODE.BYTE

emit:
   pc += 1   ;* Do increment first as we need PC+1 to index code.image
   code.image[pc,1] = char(opcode.byte)

   return

**********************************************************************
* EMIT.MULTIBYTE.VALUE  -  Emit multi-byte value
* CODE.VALUE   = Value to emit
* CODE.BYTES   = Number of bytes

emit.multibyte.value:
   loop
      opcode.byte = bitand(code.value, 255)
      code.value = shift(code.value, 8)
      gosub emit
      code.bytes -= 1
   until code.bytes = 0
   repeat

   return

**********************************************************************
* SHOW.CODE  -  Report emitted code
* Code string is in S

show.code:
   print "       ":fmt(oconv(pc, "MX"), "6'0'R"):":       ":s

   return

*****************************************************************************
*****                   STATEMENT PROCESSING ROUTINES                   *****
*****************************************************************************

*****************************************************************************
* EXPR  -  Process expression
*
* ------  +  ----------  (  ---  expr  ---  )  ---|
*   |---  -  ---|   |-------  var  -------------------  op  ---  expr  ---
*   |-----------|   |-------  const  -------------| |-------------------|
*

expr:
   gosub get.token

   if unary.minus then
      op.stack.depth += 1
      operator.stack(op.stack.depth) = OP.NEG
      priority.stack(op.stack.depth) = 1
      unary.minus = @false
   end

   op.stack.depth += 1
   priority.stack(op.stack.depth) = STACK.MARK

   loop
      gosub get.expr.item

      * Check for operator using look ahead

   until look.ahead.token < tkn.low.operator
   until look.ahead.token > tkn.high.operator

      priority = op.priority(look.ahead.token)
      loop
      while priority >= priority.stack(op.stack.depth)
         opcode.byte = operator.stack(op.stack.depth)
         gosub emit.simple
         op.stack.depth -= 1
      repeat

      op.stack.depth += 1
      operator.stack(op.stack.depth) =  op(look.ahead.token) ;* Opcode
      if look.ahead.token = tkn.pwr then
         * The ** operator associates right to left. Save a slightly higher
         * priority on the stack to force this action.
         priority.stack(op.stack.depth) = priority + 1            ;* Priority
      end
      else priority.stack(op.stack.depth) = priority              ;* Priority

      gosub get.token              ;* Skip operator token
      gosub get.token
   repeat

   * Apply remaining operators from stack

   loop
   while priority.stack(op.stack.depth) # STACK.MARK
      opcode.byte = operator.stack(op.stack.depth)
      gosub emit.simple
      op.stack.depth -= 1
   repeat

   if op.stack.depth then op.stack.depth -= 1    ;* Remove STACK.MARK

   return

* ======================================================================

get.expr.item:
   unary.minus = @FALSE

get.expr.item.again:
   begin case
      case token = tkn.name
         if u.token.string = "IF" then
            gosub expr          ;* Process condition

            * Add new entry to jump stack

            ins jump.no before jump.stack<1>
            label.name = "_":jump.no:"E"
            jump.no += 1
            opcode.byte = op.jfalse    ;* 0253
            gosub emit.jump

            * Emit THEN clause

            if u.look.ahead.token.string # "THEN" then
               err.msg = sysmsg(2950) ;* THEN not found where expected in conditional expression
               goto error
            end

            gosub get.token

            gosub expr          ;* Process THEN clause

            * Emit jump to exit label

            label.name = "_":jump.stack<1>:"X"
            opcode.byte = op.jmp
            gosub emit.jump

            * Emit ELSE clause

            label.name = "_":jump.stack<1>:"E"
            gosub set.label

            if u.look.ahead.token.string # "ELSE" then
               err.msg = sysmsg(2951) ;* ELSE not found where expected in conditional expression
               goto error
            end
            gosub get.token

            gosub expr          ;* Process ELSE clause

            * Emit exit label
            label.name = "_":jump.stack<1>:"X"
            gosub set.label

if.then.else.expr.abort:
            del jump.stack<1>
         end else
            * Look up name in dictionary

            read field.rec from dict.file, u.token.string else
               read field.rec from dict.file, u.token.string then
                  token.string = u.token.string
               end else
                  read field.rec from @voc, token.string else
                     read field.rec from @voc, u.token.string then
                        token.string = u.token.string
                     end else
                        err.msg = sysmsg(2982, token.string) ;* Field 'xx' is not defined
                        goto error
                     end
                  end
               end
            end

            type = upcase(field.rec[1,1])
            begin case
               case type = 'D' or ((type = 'A' or type = 'S') and field.rec<dict.a.correlative> = '')
                  fno = field.rec<dict.loc>
                  if not(num(fno)) then
                     err.msg = sysmsg(2983, token.string) ;* Field 'xx' has a non-numeric location
                     goto error
                  end

                  gosub emit.field.load

               case type = 'A' or type = 'S' or type = 'C'
                  * A/S-type item with correlative or C-type
                  * Unlike nested I-types, A/S-types that reference other
                  * compiled items do this as a run time subroutine call
                  * using ITYPE() to execute embedded object code.

                  if len(field.rec<DICT.ITYPE.OBJECT>) = 0 ~
                  or checksum(replace(field.rec, DICT.SYS.INFO, 1;'')) # field.rec<DICT.SYS.INFO,1> then
                     * Need to compile nested item

                     if depth > 10 then
                        err.msg = sysmsg(2998) ;* Compiled dictionary items nested too deeply
                        goto error
                     end

                     call $dcomp(dict.file,       ;* File var to source file
                                 token.string,    ;* Record name
                                 field.rec,       ;* Record to compile
                                 z,               ;* I-type format
                                 z,               ;* I-type conversion
                                 z,               ;* I-type S/M flag
                                 z,               ;* I-type association
                                 z,               ;* I-type is constant
                                 depth + 1)       ;* Recursive compilation depth

                     if field.rec<DICT.ITYPE.OBJECT> = '' then
                        err.msg = sysmsg(2612, token.string) ;* Compilation error in %1
                        goto error
                     end

                     write field.rec to dict.file, token.string
                  end

                  * Check to see if we have already loaded this object code.

                  locate token.string in embedded.objects<1> setting i then
                     n = embedded.object.vars<i> ;* Variable number
                  end else
                     embedded.objects<-1> = token.string
                     embedded.object.vars<-1> = no.vars
                     n = no.vars
                     no.vars += 1
                  end

                  gosub emit.var.load
                  opcode.byte = OP.ITYPE
                  gosub emit.simple

               case type = "I"  ;* Nested I-type
                  nested.source = field.rec<2>
                  if nested.source[1,1] = '!' then
                     nested.source = nested.source[2,99999]
                  end

                  max.nested.tokens = 200
                  dim nested.tokens(max.nested.tokens)
                  dim nested.token.strings(max.nested.tokens)
                  dim nested.u.token.strings(max.nested.tokens)

                  nested.tokens(1) = TKN.LBR
                  nested.token.strings(1) = '('
                  nested.u.token.strings(1) = '('
                  num.nested.tokens = 1

                  * Parse nested item into tokens, counting expressions
                  expr.count = 1
                  loop
                     remove.token s from nested.source setting i

                     num.nested.tokens += 1
                     if num.nested.tokens > max.nested.tokens then
                        max.nested.tokens += 100
                        dim nested.tokens(max.tokens)
                        dim nested.token.strings(max.tokens)
                        dim nested.u.token.strings(max.tokens)
                        for n = num.nested.tokens to max.nested.tokens
                           nested.tokens(n) = ''
                           nested.token.strings(n) = ''
                           nested.u.token.strings(n) = ''
                        next n
                     end

                     nested.token.strings(num.nested.tokens) = s
                     nested.u.token.strings(num.nested.tokens) = upcase(s)
                     nested.tokens(num.nested.tokens) = i
                     if i = TKN.SEMICOLON then expr.count += 1
                  while i
                  repeat


                  if expr.count > 1 then
                     * This is a compound I-type. We must create a separate
                     * variable space to store its intermediate results.

                     nested.tokens(1) = TKN.NEST
                     nested.token.strings(1) = '{'
                     nested.u.token.strings(1) = '{'
                     nested.tokens(num.nested.tokens) = TKN.UNNEST
                     nested.token.strings(num.nested.tokens) = '}'
                     nested.u.token.strings(num.nested.tokens) = '}'

                     ins expr.var.base : @vm : expr.no before nested.itype.stack<1>
                     expr.no = 1
                     expr.var.base = no.vars
                     no.vars += expr.count
                  end else
                     nested.tokens(num.nested.tokens) = TKN.RBR
                     nested.token.strings(num.nested.tokens) = ')'
                     nested.u.token.strings(num.nested.tokens) = ')'
                  end

                  * Check compiler limits
                  if num.tokens + num.nested.tokens > max.tokens then
                     max.tokens = num.tokens + num.nested.tokens + 100
                     gosub expand.token.tables
                  end

                  * Make a space in the token tables
                  for i = num.tokens to token.index step -1
                     j = i + num.nested.tokens
                     tokens(j) = tokens(i)
                     token.strings(j) = token.strings(i)
                     u.token.strings(j) = u.token.strings(i)
                  next i

                  * Insert the nested item
                  for i = 1 to num.nested.tokens
                     j = token.index + i - 1
                     tokens(j) = nested.tokens(i)
                     token.strings(j) = nested.token.strings(i)
                     u.token.strings(j) = nested.u.token.strings(i)
                  next i
                  num.tokens += num.nested.tokens

                  * Update the look-ahead
                  look.ahead.token = tokens(token.index)
                  look.ahead.token.string = token.strings(token.index)
                  u.look.ahead.token.string = u.token.strings(token.index)
                  gosub get.token
                  goto get.expr.item.again

               case 1
                  err.msg = sysmsg(2984, token.string) ;* Field 'xx' is not a data item
                  goto error
            end case

            if first.field then
               constant = @false
               format = field.rec<dict.format>
               conversion = field.rec<dict.conv>
               sm = field.rec<dict.s.m>
               assoc = field.rec<dict.assoc>
               first.field = @false
            end
         end

      case token = tkn.name.lbr    ;* Intrinsic function
         intrinsic.name = u.token.string

         gosub get.token           ; * Skip left bracket

         locate intrinsic.name in intrinsics<1> by ascending.left setting i else
            err.msg = sysmsg(2862, intrinsic.name) ;* Unrecognised function 'xx'
            goto error
         end

         constant = @false    ;* 0388
         ins intrinsic.opcodes<i> before intrinsic.stack<1>
         on i goto in.one,     ;* ABS
                   in.one,     ;* ABSS
                   in.one,     ;* ACOS
                   in.one,     ;* ALPHA
                   in.two,     ;* ANDS
                   in.one,     ;* ASCII
                   in.one,     ;* ASIN
                   in.one,     ;* ATAN
                   in.two,     ;* BITAND
                   in.one,     ;* BITNOT
                   in.two,     ;* BITOR
                   in.two,     ;* BITRESET
                   in.two,     ;* BITSET
                   in.two,     ;* BITTEST
                   in.two,     ;* BITXOR
                   in.two,     ;* CATS
                   in.change,  ;* CHANGE
                   in.one,     ;* CHAR
                   in.one,     ;* CHECKSUM
                   in.none,    ;* COL1
                   in.none,    ;* COL2
                   in.compare, ;* COMPARE
                   in.three,   ;* CONVERT
                   in.one,     ;* COS
                   in.two,     ;* COUNT
                   in.two,     ;* COUNTS
                   in.one,     ;* CROP
                   in.csvdq,   ;* CSVDQ
                   in.none,    ;* DATE
                   in.two,     ;* DCOUNT
                   in.two,     ;* DECRYPT
                   in.delete,  ;* DELETE
                   in.one,     ;* DIR
                   in.two,     ;* DIV
                   in.one,     ;* DOWNCASE
                   in.one,     ;* DQUOTE
                   in.dtx,     ;* DTX
                   in.one,     ;* EBCDIC
                   in.two,     ;* ENCRYPT
                   in.one,     ;* ENV
                   in.two,     ;* EQS
                   in.one,     ;* EXP
                   in.extract, ;* EXTRACT
                   in.field,   ;* FIELD
                   in.field,   ;* FIELDS
                   in.two,     ;* FMT
                   in.two,     ;* FMTS
                   in.fold,    ;* FOLD
                   in.fold,    ;* FOLDS
                   in.two,     ;* GES
                   in.two,     ;* GTS
                   in.two,     ;* ICONV
                   in.two,     ;* ICONVS
                   in.two,     ;* IDIV
                   in.three,   ;* IFS
                   in.three,   ;* INDEX
                   in.three,   ;* INDEXS
                   in.insert,  ;* INSERT
                   in.one,     ;* INT
                   in.one,     ;* LEN
                   in.one,     ;* LENS
                   in.two,     ;* LES
                   in.three,   ;* LISTINDEX
                   in.one,     ;* LN
                   in.locate,  ;* LOCATE
                   in.one,     ;* LOWER
                   in.two,     ;* LTS
                   in.three,   ;* MATCHFIELD
                   in.two,     ;* MAX
                   in.one,     ;* MAXIMUM
                   in.two,     ;* MIN
                   in.one,     ;* MINIMUM
                   in.two,     ;* MOD
                   in.two,     ;* MODS
                   in.one,     ;* NEG
                   in.one,     ;* NEGS
                   in.two,     ;* NES
                   in.one,     ;* NOT
                   in.one,     ;* NOTS
                   in.one,     ;* NUM
                   in.one,     ;* NUMS
                   in.two,     ;* OCONV
                   in.two,     ;* OCONVS
                   in.two,     ;* ORS
                   in.three,   ;* OUTERJOIN
                   in.two,     ;* PWR
                   in.one,     ;* QUOTE
                   in.one,     ;* RAISE
                   in.two,     ;* RDIV
                   in.two,     ;* REM
                   in.replace, ;* REPLACE
                   in.one,     ;* REUSE
                   in.one,     ;* RND
                   in.trans,   ;* RTRANS
                   in.one,     ;* SEQ
                   in.two,     ;* SHIFT
                   in.one,     ;* SIN
                   in.one,     ;* SOUNDEX
                   in.one,     ;* SOUNDEXS
                   in.one,     ;* SPACE
                   in.one,     ;* SPACES
                   in.three,   ;* SPLICE
                   in.one,     ;* SQRT
                   in.one,     ;* SQUOTE
                   in.none,    ;* STATUS
                   in.two,     ;* STR
                   in.two,     ;* STRS
                   in.subr,    ;* SUBR
                   in.subst,   ;* SUBSTITUTE
                   in.three,   ;* SUBSTRINGS
                   in.one,     ;* SUM
                   in.one,     ;* SUMMATION
                   in.change,  ;* SWAP
                   in.one,     ;* SWAPCASE
                   in.one,     ;* SYSTEM
                   in.one,     ;* TAN
                   in.none,    ;* TIME
                   in.none,    ;* TIMEDATE
                   in.total,   ;* TOTAL
                   in.trans,   ;* TRANS
                   in.trim,    ;* TRIM
                   in.one,     ;* TRIMB
                   in.one,     ;* TRIMBS
                   in.one,     ;* TRIMF
                   in.one,     ;* TRIMFS
                   in.trim,    ;* TRIMS
                   in.one,     ;* UPCASE
                   in.two,     ;* VSLICE
                   in.trans,   ;* XLATE
                   in.one      ;* XTD



in.one:
         gosub expr
         goto intrinsic.common

in.two:
         arg.count = 2
         gosub get.args
         goto intrinsic.common

in.three:
         arg.count = 3
         gosub get.args
         goto intrinsic.common

*** CHANGE()   3, 4 or 5 arguments. Arg 4 defaults to -1, arg 5 to 1
in.change:
            arg.count = 3
            gosub get.args

            if look.ahead.token = tkn.comma then
               gosub get.token
               gosub expr
            end else
               n = -1
               gosub emit.numeric.load
            end

            if look.ahead.token = tkn.comma then
               gosub get.token
               gosub expr
            end else
               n = 1
               gosub emit.numeric.load
            end
            goto intrinsic.common

*** COMPARE()   2 or 3 arguments, absent arg defaults to "L"
in.compare:
         arg.count = 2
         gosub get.args
         if look.ahead.token = tkn.comma then
            gosub get.token
            gosub expr
         end
         else
            opcode.string = "L"
            gosub emit.string.load
         end
         goto intrinsic.common

*** CSVDQ()  1 or 2 arguments, arg 2 defaulting to a comma
in.csvdq:
         gosub expr
         if look.ahead.token = TKN.COMMA then
            gosub get.token
            gosub expr
         end else
            opcode.string = ',' ; gosub emit.string.load
         end
         goto intrinsic.common

*** DELETE()   2, 3 or 4 arguments. Absent args default to zero
*** EXTRACT()   2, 3 or 4 arguments. Absent args default to zero
in.delete:
in.extract:
         arg.count = 2
         gosub get.args

         if look.ahead.token = tkn.comma then
            gosub get.token
            gosub expr
         end
         else
            n = 0
            gosub emit.numeric.load
         end

         if look.ahead.token = tkn.comma then
            gosub get.token
            gosub expr
         end
         else
            n = 0
            gosub emit.numeric.load
         end

         goto intrinsic.common

*** DTX()  1 or 2 arguments. Second defaults to 0 if omitted.
in.dtx:
         gosub expr        ;* Value to convert

         if look.ahead.token = tkn.comma then
            gosub get.token
            gosub expr
         end else
            n = 0; gosub emit.numeric.load
         end
         goto intrinsic.common

*** FIELD()   3 or 4 arguments, absent arg defaults to 1
in.field:
         arg.count = 3
         gosub get.args
         if look.ahead.token = tkn.comma then
            gosub get.token
            gosub expr
         end
         else
            n = 1
            gosub emit.numeric.load
         end
         goto intrinsic.common

*** FOLD()/FOLDS()  Two or three arguments
in.fold:
         arg.count = 2 ; gosub get.args
         if look.ahead.token = TKN.COMMA then
            gosub get.token
            gosub expr
            * Replace opcode on intrinsic stack
            if intrinsic.stack<1> = OP.FOLD then
               intrinsic.stack<1> = OP.FOLD3
            end else
               intrinsic.stack<1> = OP.FOLDS3
            end
         end
         goto intrinsic.common
            
*** INSERT()  3, 4 or 5 args, args 2 and 4 default to zero
*** REPLACE()  3, 4 or 5 args, args 2 and 4 default to zero
***          final arg may have semicolon delimiter.
in.insert:
in.replace:
         arg.count = 2       ;* Source string and field number
         gosub get.args

         if look.ahead.token = tkn.comma then    ;* Value number present
            gosub get.token
            gosub expr
         end else
            n = 0
            gosub emit.numeric.load
         end

         if look.ahead.token = tkn.comma then    ;* Subvalue number present
            gosub get.token
            gosub expr
         end else
            n = 0
            gosub emit.numeric.load
         end

         if (look.ahead.token # tkn.comma) and (look.ahead.token # tkn.semicolon) then
            err.msg = sysmsg(2861) ;* Expected comma or semicolon
            gosub error
            return
         end

         gosub get.token
         gosub expr                ;* New string value
         goto intrinsic.common

*** LOCATE()  3, 4 or 5 args. Final arg may have semicolon delimiter.
in.locate:
         arg.count = 3       ;* Search string, dynamic array, field pos
         gosub get.args

         if look.ahead.token = tkn.comma then    ;* Value number present
            gosub get.token
            gosub expr
         end else
            n = 0
            gosub emit.numeric.load
         end

         if look.ahead.token = tkn.comma then    ;* Subvalue number present
            gosub get.token
            gosub expr
         end else
            n = 0
            gosub emit.numeric.load
         end

         if (look.ahead.token = tkn.comma) or (look.ahead.token = tkn.semicolon) then
            gosub get.token
            gosub expr                ;* Order code
         end else
            opcode.string = ''
            gosub emit.string.load
         end

         goto intrinsic.common

*** SUBR(name [, arg1 [,arg2...]])
in.subr:
         gosub expr   ;* Subroutine name expression

         * Emit return argument

         n = no.vars                         ;* 0322
         ins no.vars before subr.stack<1>    ;* Remember result variable
         no.vars += 1
         gosub emit.var.load

         subr.stack<1,2> = 1                 ;* Track arg count
         loop
         while look.ahead.token = TKN.COMMA
            subr.stack<1,2> = subr.stack<1,2> + 1
            gosub get.token  ;* Skip comma
            gosub expr
         repeat

         * Emit call

         call.arg.count = subr.stack<1,2> + 0

         if call.arg.count > greatest.call.arg.count then
            greatest.call.arg.count = call.arg.count
         end

         if print.code then
            s = "CALL     (" : call.arg.count : " arguments)"
            gosub show.code
         end

         opcode.byte = op.call
         gosub emit

         opcode.byte = call.arg.count
         gosub emit

         * Load result

         n = subr.stack<1,1>    ;* 0322
         gosub emit.var.load

         del subr.stack<1>
         goto intrinsic.end

*** SUBSTITUTE()   3 or 4 arguments, absent arg defaults to @vm
in.subst:
         arg.count = 3
         gosub get.args
         if look.ahead.token = tkn.comma then
            gosub get.token
            gosub expr
         end else
            opcode.string = @vm
            gosub emit.string.load
         end
         goto intrinsic.common

*** TOTAL()  -  Special processing
in.total:
         total.index += 1

         n = SYSCOM.QPROC.BREAK.LEVEL ; gosub emit.ldsys
         opcode.byte = op.jnz
         label.name = '_T':total.index
         gosub emit.jump

         gosub expr

         label.name = '_T':total.index
         gosub set.label
         if print.code then
            s = "TOTAL    " : total.index
            gosub show.code
         end
         opcode.byte = op.total ; gosub emit.simple
         opcode.byte = total.index ; gosub emit
         goto intrinsic.end

in.trans:
         gosub get.token                ;* Read file name
         if token # tkn.string then     ;* It's not a quoted string
            if token # tkn.name then
               err.msg = sysmsg(2985) ;* Filename not found where expected in TRANS()
               goto error
            end

            if look.ahead.token = tkn.name then  ;* Was name a DICT qualifier?
               if token # 'DICT' then
                  err.msg = sysmsg(2986) ;* Syntax error in TRANS() filename
                  goto error
               end

               gosub get.token
               token.string = 'DICT ' : token.string
               u.token.string = upcase(token.string)
            end
         end

         ins token.string before trans.stack<1>

         opcode.string = token.string
         gosub emit.string.load         ;* File name
         if look.ahead.token # tkn.comma then
            err.msg = sysmsg(2959) ;* Comma not found where expected
            goto error
         end

         gosub get.token
         gosub expr                     ;* ID expression

         if look.ahead.token # tkn.comma then
            err.msg = sysmsg(2959) ;* Comma not found where expected
            goto error
         end
         gosub get.token

         gosub get.token

         begin case                     ;* Process field identifier
            case token = tkn.minus
               gosub get.token
               if token # tkn.num then
                  err.msg = sysmsg(2987) ;* Invalid TRANS() field number/name
                  goto error
               end
               n = -token.string
               if n < -1 then
                  err.msg = sysmsg(2987) ;* Invalid TRANS() field number/name
                  goto error
               end
               gosub emit.numeric.load

            case token = tkn.num        ;* Absolute field number
               n = token.string + 0
               if n < -1 then
                  err.msg = sysmsg(2987) ;* Invalid TRANS() field number/name
                  goto error
               end
               gosub emit.numeric.load

            case token = tkn.lbr        ;* Field number expression
               gosub expr
               gosub get.token
               if token # tkn.rbr then
                  err.msg = sysmsg(2963) ;* Right bracket not found where expected
                  goto error
               end

            case token = tkn.at.name         ;* @xxx
               gosub get.token
               if token.string # "RECORD" then     ;* 0286
                  token.string = '@':token.string
                  goto parse.as.dictionary.name
               end
               n = -1
               gosub emit.numeric.load

            case token = tkn.name           ;* Field name
parse.as.dictionary.name:
               * Open the dictionary for the specified file
               s = trans.stack<1>
               if s[1,5] = 'DICT ' then   ;* DICT part
                  open "DICT.DICT" to trans.file.dict else
                     err.msg = sysmsg(2022) ;* DICT.DICT not found
                     goto error
                  end
               end else                   ;* DATA part
                  open "DICT", s to trans.file.dict else
                     err.msg = sysmsg(2023, s) ;* Dictionary for 'xx' not found
                     goto error
                  end
               end

               read trans.dict.rec from trans.file.dict, token.string else
                  read trans.dict.rec from trans.file.dict, upcase(token.string) else
                     err.msg = sysmsg(2024, token.string)  ;* 'xx' not found in dictionary
                     goto error
                  end
               end

               begin case
                  case trans.dict.rec[1,1] = 'D'   
                     n = trans.dict.rec<2>
                     gosub emit.numeric.load

                  case trans.dict.rec[1,1] = 'I'
                     call @icomp(trans.file.dict,    ;* File var of dictionary
                                 trans.dict.rec<2>,  ;* Source code
                                 trans.object,       ;* Returned object code
                                 z,                  ;* Returned format code
                                 z,                  ;* Returned conversion code
                                 z,                  ;* Returned sm flag
                                 z,                  ;* Returned assoc name
                                 z,                  ;* Returned constant flag
                                 depth + 1)          ;* Compilation depth
                     if @system.return.code # 0 then goto error.return

                     opcode.string = trans.object
                     gosub emit.string.load

                  case 1
                     err.msg = sysmsg(2025, token.string)
                     * Dictionary record 'xx' is not of valid type for this use
                     goto error
               end case

               close trans.file.dict

            case 1
               err.msg = sysmsg(2987) ;* Invalid TRANS() field number/name
               goto error
         end case

         if look.ahead.token # tkn.comma then
            err.msg = sysmsg(2959) ;* Comma not found where expected
            goto error
         end
         gosub get.token

         gosub expr                          ;* Code expression

         del trans.stack<1>

         goto intrinsic.common

*** TRIM()   1, 2 or 3 args
in.trim:
         gosub expr                ;* Source item

         if look.ahead.token # tkn.comma then   ;* TRIM(s)
            goto intrinsic.common
         end

         if intrinsic.stack<1> = op.trim then   ;* TRIM -> TRIMX
            intrinsic.stack<1> = op.trimx
         end else                               ;* TRIMS -> TRIMXS
            intrinsic.stack<1> = op.trimxs
         end

         * Process second argument (trim character)
         gosub get.token
         gosub expr

         * Look for optional third argument, defaulting to null string
         if look.ahead.token = tkn.comma then
            gosub get.token
            gosub expr
         end else
            opcode.string = ''
            gosub emit.string.load
         end

         goto intrinsic.common


in.none:
intrinsic.common:
         opcode.byte = intrinsic.stack<1> ;gosub emit.simple

intrinsic.end:
         del intrinsic.stack<1>

         if look.ahead.token # tkn.rbr then
            err.msg = sysmsg(2963) ;* Right bracket not found where expected
            goto error
         end

         gosub get.token      ;* Skip right bracket

      case token = tkn.num or token = tkn.float
         n = token.string + 0   ;* Convert to numeric form
         if unary.minus then
            n = -n
            unary.minus = @false
         end
         gosub emit.numeric.load

      case token = tkn.hexnum
         n = xtd(token.string)
         if unary.minus then
            n = -n
            unary.minus = @false
         end
         gosub emit.numeric.load

      case token = tkn.string
         opcode.string = token.string
         gosub emit.string.load

      case token = tkn.at.name
         gosub emit.at.var.load

      case token = tkn.at
         begin case
            case look.ahead.token = tkn.num  ;* @n expression token
               gosub get.token
               n = token.string + 0

               if (n < 1) or (n >= expr.no) then
                  err.msg = sysmsg(2989) ;* Invalid expression number
                  goto error
               end

               n += expr.var.base - 1
               gosub emit.var.load

            case look.ahead.token = tkn.lbr  ;* @(n) function
               gosub get.token         ;* Skip left bracket
               gosub expr      ;* Load first argument
               if look.ahead.token = tkn.comma then     ;* Two arguments
                  gosub get.token
                  if look.ahead.token = tkn.end then
                     err.msg = sysmsg(2952) ;* Argument missing in @ function
                     goto error
                  end
                  gosub expr  ;* Load second argument
               end
               else                    ;* Single argument - Set second as -1
                  n = -1
                  gosub emit.numeric.load
               end

               opcode.byte = op.at
               gosub emit.simple

               if look.ahead.token # tkn.rbr then
                 err.msg = sysmsg(2963) ;* Right bracket not found where expected
                 goto error
               end

               gosub get.token         ;* Skip close bracket

            case 1                           ;* Treat as @
               if expr.no = 1 then
                  err.msg = sysmsg(2990) ;* @ not valid in first expression
                  goto error
               end

               n = expr.no + expr.var.base - 2
               gosub emit.var.load
         end case

      case token = tkn.lbr
         * Call EXPR recursively to process the content of the brackets

         gosub expr

         * Check that the next token is a close bracket

         gosub get.token
         if token # tkn.rbr then
            err.msg = sysmsg(2954) ;* Mismatched brackets
            goto error
         end

      case token = tkn.plus               ;* Unary plus
         gosub get.token
         goto get.expr.item.again

      case token = tkn.minus              ;* Unary minus
         unary.minus = not(unary.minus)
         gosub get.token
         goto get.expr.item.again

      case token = TKN.NEST
         loop
            n = expr.var.base + expr.no - 1
            gosub emit.var.load

            gosub expr

            opcode.byte = op.stor
            gosub emit.simple

         while look.ahead.token = tkn.semicolon

            gosub get.token                      ;* Skip semicolon

            expr.no += 1
         repeat
         
         if look.ahead.token = tkn.unnest then
            gosub get.token

            n = expr.var.base + expr.no - 1
            gosub emit.var.load

            expr.var.base = nested.itype.stack<1,1>
            expr.no = nested.itype.stack<1,2>
            del nested.itype.stack<1>
         end

      case token = TKN.UNNEST
          err.msg = sysmsg(2991) ;* Internal error: Nesting error in I-type
          goto error

      case 1
         err.msg = sysmsg(2955) ;* Data item or constant not found where expected
         goto error
   end case

   * Check for field extraction

   if look.ahead.token = tkn.lt then
      gosub is.field.ref
      if ifr.index then
         gosub get.token   ;* Skip < token
         gosub emit.field.reference
         opcode.byte = op.extract
         gosub emit.simple
      end
   end

   * Check for substring extraction

   if look.ahead.token = tkn.lsqbr then
      gosub get.token     ;* Skip [ token
      gosub expr          ;* Process first (or only) bound
      if look.ahead.token = tkn.comma then  ;* Two bounds present
         gosub get.token    ;* Skip comma
         gosub expr ;* Get substring length
         if look.ahead.token = tkn.comma then  ;* Three items, group extraction
            gosub get.token  ;* Skip comma
            gosub expr       ;* Get field count
            opcode.byte = op.field
            gosub emit.simple
         end else
            opcode.byte = op.substr
            gosub emit.simple
         end
      end
      else                                ;* Trailing substring extraction
         opcode.byte = op.substre
         gosub emit.simple
      end
      if look.ahead.token # tkn.rsqbr then
         err.msg = sysmsg(2964) ;* Right square bracket not found where expected
         goto error
      end
      gosub get.token        ;* Skip bracket
   end

   if unary.minus then
      opcode.byte = op.neg
      gosub emit.simple
   end

   return

*****************************************************************************
* IS.FIELD.REF  -  Establish the role of a < token
*
* On entry, the < token is in the look-ahead.  Examine subsequent tokens
* to establish whether this is a field reference or not.
*
* It is a field reference if
*    we find a matching > taking into account pairing of other < tokens
*    and round brackets found on the way
* unless
*    the > token is followed by
*      a name except for reserved tokens (THEN, ELSE, SETTING, BY, GO, GOTO,
*      GOSUB, BEFORE)
*      a name.lbr
*      a number
*      a string
*    or the enclosed expression includes the THEN, AND or OR keywords
*
* If it is a field reference, the > token is replaced by TKN.END.FIELD and
* its position is returned in IFR.INDEX. Otherwise, IFR.INDEX is set to zero.
*
is.field.ref:
   ifr.first = token.index + 1  ;* Point after < token
   i = 0                        ;* Current bracket depth
   j = 1                        ;* Current field depth
   ifr.index = 0

   n = ifr.first
   loop
      k = tokens(n)

      begin case
         case k = tkn.end            ;* End of source line
            goto exit.is.field.ref

         case k = tkn.lt
            if i = 0 then j += 1

         case k = tkn.gt
            if i = 0 then j -= 1

         case k = tkn.ge or k = tkn.nex
            if i = 0 then j -= 1

         case k = tkn.lbr
            i += 1

         case k = tkn.rbr
            i -= 1
            if i < 0 then goto exit.is.field.ref

         case k = TKN.AND
            if i = 0 then goto exit.is.field.ref  ;* 0342

         case k = TKN.OR
            if i = 0 then goto exit.is.field.ref  ;* 0342

         case u.token.strings(n) = 'THEN'         ;* 0143
            if i = 0 then goto exit.is.field.ref  ;* 0342
      end case

   until (i = 0) and (j = 0)

      n += 1
   repeat
   
   * We have found a matching > token. Now look to see what follows it.

   begin case
      case k = tkn.ge
      case k = tkn.nex
      case 1                   ; k = tokens(n + 1)
   end case

   i = n - ifr.first   ;* Number of tokens between < and >
   if i # 1 then
      begin case
         case k = tkn.name
            locate u.token.strings(n + 1) in reserved.names<1> setting z
            else goto exit.is.field.ref

         case k = tkn.name.lbr
            goto exit.is.field.ref

         case k = tkn.num
            goto exit.is.field.ref

         case k = tkn.hexnum
            goto exit.is.field.ref

         case k = tkn.float
            goto exit.is.field.ref

         case k = tkn.string
            goto exit.is.field.ref
      end case
   end

   ifr.index = n

   begin case
      case tokens(n) = tkn.ge
         for k = num.tokens to n step -1
            tokens(k+1) = tokens(k)
            token.strings(k+1) = token.strings(k)
            u.token.strings(k+1) = u.token.strings(k)
         next k
         tokens(n+1) = tkn.eq
         token.strings(n+1) = '='
         u.token.strings(n+1) = '='
         num.tokens += 1

      case tokens(n) = tkn.nex           ;* ><
         if token.strings(n+1) = '=' then   ;* 0113: a<b><=c  ->  a<b> <= c
            tokens(n+1) = tkn.le
            token.strings(n+1) = '<='
            u.token.strings(n+1) = '<='
         end else                           ;* a<b><c (etc)
            for k = num.tokens to n step -1
               tokens(k+1) = tokens(k)
               token.strings(k+1) = token.strings(k)
               u.token.strings(k+1) = u.token.strings(k)
            next k
            tokens(n+1) = tkn.lt
            token.strings(n+1) = '<'
            u.token.strings(n+1) = '<'
            num.tokens += 1
         end
   end case

   tokens(n) = tkn.end.field

exit.is.field.ref:
   return

*****************************************************************************
* EMIT.FIELD.REFERENCE  -  Process <f,v,s> construct
* On entry, we are positioned after the < token
* On exit, we will be positioned after the > token

emit.field.reference:
   * Get field position
   gosub expr

   * Get value position
   if look.ahead.token = tkn.comma then
      gosub get.token
      gosub expr
   end
   else
      * Emit a zero value position reference
      n = 0
      gosub emit.numeric.load
   end

   * Get subvalue position
   if look.ahead.token = tkn.comma then
      gosub get.token
      gosub expr
   end
   else
      * Emit a zero subvalue position reference
      n = 0
      gosub emit.numeric.load
   end

   if look.ahead.token # tkn.end.field then
      err.msg = sysmsg(2961) ;* Incorrectly formed field reference
      goto error
   end
   else
      gosub get.token        ;* Skip > token
   end

   return

*****************************************************************************
* GET.ARGS  -  Emit multiple comma separated expressions
* ARG.COUNT holds required number of expressions

get.args:
   ins arg.count before arg.count.stack<1>

   loop
      gosub expr

      arg.count = arg.count.stack<1> - 1
   while arg.count
      arg.count.stack<1> = arg.count

      if look.ahead.token # tkn.comma then
         err.msg = sysmsg(2959) ;* Comma not found where expected
         goto error
      end

      gosub get.token
   repeat

exit.get.args:

   del arg.count.stack<1>

   return

**********************************************************************
* DISPLAY.CODE  -  Debug function to display the code

display.code:
   pcx = 0
   loop
   while pcx < pc
      print fmt(oconv(pcx, "MX"), "6'0'R"):":":
      k = 1                
      loop
      while k <= 16
      while pcx < pc
         n = seq(code.image[pcx+1,1])
         print "  ": fmt(oconv(n, "MX"), "2'0'R"):
         pcx += 1
         k += 1
      repeat
      print
   repeat

   return

*****************************************************************************
* ERROR  -  Report error

error:
   @system.return.code = -ER$ICOMP
   print '*** ' : err.msg

error.return:
   return to error.return

* ======================================================================

expand.token.tables:
   n = idiv(max.tokens, 2)
   dim operator.stack(n)
   dim priority.stack(n)
   dim tokens(max.tokens)
   dim token.strings(max.tokens)
   dim u.token.strings(max.tokens)
   for n = num.tokens + 1 to max.tokens     ;* 0320
      tokens(n) = ''
      token.strings(n) = ''
      u.token.strings(n) = ''
   next n
   return
end

* END-CODE
