; copyright 1987-2012 robert b. k. dewar and mark emmer.

; copyright 2012-2015 david shields
;
; this file is part of macro spitbol.
;
;     macro spitbol 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 of the license, or
;     (at your option) any later version.
;
;     macro spitbol 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 macro spitbol.  if not, see <http://www.gnu.org/licenses/>.

        BITS 64
        DEFAULT REL

        %define m_char  byte    ; reference to byte in memory
        %define d_char  db      ; define value of byte

        %define m_word  qword
        %define d_word  dq

        %define m_real  qword   ; reference to floating point value in memory
        %define d_real  dq      ; define value for floating point
        %define m_reall oword   ; 128-bit
; N INCLUDE
        %define xl      rsi
        %define xr      rdi
        %define xt      rsi
        %define xs      rsp

        %define w0      rax

        %define wa      rcx
        %define wa_l    cl

        %define wb      rbx
        %define wb_l    bl

        %define wc      rdx
        %define wc_l    dl

        %define ia      r12
        %define ra      xmm12

;       %define cfp_b   8

        %define log_cfp_b 3
        %define log_cfp_c 3
        %define d_real  dq
        %define cfp_c_val       8
        %define log_cfp_c 3
        %define cfp_m_  9223372036854775807
;       %define cfp_n_  64

        %define lods_w  lodsq
        %define lods_b  lodsb
        %define movs_b  movsb
        %define movs_w  movsq
        %define stos_b  stosb
        %define stos_w  stosq
        %define cmps_b  cmpsb

        %define cdq     cqo     ; sign extend (64 bits)

;       flags
        %define flag_of 0x80
        %define flag_cf 0x01
        %define flag_ca 0x40
; copyright 1987-2012 robert b. k. dewar and mark emmer.
; copyright 2012-2015 david shields
;
; this file is part of macro spitbol.
;
;     macro spitbol 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 of the license, or
;     (at your option) any later version.
;
;     macro spitbol 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 macro spitbol.  if not, see <http://www.gnu.org/licenses/>.
;
    section .text

    extern  osisp
    extern  compsp
    extern  save_regs
    extern  restore_regs
    extern  _rc_
    extern  reg_fl
    extern  reg_ra
    extern  inf
    extern  neg1f
    extern  zeron
    extern  lowspminx
    extern  mxcsr_set

    global  mxint

;%define zz_trace
%ifdef zz_trace
    extern  zz
    extern  zzz
    extern  zz_cp
    extern  zz_xl
    extern  zz_xr
    extern  zz_xs
    extern  zz_wa
    extern  zz_wb
    extern  zz_wc
    extern  zz_w0
    extern  zz_zz
    extern  zz_id
    extern  zz_de
    extern  zz_0
    extern  zz_1
    extern  zz_2
    extern  zz_3
    extern  zz_4
    extern  zz_arg
    extern  zz_num
%endif
    global  start


;
;
;   table to recover type word from type ordinal
;

    extern  _rc_
    global  typet
    section .data

    d_word  b_art   ; arblk type word - 0
    d_word  b_cdc   ; cdblk type word - 1
    d_word  b_exl   ; exblk type word - 2
    d_word  b_icl   ; icblk type word - 3
    d_word  b_nml   ; nmblk type word - 4
    d_word  p_aba   ; p0blk type word - 5
    d_word  p_alt   ; p1blk type word - 6
    d_word  p_any   ; p2blk type word - 7
; next needed only if support real arithmetic cnra
    d_word  b_rcl   ; rcblk type word - 8
    d_word  b_scl   ; scblk type word - 9
    d_word  b_sel   ; seblk type word - 10
    d_word  b_tbt   ; tbblk type word - 11
    d_word  b_vct   ; vcblk type word - 12
    d_word  b_xnt   ; xnblk type word - 13
    d_word  b_xrt   ; xrblk type word - 14
    d_word  b_bct   ; bcblk type word - 15
    d_word  b_pdt   ; pdblk type word - 16
    d_word  b_trt   ; trblk type word - 17
    d_word  b_bft   ; bfblk type word   18
    d_word  b_cct   ; ccblk type word - 19
    d_word  b_cmt   ; cmblk type word - 20
    d_word  b_ctt   ; ctblk type word - 21
    d_word  b_dfc   ; dfblk type word - 22
    d_word  b_efc   ; efblk type word - 23
    d_word  b_evt   ; evblk type word - 24
    d_word  b_ffc   ; ffblk type word - 25
    d_word  b_kvt   ; kvblk type word - 26
    d_word  b_pfc   ; pfblk type word - 27
    d_word  b_tet   ; teblk type word - 28
;
;   table of minimal entry points that can be dded from c
;   via the minimal function (see inter.asm).
;
;   note that the order of entries in this table must correspond
;   to the order of entries in the call enumeration in osint.h
;   and osint.inc.
;
    global calltab
calltab:
    d_word  relaj
    d_word  relcr
    d_word  reloc
    d_word  alloc
    d_word  alocs
    d_word  alost
    d_word  blkln
    d_word  insta
    d_word  rstrt
    d_word  start
    d_word  filnm
    d_word  dtype
;   d_word  enevs ;  engine words
;   d_word  engts ;   not used

    global  gbcnt
    global  headv
    global  mxlen
    global  stage
    global  timsx
    global  dnamb
    global  dnamp
    global  state
    global  b_efc
    global  b_icl
    global  b_scl
    global  b_vct
    global  b_xnt
    global  b_xrt
    global  stbas
    global  statb
    global  polct
    global  typet
    global  lowspmin
    global  flprt
    global  flptr
    global  gtcef
    global  hshtb
    global  pmhbs
    global  r_fcb
    global  c_aaa
    global  c_yyy
    global  g_aaa
    global  w_yyy
    global  s_aaa
    global  s_yyy
    global  r_cod
    global  kvstn
    global  kvdmp
    global  kvftr
    global  kvcom
    global  kvpfl
    global  cswfl
    global  stmcs
    global  stmct
    global  b_rcl
    global  end_min_data


    extern ldr_
    extern str_
    extern itr_
    extern adr_
    extern sbr_
    extern mlr_
    extern dvr_
    extern ngr_
    extern atn_
    extern chp_
    extern cos_
    extern etx_
    extern lnf_
    extern sin_
    extern sqr_
    extern tan_
    extern cpr_
    extern ovr_

    %macro  zzz 3
    section .data
%%desc: db  %3,0
    section .text
    mov m_word [zz_id],%1
    mov m_word [zz_zz],%2
    mov m_word [zz_de],%%desc
    call    zzz
    %endmacro

;   integer arithmetic instructions

;   code pointer instructions (cp maintained in location reg_cp)

    extern  reg_cp
    section .data
    align   8
mxcsr       dd      0       ; used to test mxcsr exceptions
    section .text
; divide ia by r10 result in ia
; clobbers wc:w0
; set overflow
do_dvi:
    test    r10,r10         ; check for divide by zero
    jz      do_dvi_over     ; set overflow
    mov     w0,ia
    cdq
    idiv    r10
    mov     ia,w0
    xor     w0,w0
    ret
do_dvi_over:
    xor     w0,w0
    cmp     al,-128
    ret

; remained of ia by r10 result in ia
; clobbers wc:w0
; set overflow
do_rmi:
    test    r10,r10         ; check for divide by zero
    jz      do_rmi_over     ; set overflow
    mov     w0,ia
    cdq
    idiv    r10
    mov     ia,wc
    xor     w0,w0
    ret
do_rmi_over:
    xor     w0,w0
    cmp     al,-128
    ret

; Check ra for inf or fpe exception
; clobbers xmm1
; sets:
;  unordered  ZF PF CF all 1  (either is NAN)
;  GT         ZF PF CF all 0
;  LT         ZF PF zero CF 1
;  EQUAL      ZF 1 PF CF 0
;
do_chk_real_inf:
    stmxcsr [mxcsr]                 ; get SSE status word
    test    m_word [mxcsr], 0x000c  ; Overflow | divide by zero set ZF=1
    jnz     do_chk_real_inf_except  ;
    test    m_word [mxcsr], 0x0013  ; All others set as zero and ZF=0
    jnz     do_chk_real_inf_zero    ; Set value as zero and return "okay"
    movapd  xmm1,ra
    andpd   xmm1,m_reall [neg1f]    ; Test for +/- NAN
    ucomisd xmm1,m_real [inf]
    je      do_chk_real_inf_except
    cmp     al,al
    ret
do_chk_real_inf_zero:               ; Some exception, return a zero ZF=0
    pxor    ra,ra
    cmp     al,al
    ret
do_chk_real_inf_except:             ; Overflow ZF=1
    xor     al,al
    cmp     al,-128
    ret
                                                ; start of procedures section} sec   
        segment .text                           ; 
        global sec01                            ; 
sec01:                                          ; 
        extern sysax                            ; define external entry point} exp 0  
        extern sysbs                            ; define external entry point} exp 3  
        extern sysbx                            ; define external entry point} exp 0  
        extern sysdc                            ; define external entry point} exp 0  
        extern sysdm                            ; define external entry point} exp 0  
        extern sysdt                            ; define external entry point} exp 0  
        extern sysea                            ; define external entry point} exp 1  
        extern sysef                            ; define external entry point} exp 3  
        extern sysej                            ; define external entry point} exp 0  
        extern sysem                            ; define external entry point} exp 0  
        extern sysen                            ; define external entry point} exp 3  
        extern sysep                            ; define external entry point} exp 0  
        extern sysex                            ; define external entry point} exp 3  
        extern sysfc                            ; define external entry point} exp 2  
        extern sysgc                            ; define external entry point} exp 0  
        extern syshs                            ; define external entry point} exp 8  
        extern sysid                            ; define external entry point} exp 0  
        extern sysif                            ; define external entry point} exp 1  
        extern sysil                            ; define external entry point} exp 0  
        extern sysin                            ; define external entry point} exp 3  
        extern sysio                            ; define external entry point} exp 2  
        extern sysld                            ; define external entry point} exp 3  
        extern sysmm                            ; define external entry point} exp 0  
        extern sysmx                            ; define external entry point} exp 0  
        extern sysou                            ; define external entry point} exp 2  
        extern syspi                            ; define external entry point} exp 1  
        extern syspl                            ; define external entry point} exp 3  
        extern syspp                            ; define external entry point} exp 0  
        extern syspr                            ; define external entry point} exp 1  
        extern sysrd                            ; define external entry point} exp 1  
        extern sysri                            ; define external entry point} exp 1  
        extern sysrw                            ; define external entry point} exp 3  
        extern systm                            ; define external entry point} exp 0  
        extern systt                            ; define external entry point} exp 0  
        extern sysul                            ; define external entry point} exp 0  
        extern sysxi                            ; define external entry point} exp 2  
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; } inr   
                                                ; start of definitions section} sec   
        segment .data                           ; 
        global sec02                            ; 
sec02:                                          ; 
cfp_a   equ  256                                ; number of characters in alphabet} equ 256  
cfp_b   equ  8                                  ; bytes/word addressing factor} equ 8  
cfp_c   equ  8                                  ; number of characters per word} equ 8  
cfp_f   equ  16                                 ; offset in bytes to chars in} equ 16  
cfp_i   equ  1                                  ; number of words in integer constant} equ 1  
cfp_m   equ  9223372036854775807                ; max positive integer in one word} equ 9223372036854775807  
cfp_n   equ  64                                 ; number of bits in one word} equ 64  
cfp_r   equ  1                                  ; number of words in real constant} equ 1  
cfp_s   equ  15                                 ; number of sig digs for real output} equ 15  
cfp_x   equ  3                                  ; max digits in real exponent} equ 3  
mxdgs   equ  cfp_s+cfp_x                        ; max digits in real number} equ cfp_s+cfp_x  
nstmx   equ  mxdgs+5                            ; max space for real} equ mxdgs+5  
cfp_u   equ  128                                ; realistic upper bound on alphabet} equ 128  
e_srs   equ  100                                ; 30 words} equ 100  
e_sts   equ  1000                               ; 500 words} equ 1000  
e_cbs   equ  500                                ; 500 words} equ 500  
e_hnb   equ  257                                ; 127 bucket headers} equ 257  
e_hnw   equ  3                                  ; 6 words} equ 3  
e_fsp   equ  15                                 ; 15 percent} equ 15  
e_sed   equ  25                                 ; 25 percent} equ 25  
ch_la   equ  97                                 ; letter a} equ 97  
ch_lb   equ  98                                 ; letter b} equ 98  
ch_lc   equ  99                                 ; letter c} equ 99  
ch_ld   equ  100                                ; letter d} equ 100  
ch_le   equ  101                                ; letter e} equ 101  
ch_lf   equ  102                                ; letter f} equ 102  
ch_lg   equ  103                                ; letter g} equ 103  
ch_lh   equ  104                                ; letter h} equ 104  
ch_li   equ  105                                ; letter i} equ 105  
ch_lj   equ  106                                ; letter j} equ 106  
ch_lk   equ  107                                ; letter k} equ 107  
ch_ll   equ  108                                ; letter l} equ 108  
ch_lm   equ  109                                ; letter m} equ 109  
ch_ln   equ  110                                ; letter n} equ 110  
ch_lo   equ  111                                ; letter o} equ 111  
ch_lp   equ  112                                ; letter p} equ 112  
ch_lq   equ  113                                ; letter q} equ 113  
ch_lr   equ  114                                ; letter r} equ 114  
ch_ls   equ  115                                ; letter s} equ 115  
ch_lt   equ  116                                ; letter t} equ 116  
ch_lu   equ  117                                ; letter u} equ 117  
ch_lv   equ  118                                ; letter v} equ 118  
ch_lw   equ  119                                ; letter w} equ 119  
ch_lx   equ  120                                ; letter x} equ 120  
ch_ly   equ  121                                ; letter y} equ 121  
ch_l_   equ  122                                ; letter z} equ 122  
ch_d0   equ  48                                 ; digit 0} equ 48  
ch_d1   equ  49                                 ; digit 1} equ 49  
ch_d2   equ  50                                 ; digit 2} equ 50  
ch_d3   equ  51                                 ; digit 3} equ 51  
ch_d4   equ  52                                 ; digit 4} equ 52  
ch_d5   equ  53                                 ; digit 5} equ 53  
ch_d6   equ  54                                 ; digit 6} equ 54  
ch_d7   equ  55                                 ; digit 7} equ 55  
ch_d8   equ  56                                 ; digit 8} equ 56  
ch_d9   equ  57                                 ; digit 9} equ 57  
ch_am   equ  38                                 ; keyword operator (ampersand)} equ 38  
ch_as   equ  42                                 ; multiplication symbol (asterisk)} equ 42  
ch_at   equ  64                                 ; cursor position operator (at)} equ 64  
ch_bb   equ  60                                 ; left array bracket (less than)} equ 60  
ch_bl   equ  32                                 ; blank} equ 32  
ch_br   equ  124                                ; alternation operator (vertical bar)} equ 124  
ch_cl   equ  58                                 ; goto symbol (colon)} equ 58  
ch_cm   equ  44                                 ; comma} equ 44  
ch_dl   equ  36                                 ; indirection operator (dollar)} equ 36  
ch_dt   equ  46                                 ; name operator (dot)} equ 46  
ch_dq   equ  34                                 ; double quote} equ 34  
ch_eq   equ  61                                 ; equal sign} equ 61  
ch_ex   equ  33                                 ; exponentiation operator (exclm)} equ 33  
ch_mn   equ  45                                 ; minus sign / hyphen} equ 45  
ch_nm   equ  35                                 ; number sign} equ 35  
ch_nt   equ  126                                ; negation operator (not)} equ 126  
ch_pc   equ  37                                 ; percent} equ 37  
ch_pl   equ  43                                 ; plus sign} equ 43  
ch_pp   equ  40                                 ; left parenthesis} equ 40  
ch_rb   equ  62                                 ; right array bracket (grtr than)} equ 62  
ch_rp   equ  41                                 ; right parenthesis} equ 41  
ch_qu   equ  63                                 ; interrogation operator (question)} equ 63  
ch_sl   equ  47                                 ; slash} equ 47  
ch_sm   equ  59                                 ; semicolon} equ 59  
ch_sq   equ  39                                 ; single quote} equ 39  
ch_u_   equ  95                                 ; special identifier char (underline)} equ 95  
ch_ob   equ  91                                 ; opening bracket} equ 91  
ch_cb   equ  93                                 ; closing bracket} equ 93  
ch_ht   equ  9                                  ; horizontal tab} equ 9  
ch_ey   equ  94                                 ; up arrow} equ 94  
ch_ua   equ  65                                 ; shifted a} equ 65  
ch_ub   equ  66                                 ; shifted b} equ 66  
ch_uc   equ  67                                 ; shifted c} equ 67  
ch_ud   equ  68                                 ; shifted d} equ 68  
ch_ue   equ  69                                 ; shifted e} equ 69  
ch_uf   equ  70                                 ; shifted f} equ 70  
ch_ug   equ  71                                 ; shifted g} equ 71  
ch_uh   equ  72                                 ; shifted h} equ 72  
ch_ui   equ  73                                 ; shifted i} equ 73  
ch_uj   equ  74                                 ; shifted j} equ 74  
ch_uk   equ  75                                 ; shifted k} equ 75  
ch_ul   equ  76                                 ; shifted l} equ 76  
ch_um   equ  77                                 ; shifted m} equ 77  
ch_un   equ  78                                 ; shifted n} equ 78  
ch_uo   equ  79                                 ; shifted o} equ 79  
ch_up   equ  80                                 ; shifted p} equ 80  
ch_uq   equ  81                                 ; shifted q} equ 81  
ch_ur   equ  82                                 ; shifted r} equ 82  
ch_us   equ  83                                 ; shifted s} equ 83  
ch_ut   equ  84                                 ; shifted t} equ 84  
ch_uu   equ  85                                 ; shifted u} equ 85  
ch_uv   equ  86                                 ; shifted v} equ 86  
ch_uw   equ  87                                 ; shifted w} equ 87  
ch_ux   equ  88                                 ; shifted x} equ 88  
ch_uy   equ  89                                 ; shifted y} equ 89  
ch_uz   equ  90                                 ; shifted z} equ 90  
iodel   equ  32                                 ; } equ 32  
offs1   equ  1                                  ; } equ 1  
offs2   equ  2                                  ; } equ 2  
offs3   equ  3                                  ; } equ 3  
bl_ar   equ  0                                  ; arblk     array} equ 0  
bl_cd   equ  bl_ar+1                            ; cdblk     code} equ bl_ar+1  
bl_ex   equ  bl_cd+1                            ; exblk     expression} equ bl_cd+1  
bl_ic   equ  bl_ex+1                            ; icblk     integer} equ bl_ex+1  
bl_nm   equ  bl_ic+1                            ; nmblk     name} equ bl_ic+1  
bl_p0   equ  bl_nm+1                            ; p0blk     pattern} equ bl_nm+1  
bl_p1   equ  bl_p0+1                            ; p1blk     pattern} equ bl_p0+1  
bl_p2   equ  bl_p1+1                            ; p2blk     pattern} equ bl_p1+1  
bl_rc   equ  bl_p2+1                            ; rcblk     real} equ bl_p2+1  
bl_sc   equ  bl_rc+1                            ; scblk     string} equ bl_rc+1  
bl_se   equ  bl_sc+1                            ; seblk     expression} equ bl_sc+1  
bl_tb   equ  bl_se+1                            ; tbblk     table} equ bl_se+1  
bl_vc   equ  bl_tb+1                            ; vcblk     array} equ bl_tb+1  
bl_xn   equ  bl_vc+1                            ; xnblk     external} equ bl_vc+1  
bl_xr   equ  bl_xn+1                            ; xrblk     external} equ bl_xn+1  
bl_bc   equ  bl_xr+1                            ; bcblk     buffer} equ bl_xr+1  
bl_pd   equ  bl_bc+1                            ; pdblk     program defined datatype} equ bl_bc+1  
bl__d   equ  bl_pd+1                            ; number of block codes for data} equ bl_pd+1  
bl_tr   equ  bl_pd+1                            ; trblk} equ bl_pd+1  
bl_bf   equ  bl_tr+1                            ; bfblk} equ bl_tr+1  
bl_cc   equ  bl_bf+1                            ; ccblk} equ bl_bf+1  
bl_cm   equ  bl_cc+1                            ; cmblk} equ bl_cc+1  
bl_ct   equ  bl_cm+1                            ; ctblk} equ bl_cm+1  
bl_df   equ  bl_ct+1                            ; dfblk} equ bl_ct+1  
bl_ef   equ  bl_df+1                            ; efblk} equ bl_df+1  
bl_ev   equ  bl_ef+1                            ; evblk} equ bl_ef+1  
bl_ff   equ  bl_ev+1                            ; ffblk} equ bl_ev+1  
bl_kv   equ  bl_ff+1                            ; kvblk} equ bl_ff+1  
bl_pf   equ  bl_kv+1                            ; pfblk} equ bl_kv+1  
bl_te   equ  bl_pf+1                            ; teblk} equ bl_pf+1  
bl__i   equ  0                                  ; default identification code} equ 0  
bl__t   equ  bl_tr+1                            ; code for data or trace block} equ bl_tr+1  
bl___   equ  bl_te+1                            ; number of block codes} equ bl_te+1  
fcode   equ  0                                  ; pointer to code for function} equ 0  
fargs   equ  1                                  ; number of arguments} equ 1  
idval   equ  1                                  ; id value field} equ 1  
artyp   equ  0                                  ; pointer to dummy routine b_art} equ 0  
arlen   equ  idval+1                            ; length of arblk in bytes} equ idval+1  
arofs   equ  arlen+1                            ; offset in arblk to arpro field} equ arlen+1  
arndm   equ  arofs+1                            ; number of dimensions} equ arofs+1  
arlbd   equ  arndm+1                            ; low bound (first subscript)} equ arndm+1  
ardim   equ  arlbd+cfp_i                        ; dimension (first subscript)} equ arlbd+cfp_i  
arlb2   equ  ardim+cfp_i                        ; low bound (second subscript)} equ ardim+cfp_i  
ardm2   equ  arlb2+cfp_i                        ; dimension (second subscript)} equ arlb2+cfp_i  
arpro   equ  ardim+cfp_i                        ; array prototype (one dimension)} equ ardim+cfp_i  
arvls   equ  arpro+1                            ; start of values (one dimension)} equ arpro+1  
arpr2   equ  ardm2+cfp_i                        ; array prototype (two dimensions)} equ ardm2+cfp_i  
arvl2   equ  arpr2+1                            ; start of values (two dimensions)} equ arpr2+1  
arsi_   equ  arlbd                              ; number of standard fields in block} equ arlbd  
ardms   equ  arlb2-arlbd                        ; size of info for one set of bounds} equ arlb2-arlbd  
cctyp   equ  0                                  ; pointer to dummy routine b_cct} equ 0  
cclen   equ  cctyp+1                            ; length of ccblk in bytes} equ cctyp+1  
ccsln   equ  cclen+1                            ; source line number} equ cclen+1  
ccuse   equ  ccsln+1                            ; offset past last used word (bytes)} equ ccsln+1  
cccod   equ  ccuse+1                            ; start of generated code in block} equ ccuse+1  
cdjmp   equ  0                                  ; ptr to routine to execute statement} equ 0  
cdstm   equ  cdjmp+1                            ; statement number} equ cdjmp+1  
cdsln   equ  cdstm+1                            ; source line number} equ cdstm+1  
cdlen   equ  cdsln+1                            ; length of cdblk in bytes} equ cdsln+1  
cdfal   equ  cdlen+1                            ; failure exit (see below)} equ cdlen+1  
cdcod   equ  cdfal+1                            ; executable pseudo-code} equ cdfal+1  
cdsi_   equ  cdcod                              ; number of standard fields in cdblk} equ cdcod  
cmidn   equ  0                                  ; pointer to dummy routine b_cmt} equ 0  
cmlen   equ  cmidn+1                            ; length of cmblk in bytes} equ cmidn+1  
cmtyp   equ  cmlen+1                            ; type (c_xxx, see list below)} equ cmlen+1  
cmopn   equ  cmtyp+1                            ; operand pointer (see below)} equ cmtyp+1  
cmvls   equ  cmopn+1                            ; operand value pointers (see below)} equ cmopn+1  
cmrop   equ  cmvls                              ; right (only) operator operand} equ cmvls  
cmlop   equ  cmvls+1                            ; left operator operand} equ cmvls+1  
cmsi_   equ  cmvls                              ; number of standard fields in cmblk} equ cmvls  
cmus_   equ  cmsi_+1                            ; size of unary operator cmblk} equ cmsi_+1  
cmbs_   equ  cmsi_+2                            ; size of binary operator cmblk} equ cmsi_+2  
cmar1   equ  cmvls+1                            ; array subscript pointers} equ cmvls+1  
c_arr   equ  0                                  ; array reference} equ 0  
c_fnc   equ  c_arr+1                            ; function call} equ c_arr+1  
c_def   equ  c_fnc+1                            ; deferred expression (unary *)} equ c_fnc+1  
c_ind   equ  c_def+1                            ; indirection (unary _)} equ c_def+1  
c_key   equ  c_ind+1                            ; keyword reference (unary ampersand)} equ c_ind+1  
c_ubo   equ  c_key+1                            ; undefined binary operator} equ c_key+1  
c_uuo   equ  c_ubo+1                            ; undefined unary operator} equ c_ubo+1  
c_uo_   equ  c_uuo+1                            ; test value (=c_uuo+1=c_ubo+2)} equ c_uuo+1  
c__nm   equ  c_uuo+1                            ; number of codes for name operands} equ c_uuo+1  
c_bvl   equ  c_uuo+1                            ; binary op with value operands} equ c_uuo+1  
c_uvl   equ  c_bvl+1                            ; unary operator with value operand} equ c_bvl+1  
c_alt   equ  c_uvl+1                            ; alternation (binary bar)} equ c_uvl+1  
c_cnc   equ  c_alt+1                            ; concatenation} equ c_alt+1  
c_cnp   equ  c_cnc+1                            ; concatenation, not pattern match} equ c_cnc+1  
c_unm   equ  c_cnp+1                            ; unary op with name operand} equ c_cnp+1  
c_bvn   equ  c_unm+1                            ; binary op (operands by value, name)} equ c_unm+1  
c_ass   equ  c_bvn+1                            ; assignment} equ c_bvn+1  
c_int   equ  c_ass+1                            ; interrogation} equ c_ass+1  
c_neg   equ  c_int+1                            ; negation (unary not)} equ c_int+1  
c_sel   equ  c_neg+1                            ; selection} equ c_neg+1  
c_pmt   equ  c_sel+1                            ; pattern match} equ c_sel+1  
c_pr_   equ  c_bvn                              ; last preevaluable code} equ c_bvn  
c__nv   equ  c_pmt+1                            ; number of different cmblk types} equ c_pmt+1  
cttyp   equ  0                                  ; pointer to dummy routine b_ctt} equ 0  
ctchs   equ  cttyp+1                            ; start of character table words} equ cttyp+1  
ctsi_   equ  ctchs+cfp_a                        ; number of words in ctblk} equ ctchs+cfp_a  
dflen   equ  fargs+1                            ; length of dfblk in bytes} equ fargs+1  
dfpdl   equ  dflen+1                            ; length of corresponding pdblk} equ dflen+1  
dfnam   equ  dfpdl+1                            ; pointer to scblk for datatype name} equ dfpdl+1  
dffld   equ  dfnam+1                            ; start of vrblk ptrs for field names} equ dfnam+1  
dfflb   equ  dffld-1                            ; offset behind dffld for field func} equ dffld-1  
dfsi_   equ  dffld                              ; number of standard fields in dfblk} equ dffld  
dvopn   equ  0                                  ; entry address (ptr to o_xxx)} equ 0  
dvtyp   equ  dvopn+1                            ; type code (c_xxx, see cmblk)} equ dvopn+1  
dvlpr   equ  dvtyp+1                            ; left precedence (llxxx, see below)} equ dvtyp+1  
dvrpr   equ  dvlpr+1                            ; right precedence (rrxxx, see below)} equ dvlpr+1  
dvus_   equ  dvlpr+1                            ; size of unary operator dv} equ dvlpr+1  
dvbs_   equ  dvrpr+1                            ; size of binary operator dv} equ dvrpr+1  
dvubs   equ  dvus_+dvbs_                        ; size of unop + binop (see scane)} equ dvus_+dvbs_  
rrass   equ  10                                 ; right     equal} equ 10  
llass   equ  00                                 ; left      equal} equ 00  
rrpmt   equ  20                                 ; right     question mark} equ 20  
llpmt   equ  30                                 ; left      question mark} equ 30  
rramp   equ  40                                 ; right     ampersand} equ 40  
llamp   equ  50                                 ; left      ampersand} equ 50  
rralt   equ  70                                 ; right     vertical bar} equ 70  
llalt   equ  60                                 ; left      vertical bar} equ 60  
rrcnc   equ  90                                 ; right     blank} equ 90  
llcnc   equ  80                                 ; left      blank} equ 80  
rrats   equ  110                                ; right     at} equ 110  
llats   equ  100                                ; left      at} equ 100  
rrplm   equ  120                                ; right     plus, minus} equ 120  
llplm   equ  130                                ; left      plus, minus} equ 130  
rrnum   equ  140                                ; right     number} equ 140  
llnum   equ  150                                ; left      number} equ 150  
rrdvd   equ  160                                ; right     slash} equ 160  
lldvd   equ  170                                ; left      slash} equ 170  
rrmlt   equ  180                                ; right     asterisk} equ 180  
llmlt   equ  190                                ; left      asterisk} equ 190  
rrpct   equ  200                                ; right     percent} equ 200  
llpct   equ  210                                ; left      percent} equ 210  
rrexp   equ  230                                ; right     exclamation} equ 230  
llexp   equ  220                                ; left      exclamation} equ 220  
rrdld   equ  240                                ; right     dollar, dot} equ 240  
lldld   equ  250                                ; left      dollar, dot} equ 250  
rrnot   equ  270                                ; right     not} equ 270  
llnot   equ  260                                ; left      not} equ 260  
lluno   equ  999                                ; left      all unary operators} equ 999  
eflen   equ  fargs+1                            ; length of efblk in bytes} equ fargs+1  
efuse   equ  eflen+1                            ; use count (for opsyn)} equ eflen+1  
efcod   equ  efuse+1                            ; ptr to code (from sysld)} equ efuse+1  
efvar   equ  efcod+1                            ; ptr to associated vrblk} equ efcod+1  
efrsl   equ  efvar+1                            ; result type (see below)} equ efvar+1  
eftar   equ  efrsl+1                            ; argument types (see below)} equ efrsl+1  
efsi_   equ  eftar                              ; number of standard fields in efblk} equ eftar  
evtyp   equ  0                                  ; pointer to dummy routine b_evt} equ 0  
evexp   equ  evtyp+1                            ; pointer to exblk for expression} equ evtyp+1  
evvar   equ  evexp+1                            ; pointer to trbev dummy trblk} equ evexp+1  
evsi_   equ  evvar+1                            ; size of evblk} equ evvar+1  
extyp   equ  0                                  ; ptr to routine b_exl to load expr} equ 0  
exstm   equ  cdstm                              ; stores stmnt no. during evaluation} equ cdstm  
exsln   equ  exstm+1                            ; stores line no. during evaluation} equ exstm+1  
exlen   equ  exsln+1                            ; length of exblk in bytes} equ exsln+1  
exflc   equ  exlen+1                            ; failure code (=o_fex)} equ exlen+1  
excod   equ  exflc+1                            ; pseudo-code for expression} equ exflc+1  
exsi_   equ  excod                              ; number of standard fields in exblk} equ excod  
ffdfp   equ  fargs+1                            ; pointer to associated dfblk} equ fargs+1  
ffnxt   equ  ffdfp+1                            ; ptr to next ffblk on chain or zero} equ ffdfp+1  
ffofs   equ  ffnxt+1                            ; offset (bytes) to field in pdblk} equ ffnxt+1  
ffsi_   equ  ffofs+1                            ; size of ffblk in words} equ ffofs+1  
icget   equ  0                                  ; ptr to routine b_icl to load int} equ 0  
icval   equ  icget+1                            ; integer value} equ icget+1  
icsi_   equ  icval+cfp_i                        ; size of icblk} equ icval+cfp_i  
kvtyp   equ  0                                  ; pointer to dummy routine b_kvt} equ 0  
kvvar   equ  kvtyp+1                            ; pointer to dummy block trbkv} equ kvtyp+1  
kvnum   equ  kvvar+1                            ; keyword number} equ kvvar+1  
kvsi_   equ  kvnum+1                            ; size of kvblk} equ kvnum+1  
nmtyp   equ  0                                  ; ptr to routine b_nml to load name} equ 0  
nmbas   equ  nmtyp+1                            ; base pointer for variable} equ nmtyp+1  
nmofs   equ  nmbas+1                            ; offset for variable} equ nmbas+1  
nmsi_   equ  nmofs+1                            ; size of nmblk} equ nmofs+1  
pcode   equ  0                                  ; ptr to match routine (p_xxx)} equ 0  
pthen   equ  pcode+1                            ; pointer to subsequent node} equ pcode+1  
pasi_   equ  pthen+1                            ; size of p0blk} equ pthen+1  
parm1   equ  pthen+1                            ; first parameter value} equ pthen+1  
pbsi_   equ  parm1+1                            ; size of p1blk in words} equ parm1+1  
parm2   equ  parm1+1                            ; second parameter value} equ parm1+1  
pcsi_   equ  parm2+1                            ; size of p2blk in words} equ parm2+1  
pdtyp   equ  0                                  ; ptr to dummy routine b_pdt} equ 0  
pddfp   equ  idval+1                            ; ptr to associated dfblk} equ idval+1  
pdfld   equ  pddfp+1                            ; start of field value pointers} equ pddfp+1  
pdfof   equ  dffld-pdfld                        ; difference in offset to field ptrs} equ dffld-pdfld  
pdsi_   equ  pdfld                              ; size of standard fields in pdblk} equ pdfld  
pddfs   equ  dfsi_-pdsi_                        ; difference in dfblk, pdblk sizes} equ dfsi_-pdsi_  
pflen   equ  fargs+1                            ; length of pfblk in bytes} equ fargs+1  
pfvbl   equ  pflen+1                            ; pointer to vrblk for function name} equ pflen+1  
pfnlo   equ  pfvbl+1                            ; number of locals} equ pfvbl+1  
pfcod   equ  pfnlo+1                            ; ptr to vrblk for entry label} equ pfnlo+1  
pfctr   equ  pfcod+1                            ; trblk ptr if call traced else 0} equ pfcod+1  
pfrtr   equ  pfctr+1                            ; trblk ptr if return traced else 0} equ pfctr+1  
pfarg   equ  pfrtr+1                            ; vrblk ptrs for arguments and locals} equ pfrtr+1  
pfagb   equ  pfarg-1                            ; offset behind pfarg for arg, local} equ pfarg-1  
pfsi_   equ  pfarg                              ; number of standard fields in pfblk} equ pfarg  
rcget   equ  0                                  ; ptr to routine b_rcl to load real} equ 0  
rcval   equ  rcget+1                            ; real value} equ rcget+1  
rcsi_   equ  rcval+cfp_r                        ; size of rcblk} equ rcval+cfp_r  
scget   equ  0                                  ; ptr to routine b_scl to load string} equ 0  
sclen   equ  scget+1                            ; length of string in characters} equ scget+1  
schar   equ  sclen+1                            ; characters of string} equ sclen+1  
scsi_   equ  schar                              ; size of standard fields in scblk} equ schar  
setyp   equ  0                                  ; ptr to routine b_sel to load expr} equ 0  
sevar   equ  setyp+1                            ; ptr to vrblk for variable} equ setyp+1  
sesi_   equ  sevar+1                            ; length of seblk in words} equ sevar+1  
svbit   equ  0                                  ; bit string indicating attributes} equ 0  
svlen   equ  1                                  ; (=sclen) length of name in chars} equ 1  
svchs   equ  2                                  ; (=schar) characters of name} equ 2  
svsi_   equ  2                                  ; number of standard fields in svblk} equ 2  
svpre   equ  1                                  ; set if preevaluation permitted} equ 1  
svffc   equ  svpre+svpre                        ; set on if fast call permitted} equ svpre+svpre  
svckw   equ  svffc+svffc                        ; set on if keyword value constant} equ svffc+svffc  
svprd   equ  svckw+svckw                        ; set on if predicate function} equ svckw+svckw  
svnbt   equ  4                                  ; number of bits to right of svknm} equ 4  
svknm   equ  svprd+svprd                        ; set on if keyword association} equ svprd+svprd  
svfnc   equ  svknm+svknm                        ; set on if system function} equ svknm+svknm  
svnar   equ  svfnc+svfnc                        ; set on if system function} equ svfnc+svfnc  
svlbl   equ  svnar+svnar                        ; set on if system label} equ svnar+svnar  
svval   equ  svlbl+svlbl                        ; set on if predefined value} equ svlbl+svlbl  
svfnf   equ  svfnc+svnar                        ; function with no fast call} equ svfnc+svnar  
svfnn   equ  svfnf+svffc                        ; function with fast call, no preeval} equ svfnf+svffc  
svfnp   equ  svfnn+svpre                        ; function allowing preevaluation} equ svfnn+svpre  
svfpr   equ  svfnn+svprd                        ; predicate function} equ svfnn+svprd  
svfnk   equ  svfnn+svknm                        ; no preeval func + keyword} equ svfnn+svknm  
svkwv   equ  svknm+svval                        ; keyword + value} equ svknm+svval  
svkwc   equ  svckw+svknm                        ; keyword with constant value} equ svckw+svknm  
svkvc   equ  svkwv+svckw                        ; constant keyword + value} equ svkwv+svckw  
svkvl   equ  svkvc+svlbl                        ; constant keyword + value + label} equ svkvc+svlbl  
svfpk   equ  svfnp+svkvc                        ; preeval fcn + const keywd + val} equ svfnp+svkvc  
k_abe   equ  0                                  ; abend} equ 0  
k_anc   equ  k_abe+cfp_b                        ; anchor} equ k_abe+cfp_b  
k_cas   equ  k_anc+cfp_b                        ; case} equ k_anc+cfp_b  
k_cod   equ  k_cas+cfp_b                        ; code} equ k_cas+cfp_b  
k_com   equ  k_cod+cfp_b                        ; compare} equ k_cod+cfp_b  
k_dmp   equ  k_com+cfp_b                        ; dump} equ k_com+cfp_b  
k_erl   equ  k_dmp+cfp_b                        ; errlimit} equ k_dmp+cfp_b  
k_ert   equ  k_erl+cfp_b                        ; errtype} equ k_erl+cfp_b  
k_ftr   equ  k_ert+cfp_b                        ; ftrace} equ k_ert+cfp_b  
k_fls   equ  k_ftr+cfp_b                        ; fullscan} equ k_ftr+cfp_b  
k_inp   equ  k_fls+cfp_b                        ; input} equ k_fls+cfp_b  
k_mxl   equ  k_inp+cfp_b                        ; maxlength} equ k_inp+cfp_b  
k_oup   equ  k_mxl+cfp_b                        ; output} equ k_mxl+cfp_b  
k_pfl   equ  k_oup+cfp_b                        ; profile} equ k_oup+cfp_b  
k_tra   equ  k_pfl+cfp_b                        ; trace} equ k_pfl+cfp_b  
k_trm   equ  k_tra+cfp_b                        ; trim} equ k_tra+cfp_b  
k_fnc   equ  k_trm+cfp_b                        ; fnclevel} equ k_trm+cfp_b  
k_lst   equ  k_fnc+cfp_b                        ; lastno} equ k_fnc+cfp_b  
k_lln   equ  k_lst+cfp_b                        ; lastline} equ k_lst+cfp_b  
k_lin   equ  k_lln+cfp_b                        ; line} equ k_lln+cfp_b  
k_stn   equ  k_lin+cfp_b                        ; stno} equ k_lin+cfp_b  
k_abo   equ  k_stn+cfp_b                        ; abort} equ k_stn+cfp_b  
k_arb   equ  k_abo+pasi_                        ; arb} equ k_abo+pasi_  
k_bal   equ  k_arb+pasi_                        ; bal} equ k_arb+pasi_  
k_fal   equ  k_bal+pasi_                        ; fail} equ k_bal+pasi_  
k_fen   equ  k_fal+pasi_                        ; fence} equ k_fal+pasi_  
k_rem   equ  k_fen+pasi_                        ; rem} equ k_fen+pasi_  
k_suc   equ  k_rem+pasi_                        ; succeed} equ k_rem+pasi_  
k_alp   equ  k_suc+1                            ; alphabet} equ k_suc+1  
k_rtn   equ  k_alp+1                            ; rtntype} equ k_alp+1  
k_stc   equ  k_rtn+1                            ; stcount} equ k_rtn+1  
k_etx   equ  k_stc+1                            ; errtext} equ k_stc+1  
k_fil   equ  k_etx+1                            ; file} equ k_etx+1  
k_lfl   equ  k_fil+1                            ; lastfile} equ k_fil+1  
k_stl   equ  k_lfl+1                            ; stlimit} equ k_lfl+1  
k_lcs   equ  k_stl+1                            ; lcase} equ k_stl+1  
k_ucs   equ  k_lcs+1                            ; ucase} equ k_lcs+1  
k__al   equ  k_alp-k_alp                        ; alphabet} equ k_alp-k_alp  
k__rt   equ  k_rtn-k_alp                        ; rtntype} equ k_rtn-k_alp  
k__sc   equ  k_stc-k_alp                        ; stcount} equ k_stc-k_alp  
k__et   equ  k_etx-k_alp                        ; errtext} equ k_etx-k_alp  
k__fl   equ  k_fil-k_alp                        ; file} equ k_fil-k_alp  
k__lf   equ  k_lfl-k_alp                        ; lastfile} equ k_lfl-k_alp  
k__sl   equ  k_stl-k_alp                        ; stlimit} equ k_stl-k_alp  
k__lc   equ  k_lcs-k_alp                        ; lcase} equ k_lcs-k_alp  
k__uc   equ  k_ucs-k_alp                        ; ucase} equ k_ucs-k_alp  
k__n_   equ  k__uc+1                            ; number of special cases} equ k__uc+1  
k_p__   equ  k_fnc                              ; first protected keyword} equ k_fnc  
k_v__   equ  k_abo                              ; first keyword with constant value} equ k_abo  
k_s__   equ  k_alp                              ; first keyword with special acess} equ k_alp  
tbtyp   equ  0                                  ; pointer to dummy routine b_tbt} equ 0  
tblen   equ  offs2                              ; length of tbblk in bytes} equ offs2  
tbinv   equ  offs3                              ; default initial lookup value} equ offs3  
tbbuk   equ  tbinv+1                            ; start of hash bucket pointers} equ tbinv+1  
tbsi_   equ  tbbuk                              ; size of standard fields in tbblk} equ tbbuk  
tbnbk   equ  11                                 ; default no. of buckets} equ 11  
tetyp   equ  0                                  ; pointer to dummy routine b_tet} equ 0  
tesub   equ  tetyp+1                            ; subscript value} equ tetyp+1  
teval   equ  tesub+1                            ; (=vrval) table element value} equ tesub+1  
tenxt   equ  teval+1                            ; link to next teblk} equ teval+1  
tesi_   equ  tenxt+1                            ; size of teblk in words} equ tenxt+1  
tridn   equ  0                                  ; pointer to dummy routine b_trt} equ 0  
trtyp   equ  tridn+1                            ; trap type code} equ tridn+1  
trval   equ  trtyp+1                            ; value of trapped variable (=vrval)} equ trtyp+1  
trnxt   equ  trval                              ; ptr to next trblk on trblk chain} equ trval  
trlbl   equ  trval                              ; ptr to actual label (traced label)} equ trval  
trkvr   equ  trval                              ; vrblk pointer for keyword trace} equ trval  
trtag   equ  trval+1                            ; trace tag} equ trval+1  
trter   equ  trtag                              ; ptr to terminal vrblk or null} equ trtag  
trtrf   equ  trtag                              ; ptr to trblk holding fcblk ptr} equ trtag  
trfnc   equ  trtag+1                            ; trace function vrblk (zero if none)} equ trtag+1  
trfpt   equ  trfnc                              ; fcblk ptr for sysio} equ trfnc  
trsi_   equ  trfnc+1                            ; number of words in trblk} equ trfnc+1  
trtin   equ  0                                  ; trace type for input association} equ 0  
trtac   equ  trtin+1                            ; trace type for access trace} equ trtin+1  
trtvl   equ  trtac+1                            ; trace type for value trace} equ trtac+1  
trtou   equ  trtvl+1                            ; trace type for output association} equ trtvl+1  
trtfc   equ  trtou+1                            ; trace type for fcblk identification} equ trtou+1  
vctyp   equ  0                                  ; pointer to dummy routine b_vct} equ 0  
vclen   equ  offs2                              ; length of vcblk in bytes} equ offs2  
vcvls   equ  offs3                              ; start of vector values} equ offs3  
vcsi_   equ  vcvls                              ; size of standard fields in vcblk} equ vcvls  
vcvlb   equ  vcvls-1                            ; offset one word behind vcvls} equ vcvls-1  
vctbd   equ  tbsi_-vcsi_                        ; difference in sizes - see prtvl} equ tbsi_-vcsi_  
vrget   equ  0                                  ; pointer to routine to load value} equ 0  
vrsto   equ  vrget+1                            ; pointer to routine to store value} equ vrget+1  
vrval   equ  vrsto+1                            ; variable value} equ vrsto+1  
vrvlo   equ  vrval-vrsto                        ; offset to value from store field} equ vrval-vrsto  
vrtra   equ  vrval+1                            ; pointer to routine to jump to label} equ vrval+1  
vrlbl   equ  vrtra+1                            ; pointer to code for label} equ vrtra+1  
vrlbo   equ  vrlbl-vrtra                        ; offset to label from transfer field} equ vrlbl-vrtra  
vrfnc   equ  vrlbl+1                            ; pointer to function block} equ vrlbl+1  
vrnxt   equ  vrfnc+1                            ; pointer to next vrblk on hash chain} equ vrfnc+1  
vrlen   equ  vrnxt+1                            ; length of name (or zero)} equ vrnxt+1  
vrchs   equ  vrlen+1                            ; characters of name (vrlen gt 0)} equ vrlen+1  
vrsvp   equ  vrlen+1                            ; ptr to svblk (vrlen eq 0)} equ vrlen+1  
vrsi_   equ  vrchs+1                            ; number of standard fields in vrblk} equ vrchs+1  
vrsof   equ  vrlen-sclen                        ; offset to dummy scblk for name} equ vrlen-sclen  
vrsvo   equ  vrsvp-vrsof                        ; pseudo-offset to vrsvp field} equ vrsvp-vrsof  
xntyp   equ  0                                  ; pointer to dummy routine b_xnt} equ 0  
xnlen   equ  xntyp+1                            ; length of xnblk in bytes} equ xntyp+1  
xndta   equ  xnlen+1                            ; data words} equ xnlen+1  
xnsi_   equ  xndta                              ; size of standard fields in xnblk} equ xndta  
xrtyp   equ  0                                  ; pointer to dummy routine b_xrt} equ 0  
xrlen   equ  xrtyp+1                            ; length of xrblk in bytes} equ xrtyp+1  
xrptr   equ  xrlen+1                            ; start of address pointers} equ xrlen+1  
xrsi_   equ  xrptr                              ; size of standard fields in xrblk} equ xrptr  
cnvst   equ  8                                  ; max standard type code for convert} equ 8  
cnvrt   equ  cnvst+1                            ; convert code for reals} equ cnvst+1  
cnvbt   equ  cnvrt                              ; no buffers - same as real code} equ cnvrt  
cnvtt   equ  cnvbt+1                            ; bsw code for convert} equ cnvbt+1  
iniln   equ  1024                               ; default image length for compiler} equ 1024  
inils   equ  1024                               ; image length if -sequ in effect} equ 1024  
ionmb   equ  2                                  ; name base used for iochn in sysio} equ 2  
ionmo   equ  4                                  ; name offset used for iochn in sysio} equ 4  
mnlen   equ  1024                               ; min value allowed keyword maxlngth} equ 1024  
mxern   equ  329                                ; err num inadequate startup memory} equ 329  
num01   equ  1                                  ; } equ 1  
num02   equ  2                                  ; } equ 2  
num03   equ  3                                  ; } equ 3  
num04   equ  4                                  ; } equ 4  
num05   equ  5                                  ; } equ 5  
num06   equ  6                                  ; } equ 6  
num07   equ  7                                  ; } equ 7  
num08   equ  8                                  ; } equ 8  
num09   equ  9                                  ; } equ 9  
num10   equ  10                                 ; } equ 10  
num25   equ  25                                 ; } equ 25  
nm320   equ  320                                ; } equ 320  
nm321   equ  321                                ; } equ 321  
nini8   equ  998                                ; } equ 998  
nini9   equ  999                                ; } equ 999  
thsnd   equ  1000                               ; } equ 1000  
opbun   equ  5                                  ; no. of binary undefined ops} equ 5  
opuun   equ  6                                  ; no of unary undefined ops} equ 6  
prsnf   equ  13                                 ; offset used in prtsn} equ 13  
prtmf   equ  21                                 ; offset to col 21 (prtmi)} equ 21  
rilen   equ  1024                               ; buffer length for sysri} equ 1024  
stgic   equ  0                                  ; initial compile} equ 0  
stgxc   equ  stgic+1                            ; execution compile (code)} equ stgic+1  
stgev   equ  stgxc+1                            ; expression eval during execution} equ stgxc+1  
stgxt   equ  stgev+1                            ; execution time} equ stgev+1  
stgce   equ  stgxt+1                            ; initial compile after end line} equ stgxt+1  
stgxe   equ  stgce+1                            ; exec. compile after end line} equ stgce+1  
stgnd   equ  stgce-stgic                        ; difference in stage after end} equ stgce-stgic  
stgee   equ  stgxe+1                            ; eval evaluating expression} equ stgxe+1  
stgno   equ  stgee+1                            ; number of codes} equ stgee+1  
stnpd   equ  8                                  ; statement no. pad count} equ 8  
t_uop   equ  0                                  ; unary operator} equ 0  
t_lpr   equ  t_uop+3                            ; left paren} equ t_uop+3  
t_lbr   equ  t_lpr+3                            ; left bracket} equ t_lpr+3  
t_cma   equ  t_lbr+3                            ; comma} equ t_lbr+3  
t_fnc   equ  t_cma+3                            ; function call} equ t_cma+3  
t_var   equ  t_fnc+3                            ; variable} equ t_fnc+3  
t_con   equ  t_var+3                            ; constant} equ t_var+3  
t_bop   equ  t_con+3                            ; binary operator} equ t_con+3  
t_rpr   equ  t_bop+3                            ; right paren} equ t_bop+3  
t_rbr   equ  t_rpr+3                            ; right bracket} equ t_rpr+3  
t_col   equ  t_rbr+3                            ; colon} equ t_rbr+3  
t_smc   equ  t_col+3                            ; semi-colon} equ t_col+3  
t_fgo   equ  t_smc+1                            ; failure goto} equ t_smc+1  
t_sgo   equ  t_fgo+1                            ; success goto} equ t_fgo+1  
t_uok   equ  t_fnc                              ; last code ok before unary operator} equ t_fnc  
t_uo0   equ  t_uop+0                            ; unary operator, state zero} equ t_uop+0  
t_uo1   equ  t_uop+1                            ; unary operator, state one} equ t_uop+1  
t_uo2   equ  t_uop+2                            ; unary operator, state two} equ t_uop+2  
t_lp0   equ  t_lpr+0                            ; left paren, state zero} equ t_lpr+0  
t_lp1   equ  t_lpr+1                            ; left paren, state one} equ t_lpr+1  
t_lp2   equ  t_lpr+2                            ; left paren, state two} equ t_lpr+2  
t_lb0   equ  t_lbr+0                            ; left bracket, state zero} equ t_lbr+0  
t_lb1   equ  t_lbr+1                            ; left bracket, state one} equ t_lbr+1  
t_lb2   equ  t_lbr+2                            ; left bracket, state two} equ t_lbr+2  
t_cm0   equ  t_cma+0                            ; comma, state zero} equ t_cma+0  
t_cm1   equ  t_cma+1                            ; comma, state one} equ t_cma+1  
t_cm2   equ  t_cma+2                            ; comma, state two} equ t_cma+2  
t_fn0   equ  t_fnc+0                            ; function call, state zero} equ t_fnc+0  
t_fn1   equ  t_fnc+1                            ; function call, state one} equ t_fnc+1  
t_fn2   equ  t_fnc+2                            ; function call, state two} equ t_fnc+2  
t_va0   equ  t_var+0                            ; variable, state zero} equ t_var+0  
t_va1   equ  t_var+1                            ; variable, state one} equ t_var+1  
t_va2   equ  t_var+2                            ; variable, state two} equ t_var+2  
t_co0   equ  t_con+0                            ; constant, state zero} equ t_con+0  
t_co1   equ  t_con+1                            ; constant, state one} equ t_con+1  
t_co2   equ  t_con+2                            ; constant, state two} equ t_con+2  
t_bo0   equ  t_bop+0                            ; binary operator, state zero} equ t_bop+0  
t_bo1   equ  t_bop+1                            ; binary operator, state one} equ t_bop+1  
t_bo2   equ  t_bop+2                            ; binary operator, state two} equ t_bop+2  
t_rp0   equ  t_rpr+0                            ; right paren, state zero} equ t_rpr+0  
t_rp1   equ  t_rpr+1                            ; right paren, state one} equ t_rpr+1  
t_rp2   equ  t_rpr+2                            ; right paren, state two} equ t_rpr+2  
t_rb0   equ  t_rbr+0                            ; right bracket, state zero} equ t_rbr+0  
t_rb1   equ  t_rbr+1                            ; right bracket, state one} equ t_rbr+1  
t_rb2   equ  t_rbr+2                            ; right bracket, state two} equ t_rbr+2  
t_cl0   equ  t_col+0                            ; colon, state zero} equ t_col+0  
t_cl1   equ  t_col+1                            ; colon, state one} equ t_col+1  
t_cl2   equ  t_col+2                            ; colon, state two} equ t_col+2  
t_sm0   equ  t_smc+0                            ; semicolon, state zero} equ t_smc+0  
t_sm1   equ  t_smc+1                            ; semicolon, state one} equ t_smc+1  
t_sm2   equ  t_smc+2                            ; semicolon, state two} equ t_smc+2  
t_nes   equ  t_sm2+1                            ; number of entries in branch table} equ t_sm2+1  
cc_ca   equ  0                                  ; -case} equ 0  
cc_do   equ  cc_ca+1                            ; -double} equ cc_ca+1  
cc_co   equ  cc_do+1                            ; -compare} equ cc_do+1  
cc_du   equ  cc_co+1                            ; -dump} equ cc_co+1  
cc_cp   equ  cc_du+1                            ; -copy} equ cc_du+1  
cc_ej   equ  cc_cp+1                            ; -eject} equ cc_cp+1  
cc_er   equ  cc_ej+1                            ; -errors} equ cc_ej+1  
cc_ex   equ  cc_er+1                            ; -execute} equ cc_er+1  
cc_fa   equ  cc_ex+1                            ; -fail} equ cc_ex+1  
cc_in   equ  cc_fa+1                            ; -include} equ cc_fa+1  
cc_ln   equ  cc_in+1                            ; -line} equ cc_in+1  
cc_li   equ  cc_ln+1                            ; -list} equ cc_ln+1  
cc_nr   equ  cc_li+1                            ; -noerrors} equ cc_li+1  
cc_nx   equ  cc_nr+1                            ; -noexecute} equ cc_nr+1  
cc_nf   equ  cc_nx+1                            ; -nofail} equ cc_nx+1  
cc_nl   equ  cc_nf+1                            ; -nolist} equ cc_nf+1  
cc_no   equ  cc_nl+1                            ; -noopt} equ cc_nl+1  
cc_np   equ  cc_no+1                            ; -noprint} equ cc_no+1  
cc_op   equ  cc_np+1                            ; -optimise} equ cc_np+1  
cc_pr   equ  cc_op+1                            ; -print} equ cc_op+1  
cc_si   equ  cc_pr+1                            ; -single} equ cc_pr+1  
cc_sp   equ  cc_si+1                            ; -space} equ cc_si+1  
cc_st   equ  cc_sp+1                            ; -stitl} equ cc_sp+1  
cc_ti   equ  cc_st+1                            ; -title} equ cc_st+1  
cc_tr   equ  cc_ti+1                            ; -trace} equ cc_ti+1  
cc_nc   equ  cc_tr+1                            ; number of control cards} equ cc_tr+1  
ccnoc   equ  4                                  ; no. of chars included in match} equ 4  
ccofs   equ  7                                  ; offset to start of title/subtitle} equ 7  
ccinm   equ  9                                  ; max depth of include file nesting} equ 9  
cmstm   equ  0                                  ; tree for statement body} equ 0  
cmsgo   equ  cmstm+1                            ; tree for success goto} equ cmstm+1  
cmfgo   equ  cmsgo+1                            ; tree for fail goto} equ cmsgo+1  
cmcgo   equ  cmfgo+1                            ; conditional goto flag} equ cmfgo+1  
cmpcd   equ  cmcgo+1                            ; previous cdblk pointer} equ cmcgo+1  
cmffp   equ  cmpcd+1                            ; failure fill in flag for previous} equ cmpcd+1  
cmffc   equ  cmffp+1                            ; failure fill in flag for current} equ cmffp+1  
cmsop   equ  cmffc+1                            ; success fill in offset for previous} equ cmffc+1  
cmsoc   equ  cmsop+1                            ; success fill in offset for current} equ cmsop+1  
cmlbl   equ  cmsoc+1                            ; ptr to vrblk for current label} equ cmsoc+1  
cmtra   equ  cmlbl+1                            ; ptr to entry cdblk} equ cmlbl+1  
cmnen   equ  cmtra+1                            ; count of stack entries for cmpil} equ cmtra+1  
pfpd1   equ  8                                  ; pad positions ...} equ 8  
pfpd2   equ  20                                 ; ... for profile ...} equ 20  
pfpd3   equ  32                                 ; ... printout} equ 32  
pf_i2   equ  cfp_i+cfp_i                        ; size of table entry (2 ints)} equ cfp_i+cfp_i  
rlend   equ  0                                  ; end} equ 0  
rladj   equ  rlend+1                            ; adjustment} equ rlend+1  
rlstr   equ  rladj+1                            ; start} equ rladj+1  
rssi_   equ  rlstr+1                            ; size of section} equ rlstr+1  
rnsi_   equ  5                                  ; number of structures} equ 5  
rldye   equ  0                                  ; dynamic region end} equ 0  
rldya   equ  rldye+1                            ; dynamic region adjustment} equ rldye+1  
rldys   equ  rldya+1                            ; dynamic region start} equ rldya+1  
rlste   equ  rldys+1                            ; static region end} equ rldys+1  
rlsta   equ  rlste+1                            ; static region adjustment} equ rlste+1  
rlsts   equ  rlsta+1                            ; static region start} equ rlsta+1  
rlwke   equ  rlsts+1                            ; working section globals end} equ rlsts+1  
rlwka   equ  rlwke+1                            ; working section globals adjustment} equ rlwke+1  
rlwks   equ  rlwka+1                            ; working section globals start} equ rlwka+1  
rlcne   equ  rlwks+1                            ; constants section end} equ rlwks+1  
rlcna   equ  rlcne+1                            ; constants section adjustment} equ rlcne+1  
rlcns   equ  rlcna+1                            ; constants section start} equ rlcna+1  
rlcde   equ  rlcns+1                            ; code section end} equ rlcns+1  
rlcda   equ  rlcde+1                            ; code section adjustment} equ rlcde+1  
rlcds   equ  rlcda+1                            ; code section start} equ rlcda+1  
rlsi_   equ  rlcds+1                            ; number of fields in structure} equ rlcds+1  
                                                ; start of constant section} sec   
        segment .data                           ; 
        global sec03                            ; 
sec03:                                          ; 
c_aaa:  d_word 0                                ; first location of constant section} dac 0  
alfsp:  d_word e_fsp                            ; free store percentage} dac e_fsp  
bits0:  d_word 0                                ; all zero bits} dbc 0  
bits1:  d_word 1                                ; one bit in low order position} dbc 1  
bits2:  d_word 2                                ; bit in position 2} dbc 2  
bits3:  d_word 4                                ; bit in position 3} dbc 4  
bits4:  d_word 8                                ; bit in position 4} dbc 8  
bits5:  d_word 16                               ; bit in position 5} dbc 16  
bits6:  d_word 32                               ; bit in position 6} dbc 32  
bits7:  d_word 64                               ; bit in position 7} dbc 64  
bits8:  d_word 128                              ; bit in position 8} dbc 128  
bits9:  d_word 256                              ; bit in position 9} dbc 256  
bit10:  d_word 512                              ; bit in position 10} dbc 512  
bit11:  d_word 1024                             ; bit in position 11} dbc 1024  
bit12:  d_word 2048                             ; bit in position 12} dbc 2048  
bitsm:  d_word 0                                ; mask for max integer (value filled in at runtime)} dbc 0  
btfnc:  d_word svfnc                            ; bit to test for function} dbc svfnc  
btknm:  d_word svknm                            ; bit to test for keyword number} dbc svknm  
btlbl:  d_word svlbl                            ; bit to test for label} dbc svlbl  
btffc:  d_word svffc                            ; bit to test for fast call} dbc svffc  
btckw:  d_word svckw                            ; bit to test for constant keyword} dbc svckw  
btkwv:  d_word svkwv                            ; bits to test for keword with value} dbc svkwv  
btprd:  d_word svprd                            ; bit to test for predicate function} dbc svprd  
btpre:  d_word svpre                            ; bit to test for preevaluation} dbc svpre  
btval:  d_word svval                            ; bit to test for value} dbc svval  
ccnms:  d_char 'c','a','s','e',0,0,0,0          ; } dtc /case/  
        d_char 'd','o','u','b',0,0,0,0          ; } dtc /doub/  
        d_char 'c','o','m','p',0,0,0,0          ; } dtc /comp/  
        d_char 'd','u','m','p',0,0,0,0          ; } dtc /dump/  
        d_char 'c','o','p','y',0,0,0,0          ; } dtc /copy/  
        d_char 'e','j','e','c',0,0,0,0          ; } dtc /ejec/  
        d_char 'e','r','r','o',0,0,0,0          ; } dtc /erro/  
        d_char 'e','x','e','c',0,0,0,0          ; } dtc /exec/  
        d_char 'f','a','i','l',0,0,0,0          ; } dtc /fail/  
        d_char 'i','n','c','l',0,0,0,0          ; } dtc /incl/  
        d_char 'l','i','n','e',0,0,0,0          ; } dtc /line/  
        d_char 'l','i','s','t',0,0,0,0          ; } dtc /list/  
        d_char 'n','o','e','r',0,0,0,0          ; } dtc /noer/  
        d_char 'n','o','e','x',0,0,0,0          ; } dtc /noex/  
        d_char 'n','o','f','a',0,0,0,0          ; } dtc /nofa/  
        d_char 'n','o','l','i',0,0,0,0          ; } dtc /noli/  
        d_char 'n','o','o','p',0,0,0,0          ; } dtc /noop/  
        d_char 'n','o','p','r',0,0,0,0          ; } dtc /nopr/  
        d_char 'o','p','t','i',0,0,0,0          ; } dtc /opti/  
        d_char 'p','r','i','n',0,0,0,0          ; } dtc /prin/  
        d_char 's','i','n','g',0,0,0,0          ; } dtc /sing/  
        d_char 's','p','a','c',0,0,0,0          ; } dtc /spac/  
        d_char 's','t','i','t',0,0,0,0          ; } dtc /stit/  
        d_char 't','i','t','l',0,0,0,0          ; } dtc /titl/  
        d_char 't','r','a','c',0,0,0,0          ; } dtc /trac/  
dmhdk:  d_word b_scl                            ; dump of keyword values} dac b_scl  
        d_word 22                               ; } dac 22  
        d_char 'd','u','m','p',' ','o','f',' ','k','e','y','w','o','r','d',' ','v','a','l','u','e','s',0,0; } dtc /dump of keyword values/  
dmhdv:  d_word b_scl                            ; dump of natural variables} dac b_scl  
        d_word 25                               ; } dac 25  
        d_char 'd','u','m','p',' ','o','f',' ','n','a','t','u','r','a','l',' ','v','a','r','i','a','b','l','e','s',0,0,0,0,0,0,0; } dtc /dump of natural variables/  
encm1:  d_word b_scl                            ; } dac b_scl  
        d_word 19                               ; } dac 19  
        d_char 'm','e','m','o','r','y',' ','u','s','e','d',' ','(','b','y','t','e','s',')',0,0,0,0,0; } dtc /memory used (bytes)/  
encm2:  d_word b_scl                            ; } dac b_scl  
        d_word 19                               ; } dac 19  
        d_char 'm','e','m','o','r','y',' ','l','e','f','t',' ','(','b','y','t','e','s',')',0,0,0,0,0; } dtc /memory left (bytes)/  
encm3:  d_word b_scl                            ; } dac b_scl  
        d_word 11                               ; } dac 11  
        d_char 'c','o','m','p',' ','e','r','r','o','r','s',0,0,0,0,0; } dtc /comp errors/  
encm4:  d_word b_scl                            ; } dac b_scl  
        d_word 20                               ; } dac 20  
        d_char 'c','o','m','p',' ','t','i','m','e',' ','(','m','i','c','r','o','s','e','c',')',0,0,0,0; } dtc /comp time (microsec)/  
encm5:  d_word b_scl                            ; execution suppressed} dac b_scl  
        d_word 20                               ; } dac 20  
        d_char 'e','x','e','c','u','t','i','o','n',' ','s','u','p','p','r','e','s','s','e','d',0,0,0,0; } dtc /execution suppressed/  
endab:  d_word b_scl                            ; } dac b_scl  
        d_word 12                               ; } dac 12  
        d_char 'a','b','n','o','r','m','a','l',' ','e','n','d',0,0,0,0; } dtc /abnormal end/  
endmo:  d_word b_scl                            ; } dac b_scl  
endml:  d_word 15                               ; } dac 15  
        d_char 'm','e','m','o','r','y',' ','o','v','e','r','f','l','o','w',0; } dtc /memory overflow/  
endms:  d_word b_scl                            ; } dac b_scl  
        d_word 10                               ; } dac 10  
        d_char 'n','o','r','m','a','l',' ','e','n','d',0,0,0,0,0,0; } dtc /normal end/  
endso:  d_word b_scl                            ; stack overflow in garbage collector} dac b_scl  
        d_word 36                               ; } dac 36  
        d_char 's','t','a','c','k',' ','o','v','e','r','f','l','o','w',' ','i','n',' ','g','a','r','b','a','g','e',' ','c','o','l','l','e','c','t','i','o','n',0,0,0,0; } dtc /stack overflow in garbage collection/  
endtu:  d_word b_scl                            ; } dac b_scl  
        d_word 15                               ; } dac 15  
        d_char 'e','r','r','o','r',' ','-',' ','t','i','m','e',' ','u','p',0; } dtc /error - time up/  
ermms:  d_word b_scl                            ; error} dac b_scl  
        d_word 5                                ; } dac 5  
        d_char 'e','r','r','o','r',0,0,0        ; } dtc /error/  
ermns:  d_word b_scl                            ; string / -- /} dac b_scl  
        d_word 4                                ; } dac 4  
        d_char ' ','-','-',' ',0,0,0,0          ; } dtc / -- /  
lstms:  d_word b_scl                            ; page} dac b_scl  
        d_word 5                                ; } dac 5  
        d_char 'p','a','g','e',' ',0,0,0        ; } dtc /page /  
headr:  d_word b_scl                            ; } dac b_scl  
        d_word 26                               ; } dac 26  
        d_char 'm','a','c','r','o',' ','s','p','i','t','b','o','l',' ','v','e','r','s','i','o','n',' ','4','.','0','f',0,0,0,0,0,0; } dtc /macro spitbol version 4.0f/  
headv:  d_word b_scl                            ; for exit() version no. check} dac b_scl  
        d_word 5                                ; } dac 5  
        d_char '1','5','.','0','1',0,0,0        ; } dtc /15.01/  
gbsdp:  d_word e_sed                            ; sediment percentage} dac e_sed  
int_r:  d_word b_icl                            ; } dac b_icl  
intv0:  d_word +0                               ; 0} dic +0  
inton:  d_word b_icl                            ; } dac b_icl  
intv1:  d_word +1                               ; 1} dic +1  
inttw:  d_word b_icl                            ; } dac b_icl  
intv2:  d_word +2                               ; 2} dic +2  
intvt:  d_word +10                              ; 10} dic +10  
intvh:  d_word +100                             ; 100} dic +100  
intth:  d_word +1000                            ; 1000} dic +1000  
intab:  d_word int_r                            ; pointer to 0} dac int_r  
        d_word inton                            ; pointer to 1} dac inton  
        d_word inttw                            ; pointer to 2} dac inttw  
ndabb:  d_word p_abb                            ; arbno} dac p_abb  
ndabd:  d_word p_abd                            ; arbno} dac p_abd  
ndarc:  d_word p_arc                            ; arb} dac p_arc  
ndexb:  d_word p_exb                            ; expression} dac p_exb  
ndfnb:  d_word p_fnb                            ; fence()} dac p_fnb  
ndfnd:  d_word p_fnd                            ; fence()} dac p_fnd  
ndexc:  d_word p_exc                            ; expression} dac p_exc  
ndimb:  d_word p_imb                            ; immediate assignment} dac p_imb  
ndimd:  d_word p_imd                            ; immediate assignment} dac p_imd  
ndnth:  d_word p_nth                            ; pattern end (null pattern)} dac p_nth  
ndpab:  d_word p_pab                            ; pattern assignment} dac p_pab  
ndpad:  d_word p_pad                            ; pattern assignment} dac p_pad  
nduna:  d_word p_una                            ; anchor point movement} dac p_una  
ndabo:  d_word p_abo                            ; abort} dac p_abo  
        d_word ndnth                            ; } dac ndnth  
ndarb:  d_word p_arb                            ; arb} dac p_arb  
        d_word ndnth                            ; } dac ndnth  
ndbal:  d_word p_bal                            ; bal} dac p_bal  
        d_word ndnth                            ; } dac ndnth  
ndfal:  d_word p_fal                            ; fail} dac p_fal  
        d_word ndnth                            ; } dac ndnth  
ndfen:  d_word p_fen                            ; fence} dac p_fen  
        d_word ndnth                            ; } dac ndnth  
ndrem:  d_word p_rem                            ; rem} dac p_rem  
        d_word ndnth                            ; } dac ndnth  
ndsuc:  d_word p_suc                            ; succeed} dac p_suc  
        d_word ndnth                            ; } dac ndnth  
nulls:  d_word b_scl                            ; null string value} dac b_scl  
        d_word 0                                ; sclen = 0} dac 0  
nullw:  d_char ' ',' ',' ',' ',' ',' ',' ',' ',' ',' ',0,0,0,0,0,0; } dtc /          /  
lcase:  d_word b_scl                            ; } dac b_scl  
        d_word 26                               ; } dac 26  
        d_char 'a','b','c','d','e','f','g','h','i','j','k','l','m','n','o','p','q','r','s','t','u','v','w','x','y','z',0,0,0,0,0,0; } dtc /abcdefghijklmnopqrstuvwxyz/  
ucase:  d_word b_scl                            ; } dac b_scl  
        d_word 26                               ; } dac 26  
        d_char 'A','B','C','D','E','F','G','H','I','J','K','L','M','N','O','P','Q','R','S','T','U','V','W','X','Y','Z',0,0,0,0,0,0; } dtc /ABCDEFGHIJKLMNOPQRSTUVWXYZ/  
opdvc:  d_word o_cnc                            ; concatenation} dac o_cnc  
        d_word c_cnc                            ; } dac c_cnc  
        d_word llcnc                            ; } dac llcnc  
        d_word rrcnc                            ; } dac rrcnc  
opdvp:  d_word o_cnc                            ; concatenation - not pattern match} dac o_cnc  
        d_word c_cnp                            ; } dac c_cnp  
        d_word llcnc                            ; } dac llcnc  
        d_word rrcnc                            ; } dac rrcnc  
opdvs:  d_word o_ass                            ; assignment} dac o_ass  
        d_word c_ass                            ; } dac c_ass  
        d_word llass                            ; } dac llass  
        d_word rrass                            ; } dac rrass  
        d_word 6                                ; unary equal} dac 6  
        d_word c_uuo                            ; } dac c_uuo  
        d_word lluno                            ; } dac lluno  
        d_word o_pmv                            ; pattern match} dac o_pmv  
        d_word c_pmt                            ; } dac c_pmt  
        d_word llpmt                            ; } dac llpmt  
        d_word rrpmt                            ; } dac rrpmt  
        d_word o_int                            ; interrogation} dac o_int  
        d_word c_uvl                            ; } dac c_uvl  
        d_word lluno                            ; } dac lluno  
        d_word 1                                ; binary ampersand} dac 1  
        d_word c_ubo                            ; } dac c_ubo  
        d_word llamp                            ; } dac llamp  
        d_word rramp                            ; } dac rramp  
        d_word o_kwv                            ; keyword reference} dac o_kwv  
        d_word c_key                            ; } dac c_key  
        d_word lluno                            ; } dac lluno  
        d_word o_alt                            ; alternation} dac o_alt  
        d_word c_alt                            ; } dac c_alt  
        d_word llalt                            ; } dac llalt  
        d_word rralt                            ; } dac rralt  
        d_word 5                                ; unary vertical bar} dac 5  
        d_word c_uuo                            ; } dac c_uuo  
        d_word lluno                            ; } dac lluno  
        d_word 0                                ; binary at} dac 0  
        d_word c_ubo                            ; } dac c_ubo  
        d_word llats                            ; } dac llats  
        d_word rrats                            ; } dac rrats  
        d_word o_cas                            ; cursor assignment} dac o_cas  
        d_word c_unm                            ; } dac c_unm  
        d_word lluno                            ; } dac lluno  
        d_word 2                                ; binary number sign} dac 2  
        d_word c_ubo                            ; } dac c_ubo  
        d_word llnum                            ; } dac llnum  
        d_word rrnum                            ; } dac rrnum  
        d_word 7                                ; unary number sign} dac 7  
        d_word c_uuo                            ; } dac c_uuo  
        d_word lluno                            ; } dac lluno  
        d_word o_dvd                            ; division} dac o_dvd  
        d_word c_bvl                            ; } dac c_bvl  
        d_word lldvd                            ; } dac lldvd  
        d_word rrdvd                            ; } dac rrdvd  
        d_word 9                                ; unary slash} dac 9  
        d_word c_uuo                            ; } dac c_uuo  
        d_word lluno                            ; } dac lluno  
        d_word o_mlt                            ; multiplication} dac o_mlt  
        d_word c_bvl                            ; } dac c_bvl  
        d_word llmlt                            ; } dac llmlt  
        d_word rrmlt                            ; } dac rrmlt  
        d_word 0                                ; deferred expression} dac 0  
        d_word c_def                            ; } dac c_def  
        d_word lluno                            ; } dac lluno  
        d_word 3                                ; binary percent} dac 3  
        d_word c_ubo                            ; } dac c_ubo  
        d_word llpct                            ; } dac llpct  
        d_word rrpct                            ; } dac rrpct  
        d_word 8                                ; unary percent} dac 8  
        d_word c_uuo                            ; } dac c_uuo  
        d_word lluno                            ; } dac lluno  
        d_word o_exp                            ; exponentiation} dac o_exp  
        d_word c_bvl                            ; } dac c_bvl  
        d_word llexp                            ; } dac llexp  
        d_word rrexp                            ; } dac rrexp  
        d_word 10                               ; unary exclamation} dac 10  
        d_word c_uuo                            ; } dac c_uuo  
        d_word lluno                            ; } dac lluno  
        d_word o_ima                            ; immediate assignment} dac o_ima  
        d_word c_bvn                            ; } dac c_bvn  
        d_word lldld                            ; } dac lldld  
        d_word rrdld                            ; } dac rrdld  
        d_word o_inv                            ; indirection} dac o_inv  
        d_word c_ind                            ; } dac c_ind  
        d_word lluno                            ; } dac lluno  
        d_word 4                                ; binary not} dac 4  
        d_word c_ubo                            ; } dac c_ubo  
        d_word llnot                            ; } dac llnot  
        d_word rrnot                            ; } dac rrnot  
        d_word 0                                ; negation} dac 0  
        d_word c_neg                            ; } dac c_neg  
        d_word lluno                            ; } dac lluno  
        d_word o_sub                            ; subtraction} dac o_sub  
        d_word c_bvl                            ; } dac c_bvl  
        d_word llplm                            ; } dac llplm  
        d_word rrplm                            ; } dac rrplm  
        d_word o_com                            ; complementation} dac o_com  
        d_word c_uvl                            ; } dac c_uvl  
        d_word lluno                            ; } dac lluno  
        d_word o_add                            ; addition} dac o_add  
        d_word c_bvl                            ; } dac c_bvl  
        d_word llplm                            ; } dac llplm  
        d_word rrplm                            ; } dac rrplm  
        d_word o_aff                            ; affirmation} dac o_aff  
        d_word c_uvl                            ; } dac c_uvl  
        d_word lluno                            ; } dac lluno  
        d_word o_pas                            ; pattern assignment} dac o_pas  
        d_word c_bvn                            ; } dac c_bvn  
        d_word lldld                            ; } dac lldld  
        d_word rrdld                            ; } dac rrdld  
        d_word o_nam                            ; name reference} dac o_nam  
        d_word c_unm                            ; } dac c_unm  
        d_word lluno                            ; } dac lluno  
opdvd:  d_word o_god                            ; direct goto} dac o_god  
        d_word c_uvl                            ; } dac c_uvl  
        d_word lluno                            ; } dac lluno  
opdvn:  d_word o_goc                            ; complex normal goto} dac o_goc  
        d_word c_unm                            ; } dac c_unm  
        d_word lluno                            ; } dac lluno  
oamn_:  d_word o_amn                            ; array ref (multi-subs by value)} dac o_amn  
oamv_:  d_word o_amv                            ; array ref (multi-subs by value)} dac o_amv  
oaon_:  d_word o_aon                            ; array ref (one sub by name)} dac o_aon  
oaov_:  d_word o_aov                            ; array ref (one sub by value)} dac o_aov  
ocer_:  d_word o_cer                            ; compilation error} dac o_cer  
ofex_:  d_word o_fex                            ; failure in expression evaluation} dac o_fex  
ofif_:  d_word o_fif                            ; failure during goto evaluation} dac o_fif  
ofnc_:  d_word o_fnc                            ; function call (more than one arg)} dac o_fnc  
ofne_:  d_word o_fne                            ; function name error} dac o_fne  
ofns_:  d_word o_fns                            ; function call (single argument)} dac o_fns  
ogof_:  d_word o_gof                            ; set goto failure trap} dac o_gof  
oinn_:  d_word o_inn                            ; indirection by name} dac o_inn  
okwn_:  d_word o_kwn                            ; keyword reference by name} dac o_kwn  
olex_:  d_word o_lex                            ; load expression by name} dac o_lex  
olpt_:  d_word o_lpt                            ; load pattern} dac o_lpt  
olvn_:  d_word o_lvn                            ; load variable name} dac o_lvn  
onta_:  d_word o_nta                            ; negation, first entry} dac o_nta  
ontb_:  d_word o_ntb                            ; negation, second entry} dac o_ntb  
ontc_:  d_word o_ntc                            ; negation, third entry} dac o_ntc  
opmn_:  d_word o_pmn                            ; pattern match by name} dac o_pmn  
opms_:  d_word o_pms                            ; pattern match (statement)} dac o_pms  
opop_:  d_word o_pop                            ; pop top stack item} dac o_pop  
ornm_:  d_word o_rnm                            ; return name from expression} dac o_rnm  
orpl_:  d_word o_rpl                            ; pattern replacement} dac o_rpl  
orvl_:  d_word o_rvl                            ; return value from expression} dac o_rvl  
osla_:  d_word o_sla                            ; selection, first entry} dac o_sla  
oslb_:  d_word o_slb                            ; selection, second entry} dac o_slb  
oslc_:  d_word o_slc                            ; selection, third entry} dac o_slc  
osld_:  d_word o_sld                            ; selection, fourth entry} dac o_sld  
ostp_:  d_word o_stp                            ; stop execution} dac o_stp  
ounf_:  d_word o_unf                            ; unexpected failure} dac o_unf  
opsnb:  d_word ch_at                            ; at} dac ch_at  
        d_word ch_am                            ; ampersand} dac ch_am  
        d_word ch_nm                            ; number} dac ch_nm  
        d_word ch_pc                            ; percent} dac ch_pc  
        d_word ch_nt                            ; not} dac ch_nt  
opnsu:  d_word ch_br                            ; vertical bar} dac ch_br  
        d_word ch_eq                            ; equal} dac ch_eq  
        d_word ch_nm                            ; number} dac ch_nm  
        d_word ch_pc                            ; percent} dac ch_pc  
        d_word ch_sl                            ; slash} dac ch_sl  
        d_word ch_ex                            ; exclamation} dac ch_ex  
pfi2a:  d_word pf_i2                            ; } dac pf_i2  
pfms1:  d_word b_scl                            ; } dac b_scl  
        d_word 15                               ; } dac 15  
        d_char 'p','r','o','g','r','a','m',' ','p','r','o','f','i','l','e',0; } dtc /program profile/  
pfms2:  d_word b_scl                            ; } dac b_scl  
        d_word 42                               ; } dac 42  
        d_char 's','t','m','t',' ',' ',' ',' ','n','u','m','b','e','r',' ','o','f',' ',' ',' ',' ',' ','-','-',' ','e','x','e','c','u','t','i','o','n',' ','t','i','m','e',' ','-','-',0,0,0,0,0,0; } dtc /stmt    number of     -- execution time --/  
pfms3:  d_word b_scl                            ; } dac b_scl  
        d_word 47                               ; } dac 47  
        d_char 'n','u','m','b','e','r',' ',' ','e','x','e','c','u','t','i','o','n','s',' ',' ','t','o','t','a','l','(','m','s','e','c',')',' ','p','e','r',' ','e','x','c','n','(','m','c','s','e','c',')',0; } dtc /number  executions  total(msec) per excn(mcsec)/  
        align 8                                 ; 0.0} drc +0.0  
reav0:  d_real 0.0                              ; 
        align 8                                 ; 0.1} drc +0.1  
reap1:  d_real 0.1                              ; 
        align 8                                 ; 0.5} drc +0.5  
reap5:  d_real 0.5                              ; 
        align 8                                 ; 10**0} drc +1.0  
reav1:  d_real 1.0                              ; 
        align 8                                 ; 10**1} drc +1.0e+1  
reavt:  d_real 1.0e+1                           ; 
        align 8                                 ; 10**2} drc +1.0e+2  
        d_real 1.0e+2                           ; 
        align 8                                 ; 10**3} drc +1.0e+3  
        d_real 1.0e+3                           ; 
        align 8                                 ; 10**4} drc +1.0e+4  
        d_real 1.0e+4                           ; 
        align 8                                 ; 10**5} drc +1.0e+5  
        d_real 1.0e+5                           ; 
        align 8                                 ; 10**6} drc +1.0e+6  
        d_real 1.0e+6                           ; 
        align 8                                 ; 10**7} drc +1.0e+7  
        d_real 1.0e+7                           ; 
        align 8                                 ; 10**8} drc +1.0e+8  
        d_real 1.0e+8                           ; 
        align 8                                 ; 10**9} drc +1.0e+9  
        d_real 1.0e+9                           ; 
        align 8                                 ; 10**10} drc +1.0e+10  
reatt:  d_real 1.0e+10                          ; 
scarr:  d_word b_scl                            ; array} dac b_scl  
        d_word 5                                ; } dac 5  
        d_char 'a','r','r','a','y',0,0,0        ; } dtc /array/  
sccod:  d_word b_scl                            ; code} dac b_scl  
        d_word 4                                ; } dac 4  
        d_char 'c','o','d','e',0,0,0,0          ; } dtc /code/  
scexp:  d_word b_scl                            ; expression} dac b_scl  
        d_word 10                               ; } dac 10  
        d_char 'e','x','p','r','e','s','s','i','o','n',0,0,0,0,0,0; } dtc /expression/  
scext:  d_word b_scl                            ; external} dac b_scl  
        d_word 8                                ; } dac 8  
        d_char 'e','x','t','e','r','n','a','l'  ; } dtc /external/  
scint:  d_word b_scl                            ; integer} dac b_scl  
        d_word 7                                ; } dac 7  
        d_char 'i','n','t','e','g','e','r',0    ; } dtc /integer/  
scnam:  d_word b_scl                            ; name} dac b_scl  
        d_word 4                                ; } dac 4  
        d_char 'n','a','m','e',0,0,0,0          ; } dtc /name/  
scnum:  d_word b_scl                            ; numeric} dac b_scl  
        d_word 7                                ; } dac 7  
        d_char 'n','u','m','e','r','i','c',0    ; } dtc /numeric/  
scpat:  d_word b_scl                            ; pattern} dac b_scl  
        d_word 7                                ; } dac 7  
        d_char 'p','a','t','t','e','r','n',0    ; } dtc /pattern/  
screa:  d_word b_scl                            ; real} dac b_scl  
        d_word 4                                ; } dac 4  
        d_char 'r','e','a','l',0,0,0,0          ; } dtc /real/  
scstr:  d_word b_scl                            ; string} dac b_scl  
        d_word 6                                ; } dac 6  
        d_char 's','t','r','i','n','g',0,0      ; } dtc /string/  
sctab:  d_word b_scl                            ; table} dac b_scl  
        d_word 5                                ; } dac 5  
        d_char 't','a','b','l','e',0,0,0        ; } dtc /table/  
scfil:  d_word b_scl                            ; file (for extended load arguments)} dac b_scl  
        d_word 4                                ; } dac 4  
        d_char 'f','i','l','e',0,0,0,0          ; } dtc /file/  
scfrt:  d_word b_scl                            ; freturn} dac b_scl  
        d_word 7                                ; } dac 7  
        d_char 'f','r','e','t','u','r','n',0    ; } dtc /freturn/  
scnrt:  d_word b_scl                            ; nreturn} dac b_scl  
        d_word 7                                ; } dac 7  
        d_char 'n','r','e','t','u','r','n',0    ; } dtc /nreturn/  
scrtn:  d_word b_scl                            ; return} dac b_scl  
        d_word 6                                ; } dac 6  
        d_char 'r','e','t','u','r','n',0,0      ; } dtc /return/  
scnmt:  d_word scarr                            ; arblk     array} dac scarr  
        d_word sccod                            ; cdblk     code} dac sccod  
        d_word scexp                            ; exblk     expression} dac scexp  
        d_word scint                            ; icblk     integer} dac scint  
        d_word scnam                            ; nmblk     name} dac scnam  
        d_word scpat                            ; p0blk     pattern} dac scpat  
        d_word scpat                            ; p1blk     pattern} dac scpat  
        d_word scpat                            ; p2blk     pattern} dac scpat  
        d_word screa                            ; rcblk     real} dac screa  
        d_word scstr                            ; scblk     string} dac scstr  
        d_word scexp                            ; seblk     expression} dac scexp  
        d_word sctab                            ; tbblk     table} dac sctab  
        d_word scarr                            ; vcblk     array} dac scarr  
        d_word scext                            ; xnblk     external} dac scext  
        d_word scext                            ; xrblk     external} dac scext  
        d_word nulls                            ; bfblk     no buffer in this version} dac nulls  
scre0:  d_word b_scl                            ; } dac b_scl  
        d_word 2                                ; } dac 2  
        d_char '0','.',0,0,0,0,0,0              ; } dtc /0./  
stlim:  d_word +2147483647                      ; default statement limit} dic +2147483647  
stndf:  d_word o_fun                            ; ptr to undefined function err call} dac o_fun  
        d_word 0                                ; dummy fargs count for call circuit} dac 0  
stndl:  d_word l_und                            ; code ptr points to undefined lbl} dac l_und  
stndo:  d_word o_oun                            ; ptr to undefined operator err call} dac o_oun  
        d_word 0                                ; dummy fargs count for call circuit} dac 0  
stnvr:  d_word b_vrl                            ; vrget} dac b_vrl  
        d_word b_vrs                            ; vrsto} dac b_vrs  
        d_word nulls                            ; vrval} dac nulls  
        d_word b_vrg                            ; vrtra} dac b_vrg  
        d_word stndl                            ; vrlbl} dac stndl  
        d_word stndf                            ; vrfnc} dac stndf  
        d_word 0                                ; vrnxt} dac 0  
stpm1:  d_word b_scl                            ; in statement} dac b_scl  
        d_word 12                               ; } dac 12  
        d_char 'i','n',' ','s','t','a','t','e','m','e','n','t',0,0,0,0; } dtc /in statement/  
stpm2:  d_word b_scl                            ; } dac b_scl  
        d_word 14                               ; } dac 14  
        d_char 's','t','m','t','s',' ','e','x','e','c','u','t','e','d',0,0; } dtc /stmts executed/  
stpm3:  d_word b_scl                            ; } dac b_scl  
        d_word 20                               ; } dac 20  
        d_char 'e','x','e','c','u','t','i','o','n',' ','t','i','m','e',' ','m','s','e','c',' ',0,0,0,0; } dtc /execution time msec /  
stpm4:  d_word b_scl                            ; in line} dac b_scl  
        d_word 7                                ; } dac 7  
        d_char 'i','n',' ','l','i','n','e',0    ; } dtc /in line/  
stpm5:  d_word b_scl                            ; } dac b_scl  
        d_word 13                               ; } dac 13  
        d_char 'r','e','g','e','n','e','r','a','t','i','o','n','s',0,0,0; } dtc /regenerations/  
stpm6:  d_word b_scl                            ; in file} dac b_scl  
        d_word 7                                ; } dac 7  
        d_char 'i','n',' ','f','i','l','e',0    ; } dtc /in file/  
stpm7:  d_word b_scl                            ; } dac b_scl  
        d_word 15                               ; } dac 15  
        d_char 's','t','m','t',' ','/',' ','m','i','c','r','o','s','e','c',0; } dtc _stmt / microsec_  
stpm8:  d_word b_scl                            ; } dac b_scl  
        d_word 15                               ; } dac 15  
        d_char 's','t','m','t',' ','/',' ','m','i','l','l','i','s','e','c',0; } dtc _stmt / millisec_  
stpm9:  d_word b_scl                            ; } dac b_scl  
        d_word 13                               ; } dac 13  
        d_char 's','t','m','t',' ','/',' ','s','e','c','o','n','d',0,0,0; } dtc _stmt / second_  
strtu:  d_char 't','u',0,0,0,0,0,0              ; } dtc /tu/  
svctb:  d_word scstr                            ; string} dac scstr  
        d_word scint                            ; integer} dac scint  
        d_word scnam                            ; name} dac scnam  
        d_word scpat                            ; pattern} dac scpat  
        d_word scarr                            ; array} dac scarr  
        d_word sctab                            ; table} dac sctab  
        d_word scexp                            ; expression} dac scexp  
        d_word sccod                            ; code} dac sccod  
        d_word scnum                            ; numeric} dac scnum  
        d_word screa                            ; real} dac screa  
        d_word 0                                ; zero marks end of list} dac 0  
tmasb:  d_word b_scl                            ; asterisks for trace statement no} dac b_scl  
        d_word 13                               ; } dac 13  
        d_char '*','*','*','*','*','*','*','*','*','*','*','*',' ',0,0,0; } dtc /************ /  
tmbeb:  d_word b_scl                            ; blank-equal-blank} dac b_scl  
        d_word 3                                ; } dac 3  
        d_char ' ','=',' ',0,0,0,0,0            ; } dtc / = /  
trbev:  d_word b_trt                            ; dummy trblk} dac b_trt  
trbkv:  d_word b_trt                            ; dummy trblk} dac b_trt  
trxdr:  d_word o_txr                            ; block points to return routine} dac o_txr  
trxdc:  d_word trxdr                            ; pointer to block} dac trxdr  
v_eqf:  d_word svfpr                            ; eq} dbc svfpr  
        d_word 2                                ; } dac 2  
        d_char 'e','q',0,0,0,0,0,0              ; } dtc /eq/  
        d_word s_eqf                            ; } dac s_eqf  
        d_word 2                                ; } dac 2  
v_gef:  d_word svfpr                            ; ge} dbc svfpr  
        d_word 2                                ; } dac 2  
        d_char 'g','e',0,0,0,0,0,0              ; } dtc /ge/  
        d_word s_gef                            ; } dac s_gef  
        d_word 2                                ; } dac 2  
v_gtf:  d_word svfpr                            ; gt} dbc svfpr  
        d_word 2                                ; } dac 2  
        d_char 'g','t',0,0,0,0,0,0              ; } dtc /gt/  
        d_word s_gtf                            ; } dac s_gtf  
        d_word 2                                ; } dac 2  
v_lef:  d_word svfpr                            ; le} dbc svfpr  
        d_word 2                                ; } dac 2  
        d_char 'l','e',0,0,0,0,0,0              ; } dtc /le/  
        d_word s_lef                            ; } dac s_lef  
        d_word 2                                ; } dac 2  
v_lnf:  d_word svfnp                            ; ln} dbc svfnp  
        d_word 2                                ; } dac 2  
        d_char 'l','n',0,0,0,0,0,0              ; } dtc /ln/  
        d_word s_lnf                            ; } dac s_lnf  
        d_word 1                                ; } dac 1  
v_ltf:  d_word svfpr                            ; lt} dbc svfpr  
        d_word 2                                ; } dac 2  
        d_char 'l','t',0,0,0,0,0,0              ; } dtc /lt/  
        d_word s_ltf                            ; } dac s_ltf  
        d_word 2                                ; } dac 2  
v_nef:  d_word svfpr                            ; ne} dbc svfpr  
        d_word 2                                ; } dac 2  
        d_char 'n','e',0,0,0,0,0,0              ; } dtc /ne/  
        d_word s_nef                            ; } dac s_nef  
        d_word 2                                ; } dac 2  
v_any:  d_word svfnp                            ; any} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 'a','n','y',0,0,0,0,0            ; } dtc /any/  
        d_word s_any                            ; } dac s_any  
        d_word 1                                ; } dac 1  
v_arb:  d_word svkvc                            ; arb} dbc svkvc  
        d_word 3                                ; } dac 3  
        d_char 'a','r','b',0,0,0,0,0            ; } dtc /arb/  
        d_word k_arb                            ; } dac k_arb  
        d_word ndarb                            ; } dac ndarb  
v_arg:  d_word svfnn                            ; arg} dbc svfnn  
        d_word 3                                ; } dac 3  
        d_char 'a','r','g',0,0,0,0,0            ; } dtc /arg/  
        d_word s_arg                            ; } dac s_arg  
        d_word 2                                ; } dac 2  
v_bal:  d_word svkvc                            ; bal} dbc svkvc  
        d_word 3                                ; } dac 3  
        d_char 'b','a','l',0,0,0,0,0            ; } dtc /bal/  
        d_word k_bal                            ; } dac k_bal  
        d_word ndbal                            ; } dac ndbal  
v_cos:  d_word svfnp                            ; cos} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 'c','o','s',0,0,0,0,0            ; } dtc /cos/  
        d_word s_cos                            ; } dac s_cos  
        d_word 1                                ; } dac 1  
v_end:  d_word svlbl                            ; end} dbc svlbl  
        d_word 3                                ; } dac 3  
        d_char 'e','n','d',0,0,0,0,0            ; } dtc /end/  
        d_word l_end                            ; } dac l_end  
v_exp:  d_word svfnp                            ; exp} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 'e','x','p',0,0,0,0,0            ; } dtc /exp/  
        d_word s_exp                            ; } dac s_exp  
        d_word 1                                ; } dac 1  
v_len:  d_word svfnp                            ; len} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 'l','e','n',0,0,0,0,0            ; } dtc /len/  
        d_word s_len                            ; } dac s_len  
        d_word 1                                ; } dac 1  
v_leq:  d_word svfpr                            ; leq} dbc svfpr  
        d_word 3                                ; } dac 3  
        d_char 'l','e','q',0,0,0,0,0            ; } dtc /leq/  
        d_word s_leq                            ; } dac s_leq  
        d_word 2                                ; } dac 2  
v_lge:  d_word svfpr                            ; lge} dbc svfpr  
        d_word 3                                ; } dac 3  
        d_char 'l','g','e',0,0,0,0,0            ; } dtc /lge/  
        d_word s_lge                            ; } dac s_lge  
        d_word 2                                ; } dac 2  
v_lgt:  d_word svfpr                            ; lgt} dbc svfpr  
        d_word 3                                ; } dac 3  
        d_char 'l','g','t',0,0,0,0,0            ; } dtc /lgt/  
        d_word s_lgt                            ; } dac s_lgt  
        d_word 2                                ; } dac 2  
v_lle:  d_word svfpr                            ; lle} dbc svfpr  
        d_word 3                                ; } dac 3  
        d_char 'l','l','e',0,0,0,0,0            ; } dtc /lle/  
        d_word s_lle                            ; } dac s_lle  
        d_word 2                                ; } dac 2  
v_llt:  d_word svfpr                            ; llt} dbc svfpr  
        d_word 3                                ; } dac 3  
        d_char 'l','l','t',0,0,0,0,0            ; } dtc /llt/  
        d_word s_llt                            ; } dac s_llt  
        d_word 2                                ; } dac 2  
v_lne:  d_word svfpr                            ; lne} dbc svfpr  
        d_word 3                                ; } dac 3  
        d_char 'l','n','e',0,0,0,0,0            ; } dtc /lne/  
        d_word s_lne                            ; } dac s_lne  
        d_word 2                                ; } dac 2  
v_pos:  d_word svfnp                            ; pos} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 'p','o','s',0,0,0,0,0            ; } dtc /pos/  
        d_word s_pos                            ; } dac s_pos  
        d_word 1                                ; } dac 1  
v_rem:  d_word svkvc                            ; rem} dbc svkvc  
        d_word 3                                ; } dac 3  
        d_char 'r','e','m',0,0,0,0,0            ; } dtc /rem/  
        d_word k_rem                            ; } dac k_rem  
        d_word ndrem                            ; } dac ndrem  
v_sin:  d_word svfnp                            ; sin} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 's','i','n',0,0,0,0,0            ; } dtc /sin/  
        d_word s_sin                            ; } dac s_sin  
        d_word 1                                ; } dac 1  
v_tab:  d_word svfnp                            ; tab} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 't','a','b',0,0,0,0,0            ; } dtc /tab/  
        d_word s_tab                            ; } dac s_tab  
        d_word 1                                ; } dac 1  
v_tan:  d_word svfnp                            ; tan} dbc svfnp  
        d_word 3                                ; } dac 3  
        d_char 't','a','n',0,0,0,0,0            ; } dtc /tan/  
        d_word s_tan                            ; } dac s_tan  
        d_word 1                                ; } dac 1  
v_atn:  d_word svfnp                            ; atan} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 'a','t','a','n',0,0,0,0          ; } dtc /atan/  
        d_word s_atn                            ; } dac s_atn  
        d_word 1                                ; } dac 1  
v_cas:  d_word svknm                            ; case} dbc svknm  
        d_word 4                                ; } dac 4  
        d_char 'c','a','s','e',0,0,0,0          ; } dtc /case/  
        d_word k_cas                            ; } dac k_cas  
v_chr:  d_word svfnp                            ; char} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 'c','h','a','r',0,0,0,0          ; } dtc /char/  
        d_word s_chr                            ; } dac s_chr  
        d_word 1                                ; } dac 1  
v_chp:  d_word svfnp                            ; chop} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 'c','h','o','p',0,0,0,0          ; } dtc /chop/  
        d_word s_chp                            ; } dac s_chp  
        d_word 1                                ; } dac 1  
v_cod:  d_word svfnk                            ; code} dbc svfnk  
        d_word 4                                ; } dac 4  
        d_char 'c','o','d','e',0,0,0,0          ; } dtc /code/  
        d_word k_cod                            ; } dac k_cod  
        d_word s_cod                            ; } dac s_cod  
        d_word 1                                ; } dac 1  
v_cop:  d_word svfnn                            ; copy} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'c','o','p','y',0,0,0,0          ; } dtc /copy/  
        d_word s_cop                            ; } dac s_cop  
        d_word 1                                ; } dac 1  
v_dat:  d_word svfnn                            ; data} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'd','a','t','a',0,0,0,0          ; } dtc /data/  
        d_word s_dat                            ; } dac s_dat  
        d_word 1                                ; } dac 1  
v_dte:  d_word svfnn                            ; date} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'd','a','t','e',0,0,0,0          ; } dtc /date/  
        d_word s_dte                            ; } dac s_dte  
        d_word 1                                ; } dac 1  
v_dmp:  d_word svfnk                            ; dump} dbc svfnk  
        d_word 4                                ; } dac 4  
        d_char 'd','u','m','p',0,0,0,0          ; } dtc /dump/  
        d_word k_dmp                            ; } dac k_dmp  
        d_word s_dmp                            ; } dac s_dmp  
        d_word 1                                ; } dac 1  
v_dup:  d_word svfnn                            ; dupl} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'd','u','p','l',0,0,0,0          ; } dtc /dupl/  
        d_word s_dup                            ; } dac s_dup  
        d_word 2                                ; } dac 2  
v_evl:  d_word svfnn                            ; eval} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'e','v','a','l',0,0,0,0          ; } dtc /eval/  
        d_word s_evl                            ; } dac s_evl  
        d_word 1                                ; } dac 1  
v_ext:  d_word svfnn                            ; exit} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'e','x','i','t',0,0,0,0          ; } dtc /exit/  
        d_word s_ext                            ; } dac s_ext  
        d_word 2                                ; } dac 2  
v_fal:  d_word svkvc                            ; fail} dbc svkvc  
        d_word 4                                ; } dac 4  
        d_char 'f','a','i','l',0,0,0,0          ; } dtc /fail/  
        d_word k_fal                            ; } dac k_fal  
        d_word ndfal                            ; } dac ndfal  
v_fil:  d_word svknm                            ; file} dbc svknm  
        d_word 4                                ; } dac 4  
        d_char 'f','i','l','e',0,0,0,0          ; } dtc /file/  
        d_word k_fil                            ; } dac k_fil  
v_hst:  d_word svfnn                            ; host} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'h','o','s','t',0,0,0,0          ; } dtc /host/  
        d_word s_hst                            ; } dac s_hst  
        d_word 5                                ; } dac 5  
v_itm:  d_word svfnf                            ; item} dbc svfnf  
        d_word 4                                ; } dac 4  
        d_char 'i','t','e','m',0,0,0,0          ; } dtc /item/  
        d_word s_itm                            ; } dac s_itm  
        d_word 999                              ; } dac 999  
v_lin:  d_word svknm                            ; line} dbc svknm  
        d_word 4                                ; } dac 4  
        d_char 'l','i','n','e',0,0,0,0          ; } dtc /line/  
        d_word k_lin                            ; } dac k_lin  
v_lod:  d_word svfnn                            ; load} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 'l','o','a','d',0,0,0,0          ; } dtc /load/  
        d_word s_lod                            ; } dac s_lod  
        d_word 2                                ; } dac 2  
v_lpd:  d_word svfnp                            ; lpad} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 'l','p','a','d',0,0,0,0          ; } dtc /lpad/  
        d_word s_lpd                            ; } dac s_lpd  
        d_word 3                                ; } dac 3  
v_rpd:  d_word svfnp                            ; rpad} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 'r','p','a','d',0,0,0,0          ; } dtc /rpad/  
        d_word s_rpd                            ; } dac s_rpd  
        d_word 3                                ; } dac 3  
v_rps:  d_word svfnp                            ; rpos} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 'r','p','o','s',0,0,0,0          ; } dtc /rpos/  
        d_word s_rps                            ; } dac s_rps  
        d_word 1                                ; } dac 1  
v_rtb:  d_word svfnp                            ; rtab} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 'r','t','a','b',0,0,0,0          ; } dtc /rtab/  
        d_word s_rtb                            ; } dac s_rtb  
        d_word 1                                ; } dac 1  
v_si_:  d_word svfnp                            ; size} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 's','i','z','e',0,0,0,0          ; } dtc /size/  
        d_word s_si_                            ; } dac s_si_  
        d_word 1                                ; } dac 1  
v_srt:  d_word svfnn                            ; sort} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 's','o','r','t',0,0,0,0          ; } dtc /sort/  
        d_word s_srt                            ; } dac s_srt  
        d_word 2                                ; } dac 2  
v_spn:  d_word svfnp                            ; span} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 's','p','a','n',0,0,0,0          ; } dtc /span/  
        d_word s_spn                            ; } dac s_spn  
        d_word 1                                ; } dac 1  
v_sqr:  d_word svfnp                            ; sqrt} dbc svfnp  
        d_word 4                                ; } dac 4  
        d_char 's','q','r','t',0,0,0,0          ; } dtc /sqrt/  
        d_word s_sqr                            ; } dac s_sqr  
        d_word 1                                ; } dac 1  
v_stn:  d_word svknm                            ; stno} dbc svknm  
        d_word 4                                ; } dac 4  
        d_char 's','t','n','o',0,0,0,0          ; } dtc /stno/  
        d_word k_stn                            ; } dac k_stn  
v_tim:  d_word svfnn                            ; time} dbc svfnn  
        d_word 4                                ; } dac 4  
        d_char 't','i','m','e',0,0,0,0          ; } dtc /time/  
        d_word s_tim                            ; } dac s_tim  
        d_word 0                                ; } dac 0  
v_trm:  d_word svfnk                            ; trim} dbc svfnk  
        d_word 4                                ; } dac 4  
        d_char 't','r','i','m',0,0,0,0          ; } dtc /trim/  
        d_word k_trm                            ; } dac k_trm  
        d_word s_trm                            ; } dac s_trm  
        d_word 1                                ; } dac 1  
v_abe:  d_word svknm                            ; abend} dbc svknm  
        d_word 5                                ; } dac 5  
        d_char 'a','b','e','n','d',0,0,0        ; } dtc /abend/  
        d_word k_abe                            ; } dac k_abe  
v_abo:  d_word svkvl                            ; abort} dbc svkvl  
        d_word 5                                ; } dac 5  
        d_char 'a','b','o','r','t',0,0,0        ; } dtc /abort/  
        d_word k_abo                            ; } dac k_abo  
        d_word l_abo                            ; } dac l_abo  
        d_word ndabo                            ; } dac ndabo  
v_app:  d_word svfnf                            ; apply} dbc svfnf  
        d_word 5                                ; } dac 5  
        d_char 'a','p','p','l','y',0,0,0        ; } dtc /apply/  
        d_word s_app                            ; } dac s_app  
        d_word 999                              ; } dac 999  
v_abn:  d_word svfnp                            ; arbno} dbc svfnp  
        d_word 5                                ; } dac 5  
        d_char 'a','r','b','n','o',0,0,0        ; } dtc /arbno/  
        d_word s_abn                            ; } dac s_abn  
        d_word 1                                ; } dac 1  
v_arr:  d_word svfnn                            ; array} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 'a','r','r','a','y',0,0,0        ; } dtc /array/  
        d_word s_arr                            ; } dac s_arr  
        d_word 2                                ; } dac 2  
v_brk:  d_word svfnp                            ; break} dbc svfnp  
        d_word 5                                ; } dac 5  
        d_char 'b','r','e','a','k',0,0,0        ; } dtc /break/  
        d_word s_brk                            ; } dac s_brk  
        d_word 1                                ; } dac 1  
v_clr:  d_word svfnn                            ; clear} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 'c','l','e','a','r',0,0,0        ; } dtc /clear/  
        d_word s_clr                            ; } dac s_clr  
        d_word 1                                ; } dac 1  
v_ejc:  d_word svfnn                            ; eject} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 'e','j','e','c','t',0,0,0        ; } dtc /eject/  
        d_word s_ejc                            ; } dac s_ejc  
        d_word 1                                ; } dac 1  
v_fen:  d_word svfpk                            ; fence} dbc svfpk  
        d_word 5                                ; } dac 5  
        d_char 'f','e','n','c','e',0,0,0        ; } dtc /fence/  
        d_word k_fen                            ; } dac k_fen  
        d_word s_fnc                            ; } dac s_fnc  
        d_word 1                                ; } dac 1  
        d_word ndfen                            ; } dac ndfen  
v_fld:  d_word svfnn                            ; field} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 'f','i','e','l','d',0,0,0        ; } dtc /field/  
        d_word s_fld                            ; } dac s_fld  
        d_word 2                                ; } dac 2  
v_idn:  d_word svfpr                            ; ident} dbc svfpr  
        d_word 5                                ; } dac 5  
        d_char 'i','d','e','n','t',0,0,0        ; } dtc /ident/  
        d_word s_idn                            ; } dac s_idn  
        d_word 2                                ; } dac 2  
v_inp:  d_word svfnk                            ; input} dbc svfnk  
        d_word 5                                ; } dac 5  
        d_char 'i','n','p','u','t',0,0,0        ; } dtc /input/  
        d_word k_inp                            ; } dac k_inp  
        d_word s_inp                            ; } dac s_inp  
        d_word 3                                ; } dac 3  
v_lcs:  d_word svkwc                            ; lcase} dbc svkwc  
        d_word 5                                ; } dac 5  
        d_char 'l','c','a','s','e',0,0,0        ; } dtc /lcase/  
        d_word k_lcs                            ; } dac k_lcs  
v_loc:  d_word svfnn                            ; local} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 'l','o','c','a','l',0,0,0        ; } dtc /local/  
        d_word s_loc                            ; } dac s_loc  
        d_word 2                                ; } dac 2  
v_ops:  d_word svfnn                            ; opsyn} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 'o','p','s','y','n',0,0,0        ; } dtc /opsyn/  
        d_word s_ops                            ; } dac s_ops  
        d_word 3                                ; } dac 3  
v_rmd:  d_word svfnp                            ; remdr} dbc svfnp  
        d_word 5                                ; } dac 5  
        d_char 'r','e','m','d','r',0,0,0        ; } dtc /remdr/  
        d_word s_rmd                            ; } dac s_rmd  
        d_word 2                                ; } dac 2  
v_rsr:  d_word svfnn                            ; rsort} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 'r','s','o','r','t',0,0,0        ; } dtc /rsort/  
        d_word s_rsr                            ; } dac s_rsr  
        d_word 2                                ; } dac 2  
v_tbl:  d_word svfnn                            ; table} dbc svfnn  
        d_word 5                                ; } dac 5  
        d_char 't','a','b','l','e',0,0,0        ; } dtc /table/  
        d_word s_tbl                            ; } dac s_tbl  
        d_word 3                                ; } dac 3  
v_tra:  d_word svfnk                            ; trace} dbc svfnk  
        d_word 5                                ; } dac 5  
        d_char 't','r','a','c','e',0,0,0        ; } dtc /trace/  
        d_word k_tra                            ; } dac k_tra  
        d_word s_tra                            ; } dac s_tra  
        d_word 4                                ; } dac 4  
v_ucs:  d_word svkwc                            ; ucase} dbc svkwc  
        d_word 5                                ; } dac 5  
        d_char 'u','c','a','s','e',0,0,0        ; } dtc /ucase/  
        d_word k_ucs                            ; } dac k_ucs  
v_anc:  d_word svknm                            ; anchor} dbc svknm  
        d_word 6                                ; } dac 6  
        d_char 'a','n','c','h','o','r',0,0      ; } dtc /anchor/  
        d_word k_anc                            ; } dac k_anc  
v_bkx:  d_word svfnp                            ; breakx} dbc svfnp  
        d_word 6                                ; } dac 6  
        d_char 'b','r','e','a','k','x',0,0      ; } dtc /breakx/  
        d_word s_bkx                            ; } dac s_bkx  
        d_word 1                                ; } dac 1  
v_def:  d_word svfnn                            ; define} dbc svfnn  
        d_word 6                                ; } dac 6  
        d_char 'd','e','f','i','n','e',0,0      ; } dtc /define/  
        d_word s_def                            ; } dac s_def  
        d_word 2                                ; } dac 2  
v_det:  d_word svfnn                            ; detach} dbc svfnn  
        d_word 6                                ; } dac 6  
        d_char 'd','e','t','a','c','h',0,0      ; } dtc /detach/  
        d_word s_det                            ; } dac s_det  
        d_word 1                                ; } dac 1  
v_dif:  d_word svfpr                            ; differ} dbc svfpr  
        d_word 6                                ; } dac 6  
        d_char 'd','i','f','f','e','r',0,0      ; } dtc /differ/  
        d_word s_dif                            ; } dac s_dif  
        d_word 2                                ; } dac 2  
v_ftr:  d_word svknm                            ; ftrace} dbc svknm  
        d_word 6                                ; } dac 6  
        d_char 'f','t','r','a','c','e',0,0      ; } dtc /ftrace/  
        d_word k_ftr                            ; } dac k_ftr  
v_lst:  d_word svknm                            ; lastno} dbc svknm  
        d_word 6                                ; } dac 6  
        d_char 'l','a','s','t','n','o',0,0      ; } dtc /lastno/  
        d_word k_lst                            ; } dac k_lst  
v_nay:  d_word svfnp                            ; notany} dbc svfnp  
        d_word 6                                ; } dac 6  
        d_char 'n','o','t','a','n','y',0,0      ; } dtc /notany/  
        d_word s_nay                            ; } dac s_nay  
        d_word 1                                ; } dac 1  
v_oup:  d_word svfnk                            ; output} dbc svfnk  
        d_word 6                                ; } dac 6  
        d_char 'o','u','t','p','u','t',0,0      ; } dtc /output/  
        d_word k_oup                            ; } dac k_oup  
        d_word s_oup                            ; } dac s_oup  
        d_word 3                                ; } dac 3  
v_ret:  d_word svlbl                            ; return} dbc svlbl  
        d_word 6                                ; } dac 6  
        d_char 'r','e','t','u','r','n',0,0      ; } dtc /return/  
        d_word l_rtn                            ; } dac l_rtn  
v_rew:  d_word svfnn                            ; rewind} dbc svfnn  
        d_word 6                                ; } dac 6  
        d_char 'r','e','w','i','n','d',0,0      ; } dtc /rewind/  
        d_word s_rew                            ; } dac s_rew  
        d_word 1                                ; } dac 1  
v_stt:  d_word svfnn                            ; stoptr} dbc svfnn  
        d_word 6                                ; } dac 6  
        d_char 's','t','o','p','t','r',0,0      ; } dtc /stoptr/  
        d_word s_stt                            ; } dac s_stt  
        d_word 2                                ; } dac 2  
v_sub:  d_word svfnn                            ; substr} dbc svfnn  
        d_word 6                                ; } dac 6  
        d_char 's','u','b','s','t','r',0,0      ; } dtc /substr/  
        d_word s_sub                            ; } dac s_sub  
        d_word 3                                ; } dac 3  
v_unl:  d_word svfnn                            ; unload} dbc svfnn  
        d_word 6                                ; } dac 6  
        d_char 'u','n','l','o','a','d',0,0      ; } dtc /unload/  
        d_word s_unl                            ; } dac s_unl  
        d_word 1                                ; } dac 1  
v_col:  d_word svfnn                            ; collect} dbc svfnn  
        d_word 7                                ; } dac 7  
        d_char 'c','o','l','l','e','c','t',0    ; } dtc /collect/  
        d_word s_col                            ; } dac s_col  
        d_word 1                                ; } dac 1  
v_com:  d_word svknm                            ; compare} dbc svknm  
        d_word 7                                ; } dac 7  
        d_char 'c','o','m','p','a','r','e',0    ; } dtc /compare/  
        d_word k_com                            ; } dac k_com  
v_cnv:  d_word svfnn                            ; convert} dbc svfnn  
        d_word 7                                ; } dac 7  
        d_char 'c','o','n','v','e','r','t',0    ; } dtc /convert/  
        d_word s_cnv                            ; } dac s_cnv  
        d_word 2                                ; } dac 2  
v_enf:  d_word svfnn                            ; endfile} dbc svfnn  
        d_word 7                                ; } dac 7  
        d_char 'e','n','d','f','i','l','e',0    ; } dtc /endfile/  
        d_word s_enf                            ; } dac s_enf  
        d_word 1                                ; } dac 1  
v_etx:  d_word svknm                            ; errtext} dbc svknm  
        d_word 7                                ; } dac 7  
        d_char 'e','r','r','t','e','x','t',0    ; } dtc /errtext/  
        d_word k_etx                            ; } dac k_etx  
v_ert:  d_word svknm                            ; errtype} dbc svknm  
        d_word 7                                ; } dac 7  
        d_char 'e','r','r','t','y','p','e',0    ; } dtc /errtype/  
        d_word k_ert                            ; } dac k_ert  
v_frt:  d_word svlbl                            ; freturn} dbc svlbl  
        d_word 7                                ; } dac 7  
        d_char 'f','r','e','t','u','r','n',0    ; } dtc /freturn/  
        d_word l_frt                            ; } dac l_frt  
v_int:  d_word svfpr                            ; integer} dbc svfpr  
        d_word 7                                ; } dac 7  
        d_char 'i','n','t','e','g','e','r',0    ; } dtc /integer/  
        d_word s_int                            ; } dac s_int  
        d_word 1                                ; } dac 1  
v_nrt:  d_word svlbl                            ; nreturn} dbc svlbl  
        d_word 7                                ; } dac 7  
        d_char 'n','r','e','t','u','r','n',0    ; } dtc /nreturn/  
        d_word l_nrt                            ; } dac l_nrt  
v_pfl:  d_word svknm                            ; profile} dbc svknm  
        d_word 7                                ; } dac 7  
        d_char 'p','r','o','f','i','l','e',0    ; } dtc /profile/  
        d_word k_pfl                            ; } dac k_pfl  
v_rpl:  d_word svfnp                            ; replace} dbc svfnp  
        d_word 7                                ; } dac 7  
        d_char 'r','e','p','l','a','c','e',0    ; } dtc /replace/  
        d_word s_rpl                            ; } dac s_rpl  
        d_word 3                                ; } dac 3  
v_rvs:  d_word svfnp                            ; reverse} dbc svfnp  
        d_word 7                                ; } dac 7  
        d_char 'r','e','v','e','r','s','e',0    ; } dtc /reverse/  
        d_word s_rvs                            ; } dac s_rvs  
        d_word 1                                ; } dac 1  
v_rtn:  d_word svknm                            ; rtntype} dbc svknm  
        d_word 7                                ; } dac 7  
        d_char 'r','t','n','t','y','p','e',0    ; } dtc /rtntype/  
        d_word k_rtn                            ; } dac k_rtn  
v_stx:  d_word svfnn                            ; setexit} dbc svfnn  
        d_word 7                                ; } dac 7  
        d_char 's','e','t','e','x','i','t',0    ; } dtc /setexit/  
        d_word s_stx                            ; } dac s_stx  
        d_word 1                                ; } dac 1  
v_stc:  d_word svknm                            ; stcount} dbc svknm  
        d_word 7                                ; } dac 7  
        d_char 's','t','c','o','u','n','t',0    ; } dtc /stcount/  
        d_word k_stc                            ; } dac k_stc  
v_stl:  d_word svknm                            ; stlimit} dbc svknm  
        d_word 7                                ; } dac 7  
        d_char 's','t','l','i','m','i','t',0    ; } dtc /stlimit/  
        d_word k_stl                            ; } dac k_stl  
v_suc:  d_word svkvc                            ; succeed} dbc svkvc  
        d_word 7                                ; } dac 7  
        d_char 's','u','c','c','e','e','d',0    ; } dtc /succeed/  
        d_word k_suc                            ; } dac k_suc  
        d_word ndsuc                            ; } dac ndsuc  
v_alp:  d_word svkwc                            ; alphabet} dbc svkwc  
        d_word 8                                ; } dac 8  
        d_char 'a','l','p','h','a','b','e','t'  ; } dtc /alphabet/  
        d_word k_alp                            ; } dac k_alp  
v_cnt:  d_word svlbl                            ; continue} dbc svlbl  
        d_word 8                                ; } dac 8  
        d_char 'c','o','n','t','i','n','u','e'  ; } dtc /continue/  
        d_word l_cnt                            ; } dac l_cnt  
v_dtp:  d_word svfnp                            ; datatype} dbc svfnp  
        d_word 8                                ; } dac 8  
        d_char 'd','a','t','a','t','y','p','e'  ; } dtc /datatype/  
        d_word s_dtp                            ; } dac s_dtp  
        d_word 1                                ; } dac 1  
v_erl:  d_word svknm                            ; errlimit} dbc svknm  
        d_word 8                                ; } dac 8  
        d_char 'e','r','r','l','i','m','i','t'  ; } dtc /errlimit/  
        d_word k_erl                            ; } dac k_erl  
v_fnc:  d_word svknm                            ; fnclevel} dbc svknm  
        d_word 8                                ; } dac 8  
        d_char 'f','n','c','l','e','v','e','l'  ; } dtc /fnclevel/  
        d_word k_fnc                            ; } dac k_fnc  
v_fls:  d_word svknm                            ; fullscan} dbc svknm  
        d_word 8                                ; } dac 8  
        d_char 'f','u','l','l','s','c','a','n'  ; } dtc /fullscan/  
        d_word k_fls                            ; } dac k_fls  
v_lfl:  d_word svknm                            ; lastfile} dbc svknm  
        d_word 8                                ; } dac 8  
        d_char 'l','a','s','t','f','i','l','e'  ; } dtc /lastfile/  
        d_word k_lfl                            ; } dac k_lfl  
v_lln:  d_word svknm                            ; lastline} dbc svknm  
        d_word 8                                ; } dac 8  
        d_char 'l','a','s','t','l','i','n','e'  ; } dtc /lastline/  
        d_word k_lln                            ; } dac k_lln  
v_mxl:  d_word svknm                            ; maxlngth} dbc svknm  
        d_word 8                                ; } dac 8  
        d_char 'm','a','x','l','n','g','t','h'  ; } dtc /maxlngth/  
        d_word k_mxl                            ; } dac k_mxl  
v_ter:  d_word 0                                ; terminal} dbc 0  
        d_word 8                                ; } dac 8  
        d_char 't','e','r','m','i','n','a','l'  ; } dtc /terminal/  
        d_word 0                                ; } dac 0  
v_bsp:  d_word svfnn                            ; backspace} dbc svfnn  
        d_word 9                                ; } dac 9  
        d_char 'b','a','c','k','s','p','a','c','e',0,0,0,0,0,0,0; } dtc /backspace/  
        d_word s_bsp                            ; } dac s_bsp  
        d_word 1                                ; } dac 1  
v_pro:  d_word svfnn                            ; prototype} dbc svfnn  
        d_word 9                                ; } dac 9  
        d_char 'p','r','o','t','o','t','y','p','e',0,0,0,0,0,0,0; } dtc /prototype/  
        d_word s_pro                            ; } dac s_pro  
        d_word 1                                ; } dac 1  
v_scn:  d_word svlbl                            ; scontinue} dbc svlbl  
        d_word 9                                ; } dac 9  
        d_char 's','c','o','n','t','i','n','u','e',0,0,0,0,0,0,0; } dtc /scontinue/  
        d_word l_scn                            ; } dac l_scn  
        d_word 0                                ; dummy entry to end list} dbc 0  
        d_word 10                               ; length gt 9 (scontinue)} dac 10  
vdmkw:  d_word v_anc                            ; anchor} dac v_anc  
        d_word v_cas                            ; ccase} dac v_cas  
        d_word v_cod                            ; code} dac v_cod  
        d_word 1                                ; compare not printed} dac 1  
        d_word v_dmp                            ; dump} dac v_dmp  
        d_word v_erl                            ; errlimit} dac v_erl  
        d_word v_etx                            ; errtext} dac v_etx  
        d_word v_ert                            ; errtype} dac v_ert  
        d_word v_fil                            ; file} dac v_fil  
        d_word v_fnc                            ; fnclevel} dac v_fnc  
        d_word v_ftr                            ; ftrace} dac v_ftr  
        d_word v_fls                            ; fullscan} dac v_fls  
        d_word v_inp                            ; input} dac v_inp  
        d_word v_lfl                            ; lastfile} dac v_lfl  
        d_word v_lln                            ; lastline} dac v_lln  
        d_word v_lst                            ; lastno} dac v_lst  
        d_word v_lin                            ; line} dac v_lin  
        d_word v_mxl                            ; maxlength} dac v_mxl  
        d_word v_oup                            ; output} dac v_oup  
        d_word v_pfl                            ; profile} dac v_pfl  
        d_word v_rtn                            ; rtntype} dac v_rtn  
        d_word v_stc                            ; stcount} dac v_stc  
        d_word v_stl                            ; stlimit} dac v_stl  
        d_word v_stn                            ; stno} dac v_stn  
        d_word v_tra                            ; trace} dac v_tra  
        d_word v_trm                            ; trim} dac v_trm  
        d_word 0                                ; end of list} dac 0  
vsrch:  d_word 0                                ; dummy entry to get proper indexing} dac 0  
        d_word v_eqf                            ; start of 1 char variables (none)} dac v_eqf  
        d_word v_eqf                            ; start of 2 char variables} dac v_eqf  
        d_word v_any                            ; start of 3 char variables} dac v_any  
        d_word v_atn                            ; start of 4 char variables} dac v_atn  
        d_word v_abe                            ; start of 5 char variables} dac v_abe  
        d_word v_anc                            ; start of 6 char variables} dac v_anc  
        d_word v_col                            ; start of 7 char variables} dac v_col  
        d_word v_alp                            ; start of 8 char variables} dac v_alp  
        d_word v_bsp                            ; start of 9 char variables} dac v_bsp  
c_yyy:  d_word 0                                ; last location in constant section} dac 0  
                                                ; start of working storage section} sec   
        global esec03                           ; 
esec03:                                         ; 
        segment .data                           ; 
        global sec04                            ; 
sec04:                                          ; 
cmlab:  d_word b_scl                            ; string used to check label legality} dac b_scl  
        d_word 2                                ; } dac 2  
        d_char ' ',' ',0,0,0,0,0,0              ; } dtc /  /  
w_aaa:  d_word 0                                ; } dac 0  
actrm:  d_word 0                                ; trim indicator} dac 0  
aldyn:  d_word 0                                ; amount of dynamic store} dac 0  
allia:  d_word +0                               ; dump ia} dic +0  
allsv:  d_word 0                                ; save wb in alloc} dac 0  
alsta:  d_word 0                                ; save wa in alost} dac 0  
arcdm:  d_word 0                                ; count dimensions} dac 0  
arnel:  d_word +0                               ; count elements} dic +0  
arptr:  d_word 0                                ; offset ptr into arblk} dac 0  
arsvl:  d_word +0                               ; save integer low bound} dic +0  
arfsi:  d_word +0                               ; save current evolving subscript} dic +0  
arfxs:  d_word 0                                ; save base stack pointer} dac 0  
befof:  d_word 0                                ; save offset ptr into efblk} dac 0  
bpfpf:  d_word 0                                ; save pfblk pointer} dac 0  
bpfsv:  d_word 0                                ; save old function value} dac 0  
bpfxt:  d_word 0                                ; pointer to stacked arguments} dac 0  
clsvi:  d_word +0                               ; save integer argument} dic +0  
cnscc:  d_word 0                                ; pointer to control card string} dac 0  
cnswc:  d_word 0                                ; word count} dac 0  
cnr_t:  d_word 0                                ; pointer to r_ttl or r_stl} dac 0  
cnvtp:  d_word 0                                ; save ptr into scvtb} dac 0  
datdv:  d_word 0                                ; save vrblk ptr for datatype name} dac 0  
datxs:  d_word 0                                ; save initial stack pointer} dac 0  
deflb:  d_word 0                                ; save vrblk ptr for label} dac 0  
defna:  d_word 0                                ; count function arguments} dac 0  
defvr:  d_word 0                                ; save vrblk ptr for function name} dac 0  
defxs:  d_word 0                                ; save initial stack pointer} dac 0  
dmarg:  d_word 0                                ; dump argument} dac 0  
dmpsa:  d_word 0                                ; preserve wa over prtvl call} dac 0  
dmpsb:  d_word 0                                ; preserve wb over syscm call} dac 0  
dmpsv:  d_word 0                                ; general scratch save} dac 0  
dmvch:  d_word 0                                ; chain pointer for variable blocks} dac 0  
dmpch:  d_word 0                                ; save sorted vrblk chain pointer} dac 0  
dmpkb:  d_word 0                                ; dummy kvblk for use in dumpr} dac 0  
dmpkt:  d_word 0                                ; kvvar trblk ptr (must follow dmpkb)} dac 0  
dmpkn:  d_word 0                                ; keyword number (must follow dmpkt)} dac 0  
dtcnb:  d_word 0                                ; name base} dac 0  
dtcnm:  d_word 0                                ; name ptr} dac 0  
dupsi:  d_word +0                               ; store integer string length} dic +0  
enfch:  d_word 0                                ; for iochn chain head} dac 0  
ertwa:  d_word 0                                ; save wa} dac 0  
ertwb:  d_word 0                                ; save wb} dac 0  
evlin:  d_word 0                                ; dummy pattern block pcode} dac 0  
evlis:  d_word 0                                ; then node (must follow evlin)} dac 0  
evliv:  d_word 0                                ; value of parm1 (must follow evlis)} dac 0  
evlio:  d_word 0                                ; ptr to original node} dac 0  
evlif:  d_word 0                                ; flag for simple/complex argument} dac 0  
expsv:  d_word 0                                ; save op dope vector pointer} dac 0  
gbcfl:  d_word 0                                ; garbage collector active flag} dac 0  
gbclm:  d_word 0                                ; pointer to last move block (pass 3)} dac 0  
gbcnm:  d_word 0                                ; dummy first move block} dac 0  
gbcns:  d_word 0                                ; rest of dummy block (follows gbcnm)} dac 0  
gbcia:  d_word +0                               ; dump ia} dic +0  
gbcsd:  d_word 0                                ; first address beyond sediment} dac 0  
gbcsf:  d_word 0                                ; free space within sediment} dac 0  
gbsva:  d_word 0                                ; save wa} dac 0  
gbsvb:  d_word 0                                ; save wb} dac 0  
gbsvc:  d_word 0                                ; save wc} dac 0  
gnvhe:  d_word 0                                ; ptr to end of hash chain} dac 0  
gnvnw:  d_word 0                                ; number of words in string name} dac 0  
gnvsa:  d_word 0                                ; save wa} dac 0  
gnvsb:  d_word 0                                ; save wb} dac 0  
gnvsp:  d_word 0                                ; pointer into vsrch table} dac 0  
gnvst:  d_word 0                                ; pointer to chars of string} dac 0  
gtawa:  d_word 0                                ; save wa} dac 0  
gtina:  d_word 0                                ; save wa} dac 0  
gtinb:  d_word 0                                ; save wb} dac 0  
gtnnf:  d_word 0                                ; zero/nonzero for result +/-} dac 0  
gtnsi:  d_word +0                               ; general integer save} dic +0  
gtndf:  d_word 0                                ; 0/1 for dec point so far no/yes} dac 0  
gtnes:  d_word 0                                ; zero/nonzero exponent +/-} dac 0  
gtnex:  d_word +0                               ; real exponent} dic +0  
gtnsc:  d_word 0                                ; scale (places after point)} dac 0  
        align 8                                 ; general real save} drc +0.0  
gtnsr:  d_real 0.0                              ; 
gtnrd:  d_word 0                                ; flag for ok real number} dac 0  
gtpsb:  d_word 0                                ; save wb} dac 0  
gtssf:  d_word 0                                ; 0/1 for result +/-} dac 0  
gtsvc:  d_word 0                                ; save wc} dac 0  
gtsvb:  d_word 0                                ; save wb} dac 0  
gtses:  d_word 0                                ; char + or - for exponent +/-} dac 0  
        align 8                                 ; general real save} drc +0.0  
gtsrs:  d_real 0.0                              ; 
gtvrc:  d_word 0                                ; save wc} dac 0  
ioptt:  d_word 0                                ; type of association} dac 0  
lodfn:  d_word 0                                ; pointer to vrblk for func name} dac 0  
lodna:  d_word 0                                ; count number of arguments} dac 0  
mxint:  d_word 0                                ; } dac 0  
pfsvw:  d_word 0                                ; to save a w-reg} dac 0  
prnsi:  d_word +0                               ; scratch integer loc} dic +0  
prsna:  d_word 0                                ; save wa} dac 0  
prsva:  d_word 0                                ; save wa} dac 0  
prsvb:  d_word 0                                ; save wb} dac 0  
prsvc:  d_word 0                                ; save char counter} dac 0  
prtsa:  d_word 0                                ; save wa} dac 0  
prtsb:  d_word 0                                ; save wb} dac 0  
prvsi:  d_word 0                                ; save idval} dac 0  
psave:  d_word 0                                ; temporary save for current node ptr} dac 0  
psavc:  d_word 0                                ; save cursor in p_spn, p_str} dac 0  
rlals:  d_word 0                                ; ptr to list of bounds and adjusts} dac 0  
rldcd:  d_word 0                                ; save code adjustment} dac 0  
rldst:  d_word 0                                ; save static adjustment} dac 0  
rldls:  d_word 0                                ; save list pointer} dac 0  
rtnbp:  d_word 0                                ; to save a block pointer} dac 0  
rtnfv:  d_word 0                                ; new function value (result)} dac 0  
rtnsv:  d_word 0                                ; old function value (saved value)} dac 0  
sbssv:  d_word 0                                ; save third argument} dac 0  
scnsa:  d_word 0                                ; save wa} dac 0  
scnsb:  d_word 0                                ; save wb} dac 0  
scnsc:  d_word 0                                ; save wc} dac 0  
scnof:  d_word 0                                ; save offset} dac 0  
srtdf:  d_word 0                                ; datatype field name} dac 0  
srtfd:  d_word 0                                ; found dfblk address} dac 0  
srtff:  d_word 0                                ; found field name} dac 0  
srtfo:  d_word 0                                ; offset to field name} dac 0  
srtnr:  d_word 0                                ; number of rows} dac 0  
srtof:  d_word 0                                ; offset within row to sort key} dac 0  
srtrt:  d_word 0                                ; root offset} dac 0  
srts1:  d_word 0                                ; save offset 1} dac 0  
srts2:  d_word 0                                ; save offset 2} dac 0  
srtsc:  d_word 0                                ; save wc} dac 0  
srtsf:  d_word 0                                ; sort array first row offset} dac 0  
srtsn:  d_word 0                                ; save n} dac 0  
srtso:  d_word 0                                ; offset to a(0)} dac 0  
srtsr:  d_word 0                                ; 0, non-zero for sort, rsort} dac 0  
srtst:  d_word 0                                ; stride from one row to next} dac 0  
srtwc:  d_word 0                                ; dump wc} dac 0  
stpsi:  d_word +0                               ; save value of stcount} dic +0  
stpti:  d_word +0                               ; save time elapsed} dic +0  
tfnsi:  d_word +0                               ; number of headers} dic +0  
xscrt:  d_word 0                                ; save return code} dac 0  
xscwb:  d_word 0                                ; save register wb} dac 0  
g_aaa:  d_word 0                                ; } dac 0  
alfsf:  d_word +0                               ; factor in free store pcntage check} dic +0  
cmerc:  d_word 0                                ; count of initial compile errors} dac 0  
cmpln:  d_word 0                                ; line number of first line of stmt} dac 0  
cmpxs:  d_word 0                                ; save stack ptr in case of errors} dac 0  
cmpsn:  d_word 1                                ; number of next statement to compile} dac 1  
cnsil:  d_word 0                                ; save scnil during include process.} dac 0  
cnind:  d_word 0                                ; current include file nest level} dac 0  
cnspt:  d_word 0                                ; save scnpt during include process.} dac 0  
cnttl:  d_word 0                                ; flag for -title, -stitl} dac 0  
cpsts:  d_word 0                                ; suppress comp. stats if non zero} dac 0  
cswdb:  d_word 0                                ; 0/1 for -single/-double} dac 0  
cswer:  d_word 0                                ; 0/1 for -errors/-noerrors} dac 0  
cswex:  d_word 0                                ; 0/1 for -execute/-noexecute} dac 0  
cswfl:  d_word 1                                ; 0/1 for -nofail/-fail} dac 1  
cswin:  d_word iniln                            ; xxx for -inxxx} dac iniln  
cswls:  d_word 1                                ; 0/1 for -nolist/-list} dac 1  
cswno:  d_word 0                                ; 0/1 for -optimise/-noopt} dac 0  
cswpr:  d_word 0                                ; 0/1 for -noprint/-print} dac 0  
ctmsk:  d_word 0                                ; last bit position used in r_ctp} dbc 0  
curid:  d_word 0                                ; current id value} dac 0  
cwcof:  d_word 0                                ; next word offset in current ccblk} dac 0  
dnams:  d_word 0                                ; size of sediment in baus} dac 0  
erich:  d_word 0                                ; copy error reports to int.chan if 1} dac 0  
erlst:  d_word 0                                ; for listr when errors go to int.ch.} dac 0  
errft:  d_word 0                                ; fatal error flag} dac 0  
errsp:  d_word 0                                ; error suppression flag} dac 0  
exsts:  d_word 0                                ; suppress exec stats if set} dac 0  
flprt:  d_word 0                                ; location of fail offset for return} dac 0  
flptr:  d_word 0                                ; location of failure offset on stack} dac 0  
gbsed:  d_word +0                               ; factor in sediment pcntage check} dic +0  
gbcnt:  d_word 0                                ; count of garbage collections} dac 0  
gtcef:  d_word 0                                ; save fail ptr in case of error} dac 0  
        align 8                                 ; rounding factor 0.5*10**-cfp_s} drc +0.0  
gtsrn:  d_real 0.0                              ; 
        align 8                                 ; scaling value 10**cfp_s} drc +0.0  
gtssc:  d_real 0.0                              ; 
gtswk:  d_word 0                                ; ptr to work area for gtstg} dac 0  
headp:  d_word 0                                ; header printed flag} dac 0  
hshnb:  d_word +0                               ; number of hash buckets} dic +0  
initr:  d_word 0                                ; save terminal flag} dac 0  
kvabe:  d_word 0                                ; abend} dac 0  
kvanc:  d_word 0                                ; anchor} dac 0  
kvcas:  d_word 0                                ; case} dac 0  
kvcod:  d_word 0                                ; code} dac 0  
kvcom:  d_word 0                                ; compare} dac 0  
kvdmp:  d_word 0                                ; dump} dac 0  
kverl:  d_word 0                                ; errlimit} dac 0  
kvert:  d_word 0                                ; errtype} dac 0  
kvftr:  d_word 0                                ; ftrace} dac 0  
kvfls:  d_word 1                                ; fullscan} dac 1  
kvinp:  d_word 1                                ; input} dac 1  
kvmxl:  d_word 5000                             ; maxlength} dac 5000  
kvoup:  d_word 1                                ; output} dac 1  
kvpfl:  d_word 0                                ; profile} dac 0  
kvtra:  d_word 0                                ; trace} dac 0  
kvtrm:  d_word 1                                ; trim} dac 1  
kvfnc:  d_word 0                                ; fnclevel} dac 0  
kvlst:  d_word 0                                ; lastno} dac 0  
kvlln:  d_word 0                                ; lastline} dac 0  
kvlin:  d_word 0                                ; line} dac 0  
kvstn:  d_word 0                                ; stno} dac 0  
kvalp:  d_word 0                                ; alphabet} dac 0  
kvrtn:  d_word nulls                            ; rtntype (scblk pointer)} dac nulls  
kvstl:  d_word +2147483647                      ; stlimit} dic +2147483647  
kvstc:  d_word +2147483647                      ; stcount (counts down from stlimit)} dic +2147483647  
lstid:  d_word 0                                ; include depth of current image} dac 0  
lstlc:  d_word 0                                ; count lines on source list page} dac 0  
lstnp:  d_word 0                                ; max number of lines on page} dac 0  
lstpf:  d_word 1                                ; set nonzero if current image listed} dac 1  
lstpg:  d_word 0                                ; current source list page number} dac 0  
lstpo:  d_word 0                                ; offset to   page nnn   message} dac 0  
lstsn:  d_word 0                                ; remember last stmnum listed} dac 0  
mxlen:  d_word 0                                ; initialised by sysmx call} dac 0  
noxeq:  d_word 0                                ; set non-zero to inhibit execution} dac 0  
pfdmp:  d_word 0                                ; set non-0 if &profile set non-0} dac 0  
pffnc:  d_word 0                                ; set non-0 if funct just entered} dac 0  
pfstm:  d_word +0                               ; to store starting time of stmt} dic +0  
pfetm:  d_word +0                               ; to store ending time of stmt} dic +0  
pfnte:  d_word 0                                ; nr of table entries} dac 0  
pfste:  d_word +0                               ; gets int rep of table entry size} dic +0  
pmdfl:  d_word 0                                ; pattern assignment flag} dac 0  
pmhbs:  d_word 0                                ; history stack base pointer} dac 0  
pmssl:  d_word 0                                ; length of subject string in chars} dac 0  
polcs:  d_word 1                                ; poll interval start value} dac 1  
polct:  d_word 1                                ; poll interval counter} dac 1  
prich:  d_word 0                                ; printer on interactive channel} dac 0  
prstd:  d_word 0                                ; tested by prtpg} dac 0  
prsto:  d_word 0                                ; standard listing option flag} dac 0  
prbuf:  d_word 0                                ; ptr to print bfr in static} dac 0  
precl:  d_word 0                                ; extended/compact listing flag} dac 0  
prlen:  d_word 0                                ; length of print buffer in chars} dac 0  
prlnw:  d_word 0                                ; length of print buffer in words} dac 0  
profs:  d_word 0                                ; offset to next location in prbuf} dac 0  
prtef:  d_word 0                                ; endfile flag} dac 0  
rdcln:  d_word 0                                ; current statement line number} dac 0  
rdnln:  d_word 0                                ; next statement line number} dac 0  
rsmem:  d_word 0                                ; reserve memory} dac 0  
stmcs:  d_word 1                                ; counter startup value} dac 1  
stmct:  d_word 1                                ; counter active value} dac 1  
a_aaa:  d_word 0                                ; start of adjustable values} dac 0  
cmpss:  d_word 0                                ; save subroutine stack ptr} dac 0  
dnamb:  d_word 0                                ; start of dynamic area} dac 0  
dnamp:  d_word 0                                ; next available loc in dynamic area} dac 0  
dname:  d_word 0                                ; end of available dynamic area} dac 0  
hshtb:  d_word 0                                ; pointer to start of vrblk hash tabl} dac 0  
hshte:  d_word 0                                ; pointer past end of vrblk hash tabl} dac 0  
iniss:  d_word 0                                ; save subroutine stack ptr} dac 0  
pftbl:  d_word 0                                ; gets adrs of (imag) table base} dac 0  
prnmv:  d_word 0                                ; vrblk ptr from last name search} dac 0  
statb:  d_word 0                                ; start of static area} dac 0  
state:  d_word 0                                ; end of static area} dac 0  
stxvr:  d_word nulls                            ; vrblk pointer or null} dac nulls  
r_aaa:  d_word 0                                ; start of relocatable values} dac 0  
r_arf:  d_word 0                                ; array block pointer for arref} dac 0  
r_ccb:  d_word 0                                ; ptr to ccblk being built (cdwrd)} dac 0  
r_cim:  d_word 0                                ; ptr to current compiler input str} dac 0  
r_cmp:  d_word 0                                ; copy of r_cim used in cmpil} dac 0  
r_cni:  d_word 0                                ; ptr to next compiler input string} dac 0  
r_cnt:  d_word 0                                ; cdblk pointer for setexit continue} dac 0  
r_cod:  d_word 0                                ; pointer to current cdblk or exblk} dac 0  
r_ctp:  d_word 0                                ; ptr to current ctblk for patst} dac 0  
r_cts:  d_word 0                                ; ptr to last string scanned by patst} dac 0  
r_ert:  d_word 0                                ; trblk pointer for errtype trace} dac 0  
r_etx:  d_word nulls                            ; pointer to errtext string} dac nulls  
r_exs:  d_word 0                                ; = save xl in expdm} dac 0  
r_fcb:  d_word 0                                ; fcblk chain head} dac 0  
r_fnc:  d_word 0                                ; trblk pointer for fnclevel trace} dac 0  
r_gtc:  d_word 0                                ; keep code ptr for gtcod,gtexp} dac 0  
r_ici:  d_word 0                                ; saved r_cim during include process.} dac 0  
r_ifa:  d_word 0                                ; array of file names by incl. depth} dac 0  
r_ifl:  d_word 0                                ; array of line nums by include depth} dac 0  
r_ifn:  d_word 0                                ; last include file name} dac 0  
r_inc:  d_word 0                                ; table of include file names seen} dac 0  
r_io1:  d_word 0                                ; file arg1 for ioput} dac 0  
r_io2:  d_word 0                                ; file arg2 for ioput} dac 0  
r_iof:  d_word 0                                ; fcblk ptr or 0} dac 0  
r_ion:  d_word 0                                ; name base ptr} dac 0  
r_iop:  d_word 0                                ; predecessor block ptr for ioput} dac 0  
r_iot:  d_word 0                                ; trblk ptr for ioput} dac 0  
r_pms:  d_word 0                                ; subject string ptr in pattern match} dac 0  
r_ra2:  d_word 0                                ; replace second argument last time} dac 0  
r_ra3:  d_word 0                                ; replace third argument last time} dac 0  
r_rpt:  d_word 0                                ; ptr to ctblk replace table last usd} dac 0  
r_scp:  d_word 0                                ; save pointer from last scane call} dac 0  
r_sfc:  d_word nulls                            ; current source file name} dac nulls  
r_sfn:  d_word 0                                ; ptr to source file name table} dac 0  
r_sxl:  d_word 0                                ; preserve xl in sortc} dac 0  
r_sxr:  d_word 0                                ; preserve xr in sorta/sortc} dac 0  
r_stc:  d_word 0                                ; trblk pointer for stcount trace} dac 0  
r_stl:  d_word 0                                ; source listing sub-title} dac 0  
r_sxc:  d_word 0                                ; code (cdblk) ptr for setexit trap} dac 0  
r_ttl:  d_word nulls                            ; source listing title} dac nulls  
r_xsc:  d_word 0                                ; string pointer for xscan} dac 0  
r_uba:  d_word stndo                            ; binary at} dac stndo  
r_ubm:  d_word stndo                            ; binary ampersand} dac stndo  
r_ubn:  d_word stndo                            ; binary number sign} dac stndo  
r_ubp:  d_word stndo                            ; binary percent} dac stndo  
r_ubt:  d_word stndo                            ; binary not} dac stndo  
r_uub:  d_word stndo                            ; unary vertical bar} dac stndo  
r_uue:  d_word stndo                            ; unary equal} dac stndo  
r_uun:  d_word stndo                            ; unary number sign} dac stndo  
r_uup:  d_word stndo                            ; unary percent} dac stndo  
r_uus:  d_word stndo                            ; unary slash} dac stndo  
r_uux:  d_word stndo                            ; unary exclamation} dac stndo  
r_yyy:  d_word 0                                ; last relocatable location} dac 0  
scnbl:  d_word 0                                ; set non-zero if scanned past blanks} dac 0  
scncc:  d_word 0                                ; non-zero to scan control card name} dac 0  
scngo:  d_word 0                                ; set non-zero to scan goto field} dac 0  
scnil:  d_word 0                                ; length of current input image} dac 0  
scnpt:  d_word 0                                ; pointer to next location in r_cim} dac 0  
scnrs:  d_word 0                                ; set non-zero to signal rescan} dac 0  
scnse:  d_word 0                                ; start of current element} dac 0  
scntp:  d_word 0                                ; save syntax type from last call} dac 0  
stage:  d_word 0                                ; initial value = initial compile} dac 0  
stbas:  d_word 0                                ; pointer past stack base} dac 0  
stxoc:  d_word 0                                ; code pointer offset} dac 0  
stxof:  d_word 0                                ; failure offset} dac 0  
timsx:  d_word +0                               ; time at start of execution} dic +0  
timup:  d_word 0                                ; set when time up occurs} dac 0  
xsofs:  d_word 0                                ; offset to current location in r_xsc} dac 0  
w_yyy:  d_word 0                                ; } dac 0  
                                                ; start of program section} sec   
        global esec04                           ; 
esec04:                                         ; 
prc_:   times 19 dq 0                           ; 
        global lowspmin                         ; 
lowspmin: d_word 0                              ; 
        global end_min_data                     ; 
end_min_data:                                   ; 
        segment .text                           ; 
        global sec05                            ; 
sec05:                                          ; 
        align 2                                 ; mark start of code} ent bl__i  
        db   bl__i                              ; 
s_aaa:                                          ; 
relaj:
                                                ; entry point} prc e 0 
        push xr                                 ; save xr} mov -(xs) xr 
        push wa                                 ; save wa} mov -(xs) wa 
        mov  m_word [rlals],xl                  ; save ptr to list of bounds} mov rlals xl 
        mov  xr,wb                              ; ptr to first pointer to process} mov xr wb 
rlaj0:
        mov  xl,m_word [rlals]                  ; restore xl} mov xl rlals 
        cmp  xr,m_word [xs]                     ; proceed if more to do} bne xr (xs) rlaj1
        jne  rlaj1                              ; 
        pop  wa                                 ; restore wa} mov wa (xs)+ 
        pop  xr                                 ; restore xr} mov xr (xs)+ 
        ret                                     ; return to caller} exi   
rlaj1:
        mov  wa,m_word [xr]                     ; load next pointer on list} mov wa (xr) 
        mov  wb,rnsi_                           ; number of sections of adjusters} lct wb =rnsi_ 
rlaj2:
        cmp  wa,m_word [(cfp_b*rlend)+xl]       ; ok if past end of section} bgt wa rlend(xl) rlaj3
        ja   rlaj3                              ; 
        cmp  wa,m_word [(cfp_b*rlstr)+xl]       ; or if before start of section} blt wa rlstr(xl) rlaj3
        jb   rlaj3                              ; 
        add  wa,m_word [(cfp_b*rladj)+xl]       ; within section, add adjustment} add wa rladj(xl) 
        mov  m_word [xr],wa                     ; return updated ptr to memory} mov (xr) wa 
        jmp  rlaj4                              ; done with this pointer} brn rlaj4  
rlaj3:
        add  xl,cfp_b*rssi_                     ; advance to next section} add xl *rssi_ 
        dec  wb                                 ; jump if more to go} bct wb rlaj2 
        jnz  rlaj2                              ; 
rlaj4:
        add  xr,cfp_b                           ; increment to next ptr on list} ica xr  
        jmp  rlaj0                              ; jump to check  for completion} brn rlaj0  
                                                ; end procedure relaj} enp   
relcr:
                                                ; entry point} prc e 0 
        add  xl,cfp_b*rlsi_                     ; point past build area} add xl *rlsi_ 
        lea  xl,[xl-cfp_b]                      ; save original code address} mov -(xl) wa 
        mov  m_word [xl],wa                     ; 
        mov  wa,s_aaa                           ; compute adjustment} mov wa =s_aaa 
        sub  wa,m_word [xl]                     ; as new s_aaa minus original s_aaa} sub wa (xl) 
        lea  xl,[xl-cfp_b]                      ; save code adjustment} mov -(xl) wa 
        mov  m_word [xl],wa                     ; 
        mov  wa,s_yyy                           ; end of target code section} mov wa =s_yyy 
        sub  wa,s_aaa                           ; length of code section} sub wa =s_aaa 
        add  wa,m_word [(cfp_b*num01)+xl]       ; plus original start address} add wa num01(xl) 
        lea  xl,[xl-cfp_b]                      ; end of original code section} mov -(xl) wa 
        mov  m_word [xl],wa                     ; 
        lea  xl,[xl-cfp_b]                      ; save constant section address} mov -(xl) wb 
        mov  m_word [xl],wb                     ; 
        mov  wb,c_aaa                           ; start of constants section} mov wb =c_aaa 
        mov  wa,c_yyy                           ; end of constants section} mov wa =c_yyy 
        sub  wa,wb                              ; length of constants section} sub wa wb 
        sub  wb,m_word [xl]                     ; new c_aaa minus original c_aaa} sub wb (xl) 
        lea  xl,[xl-cfp_b]                      ; save constant adjustment} mov -(xl) wb 
        mov  m_word [xl],wb                     ; 
        add  wa,m_word [(cfp_b*num01)+xl]       ; length plus original start adr} add wa num01(xl) 
        lea  xl,[xl-cfp_b]                      ; save as end of original constants} mov -(xl) wa 
        mov  m_word [xl],wa                     ; 
        lea  xl,[xl-cfp_b]                      ; save working globals address} mov -(xl) wc 
        mov  m_word [xl],wc                     ; 
        mov  wc,g_aaa                           ; start of working globals section} mov wc =g_aaa 
        mov  wa,w_yyy                           ; end of working section} mov wa =w_yyy 
        sub  wa,wc                              ; length of working globals} sub wa wc 
        sub  wc,m_word [xl]                     ; new g_aaa minus original g_aaa} sub wc (xl) 
        lea  xl,[xl-cfp_b]                      ; save working globals adjustment} mov -(xl) wc 
        mov  m_word [xl],wc                     ; 
        add  wa,m_word [(cfp_b*num01)+xl]       ; length plus original start adr} add wa num01(xl) 
        lea  xl,[xl-cfp_b]                      ; save as end of working globals} mov -(xl) wa 
        mov  m_word [xl],wa                     ; 
        mov  wb,m_word [statb]                  ; old start of static region} mov wb statb 
        lea  xl,[xl-cfp_b]                      ; save} mov -(xl) wb 
        mov  m_word [xl],wb                     ; 
        sub  xr,wb                              ; compute adjustment} sub xr wb 
        lea  xl,[xl-cfp_b]                      ; save new statb minus old statb} mov -(xl) xr 
        mov  m_word [xl],xr                     ; 
        lea  xl,[xl-cfp_b]                      ; old end of static region} mov -(xl) state 
        mov  w0,m_word [state]                  ; 
        mov  m_word [xl],w0                     ; 
        mov  wb,m_word [dnamb]                  ; old start of dynamic region} mov wb dnamb 
        lea  xl,[xl-cfp_b]                      ; save} mov -(xl) wb 
        mov  m_word [xl],wb                     ; 
        mov  wa,r13                             ; new start of dynamic} scp wa  
        sub  wa,wb                              ; compute adjustment} sub wa wb 
        lea  xl,[xl-cfp_b]                      ; save new dnamb minus old dnamb} mov -(xl) wa 
        mov  m_word [xl],wa                     ; 
        mov  wc,m_word [dnamp]                  ; old end of dynamic region in use} mov wc dnamp 
        lea  xl,[xl-cfp_b]                      ; save as end of old dynamic region} mov -(xl) wc 
        mov  m_word [xl],wc                     ; 
        ret                                     ; } exi   
                                                ; } enp   
reldn:
                                                ; entry point} prc e 0 
        mov  w0,m_word [(cfp_b*rlcda)+xl]       ; save code adjustment} mov rldcd rlcda(xl) 
        mov  m_word [rldcd],w0                  ; 
        mov  w0,m_word [(cfp_b*rlsta)+xl]       ; save static adjustment} mov rldst rlsta(xl) 
        mov  m_word [rldst],w0                  ; 
        mov  m_word [rldls],xl                  ; save list pointer} mov rldls xl 
rld01:
        mov  w0,m_word [rldcd]                  ; adjust block type word} add (xr) rldcd 
        add  m_word [xr],w0                     ; 
        mov  xl,m_word [xr]                     ; load block type word} mov xl (xr) 
        movzx xl,byte [xl-1]                    ; load entry point id (bl_xx)} lei xl  
        jmp  m_word [_l0001+xl*cfp_b]           ; switch on block type} bsw xl bl___ 
        segment .data                           ; 
_l0001:                                         ; 
        d_word rld03                            ; arblk} iff bl_ar rld03 
        d_word rld07                            ; cdblk} iff bl_cd rld07 
        d_word rld10                            ; exblk} iff bl_ex rld10 
        d_word rld05                            ; icblk} iff bl_ic rld05 
        d_word rld13                            ; nmblk} iff bl_nm rld13 
        d_word rld13                            ; p0blk} iff bl_p0 rld13 
        d_word rld14                            ; p1blk} iff bl_p1 rld14 
        d_word rld14                            ; p2blk} iff bl_p2 rld14 
        d_word rld05                            ; rcblk} iff bl_rc rld05 
        d_word rld05                            ; scblk} iff bl_sc rld05 
        d_word rld13                            ; seblk} iff bl_se rld13 
        d_word rld17                            ; tbblk} iff bl_tb rld17 
        d_word rld17                            ; vcblk} iff bl_vc rld17 
        d_word rld05                            ; xnblk} iff bl_xn rld05 
        d_word rld20                            ; xrblk} iff bl_xr rld20 
        d_word rld05                            ; bcblk - dummy to fill out iffs} iff bl_bc rld05 
        d_word rld15                            ; pdblk} iff bl_pd rld15 
        d_word rld19                            ; trblk} iff bl_tr rld19 
        d_word rld05                            ; bfblk} iff bl_bf rld05 
        d_word rld05                            ; ccblk} iff bl_cc rld05 
        d_word rld05                            ; cmblk} iff bl_cm rld05 
        d_word rld05                            ; ctblk} iff bl_ct rld05 
        d_word rld05                            ; dfblk} iff bl_df rld05 
        d_word rld08                            ; efblk} iff bl_ef rld08 
        d_word rld09                            ; evblk} iff bl_ev rld09 
        d_word rld11                            ; ffblk} iff bl_ff rld11 
        d_word rld13                            ; kvblk} iff bl_kv rld13 
        d_word rld16                            ; pfblk} iff bl_pf rld16 
        d_word rld18                            ; teblk} iff bl_te rld18 
        segment .text                           ; end of jump table} esw   
rld03:
        mov  wa,m_word [(cfp_b*arlen)+xr]       ; load length} mov wa arlen(xr) 
        mov  wb,m_word [(cfp_b*arofs)+xr]       ; set offset to 1st reloc fld (arpro)} mov wb arofs(xr) 
rld04:
        add  wa,xr                              ; point past last reloc field} add wa xr 
        add  wb,xr                              ; point to first reloc field} add wb xr 
        mov  xl,m_word [rldls]                  ; point to list of bounds} mov xl rldls 
        call relaj                              ; adjust pointers} jsr relaj  
rld05:
        mov  wa,m_word [xr]                     ; block type word} mov wa (xr) 
        call blkln                              ; get length of block} jsr blkln  
        add  xr,wa                              ; point to next block} add xr wa 
        cmp  xr,wc                              ; continue if more to process} blt xr wc rld01
        jb   rld01                              ; 
        mov  xl,m_word [rldls]                  ; restore xl} mov xl rldls 
        ret                                     ; return to caller if done} exi   
rld07:
        mov  wa,m_word [(cfp_b*cdlen)+xr]       ; load length} mov wa cdlen(xr) 
        mov  wb,cfp_b*cdfal                     ; set offset} mov wb *cdfal 
        cmp  m_word [xr],b_cdc                  ; jump back if not complex goto} bne (xr) =b_cdc rld04
        jne  rld04                              ; 
        mov  wb,cfp_b*cdcod                     ; do not process cdfal word} mov wb *cdcod 
        jmp  rld04                              ; jump back} brn rld04  
rld08:
        mov  wa,cfp_b*efrsl                     ; set length} mov wa *efrsl 
        mov  wb,cfp_b*efcod                     ; and offset} mov wb *efcod 
        jmp  rld04                              ; all set} brn rld04  
rld09:
        mov  wa,cfp_b*offs3                     ; point past third field} mov wa *offs3 
        mov  wb,cfp_b*evexp                     ; set offset} mov wb *evexp 
        jmp  rld04                              ; all set} brn rld04  
rld10:
        mov  wa,m_word [(cfp_b*exlen)+xr]       ; load length} mov wa exlen(xr) 
        mov  wb,cfp_b*exflc                     ; set offset} mov wb *exflc 
        jmp  rld04                              ; jump back} brn rld04  
rld11:
        cmp  m_word [(cfp_b*ffofs)+xr],cfp_b*pdfld      ; skip dfblk if not first field} bne ffofs(xr) *pdfld rld12
        jne  rld12                              ; 
        push xr                                 ; save xr} mov -(xs) xr 
        mov  xr,m_word [(cfp_b*ffdfp)+xr]       ; load old ptr to dfblk} mov xr ffdfp(xr) 
        add  xr,m_word [rldst]                  ; current location of dfblk} add xr rldst 
        mov  w0,m_word [rldcd]                  ; adjust dfblk type word} add (xr) rldcd 
        add  m_word [xr],w0                     ; 
        mov  wa,m_word [(cfp_b*dflen)+xr]       ; length of dfblk} mov wa dflen(xr) 
        mov  wb,cfp_b*dfnam                     ; offset to dfnam field} mov wb *dfnam 
        add  wa,xr                              ; point past last reloc field} add wa xr 
        add  wb,xr                              ; point to first reloc field} add wb xr 
        mov  xl,m_word [rldls]                  ; point to list of bounds} mov xl rldls 
        call relaj                              ; adjust pointers} jsr relaj  
        mov  xr,m_word [(cfp_b*dfnam)+xr]       ; pointer to static scblk} mov xr dfnam(xr) 
        mov  w0,m_word [rldcd]                  ; adjust scblk type word} add (xr) rldcd 
        add  m_word [xr],w0                     ; 
        pop  xr                                 ; restore ffblk pointer} mov xr (xs)+ 
rld12:
        mov  wa,cfp_b*ffofs                     ; set length} mov wa *ffofs 
        mov  wb,cfp_b*ffdfp                     ; set offset} mov wb *ffdfp 
        jmp  rld04                              ; all set} brn rld04  
rld13:
        mov  wa,cfp_b*offs2                     ; point past second field} mov wa *offs2 
        mov  wb,cfp_b*offs1                     ; offset is one (only reloc fld is 2)} mov wb *offs1 
        jmp  rld04                              ; all set} brn rld04  
rld14:
        mov  wa,cfp_b*parm2                     ; length (parm2 is non-relocatable)} mov wa *parm2 
        mov  wb,cfp_b*pthen                     ; set offset} mov wb *pthen 
        jmp  rld04                              ; all set} brn rld04  
rld15:
        mov  xl,m_word [(cfp_b*pddfp)+xr]       ; load ptr to dfblk} mov xl pddfp(xr) 
        add  xl,m_word [rldst]                  ; adjust for static relocation} add xl rldst 
        mov  wa,m_word [(cfp_b*dfpdl)+xl]       ; get pdblk length} mov wa dfpdl(xl) 
        mov  wb,cfp_b*pddfp                     ; set offset} mov wb *pddfp 
        jmp  rld04                              ; all set} brn rld04  
rld16:
        mov  w0,m_word [rldst]                  ; adjust non-contiguous field} add pfvbl(xr) rldst 
        add  m_word [(cfp_b*pfvbl)+xr],w0       ; 
        mov  wa,m_word [(cfp_b*pflen)+xr]       ; get pfblk length} mov wa pflen(xr) 
        mov  wb,cfp_b*pfcod                     ; offset to first reloc} mov wb *pfcod 
        jmp  rld04                              ; all set} brn rld04  
rld17:
        mov  wa,m_word [(cfp_b*offs2)+xr]       ; load length} mov wa offs2(xr) 
        mov  wb,cfp_b*offs3                     ; set offset} mov wb *offs3 
        jmp  rld04                              ; jump back} brn rld04  
rld18:
        mov  wa,cfp_b*tesi_                     ; set length} mov wa *tesi_ 
        mov  wb,cfp_b*tesub                     ; and offset} mov wb *tesub 
        jmp  rld04                              ; all set} brn rld04  
rld19:
        mov  wa,cfp_b*trsi_                     ; set length} mov wa *trsi_ 
        mov  wb,cfp_b*trval                     ; and offset} mov wb *trval 
        jmp  rld04                              ; all set} brn rld04  
rld20:
        mov  wa,m_word [(cfp_b*xrlen)+xr]       ; load length} mov wa xrlen(xr) 
        mov  wb,cfp_b*xrptr                     ; set offset} mov wb *xrptr 
        jmp  rld04                              ; jump back} brn rld04  
                                                ; end procedure reldn} enp   
reloc:
                                                ; entry point} prc e 0 
        mov  xr,m_word [(cfp_b*rldys)+xl]       ; old start of dynamic} mov xr rldys(xl) 
        mov  wc,m_word [(cfp_b*rldye)+xl]       ; old end of dynamic} mov wc rldye(xl) 
        add  xr,m_word [(cfp_b*rldya)+xl]       ; create new start of dynamic} add xr rldya(xl) 
        add  wc,m_word [(cfp_b*rldya)+xl]       ; create new end of dynamic} add wc rldya(xl) 
        call reldn                              ; relocate pointers in dynamic} jsr reldn  
        call relws                              ; relocate pointers in working sect} jsr relws  
        call relst                              ; relocate pointers in static} jsr relst  
        ret                                     ; return to caller} exi   
                                                ; end procedure reloc} enp   
relst:
                                                ; entry point} prc e 0 
        mov  xr,m_word [pftbl]                  ; profile table} mov xr pftbl 
        test xr,xr                              ; branch if no table allocated} bze xr rls01 
        jz   rls01                              ; 
        mov  w0,m_word [(cfp_b*rlcda)+xl]       ; adjust block type word} add (xr) rlcda(xl) 
        add  m_word [xr],w0                     ; 
rls01:
        mov  wc,m_word [hshtb]                  ; point to start of hash table} mov wc hshtb 
        mov  wb,wc                              ; point to first hash bucket} mov wb wc 
        mov  wa,m_word [hshte]                  ; point beyond hash table} mov wa hshte 
        call relaj                              ; adjust bucket pointers} jsr relaj  
rls02:
        cmp  wc,m_word [hshte]                  ; done if none left} beq wc hshte rls05
        je   rls05                              ; 
        mov  xr,wc                              ; else copy slot pointer} mov xr wc 
        add  wc,cfp_b                           ; bump slot pointer} ica wc  
        sub  xr,cfp_b*vrnxt                     ; set offset to merge into loop} sub xr *vrnxt 
rls03:
        mov  xr,m_word [(cfp_b*vrnxt)+xr]       ; point to next vrblk on chain} mov xr vrnxt(xr) 
        test xr,xr                              ; jump for next bucket if chain end} bze xr rls02 
        jz   rls02                              ; 
        mov  wa,cfp_b*vrlen                     ; offset of first loc past ptr fields} mov wa *vrlen 
        mov  wb,cfp_b*vrget                     ; offset of first location in vrblk} mov wb *vrget 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; jump if not system variable} bnz vrlen(xr) rls04 
        jnz  rls04                              ; 
        mov  wa,cfp_b*vrsi_                     ; offset to include vrsvp field} mov wa *vrsi_ 
rls04:
        add  wa,xr                              ; create end ptr} add wa xr 
        add  wb,xr                              ; create start ptr} add wb xr 
        call relaj                              ; adjust pointers in vrblk} jsr relaj  
        jmp  rls03                              ; check for another vrblk on chain} brn rls03  
rls05:
        ret                                     ; return to caller} exi   
                                                ; end procedure relst} enp   
relws:
                                                ; entry point} prc e 0 
        mov  wb,a_aaa                           ; point to start of adjustables} mov wb =a_aaa 
        mov  wa,r_yyy                           ; point to end of adjustables} mov wa =r_yyy 
        call relaj                              ; relocate adjustable pointers} jsr relaj  
        mov  w0,m_word [(cfp_b*rldya)+xl]       ; adjust ptr missed by relaj} add dname rldya(xl) 
        add  m_word [dname],w0                  ; 
        mov  wb,kvrtn                           ; case of kvrtn} mov wb =kvrtn 
        mov  wa,wb                              ; handled specially} mov wa wb 
        add  wa,cfp_b                           ; one value to adjust} ica wa  
        call relaj                              ; adjust kvrtn} jsr relaj  
        ret                                     ; return to caller} exi   
                                                ; end procedure relws} enp   
start:
                                                ; entry point} prc e 0 
        mov  m_word [mxint],wb                  ; } mov mxint wb 
        mov  m_word [bitsm],wb                  ; } mov bitsm wb 
        xor  wb,wb                              ; } zer wb  
        mov  xs,wa                              ; discard return} mov xs wa 
        call systm                              ; initialise timer} jsr systm  
        mov  m_word [timsx],ia                  ; store time} sti timsx  
        mov  m_word [statb],xr                  ; start address of static} mov statb xr 
        mov  m_word [rsmem],cfp_b*e_srs         ; reserve memory} mov rsmem *e_srs 
        mov  m_word [stbas],xs                  ; store stack base} mov stbas xs 
                                                ; save s-r stack ptr} sss iniss  
        mov  ia,m_word [intvh]                  ; get 100} ldi intvh  
        mov  r10,m_word [alfsp]                 ; form 100 / alfsp} dvi alfsp  
        call do_dvi                             ; 
        mov  m_word [alfsf],ia                  ; store the factor} sti alfsf  
        mov  ia,m_word [intvh]                  ; get 100} ldi intvh  
        mov  r10,m_word [gbsdp]                 ; form 100 / gbsdp} dvi gbsdp  
        call do_dvi                             ; 
        mov  m_word [gbsed],ia                  ; store the factor} sti gbsed  
        mov  wb,cfp_s                           ; load counter for significant digits} lct wb =cfp_s 
        movsd ra,[reav1]                        ; load 1.0} ldr reav1  
ini03:
        ldmxcsr [mxcsr_set]                     ; * 10.0} mlr reavt  
        mulsd ra,[reavt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0002                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0002:                                         ; 
        dec  wb                                 ; loop till done} bct wb ini03 
        jnz  ini03                              ; 
        movsd [gtssc],ra                        ; store 10**(max sig digits)} str gtssc  
        movsd ra,[reap5]                        ; load 0.5} ldr reap5  
        ldmxcsr [mxcsr_set]                     ; compute 0.5*10**(max sig digits)} dvr gtssc  
        divsd ra,[gtssc]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0003                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0003:                                         ; 
        movsd [gtsrn],ra                        ; store as rounding bias} str gtsrn  
        xor  wc,wc                              ; set to read parameters} zer wc  
        call prpar                              ; read them} jsr prpar  
        sub  xl,cfp_b*e_srs                     ; allow for reserve memory} sub xl *e_srs 
        mov  wa,m_word [prlen]                  ; get print buffer length} mov wa prlen 
        add  wa,cfp_a                           ; add no. of chars in alphabet} add wa =cfp_a 
        add  wa,nstmx                           ; add chars for gtstg bfr} add wa =nstmx 
        add  wa,(cfp_b-1)+cfp_b*8               ; convert to bytes, allowing a margin} ctb wa 8 
        and  wa,-cfp_b                          ; 
        mov  xr,m_word [statb]                  ; point to static base} mov xr statb 
        add  xr,wa                              ; increment for above buffers} add xr wa 
        add  xr,cfp_b*e_hnb                     ; increment for hash table} add xr *e_hnb 
        add  xr,cfp_b*e_sts                     ; bump for initial static block} add xr *e_sts 
        call sysmx                              ; get mxlen} jsr sysmx  
        mov  m_word [kvmxl],wa                  ; provisionally store as maxlngth} mov kvmxl wa 
        mov  m_word [mxlen],wa                  ; and as mxlen} mov mxlen wa 
        cmp  xr,wa                              ; skip if static hi exceeds mxlen} bgt xr wa ini06
        ja   ini06                              ; 
        add  wa,(cfp_b-1)+cfp_b*1               ; round up and make bigger than mxlen} ctb wa 1 
        and  wa,-cfp_b                          ; 
        mov  xr,wa                              ; use it instead} mov xr wa 
ini06:
        mov  m_word [dnamb],xr                  ; dynamic base adrs} mov dnamb xr 
        mov  m_word [dnamp],xr                  ; dynamic ptr} mov dnamp xr 
        test wa,wa                              ; skip if non-zero mxlen} bnz wa ini07 
        jnz  ini07                              ; 
        sub  xr,cfp_b                           ; point a word in front} dca xr  
        mov  m_word [kvmxl],xr                  ; use as maxlngth} mov kvmxl xr 
        mov  m_word [mxlen],xr                  ; and as mxlen} mov mxlen xr 
ini07:
        mov  m_word [dname],xl                  ; store dynamic end address} mov dname xl 
        cmp  m_word [dnamb],xl                  ; skip if high enough} blt dnamb xl ini09
        jb   ini09                              ; 
        call sysmm                              ; request more memory} jsr sysmm  
        sal  xr,log_cfp_b                       ; get as baus (sgd05)} wtb xr  
        add  xl,xr                              ; bump by amount obtained} add xl xr 
        test xr,xr                              ; try again} bnz xr ini07 
        jnz  ini07                              ; 
        mov  wa,mxern                           ; insufficient memory for maxlength} mov wa =mxern 
        xor  wb,wb                              ; no column number info} zer wb  
        xor  wc,wc                              ; no line number info} zer wc  
        mov  xr,stgic                           ; initial compile stage} mov xr =stgic 
        mov  xl,nulls                           ; no file name} mov xl =nulls 
        call sysea                              ; advise of error} jsr sysea  
        dec  m_word [_rc_]                      ; 
        js   call_1                             ; 
        dec  m_word [_rc_]                      ; cant use error logic yet} ppm ini08  
        jns  _l0004                             ; 
        jmp  ini08                              ; 
_l0004:                                         ; 
call_1:                                         ; 
        jmp  ini08                              ; force termination} brn ini08  
        mov  m_word [_rc_],329                  ; } erb 329 requested maxlngth too large 
        jmp  err_                               ; 
ini08:
        mov  xr,endmo                           ; point to failure message} mov xr =endmo 
        mov  wa,m_word [endml]                  ; message length} mov wa endml 
        call syspr                              ; print it (prtst not yet usable)} jsr syspr  
        dec  m_word [_rc_]                      ; 
        js   call_2                             ; 
        dec  m_word [_rc_]                      ; should not fail} ppm   
        jns  _l0005                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0005:                                         ; 
call_2:                                         ; 
        xor  xl,xl                              ; no fcb chain yet} zer xl  
        mov  wb,num10                           ; set special code value} mov wb =num10 
        call sysej                              ; pack up (stopr not yet usable)} jsr sysej  
ini09:
        mov  xr,m_word [statb]                  ; point to static again} mov xr statb 
        call insta                              ; initialize static} jsr insta  
        mov  wa,e_hnb                           ; get number of hash headers} mov wa =e_hnb 
        mov  ia,wa                              ; convert to integer} mti wa  
        mov  m_word [hshnb],ia                  ; store for use by gtnvr procedure} sti hshnb  
        mov  m_word [hshtb],xr                  ; pointer to hash table} mov hshtb xr 
ini11:
        xor  w0,w0                              ; blank a word} zer (xr)+  
        stos_w                                  ; 
        dec  wa                                 ; loop} bct wa ini11 
        jnz  ini11                              ; 
        mov  m_word [hshte],xr                  ; end of hash table adrs is kept} mov hshte xr 
        mov  m_word [state],xr                  ; store static end address} mov state xr 
        mov  wc,num01                           ; table will have only one bucket} mov wc =num01 
        mov  xl,nulls                           ; default table value} mov xl =nulls 
        mov  m_word [r_sfc],xl                  ; current source file name} mov r_sfc xl 
        call tmake                              ; create table} jsr tmake  
        mov  m_word [r_sfn],xr                  ; save ptr to table} mov r_sfn xr 
        mov  wc,num01                           ; table will have only one bucket} mov wc =num01 
        mov  xl,nulls                           ; default table value} mov xl =nulls 
        call tmake                              ; create table} jsr tmake  
        mov  m_word [r_inc],xr                  ; save ptr to table} mov r_inc xr 
        mov  wa,ccinm                           ; maximum nesting level} mov wa =ccinm 
        mov  xl,nulls                           ; null string default value} mov xl =nulls 
        call vmake                              ; create array} jsr vmake  
        dec  m_word [_rc_]                      ; 
        js   call_3                             ; 
        dec  m_word [_rc_]                      ; } ppm   
        jns  _l0006                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0006:                                         ; 
call_3:                                         ; 
        mov  m_word [r_ifa],xr                  ; save ptr to array} mov r_ifa xr 
        mov  wa,ccinm                           ; maximum nesting level} mov wa =ccinm 
        mov  xl,inton                           ; integer one default value} mov xl =inton 
        call vmake                              ; create array} jsr vmake  
        dec  m_word [_rc_]                      ; 
        js   call_4                             ; 
        dec  m_word [_rc_]                      ; } ppm   
        jns  _l0007                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0007:                                         ; 
call_4:                                         ; 
        mov  m_word [r_ifl],xr                  ; save ptr to array} mov r_ifl xr 
        mov  xl,v_inp                           ; point to string /input/} mov xl =v_inp 
        mov  wb,trtin                           ; trblk type for input} mov wb =trtin 
        call inout                              ; perform input association} jsr inout  
        mov  xl,v_oup                           ; point to string /output/} mov xl =v_oup 
        mov  wb,trtou                           ; trblk type for output} mov wb =trtou 
        call inout                              ; perform output association} jsr inout  
        mov  wc,m_word [initr]                  ; terminal flag} mov wc initr 
        test wc,wc                              ; skip if no terminal} bze wc ini13 
        jz   ini13                              ; 
        call prpar                              ; associate terminal} jsr prpar  
ini13:
        call sysdc                              ; call date check} jsr sysdc  
        mov  m_word [flptr],xs                  ; in case stack overflows in compiler} mov flptr xs 
        call cmpil                              ; call compiler} jsr cmpil  
        mov  m_word [r_cod],xr                  ; set ptr to first code block} mov r_cod xr 
        mov  m_word [r_ttl],nulls               ; forget title} mov r_ttl =nulls 
        mov  m_word [r_stl],nulls               ; forget sub-title} mov r_stl =nulls 
        xor  w0,w0                              ; forget compiler input image} zer r_cim  
        mov  m_word [r_cim],w0                  ; 
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        xor  w0,w0                              ; in case end occurred with include} zer cnind  
        mov  m_word [cnind],w0                  ; 
        xor  w0,w0                              ; listing include depth} zer lstid  
        mov  m_word [lstid],w0                  ; 
        xor  xl,xl                              ; clear dud value} zer xl  
        xor  wb,wb                              ; dont shift dynamic store up} zer wb  
        xor  w0,w0                              ; collect sediment too} zer dnams  
        mov  m_word [dnams],w0                  ; 
        call gbcol                              ; clear garbage left from compile} jsr gbcol  
        mov  m_word [dnams],xr                  ; record new sediment size} mov dnams xr 
        cmp  m_word [cpsts],0                   ; skip if no listing of comp stats} bnz cpsts inix0 
        jnz  inix0                              ; 
        call prtpg                              ; eject page} jsr prtpg  
        call prtmm                              ; print memory usage} jsr prtmm  
        mov  ia,m_word [cmerc]                  ; get count of errors as integer} mti cmerc  
        mov  xr,encm3                           ; point to /compile errors/} mov xr =encm3 
        call prtmi                              ; print it} jsr prtmi  
        mov  ia,m_word [gbcnt]                  ; garbage collection count} mti gbcnt  
        sub  ia,m_word [intv1]                  ; adjust for unavoidable collect} sbi intv1  
        mov  xr,stpm5                           ; point to /storage regenerations/} mov xr =stpm5 
        call prtmi                              ; print gbcol count} jsr prtmi  
        call systm                              ; get time} jsr systm  
        sub  ia,m_word [timsx]                  ; get compilation time} sbi timsx  
        mov  xr,encm4                           ; point to compilation time (msec)/} mov xr =encm4 
        call prtmi                              ; print message} jsr prtmi  
        add  m_word [lstlc],num05               ; bump line count} add lstlc =num05 
        cmp  m_word [headp],0                   ; no eject if nothing printed} bze headp inix0 
        jz   inix0                              ; 
        call prtpg                              ; eject printer} jsr prtpg  
inix0:
        cmp  m_word [cswin],iniln               ; skip if not default -in72 used} bgt cswin =iniln inix1
        ja   inix1                              ; 
        mov  m_word [cswin],inils               ; else use default record length} mov cswin =inils 
inix1:
        call systm                              ; get time again} jsr systm  
        mov  m_word [timsx],ia                  ; store for end run processing} sti timsx  
        xor  w0,w0                              ; initialise collect count} zer gbcnt  
        mov  m_word [gbcnt],w0                  ; 
        call sysbx                              ; call before starting execution} jsr sysbx  
        mov  w0,m_word [cswex]                  ; add -noexecute flag} add noxeq cswex 
        add  m_word [noxeq],w0                  ; 
        cmp  m_word [noxeq],0                   ; jump if execution suppressed} bnz noxeq inix2 
        jnz  inix2                              ; 
iniy0:
        mov  m_word [headp],xs                  ; mark headers out regardless} mnz headp  
        push 0                                  ; set failure location on stack} zer -(xs)  
        mov  m_word [flptr],xs                  ; save ptr to failure offset word} mov flptr xs 
        mov  xr,m_word [r_cod]                  ; load ptr to entry code block} mov xr r_cod 
        mov  m_word [stage],stgxt               ; set stage for execute time} mov stage =stgxt 
        mov  m_word [polcs],num01               ; reset interface polling interval} mov polcs =num01 
        mov  m_word [polct],num01               ; reset interface polling interval} mov polct =num01 
        mov  w0,m_word [cmpsn]                  ; copy stmts compiled count in case} mov pfnte cmpsn 
        mov  m_word [pfnte],w0                  ; 
        mov  w0,m_word [kvpfl]                  ; start profiling if &profile set} mov pfdmp kvpfl 
        mov  m_word [pfdmp],w0                  ; 
        call systm                              ; time yet again} jsr systm  
        mov  m_word [pfstm],ia                  ; } sti pfstm  
        call stgcc                              ; compute stmgo countdown counters} jsr stgcc  
        jmp  m_word [xr]                        ; start xeq with first statement} bri (xr)  
inix2:
        xor  wa,wa                              ; set abend value to zero} zer wa  
        mov  wb,nini9                           ; set special code value} mov wb =nini9 
        xor  xl,xl                              ; no fcb chain} zer xl  
        call sysej                              ; end of job, exit to system} jsr sysej  
                                                ; end procedure start} enp   
rstrt:
                                                ; entry point} prc e 0 
        mov  xs,m_word [stbas]                  ; discard return} mov xs stbas 
        xor  xl,xl                              ; clear xl} zer xl  
        jmp  iniy0                              ; resume execution} brn iniy0  
                                                ; end procedure rstrt} enp   
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_add:                                          ; 
        call arith                              ; fetch arithmetic operands} jsr arith  
        dec  m_word [_rc_]                      ; 
        js   call_5                             ; 
        dec  m_word [_rc_]                      ; } err 001 addition left operand is not numeric 
        jns  _l0008                             ; 
        mov  m_word [_rc_],1                    ; 
        jmp  err_                               ; 
_l0008:                                         ; 
        dec  m_word [_rc_]                      ; } err 002 addition right operand is not numeric 
        jns  _l0009                             ; 
        mov  m_word [_rc_],2                    ; 
        jmp  err_                               ; 
_l0009:                                         ; 
        dec  m_word [_rc_]                      ; jump if real operands} ppm oadd1  
        jns  _l0010                             ; 
        jmp  oadd1                              ; 
_l0010:                                         ; 
call_5:                                         ; 
        add  ia,m_word [(cfp_b*icval)+xl]       ; add right operand to left} adi icval(xl)  
        jno  exint                              ; return integer if no overflow} ino exint  
        mov  m_word [_rc_],3                    ; } erb 003 addition caused integer overflow 
        jmp  err_                               ; 
oadd1:
        ldmxcsr [mxcsr_set]                     ; add right operand to left} adr rcval(xl)  
        addsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0011                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0011:                                         ; 
        call do_chk_real_inf                    ; return real if no overflow} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],261                  ; } erb 261 addition caused real overflow 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_aff:                                          ; 
        pop  xr                                 ; load operand} mov xr (xs)+ 
        call gtnum                              ; convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_6                             ; 
        dec  m_word [_rc_]                      ; } err 004 affirmation operand is not numeric 
        jns  _l0012                             ; 
        mov  m_word [_rc_],4                    ; 
        jmp  err_                               ; 
_l0012:                                         ; 
call_6:                                         ; 
        push xr                                 ; result if converted to numeric} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_alt:                                          ; 
        pop  xr                                 ; load right operand} mov xr (xs)+ 
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_7                             ; 
        dec  m_word [_rc_]                      ; } err 005 alternation right operand is not pattern 
        jns  _l0013                             ; 
        mov  m_word [_rc_],5                    ; 
        jmp  err_                               ; 
_l0013:                                         ; 
call_7:                                         ; 
oalt1:
        mov  wb,p_alt                           ; set pcode for alternative node} mov wb =p_alt 
        call pbild                              ; build alternative node} jsr pbild  
        mov  xl,xr                              ; save address of alternative node} mov xl xr 
        pop  xr                                 ; load left operand} mov xr (xs)+ 
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_8                             ; 
        dec  m_word [_rc_]                      ; } err 006 alternation left operand is not pattern 
        jns  _l0014                             ; 
        mov  m_word [_rc_],6                    ; 
        jmp  err_                               ; 
_l0014:                                         ; 
call_8:                                         ; 
        cmp  xr,p_alt                           ; jump if left arg is alternation} beq xr =p_alt oalt2
        je   oalt2                              ; 
        mov  m_word [(cfp_b*pthen)+xl],xr       ; set left operand as successor} mov pthen(xl) xr 
        push xl                                 ; stack result} mov -(xs) xl 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
oalt2:
        mov  w0,m_word [(cfp_b*parm1)+xr]       ; build the (b / c) node} mov pthen(xl) parm1(xr) 
        mov  m_word [(cfp_b*pthen)+xl],w0       ; 
        push m_word [(cfp_b*pthen)+xr]          ; set a as new left arg} mov -(xs) pthen(xr) 
        mov  xr,xl                              ; set (b / c) as new right arg} mov xr xl 
        jmp  oalt1                              ; merge back to build a / (b / c)} brn oalt1  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_amn:                                          ; 
        mov  r10,m_word [r13]                   ; load number of subscripts} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  wb,xr                              ; set flag for by name} mov wb xr 
        jmp  arref                              ; jump to array reference routine} brn arref  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_amv:                                          ; 
        mov  r10,m_word [r13]                   ; load number of subscripts} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        xor  wb,wb                              ; set flag for by value} zer wb  
        jmp  arref                              ; jump to array reference routine} brn arref  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_aon:                                          ; 
        mov  xr,m_word [xs]                     ; load subscript value} mov xr (xs) 
        mov  xl,m_word [(cfp_b*num01)+xs]       ; load array value} mov xl num01(xs) 
        mov  wa,m_word [xl]                     ; load first word of array operand} mov wa (xl) 
        cmp  wa,b_vct                           ; jump if vector reference} beq wa =b_vct oaon2
        je   oaon2                              ; 
        cmp  wa,b_tbt                           ; jump if table reference} beq wa =b_tbt oaon3
        je   oaon3                              ; 
oaon1:
        mov  xr,num01                           ; set number of subscripts to one} mov xr =num01 
        mov  wb,xr                              ; set flag for by name} mov wb xr 
        jmp  arref                              ; jump to array reference routine} brn arref  
oaon2:
        cmp  m_word [xr],b_icl                  ; use long routine if not integer} bne (xr) =b_icl oaon1
        jne  oaon1                              ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer subscript value} ldi icval(xr)  
        test ia,ia                              ; copy as address int, fail if ovflo} mfi wa exfal 
        js   exfal                              ; 
        mov  wa,ia                              ; 
        test wa,wa                              ; fail if zero} bze wa exfal 
        jz   exfal                              ; 
        add  wa,vcvlb                           ; compute offset in words} add wa =vcvlb 
        sal  wa,log_cfp_b                       ; convert to bytes} wtb wa  
        mov  m_word [xs],wa                     ; complete name on stack} mov (xs) wa 
        cmp  wa,m_word [(cfp_b*vclen)+xl]       ; exit if subscript not too large} blt wa vclen(xl) oaon4
        jb   oaon4                              ; 
        jmp  exfal                              ; else fail} brn exfal  
oaon3:
        mov  wb,xs                              ; set flag for name reference} mnz wb  
        call tfind                              ; locate/create table element} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_9                             ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0015                             ; 
        jmp  exfal                              ; 
_l0015:                                         ; 
call_9:                                         ; 
        mov  m_word [(cfp_b*num01)+xs],xl       ; store name base on stack} mov num01(xs) xl 
        mov  m_word [xs],wa                     ; store name offset on stack} mov (xs) wa 
oaon4:
        mov  r10,m_word [r13]                   ; result on stack, get code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_aov:                                          ; 
        pop  xr                                 ; load subscript value} mov xr (xs)+ 
        pop  xl                                 ; load array value} mov xl (xs)+ 
        mov  wa,m_word [xl]                     ; load first word of array operand} mov wa (xl) 
        cmp  wa,b_vct                           ; jump if vector reference} beq wa =b_vct oaov2
        je   oaov2                              ; 
        cmp  wa,b_tbt                           ; jump if table reference} beq wa =b_tbt oaov3
        je   oaov3                              ; 
oaov1:
        push xl                                 ; restack array value} mov -(xs) xl 
        push xr                                 ; restack subscript} mov -(xs) xr 
        mov  xr,num01                           ; set number of subscripts to one} mov xr =num01 
        xor  wb,wb                              ; set flag for value call} zer wb  
        jmp  arref                              ; jump to array reference routine} brn arref  
oaov2:
        cmp  m_word [xr],b_icl                  ; use long routine if not integer} bne (xr) =b_icl oaov1
        jne  oaov1                              ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer subscript value} ldi icval(xr)  
        test ia,ia                              ; move as one word int, fail if ovflo} mfi wa exfal 
        js   exfal                              ; 
        mov  wa,ia                              ; 
        test wa,wa                              ; fail if zero} bze wa exfal 
        jz   exfal                              ; 
        add  wa,vcvlb                           ; compute offset in words} add wa =vcvlb 
        sal  wa,log_cfp_b                       ; convert to bytes} wtb wa  
        cmp  wa,m_word [(cfp_b*vclen)+xl]       ; fail if subscript too large} bge wa vclen(xl) exfal
        jae  exfal                              ; 
        call acess                              ; access value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_10                            ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0016                             ; 
        jmp  exfal                              ; 
_l0016:                                         ; 
call_10:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
oaov3:
        xor  wb,wb                              ; set flag for value reference} zer wb  
        call tfind                              ; call table search routine} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_11                            ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0017                             ; 
        jmp  exfal                              ; 
_l0017:                                         ; 
call_11:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_ass:                                          ; 
oass0:
        pop  wb                                 ; load value to be assigned} mov wb (xs)+ 
        pop  wa                                 ; load name offset} mov wa (xs)+ 
        mov  xl,m_word [xs]                     ; load name base} mov xl (xs) 
        mov  m_word [xs],wb                     ; store assigned value as result} mov (xs) wb 
        call asign                              ; perform assignment} jsr asign  
        dec  m_word [_rc_]                      ; 
        js   call_12                            ; 
        dec  m_word [_rc_]                      ; fail if assignment fails} ppm exfal  
        jns  _l0018                             ; 
        jmp  exfal                              ; 
_l0018:                                         ; 
call_12:                                        ; 
        mov  r10,m_word [r13]                   ; result on stack, get code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_cer:                                          ; 
        mov  m_word [_rc_],7                    ; } erb 007 compilation error encountered during execution 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_cas:                                          ; 
        pop  wc                                 ; load name offset (parm2)} mov wc (xs)+ 
        pop  xr                                 ; load name base (parm1)} mov xr (xs)+ 
        mov  wb,p_cas                           ; set pcode for cursor assignment} mov wb =p_cas 
        call pbild                              ; build node} jsr pbild  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_cnc:                                          ; 
        mov  xr,m_word [xs]                     ; load right argument} mov xr (xs) 
        cmp  xr,nulls                           ; jump if right arg is null} beq xr =nulls ocnc3
        je   ocnc3                              ; 
        mov  xl,m_word [(cfp_b*1)+xs]           ; load left argument} mov xl 1(xs) 
        cmp  xl,nulls                           ; jump if left argument is null} beq xl =nulls ocnc4
        je   ocnc4                              ; 
        mov  wa,b_scl                           ; get constant to test for string} mov wa =b_scl 
        cmp  wa,m_word [xl]                     ; jump if left arg not a string} bne wa (xl) ocnc2
        jne  ocnc2                              ; 
        cmp  wa,m_word [xr]                     ; jump if right arg not a string} bne wa (xr) ocnc2
        jne  ocnc2                              ; 
ocnc1:
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load left argument length} mov wa sclen(xl) 
        add  wa,m_word [(cfp_b*sclen)+xr]       ; compute result length} add wa sclen(xr) 
        call alocs                              ; allocate scblk for result} jsr alocs  
        mov  m_word [(cfp_b*1)+xs],xr           ; store result ptr over left argument} mov 1(xs) xr 
        add  xr,cfp_f                           ; prepare to store chars of result} psc xr  
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; get number of chars in left arg} mov wa sclen(xl) 
        add  xl,cfp_f                           ; prepare to load left arg chars} plc xl  
        rep                                     ; move characters of left argument} mvc   
        movs_b                                  ; 
        pop  xl                                 ; load right arg pointer, pop stack} mov xl (xs)+ 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load number of chars in right arg} mov wa sclen(xl) 
        add  xl,cfp_f                           ; prepare to load right arg chars} plc xl  
        rep                                     ; move characters of right argument} mvc   
        movs_b                                  ; 
        xor  xl,xl                              ; clear garbage value in xl} zer xl  
        mov  r10,m_word [r13]                   ; result on stack, get code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
ocnc2:
        call gtstg                              ; convert right arg to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_13                            ; 
        dec  m_word [_rc_]                      ; jump if right arg is not string} ppm ocnc5  
        jns  _l0021                             ; 
        jmp  ocnc5                              ; 
_l0021:                                         ; 
call_13:                                        ; 
        mov  xl,xr                              ; save right arg ptr} mov xl xr 
        call gtstg                              ; convert left arg to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_14                            ; 
        dec  m_word [_rc_]                      ; jump if left arg is not a string} ppm ocnc6  
        jns  _l0022                             ; 
        jmp  ocnc6                              ; 
_l0022:                                         ; 
call_14:                                        ; 
        push xr                                 ; stack left argument} mov -(xs) xr 
        push xl                                 ; stack right argument} mov -(xs) xl 
        mov  xl,xr                              ; move left arg to proper reg} mov xl xr 
        mov  xr,m_word [xs]                     ; move right arg to proper reg} mov xr (xs) 
        jmp  ocnc1                              ; merge back to concatenate strings} brn ocnc1  
ocnc3:
        add  xs,cfp_b                           ; remove right arg from stack} ica xs  
        mov  r10,m_word [r13]                   ; left argument on stack} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
ocnc4:
        add  xs,cfp_b                           ; unstack one argument} ica xs  
        mov  m_word [xs],xr                     ; store right argument} mov (xs) xr 
        mov  r10,m_word [r13]                   ; result on stack, get code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
ocnc5:
        mov  xl,xr                              ; move right argument ptr} mov xl xr 
        pop  xr                                 ; load left arg pointer} mov xr (xs)+ 
ocnc6:
        call gtpat                              ; convert left arg to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_15                            ; 
        dec  m_word [_rc_]                      ; } err 008 concatenation left operand is not a string or pattern 
        jns  _l0023                             ; 
        mov  m_word [_rc_],8                    ; 
        jmp  err_                               ; 
_l0023:                                         ; 
call_15:                                        ; 
        push xr                                 ; save result on stack} mov -(xs) xr 
        mov  xr,xl                              ; point to right operand} mov xr xl 
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_16                            ; 
        dec  m_word [_rc_]                      ; } err 009 concatenation right operand is not a string or pattern 
        jns  _l0024                             ; 
        mov  m_word [_rc_],9                    ; 
        jmp  err_                               ; 
_l0024:                                         ; 
call_16:                                        ; 
        mov  xl,xr                              ; move for pconc} mov xl xr 
        pop  xr                                 ; reload left operand ptr} mov xr (xs)+ 
        call pconc                              ; concatenate patterns} jsr pconc  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_com:                                          ; 
        pop  xr                                 ; load operand} mov xr (xs)+ 
        mov  wa,m_word [xr]                     ; load type word} mov wa (xr) 
ocom1:
        cmp  wa,b_icl                           ; jump if integer} beq wa =b_icl ocom2
        je   ocom2                              ; 
        cmp  wa,b_rcl                           ; jump if real} beq wa =b_rcl ocom3
        je   ocom3                              ; 
        call gtnum                              ; else convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_17                            ; 
        dec  m_word [_rc_]                      ; } err 010 negation operand is not numeric 
        jns  _l0025                             ; 
        mov  m_word [_rc_],10                   ; 
        jmp  err_                               ; 
_l0025:                                         ; 
call_17:                                        ; 
        jmp  ocom1                              ; back to check cases} brn ocom1  
ocom2:
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer value} ldi icval(xr)  
        neg  ia                                 ; negate} ngi   
        jno  exint                              ; return integer if no overflow} ino exint  
        mov  m_word [_rc_],11                   ; } erb 011 negation caused integer overflow 
        jmp  err_                               ; 
ocom3:
        movsd ra,[(cfp_b*rcval)+xr]             ; load real value} ldr rcval(xr)  
        movsd xmm0,m_real [zeron]               ; negate} ngr   
        pxor ra,xmm0                            ; 
        jmp  exrea                              ; return real result} brn exrea  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_dvd:                                          ; 
        call arith                              ; fetch arithmetic operands} jsr arith  
        dec  m_word [_rc_]                      ; 
        js   call_18                            ; 
        dec  m_word [_rc_]                      ; } err 012 division left operand is not numeric 
        jns  _l0026                             ; 
        mov  m_word [_rc_],12                   ; 
        jmp  err_                               ; 
_l0026:                                         ; 
        dec  m_word [_rc_]                      ; } err 013 division right operand is not numeric 
        jns  _l0027                             ; 
        mov  m_word [_rc_],13                   ; 
        jmp  err_                               ; 
_l0027:                                         ; 
        dec  m_word [_rc_]                      ; jump if real operands} ppm odvd2  
        jns  _l0028                             ; 
        jmp  odvd2                              ; 
_l0028:                                         ; 
call_18:                                        ; 
        mov  r10,m_word [(cfp_b*icval)+xl]      ; divide left operand by right} dvi icval(xl)  
        call do_dvi                             ; 
        jno  exint                              ; result ok if no overflow} ino exint  
        mov  m_word [_rc_],14                   ; } erb 014 division caused integer overflow 
        jmp  err_                               ; 
odvd2:
        ldmxcsr [mxcsr_set]                     ; divide left operand by right} dvr rcval(xl)  
        divsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0029                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0029:                                         ; 
        call do_chk_real_inf                    ; return real if no overflow} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],262                  ; } erb 262 division caused real overflow 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_exp:                                          ; 
        pop  xr                                 ; load exponent} mov xr (xs)+ 
        call gtnum                              ; convert to number} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_19                            ; 
        dec  m_word [_rc_]                      ; } err 015 exponentiation right operand is not numeric 
        jns  _l0030                             ; 
        mov  m_word [_rc_],15                   ; 
        jmp  err_                               ; 
_l0030:                                         ; 
call_19:                                        ; 
        mov  xl,xr                              ; move exponent to xl} mov xl xr 
        pop  xr                                 ; load base} mov xr (xs)+ 
        call gtnum                              ; convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_20                            ; 
        dec  m_word [_rc_]                      ; } err 016 exponentiation left operand is not numeric 
        jns  _l0031                             ; 
        mov  m_word [_rc_],16                   ; 
        jmp  err_                               ; 
_l0031:                                         ; 
call_20:                                        ; 
        cmp  m_word [xl],b_rcl                  ; jump if real exponent} beq (xl) =b_rcl oexp7
        je   oexp7                              ; 
        mov  ia,m_word [(cfp_b*icval)+xl]       ; load exponent} ldi icval(xl)  
        cmp  ia,0                               ; jump if negative exponent} ilt oex12  
        jl   oex12                              ; 
        cmp  wa,b_rcl                           ; jump if base is real} beq wa =b_rcl oexp3
        je   oexp3                              ; 
        test ia,ia                              ; convert exponent to 1 word integer} mfi wa oexp2 
        js   oexp2                              ; 
        mov  wa,ia                              ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load base as initial value} ldi icval(xr)  
        test wa,wa                              ; jump into loop if non-zero exponent} bnz wa oexp1 
        jnz  oexp1                              ; 
        cmp  ia,0                               ; error if 0**0} ieq oexp4  
        je   oexp4                              ; 
        mov  ia,m_word [intv1]                  ; nonzero**0} ldi intv1  
        jmp  exint                              ; give one as result for nonzero**0} brn exint  
oex13:
        imul ia,m_word [(cfp_b*icval)+xr]       ; multiply by base} mli icval(xr)  
        jo   oexp2                              ; jump if overflow} iov oexp2  
oexp1:
        dec  wa                                 ; loop if more to go} bct wa oex13 
        jnz  oex13                              ; 
        jmp  exint                              ; else return integer result} brn exint  
oexp2:
        mov  m_word [_rc_],17                   ; } erb 017 exponentiation caused integer overflow 
        jmp  err_                               ; 
oexp3:
        test ia,ia                              ; convert exponent to one word} mfi wa oexp6 
        js   oexp6                              ; 
        mov  wa,ia                              ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load base as initial value} ldr rcval(xr)  
        test wa,wa                              ; jump into loop if non-zero exponent} bnz wa oexp5 
        jnz  oexp5                              ; 
        pxor xmm0,xmm0                          ; error if 0.0**0} req oexp4  
        ucomisd ra,xmm0                         ; 
        je   oexp4                              ; 
        movsd ra,[reav1]                        ; nonzero**0} ldr reav1  
        jmp  exrea                              ; return 1.0 if nonzero**zero} brn exrea  
oexp4:
        mov  m_word [_rc_],18                   ; } erb 018 exponentiation result is undefined 
        jmp  err_                               ; 
oex14:
        ldmxcsr [mxcsr_set]                     ; multiply by base} mlr rcval(xr)  
        mulsd ra,[(cfp_b*rcval)+xr]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0032                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0032:                                         ; 
        call do_chk_real_inf                    ; jump if overflow} rov oexp6  
        jnz  oexp6                              ; 
oexp5:
        dec  wa                                 ; loop till computation complete} bct wa oex14 
        jnz  oex14                              ; 
        jmp  exrea                              ; then return real result} brn exrea  
oexp6:
        mov  m_word [_rc_],266                  ; } erb 266 exponentiation caused real overflow 
        jmp  err_                               ; 
oexp7:
        cmp  m_word [xr],b_rcl                  ; jump if base real} beq (xr) =b_rcl oexp8
        je   oexp8                              ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer base} ldi icval(xr)  
        pxor ra,ra                              ; convert to real} itr   
        cvtsi2sd ra,ia                          ; 
        call rcbld                              ; create real in (xr)} jsr rcbld  
oexp8:
        xor  wb,wb                              ; set positive result flag} zer wb  
        movsd ra,[(cfp_b*rcval)+xr]             ; load base to ra} ldr rcval(xr)  
        pxor xmm0,xmm0                          ; jump if base non-zero} rne oexp9  
        ucomisd ra,xmm0                         ; 
        jne  oexp9                              ; 
        movsd ra,[(cfp_b*rcval)+xl]             ; base is zero.  check exponent} ldr rcval(xl)  
        pxor xmm0,xmm0                          ; jump if 0.0 ** 0.0} req oexp4  
        ucomisd ra,xmm0                         ; 
        je   oexp4                              ; 
        movsd ra,[reav0]                        ; 0.0 to non-zero exponent yields 0.0} ldr reav0  
        jmp  exrea                              ; return zero result} brn exrea  
oexp9:
        pxor xmm0,xmm0                          ; jump if base gt 0.0} rgt oex10  
        ucomisd ra,xmm0                         ; 
        ja   oex10                              ; 
        movsd xmm0,m_real [zeron]               ; make base positive} ngr   
        pxor ra,xmm0                            ; 
        call rcbld                              ; create positive base in (xr)} jsr rcbld  
        movsd ra,[(cfp_b*rcval)+xl]             ; examine exponent} ldr rcval(xl)  
        call chp_                               ; chop to integral value} chp   
        cvttsd2si ia,ra                         ; convert to integer, br if too large} rti oexp6  
        mov  r10,0x80000000                     ; 
        cmp  ia,r10                             ; 
        je   oexp6                              ; 
        ldmxcsr [mxcsr_set]                     ; chop(exponent) - exponent} sbr rcval(xl)  
        subsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0033                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0033:                                         ; 
        pxor xmm0,xmm0                          ; non-integral power with neg base} rne oex11  
        ucomisd ra,xmm0                         ; 
        jne  oex11                              ; 
        mov  wb,ia                              ; record even/odd exponent} mfi wb  
        and  wb,m_word [bits1]                  ; odd exponent yields negative result} anb wb bits1 
        movsd ra,[(cfp_b*rcval)+xr]             ; restore base to ra} ldr rcval(xr)  
oex10:
        call lnf_                               ; log of base} lnf   
        call do_chk_real_inf                    ; too large} rov oexp6  
        jnz  oexp6                              ; 
        ldmxcsr [mxcsr_set]                     ; times exponent} mlr rcval(xl)  
        mulsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0034                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0034:                                         ; 
        call do_chk_real_inf                    ; too large} rov oexp6  
        jnz  oexp6                              ; 
        call etx_                               ; e ** (exponent * ln(base))} etx   
        call do_chk_real_inf                    ; too large} rov oexp6  
        jnz  oexp6                              ; 
        test wb,wb                              ; if no sign fixup required} bze wb exrea 
        jz   exrea                              ; 
        movsd xmm0,m_real [zeron]               ; negative result needed} ngr   
        pxor ra,xmm0                            ; 
        jmp  exrea                              ; } brn exrea  
oex11:
        mov  m_word [_rc_],311                  ; } erb 311 exponentiation of negative base to non-integral power 
        jmp  err_                               ; 
oex12:
        push xr                                 ; stack base} mov -(xs) xr 
        pxor ra,ra                              ; convert to real exponent} itr   
        cvtsi2sd ra,ia                          ; 
        call rcbld                              ; real negative exponent in (xr)} jsr rcbld  
        mov  xl,xr                              ; put exponent in xl} mov xl xr 
        pop  xr                                 ; restore base value} mov xr (xs)+ 
        jmp  oexp7                              ; process real exponent} brn oexp7  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_fex:                                          ; 
        jmp  evlx6                              ; jump to failure loc in evalx} brn evlx6  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_fif:                                          ; 
        mov  m_word [_rc_],20                   ; } erb 020 goto evaluation failure 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_fnc:                                          ; 
        mov  r10,m_word [r13]                   ; load number of arguments} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  r10,m_word [r13]                   ; load function vrblk pointer} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  xl,m_word [(cfp_b*vrfnc)+xr]       ; load function pointer} mov xl vrfnc(xr) 
        cmp  wa,m_word [(cfp_b*fargs)+xl]       ; use central routine if wrong num} bne wa fargs(xl) cfunc
        jne  cfunc                              ; 
        jmp  m_word [xl]                        ; jump to function if arg count ok} bri (xl)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_fne:                                          ; 
        mov  r10,m_word [r13]                   ; get next code word} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        cmp  wa,ornm_                           ; fail if not evaluating expression} bne wa =ornm_ ofne1
        jne  ofne1                              ; 
        cmp  m_word [(cfp_b*num02)+xs],0        ; ok if expr. was wanted by value} bze num02(xs) evlx3 
        jz   evlx3                              ; 
ofne1:
        mov  m_word [_rc_],21                   ; } erb 021 function called by name returned a value 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_fns:                                          ; 
        mov  r10,m_word [r13]                   ; load function vrblk pointer} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  wa,num01                           ; set number of arguments to one} mov wa =num01 
        mov  xl,m_word [(cfp_b*vrfnc)+xr]       ; load function pointer} mov xl vrfnc(xr) 
        cmp  wa,m_word [(cfp_b*fargs)+xl]       ; use central routine if wrong num} bne wa fargs(xl) cfunc
        jne  cfunc                              ; 
        jmp  m_word [xl]                        ; jump to function if arg count ok} bri (xl)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_fun:                                          ; 
        mov  m_word [_rc_],22                   ; } erb 022 undefined function called 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_goc:                                          ; 
        mov  xr,m_word [(cfp_b*num01)+xs]       ; load name base pointer} mov xr num01(xs) 
        cmp  xr,m_word [state]                  ; jump if not natural variable} bhi xr state ogoc1
        ja   ogoc1                              ; 
        add  xr,cfp_b*vrtra                     ; else point to vrtra field} add xr *vrtra 
        jmp  m_word [xr]                        ; and jump through it} bri (xr)  
ogoc1:
        mov  m_word [_rc_],23                   ; } erb 023 goto operand is not a natural variable 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_god:                                          ; 
        mov  xr,m_word [xs]                     ; load operand} mov xr (xs) 
        mov  wa,m_word [xr]                     ; load first word} mov wa (xr) 
        cmp  wa,b_cds                           ; jump if code block to code routine} beq wa =b_cds bcds0
        je   bcds0                              ; 
        cmp  wa,b_cdc                           ; jump if code block to code routine} beq wa =b_cdc bcdc0
        je   bcdc0                              ; 
        mov  m_word [_rc_],24                   ; } erb 024 goto operand in direct goto is not code 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_gof:                                          ; 
        mov  xr,m_word [flptr]                  ; point to fail offset on stack} mov xr flptr 
        add  m_word [xr],cfp_b                  ; point failure to o_fif word} ica (xr)  
        add  r13,cfp_b                          ; point to next code word} icp   
        mov  r10,m_word [r13]                   ; fetch next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_ima:                                          ; 
        mov  wb,p_imc                           ; set pcode for last node} mov wb =p_imc 
        pop  wc                                 ; pop name offset (parm2)} mov wc (xs)+ 
        pop  xr                                 ; pop name base (parm1)} mov xr (xs)+ 
        call pbild                              ; build p_imc node} jsr pbild  
        mov  xl,xr                              ; save ptr to node} mov xl xr 
        mov  xr,m_word [xs]                     ; load left argument} mov xr (xs) 
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_21                            ; 
        dec  m_word [_rc_]                      ; } err 025 immediate assignment left operand is not pattern 
        jns  _l0035                             ; 
        mov  m_word [_rc_],25                   ; 
        jmp  err_                               ; 
_l0035:                                         ; 
call_21:                                        ; 
        mov  m_word [xs],xr                     ; save ptr to left operand pattern} mov (xs) xr 
        mov  wb,p_ima                           ; set pcode for first node} mov wb =p_ima 
        call pbild                              ; build p_ima node} jsr pbild  
        pop  m_word [(cfp_b*pthen)+xr]          ; set left operand as p_ima successor} mov pthen(xr) (xs)+ 
        call pconc                              ; concatenate to form final pattern} jsr pconc  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_inn:                                          ; 
        mov  wb,xs                              ; set flag for result by name} mnz wb  
        jmp  indir                              ; jump to common routine} brn indir  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_int:                                          ; 
        mov  m_word [xs],nulls                  ; replace operand with null} mov (xs) =nulls 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_inv:                                          ; 
        xor  wb,wb                              ; set flag for by value} zer wb  
        jmp  indir                              ; jump to common routine} brn indir  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_kwn:                                          ; 
        call kwnam                              ; get keyword name} jsr kwnam  
        jmp  exnam                              ; exit with result name} brn exnam  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_kwv:                                          ; 
        call kwnam                              ; get keyword name} jsr kwnam  
        mov  m_word [dnamp],xr                  ; delete kvblk} mov dnamp xr 
        call acess                              ; access value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_22                            ; 
        dec  m_word [_rc_]                      ; dummy (unused) failure return} ppm exnul  
        jns  _l0036                             ; 
        jmp  exnul                              ; 
_l0036:                                         ; 
call_22:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_lex:                                          ; 
        mov  wa,cfp_b*evsi_                     ; set size of evblk} mov wa *evsi_ 
        call alloc                              ; allocate space for evblk} jsr alloc  
        mov  m_word [xr],b_evt                  ; set type word} mov (xr) =b_evt 
        mov  m_word [(cfp_b*evvar)+xr],trbev    ; set dummy trblk pointer} mov evvar(xr) =trbev 
        mov  r10,m_word [r13]                   ; load exblk pointer} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  m_word [(cfp_b*evexp)+xr],wa       ; set exblk pointer} mov evexp(xr) wa 
        mov  xl,xr                              ; move name base to proper reg} mov xl xr 
        mov  wa,cfp_b*evvar                     ; set name offset = zero} mov wa *evvar 
        jmp  exnam                              ; exit with name in (xl,wa)} brn exnam  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_lpt:                                          ; 
        mov  r10,m_word [r13]                   ; load pattern pointer} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_lvn:                                          ; 
        mov  r10,m_word [r13]                   ; load vrblk pointer} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        push wa                                 ; stack vrblk ptr (name base)} mov -(xs) wa 
        push cfp_b*vrval                        ; stack name offset} mov -(xs) *vrval 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_mlt:                                          ; 
        call arith                              ; fetch arithmetic operands} jsr arith  
        dec  m_word [_rc_]                      ; 
        js   call_23                            ; 
        dec  m_word [_rc_]                      ; } err 026 multiplication left operand is not numeric 
        jns  _l0037                             ; 
        mov  m_word [_rc_],26                   ; 
        jmp  err_                               ; 
_l0037:                                         ; 
        dec  m_word [_rc_]                      ; } err 027 multiplication right operand is not numeric 
        jns  _l0038                             ; 
        mov  m_word [_rc_],27                   ; 
        jmp  err_                               ; 
_l0038:                                         ; 
        dec  m_word [_rc_]                      ; jump if real operands} ppm omlt1  
        jns  _l0039                             ; 
        jmp  omlt1                              ; 
_l0039:                                         ; 
call_23:                                        ; 
        imul ia,m_word [(cfp_b*icval)+xl]       ; multiply left operand by right} mli icval(xl)  
        jno  exint                              ; return integer if no overflow} ino exint  
        mov  m_word [_rc_],28                   ; } erb 028 multiplication caused integer overflow 
        jmp  err_                               ; 
omlt1:
        ldmxcsr [mxcsr_set]                     ; multiply left operand by right} mlr rcval(xl)  
        mulsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0040                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0040:                                         ; 
        call do_chk_real_inf                    ; return real if no overflow} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],263                  ; } erb 263 multiplication caused real overflow 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_nam:                                          ; 
        mov  wa,cfp_b*nmsi_                     ; set length of nmblk} mov wa *nmsi_ 
        call alloc                              ; allocate nmblk} jsr alloc  
        mov  m_word [xr],b_nml                  ; set name block code} mov (xr) =b_nml 
        pop  m_word [(cfp_b*nmofs)+xr]          ; set name offset from operand} mov nmofs(xr) (xs)+ 
        pop  m_word [(cfp_b*nmbas)+xr]          ; set name base from operand} mov nmbas(xr) (xs)+ 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_nta:                                          ; 
        mov  r10,m_word [r13]                   ; load new failure offset} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        push m_word [flptr]                     ; stack old failure pointer} mov -(xs) flptr 
        push wa                                 ; stack new failure offset} mov -(xs) wa 
        mov  m_word [flptr],xs                  ; set new failure pointer} mov flptr xs 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_ntb:                                          ; 
        mov  w0,m_word [(cfp_b*num02)+xs]       ; restore old failure pointer} mov flptr num02(xs) 
        mov  m_word [flptr],w0                  ; 
        jmp  exfal                              ; and fail} brn exfal  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_ntc:                                          ; 
        add  xs,cfp_b                           ; pop failure offset} ica xs  
        pop  m_word [flptr]                     ; restore old failure pointer} mov flptr (xs)+ 
        jmp  exnul                              ; exit giving null result} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_oun:                                          ; 
        mov  m_word [_rc_],29                   ; } erb 029 undefined operator referenced 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_pas:                                          ; 
        mov  wb,p_pac                           ; load pcode for p_pac node} mov wb =p_pac 
        pop  wc                                 ; load name offset (parm2)} mov wc (xs)+ 
        pop  xr                                 ; load name base (parm1)} mov xr (xs)+ 
        call pbild                              ; build p_pac node} jsr pbild  
        mov  xl,xr                              ; save ptr to node} mov xl xr 
        mov  xr,m_word [xs]                     ; load left operand} mov xr (xs) 
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_24                            ; 
        dec  m_word [_rc_]                      ; } err 030 pattern assignment left operand is not pattern 
        jns  _l0041                             ; 
        mov  m_word [_rc_],30                   ; 
        jmp  err_                               ; 
_l0041:                                         ; 
call_24:                                        ; 
        mov  m_word [xs],xr                     ; save ptr to left operand pattern} mov (xs) xr 
        mov  wb,p_paa                           ; set pcode for p_paa node} mov wb =p_paa 
        call pbild                              ; build p_paa node} jsr pbild  
        pop  m_word [(cfp_b*pthen)+xr]          ; set left operand as p_paa successor} mov pthen(xr) (xs)+ 
        call pconc                              ; concatenate to form final pattern} jsr pconc  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_pmn:                                          ; 
        xor  wb,wb                              ; set type code for match by name} zer wb  
        jmp  match                              ; jump to routine to start match} brn match  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_pms:                                          ; 
        mov  wb,num02                           ; set flag for statement to match} mov wb =num02 
        jmp  match                              ; jump to routine to start match} brn match  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_pmv:                                          ; 
        mov  wb,num01                           ; set type code for value match} mov wb =num01 
        jmp  match                              ; jump to routine to start match} brn match  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_pop:                                          ; 
        add  xs,cfp_b                           ; pop top stack entry} ica xs  
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_stp:                                          ; 
        jmp  lend0                              ; jump to end circuit} brn lend0  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_rnm:                                          ; 
        jmp  evlx4                              ; return to evalx procedure} brn evlx4  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_rpl:                                          ; 
        call gtstg                              ; convert replacement val to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_25                            ; 
        dec  m_word [_rc_]                      ; } err 031 pattern replacement right operand is not a string 
        jns  _l0042                             ; 
        mov  m_word [_rc_],31                   ; 
        jmp  err_                               ; 
_l0042:                                         ; 
call_25:                                        ; 
        mov  xl,m_word [xs]                     ; load subject string pointer} mov xl (xs) 
        add  wa,m_word [(cfp_b*sclen)+xl]       ; add subject string length} add wa sclen(xl) 
        add  wa,m_word [(cfp_b*num02)+xs]       ; add starting cursor} add wa num02(xs) 
        sub  wa,m_word [(cfp_b*num01)+xs]       ; minus final cursor = total length} sub wa num01(xs) 
        test wa,wa                              ; jump if result is null} bze wa orpl3 
        jz   orpl3                              ; 
        push xr                                 ; restack replacement string} mov -(xs) xr 
        call alocs                              ; allocate scblk for result} jsr alocs  
        mov  wa,m_word [(cfp_b*num03)+xs]       ; get initial cursor (part 1 len)} mov wa num03(xs) 
        mov  m_word [(cfp_b*num03)+xs],xr       ; stack result pointer} mov num03(xs) xr 
        add  xr,cfp_f                           ; point to characters of result} psc xr  
        test wa,wa                              ; jump if first part is null} bze wa orpl1 
        jz   orpl1                              ; 
        mov  xl,m_word [(cfp_b*num01)+xs]       ; else point to subject string} mov xl num01(xs) 
        add  xl,cfp_f                           ; point to subject string chars} plc xl  
        rep                                     ; move first part to result} mvc   
        movs_b                                  ; 
orpl1:
        pop  xl                                 ; load replacement string, pop} mov xl (xs)+ 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load length} mov wa sclen(xl) 
        test wa,wa                              ; jump if null replacement} bze wa orpl2 
        jz   orpl2                              ; 
        add  xl,cfp_f                           ; else point to chars of replacement} plc xl  
        rep                                     ; move in chars (part 2)} mvc   
        movs_b                                  ; 
orpl2:
        pop  xl                                 ; load subject string pointer, pop} mov xl (xs)+ 
        pop  wc                                 ; load final cursor, pop} mov wc (xs)+ 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load subject string length} mov wa sclen(xl) 
        sub  wa,wc                              ; minus final cursor = part 3 length} sub wa wc 
        test wa,wa                              ; jump to assign if part 3 is null} bze wa oass0 
        jz   oass0                              ; 
        lea  xl,[cfp_f+xl+wc]                   ; else point to last part of string} plc xl wc 
        rep                                     ; move part 3 to result} mvc   
        movs_b                                  ; 
        jmp  oass0                              ; jump to perform assignment} brn oass0  
orpl3:
        add  xs,cfp_b*num02                     ; pop subject str ptr, final cursor} add xs *num02 
        mov  m_word [xs],nulls                  ; set null result} mov (xs) =nulls 
        jmp  oass0                              ; jump to assign null value} brn oass0  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_rvl:                                          ; 
        jmp  evlx3                              ; return to evalx procedure} brn evlx3  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_sla:                                          ; 
        mov  r10,m_word [r13]                   ; load new failure offset} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        push m_word [flptr]                     ; stack old failure pointer} mov -(xs) flptr 
        push wa                                 ; stack new failure offset} mov -(xs) wa 
        mov  m_word [flptr],xs                  ; set new failure pointer} mov flptr xs 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_slb:                                          ; 
        pop  xr                                 ; load result} mov xr (xs)+ 
        add  xs,cfp_b                           ; pop fail offset} ica xs  
        mov  w0,m_word [xs]                     ; restore old failure pointer} mov flptr (xs) 
        mov  m_word [flptr],w0                  ; 
        mov  m_word [xs],xr                     ; restack result} mov (xs) xr 
        mov  r10,m_word [r13]                   ; load new code offset} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        add  wa,m_word [r_cod]                  ; point to absolute code location} add wa r_cod 
        mov  r13,wa                             ; set new code pointer} lcp wa  
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_slc:                                          ; 
        mov  r10,m_word [r13]                   ; load new fail offset} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  m_word [xs],wa                     ; store new fail offset} mov (xs) wa 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_sld:                                          ; 
        add  xs,cfp_b                           ; pop failure offset} ica xs  
        pop  m_word [flptr]                     ; restore old failure pointer} mov flptr (xs)+ 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_sub:                                          ; 
        call arith                              ; fetch arithmetic operands} jsr arith  
        dec  m_word [_rc_]                      ; 
        js   call_26                            ; 
        dec  m_word [_rc_]                      ; } err 032 subtraction left operand is not numeric 
        jns  _l0046                             ; 
        mov  m_word [_rc_],32                   ; 
        jmp  err_                               ; 
_l0046:                                         ; 
        dec  m_word [_rc_]                      ; } err 033 subtraction right operand is not numeric 
        jns  _l0047                             ; 
        mov  m_word [_rc_],33                   ; 
        jmp  err_                               ; 
_l0047:                                         ; 
        dec  m_word [_rc_]                      ; jump if real operands} ppm osub1  
        jns  _l0048                             ; 
        jmp  osub1                              ; 
_l0048:                                         ; 
call_26:                                        ; 
        sub  ia,m_word [(cfp_b*icval)+xl]       ; subtract right operand from left} sbi icval(xl)  
        jno  exint                              ; return integer if no overflow} ino exint  
        mov  m_word [_rc_],34                   ; } erb 034 subtraction caused integer overflow 
        jmp  err_                               ; 
osub1:
        ldmxcsr [mxcsr_set]                     ; subtract right operand from left} sbr rcval(xl)  
        subsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0049                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0049:                                         ; 
        call do_chk_real_inf                    ; return real if no overflow} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],264                  ; } erb 264 subtraction caused real overflow 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_txr:                                          ; 
        jmp  trxq1                              ; jump into trxeq procedure} brn trxq1  
        align 2                                 ; entry point} ent   
        nop                                     ; 
o_unf:                                          ; 
        mov  m_word [_rc_],35                   ; } erb 035 unexpected failure in -nofail mode 
        jmp  err_                               ; 
        align 2                                 ; entry point of first block routine} ent bl__i  
        db   bl__i                              ; 
b_aaa:                                          ; 
        align 2                                 ; entry point (exblk)} ent bl_ex  
        db   bl_ex                              ; 
b_exl:                                          ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point (seblk)} ent bl_se  
        db   bl_se                              ; 
b_sel:                                          ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent bl__i  
        db   bl__i                              ; 
b_e__:                                          ; 
        align 2                                 ; entry point (trblk)} ent bl_tr  
        db   bl_tr                              ; 
b_trt:                                          ; 
        align 2                                 ; end of trblk,seblk,exblk entries} ent bl__i  
        db   bl__i                              ; 
b_t__:                                          ; 
        align 2                                 ; entry point (arblk)} ent bl_ar  
        db   bl_ar                              ; 
b_art:                                          ; 
        align 2                                 ; entry point (bcblk)} ent bl_bc  
        db   bl_bc                              ; 
b_bct:                                          ; 
        align 2                                 ; entry point (bfblk)} ent bl_bf  
        db   bl_bf                              ; 
b_bft:                                          ; 
        align 2                                 ; entry point (ccblk)} ent bl_cc  
        db   bl_cc                              ; 
b_cct:                                          ; 
        align 2                                 ; entry point (cdblk)} ent bl_cd  
        db   bl_cd                              ; 
b_cdc:                                          ; 
bcdc0:
        mov  xs,m_word [flptr]                  ; pop garbage off stack} mov xs flptr 
        mov  w0,m_word [(cfp_b*cdfal)+xr]       ; set failure offset} mov (xs) cdfal(xr) 
        mov  m_word [xs],w0                     ; 
        jmp  stmgo                              ; enter stmt} brn stmgo  
        align 2                                 ; entry point (cdblk)} ent bl_cd  
        db   bl_cd                              ; 
b_cds:                                          ; 
bcds0:
        mov  xs,m_word [flptr]                  ; pop garbage off stack} mov xs flptr 
        mov  m_word [xs],cfp_b*cdfal            ; set failure offset} mov (xs) *cdfal 
        jmp  stmgo                              ; enter stmt} brn stmgo  
        align 2                                 ; entry point (cmblk)} ent bl_cm  
        db   bl_cm                              ; 
b_cmt:                                          ; 
        align 2                                 ; entry point (ctblk)} ent bl_ct  
        db   bl_ct                              ; 
b_ctt:                                          ; 
        align 2                                 ; entry point} ent bl_df  
        db   bl_df                              ; 
b_dfc:                                          ; 
        mov  wa,m_word [(cfp_b*dfpdl)+xl]       ; load length of pdblk} mov wa dfpdl(xl) 
        call alloc                              ; allocate pdblk} jsr alloc  
        mov  m_word [xr],b_pdt                  ; store type word} mov (xr) =b_pdt 
        mov  m_word [(cfp_b*pddfp)+xr],xl       ; store dfblk pointer} mov pddfp(xr) xl 
        mov  wc,xr                              ; save pointer to pdblk} mov wc xr 
        add  xr,wa                              ; point past pdblk} add xr wa 
        mov  wa,m_word [(cfp_b*fargs)+xl]       ; set to count fields} lct wa fargs(xl) 
bdfc1:
        lea  xr,[xr-cfp_b]                      ; move a field value} mov -(xr) (xs)+ 
        pop  m_word [xr]                        ; 
        dec  wa                                 ; loop till all moved} bct wa bdfc1 
        jnz  bdfc1                              ; 
        mov  xr,wc                              ; recall pointer to pdblk} mov xr wc 
        jmp  exsid                              ; exit setting id field} brn exsid  
        align 2                                 ; entry point (efblk)} ent bl_ef  
        db   bl_ef                              ; 
b_efc:                                          ; 
        mov  wc,m_word [(cfp_b*fargs)+xl]       ; load number of arguments} mov wc fargs(xl) 
        sal  wc,log_cfp_b                       ; convert to offset} wtb wc  
        push xl                                 ; save pointer to efblk} mov -(xs) xl 
        mov  xl,xs                              ; copy pointer to arguments} mov xt xs 
befc1:
        add  xl,cfp_b                           ; point to next entry} ica xt  
        mov  xr,m_word [xs]                     ; load pointer to efblk} mov xr (xs) 
        sub  wc,cfp_b                           ; decrement eftar offset} dca wc  
        add  xr,wc                              ; point to next eftar entry} add xr wc 
        mov  xr,m_word [(cfp_b*eftar)+xr]       ; load eftar entry} mov xr eftar(xr) 
        jmp  m_word [_l0050+xr*cfp_b]           ; switch on type} bsw xr 5 
        segment .data                           ; 
_l0050:                                         ; 
        d_word befc7                            ; no conversion needed} iff 0 befc7 
        d_word befc2                            ; string} iff 1 befc2 
        d_word befc3                            ; integer} iff 2 befc3 
        d_word befc4                            ; real} iff 3 befc4 
        d_word beff1                            ; file} iff 4 beff1 
        segment .text                           ; end of switch on type} esw   
beff1:
        push xl                                 ; save entry pointer} mov -(xs) xt 
        mov  m_word [befof],wc                  ; save offset} mov befof wc 
        push m_word [xl]                        ; stack arg pointer} mov -(xs) (xt) 
        call iofcb                              ; convert to fcb} jsr iofcb  
        dec  m_word [_rc_]                      ; 
        js   call_27                            ; 
        dec  m_word [_rc_]                      ; } err 298 external function argument is not file 
        jns  _l0051                             ; 
        mov  m_word [_rc_],298                  ; 
        jmp  err_                               ; 
_l0051:                                         ; 
        dec  m_word [_rc_]                      ; } err 298 external function argument is not file 
        jns  _l0052                             ; 
        mov  m_word [_rc_],298                  ; 
        jmp  err_                               ; 
_l0052:                                         ; 
        dec  m_word [_rc_]                      ; } err 298 external function argument is not file 
        jns  _l0053                             ; 
        mov  m_word [_rc_],298                  ; 
        jmp  err_                               ; 
_l0053:                                         ; 
call_27:                                        ; 
        mov  xr,wa                              ; point to fcb} mov xr wa 
        pop  xl                                 ; reload entry pointer} mov xt (xs)+ 
        jmp  befc5                              ; jump to merge} brn befc5  
befc2:
        push m_word [xl]                        ; stack arg ptr} mov -(xs) (xt) 
        call gtstg                              ; convert argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_28                            ; 
        dec  m_word [_rc_]                      ; } err 039 external function argument is not a string 
        jns  _l0054                             ; 
        mov  m_word [_rc_],39                   ; 
        jmp  err_                               ; 
_l0054:                                         ; 
call_28:                                        ; 
        jmp  befc6                              ; jump to merge} brn befc6  
befc3:
        mov  xr,m_word [xl]                     ; load next argument} mov xr (xt) 
        mov  m_word [befof],wc                  ; save offset} mov befof wc 
        call gtint                              ; convert to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_29                            ; 
        dec  m_word [_rc_]                      ; } err 040 external function argument is not integer 
        jns  _l0055                             ; 
        mov  m_word [_rc_],40                   ; 
        jmp  err_                               ; 
_l0055:                                         ; 
call_29:                                        ; 
        jmp  befc5                              ; merge with real case} brn befc5  
befc4:
        mov  xr,m_word [xl]                     ; load next argument} mov xr (xt) 
        mov  m_word [befof],wc                  ; save offset} mov befof wc 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_30                            ; 
        dec  m_word [_rc_]                      ; } err 265 external function argument is not real 
        jns  _l0056                             ; 
        mov  m_word [_rc_],265                  ; 
        jmp  err_                               ; 
_l0056:                                         ; 
call_30:                                        ; 
befc5:
        mov  wc,m_word [befof]                  ; restore offset} mov wc befof 
befc6:
        mov  m_word [xl],xr                     ; store converted result} mov (xt) xr 
befc7:
        test wc,wc                              ; loop back if more to go} bnz wc befc1 
        jnz  befc1                              ; 
        pop  xl                                 ; restore efblk pointer} mov xl (xs)+ 
        mov  wa,m_word [(cfp_b*fargs)+xl]       ; get number of args} mov wa fargs(xl) 
        call sysex                              ; call routine to call external fnc} jsr sysex  
        dec  m_word [_rc_]                      ; 
        js   call_31                            ; 
        dec  m_word [_rc_]                      ; fail if failure} ppm exfal  
        jns  _l0057                             ; 
        jmp  exfal                              ; 
_l0057:                                         ; 
        dec  m_word [_rc_]                      ; } err 327 calling external function - not found 
        jns  _l0058                             ; 
        mov  m_word [_rc_],327                  ; 
        jmp  err_                               ; 
_l0058:                                         ; 
        dec  m_word [_rc_]                      ; } err 326 calling external function - bad argument type 
        jns  _l0059                             ; 
        mov  m_word [_rc_],326                  ; 
        jmp  err_                               ; 
_l0059:                                         ; 
call_31:                                        ; 
        sal  wa,log_cfp_b                       ; convert number of args to bytes} wtb wa  
        add  xs,wa                              ; remove arguments from stack} add xs wa 
        mov  wb,m_word [(cfp_b*efrsl)+xl]       ; get result type id} mov wb efrsl(xl) 
        test wb,wb                              ; branch if not unconverted} bnz wb befa8 
        jnz  befa8                              ; 
        cmp  m_word [xr],b_scl                  ; jump if not a string} bne (xr) =b_scl befc8
        jne  befc8                              ; 
        cmp  m_word [(cfp_b*sclen)+xr],0        ; return null if null} bze sclen(xr) exnul 
        jz   exnul                              ; 
befa8:
        cmp  wb,num01                           ; jump if not a string} bne wb =num01 befc8
        jne  befc8                              ; 
        cmp  m_word [(cfp_b*sclen)+xr],0        ; return null if null} bze sclen(xr) exnul 
        jz   exnul                              ; 
befc8:
        cmp  xr,m_word [dnamb]                  ; jump if not in dynamic storage} blt xr dnamb befc9
        jb   befc9                              ; 
        cmp  xr,m_word [dnamp]                  ; return result if already dynamic} ble xr dnamp exixr
        jbe  exixr                              ; 
befc9:
        mov  wa,m_word [xr]                     ; get possible type word} mov wa (xr) 
        test wb,wb                              ; jump if unconverted result} bze wb bef11 
        jz   bef11                              ; 
        mov  wa,b_scl                           ; string} mov wa =b_scl 
        cmp  wb,num01                           ; yes jump} beq wb =num01 bef10
        je   bef10                              ; 
        mov  wa,b_icl                           ; integer} mov wa =b_icl 
        cmp  wb,num02                           ; yes jump} beq wb =num02 bef10
        je   bef10                              ; 
        mov  wa,b_rcl                           ; real} mov wa =b_rcl 
bef10:
        mov  m_word [xr],wa                     ; stored before copying to dynamic} mov (xr) wa 
bef11:
        cmp  m_word [xr],b_scl                  ; branch if string result} beq (xr) =b_scl bef12
        je   bef12                              ; 
        call blkln                              ; get length of block} jsr blkln  
        mov  xl,xr                              ; copy address of old block} mov xl xr 
        call alloc                              ; allocate dynamic block same size} jsr alloc  
        push xr                                 ; set pointer to new block as result} mov -(xs) xr 
        shr  wa,log_cfp_b                       ; copy old block to dynamic block} mvw   
        rep  movs_w                             ; 
        xor  xl,xl                              ; clear garbage value} zer xl  
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
bef12:
        mov  xl,xr                              ; save source string pointer} mov xl xr 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; fetch string length} mov wa sclen(xr) 
        test wa,wa                              ; return null string if length zero} bze wa exnul 
        jz   exnul                              ; 
        call alocs                              ; allocate space for string} jsr alocs  
        push xr                                 ; save as result pointer} mov -(xs) xr 
        add  xr,cfp_f                           ; prepare to store chars of result} psc xr  
        add  xl,cfp_f                           ; point to chars in source string} plc xl  
        mov  wa,wc                              ; number of characters to copy} mov wa wc 
        rep                                     ; move characters to result string} mvc   
        movs_b                                  ; 
        xor  xl,xl                              ; clear garbage value} zer xl  
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point (evblk)} ent bl_ev  
        db   bl_ev                              ; 
b_evt:                                          ; 
        align 2                                 ; entry point (ffblk)} ent bl_ff  
        db   bl_ff                              ; 
b_ffc:                                          ; 
        mov  xr,xl                              ; copy ffblk pointer} mov xr xl 
        mov  r10,m_word [r13]                   ; load next code word} lcw wc  
        mov  wc,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  xl,m_word [xs]                     ; load pdblk pointer} mov xl (xs) 
        cmp  m_word [xl],b_pdt                  ; jump if not pdblk at all} bne (xl) =b_pdt bffc2
        jne  bffc2                              ; 
        mov  wa,m_word [(cfp_b*pddfp)+xl]       ; load dfblk pointer from pdblk} mov wa pddfp(xl) 
bffc1:
        cmp  wa,m_word [(cfp_b*ffdfp)+xr]       ; jump if this is the correct ffblk} beq wa ffdfp(xr) bffc3
        je   bffc3                              ; 
        mov  xr,m_word [(cfp_b*ffnxt)+xr]       ; else link to next ffblk on chain} mov xr ffnxt(xr) 
        test xr,xr                              ; loop back if another entry to check} bnz xr bffc1 
        jnz  bffc1                              ; 
bffc2:
        mov  m_word [_rc_],41                   ; } erb 041 field function argument is wrong datatype 
        jmp  err_                               ; 
bffc3:
        mov  wa,m_word [(cfp_b*ffofs)+xr]       ; load field offset} mov wa ffofs(xr) 
        cmp  wc,ofne_                           ; jump if called by name} beq wc =ofne_ bffc5
        je   bffc5                              ; 
        add  xl,wa                              ; else point to value field} add xl wa 
        mov  xr,m_word [xl]                     ; load value} mov xr (xl) 
        cmp  m_word [xr],b_trt                  ; jump if not trapped} bne (xr) =b_trt bffc4
        jne  bffc4                              ; 
        sub  xl,wa                              ; else restore name base,offset} sub xl wa 
        mov  m_word [xs],wc                     ; save next code word over pdblk ptr} mov (xs) wc 
        call acess                              ; access value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_32                            ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0061                             ; 
        jmp  exfal                              ; 
_l0061:                                         ; 
call_32:                                        ; 
        mov  wc,m_word [xs]                     ; restore next code word} mov wc (xs) 
bffc4:
        mov  m_word [xs],xr                     ; store value on stack (over pdblk)} mov (xs) xr 
        mov  xr,wc                              ; copy next code word} mov xr wc 
        mov  xl,m_word [xr]                     ; load entry address} mov xl (xr) 
        jmp  xl                                 ; jump to routine for next code word} bri xl  
bffc5:
        push wa                                 ; store name offset (base is set)} mov -(xs) wa 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point (icblk)} ent bl_ic  
        db   bl_ic                              ; 
b_icl:                                          ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point (kvblk)} ent bl_kv  
        db   bl_kv                              ; 
b_kvt:                                          ; 
        align 2                                 ; entry point (nmblk)} ent bl_nm  
        db   bl_nm                              ; 
b_nml:                                          ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point (pdblk)} ent bl_pd  
        db   bl_pd                              ; 
b_pdt:                                          ; 
        align 2                                 ; entry point (pfblk)} ent bl_pf  
        db   bl_pf                              ; 
b_pfc:                                          ; 
        mov  m_word [bpfpf],xl                  ; save pfblk ptr (need not be reloc)} mov bpfpf xl 
        mov  xr,xl                              ; copy for the moment} mov xr xl 
        mov  xl,m_word [(cfp_b*pfvbl)+xr]       ; point to vrblk for function} mov xl pfvbl(xr) 
bpf01:
        mov  wb,xl                              ; save pointer} mov wb xl 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load value} mov xl vrval(xl) 
        cmp  m_word [xl],b_trt                  ; loop if trblk} beq (xl) =b_trt bpf01
        je   bpf01                              ; 
        mov  m_word [bpfsv],xl                  ; save old value} mov bpfsv xl 
        mov  xl,wb                              ; point back to block with value} mov xl wb 
        mov  m_word [(cfp_b*vrval)+xl],nulls    ; set value to null} mov vrval(xl) =nulls 
        mov  wa,m_word [(cfp_b*fargs)+xr]       ; load number of arguments} mov wa fargs(xr) 
        add  xr,cfp_b*pfarg                     ; point to pfarg entries} add xr *pfarg 
        test wa,wa                              ; jump if no arguments} bze wa bpf04 
        jz   bpf04                              ; 
        mov  xl,xs                              ; ptr to last arg} mov xt xs 
        sal  wa,log_cfp_b                       ; convert no. of args to bytes offset} wtb wa  
        add  xl,wa                              ; point before first arg} add xt wa 
        mov  m_word [bpfxt],xl                  ; remember arg pointer} mov bpfxt xt 
bpf02:
        mov  xl,m_word [xr]                     ; load vrblk ptr for next argument} mov xl (xr)+ 
        lea  xr,[xr+cfp_b]                      ; 
bpf03:
        mov  wc,xl                              ; save pointer} mov wc xl 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load next value} mov xl vrval(xl) 
        cmp  m_word [xl],b_trt                  ; loop back if trblk} beq (xl) =b_trt bpf03
        je   bpf03                              ; 
        mov  wa,xl                              ; keep old value} mov wa xl 
        mov  xl,m_word [bpfxt]                  ; point before next stacked arg} mov xt bpfxt 
        lea  xl,[xl-cfp_b]                      ; load argument (new value)} mov wb -(xt) 
        mov  wb,m_word [xl]                     ; 
        mov  m_word [xl],wa                     ; save old value} mov (xt) wa 
        mov  m_word [bpfxt],xl                  ; keep arg ptr for next time} mov bpfxt xt 
        mov  xl,wc                              ; point back to block with value} mov xl wc 
        mov  m_word [(cfp_b*vrval)+xl],wb       ; set new value} mov vrval(xl) wb 
        cmp  xs,m_word [bpfxt]                  ; loop if not all done} bne xs bpfxt bpf02
        jne  bpf02                              ; 
bpf04:
        mov  xl,m_word [bpfpf]                  ; restore pfblk pointer} mov xl bpfpf 
        mov  wa,m_word [(cfp_b*pfnlo)+xl]       ; load number of locals} mov wa pfnlo(xl) 
        test wa,wa                              ; jump if no locals} bze wa bpf07 
        jz   bpf07                              ; 
        mov  wb,nulls                           ; get null constant} mov wb =nulls 
bpf05:
        mov  xl,m_word [xr]                     ; load vrblk ptr for next local} mov xl (xr)+ 
        lea  xr,[xr+cfp_b]                      ; 
bpf06:
        mov  wc,xl                              ; save pointer} mov wc xl 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load next value} mov xl vrval(xl) 
        cmp  m_word [xl],b_trt                  ; loop back if trblk} beq (xl) =b_trt bpf06
        je   bpf06                              ; 
        push xl                                 ; stack old value} mov -(xs) xl 
        mov  xl,wc                              ; point back to block with value} mov xl wc 
        mov  m_word [(cfp_b*vrval)+xl],wb       ; set null as new value} mov vrval(xl) wb 
        dec  wa                                 ; loop till all locals processed} bct wa bpf05 
        jnz  bpf05                              ; 
bpf07:
        xor  xr,xr                              ; zero reg xr in case} zer xr  
        cmp  m_word [kvpfl],0                   ; skip if profiling is off} bze kvpfl bpf7c 
        jz   bpf7c                              ; 
        cmp  m_word [kvpfl],num02               ; branch on type of profile} beq kvpfl =num02 bpf7a
        je   bpf7a                              ; 
        call systm                              ; get current time} jsr systm  
        mov  m_word [pfetm],ia                  ; save for a sec} sti pfetm  
        sub  ia,m_word [pfstm]                  ; find time used by caller} sbi pfstm  
        call icbld                              ; build into an icblk} jsr icbld  
        mov  ia,m_word [pfetm]                  ; reload current time} ldi pfetm  
        jmp  bpf7b                              ; merge} brn bpf7b  
bpf7a:
        mov  ia,m_word [pfstm]                  ; get start time of calling stmt} ldi pfstm  
        call icbld                              ; assemble an icblk round it} jsr icbld  
        call systm                              ; get now time} jsr systm  
bpf7b:
        mov  m_word [pfstm],ia                  ; set start time of 1st func stmt} sti pfstm  
        mov  m_word [pffnc],xs                  ; flag function entry} mnz pffnc  
bpf7c:
        push xr                                 ; stack icblk ptr (or zero)} mov -(xs) xr 
        mov  wa,m_word [r_cod]                  ; load old code block pointer} mov wa r_cod 
        mov  wb,r13                             ; get code pointer} scp wb  
        sub  wb,wa                              ; make code pointer into offset} sub wb wa 
        mov  xl,m_word [bpfpf]                  ; recall pfblk pointer} mov xl bpfpf 
        push m_word [bpfsv]                     ; stack old value of function name} mov -(xs) bpfsv 
        push wa                                 ; stack code block pointer} mov -(xs) wa 
        push wb                                 ; stack code offset} mov -(xs) wb 
        push m_word [flprt]                     ; stack old flprt} mov -(xs) flprt 
        push m_word [flptr]                     ; stack old failure pointer} mov -(xs) flptr 
        push xl                                 ; stack pointer to pfblk} mov -(xs) xl 
        push 0                                  ; dummy zero entry for fail return} zer -(xs)  
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0062                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0062:                                         ; 
        mov  m_word [flptr],xs                  ; set new fail return value} mov flptr xs 
        mov  m_word [flprt],xs                  ; set new flprt} mov flprt xs 
        mov  wa,m_word [kvtra]                  ; load trace value} mov wa kvtra 
        add  wa,m_word [kvftr]                  ; add ftrace value} add wa kvftr 
        test wa,wa                              ; jump if tracing possible} bnz wa bpf09 
        jnz  bpf09                              ; 
        inc  m_word [kvfnc]                     ; else bump fnclevel} icv kvfnc  
bpf08:
        mov  xr,m_word [(cfp_b*pfcod)+xl]       ; point to vrblk of entry label} mov xr pfcod(xl) 
        mov  xr,m_word [(cfp_b*vrlbl)+xr]       ; point to target code} mov xr vrlbl(xr) 
        cmp  xr,stndl                           ; test for undefined label} beq xr =stndl bpf17
        je   bpf17                              ; 
        cmp  m_word [xr],b_trt                  ; jump if not trapped} bne (xr) =b_trt bpf8a
        jne  bpf8a                              ; 
        mov  xr,m_word [(cfp_b*trlbl)+xr]       ; else load ptr to real label code} mov xr trlbl(xr) 
bpf8a:
        jmp  m_word [xr]                        ; off to execute function} bri (xr)  
bpf09:
        mov  xr,m_word [(cfp_b*pfctr)+xl]       ; load possible call trace trblk} mov xr pfctr(xl) 
        mov  xl,m_word [(cfp_b*pfvbl)+xl]       ; load vrblk pointer for function} mov xl pfvbl(xl) 
        mov  wa,cfp_b*vrval                     ; set name offset for variable} mov wa *vrval 
        cmp  m_word [kvtra],0                   ; jump if trace mode is off} bze kvtra bpf10 
        jz   bpf10                              ; 
        test xr,xr                              ; or if there is no call trace} bze xr bpf10 
        jz   bpf10                              ; 
        dec  m_word [kvtra]                     ; decrement trace count} dcv kvtra  
        cmp  m_word [(cfp_b*trfnc)+xr],0        ; jump if print trace} bze trfnc(xr) bpf11 
        jz   bpf11                              ; 
        call trxeq                              ; execute function type trace} jsr trxeq  
bpf10:
        cmp  m_word [kvftr],0                   ; jump if ftrace is off} bze kvftr bpf16 
        jz   bpf16                              ; 
        dec  m_word [kvftr]                     ; else decrement ftrace} dcv kvftr  
bpf11:
        call prtsn                              ; print statement number} jsr prtsn  
        call prtnm                              ; print function name} jsr prtnm  
        mov  wa,ch_pp                           ; load left paren} mov wa =ch_pp 
        call prtch                              ; print left paren} jsr prtch  
        mov  xl,m_word [(cfp_b*num01)+xs]       ; recover pfblk pointer} mov xl num01(xs) 
        cmp  m_word [(cfp_b*fargs)+xl],0        ; skip if no arguments} bze fargs(xl) bpf15 
        jz   bpf15                              ; 
        xor  wb,wb                              ; else set argument counter} zer wb  
        jmp  bpf13                              ; jump into loop} brn bpf13  
bpf12:
        mov  wa,ch_cm                           ; load comma} mov wa =ch_cm 
        call prtch                              ; print to separate from last arg} jsr prtch  
bpf13:
        mov  m_word [xs],wb                     ; save arg ctr (over failoffs is ok)} mov (xs) wb 
        sal  wb,log_cfp_b                       ; convert to byte offset} wtb wb  
        add  xl,wb                              ; point to next argument pointer} add xl wb 
        mov  xr,m_word [(cfp_b*pfarg)+xl]       ; load next argument vrblk ptr} mov xr pfarg(xl) 
        sub  xl,wb                              ; restore pfblk pointer} sub xl wb 
        mov  xr,m_word [(cfp_b*vrval)+xr]       ; load next value} mov xr vrval(xr) 
        call prtvl                              ; print argument value} jsr prtvl  
        mov  wb,m_word [xs]                     ; restore argument counter} mov wb (xs) 
        inc  wb                                 ; increment argument counter} icv wb  
        cmp  wb,m_word [(cfp_b*fargs)+xl]       ; loop if more to print} blt wb fargs(xl) bpf12
        jb   bpf12                              ; 
bpf15:
        mov  wa,ch_rp                           ; load right paren} mov wa =ch_rp 
        call prtch                              ; print to terminate output} jsr prtch  
        call prtnl                              ; terminate print line} jsr prtnl  
bpf16:
        inc  m_word [kvfnc]                     ; increment fnclevel} icv kvfnc  
        mov  xl,m_word [r_fnc]                  ; load ptr to possible trblk} mov xl r_fnc 
        call ktrex                              ; call keyword trace routine} jsr ktrex  
        mov  xl,m_word [(cfp_b*num01)+xs]       ; restore pfblk pointer} mov xl num01(xs) 
        jmp  bpf08                              ; jump back to execute function} brn bpf08  
bpf17:
        mov  w0,m_word [(cfp_b*num02)+xs]       ; reset so exfal can return to evalx} mov flptr num02(xs) 
        mov  m_word [flptr],w0                  ; 
        mov  m_word [_rc_],286                  ; } erb 286 function call to undefined entry label 
        jmp  err_                               ; 
        align 2                                 ; entry point (rcblk)} ent bl_rc  
        db   bl_rc                              ; 
b_rcl:                                          ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point (scblk)} ent bl_sc  
        db   bl_sc                              ; 
b_scl:                                          ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point (tbblk)} ent bl_tb  
        db   bl_tb                              ; 
b_tbt:                                          ; 
        align 2                                 ; entry point (teblk)} ent bl_te  
        db   bl_te                              ; 
b_tet:                                          ; 
        align 2                                 ; entry point (vcblk)} ent bl_vc  
        db   bl_vc                              ; 
b_vct:                                          ; 
        align 2                                 ; mark start of vrblk entry points} ent bl__i  
        db   bl__i                              ; 
b_vr_:                                          ; 
        align 2                                 ; entry point} ent bl__i  
        db   bl__i                              ; 
b_vra:                                          ; 
        mov  xl,xr                              ; copy name base (vrget = 0)} mov xl xr 
        mov  wa,cfp_b*vrval                     ; set name offset} mov wa *vrval 
        call acess                              ; access value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_33                            ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0063                             ; 
        jmp  exfal                              ; 
_l0063:                                         ; 
call_33:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
b_vre:                                          ; 
        mov  m_word [_rc_],42                   ; } erb 042 attempt to change value of protected variable 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
b_vrg:                                          ; 
        mov  xr,m_word [(cfp_b*vrlbo)+xr]       ; load code pointer} mov xr vrlbo(xr) 
        mov  xl,m_word [xr]                     ; load entry address} mov xl (xr) 
        jmp  xl                                 ; jump to routine for next code word} bri xl  
        align 2                                 ; entry point} ent   
        nop                                     ; 
b_vrl:                                          ; 
        push m_word [(cfp_b*vrval)+xr]          ; load value onto stack (vrget = 0)} mov -(xs) vrval(xr) 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
b_vrs:                                          ; 
        mov  w0,m_word [xs]                     ; store value, leave on stack} mov vrvlo(xr) (xs) 
        mov  m_word [(cfp_b*vrvlo)+xr],w0       ; 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
b_vrt:                                          ; 
        sub  xr,cfp_b*vrtra                     ; point back to start of vrblk} sub xr *vrtra 
        mov  xl,xr                              ; copy vrblk pointer} mov xl xr 
        mov  wa,cfp_b*vrval                     ; set name offset} mov wa *vrval 
        mov  xr,m_word [(cfp_b*vrlbl)+xl]       ; load pointer to trblk} mov xr vrlbl(xl) 
        cmp  m_word [kvtra],0                   ; jump if trace is off} bze kvtra bvrt2 
        jz   bvrt2                              ; 
        dec  m_word [kvtra]                     ; else decrement trace count} dcv kvtra  
        cmp  m_word [(cfp_b*trfnc)+xr],0        ; jump if print trace case} bze trfnc(xr) bvrt1 
        jz   bvrt1                              ; 
        call trxeq                              ; else execute full trace} jsr trxeq  
        jmp  bvrt2                              ; merge to jump to label} brn bvrt2  
bvrt1:
        call prtsn                              ; print statement number} jsr prtsn  
        mov  xr,xl                              ; copy vrblk pointer} mov xr xl 
        mov  wa,ch_cl                           ; colon} mov wa =ch_cl 
        call prtch                              ; print it} jsr prtch  
        mov  wa,ch_pp                           ; left paren} mov wa =ch_pp 
        call prtch                              ; print it} jsr prtch  
        call prtvn                              ; print label name} jsr prtvn  
        mov  wa,ch_rp                           ; right paren} mov wa =ch_rp 
        call prtch                              ; print it} jsr prtch  
        call prtnl                              ; terminate line} jsr prtnl  
        mov  xr,m_word [(cfp_b*vrlbl)+xl]       ; point back to trblk} mov xr vrlbl(xl) 
bvrt2:
        mov  xr,m_word [(cfp_b*trlbl)+xr]       ; load pointer to actual code} mov xr trlbl(xr) 
        jmp  m_word [xr]                        ; execute statement at label} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
b_vrv:                                          ; 
        mov  wb,m_word [xs]                     ; load value (leave copy on stack)} mov wb (xs) 
        sub  xr,cfp_b*vrsto                     ; point to vrblk} sub xr *vrsto 
        mov  xl,xr                              ; copy vrblk pointer} mov xl xr 
        mov  wa,cfp_b*vrval                     ; set offset} mov wa *vrval 
        call asign                              ; call assignment routine} jsr asign  
        dec  m_word [_rc_]                      ; 
        js   call_34                            ; 
        dec  m_word [_rc_]                      ; fail if assignment fails} ppm exfal  
        jns  _l0064                             ; 
        jmp  exfal                              ; 
_l0064:                                         ; 
call_34:                                        ; 
        mov  r10,m_word [r13]                   ; else get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point (xnblk)} ent bl_xn  
        db   bl_xn                              ; 
b_xnt:                                          ; 
        align 2                                 ; entry point (xrblk)} ent bl_xr  
        db   bl_xr                              ; 
b_xrt:                                          ; 
        align 2                                 ; last block routine entry point} ent bl__i  
        db   bl__i                              ; 
b_yyy:                                          ; 
        align 2                                 ; entry to mark first pattern} ent bl__i  
        db   bl__i                              ; 
p_aaa:                                          ; 
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_aba:                                          ; 
        push wb                                 ; stack cursor} mov -(xs) wb 
        push xr                                 ; stack dummy node ptr} mov -(xs) xr 
        push m_word [pmhbs]                     ; stack old stack base ptr} mov -(xs) pmhbs 
        push ndabb                              ; stack ptr to node ndabb} mov -(xs) =ndabb 
        mov  m_word [pmhbs],xs                  ; store new stack base ptr} mov pmhbs xs 
        jmp  succp                              ; succeed} brn succp  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_abb:                                          ; 
        mov  m_word [pmhbs],wb                  ; restore history stack base ptr} mov pmhbs wb 
        jmp  flpop                              ; fail and pop dummy node ptr} brn flpop  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_abc:                                          ; 
        mov  xl,m_word [pmhbs]                  ; keep p_abb stack base} mov xt pmhbs 
        mov  wa,m_word [(cfp_b*num03)+xl]       ; load initial cursor} mov wa num03(xt) 
        mov  w0,m_word [(cfp_b*num01)+xl]       ; restore outer stack base ptr} mov pmhbs num01(xt) 
        mov  m_word [pmhbs],w0                  ; 
        cmp  xl,xs                              ; jump if no history stack entries} beq xt xs pabc1
        je   pabc1                              ; 
        push xl                                 ; else save inner pmhbs entry} mov -(xs) xt 
        push ndabd                              ; stack ptr to special node ndabd} mov -(xs) =ndabd 
        jmp  pabc2                              ; merge} brn pabc2  
pabc1:
        add  xs,cfp_b*num04                     ; remove ndabb entry and cursor} add xs *num04 
pabc2:
        cmp  wa,wb                              ; allow further attempt if non-null} bne wa wb succp
        jne  succp                              ; 
        mov  xr,m_word [(cfp_b*pthen)+xr]       ; bypass alternative node so as to ...} mov xr pthen(xr) 
        jmp  succp                              ; ... refuse further match attempts} brn succp  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_abd:                                          ; 
        mov  m_word [pmhbs],wb                  ; restore inner stack base ptr} mov pmhbs wb 
        jmp  failp                              ; and fail} brn failp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_abo:                                          ; 
        jmp  exfal                              ; signal statement failure} brn exfal  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_alt:                                          ; 
        push wb                                 ; stack cursor} mov -(xs) wb 
        push m_word [(cfp_b*parm1)+xr]          ; stack pointer to alternative} mov -(xs) parm1(xr) 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0065                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0065:                                         ; 
        jmp  succp                              ; if all ok, then succeed} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_ans:                                          ; 
        cmp  wb,m_word [pmssl]                  ; fail if no chars left} beq wb pmssl failp
        je   failp                              ; 
        mov  xl,m_word [r_pms]                  ; else point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character} plc xl wb 
        xor  w0,w0                              ; load current character} lch wa (xl) 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        cmp  wa,m_word [(cfp_b*parm1)+xr]       ; fail if no match} bne wa parm1(xr) failp
        jne  failp                              ; 
        inc  wb                                 ; else bump cursor} icv wb  
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; p2blk} ent bl_p2  
        db   bl_p2                              ; 
p_any:                                          ; 
pany1:
        cmp  wb,m_word [pmssl]                  ; fail if no characters left} beq wb pmssl failp
        je   failp                              ; 
        mov  xl,m_word [r_pms]                  ; else point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; get char ptr to current character} plc xl wb 
        xor  w0,w0                              ; load current character} lch wa (xl) 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        mov  xl,m_word [(cfp_b*parm1)+xr]       ; point to ctblk} mov xl parm1(xr) 
        sal  wa,log_cfp_b                       ; change to byte offset} wtb wa  
        add  xl,wa                              ; point to entry in ctblk} add xl wa 
        mov  wa,m_word [(cfp_b*ctchs)+xl]       ; load word from ctblk} mov wa ctchs(xl) 
        and  wa,m_word [(cfp_b*parm2)+xr]       ; and with selected bit} anb wa parm2(xr) 
        test wa,wa                              ; fail if no match} zrb wa failp 
        jz   failp                              ; 
        inc  wb                                 ; else bump cursor} icv wb  
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_ayd:                                          ; 
        call evals                              ; evaluate string argument} jsr evals  
        dec  m_word [_rc_]                      ; 
        js   call_35                            ; 
        dec  m_word [_rc_]                      ; } err 043 any evaluated argument is not a string 
        jns  _l0066                             ; 
        mov  m_word [_rc_],43                   ; 
        jmp  err_                               ; 
_l0066:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation failure} ppm failp  
        jns  _l0067                             ; 
        jmp  failp                              ; 
_l0067:                                         ; 
        dec  m_word [_rc_]                      ; merge multi-char case if ok} ppm pany1  
        jns  _l0068                             ; 
        jmp  pany1                              ; 
_l0068:                                         ; 
call_35:                                        ; 
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_arb:                                          ; 
        mov  xr,m_word [(cfp_b*pthen)+xr]       ; load successor pointer} mov xr pthen(xr) 
        push wb                                 ; stack dummy cursor} mov -(xs) wb 
        push xr                                 ; stack successor pointer} mov -(xs) xr 
        push wb                                 ; stack cursor} mov -(xs) wb 
        push ndarc                              ; stack ptr to special node ndarc} mov -(xs) =ndarc 
        jmp  m_word [xr]                        ; execute next node matching null} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_arc:                                          ; 
        cmp  wb,m_word [pmssl]                  ; fail and pop stack to successor} beq wb pmssl flpop
        je   flpop                              ; 
        inc  wb                                 ; else bump cursor} icv wb  
        push wb                                 ; stack updated cursor} mov -(xs) wb 
        push xr                                 ; restack pointer to ndarc node} mov -(xs) xr 
        mov  xr,m_word [(cfp_b*num02)+xs]       ; load successor pointer} mov xr num02(xs) 
        jmp  m_word [xr]                        ; off to reexecute successor node} bri (xr)  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_bal:                                          ; 
        xor  wc,wc                              ; zero parentheses level counter} zer wc  
        mov  xl,m_word [r_pms]                  ; point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character} plc xl wb 
        jmp  pbal2                              ; jump into scan loop} brn pbal2  
pbal1:
        xor  w0,w0                              ; load next character, bump pointer} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        inc  wb                                 ; push cursor for character} icv wb  
        cmp  wa,ch_pp                           ; jump if left paren} beq wa =ch_pp pbal3
        je   pbal3                              ; 
        cmp  wa,ch_rp                           ; jump if right paren} beq wa =ch_rp pbal4
        je   pbal4                              ; 
        test wc,wc                              ; else succeed if at outer level} bze wc pbal5 
        jz   pbal5                              ; 
pbal2:
        cmp  wb,m_word [pmssl]                  ; loop back unless end of string} bne wb pmssl pbal1
        jne  pbal1                              ; 
        jmp  failp                              ; in which case, fail} brn failp  
pbal3:
        inc  wc                                 ; bump paren level} icv wc  
        jmp  pbal2                              ; loop back to check end of string} brn pbal2  
pbal4:
        test wc,wc                              ; fail if no matching left paren} bze wc failp 
        jz   failp                              ; 
        dec  wc                                 ; else decrement level counter} dcv wc  
        test wc,wc                              ; loop back if not at outer level} bnz wc pbal2 
        jnz  pbal2                              ; 
pbal5:
        push wb                                 ; stack cursor} mov -(xs) wb 
        push xr                                 ; stack ptr to bal node for extend} mov -(xs) xr 
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_bkd:                                          ; 
        call evals                              ; evaluate string expression} jsr evals  
        dec  m_word [_rc_]                      ; 
        js   call_36                            ; 
        dec  m_word [_rc_]                      ; } err 044 break evaluated argument is not a string 
        jns  _l0069                             ; 
        mov  m_word [_rc_],44                   ; 
        jmp  err_                               ; 
_l0069:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0070                             ; 
        jmp  failp                              ; 
_l0070:                                         ; 
        dec  m_word [_rc_]                      ; merge with multi-char case if ok} ppm pbrk1  
        jns  _l0071                             ; 
        jmp  pbrk1                              ; 
_l0071:                                         ; 
call_36:                                        ; 
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_bks:                                          ; 
        mov  wc,m_word [pmssl]                  ; get subject string length} mov wc pmssl 
        sub  wc,wb                              ; get number of characters left} sub wc wb 
        test wc,wc                              ; fail if no characters left} bze wc failp 
        jz   failp                              ; 
        mov  xl,m_word [r_pms]                  ; point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character} plc xl wb 
pbks1:
        xor  w0,w0                              ; load next char, bump pointer} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        cmp  wa,m_word [(cfp_b*parm1)+xr]       ; succeed if break character found} beq wa parm1(xr) succp
        je   succp                              ; 
        inc  wb                                 ; else push cursor} icv wb  
        dec  wc                                 ; loop back if more to go} bct wc pbks1 
        jnz  pbks1                              ; 
        jmp  failp                              ; fail if end of string, no break chr} brn failp  
        align 2                                 ; p2blk} ent bl_p2  
        db   bl_p2                              ; 
p_brk:                                          ; 
pbrk1:
        mov  wc,m_word [pmssl]                  ; load subject string length} mov wc pmssl 
        sub  wc,wb                              ; get number of characters left} sub wc wb 
        test wc,wc                              ; fail if no characters left} bze wc failp 
        jz   failp                              ; 
        mov  xl,m_word [r_pms]                  ; else point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character} plc xl wb 
        mov  m_word [psave],xr                  ; save node pointer} mov psave xr 
pbrk2:
        xor  w0,w0                              ; load next char, bump pointer} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        mov  xr,m_word [(cfp_b*parm1)+xr]       ; load pointer to ctblk} mov xr parm1(xr) 
        sal  wa,log_cfp_b                       ; convert to byte offset} wtb wa  
        add  xr,wa                              ; point to ctblk entry} add xr wa 
        mov  wa,m_word [(cfp_b*ctchs)+xr]       ; load ctblk word} mov wa ctchs(xr) 
        mov  xr,m_word [psave]                  ; restore node pointer} mov xr psave 
        and  wa,m_word [(cfp_b*parm2)+xr]       ; and with selected bit} anb wa parm2(xr) 
        test wa,wa                              ; succeed if break character found} nzb wa succp 
        jnz  succp                              ; 
        inc  wb                                 ; else push cursor} icv wb  
        dec  wc                                 ; loop back unless end of string} bct wc pbrk2 
        jnz  pbrk2                              ; 
        jmp  failp                              ; fail if end of string, no break chr} brn failp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_bkx:                                          ; 
        inc  wb                                 ; step cursor past previous break chr} icv wb  
        jmp  succp                              ; succeed to rematch break} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_bxd:                                          ; 
        call evals                              ; evaluate string argument} jsr evals  
        dec  m_word [_rc_]                      ; 
        js   call_37                            ; 
        dec  m_word [_rc_]                      ; } err 045 breakx evaluated argument is not a string 
        jns  _l0072                             ; 
        mov  m_word [_rc_],45                   ; 
        jmp  err_                               ; 
_l0072:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0073                             ; 
        jmp  failp                              ; 
_l0073:                                         ; 
        dec  m_word [_rc_]                      ; merge with break if all ok} ppm pbrk1  
        jns  _l0074                             ; 
        jmp  pbrk1                              ; 
_l0074:                                         ; 
call_37:                                        ; 
        align 2                                 ; p2blk} ent bl_p2  
        db   bl_p2                              ; 
p_cas:                                          ; 
        push xr                                 ; save node pointer} mov -(xs) xr 
        push wb                                 ; save cursor} mov -(xs) wb 
        mov  xl,m_word [(cfp_b*parm1)+xr]       ; load name base} mov xl parm1(xr) 
        mov  ia,wb                              ; load cursor as integer} mti wb  
        mov  wb,m_word [(cfp_b*parm2)+xr]       ; load name offset} mov wb parm2(xr) 
        call icbld                              ; get icblk for cursor value} jsr icbld  
        mov  wa,wb                              ; move name offset} mov wa wb 
        mov  wb,xr                              ; move value to assign} mov wb xr 
        call asinp                              ; perform assignment} jsr asinp  
        dec  m_word [_rc_]                      ; 
        js   call_38                            ; 
        dec  m_word [_rc_]                      ; fail on assignment failure} ppm flpop  
        jns  _l0075                             ; 
        jmp  flpop                              ; 
_l0075:                                         ; 
call_38:                                        ; 
        pop  wb                                 ; else restore cursor} mov wb (xs)+ 
        pop  xr                                 ; restore node pointer} mov xr (xs)+ 
        jmp  succp                              ; and succeed matching null} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_exa:                                          ; 
        call evalp                              ; evaluate expression} jsr evalp  
        dec  m_word [_rc_]                      ; 
        js   call_39                            ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0076                             ; 
        jmp  failp                              ; 
_l0076:                                         ; 
call_39:                                        ; 
        cmp  wa,p_aaa                           ; jump if result is not a pattern} blo wa =p_aaa pexa1
        jb   pexa1                              ; 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0077                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0077:                                         ; 
        push wb                                 ; stack dummy cursor} mov -(xs) wb 
        push xr                                 ; stack ptr to p_exa node} mov -(xs) xr 
        push m_word [pmhbs]                     ; stack history stack base ptr} mov -(xs) pmhbs 
        push ndexb                              ; stack ptr to special node ndexb} mov -(xs) =ndexb 
        mov  m_word [pmhbs],xs                  ; store new stack base pointer} mov pmhbs xs 
        mov  xr,xl                              ; copy node pointer} mov xr xl 
        jmp  m_word [xr]                        ; match first node in expression pat} bri (xr)  
pexa1:
        cmp  wa,b_scl                           ; jump if it is already a string} beq wa =b_scl pexa2
        je   pexa2                              ; 
        push xl                                 ; else stack result} mov -(xs) xl 
        mov  xl,xr                              ; save node pointer} mov xl xr 
        call gtstg                              ; convert result to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_40                            ; 
        dec  m_word [_rc_]                      ; } err 046 expression does not evaluate to pattern 
        jns  _l0078                             ; 
        mov  m_word [_rc_],46                   ; 
        jmp  err_                               ; 
_l0078:                                         ; 
call_40:                                        ; 
        mov  wc,xr                              ; copy string pointer} mov wc xr 
        mov  xr,xl                              ; restore node pointer} mov xr xl 
        mov  xl,wc                              ; copy string pointer again} mov xl wc 
pexa2:
        cmp  m_word [(cfp_b*sclen)+xl],0        ; just succeed if null string} bze sclen(xl) succp 
        jz   succp                              ; 
        jmp  pstr1                              ; else merge with string circuit} brn pstr1  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_exb:                                          ; 
        mov  m_word [pmhbs],wb                  ; restore outer level stack pointer} mov pmhbs wb 
        jmp  flpop                              ; fail and pop p_exa node ptr} brn flpop  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_exc:                                          ; 
        mov  m_word [pmhbs],wb                  ; restore inner stack base pointer} mov pmhbs wb 
        jmp  failp                              ; and fail into expr pattern alternvs} brn failp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_fal:                                          ; 
        jmp  failp                              ; just signal failure} brn failp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_fen:                                          ; 
        push wb                                 ; stack dummy cursor} mov -(xs) wb 
        push ndabo                              ; stack ptr to abort node} mov -(xs) =ndabo 
        jmp  succp                              ; and succeed matching null} brn succp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_fna:                                          ; 
        push m_word [pmhbs]                     ; stack current history stack base} mov -(xs) pmhbs 
        push ndfnb                              ; stack indir ptr to p_fnb (failure)} mov -(xs) =ndfnb 
        mov  m_word [pmhbs],xs                  ; begin new history stack} mov pmhbs xs 
        jmp  succp                              ; succeed} brn succp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_fnb:                                          ; 
        mov  m_word [pmhbs],wb                  ; restore outer pmhbs stack base} mov pmhbs wb 
        jmp  failp                              ; ...and fail} brn failp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_fnc:                                          ; 
        mov  xl,m_word [pmhbs]                  ; get inner stack base ptr} mov xt pmhbs 
        mov  w0,m_word [(cfp_b*num01)+xl]       ; restore outer stack base} mov pmhbs num01(xt) 
        mov  m_word [pmhbs],w0                  ; 
        cmp  xl,xs                              ; optimize if no alternatives} beq xt xs pfnc1
        je   pfnc1                              ; 
        push xl                                 ; else stack inner stack base} mov -(xs) xt 
        push ndfnd                              ; stack ptr to ndfnd} mov -(xs) =ndfnd 
        jmp  succp                              ; succeed} brn succp  
pfnc1:
        add  xs,cfp_b*num02                     ; pop off p_fnb entry} add xs *num02 
        jmp  succp                              ; succeed} brn succp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_fnd:                                          ; 
        mov  xs,wb                              ; pop stack to fence() history base} mov xs wb 
        jmp  flpop                              ; pop base entry and fail} brn flpop  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_ima:                                          ; 
        push wb                                 ; stack cursor} mov -(xs) wb 
        push xr                                 ; stack dummy node pointer} mov -(xs) xr 
        push m_word [pmhbs]                     ; stack old stack base pointer} mov -(xs) pmhbs 
        push ndimb                              ; stack ptr to special node ndimb} mov -(xs) =ndimb 
        mov  m_word [pmhbs],xs                  ; store new stack base pointer} mov pmhbs xs 
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_imb:                                          ; 
        mov  m_word [pmhbs],wb                  ; restore history stack base ptr} mov pmhbs wb 
        jmp  flpop                              ; fail and pop dummy node ptr} brn flpop  
        align 2                                 ; p2blk} ent bl_p2  
        db   bl_p2                              ; 
p_imc:                                          ; 
        mov  xl,m_word [pmhbs]                  ; load pointer to p_imb entry} mov xt pmhbs 
        mov  wa,wb                              ; copy final cursor} mov wa wb 
        mov  wb,m_word [(cfp_b*num03)+xl]       ; load initial cursor} mov wb num03(xt) 
        mov  w0,m_word [(cfp_b*num01)+xl]       ; restore outer stack base pointer} mov pmhbs num01(xt) 
        mov  m_word [pmhbs],w0                  ; 
        cmp  xl,xs                              ; jump if no history stack entries} beq xt xs pimc1
        je   pimc1                              ; 
        push xl                                 ; else save inner pmhbs pointer} mov -(xs) xt 
        push ndimd                              ; and a ptr to special node ndimd} mov -(xs) =ndimd 
        jmp  pimc2                              ; merge} brn pimc2  
pimc1:
        add  xs,cfp_b*num04                     ; remove ndimb entry and cursor} add xs *num04 
pimc2:
        push wa                                 ; save current (final) cursor} mov -(xs) wa 
        push xr                                 ; save current node pointer} mov -(xs) xr 
        mov  xl,m_word [r_pms]                  ; point to subject string} mov xl r_pms 
        sub  wa,wb                              ; compute substring length} sub wa wb 
        call sbstr                              ; build substring} jsr sbstr  
        mov  wb,xr                              ; move result} mov wb xr 
        mov  xr,m_word [xs]                     ; reload node pointer} mov xr (xs) 
        mov  xl,m_word [(cfp_b*parm1)+xr]       ; load name base} mov xl parm1(xr) 
        mov  wa,m_word [(cfp_b*parm2)+xr]       ; load name offset} mov wa parm2(xr) 
        call asinp                              ; perform assignment} jsr asinp  
        dec  m_word [_rc_]                      ; 
        js   call_41                            ; 
        dec  m_word [_rc_]                      ; fail if assignment fails} ppm flpop  
        jns  _l0079                             ; 
        jmp  flpop                              ; 
_l0079:                                         ; 
call_41:                                        ; 
        pop  xr                                 ; else restore node pointer} mov xr (xs)+ 
        pop  wb                                 ; restore cursor} mov wb (xs)+ 
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_imd:                                          ; 
        mov  m_word [pmhbs],wb                  ; restore inner stack base pointer} mov pmhbs wb 
        jmp  failp                              ; and fail} brn failp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_len:                                          ; 
plen1:
        add  wb,m_word [(cfp_b*parm1)+xr]       ; push cursor indicated amount} add wb parm1(xr) 
        cmp  wb,m_word [pmssl]                  ; succeed if not off end} ble wb pmssl succp
        jbe  succp                              ; 
        jmp  failp                              ; else fail} brn failp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_lnd:                                          ; 
        call evali                              ; evaluate integer argument} jsr evali  
        dec  m_word [_rc_]                      ; 
        js   call_42                            ; 
        dec  m_word [_rc_]                      ; } err 047 len evaluated argument is not integer 
        jns  _l0080                             ; 
        mov  m_word [_rc_],47                   ; 
        jmp  err_                               ; 
_l0080:                                         ; 
        dec  m_word [_rc_]                      ; } err 048 len evaluated argument is negative or too large 
        jns  _l0081                             ; 
        mov  m_word [_rc_],48                   ; 
        jmp  err_                               ; 
_l0081:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0082                             ; 
        jmp  failp                              ; 
_l0082:                                         ; 
        dec  m_word [_rc_]                      ; merge with normal circuit if ok} ppm plen1  
        jns  _l0083                             ; 
        jmp  plen1                              ; 
_l0083:                                         ; 
call_42:                                        ; 
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_nad:                                          ; 
        call evals                              ; evaluate string argument} jsr evals  
        dec  m_word [_rc_]                      ; 
        js   call_43                            ; 
        dec  m_word [_rc_]                      ; } err 049 notany evaluated argument is not a string 
        jns  _l0084                             ; 
        mov  m_word [_rc_],49                   ; 
        jmp  err_                               ; 
_l0084:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0085                             ; 
        jmp  failp                              ; 
_l0085:                                         ; 
        dec  m_word [_rc_]                      ; merge with multi-char case if ok} ppm pnay1  
        jns  _l0086                             ; 
        jmp  pnay1                              ; 
_l0086:                                         ; 
call_43:                                        ; 
        align 2                                 ; entry point} ent bl_p1  
        db   bl_p1                              ; 
p_nas:                                          ; 
        cmp  wb,m_word [pmssl]                  ; fail if no chars left} beq wb pmssl failp
        je   failp                              ; 
        mov  xl,m_word [r_pms]                  ; else point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character in strin} plc xl wb 
        xor  w0,w0                              ; load current character} lch wa (xl) 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        cmp  wa,m_word [(cfp_b*parm1)+xr]       ; fail if match} beq wa parm1(xr) failp
        je   failp                              ; 
        inc  wb                                 ; else bump cursor} icv wb  
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; p2blk} ent bl_p2  
        db   bl_p2                              ; 
p_nay:                                          ; 
pnay1:
        cmp  wb,m_word [pmssl]                  ; fail if no characters left} beq wb pmssl failp
        je   failp                              ; 
        mov  xl,m_word [r_pms]                  ; else point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character} plc xl wb 
        xor  w0,w0                              ; load current character} lch wa (xl) 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        sal  wa,log_cfp_b                       ; convert to byte offset} wtb wa  
        mov  xl,m_word [(cfp_b*parm1)+xr]       ; load pointer to ctblk} mov xl parm1(xr) 
        add  xl,wa                              ; point to entry in ctblk} add xl wa 
        mov  wa,m_word [(cfp_b*ctchs)+xl]       ; load entry from ctblk} mov wa ctchs(xl) 
        and  wa,m_word [(cfp_b*parm2)+xr]       ; and with selected bit} anb wa parm2(xr) 
        test wa,wa                              ; fail if character is matched} nzb wa failp 
        jnz  failp                              ; 
        inc  wb                                 ; else bump cursor} icv wb  
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; p0blk (dummy)} ent bl_p0  
        db   bl_p0                              ; 
p_nth:                                          ; 
        mov  xl,m_word [pmhbs]                  ; load pointer to base of stack} mov xt pmhbs 
        mov  wa,m_word [(cfp_b*num01)+xl]       ; load saved pmhbs (or pattern type)} mov wa num01(xt) 
        cmp  wa,num02                           ; jump if outer level (pattern type)} ble wa =num02 pnth2
        jbe  pnth2                              ; 
        mov  m_word [pmhbs],wa                  ; restore outer stack base pointer} mov pmhbs wa 
        mov  xr,m_word [(cfp_b*num02)+xl]       ; restore pointer to p_exa node} mov xr num02(xt) 
        cmp  xl,xs                              ; jump if no history stack entries} beq xt xs pnth1
        je   pnth1                              ; 
        push xl                                 ; else stack inner stack base ptr} mov -(xs) xt 
        push ndexc                              ; stack ptr to special node ndexc} mov -(xs) =ndexc 
        jmp  succp                              ; and succeed} brn succp  
pnth1:
        add  xs,cfp_b*num04                     ; remove p_exb entry and node ptr} add xs *num04 
        jmp  succp                              ; and succeed} brn succp  
pnth2:
        mov  m_word [pmssl],wb                  ; save final cursor in safe place} mov pmssl wb 
        cmp  m_word [pmdfl],0                   ; jump if no pattern assignments} bze pmdfl pnth6 
        jz   pnth6                              ; 
pnth3:
        sub  xl,cfp_b                           ; point past cursor entry} dca xt  
        lea  xl,[xl-cfp_b]                      ; load node pointer} mov wa -(xt) 
        mov  wa,m_word [xl]                     ; 
        cmp  wa,ndpad                           ; jump if ndpad entry} beq wa =ndpad pnth4
        je   pnth4                              ; 
        cmp  wa,ndpab                           ; jump if not ndpab entry} bne wa =ndpab pnth5
        jne  pnth5                              ; 
        push m_word [(cfp_b*num01)+xl]          ; stack initial cursor} mov -(xs) num01(xt) 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0087                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0087:                                         ; 
        jmp  pnth3                              ; loop back if ok} brn pnth3  
pnth4:
        mov  wa,m_word [(cfp_b*num01)+xl]       ; load final cursor} mov wa num01(xt) 
        mov  wb,m_word [xs]                     ; load initial cursor from stack} mov wb (xs) 
        mov  m_word [xs],xl                     ; save history stack scan ptr} mov (xs) xt 
        sub  wa,wb                              ; compute length of string} sub wa wb 
        mov  xl,m_word [r_pms]                  ; point to subject string} mov xl r_pms 
        call sbstr                              ; construct substring} jsr sbstr  
        mov  wb,xr                              ; copy substring pointer} mov wb xr 
        mov  xl,m_word [xs]                     ; reload history stack scan ptr} mov xt (xs) 
        mov  xl,m_word [(cfp_b*num02)+xl]       ; load pointer to p_pac node with nam} mov xl num02(xt) 
        mov  wa,m_word [(cfp_b*parm2)+xl]       ; load name offset} mov wa parm2(xl) 
        mov  xl,m_word [(cfp_b*parm1)+xl]       ; load name base} mov xl parm1(xl) 
        call asinp                              ; perform assignment} jsr asinp  
        dec  m_word [_rc_]                      ; 
        js   call_44                            ; 
        dec  m_word [_rc_]                      ; match fails if name eval fails} ppm exfal  
        jns  _l0088                             ; 
        jmp  exfal                              ; 
_l0088:                                         ; 
call_44:                                        ; 
        pop  xl                                 ; else restore history stack ptr} mov xt (xs)+ 
pnth5:
        cmp  xl,xs                              ; loop if more entries to scan} bne xt xs pnth3
        jne  pnth3                              ; 
pnth6:
        mov  xs,m_word [pmhbs]                  ; wipe out history stack} mov xs pmhbs 
        pop  wb                                 ; load initial cursor} mov wb (xs)+ 
        pop  wc                                 ; load match type code} mov wc (xs)+ 
        mov  wa,m_word [pmssl]                  ; load final cursor value} mov wa pmssl 
        mov  xl,m_word [r_pms]                  ; point to subject string} mov xl r_pms 
        xor  w0,w0                              ; clear subject string ptr for gbcol} zer r_pms  
        mov  m_word [r_pms],w0                  ; 
        test wc,wc                              ; jump if call by name} bze wc pnth7 
        jz   pnth7                              ; 
        cmp  wc,num02                           ; exit if statement level call} beq wc =num02 pnth9
        je   pnth9                              ; 
        sub  wa,wb                              ; compute length of string} sub wa wb 
        call sbstr                              ; build substring} jsr sbstr  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
pnth7:
        push wb                                 ; stack initial cursor} mov -(xs) wb 
        push wa                                 ; stack final cursor} mov -(xs) wa 
pnth8:
        push xl                                 ; stack subject pointer} mov -(xs) xl 
pnth9:
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_pos:                                          ; 
        cmp  wb,m_word [(cfp_b*parm1)+xr]       ; succeed if at right location} beq wb parm1(xr) succp
        je   succp                              ; 
        test wb,wb                              ; don't look further if cursor not 0} bnz wb failp 
        jnz  failp                              ; 
        mov  xl,m_word [pmhbs]                  ; get history stack base ptr} mov xt pmhbs 
        lea  xl,[xl-cfp_b]                      ; fail if pos is not first node} bne xr -(xt) failp
        cmp  xr,m_word [xl]                     ; 
        jne  failp                              ; 
ppos2:
        lea  xl,[xl-cfp_b]                      ; fail if not unanchored mode} bne -(xt) =nduna failp
        cmp  m_word [xl],nduna                  ; 
        jne  failp                              ; 
        mov  wb,m_word [(cfp_b*parm1)+xr]       ; get desired cursor position} mov wb parm1(xr) 
        cmp  wb,m_word [pmssl]                  ; abort if off end} bgt wb pmssl exfal
        ja   exfal                              ; 
        mov  m_word [(cfp_b*num02)+xl],wb       ; fake number of unanchored moves} mov num02(xt) wb 
        jmp  succp                              ; continue match with adjusted cursor} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_psd:                                          ; 
        call evali                              ; evaluate integer argument} jsr evali  
        dec  m_word [_rc_]                      ; 
        js   call_45                            ; 
        dec  m_word [_rc_]                      ; } err 050 pos evaluated argument is not integer 
        jns  _l0089                             ; 
        mov  m_word [_rc_],50                   ; 
        jmp  err_                               ; 
_l0089:                                         ; 
        dec  m_word [_rc_]                      ; } err 051 pos evaluated argument is negative or too large 
        jns  _l0090                             ; 
        mov  m_word [_rc_],51                   ; 
        jmp  err_                               ; 
_l0090:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0091                             ; 
        jmp  failp                              ; 
_l0091:                                         ; 
        dec  m_word [_rc_]                      ; process expression case} ppm ppos1  
        jns  _l0092                             ; 
        jmp  ppos1                              ; 
_l0092:                                         ; 
call_45:                                        ; 
ppos1:
        cmp  wb,m_word [(cfp_b*parm1)+xr]       ; succeed if at right location} beq wb parm1(xr) succp
        je   succp                              ; 
        test wb,wb                              ; don't look further if cursor not 0} bnz wb failp 
        jnz  failp                              ; 
        cmp  m_word [evlif],0                   ; fail if complex argument} bnz evlif failp 
        jnz  failp                              ; 
        mov  xl,m_word [pmhbs]                  ; get history stack base ptr} mov xt pmhbs 
        mov  wa,m_word [evlio]                  ; get original node ptr} mov wa evlio 
        lea  xl,[xl-cfp_b]                      ; fail if pos is not first node} bne wa -(xt) failp
        cmp  wa,m_word [xl]                     ; 
        jne  failp                              ; 
        jmp  ppos2                              ; merge with integer argument code} brn ppos2  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_paa:                                          ; 
        push wb                                 ; stack initial cursor} mov -(xs) wb 
        push ndpab                              ; stack ptr to ndpab special node} mov -(xs) =ndpab 
        jmp  succp                              ; and succeed matching null} brn succp  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_pab:                                          ; 
        jmp  failp                              ; just fail (entry is already popped)} brn failp  
        align 2                                 ; p2blk} ent bl_p2  
        db   bl_p2                              ; 
p_pac:                                          ; 
        push wb                                 ; stack dummy cursor value} mov -(xs) wb 
        push xr                                 ; stack pointer to p_pac node} mov -(xs) xr 
        push wb                                 ; stack final cursor} mov -(xs) wb 
        push ndpad                              ; stack ptr to special ndpad node} mov -(xs) =ndpad 
        mov  m_word [pmdfl],xs                  ; set dot flag non-zero} mnz pmdfl  
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_pad:                                          ; 
        jmp  flpop                              ; fail and remove p_pac node} brn flpop  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_rem:                                          ; 
        mov  wb,m_word [pmssl]                  ; point cursor to end of string} mov wb pmssl 
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_rpd:                                          ; 
        call evali                              ; evaluate integer argument} jsr evali  
        dec  m_word [_rc_]                      ; 
        js   call_46                            ; 
        dec  m_word [_rc_]                      ; } err 052 rpos evaluated argument is not integer 
        jns  _l0093                             ; 
        mov  m_word [_rc_],52                   ; 
        jmp  err_                               ; 
_l0093:                                         ; 
        dec  m_word [_rc_]                      ; } err 053 rpos evaluated argument is negative or too large 
        jns  _l0094                             ; 
        mov  m_word [_rc_],53                   ; 
        jmp  err_                               ; 
_l0094:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0095                             ; 
        jmp  failp                              ; 
_l0095:                                         ; 
        dec  m_word [_rc_]                      ; merge with normal case if ok} ppm prps1  
        jns  _l0096                             ; 
        jmp  prps1                              ; 
_l0096:                                         ; 
call_46:                                        ; 
prps1:
        mov  wc,m_word [pmssl]                  ; get length of string} mov wc pmssl 
        sub  wc,wb                              ; get number of characters remaining} sub wc wb 
        cmp  wc,m_word [(cfp_b*parm1)+xr]       ; succeed if at right location} beq wc parm1(xr) succp
        je   succp                              ; 
        test wb,wb                              ; don't look further if cursor not 0} bnz wb failp 
        jnz  failp                              ; 
        cmp  m_word [evlif],0                   ; fail if complex argument} bnz evlif failp 
        jnz  failp                              ; 
        mov  xl,m_word [pmhbs]                  ; get history stack base ptr} mov xt pmhbs 
        mov  wa,m_word [evlio]                  ; get original node ptr} mov wa evlio 
        lea  xl,[xl-cfp_b]                      ; fail if pos is not first node} bne wa -(xt) failp
        cmp  wa,m_word [xl]                     ; 
        jne  failp                              ; 
        jmp  prps2                              ; merge with integer arg code} brn prps2  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_rps:                                          ; 
        mov  wc,m_word [pmssl]                  ; get length of string} mov wc pmssl 
        sub  wc,wb                              ; get number of characters remaining} sub wc wb 
        cmp  wc,m_word [(cfp_b*parm1)+xr]       ; succeed if at right location} beq wc parm1(xr) succp
        je   succp                              ; 
        test wb,wb                              ; don't look further if cursor not 0} bnz wb failp 
        jnz  failp                              ; 
        mov  xl,m_word [pmhbs]                  ; get history stack base ptr} mov xt pmhbs 
        lea  xl,[xl-cfp_b]                      ; fail if rpos is not first node} bne xr -(xt) failp
        cmp  xr,m_word [xl]                     ; 
        jne  failp                              ; 
prps2:
        lea  xl,[xl-cfp_b]                      ; fail if not unanchored mode} bne -(xt) =nduna failp
        cmp  m_word [xl],nduna                  ; 
        jne  failp                              ; 
        mov  wb,m_word [pmssl]                  ; point to end of string} mov wb pmssl 
        cmp  wb,m_word [(cfp_b*parm1)+xr]       ; fail if string not long enough} blt wb parm1(xr) failp
        jb   failp                              ; 
        sub  wb,m_word [(cfp_b*parm1)+xr]       ; else set new cursor} sub wb parm1(xr) 
        mov  m_word [(cfp_b*num02)+xl],wb       ; fake number of unanchored moves} mov num02(xt) wb 
        jmp  succp                              ; continue match with adjusted cursor} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_rtb:                                          ; 
prtb1:
        mov  wc,wb                              ; save initial cursor} mov wc wb 
        mov  wb,m_word [pmssl]                  ; point to end of string} mov wb pmssl 
        cmp  wb,m_word [(cfp_b*parm1)+xr]       ; fail if string not long enough} blt wb parm1(xr) failp
        jb   failp                              ; 
        sub  wb,m_word [(cfp_b*parm1)+xr]       ; else set new cursor} sub wb parm1(xr) 
        cmp  wb,wc                              ; and succeed if not too far already} bge wb wc succp
        jae  succp                              ; 
        jmp  failp                              ; in which case, fail} brn failp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_rtd:                                          ; 
        call evali                              ; evaluate integer argument} jsr evali  
        dec  m_word [_rc_]                      ; 
        js   call_47                            ; 
        dec  m_word [_rc_]                      ; } err 054 rtab evaluated argument is not integer 
        jns  _l0097                             ; 
        mov  m_word [_rc_],54                   ; 
        jmp  err_                               ; 
_l0097:                                         ; 
        dec  m_word [_rc_]                      ; } err 055 rtab evaluated argument is negative or too large 
        jns  _l0098                             ; 
        mov  m_word [_rc_],55                   ; 
        jmp  err_                               ; 
_l0098:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0099                             ; 
        jmp  failp                              ; 
_l0099:                                         ; 
        dec  m_word [_rc_]                      ; merge with normal case if success} ppm prtb1  
        jns  _l0100                             ; 
        jmp  prtb1                              ; 
_l0100:                                         ; 
call_47:                                        ; 
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_spd:                                          ; 
        call evals                              ; evaluate string argument} jsr evals  
        dec  m_word [_rc_]                      ; 
        js   call_48                            ; 
        dec  m_word [_rc_]                      ; } err 056 span evaluated argument is not a string 
        jns  _l0101                             ; 
        mov  m_word [_rc_],56                   ; 
        jmp  err_                               ; 
_l0101:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0102                             ; 
        jmp  failp                              ; 
_l0102:                                         ; 
        dec  m_word [_rc_]                      ; merge with multi-char case if ok} ppm pspn1  
        jns  _l0103                             ; 
        jmp  pspn1                              ; 
_l0103:                                         ; 
call_48:                                        ; 
        align 2                                 ; p2blk} ent bl_p2  
        db   bl_p2                              ; 
p_spn:                                          ; 
pspn1:
        mov  wc,m_word [pmssl]                  ; copy subject string length} mov wc pmssl 
        sub  wc,wb                              ; calculate number of characters left} sub wc wb 
        test wc,wc                              ; fail if no characters left} bze wc failp 
        jz   failp                              ; 
        mov  xl,m_word [r_pms]                  ; point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character} plc xl wb 
        mov  m_word [psavc],wb                  ; save initial cursor} mov psavc wb 
        mov  m_word [psave],xr                  ; save node pointer} mov psave xr 
pspn2:
        xor  w0,w0                              ; load next character, bump pointer} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        sal  wa,log_cfp_b                       ; convert to byte offset} wtb wa  
        mov  xr,m_word [(cfp_b*parm1)+xr]       ; point to ctblk} mov xr parm1(xr) 
        add  xr,wa                              ; point to ctblk entry} add xr wa 
        mov  wa,m_word [(cfp_b*ctchs)+xr]       ; load ctblk entry} mov wa ctchs(xr) 
        mov  xr,m_word [psave]                  ; restore node pointer} mov xr psave 
        and  wa,m_word [(cfp_b*parm2)+xr]       ; and with selected bit} anb wa parm2(xr) 
        test wa,wa                              ; jump if no match} zrb wa pspn3 
        jz   pspn3                              ; 
        inc  wb                                 ; else push cursor} icv wb  
        dec  wc                                 ; loop back unless end of string} bct wc pspn2 
        jnz  pspn2                              ; 
pspn3:
        cmp  wb,m_word [psavc]                  ; succeed if chars matched} bne wb psavc succp
        jne  succp                              ; 
        jmp  failp                              ; else fail if null string matched} brn failp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_sps:                                          ; 
        mov  wc,m_word [pmssl]                  ; get subject string length} mov wc pmssl 
        sub  wc,wb                              ; calculate number of characters left} sub wc wb 
        test wc,wc                              ; fail if no characters left} bze wc failp 
        jz   failp                              ; 
        mov  xl,m_word [r_pms]                  ; else point to subject string} mov xl r_pms 
        lea  xl,[cfp_f+xl+wb]                   ; point to current character} plc xl wb 
        mov  m_word [psavc],wb                  ; save initial cursor} mov psavc wb 
psps1:
        xor  w0,w0                              ; load next character, bump pointer} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        cmp  wa,m_word [(cfp_b*parm1)+xr]       ; jump if no match} bne wa parm1(xr) psps2
        jne  psps2                              ; 
        inc  wb                                 ; else push cursor} icv wb  
        dec  wc                                 ; and loop unless end of string} bct wc psps1 
        jnz  psps1                              ; 
psps2:
        cmp  wb,m_word [psavc]                  ; succeed if chars matched} bne wb psavc succp
        jne  succp                              ; 
        jmp  failp                              ; fail if null string matched} brn failp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_str:                                          ; 
        mov  xl,m_word [(cfp_b*parm1)+xr]       ; get pointer to string} mov xl parm1(xr) 
pstr1:
        mov  m_word [psave],xr                  ; save node pointer} mov psave xr 
        mov  xr,m_word [r_pms]                  ; load subject string pointer} mov xr r_pms 
        lea  xr,[cfp_f+xr+wb]                   ; point to current character} plc xr wb 
        add  wb,m_word [(cfp_b*sclen)+xl]       ; compute new cursor position} add wb sclen(xl) 
        cmp  wb,m_word [pmssl]                  ; fail if past end of string} bgt wb pmssl failp
        ja   failp                              ; 
        mov  m_word [psavc],wb                  ; save updated cursor} mov psavc wb 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; get number of chars to compare} mov wa sclen(xl) 
        add  xl,cfp_f                           ; point to chars of test string} plc xl  
        repe cmps_b                             ; compare, fail if not equal} cmc failp failp 
        mov  xl,0                               ; 
        mov  xr,xl                              ; 
        jnz  failp                              ; 
        mov  xr,m_word [psave]                  ; if all matched, restore node ptr} mov xr psave 
        mov  wb,m_word [psavc]                  ; restore updated cursor} mov wb psavc 
        jmp  succp                              ; and succeed} brn succp  
        align 2                                 ; p0blk} ent bl_p0  
        db   bl_p0                              ; 
p_suc:                                          ; 
        push wb                                 ; stack cursor} mov -(xs) wb 
        push xr                                 ; stack pointer to this node} mov -(xs) xr 
        jmp  succp                              ; succeed matching null} brn succp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_tab:                                          ; 
ptab1:
        cmp  wb,m_word [(cfp_b*parm1)+xr]       ; fail if too far already} bgt wb parm1(xr) failp
        ja   failp                              ; 
        mov  wb,m_word [(cfp_b*parm1)+xr]       ; else set new cursor position} mov wb parm1(xr) 
        cmp  wb,m_word [pmssl]                  ; succeed if not off end} ble wb pmssl succp
        jbe  succp                              ; 
        jmp  failp                              ; else fail} brn failp  
        align 2                                 ; p1blk} ent bl_p1  
        db   bl_p1                              ; 
p_tbd:                                          ; 
        call evali                              ; evaluate integer argument} jsr evali  
        dec  m_word [_rc_]                      ; 
        js   call_49                            ; 
        dec  m_word [_rc_]                      ; } err 057 tab evaluated argument is not integer 
        jns  _l0104                             ; 
        mov  m_word [_rc_],57                   ; 
        jmp  err_                               ; 
_l0104:                                         ; 
        dec  m_word [_rc_]                      ; } err 058 tab evaluated argument is negative or too large 
        jns  _l0105                             ; 
        mov  m_word [_rc_],58                   ; 
        jmp  err_                               ; 
_l0105:                                         ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm failp  
        jns  _l0106                             ; 
        jmp  failp                              ; 
_l0106:                                         ; 
        dec  m_word [_rc_]                      ; merge with normal case if ok} ppm ptab1  
        jns  _l0107                             ; 
        jmp  ptab1                              ; 
_l0107:                                         ; 
call_49:                                        ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
p_una:                                          ; 
        mov  xr,wb                              ; copy initial pattern node pointer} mov xr wb 
        mov  wb,m_word [xs]                     ; get initial cursor} mov wb (xs) 
        cmp  wb,m_word [pmssl]                  ; match fails if at end of string} beq wb pmssl exfal
        je   exfal                              ; 
        inc  wb                                 ; else increment cursor} icv wb  
        mov  m_word [xs],wb                     ; store incremented cursor} mov (xs) wb 
        push xr                                 ; restack initial node ptr} mov -(xs) xr 
        push nduna                              ; restack unanchored node} mov -(xs) =nduna 
        jmp  m_word [xr]                        ; rematch first node} bri (xr)  
        align 2                                 ; mark last entry in pattern section} ent bl__i  
        db   bl__i                              ; 
p_yyy:                                          ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_abo:                                          ; 
labo1:
        mov  wa,m_word [kvert]                  ; load error code} mov wa kvert 
        test wa,wa                              ; jump if no error has occured} bze wa labo3 
        jz   labo3                              ; 
        call sysax                              ; call after execution proc} jsr sysax  
        mov  wc,m_word [kvstn]                  ; current statement} mov wc kvstn 
        call filnm                              ; obtain file name for this statement} jsr filnm  
        mov  xr,m_word [r_cod]                  ; current code block} mov xr r_cod 
        mov  wc,m_word [(cfp_b*cdsln)+xr]       ; line number} mov wc cdsln(xr) 
        xor  wb,wb                              ; column number} zer wb  
        mov  xr,m_word [stage]                  ; } mov xr stage 
        call sysea                              ; advise system of error} jsr sysea  
        dec  m_word [_rc_]                      ; 
        js   call_50                            ; 
        dec  m_word [_rc_]                      ; if system does not want print} ppm stpr4  
        jns  _l0108                             ; 
        jmp  stpr4                              ; 
_l0108:                                         ; 
call_50:                                        ; 
        call prtpg                              ; else eject printer} jsr prtpg  
        test xr,xr                              ; did sysea request print} bze xr labo2 
        jz   labo2                              ; 
        call prtst                              ; print text from sysea} jsr prtst  
labo2:
        call ermsg                              ; print error message} jsr ermsg  
        xor  xr,xr                              ; indicate no message to print} zer xr  
        jmp  stopr                              ; jump to routine to stop run} brn stopr  
labo3:
        mov  m_word [_rc_],36                   ; } erb 036 goto abort with no preceding error 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_cnt:                                          ; 
lcnt1:
        mov  xr,m_word [r_cnt]                  ; load continuation code block ptr} mov xr r_cnt 
        test xr,xr                              ; jump if no previous error} bze xr lcnt3 
        jz   lcnt3                              ; 
        xor  w0,w0                              ; clear flag} zer r_cnt  
        mov  m_word [r_cnt],w0                  ; 
        mov  m_word [r_cod],xr                  ; else store as new code block ptr} mov r_cod xr 
        cmp  m_word [xr],b_cdc                  ; jump if not complex go} bne (xr) =b_cdc lcnt2
        jne  lcnt2                              ; 
        mov  wa,m_word [stxoc]                  ; get offset of error} mov wa stxoc 
        cmp  wa,m_word [stxof]                  ; jump if error in goto evaluation} bge wa stxof lcnt4
        jae  lcnt4                              ; 
lcnt2:
        add  xr,m_word [stxof]                  ; add failure offset} add xr stxof 
        mov  r13,xr                             ; load code pointer} lcp xr  
        mov  xs,m_word [flptr]                  ; reset stack pointer} mov xs flptr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
lcnt3:
        inc  m_word [errft]                     ; fatal error} icv errft  
        mov  m_word [_rc_],37                   ; } erb 037 goto continue with no preceding error 
        jmp  err_                               ; 
lcnt4:
        inc  m_word [errft]                     ; fatal error} icv errft  
        mov  m_word [_rc_],332                  ; } erb 332 goto continue with error in failure goto 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_end:                                          ; 
lend0:
        mov  xr,endms                           ; point to message /normal term.../} mov xr =endms 
        jmp  stopr                              ; jump to routine to stop run} brn stopr  
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_frt:                                          ; 
        mov  wa,scfrt                           ; point to string /freturn/} mov wa =scfrt 
        jmp  retrn                              ; jump to common return routine} brn retrn  
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_nrt:                                          ; 
        mov  wa,scnrt                           ; point to string /nreturn/} mov wa =scnrt 
        jmp  retrn                              ; jump to common return routine} brn retrn  
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_rtn:                                          ; 
        mov  wa,scrtn                           ; point to string /return/} mov wa =scrtn 
        jmp  retrn                              ; jump to common return routine} brn retrn  
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_scn:                                          ; 
        mov  xr,m_word [r_cnt]                  ; load continuation code block ptr} mov xr r_cnt 
        test xr,xr                              ; jump if no previous error} bze xr lscn2 
        jz   lscn2                              ; 
        xor  w0,w0                              ; clear flag} zer r_cnt  
        mov  m_word [r_cnt],w0                  ; 
        cmp  m_word [kvert],nm320               ; error must be user interrupt} bne kvert =nm320 lscn1
        jne  lscn1                              ; 
        cmp  m_word [kvert],nm321               ; detect scontinue loop} beq kvert =nm321 lscn2
        je   lscn2                              ; 
        mov  m_word [r_cod],xr                  ; else store as new code block ptr} mov r_cod xr 
        add  xr,m_word [stxoc]                  ; add resume offset} add xr stxoc 
        mov  r13,xr                             ; load code pointer} lcp xr  
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
lscn1:
        inc  m_word [errft]                     ; fatal error} icv errft  
        mov  m_word [_rc_],331                  ; } erb 331 goto scontinue with no user interrupt 
        jmp  err_                               ; 
lscn2:
        inc  m_word [errft]                     ; fatal error} icv errft  
        mov  m_word [_rc_],321                  ; } erb 321 goto scontinue with no preceding error 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
l_und:                                          ; 
        mov  m_word [_rc_],38                   ; } erb 038 goto undefined label 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_any:                                          ; 
        mov  wb,p_ans                           ; set pcode for single char case} mov wb =p_ans 
        mov  xl,p_any                           ; pcode for multi-char case} mov xl =p_any 
        mov  wc,p_ayd                           ; pcode for expression case} mov wc =p_ayd 
        call patst                              ; call common routine to build node} jsr patst  
        dec  m_word [_rc_]                      ; 
        js   call_51                            ; 
        dec  m_word [_rc_]                      ; } err 059 any argument is not a string or expression 
        jns  _l0109                             ; 
        mov  m_word [_rc_],59                   ; 
        jmp  err_                               ; 
_l0109:                                         ; 
call_51:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_app:                                          ; 
        test wa,wa                              ; jump if no arguments} bze wa sapp3 
        jz   sapp3                              ; 
        dec  wa                                 ; else get applied func arg count} dcv wa  
        mov  wb,wa                              ; copy} mov wb wa 
        sal  wb,log_cfp_b                       ; convert to bytes} wtb wb  
        mov  xl,xs                              ; copy stack pointer} mov xt xs 
        add  xl,wb                              ; point to function argument on stack} add xt wb 
        mov  xr,m_word [xl]                     ; load function ptr (apply 1st arg)} mov xr (xt) 
        test wa,wa                              ; jump if no args for applied func} bze wa sapp2 
        jz   sapp2                              ; 
        mov  wb,wa                              ; else set counter for loop} lct wb wa 
sapp1:
        sub  xl,cfp_b                           ; point to next argument} dca xt  
        mov  w0,m_word [xl]                     ; move argument up} mov num01(xt) (xt) 
        mov  m_word [(cfp_b*num01)+xl],w0       ; 
        dec  wb                                 ; loop till all moved} bct wb sapp1 
        jnz  sapp1                              ; 
sapp2:
        add  xs,cfp_b                           ; adjust stack ptr for apply 1st arg} ica xs  
        call gtnvr                              ; get variable block addr for func} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_52                            ; 
        dec  m_word [_rc_]                      ; jump if not natural variable} ppm sapp3  
        jns  _l0110                             ; 
        jmp  sapp3                              ; 
_l0110:                                         ; 
call_52:                                        ; 
        mov  xl,m_word [(cfp_b*vrfnc)+xr]       ; else point to function block} mov xl vrfnc(xr) 
        jmp  cfunc                              ; go call applied function} brn cfunc  
sapp3:
        mov  m_word [_rc_],60                   ; } erb 060 apply first arg is not natural variable name 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_abn:                                          ; 
        xor  xr,xr                              ; set parm1 = 0 for the moment} zer xr  
        mov  wb,p_alt                           ; set pcode for alternative node} mov wb =p_alt 
        call pbild                              ; build alternative node} jsr pbild  
        mov  xl,xr                              ; save ptr to alternative pattern} mov xl xr 
        mov  wb,p_abc                           ; pcode for p_abc} mov wb =p_abc 
        xor  xr,xr                              ; p0blk} zer xr  
        call pbild                              ; build p_abc node} jsr pbild  
        mov  m_word [(cfp_b*pthen)+xr],xl       ; put alternative node as successor} mov pthen(xr) xl 
        mov  wa,xl                              ; remember alternative node pointer} mov wa xl 
        mov  xl,xr                              ; copy p_abc node ptr} mov xl xr 
        mov  xr,m_word [xs]                     ; load arbno argument} mov xr (xs) 
        mov  m_word [xs],wa                     ; stack alternative node pointer} mov (xs) wa 
        call gtpat                              ; get arbno argument as pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_53                            ; 
        dec  m_word [_rc_]                      ; } err 061 arbno argument is not pattern 
        jns  _l0111                             ; 
        mov  m_word [_rc_],61                   ; 
        jmp  err_                               ; 
_l0111:                                         ; 
call_53:                                        ; 
        call pconc                              ; concat arg with p_abc node} jsr pconc  
        mov  xl,xr                              ; remember ptr to concd patterns} mov xl xr 
        mov  wb,p_aba                           ; pcode for p_aba} mov wb =p_aba 
        xor  xr,xr                              ; p0blk} zer xr  
        call pbild                              ; build p_aba node} jsr pbild  
        mov  m_word [(cfp_b*pthen)+xr],xl       ; concatenate nodes} mov pthen(xr) xl 
        mov  xl,m_word [xs]                     ; recall ptr to alternative node} mov xl (xs) 
        mov  m_word [(cfp_b*parm1)+xl],xr       ; point alternative back to argument} mov parm1(xl) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_arg:                                          ; 
        call gtsmi                              ; get second arg as small integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_54                            ; 
        dec  m_word [_rc_]                      ; } err 062 arg second argument is not integer 
        jns  _l0112                             ; 
        mov  m_word [_rc_],62                   ; 
        jmp  err_                               ; 
_l0112:                                         ; 
        dec  m_word [_rc_]                      ; fail if out of range or negative} ppm exfal  
        jns  _l0113                             ; 
        jmp  exfal                              ; 
_l0113:                                         ; 
call_54:                                        ; 
        mov  wa,xr                              ; save argument number} mov wa xr 
        pop  xr                                 ; load first argument} mov xr (xs)+ 
        call gtnvr                              ; locate vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_55                            ; 
        dec  m_word [_rc_]                      ; jump if not natural variable} ppm sarg1  
        jns  _l0114                             ; 
        jmp  sarg1                              ; 
_l0114:                                         ; 
call_55:                                        ; 
        mov  xr,m_word [(cfp_b*vrfnc)+xr]       ; else load function block pointer} mov xr vrfnc(xr) 
        cmp  m_word [xr],b_pfc                  ; jump if not program defined} bne (xr) =b_pfc sarg1
        jne  sarg1                              ; 
        test wa,wa                              ; fail if arg number is zero} bze wa exfal 
        jz   exfal                              ; 
        cmp  wa,m_word [(cfp_b*fargs)+xr]       ; fail if arg number is too large} bgt wa fargs(xr) exfal
        ja   exfal                              ; 
        sal  wa,log_cfp_b                       ; else convert to byte offset} wtb wa  
        add  xr,wa                              ; point to argument selected} add xr wa 
        mov  xr,m_word [(cfp_b*pfagb)+xr]       ; load argument vrblk pointer} mov xr pfagb(xr) 
        jmp  exvnm                              ; exit to build nmblk} brn exvnm  
sarg1:
        mov  m_word [_rc_],63                   ; } erb 063 arg first argument is not program function name 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_arr:                                          ; 
        pop  xl                                 ; load initial element value} mov xl (xs)+ 
        pop  xr                                 ; load first argument} mov xr (xs)+ 
        call gtint                              ; convert first arg to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_56                            ; 
        dec  m_word [_rc_]                      ; jump if not integer} ppm sar02  
        jns  _l0115                             ; 
        jmp  sar02                              ; 
_l0115:                                         ; 
call_56:                                        ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer value} ldi icval(xr)  
        cmp  ia,0                               ; jump if zero or neg (bad dimension)} ile sar10  
        jle  sar10                              ; 
        test ia,ia                              ; else convert to one word, test ovfl} mfi wa sar11 
        js   sar11                              ; 
        mov  wa,ia                              ; 
        call vmake                              ; create vector} jsr vmake  
        dec  m_word [_rc_]                      ; 
        js   call_57                            ; 
        dec  m_word [_rc_]                      ; fail if too large} ppm sar11  
        jns  _l0116                             ; 
        jmp  sar11                              ; 
_l0116:                                         ; 
call_57:                                        ; 
        jmp  exsid                              ; exit setting idval} brn exsid  
sar02:
        push xr                                 ; replace argument on stack} mov -(xs) xr 
        call xscni                              ; initialize scan of first argument} jsr xscni  
        dec  m_word [_rc_]                      ; 
        js   call_58                            ; 
        dec  m_word [_rc_]                      ; } err 064 array first argument is not integer or string 
        jns  _l0117                             ; 
        mov  m_word [_rc_],64                   ; 
        jmp  err_                               ; 
_l0117:                                         ; 
        dec  m_word [_rc_]                      ; dummy (unused) null string exit} ppm exnul  
        jns  _l0118                             ; 
        jmp  exnul                              ; 
_l0118:                                         ; 
call_58:                                        ; 
        push m_word [r_xsc]                     ; save prototype pointer} mov -(xs) r_xsc 
        push xl                                 ; save default value} mov -(xs) xl 
        xor  w0,w0                              ; zero count of dimensions} zer arcdm  
        mov  m_word [arcdm],w0                  ; 
        xor  w0,w0                              ; zero offset to indicate pass one} zer arptr  
        mov  m_word [arptr],w0                  ; 
        mov  ia,m_word [intv1]                  ; load integer one} ldi intv1  
        mov  m_word [arnel],ia                  ; initialize element count} sti arnel  
sar03:
        mov  ia,m_word [intv1]                  ; load one as default low bound} ldi intv1  
        mov  m_word [arsvl],ia                  ; save as low bound} sti arsvl  
        mov  wc,ch_cl                           ; set delimiter one = colon} mov wc =ch_cl 
        mov  xl,ch_cm                           ; set delimiter two = comma} mov xl =ch_cm 
        xor  wa,wa                              ; retain blanks in prototype} zer wa  
        call xscan                              ; scan next bound} jsr xscan  
        cmp  wa,num01                           ; jump if not colon} bne wa =num01 sar04
        jne  sar04                              ; 
        call gtint                              ; convert low bound} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_59                            ; 
        dec  m_word [_rc_]                      ; } err 065 array first argument lower bound is not integer 
        jns  _l0119                             ; 
        mov  m_word [_rc_],65                   ; 
        jmp  err_                               ; 
_l0119:                                         ; 
call_59:                                        ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load value of low bound} ldi icval(xr)  
        mov  m_word [arsvl],ia                  ; store low bound value} sti arsvl  
        mov  wc,ch_cm                           ; set delimiter one = comma} mov wc =ch_cm 
        mov  xl,wc                              ; and delimiter two = comma} mov xl wc 
        xor  wa,wa                              ; retain blanks in prototype} zer wa  
        call xscan                              ; scan high bound} jsr xscan  
sar04:
        call gtint                              ; convert high bound to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_60                            ; 
        dec  m_word [_rc_]                      ; } err 066 array first argument upper bound is not integer 
        jns  _l0120                             ; 
        mov  m_word [_rc_],66                   ; 
        jmp  err_                               ; 
_l0120:                                         ; 
call_60:                                        ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; get high bound} ldi icval(xr)  
        sub  ia,m_word [arsvl]                  ; subtract lower bound} sbi arsvl  
        jo   sar10                              ; bad dimension if overflow} iov sar10  
        cmp  ia,0                               ; bad dimension if negative} ilt sar10  
        jl   sar10                              ; 
        add  ia,m_word [intv1]                  ; add 1 to get dimension} adi intv1  
        jo   sar10                              ; bad dimension if overflow} iov sar10  
        mov  xl,m_word [arptr]                  ; load offset (also pass indicator)} mov xl arptr 
        test xl,xl                              ; jump if first pass} bze xl sar05 
        jz   sar05                              ; 
        add  xl,m_word [xs]                     ; point to current location in arblk} add xl (xs) 
        mov  m_word [(cfp_b*cfp_i)+xl],ia       ; store dimension} sti cfp_i(xl)  
        mov  ia,m_word [arsvl]                  ; load low bound} ldi arsvl  
        mov  m_word [xl],ia                     ; store low bound} sti (xl)  
        add  m_word [arptr],cfp_b*ardms         ; bump offset to next bounds} add arptr *ardms 
        jmp  sar06                              ; jump to check for end of bounds} brn sar06  
sar05:
        inc  m_word [arcdm]                     ; bump dimension count} icv arcdm  
        imul ia,m_word [arnel]                  ; multiply dimension by count so far} mli arnel  
        jo   sar11                              ; too large if overflow} iov sar11  
        mov  m_word [arnel],ia                  ; else store updated element count} sti arnel  
sar06:
        test wa,wa                              ; loop back unless end of bounds} bnz wa sar03 
        jnz  sar03                              ; 
        cmp  m_word [arptr],0                   ; jump if end of pass 2} bnz arptr sar09 
        jnz  sar09                              ; 
        mov  ia,m_word [arnel]                  ; get number of elements} ldi arnel  
        test ia,ia                              ; get as addr integer, test ovflo} mfi wb sar11 
        js   sar11                              ; 
        mov  wb,ia                              ; 
        sal  wb,log_cfp_b                       ; else convert to length in bytes} wtb wb  
        mov  wa,cfp_b*arsi_                     ; set size of standard fields} mov wa *arsi_ 
        mov  wc,m_word [arcdm]                  ; set dimension count to control loop} lct wc arcdm 
sar07:
        add  wa,cfp_b*ardms                     ; allow space for one set of bounds} add wa *ardms 
        dec  wc                                 ; loop back till all accounted for} bct wc sar07 
        jnz  sar07                              ; 
        mov  xl,wa                              ; save size (=arofs)} mov xl wa 
        add  wa,wb                              ; add space for elements} add wa wb 
        add  wa,cfp_b                           ; allow for arpro prototype field} ica wa  
        cmp  wa,m_word [mxlen]                  ; fail if too large} bgt wa mxlen sar11
        ja   sar11                              ; 
        call alloc                              ; else allocate arblk} jsr alloc  
        mov  wb,m_word [xs]                     ; load default value} mov wb (xs) 
        mov  m_word [xs],xr                     ; save arblk pointer} mov (xs) xr 
        mov  wc,wa                              ; save length in bytes} mov wc wa 
        shr  wa,log_cfp_b                       ; convert length back to words} btw wa  
sar08:
        mov  w0,wb                              ; set one word} mov (xr)+ wb 
        stos_w                                  ; 
        dec  wa                                 ; loop till all set} bct wa sar08 
        jnz  sar08                              ; 
        pop  xr                                 ; reload arblk pointer} mov xr (xs)+ 
        mov  wb,m_word [xs]                     ; load prototype} mov wb (xs) 
        mov  m_word [xr],b_art                  ; set type word} mov (xr) =b_art 
        mov  m_word [(cfp_b*arlen)+xr],wc       ; store length in bytes} mov arlen(xr) wc 
        xor  w0,w0                              ; zero id till we get it built} zer idval(xr)  
        mov  m_word [(cfp_b*idval)+xr],w0       ; 
        mov  m_word [(cfp_b*arofs)+xr],xl       ; set prototype field ptr} mov arofs(xr) xl 
        mov  w0,m_word [arcdm]                  ; set number of dimensions} mov arndm(xr) arcdm 
        mov  m_word [(cfp_b*arndm)+xr],w0       ; 
        mov  wc,xr                              ; save arblk pointer} mov wc xr 
        add  xr,xl                              ; point to prototype field} add xr xl 
        mov  m_word [xr],wb                     ; store prototype ptr in arblk} mov (xr) wb 
        mov  m_word [arptr],cfp_b*arlbd         ; set offset for pass 2 bounds scan} mov arptr *arlbd 
        mov  m_word [r_xsc],wb                  ; reset string pointer for xscan} mov r_xsc wb 
        mov  m_word [xs],wc                     ; store arblk pointer on stack} mov (xs) wc 
        xor  w0,w0                              ; reset offset ptr to start of string} zer xsofs  
        mov  m_word [xsofs],w0                  ; 
        jmp  sar03                              ; jump back to rescan bounds} brn sar03  
sar09:
        pop  xr                                 ; reload pointer to arblk} mov xr (xs)+ 
        jmp  exsid                              ; exit setting idval} brn exsid  
sar10:
        mov  m_word [_rc_],67                   ; } erb 067 array dimension is zero, negative or out of range 
        jmp  err_                               ; 
sar11:
        mov  m_word [_rc_],68                   ; } erb 068 array size exceeds maximum permitted 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_atn:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_61                            ; 
        dec  m_word [_rc_]                      ; } err 301 atan argument not numeric 
        jns  _l0121                             ; 
        mov  m_word [_rc_],301                  ; 
        jmp  err_                               ; 
_l0121:                                         ; 
call_61:                                        ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        call atn_                               ; take arctangent} atn   
        jmp  exrea                              ; overflow, out of range not possible} brn exrea  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_bsp:                                          ; 
        call iofcb                              ; call fcblk routine} jsr iofcb  
        dec  m_word [_rc_]                      ; 
        js   call_62                            ; 
        dec  m_word [_rc_]                      ; } err 316 backspace argument is not a suitable name 
        jns  _l0122                             ; 
        mov  m_word [_rc_],316                  ; 
        jmp  err_                               ; 
_l0122:                                         ; 
        dec  m_word [_rc_]                      ; } err 316 backspace argument is not a suitable name 
        jns  _l0123                             ; 
        mov  m_word [_rc_],316                  ; 
        jmp  err_                               ; 
_l0123:                                         ; 
        dec  m_word [_rc_]                      ; } err 317 backspace file does not exist 
        jns  _l0124                             ; 
        mov  m_word [_rc_],317                  ; 
        jmp  err_                               ; 
_l0124:                                         ; 
call_62:                                        ; 
        call sysbs                              ; call backspace file function} jsr sysbs  
        dec  m_word [_rc_]                      ; 
        js   call_63                            ; 
        dec  m_word [_rc_]                      ; } err 317 backspace file does not exist 
        jns  _l0125                             ; 
        mov  m_word [_rc_],317                  ; 
        jmp  err_                               ; 
_l0125:                                         ; 
        dec  m_word [_rc_]                      ; } err 318 backspace file does not permit backspace 
        jns  _l0126                             ; 
        mov  m_word [_rc_],318                  ; 
        jmp  err_                               ; 
_l0126:                                         ; 
        dec  m_word [_rc_]                      ; } err 319 backspace caused non-recoverable error 
        jns  _l0127                             ; 
        mov  m_word [_rc_],319                  ; 
        jmp  err_                               ; 
_l0127:                                         ; 
call_63:                                        ; 
        jmp  exnul                              ; return null as result} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_brk:                                          ; 
        mov  wb,p_bks                           ; set pcode for single char case} mov wb =p_bks 
        mov  xl,p_brk                           ; pcode for multi-char case} mov xl =p_brk 
        mov  wc,p_bkd                           ; pcode for expression case} mov wc =p_bkd 
        call patst                              ; call common routine to build node} jsr patst  
        dec  m_word [_rc_]                      ; 
        js   call_64                            ; 
        dec  m_word [_rc_]                      ; } err 069 break argument is not a string or expression 
        jns  _l0128                             ; 
        mov  m_word [_rc_],69                   ; 
        jmp  err_                               ; 
_l0128:                                         ; 
call_64:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_bkx:                                          ; 
        mov  wb,p_bks                           ; pcode for single char argument} mov wb =p_bks 
        mov  xl,p_brk                           ; pcode for multi-char argument} mov xl =p_brk 
        mov  wc,p_bxd                           ; pcode for expression case} mov wc =p_bxd 
        call patst                              ; call common routine to build node} jsr patst  
        dec  m_word [_rc_]                      ; 
        js   call_65                            ; 
        dec  m_word [_rc_]                      ; } err 070 breakx argument is not a string or expression 
        jns  _l0129                             ; 
        mov  m_word [_rc_],70                   ; 
        jmp  err_                               ; 
_l0129:                                         ; 
call_65:                                        ; 
        push xr                                 ; save ptr to break node} mov -(xs) xr 
        mov  wb,p_bkx                           ; set pcode for breakx node} mov wb =p_bkx 
        call pbild                              ; build it} jsr pbild  
        mov  w0,m_word [xs]                     ; set break node as successor} mov pthen(xr) (xs) 
        mov  m_word [(cfp_b*pthen)+xr],w0       ; 
        mov  wb,p_alt                           ; set pcode for alternation node} mov wb =p_alt 
        call pbild                              ; build (parm1=alt=breakx node)} jsr pbild  
        mov  wa,xr                              ; save ptr to alternation node} mov wa xr 
        mov  xr,m_word [xs]                     ; point to break node} mov xr (xs) 
        mov  m_word [(cfp_b*pthen)+xr],wa       ; set alternate node as successor} mov pthen(xr) wa 
        mov  r10,m_word [r13]                   ; result on stack} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_chr:                                          ; 
        call gtsmi                              ; convert arg to integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_66                            ; 
        dec  m_word [_rc_]                      ; } err 281 char argument not integer 
        jns  _l0130                             ; 
        mov  m_word [_rc_],281                  ; 
        jmp  err_                               ; 
_l0130:                                         ; 
        dec  m_word [_rc_]                      ; too big error exit} ppm schr1  
        jns  _l0131                             ; 
        jmp  schr1                              ; 
_l0131:                                         ; 
call_66:                                        ; 
        cmp  wc,cfp_a                           ; see if out of range of host set} bge wc =cfp_a schr1
        jae  schr1                              ; 
        mov  wa,num01                           ; if not set scblk allocation} mov wa =num01 
        mov  wb,wc                              ; save char code} mov wb wc 
        call alocs                              ; allocate 1 bau scblk} jsr alocs  
        mov  xl,xr                              ; copy scblk pointer} mov xl xr 
        add  xl,cfp_f                           ; get set to stuff char} psc xl  
        mov  m_char [xl],bl                     ; stuff it} sch wb (xl) 
        xor  xl,xl                              ; clear slop in xl} zer xl  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
schr1:
        mov  m_word [_rc_],282                  ; } erb 282 char argument not in range 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_chp:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_67                            ; 
        dec  m_word [_rc_]                      ; } err 302 chop argument not numeric 
        jns  _l0132                             ; 
        mov  m_word [_rc_],302                  ; 
        jmp  err_                               ; 
_l0132:                                         ; 
call_67:                                        ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        call chp_                               ; truncate to integer valued real} chp   
        jmp  exrea                              ; no overflow possible} brn exrea  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_clr:                                          ; 
        call xscni                              ; initialize to scan argument} jsr xscni  
        dec  m_word [_rc_]                      ; 
        js   call_68                            ; 
        dec  m_word [_rc_]                      ; } err 071 clear argument is not a string 
        jns  _l0133                             ; 
        mov  m_word [_rc_],71                   ; 
        jmp  err_                               ; 
_l0133:                                         ; 
        dec  m_word [_rc_]                      ; jump if null} ppm sclr2  
        jns  _l0134                             ; 
        jmp  sclr2                              ; 
_l0134:                                         ; 
call_68:                                        ; 
sclr1:
        mov  wc,ch_cm                           ; set delimiter one = comma} mov wc =ch_cm 
        mov  xl,wc                              ; delimiter two = comma} mov xl wc 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan next variable name} jsr xscan  
        call gtnvr                              ; locate vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_69                            ; 
        dec  m_word [_rc_]                      ; } err 072 clear argument has null variable name 
        jns  _l0135                             ; 
        mov  m_word [_rc_],72                   ; 
        jmp  err_                               ; 
_l0135:                                         ; 
call_69:                                        ; 
        xor  w0,w0                              ; else flag by zeroing vrget field} zer vrget(xr)  
        mov  m_word [(cfp_b*vrget)+xr],w0       ; 
        test wa,wa                              ; loop back if stopped by comma} bnz wa sclr1 
        jnz  sclr1                              ; 
sclr2:
        mov  wb,m_word [hshtb]                  ; point to start of hash table} mov wb hshtb 
sclr3:
        cmp  wb,m_word [hshte]                  ; exit returning null if none left} beq wb hshte exnul
        je   exnul                              ; 
        mov  xr,wb                              ; else copy slot pointer} mov xr wb 
        add  wb,cfp_b                           ; bump slot pointer} ica wb  
        sub  xr,cfp_b*vrnxt                     ; set offset to merge into loop} sub xr *vrnxt 
sclr4:
        mov  xr,m_word [(cfp_b*vrnxt)+xr]       ; point to next vrblk on chain} mov xr vrnxt(xr) 
        test xr,xr                              ; jump for next bucket if chain end} bze xr sclr3 
        jz   sclr3                              ; 
        cmp  m_word [(cfp_b*vrget)+xr],0        ; jump if not flagged} bnz vrget(xr) sclr5 
        jnz  sclr5                              ; 
        call setvr                              ; for flagged var, restore vrget} jsr setvr  
        jmp  sclr4                              ; and loop back for next vrblk} brn sclr4  
sclr5:
        cmp  m_word [(cfp_b*vrsto)+xr],b_vre    ; check for protected variable} beq vrsto(xr) =b_vre sclr4
        je   sclr4                              ; 
        mov  xl,xr                              ; copy vrblk pointer} mov xl xr 
sclr6:
        mov  wa,xl                              ; save block pointer} mov wa xl 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load next value field} mov xl vrval(xl) 
        cmp  m_word [xl],b_trt                  ; loop back if trapped} beq (xl) =b_trt sclr6
        je   sclr6                              ; 
        mov  xl,wa                              ; restore block pointer} mov xl wa 
        mov  m_word [(cfp_b*vrval)+xl],nulls    ; store null constant value} mov vrval(xl) =nulls 
        jmp  sclr4                              ; loop back for next vrblk} brn sclr4  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_cod:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        call gtcod                              ; convert to code} jsr gtcod  
        dec  m_word [_rc_]                      ; 
        js   call_70                            ; 
        dec  m_word [_rc_]                      ; fail if conversion is impossible} ppm exfal  
        jns  _l0136                             ; 
        jmp  exfal                              ; 
_l0136:                                         ; 
call_70:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_col:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        call gtint                              ; convert to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_71                            ; 
        dec  m_word [_rc_]                      ; } err 073 collect argument is not integer 
        jns  _l0137                             ; 
        mov  m_word [_rc_],73                   ; 
        jmp  err_                               ; 
_l0137:                                         ; 
call_71:                                        ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load collect argument} ldi icval(xr)  
        mov  m_word [clsvi],ia                  ; save collect argument} sti clsvi  
        xor  wb,wb                              ; set no move up} zer wb  
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        xor  w0,w0                              ; collect sediment too} zer dnams  
        mov  m_word [dnams],w0                  ; 
        call gbcol                              ; perform garbage collection} jsr gbcol  
        mov  m_word [dnams],xr                  ; record new sediment size} mov dnams xr 
        mov  wa,m_word [dname]                  ; point to end of memory} mov wa dname 
        sub  wa,m_word [dnamp]                  ; subtract next location} sub wa dnamp 
        shr  wa,log_cfp_b                       ; convert bytes to words} btw wa  
        mov  ia,wa                              ; convert words available as integer} mti wa  
        sub  ia,m_word [clsvi]                  ; subtract argument} sbi clsvi  
        jo   exfal                              ; fail if overflow} iov exfal  
        cmp  ia,0                               ; fail if not enough} ilt exfal  
        jl   exfal                              ; 
        add  ia,m_word [clsvi]                  ; else recompute available} adi clsvi  
        jmp  exint                              ; and exit with integer result} brn exint  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_cnv:                                          ; 
        call gtstg                              ; convert second argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_72                            ; 
        dec  m_word [_rc_]                      ; error if second argument not string} ppm scv29  
        jns  _l0138                             ; 
        jmp  scv29                              ; 
_l0138:                                         ; 
call_72:                                        ; 
        test wa,wa                              ; or if null string} bze wa scv29 
        jz   scv29                              ; 
        call flstg                              ; fold upper case to lower case} jsr flstg  
        mov  xl,m_word [xs]                     ; load first argument} mov xl (xs) 
        cmp  m_word [xl],b_pdt                  ; jump if not program defined} bne (xl) =b_pdt scv01
        jne  scv01                              ; 
        mov  xl,m_word [(cfp_b*pddfp)+xl]       ; point to dfblk} mov xl pddfp(xl) 
        mov  xl,m_word [(cfp_b*dfnam)+xl]       ; load datatype name} mov xl dfnam(xl) 
        call ident                              ; compare with second arg} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_73                            ; 
        dec  m_word [_rc_]                      ; exit if ident with arg as result} ppm exits  
        jns  _l0139                             ; 
        jmp  exits                              ; 
_l0139:                                         ; 
call_73:                                        ; 
        jmp  exfal                              ; else fail} brn exfal  
scv01:
        push xr                                 ; save string argument} mov -(xs) xr 
        mov  xl,svctb                           ; point to table of names to compare} mov xl =svctb 
        xor  wb,wb                              ; initialize counter} zer wb  
        mov  wc,wa                              ; save length of argument string} mov wc wa 
scv02:
        lods_w                                  ; load next table entry, bump pointer} mov xr (xl)+ 
        mov  xr,w0                              ; 
        test xr,xr                              ; fail if zero marking end of list} bze xr exfal 
        jz   exfal                              ; 
        cmp  wc,m_word [(cfp_b*sclen)+xr]       ; jump if wrong length} bne wc sclen(xr) scv05
        jne  scv05                              ; 
        mov  m_word [cnvtp],xl                  ; else store table pointer} mov cnvtp xl 
        add  xr,cfp_f                           ; point to chars of table entry} plc xr  
        mov  xl,m_word [xs]                     ; load pointer to string argument} mov xl (xs) 
        add  xl,cfp_f                           ; point to chars of string arg} plc xl  
        mov  wa,wc                              ; set number of chars to compare} mov wa wc 
        repe cmps_b                             ; compare, jump if no match} cmc scv04 scv04 
        mov  xl,0                               ; 
        mov  xr,xl                              ; 
        jnz  scv04                              ; 
scv03:
        mov  xl,wb                              ; copy entry number} mov xl wb 
        add  xs,cfp_b                           ; pop string arg off stack} ica xs  
        pop  xr                                 ; load first argument} mov xr (xs)+ 
        jmp  m_word [_l0140+xl*cfp_b]           ; jump to appropriate routine} bsw xl cnvtt 
        segment .data                           ; 
_l0140:                                         ; 
        d_word scv06                            ; string} iff 0 scv06 
        d_word scv07                            ; integer} iff 1 scv07 
        d_word scv09                            ; name} iff 2 scv09 
        d_word scv10                            ; pattern} iff 3 scv10 
        d_word scv11                            ; array} iff 4 scv11 
        d_word scv19                            ; table} iff 5 scv19 
        d_word scv25                            ; expression} iff 6 scv25 
        d_word scv26                            ; code} iff 7 scv26 
        d_word scv27                            ; numeric} iff 8 scv27 
        d_word scv08                            ; real} iff cnvrt scv08 
        segment .text                           ; end of switch table} esw   
scv04:
        mov  xl,m_word [cnvtp]                  ; restore table pointer, merge} mov xl cnvtp 
scv05:
        inc  wb                                 ; bump entry number} icv wb  
        jmp  scv02                              ; loop back to check next entry} brn scv02  
scv06:
        push xr                                 ; replace string argument on stack} mov -(xs) xr 
        call gtstg                              ; convert to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_74                            ; 
        dec  m_word [_rc_]                      ; fail if conversion not possible} ppm exfal  
        jns  _l0141                             ; 
        jmp  exfal                              ; 
_l0141:                                         ; 
call_74:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
scv07:
        call gtint                              ; convert to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_75                            ; 
        dec  m_word [_rc_]                      ; fail if conversion not possible} ppm exfal  
        jns  _l0142                             ; 
        jmp  exfal                              ; 
_l0142:                                         ; 
call_75:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
scv08:
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_76                            ; 
        dec  m_word [_rc_]                      ; fail if conversion not possible} ppm exfal  
        jns  _l0143                             ; 
        jmp  exfal                              ; 
_l0143:                                         ; 
call_76:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
scv09:
        cmp  m_word [xr],b_nml                  ; return if already a name} beq (xr) =b_nml exixr
        je   exixr                              ; 
        call gtnvr                              ; else try string to name convert} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_77                            ; 
        dec  m_word [_rc_]                      ; fail if conversion not possible} ppm exfal  
        jns  _l0144                             ; 
        jmp  exfal                              ; 
_l0144:                                         ; 
call_77:                                        ; 
        jmp  exvnm                              ; else exit building nmblk for vrblk} brn exvnm  
scv10:
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_78                            ; 
        dec  m_word [_rc_]                      ; fail if conversion not possible} ppm exfal  
        jns  _l0145                             ; 
        jmp  exfal                              ; 
_l0145:                                         ; 
call_78:                                        ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
scv11:
        push xr                                 ; save argument on stack} mov -(xs) xr 
        xor  wa,wa                              ; use table chain block addresses} zer wa  
        call gtarr                              ; get an array} jsr gtarr  
        dec  m_word [_rc_]                      ; 
        js   call_79                            ; 
        dec  m_word [_rc_]                      ; fail if empty table} ppm exfal  
        jns  _l0146                             ; 
        jmp  exfal                              ; 
_l0146:                                         ; 
        dec  m_word [_rc_]                      ; fail if not convertible} ppm exfal  
        jns  _l0147                             ; 
        jmp  exfal                              ; 
_l0147:                                         ; 
call_79:                                        ; 
        pop  xl                                 ; reload original arg} mov xl (xs)+ 
        cmp  m_word [xl],b_tbt                  ; exit if original not a table} bne (xl) =b_tbt exsid
        jne  exsid                              ; 
        push xr                                 ; sort the intermediate array} mov -(xs) xr 
        push nulls                              ; on first column} mov -(xs) =nulls 
        xor  wa,wa                              ; sort ascending} zer wa  
        call sorta                              ; do sort} jsr sorta  
        dec  m_word [_rc_]                      ; 
        js   call_80                            ; 
        dec  m_word [_rc_]                      ; if sort fails, so shall we} ppm exfal  
        jns  _l0148                             ; 
        jmp  exfal                              ; 
_l0148:                                         ; 
call_80:                                        ; 
        mov  wb,xr                              ; save array result} mov wb xr 
        mov  ia,m_word [(cfp_b*ardim)+xr]       ; load dim 1 (number of elements)} ldi ardim(xr)  
        mov  wa,ia                              ; get as one word integer} mfi wa  
        add  xr,cfp_b*arvl2                     ; point to first element in array} add xr *arvl2 
scv12:
        mov  xl,m_word [xr]                     ; get teblk address} mov xl (xr) 
        mov  w0,m_word [(cfp_b*tesub)+xl]       ; replace with subscript} mov (xr)+ tesub(xl) 
        stos_w                                  ; 
        mov  w0,m_word [(cfp_b*teval)+xl]       ; replace with value} mov (xr)+ teval(xl) 
        stos_w                                  ; 
        dec  wa                                 ; loop till all copied over} bct wa scv12 
        jnz  scv12                              ; 
        mov  xr,wb                              ; retrieve array address} mov xr wb 
        jmp  exsid                              ; exit setting id field} brn exsid  
scv19:
        mov  wa,m_word [xr]                     ; load first word of block} mov wa (xr) 
        push xr                                 ; replace arblk pointer on stack} mov -(xs) xr 
        cmp  wa,b_tbt                           ; return arg if already a table} beq wa =b_tbt exits
        je   exits                              ; 
        cmp  wa,b_art                           ; else fail if not an array} bne wa =b_art exfal
        jne  exfal                              ; 
        cmp  m_word [(cfp_b*arndm)+xr],num02    ; fail if not 2-dim array} bne arndm(xr) =num02 exfal
        jne  exfal                              ; 
        mov  ia,m_word [(cfp_b*ardm2)+xr]       ; load dim 2} ldi ardm2(xr)  
        sub  ia,m_word [intv2]                  ; subtract 2 to compare} sbi intv2  
        cmp  ia,0                               ; fail if dim2 not 2} ine exfal  
        jne  exfal                              ; 
        mov  ia,m_word [(cfp_b*ardim)+xr]       ; load dim 1 (number of elements)} ldi ardim(xr)  
        mov  wa,ia                              ; get as one word integer} mfi wa  
        mov  wb,wa                              ; copy to control loop} lct wb wa 
        add  wa,tbsi_                           ; add space for standard fields} add wa =tbsi_ 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        call alloc                              ; allocate space for tbblk} jsr alloc  
        mov  wc,xr                              ; copy tbblk pointer} mov wc xr 
        push xr                                 ; save tbblk pointer} mov -(xs) xr 
        mov  w0,b_tbt                           ; store type word} mov (xr)+ =b_tbt 
        stos_w                                  ; 
        xor  w0,w0                              ; store zero for idval for now} zer (xr)+  
        stos_w                                  ; 
        mov  w0,wa                              ; store length} mov (xr)+ wa 
        stos_w                                  ; 
        mov  w0,nulls                           ; null initial lookup value} mov (xr)+ =nulls 
        stos_w                                  ; 
scv20:
        mov  w0,wc                              ; set bucket ptr to point to tbblk} mov (xr)+ wc 
        stos_w                                  ; 
        dec  wb                                 ; loop till all initialized} bct wb scv20 
        jnz  scv20                              ; 
        mov  wb,cfp_b*arvl2                     ; set offset to first arblk element} mov wb *arvl2 
scv21:
        mov  xl,m_word [(cfp_b*num01)+xs]       ; point to arblk} mov xl num01(xs) 
        cmp  wb,m_word [(cfp_b*arlen)+xl]       ; jump if all moved} beq wb arlen(xl) scv24
        je   scv24                              ; 
        add  xl,wb                              ; else point to current location} add xl wb 
        add  wb,cfp_b*num02                     ; bump offset} add wb *num02 
        mov  xr,m_word [xl]                     ; load subscript name} mov xr (xl) 
        sub  xl,cfp_b                           ; adjust ptr to merge (trval=1+1)} dca xl  
scv22:
        mov  xl,m_word [(cfp_b*trval)+xl]       ; point to next value} mov xl trval(xl) 
        cmp  m_word [xl],b_trt                  ; loop back if trapped} beq (xl) =b_trt scv22
        je   scv22                              ; 
scv23:
        push xl                                 ; stack value} mov -(xs) xl 
        mov  xl,m_word [(cfp_b*num01)+xs]       ; load tbblk pointer} mov xl num01(xs) 
        call tfind                              ; build teblk (note wb gt 0 by name)} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_81                            ; 
        dec  m_word [_rc_]                      ; fail if acess fails} ppm exfal  
        jns  _l0149                             ; 
        jmp  exfal                              ; 
_l0149:                                         ; 
call_81:                                        ; 
        pop  m_word [(cfp_b*teval)+xl]          ; store value in teblk} mov teval(xl) (xs)+ 
        jmp  scv21                              ; loop back for next element} brn scv21  
scv24:
        pop  xr                                 ; load tbblk pointer} mov xr (xs)+ 
        add  xs,cfp_b                           ; pop arblk pointer} ica xs  
        jmp  exsid                              ; exit setting idval} brn exsid  
scv25:
        xor  wb,wb                              ; by value} zer wb  
        call gtexp                              ; convert to expression} jsr gtexp  
        dec  m_word [_rc_]                      ; 
        js   call_82                            ; 
        dec  m_word [_rc_]                      ; fail if conversion not possible} ppm exfal  
        jns  _l0150                             ; 
        jmp  exfal                              ; 
_l0150:                                         ; 
call_82:                                        ; 
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
scv26:
        call gtcod                              ; convert to code} jsr gtcod  
        dec  m_word [_rc_]                      ; 
        js   call_83                            ; 
        dec  m_word [_rc_]                      ; fail if conversion is not possible} ppm exfal  
        jns  _l0151                             ; 
        jmp  exfal                              ; 
_l0151:                                         ; 
call_83:                                        ; 
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
scv27:
        call gtnum                              ; convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_84                            ; 
        dec  m_word [_rc_]                      ; fail if unconvertible} ppm exfal  
        jns  _l0152                             ; 
        jmp  exfal                              ; 
_l0152:                                         ; 
call_84:                                        ; 
scv31:
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
scv29:
        mov  m_word [_rc_],74                   ; } erb 074 convert second argument is not a string 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_cop:                                          ; 
        call copyb                              ; copy the block} jsr copyb  
        dec  m_word [_rc_]                      ; 
        js   call_85                            ; 
        dec  m_word [_rc_]                      ; return if no idval field} ppm exits  
        jns  _l0153                             ; 
        jmp  exits                              ; 
_l0153:                                         ; 
call_85:                                        ; 
        jmp  exsid                              ; exit setting id value} brn exsid  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_cos:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_86                            ; 
        dec  m_word [_rc_]                      ; } err 303 cos argument not numeric 
        jns  _l0154                             ; 
        mov  m_word [_rc_],303                  ; 
        jmp  err_                               ; 
_l0154:                                         ; 
call_86:                                        ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        call cos_                               ; take cosine} cos   
        call do_chk_real_inf                    ; if no overflow, return result in ra} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],322                  ; } erb 322 cos argument is out of range 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_dat:                                          ; 
        call xscni                              ; prepare to scan argument} jsr xscni  
        dec  m_word [_rc_]                      ; 
        js   call_87                            ; 
        dec  m_word [_rc_]                      ; } err 075 data argument is not a string 
        jns  _l0155                             ; 
        mov  m_word [_rc_],75                   ; 
        jmp  err_                               ; 
_l0155:                                         ; 
        dec  m_word [_rc_]                      ; } err 076 data argument is null 
        jns  _l0156                             ; 
        mov  m_word [_rc_],76                   ; 
        jmp  err_                               ; 
_l0156:                                         ; 
call_87:                                        ; 
        mov  wc,ch_pp                           ; delimiter one = left paren} mov wc =ch_pp 
        mov  xl,wc                              ; delimiter two = left paren} mov xl wc 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan datatype name} jsr xscan  
        test wa,wa                              ; skip if left paren found} bnz wa sdat1 
        jnz  sdat1                              ; 
        mov  m_word [_rc_],77                   ; } erb 077 data argument is missing a left paren 
        jmp  err_                               ; 
sdat1:
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; get length} mov wa sclen(xr) 
        test wa,wa                              ; avoid folding if null string} bze wa sdt1a 
        jz   sdt1a                              ; 
        call flstg                              ; fold upper case to lower case} jsr flstg  
sdt1a:
        mov  xl,xr                              ; save name ptr} mov xl xr 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; get length} mov wa sclen(xr) 
        add  wa,(cfp_b-1)+cfp_b*scsi_           ; compute space needed} ctb wa scsi_ 
        and  wa,-cfp_b                          ; 
        call alost                              ; request static store for name} jsr alost  
        push xr                                 ; save datatype name} mov -(xs) xr 
        shr  wa,log_cfp_b                       ; copy name to static} mvw   
        rep  movs_w                             ; 
        mov  xr,m_word [xs]                     ; get name ptr} mov xr (xs) 
        xor  xl,xl                              ; scrub dud register} zer xl  
        call gtnvr                              ; locate vrblk for datatype name} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_88                            ; 
        dec  m_word [_rc_]                      ; } err 078 data argument has null datatype name 
        jns  _l0157                             ; 
        mov  m_word [_rc_],78                   ; 
        jmp  err_                               ; 
_l0157:                                         ; 
call_88:                                        ; 
        mov  m_word [datdv],xr                  ; save vrblk pointer for datatype} mov datdv xr 
        mov  m_word [datxs],xs                  ; store starting stack value} mov datxs xs 
        xor  wb,wb                              ; zero count of field names} zer wb  
sdat2:
        mov  wc,ch_rp                           ; delimiter one = right paren} mov wc =ch_rp 
        mov  xl,ch_cm                           ; delimiter two = comma} mov xl =ch_cm 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan next field name} jsr xscan  
        test wa,wa                              ; jump if delimiter found} bnz wa sdat3 
        jnz  sdat3                              ; 
        mov  m_word [_rc_],79                   ; } erb 079 data argument is missing a right paren 
        jmp  err_                               ; 
sdat3:
        call gtnvr                              ; locate vrblk for field name} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_89                            ; 
        dec  m_word [_rc_]                      ; } err 080 data argument has null field name 
        jns  _l0158                             ; 
        mov  m_word [_rc_],80                   ; 
        jmp  err_                               ; 
_l0158:                                         ; 
call_89:                                        ; 
        push xr                                 ; stack vrblk pointer} mov -(xs) xr 
        inc  wb                                 ; increment counter} icv wb  
        cmp  wa,num02                           ; loop back if stopped by comma} beq wa =num02 sdat2
        je   sdat2                              ; 
        mov  wa,dfsi_                           ; set size of dfblk standard fields} mov wa =dfsi_ 
        add  wa,wb                              ; add number of fields} add wa wb 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        mov  wc,wb                              ; preserve no. of fields} mov wc wb 
        call alost                              ; allocate space for dfblk} jsr alost  
        mov  wb,wc                              ; get no of fields} mov wb wc 
        mov  xl,m_word [datxs]                  ; point to start of stack} mov xt datxs 
        mov  wc,m_word [xl]                     ; load datatype name} mov wc (xt) 
        mov  m_word [xl],xr                     ; save dfblk pointer on stack} mov (xt) xr 
        mov  w0,b_dfc                           ; store type word} mov (xr)+ =b_dfc 
        stos_w                                  ; 
        mov  w0,wb                              ; store number of fields (fargs)} mov (xr)+ wb 
        stos_w                                  ; 
        mov  w0,wa                              ; store length (dflen)} mov (xr)+ wa 
        stos_w                                  ; 
        sub  wa,cfp_b*pddfs                     ; compute pdblk length (for dfpdl)} sub wa *pddfs 
        mov  w0,wa                              ; store pdblk length (dfpdl)} mov (xr)+ wa 
        stos_w                                  ; 
        mov  w0,wc                              ; store datatype name (dfnam)} mov (xr)+ wc 
        stos_w                                  ; 
        mov  wc,wb                              ; copy number of fields} lct wc wb 
sdat4:
        lea  xl,[xl-cfp_b]                      ; move one field name vrblk pointer} mov (xr)+ -(xt) 
        mov  w0,m_word [xl]                     ; 
        stos_w                                  ; 
        dec  wc                                 ; loop till all moved} bct wc sdat4 
        jnz  sdat4                              ; 
        mov  wc,wa                              ; copy length of pdblk for later loop} mov wc wa 
        mov  xr,m_word [datdv]                  ; point to vrblk} mov xr datdv 
        mov  xl,m_word [datxs]                  ; point back on stack} mov xt datxs 
        mov  xl,m_word [xl]                     ; load dfblk pointer} mov xl (xt) 
        call dffnc                              ; define function} jsr dffnc  
sdat5:
        mov  wa,cfp_b*ffsi_                     ; set length of ffblk} mov wa *ffsi_ 
        call alloc                              ; allocate space for ffblk} jsr alloc  
        mov  m_word [xr],b_ffc                  ; set type word} mov (xr) =b_ffc 
        mov  m_word [(cfp_b*fargs)+xr],num01    ; store fargs (always one)} mov fargs(xr) =num01 
        mov  xl,m_word [datxs]                  ; point back on stack} mov xt datxs 
        mov  w0,m_word [xl]                     ; copy dfblk ptr to ffblk} mov ffdfp(xr) (xt) 
        mov  m_word [(cfp_b*ffdfp)+xr],w0       ; 
        sub  wc,cfp_b                           ; decrement old dfpdl to get next ofs} dca wc  
        mov  m_word [(cfp_b*ffofs)+xr],wc       ; set offset to this field} mov ffofs(xr) wc 
        xor  w0,w0                              ; tentatively set zero forward ptr} zer ffnxt(xr)  
        mov  m_word [(cfp_b*ffnxt)+xr],w0       ; 
        mov  xl,xr                              ; copy ffblk pointer for dffnc} mov xl xr 
        mov  xr,m_word [xs]                     ; load vrblk pointer for field} mov xr (xs) 
        mov  xr,m_word [(cfp_b*vrfnc)+xr]       ; load current function pointer} mov xr vrfnc(xr) 
        cmp  m_word [xr],b_ffc                  ; skip if not currently a field func} bne (xr) =b_ffc sdat6
        jne  sdat6                              ; 
        mov  m_word [(cfp_b*ffnxt)+xl],xr       ; link new ffblk to previous chain} mov ffnxt(xl) xr 
sdat6:
        pop  xr                                 ; load vrblk pointer} mov xr (xs)+ 
        call dffnc                              ; define field function} jsr dffnc  
        cmp  xs,m_word [datxs]                  ; loop back till all done} bne xs datxs sdat5
        jne  sdat5                              ; 
        add  xs,cfp_b                           ; pop dfblk pointer} ica xs  
        jmp  exnul                              ; return with null result} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_dtp:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        call dtype                              ; get datatype} jsr dtype  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_dte:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        call gtint                              ; convert to an integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_90                            ; 
        dec  m_word [_rc_]                      ; } err 330 date argument is not integer 
        jns  _l0159                             ; 
        mov  m_word [_rc_],330                  ; 
        jmp  err_                               ; 
_l0159:                                         ; 
call_90:                                        ; 
        call sysdt                              ; call system date routine} jsr sysdt  
        mov  wa,m_word [(cfp_b*num01)+xl]       ; load length for sbstr} mov wa num01(xl) 
        test wa,wa                              ; return null if length is zero} bze wa exnul 
        jz   exnul                              ; 
        xor  wb,wb                              ; set zero offset} zer wb  
        call sbstr                              ; use sbstr to build scblk} jsr sbstr  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_def:                                          ; 
        pop  xr                                 ; load second argument} mov xr (xs)+ 
        xor  w0,w0                              ; zero label pointer in case null} zer deflb  
        mov  m_word [deflb],w0                  ; 
        cmp  xr,nulls                           ; jump if null second argument} beq xr =nulls sdf01
        je   sdf01                              ; 
        call gtnvr                              ; else find vrblk for label} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_91                            ; 
        dec  m_word [_rc_]                      ; jump if not a variable name} ppm sdf12  
        jns  _l0160                             ; 
        jmp  sdf12                              ; 
_l0160:                                         ; 
call_91:                                        ; 
        mov  m_word [deflb],xr                  ; else set specified entry} mov deflb xr 
sdf01:
        call xscni                              ; prepare to scan first argument} jsr xscni  
        dec  m_word [_rc_]                      ; 
        js   call_92                            ; 
        dec  m_word [_rc_]                      ; } err 081 define first argument is not a string 
        jns  _l0161                             ; 
        mov  m_word [_rc_],81                   ; 
        jmp  err_                               ; 
_l0161:                                         ; 
        dec  m_word [_rc_]                      ; } err 082 define first argument is null 
        jns  _l0162                             ; 
        mov  m_word [_rc_],82                   ; 
        jmp  err_                               ; 
_l0162:                                         ; 
call_92:                                        ; 
        mov  wc,ch_pp                           ; delimiter one = left paren} mov wc =ch_pp 
        mov  xl,wc                              ; delimiter two = left paren} mov xl wc 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan out function name} jsr xscan  
        test wa,wa                              ; jump if left paren found} bnz wa sdf02 
        jnz  sdf02                              ; 
        mov  m_word [_rc_],83                   ; } erb 083 define first argument is missing a left paren 
        jmp  err_                               ; 
sdf02:
        call gtnvr                              ; get variable name} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_93                            ; 
        dec  m_word [_rc_]                      ; } err 084 define first argument has null function name 
        jns  _l0163                             ; 
        mov  m_word [_rc_],84                   ; 
        jmp  err_                               ; 
_l0163:                                         ; 
call_93:                                        ; 
        mov  m_word [defvr],xr                  ; save vrblk pointer for function nam} mov defvr xr 
        xor  wb,wb                              ; zero count of arguments} zer wb  
        mov  m_word [defxs],xs                  ; save initial stack pointer} mov defxs xs 
        cmp  m_word [deflb],0                   ; jump if second argument given} bnz deflb sdf03 
        jnz  sdf03                              ; 
        mov  m_word [deflb],xr                  ; else default is function name} mov deflb xr 
sdf03:
        mov  wc,ch_rp                           ; delimiter one = right paren} mov wc =ch_rp 
        mov  xl,ch_cm                           ; delimiter two = comma} mov xl =ch_cm 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan out next argument name} jsr xscan  
        test wa,wa                              ; skip if delimiter found} bnz wa sdf04 
        jnz  sdf04                              ; 
        mov  m_word [_rc_],85                   ; } erb 085 null arg name or missing ) in define first arg. 
        jmp  err_                               ; 
sdf04:
        cmp  xr,nulls                           ; skip if non-null} bne xr =nulls sdf05
        jne  sdf05                              ; 
        test wb,wb                              ; ignore null if case of no arguments} bze wb sdf06 
        jz   sdf06                              ; 
sdf05:
        call gtnvr                              ; get vrblk pointer} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_94                            ; 
        dec  m_word [_rc_]                      ; loop back to ignore null name} ppm sdf03  
        jns  _l0164                             ; 
        jmp  sdf03                              ; 
_l0164:                                         ; 
call_94:                                        ; 
        push xr                                 ; stack argument vrblk pointer} mov -(xs) xr 
        inc  wb                                 ; increment counter} icv wb  
        cmp  wa,num02                           ; loop back if stopped by a comma} beq wa =num02 sdf03
        je   sdf03                              ; 
sdf06:
        mov  m_word [defna],wb                  ; save number of arguments} mov defna wb 
        xor  wb,wb                              ; zero count of locals} zer wb  
sdf07:
        mov  wc,ch_cm                           ; set delimiter one = comma} mov wc =ch_cm 
        mov  xl,wc                              ; set delimiter two = comma} mov xl wc 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan out next local name} jsr xscan  
        cmp  xr,nulls                           ; skip if non-null} bne xr =nulls sdf08
        jne  sdf08                              ; 
        test wa,wa                              ; exit scan if end of string} bze wa sdf09 
        jz   sdf09                              ; 
sdf08:
        call gtnvr                              ; get vrblk pointer} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_95                            ; 
        dec  m_word [_rc_]                      ; loop back to ignore null name} ppm sdf07  
        jns  _l0165                             ; 
        jmp  sdf07                              ; 
_l0165:                                         ; 
call_95:                                        ; 
        inc  wb                                 ; if ok, increment count} icv wb  
        push xr                                 ; stack vrblk pointer} mov -(xs) xr 
        test wa,wa                              ; loop back if stopped by a comma} bnz wa sdf07 
        jnz  sdf07                              ; 
sdf09:
        mov  wa,wb                              ; copy count of locals} mov wa wb 
        add  wa,m_word [defna]                  ; add number of arguments} add wa defna 
        mov  wc,wa                              ; set sum args+locals as loop count} mov wc wa 
        add  wa,pfsi_                           ; add space for standard fields} add wa =pfsi_ 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        call alloc                              ; allocate space for pfblk} jsr alloc  
        mov  xl,xr                              ; save pointer to pfblk} mov xl xr 
        mov  w0,b_pfc                           ; store first word} mov (xr)+ =b_pfc 
        stos_w                                  ; 
        mov  w0,m_word [defna]                  ; store number of arguments} mov (xr)+ defna 
        stos_w                                  ; 
        mov  w0,wa                              ; store length (pflen)} mov (xr)+ wa 
        stos_w                                  ; 
        mov  w0,m_word [defvr]                  ; store vrblk ptr for function name} mov (xr)+ defvr 
        stos_w                                  ; 
        mov  w0,wb                              ; store number of locals} mov (xr)+ wb 
        stos_w                                  ; 
        xor  w0,w0                              ; deal with label later} zer (xr)+  
        stos_w                                  ; 
        xor  w0,w0                              ; zero pfctr} zer (xr)+  
        stos_w                                  ; 
        xor  w0,w0                              ; zero pfrtr} zer (xr)+  
        stos_w                                  ; 
        test wc,wc                              ; skip if no args or locals} bze wc sdf11 
        jz   sdf11                              ; 
        mov  wa,xl                              ; keep pfblk pointer} mov wa xl 
        mov  xl,m_word [defxs]                  ; point before arguments} mov xt defxs 
sdf10:
        lea  xl,[xl-cfp_b]                      ; store one entry and bump pointers} mov (xr)+ -(xt) 
        mov  w0,m_word [xl]                     ; 
        stos_w                                  ; 
        dec  wc                                 ; loop till all stored} bct wc sdf10 
        jnz  sdf10                              ; 
        mov  xl,wa                              ; recover pfblk pointer} mov xl wa 
sdf11:
        mov  xs,m_word [defxs]                  ; pop stack} mov xs defxs 
        mov  w0,m_word [deflb]                  ; store label vrblk in pfblk} mov pfcod(xl) deflb 
        mov  m_word [(cfp_b*pfcod)+xl],w0       ; 
        mov  xr,m_word [defvr]                  ; point back to vrblk for function} mov xr defvr 
        call dffnc                              ; define function} jsr dffnc  
        jmp  exnul                              ; and exit returning null} brn exnul  
sdf12:
        mov  m_word [_rc_],86                   ; } erb 086 define function entry point is not defined label 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_det:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        call gtvar                              ; locate variable} jsr gtvar  
        dec  m_word [_rc_]                      ; 
        js   call_96                            ; 
        dec  m_word [_rc_]                      ; } err 087 detach argument is not appropriate name 
        jns  _l0166                             ; 
        mov  m_word [_rc_],87                   ; 
        jmp  err_                               ; 
_l0166:                                         ; 
call_96:                                        ; 
        call dtach                              ; detach i/o association from name} jsr dtach  
        jmp  exnul                              ; return null result} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_dif:                                          ; 
        pop  xr                                 ; load second argument} mov xr (xs)+ 
        pop  xl                                 ; load first argument} mov xl (xs)+ 
        call ident                              ; call ident comparison routine} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_97                            ; 
        dec  m_word [_rc_]                      ; fail if ident} ppm exfal  
        jns  _l0167                             ; 
        jmp  exfal                              ; 
_l0167:                                         ; 
call_97:                                        ; 
        jmp  exnul                              ; return null if differ} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_dmp:                                          ; 
        call gtsmi                              ; load dump arg as small integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_98                            ; 
        dec  m_word [_rc_]                      ; } err 088 dump argument is not integer 
        jns  _l0168                             ; 
        mov  m_word [_rc_],88                   ; 
        jmp  err_                               ; 
_l0168:                                         ; 
        dec  m_word [_rc_]                      ; } err 089 dump argument is negative or too large 
        jns  _l0169                             ; 
        mov  m_word [_rc_],89                   ; 
        jmp  err_                               ; 
_l0169:                                         ; 
call_98:                                        ; 
        call dumpr                              ; else call dump routine} jsr dumpr  
        jmp  exnul                              ; and return null as result} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_dup:                                          ; 
        call gtsmi                              ; get second argument as small integr} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_99                            ; 
        dec  m_word [_rc_]                      ; } err 090 dupl second argument is not integer 
        jns  _l0170                             ; 
        mov  m_word [_rc_],90                   ; 
        jmp  err_                               ; 
_l0170:                                         ; 
        dec  m_word [_rc_]                      ; jump if negative or too big} ppm sdup7  
        jns  _l0171                             ; 
        jmp  sdup7                              ; 
_l0171:                                         ; 
call_99:                                        ; 
        mov  wb,xr                              ; save duplication factor} mov wb xr 
        call gtstg                              ; get first arg as string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_100                           ; 
        dec  m_word [_rc_]                      ; jump if not a string} ppm sdup4  
        jns  _l0172                             ; 
        jmp  sdup4                              ; 
_l0172:                                         ; 
call_100:                                       ; 
        mov  ia,wa                              ; acquire length as integer} mti wa  
        mov  m_word [dupsi],ia                  ; save for the moment} sti dupsi  
        mov  ia,wb                              ; get duplication factor as integer} mti wb  
        imul ia,m_word [dupsi]                  ; form product} mli dupsi  
        jo   sdup3                              ; jump if overflow} iov sdup3  
        cmp  ia,0                               ; return null if result length = 0} ieq exnul  
        je   exnul                              ; 
        test ia,ia                              ; get as addr integer, check ovflo} mfi wa sdup3 
        js   sdup3                              ; 
        mov  wa,ia                              ; 
sdup1:
        mov  xl,xr                              ; save string pointer} mov xl xr 
        call alocs                              ; allocate space for string} jsr alocs  
        push xr                                 ; save as result pointer} mov -(xs) xr 
        mov  wc,xl                              ; save pointer to argument string} mov wc xl 
        add  xr,cfp_f                           ; prepare to store chars of result} psc xr  
sdup2:
        mov  xl,wc                              ; point back to argument string} mov xl wc 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; get number of characters} mov wa sclen(xl) 
        add  xl,cfp_f                           ; point to chars in argument string} plc xl  
        rep                                     ; move characters to result string} mvc   
        movs_b                                  ; 
        dec  wb                                 ; loop till all duplications done} bct wb sdup2 
        jnz  sdup2                              ; 
        xor  xl,xl                              ; clear garbage value} zer xl  
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
sdup3:
        mov  wa,m_word [dname]                  ; set impossible length for alocs} mov wa dname 
        jmp  sdup1                              ; merge back} brn sdup1  
sdup4:
        call gtpat                              ; convert argument to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_101                           ; 
        dec  m_word [_rc_]                      ; } err 091 dupl first argument is not a string or pattern 
        jns  _l0174                             ; 
        mov  m_word [_rc_],91                   ; 
        jmp  err_                               ; 
_l0174:                                         ; 
call_101:                                       ; 
        push xr                                 ; store pattern on stack} mov -(xs) xr 
        mov  xr,ndnth                           ; start off with null pattern} mov xr =ndnth 
        test wb,wb                              ; null pattern is result if dupfac=0} bze wb sdup6 
        jz   sdup6                              ; 
        push wb                                 ; preserve loop count} mov -(xs) wb 
sdup5:
        mov  xl,xr                              ; copy current value as right argumnt} mov xl xr 
        mov  xr,m_word [(cfp_b*num01)+xs]       ; get a new copy of left} mov xr num01(xs) 
        call pconc                              ; concatenate} jsr pconc  
        dec  m_word [xs]                        ; count down} dcv (xs)  
        cmp  m_word [xs],0                      ; loop} bnz (xs) sdup5 
        jnz  sdup5                              ; 
        add  xs,cfp_b                           ; pop loop count} ica xs  
sdup6:
        mov  m_word [xs],xr                     ; store result on stack} mov (xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
sdup7:
        add  xs,cfp_b                           ; pop first argument} ica xs  
        jmp  exfal                              ; fail} brn exfal  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_ejc:                                          ; 
        call iofcb                              ; call fcblk routine} jsr iofcb  
        dec  m_word [_rc_]                      ; 
        js   call_102                           ; 
        dec  m_word [_rc_]                      ; } err 092 eject argument is not a suitable name 
        jns  _l0175                             ; 
        mov  m_word [_rc_],92                   ; 
        jmp  err_                               ; 
_l0175:                                         ; 
        dec  m_word [_rc_]                      ; null argument} ppm sejc1  
        jns  _l0176                             ; 
        jmp  sejc1                              ; 
_l0176:                                         ; 
        dec  m_word [_rc_]                      ; } err 093 eject file does not exist 
        jns  _l0177                             ; 
        mov  m_word [_rc_],93                   ; 
        jmp  err_                               ; 
_l0177:                                         ; 
call_102:                                       ; 
        call sysef                              ; call eject file function} jsr sysef  
        dec  m_word [_rc_]                      ; 
        js   call_103                           ; 
        dec  m_word [_rc_]                      ; } err 093 eject file does not exist 
        jns  _l0178                             ; 
        mov  m_word [_rc_],93                   ; 
        jmp  err_                               ; 
_l0178:                                         ; 
        dec  m_word [_rc_]                      ; } err 094 eject file does not permit page eject 
        jns  _l0179                             ; 
        mov  m_word [_rc_],94                   ; 
        jmp  err_                               ; 
_l0179:                                         ; 
        dec  m_word [_rc_]                      ; } err 095 eject caused non-recoverable output error 
        jns  _l0180                             ; 
        mov  m_word [_rc_],95                   ; 
        jmp  err_                               ; 
_l0180:                                         ; 
call_103:                                       ; 
        jmp  exnul                              ; return null as result} brn exnul  
sejc1:
        call sysep                              ; call routine to eject printer} jsr sysep  
        jmp  exnul                              ; exit with null result} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_enf:                                          ; 
        call iofcb                              ; call fcblk routine} jsr iofcb  
        dec  m_word [_rc_]                      ; 
        js   call_104                           ; 
        dec  m_word [_rc_]                      ; } err 096 endfile argument is not a suitable name 
        jns  _l0181                             ; 
        mov  m_word [_rc_],96                   ; 
        jmp  err_                               ; 
_l0181:                                         ; 
        dec  m_word [_rc_]                      ; } err 097 endfile argument is null 
        jns  _l0182                             ; 
        mov  m_word [_rc_],97                   ; 
        jmp  err_                               ; 
_l0182:                                         ; 
        dec  m_word [_rc_]                      ; } err 098 endfile file does not exist 
        jns  _l0183                             ; 
        mov  m_word [_rc_],98                   ; 
        jmp  err_                               ; 
_l0183:                                         ; 
call_104:                                       ; 
        call sysen                              ; call endfile routine} jsr sysen  
        dec  m_word [_rc_]                      ; 
        js   call_105                           ; 
        dec  m_word [_rc_]                      ; } err 098 endfile file does not exist 
        jns  _l0184                             ; 
        mov  m_word [_rc_],98                   ; 
        jmp  err_                               ; 
_l0184:                                         ; 
        dec  m_word [_rc_]                      ; } err 099 endfile file does not permit endfile 
        jns  _l0185                             ; 
        mov  m_word [_rc_],99                   ; 
        jmp  err_                               ; 
_l0185:                                         ; 
        dec  m_word [_rc_]                      ; } err 100 endfile caused non-recoverable output error 
        jns  _l0186                             ; 
        mov  m_word [_rc_],100                  ; 
        jmp  err_                               ; 
_l0186:                                         ; 
call_105:                                       ; 
        mov  wb,xl                              ; remember vrblk ptr from iofcb call} mov wb xl 
        mov  xr,xl                              ; copy pointer} mov xr xl 
senf1:
        mov  xl,xr                              ; remember previous entry} mov xl xr 
        mov  xr,m_word [(cfp_b*trval)+xr]       ; chain along} mov xr trval(xr) 
        cmp  m_word [xr],b_trt                  ; skip out if chain end} bne (xr) =b_trt exnul
        jne  exnul                              ; 
        cmp  m_word [(cfp_b*trtyp)+xr],trtfc    ; loop if not found} bne trtyp(xr) =trtfc senf1
        jne  senf1                              ; 
        mov  w0,m_word [(cfp_b*trval)+xr]       ; remove trtrf} mov trval(xl) trval(xr) 
        mov  m_word [(cfp_b*trval)+xl],w0       ; 
        mov  w0,m_word [(cfp_b*trtrf)+xr]       ; point to head of iochn} mov enfch trtrf(xr) 
        mov  m_word [enfch],w0                  ; 
        mov  wc,m_word [(cfp_b*trfpt)+xr]       ; point to fcblk} mov wc trfpt(xr) 
        mov  xr,wb                              ; filearg1 vrblk from iofcb} mov xr wb 
        call setvr                              ; reset it} jsr setvr  
        mov  xl,r_fcb                           ; ptr to head of fcblk chain} mov xl =r_fcb 
        sub  xl,cfp_b*num02                     ; adjust ready to enter loop} sub xl *num02 
senf2:
        mov  xr,xl                              ; copy ptr} mov xr xl 
        mov  xl,m_word [(cfp_b*num02)+xl]       ; get next link} mov xl num02(xl) 
        test xl,xl                              ; stop if chain end} bze xl senf4 
        jz   senf4                              ; 
        cmp  m_word [(cfp_b*num03)+xl],wc       ; jump if fcblk found} beq num03(xl) wc senf3
        je   senf3                              ; 
        jmp  senf2                              ; loop} brn senf2  
senf3:
        mov  w0,m_word [(cfp_b*num02)+xl]       ; delete fcblk from chain} mov num02(xr) num02(xl) 
        mov  m_word [(cfp_b*num02)+xr],w0       ; 
senf4:
        mov  xl,m_word [enfch]                  ; get chain head} mov xl enfch 
        test xl,xl                              ; finished if chain end} bze xl exnul 
        jz   exnul                              ; 
        mov  w0,m_word [(cfp_b*trtrf)+xl]       ; chain along} mov enfch trtrf(xl) 
        mov  m_word [enfch],w0                  ; 
        mov  wa,m_word [(cfp_b*ionmo)+xl]       ; name offset} mov wa ionmo(xl) 
        mov  xl,m_word [(cfp_b*ionmb)+xl]       ; name base} mov xl ionmb(xl) 
        call dtach                              ; detach name} jsr dtach  
        jmp  senf4                              ; loop till done} brn senf4  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_eqf:                                          ; 
        call acomp                              ; call arithmetic comparison routine} jsr acomp  
        dec  m_word [_rc_]                      ; 
        js   call_106                           ; 
        dec  m_word [_rc_]                      ; } err 101 eq first argument is not numeric 
        jns  _l0187                             ; 
        mov  m_word [_rc_],101                  ; 
        jmp  err_                               ; 
_l0187:                                         ; 
        dec  m_word [_rc_]                      ; } err 102 eq second argument is not numeric 
        jns  _l0188                             ; 
        mov  m_word [_rc_],102                  ; 
        jmp  err_                               ; 
_l0188:                                         ; 
        dec  m_word [_rc_]                      ; fail if lt} ppm exfal  
        jns  _l0189                             ; 
        jmp  exfal                              ; 
_l0189:                                         ; 
        dec  m_word [_rc_]                      ; return null if eq} ppm exnul  
        jns  _l0190                             ; 
        jmp  exnul                              ; 
_l0190:                                         ; 
        dec  m_word [_rc_]                      ; fail if gt} ppm exfal  
        jns  _l0191                             ; 
        jmp  exfal                              ; 
_l0191:                                         ; 
call_106:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_evl:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        mov  r10,m_word [r13]                   ; load next code word} lcw wc  
        mov  wc,r10                             ; 
        add  r13,cfp_b                          ; 
        cmp  wc,ofne_                           ; jump if called by value} bne wc =ofne_ sevl1
        jne  sevl1                              ; 
        mov  xl,r13                             ; copy code pointer} scp xl  
        mov  wa,m_word [xl]                     ; get next code word} mov wa (xl) 
        cmp  wa,ornm_                           ; by name unless expression} bne wa =ornm_ sevl2
        jne  sevl2                              ; 
        cmp  m_word [(cfp_b*num01)+xs],0        ; jump if by name} bnz num01(xs) sevl2 
        jnz  sevl2                              ; 
sevl1:
        xor  wb,wb                              ; set flag for by value} zer wb  
        push wc                                 ; save code word} mov -(xs) wc 
        call gtexp                              ; convert to expression} jsr gtexp  
        dec  m_word [_rc_]                      ; 
        js   call_107                           ; 
        dec  m_word [_rc_]                      ; } err 103 eval argument is not expression 
        jns  _l0192                             ; 
        mov  m_word [_rc_],103                  ; 
        jmp  err_                               ; 
_l0192:                                         ; 
call_107:                                       ; 
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        xor  wb,wb                              ; set flag for by value} zer wb  
        call evalx                              ; evaluate expression by value} jsr evalx  
        dec  m_word [_rc_]                      ; 
        js   call_108                           ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm exfal  
        jns  _l0193                             ; 
        jmp  exfal                              ; 
_l0193:                                         ; 
call_108:                                       ; 
        mov  xl,xr                              ; copy result} mov xl xr 
        mov  xr,m_word [xs]                     ; reload next code word} mov xr (xs) 
        mov  m_word [xs],xl                     ; stack result} mov (xs) xl 
        jmp  m_word [xr]                        ; jump to execute next code word} bri (xr)  
sevl2:
        mov  wb,num01                           ; set flag for by name} mov wb =num01 
        call gtexp                              ; convert to expression} jsr gtexp  
        dec  m_word [_rc_]                      ; 
        js   call_109                           ; 
        dec  m_word [_rc_]                      ; } err 103 eval argument is not expression 
        jns  _l0194                             ; 
        mov  m_word [_rc_],103                  ; 
        jmp  err_                               ; 
_l0194:                                         ; 
call_109:                                       ; 
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        mov  wb,num01                           ; set flag for by name} mov wb =num01 
        call evalx                              ; evaluate expression by name} jsr evalx  
        dec  m_word [_rc_]                      ; 
        js   call_110                           ; 
        dec  m_word [_rc_]                      ; fail if evaluation fails} ppm exfal  
        jns  _l0195                             ; 
        jmp  exfal                              ; 
_l0195:                                         ; 
call_110:                                       ; 
        jmp  exnam                              ; exit with name} brn exnam  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_ext:                                          ; 
        xor  wb,wb                              ; clear amount of static shift} zer wb  
        xor  w0,w0                              ; forget interim code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        xor  w0,w0                              ; collect sediment too} zer dnams  
        mov  m_word [dnams],w0                  ; 
        call gbcol                              ; compact memory by collecting} jsr gbcol  
        mov  m_word [dnams],xr                  ; record new sediment size} mov dnams xr 
        call gtstg                              ; } jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_111                           ; 
        dec  m_word [_rc_]                      ; } err 288 exit second argument is not a string 
        jns  _l0196                             ; 
        mov  m_word [_rc_],288                  ; 
        jmp  err_                               ; 
_l0196:                                         ; 
call_111:                                       ; 
        mov  xl,xr                              ; copy second arg string pointer} mov xl xr 
        call gtstg                              ; convert arg to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_112                           ; 
        dec  m_word [_rc_]                      ; } err 104 exit first argument is not suitable integer or string 
        jns  _l0197                             ; 
        mov  m_word [_rc_],104                  ; 
        jmp  err_                               ; 
_l0197:                                         ; 
call_112:                                       ; 
        push xl                                 ; save second argument} mov -(xs) xl 
        mov  xl,xr                              ; copy first arg string ptr} mov xl xr 
        call gtint                              ; check it is integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_113                           ; 
        dec  m_word [_rc_]                      ; skip if unconvertible} ppm sext1  
        jns  _l0198                             ; 
        jmp  sext1                              ; 
_l0198:                                         ; 
call_113:                                       ; 
        xor  xl,xl                              ; note it is integer} zer xl  
        mov  ia,m_word [(cfp_b*icval)+xr]       ; get integer arg} ldi icval(xr)  
sext1:
        mov  wb,m_word [r_fcb]                  ; get fcblk chain header} mov wb r_fcb 
        mov  xr,headv                           ; point to v.v string} mov xr =headv 
        pop  wa                                 ; provide second argument scblk} mov wa (xs)+ 
        call sysxi                              ; call external routine} jsr sysxi  
        dec  m_word [_rc_]                      ; 
        js   call_114                           ; 
        dec  m_word [_rc_]                      ; } err 105 exit action not available in this implementation 
        jns  _l0199                             ; 
        mov  m_word [_rc_],105                  ; 
        jmp  err_                               ; 
_l0199:                                         ; 
        dec  m_word [_rc_]                      ; } err 106 exit action caused irrecoverable error 
        jns  _l0200                             ; 
        mov  m_word [_rc_],106                  ; 
        jmp  err_                               ; 
_l0200:                                         ; 
call_114:                                       ; 
        cmp  ia,0                               ; return if argument 0} ieq exnul  
        je   exnul                              ; 
        cmp  ia,0                               ; skip if positive} igt sext2  
        jg   sext2                              ; 
        neg  ia                                 ; make positive} ngi   
sext2:
        mov  wc,ia                              ; get value in work reg} mfi wc  
        add  wa,wc                              ; prepare to test for continue} add wa wc 
        cmp  wa,num05                           ; continued execution if 4 plus 1} beq wa =num05 sext5
        je   sext5                              ; 
        xor  w0,w0                              ; resuming execution so reset} zer gbcnt  
        mov  m_word [gbcnt],w0                  ; 
        cmp  wc,num03                           ; skip if was 3 or 4} bge wc =num03 sext3
        jae  sext3                              ; 
        push wc                                 ; save value} mov -(xs) wc 
        xor  wc,wc                              ; set to read options} zer wc  
        call prpar                              ; read syspp options} jsr prpar  
        pop  wc                                 ; restore value} mov wc (xs)+ 
sext3:
        mov  m_word [headp],xs                  ; assume no headers} mnz headp  
        cmp  wc,num01                           ; skip if not 1} bne wc =num01 sext4
        jne  sext4                              ; 
        xor  w0,w0                              ; request header printing} zer headp  
        mov  m_word [headp],w0                  ; 
sext4:
        call systm                              ; get execution time start (sgd11)} jsr systm  
        mov  m_word [timsx],ia                  ; save as initial time} sti timsx  
        mov  ia,m_word [kvstc]                  ; reset to ensure ...} ldi kvstc  
        mov  m_word [kvstl],ia                  ; ... correct execution stats} sti kvstl  
        call stgcc                              ; recompute countdown counters} jsr stgcc  
        jmp  exnul                              ; resume execution} brn exnul  
sext5:
        mov  xr,inton                           ; integer one} mov xr =inton 
        jmp  exixr                              ; return as result} brn exixr  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_exp:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_115                           ; 
        dec  m_word [_rc_]                      ; } err 304 exp argument not numeric 
        jns  _l0201                             ; 
        mov  m_word [_rc_],304                  ; 
        jmp  err_                               ; 
_l0201:                                         ; 
call_115:                                       ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        call etx_                               ; take exponential} etx   
        call do_chk_real_inf                    ; if no overflow, return result in ra} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],305                  ; } erb 305 exp produced real overflow 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_fld:                                          ; 
        call gtsmi                              ; get second argument (field number)} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_116                           ; 
        dec  m_word [_rc_]                      ; } err 107 field second argument is not integer 
        jns  _l0202                             ; 
        mov  m_word [_rc_],107                  ; 
        jmp  err_                               ; 
_l0202:                                         ; 
        dec  m_word [_rc_]                      ; fail if out of range} ppm exfal  
        jns  _l0203                             ; 
        jmp  exfal                              ; 
_l0203:                                         ; 
call_116:                                       ; 
        mov  wb,xr                              ; else save integer value} mov wb xr 
        pop  xr                                 ; load first argument} mov xr (xs)+ 
        call gtnvr                              ; point to vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_117                           ; 
        dec  m_word [_rc_]                      ; jump (error) if not variable name} ppm sfld1  
        jns  _l0204                             ; 
        jmp  sfld1                              ; 
_l0204:                                         ; 
call_117:                                       ; 
        mov  xr,m_word [(cfp_b*vrfnc)+xr]       ; else point to function block} mov xr vrfnc(xr) 
        cmp  m_word [xr],b_dfc                  ; error if not datatype function} bne (xr) =b_dfc sfld1
        jne  sfld1                              ; 
        test wb,wb                              ; fail if argument number is zero} bze wb exfal 
        jz   exfal                              ; 
        cmp  wb,m_word [(cfp_b*fargs)+xr]       ; fail if too large} bgt wb fargs(xr) exfal
        ja   exfal                              ; 
        sal  wb,log_cfp_b                       ; else convert to byte offset} wtb wb  
        add  xr,wb                              ; point to field name} add xr wb 
        mov  xr,m_word [(cfp_b*dfflb)+xr]       ; load vrblk pointer} mov xr dfflb(xr) 
        jmp  exvnm                              ; exit to build nmblk} brn exvnm  
sfld1:
        mov  m_word [_rc_],108                  ; } erb 108 field first argument is not datatype name 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_fnc:                                          ; 
        mov  wb,p_fnc                           ; set pcode for p_fnc} mov wb =p_fnc 
        xor  xr,xr                              ; p0blk} zer xr  
        call pbild                              ; build p_fnc node} jsr pbild  
        mov  xl,xr                              ; save pointer to it} mov xl xr 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_118                           ; 
        dec  m_word [_rc_]                      ; } err 259 fence argument is not pattern 
        jns  _l0205                             ; 
        mov  m_word [_rc_],259                  ; 
        jmp  err_                               ; 
_l0205:                                         ; 
call_118:                                       ; 
        call pconc                              ; concatenate to p_fnc node} jsr pconc  
        mov  xl,xr                              ; save ptr to concatenated pattern} mov xl xr 
        mov  wb,p_fna                           ; set for p_fna pcode} mov wb =p_fna 
        xor  xr,xr                              ; p0blk} zer xr  
        call pbild                              ; construct p_fna node} jsr pbild  
        mov  m_word [(cfp_b*pthen)+xr],xl       ; set pattern as pthen} mov pthen(xr) xl 
        push xr                                 ; set as result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute next code word} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_gef:                                          ; 
        call acomp                              ; call arithmetic comparison routine} jsr acomp  
        dec  m_word [_rc_]                      ; 
        js   call_119                           ; 
        dec  m_word [_rc_]                      ; } err 109 ge first argument is not numeric 
        jns  _l0206                             ; 
        mov  m_word [_rc_],109                  ; 
        jmp  err_                               ; 
_l0206:                                         ; 
        dec  m_word [_rc_]                      ; } err 110 ge second argument is not numeric 
        jns  _l0207                             ; 
        mov  m_word [_rc_],110                  ; 
        jmp  err_                               ; 
_l0207:                                         ; 
        dec  m_word [_rc_]                      ; fail if lt} ppm exfal  
        jns  _l0208                             ; 
        jmp  exfal                              ; 
_l0208:                                         ; 
        dec  m_word [_rc_]                      ; return null if eq} ppm exnul  
        jns  _l0209                             ; 
        jmp  exnul                              ; 
_l0209:                                         ; 
        dec  m_word [_rc_]                      ; return null if gt} ppm exnul  
        jns  _l0210                             ; 
        jmp  exnul                              ; 
_l0210:                                         ; 
call_119:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_gtf:                                          ; 
        call acomp                              ; call arithmetic comparison routine} jsr acomp  
        dec  m_word [_rc_]                      ; 
        js   call_120                           ; 
        dec  m_word [_rc_]                      ; } err 111 gt first argument is not numeric 
        jns  _l0211                             ; 
        mov  m_word [_rc_],111                  ; 
        jmp  err_                               ; 
_l0211:                                         ; 
        dec  m_word [_rc_]                      ; } err 112 gt second argument is not numeric 
        jns  _l0212                             ; 
        mov  m_word [_rc_],112                  ; 
        jmp  err_                               ; 
_l0212:                                         ; 
        dec  m_word [_rc_]                      ; fail if lt} ppm exfal  
        jns  _l0213                             ; 
        jmp  exfal                              ; 
_l0213:                                         ; 
        dec  m_word [_rc_]                      ; fail if eq} ppm exfal  
        jns  _l0214                             ; 
        jmp  exfal                              ; 
_l0214:                                         ; 
        dec  m_word [_rc_]                      ; return null if gt} ppm exnul  
        jns  _l0215                             ; 
        jmp  exnul                              ; 
_l0215:                                         ; 
call_120:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_hst:                                          ; 
        pop  wc                                 ; get fifth arg} mov wc (xs)+ 
        pop  wb                                 ; get fourth arg} mov wb (xs)+ 
        pop  xr                                 ; get third arg} mov xr (xs)+ 
        pop  xl                                 ; get second arg} mov xl (xs)+ 
        pop  wa                                 ; get first arg} mov wa (xs)+ 
        call syshs                              ; enter syshs routine} jsr syshs  
        dec  m_word [_rc_]                      ; 
        js   call_121                           ; 
        dec  m_word [_rc_]                      ; } err 254 erroneous argument for host 
        jns  _l0216                             ; 
        mov  m_word [_rc_],254                  ; 
        jmp  err_                               ; 
_l0216:                                         ; 
        dec  m_word [_rc_]                      ; } err 255 error during execution of host 
        jns  _l0217                             ; 
        mov  m_word [_rc_],255                  ; 
        jmp  err_                               ; 
_l0217:                                         ; 
        dec  m_word [_rc_]                      ; store host string} ppm shst1  
        jns  _l0218                             ; 
        jmp  shst1                              ; 
_l0218:                                         ; 
        dec  m_word [_rc_]                      ; return null result} ppm exnul  
        jns  _l0219                             ; 
        jmp  exnul                              ; 
_l0219:                                         ; 
        dec  m_word [_rc_]                      ; return xr} ppm exixr  
        jns  _l0220                             ; 
        jmp  exixr                              ; 
_l0220:                                         ; 
        dec  m_word [_rc_]                      ; fail return} ppm exfal  
        jns  _l0221                             ; 
        jmp  exfal                              ; 
_l0221:                                         ; 
        dec  m_word [_rc_]                      ; store actual string} ppm shst3  
        jns  _l0222                             ; 
        jmp  shst3                              ; 
_l0222:                                         ; 
        dec  m_word [_rc_]                      ; return copy of xr} ppm shst4  
        jns  _l0223                             ; 
        jmp  shst4                              ; 
_l0223:                                         ; 
call_121:                                       ; 
shst1:
        test xl,xl                              ; null string if syshs uncooperative} bze xl exnul 
        jz   exnul                              ; 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; length} mov wa sclen(xl) 
        xor  wb,wb                              ; zero offset} zer wb  
shst2:
        call sbstr                              ; build copy of string} jsr sbstr  
        push xr                                 ; stack the result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
shst3:
        xor  wb,wb                              ; treat xl like an scblk ptr} zer wb  
        sub  wb,cfp_f                           ; by creating a negative offset} sub wb =cfp_f 
        jmp  shst2                              ; join to copy string} brn shst2  
shst4:
        push xr                                 ; stack results} mov -(xs) xr 
        call copyb                              ; make copy of block} jsr copyb  
        dec  m_word [_rc_]                      ; 
        js   call_122                           ; 
        dec  m_word [_rc_]                      ; if not an aggregate structure} ppm exits  
        jns  _l0224                             ; 
        jmp  exits                              ; 
_l0224:                                         ; 
call_122:                                       ; 
        jmp  exsid                              ; set current id value otherwise} brn exsid  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_idn:                                          ; 
        pop  xr                                 ; load second argument} mov xr (xs)+ 
        pop  xl                                 ; load first argument} mov xl (xs)+ 
        call ident                              ; call ident comparison routine} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_123                           ; 
        dec  m_word [_rc_]                      ; return null if ident} ppm exnul  
        jns  _l0225                             ; 
        jmp  exnul                              ; 
_l0225:                                         ; 
call_123:                                       ; 
        jmp  exfal                              ; fail if differ} brn exfal  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_inp:                                          ; 
        xor  wb,wb                              ; input flag} zer wb  
        call ioput                              ; call input/output assoc. routine} jsr ioput  
        dec  m_word [_rc_]                      ; 
        js   call_124                           ; 
        dec  m_word [_rc_]                      ; } err 113 input third argument is not a string 
        jns  _l0226                             ; 
        mov  m_word [_rc_],113                  ; 
        jmp  err_                               ; 
_l0226:                                         ; 
        dec  m_word [_rc_]                      ; } err 114 inappropriate second argument for input 
        jns  _l0227                             ; 
        mov  m_word [_rc_],114                  ; 
        jmp  err_                               ; 
_l0227:                                         ; 
        dec  m_word [_rc_]                      ; } err 115 inappropriate first argument for input 
        jns  _l0228                             ; 
        mov  m_word [_rc_],115                  ; 
        jmp  err_                               ; 
_l0228:                                         ; 
        dec  m_word [_rc_]                      ; } err 116 inappropriate file specification for input 
        jns  _l0229                             ; 
        mov  m_word [_rc_],116                  ; 
        jmp  err_                               ; 
_l0229:                                         ; 
        dec  m_word [_rc_]                      ; fail if file does not exist} ppm exfal  
        jns  _l0230                             ; 
        jmp  exfal                              ; 
_l0230:                                         ; 
        dec  m_word [_rc_]                      ; } err 117 input file cannot be read 
        jns  _l0231                             ; 
        mov  m_word [_rc_],117                  ; 
        jmp  err_                               ; 
_l0231:                                         ; 
        dec  m_word [_rc_]                      ; } err 289 input channel currently in use 
        jns  _l0232                             ; 
        mov  m_word [_rc_],289                  ; 
        jmp  err_                               ; 
_l0232:                                         ; 
call_124:                                       ; 
        jmp  exnul                              ; return null string} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_int:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        call gtnum                              ; convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_125                           ; 
        dec  m_word [_rc_]                      ; fail if non-numeric} ppm exfal  
        jns  _l0233                             ; 
        jmp  exfal                              ; 
_l0233:                                         ; 
call_125:                                       ; 
        cmp  wa,b_icl                           ; return null if integer} beq wa =b_icl exnul
        je   exnul                              ; 
        jmp  exfal                              ; fail if real} brn exfal  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_itm:                                          ; 
        test wa,wa                              ; jump if at least one arg} bnz wa sitm1 
        jnz  sitm1                              ; 
        push nulls                              ; else supply garbage null arg} mov -(xs) =nulls 
        mov  wa,num01                           ; and fix argument count} mov wa =num01 
sitm1:
        mov  xr,r13                             ; get current code pointer} scp xr  
        mov  xl,m_word [xr]                     ; load next code word} mov xl (xr) 
        dec  wa                                 ; get number of subscripts} dcv wa  
        mov  xr,wa                              ; copy for arref} mov xr wa 
        cmp  xl,ofne_                           ; jump if called by name} beq xl =ofne_ sitm2
        je   sitm2                              ; 
        xor  wb,wb                              ; set code for call by value} zer wb  
        jmp  arref                              ; off to array reference routine} brn arref  
sitm2:
        mov  wb,xs                              ; set code for call by name} mnz wb  
        mov  r10,m_word [r13]                   ; load and ignore ofne_ call} lcw wa  
        mov  wa,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  arref                              ; off to array reference routine} brn arref  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lef:                                          ; 
        call acomp                              ; call arithmetic comparison routine} jsr acomp  
        dec  m_word [_rc_]                      ; 
        js   call_126                           ; 
        dec  m_word [_rc_]                      ; } err 118 le first argument is not numeric 
        jns  _l0234                             ; 
        mov  m_word [_rc_],118                  ; 
        jmp  err_                               ; 
_l0234:                                         ; 
        dec  m_word [_rc_]                      ; } err 119 le second argument is not numeric 
        jns  _l0235                             ; 
        mov  m_word [_rc_],119                  ; 
        jmp  err_                               ; 
_l0235:                                         ; 
        dec  m_word [_rc_]                      ; return null if lt} ppm exnul  
        jns  _l0236                             ; 
        jmp  exnul                              ; 
_l0236:                                         ; 
        dec  m_word [_rc_]                      ; return null if eq} ppm exnul  
        jns  _l0237                             ; 
        jmp  exnul                              ; 
_l0237:                                         ; 
        dec  m_word [_rc_]                      ; fail if gt} ppm exfal  
        jns  _l0238                             ; 
        jmp  exfal                              ; 
_l0238:                                         ; 
call_126:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_len:                                          ; 
        mov  wb,p_len                           ; set pcode for integer arg case} mov wb =p_len 
        mov  wa,p_lnd                           ; set pcode for expr arg case} mov wa =p_lnd 
        call patin                              ; call common routine to build node} jsr patin  
        dec  m_word [_rc_]                      ; 
        js   call_127                           ; 
        dec  m_word [_rc_]                      ; } err 120 len argument is not integer or expression 
        jns  _l0239                             ; 
        mov  m_word [_rc_],120                  ; 
        jmp  err_                               ; 
_l0239:                                         ; 
        dec  m_word [_rc_]                      ; } err 121 len argument is negative or too large 
        jns  _l0240                             ; 
        mov  m_word [_rc_],121                  ; 
        jmp  err_                               ; 
_l0240:                                         ; 
call_127:                                       ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_leq:                                          ; 
        call lcomp                              ; call string comparison routine} jsr lcomp  
        dec  m_word [_rc_]                      ; 
        js   call_128                           ; 
        dec  m_word [_rc_]                      ; } err 122 leq first argument is not a string 
        jns  _l0241                             ; 
        mov  m_word [_rc_],122                  ; 
        jmp  err_                               ; 
_l0241:                                         ; 
        dec  m_word [_rc_]                      ; } err 123 leq second argument is not a string 
        jns  _l0242                             ; 
        mov  m_word [_rc_],123                  ; 
        jmp  err_                               ; 
_l0242:                                         ; 
        dec  m_word [_rc_]                      ; fail if llt} ppm exfal  
        jns  _l0243                             ; 
        jmp  exfal                              ; 
_l0243:                                         ; 
        dec  m_word [_rc_]                      ; return null if leq} ppm exnul  
        jns  _l0244                             ; 
        jmp  exnul                              ; 
_l0244:                                         ; 
        dec  m_word [_rc_]                      ; fail if lgt} ppm exfal  
        jns  _l0245                             ; 
        jmp  exfal                              ; 
_l0245:                                         ; 
call_128:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lge:                                          ; 
        call lcomp                              ; call string comparison routine} jsr lcomp  
        dec  m_word [_rc_]                      ; 
        js   call_129                           ; 
        dec  m_word [_rc_]                      ; } err 124 lge first argument is not a string 
        jns  _l0246                             ; 
        mov  m_word [_rc_],124                  ; 
        jmp  err_                               ; 
_l0246:                                         ; 
        dec  m_word [_rc_]                      ; } err 125 lge second argument is not a string 
        jns  _l0247                             ; 
        mov  m_word [_rc_],125                  ; 
        jmp  err_                               ; 
_l0247:                                         ; 
        dec  m_word [_rc_]                      ; fail if llt} ppm exfal  
        jns  _l0248                             ; 
        jmp  exfal                              ; 
_l0248:                                         ; 
        dec  m_word [_rc_]                      ; return null if leq} ppm exnul  
        jns  _l0249                             ; 
        jmp  exnul                              ; 
_l0249:                                         ; 
        dec  m_word [_rc_]                      ; return null if lgt} ppm exnul  
        jns  _l0250                             ; 
        jmp  exnul                              ; 
_l0250:                                         ; 
call_129:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lgt:                                          ; 
        call lcomp                              ; call string comparison routine} jsr lcomp  
        dec  m_word [_rc_]                      ; 
        js   call_130                           ; 
        dec  m_word [_rc_]                      ; } err 126 lgt first argument is not a string 
        jns  _l0251                             ; 
        mov  m_word [_rc_],126                  ; 
        jmp  err_                               ; 
_l0251:                                         ; 
        dec  m_word [_rc_]                      ; } err 127 lgt second argument is not a string 
        jns  _l0252                             ; 
        mov  m_word [_rc_],127                  ; 
        jmp  err_                               ; 
_l0252:                                         ; 
        dec  m_word [_rc_]                      ; fail if llt} ppm exfal  
        jns  _l0253                             ; 
        jmp  exfal                              ; 
_l0253:                                         ; 
        dec  m_word [_rc_]                      ; fail if leq} ppm exfal  
        jns  _l0254                             ; 
        jmp  exfal                              ; 
_l0254:                                         ; 
        dec  m_word [_rc_]                      ; return null if lgt} ppm exnul  
        jns  _l0255                             ; 
        jmp  exnul                              ; 
_l0255:                                         ; 
call_130:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lle:                                          ; 
        call lcomp                              ; call string comparison routine} jsr lcomp  
        dec  m_word [_rc_]                      ; 
        js   call_131                           ; 
        dec  m_word [_rc_]                      ; } err 128 lle first argument is not a string 
        jns  _l0256                             ; 
        mov  m_word [_rc_],128                  ; 
        jmp  err_                               ; 
_l0256:                                         ; 
        dec  m_word [_rc_]                      ; } err 129 lle second argument is not a string 
        jns  _l0257                             ; 
        mov  m_word [_rc_],129                  ; 
        jmp  err_                               ; 
_l0257:                                         ; 
        dec  m_word [_rc_]                      ; return null if llt} ppm exnul  
        jns  _l0258                             ; 
        jmp  exnul                              ; 
_l0258:                                         ; 
        dec  m_word [_rc_]                      ; return null if leq} ppm exnul  
        jns  _l0259                             ; 
        jmp  exnul                              ; 
_l0259:                                         ; 
        dec  m_word [_rc_]                      ; fail if lgt} ppm exfal  
        jns  _l0260                             ; 
        jmp  exfal                              ; 
_l0260:                                         ; 
call_131:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_llt:                                          ; 
        call lcomp                              ; call string comparison routine} jsr lcomp  
        dec  m_word [_rc_]                      ; 
        js   call_132                           ; 
        dec  m_word [_rc_]                      ; } err 130 llt first argument is not a string 
        jns  _l0261                             ; 
        mov  m_word [_rc_],130                  ; 
        jmp  err_                               ; 
_l0261:                                         ; 
        dec  m_word [_rc_]                      ; } err 131 llt second argument is not a string 
        jns  _l0262                             ; 
        mov  m_word [_rc_],131                  ; 
        jmp  err_                               ; 
_l0262:                                         ; 
        dec  m_word [_rc_]                      ; return null if llt} ppm exnul  
        jns  _l0263                             ; 
        jmp  exnul                              ; 
_l0263:                                         ; 
        dec  m_word [_rc_]                      ; fail if leq} ppm exfal  
        jns  _l0264                             ; 
        jmp  exfal                              ; 
_l0264:                                         ; 
        dec  m_word [_rc_]                      ; fail if lgt} ppm exfal  
        jns  _l0265                             ; 
        jmp  exfal                              ; 
_l0265:                                         ; 
call_132:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lne:                                          ; 
        call lcomp                              ; call string comparison routine} jsr lcomp  
        dec  m_word [_rc_]                      ; 
        js   call_133                           ; 
        dec  m_word [_rc_]                      ; } err 132 lne first argument is not a string 
        jns  _l0266                             ; 
        mov  m_word [_rc_],132                  ; 
        jmp  err_                               ; 
_l0266:                                         ; 
        dec  m_word [_rc_]                      ; } err 133 lne second argument is not a string 
        jns  _l0267                             ; 
        mov  m_word [_rc_],133                  ; 
        jmp  err_                               ; 
_l0267:                                         ; 
        dec  m_word [_rc_]                      ; return null if llt} ppm exnul  
        jns  _l0268                             ; 
        jmp  exnul                              ; 
_l0268:                                         ; 
        dec  m_word [_rc_]                      ; fail if leq} ppm exfal  
        jns  _l0269                             ; 
        jmp  exfal                              ; 
_l0269:                                         ; 
        dec  m_word [_rc_]                      ; return null if lgt} ppm exnul  
        jns  _l0270                             ; 
        jmp  exnul                              ; 
_l0270:                                         ; 
call_133:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lnf:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_134                           ; 
        dec  m_word [_rc_]                      ; } err 306 ln argument not numeric 
        jns  _l0271                             ; 
        mov  m_word [_rc_],306                  ; 
        jmp  err_                               ; 
_l0271:                                         ; 
call_134:                                       ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        pxor xmm0,xmm0                          ; overflow if argument is 0} req slnf1  
        ucomisd ra,xmm0                         ; 
        je   slnf1                              ; 
        pxor xmm0,xmm0                          ; error if argument less than 0} rlt slnf2  
        ucomisd ra,xmm0                         ; 
        jb   slnf2                              ; 
        call lnf_                               ; take natural logarithm} lnf   
        call do_chk_real_inf                    ; if no overflow, return result in ra} rno exrea  
        jz   exrea                              ; 
slnf1:
        mov  m_word [_rc_],307                  ; } erb 307 ln produced real overflow 
        jmp  err_                               ; 
slnf2:
        mov  m_word [_rc_],315                  ; } erb 315 ln argument negative 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_loc:                                          ; 
        call gtsmi                              ; get second argument (local number)} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_135                           ; 
        dec  m_word [_rc_]                      ; } err 134 local second argument is not integer 
        jns  _l0272                             ; 
        mov  m_word [_rc_],134                  ; 
        jmp  err_                               ; 
_l0272:                                         ; 
        dec  m_word [_rc_]                      ; fail if out of range} ppm exfal  
        jns  _l0273                             ; 
        jmp  exfal                              ; 
_l0273:                                         ; 
call_135:                                       ; 
        mov  wb,xr                              ; save local number} mov wb xr 
        pop  xr                                 ; load first argument} mov xr (xs)+ 
        call gtnvr                              ; point to vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_136                           ; 
        dec  m_word [_rc_]                      ; jump if not variable name} ppm sloc1  
        jns  _l0274                             ; 
        jmp  sloc1                              ; 
_l0274:                                         ; 
call_136:                                       ; 
        mov  xr,m_word [(cfp_b*vrfnc)+xr]       ; else load function pointer} mov xr vrfnc(xr) 
        cmp  m_word [xr],b_pfc                  ; jump if not program defined} bne (xr) =b_pfc sloc1
        jne  sloc1                              ; 
        test wb,wb                              ; fail if second arg is zero} bze wb exfal 
        jz   exfal                              ; 
        cmp  wb,m_word [(cfp_b*pfnlo)+xr]       ; or too large} bgt wb pfnlo(xr) exfal
        ja   exfal                              ; 
        add  wb,m_word [(cfp_b*fargs)+xr]       ; else adjust offset to include args} add wb fargs(xr) 
        sal  wb,log_cfp_b                       ; convert to bytes} wtb wb  
        add  xr,wb                              ; point to local pointer} add xr wb 
        mov  xr,m_word [(cfp_b*pfagb)+xr]       ; load vrblk pointer} mov xr pfagb(xr) 
        jmp  exvnm                              ; exit building nmblk} brn exvnm  
sloc1:
        mov  m_word [_rc_],135                  ; } erb 135 local first arg is not a program function name 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lod:                                          ; 
        call gtstg                              ; load library name} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_137                           ; 
        dec  m_word [_rc_]                      ; } err 136 load second argument is not a string 
        jns  _l0275                             ; 
        mov  m_word [_rc_],136                  ; 
        jmp  err_                               ; 
_l0275:                                         ; 
call_137:                                       ; 
        mov  xl,xr                              ; save library name} mov xl xr 
        call xscni                              ; prepare to scan first argument} jsr xscni  
        dec  m_word [_rc_]                      ; 
        js   call_138                           ; 
        dec  m_word [_rc_]                      ; } err 137 load first argument is not a string 
        jns  _l0276                             ; 
        mov  m_word [_rc_],137                  ; 
        jmp  err_                               ; 
_l0276:                                         ; 
        dec  m_word [_rc_]                      ; } err 138 load first argument is null 
        jns  _l0277                             ; 
        mov  m_word [_rc_],138                  ; 
        jmp  err_                               ; 
_l0277:                                         ; 
call_138:                                       ; 
        push xl                                 ; stack library name} mov -(xs) xl 
        mov  wc,ch_pp                           ; set delimiter one = left paren} mov wc =ch_pp 
        mov  xl,wc                              ; set delimiter two = left paren} mov xl wc 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan function name} jsr xscan  
        push xr                                 ; save ptr to function name} mov -(xs) xr 
        test wa,wa                              ; jump if left paren found} bnz wa slod1 
        jnz  slod1                              ; 
        mov  m_word [_rc_],139                  ; } erb 139 load first argument is missing a left paren 
        jmp  err_                               ; 
slod1:
        call gtnvr                              ; locate vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_139                           ; 
        dec  m_word [_rc_]                      ; } err 140 load first argument has null function name 
        jns  _l0278                             ; 
        mov  m_word [_rc_],140                  ; 
        jmp  err_                               ; 
_l0278:                                         ; 
call_139:                                       ; 
        mov  m_word [lodfn],xr                  ; save vrblk pointer} mov lodfn xr 
        xor  w0,w0                              ; zero count of arguments} zer lodna  
        mov  m_word [lodna],w0                  ; 
slod2:
        mov  wc,ch_rp                           ; delimiter one is right paren} mov wc =ch_rp 
        mov  xl,ch_cm                           ; delimiter two is comma} mov xl =ch_cm 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan next argument name} jsr xscan  
        inc  m_word [lodna]                     ; bump argument count} icv lodna  
        test wa,wa                              ; jump if ok delimiter was found} bnz wa slod3 
        jnz  slod3                              ; 
        mov  m_word [_rc_],141                  ; } erb 141 load first argument is missing a right paren 
        jmp  err_                               ; 
slod3:
        mov  wb,wa                              ; save scan mode} mov wb wa 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; datatype length} mov wa sclen(xr) 
        test wa,wa                              ; bypass if null string} bze wa sld3a 
        jz   sld3a                              ; 
        call flstg                              ; fold to lower case} jsr flstg  
sld3a:
        mov  wa,wb                              ; restore scan mode} mov wa wb 
        push xr                                 ; stack datatype name pointer} mov -(xs) xr 
        mov  wb,num01                           ; set string code in case} mov wb =num01 
        mov  xl,scstr                           ; point to /string/} mov xl =scstr 
        call ident                              ; check for match} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_140                           ; 
        dec  m_word [_rc_]                      ; jump if match} ppm slod4  
        jns  _l0279                             ; 
        jmp  slod4                              ; 
_l0279:                                         ; 
call_140:                                       ; 
        mov  xr,m_word [xs]                     ; else reload name} mov xr (xs) 
        add  wb,wb                              ; set code for integer (2)} add wb wb 
        mov  xl,scint                           ; point to /integer/} mov xl =scint 
        call ident                              ; check for match} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_141                           ; 
        dec  m_word [_rc_]                      ; jump if match} ppm slod4  
        jns  _l0280                             ; 
        jmp  slod4                              ; 
_l0280:                                         ; 
call_141:                                       ; 
        mov  xr,m_word [xs]                     ; else reload string pointer} mov xr (xs) 
        inc  wb                                 ; set code for real (3)} icv wb  
        mov  xl,screa                           ; point to /real/} mov xl =screa 
        call ident                              ; check for match} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_142                           ; 
        dec  m_word [_rc_]                      ; jump if match} ppm slod4  
        jns  _l0281                             ; 
        jmp  slod4                              ; 
_l0281:                                         ; 
call_142:                                       ; 
        mov  xr,m_word [xs]                     ; reload string pointer} mov xr (xs) 
        inc  wb                                 ; code for file (4, or 3 if no reals)} icv wb  
        mov  xl,scfil                           ; point to /file/} mov xl =scfil 
        call ident                              ; check for match} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_143                           ; 
        dec  m_word [_rc_]                      ; jump if match} ppm slod4  
        jns  _l0282                             ; 
        jmp  slod4                              ; 
_l0282:                                         ; 
call_143:                                       ; 
        xor  wb,wb                              ; else get code for no convert} zer wb  
slod4:
        mov  m_word [xs],wb                     ; store code on stack} mov (xs) wb 
        cmp  wa,num02                           ; loop back if arg stopped by comma} beq wa =num02 slod2
        je   slod2                              ; 
        test wa,wa                              ; jump if that was the result type} bze wa slod5 
        jz   slod5                              ; 
        mov  wc,m_word [mxlen]                  ; set dummy (impossible) delimiter 1} mov wc mxlen 
        mov  xl,wc                              ; and delimiter two} mov xl wc 
        mov  wa,xs                              ; skip/trim blanks in prototype} mnz wa  
        call xscan                              ; scan result name} jsr xscan  
        xor  wa,wa                              ; set code for processing result} zer wa  
        jmp  slod3                              ; jump back to process result name} brn slod3  
slod5:
        mov  wa,m_word [lodna]                  ; get number of arguments} mov wa lodna 
        mov  wc,wa                              ; copy for later} mov wc wa 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        add  wa,cfp_b*efsi_                     ; add space for standard fields} add wa *efsi_ 
        call alloc                              ; allocate efblk} jsr alloc  
        mov  m_word [xr],b_efc                  ; set type word} mov (xr) =b_efc 
        mov  m_word [(cfp_b*fargs)+xr],wc       ; set number of arguments} mov fargs(xr) wc 
        xor  w0,w0                              ; set use count (dffnc will set to 1)} zer efuse(xr)  
        mov  m_word [(cfp_b*efuse)+xr],w0       ; 
        xor  w0,w0                              ; zero code pointer for now} zer efcod(xr)  
        mov  m_word [(cfp_b*efcod)+xr],w0       ; 
        pop  m_word [(cfp_b*efrsl)+xr]          ; store result type code} mov efrsl(xr) (xs)+ 
        mov  w0,m_word [lodfn]                  ; store function vrblk pointer} mov efvar(xr) lodfn 
        mov  m_word [(cfp_b*efvar)+xr],w0       ; 
        mov  m_word [(cfp_b*eflen)+xr],wa       ; store efblk length} mov eflen(xr) wa 
        mov  wb,xr                              ; save efblk pointer} mov wb xr 
        add  xr,wa                              ; point past end of efblk} add xr wa 
slod6:
        lea  xr,[xr-cfp_b]                      ; store one type code from stack} mov -(xr) (xs)+ 
        pop  m_word [xr]                        ; 
        dec  wc                                 ; loop till all stored} bct wc slod6 
        jnz  slod6                              ; 
        pop  xr                                 ; load function string name} mov xr (xs)+ 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; function name length} mov wa sclen(xr) 
        call flstg                              ; fold to lower case} jsr flstg  
        mov  xl,m_word [xs]                     ; load library name} mov xl (xs) 
        mov  m_word [xs],wb                     ; store efblk pointer} mov (xs) wb 
        call sysld                              ; call function to load external func} jsr sysld  
        dec  m_word [_rc_]                      ; 
        js   call_144                           ; 
        dec  m_word [_rc_]                      ; } err 142 load function does not exist 
        jns  _l0283                             ; 
        mov  m_word [_rc_],142                  ; 
        jmp  err_                               ; 
_l0283:                                         ; 
        dec  m_word [_rc_]                      ; } err 143 load function caused input error during load 
        jns  _l0284                             ; 
        mov  m_word [_rc_],143                  ; 
        jmp  err_                               ; 
_l0284:                                         ; 
        dec  m_word [_rc_]                      ; } err 328 load function - insufficient memory 
        jns  _l0285                             ; 
        mov  m_word [_rc_],328                  ; 
        jmp  err_                               ; 
_l0285:                                         ; 
call_144:                                       ; 
        pop  xl                                 ; recall efblk pointer} mov xl (xs)+ 
        mov  m_word [(cfp_b*efcod)+xl],xr       ; store code pointer} mov efcod(xl) xr 
        mov  xr,m_word [lodfn]                  ; point to vrblk for function} mov xr lodfn 
        call dffnc                              ; perform function definition} jsr dffnc  
        jmp  exnul                              ; return null result} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_lpd:                                          ; 
        call gtstg                              ; get pad character} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_145                           ; 
        dec  m_word [_rc_]                      ; } err 144 lpad third argument is not a string 
        jns  _l0286                             ; 
        mov  m_word [_rc_],144                  ; 
        jmp  err_                               ; 
_l0286:                                         ; 
call_145:                                       ; 
        add  xr,cfp_f                           ; point to character (null is blank)} plc xr  
        xor  w0,w0                              ; load pad character} lch wb (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        call gtsmi                              ; get pad length} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_146                           ; 
        dec  m_word [_rc_]                      ; } err 145 lpad second argument is not integer 
        jns  _l0287                             ; 
        mov  m_word [_rc_],145                  ; 
        jmp  err_                               ; 
_l0287:                                         ; 
        dec  m_word [_rc_]                      ; skip if negative or large} ppm slpd4  
        jns  _l0288                             ; 
        jmp  slpd4                              ; 
_l0288:                                         ; 
call_146:                                       ; 
slpd1:
        call gtstg                              ; get first argument (string to pad)} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_147                           ; 
        dec  m_word [_rc_]                      ; } err 146 lpad first argument is not a string 
        jns  _l0289                             ; 
        mov  m_word [_rc_],146                  ; 
        jmp  err_                               ; 
_l0289:                                         ; 
call_147:                                       ; 
        cmp  wa,wc                              ; return 1st arg if too long to pad} bge wa wc exixr
        jae  exixr                              ; 
        mov  xl,xr                              ; else move ptr to string to pad} mov xl xr 
        mov  wa,wc                              ; copy length} mov wa wc 
        call alocs                              ; allocate scblk for new string} jsr alocs  
        push xr                                 ; save as result} mov -(xs) xr 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load length of argument} mov wa sclen(xl) 
        sub  wc,wa                              ; calculate number of pad characters} sub wc wa 
        add  xr,cfp_f                           ; point to chars in result string} psc xr  
slpd2:
        mov  al,bl                              ; store pad character, bump ptr} sch wb (xr)+ 
        stos_b                                  ; 
        dec  wc                                 ; loop till all pad chars stored} bct wc slpd2 
        jnz  slpd2                              ; 
        test wa,wa                              ; exit if null string} bze wa slpd3 
        jz   slpd3                              ; 
        add  xl,cfp_f                           ; else point to chars in argument} plc xl  
        rep                                     ; move characters to result string} mvc   
        movs_b                                  ; 
        xor  xl,xl                              ; clear garbage xl} zer xl  
slpd3:
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
slpd4:
        xor  wc,wc                              ; zero pad count} zer wc  
        jmp  slpd1                              ; merge} brn slpd1  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_ltf:                                          ; 
        call acomp                              ; call arithmetic comparison routine} jsr acomp  
        dec  m_word [_rc_]                      ; 
        js   call_148                           ; 
        dec  m_word [_rc_]                      ; } err 147 lt first argument is not numeric 
        jns  _l0291                             ; 
        mov  m_word [_rc_],147                  ; 
        jmp  err_                               ; 
_l0291:                                         ; 
        dec  m_word [_rc_]                      ; } err 148 lt second argument is not numeric 
        jns  _l0292                             ; 
        mov  m_word [_rc_],148                  ; 
        jmp  err_                               ; 
_l0292:                                         ; 
        dec  m_word [_rc_]                      ; return null if lt} ppm exnul  
        jns  _l0293                             ; 
        jmp  exnul                              ; 
_l0293:                                         ; 
        dec  m_word [_rc_]                      ; fail if eq} ppm exfal  
        jns  _l0294                             ; 
        jmp  exfal                              ; 
_l0294:                                         ; 
        dec  m_word [_rc_]                      ; fail if gt} ppm exfal  
        jns  _l0295                             ; 
        jmp  exfal                              ; 
_l0295:                                         ; 
call_148:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_nef:                                          ; 
        call acomp                              ; call arithmetic comparison routine} jsr acomp  
        dec  m_word [_rc_]                      ; 
        js   call_149                           ; 
        dec  m_word [_rc_]                      ; } err 149 ne first argument is not numeric 
        jns  _l0296                             ; 
        mov  m_word [_rc_],149                  ; 
        jmp  err_                               ; 
_l0296:                                         ; 
        dec  m_word [_rc_]                      ; } err 150 ne second argument is not numeric 
        jns  _l0297                             ; 
        mov  m_word [_rc_],150                  ; 
        jmp  err_                               ; 
_l0297:                                         ; 
        dec  m_word [_rc_]                      ; return null if lt} ppm exnul  
        jns  _l0298                             ; 
        jmp  exnul                              ; 
_l0298:                                         ; 
        dec  m_word [_rc_]                      ; fail if eq} ppm exfal  
        jns  _l0299                             ; 
        jmp  exfal                              ; 
_l0299:                                         ; 
        dec  m_word [_rc_]                      ; return null if gt} ppm exnul  
        jns  _l0300                             ; 
        jmp  exnul                              ; 
_l0300:                                         ; 
call_149:                                       ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_nay:                                          ; 
        mov  wb,p_nas                           ; set pcode for single char arg} mov wb =p_nas 
        mov  xl,p_nay                           ; pcode for multi-char arg} mov xl =p_nay 
        mov  wc,p_nad                           ; set pcode for expr arg} mov wc =p_nad 
        call patst                              ; call common routine to build node} jsr patst  
        dec  m_word [_rc_]                      ; 
        js   call_150                           ; 
        dec  m_word [_rc_]                      ; } err 151 notany argument is not a string or expression 
        jns  _l0301                             ; 
        mov  m_word [_rc_],151                  ; 
        jmp  err_                               ; 
_l0301:                                         ; 
call_150:                                       ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_ops:                                          ; 
        call gtsmi                              ; load third argument} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_151                           ; 
        dec  m_word [_rc_]                      ; } err 152 opsyn third argument is not integer 
        jns  _l0302                             ; 
        mov  m_word [_rc_],152                  ; 
        jmp  err_                               ; 
_l0302:                                         ; 
        dec  m_word [_rc_]                      ; } err 153 opsyn third argument is negative or too large 
        jns  _l0303                             ; 
        mov  m_word [_rc_],153                  ; 
        jmp  err_                               ; 
_l0303:                                         ; 
call_151:                                       ; 
        mov  wb,wc                              ; if ok, save third argumnet} mov wb wc 
        pop  xr                                 ; load second argument} mov xr (xs)+ 
        call gtnvr                              ; locate variable block} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_152                           ; 
        dec  m_word [_rc_]                      ; } err 154 opsyn second arg is not natural variable name 
        jns  _l0304                             ; 
        mov  m_word [_rc_],154                  ; 
        jmp  err_                               ; 
_l0304:                                         ; 
call_152:                                       ; 
        mov  xl,m_word [(cfp_b*vrfnc)+xr]       ; if ok, load function block pointer} mov xl vrfnc(xr) 
        test wb,wb                              ; jump if operator opsyn case} bnz wb sops2 
        jnz  sops2                              ; 
        pop  xr                                 ; load first argument} mov xr (xs)+ 
        call gtnvr                              ; get vrblk pointer} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_153                           ; 
        dec  m_word [_rc_]                      ; } err 155 opsyn first arg is not natural variable name 
        jns  _l0305                             ; 
        mov  m_word [_rc_],155                  ; 
        jmp  err_                               ; 
_l0305:                                         ; 
call_153:                                       ; 
sops1:
        call dffnc                              ; call function definer} jsr dffnc  
        jmp  exnul                              ; exit with null result} brn exnul  
sops2:
        call gtstg                              ; get operator name} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_154                           ; 
        dec  m_word [_rc_]                      ; jump if not string} ppm sops5  
        jns  _l0306                             ; 
        jmp  sops5                              ; 
_l0306:                                         ; 
call_154:                                       ; 
        cmp  wa,num01                           ; error if not one char long} bne wa =num01 sops5
        jne  sops5                              ; 
        add  xr,cfp_f                           ; else point to character} plc xr  
        xor  w0,w0                              ; load character name} lch wc (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        mov  wa,r_uub                           ; point to unop pointers in case} mov wa =r_uub 
        mov  xr,opnsu                           ; point to names of unary operators} mov xr =opnsu 
        add  wb,opbun                           ; add no. of undefined binary ops} add wb =opbun 
        cmp  wb,opuun                           ; jump if unop (third arg was 1)} beq wb =opuun sops3
        je   sops3                              ; 
        mov  wa,r_uba                           ; else point to binary operator ptrs} mov wa =r_uba 
        mov  xr,opsnb                           ; point to names of binary operators} mov xr =opsnb 
        mov  wb,opbun                           ; set number of undefined binops} mov wb =opbun 
sops3:
                                                ; set counter to control loop} lct wb wb 
sops4:
        cmp  wc,m_word [xr]                     ; jump if names match} beq wc (xr) sops6
        je   sops6                              ; 
        add  wa,cfp_b                           ; else push pointer to function ptr} ica wa  
        add  xr,cfp_b                           ; bump pointer} ica xr  
        dec  wb                                 ; loop back till all checked} bct wb sops4 
        jnz  sops4                              ; 
sops5:
        mov  m_word [_rc_],156                  ; } erb 156 opsyn first arg is not correct operator name 
        jmp  err_                               ; 
sops6:
        mov  xr,wa                              ; copy pointer to function block ptr} mov xr wa 
        sub  xr,cfp_b*vrfnc                     ; make it look like dummy vrblk} sub xr *vrfnc 
        jmp  sops1                              ; merge back to define operator} brn sops1  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_oup:                                          ; 
        mov  wb,num03                           ; output flag} mov wb =num03 
        call ioput                              ; call input/output assoc. routine} jsr ioput  
        dec  m_word [_rc_]                      ; 
        js   call_155                           ; 
        dec  m_word [_rc_]                      ; } err 157 output third argument is not a string 
        jns  _l0307                             ; 
        mov  m_word [_rc_],157                  ; 
        jmp  err_                               ; 
_l0307:                                         ; 
        dec  m_word [_rc_]                      ; } err 158 inappropriate second argument for output 
        jns  _l0308                             ; 
        mov  m_word [_rc_],158                  ; 
        jmp  err_                               ; 
_l0308:                                         ; 
        dec  m_word [_rc_]                      ; } err 159 inappropriate first argument for output 
        jns  _l0309                             ; 
        mov  m_word [_rc_],159                  ; 
        jmp  err_                               ; 
_l0309:                                         ; 
        dec  m_word [_rc_]                      ; } err 160 inappropriate file specification for output 
        jns  _l0310                             ; 
        mov  m_word [_rc_],160                  ; 
        jmp  err_                               ; 
_l0310:                                         ; 
        dec  m_word [_rc_]                      ; fail if file does not exist} ppm exfal  
        jns  _l0311                             ; 
        jmp  exfal                              ; 
_l0311:                                         ; 
        dec  m_word [_rc_]                      ; } err 161 output file cannot be written to 
        jns  _l0312                             ; 
        mov  m_word [_rc_],161                  ; 
        jmp  err_                               ; 
_l0312:                                         ; 
        dec  m_word [_rc_]                      ; } err 290 output channel currently in use 
        jns  _l0313                             ; 
        mov  m_word [_rc_],290                  ; 
        jmp  err_                               ; 
_l0313:                                         ; 
call_155:                                       ; 
        jmp  exnul                              ; return null string} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_pos:                                          ; 
        mov  wb,p_pos                           ; set pcode for integer arg case} mov wb =p_pos 
        mov  wa,p_psd                           ; set pcode for expression arg case} mov wa =p_psd 
        call patin                              ; call common routine to build node} jsr patin  
        dec  m_word [_rc_]                      ; 
        js   call_156                           ; 
        dec  m_word [_rc_]                      ; } err 162 pos argument is not integer or expression 
        jns  _l0314                             ; 
        mov  m_word [_rc_],162                  ; 
        jmp  err_                               ; 
_l0314:                                         ; 
        dec  m_word [_rc_]                      ; } err 163 pos argument is negative or too large 
        jns  _l0315                             ; 
        mov  m_word [_rc_],163                  ; 
        jmp  err_                               ; 
_l0315:                                         ; 
call_156:                                       ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_pro:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        mov  wb,m_word [(cfp_b*tblen)+xr]       ; length if table, vector (=vclen)} mov wb tblen(xr) 
        shr  wb,log_cfp_b                       ; convert to words} btw wb  
        mov  wa,m_word [xr]                     ; load type word of argument block} mov wa (xr) 
        cmp  wa,b_art                           ; jump if array} beq wa =b_art spro4
        je   spro4                              ; 
        cmp  wa,b_tbt                           ; jump if table} beq wa =b_tbt spro1
        je   spro1                              ; 
        cmp  wa,b_vct                           ; jump if vector} beq wa =b_vct spro3
        je   spro3                              ; 
        mov  m_word [_rc_],164                  ; } erb 164 prototype argument is not valid object 
        jmp  err_                               ; 
spro1:
        sub  wb,tbsi_                           ; subtract standard fields} sub wb =tbsi_ 
spro2:
        mov  ia,wb                              ; convert to integer} mti wb  
        jmp  exint                              ; exit with integer result} brn exint  
spro3:
        sub  wb,vcsi_                           ; subtract standard fields} sub wb =vcsi_ 
        jmp  spro2                              ; merge} brn spro2  
spro4:
        add  xr,m_word [(cfp_b*arofs)+xr]       ; point to prototype field} add xr arofs(xr) 
        mov  xr,m_word [xr]                     ; load prototype} mov xr (xr) 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rmd:                                          ; 
        call arith                              ; get two integers or two reals} jsr arith  
        dec  m_word [_rc_]                      ; 
        js   call_157                           ; 
        dec  m_word [_rc_]                      ; } err 166 remdr first argument is not numeric 
        jns  _l0316                             ; 
        mov  m_word [_rc_],166                  ; 
        jmp  err_                               ; 
_l0316:                                         ; 
        dec  m_word [_rc_]                      ; } err 165 remdr second argument is not numeric 
        jns  _l0317                             ; 
        mov  m_word [_rc_],165                  ; 
        jmp  err_                               ; 
_l0317:                                         ; 
        dec  m_word [_rc_]                      ; if real} ppm srm06  
        jns  _l0318                             ; 
        jmp  srm06                              ; 
_l0318:                                         ; 
call_157:                                       ; 
        xor  wb,wb                              ; set positive flag} zer wb  
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load left argument value} ldi icval(xr)  
        cmp  ia,0                               ; jump if positive} ige srm01  
        jge  srm01                              ; 
        mov  wb,xs                              ; set negative flag} mnz wb  
srm01:
        mov  r10,m_word [(cfp_b*icval)+xl]      ; get remainder} rmi icval(xl)  
        call do_rmi                             ; 
        jo   srm05                              ; error if overflow} iov srm05  
        test wb,wb                              ; if result should be positive} bze wb srm03 
        jz   srm03                              ; 
        cmp  ia,0                               ; if should be negative, and is} ile exint  
        jle  exint                              ; 
srm02:
        neg  ia                                 ; adjust sign of result} ngi   
        jmp  exint                              ; return result} brn exint  
srm03:
        cmp  ia,0                               ; should be pos, and result negative} ilt srm02  
        jl   srm02                              ; 
        jmp  exint                              ; should be positive, and is} brn exint  
srm04:
        mov  m_word [_rc_],166                  ; } erb 166 remdr first argument is not numeric 
        jmp  err_                               ; 
srm05:
        mov  m_word [_rc_],167                  ; } erb 167 remdr caused integer overflow 
        jmp  err_                               ; 
srm06:
        xor  wb,wb                              ; set positive flag} zer wb  
        movsd ra,[(cfp_b*rcval)+xr]             ; load left argument value} ldr rcval(xr)  
        pxor xmm0,xmm0                          ; jump if positive} rge srm07  
        ucomisd ra,xmm0                         ; 
        jae  srm07                              ; 
        mov  wb,xs                              ; set negative flag} mnz wb  
srm07:
        ldmxcsr [mxcsr_set]                     ; compute n1/n2} dvr rcval(xl)  
        divsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0319                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0319:                                         ; 
        call do_chk_real_inf                    ; jump if overflow} rov srm10  
        jnz  srm10                              ; 
        call chp_                               ; chop result} chp   
        ldmxcsr [mxcsr_set]                     ; times n2} mlr rcval(xl)  
        mulsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0320                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0320:                                         ; 
        ldmxcsr [mxcsr_set]                     ; compute difference} sbr rcval(xr)  
        subsd ra,[(cfp_b*rcval)+xr]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0321                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0321:                                         ; 
        test wb,wb                              ; if result should be positive} bze wb srm09 
        jz   srm09                              ; 
        pxor xmm0,xmm0                          ; if should be negative, and is} rle exrea  
        ucomisd ra,xmm0                         ; 
        jbe  exrea                              ; 
srm08:
        movsd xmm0,m_real [zeron]               ; adjust sign of result} ngr   
        pxor ra,xmm0                            ; 
        jmp  exrea                              ; return result} brn exrea  
srm09:
        pxor xmm0,xmm0                          ; should be pos, and result negative} rlt srm08  
        ucomisd ra,xmm0                         ; 
        jb   srm08                              ; 
        jmp  exrea                              ; should be positive, and is} brn exrea  
srm10:
        mov  m_word [_rc_],312                  ; } erb 312 remdr caused real overflow 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rpl:                                          ; 
        call gtstg                              ; load third argument as string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_158                           ; 
        dec  m_word [_rc_]                      ; } err 168 replace third argument is not a string 
        jns  _l0322                             ; 
        mov  m_word [_rc_],168                  ; 
        jmp  err_                               ; 
_l0322:                                         ; 
call_158:                                       ; 
        mov  xl,xr                              ; save third arg ptr} mov xl xr 
        call gtstg                              ; get second argument} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_159                           ; 
        dec  m_word [_rc_]                      ; } err 169 replace second argument is not a string 
        jns  _l0323                             ; 
        mov  m_word [_rc_],169                  ; 
        jmp  err_                               ; 
_l0323:                                         ; 
call_159:                                       ; 
        cmp  xr,m_word [r_ra2]                  ; jump if 2nd argument different} bne xr r_ra2 srpl1
        jne  srpl1                              ; 
        cmp  xl,m_word [r_ra3]                  ; jump if args same as last time} beq xl r_ra3 srpl4
        je   srpl4                              ; 
srpl1:
        mov  wb,m_word [(cfp_b*sclen)+xl]       ; load 3rd argument length} mov wb sclen(xl) 
        cmp  wa,wb                              ; jump if arguments not same length} bne wa wb srpl6
        jne  srpl6                              ; 
        cmp  xr,m_word [kvalp]                  ; jump if 2nd arg is alphabet string} beq xr kvalp srpl5
        je   srpl5                              ; 
        test wb,wb                              ; jump if null 2nd argument} bze wb srpl6 
        jz   srpl6                              ; 
        mov  m_word [r_ra3],xl                  ; save third arg for next time in} mov r_ra3 xl 
        mov  m_word [r_ra2],xr                  ; save second arg for next time in} mov r_ra2 xr 
        mov  xl,m_word [kvalp]                  ; point to alphabet string} mov xl kvalp 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load alphabet scblk length} mov wa sclen(xl) 
        mov  xr,m_word [r_rpt]                  ; point to current table (if any)} mov xr r_rpt 
        test xr,xr                              ; jump if we already have a table} bnz xr srpl2 
        jnz  srpl2                              ; 
        call alocs                              ; allocate new table} jsr alocs  
        mov  wa,wc                              ; keep scblk length} mov wa wc 
        mov  m_word [r_rpt],xr                  ; save table pointer for next time} mov r_rpt xr 
srpl2:
        add  wa,(cfp_b-1)+cfp_b*scsi_           ; compute length of scblk} ctb wa scsi_ 
        and  wa,-cfp_b                          ; 
        shr  wa,log_cfp_b                       ; copy to get initial table values} mvw   
        rep  movs_w                             ; 
        mov  xl,m_word [r_ra2]                  ; point to second argument} mov xl r_ra2 
        xor  wc,wc                              ; zero char offset} zer wc  
        mov  xr,m_word [r_ra3]                  ; point to 3rd arg} mov xr r_ra3 
        add  xr,cfp_f                           ; get char ptr for 3rd arg} plc xr  
srpl3:
        mov  xl,m_word [r_ra2]                  ; point to 2nd arg} mov xl r_ra2 
        lea  xl,[cfp_f+xl+wc]                   ; point to next char} plc xl wc 
        inc  wc                                 ; increment offset} icv wc  
        xor  w0,w0                              ; get next char} lch wa (xl) 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        mov  xl,m_word [r_rpt]                  ; point to translate table} mov xl r_rpt 
        lea  xl,[cfp_f+xl+wa]                   ; convert char to offset into table} psc xl wa 
        xor  w0,w0                              ; get translated char} lch wa (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        inc  xr                                 ; 
        mov  m_char [xl],cl                     ; store in table} sch wa (xl) 
        dec  wb                                 ; loop till done} bct wb srpl3 
        jnz  srpl3                              ; 
srpl4:
        mov  xl,m_word [r_rpt]                  ; replace table to use} mov xl r_rpt 
srpl5:
        call gtstg                              ; get first argument} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_160                           ; 
        dec  m_word [_rc_]                      ; } err 170 replace first argument is not a string 
        jns  _l0324                             ; 
        mov  m_word [_rc_],170                  ; 
        jmp  err_                               ; 
_l0324:                                         ; 
call_160:                                       ; 
        test wa,wa                              ; return null if null argument} bze wa exnul 
        jz   exnul                              ; 
        push xl                                 ; stack replace table to use} mov -(xs) xl 
        mov  xl,xr                              ; copy pointer} mov xl xr 
        mov  wc,wa                              ; save length} mov wc wa 
        add  wa,(cfp_b-1)+cfp_b*schar           ; get scblk length} ctb wa schar 
        and  wa,-cfp_b                          ; 
        call alloc                              ; allocate space for copy} jsr alloc  
        mov  wb,xr                              ; save address of copy} mov wb xr 
        shr  wa,log_cfp_b                       ; move scblk contents to copy} mvw   
        rep  movs_w                             ; 
        pop  xr                                 ; unstack replace table} mov xr (xs)+ 
        add  xr,cfp_f                           ; point to chars of table} plc xr  
        mov  xl,wb                              ; point to string to translate} mov xl wb 
        add  xl,cfp_f                           ; point to chars of string} plc xl  
        mov  wa,wc                              ; set number of chars to translate} mov wa wc 
        xchg xl,xr                              ; perform translation} trc   
_l0325: movzx w0,m_char [xr]                    ; 
        mov  al,[xl+w0]                         ; 
        stosb                                   ; 
        dec  wa                                 ; 
        jnz  _l0325                             ; 
        xor  xl,xl                              ; 
        xor  xr,xr                              ; 
srpl8:
        push wb                                 ; stack result} mov -(xs) wb 
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
srpl6:
        mov  m_word [_rc_],171                  ; } erb 171 null or unequally long 2nd, 3rd args to replace 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rew:                                          ; 
        call iofcb                              ; call fcblk routine} jsr iofcb  
        dec  m_word [_rc_]                      ; 
        js   call_161                           ; 
        dec  m_word [_rc_]                      ; } err 172 rewind argument is not a suitable name 
        jns  _l0326                             ; 
        mov  m_word [_rc_],172                  ; 
        jmp  err_                               ; 
_l0326:                                         ; 
        dec  m_word [_rc_]                      ; } err 173 rewind argument is null 
        jns  _l0327                             ; 
        mov  m_word [_rc_],173                  ; 
        jmp  err_                               ; 
_l0327:                                         ; 
        dec  m_word [_rc_]                      ; } err 174 rewind file does not exist 
        jns  _l0328                             ; 
        mov  m_word [_rc_],174                  ; 
        jmp  err_                               ; 
_l0328:                                         ; 
call_161:                                       ; 
        call sysrw                              ; call system rewind function} jsr sysrw  
        dec  m_word [_rc_]                      ; 
        js   call_162                           ; 
        dec  m_word [_rc_]                      ; } err 174 rewind file does not exist 
        jns  _l0329                             ; 
        mov  m_word [_rc_],174                  ; 
        jmp  err_                               ; 
_l0329:                                         ; 
        dec  m_word [_rc_]                      ; } err 175 rewind file does not permit rewind 
        jns  _l0330                             ; 
        mov  m_word [_rc_],175                  ; 
        jmp  err_                               ; 
_l0330:                                         ; 
        dec  m_word [_rc_]                      ; } err 176 rewind caused non-recoverable error 
        jns  _l0331                             ; 
        mov  m_word [_rc_],176                  ; 
        jmp  err_                               ; 
_l0331:                                         ; 
call_162:                                       ; 
        jmp  exnul                              ; exit with null result if no error} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rvs:                                          ; 
        call gtstg                              ; load string argument} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_163                           ; 
        dec  m_word [_rc_]                      ; } err 177 reverse argument is not a string 
        jns  _l0332                             ; 
        mov  m_word [_rc_],177                  ; 
        jmp  err_                               ; 
_l0332:                                         ; 
call_163:                                       ; 
        test wa,wa                              ; return argument if null} bze wa exixr 
        jz   exixr                              ; 
        mov  xl,xr                              ; else save pointer to string arg} mov xl xr 
        call alocs                              ; allocate space for new scblk} jsr alocs  
        push xr                                 ; store scblk ptr on stack as result} mov -(xs) xr 
        add  xr,cfp_f                           ; prepare to store in new scblk} psc xr  
        lea  xl,[cfp_f+xl+wc]                   ; point past last char in argument} plc xl wc 
srvs1:
        dec  xl                                 ; load next char from argument} lch wb -(xl) 
        xor  w0,w0                              ; 
        mov  al,m_char [xl]                     ; 
        mov  wb,w0                              ; 
        mov  al,bl                              ; store in result} sch wb (xr)+ 
        stos_b                                  ; 
        dec  wc                                 ; loop till all moved} bct wc srvs1 
        jnz  srvs1                              ; 
srvs4:
                                                ; complete store characters} csc xr  
        xor  xl,xl                              ; clear garbage xl} zer xl  
srvs2:
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rpd:                                          ; 
        call gtstg                              ; get pad character} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_164                           ; 
        dec  m_word [_rc_]                      ; } err 178 rpad third argument is not a string 
        jns  _l0333                             ; 
        mov  m_word [_rc_],178                  ; 
        jmp  err_                               ; 
_l0333:                                         ; 
call_164:                                       ; 
        add  xr,cfp_f                           ; point to character (null is blank)} plc xr  
        xor  w0,w0                              ; load pad character} lch wb (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        call gtsmi                              ; get pad length} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_165                           ; 
        dec  m_word [_rc_]                      ; } err 179 rpad second argument is not integer 
        jns  _l0334                             ; 
        mov  m_word [_rc_],179                  ; 
        jmp  err_                               ; 
_l0334:                                         ; 
        dec  m_word [_rc_]                      ; skip if negative or large} ppm srpd3  
        jns  _l0335                             ; 
        jmp  srpd3                              ; 
_l0335:                                         ; 
call_165:                                       ; 
srpd1:
        call gtstg                              ; get first argument (string to pad)} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_166                           ; 
        dec  m_word [_rc_]                      ; } err 180 rpad first argument is not a string 
        jns  _l0336                             ; 
        mov  m_word [_rc_],180                  ; 
        jmp  err_                               ; 
_l0336:                                         ; 
call_166:                                       ; 
        cmp  wa,wc                              ; return 1st arg if too long to pad} bge wa wc exixr
        jae  exixr                              ; 
        mov  xl,xr                              ; else move ptr to string to pad} mov xl xr 
        mov  wa,wc                              ; copy length} mov wa wc 
        call alocs                              ; allocate scblk for new string} jsr alocs  
        push xr                                 ; save as result} mov -(xs) xr 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load length of argument} mov wa sclen(xl) 
        sub  wc,wa                              ; calculate number of pad characters} sub wc wa 
        add  xr,cfp_f                           ; point to chars in result string} psc xr  
        test wa,wa                              ; jump if argument is null} bze wa srpd2 
        jz   srpd2                              ; 
        add  xl,cfp_f                           ; else point to argument chars} plc xl  
        rep                                     ; move characters to result string} mvc   
        movs_b                                  ; 
        xor  xl,xl                              ; clear garbage xl} zer xl  
srpd2:
        mov  al,bl                              ; store pad character, bump ptr} sch wb (xr)+ 
        stos_b                                  ; 
        dec  wc                                 ; loop till all pad chars stored} bct wc srpd2 
        jnz  srpd2                              ; 
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
srpd3:
        xor  wc,wc                              ; zero pad count} zer wc  
        jmp  srpd1                              ; merge} brn srpd1  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rtb:                                          ; 
        mov  wb,p_rtb                           ; set pcode for integer arg case} mov wb =p_rtb 
        mov  wa,p_rtd                           ; set pcode for expression arg case} mov wa =p_rtd 
        call patin                              ; call common routine to build node} jsr patin  
        dec  m_word [_rc_]                      ; 
        js   call_167                           ; 
        dec  m_word [_rc_]                      ; } err 181 rtab argument is not integer or expression 
        jns  _l0338                             ; 
        mov  m_word [_rc_],181                  ; 
        jmp  err_                               ; 
_l0338:                                         ; 
        dec  m_word [_rc_]                      ; } err 182 rtab argument is negative or too large 
        jns  _l0339                             ; 
        mov  m_word [_rc_],182                  ; 
        jmp  err_                               ; 
_l0339:                                         ; 
call_167:                                       ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_tab:                                          ; 
        mov  wb,p_tab                           ; set pcode for integer arg case} mov wb =p_tab 
        mov  wa,p_tbd                           ; set pcode for expression arg case} mov wa =p_tbd 
        call patin                              ; call common routine to build node} jsr patin  
        dec  m_word [_rc_]                      ; 
        js   call_168                           ; 
        dec  m_word [_rc_]                      ; } err 183 tab argument is not integer or expression 
        jns  _l0340                             ; 
        mov  m_word [_rc_],183                  ; 
        jmp  err_                               ; 
_l0340:                                         ; 
        dec  m_word [_rc_]                      ; } err 184 tab argument is negative or too large 
        jns  _l0341                             ; 
        mov  m_word [_rc_],184                  ; 
        jmp  err_                               ; 
_l0341:                                         ; 
call_168:                                       ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rps:                                          ; 
        mov  wb,p_rps                           ; set pcode for integer arg case} mov wb =p_rps 
        mov  wa,p_rpd                           ; set pcode for expression arg case} mov wa =p_rpd 
        call patin                              ; call common routine to build node} jsr patin  
        dec  m_word [_rc_]                      ; 
        js   call_169                           ; 
        dec  m_word [_rc_]                      ; } err 185 rpos argument is not integer or expression 
        jns  _l0342                             ; 
        mov  m_word [_rc_],185                  ; 
        jmp  err_                               ; 
_l0342:                                         ; 
        dec  m_word [_rc_]                      ; } err 186 rpos argument is negative or too large 
        jns  _l0343                             ; 
        mov  m_word [_rc_],186                  ; 
        jmp  err_                               ; 
_l0343:                                         ; 
call_169:                                       ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_rsr:                                          ; 
        mov  wa,xs                              ; mark as rsort} mnz wa  
        call sorta                              ; call sort routine} jsr sorta  
        dec  m_word [_rc_]                      ; 
        js   call_170                           ; 
        dec  m_word [_rc_]                      ; if conversion fails, so shall we} ppm exfal  
        jns  _l0344                             ; 
        jmp  exfal                              ; 
_l0344:                                         ; 
call_170:                                       ; 
        jmp  exsid                              ; return, setting idval} brn exsid  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_stx:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        mov  wa,m_word [stxvr]                  ; load old vrblk pointer} mov wa stxvr 
        xor  xl,xl                              ; load zero in case null arg} zer xl  
        cmp  xr,nulls                           ; jump if null argument (reset call)} beq xr =nulls sstx1
        je   sstx1                              ; 
        call gtnvr                              ; else get specified vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_171                           ; 
        dec  m_word [_rc_]                      ; jump if not natural variable} ppm sstx2  
        jns  _l0345                             ; 
        jmp  sstx2                              ; 
_l0345:                                         ; 
call_171:                                       ; 
        mov  xl,m_word [(cfp_b*vrlbl)+xr]       ; else load label} mov xl vrlbl(xr) 
        cmp  xl,stndl                           ; jump if label is not defined} beq xl =stndl sstx2
        je   sstx2                              ; 
        cmp  m_word [xl],b_trt                  ; jump if not trapped} bne (xl) =b_trt sstx1
        jne  sstx1                              ; 
        mov  xl,m_word [(cfp_b*trlbl)+xl]       ; else load ptr to real label code} mov xl trlbl(xl) 
sstx1:
        mov  m_word [stxvr],xr                  ; store new vrblk pointer (or null)} mov stxvr xr 
        mov  m_word [r_sxc],xl                  ; store new code ptr (or zero)} mov r_sxc xl 
        cmp  wa,nulls                           ; return null if null result} beq wa =nulls exnul
        je   exnul                              ; 
        mov  xr,wa                              ; else copy vrblk pointer} mov xr wa 
        jmp  exvnm                              ; and return building nmblk} brn exvnm  
sstx2:
        mov  m_word [_rc_],187                  ; } erb 187 setexit argument is not label name or null 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_sin:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_172                           ; 
        dec  m_word [_rc_]                      ; } err 308 sin argument not numeric 
        jns  _l0346                             ; 
        mov  m_word [_rc_],308                  ; 
        jmp  err_                               ; 
_l0346:                                         ; 
call_172:                                       ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        call sin_                               ; take sine} sin   
        call do_chk_real_inf                    ; if no overflow, return result in ra} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],323                  ; } erb 323 sin argument is out of range 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_sqr:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_173                           ; 
        dec  m_word [_rc_]                      ; } err 313 sqrt argument not numeric 
        jns  _l0347                             ; 
        mov  m_word [_rc_],313                  ; 
        jmp  err_                               ; 
_l0347:                                         ; 
call_173:                                       ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        pxor xmm0,xmm0                          ; negative number} rlt ssqr1  
        ucomisd ra,xmm0                         ; 
        jb   ssqr1                              ; 
        call sqr_                               ; take square root} sqr   
        jmp  exrea                              ; no overflow possible, result in ra} brn exrea  
ssqr1:
        mov  m_word [_rc_],314                  ; } erb 314 sqrt argument negative 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_srt:                                          ; 
        xor  wa,wa                              ; mark as sort} zer wa  
        call sorta                              ; call sort routine} jsr sorta  
        dec  m_word [_rc_]                      ; 
        js   call_174                           ; 
        dec  m_word [_rc_]                      ; if conversion fails, so shall we} ppm exfal  
        jns  _l0348                             ; 
        jmp  exfal                              ; 
_l0348:                                         ; 
call_174:                                       ; 
        jmp  exsid                              ; return, setting idval} brn exsid  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_spn:                                          ; 
        mov  wb,p_sps                           ; set pcode for single char arg} mov wb =p_sps 
        mov  xl,p_spn                           ; set pcode for multi-char arg} mov xl =p_spn 
        mov  wc,p_spd                           ; set pcode for expression arg} mov wc =p_spd 
        call patst                              ; call common routine to build node} jsr patst  
        dec  m_word [_rc_]                      ; 
        js   call_175                           ; 
        dec  m_word [_rc_]                      ; } err 188 span argument is not a string or expression 
        jns  _l0349                             ; 
        mov  m_word [_rc_],188                  ; 
        jmp  err_                               ; 
_l0349:                                         ; 
call_175:                                       ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_si_:                                          ; 
        call gtstg                              ; load string argument} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_176                           ; 
        dec  m_word [_rc_]                      ; } err 189 size argument is not a string 
        jns  _l0350                             ; 
        mov  m_word [_rc_],189                  ; 
        jmp  err_                               ; 
_l0350:                                         ; 
call_176:                                       ; 
        mov  ia,wa                              ; load length as integer} mti wa  
        jmp  exint                              ; exit with integer result} brn exint  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_stt:                                          ; 
        xor  xl,xl                              ; indicate stoptr case} zer xl  
        call trace                              ; call trace procedure} jsr trace  
        dec  m_word [_rc_]                      ; 
        js   call_177                           ; 
        dec  m_word [_rc_]                      ; } err 190 stoptr first argument is not appropriate name 
        jns  _l0351                             ; 
        mov  m_word [_rc_],190                  ; 
        jmp  err_                               ; 
_l0351:                                         ; 
        dec  m_word [_rc_]                      ; } err 191 stoptr second argument is not trace type 
        jns  _l0352                             ; 
        mov  m_word [_rc_],191                  ; 
        jmp  err_                               ; 
_l0352:                                         ; 
call_177:                                       ; 
        jmp  exnul                              ; return null} brn exnul  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_sub:                                          ; 
        call gtsmi                              ; load third argument} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_178                           ; 
        dec  m_word [_rc_]                      ; } err 192 substr third argument is not integer 
        jns  _l0353                             ; 
        mov  m_word [_rc_],192                  ; 
        jmp  err_                               ; 
_l0353:                                         ; 
        dec  m_word [_rc_]                      ; jump if negative or too large} ppm exfal  
        jns  _l0354                             ; 
        jmp  exfal                              ; 
_l0354:                                         ; 
call_178:                                       ; 
        mov  m_word [sbssv],xr                  ; save third argument} mov sbssv xr 
        call gtsmi                              ; load second argument} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_179                           ; 
        dec  m_word [_rc_]                      ; } err 193 substr second argument is not integer 
        jns  _l0355                             ; 
        mov  m_word [_rc_],193                  ; 
        jmp  err_                               ; 
_l0355:                                         ; 
        dec  m_word [_rc_]                      ; jump if out of range} ppm exfal  
        jns  _l0356                             ; 
        jmp  exfal                              ; 
_l0356:                                         ; 
call_179:                                       ; 
        mov  wc,xr                              ; save second argument} mov wc xr 
        test wc,wc                              ; jump if second argument zero} bze wc exfal 
        jz   exfal                              ; 
        dec  wc                                 ; else decrement for ones origin} dcv wc  
        call gtstg                              ; load first argument} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_180                           ; 
        dec  m_word [_rc_]                      ; } err 194 substr first argument is not a string 
        jns  _l0357                             ; 
        mov  m_word [_rc_],194                  ; 
        jmp  err_                               ; 
_l0357:                                         ; 
call_180:                                       ; 
        mov  wb,wc                              ; copy second arg to wb} mov wb wc 
        mov  wc,m_word [sbssv]                  ; reload third argument} mov wc sbssv 
        test wc,wc                              ; skip if third arg given} bnz wc ssub2 
        jnz  ssub2                              ; 
        mov  wc,wa                              ; else get string length} mov wc wa 
        cmp  wb,wc                              ; fail if improper} bgt wb wc exfal
        ja   exfal                              ; 
        sub  wc,wb                              ; reduce by offset to start} sub wc wb 
ssub2:
        mov  xl,wa                              ; save string length} mov xl wa 
        mov  wa,wc                              ; set length of substring} mov wa wc 
        add  wc,wb                              ; add 2nd arg to 3rd arg} add wc wb 
        cmp  wc,xl                              ; jump if improper substring} bgt wc xl exfal
        ja   exfal                              ; 
        mov  xl,xr                              ; copy pointer to first arg} mov xl xr 
        call sbstr                              ; build substring} jsr sbstr  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_tbl:                                          ; 
        pop  xl                                 ; get initial lookup value} mov xl (xs)+ 
        add  xs,cfp_b                           ; pop second argument} ica xs  
        call gtsmi                              ; load argument} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_181                           ; 
        dec  m_word [_rc_]                      ; } err 195 table argument is not integer 
        jns  _l0358                             ; 
        mov  m_word [_rc_],195                  ; 
        jmp  err_                               ; 
_l0358:                                         ; 
        dec  m_word [_rc_]                      ; } err 196 table argument is out of range 
        jns  _l0359                             ; 
        mov  m_word [_rc_],196                  ; 
        jmp  err_                               ; 
_l0359:                                         ; 
call_181:                                       ; 
        test wc,wc                              ; jump if non-zero} bnz wc stbl1 
        jnz  stbl1                              ; 
        mov  wc,tbnbk                           ; else supply default value} mov wc =tbnbk 
stbl1:
        call tmake                              ; make table} jsr tmake  
        jmp  exsid                              ; exit setting idval} brn exsid  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_tan:                                          ; 
        pop  xr                                 ; get argument} mov xr (xs)+ 
        call gtrea                              ; convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_182                           ; 
        dec  m_word [_rc_]                      ; } err 309 tan argument not numeric 
        jns  _l0360                             ; 
        mov  m_word [_rc_],309                  ; 
        jmp  err_                               ; 
_l0360:                                         ; 
call_182:                                       ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load accumulator with argument} ldr rcval(xr)  
        call tan_                               ; take tangent} tan   
        call do_chk_real_inf                    ; if no overflow, return result in ra} rno exrea  
        jz   exrea                              ; 
        mov  m_word [_rc_],310                  ; } erb 310 tan produced real overflow or argument is out of range 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_tim:                                          ; 
        call systm                              ; get timer value} jsr systm  
        sub  ia,m_word [timsx]                  ; subtract starting time} sbi timsx  
        jmp  exint                              ; exit with integer value} brn exint  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_tra:                                          ; 
        cmp  m_word [(cfp_b*num03)+xs],nulls    ; jump if first argument is null} beq num03(xs) =nulls str02
        je   str02                              ; 
        pop  xr                                 ; load fourth argument} mov xr (xs)+ 
        xor  xl,xl                              ; tentatively set zero pointer} zer xl  
        cmp  xr,nulls                           ; jump if 4th argument is null} beq xr =nulls str01
        je   str01                              ; 
        call gtnvr                              ; else point to vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_183                           ; 
        dec  m_word [_rc_]                      ; jump if not variable name} ppm str03  
        jns  _l0361                             ; 
        jmp  str03                              ; 
_l0361:                                         ; 
call_183:                                       ; 
        mov  xl,xr                              ; else save vrblk in trfnc} mov xl xr 
str01:
        pop  xr                                 ; load third argument (tag)} mov xr (xs)+ 
        xor  wb,wb                              ; set zero as trtyp value for now} zer wb  
        call trbld                              ; build trblk for trace call} jsr trbld  
        mov  xl,xr                              ; move trblk pointer for trace} mov xl xr 
        call trace                              ; call trace procedure} jsr trace  
        dec  m_word [_rc_]                      ; 
        js   call_184                           ; 
        dec  m_word [_rc_]                      ; } err 198 trace first argument is not appropriate name 
        jns  _l0362                             ; 
        mov  m_word [_rc_],198                  ; 
        jmp  err_                               ; 
_l0362:                                         ; 
        dec  m_word [_rc_]                      ; } err 199 trace second argument is not trace type 
        jns  _l0363                             ; 
        mov  m_word [_rc_],199                  ; 
        jmp  err_                               ; 
_l0363:                                         ; 
call_184:                                       ; 
        jmp  exnul                              ; return null} brn exnul  
str02:
        call systt                              ; call it} jsr systt  
        add  xs,cfp_b*num04                     ; pop trace arguments} add xs *num04 
        jmp  exnul                              ; return} brn exnul  
str03:
        mov  m_word [_rc_],197                  ; } erb 197 trace fourth arg is not function name or null 
        jmp  err_                               ; 
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_trm:                                          ; 
        call gtstg                              ; load argument as string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_185                           ; 
        dec  m_word [_rc_]                      ; } err 200 trim argument is not a string 
        jns  _l0364                             ; 
        mov  m_word [_rc_],200                  ; 
        jmp  err_                               ; 
_l0364:                                         ; 
call_185:                                       ; 
        test wa,wa                              ; return null if argument is null} bze wa exnul 
        jz   exnul                              ; 
        mov  xl,xr                              ; copy string pointer} mov xl xr 
        add  wa,(cfp_b-1)+cfp_b*schar           ; get block length} ctb wa schar 
        and  wa,-cfp_b                          ; 
        call alloc                              ; allocate copy same size} jsr alloc  
        mov  wb,xr                              ; save pointer to copy} mov wb xr 
        shr  wa,log_cfp_b                       ; copy old string block to new} mvw   
        rep  movs_w                             ; 
        mov  xr,wb                              ; restore ptr to new block} mov xr wb 
        call trimr                              ; trim blanks (wb is non-zero)} jsr trimr  
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
        align 2                                 ; entry point} ent   
        nop                                     ; 
s_unl:                                          ; 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        call gtnvr                              ; point to vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_186                           ; 
        dec  m_word [_rc_]                      ; } err 201 unload argument is not natural variable name 
        jns  _l0365                             ; 
        mov  m_word [_rc_],201                  ; 
        jmp  err_                               ; 
_l0365:                                         ; 
call_186:                                       ; 
        mov  xl,stndf                           ; get ptr to undefined function} mov xl =stndf 
        call dffnc                              ; undefine named function} jsr dffnc  
        jmp  exnul                              ; return null as result} brn exnul  
arref:
                                                ; } rtn   
        mov  wa,xr                              ; copy number of subscripts} mov wa xr 
        mov  xl,xs                              ; point to stack front} mov xt xs 
        sal  xr,log_cfp_b                       ; convert to byte offset} wtb xr  
        add  xl,xr                              ; point to array operand on stack} add xt xr 
        add  xl,cfp_b                           ; final value for stack popping} ica xt  
        mov  m_word [arfxs],xl                  ; keep for later} mov arfxs xt 
        lea  xl,[xl-cfp_b]                      ; load array operand pointer} mov xr -(xt) 
        mov  xr,m_word [xl]                     ; 
        mov  m_word [r_arf],xr                  ; keep array pointer} mov r_arf xr 
        mov  xr,xl                              ; save pointer to subscripts} mov xr xt 
        mov  xl,m_word [r_arf]                  ; point xl to possible vcblk or tbblk} mov xl r_arf 
        mov  wc,m_word [xl]                     ; load first word} mov wc (xl) 
        cmp  wc,b_art                           ; jump if arblk} beq wc =b_art arf01
        je   arf01                              ; 
        cmp  wc,b_vct                           ; jump if vcblk} beq wc =b_vct arf07
        je   arf07                              ; 
        cmp  wc,b_tbt                           ; jump if tbblk} beq wc =b_tbt arf10
        je   arf10                              ; 
        mov  m_word [_rc_],235                  ; } erb 235 subscripted operand is not table or array 
        jmp  err_                               ; 
arf01:
        cmp  wa,m_word [(cfp_b*arndm)+xl]       ; jump if wrong number of dims} bne wa arndm(xl) arf09
        jne  arf09                              ; 
        mov  ia,m_word [intv0]                  ; get initial subscript of zero} ldi intv0  
        mov  xl,xr                              ; point before subscripts} mov xt xr 
        xor  wa,wa                              ; initial offset to bounds} zer wa  
        jmp  arf03                              ; jump into loop} brn arf03  
arf02:
        imul ia,m_word [(cfp_b*ardm2)+xr]       ; multiply total by next dimension} mli ardm2(xr)  
arf03:
        lea  xl,[xl-cfp_b]                      ; load next subscript} mov xr -(xt) 
        mov  xr,m_word [xl]                     ; 
        mov  m_word [arfsi],ia                  ; save current subscript} sti arfsi  
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer value in case} ldi icval(xr)  
        cmp  m_word [xr],b_icl                  ; jump if it was an integer} beq (xr) =b_icl arf04
        je   arf04                              ; 
        call gtint                              ; convert to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_187                           ; 
        dec  m_word [_rc_]                      ; jump if not integer} ppm arf12  
        jns  _l0366                             ; 
        jmp  arf12                              ; 
_l0366:                                         ; 
call_187:                                       ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; if ok, load integer value} ldi icval(xr)  
arf04:
        mov  xr,m_word [r_arf]                  ; point to array} mov xr r_arf 
        add  xr,wa                              ; offset to next bounds} add xr wa 
        sub  ia,m_word [(cfp_b*arlbd)+xr]       ; subtract low bound to compare} sbi arlbd(xr)  
        jo   arf13                              ; out of range fail if overflow} iov arf13  
        cmp  ia,0                               ; out of range fail if too small} ilt arf13  
        jl   arf13                              ; 
        sub  ia,m_word [(cfp_b*ardim)+xr]       ; subtract dimension} sbi ardim(xr)  
        cmp  ia,0                               ; out of range fail if too large} ige arf13  
        jge  arf13                              ; 
        add  ia,m_word [(cfp_b*ardim)+xr]       ; else restore subscript offset} adi ardim(xr)  
        add  ia,m_word [arfsi]                  ; add to current total} adi arfsi  
        add  wa,cfp_b*ardms                     ; point to next bounds} add wa *ardms 
        cmp  xl,xs                              ; loop back if more to go} bne xt xs arf02
        jne  arf02                              ; 
        mov  wa,ia                              ; get as one word integer} mfi wa  
        sal  wa,log_cfp_b                       ; convert to offset} wtb wa  
        mov  xl,m_word [r_arf]                  ; point to arblk} mov xl r_arf 
        add  wa,m_word [(cfp_b*arofs)+xl]       ; add offset past bounds} add wa arofs(xl) 
        add  wa,cfp_b                           ; adjust for arpro field} ica wa  
        test wb,wb                              ; exit with name if name call} bnz wb arf08 
        jnz  arf08                              ; 
arf05:
        call acess                              ; get value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_188                           ; 
        dec  m_word [_rc_]                      ; fail if acess fails} ppm arf13  
        jns  _l0367                             ; 
        jmp  arf13                              ; 
_l0367:                                         ; 
call_188:                                       ; 
arf06:
        mov  xs,m_word [arfxs]                  ; pop stack entries} mov xs arfxs 
        xor  w0,w0                              ; finished with array pointer} zer r_arf  
        mov  m_word [r_arf],w0                  ; 
        push xr                                 ; stack result} mov -(xs) xr 
        mov  r10,m_word [r13]                   ; get next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
arf07:
        cmp  wa,num01                           ; error if more than 1 subscript} bne wa =num01 arf09
        jne  arf09                              ; 
        mov  xr,m_word [xs]                     ; else load subscript} mov xr (xs) 
        call gtint                              ; convert to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_189                           ; 
        dec  m_word [_rc_]                      ; error if not integer} ppm arf12  
        jns  _l0368                             ; 
        jmp  arf12                              ; 
_l0368:                                         ; 
call_189:                                       ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; else load integer value} ldi icval(xr)  
        sub  ia,m_word [intv1]                  ; subtract for ones offset} sbi intv1  
        test ia,ia                              ; get subscript as one word} mfi wa arf13 
        js   arf13                              ; 
        mov  wa,ia                              ; 
        add  wa,vcvls                           ; add offset for standard fields} add wa =vcvls 
        sal  wa,log_cfp_b                       ; convert offset to bytes} wtb wa  
        cmp  wa,m_word [(cfp_b*vclen)+xl]       ; fail if out of range subscript} bge wa vclen(xl) arf13
        jae  arf13                              ; 
        test wb,wb                              ; back to get value if value call} bze wb arf05 
        jz   arf05                              ; 
arf08:
        mov  xs,m_word [arfxs]                  ; pop stack entries} mov xs arfxs 
        xor  w0,w0                              ; finished with array pointer} zer r_arf  
        mov  m_word [r_arf],w0                  ; 
        jmp  exnam                              ; else exit with name} brn exnam  
arf09:
        mov  m_word [_rc_],236                  ; } erb 236 array referenced with wrong number of subscripts 
        jmp  err_                               ; 
arf10:
        cmp  wa,num01                           ; error if more than 1 subscript} bne wa =num01 arf11
        jne  arf11                              ; 
        mov  xr,m_word [xs]                     ; else load subscript} mov xr (xs) 
        call tfind                              ; call table search routine} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_190                           ; 
        dec  m_word [_rc_]                      ; fail if failed} ppm arf13  
        jns  _l0369                             ; 
        jmp  arf13                              ; 
_l0369:                                         ; 
call_190:                                       ; 
        test wb,wb                              ; exit with name if name call} bnz wb arf08 
        jnz  arf08                              ; 
        jmp  arf06                              ; else exit with value} brn arf06  
arf11:
        mov  m_word [_rc_],237                  ; } erb 237 table referenced with more than one subscript 
        jmp  err_                               ; 
arf12:
        mov  m_word [_rc_],238                  ; } erb 238 array subscript is not integer 
        jmp  err_                               ; 
arf13:
        xor  w0,w0                              ; finished with array pointer} zer r_arf  
        mov  m_word [r_arf],w0                  ; 
        jmp  exfal                              ; fail} brn exfal  
cfunc:
                                                ; } rtn   
        cmp  wa,m_word [(cfp_b*fargs)+xl]       ; jump if too few arguments} blt wa fargs(xl) cfnc1
        jb   cfnc1                              ; 
        cmp  wa,m_word [(cfp_b*fargs)+xl]       ; jump if correct number of args} beq wa fargs(xl) cfnc3
        je   cfnc3                              ; 
        mov  wb,wa                              ; copy actual number} mov wb wa 
        sub  wb,m_word [(cfp_b*fargs)+xl]       ; get number of extra args} sub wb fargs(xl) 
        sal  wb,log_cfp_b                       ; convert to bytes} wtb wb  
        add  xs,wb                              ; pop off unwanted arguments} add xs wb 
        jmp  cfnc3                              ; jump to go off to function} brn cfnc3  
cfnc1:
        mov  wb,m_word [(cfp_b*fargs)+xl]       ; load required number of arguments} mov wb fargs(xl) 
        cmp  wb,nini9                           ; jump if case of var num of args} beq wb =nini9 cfnc3
        je   cfnc3                              ; 
        sub  wb,wa                              ; calculate number missing} sub wb wa 
cfnc2:
        push nulls                              ; stack a null argument} mov -(xs) =nulls 
        dec  wb                                 ; loop till proper number stacked} bct wb cfnc2 
        jnz  cfnc2                              ; 
cfnc3:
        jmp  m_word [xl]                        ; jump through fcode field} bri (xl)  
exfal:
                                                ; } rtn   
        mov  xs,m_word [flptr]                  ; pop stack} mov xs flptr 
        mov  xr,m_word [xs]                     ; load failure offset} mov xr (xs) 
        add  xr,m_word [r_cod]                  ; point to failure code location} add xr r_cod 
        mov  r13,xr                             ; set code pointer} lcp xr  
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  xl,m_word [xr]                     ; load entry address} mov xl (xr) 
        jmp  xl                                 ; jump to execute next code word} bri xl  
exint:
                                                ; } rtn   
        xor  xl,xl                              ; clear dud value} zer xl  
        call icbld                              ; build icblk} jsr icbld  
exixr:
                                                ; } rtn   
        push xr                                 ; stack result} mov -(xs) xr 
exits:
                                                ; } rtn   
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  xl,m_word [xr]                     ; load entry address} mov xl (xr) 
        jmp  xl                                 ; jump to execute next code word} bri xl  
exnam:
                                                ; } rtn   
        push xl                                 ; stack name base} mov -(xs) xl 
        push wa                                 ; stack name offset} mov -(xs) wa 
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
exnul:
                                                ; } rtn   
        push nulls                              ; stack null value} mov -(xs) =nulls 
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  xl,m_word [xr]                     ; load entry address} mov xl (xr) 
        jmp  xl                                 ; jump to execute next code word} bri xl  
exrea:
                                                ; } rtn   
        xor  xl,xl                              ; clear dud value} zer xl  
        call rcbld                              ; build rcblk} jsr rcbld  
        jmp  exixr                              ; jump to exit with result in xr} brn exixr  
exsid:
                                                ; } rtn   
        mov  wa,m_word [curid]                  ; load current id value} mov wa curid 
        cmp  wa,m_word [mxint]                  ; jump if no overflow} bne wa mxint exsi1
        jne  exsi1                              ; 
        xor  wa,wa                              ; else reset for wraparound} zer wa  
exsi1:
        inc  wa                                 ; bump id value} icv wa  
        mov  m_word [curid],wa                  ; store for next time} mov curid wa 
        mov  m_word [(cfp_b*idval)+xr],wa       ; store id value} mov idval(xr) wa 
        jmp  exixr                              ; exit with result in (xr)} brn exixr  
exvnm:
                                                ; } rtn   
        mov  xl,xr                              ; copy name base pointer} mov xl xr 
        mov  wa,cfp_b*nmsi_                     ; set size of nmblk} mov wa *nmsi_ 
        call alloc                              ; allocate nmblk} jsr alloc  
        mov  m_word [xr],b_nml                  ; store type word} mov (xr) =b_nml 
        mov  m_word [(cfp_b*nmbas)+xr],xl       ; store name base} mov nmbas(xr) xl 
        mov  m_word [(cfp_b*nmofs)+xr],cfp_b*vrval      ; store name offset} mov nmofs(xr) *vrval 
        jmp  exixr                              ; exit with result in xr} brn exixr  
flpop:
                                                ; } rtn   
        add  xs,cfp_b*num02                     ; pop two entries off stack} add xs *num02 
failp:
                                                ; } rtn   
        pop  xr                                 ; load alternative node pointer} mov xr (xs)+ 
        pop  wb                                 ; restore old cursor} mov wb (xs)+ 
        mov  xl,m_word [xr]                     ; load pcode entry pointer} mov xl (xr) 
        jmp  xl                                 ; jump to execute code for node} bri xl  
indir:
                                                ; } rtn   
        pop  xr                                 ; load argument} mov xr (xs)+ 
        cmp  m_word [xr],b_nml                  ; jump if a name} beq (xr) =b_nml indr2
        je   indr2                              ; 
        call gtnvr                              ; else convert to variable} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_191                           ; 
        dec  m_word [_rc_]                      ; } err 239 indirection operand is not name 
        jns  _l0370                             ; 
        mov  m_word [_rc_],239                  ; 
        jmp  err_                               ; 
_l0370:                                         ; 
call_191:                                       ; 
        test wb,wb                              ; skip if by value} bze wb indr1 
        jz   indr1                              ; 
        push xr                                 ; else stack vrblk ptr} mov -(xs) xr 
        push cfp_b*vrval                        ; stack name offset} mov -(xs) *vrval 
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  xl,m_word [xr]                     ; load entry address} mov xl (xr) 
        jmp  xl                                 ; jump to execute next code word} bri xl  
indr1:
        jmp  m_word [xr]                        ; jump through vrget field of vrblk} bri (xr)  
indr2:
        mov  xl,m_word [(cfp_b*nmbas)+xr]       ; load name base} mov xl nmbas(xr) 
        mov  wa,m_word [(cfp_b*nmofs)+xr]       ; load name offset} mov wa nmofs(xr) 
        test wb,wb                              ; exit if called by name} bnz wb exnam 
        jnz  exnam                              ; 
        call acess                              ; else get value first} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_192                           ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0371                             ; 
        jmp  exfal                              ; 
_l0371:                                         ; 
call_192:                                       ; 
        jmp  exixr                              ; else return with value in xr} brn exixr  
match:
                                                ; } rtn   
        pop  xr                                 ; load pattern operand} mov xr (xs)+ 
        call gtpat                              ; convert to pattern} jsr gtpat  
        dec  m_word [_rc_]                      ; 
        js   call_193                           ; 
        dec  m_word [_rc_]                      ; } err 240 pattern match right operand is not pattern 
        jns  _l0372                             ; 
        mov  m_word [_rc_],240                  ; 
        jmp  err_                               ; 
_l0372:                                         ; 
call_193:                                       ; 
        mov  xl,xr                              ; if ok, save pattern pointer} mov xl xr 
        test wb,wb                              ; jump if not match by name} bnz wb mtch1 
        jnz  mtch1                              ; 
        mov  wa,m_word [xs]                     ; else load name offset} mov wa (xs) 
        push xl                                 ; save pattern pointer} mov -(xs) xl 
        mov  xl,m_word [(cfp_b*num02)+xs]       ; load name base} mov xl num02(xs) 
        call acess                              ; access subject value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_194                           ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0373                             ; 
        jmp  exfal                              ; 
_l0373:                                         ; 
call_194:                                       ; 
        mov  xl,m_word [xs]                     ; restore pattern pointer} mov xl (xs) 
        mov  m_word [xs],xr                     ; stack subject string val for merge} mov (xs) xr 
        xor  wb,wb                              ; restore type code} zer wb  
mtch1:
        call gtstg                              ; convert subject to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_195                           ; 
        dec  m_word [_rc_]                      ; } err 241 pattern match left operand is not a string 
        jns  _l0374                             ; 
        mov  m_word [_rc_],241                  ; 
        jmp  err_                               ; 
_l0374:                                         ; 
call_195:                                       ; 
        push wb                                 ; stack match type code} mov -(xs) wb 
        mov  m_word [r_pms],xr                  ; if ok, store subject string pointer} mov r_pms xr 
        mov  m_word [pmssl],wa                  ; and length} mov pmssl wa 
        push 0                                  ; stack initial cursor (zero)} zer -(xs)  
        xor  wb,wb                              ; set initial cursor} zer wb  
        mov  m_word [pmhbs],xs                  ; set history stack base ptr} mov pmhbs xs 
        xor  w0,w0                              ; reset pattern assignment flag} zer pmdfl  
        mov  m_word [pmdfl],w0                  ; 
        mov  xr,xl                              ; set initial node pointer} mov xr xl 
        cmp  m_word [kvanc],0                   ; jump if anchored} bnz kvanc mtch2 
        jnz  mtch2                              ; 
        push xr                                 ; stack initial node pointer} mov -(xs) xr 
        push nduna                              ; stack pointer to anchor move node} mov -(xs) =nduna 
        jmp  m_word [xr]                        ; start match of first node} bri (xr)  
mtch2:
        push 0                                  ; dummy cursor value} zer -(xs)  
        push ndabo                              ; stack pointer to abort node} mov -(xs) =ndabo 
        jmp  m_word [xr]                        ; start match of first node} bri (xr)  
retrn:
                                                ; } rtn   
        cmp  m_word [kvfnc],0                   ; jump if not level zero} bnz kvfnc rtn01 
        jnz  rtn01                              ; 
        mov  m_word [_rc_],242                  ; } erb 242 function return from level zero 
        jmp  err_                               ; 
rtn01:
        mov  xs,m_word [flprt]                  ; pop stack} mov xs flprt 
        add  xs,cfp_b                           ; remove failure offset} ica xs  
        pop  xr                                 ; pop pfblk pointer} mov xr (xs)+ 
        pop  m_word [flptr]                     ; pop failure pointer} mov flptr (xs)+ 
        pop  m_word [flprt]                     ; pop old flprt} mov flprt (xs)+ 
        pop  wb                                 ; pop code pointer offset} mov wb (xs)+ 
        pop  wc                                 ; pop old code block pointer} mov wc (xs)+ 
        add  wb,wc                              ; make old code pointer absolute} add wb wc 
        mov  r13,wb                             ; restore old code pointer} lcp wb  
        mov  m_word [r_cod],wc                  ; restore old code block pointer} mov r_cod wc 
        dec  m_word [kvfnc]                     ; decrement function level} dcv kvfnc  
        mov  wb,m_word [kvtra]                  ; load trace} mov wb kvtra 
        add  wb,m_word [kvftr]                  ; add ftrace} add wb kvftr 
        test wb,wb                              ; jump if no tracing possible} bze wb rtn06 
        jz   rtn06                              ; 
        push wa                                 ; save function return type} mov -(xs) wa 
        push xr                                 ; save pfblk pointer} mov -(xs) xr 
        mov  m_word [kvrtn],wa                  ; set rtntype for trace function} mov kvrtn wa 
        mov  xl,m_word [r_fnc]                  ; load fnclevel trblk ptr (if any)} mov xl r_fnc 
        call ktrex                              ; execute possible fnclevel trace} jsr ktrex  
        mov  xl,m_word [(cfp_b*pfvbl)+xr]       ; load vrblk ptr (sgd13)} mov xl pfvbl(xr) 
        cmp  m_word [kvtra],0                   ; jump if trace is off} bze kvtra rtn02 
        jz   rtn02                              ; 
        mov  xr,m_word [(cfp_b*pfrtr)+xr]       ; else load return trace trblk ptr} mov xr pfrtr(xr) 
        test xr,xr                              ; jump if not return traced} bze xr rtn02 
        jz   rtn02                              ; 
        dec  m_word [kvtra]                     ; else decrement trace count} dcv kvtra  
        cmp  m_word [(cfp_b*trfnc)+xr],0        ; jump if print trace} bze trfnc(xr) rtn03 
        jz   rtn03                              ; 
        mov  wa,cfp_b*vrval                     ; else set name offset} mov wa *vrval 
        mov  w0,m_word [(cfp_b*num01)+xs]       ; make sure rtntype is set right} mov kvrtn num01(xs) 
        mov  m_word [kvrtn],w0                  ; 
        call trxeq                              ; execute full trace} jsr trxeq  
rtn02:
        cmp  m_word [kvftr],0                   ; jump if ftrace is off} bze kvftr rtn05 
        jz   rtn05                              ; 
        dec  m_word [kvftr]                     ; else decrement ftrace} dcv kvftr  
rtn03:
        call prtsn                              ; print statement number} jsr prtsn  
        mov  xr,m_word [(cfp_b*num01)+xs]       ; load return type} mov xr num01(xs) 
        call prtst                              ; print it} jsr prtst  
        mov  wa,ch_bl                           ; load blank} mov wa =ch_bl 
        call prtch                              ; print it} jsr prtch  
        mov  xl,m_word [(cfp_b*0)+xs]           ; load pfblk ptr} mov xl 0(xs) 
        mov  xl,m_word [(cfp_b*pfvbl)+xl]       ; load function vrblk ptr} mov xl pfvbl(xl) 
        mov  wa,cfp_b*vrval                     ; set vrblk name offset} mov wa *vrval 
        cmp  xr,scfrt                           ; jump if not freturn case} bne xr =scfrt rtn04
        jne  rtn04                              ; 
        call prtnm                              ; print name} jsr prtnm  
        call prtnl                              ; terminate print line} jsr prtnl  
        jmp  rtn05                              ; merge} brn rtn05  
rtn04:
        call prtnv                              ; print name = value} jsr prtnv  
rtn05:
        pop  xr                                 ; pop pfblk pointer} mov xr (xs)+ 
        pop  wa                                 ; pop return type string} mov wa (xs)+ 
rtn06:
        mov  m_word [kvrtn],wa                  ; set rtntype keyword} mov kvrtn wa 
        mov  xl,m_word [(cfp_b*pfvbl)+xr]       ; load pointer to fn vrblk} mov xl pfvbl(xr) 
rtn07:
        mov  m_word [rtnbp],xl                  ; save block pointer} mov rtnbp xl 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load value} mov xl vrval(xl) 
        cmp  m_word [xl],b_trt                  ; loop back if trapped} beq (xl) =b_trt rtn07
        je   rtn07                              ; 
        mov  m_word [rtnfv],xl                  ; else save function result value} mov rtnfv xl 
        pop  m_word [rtnsv]                     ; save original function value} mov rtnsv (xs)+ 
        pop  xl                                 ; pop saved pointer} mov xl (xs)+ 
        test xl,xl                              ; no action if none} bze xl rtn7c 
        jz   rtn7c                              ; 
        cmp  m_word [kvpfl],0                   ; jump if no profiling} bze kvpfl rtn7c 
        jz   rtn7c                              ; 
        call prflu                              ; else profile last func stmt} jsr prflu  
        cmp  m_word [kvpfl],num02               ; branch on value of profile keywd} beq kvpfl =num02 rtn7a
        je   rtn7a                              ; 
        mov  ia,m_word [pfstm]                  ; load current time} ldi pfstm  
        sub  ia,m_word [(cfp_b*icval)+xl]       ; frig by subtracting saved amount} sbi icval(xl)  
        jmp  rtn7b                              ; and merge} brn rtn7b  
rtn7a:
        mov  ia,m_word [(cfp_b*icval)+xl]       ; load saved time} ldi icval(xl)  
rtn7b:
        mov  m_word [pfstm],ia                  ; store back correct start time} sti pfstm  
rtn7c:
        mov  wb,m_word [(cfp_b*fargs)+xr]       ; get number of args} mov wb fargs(xr) 
        add  wb,m_word [(cfp_b*pfnlo)+xr]       ; add number of locals} add wb pfnlo(xr) 
        test wb,wb                              ; jump if no args/locals} bze wb rtn10 
        jz   rtn10                              ; 
        add  xr,m_word [(cfp_b*pflen)+xr]       ; and point to end of pfblk} add xr pflen(xr) 
rtn08:
        lea  xr,[xr-cfp_b]                      ; load next vrblk pointer} mov xl -(xr) 
        mov  xl,m_word [xr]                     ; 
rtn09:
        mov  wa,xl                              ; save block pointer} mov wa xl 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load pointer to next value} mov xl vrval(xl) 
        cmp  m_word [xl],b_trt                  ; loop back if trapped} beq (xl) =b_trt rtn09
        je   rtn09                              ; 
        mov  xl,wa                              ; else restore last block pointer} mov xl wa 
        pop  m_word [(cfp_b*vrval)+xl]          ; restore old variable value} mov vrval(xl) (xs)+ 
        dec  wb                                 ; loop till all processed} bct wb rtn08 
        jnz  rtn08                              ; 
rtn10:
        mov  xl,m_word [rtnbp]                  ; restore ptr to last function block} mov xl rtnbp 
        mov  w0,m_word [rtnsv]                  ; restore old function value} mov vrval(xl) rtnsv 
        mov  m_word [(cfp_b*vrval)+xl],w0       ; 
        mov  xr,m_word [rtnfv]                  ; reload function result} mov xr rtnfv 
        mov  xl,m_word [r_cod]                  ; point to new code block} mov xl r_cod 
        mov  w0,m_word [kvstn]                  ; set lastno from stno} mov kvlst kvstn 
        mov  m_word [kvlst],w0                  ; 
        mov  w0,m_word [(cfp_b*cdstm)+xl]       ; reset proper stno value} mov kvstn cdstm(xl) 
        mov  m_word [kvstn],w0                  ; 
        mov  w0,m_word [kvlin]                  ; set lastline from line} mov kvlln kvlin 
        mov  m_word [kvlln],w0                  ; 
        mov  w0,m_word [(cfp_b*cdsln)+xl]       ; reset proper line value} mov kvlin cdsln(xl) 
        mov  m_word [kvlin],w0                  ; 
        mov  wa,m_word [kvrtn]                  ; load return type} mov wa kvrtn 
        cmp  wa,scrtn                           ; exit with result in xr if return} beq wa =scrtn exixr
        je   exixr                              ; 
        cmp  wa,scfrt                           ; fail if freturn} beq wa =scfrt exfal
        je   exfal                              ; 
        cmp  m_word [xr],b_nml                  ; jump if is a name} beq (xr) =b_nml rtn11
        je   rtn11                              ; 
        call gtnvr                              ; else try convert to variable name} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_196                           ; 
        dec  m_word [_rc_]                      ; } err 243 function result in nreturn is not name 
        jns  _l0375                             ; 
        mov  m_word [_rc_],243                  ; 
        jmp  err_                               ; 
_l0375:                                         ; 
call_196:                                       ; 
        mov  xl,xr                              ; if ok, copy vrblk (name base) ptr} mov xl xr 
        mov  wa,cfp_b*vrval                     ; set name offset} mov wa *vrval 
        jmp  rtn12                              ; and merge} brn rtn12  
rtn11:
        mov  xl,m_word [(cfp_b*nmbas)+xr]       ; load name base} mov xl nmbas(xr) 
        mov  wa,m_word [(cfp_b*nmofs)+xr]       ; load name offset} mov wa nmofs(xr) 
rtn12:
        mov  xr,xl                              ; preserve xl} mov xr xl 
        mov  r10,m_word [r13]                   ; load next word} lcw wb  
        mov  wb,r10                             ; 
        add  r13,cfp_b                          ; 
        mov  xl,xr                              ; restore xl} mov xl xr 
        cmp  wb,ofne_                           ; exit if called by name} beq wb =ofne_ exnam
        je   exnam                              ; 
        push wb                                 ; else save code word} mov -(xs) wb 
        call acess                              ; get value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_197                           ; 
        dec  m_word [_rc_]                      ; fail if access fails} ppm exfal  
        jns  _l0376                             ; 
        jmp  exfal                              ; 
_l0376:                                         ; 
call_197:                                       ; 
        mov  xl,xr                              ; if ok, copy result} mov xl xr 
        mov  xr,m_word [xs]                     ; reload next code word} mov xr (xs) 
        mov  m_word [xs],xl                     ; store result on stack} mov (xs) xl 
        mov  xl,m_word [xr]                     ; load routine address} mov xl (xr) 
        jmp  xl                                 ; jump to execute next code word} bri xl  
stcov:
                                                ; } rtn   
        inc  m_word [errft]                     ; fatal error} icv errft  
        mov  ia,m_word [intvt]                  ; get 10} ldi intvt  
        add  ia,m_word [kvstl]                  ; add to former limit} adi kvstl  
        mov  m_word [kvstl],ia                  ; store as new stlimit} sti kvstl  
        mov  ia,m_word [intvt]                  ; get 10} ldi intvt  
        mov  m_word [kvstc],ia                  ; set as new count} sti kvstc  
        call stgcc                              ; recompute countdown counters} jsr stgcc  
        mov  m_word [_rc_],244                  ; } erb 244 statement count exceeds value of stlimit keyword 
        jmp  err_                               ; 
stmgo:
                                                ; } rtn   
        mov  m_word [r_cod],xr                  ; set new code block pointer} mov r_cod xr 
        dec  m_word [stmct]                     ; see if time to check something} dcv stmct  
        cmp  m_word [stmct],0                   ; jump if so} bze stmct stgo2 
        jz   stgo2                              ; 
        mov  w0,m_word [kvstn]                  ; set lastno} mov kvlst kvstn 
        mov  m_word [kvlst],w0                  ; 
        mov  w0,m_word [(cfp_b*cdstm)+xr]       ; set stno} mov kvstn cdstm(xr) 
        mov  m_word [kvstn],w0                  ; 
        mov  w0,m_word [kvlin]                  ; set lastline} mov kvlln kvlin 
        mov  m_word [kvlln],w0                  ; 
        mov  w0,m_word [(cfp_b*cdsln)+xr]       ; set line} mov kvlin cdsln(xr) 
        mov  m_word [kvlin],w0                  ; 
        add  xr,cfp_b*cdcod                     ; point to first code word} add xr *cdcod 
        mov  r13,xr                             ; set code pointer} lcp xr  
stgo1:
        mov  r10,m_word [r13]                   ; load next code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        xor  xl,xl                              ; clear garbage xl} zer xl  
        jmp  m_word [xr]                        ; execute it} bri (xr)  
stgo2:
        cmp  m_word [kvpfl],0                   ; skip if no profiling} bze kvpfl stgo3 
        jz   stgo3                              ; 
        call prflu                              ; else profile the statement in kvstn} jsr prflu  
stgo3:
        mov  w0,m_word [kvstn]                  ; set lastno} mov kvlst kvstn 
        mov  m_word [kvlst],w0                  ; 
        mov  w0,m_word [(cfp_b*cdstm)+xr]       ; set stno} mov kvstn cdstm(xr) 
        mov  m_word [kvstn],w0                  ; 
        mov  w0,m_word [kvlin]                  ; set lastline} mov kvlln kvlin 
        mov  m_word [kvlln],w0                  ; 
        mov  w0,m_word [(cfp_b*cdsln)+xr]       ; set line} mov kvlin cdsln(xr) 
        mov  m_word [kvlin],w0                  ; 
        add  xr,cfp_b*cdcod                     ; point to first code word} add xr *cdcod 
        mov  r13,xr                             ; set code pointer} lcp xr  
        push m_word [stmcs]                     ; save present count start on stack} mov -(xs) stmcs 
        dec  m_word [polct]                     ; poll interval within stmct} dcv polct  
        cmp  m_word [polct],0                   ; jump if not poll time yet} bnz polct stgo4 
        jnz  stgo4                              ; 
        xor  wa,wa                              ; =0 for poll} zer wa  
        mov  wb,m_word [kvstn]                  ; statement number} mov wb kvstn 
        mov  xl,xr                              ; make collectable} mov xl xr 
        call syspl                              ; allow interactive access} jsr syspl  
        dec  m_word [_rc_]                      ; 
        js   call_198                           ; 
        dec  m_word [_rc_]                      ; } err 320 user interrupt 
        jns  _l0377                             ; 
        mov  m_word [_rc_],320                  ; 
        jmp  err_                               ; 
_l0377:                                         ; 
        dec  m_word [_rc_]                      ; single step} ppm   
        jns  _l0378                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0378:                                         ; 
        dec  m_word [_rc_]                      ; expression evaluation} ppm   
        jns  _l0379                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0379:                                         ; 
call_198:                                       ; 
        mov  xr,xl                              ; restore code block pointer} mov xr xl 
        mov  m_word [polcs],wa                  ; poll interval start value} mov polcs wa 
        call stgcc                              ; recompute counter values} jsr stgcc  
stgo4:
        mov  ia,m_word [kvstc]                  ; get stmt count} ldi kvstc  
        cmp  ia,0                               ; omit counting if negative} ilt stgo5  
        jl   stgo5                              ; 
        pop  ia                                 ; reload start value of counter} mti (xs)+  
        neg  ia                                 ; negate} ngi   
        add  ia,m_word [kvstc]                  ; stmt count minus counter} adi kvstc  
        mov  m_word [kvstc],ia                  ; replace it} sti kvstc  
        cmp  ia,0                               ; fail if stlimit reached} ile stcov  
        jle  stcov                              ; 
        cmp  m_word [r_stc],0                   ; jump if no statement trace} bze r_stc stgo5 
        jz   stgo5                              ; 
        xor  xr,xr                              ; clear garbage value in xr} zer xr  
        mov  xl,m_word [r_stc]                  ; load pointer to stcount trblk} mov xl r_stc 
        call ktrex                              ; execute keyword trace} jsr ktrex  
stgo5:
        mov  w0,m_word [stmcs]                  ; reset counter} mov stmct stmcs 
        mov  m_word [stmct],w0                  ; 
        jmp  stgo1                              ; fetch next code word} brn stgo1  
stopr:
                                                ; } rtn   
        test xr,xr                              ; skip if sysax already called} bze xr stpra 
        jz   stpra                              ; 
        call sysax                              ; call after execution proc} jsr sysax  
stpra:
        mov  w0,m_word [rsmem]                  ; use the reserve memory} add dname rsmem 
        add  m_word [dname],w0                  ; 
        cmp  xr,endms                           ; skip if not normal end message} bne xr =endms stpr0
        jne  stpr0                              ; 
        cmp  m_word [exsts],0                   ; skip if exec stats suppressed} bnz exsts stpr3 
        jnz  stpr3                              ; 
        xor  w0,w0                              ; clear errors to int.ch. flag} zer erich  
        mov  m_word [erich],w0                  ; 
stpr0:
        call prtpg                              ; eject printer} jsr prtpg  
        test xr,xr                              ; skip if no message} bze xr stpr1 
        jz   stpr1                              ; 
        call prtst                              ; print message} jsr prtst  
stpr1:
        call prtis                              ; print blank line} jsr prtis  
        cmp  m_word [gbcfl],0                   ; if in garbage collection, skip} bnz gbcfl stpr5 
        jnz  stpr5                              ; 
        mov  xr,stpm6                           ; point to message /in file xxx/} mov xr =stpm6 
        call prtst                              ; print it} jsr prtst  
        mov  m_word [profs],prtmf               ; set column offset} mov profs =prtmf 
        mov  wc,m_word [kvstn]                  ; get statement number} mov wc kvstn 
        call filnm                              ; get file name} jsr filnm  
        mov  xr,xl                              ; prepare to print} mov xr xl 
        call prtst                              ; print file name} jsr prtst  
        call prtis                              ; print to interactive channel} jsr prtis  
        mov  xr,m_word [r_cod]                  ; get code pointer} mov xr r_cod 
        mov  ia,m_word [(cfp_b*cdsln)+xr]       ; get source line number} mti cdsln(xr)  
        mov  xr,stpm4                           ; point to message /in line xxx/} mov xr =stpm4 
        call prtmx                              ; print it} jsr prtmx  
stpr5:
        mov  ia,m_word [kvstn]                  ; get statement number} mti kvstn  
        mov  xr,stpm1                           ; point to message /in statement xxx/} mov xr =stpm1 
        call prtmx                              ; print it} jsr prtmx  
        mov  ia,m_word [kvstl]                  ; get statement limit} ldi kvstl  
        cmp  ia,0                               ; skip if negative} ilt stpr2  
        jl   stpr2                              ; 
        sub  ia,m_word [kvstc]                  ; minus counter = course count} sbi kvstc  
        mov  m_word [stpsi],ia                  ; save} sti stpsi  
        mov  wa,m_word [stmcs]                  ; refine with counter start value} mov wa stmcs 
        sub  wa,m_word [stmct]                  ; minus current counter} sub wa stmct 
        mov  ia,wa                              ; convert to integer} mti wa  
        add  ia,m_word [stpsi]                  ; add in course count} adi stpsi  
        mov  m_word [stpsi],ia                  ; save} sti stpsi  
        mov  xr,stpm2                           ; point to message /stmts executed/} mov xr =stpm2 
        call prtmx                              ; print it} jsr prtmx  
        call systm                              ; get current time} jsr systm  
        sub  ia,m_word [timsx]                  ; minus start time = elapsed exec tim in nanosec} sbi timsx  
        mov  m_word [stpti],ia                  ; save for later} sti stpti  
        mov  r10,m_word [intth]                 ; divide by 1000 to convert to microseconds} dvi intth  
        call do_dvi                             ; 
        jo   stpr2                              ; jump if we cannot compute} iov stpr2  
        mov  r10,m_word [intth]                 ; divide by 1000 to convert to milliseconds} dvi intth  
        call do_dvi                             ; 
        jo   stpr2                              ; jump if we cannot compute} iov stpr2  
        mov  m_word [stpti],ia                  ; save elapsed time in milliseconds} sti stpti  
        mov  xr,stpm3                           ; point to msg /execution time msec /} mov xr =stpm3 
        call prtmx                              ; print it} jsr prtmx  
        mov  ia,m_word [stpti]                  ; reload execution time in milliseconds} ldi stpti  
        cmp  ia,0                               ; jump if exection time less than a millisecond} ile stpr2  
        jle  stpr2                              ; 
        mov  ia,m_word [stpsi]                  ; load statement count} ldi stpsi  
        mov  r10,m_word [stpti]                 ; divide to get stmts per millisecond} dvi stpti  
        call do_dvi                             ; 
        jo   stpr2                              ; jump if we cannot compute} iov stpr2  
        mov  r10,m_word [intth]                 ; divide to get stmts per microsecond} dvi intth  
        call do_dvi                             ; 
        jo   stpr2                              ; jump if we cannot compute} iov stpr2  
        mov  xr,stpm7                           ; point to msg (stmt / microsec)} mov xr =stpm7 
        call prtmx                              ; print it} jsr prtmx  
        mov  ia,m_word [stpsi]                  ; reload statement count} ldi stpsi  
        mov  r10,m_word [stpti]                 ; divide to get stmts per millisecond} dvi stpti  
        call do_dvi                             ; 
        jo   stpr2                              ; jump if we cannot compute} iov stpr2  
        mov  xr,stpm8                           ; point to msg (stmt / millisec )} mov xr =stpm8 
        call prtmx                              ; print it} jsr prtmx  
        mov  ia,m_word [stpsi]                  ; reload statement count} ldi stpsi  
        mov  r10,m_word [stpti]                 ; divide to get stmts per millisecond} dvi stpti  
        call do_dvi                             ; 
        jo   stpr2                              ; jump if we cannot compute} iov stpr2  
        imul ia,m_word [intth]                  ; multiply by 1000 to get stmts per microsecond} mli intth  
        jo   stpr2                              ; jump if overflow} iov stpr2  
        mov  xr,stpm9                           ; point to msg ( stmt / second )} mov xr =stpm9 
        call prtmx                              ; print it} jsr prtmx  
stpr2:
        mov  ia,m_word [gbcnt]                  ; load count of collections} mti gbcnt  
        mov  xr,stpm5                           ; point to message /regenerations /} mov xr =stpm5 
        call prtmx                              ; print it} jsr prtmx  
        call prtmm                              ; print memory usage} jsr prtmm  
        call prtis                              ; one more blank for luck} jsr prtis  
stpr3:
        call prflr                              ; print profile if wanted} jsr prflr  
        mov  xr,m_word [kvdmp]                  ; load dump keyword} mov xr kvdmp 
        call dumpr                              ; execute dump if requested} jsr dumpr  
        mov  xl,m_word [r_fcb]                  ; get fcblk chain head} mov xl r_fcb 
        mov  wa,m_word [kvabe]                  ; load abend value} mov wa kvabe 
        mov  wb,m_word [kvcod]                  ; load code value} mov wb kvcod 
        call sysej                              ; exit to system} jsr sysej  
stpr4:
                                                ; } rtn   
        mov  w0,m_word [rsmem]                  ; use the reserve memory} add dname rsmem 
        add  m_word [dname],w0                  ; 
        cmp  m_word [exsts],0                   ; if execution stats requested} bze exsts stpr1 
        jz   stpr1                              ; 
        jmp  stpr3                              ; check if dump or profile needed} brn stpr3  
succp:
                                                ; } rtn   
        mov  xr,m_word [(cfp_b*pthen)+xr]       ; load successor node} mov xr pthen(xr) 
        mov  xl,m_word [xr]                     ; load node code entry address} mov xl (xr) 
        jmp  xl                                 ; jump to match successor node} bri xl  
sysab:
                                                ; } rtn   
        mov  xr,endab                           ; point to message} mov xr =endab 
        mov  m_word [kvabe],num01               ; set abend flag} mov kvabe =num01 
        call prtnl                              ; skip to new line} jsr prtnl  
        jmp  stopr                              ; jump to pack up} brn stopr  
systu:
                                                ; } rtn   
        mov  xr,endtu                           ; point to message} mov xr =endtu 
        mov  wa,m_word [strtu]                  ; get chars /tu/} mov wa strtu 
        mov  m_word [kvcod],wa                  ; put in kvcod} mov kvcod wa 
        mov  wa,m_word [timup]                  ; check state of timeup switch} mov wa timup 
        mov  m_word [timup],xs                  ; set switch} mnz timup  
        test wa,wa                              ; stop run if already set} bnz wa stopr 
        jnz  stopr                              ; 
        mov  m_word [_rc_],245                  ; } erb 245 translation/execution time expired 
        jmp  err_                               ; 
acess:
                                                ; entry point (recursive)} prc r 1 
        mov  xr,xl                              ; copy name base} mov xr xl 
        add  xr,wa                              ; point to variable location} add xr wa 
        mov  xr,m_word [xr]                     ; load variable value} mov xr (xr) 
acs02:
        cmp  m_word [xr],b_trt                  ; jump if not trapped} bne (xr) =b_trt acs18
        jne  acs18                              ; 
        cmp  xr,trbkv                           ; jump if keyword variable} beq xr =trbkv acs12
        je   acs12                              ; 
        cmp  xr,trbev                           ; jump if not expression variable} bne xr =trbev acs05
        jne  acs05                              ; 
        mov  xr,m_word [(cfp_b*evexp)+xl]       ; load expression pointer} mov xr evexp(xl) 
        xor  wb,wb                              ; evaluate by value} zer wb  
        call evalx                              ; evaluate expression} jsr evalx  
        dec  m_word [_rc_]                      ; 
        js   call_199                           ; 
        dec  m_word [_rc_]                      ; jump if evaluation failure} ppm acs04  
        jns  _l0380                             ; 
        jmp  acs04                              ; 
_l0380:                                         ; 
call_199:                                       ; 
        jmp  acs02                              ; check value for more trblks} brn acs02  
acs03:
        add  xs,cfp_b*num03                     ; pop trblk ptr, name base and offset} add xs *num03 
        mov  m_word [dnamp],xr                  ; pop unused scblk} mov dnamp xr 
acs04:
        mov  m_word [_rc_],1                    ; take alternate (failure) return} exi 1  
        ret                                     ; 
acs05:
        mov  wb,m_word [(cfp_b*trtyp)+xr]       ; load trap type code} mov wb trtyp(xr) 
        test wb,wb                              ; jump if not input association} bnz wb acs10 
        jnz  acs10                              ; 
        cmp  m_word [kvinp],0                   ; ignore input assoc if input is off} bze kvinp acs09 
        jz   acs09                              ; 
        push xl                                 ; stack name base} mov -(xs) xl 
        push wa                                 ; stack name offset} mov -(xs) wa 
        push xr                                 ; stack trblk pointer} mov -(xs) xr 
        mov  w0,m_word [kvtrm]                  ; temp to hold trim keyword} mov actrm kvtrm 
        mov  m_word [actrm],w0                  ; 
        mov  xl,m_word [(cfp_b*trfpt)+xr]       ; get file ctrl blk ptr or zero} mov xl trfpt(xr) 
        test xl,xl                              ; jump if not standard input file} bnz xl acs06 
        jnz  acs06                              ; 
        cmp  m_word [(cfp_b*trter)+xr],v_ter    ; jump if terminal} beq trter(xr) =v_ter acs21
        je   acs21                              ; 
        mov  wa,m_word [cswin]                  ; length for read buffer} mov wa cswin 
        call alocs                              ; build string of appropriate length} jsr alocs  
        call sysrd                              ; read next standard input image} jsr sysrd  
        dec  m_word [_rc_]                      ; 
        js   call_200                           ; 
        dec  m_word [_rc_]                      ; jump to fail exit if end of file} ppm acs03  
        jns  _l0381                             ; 
        jmp  acs03                              ; 
_l0381:                                         ; 
call_200:                                       ; 
        jmp  acs07                              ; else merge with other file case} brn acs07  
acs06:
        mov  wa,xl                              ; fcblk ptr} mov wa xl 
        call sysil                              ; get input record max length (to wa)} jsr sysil  
        test wc,wc                              ; jump if not binary file} bnz wc acs6a 
        jnz  acs6a                              ; 
        mov  m_word [actrm],wc                  ; disable trim for binary file} mov actrm wc 
acs6a:
        call alocs                              ; allocate string of correct size} jsr alocs  
        mov  wa,xl                              ; fcblk ptr} mov wa xl 
        call sysin                              ; call system input routine} jsr sysin  
        dec  m_word [_rc_]                      ; 
        js   call_201                           ; 
        dec  m_word [_rc_]                      ; jump to fail exit if end of file} ppm acs03  
        jns  _l0382                             ; 
        jmp  acs03                              ; 
_l0382:                                         ; 
        dec  m_word [_rc_]                      ; error} ppm acs22  
        jns  _l0383                             ; 
        jmp  acs22                              ; 
_l0383:                                         ; 
        dec  m_word [_rc_]                      ; error} ppm acs23  
        jns  _l0384                             ; 
        jmp  acs23                              ; 
_l0384:                                         ; 
call_201:                                       ; 
acs07:
        mov  wb,m_word [actrm]                  ; load trim indicator} mov wb actrm 
        call trimr                              ; trim record as required} jsr trimr  
        mov  wb,xr                              ; copy result pointer} mov wb xr 
        mov  xr,m_word [xs]                     ; reload pointer to trblk} mov xr (xs) 
acs08:
        mov  xl,xr                              ; save pointer to this trblk} mov xl xr 
        mov  xr,m_word [(cfp_b*trnxt)+xr]       ; load forward pointer} mov xr trnxt(xr) 
        cmp  m_word [xr],b_trt                  ; loop if this is another trblk} beq (xr) =b_trt acs08
        je   acs08                              ; 
        mov  m_word [(cfp_b*trnxt)+xl],wb       ; else store result at end of chain} mov trnxt(xl) wb 
        pop  xr                                 ; restore initial trblk pointer} mov xr (xs)+ 
        pop  wa                                 ; restore name offset} mov wa (xs)+ 
        pop  xl                                 ; restore name base pointer} mov xl (xs)+ 
acs09:
        mov  xr,m_word [(cfp_b*trnxt)+xr]       ; load forward ptr to next value} mov xr trnxt(xr) 
        jmp  acs02                              ; back to check if trapped} brn acs02  
acs10:
        cmp  wb,trtac                           ; loop back if not access trace} bne wb =trtac acs09
        jne  acs09                              ; 
        cmp  m_word [kvtra],0                   ; ignore access trace if trace off} bze kvtra acs09 
        jz   acs09                              ; 
        dec  m_word [kvtra]                     ; else decrement trace count} dcv kvtra  
        cmp  m_word [(cfp_b*trfnc)+xr],0        ; jump if print trace} bze trfnc(xr) acs11 
        jz   acs11                              ; 
        call trxeq                              ; call routine to execute trace} jsr trxeq  
        jmp  acs09                              ; jump for next trblk} brn acs09  
acs11:
        call prtsn                              ; print statement number} jsr prtsn  
        call prtnv                              ; print name = value} jsr prtnv  
        jmp  acs09                              ; jump back for next trblk} brn acs09  
acs12:
        mov  xr,m_word [(cfp_b*kvnum)+xl]       ; load keyword number} mov xr kvnum(xl) 
        cmp  xr,k_v__                           ; jump if not one word value} bge xr =k_v__ acs14
        jae  acs14                              ; 
        mov  ia,m_word [kvabe+xr]               ; else load value as integer} mti kvabe(xr)  
acs13:
        call icbld                              ; build icblk} jsr icbld  
        jmp  acs18                              ; jump to exit} brn acs18  
acs14:
        cmp  xr,k_s__                           ; jump if special case} bge xr =k_s__ acs15
        jae  acs15                              ; 
        sub  xr,k_v__                           ; else get offset} sub xr =k_v__ 
        sal  xr,log_cfp_b                       ; convert to byte offset} wtb xr  
        add  xr,ndabo                           ; point to pattern value} add xr =ndabo 
        jmp  acs18                              ; jump to exit} brn acs18  
acs15:
        mov  xl,m_word [kvrtn]                  ; load rtntype in case} mov xl kvrtn 
        mov  ia,m_word [kvstl]                  ; load stlimit in case} ldi kvstl  
        sub  xr,k_s__                           ; get case number} sub xr =k_s__ 
        jmp  m_word [_l0385+xr*cfp_b]           ; switch on keyword number} bsw xr k__n_ 
        segment .data                           ; 
_l0385:                                         ; 
        d_word acs16                            ; jump if alphabet} iff k__al acs16 
        d_word acs17                            ; rtntype} iff k__rt acs17 
        d_word acs19                            ; stcount} iff k__sc acs19 
        d_word acs20                            ; errtext} iff k__et acs20 
        d_word acs26                            ; file} iff k__fl acs26 
        d_word acs27                            ; lastfile} iff k__lf acs27 
        d_word acs13                            ; stlimit} iff k__sl acs13 
        d_word acs24                            ; lcase} iff k__lc acs24 
        d_word acs25                            ; ucase} iff k__uc acs25 
        segment .text                           ; end switch on keyword number} esw   
acs24:
        mov  xr,lcase                           ; load pointer to lcase string} mov xr =lcase 
        jmp  acs18                              ; common return} brn acs18  
acs25:
        mov  xr,ucase                           ; load pointer to ucase string} mov xr =ucase 
        jmp  acs18                              ; common return} brn acs18  
acs26:
        mov  wc,m_word [kvstn]                  ; load current stmt number} mov wc kvstn 
        jmp  acs28                              ; merge to obtain file name} brn acs28  
acs27:
        mov  wc,m_word [kvlst]                  ; load last stmt number} mov wc kvlst 
acs28:
        call filnm                              ; obtain file name for this stmt} jsr filnm  
        jmp  acs17                              ; merge to return string in xl} brn acs17  
acs16:
        mov  xl,m_word [kvalp]                  ; load pointer to alphabet string} mov xl kvalp 
acs17:
        mov  xr,xl                              ; copy string ptr to proper reg} mov xr xl 
acs18:
        mov  m_word [_rc_],0                    ; return to acess caller} exi   
        ret                                     ; 
acs19:
        cmp  ia,0                               ; if counting suppressed} ilt acs29  
        jl   acs29                              ; 
        mov  wa,m_word [stmcs]                  ; refine with counter start value} mov wa stmcs 
        sub  wa,m_word [stmct]                  ; minus current counter} sub wa stmct 
        mov  ia,wa                              ; convert to integer} mti wa  
        add  ia,m_word [kvstl]                  ; add stlimit} adi kvstl  
acs29:
        sub  ia,m_word [kvstc]                  ; stcount = limit - left} sbi kvstc  
        jmp  acs13                              ; merge back with integer result} brn acs13  
acs20:
        mov  xr,m_word [r_etx]                  ; get errtext string} mov xr r_etx 
        jmp  acs18                              ; merge with result} brn acs18  
acs21:
        mov  wa,rilen                           ; buffer length} mov wa =rilen 
        call alocs                              ; allocate buffer} jsr alocs  
        call sysri                              ; read record} jsr sysri  
        dec  m_word [_rc_]                      ; 
        js   call_202                           ; 
        dec  m_word [_rc_]                      ; endfile} ppm acs03  
        jns  _l0386                             ; 
        jmp  acs03                              ; 
_l0386:                                         ; 
call_202:                                       ; 
        jmp  acs07                              ; merge with record read} brn acs07  
acs22:
        mov  m_word [dnamp],xr                  ; pop unused scblk} mov dnamp xr 
        mov  m_word [_rc_],202                  ; } erb 202 input from file caused non-recoverable error 
        jmp  err_                               ; 
acs23:
        mov  m_word [dnamp],xr                  ; pop unused scblk} mov dnamp xr 
        mov  m_word [_rc_],203                  ; } erb 203 input file record has incorrect format 
        jmp  err_                               ; 
                                                ; end procedure acess} enp   
acomp:
        pop  m_word [prc_+cfp_b*0]              ; entry point} prc n 5 
        call arith                              ; load arithmetic operands} jsr arith  
        dec  m_word [_rc_]                      ; 
        js   call_203                           ; 
        dec  m_word [_rc_]                      ; jump if first arg non-numeric} ppm acmp7  
        jns  _l0387                             ; 
        jmp  acmp7                              ; 
_l0387:                                         ; 
        dec  m_word [_rc_]                      ; jump if second arg non-numeric} ppm acmp8  
        jns  _l0388                             ; 
        jmp  acmp8                              ; 
_l0388:                                         ; 
        dec  m_word [_rc_]                      ; jump if real arguments} ppm acmp4  
        jns  _l0389                             ; 
        jmp  acmp4                              ; 
_l0389:                                         ; 
call_203:                                       ; 
        sub  ia,m_word [(cfp_b*icval)+xl]       ; subtract to compare} sbi icval(xl)  
        jo   acmp3                              ; jump if overflow} iov acmp3  
        cmp  ia,0                               ; else jump if arg1 lt arg2} ilt acmp5  
        jl   acmp5                              ; 
        cmp  ia,0                               ; jump if arg1 eq arg2} ieq acmp2  
        je   acmp2                              ; 
acmp1:
        mov  m_word [_rc_],5                    ; take gt exit} exi 5  
        mov  w0,m_word [prc_+cfp_b*0]           ; 
        jmp  w0                                 ; 
acmp2:
        mov  m_word [_rc_],4                    ; take eq exit} exi 4  
        mov  w0,m_word [prc_+cfp_b*0]           ; 
        jmp  w0                                 ; 
acmp3:
        mov  ia,m_word [(cfp_b*icval)+xl]       ; load second argument} ldi icval(xl)  
        cmp  ia,0                               ; gt if negative} ilt acmp1  
        jl   acmp1                              ; 
        jmp  acmp5                              ; else lt} brn acmp5  
acmp4:
        ldmxcsr [mxcsr_set]                     ; subtract to compare} sbr rcval(xl)  
        subsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0390                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0390:                                         ; 
        call do_chk_real_inf                    ; jump if overflow} rov acmp6  
        jnz  acmp6                              ; 
        pxor xmm0,xmm0                          ; else jump if arg1 gt} rgt acmp1  
        ucomisd ra,xmm0                         ; 
        ja   acmp1                              ; 
        pxor xmm0,xmm0                          ; jump if arg1 eq arg2} req acmp2  
        ucomisd ra,xmm0                         ; 
        je   acmp2                              ; 
acmp5:
        mov  m_word [_rc_],3                    ; take lt exit} exi 3  
        mov  w0,m_word [prc_+cfp_b*0]           ; 
        jmp  w0                                 ; 
acmp6:
        movsd ra,[(cfp_b*rcval)+xl]             ; reload arg2} ldr rcval(xl)  
        pxor xmm0,xmm0                          ; gt if negative} rlt acmp1  
        ucomisd ra,xmm0                         ; 
        jb   acmp1                              ; 
        jmp  acmp5                              ; else lt} brn acmp5  
acmp7:
        mov  m_word [_rc_],1                    ; take error exit} exi 1  
        mov  w0,m_word [prc_+cfp_b*0]           ; 
        jmp  w0                                 ; 
acmp8:
        mov  m_word [_rc_],2                    ; take error exit} exi 2  
        mov  w0,m_word [prc_+cfp_b*0]           ; 
        jmp  w0                                 ; 
                                                ; end procedure acomp} enp   
alloc:
                                                ; entry point} prc e 0 
aloc1:
        mov  xr,m_word [dnamp]                  ; point to next available loc} mov xr dnamp 
        add  xr,wa                              ; point past allocated block} aov wa xr aloc2
        jc   aloc2                              ; 
        cmp  xr,m_word [dname]                  ; jump if not enough room} bgt xr dname aloc2
        ja   aloc2                              ; 
        mov  m_word [dnamp],xr                  ; store new pointer} mov dnamp xr 
        sub  xr,wa                              ; point back to start of allocated bk} sub xr wa 
        ret                                     ; return to caller} exi   
aloc2:
        mov  m_word [allsv],wb                  ; save wb} mov allsv wb 
alc2a:
        xor  wb,wb                              ; set no upward move for gbcol} zer wb  
        call gbcol                              ; garbage collect} jsr gbcol  
        mov  wb,xr                              ; remember new sediment size} mov wb xr 
aloc3:
        mov  xr,m_word [dnamp]                  ; point to first available loc} mov xr dnamp 
        add  xr,wa                              ; point past new block} aov wa xr alc3a
        jc   alc3a                              ; 
        cmp  xr,m_word [dname]                  ; jump if there is room now} blo xr dname aloc4
        jb   aloc4                              ; 
alc3a:
        call sysmm                              ; try to get more memory} jsr sysmm  
        sal  xr,log_cfp_b                       ; convert to baus (sgd05)} wtb xr  
        add  m_word [dname],xr                  ; bump ptr by amount obtained} add dname xr 
        test xr,xr                              ; jump if got more core} bnz xr aloc3 
        jnz  aloc3                              ; 
        cmp  m_word [dnams],0                   ; jump if there was no sediment} bze dnams alc3b 
        jz   alc3b                              ; 
        xor  w0,w0                              ; try collecting the sediment} zer dnams  
        mov  m_word [dnams],w0                  ; 
        jmp  alc2a                              ; } brn alc2a  
alc3b:
        mov  w0,m_word [rsmem]                  ; get the reserve memory} add dname rsmem 
        add  m_word [dname],w0                  ; 
        xor  w0,w0                              ; only permissible once} zer rsmem  
        mov  m_word [rsmem],w0                  ; 
        inc  m_word [errft]                     ; fatal error} icv errft  
        mov  m_word [_rc_],204                  ; } erb 204 memory overflow 
        jmp  err_                               ; 
aloc4:
        mov  m_word [allia],ia                  ; save ia} sti allia  
        mov  m_word [dnams],wb                  ; record new sediment size} mov dnams wb 
        mov  wb,m_word [dname]                  ; get dynamic end adrs} mov wb dname 
        sub  wb,m_word [dnamp]                  ; compute free store} sub wb dnamp 
        shr  wb,log_cfp_b                       ; convert bytes to words} btw wb  
        mov  ia,wb                              ; put free store in ia} mti wb  
        imul ia,m_word [alfsf]                  ; multiply by free store factor} mli alfsf  
        jo   aloc5                              ; jump if overflowed} iov aloc5  
        mov  wb,m_word [dname]                  ; dynamic end adrs} mov wb dname 
        sub  wb,m_word [dnamb]                  ; compute total amount of dynamic} sub wb dnamb 
        shr  wb,log_cfp_b                       ; convert to words} btw wb  
        mov  m_word [aldyn],wb                  ; store it} mov aldyn wb 
        sub  ia,m_word [aldyn]                  ; subtract from scaled up free store} sbi aldyn  
        cmp  ia,0                               ; jump if sufficient free store} igt aloc5  
        jg   aloc5                              ; 
        call sysmm                              ; try to get more store} jsr sysmm  
        sal  xr,log_cfp_b                       ; convert to baus (sgd05)} wtb xr  
        add  m_word [dname],xr                  ; adjust dynamic end adrs} add dname xr 
aloc5:
        mov  ia,m_word [allia]                  ; recover ia} ldi allia  
        mov  wb,m_word [allsv]                  ; restore wb} mov wb allsv 
        jmp  aloc1                              ; jump back to exit} brn aloc1  
                                                ; end procedure alloc} enp   
alocs:
                                                ; entry point} prc e 0 
        cmp  wa,m_word [kvmxl]                  ; jump if length exceeds maxlength} bgt wa kvmxl alcs2
        ja   alcs2                              ; 
        mov  wc,wa                              ; else copy length} mov wc wa 
        add  wa,(cfp_b-1)+cfp_b*scsi_           ; compute length of scblk in bytes} ctb wa scsi_ 
        and  wa,-cfp_b                          ; 
        mov  xr,m_word [dnamp]                  ; point to next available location} mov xr dnamp 
        add  xr,wa                              ; point past block} aov wa xr alcs0
        jc   alcs0                              ; 
        cmp  xr,m_word [dname]                  ; jump if there is room} blo xr dname alcs1
        jb   alcs1                              ; 
alcs0:
        xor  xr,xr                              ; else clear garbage xr value} zer xr  
        call alloc                              ; and use standard allocator} jsr alloc  
        add  xr,wa                              ; point past end of block to merge} add xr wa 
alcs1:
        mov  m_word [dnamp],xr                  ; set updated storage pointer} mov dnamp xr 
        lea  xr,[xr-cfp_b]                      ; store zero chars in last word} zer -(xr)  
        xor  w0,w0                              ; 
        mov  m_word [xr],w0                     ; 
        sub  wa,cfp_b                           ; decrement length} dca wa  
        sub  xr,wa                              ; point back to start of block} sub xr wa 
        mov  m_word [xr],b_scl                  ; set type word} mov (xr) =b_scl 
        mov  m_word [(cfp_b*sclen)+xr],wc       ; store length in chars} mov sclen(xr) wc 
        ret                                     ; return to alocs caller} exi   
alcs2:
        mov  m_word [_rc_],205                  ; } erb 205 string length exceeds value of maxlngth keyword 
        jmp  err_                               ; 
                                                ; end procedure alocs} enp   
alost:
                                                ; entry point} prc e 0 
alst1:
        mov  xr,m_word [state]                  ; point to current end of area} mov xr state 
        add  xr,wa                              ; point beyond proposed block} aov wa xr alst2
        jc   alst2                              ; 
        cmp  xr,m_word [dnamb]                  ; jump if overlap with dynamic area} bge xr dnamb alst2
        jae  alst2                              ; 
        mov  m_word [state],xr                  ; else store new pointer} mov state xr 
        sub  xr,wa                              ; point back to start of block} sub xr wa 
        ret                                     ; return to alost caller} exi   
alst2:
        mov  m_word [alsta],wa                  ; save wa} mov alsta wa 
        cmp  wa,cfp_b*e_sts                     ; skip if requested chunk is large} bge wa *e_sts alst3
        jae  alst3                              ; 
        mov  wa,cfp_b*e_sts                     ; else set to get large enough chunk} mov wa *e_sts 
alst3:
        call alloc                              ; allocate block to ensure room} jsr alloc  
        mov  m_word [dnamp],xr                  ; and delete it} mov dnamp xr 
        mov  wb,wa                              ; copy move up amount} mov wb wa 
        call gbcol                              ; call gbcol to move dynamic area up} jsr gbcol  
        mov  m_word [dnams],xr                  ; remember new sediment size} mov dnams xr 
        mov  wa,m_word [alsta]                  ; restore wa} mov wa alsta 
        jmp  alst1                              ; loop back to try again} brn alst1  
                                                ; end procedure alost} enp   
arith:
        pop  m_word [prc_+cfp_b*1]              ; entry point} prc n 3 
        pop  xl                                 ; load right operand} mov xl (xs)+ 
        pop  xr                                 ; load left operand} mov xr (xs)+ 
        mov  wa,m_word [xl]                     ; get right operand type word} mov wa (xl) 
        cmp  wa,b_icl                           ; jump if integer} beq wa =b_icl arth1
        je   arth1                              ; 
        cmp  wa,b_rcl                           ; jump if real} beq wa =b_rcl arth4
        je   arth4                              ; 
        push xr                                 ; else replace left arg on stack} mov -(xs) xr 
        mov  xr,xl                              ; copy left arg pointer} mov xr xl 
        call gtnum                              ; convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_204                           ; 
        dec  m_word [_rc_]                      ; jump if unconvertible} ppm arth6  
        jns  _l0391                             ; 
        jmp  arth6                              ; 
_l0391:                                         ; 
call_204:                                       ; 
        mov  xl,xr                              ; else copy converted result} mov xl xr 
        mov  wa,m_word [xl]                     ; get right operand type word} mov wa (xl) 
        pop  xr                                 ; reload left argument} mov xr (xs)+ 
        cmp  wa,b_rcl                           ; jump if right arg is real} beq wa =b_rcl arth4
        je   arth4                              ; 
arth1:
        cmp  m_word [xr],b_icl                  ; jump if left arg not integer} bne (xr) =b_icl arth3
        jne  arth3                              ; 
arth2:
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load left operand value} ldi icval(xr)  
        mov  m_word [_rc_],0                    ; return to arith caller} exi   
        mov  w0,m_word [prc_+cfp_b*1]           ; 
        jmp  w0                                 ; 
arth3:
        call gtnum                              ; convert left arg to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_205                           ; 
        dec  m_word [_rc_]                      ; jump if not convertible} ppm arth7  
        jns  _l0392                             ; 
        jmp  arth7                              ; 
_l0392:                                         ; 
call_205:                                       ; 
        cmp  wa,b_icl                           ; jump back if integer-integer} beq wa =b_icl arth2
        je   arth2                              ; 
        push xr                                 ; put left arg back on stack} mov -(xs) xr 
        mov  ia,m_word [(cfp_b*icval)+xl]       ; load right argument value} ldi icval(xl)  
        pxor ra,ra                              ; convert to real} itr   
        cvtsi2sd ra,ia                          ; 
        call rcbld                              ; get real block for right arg, merge} jsr rcbld  
        mov  xl,xr                              ; copy right arg ptr} mov xl xr 
        pop  xr                                 ; load left argument} mov xr (xs)+ 
        jmp  arth5                              ; merge for real-real case} brn arth5  
arth4:
        cmp  m_word [xr],b_rcl                  ; jump if left arg real} beq (xr) =b_rcl arth5
        je   arth5                              ; 
        call gtrea                              ; else convert to real} jsr gtrea  
        dec  m_word [_rc_]                      ; 
        js   call_206                           ; 
        dec  m_word [_rc_]                      ; error if unconvertible} ppm arth7  
        jns  _l0393                             ; 
        jmp  arth7                              ; 
_l0393:                                         ; 
call_206:                                       ; 
arth5:
        movsd ra,[(cfp_b*rcval)+xr]             ; load left operand value} ldr rcval(xr)  
        mov  m_word [_rc_],3                    ; take real-real exit} exi 3  
        mov  w0,m_word [prc_+cfp_b*1]           ; 
        jmp  w0                                 ; 
arth6:
        add  xs,cfp_b                           ; pop unwanted left arg} ica xs  
        mov  m_word [_rc_],2                    ; take appropriate error exit} exi 2  
        mov  w0,m_word [prc_+cfp_b*1]           ; 
        jmp  w0                                 ; 
arth7:
        mov  m_word [_rc_],1                    ; take appropriate error return} exi 1  
        mov  w0,m_word [prc_+cfp_b*1]           ; 
        jmp  w0                                 ; 
                                                ; end procedure arith} enp   
asign:
                                                ; entry point (recursive)} prc r 1 
asg01:
        add  xl,wa                              ; point to variable value} add xl wa 
        mov  xr,m_word [xl]                     ; load variable value} mov xr (xl) 
        cmp  m_word [xr],b_trt                  ; jump if trapped} beq (xr) =b_trt asg02
        je   asg02                              ; 
        mov  m_word [xl],wb                     ; else perform assignment} mov (xl) wb 
        xor  xl,xl                              ; clear garbage value in xl} zer xl  
        mov  m_word [_rc_],0                    ; and return to asign caller} exi   
        ret                                     ; 
asg02:
        sub  xl,wa                              ; restore name base} sub xl wa 
        cmp  xr,trbkv                           ; jump if keyword variable} beq xr =trbkv asg14
        je   asg14                              ; 
        cmp  xr,trbev                           ; jump if not expression variable} bne xr =trbev asg04
        jne  asg04                              ; 
        mov  xr,m_word [(cfp_b*evexp)+xl]       ; point to expression} mov xr evexp(xl) 
        push wb                                 ; store value to assign on stack} mov -(xs) wb 
        mov  wb,num01                           ; set for evaluation by name} mov wb =num01 
        call evalx                              ; evaluate expression by name} jsr evalx  
        dec  m_word [_rc_]                      ; 
        js   call_207                           ; 
        dec  m_word [_rc_]                      ; jump if evaluation fails} ppm asg03  
        jns  _l0394                             ; 
        jmp  asg03                              ; 
_l0394:                                         ; 
call_207:                                       ; 
        pop  wb                                 ; else reload value to assign} mov wb (xs)+ 
        jmp  asg01                              ; loop back to perform assignment} brn asg01  
asg03:
        add  xs,cfp_b                           ; remove stacked value entry} ica xs  
        mov  m_word [_rc_],1                    ; take failure exit} exi 1  
        ret                                     ; 
asg04:
        push xr                                 ; save ptr to first trblk} mov -(xs) xr 
asg05:
        mov  wc,xr                              ; save ptr to this trblk} mov wc xr 
        mov  xr,m_word [(cfp_b*trnxt)+xr]       ; point to next trblk} mov xr trnxt(xr) 
        cmp  m_word [xr],b_trt                  ; loop back if another trblk} beq (xr) =b_trt asg05
        je   asg05                              ; 
        mov  xr,wc                              ; else point back to last trblk} mov xr wc 
        mov  m_word [(cfp_b*trval)+xr],wb       ; store value at end of chain} mov trval(xr) wb 
        pop  xr                                 ; restore ptr to first trblk} mov xr (xs)+ 
asg06:
        mov  wb,m_word [(cfp_b*trtyp)+xr]       ; load type code of trblk} mov wb trtyp(xr) 
        cmp  wb,trtvl                           ; jump if value trace} beq wb =trtvl asg08
        je   asg08                              ; 
        cmp  wb,trtou                           ; jump if output association} beq wb =trtou asg10
        je   asg10                              ; 
asg07:
        mov  xr,m_word [(cfp_b*trnxt)+xr]       ; point to next trblk on chain} mov xr trnxt(xr) 
        cmp  m_word [xr],b_trt                  ; loop back if another trblk} beq (xr) =b_trt asg06
        je   asg06                              ; 
        mov  m_word [_rc_],0                    ; else end of chain, return to caller} exi   
        ret                                     ; 
asg08:
        cmp  m_word [kvtra],0                   ; ignore value trace if trace off} bze kvtra asg07 
        jz   asg07                              ; 
        dec  m_word [kvtra]                     ; else decrement trace count} dcv kvtra  
        cmp  m_word [(cfp_b*trfnc)+xr],0        ; jump if print trace} bze trfnc(xr) asg09 
        jz   asg09                              ; 
        call trxeq                              ; else execute function trace} jsr trxeq  
        jmp  asg07                              ; and loop back} brn asg07  
asg09:
        call prtsn                              ; print statement number} jsr prtsn  
        call prtnv                              ; print name = value} jsr prtnv  
        jmp  asg07                              ; loop back for next trblk} brn asg07  
asg10:
        cmp  m_word [kvoup],0                   ; ignore output assoc if output off} bze kvoup asg07 
        jz   asg07                              ; 
asg1b:
        mov  xl,xr                              ; copy trblk pointer} mov xl xr 
        mov  xr,m_word [(cfp_b*trnxt)+xr]       ; point to next trblk} mov xr trnxt(xr) 
        cmp  m_word [xr],b_trt                  ; loop back if another trblk} beq (xr) =b_trt asg1b
        je   asg1b                              ; 
        mov  xr,xl                              ; else point back to last trblk} mov xr xl 
        push m_word [(cfp_b*trval)+xr]          ; stack value to output} mov -(xs) trval(xr) 
        call gtstg                              ; convert to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_208                           ; 
        dec  m_word [_rc_]                      ; get datatype name if unconvertible} ppm asg12  
        jns  _l0395                             ; 
        jmp  asg12                              ; 
_l0395:                                         ; 
call_208:                                       ; 
asg11:
        mov  wa,m_word [(cfp_b*trfpt)+xl]       ; fcblk ptr} mov wa trfpt(xl) 
        test wa,wa                              ; jump if standard output file} bze wa asg13 
        jz   asg13                              ; 
asg1a:
        call sysou                              ; call system output routine} jsr sysou  
        dec  m_word [_rc_]                      ; 
        js   call_209                           ; 
        dec  m_word [_rc_]                      ; } err 206 output caused file overflow 
        jns  _l0396                             ; 
        mov  m_word [_rc_],206                  ; 
        jmp  err_                               ; 
_l0396:                                         ; 
        dec  m_word [_rc_]                      ; } err 207 output caused non-recoverable error 
        jns  _l0397                             ; 
        mov  m_word [_rc_],207                  ; 
        jmp  err_                               ; 
_l0397:                                         ; 
call_209:                                       ; 
        mov  m_word [_rc_],0                    ; else all done, return to caller} exi   
        ret                                     ; 
asg12:
        call dtype                              ; call datatype routine} jsr dtype  
        jmp  asg11                              ; merge} brn asg11  
asg13:
        cmp  m_word [(cfp_b*trter)+xl],v_ter    ; jump if terminal output} beq trter(xl) =v_ter asg1a
        je   asg1a                              ; 
        inc  wa                                 ; signal standard output} icv wa  
        jmp  asg1a                              ; use sysou to perform output} brn asg1a  
asg14:
        mov  xl,m_word [(cfp_b*kvnum)+xl]       ; load keyword number} mov xl kvnum(xl) 
        cmp  xl,k_etx                           ; jump if errtext} beq xl =k_etx asg19
        je   asg19                              ; 
        mov  xr,wb                              ; copy value to be assigned} mov xr wb 
        call gtint                              ; convert to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_210                           ; 
        dec  m_word [_rc_]                      ; } err 208 keyword value assigned is not integer 
        jns  _l0398                             ; 
        mov  m_word [_rc_],208                  ; 
        jmp  err_                               ; 
_l0398:                                         ; 
call_210:                                       ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; else load value} ldi icval(xr)  
        cmp  xl,k_stl                           ; jump if special case of stlimit} beq xl =k_stl asg16
        je   asg16                              ; 
        test ia,ia                              ; else get addr integer, test ovflow} mfi wa asg18 
        js   asg18                              ; 
        mov  wa,ia                              ; 
        cmp  wa,m_word [mxlen]                  ; fail if too large} bgt wa mxlen asg18
        ja   asg18                              ; 
        cmp  xl,k_ert                           ; jump if special case of errtype} beq xl =k_ert asg17
        je   asg17                              ; 
        cmp  xl,k_pfl                           ; jump if special case of profile} beq xl =k_pfl asg21
        je   asg21                              ; 
        cmp  xl,k_mxl                           ; jump if special case of maxlngth} beq xl =k_mxl asg24
        je   asg24                              ; 
        cmp  xl,k_fls                           ; jump if special case of fullscan} beq xl =k_fls asg26
        je   asg26                              ; 
        cmp  xl,k_p__                           ; jump unless protected} blt xl =k_p__ asg15
        jb   asg15                              ; 
        mov  m_word [_rc_],209                  ; } erb 209 keyword in assignment is protected 
        jmp  err_                               ; 
asg15:
        mov  m_word [kvabe+xl],wa               ; store new value} mov kvabe(xl) wa 
        mov  m_word [_rc_],0                    ; return to asign caller} exi   
        ret                                     ; 
asg16:
        sub  ia,m_word [kvstl]                  ; subtract old limit} sbi kvstl  
        add  ia,m_word [kvstc]                  ; add old counter} adi kvstc  
        mov  m_word [kvstc],ia                  ; store course counter value} sti kvstc  
        mov  ia,m_word [kvstl]                  ; check if counting suppressed} ldi kvstl  
        cmp  ia,0                               ; do not refine if so} ilt asg25  
        jl   asg25                              ; 
        mov  wa,m_word [stmcs]                  ; refine with counter breakout} mov wa stmcs 
        sub  wa,m_word [stmct]                  ; values} sub wa stmct 
        mov  ia,wa                              ; convert to integer} mti wa  
        neg  ia                                 ; current-start value} ngi   
        add  ia,m_word [kvstc]                  ; add in course counter value} adi kvstc  
        mov  m_word [kvstc],ia                  ; save refined value} sti kvstc  
asg25:
        mov  ia,m_word [(cfp_b*icval)+xr]       ; reload new limit value} ldi icval(xr)  
        mov  m_word [kvstl],ia                  ; store new limit value} sti kvstl  
        call stgcc                              ; recompute countdown counters} jsr stgcc  
        mov  m_word [_rc_],0                    ; return to asign caller} exi   
        ret                                     ; 
asg17:
        cmp  wa,nini9                           ; ok to signal if in range} ble wa =nini9 error
        jbe  error                              ; 
asg18:
        mov  m_word [_rc_],210                  ; } erb 210 keyword value assigned is negative or too large 
        jmp  err_                               ; 
asg19:
        push wb                                 ; stack value} mov -(xs) wb 
        call gtstg                              ; convert to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_211                           ; 
        dec  m_word [_rc_]                      ; } err 211 value assigned to keyword errtext not a string 
        jns  _l0399                             ; 
        mov  m_word [_rc_],211                  ; 
        jmp  err_                               ; 
_l0399:                                         ; 
call_211:                                       ; 
        mov  m_word [r_etx],xr                  ; make assignment} mov r_etx xr 
        mov  m_word [_rc_],0                    ; return to caller} exi   
        ret                                     ; 
asg21:
        cmp  wa,num02                           ; moan if not 0,1, or 2} bgt wa =num02 asg18
        ja   asg18                              ; 
        test wa,wa                              ; just assign if zero} bze wa asg15 
        jz   asg15                              ; 
        cmp  m_word [pfdmp],0                   ; branch if first assignment} bze pfdmp asg22 
        jz   asg22                              ; 
        cmp  wa,m_word [pfdmp]                  ; also if same value as before} beq wa pfdmp asg23
        je   asg23                              ; 
        mov  m_word [_rc_],268                  ; } erb 268 inconsistent value assigned to keyword profile 
        jmp  err_                               ; 
asg22:
        mov  m_word [pfdmp],wa                  ; note value on first assignment} mov pfdmp wa 
asg23:
        mov  m_word [kvpfl],wa                  ; store new value} mov kvpfl wa 
        call stgcc                              ; recompute countdown counts} jsr stgcc  
        call systm                              ; get the time} jsr systm  
        mov  m_word [pfstm],ia                  ; fudge some kind of start time} sti pfstm  
        mov  m_word [_rc_],0                    ; return to asign caller} exi   
        ret                                     ; 
asg24:
        cmp  wa,mnlen                           ; if acceptable value} bge wa =mnlen asg15
        jae  asg15                              ; 
        mov  m_word [_rc_],287                  ; } erb 287 value assigned to keyword maxlngth is too small 
        jmp  err_                               ; 
asg26:
        test wa,wa                              ; if acceptable value} bnz wa asg15 
        jnz  asg15                              ; 
        mov  m_word [_rc_],274                  ; } erb 274 value assigned to keyword fullscan is zero 
        jmp  err_                               ; 
                                                ; end procedure asign} enp   
asinp:
                                                ; entry point, recursive} prc r 1 
        add  xl,wa                              ; point to variable} add xl wa 
        mov  xr,m_word [xl]                     ; load current contents} mov xr (xl) 
        cmp  m_word [xr],b_trt                  ; jump if trapped} beq (xr) =b_trt asnp1
        je   asnp1                              ; 
        mov  m_word [xl],wb                     ; else perform assignment} mov (xl) wb 
        xor  xl,xl                              ; clear garbage value in xl} zer xl  
        mov  m_word [_rc_],0                    ; return to asinp caller} exi   
        ret                                     ; 
asnp1:
        sub  xl,wa                              ; restore base pointer} sub xl wa 
        push m_word [pmssl]                     ; stack subject string length} mov -(xs) pmssl 
        push m_word [pmhbs]                     ; stack history stack base ptr} mov -(xs) pmhbs 
        push m_word [r_pms]                     ; stack subject string pointer} mov -(xs) r_pms 
        push m_word [pmdfl]                     ; stack dot flag} mov -(xs) pmdfl 
        call asign                              ; call full-blown assignment routine} jsr asign  
        dec  m_word [_rc_]                      ; 
        js   call_212                           ; 
        dec  m_word [_rc_]                      ; jump if failure} ppm asnp2  
        jns  _l0400                             ; 
        jmp  asnp2                              ; 
_l0400:                                         ; 
call_212:                                       ; 
        pop  m_word [pmdfl]                     ; restore dot flag} mov pmdfl (xs)+ 
        pop  m_word [r_pms]                     ; restore subject string pointer} mov r_pms (xs)+ 
        pop  m_word [pmhbs]                     ; restore history stack base pointer} mov pmhbs (xs)+ 
        pop  m_word [pmssl]                     ; restore subject string length} mov pmssl (xs)+ 
        mov  m_word [_rc_],0                    ; return to asinp caller} exi   
        ret                                     ; 
asnp2:
        pop  m_word [pmdfl]                     ; restore dot flag} mov pmdfl (xs)+ 
        pop  m_word [r_pms]                     ; restore subject string pointer} mov r_pms (xs)+ 
        pop  m_word [pmhbs]                     ; restore history stack base pointer} mov pmhbs (xs)+ 
        pop  m_word [pmssl]                     ; restore subject string length} mov pmssl (xs)+ 
        mov  m_word [_rc_],1                    ; take failure exit} exi 1  
        ret                                     ; 
                                                ; end procedure asinp} enp   
blkln:
                                                ; entry point} prc e 0 
        mov  xl,wa                              ; copy first word} mov xl wa 
        movzx xl,byte [xl-1]                    ; get entry id (bl_xx)} lei xl  
        cmp  xl,bl___                           ; switch on block type} bsw xl bl___ bln00
        jge  bln00                              ; 
        jmp  m_word [_l0401+xl*cfp_b]           ; 
        segment .data                           ; 
_l0401:                                         ; 
        d_word bln01                            ; arblk} iff bl_ar bln01 
        d_word bln12                            ; cdblk} iff bl_cd bln12 
        d_word bln12                            ; exblk} iff bl_ex bln12 
        d_word bln07                            ; icblk} iff bl_ic bln07 
        d_word bln03                            ; nmblk} iff bl_nm bln03 
        d_word bln02                            ; p0blk} iff bl_p0 bln02 
        d_word bln03                            ; p1blk} iff bl_p1 bln03 
        d_word bln04                            ; p2blk} iff bl_p2 bln04 
        d_word bln09                            ; rcblk} iff bl_rc bln09 
        d_word bln10                            ; scblk} iff bl_sc bln10 
        d_word bln02                            ; seblk} iff bl_se bln02 
        d_word bln01                            ; tbblk} iff bl_tb bln01 
        d_word bln01                            ; vcblk} iff bl_vc bln01 
        d_word bln00                            ; } iff 13 bln00 
        d_word bln00                            ; } iff 14 bln00 
        d_word bln00                            ; } iff 15 bln00 
        d_word bln08                            ; pdblk} iff bl_pd bln08 
        d_word bln05                            ; trblk} iff bl_tr bln05 
        d_word bln00                            ; } iff 18 bln00 
        d_word bln00                            ; } iff 19 bln00 
        d_word bln00                            ; } iff 20 bln00 
        d_word bln06                            ; ctblk} iff bl_ct bln06 
        d_word bln01                            ; dfblk} iff bl_df bln01 
        d_word bln01                            ; efblk} iff bl_ef bln01 
        d_word bln03                            ; evblk} iff bl_ev bln03 
        d_word bln05                            ; ffblk} iff bl_ff bln05 
        d_word bln03                            ; kvblk} iff bl_kv bln03 
        d_word bln01                            ; pfblk} iff bl_pf bln01 
        d_word bln04                            ; teblk} iff bl_te bln04 
        segment .text                           ; end of jump table on block type} esw   
bln00:
        mov  wa,m_word [(cfp_b*num01)+xr]       ; load length} mov wa num01(xr) 
        ret                                     ; return to blkln caller} exi   
bln01:
        mov  wa,m_word [(cfp_b*num02)+xr]       ; load length from third word} mov wa num02(xr) 
        ret                                     ; return to blkln caller} exi   
bln02:
        mov  wa,cfp_b*num02                     ; load length (two words)} mov wa *num02 
        ret                                     ; return to blkln caller} exi   
bln03:
        mov  wa,cfp_b*num03                     ; load length (three words)} mov wa *num03 
        ret                                     ; return to blkln caller} exi   
bln04:
        mov  wa,cfp_b*num04                     ; load length (four words)} mov wa *num04 
        ret                                     ; return to blkln caller} exi   
bln05:
        mov  wa,cfp_b*num05                     ; load length} mov wa *num05 
        ret                                     ; return to blkln caller} exi   
bln06:
        mov  wa,cfp_b*ctsi_                     ; set size of ctblk} mov wa *ctsi_ 
        ret                                     ; return to blkln caller} exi   
bln07:
        mov  wa,cfp_b*icsi_                     ; set size of icblk} mov wa *icsi_ 
        ret                                     ; return to blkln caller} exi   
bln08:
        mov  xl,m_word [(cfp_b*pddfp)+xr]       ; point to dfblk} mov xl pddfp(xr) 
        mov  wa,m_word [(cfp_b*dfpdl)+xl]       ; load pdblk length from dfblk} mov wa dfpdl(xl) 
        ret                                     ; return to blkln caller} exi   
bln09:
        mov  wa,cfp_b*rcsi_                     ; set size of rcblk} mov wa *rcsi_ 
        ret                                     ; return to blkln caller} exi   
bln10:
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; load length in characters} mov wa sclen(xr) 
        add  wa,(cfp_b-1)+cfp_b*scsi_           ; calculate length in bytes} ctb wa scsi_ 
        and  wa,-cfp_b                          ; 
        ret                                     ; return to blkln caller} exi   
bln12:
        mov  wa,m_word [(cfp_b*num03)+xr]       ; load length from cdlen/exlen} mov wa num03(xr) 
        ret                                     ; return to blkln caller} exi   
                                                ; end procedure blkln} enp   
copyb:
        pop  m_word [prc_+cfp_b*2]              ; entry point} prc n 1 
        mov  xr,m_word [xs]                     ; load argument} mov xr (xs) 
        cmp  xr,nulls                           ; return argument if it is null} beq xr =nulls cop10
        je   cop10                              ; 
        mov  wa,m_word [xr]                     ; else load type word} mov wa (xr) 
        mov  wb,wa                              ; copy type word} mov wb wa 
        call blkln                              ; get length of argument block} jsr blkln  
        mov  xl,xr                              ; copy pointer} mov xl xr 
        call alloc                              ; allocate block of same size} jsr alloc  
        mov  m_word [xs],xr                     ; store pointer to copy} mov (xs) xr 
        shr  wa,log_cfp_b                       ; copy contents of old block to new} mvw   
        rep  movs_w                             ; 
        xor  xl,xl                              ; clear garbage xl} zer xl  
        mov  xr,m_word [xs]                     ; reload pointer to start of copy} mov xr (xs) 
        cmp  wb,b_tbt                           ; jump if table} beq wb =b_tbt cop05
        je   cop05                              ; 
        cmp  wb,b_vct                           ; jump if vector} beq wb =b_vct cop01
        je   cop01                              ; 
        cmp  wb,b_pdt                           ; jump if program defined} beq wb =b_pdt cop01
        je   cop01                              ; 
        cmp  wb,b_art                           ; return copy if not array} bne wb =b_art cop10
        jne  cop10                              ; 
        add  xr,m_word [(cfp_b*arofs)+xr]       ; point to prototype field} add xr arofs(xr) 
        jmp  cop02                              ; jump to merge} brn cop02  
cop01:
        add  xr,cfp_b*pdfld                     ; point to pdfld = vcvls} add xr *pdfld 
cop02:
        mov  xl,m_word [xr]                     ; load next pointer} mov xl (xr) 
cop03:
        cmp  m_word [xl],b_trt                  ; jump if not trapped} bne (xl) =b_trt cop04
        jne  cop04                              ; 
        mov  xl,m_word [(cfp_b*trval)+xl]       ; else point to next value} mov xl trval(xl) 
        jmp  cop03                              ; and loop back} brn cop03  
cop04:
        mov  w0,xl                              ; store real value, bump pointer} mov (xr)+ xl 
        stos_w                                  ; 
        cmp  xr,m_word [dnamp]                  ; loop back if more to go} bne xr dnamp cop02
        jne  cop02                              ; 
        jmp  cop09                              ; else jump to exit} brn cop09  
cop05:
        xor  w0,w0                              ; zero id to stop dump blowing up} zer idval(xr)  
        mov  m_word [(cfp_b*idval)+xr],w0       ; 
        mov  wa,cfp_b*tesi_                     ; set size of teblk} mov wa *tesi_ 
        mov  wc,cfp_b*tbbuk                     ; set initial offset} mov wc *tbbuk 
cop06:
        mov  xr,m_word [xs]                     ; load table pointer} mov xr (xs) 
        cmp  wc,m_word [(cfp_b*tblen)+xr]       ; jump to exit if all done} beq wc tblen(xr) cop09
        je   cop09                              ; 
        mov  wb,wc                              ; else copy offset} mov wb wc 
        sub  wb,cfp_b*tenxt                     ; subtract link offset to merge} sub wb *tenxt 
        add  xr,wb                              ; next bucket header less link offset} add xr wb 
        add  wc,cfp_b                           ; bump offset} ica wc  
cop07:
        mov  xl,m_word [(cfp_b*tenxt)+xr]       ; load pointer to next teblk} mov xl tenxt(xr) 
        mov  w0,m_word [xs]                     ; set end of chain pointer in case} mov tenxt(xr) (xs) 
        mov  m_word [(cfp_b*tenxt)+xr],w0       ; 
        cmp  m_word [xl],b_tbt                  ; back for next bucket if chain end} beq (xl) =b_tbt cop06
        je   cop06                              ; 
        sub  xr,wb                              ; point to head of previous block} sub xr wb 
        push xr                                 ; stack ptr to previous block} mov -(xs) xr 
        mov  wa,cfp_b*tesi_                     ; set size of teblk} mov wa *tesi_ 
        call alloc                              ; allocate new teblk} jsr alloc  
        push xr                                 ; stack ptr to new teblk} mov -(xs) xr 
        shr  wa,log_cfp_b                       ; copy old teblk to new teblk} mvw   
        rep  movs_w                             ; 
        pop  xr                                 ; restore pointer to new teblk} mov xr (xs)+ 
        pop  xl                                 ; restore pointer to previous block} mov xl (xs)+ 
        add  xl,wb                              ; add offset back in} add xl wb 
        mov  m_word [(cfp_b*tenxt)+xl],xr       ; link new block to previous} mov tenxt(xl) xr 
        mov  xl,xr                              ; copy pointer to new block} mov xl xr 
cop08:
        mov  xl,m_word [(cfp_b*teval)+xl]       ; load value} mov xl teval(xl) 
        cmp  m_word [xl],b_trt                  ; loop back if trapped} beq (xl) =b_trt cop08
        je   cop08                              ; 
        mov  m_word [(cfp_b*teval)+xr],xl       ; store untrapped value in teblk} mov teval(xr) xl 
        xor  wb,wb                              ; zero offset within teblk} zer wb  
        jmp  cop07                              ; back for next teblk} brn cop07  
cop09:
        pop  xr                                 ; load pointer to block} mov xr (xs)+ 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*2]           ; 
        jmp  w0                                 ; 
cop10:
        mov  m_word [_rc_],1                    ; return} exi 1  
        mov  w0,m_word [prc_+cfp_b*2]           ; 
        jmp  w0                                 ; 
                                                ; end procedure copyb} enp   
cdgcg:
                                                ; entry point} prc e 0 
        mov  xl,m_word [(cfp_b*cmopn)+xr]       ; get unary goto operator} mov xl cmopn(xr) 
        mov  xr,m_word [(cfp_b*cmrop)+xr]       ; point to goto operand} mov xr cmrop(xr) 
        cmp  xl,opdvd                           ; jump if direct goto} beq xl =opdvd cdgc2
        je   cdgc2                              ; 
        call cdgnm                              ; generate opnd by name if not direct} jsr cdgnm  
cdgc1:
        mov  wa,xl                              ; goto operator} mov wa xl 
        call cdwrd                              ; generate it} jsr cdwrd  
        ret                                     ; return to caller} exi   
cdgc2:
        call cdgvl                              ; generate operand by value} jsr cdgvl  
        jmp  cdgc1                              ; merge to return} brn cdgc1  
                                                ; end procedure cdgcg} enp   
cdgex:
                                                ; entry point, recursive} prc r 0 
        cmp  m_word [xl],b_vr_                  ; jump if not variable} blo (xl) =b_vr_ cdgx1
        jb   cdgx1                              ; 
        mov  wa,cfp_b*sesi_                     ; set size of seblk} mov wa *sesi_ 
        call alloc                              ; allocate space for seblk} jsr alloc  
        mov  m_word [xr],b_sel                  ; set type word} mov (xr) =b_sel 
        mov  m_word [(cfp_b*sevar)+xr],xl       ; store vrblk pointer} mov sevar(xr) xl 
        ret                                     ; return to cdgex caller} exi   
cdgx1:
        mov  xr,xl                              ; copy tree pointer} mov xr xl 
        push wc                                 ; save wc} mov -(xs) wc 
        mov  xl,m_word [cwcof]                  ; save current offset} mov xl cwcof 
        test wa,wa                              ; jump if by value} bze wa cdgx2 
        jz   cdgx2                              ; 
        mov  wa,m_word [xr]                     ; get type word} mov wa (xr) 
        cmp  wa,b_cmt                           ; call by value if not cmblk} bne wa =b_cmt cdgx2
        jne  cdgx2                              ; 
        cmp  m_word [(cfp_b*cmtyp)+xr],c__nm    ; jump if cmblk only by value} bge cmtyp(xr) =c__nm cdgx2
        jae  cdgx2                              ; 
        call cdgnm                              ; generate code by name} jsr cdgnm  
        mov  wa,ornm_                           ; load return by name word} mov wa =ornm_ 
        jmp  cdgx3                              ; merge with value case} brn cdgx3  
cdgx2:
        call cdgvl                              ; generate code by value} jsr cdgvl  
        mov  wa,orvl_                           ; load return by value word} mov wa =orvl_ 
cdgx3:
        call cdwrd                              ; generate return word} jsr cdwrd  
        call exbld                              ; build exblk} jsr exbld  
        pop  wc                                 ; restore wc} mov wc (xs)+ 
        ret                                     ; return to cdgex caller} exi   
                                                ; end procedure cdgex} enp   
cdgnm:
                                                ; entry point, recursive} prc r 0 
        push xl                                 ; save entry xl} mov -(xs) xl 
        push wb                                 ; save entry wb} mov -(xs) wb 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0402                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0402:                                         ; 
        mov  wa,m_word [xr]                     ; load type word} mov wa (xr) 
        cmp  wa,b_cmt                           ; jump if cmblk} beq wa =b_cmt cgn04
        je   cgn04                              ; 
        cmp  wa,b_vr_                           ; jump if simple variable} bhi wa =b_vr_ cgn02
        ja   cgn02                              ; 
cgn01:
        mov  m_word [_rc_],212                  ; } erb 212 syntax error: value used where name is required 
        jmp  err_                               ; 
cgn02:
        mov  wa,olvn_                           ; load variable load call} mov wa =olvn_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  wa,xr                              ; copy vrblk pointer} mov wa xr 
        call cdwrd                              ; generate vrblk pointer} jsr cdwrd  
cgn03:
        pop  wb                                 ; restore entry wb} mov wb (xs)+ 
        pop  xl                                 ; restore entry xl} mov xl (xs)+ 
        ret                                     ; return to cdgnm caller} exi   
cgn04:
        mov  xl,xr                              ; copy cmblk pointer} mov xl xr 
        mov  xr,m_word [(cfp_b*cmtyp)+xr]       ; load cmblk type} mov xr cmtyp(xr) 
        cmp  xr,c__nm                           ; error if not name operand} bge xr =c__nm cgn01
        jae  cgn01                              ; 
        jmp  m_word [_l0403+xr*cfp_b]           ; else switch on type} bsw xr c__nm 
        segment .data                           ; 
_l0403:                                         ; 
        d_word cgn05                            ; array reference} iff c_arr cgn05 
        d_word cgn08                            ; function call} iff c_fnc cgn08 
        d_word cgn09                            ; deferred expression} iff c_def cgn09 
        d_word cgn10                            ; indirect reference} iff c_ind cgn10 
        d_word cgn11                            ; keyword reference} iff c_key cgn11 
        d_word cgn08                            ; undefined binary op} iff c_ubo cgn08 
        d_word cgn08                            ; undefined unary op} iff c_uuo cgn08 
        segment .text                           ; end switch on cmblk type} esw   
cgn05:
        mov  wb,cfp_b*cmopn                     ; point to array operand} mov wb *cmopn 
cgn06:
        call cmgen                              ; generate code for next operand} jsr cmgen  
        mov  wc,m_word [(cfp_b*cmlen)+xl]       ; load length of cmblk} mov wc cmlen(xl) 
        cmp  wb,wc                              ; loop till all generated} blt wb wc cgn06
        jb   cgn06                              ; 
        mov  wa,oaon_                           ; load one-subscript case call} mov wa =oaon_ 
        cmp  wc,cfp_b*cmar1                     ; jump to exit if one subscript case} beq wc *cmar1 cgn07
        je   cgn07                              ; 
        mov  wa,oamn_                           ; else load multi-subscript case call} mov wa =oamn_ 
        call cdwrd                              ; generate call} jsr cdwrd  
        mov  wa,wc                              ; copy cmblk length} mov wa wc 
        shr  wa,log_cfp_b                       ; convert to words} btw wa  
        sub  wa,cmvls                           ; calculate number of subscripts} sub wa =cmvls 
cgn07:
        mov  wc,xs                              ; set result non-constant} mnz wc  
        call cdwrd                              ; generate word} jsr cdwrd  
        jmp  cgn03                              ; back to exit} brn cgn03  
cgn08:
        mov  xr,xl                              ; copy cmblk pointer} mov xr xl 
        call cdgvl                              ; gen code by value for call} jsr cdgvl  
        mov  wa,ofne_                           ; get extra call for by name} mov wa =ofne_ 
        jmp  cgn07                              ; back to generate and exit} brn cgn07  
cgn09:
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; check if variable} mov xr cmrop(xl) 
        cmp  m_word [xr],b_vr_                  ; treat *variable as simple var} bhi (xr) =b_vr_ cgn02
        ja   cgn02                              ; 
        mov  xl,xr                              ; copy ptr to expression tree} mov xl xr 
        mov  wa,num01                           ; return name} mov wa =num01 
        call cdgex                              ; else build exblk} jsr cdgex  
        mov  wa,olex_                           ; set call to load expr by name} mov wa =olex_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  wa,xr                              ; copy exblk pointer} mov wa xr 
        call cdwrd                              ; generate exblk pointer} jsr cdwrd  
        jmp  cgn03                              ; back to exit} brn cgn03  
cgn10:
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; get operand} mov xr cmrop(xl) 
        call cdgvl                              ; generate code by value for it} jsr cdgvl  
        mov  wa,oinn_                           ; load call for indirect by name} mov wa =oinn_ 
        jmp  cgn12                              ; merge} brn cgn12  
cgn11:
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; get operand} mov xr cmrop(xl) 
        call cdgnm                              ; generate code by name for it} jsr cdgnm  
        mov  wa,okwn_                           ; load call for keyword by name} mov wa =okwn_ 
cgn12:
        call cdwrd                              ; generate code for operator} jsr cdwrd  
        jmp  cgn03                              ; exit} brn cgn03  
                                                ; end procedure cdgnm} enp   
cdgvl:
                                                ; entry point, recursive} prc r 0 
        mov  wa,m_word [xr]                     ; load type word} mov wa (xr) 
        cmp  wa,b_cmt                           ; jump if cmblk} beq wa =b_cmt cgv01
        je   cgv01                              ; 
        cmp  wa,b_vra                           ; jump if icblk, rcblk, scblk} blt wa =b_vra cgv00
        jb   cgv00                              ; 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; jump if not system variable} bnz vrlen(xr) cgvl0 
        jnz  cgvl0                              ; 
        push xr                                 ; stack xr} mov -(xs) xr 
        mov  xr,m_word [(cfp_b*vrsvp)+xr]       ; point to svblk} mov xr vrsvp(xr) 
        mov  wa,m_word [(cfp_b*svbit)+xr]       ; get svblk property bits} mov wa svbit(xr) 
        pop  xr                                 ; recover xr} mov xr (xs)+ 
        and  wa,m_word [btkwv]                  ; check if constant keyword value} anb wa btkwv 
        cmp  wa,m_word [btkwv]                  ; jump if constant keyword value} beq wa btkwv cgv00
        je   cgv00                              ; 
cgvl0:
        mov  wc,xs                              ; indicate non-constant value} mnz wc  
cgv00:
        mov  wa,xr                              ; copy ptr to var or constant} mov wa xr 
        call cdwrd                              ; generate as code word} jsr cdwrd  
        ret                                     ; return to caller} exi   
cgv01:
        push wb                                 ; save entry wb} mov -(xs) wb 
        push xl                                 ; save entry xl} mov -(xs) xl 
        push wc                                 ; save entry constant flag} mov -(xs) wc 
        push m_word [cwcof]                     ; save initial code offset} mov -(xs) cwcof 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0404                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0404:                                         ; 
        mov  xl,xr                              ; copy cmblk pointer} mov xl xr 
        mov  xr,m_word [(cfp_b*cmtyp)+xr]       ; load cmblk type} mov xr cmtyp(xr) 
        mov  wc,m_word [cswno]                  ; reset constant flag} mov wc cswno 
        cmp  xr,c_pr_                           ; jump if not predicate value} ble xr =c_pr_ cgv02
        jbe  cgv02                              ; 
        mov  wc,xs                              ; else force non-constant case} mnz wc  
cgv02:
        jmp  m_word [_l0405+xr*cfp_b]           ; switch to appropriate generator} bsw xr c__nv 
        segment .data                           ; 
_l0405:                                         ; 
        d_word cgv03                            ; array reference} iff c_arr cgv03 
        d_word cgv05                            ; function call} iff c_fnc cgv05 
        d_word cgv14                            ; deferred expression} iff c_def cgv14 
        d_word cgv31                            ; indirect reference} iff c_ind cgv31 
        d_word cgv27                            ; keyword reference} iff c_key cgv27 
        d_word cgv29                            ; undefined binop} iff c_ubo cgv29 
        d_word cgv30                            ; undefined unop} iff c_uuo cgv30 
        d_word cgv18                            ; binops with val opds} iff c_bvl cgv18 
        d_word cgv19                            ; unops with valu opnd} iff c_uvl cgv19 
        d_word cgv18                            ; alternation} iff c_alt cgv18 
        d_word cgv24                            ; concatenation} iff c_cnc cgv24 
        d_word cgv24                            ; concatenation (not pattern match)} iff c_cnp cgv24 
        d_word cgv27                            ; unops with name opnd} iff c_unm cgv27 
        d_word cgv26                            ; binary _ and .} iff c_bvn cgv26 
        d_word cgv21                            ; assignment} iff c_ass cgv21 
        d_word cgv31                            ; interrogation} iff c_int cgv31 
        d_word cgv28                            ; negation} iff c_neg cgv28 
        d_word cgv15                            ; selection} iff c_sel cgv15 
        d_word cgv18                            ; pattern match} iff c_pmt cgv18 
        segment .text                           ; end switch on cmblk type} esw   
cgv03:
        mov  wb,cfp_b*cmopn                     ; set offset to array operand} mov wb *cmopn 
cgv04:
        call cmgen                              ; gen value code for next operand} jsr cmgen  
        mov  wc,m_word [(cfp_b*cmlen)+xl]       ; load cmblk length} mov wc cmlen(xl) 
        cmp  wb,wc                              ; loop back if more to go} blt wb wc cgv04
        jb   cgv04                              ; 
        mov  wa,oaov_                           ; set one subscript call in case} mov wa =oaov_ 
        cmp  wc,cfp_b*cmar1                     ; jump to exit if 1-sub case} beq wc *cmar1 cgv32
        je   cgv32                              ; 
        mov  wa,oamv_                           ; else set call for multi-subscripts} mov wa =oamv_ 
        call cdwrd                              ; generate call} jsr cdwrd  
        mov  wa,wc                              ; copy length of cmblk} mov wa wc 
        sub  wa,cfp_b*cmvls                     ; subtract standard length} sub wa *cmvls 
        shr  wa,log_cfp_b                       ; get number of words} btw wa  
        jmp  cgv32                              ; jump to generate subscript count} brn cgv32  
cgv05:
        mov  wb,cfp_b*cmvls                     ; set offset to first argument} mov wb *cmvls 
cgv06:
        cmp  wb,m_word [(cfp_b*cmlen)+xl]       ; jump if all generated} beq wb cmlen(xl) cgv07
        je   cgv07                              ; 
        call cmgen                              ; else gen value code for next arg} jsr cmgen  
        jmp  cgv06                              ; back to generate next argument} brn cgv06  
cgv07:
        sub  wb,cfp_b*cmvls                     ; get number of arg ptrs (bytes)} sub wb *cmvls 
        shr  wb,log_cfp_b                       ; convert bytes to words} btw wb  
        mov  xr,m_word [(cfp_b*cmopn)+xl]       ; load function vrblk pointer} mov xr cmopn(xl) 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; jump if not system function} bnz vrlen(xr) cgv12 
        jnz  cgv12                              ; 
        mov  xl,m_word [(cfp_b*vrsvp)+xr]       ; load svblk ptr if system var} mov xl vrsvp(xr) 
        mov  wa,m_word [(cfp_b*svbit)+xl]       ; load bit mask} mov wa svbit(xl) 
        and  wa,m_word [btffc]                  ; test for fast function call allowed} anb wa btffc 
        test wa,wa                              ; jump if not} zrb wa cgv12 
        jz   cgv12                              ; 
        mov  wa,m_word [(cfp_b*svbit)+xl]       ; reload bit indicators} mov wa svbit(xl) 
        and  wa,m_word [btpre]                  ; test for preevaluation ok} anb wa btpre 
        test wa,wa                              ; jump if preevaluation permitted} nzb wa cgv08 
        jnz  cgv08                              ; 
        mov  wc,xs                              ; else set result non-constant} mnz wc  
cgv08:
        mov  xl,m_word [(cfp_b*vrfnc)+xr]       ; load ptr to svfnc field} mov xl vrfnc(xr) 
        mov  wa,m_word [(cfp_b*fargs)+xl]       ; load svnar field value} mov wa fargs(xl) 
        cmp  wa,wb                              ; jump if argument count is correct} beq wa wb cgv11
        je   cgv11                              ; 
        cmp  wa,wb                              ; jump if too few arguments given} bhi wa wb cgv09
        ja   cgv09                              ; 
        sub  wb,wa                              ; get number of extra args} sub wb wa 
        mov  wa,opop_                           ; set pop call} mov wa =opop_ 
        jmp  cgv10                              ; jump to common loop} brn cgv10  
cgv09:
        sub  wa,wb                              ; get number of missing arguments} sub wa wb 
        mov  wb,wa                              ; load as count to control loop} lct wb wa 
        mov  wa,nulls                           ; load ptr to null constant} mov wa =nulls 
cgv10:
        call cdwrd                              ; generate one call} jsr cdwrd  
        dec  wb                                 ; loop till all generated} bct wb cgv10 
        jnz  cgv10                              ; 
cgv11:
        mov  wa,xl                              ; copy pointer to svfnc field} mov wa xl 
        jmp  cgv36                              ; jump to generate call} brn cgv36  
cgv12:
        mov  wa,ofns_                           ; set one arg call in case} mov wa =ofns_ 
        cmp  wb,num01                           ; jump if one arg case} beq wb =num01 cgv13
        je   cgv13                              ; 
        mov  wa,ofnc_                           ; else load call for more than 1 arg} mov wa =ofnc_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  wa,wb                              ; copy argument count} mov wa wb 
cgv13:
        call cdwrd                              ; generate =o_fns or arg count} jsr cdwrd  
        mov  wa,xr                              ; copy vrblk pointer} mov wa xr 
        jmp  cgv32                              ; jump to generate vrblk ptr} brn cgv32  
cgv14:
        mov  xl,m_word [(cfp_b*cmrop)+xl]       ; point to expression tree} mov xl cmrop(xl) 
        xor  wa,wa                              ; return value} zer wa  
        call cdgex                              ; build exblk or seblk} jsr cdgex  
        mov  wa,xr                              ; copy block ptr} mov wa xr 
        call cdwrd                              ; generate ptr to exblk or seblk} jsr cdwrd  
        jmp  cgv34                              ; jump to exit, constant test} brn cgv34  
cgv15:
        push 0                                  ; zero ptr to chain of forward jumps} zer -(xs)  
        push 0                                  ; zero ptr to prev o_slc forward ptr} zer -(xs)  
        mov  wb,cfp_b*cmvls                     ; point to first alternative} mov wb *cmvls 
        mov  wa,osla_                           ; set initial code word} mov wa =osla_ 
cgv16:
        call cdwrd                              ; generate o_slc (o_sla first time)} jsr cdwrd  
        mov  w0,m_word [cwcof]                  ; set current loc as ptr to fill in} mov (xs) cwcof 
        mov  m_word [xs],w0                     ; 
        call cdwrd                              ; generate garbage word there for now} jsr cdwrd  
        call cmgen                              ; gen value code for alternative} jsr cmgen  
        mov  wa,oslb_                           ; load o_slb pointer} mov wa =oslb_ 
        call cdwrd                              ; generate o_slb call} jsr cdwrd  
        mov  wa,m_word [(cfp_b*num01)+xs]       ; load old chain ptr} mov wa num01(xs) 
        mov  w0,m_word [cwcof]                  ; set current loc as new chain head} mov num01(xs) cwcof 
        mov  m_word [(cfp_b*num01)+xs],w0       ; 
        call cdwrd                              ; generate forward chain link} jsr cdwrd  
        mov  xr,m_word [xs]                     ; load offset to word to plug} mov xr (xs) 
        add  xr,m_word [r_ccb]                  ; point to actual location to plug} add xr r_ccb 
        mov  w0,m_word [cwcof]                  ; plug proper offset in} mov (xr) cwcof 
        mov  m_word [xr],w0                     ; 
        mov  wa,oslc_                           ; load o_slc ptr for next alternative} mov wa =oslc_ 
        mov  xr,wb                              ; copy offset (destroy garbage xr)} mov xr wb 
        add  xr,cfp_b                           ; bump extra time for test} ica xr  
        cmp  xr,m_word [(cfp_b*cmlen)+xl]       ; loop back if not last alternative} blt xr cmlen(xl) cgv16
        jb   cgv16                              ; 
        mov  wa,osld_                           ; get header call} mov wa =osld_ 
        call cdwrd                              ; generate o_sld call} jsr cdwrd  
        call cmgen                              ; generate code for last alternative} jsr cmgen  
        add  xs,cfp_b                           ; pop offset ptr} ica xs  
        pop  xr                                 ; load chain ptr} mov xr (xs)+ 
cgv17:
        add  xr,m_word [r_ccb]                  ; make next ptr absolute} add xr r_ccb 
        mov  wa,m_word [xr]                     ; load forward ptr} mov wa (xr) 
        mov  w0,m_word [cwcof]                  ; plug required offset} mov (xr) cwcof 
        mov  m_word [xr],w0                     ; 
        mov  xr,wa                              ; copy forward ptr} mov xr wa 
        test wa,wa                              ; loop back if more to go} bnz wa cgv17 
        jnz  cgv17                              ; 
        jmp  cgv33                              ; else jump to exit (not constant)} brn cgv33  
cgv18:
        mov  xr,m_word [(cfp_b*cmlop)+xl]       ; load left operand pointer} mov xr cmlop(xl) 
        call cdgvl                              ; gen value code for left operand} jsr cdgvl  
cgv19:
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load right (only) operand ptr} mov xr cmrop(xl) 
        call cdgvl                              ; gen code by value} jsr cdgvl  
cgv20:
        mov  wa,m_word [(cfp_b*cmopn)+xl]       ; load operator call pointer} mov wa cmopn(xl) 
        jmp  cgv36                              ; jump to generate it with cons test} brn cgv36  
cgv21:
        mov  xr,m_word [(cfp_b*cmlop)+xl]       ; load left operand pointer} mov xr cmlop(xl) 
        cmp  m_word [xr],b_vr_                  ; jump if not variable} blo (xr) =b_vr_ cgv22
        jb   cgv22                              ; 
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load right operand ptr} mov xr cmrop(xl) 
        call cdgvl                              ; generate code by value} jsr cdgvl  
        mov  wa,m_word [(cfp_b*cmlop)+xl]       ; reload left operand vrblk ptr} mov wa cmlop(xl) 
        add  wa,cfp_b*vrsto                     ; point to vrsto field} add wa *vrsto 
        jmp  cgv32                              ; jump to generate store ptr} brn cgv32  
cgv22:
        call expap                              ; test for pattern match on left side} jsr expap  
        dec  m_word [_rc_]                      ; 
        js   call_213                           ; 
        dec  m_word [_rc_]                      ; jump if not pattern match} ppm cgv23  
        jns  _l0406                             ; 
        jmp  cgv23                              ; 
_l0406:                                         ; 
call_213:                                       ; 
        mov  w0,m_word [(cfp_b*cmrop)+xr]       ; save pattern ptr in safe place} mov cmlop(xl) cmrop(xr) 
        mov  m_word [(cfp_b*cmlop)+xl],w0       ; 
        mov  xr,m_word [(cfp_b*cmlop)+xr]       ; load subject ptr} mov xr cmlop(xr) 
        call cdgnm                              ; gen code by name for subject} jsr cdgnm  
        mov  xr,m_word [(cfp_b*cmlop)+xl]       ; load pattern ptr} mov xr cmlop(xl) 
        call cdgvl                              ; gen code by value for pattern} jsr cdgvl  
        mov  wa,opmn_                           ; load match by name call} mov wa =opmn_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load replacement value ptr} mov xr cmrop(xl) 
        call cdgvl                              ; gen code by value} jsr cdgvl  
        mov  wa,orpl_                           ; load replace call} mov wa =orpl_ 
        jmp  cgv32                              ; jump to gen and exit (not constant)} brn cgv32  
cgv23:
        mov  wc,xs                              ; inhibit pre-evaluation} mnz wc  
        call cdgnm                              ; gen code by name for left side} jsr cdgnm  
        jmp  cgv31                              ; merge with unop circuit} brn cgv31  
cgv24:
        mov  xr,m_word [(cfp_b*cmlop)+xl]       ; load left operand ptr} mov xr cmlop(xl) 
        cmp  m_word [xr],b_cmt                  ; ordinary binop if not cmblk} bne (xr) =b_cmt cgv18
        jne  cgv18                              ; 
        mov  wb,m_word [(cfp_b*cmtyp)+xr]       ; load cmblk type code} mov wb cmtyp(xr) 
        cmp  wb,c_int                           ; special case if interrogation} beq wb =c_int cgv25
        je   cgv25                              ; 
        cmp  wb,c_neg                           ; or negation} beq wb =c_neg cgv25
        je   cgv25                              ; 
        cmp  wb,c_fnc                           ; else ordinary binop if not function} bne wb =c_fnc cgv18
        jne  cgv18                              ; 
        mov  xr,m_word [(cfp_b*cmopn)+xr]       ; else load function vrblk ptr} mov xr cmopn(xr) 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; ordinary binop if not system var} bnz vrlen(xr) cgv18 
        jnz  cgv18                              ; 
        mov  xr,m_word [(cfp_b*vrsvp)+xr]       ; else point to svblk} mov xr vrsvp(xr) 
        mov  wa,m_word [(cfp_b*svbit)+xr]       ; load bit indicators} mov wa svbit(xr) 
        and  wa,m_word [btprd]                  ; test for predicate function} anb wa btprd 
        test wa,wa                              ; ordinary binop if not} zrb wa cgv18 
        jz   cgv18                              ; 
cgv25:
        mov  xr,m_word [(cfp_b*cmlop)+xl]       ; reload left arg} mov xr cmlop(xl) 
        call cdgvl                              ; gen code by value} jsr cdgvl  
        mov  wa,opop_                           ; load pop call} mov wa =opop_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load right operand} mov xr cmrop(xl) 
        call cdgvl                              ; gen code by value as result code} jsr cdgvl  
        jmp  cgv33                              ; exit (not constant)} brn cgv33  
cgv26:
        mov  xr,m_word [(cfp_b*cmlop)+xl]       ; load left operand} mov xr cmlop(xl) 
        call cdgvl                              ; gen code by value, merge} jsr cdgvl  
cgv27:
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load right operand ptr} mov xr cmrop(xl) 
        call cdgnm                              ; gen code by name for right arg} jsr cdgnm  
        mov  xr,m_word [(cfp_b*cmopn)+xl]       ; get operator code word} mov xr cmopn(xl) 
        cmp  m_word [xr],o_kwv                  ; gen call unless keyword value} bne (xr) =o_kwv cgv20
        jne  cgv20                              ; 
        test wc,wc                              ; gen call if non-constant (not var)} bnz wc cgv20 
        jnz  cgv20                              ; 
        mov  wc,xs                              ; else set non-constant in case} mnz wc  
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load ptr to operand vrblk} mov xr cmrop(xl) 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; gen (non-constant) if not sys var} bnz vrlen(xr) cgv20 
        jnz  cgv20                              ; 
        mov  xr,m_word [(cfp_b*vrsvp)+xr]       ; else load ptr to svblk} mov xr vrsvp(xr) 
        mov  wa,m_word [(cfp_b*svbit)+xr]       ; load bit mask} mov wa svbit(xr) 
        and  wa,m_word [btckw]                  ; test for constant keyword} anb wa btckw 
        test wa,wa                              ; go gen if not constant} zrb wa cgv20 
        jz   cgv20                              ; 
        xor  wc,wc                              ; else set result constant} zer wc  
        jmp  cgv20                              ; and jump back to generate call} brn cgv20  
cgv28:
        mov  wa,onta_                           ; get initial word} mov wa =onta_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  wb,m_word [cwcof]                  ; save next offset} mov wb cwcof 
        call cdwrd                              ; generate gunk word for now} jsr cdwrd  
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load right operand ptr} mov xr cmrop(xl) 
        call cdgvl                              ; gen code by value} jsr cdgvl  
        mov  wa,ontb_                           ; load end of evaluation call} mov wa =ontb_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  xr,wb                              ; copy offset to word to plug} mov xr wb 
        add  xr,m_word [r_ccb]                  ; point to actual word to plug} add xr r_ccb 
        mov  w0,m_word [cwcof]                  ; plug word with current offset} mov (xr) cwcof 
        mov  m_word [xr],w0                     ; 
        mov  wa,ontc_                           ; load final call} mov wa =ontc_ 
        jmp  cgv32                              ; jump to generate it (not constant)} brn cgv32  
cgv29:
        mov  xr,m_word [(cfp_b*cmlop)+xl]       ; load left operand ptr} mov xr cmlop(xl) 
        call cdgvl                              ; generate code by value} jsr cdgvl  
cgv30:
        mov  wb,c_uo_                           ; set unop code + 1} mov wb =c_uo_ 
        sub  wb,m_word [(cfp_b*cmtyp)+xl]       ; set number of args (1 or 2)} sub wb cmtyp(xl) 
        mov  xr,m_word [(cfp_b*cmrop)+xl]       ; load right (only) operand pointer} mov xr cmrop(xl) 
        call cdgvl                              ; gen value code for right operand} jsr cdgvl  
        mov  xr,m_word [(cfp_b*cmopn)+xl]       ; load pointer to operator dv} mov xr cmopn(xl) 
        mov  xr,m_word [(cfp_b*dvopn)+xr]       ; load pointer offset} mov xr dvopn(xr) 
        sal  xr,log_cfp_b                       ; convert word offset to bytes} wtb xr  
        add  xr,r_uba                           ; point to proper function ptr} add xr =r_uba 
        sub  xr,cfp_b*vrfnc                     ; set standard function offset} sub xr *vrfnc 
        jmp  cgv12                              ; merge with function call circuit} brn cgv12  
cgv31:
        mov  wc,xs                              ; set non constant} mnz wc  
        jmp  cgv19                              ; merge} brn cgv19  
cgv32:
        call cdwrd                              ; generate word, merge} jsr cdwrd  
cgv33:
        mov  wc,xs                              ; indicate result is not constant} mnz wc  
cgv34:
        add  xs,cfp_b                           ; pop initial code offset} ica xs  
        pop  wa                                 ; restore old constant flag} mov wa (xs)+ 
        pop  xl                                 ; restore entry xl} mov xl (xs)+ 
        pop  wb                                 ; restore entry wb} mov wb (xs)+ 
        test wc,wc                              ; jump if not constant} bnz wc cgv35 
        jnz  cgv35                              ; 
        mov  wc,wa                              ; else restore entry constant flag} mov wc wa 
cgv35:
        ret                                     ; return to cdgvl caller} exi   
cgv36:
        call cdwrd                              ; generate word} jsr cdwrd  
        test wc,wc                              ; jump to exit if not constant} bnz wc cgv34 
        jnz  cgv34                              ; 
        mov  wa,orvl_                           ; load call to return value} mov wa =orvl_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  xl,m_word [xs]                     ; load initial code offset} mov xl (xs) 
        call exbld                              ; build exblk for expression} jsr exbld  
        xor  wb,wb                              ; set to evaluate by value} zer wb  
        call evalx                              ; evaluate expression} jsr evalx  
        dec  m_word [_rc_]                      ; 
        js   call_214                           ; 
        dec  m_word [_rc_]                      ; should not fail} ppm   
        jns  _l0407                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0407:                                         ; 
call_214:                                       ; 
        mov  wa,m_word [xr]                     ; load type word of result} mov wa (xr) 
        cmp  wa,p_aaa                           ; jump if not pattern} blo wa =p_aaa cgv37
        jb   cgv37                              ; 
        mov  wa,olpt_                           ; else load special pattern load call} mov wa =olpt_ 
        call cdwrd                              ; generate it} jsr cdwrd  
cgv37:
        mov  wa,xr                              ; copy constant pointer} mov wa xr 
        call cdwrd                              ; generate ptr} jsr cdwrd  
        xor  wc,wc                              ; set result constant} zer wc  
        jmp  cgv34                              ; jump back to exit} brn cgv34  
                                                ; end procedure cdgvl} enp   
cdwrd:
                                                ; entry point} prc e 0 
        push xr                                 ; save entry xr} mov -(xs) xr 
        push wa                                 ; save code word to be generated} mov -(xs) wa 
cdwd1:
        mov  xr,m_word [r_ccb]                  ; load ptr to ccblk being built} mov xr r_ccb 
        test xr,xr                              ; jump if block allocated} bnz xr cdwd2 
        jnz  cdwd2                              ; 
        mov  wa,cfp_b*e_cbs                     ; load initial length} mov wa *e_cbs 
        call alloc                              ; allocate ccblk} jsr alloc  
        mov  m_word [xr],b_cct                  ; store type word} mov (xr) =b_cct 
        mov  m_word [cwcof],cfp_b*cccod         ; set initial offset} mov cwcof *cccod 
        mov  m_word [(cfp_b*cclen)+xr],wa       ; store block length} mov cclen(xr) wa 
        xor  w0,w0                              ; zero line number} zer ccsln(xr)  
        mov  m_word [(cfp_b*ccsln)+xr],w0       ; 
        mov  m_word [r_ccb],xr                  ; store ptr to new block} mov r_ccb xr 
cdwd2:
        mov  wa,m_word [cwcof]                  ; load current offset} mov wa cwcof 
        add  wa,cfp_b*num05                     ; adjust for test (five words)} add wa *num05 
        cmp  wa,m_word [(cfp_b*cclen)+xr]       ; jump if room in this block} blo wa cclen(xr) cdwd4
        jb   cdwd4                              ; 
        cmp  wa,m_word [mxlen]                  ; jump if already at max size} bge wa mxlen cdwd5
        jae  cdwd5                              ; 
        add  wa,cfp_b*e_cbs                     ; else get new size} add wa *e_cbs 
        push xl                                 ; save entry xl} mov -(xs) xl 
        mov  xl,xr                              ; copy pointer} mov xl xr 
        cmp  wa,m_word [mxlen]                  ; jump if not too large} blt wa mxlen cdwd3
        jb   cdwd3                              ; 
        mov  wa,m_word [mxlen]                  ; else reset to max allowed size} mov wa mxlen 
cdwd3:
        call alloc                              ; allocate new block} jsr alloc  
        mov  m_word [r_ccb],xr                  ; store pointer to new block} mov r_ccb xr 
        mov  w0,b_cct                           ; store type word in new block} mov (xr)+ =b_cct 
        stos_w                                  ; 
        mov  w0,wa                              ; store block length} mov (xr)+ wa 
        stos_w                                  ; 
        mov  w0,m_word [(cfp_b*ccsln)+xl]       ; copy source line number word} mov (xr)+ ccsln(xl) 
        stos_w                                  ; 
        add  xl,cfp_b*ccuse                     ; point to ccuse,cccod fields in old} add xl *ccuse 
        mov  wa,m_word [xl]                     ; load ccuse value} mov wa (xl) 
        shr  wa,log_cfp_b                       ; copy useful words from old block} mvw   
        rep  movs_w                             ; 
        pop  xl                                 ; restore xl} mov xl (xs)+ 
        jmp  cdwd1                              ; merge back to try again} brn cdwd1  
cdwd4:
        mov  wa,m_word [cwcof]                  ; load current offset} mov wa cwcof 
        add  wa,cfp_b                           ; get new offset} ica wa  
        mov  m_word [cwcof],wa                  ; store new offset} mov cwcof wa 
        mov  m_word [(cfp_b*ccuse)+xr],wa       ; store in ccblk for gbcol} mov ccuse(xr) wa 
        sub  wa,cfp_b                           ; restore ptr to this word} dca wa  
        add  xr,wa                              ; point to current entry} add xr wa 
        pop  wa                                 ; reload word to generate} mov wa (xs)+ 
        mov  m_word [xr],wa                     ; store word in block} mov (xr) wa 
        pop  xr                                 ; restore entry xr} mov xr (xs)+ 
        ret                                     ; return to caller} exi   
cdwd5:
        mov  m_word [_rc_],213                  ; } erb 213 syntax error: statement is too complicated. 
        jmp  err_                               ; 
                                                ; end procedure cdwrd} enp   
cmgen:
                                                ; entry point, recursive} prc r 0 
        mov  xr,xl                              ; copy cmblk pointer} mov xr xl 
        add  xr,wb                              ; point to cmblk pointer} add xr wb 
        mov  xr,m_word [xr]                     ; load cmblk pointer} mov xr (xr) 
        call cdgvl                              ; generate code by value} jsr cdgvl  
        add  wb,cfp_b                           ; bump offset} ica wb  
        ret                                     ; return to caller} exi   
                                                ; end procedure cmgen} enp   
cmpil:
                                                ; entry point} prc e 0 
        mov  wb,cmnen                           ; set number of stack work locations} lct wb =cmnen 
cmp00:
        push 0                                  ; store a zero, make one entry} zer -(xs)  
        dec  wb                                 ; loop back until all set} bct wb cmp00 
        jnz  cmp00                              ; 
        mov  m_word [cmpxs],xs                  ; save stack pointer for error sec} mov cmpxs xs 
                                                ; save s-r stack pointer if any} sss cmpss  
cmp01:
        mov  wb,m_word [scnpt]                  ; set scan pointer offset} mov wb scnpt 
        mov  m_word [scnse],wb                  ; set start of element location} mov scnse wb 
        mov  wa,ocer_                           ; point to compile error call} mov wa =ocer_ 
        call cdwrd                              ; generate as temporary cdfal} jsr cdwrd  
        cmp  wb,m_word [scnil]                  ; jump if chars left on this image} blt wb scnil cmp04
        jb   cmp04                              ; 
cmpce:
        xor  xr,xr                              ; clear possible garbage xr value} zer xr  
        cmp  m_word [cnind],0                   ; if within include file} bnz cnind cmpc2 
        jnz  cmpc2                              ; 
        cmp  m_word [stage],stgic               ; skip unless initial compile} bne stage =stgic cmp02
        jne  cmp02                              ; 
cmpc2:
        call readr                              ; read next input image} jsr readr  
        test xr,xr                              ; jump if no input available} bze xr cmp09 
        jz   cmp09                              ; 
        call nexts                              ; acquire next source image} jsr nexts  
        mov  w0,m_word [cmpsn]                  ; store stmt no for use by listr} mov lstsn cmpsn 
        mov  m_word [lstsn],w0                  ; 
        mov  w0,m_word [rdcln]                  ; store line number at start of stmt} mov cmpln rdcln 
        mov  m_word [cmpln],w0                  ; 
        xor  w0,w0                              ; reset scan pointer} zer scnpt  
        mov  m_word [scnpt],w0                  ; 
        jmp  cmp04                              ; go process image} brn cmp04  
cmp02:
        mov  xr,m_word [r_cim]                  ; get current image} mov xr r_cim 
        mov  wb,m_word [scnpt]                  ; get current offset} mov wb scnpt 
        lea  xr,[cfp_f+xr+wb]                   ; prepare to get chars} plc xr wb 
cmp03:
        mov  w0,m_word [scnil]                  ; end loop if end of image} bge scnpt scnil cmp09
        cmp  m_word [scnpt],w0                  ; 
        jae  cmp09                              ; 
        xor  w0,w0                              ; get char} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        inc  m_word [scnpt]                     ; advance offset} icv scnpt  
        cmp  wc,ch_sm                           ; loop if not semi-colon} bne wc =ch_sm cmp03
        jne  cmp03                              ; 
cmp04:
        mov  xr,m_word [r_cim]                  ; point to current image} mov xr r_cim 
        mov  wb,m_word [scnpt]                  ; load current offset} mov wb scnpt 
        mov  wa,wb                              ; copy for label scan} mov wa wb 
        lea  xr,[cfp_f+xr+wb]                   ; point to first character} plc xr wb 
        xor  w0,w0                              ; load first character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        cmp  wc,ch_sm                           ; no label if semicolon} beq wc =ch_sm cmp12
        je   cmp12                              ; 
        cmp  wc,ch_as                           ; loop back if comment card} beq wc =ch_as cmpce
        je   cmpce                              ; 
        cmp  wc,ch_mn                           ; jump if control card} beq wc =ch_mn cmp32
        je   cmp32                              ; 
        mov  w0,m_word [r_cim]                  ; about to destroy r_cim} mov r_cmp r_cim 
        mov  m_word [r_cmp],w0                  ; 
        mov  xl,cmlab                           ; point to label work string} mov xl =cmlab 
        mov  m_word [r_cim],xl                  ; scane is to scan work string} mov r_cim xl 
        add  xl,cfp_f                           ; point to first character position} psc xl  
        mov  m_char [xl],dl                     ; store char just loaded} sch wc (xl)+ 
        inc  xl                                 ; 
        mov  wc,ch_sm                           ; get a semicolon} mov wc =ch_sm 
        mov  m_char [xl],dl                     ; store after first char} sch wc (xl) 
        xor  xl,xl                              ; clear pointer} zer xl  
        xor  w0,w0                              ; start at first character} zer scnpt  
        mov  m_word [scnpt],w0                  ; 
        push m_word [scnil]                     ; preserve image length} mov -(xs) scnil 
        mov  m_word [scnil],num02               ; read 2 chars at most} mov scnil =num02 
        call scane                              ; scan first char for type} jsr scane  
        pop  m_word [scnil]                     ; restore image length} mov scnil (xs)+ 
        mov  wc,xl                              ; note return code} mov wc xl 
        mov  xl,m_word [r_cmp]                  ; get old r_cim} mov xl r_cmp 
        mov  m_word [r_cim],xl                  ; put it back} mov r_cim xl 
        mov  m_word [scnpt],wb                  ; reinstate offset} mov scnpt wb 
        cmp  m_word [scnbl],0                   ; blank seen - cant be label} bnz scnbl cmp12 
        jnz  cmp12                              ; 
        mov  xr,xl                              ; point to current image} mov xr xl 
        lea  xr,[cfp_f+xr+wb]                   ; point to first char again} plc xr wb 
        cmp  wc,t_var                           ; ok if letter} beq wc =t_var cmp06
        je   cmp06                              ; 
        cmp  wc,t_con                           ; ok if digit} beq wc =t_con cmp06
        je   cmp06                              ; 
cmple:
        mov  w0,m_word [r_cmp]                  ; point to bad line} mov r_cim r_cmp 
        mov  m_word [r_cim],w0                  ; 
        mov  m_word [_rc_],214                  ; } erb 214 bad label or misplaced continuation line 
        jmp  err_                               ; 
cmp05:
        cmp  wc,ch_sm                           ; skip if semicolon} beq wc =ch_sm cmp07
        je   cmp07                              ; 
        inc  wa                                 ; bump offset} icv wa  
        cmp  wa,m_word [scnil]                  ; jump if end of image (label end)} beq wa scnil cmp07
        je   cmp07                              ; 
cmp06:
        xor  w0,w0                              ; else load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        cmp  wc,ch_ht                           ; jump if horizontal tab} beq wc =ch_ht cmp07
        je   cmp07                              ; 
        cmp  wc,ch_bl                           ; loop back if non-blank} bne wc =ch_bl cmp05
        jne  cmp05                              ; 
cmp07:
        mov  m_word [scnpt],wa                  ; save updated scan offset} mov scnpt wa 
        sub  wa,wb                              ; get length of label} sub wa wb 
        test wa,wa                              ; skip if label length zero} bze wa cmp12 
        jz   cmp12                              ; 
        xor  xr,xr                              ; clear garbage xr value} zer xr  
        call sbstr                              ; build scblk for label name} jsr sbstr  
        call gtnvr                              ; locate/contruct vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_215                           ; 
        dec  m_word [_rc_]                      ; dummy (impossible) error return} ppm   
        jns  _l0408                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0408:                                         ; 
call_215:                                       ; 
        mov  m_word [(cfp_b*cmlbl)+xs],xr       ; store label pointer} mov cmlbl(xs) xr 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; jump if not system label} bnz vrlen(xr) cmp11 
        jnz  cmp11                              ; 
        cmp  m_word [(cfp_b*vrsvp)+xr],v_end    ; jump if not end label} bne vrsvp(xr) =v_end cmp11
        jne  cmp11                              ; 
        add  m_word [stage],stgnd               ; adjust stage appropriately} add stage =stgnd 
        call scane                              ; scan out next element} jsr scane  
        cmp  xl,t_smc                           ; jump if end of image} beq xl =t_smc cmp10
        je   cmp10                              ; 
        cmp  xl,t_var                           ; else error if not variable} bne xl =t_var cmp08
        jne  cmp08                              ; 
        cmp  m_word [(cfp_b*vrlbl)+xr],stndl    ; jump if not defined (error)} beq vrlbl(xr) =stndl cmp08
        je   cmp08                              ; 
        mov  w0,m_word [(cfp_b*vrlbl)+xr]       ; else set initial entry pointer} mov cmtra(xs) vrlbl(xr) 
        mov  m_word [(cfp_b*cmtra)+xs],w0       ; 
        call scane                              ; scan next element} jsr scane  
        cmp  xl,t_smc                           ; jump if ok (end of image)} beq xl =t_smc cmp10
        je   cmp10                              ; 
cmp08:
        mov  m_word [_rc_],215                  ; } erb 215 syntax error: undefined or erroneous entry label 
        jmp  err_                               ; 
cmp09:
        xor  xr,xr                              ; clear garbage xr value} zer xr  
        add  m_word [stage],stgnd               ; adjust stage appropriately} add stage =stgnd 
        cmp  m_word [stage],stgxe               ; jump if code call (ok)} beq stage =stgxe cmp10
        je   cmp10                              ; 
        mov  m_word [_rc_],216                  ; } erb 216 syntax error: missing end line 
        jmp  err_                               ; 
cmp10:
        mov  wa,ostp_                           ; set stop call pointer} mov wa =ostp_ 
        call cdwrd                              ; generate as statement call} jsr cdwrd  
        jmp  cmpse                              ; jump to generate as failure} brn cmpse  
cmp11:
        cmp  m_word [stage],stgic               ; jump if code call - redef. ok} bne stage =stgic cmp12
        jne  cmp12                              ; 
        cmp  m_word [(cfp_b*vrlbl)+xr],stndl    ; else check for redefinition} beq vrlbl(xr) =stndl cmp12
        je   cmp12                              ; 
        xor  w0,w0                              ; leave first label decln undisturbed} zer cmlbl(xs)  
        mov  m_word [(cfp_b*cmlbl)+xs],w0       ; 
        mov  m_word [_rc_],217                  ; } erb 217 syntax error: duplicate label 
        jmp  err_                               ; 
cmp12:
        xor  wb,wb                              ; set flag for statement body} zer wb  
        call expan                              ; get tree for statement body} jsr expan  
        mov  m_word [(cfp_b*cmstm)+xs],xr       ; store for later use} mov cmstm(xs) xr 
        xor  w0,w0                              ; clear success goto pointer} zer cmsgo(xs)  
        mov  m_word [(cfp_b*cmsgo)+xs],w0       ; 
        xor  w0,w0                              ; clear failure goto pointer} zer cmfgo(xs)  
        mov  m_word [(cfp_b*cmfgo)+xs],w0       ; 
        xor  w0,w0                              ; clear conditional goto flag} zer cmcgo(xs)  
        mov  m_word [(cfp_b*cmcgo)+xs],w0       ; 
        call scane                              ; scan next element} jsr scane  
        cmp  xl,t_col                           ; jump if colon (goto)} beq xl =t_col cmp13
        je   cmp13                              ; 
        cmp  m_word [cswno],0                   ; jump if not optimizing} bnz cswno cmp18 
        jnz  cmp18                              ; 
        cmp  m_word [(cfp_b*cmlbl)+xs],0        ; jump if label present} bnz cmlbl(xs) cmp18 
        jnz  cmp18                              ; 
        mov  xr,m_word [(cfp_b*cmstm)+xs]       ; load tree ptr for statement body} mov xr cmstm(xs) 
        mov  wa,m_word [xr]                     ; load type word} mov wa (xr) 
        cmp  wa,b_cmt                           ; jump if cmblk} beq wa =b_cmt cmp18
        je   cmp18                              ; 
        cmp  wa,b_vra                           ; jump if not icblk, scblk, or rcblk} bge wa =b_vra cmp18
        jae  cmp18                              ; 
        mov  xl,m_word [r_ccb]                  ; load ptr to ccblk} mov xl r_ccb 
        mov  m_word [(cfp_b*ccuse)+xl],cfp_b*cccod      ; reset use offset in ccblk} mov ccuse(xl) *cccod 
        mov  m_word [cwcof],cfp_b*cccod         ; and in global} mov cwcof *cccod 
        inc  m_word [cmpsn]                     ; bump statement number} icv cmpsn  
        jmp  cmp01                              ; generate no code for statement} brn cmp01  
cmp13:
        mov  m_word [scngo],xs                  ; set goto flag} mnz scngo  
        call scane                              ; scan next element} jsr scane  
        cmp  xl,t_smc                           ; jump if no fields left} beq xl =t_smc cmp31
        je   cmp31                              ; 
        cmp  xl,t_sgo                           ; jump if s for success goto} beq xl =t_sgo cmp14
        je   cmp14                              ; 
        cmp  xl,t_fgo                           ; jump if f for failure goto} beq xl =t_fgo cmp16
        je   cmp16                              ; 
        mov  m_word [scnrs],xs                  ; set to rescan element not f,s} mnz scnrs  
        call scngf                              ; scan out goto field} jsr scngf  
        cmp  m_word [(cfp_b*cmfgo)+xs],0        ; error if fgoto already} bnz cmfgo(xs) cmp17 
        jnz  cmp17                              ; 
        mov  m_word [(cfp_b*cmfgo)+xs],xr       ; else set as fgoto} mov cmfgo(xs) xr 
        jmp  cmp15                              ; merge with sgoto circuit} brn cmp15  
cmp14:
        call scngf                              ; scan success goto field} jsr scngf  
        mov  m_word [(cfp_b*cmcgo)+xs],num01    ; set conditional goto flag} mov cmcgo(xs) =num01 
cmp15:
        cmp  m_word [(cfp_b*cmsgo)+xs],0        ; error if sgoto already given} bnz cmsgo(xs) cmp17 
        jnz  cmp17                              ; 
        mov  m_word [(cfp_b*cmsgo)+xs],xr       ; else set sgoto} mov cmsgo(xs) xr 
        jmp  cmp13                              ; loop back for next goto field} brn cmp13  
cmp16:
        call scngf                              ; scan goto field} jsr scngf  
        mov  m_word [(cfp_b*cmcgo)+xs],num01    ; set conditonal goto flag} mov cmcgo(xs) =num01 
        cmp  m_word [(cfp_b*cmfgo)+xs],0        ; error if fgoto already given} bnz cmfgo(xs) cmp17 
        jnz  cmp17                              ; 
        mov  m_word [(cfp_b*cmfgo)+xs],xr       ; else store fgoto pointer} mov cmfgo(xs) xr 
        jmp  cmp13                              ; loop back for next field} brn cmp13  
cmp17:
        mov  m_word [_rc_],218                  ; } erb 218 syntax error: duplicated goto field 
        jmp  err_                               ; 
cmp18:
        xor  w0,w0                              ; stop positional error flags} zer scnse  
        mov  m_word [scnse],w0                  ; 
        mov  xr,m_word [(cfp_b*cmstm)+xs]       ; load tree ptr for statement body} mov xr cmstm(xs) 
        xor  wb,wb                              ; collectable value for wb for cdgvl} zer wb  
        xor  wc,wc                              ; reset constant flag for cdgvl} zer wc  
        call expap                              ; test for pattern match} jsr expap  
        dec  m_word [_rc_]                      ; 
        js   call_216                           ; 
        dec  m_word [_rc_]                      ; jump if not pattern match} ppm cmp19  
        jns  _l0409                             ; 
        jmp  cmp19                              ; 
_l0409:                                         ; 
call_216:                                       ; 
        mov  m_word [(cfp_b*cmopn)+xr],opms_    ; else set pattern match pointer} mov cmopn(xr) =opms_ 
        mov  m_word [(cfp_b*cmtyp)+xr],c_pmt    ; } mov cmtyp(xr) =c_pmt 
cmp19:
        call cdgvl                              ; generate code for body of statement} jsr cdgvl  
        mov  xr,m_word [(cfp_b*cmsgo)+xs]       ; load sgoto pointer} mov xr cmsgo(xs) 
        mov  wa,xr                              ; copy it} mov wa xr 
        test xr,xr                              ; jump if no success goto} bze xr cmp21 
        jz   cmp21                              ; 
        xor  w0,w0                              ; clear success offset fillin ptr} zer cmsoc(xs)  
        mov  m_word [(cfp_b*cmsoc)+xs],w0       ; 
        cmp  xr,m_word [state]                  ; jump if complex goto} bhi xr state cmp20
        ja   cmp20                              ; 
        add  wa,cfp_b*vrtra                     ; point to vrtra field as required} add wa *vrtra 
        call cdwrd                              ; generate success goto} jsr cdwrd  
        jmp  cmp22                              ; jump to deal with fgoto} brn cmp22  
cmp20:
        cmp  xr,m_word [(cfp_b*cmfgo)+xs]       ; no code if same as fgoto} beq xr cmfgo(xs) cmp22
        je   cmp22                              ; 
        xor  wb,wb                              ; else set ok value for cdgvl in wb} zer wb  
        call cdgcg                              ; generate code for success goto} jsr cdgcg  
        jmp  cmp22                              ; jump to deal with fgoto} brn cmp22  
cmp21:
        mov  w0,m_word [cwcof]                  ; set success fill in offset} mov cmsoc(xs) cwcof 
        mov  m_word [(cfp_b*cmsoc)+xs],w0       ; 
        mov  wa,ocer_                           ; point to compile error call} mov wa =ocer_ 
        call cdwrd                              ; generate as temporary value} jsr cdwrd  
cmp22:
        mov  xr,m_word [(cfp_b*cmfgo)+xs]       ; load failure goto pointer} mov xr cmfgo(xs) 
        mov  wa,xr                              ; copy it} mov wa xr 
        xor  w0,w0                              ; set no fill in required yet} zer cmffc(xs)  
        mov  m_word [(cfp_b*cmffc)+xs],w0       ; 
        test xr,xr                              ; jump if no failure goto given} bze xr cmp23 
        jz   cmp23                              ; 
        add  wa,cfp_b*vrtra                     ; point to vrtra field in case} add wa *vrtra 
        cmp  xr,m_word [state]                  ; jump to gen if simple fgoto} blo xr state cmpse
        jb   cmpse                              ; 
        mov  wb,m_word [cwcof]                  ; save offset to o_gof call} mov wb cwcof 
        mov  wa,ogof_                           ; point to failure goto call} mov wa =ogof_ 
        call cdwrd                              ; generate} jsr cdwrd  
        mov  wa,ofif_                           ; point to fail in fail word} mov wa =ofif_ 
        call cdwrd                              ; generate} jsr cdwrd  
        call cdgcg                              ; generate code for failure goto} jsr cdgcg  
        mov  wa,wb                              ; copy offset to o_gof for cdfal} mov wa wb 
        mov  wb,b_cdc                           ; set complex case cdtyp} mov wb =b_cdc 
        jmp  cmp25                              ; jump to build cdblk} brn cmp25  
cmp23:
        mov  wa,ounf_                           ; load unexpected failure call in cas} mov wa =ounf_ 
        mov  wc,m_word [cswfl]                  ; get -nofail flag} mov wc cswfl 
        or   wc,m_word [(cfp_b*cmcgo)+xs]       ; check if conditional goto} orb wc cmcgo(xs) 
        test wc,wc                              ; jump if -nofail and no cond. goto} zrb wc cmpse 
        jz   cmpse                              ; 
        mov  m_word [(cfp_b*cmffc)+xs],xs       ; else set fill in flag} mnz cmffc(xs)  
        mov  wa,ocer_                           ; and set compile error for temporary} mov wa =ocer_ 
cmpse:
        mov  wb,b_cds                           ; set cdtyp for simple case} mov wb =b_cds 
cmp25:
        mov  xr,m_word [r_ccb]                  ; point to ccblk} mov xr r_ccb 
        mov  xl,m_word [(cfp_b*cmlbl)+xs]       ; get possible label pointer} mov xl cmlbl(xs) 
        test xl,xl                              ; skip if no label} bze xl cmp26 
        jz   cmp26                              ; 
        xor  w0,w0                              ; clear flag for next statement} zer cmlbl(xs)  
        mov  m_word [(cfp_b*cmlbl)+xs],w0       ; 
        mov  m_word [(cfp_b*vrlbl)+xl],xr       ; put cdblk ptr in vrblk label field} mov vrlbl(xl) xr 
cmp26:
        mov  m_word [xr],wb                     ; set type word for new cdblk} mov (xr) wb 
        mov  m_word [(cfp_b*cdfal)+xr],wa       ; set failure word} mov cdfal(xr) wa 
        mov  xl,xr                              ; copy pointer to ccblk} mov xl xr 
        mov  wb,m_word [(cfp_b*ccuse)+xr]       ; load length gen (= new cdlen)} mov wb ccuse(xr) 
        mov  wc,m_word [(cfp_b*cclen)+xr]       ; load total ccblk length} mov wc cclen(xr) 
        add  xl,wb                              ; point past cdblk} add xl wb 
        sub  wc,wb                              ; get length left for chop off} sub wc wb 
        mov  m_word [xl],b_cct                  ; set type code for new ccblk at end} mov (xl) =b_cct 
        mov  m_word [(cfp_b*ccuse)+xl],cfp_b*cccod      ; set initial code offset} mov ccuse(xl) *cccod 
        mov  m_word [cwcof],cfp_b*cccod         ; reinitialise cwcof} mov cwcof *cccod 
        mov  m_word [(cfp_b*cclen)+xl],wc       ; set new length} mov cclen(xl) wc 
        mov  m_word [r_ccb],xl                  ; set new ccblk pointer} mov r_ccb xl 
        xor  w0,w0                              ; initialize new line number} zer ccsln(xl)  
        mov  m_word [(cfp_b*ccsln)+xl],w0       ; 
        mov  w0,m_word [cmpln]                  ; set line number in old block} mov cdsln(xr) cmpln 
        mov  m_word [(cfp_b*cdsln)+xr],w0       ; 
        mov  w0,m_word [cmpsn]                  ; set statement number} mov cdstm(xr) cmpsn 
        mov  m_word [(cfp_b*cdstm)+xr],w0       ; 
        inc  m_word [cmpsn]                     ; bump statement number} icv cmpsn  
        mov  xl,m_word [(cfp_b*cmpcd)+xs]       ; load ptr to previous cdblk} mov xl cmpcd(xs) 
        cmp  m_word [(cfp_b*cmffp)+xs],0        ; jump if no failure fill in required} bze cmffp(xs) cmp27 
        jz   cmp27                              ; 
        mov  m_word [(cfp_b*cdfal)+xl],xr       ; else set failure ptr in previous} mov cdfal(xl) xr 
cmp27:
        mov  wa,m_word [(cfp_b*cmsop)+xs]       ; load success offset} mov wa cmsop(xs) 
        test wa,wa                              ; jump if no fill in required} bze wa cmp28 
        jz   cmp28                              ; 
        add  xl,wa                              ; else point to fill in location} add xl wa 
        mov  m_word [xl],xr                     ; store forward pointer} mov (xl) xr 
        xor  xl,xl                              ; clear garbage xl value} zer xl  
cmp28:
        mov  w0,m_word [(cfp_b*cmffc)+xs]       ; copy failure fill in flag} mov cmffp(xs) cmffc(xs) 
        mov  m_word [(cfp_b*cmffp)+xs],w0       ; 
        mov  w0,m_word [(cfp_b*cmsoc)+xs]       ; copy success fill in offset} mov cmsop(xs) cmsoc(xs) 
        mov  m_word [(cfp_b*cmsop)+xs],w0       ; 
        mov  m_word [(cfp_b*cmpcd)+xs],xr       ; save ptr to this cdblk} mov cmpcd(xs) xr 
        cmp  m_word [(cfp_b*cmtra)+xs],0        ; jump if initial entry already set} bnz cmtra(xs) cmp29 
        jnz  cmp29                              ; 
        mov  m_word [(cfp_b*cmtra)+xs],xr       ; else set ptr here as default} mov cmtra(xs) xr 
cmp29:
        cmp  m_word [stage],stgce               ; jump if not end line just done} blt stage =stgce cmp01
        jb   cmp01                              ; 
        cmp  m_word [cswls],0                   ; skip if -nolist} bze cswls cmp30 
        jz   cmp30                              ; 
        call listr                              ; list last line} jsr listr  
cmp30:
        mov  xr,m_word [(cfp_b*cmtra)+xs]       ; load initial entry cdblk pointer} mov xr cmtra(xs) 
        add  xs,cfp_b*cmnen                     ; pop work locations off stack} add xs *cmnen 
        ret                                     ; and return to cmpil caller} exi   
cmp31:
        mov  wb,m_word [(cfp_b*cmfgo)+xs]       ; get fail goto} mov wb cmfgo(xs) 
        or   wb,m_word [(cfp_b*cmsgo)+xs]       ; or in success goto} orb wb cmsgo(xs) 
        test wb,wb                              ; ok if non-null field} bnz wb cmp18 
        jnz  cmp18                              ; 
        mov  m_word [_rc_],219                  ; } erb 219 syntax error: empty goto field 
        jmp  err_                               ; 
cmp32:
        inc  wb                                 ; point past ch_mn} icv wb  
        call cncrd                              ; process control card} jsr cncrd  
        xor  w0,w0                              ; clear start of element loc.} zer scnse  
        mov  m_word [scnse],w0                  ; 
        jmp  cmpce                              ; loop for next statement} brn cmpce  
                                                ; end procedure cmpil} enp   
cncrd:
                                                ; entry point} prc e 0 
        mov  m_word [scnpt],wb                  ; offset for control card scan} mov scnpt wb 
        mov  wa,ccnoc                           ; number of chars for comparison} mov wa =ccnoc 
        add  wa,(cfp_c-1)+cfp_c*0               ; convert to word count} ctw wa 0 
        shr  wa,log_cfp_c                       ; 
        mov  m_word [cnswc],wa                  ; save word count} mov cnswc wa 
cnc01:
        mov  w0,m_word [scnil]                  ; return if end of image} bge scnpt scnil cnc09
        cmp  m_word [scnpt],w0                  ; 
        jae  cnc09                              ; 
        mov  xr,m_word [r_cim]                  ; point to image} mov xr r_cim 
        add  xr,cfp_f                           ; char ptr for first char} plc xr scnpt 
        add  xr,m_word [scnpt]                  ; 
        xor  w0,w0                              ; get first char} lch wa (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        inc  xr                                 ; 
        cmp  cl,'A'                             ; fold to lower case} flc wa  
        jb   _l0410                             ; 
        cmp  cl,'Z'                             ; 
        ja   _l0410                             ; 
        add  cl,32                              ; 
_l0410             :                            ; 
        cmp  wa,ch_li                           ; special case of -inxxx} beq wa =ch_li cnc07
        je   cnc07                              ; 
cnc0a:
        mov  m_word [scncc],xs                  ; set flag for scane} mnz scncc  
        call scane                              ; scan card name} jsr scane  
        xor  w0,w0                              ; clear scane flag} zer scncc  
        mov  m_word [scncc],w0                  ; 
        test xl,xl                              ; fail unless control card name} bnz xl cnc06 
        jnz  cnc06                              ; 
        mov  wa,ccnoc                           ; no. of chars to be compared} mov wa =ccnoc 
        cmp  m_word [(cfp_b*sclen)+xr],wa       ; fail if too few chars} blt sclen(xr) wa cnc08
        jb   cnc08                              ; 
        mov  xl,xr                              ; point to control card name} mov xl xr 
        xor  wb,wb                              ; zero offset for substring} zer wb  
        call sbstr                              ; extract substring for comparison} jsr sbstr  
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; reload length} mov wa sclen(xr) 
        call flstg                              ; fold to lower case} jsr flstg  
        mov  m_word [cnscc],xr                  ; keep control card substring ptr} mov cnscc xr 
        mov  xr,ccnms                           ; point to list of standard names} mov xr =ccnms 
        xor  wb,wb                              ; initialise name offset} zer wb  
        mov  wc,cc_nc                           ; number of standard names} lct wc =cc_nc 
cnc02:
        mov  xl,m_word [cnscc]                  ; point to name} mov xl cnscc 
        mov  wa,m_word [cnswc]                  ; counter for inner loop} lct wa cnswc 
        jmp  cnc04                              ; jump into loop} brn cnc04  
cnc03:
        add  xr,cfp_b                           ; bump standard names ptr} ica xr  
        add  xl,cfp_b                           ; bump name pointer} ica xl  
cnc04:
        mov  w0,m_word [xr]                     ; comp. up to cfp_c chars at once} cne schar(xl) (xr) cnc05
        cmp  m_word [(cfp_b*schar)+xl],w0       ; 
        jnz  cnc05                              ; 
        dec  wa                                 ; loop if more words to compare} bct wa cnc03 
        jnz  cnc03                              ; 
        mov  xl,wb                              ; get name offset} mov xl wb 
        cmp  xl,cc_nc                           ; switch} bsw xl cc_nc cnc08
        jge  cnc08                              ; 
        jmp  m_word [_l0411+xl*cfp_b]           ; 
        segment .data                           ; 
_l0411:                                         ; 
        d_word cnc37                            ; -case} iff cc_ca cnc37 
        d_word cnc10                            ; -double} iff cc_do cnc10 
        d_word cnc08                            ; } iff 2 cnc08 
        d_word cnc11                            ; -dump} iff cc_du cnc11 
        d_word cnc41                            ; -copy} iff cc_cp cnc41 
        d_word cnc12                            ; -eject} iff cc_ej cnc12 
        d_word cnc13                            ; -errors} iff cc_er cnc13 
        d_word cnc14                            ; -execute} iff cc_ex cnc14 
        d_word cnc15                            ; -fail} iff cc_fa cnc15 
        d_word cnc41                            ; -include} iff cc_in cnc41 
        d_word cnc44                            ; -line} iff cc_ln cnc44 
        d_word cnc16                            ; -list} iff cc_li cnc16 
        d_word cnc17                            ; -noerrors} iff cc_nr cnc17 
        d_word cnc18                            ; -noexecute} iff cc_nx cnc18 
        d_word cnc19                            ; -nofail} iff cc_nf cnc19 
        d_word cnc20                            ; -nolist} iff cc_nl cnc20 
        d_word cnc21                            ; -noopt} iff cc_no cnc21 
        d_word cnc22                            ; -noprint} iff cc_np cnc22 
        d_word cnc24                            ; -optimise} iff cc_op cnc24 
        d_word cnc25                            ; -print} iff cc_pr cnc25 
        d_word cnc27                            ; -single} iff cc_si cnc27 
        d_word cnc28                            ; -space} iff cc_sp cnc28 
        d_word cnc31                            ; -stitle} iff cc_st cnc31 
        d_word cnc32                            ; -title} iff cc_ti cnc32 
        d_word cnc36                            ; -trace} iff cc_tr cnc36 
        segment .text                           ; end switch} esw   
cnc05:
        add  xr,cfp_b                           ; bump standard names ptr} ica xr  
        dec  wa                                 ; loop} bct wa cnc05 
        jnz  cnc05                              ; 
        inc  wb                                 ; bump names offset} icv wb  
        dec  wc                                 ; continue if more names} bct wc cnc02 
        jnz  cnc02                              ; 
        jmp  cnc08                              ; ignore unrecognized control card} brn cnc08  
cnc06:
        mov  m_word [_rc_],247                  ; } erb 247 invalid control statement 
        jmp  err_                               ; 
cnc07:
        xor  w0,w0                              ; get next char} lch wa (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        inc  xr                                 ; 
        cmp  cl,'A'                             ; fold to lower case} flc wa  
        jb   _l0412                             ; 
        cmp  cl,'Z'                             ; 
        ja   _l0412                             ; 
        add  cl,32                              ; 
_l0412             :                            ; 
        cmp  wa,ch_ln                           ; if not letter n} bne wa =ch_ln cnc0a
        jne  cnc0a                              ; 
        xor  w0,w0                              ; get third char} lch wa (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        cmp  wa,ch_d0                           ; if not digit} blt wa =ch_d0 cnc0a
        jb   cnc0a                              ; 
        cmp  wa,ch_d9                           ; if not digit} bgt wa =ch_d9 cnc0a
        ja   cnc0a                              ; 
        add  m_word [scnpt],num02               ; bump offset past -in} add scnpt =num02 
        call scane                              ; scan integer after -in} jsr scane  
        push xr                                 ; stack scanned item} mov -(xs) xr 
        call gtsmi                              ; check if integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_217                           ; 
        dec  m_word [_rc_]                      ; fail if not integer} ppm cnc06  
        jns  _l0413                             ; 
        jmp  cnc06                              ; 
_l0413:                                         ; 
        dec  m_word [_rc_]                      ; fail if negative or large} ppm cnc06  
        jns  _l0414                             ; 
        jmp  cnc06                              ; 
_l0414:                                         ; 
call_217:                                       ; 
        mov  m_word [cswin],xr                  ; keep integer} mov cswin xr 
cnc08:
        mov  wa,m_word [scnpt]                  ; preserve in case xeq time compile} mov wa scnpt 
        call scane                              ; look for comma} jsr scane  
        cmp  xl,t_cma                           ; loop if comma found} beq xl =t_cma cnc01
        je   cnc01                              ; 
        mov  m_word [scnpt],wa                  ; restore scnpt in case xeq time} mov scnpt wa 
cnc09:
        ret                                     ; return} exi   
cnc10:
        mov  m_word [cswdb],xs                  ; set switch} mnz cswdb  
        jmp  cnc08                              ; merge} brn cnc08  
cnc11:
        call sysdm                              ; call dumper} jsr sysdm  
        jmp  cnc09                              ; finished} brn cnc09  
cnc12:
        cmp  m_word [cswls],0                   ; return if -nolist} bze cswls cnc09 
        jz   cnc09                              ; 
        call prtps                              ; eject} jsr prtps  
        call listt                              ; list title} jsr listt  
        jmp  cnc09                              ; finished} brn cnc09  
cnc13:
        xor  w0,w0                              ; clear switch} zer cswer  
        mov  m_word [cswer],w0                  ; 
        jmp  cnc08                              ; merge} brn cnc08  
cnc14:
        xor  w0,w0                              ; clear switch} zer cswex  
        mov  m_word [cswex],w0                  ; 
        jmp  cnc08                              ; merge} brn cnc08  
cnc15:
        mov  m_word [cswfl],xs                  ; set switch} mnz cswfl  
        jmp  cnc08                              ; merge} brn cnc08  
cnc16:
        mov  m_word [cswls],xs                  ; set switch} mnz cswls  
        cmp  m_word [stage],stgic               ; done if compile time} beq stage =stgic cnc08
        je   cnc08                              ; 
        xor  w0,w0                              ; permit listing} zer lstpf  
        mov  m_word [lstpf],w0                  ; 
        call listr                              ; list line} jsr listr  
        jmp  cnc08                              ; merge} brn cnc08  
cnc17:
        mov  m_word [cswer],xs                  ; set switch} mnz cswer  
        jmp  cnc08                              ; merge} brn cnc08  
cnc18:
        mov  m_word [cswex],xs                  ; set switch} mnz cswex  
        jmp  cnc08                              ; merge} brn cnc08  
cnc19:
        xor  w0,w0                              ; clear switch} zer cswfl  
        mov  m_word [cswfl],w0                  ; 
        jmp  cnc08                              ; merge} brn cnc08  
cnc20:
        xor  w0,w0                              ; clear switch} zer cswls  
        mov  m_word [cswls],w0                  ; 
        jmp  cnc08                              ; merge} brn cnc08  
cnc21:
        mov  m_word [cswno],xs                  ; set switch} mnz cswno  
        jmp  cnc08                              ; merge} brn cnc08  
cnc22:
        xor  w0,w0                              ; clear switch} zer cswpr  
        mov  m_word [cswpr],w0                  ; 
        jmp  cnc08                              ; merge} brn cnc08  
cnc24:
        xor  w0,w0                              ; clear switch} zer cswno  
        mov  m_word [cswno],w0                  ; 
        jmp  cnc08                              ; merge} brn cnc08  
cnc25:
        mov  m_word [cswpr],xs                  ; set switch} mnz cswpr  
        jmp  cnc08                              ; merge} brn cnc08  
cnc27:
        xor  w0,w0                              ; clear switch} zer cswdb  
        mov  m_word [cswdb],w0                  ; 
        jmp  cnc08                              ; merge} brn cnc08  
cnc28:
        cmp  m_word [cswls],0                   ; return if -nolist} bze cswls cnc09 
        jz   cnc09                              ; 
        call scane                              ; scan integer after -space} jsr scane  
        mov  wc,num01                           ; 1 space in case} mov wc =num01 
        cmp  xr,t_smc                           ; jump if no integer} beq xr =t_smc cnc29
        je   cnc29                              ; 
        push xr                                 ; stack it} mov -(xs) xr 
        call gtsmi                              ; check integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_218                           ; 
        dec  m_word [_rc_]                      ; fail if not integer} ppm cnc06  
        jns  _l0415                             ; 
        jmp  cnc06                              ; 
_l0415:                                         ; 
        dec  m_word [_rc_]                      ; fail if negative or large} ppm cnc06  
        jns  _l0416                             ; 
        jmp  cnc06                              ; 
_l0416:                                         ; 
call_218:                                       ; 
        test wc,wc                              ; jump if non zero} bnz wc cnc29 
        jnz  cnc29                              ; 
        mov  wc,num01                           ; else 1 space} mov wc =num01 
cnc29:
        add  m_word [lstlc],wc                  ; bump line count} add lstlc wc 
        mov  w0,m_word [lstnp]                  ; jump if fits on page} blt lstlc lstnp cnc30
        cmp  m_word [lstlc],w0                  ; 
        jb   cnc30                              ; 
        call prtps                              ; eject} jsr prtps  
        call listt                              ; list title} jsr listt  
        jmp  cnc09                              ; merge} brn cnc09  
cnc30:
        call prtnl                              ; print a blank} jsr prtnl  
        dec  wc                                 ; loop} bct wc cnc30 
        jnz  cnc30                              ; 
        jmp  cnc09                              ; merge} brn cnc09  
cnc31:
        mov  m_word [cnr_t],r_stl               ; ptr to r_stl} mov cnr_t =r_stl 
        jmp  cnc33                              ; merge} brn cnc33  
cnc32:
        mov  m_word [r_stl],nulls               ; clear subtitle} mov r_stl =nulls 
        mov  m_word [cnr_t],r_ttl               ; ptr to r_ttl} mov cnr_t =r_ttl 
cnc33:
        mov  xr,nulls                           ; null in case needed} mov xr =nulls 
        mov  m_word [cnttl],xs                  ; set flag for next listr call} mnz cnttl  
        mov  wb,ccofs                           ; offset to title/subtitle} mov wb =ccofs 
        mov  wa,m_word [scnil]                  ; input image length} mov wa scnil 
        cmp  wa,wb                              ; jump if no chars left} blo wa wb cnc34
        jb   cnc34                              ; 
        sub  wa,wb                              ; no of chars to extract} sub wa wb 
        mov  xl,m_word [r_cim]                  ; point to image} mov xl r_cim 
        call sbstr                              ; get title/subtitle} jsr sbstr  
cnc34:
        mov  xl,m_word [cnr_t]                  ; point to storage location} mov xl cnr_t 
        mov  m_word [xl],xr                     ; store title/subtitle} mov (xl) xr 
        cmp  xl,r_stl                           ; return if stitl} beq xl =r_stl cnc09
        je   cnc09                              ; 
        cmp  m_word [precl],0                   ; return if extended listing} bnz precl cnc09 
        jnz  cnc09                              ; 
        cmp  m_word [prich],0                   ; return if regular printer} bze prich cnc09 
        jz   cnc09                              ; 
        mov  xl,m_word [(cfp_b*sclen)+xr]       ; get length of title} mov xl sclen(xr) 
        mov  wa,xl                              ; copy it} mov wa xl 
        test xl,xl                              ; jump if null} bze xl cnc35 
        jz   cnc35                              ; 
        add  xl,num10                           ; increment} add xl =num10 
        cmp  xl,m_word [prlen]                  ; use default lstp0 val if too long} bhi xl prlen cnc09
        ja   cnc09                              ; 
        add  wa,num04                           ; point just past title} add wa =num04 
cnc35:
        mov  m_word [lstpo],wa                  ; store offset} mov lstpo wa 
        jmp  cnc09                              ; return} brn cnc09  
cnc36:
        call systt                              ; toggle switch} jsr systt  
        jmp  cnc08                              ; merge} brn cnc08  
cnc37:
        call scane                              ; scan integer after -case} jsr scane  
        xor  wc,wc                              ; get 0 in case none there} zer wc  
        cmp  xl,t_smc                           ; skip if no integer} beq xl =t_smc cnc38
        je   cnc38                              ; 
        push xr                                 ; stack it} mov -(xs) xr 
        call gtsmi                              ; check integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_219                           ; 
        dec  m_word [_rc_]                      ; fail if not integer} ppm cnc06  
        jns  _l0417                             ; 
        jmp  cnc06                              ; 
_l0417:                                         ; 
        dec  m_word [_rc_]                      ; fail if negative or too large} ppm cnc06  
        jns  _l0418                             ; 
        jmp  cnc06                              ; 
_l0418:                                         ; 
call_219:                                       ; 
cnc38:
        mov  m_word [kvcas],wc                  ; store new case value} mov kvcas wc 
        jmp  cnc09                              ; merge} brn cnc09  
cnc41:
        mov  m_word [scncc],xs                  ; set flag for scane} mnz scncc  
        call scane                              ; scan quoted file name} jsr scane  
        xor  w0,w0                              ; clear scane flag} zer scncc  
        mov  m_word [scncc],w0                  ; 
        cmp  xl,t_con                           ; if not constant} bne xl =t_con cnc06
        jne  cnc06                              ; 
        cmp  m_word [xr],b_scl                  ; if not string constant} bne (xr) =b_scl cnc06
        jne  cnc06                              ; 
        mov  m_word [r_ifn],xr                  ; save file name} mov r_ifn xr 
        mov  xl,m_word [r_inc]                  ; examine include file name table} mov xl r_inc 
        xor  wb,wb                              ; lookup by value} zer wb  
        call tfind                              ; do lookup} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_220                           ; 
        dec  m_word [_rc_]                      ; never fails} ppm   
        jns  _l0419                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0419:                                         ; 
call_220:                                       ; 
        cmp  xr,inton                           ; ignore if already in table} beq xr =inton cnc09
        je   cnc09                              ; 
        mov  wb,xs                              ; set for trim} mnz wb  
        mov  xr,m_word [r_ifn]                  ; file name} mov xr r_ifn 
        call trimr                              ; remove trailing blanks} jsr trimr  
        mov  xl,m_word [r_inc]                  ; include file name table} mov xl r_inc 
        mov  wb,xs                              ; lookup by name this time} mnz wb  
        call tfind                              ; do lookup} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_221                           ; 
        dec  m_word [_rc_]                      ; never fails} ppm   
        jns  _l0420                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0420:                                         ; 
call_221:                                       ; 
        mov  m_word [(cfp_b*teval)+xl],inton    ; make table value integer 1} mov teval(xl) =inton 
        inc  m_word [cnind]                     ; increase nesting level} icv cnind  
        mov  wa,m_word [cnind]                  ; load new nest level} mov wa cnind 
        cmp  wa,ccinm                           ; fail if excessive nesting} bgt wa =ccinm cnc42
        ja   cnc42                              ; 
        mov  xl,m_word [r_ifa]                  ; array of nested file names} mov xl r_ifa 
        add  wa,vcvlb                           ; compute offset in words} add wa =vcvlb 
        sal  wa,log_cfp_b                       ; convert to bytes} wtb wa  
        add  xl,wa                              ; point to element} add xl wa 
        mov  w0,m_word [r_sfc]                  ; record current file name} mov (xl) r_sfc 
        mov  m_word [xl],w0                     ; 
        mov  xl,wa                              ; preserve nesting byte offset} mov xl wa 
        mov  ia,m_word [rdnln]                  ; fetch source line number as integer} mti rdnln  
        call icbld                              ; convert to icblk} jsr icbld  
        add  xl,m_word [r_ifl]                  ; entry in nested line number array} add xl r_ifl 
        mov  m_word [xl],xr                     ; record in array} mov (xl) xr 
        mov  wa,m_word [cswin]                  ; max read length} mov wa cswin 
        mov  xl,m_word [r_ifn]                  ; include file name} mov xl r_ifn 
        call alocs                              ; get buffer for complete file name} jsr alocs  
        call sysif                              ; open include file} jsr sysif  
        dec  m_word [_rc_]                      ; 
        js   call_222                           ; 
        dec  m_word [_rc_]                      ; could not open} ppm cnc43  
        jns  _l0421                             ; 
        jmp  cnc43                              ; 
_l0421:                                         ; 
call_222:                                       ; 
        xor  wb,wb                              ; do not trim trailing blanks} zer wb  
        call trimr                              ; adjust scblk for actual length} jsr trimr  
        mov  m_word [r_sfc],xr                  ; save ptr to file name} mov r_sfc xr 
        mov  ia,m_word [cmpsn]                  ; current statement as integer} mti cmpsn  
        call icbld                              ; build icblk for stmt number} jsr icbld  
        mov  xl,m_word [r_sfn]                  ; file name table} mov xl r_sfn 
        mov  wb,xs                              ; lookup statement number by name} mnz wb  
        call tfind                              ; allocate new teblk} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_223                           ; 
        dec  m_word [_rc_]                      ; always possible to allocate block} ppm   
        jns  _l0422                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0422:                                         ; 
call_223:                                       ; 
        mov  w0,m_word [r_sfc]                  ; record file name as entry value} mov teval(xl) r_sfc 
        mov  m_word [(cfp_b*teval)+xl],w0       ; 
        xor  w0,w0                              ; restart line counter for new file} zer rdnln  
        mov  m_word [rdnln],w0                  ; 
        cmp  m_word [stage],stgic               ; if initial compile} beq stage =stgic cnc09
        je   cnc09                              ; 
        cmp  m_word [cnind],num01               ; if not first execute-time nesting} bne cnind =num01 cnc09
        jne  cnc09                              ; 
        mov  w0,m_word [r_cim]                  ; remember code argument string} mov r_ici r_cim 
        mov  m_word [r_ici],w0                  ; 
        mov  w0,m_word [scnpt]                  ; save position in string} mov cnspt scnpt 
        mov  m_word [cnspt],w0                  ; 
        mov  w0,m_word [scnil]                  ; and length of string} mov cnsil scnil 
        mov  m_word [cnsil],w0                  ; 
        jmp  cnc09                              ; all done, merge} brn cnc09  
cnc42:
        mov  m_word [_rc_],284                  ; } erb 284 excessively nested include files 
        jmp  err_                               ; 
cnc43:
        mov  m_word [dnamp],xr                  ; release allocated scblk} mov dnamp xr 
        mov  m_word [_rc_],285                  ; } erb 285 include file cannot be opened 
        jmp  err_                               ; 
cnc44:
        call scane                              ; scan integer after -line} jsr scane  
        cmp  xl,t_con                           ; jump if no line number} bne xl =t_con cnc06
        jne  cnc06                              ; 
        cmp  m_word [xr],b_icl                  ; jump if not integer} bne (xr) =b_icl cnc06
        jne  cnc06                              ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; fetch integer line number} ldi icval(xr)  
        cmp  ia,0                               ; error if negative or zero} ile cnc06  
        jle  cnc06                              ; 
        cmp  m_word [stage],stgic               ; skip if initial compile} beq stage =stgic cnc45
        je   cnc45                              ; 
        mov  m_word [cmpln],ia                  ; set directly for other compiles} mfi cmpln  
        jmp  cnc46                              ; no need to set rdnln} brn cnc46  
cnc45:
        sub  ia,m_word [intv1]                  ; adjust number by one} sbi intv1  
        mov  m_word [rdnln],ia                  ; save line number} mfi rdnln  
cnc46:
        mov  m_word [scncc],xs                  ; set flag for scane} mnz scncc  
        call scane                              ; scan quoted file name} jsr scane  
        xor  w0,w0                              ; clear scane flag} zer scncc  
        mov  m_word [scncc],w0                  ; 
        cmp  xl,t_smc                           ; done if no file name} beq xl =t_smc cnc47
        je   cnc47                              ; 
        cmp  xl,t_con                           ; error if not constant} bne xl =t_con cnc06
        jne  cnc06                              ; 
        cmp  m_word [xr],b_scl                  ; if not string constant} bne (xr) =b_scl cnc06
        jne  cnc06                              ; 
        call newfn                              ; record new file name} jsr newfn  
        jmp  cnc09                              ; merge} brn cnc09  
cnc47:
        dec  m_word [scnpt]                     ; set to rescan the terminator} dcv scnpt  
        jmp  cnc09                              ; merge} brn cnc09  
                                                ; end procedure cncrd} enp   
dffnc:
                                                ; entry point} prc e 0 
        cmp  m_word [xl],b_efc                  ; skip if new function not external} bne (xl) =b_efc dffn1
        jne  dffn1                              ; 
        inc  m_word [(cfp_b*efuse)+xl]          ; else increment its use count} icv efuse(xl)  
dffn1:
        mov  wa,xr                              ; save vrblk pointer} mov wa xr 
        mov  xr,m_word [(cfp_b*vrfnc)+xr]       ; load old function pointer} mov xr vrfnc(xr) 
        cmp  m_word [xr],b_efc                  ; jump if old function not external} bne (xr) =b_efc dffn2
        jne  dffn2                              ; 
        mov  wb,m_word [(cfp_b*efuse)+xr]       ; else get use count} mov wb efuse(xr) 
        dec  wb                                 ; decrement} dcv wb  
        mov  m_word [(cfp_b*efuse)+xr],wb       ; store decremented value} mov efuse(xr) wb 
        test wb,wb                              ; jump if use count still non-zero} bnz wb dffn2 
        jnz  dffn2                              ; 
        call sysul                              ; else call system unload function} jsr sysul  
dffn2:
        mov  xr,wa                              ; restore vrblk pointer} mov xr wa 
        mov  wa,xl                              ; copy function block ptr} mov wa xl 
        cmp  xr,r_yyy                           ; skip checks if opsyn op definition} blt xr =r_yyy dffn3
        jb   dffn3                              ; 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; jump if not system variable} bnz vrlen(xr) dffn3 
        jnz  dffn3                              ; 
        mov  xl,m_word [(cfp_b*vrsvp)+xr]       ; point to svblk} mov xl vrsvp(xr) 
        mov  wb,m_word [(cfp_b*svbit)+xl]       ; load bit indicators} mov wb svbit(xl) 
        and  wb,m_word [btfnc]                  ; is it a system function} anb wb btfnc 
        test wb,wb                              ; redef ok if not} zrb wb dffn3 
        jz   dffn3                              ; 
        mov  m_word [_rc_],248                  ; } erb 248 attempted redefinition of system function 
        jmp  err_                               ; 
dffn3:
        mov  m_word [(cfp_b*vrfnc)+xr],wa       ; store new function pointer} mov vrfnc(xr) wa 
        mov  xl,wa                              ; restore function block pointer} mov xl wa 
        ret                                     ; return to dffnc caller} exi   
                                                ; end procedure dffnc} enp   
dtach:
                                                ; entry point} prc e 0 
        mov  m_word [dtcnb],xl                  ; store name base (gbcol not called)} mov dtcnb xl 
        add  xl,wa                              ; point to name location} add xl wa 
        mov  m_word [dtcnm],xl                  ; store it} mov dtcnm xl 
dtch1:
        mov  xr,xl                              ; copy name pointer} mov xr xl 
dtch2:
        mov  xl,m_word [xl]                     ; point to next value} mov xl (xl) 
        cmp  m_word [xl],b_trt                  ; jump at chain end} bne (xl) =b_trt dtch6
        jne  dtch6                              ; 
        mov  wa,m_word [(cfp_b*trtyp)+xl]       ; get trap block type} mov wa trtyp(xl) 
        cmp  wa,trtin                           ; jump if input} beq wa =trtin dtch3
        je   dtch3                              ; 
        cmp  wa,trtou                           ; jump if output} beq wa =trtou dtch3
        je   dtch3                              ; 
        add  xl,cfp_b*trnxt                     ; point to next link} add xl *trnxt 
        jmp  dtch1                              ; loop} brn dtch1  
dtch3:
        mov  w0,m_word [(cfp_b*trval)+xl]       ; delete trblk} mov (xr) trval(xl) 
        mov  m_word [xr],w0                     ; 
        mov  wa,xl                              ; dump xl ...} mov wa xl 
        mov  wb,xr                              ; ... and xr} mov wb xr 
        mov  xl,m_word [(cfp_b*trtrf)+xl]       ; point to trtrf trap block} mov xl trtrf(xl) 
        test xl,xl                              ; jump if no iochn} bze xl dtch5 
        jz   dtch5                              ; 
        cmp  m_word [xl],b_trt                  ; jump if input, output, terminal} bne (xl) =b_trt dtch5
        jne  dtch5                              ; 
dtch4:
        mov  xr,xl                              ; remember link ptr} mov xr xl 
        mov  xl,m_word [(cfp_b*trtrf)+xl]       ; point to next link} mov xl trtrf(xl) 
        test xl,xl                              ; jump if end of chain} bze xl dtch5 
        jz   dtch5                              ; 
        mov  wc,m_word [(cfp_b*ionmb)+xl]       ; get name base} mov wc ionmb(xl) 
        add  wc,m_word [(cfp_b*ionmo)+xl]       ; add offset} add wc ionmo(xl) 
        cmp  wc,m_word [dtcnm]                  ; loop if no match} bne wc dtcnm dtch4
        jne  dtch4                              ; 
        mov  w0,m_word [(cfp_b*trtrf)+xl]       ; remove name from chain} mov trtrf(xr) trtrf(xl) 
        mov  m_word [(cfp_b*trtrf)+xr],w0       ; 
dtch5:
        mov  xl,wa                              ; recover xl ...} mov xl wa 
        mov  xr,wb                              ; ... and xr} mov xr wb 
        add  xl,cfp_b*trval                     ; point to value field} add xl *trval 
        jmp  dtch2                              ; continue} brn dtch2  
dtch6:
        mov  xr,m_word [dtcnb]                  ; possible vrblk ptr} mov xr dtcnb 
        call setvr                              ; reset vrblk if necessary} jsr setvr  
        ret                                     ; return} exi   
                                                ; end procedure dtach} enp   
dtype:
                                                ; entry point} prc e 0 
        cmp  m_word [xr],b_pdt                  ; jump if prog.defined} beq (xr) =b_pdt dtyp1
        je   dtyp1                              ; 
        mov  xr,m_word [xr]                     ; load type word} mov xr (xr) 
        movzx xr,byte [xr-1]                    ; get entry point id (block code)} lei xr  
        sal  xr,log_cfp_b                       ; convert to byte offset} wtb xr  
        mov  xr,m_word [scnmt+xr]               ; load table entry} mov xr scnmt(xr) 
        ret                                     ; exit to dtype caller} exi   
dtyp1:
        mov  xr,m_word [(cfp_b*pddfp)+xr]       ; point to dfblk} mov xr pddfp(xr) 
        mov  xr,m_word [(cfp_b*dfnam)+xr]       ; get datatype name from dfblk} mov xr dfnam(xr) 
        ret                                     ; return to dtype caller} exi   
                                                ; end procedure dtype} enp   
dumpr:
                                                ; entry point} prc e 0 
        test xr,xr                              ; skip dump if argument is zero} bze xr dmp28 
        jz   dmp28                              ; 
        cmp  xr,num03                           ; jump if core dump required} bgt xr =num03 dmp29
        ja   dmp29                              ; 
        xor  xl,xl                              ; clear xl} zer xl  
        xor  wb,wb                              ; zero move offset} zer wb  
        mov  m_word [dmarg],xr                  ; save dump argument} mov dmarg xr 
        xor  w0,w0                              ; collect sediment too} zer dnams  
        mov  m_word [dnams],w0                  ; 
        call gbcol                              ; collect garbage} jsr gbcol  
        call prtpg                              ; eject printer} jsr prtpg  
        mov  xr,dmhdv                           ; point to heading for variables} mov xr =dmhdv 
        call prtst                              ; print it} jsr prtst  
        call prtnl                              ; terminate print line} jsr prtnl  
        call prtnl                              ; and print a blank line} jsr prtnl  
        xor  w0,w0                              ; set null chain to start} zer dmvch  
        mov  m_word [dmvch],w0                  ; 
        mov  wa,m_word [hshtb]                  ; point to hash table} mov wa hshtb 
dmp00:
        mov  xr,wa                              ; copy hash bucket pointer} mov xr wa 
        add  wa,cfp_b                           ; bump pointer} ica wa  
        sub  xr,cfp_b*vrnxt                     ; set offset to merge} sub xr *vrnxt 
dmp01:
        mov  xr,m_word [(cfp_b*vrnxt)+xr]       ; point to next vrblk on chain} mov xr vrnxt(xr) 
        test xr,xr                              ; jump if end of this hash chain} bze xr dmp09 
        jz   dmp09                              ; 
        mov  xl,xr                              ; else copy vrblk pointer} mov xl xr 
dmp02:
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load value} mov xl vrval(xl) 
        cmp  m_word [dmarg],num03               ; skip null value check if dump(3)} beq dmarg =num03 dmp2a
        je   dmp2a                              ; 
        cmp  xl,nulls                           ; loop for next vrblk if null value} beq xl =nulls dmp01
        je   dmp01                              ; 
dmp2a:
        cmp  m_word [xl],b_trt                  ; loop back if value is trapped} beq (xl) =b_trt dmp02
        je   dmp02                              ; 
        mov  wc,xr                              ; save vrblk pointer} mov wc xr 
        add  xr,cfp_b*vrsof                     ; adjust ptr to be like scblk ptr} add xr *vrsof 
        cmp  m_word [(cfp_b*sclen)+xr],0        ; jump if non-system variable} bnz sclen(xr) dmp03 
        jnz  dmp03                              ; 
        mov  xr,m_word [(cfp_b*vrsvo)+xr]       ; else load ptr to name in svblk} mov xr vrsvo(xr) 
dmp03:
        mov  wb,xr                              ; save pointer to chars} mov wb xr 
        mov  m_word [dmpsv],wa                  ; save hash bucket pointer} mov dmpsv wa 
        mov  wa,dmvch                           ; point to chain head} mov wa =dmvch 
dmp04:
        mov  m_word [dmpch],wa                  ; save chain pointer} mov dmpch wa 
        mov  xl,wa                              ; copy it} mov xl wa 
        mov  xr,m_word [xl]                     ; load pointer to next entry} mov xr (xl) 
        test xr,xr                              ; jump if end of chain to insert} bze xr dmp08 
        jz   dmp08                              ; 
        add  xr,cfp_b*vrsof                     ; else get name ptr for chained vrblk} add xr *vrsof 
        cmp  m_word [(cfp_b*sclen)+xr],0        ; jump if not system variable} bnz sclen(xr) dmp05 
        jnz  dmp05                              ; 
        mov  xr,m_word [(cfp_b*vrsvo)+xr]       ; else point to name in svblk} mov xr vrsvo(xr) 
dmp05:
        mov  xl,wb                              ; point to entering vrblk string} mov xl wb 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load its length} mov wa sclen(xl) 
        add  xl,cfp_f                           ; point to chars of entering string} plc xl  
        cmp  wa,m_word [(cfp_b*sclen)+xr]       ; jump if entering length high} bhi wa sclen(xr) dmp06
        ja   dmp06                              ; 
        add  xr,cfp_f                           ; else point to chars of old string} plc xr  
        repe cmps_b                             ; compare, insert if new is llt old} cmc dmp08 dmp07 
        mov  xl,0                               ; 
        mov  xr,xl                              ; 
        ja   dmp07                              ; 
        jb   dmp08                              ; 
        jmp  dmp08                              ; or if leq (we had shorter length)} brn dmp08  
dmp06:
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; load shorter length} mov wa sclen(xr) 
        add  xr,cfp_f                           ; point to chars of old string} plc xr  
        repe cmps_b                             ; compare, insert if new one low} cmc dmp08 dmp07 
        mov  xl,0                               ; 
        mov  xr,xl                              ; 
        ja   dmp07                              ; 
        jb   dmp08                              ; 
dmp07:
        mov  xl,m_word [dmpch]                  ; copy chain pointer} mov xl dmpch 
        mov  wa,m_word [xl]                     ; move to next entry on chain} mov wa (xl) 
        jmp  dmp04                              ; loop back} brn dmp04  
dmp08:
        mov  xl,m_word [dmpch]                  ; copy chain pointer} mov xl dmpch 
        mov  wa,m_word [dmpsv]                  ; restore hash bucket pointer} mov wa dmpsv 
        mov  xr,wc                              ; restore vrblk pointer} mov xr wc 
        mov  w0,m_word [xl]                     ; link vrblk to rest of chain} mov vrget(xr) (xl) 
        mov  m_word [(cfp_b*vrget)+xr],w0       ; 
        mov  m_word [xl],xr                     ; link vrblk into current chain loc} mov (xl) xr 
        jmp  dmp01                              ; loop back for next vrblk} brn dmp01  
dmp09:
        cmp  wa,m_word [hshte]                  ; loop back if more buckets to go} bne wa hshte dmp00
        jne  dmp00                              ; 
dmp10:
        mov  xr,m_word [dmvch]                  ; load pointer to next entry on chain} mov xr dmvch 
        test xr,xr                              ; jump if end of chain} bze xr dmp11 
        jz   dmp11                              ; 
        mov  w0,m_word [xr]                     ; else update chain ptr to next entry} mov dmvch (xr) 
        mov  m_word [dmvch],w0                  ; 
        call setvr                              ; restore vrget field} jsr setvr  
        mov  xl,xr                              ; copy vrblk pointer (name base)} mov xl xr 
        mov  wa,cfp_b*vrval                     ; set offset for vrblk name} mov wa *vrval 
        call prtnv                              ; print name = value} jsr prtnv  
        jmp  dmp10                              ; loop back till all printed} brn dmp10  
dmp11:
        call prtnl                              ; print blank line} jsr prtnl  
        call prtnl                              ; and another} jsr prtnl  
        mov  xr,dmhdk                           ; point to keyword heading} mov xr =dmhdk 
        call prtst                              ; print heading} jsr prtst  
        call prtnl                              ; end line} jsr prtnl  
        call prtnl                              ; print one blank line} jsr prtnl  
        mov  xl,vdmkw                           ; point to list of keyword svblk ptrs} mov xl =vdmkw 
dmp12:
        lods_w                                  ; load next svblk ptr from table} mov xr (xl)+ 
        mov  xr,w0                              ; 
        test xr,xr                              ; jump if end of list} bze xr dmp13 
        jz   dmp13                              ; 
        cmp  xr,num01                           ; &compare ignored if not implemented} beq xr =num01 dmp12
        je   dmp12                              ; 
        mov  wa,ch_am                           ; load ampersand} mov wa =ch_am 
        call prtch                              ; print ampersand} jsr prtch  
        call prtst                              ; print keyword name} jsr prtst  
        mov  wa,m_word [(cfp_b*svlen)+xr]       ; load name length from svblk} mov wa svlen(xr) 
        add  wa,(cfp_b-1)+cfp_b*svchs           ; get length of name} ctb wa svchs 
        and  wa,-cfp_b                          ; 
        add  xr,wa                              ; point to svknm field} add xr wa 
        mov  w0,m_word [xr]                     ; store in dummy kvblk} mov dmpkn (xr) 
        mov  m_word [dmpkn],w0                  ; 
        mov  xr,tmbeb                           ; point to blank-equal-blank} mov xr =tmbeb 
        call prtst                              ; print it} jsr prtst  
        mov  m_word [dmpsv],xl                  ; save table pointer} mov dmpsv xl 
        mov  xl,dmpkb                           ; point to dummy kvblk} mov xl =dmpkb 
        mov  m_word [xl],b_kvt                  ; build type word} mov (xl) =b_kvt 
        mov  m_word [(cfp_b*kvvar)+xl],trbkv    ; build ptr to dummy trace block} mov kvvar(xl) =trbkv 
        mov  wa,cfp_b*kvvar                     ; set zero offset} mov wa *kvvar 
        call acess                              ; get keyword value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_224                           ; 
        dec  m_word [_rc_]                      ; failure is impossible} ppm   
        jns  _l0423                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0423:                                         ; 
call_224:                                       ; 
        call prtvl                              ; print keyword value} jsr prtvl  
        call prtnl                              ; terminate print line} jsr prtnl  
        mov  xl,m_word [dmpsv]                  ; restore table pointer} mov xl dmpsv 
        jmp  dmp12                              ; loop back till all printed} brn dmp12  
dmp13:
        cmp  m_word [dmarg],num01               ; exit if partial dump complete} beq dmarg =num01 dmp27
        je   dmp27                              ; 
        mov  xr,m_word [dnamb]                  ; else point to first dynamic block} mov xr dnamb 
dmp14:
        cmp  xr,m_word [dnamp]                  ; jump if end of used region} beq xr dnamp dmp27
        je   dmp27                              ; 
        mov  wa,m_word [xr]                     ; else load first word of block} mov wa (xr) 
        cmp  wa,b_vct                           ; jump if vector} beq wa =b_vct dmp16
        je   dmp16                              ; 
        cmp  wa,b_art                           ; jump if array} beq wa =b_art dmp17
        je   dmp17                              ; 
        cmp  wa,b_pdt                           ; jump if program defined} beq wa =b_pdt dmp18
        je   dmp18                              ; 
        cmp  wa,b_tbt                           ; jump if table} beq wa =b_tbt dmp19
        je   dmp19                              ; 
dmp15:
        call blkln                              ; get length of block} jsr blkln  
        add  xr,wa                              ; point past this block} add xr wa 
        jmp  dmp14                              ; loop back for next block} brn dmp14  
dmp16:
        mov  wb,cfp_b*vcvls                     ; set offset to first value} mov wb *vcvls 
        jmp  dmp19                              ; jump to merge} brn dmp19  
dmp17:
        mov  wb,m_word [(cfp_b*arofs)+xr]       ; set offset to arpro field} mov wb arofs(xr) 
        add  wb,cfp_b                           ; bump to get offset to values} ica wb  
        jmp  dmp19                              ; jump to merge} brn dmp19  
dmp18:
        mov  wb,cfp_b*pdfld                     ; point to values, merge} mov wb *pdfld 
dmp19:
        cmp  m_word [(cfp_b*idval)+xr],0        ; ignore block if zero id value} bze idval(xr) dmp15 
        jz   dmp15                              ; 
        call blkln                              ; else get block length} jsr blkln  
        mov  xl,xr                              ; copy block pointer} mov xl xr 
        mov  m_word [dmpsv],wa                  ; save length} mov dmpsv wa 
        mov  wa,wb                              ; copy offset to first value} mov wa wb 
        call prtnl                              ; print blank line} jsr prtnl  
        mov  m_word [dmpsa],wa                  ; preserve offset} mov dmpsa wa 
        call prtvl                              ; print block value (for title)} jsr prtvl  
        mov  wa,m_word [dmpsa]                  ; recover offset} mov wa dmpsa 
        call prtnl                              ; end print line} jsr prtnl  
        cmp  m_word [xr],b_tbt                  ; jump if table} beq (xr) =b_tbt dmp22
        je   dmp22                              ; 
        sub  wa,cfp_b                           ; point before first word} dca wa  
dmp20:
        mov  xr,xl                              ; copy block pointer} mov xr xl 
        add  wa,cfp_b                           ; bump offset} ica wa  
        add  xr,wa                              ; point to next value} add xr wa 
        cmp  wa,m_word [dmpsv]                  ; exit if end (xr past block)} beq wa dmpsv dmp14
        je   dmp14                              ; 
        sub  xr,cfp_b*vrval                     ; subtract offset to merge into loop} sub xr *vrval 
dmp21:
        mov  xr,m_word [(cfp_b*vrval)+xr]       ; load next value} mov xr vrval(xr) 
        cmp  m_word [dmarg],num03               ; skip null value check if dump(3)} beq dmarg =num03 dmp2b
        je   dmp2b                              ; 
        cmp  xr,nulls                           ; loop back if null value} beq xr =nulls dmp20
        je   dmp20                              ; 
dmp2b:
        cmp  m_word [xr],b_trt                  ; loop back if trapped} beq (xr) =b_trt dmp21
        je   dmp21                              ; 
        call prtnv                              ; else print name = value} jsr prtnv  
        jmp  dmp20                              ; loop back for next field} brn dmp20  
dmp22:
        mov  wc,cfp_b*tbbuk                     ; set offset to first bucket} mov wc *tbbuk 
        mov  wa,cfp_b*teval                     ; set name offset for all teblks} mov wa *teval 
dmp23:
        push xl                                 ; save tbblk pointer} mov -(xs) xl 
        add  xl,wc                              ; point to next bucket header} add xl wc 
        add  wc,cfp_b                           ; bump bucket offset} ica wc  
        sub  xl,cfp_b*tenxt                     ; subtract offset to merge into loop} sub xl *tenxt 
dmp24:
        mov  xl,m_word [(cfp_b*tenxt)+xl]       ; point to next teblk} mov xl tenxt(xl) 
        cmp  xl,m_word [xs]                     ; jump if end of chain} beq xl (xs) dmp26
        je   dmp26                              ; 
        mov  xr,xl                              ; else copy teblk pointer} mov xr xl 
dmp25:
        mov  xr,m_word [(cfp_b*teval)+xr]       ; load next value} mov xr teval(xr) 
        cmp  xr,nulls                           ; ignore if null value} beq xr =nulls dmp24
        je   dmp24                              ; 
        cmp  m_word [xr],b_trt                  ; loop back if trapped} beq (xr) =b_trt dmp25
        je   dmp25                              ; 
        mov  m_word [dmpsv],wc                  ; else save offset pointer} mov dmpsv wc 
        call prtnv                              ; print name = value} jsr prtnv  
        mov  wc,m_word [dmpsv]                  ; reload offset} mov wc dmpsv 
        jmp  dmp24                              ; loop back for next teblk} brn dmp24  
dmp26:
        pop  xl                                 ; restore tbblk pointer} mov xl (xs)+ 
        cmp  wc,m_word [(cfp_b*tblen)+xl]       ; loop back if more buckets to go} bne wc tblen(xl) dmp23
        jne  dmp23                              ; 
        mov  xr,xl                              ; else copy table pointer} mov xr xl 
        add  xr,wc                              ; point to following block} add xr wc 
        jmp  dmp14                              ; loop back to process next block} brn dmp14  
dmp27:
        call prtpg                              ; eject printer} jsr prtpg  
dmp28:
        ret                                     ; return to dump caller} exi   
dmp29:
        call sysdm                              ; call it} jsr sysdm  
        jmp  dmp28                              ; return} brn dmp28  
                                                ; end procedure dumpr} enp   
ermsg:
                                                ; entry point} prc e 0 
        mov  wa,m_word [kvert]                  ; load error code} mov wa kvert 
        mov  xr,ermms                           ; point to error message /error/} mov xr =ermms 
        call prtst                              ; print it} jsr prtst  
        call ertex                              ; get error message text} jsr ertex  
        add  wa,thsnd                           ; bump error code for print} add wa =thsnd 
        mov  ia,wa                              ; fail code in int acc} mti wa  
        mov  wb,m_word [profs]                  ; save current buffer position} mov wb profs 
        call prtin                              ; print code (now have error1xxx)} jsr prtin  
        mov  xl,m_word [prbuf]                  ; point to print buffer} mov xl prbuf 
        lea  xl,[cfp_f+xl+wb]                   ; point to the 1} psc xl wb 
        mov  wa,ch_bl                           ; load a blank} mov wa =ch_bl 
        mov  m_char [xl],cl                     ; store blank over 1 (error xxx)} sch wa (xl) 
        xor  xl,xl                              ; clear garbage pointer in xl} zer xl  
        mov  wa,xr                              ; keep error text} mov wa xr 
        mov  xr,ermns                           ; point to / -- /} mov xr =ermns 
        call prtst                              ; print it} jsr prtst  
        mov  xr,wa                              ; get error text again} mov xr wa 
        call prtst                              ; print error message text} jsr prtst  
        call prtis                              ; print line} jsr prtis  
        call prtis                              ; print blank line} jsr prtis  
        ret                                     ; return to ermsg caller} exi   
                                                ; end procedure ermsg} enp   
ertex:
                                                ; entry point} prc e 0 
        mov  m_word [ertwa],wa                  ; save wa} mov ertwa wa 
        mov  m_word [ertwb],wb                  ; save wb} mov ertwb wb 
        call sysem                              ; get failure message text} jsr sysem  
        mov  xl,xr                              ; copy pointer to it} mov xl xr 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; get length of string} mov wa sclen(xr) 
        test wa,wa                              ; jump if null} bze wa ert02 
        jz   ert02                              ; 
        xor  wb,wb                              ; offset of zero} zer wb  
        call sbstr                              ; copy into dynamic store} jsr sbstr  
        mov  m_word [r_etx],xr                  ; store for relocation} mov r_etx xr 
ert01:
        mov  wb,m_word [ertwb]                  ; restore wb} mov wb ertwb 
        mov  wa,m_word [ertwa]                  ; restore wa} mov wa ertwa 
        ret                                     ; return to caller} exi   
ert02:
        mov  xr,m_word [r_etx]                  ; get errtext} mov xr r_etx 
        jmp  ert01                              ; return} brn ert01  
                                                ; } enp   
evali:
                                                ; entry point (recursive)} prc r 4 
        call evalp                              ; evaluate expression} jsr evalp  
        dec  m_word [_rc_]                      ; 
        js   call_225                           ; 
        dec  m_word [_rc_]                      ; jump on failure} ppm evli1  
        jns  _l0424                             ; 
        jmp  evli1                              ; 
_l0424:                                         ; 
call_225:                                       ; 
        push xl                                 ; stack result for gtsmi} mov -(xs) xl 
        mov  xl,m_word [(cfp_b*pthen)+xr]       ; load successor pointer} mov xl pthen(xr) 
        mov  m_word [evlio],xr                  ; save original node pointer} mov evlio xr 
        mov  m_word [evlif],wc                  ; zero if simple argument} mov evlif wc 
        call gtsmi                              ; convert arg to small integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_226                           ; 
        dec  m_word [_rc_]                      ; jump if not integer} ppm evli2  
        jns  _l0425                             ; 
        jmp  evli2                              ; 
_l0425:                                         ; 
        dec  m_word [_rc_]                      ; jump if out of range} ppm evli3  
        jns  _l0426                             ; 
        jmp  evli3                              ; 
_l0426:                                         ; 
call_226:                                       ; 
        mov  m_word [evliv],xr                  ; store result in special dummy node} mov evliv xr 
        mov  xr,evlin                           ; point to dummy node with result} mov xr =evlin 
        mov  m_word [xr],p_len                  ; dummy pattern block pcode} mov (xr) =p_len 
        mov  m_word [(cfp_b*pthen)+xr],xl       ; store successor pointer} mov pthen(xr) xl 
        mov  m_word [_rc_],4                    ; take successful exit} exi 4  
        ret                                     ; 
evli1:
        mov  m_word [_rc_],3                    ; take failure return} exi 3  
        ret                                     ; 
evli2:
        mov  m_word [_rc_],1                    ; take non-integer error exit} exi 1  
        ret                                     ; 
evli3:
        mov  m_word [_rc_],2                    ; take out-of-range error exit} exi 2  
        ret                                     ; 
                                                ; end procedure evali} enp   
evalp:
                                                ; entry point (recursive)} prc r 1 
        mov  xl,m_word [(cfp_b*parm1)+xr]       ; load expression pointer} mov xl parm1(xr) 
        cmp  m_word [xl],b_exl                  ; jump if exblk case} beq (xl) =b_exl evlp1
        je   evlp1                              ; 
        mov  xl,m_word [(cfp_b*sevar)+xl]       ; load vrblk pointer} mov xl sevar(xl) 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; load value of vrblk} mov xl vrval(xl) 
        mov  wa,m_word [xl]                     ; load first word of value} mov wa (xl) 
        cmp  wa,b_t__                           ; jump if not seblk, trblk or exblk} bhi wa =b_t__ evlp3
        ja   evlp3                              ; 
evlp1:
        cmp  xs,m_word [lowspminx]              ; check for stack space} chk   
        jae  _l0427                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0427:                                         ; 
        push xr                                 ; stack node pointer} mov -(xs) xr 
        push wb                                 ; stack cursor} mov -(xs) wb 
        push m_word [r_pms]                     ; stack subject string pointer} mov -(xs) r_pms 
        push m_word [pmssl]                     ; stack subject string length} mov -(xs) pmssl 
        push m_word [pmdfl]                     ; stack dot flag} mov -(xs) pmdfl 
        push m_word [pmhbs]                     ; stack history stack base pointer} mov -(xs) pmhbs 
        mov  xr,m_word [(cfp_b*parm1)+xr]       ; load expression pointer} mov xr parm1(xr) 
evlp2:
        xor  wb,wb                              ; set flag for by value} zer wb  
        call evalx                              ; evaluate expression} jsr evalx  
        dec  m_word [_rc_]                      ; 
        js   call_227                           ; 
        dec  m_word [_rc_]                      ; jump on failure} ppm evlp4  
        jns  _l0428                             ; 
        jmp  evlp4                              ; 
_l0428:                                         ; 
call_227:                                       ; 
        mov  wa,m_word [xr]                     ; else load first word of value} mov wa (xr) 
        cmp  wa,b_e__                           ; loop back to reevaluate expression} blo wa =b_e__ evlp2
        jb   evlp2                              ; 
        mov  xl,xr                              ; copy result pointer} mov xl xr 
        pop  m_word [pmhbs]                     ; restore history stack base pointer} mov pmhbs (xs)+ 
        pop  m_word [pmdfl]                     ; restore dot flag} mov pmdfl (xs)+ 
        pop  m_word [pmssl]                     ; restore subject string length} mov pmssl (xs)+ 
        pop  m_word [r_pms]                     ; restore subject string pointer} mov r_pms (xs)+ 
        pop  wb                                 ; restore cursor} mov wb (xs)+ 
        pop  xr                                 ; restore node pointer} mov xr (xs)+ 
        mov  wc,xr                              ; non-zero for simple vrblk} mov wc xr 
        mov  m_word [_rc_],0                    ; return to evalp caller} exi   
        ret                                     ; 
evlp3:
        xor  wc,wc                              ; simple vrblk, no side effects} zer wc  
        mov  m_word [_rc_],0                    ; return to evalp caller} exi   
        ret                                     ; 
evlp4:
        pop  m_word [pmhbs]                     ; restore history stack base pointer} mov pmhbs (xs)+ 
        pop  m_word [pmdfl]                     ; restore dot flag} mov pmdfl (xs)+ 
        pop  m_word [pmssl]                     ; restore subject string length} mov pmssl (xs)+ 
        pop  m_word [r_pms]                     ; restore subject string pointer} mov r_pms (xs)+ 
        add  xs,cfp_b*num02                     ; remove node ptr, cursor} add xs *num02 
        mov  m_word [_rc_],1                    ; take failure exit} exi 1  
        ret                                     ; 
                                                ; end procedure evalp} enp   
evals:
                                                ; entry point (recursive)} prc r 3 
        call evalp                              ; evaluate expression} jsr evalp  
        dec  m_word [_rc_]                      ; 
        js   call_228                           ; 
        dec  m_word [_rc_]                      ; jump if evaluation fails} ppm evls1  
        jns  _l0429                             ; 
        jmp  evls1                              ; 
_l0429:                                         ; 
call_228:                                       ; 
        push m_word [(cfp_b*pthen)+xr]          ; save successor pointer} mov -(xs) pthen(xr) 
        push wb                                 ; save cursor} mov -(xs) wb 
        push xl                                 ; stack result ptr for patst} mov -(xs) xl 
        xor  wb,wb                              ; dummy pcode for one char string} zer wb  
        xor  wc,wc                              ; dummy pcode for expression arg} zer wc  
        mov  xl,p_brk                           ; appropriate pcode for our use} mov xl =p_brk 
        call patst                              ; call routine to build node} jsr patst  
        dec  m_word [_rc_]                      ; 
        js   call_229                           ; 
        dec  m_word [_rc_]                      ; jump if not string} ppm evls2  
        jns  _l0430                             ; 
        jmp  evls2                              ; 
_l0430:                                         ; 
call_229:                                       ; 
        pop  wb                                 ; restore cursor} mov wb (xs)+ 
        pop  m_word [(cfp_b*pthen)+xr]          ; store successor pointer} mov pthen(xr) (xs)+ 
        mov  m_word [_rc_],3                    ; take success return} exi 3  
        ret                                     ; 
evls1:
        mov  m_word [_rc_],2                    ; take failure return} exi 2  
        ret                                     ; 
evls2:
        add  xs,cfp_b*num02                     ; pop successor and cursor} add xs *num02 
        mov  m_word [_rc_],1                    ; take non-string error exit} exi 1  
        ret                                     ; 
                                                ; end procedure evals} enp   
evalx:
                                                ; entry point, recursive} prc r 1 
        cmp  m_word [xr],b_exl                  ; jump if exblk case} beq (xr) =b_exl evlx2
        je   evlx2                              ; 
        mov  xl,m_word [(cfp_b*sevar)+xr]       ; load vrblk pointer (name base)} mov xl sevar(xr) 
        mov  wa,cfp_b*vrval                     ; set name offset} mov wa *vrval 
        test wb,wb                              ; jump if called by name} bnz wb evlx1 
        jnz  evlx1                              ; 
        call acess                              ; call routine to access value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_230                           ; 
        dec  m_word [_rc_]                      ; jump if failure on access} ppm evlx9  
        jns  _l0431                             ; 
        jmp  evlx9                              ; 
_l0431:                                         ; 
call_230:                                       ; 
evlx1:
        mov  m_word [_rc_],0                    ; return to evalx caller} exi   
        ret                                     ; 
evlx2:
        mov  wc,r13                             ; get code pointer} scp wc  
        mov  wa,m_word [r_cod]                  ; load code block pointer} mov wa r_cod 
        sub  wc,wa                              ; get code pointer as offset} sub wc wa 
        push wa                                 ; stack old code block pointer} mov -(xs) wa 
        push wc                                 ; stack relative code offset} mov -(xs) wc 
        push m_word [flptr]                     ; stack old failure pointer} mov -(xs) flptr 
        push wb                                 ; stack name/value indicator} mov -(xs) wb 
        push cfp_b*exflc                        ; stack new fail offset} mov -(xs) *exflc 
        mov  w0,m_word [flptr]                  ; keep in case of error} mov gtcef flptr 
        mov  m_word [gtcef],w0                  ; 
        mov  w0,m_word [r_cod]                  ; keep code block pointer similarly} mov r_gtc r_cod 
        mov  m_word [r_gtc],w0                  ; 
        mov  m_word [flptr],xs                  ; set new failure pointer} mov flptr xs 
        mov  m_word [r_cod],xr                  ; set new code block pointer} mov r_cod xr 
        mov  w0,m_word [kvstn]                  ; remember stmnt number} mov exstm(xr) kvstn 
        mov  m_word [(cfp_b*exstm)+xr],w0       ; 
        add  xr,cfp_b*excod                     ; point to first code word} add xr *excod 
        mov  r13,xr                             ; set code pointer} lcp xr  
        cmp  m_word [stage],stgxt               ; jump if not execution time} bne stage =stgxt evlx0
        jne  evlx0                              ; 
        mov  m_word [stage],stgee               ; evaluating expression} mov stage =stgee 
evlx0:
        xor  xl,xl                              ; clear garbage xl} zer xl  
        mov  r10,m_word [r13]                   ; load first code word} lcw xr  
        mov  xr,r10                             ; 
        add  r13,cfp_b                          ; 
        jmp  m_word [xr]                        ; execute it} bri (xr)  
evlx3:
        pop  xr                                 ; load value} mov xr (xs)+ 
        cmp  m_word [(cfp_b*num01)+xs],0        ; jump if called by value} bze num01(xs) evlx5 
        jz   evlx5                              ; 
        mov  m_word [_rc_],249                  ; } erb 249 expression evaluated by name returned value 
        jmp  err_                               ; 
evlx4:
        pop  wa                                 ; load name offset} mov wa (xs)+ 
        pop  xl                                 ; load name base} mov xl (xs)+ 
        cmp  m_word [(cfp_b*num01)+xs],0        ; jump if called by name} bnz num01(xs) evlx5 
        jnz  evlx5                              ; 
        call acess                              ; else access value first} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_231                           ; 
        dec  m_word [_rc_]                      ; jump if failure during access} ppm evlx6  
        jns  _l0432                             ; 
        jmp  evlx6                              ; 
_l0432:                                         ; 
call_231:                                       ; 
evlx5:
        xor  wb,wb                              ; note successful} zer wb  
        jmp  evlx7                              ; merge} brn evlx7  
evlx6:
        mov  wb,xs                              ; note unsuccessful} mnz wb  
evlx7:
        cmp  m_word [stage],stgee               ; skip if was not previously xl} bne stage =stgee evlx8
        jne  evlx8                              ; 
        mov  m_word [stage],stgxt               ; execute time} mov stage =stgxt 
evlx8:
        add  xs,cfp_b*num02                     ; pop name/value indicator, *exfal} add xs *num02 
        pop  m_word [flptr]                     ; restore old failure pointer} mov flptr (xs)+ 
        pop  wc                                 ; load code offset} mov wc (xs)+ 
        add  wc,m_word [xs]                     ; make code pointer absolute} add wc (xs) 
        pop  m_word [r_cod]                     ; restore old code block pointer} mov r_cod (xs)+ 
        mov  r13,wc                             ; restore old code pointer} lcp wc  
        test wb,wb                              ; jump for successful return} bze wb evlx1 
        jz   evlx1                              ; 
evlx9:
        cmp  m_word [stage],stgev               ; return failure} bne stage =stgev evlxa
        jne  evlxa                              ; 
        mov  m_word [_rc_],0                    ; no failure} exi 0  
        ret                                     ; 
evlxa:
        mov  m_word [_rc_],1                    ; failure} exi 1  
        ret                                     ; 
                                                ; end of procedure evalx} enp   
exbld:
                                                ; entry point} prc e 0 
        mov  wa,xl                              ; copy offset to start of code} mov wa xl 
        sub  wa,cfp_b*excod                     ; calc reduction in offset in exblk} sub wa *excod 
        push wa                                 ; stack for later} mov -(xs) wa 
        mov  wa,m_word [cwcof]                  ; load final offset} mov wa cwcof 
        sub  wa,xl                              ; compute length of code} sub wa xl 
        add  wa,cfp_b*exsi_                     ; add space for standard fields} add wa *exsi_ 
        call alloc                              ; allocate space for exblk} jsr alloc  
        push xr                                 ; save pointer to exblk} mov -(xs) xr 
        mov  m_word [(cfp_b*extyp)+xr],b_exl    ; store type word} mov extyp(xr) =b_exl 
        xor  w0,w0                              ; zeroise stmnt number field} zer exstm(xr)  
        mov  m_word [(cfp_b*exstm)+xr],w0       ; 
        mov  w0,m_word [cmpln]                  ; set line number field} mov exsln(xr) cmpln 
        mov  m_word [(cfp_b*exsln)+xr],w0       ; 
        mov  m_word [(cfp_b*exlen)+xr],wa       ; store length} mov exlen(xr) wa 
        mov  m_word [(cfp_b*exflc)+xr],ofex_    ; store failure word} mov exflc(xr) =ofex_ 
        add  xr,cfp_b*exsi_                     ; set xr for mvw} add xr *exsi_ 
        mov  m_word [cwcof],xl                  ; reset offset to start of code} mov cwcof xl 
        add  xl,m_word [r_ccb]                  ; point to start of code} add xl r_ccb 
        sub  wa,cfp_b*exsi_                     ; length of code to move} sub wa *exsi_ 
        push wa                                 ; stack length of code} mov -(xs) wa 
        shr  wa,log_cfp_b                       ; move code to exblk} mvw   
        rep  movs_w                             ; 
        pop  wa                                 ; get length of code} mov wa (xs)+ 
        shr  wa,log_cfp_b                       ; convert byte count to word count} btw wa  
        mov  xl,m_word [xs]                     ; copy exblk ptr, dont unstack} mov xl (xs) 
        add  xl,cfp_b*excod                     ; point to code itself} add xl *excod 
        mov  wb,m_word [(cfp_b*num01)+xs]       ; get reduction in offset} mov wb num01(xs) 
exbl1:
        lods_w                                  ; get next code word} mov xr (xl)+ 
        mov  xr,w0                              ; 
        cmp  xr,osla_                           ; jump if selection found} beq xr =osla_ exbl3
        je   exbl3                              ; 
        cmp  xr,onta_                           ; jump if negation found} beq xr =onta_ exbl3
        je   exbl3                              ; 
        dec  wa                                 ; loop to end of code} bct wa exbl1 
        jnz  exbl1                              ; 
exbl2:
        pop  xr                                 ; pop exblk ptr into xr} mov xr (xs)+ 
        pop  xl                                 ; pop reduction constant} mov xl (xs)+ 
        ret                                     ; return to caller} exi   
exbl3:
        sub  m_word [xl],wb                     ; adjust offset} sub (xl)+ wb 
        lea  xl,[xl+cfp_b]                      ; 
        dec  wa                                 ; decrement count} bct wa exbl4 
        jnz  exbl4                              ; 
exbl4:
        dec  wa                                 ; decrement count} bct wa exbl5 
        jnz  exbl5                              ; 
exbl5:
        lods_w                                  ; get next code word} mov xr (xl)+ 
        mov  xr,w0                              ; 
        cmp  xr,osla_                           ; jump if offset found} beq xr =osla_ exbl3
        je   exbl3                              ; 
        cmp  xr,oslb_                           ; jump if offset found} beq xr =oslb_ exbl3
        je   exbl3                              ; 
        cmp  xr,oslc_                           ; jump if offset found} beq xr =oslc_ exbl3
        je   exbl3                              ; 
        cmp  xr,onta_                           ; jump if offset found} beq xr =onta_ exbl3
        je   exbl3                              ; 
        dec  wa                                 ; loop} bct wa exbl5 
        jnz  exbl5                              ; 
        jmp  exbl2                              ; merge to return} brn exbl2  
                                                ; end procedure exbld} enp   
expan:
                                                ; entry point} prc e 0 
        push 0                                  ; set top of stack indicator} zer -(xs)  
        xor  wa,wa                              ; set initial state to zero} zer wa  
        xor  wc,wc                              ; zero counter value} zer wc  
exp01:
        call scane                              ; scan next element} jsr scane  
        add  xl,wa                              ; add state to syntax code} add xl wa 
        jmp  m_word [_l0433+xl*cfp_b]           ; switch on element type/state} bsw xl t_nes 
        segment .data                           ; 
_l0433:                                         ; 
        d_word exp27                            ; unop, s=0} iff t_uo0 exp27 
        d_word exp27                            ; unop, s=1} iff t_uo1 exp27 
        d_word exp04                            ; unop, s=2} iff t_uo2 exp04 
        d_word exp06                            ; left paren, s=0} iff t_lp0 exp06 
        d_word exp06                            ; left paren, s=1} iff t_lp1 exp06 
        d_word exp04                            ; left paren, s=2} iff t_lp2 exp04 
        d_word exp08                            ; left brkt, s=0} iff t_lb0 exp08 
        d_word exp08                            ; left brkt, s=1} iff t_lb1 exp08 
        d_word exp09                            ; left brkt, s=2} iff t_lb2 exp09 
        d_word exp02                            ; comma, s=0} iff t_cm0 exp02 
        d_word exp05                            ; comma, s=1} iff t_cm1 exp05 
        d_word exp11                            ; comma, s=2} iff t_cm2 exp11 
        d_word exp10                            ; function, s=0} iff t_fn0 exp10 
        d_word exp10                            ; function, s=1} iff t_fn1 exp10 
        d_word exp04                            ; function, s=2} iff t_fn2 exp04 
        d_word exp03                            ; variable, s=0} iff t_va0 exp03 
        d_word exp03                            ; variable, state one} iff t_va1 exp03 
        d_word exp04                            ; variable, s=2} iff t_va2 exp04 
        d_word exp03                            ; constant, s=0} iff t_co0 exp03 
        d_word exp03                            ; constant, s=1} iff t_co1 exp03 
        d_word exp04                            ; constant, s=2} iff t_co2 exp04 
        d_word exp05                            ; binop, s=0} iff t_bo0 exp05 
        d_word exp05                            ; binop, s=1} iff t_bo1 exp05 
        d_word exp26                            ; binop, s=2} iff t_bo2 exp26 
        d_word exp02                            ; right paren, s=0} iff t_rp0 exp02 
        d_word exp05                            ; right paren, s=1} iff t_rp1 exp05 
        d_word exp12                            ; right paren, s=2} iff t_rp2 exp12 
        d_word exp02                            ; right brkt, s=0} iff t_rb0 exp02 
        d_word exp05                            ; right brkt, s=1} iff t_rb1 exp05 
        d_word exp18                            ; right brkt, s=2} iff t_rb2 exp18 
        d_word exp02                            ; colon, s=0} iff t_cl0 exp02 
        d_word exp05                            ; colon, s=1} iff t_cl1 exp05 
        d_word exp19                            ; colon, s=2} iff t_cl2 exp19 
        d_word exp02                            ; semicolon, s=0} iff t_sm0 exp02 
        d_word exp05                            ; semicolon, s=1} iff t_sm1 exp05 
        d_word exp19                            ; semicolon, s=2} iff t_sm2 exp19 
        segment .text                           ; end switch on element type/state} esw   
exp02:
        mov  m_word [scnrs],xs                  ; set to rescan element} mnz scnrs  
        mov  xr,nulls                           ; point to null, merge} mov xr =nulls 
exp03:
        push xr                                 ; stack pointer to operand} mov -(xs) xr 
        mov  wa,num02                           ; set state 2} mov wa =num02 
        jmp  exp01                              ; jump for next element} brn exp01  
exp04:
        mov  m_word [scnrs],xs                  ; set to rescan element} mnz scnrs  
        mov  xr,opdvc                           ; point to concat operator dv} mov xr =opdvc 
        test wb,wb                              ; ok if at top level} bze wb exp4a 
        jz   exp4a                              ; 
        mov  xr,opdvp                           ; else point to unmistakable concat.} mov xr =opdvp 
exp4a:
        cmp  m_word [scnbl],0                   ; merge bop if blanks, else error} bnz scnbl exp26 
        jnz  exp26                              ; 
        mov  m_word [_rc_],220                  ; } erb 220 syntax error: missing operator 
        jmp  err_                               ; 
exp05:
        mov  m_word [_rc_],221                  ; } erb 221 syntax error: missing operand 
        jmp  err_                               ; 
exp06:
        mov  xl,num04                           ; set new level indicator} mov xl =num04 
        xor  xr,xr                              ; set zero value for cmopn} zer xr  
exp07:
        push xr                                 ; stack cmopn value} mov -(xs) xr 
        push wc                                 ; stack old counter} mov -(xs) wc 
        push wb                                 ; stack old level indicator} mov -(xs) wb 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0434                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0434:                                         ; 
        xor  wa,wa                              ; set new state to zero} zer wa  
        mov  wb,xl                              ; set new level indicator} mov wb xl 
        mov  wc,num01                           ; initialize new counter} mov wc =num01 
        jmp  exp01                              ; jump to scan next element} brn exp01  
exp08:
        mov  m_word [_rc_],222                  ; } erb 222 syntax error: invalid use of left bracket 
        jmp  err_                               ; 
exp09:
        pop  xr                                 ; load array ptr for cmopn} mov xr (xs)+ 
        mov  xl,num03                           ; set new level indicator} mov xl =num03 
        jmp  exp07                              ; jump to stack old and start new} brn exp07  
exp10:
        mov  xl,num05                           ; set new lev indic (xr=vrblk=cmopn)} mov xl =num05 
        jmp  exp07                              ; jump to stack old and start new} brn exp07  
exp11:
        inc  wc                                 ; increment counter} icv wc  
        call expdm                              ; dump operators at this level} jsr expdm  
        push 0                                  ; set new level for parameter} zer -(xs)  
        xor  wa,wa                              ; set new state} zer wa  
        cmp  wb,num02                           ; loop back unless outer level} bgt wb =num02 exp01
        ja   exp01                              ; 
        mov  m_word [_rc_],223                  ; } erb 223 syntax error: invalid use of comma 
        jmp  err_                               ; 
exp12:
        cmp  wb,num01                           ; end of normal goto} beq wb =num01 exp20
        je   exp20                              ; 
        cmp  wb,num05                           ; end of function arguments} beq wb =num05 exp13
        je   exp13                              ; 
        cmp  wb,num04                           ; end of grouping / selection} beq wb =num04 exp14
        je   exp14                              ; 
        mov  m_word [_rc_],224                  ; } erb 224 syntax error: unbalanced right parenthesis 
        jmp  err_                               ; 
exp13:
        mov  xl,c_fnc                           ; set cmtyp value for function} mov xl =c_fnc 
        jmp  exp15                              ; jump to build cmblk} brn exp15  
exp14:
        cmp  wc,num01                           ; jump if end of grouping} beq wc =num01 exp17
        je   exp17                              ; 
        mov  xl,c_sel                           ; else set cmtyp for selection} mov xl =c_sel 
exp15:
        call expdm                              ; dump operators at this level} jsr expdm  
        mov  wa,wc                              ; copy count} mov wa wc 
        add  wa,cmvls                           ; add for standard fields at start} add wa =cmvls 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        call alloc                              ; allocate space for cmblk} jsr alloc  
        mov  m_word [xr],b_cmt                  ; store type code for cmblk} mov (xr) =b_cmt 
        mov  m_word [(cfp_b*cmtyp)+xr],xl       ; store cmblk node type indicator} mov cmtyp(xr) xl 
        mov  m_word [(cfp_b*cmlen)+xr],wa       ; store length} mov cmlen(xr) wa 
        add  xr,wa                              ; point past end of block} add xr wa 
exp16:
        lea  xr,[xr-cfp_b]                      ; move one operand ptr from stack} mov -(xr) (xs)+ 
        pop  m_word [xr]                        ; 
        pop  wb                                 ; pop to old level indicator} mov wb (xs)+ 
        dec  wc                                 ; loop till all moved} bct wc exp16 
        jnz  exp16                              ; 
        sub  xr,cfp_b*cmvls                     ; point back to start of block} sub xr *cmvls 
        pop  wc                                 ; restore old counter} mov wc (xs)+ 
        mov  w0,m_word [xs]                     ; store operand ptr in cmblk} mov cmopn(xr) (xs) 
        mov  m_word [(cfp_b*cmopn)+xr],w0       ; 
        mov  m_word [xs],xr                     ; stack cmblk pointer} mov (xs) xr 
        mov  wa,num02                           ; set new state} mov wa =num02 
        jmp  exp01                              ; back for next element} brn exp01  
exp17:
        call expdm                              ; dump operators at this level} jsr expdm  
        pop  xr                                 ; restore xr} mov xr (xs)+ 
        pop  wb                                 ; restore outer level} mov wb (xs)+ 
        pop  wc                                 ; restore outer count} mov wc (xs)+ 
        mov  m_word [xs],xr                     ; store opnd over unused cmopn val} mov (xs) xr 
        mov  wa,num02                           ; set new state} mov wa =num02 
        jmp  exp01                              ; back for next ele8ent} brn exp01  
exp18:
        mov  xl,c_arr                           ; set cmtyp for array reference} mov xl =c_arr 
        cmp  wb,num03                           ; jump to build cmblk if end arrayref} beq wb =num03 exp15
        je   exp15                              ; 
        cmp  wb,num02                           ; jump if end of direct goto} beq wb =num02 exp20
        je   exp20                              ; 
        mov  m_word [_rc_],225                  ; } erb 225 syntax error: unbalanced right bracket 
        jmp  err_                               ; 
exp19:
        mov  m_word [scnrs],xs                  ; rescan terminator} mnz scnrs  
        mov  xl,wb                              ; copy level indicator} mov xl wb 
        jmp  m_word [_l0435+xl*cfp_b]           ; switch on level indicator} bsw xl 6 
        segment .data                           ; 
_l0435:                                         ; 
        d_word exp20                            ; normal outer level} iff 0 exp20 
        d_word exp22                            ; fail if normal goto} iff 1 exp22 
        d_word exp23                            ; fail if direct goto} iff 2 exp23 
        d_word exp24                            ; fail array brackets} iff 3 exp24 
        d_word exp21                            ; fail if in grouping} iff 4 exp21 
        d_word exp21                            ; fail function args} iff 5 exp21 
        segment .text                           ; end switch on level} esw   
exp20:
        call expdm                              ; dump remaining operators} jsr expdm  
        pop  xr                                 ; load tree pointer} mov xr (xs)+ 
        add  xs,cfp_b                           ; pop off bottom of stack marker} ica xs  
        ret                                     ; return to expan caller} exi   
exp21:
        mov  m_word [_rc_],226                  ; } erb 226 syntax error: missing right paren 
        jmp  err_                               ; 
exp22:
        mov  m_word [_rc_],227                  ; } erb 227 syntax error: right paren missing from goto 
        jmp  err_                               ; 
exp23:
        mov  m_word [_rc_],228                  ; } erb 228 syntax error: right bracket missing from goto 
        jmp  err_                               ; 
exp24:
        mov  m_word [_rc_],229                  ; } erb 229 syntax error: missing right array bracket 
        jmp  err_                               ; 
exp25:
        mov  m_word [expsv],xr                  ; } mov expsv xr 
        call expop                              ; pop one operator} jsr expop  
        mov  xr,m_word [expsv]                  ; restore op dv pointer and merge} mov xr expsv 
exp26:
        mov  xl,m_word [(cfp_b*num01)+xs]       ; load operator dvptr from stack} mov xl num01(xs) 
        cmp  xl,num05                           ; jump if bottom of stack level} ble xl =num05 exp27
        jbe  exp27                              ; 
        mov  w0,m_word [(cfp_b*dvlpr)+xl]       ; else pop if new prec is lo} blt dvrpr(xr) dvlpr(xl) exp25
        cmp  m_word [(cfp_b*dvrpr)+xr],w0       ; 
        jb   exp25                              ; 
exp27:
        push xr                                 ; stack operator dvptr on stack} mov -(xs) xr 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0436                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0436:                                         ; 
        mov  wa,num01                           ; set new state} mov wa =num01 
        cmp  xr,opdvs                           ; back for next element unless =} bne xr =opdvs exp01
        jne  exp01                              ; 
        xor  wa,wa                              ; set state zero} zer wa  
        jmp  exp01                              ; jump for next element} brn exp01  
                                                ; end procedure expan} enp   
expap:
                                                ; entry point} prc e 1 
        push xl                                 ; save xl} mov -(xs) xl 
        cmp  m_word [xr],b_cmt                  ; no match if not complex} bne (xr) =b_cmt expp2
        jne  expp2                              ; 
        mov  wa,m_word [(cfp_b*cmtyp)+xr]       ; else load type code} mov wa cmtyp(xr) 
        cmp  wa,c_cnc                           ; concatenation is a match} beq wa =c_cnc expp1
        je   expp1                              ; 
        cmp  wa,c_pmt                           ; binary question mark is a match} beq wa =c_pmt expp1
        je   expp1                              ; 
        cmp  wa,c_alt                           ; else not match unless alternation} bne wa =c_alt expp2
        jne  expp2                              ; 
        mov  xl,m_word [(cfp_b*cmlop)+xr]       ; load left operand pointer} mov xl cmlop(xr) 
        cmp  m_word [xl],b_cmt                  ; not match if left opnd not complex} bne (xl) =b_cmt expp2
        jne  expp2                              ; 
        cmp  m_word [(cfp_b*cmtyp)+xl],c_cnc    ; not match if left op not conc} bne cmtyp(xl) =c_cnc expp2
        jne  expp2                              ; 
        mov  w0,m_word [(cfp_b*cmrop)+xl]       ; xr points to (b / c)} mov cmlop(xr) cmrop(xl) 
        mov  m_word [(cfp_b*cmlop)+xr],w0       ; 
        mov  m_word [(cfp_b*cmrop)+xl],xr       ; set xl opnds to a, (b / c)} mov cmrop(xl) xr 
        mov  xr,xl                              ; point to this altered node} mov xr xl 
expp1:
        pop  xl                                 ; restore entry xl} mov xl (xs)+ 
        mov  m_word [_rc_],0                    ; give pattern match return} exi   
        ret                                     ; 
expp2:
        pop  xl                                 ; restore entry xl} mov xl (xs)+ 
        mov  m_word [_rc_],1                    ; give non-match return} exi 1  
        ret                                     ; 
                                                ; end procedure expap} enp   
expdm:
        pop  m_word [prc_+cfp_b*3]              ; entry point} prc n 0 
        mov  m_word [r_exs],xl                  ; save xl value} mov r_exs xl 
exdm1:
        cmp  m_word [(cfp_b*num01)+xs],num05    ; jump if stack bottom (saved level} ble num01(xs) =num05 exdm2
        jbe  exdm2                              ; 
        call expop                              ; else pop one operator} jsr expop  
        jmp  exdm1                              ; and loop back} brn exdm1  
exdm2:
        mov  xl,m_word [r_exs]                  ; restore xl} mov xl r_exs 
        xor  w0,w0                              ; release save location} zer r_exs  
        mov  m_word [r_exs],w0                  ; 
        mov  m_word [_rc_],0                    ; return to expdm caller} exi   
        mov  w0,m_word [prc_+cfp_b*3]           ; 
        jmp  w0                                 ; 
                                                ; end procedure expdm} enp   
expop:
        pop  m_word [prc_+cfp_b*4]              ; entry point} prc n 0 
        mov  xr,m_word [(cfp_b*num01)+xs]       ; load operator dv pointer} mov xr num01(xs) 
        cmp  m_word [(cfp_b*dvlpr)+xr],lluno    ; jump if unary} beq dvlpr(xr) =lluno expo2
        je   expo2                              ; 
        mov  wa,cfp_b*cmbs_                     ; set size of binary operator cmblk} mov wa *cmbs_ 
        call alloc                              ; allocate space for cmblk} jsr alloc  
        pop  m_word [(cfp_b*cmrop)+xr]          ; pop and store right operand ptr} mov cmrop(xr) (xs)+ 
        pop  xl                                 ; pop and load operator dv ptr} mov xl (xs)+ 
        mov  w0,m_word [xs]                     ; store left operand pointer} mov cmlop(xr) (xs) 
        mov  m_word [(cfp_b*cmlop)+xr],w0       ; 
expo1:
        mov  m_word [xr],b_cmt                  ; store type code for cmblk} mov (xr) =b_cmt 
        mov  w0,m_word [(cfp_b*dvtyp)+xl]       ; store cmblk node type code} mov cmtyp(xr) dvtyp(xl) 
        mov  m_word [(cfp_b*cmtyp)+xr],w0       ; 
        mov  m_word [(cfp_b*cmopn)+xr],xl       ; store dvptr (=ptr to dac o_xxx)} mov cmopn(xr) xl 
        mov  m_word [(cfp_b*cmlen)+xr],wa       ; store cmblk length} mov cmlen(xr) wa 
        mov  m_word [xs],xr                     ; store resulting node ptr on stack} mov (xs) xr 
        mov  m_word [_rc_],0                    ; return to expop caller} exi   
        mov  w0,m_word [prc_+cfp_b*4]           ; 
        jmp  w0                                 ; 
expo2:
        mov  wa,cfp_b*cmus_                     ; set size of unary operator cmblk} mov wa *cmus_ 
        call alloc                              ; allocate space for cmblk} jsr alloc  
        pop  m_word [(cfp_b*cmrop)+xr]          ; pop and store operand pointer} mov cmrop(xr) (xs)+ 
        mov  xl,m_word [xs]                     ; load operator dv pointer} mov xl (xs) 
        jmp  expo1                              ; merge back to exit} brn expo1  
                                                ; end procedure expop} enp   
filnm:
                                                ; entry point} prc e 0 
        push wb                                 ; preserve wb} mov -(xs) wb 
        test wc,wc                              ; return nulls if stno is zero} bze wc filn3 
        jz   filn3                              ; 
        mov  xl,m_word [r_sfn]                  ; file name table} mov xl r_sfn 
        test xl,xl                              ; if no table} bze xl filn3 
        jz   filn3                              ; 
        mov  wb,m_word [(cfp_b*tbbuk)+xl]       ; get bucket entry} mov wb tbbuk(xl) 
        cmp  wb,m_word [r_sfn]                  ; jump if no teblks on chain} beq wb r_sfn filn3
        je   filn3                              ; 
        push xr                                 ; preserve xr} mov -(xs) xr 
        mov  xr,wb                              ; previous block pointer} mov xr wb 
        push wc                                 ; preserve stmt number} mov -(xs) wc 
filn1:
        mov  xl,xr                              ; next element to examine} mov xl xr 
        mov  xr,m_word [(cfp_b*tesub)+xl]       ; load subscript value (an icblk)} mov xr tesub(xl) 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load the statement number} ldi icval(xr)  
        mov  wc,ia                              ; convert to address constant} mfi wc  
        cmp  m_word [xs],wc                     ; compare arg with teblk stmt number} blt (xs) wc filn2
        jb   filn2                              ; 
        mov  wb,xl                              ; save previous entry pointer} mov wb xl 
        mov  xr,m_word [(cfp_b*tenxt)+xl]       ; point to next teblk on chain} mov xr tenxt(xl) 
        cmp  xr,m_word [r_sfn]                  ; jump if there is one} bne xr r_sfn filn1
        jne  filn1                              ; 
filn2:
        mov  xl,wb                              ; previous teblk} mov xl wb 
        mov  xl,m_word [(cfp_b*teval)+xl]       ; get ptr to file name scblk} mov xl teval(xl) 
        pop  wc                                 ; restore stmt number} mov wc (xs)+ 
        pop  xr                                 ; restore xr} mov xr (xs)+ 
        pop  wb                                 ; restore wb} mov wb (xs)+ 
        ret                                     ; } exi   
filn3:
        pop  wb                                 ; restore wb} mov wb (xs)+ 
        mov  xl,nulls                           ; return null string} mov xl =nulls 
        ret                                     ; } exi   
                                                ; } enp   
flstg:
                                                ; entry point} prc e 0 
        cmp  m_word [kvcas],0                   ; skip if &case is 0} bze kvcas fst99 
        jz   fst99                              ; 
        push xl                                 ; save xl across call} mov -(xs) xl 
        push xr                                 ; save original scblk ptr} mov -(xs) xr 
        call alocs                              ; allocate new string block} jsr alocs  
        mov  xl,m_word [xs]                     ; point to original scblk} mov xl (xs) 
        push xr                                 ; save pointer to new scblk} mov -(xs) xr 
        add  xl,cfp_f                           ; point to original chars} plc xl  
        add  xr,cfp_f                           ; point to new chars} psc xr  
        push 0                                  ; init did fold flag} zer -(xs)  
fst01:
        xor  w0,w0                              ; load character} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        cmp  wa,ch_ua                           ; skip if less than uc a} blt wa =ch_ua fst02
        jb   fst02                              ; 
        cmp  wa,ch_uz                           ; skip if greater than uc z} bgt wa =ch_uz fst02
        ja   fst02                              ; 
        cmp  cl,'A'                             ; fold character to lower case} flc wa  
        jb   _l0437                             ; 
        cmp  cl,'Z'                             ; 
        ja   _l0437                             ; 
        add  cl,32                              ; 
_l0437             :                            ; 
        mov  m_word [xs],xs                     ; set did fold character flag} mnz (xs)  
fst02:
        mov  al,cl                              ; store (possibly folded) character} sch wa (xr)+ 
        stos_b                                  ; 
        dec  wc                                 ; loop thru entire string} bct wc fst01 
        jnz  fst01                              ; 
        pop  xr                                 ; see if any change} mov xr (xs)+ 
        test xr,xr                              ; skip if folding done (no change)} bnz xr fst10 
        jnz  fst10                              ; 
        pop  m_word [dnamp]                     ; do not need new scblk} mov dnamp (xs)+ 
        pop  xr                                 ; return original scblk} mov xr (xs)+ 
        jmp  fst20                              ; merge below} brn fst20  
fst10:
        pop  xr                                 ; return new scblk} mov xr (xs)+ 
        add  xs,cfp_b                           ; throw away original scblk pointer} ica xs  
fst20:
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; reload string length} mov wa sclen(xr) 
        pop  xl                                 ; restore xl} mov xl (xs)+ 
fst99:
        ret                                     ; return} exi   
                                                ; } enp   
gbcol:
                                                ; entry point} prc e 0 
        cmp  m_word [dmvch],0                   ; fail if in mid-dump} bnz dmvch gbc14 
        jnz  gbc14                              ; 
        mov  m_word [gbcfl],xs                  ; note gbcol entered} mnz gbcfl  
        mov  m_word [gbsva],wa                  ; save entry wa} mov gbsva wa 
        mov  m_word [gbsvb],wb                  ; save entry wb} mov gbsvb wb 
        mov  m_word [gbsvc],wc                  ; save entry wc} mov gbsvc wc 
        push xl                                 ; save entry xl} mov -(xs) xl 
        mov  wa,r13                             ; get code pointer value} scp wa  
        sub  wa,m_word [r_cod]                  ; make relative} sub wa r_cod 
        mov  r13,wa                             ; and restore} lcp wa  
        test wb,wb                              ; check there is no move offset} bze wb gbc0a 
        jz   gbc0a                              ; 
        xor  w0,w0                              ; collect sediment if must move it} zer dnams  
        mov  m_word [dnams],w0                  ; 
gbc0a:
        mov  wa,m_word [dnamb]                  ; start of dynamic area} mov wa dnamb 
        add  wa,m_word [dnams]                  ; size of sediment} add wa dnams 
        mov  m_word [gbcsd],wa                  ; first location past sediment} mov gbcsd wa 
        mov  xr,xs                              ; non-zero flags start of collection} mnz xr  
        mov  wa,m_word [dnamb]                  ; start of dynamic area} mov wa dnamb 
        mov  wb,m_word [dnamp]                  ; next available location} mov wb dnamp 
        mov  wc,m_word [dname]                  ; last available location + 1} mov wc dname 
        call sysgc                              ; inform of collection} jsr sysgc  
        mov  xr,xs                              ; point to stack front} mov xr xs 
        mov  xl,m_word [stbas]                  ; point past end of stack} mov xl stbas 
        cmp  xl,xr                              ; ok if d-stack} bge xl xr gbc00
        jae  gbc00                              ; 
        mov  xr,xl                              ; reverse if ...} mov xr xl 
        mov  xl,xs                              ; ... u-stack} mov xl xs 
gbc00:
        call gbcpf                              ; process pointers on stack} jsr gbcpf  
        mov  xr,r_aaa                           ; point to start of relocatable locs} mov xr =r_aaa 
        mov  xl,r_yyy                           ; point past end of relocatable locs} mov xl =r_yyy 
        call gbcpf                              ; process work fields} jsr gbcpf  
        mov  wa,m_word [hshtb]                  ; point to first hash slot pointer} mov wa hshtb 
gbc01:
        mov  xl,wa                              ; point to next slot} mov xl wa 
        add  wa,cfp_b                           ; bump bucket pointer} ica wa  
        mov  m_word [gbcnm],wa                  ; save bucket pointer} mov gbcnm wa 
gbc02:
        mov  xr,m_word [xl]                     ; load ptr to next vrblk} mov xr (xl) 
        test xr,xr                              ; jump if end of chain} bze xr gbc03 
        jz   gbc03                              ; 
        mov  xl,xr                              ; else copy vrblk pointer} mov xl xr 
        add  xr,cfp_b*vrval                     ; point to first reloc fld} add xr *vrval 
        add  xl,cfp_b*vrnxt                     ; point past last (and to link ptr)} add xl *vrnxt 
        call gbcpf                              ; process reloc fields in vrblk} jsr gbcpf  
        jmp  gbc02                              ; loop back for next block} brn gbc02  
gbc03:
        mov  wa,m_word [gbcnm]                  ; restore bucket pointer} mov wa gbcnm 
        cmp  wa,m_word [hshte]                  ; loop back if more buckets to go} bne wa hshte gbc01
        jne  gbc01                              ; 
        mov  xr,m_word [dnamb]                  ; point to first block} mov xr dnamb 
        xor  wb,wb                              ; accumulate size of dead blocks} zer wb  
gbc04:
        cmp  xr,m_word [gbcsd]                  ; jump if end of sediment} beq xr gbcsd gbc4c
        je   gbc4c                              ; 
        mov  wa,m_word [xr]                     ; else get first word} mov wa (xr) 
        test cl,1                               ; jump if entry pointer (unused)} bod wa gbc4b 
        jne  gbc4b                              ; 
        dec  wa                                 ; restore entry pointer} dcv wa  
        mov  m_word [xr],wa                     ; restore first word} mov (xr) wa 
        call blkln                              ; get length of this block} jsr blkln  
        add  xr,wa                              ; bump actual pointer} add xr wa 
        jmp  gbc04                              ; continue scan through sediment} brn gbc04  
gbc4b:
        call blkln                              ; get length of this block} jsr blkln  
        add  xr,wa                              ; bump actual pointer} add xr wa 
        add  wb,wa                              ; count size of unused blocks} add wb wa 
        jmp  gbc04                              ; continue scan through sediment} brn gbc04  
gbc4c:
        mov  m_word [gbcsf],wb                  ; size of sediment free space} mov gbcsf wb 
        mov  wc,xr                              ; set as first eventual location} mov wc xr 
        add  wc,m_word [gbsvb]                  ; add offset for eventual move up} add wc gbsvb 
        xor  w0,w0                              ; clear initial forward pointer} zer gbcnm  
        mov  m_word [gbcnm],w0                  ; 
        mov  m_word [gbclm],gbcnm               ; initialize ptr to last move block} mov gbclm =gbcnm 
        mov  m_word [gbcns],xr                  ; initialize first address} mov gbcns xr 
gbc05:
        cmp  xr,m_word [dnamp]                  ; jump if end of used region} beq xr dnamp gbc07
        je   gbc07                              ; 
        mov  wa,m_word [xr]                     ; else get first word} mov wa (xr) 
        test cl,1                               ; jump if entry pointer (unused)} bod wa gbc07 
        jne  gbc07                              ; 
gbc06:
        mov  xl,wa                              ; copy pointer} mov xl wa 
        mov  wa,m_word [xl]                     ; load forward pointer} mov wa (xl) 
        mov  m_word [xl],wc                     ; relocate reference} mov (xl) wc 
        test cl,1                               ; loop back if not end of chain} bev wa gbc06 
        je   gbc06                              ; 
        mov  m_word [xr],wa                     ; restore first word} mov (xr) wa 
        call blkln                              ; get length of this block} jsr blkln  
        add  xr,wa                              ; bump actual pointer} add xr wa 
        add  wc,wa                              ; bump eventual pointer} add wc wa 
        jmp  gbc05                              ; loop back for next block} brn gbc05  
gbc07:
        mov  wa,xr                              ; copy pointer past last block} mov wa xr 
        mov  xl,m_word [gbclm]                  ; point to previous move block} mov xl gbclm 
        sub  wa,m_word [(cfp_b*num01)+xl]       ; subtract starting address} sub wa num01(xl) 
        mov  m_word [(cfp_b*num01)+xl],wa       ; store length of block to be moved} mov num01(xl) wa 
gbc08:
        cmp  xr,m_word [dnamp]                  ; jump if end of used region} beq xr dnamp gbc10
        je   gbc10                              ; 
        mov  wa,m_word [xr]                     ; else load first word of next block} mov wa (xr) 
        test cl,1                               ; jump if in use} bev wa gbc09 
        je   gbc09                              ; 
        call blkln                              ; else get length of next block} jsr blkln  
        add  xr,wa                              ; push pointer} add xr wa 
        jmp  gbc08                              ; and loop back} brn gbc08  
gbc09:
        sub  xr,cfp_b*num02                     ; point 2 words behind for move block} sub xr *num02 
        mov  xl,m_word [gbclm]                  ; point to previous move block} mov xl gbclm 
        mov  m_word [xl],xr                     ; set forward ptr in previous block} mov (xl) xr 
        xor  w0,w0                              ; zero forward ptr of new block} zer (xr)  
        mov  m_word [xr],w0                     ; 
        mov  m_word [gbclm],xr                  ; remember address of this block} mov gbclm xr 
        mov  xl,xr                              ; copy ptr to move block} mov xl xr 
        add  xr,cfp_b*num02                     ; point back to block in use} add xr *num02 
        mov  m_word [(cfp_b*num01)+xl],xr       ; store starting address} mov num01(xl) xr 
        jmp  gbc06                              ; jump to process block in use} brn gbc06  
gbc10:
        mov  xr,m_word [gbcsd]                  ; point to storage above sediment} mov xr gbcsd 
        add  xr,m_word [gbcns]                  ; bump past unmoved blocks at start} add xr gbcns 
gbc11:
        mov  xl,m_word [gbcnm]                  ; point to next move block} mov xl gbcnm 
        test xl,xl                              ; jump if end of chain} bze xl gbc12 
        jz   gbc12                              ; 
        lods_w                                  ; move pointer down chain} mov gbcnm (xl)+ 
        mov  m_word [gbcnm],w0                  ; 
        lods_w                                  ; get length to move} mov wa (xl)+ 
        mov  wa,w0                              ; 
        shr  wa,log_cfp_b                       ; perform move} mvw   
        rep  movs_w                             ; 
        jmp  gbc11                              ; loop back} brn gbc11  
gbc12:
        mov  m_word [dnamp],xr                  ; set next available loc ptr} mov dnamp xr 
        mov  wb,m_word [gbsvb]                  ; reload move offset} mov wb gbsvb 
        test wb,wb                              ; jump if no move required} bze wb gbc13 
        jz   gbc13                              ; 
        mov  xl,xr                              ; else copy old top of core} mov xl xr 
        add  xr,wb                              ; point to new top of core} add xr wb 
        mov  m_word [dnamp],xr                  ; save new top of core pointer} mov dnamp xr 
        mov  wa,xl                              ; copy old top} mov wa xl 
        sub  wa,m_word [dnamb]                  ; minus old bottom = length} sub wa dnamb 
        add  m_word [dnamb],wb                  ; bump bottom to get new value} add dnamb wb 
        shr  wa,log_cfp_b                       ; perform move (backwards)} mwb   
        std                                     ; 
        lea  xl,[xl-cfp_b]                      ; 
        lea  xr,[xr-cfp_b]                      ; 
_l0438:                                         ; 
        or   wa,wa                              ; 
        jz   _l0439                             ; 
        movs_w                                  ; 
        dec  wa                                 ; 
        jmp  _l0438                             ; 
_l0439:                                         ; 
        cld                                     ; 
gbc13:
        xor  xr,xr                              ; clear garbage value in xr} zer xr  
        mov  m_word [gbcfl],xr                  ; note exit from gbcol} mov gbcfl xr 
        mov  wa,m_word [dnamb]                  ; start of dynamic area} mov wa dnamb 
        mov  wb,m_word [dnamp]                  ; next available location} mov wb dnamp 
        mov  wc,m_word [dname]                  ; last available location + 1} mov wc dname 
        call sysgc                              ; inform sysgc of completion} jsr sysgc  
        mov  m_word [gbcia],ia                  ; save ia} sti gbcia  
        xor  xr,xr                              ; presume no sediment will remain} zer xr  
        mov  wb,m_word [gbcsf]                  ; free space in sediment} mov wb gbcsf 
        shr  wb,log_cfp_b                       ; convert bytes to words} btw wb  
        mov  ia,wb                              ; put sediment free store in ia} mti wb  
        imul ia,m_word [gbsed]                  ; multiply by sediment factor} mli gbsed  
        jo   gb13a                              ; jump if overflowed} iov gb13a  
        mov  wb,m_word [dnamp]                  ; end of dynamic area in use} mov wb dnamp 
        sub  wb,m_word [dnamb]                  ; minus start is sediment remaining} sub wb dnamb 
        shr  wb,log_cfp_b                       ; convert to words} btw wb  
        mov  m_word [gbcsf],wb                  ; store it} mov gbcsf wb 
        sub  ia,m_word [gbcsf]                  ; subtract from scaled up free store} sbi gbcsf  
        cmp  ia,0                               ; jump if large free store in sedimnt} igt gb13a  
        jg   gb13a                              ; 
        mov  xr,m_word [dnamp]                  ; below threshold, return sediment} mov xr dnamp 
        sub  xr,m_word [dnamb]                  ; for use by caller} sub xr dnamb 
gb13a:
        mov  ia,m_word [gbcia]                  ; restore ia} ldi gbcia  
        mov  wa,m_word [gbsva]                  ; restore wa} mov wa gbsva 
        mov  wb,m_word [gbsvb]                  ; restore wb} mov wb gbsvb 
        mov  wc,r13                             ; get code pointer} scp wc  
        add  wc,m_word [r_cod]                  ; make absolute again} add wc r_cod 
        mov  r13,wc                             ; and replace absolute value} lcp wc  
        mov  wc,m_word [gbsvc]                  ; restore wc} mov wc gbsvc 
        pop  xl                                 ; restore entry xl} mov xl (xs)+ 
        inc  m_word [gbcnt]                     ; increment count of collections} icv gbcnt  
        ret                                     ; exit to gbcol caller} exi   
gbc14:
        inc  m_word [errft]                     ; fatal error} icv errft  
        mov  m_word [_rc_],250                  ; } erb 250 insufficient memory to complete dump 
        jmp  err_                               ; 
                                                ; end procedure gbcol} enp   
gbcpf:
                                                ; entry point} prc e 0 
        push 0                                  ; set zero to mark bottom of stack} zer -(xs)  
        push xl                                 ; save end pointer} mov -(xs) xl 
gpf01:
        mov  xl,m_word [xr]                     ; load field contents} mov xl (xr) 
        mov  wc,xr                              ; save field pointer} mov wc xr 
        cmp  xl,m_word [dnamb]                  ; jump if not ptr into dynamic area} blt xl dnamb gpf2a
        jb   gpf2a                              ; 
        cmp  xl,m_word [dnamp]                  ; jump if not ptr into dynamic area} bge xl dnamp gpf2a
        jae  gpf2a                              ; 
        mov  wa,m_word [xl]                     ; load ptr to chain (or entry ptr)} mov wa (xl) 
        cmp  xl,m_word [gbcsd]                  ; do not chain if within sediment} blt xl gbcsd gpf1a
        jb   gpf1a                              ; 
        mov  m_word [xl],xr                     ; set this field as new head of chain} mov (xl) xr 
        mov  m_word [xr],wa                     ; set forward pointer} mov (xr) wa 
gpf1a:
        test cl,1                               ; jump if not already processed} bod wa gpf03 
        jne  gpf03                              ; 
gpf02:
        mov  xr,wc                              ; restore field pointer} mov xr wc 
gpf2a:
        add  xr,cfp_b                           ; bump to next field} ica xr  
        cmp  xr,m_word [xs]                     ; loop back if more to go} bne xr (xs) gpf01
        jne  gpf01                              ; 
        pop  xl                                 ; restore pointer past end} mov xl (xs)+ 
        pop  xr                                 ; restore block pointer} mov xr (xs)+ 
        test xr,xr                              ; continue loop unless outer levl} bnz xr gpf2a 
        jnz  gpf2a                              ; 
        ret                                     ; return to caller if outer level} exi   
gpf03:
        cmp  xl,m_word [gbcsd]                  ; if not within sediment} bge xl gbcsd gpf3a
        jae  gpf3a                              ; 
        inc  m_word [xl]                        ; mark by making entry point even} icv (xl)  
gpf3a:
        mov  xr,xl                              ; copy block pointer} mov xr xl 
        mov  xl,wa                              ; copy first word of block} mov xl wa 
        movzx xl,byte [xl-1]                    ; load entry point id (bl_xx)} lei xl  
        jmp  m_word [_l0440+xl*cfp_b]           ; switch on block type} bsw xl bl___ 
        segment .data                           ; 
_l0440:                                         ; 
        d_word gpf06                            ; arblk} iff bl_ar gpf06 
        d_word gpf19                            ; cdblk} iff bl_cd gpf19 
        d_word gpf17                            ; exblk} iff bl_ex gpf17 
        d_word gpf02                            ; icblk} iff bl_ic gpf02 
        d_word gpf10                            ; nmblk} iff bl_nm gpf10 
        d_word gpf10                            ; p0blk} iff bl_p0 gpf10 
        d_word gpf12                            ; p1blk} iff bl_p1 gpf12 
        d_word gpf12                            ; p2blk} iff bl_p2 gpf12 
        d_word gpf02                            ; rcblk} iff bl_rc gpf02 
        d_word gpf02                            ; scblk} iff bl_sc gpf02 
        d_word gpf02                            ; seblk} iff bl_se gpf02 
        d_word gpf08                            ; tbblk} iff bl_tb gpf08 
        d_word gpf08                            ; vcblk} iff bl_vc gpf08 
        d_word gpf02                            ; xnblk} iff bl_xn gpf02 
        d_word gpf09                            ; xrblk} iff bl_xr gpf09 
        d_word gpf02                            ; bcblk - dummy to fill out iffs} iff bl_bc gpf02 
        d_word gpf13                            ; pdblk} iff bl_pd gpf13 
        d_word gpf16                            ; trblk} iff bl_tr gpf16 
        d_word gpf02                            ; bfblk} iff bl_bf gpf02 
        d_word gpf07                            ; ccblk} iff bl_cc gpf07 
        d_word gpf04                            ; cmblk} iff bl_cm gpf04 
        d_word gpf02                            ; ctblk} iff bl_ct gpf02 
        d_word gpf02                            ; dfblk} iff bl_df gpf02 
        d_word gpf02                            ; efblk} iff bl_ef gpf02 
        d_word gpf10                            ; evblk} iff bl_ev gpf10 
        d_word gpf11                            ; ffblk} iff bl_ff gpf11 
        d_word gpf02                            ; kvblk} iff bl_kv gpf02 
        d_word gpf14                            ; pfblk} iff bl_pf gpf14 
        d_word gpf15                            ; teblk} iff bl_te gpf15 
        segment .text                           ; end of jump table} esw   
gpf04:
        mov  wa,m_word [(cfp_b*cmlen)+xr]       ; load length} mov wa cmlen(xr) 
        mov  wb,cfp_b*cmtyp                     ; set offset} mov wb *cmtyp 
gpf05:
        add  wa,xr                              ; point past last reloc field} add wa xr 
        add  xr,wb                              ; point to first reloc field} add xr wb 
        push wc                                 ; stack old field pointer} mov -(xs) wc 
        push wa                                 ; stack new limit pointer} mov -(xs) wa 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0441                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0441:                                         ; 
        jmp  gpf01                              ; if ok, back to process} brn gpf01  
gpf06:
        mov  wa,m_word [(cfp_b*arlen)+xr]       ; load length} mov wa arlen(xr) 
        mov  wb,m_word [(cfp_b*arofs)+xr]       ; set offset to 1st reloc fld (arpro)} mov wb arofs(xr) 
        jmp  gpf05                              ; all set} brn gpf05  
gpf07:
        mov  wa,m_word [(cfp_b*ccuse)+xr]       ; set length in use} mov wa ccuse(xr) 
        mov  wb,cfp_b*ccuse                     ; 1st word (make sure at least one)} mov wb *ccuse 
        jmp  gpf05                              ; all set} brn gpf05  
gpf19:
        mov  wa,m_word [(cfp_b*cdlen)+xr]       ; load length} mov wa cdlen(xr) 
        mov  wb,cfp_b*cdfal                     ; set offset} mov wb *cdfal 
        jmp  gpf05                              ; jump back} brn gpf05  
gpf08:
        mov  wa,m_word [(cfp_b*offs2)+xr]       ; load length} mov wa offs2(xr) 
        mov  wb,cfp_b*offs3                     ; set offset} mov wb *offs3 
        jmp  gpf05                              ; jump back} brn gpf05  
gpf09:
        mov  wa,m_word [(cfp_b*xrlen)+xr]       ; load length} mov wa xrlen(xr) 
        mov  wb,cfp_b*xrptr                     ; set offset} mov wb *xrptr 
        jmp  gpf05                              ; jump back} brn gpf05  
gpf10:
        mov  wa,cfp_b*offs2                     ; point past second field} mov wa *offs2 
        mov  wb,cfp_b*offs1                     ; offset is one (only reloc fld is 2)} mov wb *offs1 
        jmp  gpf05                              ; all set} brn gpf05  
gpf11:
        mov  wa,cfp_b*ffofs                     ; set length} mov wa *ffofs 
        mov  wb,cfp_b*ffnxt                     ; set offset} mov wb *ffnxt 
        jmp  gpf05                              ; all set} brn gpf05  
gpf12:
        mov  wa,cfp_b*parm2                     ; length (parm2 is non-relocatable)} mov wa *parm2 
        mov  wb,cfp_b*pthen                     ; set offset} mov wb *pthen 
        jmp  gpf05                              ; all set} brn gpf05  
gpf13:
        mov  xl,m_word [(cfp_b*pddfp)+xr]       ; load ptr to dfblk} mov xl pddfp(xr) 
        mov  wa,m_word [(cfp_b*dfpdl)+xl]       ; get pdblk length} mov wa dfpdl(xl) 
        mov  wb,cfp_b*pdfld                     ; set offset} mov wb *pdfld 
        jmp  gpf05                              ; all set} brn gpf05  
gpf14:
        mov  wa,cfp_b*pfarg                     ; length past last reloc} mov wa *pfarg 
        mov  wb,cfp_b*pfcod                     ; offset to first reloc} mov wb *pfcod 
        jmp  gpf05                              ; all set} brn gpf05  
gpf15:
        mov  wa,cfp_b*tesi_                     ; set length} mov wa *tesi_ 
        mov  wb,cfp_b*tesub                     ; and offset} mov wb *tesub 
        jmp  gpf05                              ; all set} brn gpf05  
gpf16:
        mov  wa,cfp_b*trsi_                     ; set length} mov wa *trsi_ 
        mov  wb,cfp_b*trval                     ; and offset} mov wb *trval 
        jmp  gpf05                              ; all set} brn gpf05  
gpf17:
        mov  wa,m_word [(cfp_b*exlen)+xr]       ; load length} mov wa exlen(xr) 
        mov  wb,cfp_b*exflc                     ; set offset} mov wb *exflc 
        jmp  gpf05                              ; jump back} brn gpf05  
                                                ; end procedure gbcpf} enp   
gtarr:
                                                ; entry point} prc e 2 
        mov  m_word [gtawa],wa                  ; save wa indicator} mov gtawa wa 
        mov  wa,m_word [xr]                     ; load type word} mov wa (xr) 
        cmp  wa,b_art                           ; exit if already an array} beq wa =b_art gtar8
        je   gtar8                              ; 
        cmp  wa,b_vct                           ; exit if already an array} beq wa =b_vct gtar8
        je   gtar8                              ; 
        cmp  wa,b_tbt                           ; else fail if not a table (sgd02)} bne wa =b_tbt gta9a
        jne  gta9a                              ; 
        push xr                                 ; replace tbblk pointer on stack} mov -(xs) xr 
        xor  xr,xr                              ; signal first pass} zer xr  
        xor  wb,wb                              ; zero non-null element count} zer wb  
gtar1:
        mov  xl,m_word [xs]                     ; point to table} mov xl (xs) 
        add  xl,m_word [(cfp_b*tblen)+xl]       ; point past last bucket} add xl tblen(xl) 
        sub  xl,cfp_b*tbbuk                     ; set first bucket offset} sub xl *tbbuk 
        mov  wa,xl                              ; copy adjusted pointer} mov wa xl 
gtar2:
        mov  xl,wa                              ; copy bucket pointer} mov xl wa 
        sub  wa,cfp_b                           ; decrement bucket pointer} dca wa  
gtar3:
        mov  xl,m_word [(cfp_b*tenxt)+xl]       ; point to next teblk} mov xl tenxt(xl) 
        cmp  xl,m_word [xs]                     ; jump if chain end (tbblk ptr)} beq xl (xs) gtar6
        je   gtar6                              ; 
        mov  m_word [cnvtp],xl                  ; else save teblk pointer} mov cnvtp xl 
gtar4:
        mov  xl,m_word [(cfp_b*teval)+xl]       ; load value} mov xl teval(xl) 
        cmp  m_word [xl],b_trt                  ; loop till value found} beq (xl) =b_trt gtar4
        je   gtar4                              ; 
        mov  wc,xl                              ; copy value} mov wc xl 
        mov  xl,m_word [cnvtp]                  ; restore teblk pointer} mov xl cnvtp 
        cmp  wc,nulls                           ; loop back to ignore null value} beq wc =nulls gtar3
        je   gtar3                              ; 
        test xr,xr                              ; jump if second pass} bnz xr gtar5 
        jnz  gtar5                              ; 
        inc  wb                                 ; for the first pass, bump count} icv wb  
        jmp  gtar3                              ; and loop back for next teblk} brn gtar3  
gtar5:
        cmp  m_word [gtawa],0                   ; jump if address wanted} bze gtawa gta5a 
        jz   gta5a                              ; 
        mov  w0,m_word [(cfp_b*tesub)+xl]       ; store subscript name} mov (xr)+ tesub(xl) 
        stos_w                                  ; 
        mov  w0,wc                              ; store value in arblk} mov (xr)+ wc 
        stos_w                                  ; 
        jmp  gtar3                              ; loop back for next teblk} brn gtar3  
gta5a:
        mov  w0,xl                              ; store teblk address in name} mov (xr)+ xl 
        stos_w                                  ; 
        mov  w0,xl                              ; and value slots} mov (xr)+ xl 
        stos_w                                  ; 
        jmp  gtar3                              ; loop back for next teblk} brn gtar3  
gtar6:
        cmp  wa,m_word [xs]                     ; loop back if more buckets to go} bne wa (xs) gtar2
        jne  gtar2                              ; 
        test xr,xr                              ; else jump if second pass} bnz xr gtar7 
        jnz  gtar7                              ; 
        test wb,wb                              ; fail if no non-null elements} bze wb gtar9 
        jz   gtar9                              ; 
        mov  wa,wb                              ; else copy count} mov wa wb 
        add  wa,wb                              ; double (two words/element)} add wa wb 
        add  wa,arvl2                           ; add space for standard fields} add wa =arvl2 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        cmp  wa,m_word [mxlen]                  ; error if too long for array} bgt wa mxlen gta9b
        ja   gta9b                              ; 
        call alloc                              ; else allocate space for arblk} jsr alloc  
        mov  m_word [xr],b_art                  ; store type word} mov (xr) =b_art 
        xor  w0,w0                              ; zero id for the moment} zer idval(xr)  
        mov  m_word [(cfp_b*idval)+xr],w0       ; 
        mov  m_word [(cfp_b*arlen)+xr],wa       ; store length} mov arlen(xr) wa 
        mov  m_word [(cfp_b*arndm)+xr],num02    ; set dimensions = 2} mov arndm(xr) =num02 
        mov  ia,m_word [intv1]                  ; get integer one} ldi intv1  
        mov  m_word [(cfp_b*arlbd)+xr],ia       ; store as lbd 1} sti arlbd(xr)  
        mov  m_word [(cfp_b*arlb2)+xr],ia       ; store as lbd 2} sti arlb2(xr)  
        mov  ia,m_word [intv2]                  ; load integer two} ldi intv2  
        mov  m_word [(cfp_b*ardm2)+xr],ia       ; store as dim 2} sti ardm2(xr)  
        mov  ia,wb                              ; get element count as integer} mti wb  
        mov  m_word [(cfp_b*ardim)+xr],ia       ; store as dim 1} sti ardim(xr)  
        xor  w0,w0                              ; zero prototype field for now} zer arpr2(xr)  
        mov  m_word [(cfp_b*arpr2)+xr],w0       ; 
        mov  m_word [(cfp_b*arofs)+xr],cfp_b*arpr2      ; set offset field (signal pass 2)} mov arofs(xr) *arpr2 
        mov  wb,xr                              ; save arblk pointer} mov wb xr 
        add  xr,cfp_b*arvl2                     ; point to first element location} add xr *arvl2 
        jmp  gtar1                              ; jump back to fill in elements} brn gtar1  
gtar7:
        mov  xr,wb                              ; restore arblk pointer} mov xr wb 
        mov  m_word [xs],wb                     ; store as result} mov (xs) wb 
        mov  ia,m_word [(cfp_b*ardim)+xr]       ; get number of elements (nn)} ldi ardim(xr)  
        imul ia,m_word [intvh]                  ; multiply by 100} mli intvh  
        add  ia,m_word [intv2]                  ; add 2 (nn02)} adi intv2  
        call icbld                              ; build integer} jsr icbld  
        push xr                                 ; store ptr for gtstg} mov -(xs) xr 
        call gtstg                              ; convert to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_232                           ; 
        dec  m_word [_rc_]                      ; convert fail is impossible} ppm   
        jns  _l0442                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0442:                                         ; 
call_232:                                       ; 
        mov  xl,xr                              ; copy string pointer} mov xl xr 
        pop  xr                                 ; reload arblk pointer} mov xr (xs)+ 
        mov  m_word [(cfp_b*arpr2)+xr],xl       ; store prototype ptr (nn02)} mov arpr2(xr) xl 
        sub  wa,num02                           ; adjust length to point to zero} sub wa =num02 
        lea  xl,[cfp_f+xl+wa]                   ; point to zero} psc xl wa 
        mov  wb,ch_cm                           ; load a comma} mov wb =ch_cm 
        mov  m_char [xl],bl                     ; store a comma over the zero} sch wb (xl) 
gtar8:
        mov  m_word [_rc_],0                    ; return to caller} exi   
        ret                                     ; 
gtar9:
        pop  xr                                 ; restore stack for conv err (sgd02)} mov xr (xs)+ 
        mov  m_word [_rc_],1                    ; return} exi 1  
        ret                                     ; 
gta9a:
        mov  m_word [_rc_],2                    ; return} exi 2  
        ret                                     ; 
gta9b:
        mov  m_word [_rc_],260                  ; } erb 260 conversion array size exceeds maximum permitted 
        jmp  err_                               ; 
                                                ; procedure gtarr} enp   
gtcod:
                                                ; entry point} prc e 1 
        cmp  m_word [xr],b_cds                  ; jump if already code} beq (xr) =b_cds gtcd1
        je   gtcd1                              ; 
        cmp  m_word [xr],b_cdc                  ; jump if already code} beq (xr) =b_cdc gtcd1
        je   gtcd1                              ; 
        push xr                                 ; stack argument for gtstg} mov -(xs) xr 
        call gtstg                              ; convert argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_233                           ; 
        dec  m_word [_rc_]                      ; jump if non-convertible} ppm gtcd2  
        jns  _l0443                             ; 
        jmp  gtcd2                              ; 
_l0443:                                         ; 
call_233:                                       ; 
        mov  w0,m_word [flptr]                  ; save fail ptr in case of error} mov gtcef flptr 
        mov  m_word [gtcef],w0                  ; 
        mov  w0,m_word [r_cod]                  ; also save code ptr} mov r_gtc r_cod 
        mov  m_word [r_gtc],w0                  ; 
        mov  m_word [r_cim],xr                  ; else set image pointer} mov r_cim xr 
        mov  m_word [scnil],wa                  ; set image length} mov scnil wa 
        xor  w0,w0                              ; set scan pointer} zer scnpt  
        mov  m_word [scnpt],w0                  ; 
        mov  m_word [stage],stgxc               ; set stage for execute compile} mov stage =stgxc 
        mov  w0,m_word [cmpsn]                  ; in case listr called} mov lstsn cmpsn 
        mov  m_word [lstsn],w0                  ; 
        inc  m_word [cmpln]                     ; bump line number} icv cmpln  
        call cmpil                              ; compile string} jsr cmpil  
        mov  m_word [stage],stgxt               ; reset stage for execute time} mov stage =stgxt 
        xor  w0,w0                              ; clear image} zer r_cim  
        mov  m_word [r_cim],w0                  ; 
gtcd1:
        mov  m_word [_rc_],0                    ; give normal gtcod return} exi   
        ret                                     ; 
gtcd2:
        mov  m_word [_rc_],1                    ; give error return} exi 1  
        ret                                     ; 
                                                ; end procedure gtcod} enp   
gtexp:
                                                ; entry point} prc e 1 
        cmp  m_word [xr],b_e__                  ; jump if already an expression} blo (xr) =b_e__ gtex1
        jb   gtex1                              ; 
        push xr                                 ; store argument for gtstg} mov -(xs) xr 
        call gtstg                              ; convert argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_234                           ; 
        dec  m_word [_rc_]                      ; jump if unconvertible} ppm gtex2  
        jns  _l0444                             ; 
        jmp  gtex2                              ; 
_l0444:                                         ; 
call_234:                                       ; 
        mov  xl,xr                              ; copy input string pointer} mov xl xr 
        lea  xl,[cfp_f+xl+wa]                   ; point one past the string end} plc xl wa 
        dec  xl                                 ; fetch the last character} lch xl -(xl) 
        xor  w0,w0                              ; 
        mov  al,m_char [xl]                     ; 
        mov  xl,w0                              ; 
        cmp  xl,ch_cl                           ; error if it is a semicolon} beq xl =ch_cl gtex2
        je   gtex2                              ; 
        cmp  xl,ch_sm                           ; or if it is a colon} beq xl =ch_sm gtex2
        je   gtex2                              ; 
        mov  m_word [r_cim],xr                  ; set input image pointer} mov r_cim xr 
        xor  w0,w0                              ; set scan pointer} zer scnpt  
        mov  m_word [scnpt],w0                  ; 
        mov  m_word [scnil],wa                  ; set input image length} mov scnil wa 
        push wb                                 ; save value/name flag} mov -(xs) wb 
        xor  wb,wb                              ; set code for normal scan} zer wb  
        mov  w0,m_word [flptr]                  ; save fail ptr in case of error} mov gtcef flptr 
        mov  m_word [gtcef],w0                  ; 
        mov  w0,m_word [r_cod]                  ; also save code ptr} mov r_gtc r_cod 
        mov  m_word [r_gtc],w0                  ; 
        mov  m_word [stage],stgev               ; adjust stage for compile} mov stage =stgev 
        mov  m_word [scntp],t_uok               ; indicate unary operator acceptable} mov scntp =t_uok 
        call expan                              ; build tree for expression} jsr expan  
        xor  w0,w0                              ; reset rescan flag} zer scnrs  
        mov  m_word [scnrs],w0                  ; 
        pop  wa                                 ; restore value/name flag} mov wa (xs)+ 
        mov  w0,m_word [scnil]                  ; error if not end of image} bne scnpt scnil gtex2
        cmp  m_word [scnpt],w0                  ; 
        jne  gtex2                              ; 
        xor  wb,wb                              ; set ok value for cdgex call} zer wb  
        mov  xl,xr                              ; copy tree pointer} mov xl xr 
        call cdgex                              ; build expression block} jsr cdgex  
        xor  w0,w0                              ; clear pointer} zer r_cim  
        mov  m_word [r_cim],w0                  ; 
        mov  m_word [stage],stgxt               ; restore stage for execute time} mov stage =stgxt 
gtex1:
        mov  m_word [_rc_],0                    ; return to gtexp caller} exi   
        ret                                     ; 
gtex2:
        mov  m_word [_rc_],1                    ; take error exit} exi 1  
        ret                                     ; 
                                                ; end procedure gtexp} enp   
gtint:
                                                ; entry point} prc e 1 
        cmp  m_word [xr],b_icl                  ; jump if already an integer} beq (xr) =b_icl gtin2
        je   gtin2                              ; 
        mov  m_word [gtina],wa                  ; else save wa} mov gtina wa 
        mov  m_word [gtinb],wb                  ; save wb} mov gtinb wb 
        call gtnum                              ; convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_235                           ; 
        dec  m_word [_rc_]                      ; jump if unconvertible} ppm gtin3  
        jns  _l0445                             ; 
        jmp  gtin3                              ; 
_l0445:                                         ; 
call_235:                                       ; 
        cmp  wa,b_icl                           ; jump if integer} beq wa =b_icl gtin1
        je   gtin1                              ; 
        movsd ra,[(cfp_b*rcval)+xr]             ; load real value} ldr rcval(xr)  
        cvttsd2si ia,ra                         ; convert to integer (err if ovflow)} rti gtin3  
        mov  r10,0x80000000                     ; 
        cmp  ia,r10                             ; 
        je   gtin3                              ; 
        call icbld                              ; if ok build icblk} jsr icbld  
gtin1:
        mov  wa,m_word [gtina]                  ; restore wa} mov wa gtina 
        mov  wb,m_word [gtinb]                  ; restore wb} mov wb gtinb 
gtin2:
        mov  m_word [_rc_],0                    ; return to gtint caller} exi   
        ret                                     ; 
gtin3:
        mov  m_word [_rc_],1                    ; take convert error exit} exi 1  
        ret                                     ; 
                                                ; end procedure gtint} enp   
gtnum:
                                                ; entry point} prc e 1 
        mov  wa,m_word [xr]                     ; load first word of block} mov wa (xr) 
        cmp  wa,b_icl                           ; jump if integer (no conversion)} beq wa =b_icl gtn34
        je   gtn34                              ; 
        cmp  wa,b_rcl                           ; jump if real (no conversion)} beq wa =b_rcl gtn34
        je   gtn34                              ; 
        push xr                                 ; stack argument in case convert err} mov -(xs) xr 
        push xr                                 ; stack argument for gtstg} mov -(xs) xr 
        call gtstg                              ; convert argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_236                           ; 
        dec  m_word [_rc_]                      ; jump if unconvertible} ppm gtn36  
        jns  _l0446                             ; 
        jmp  gtn36                              ; 
_l0446:                                         ; 
call_236:                                       ; 
        mov  ia,m_word [intv0]                  ; initialize integer result to zero} ldi intv0  
        test wa,wa                              ; jump to exit with zero if null} bze wa gtn32 
        jz   gtn32                              ; 
        xor  w0,w0                              ; tentatively indicate result +} zer gtnnf  
        mov  m_word [gtnnf],w0                  ; 
        mov  m_word [gtnex],ia                  ; initialise exponent to zero} sti gtnex  
        xor  w0,w0                              ; zero scale in case real} zer gtnsc  
        mov  m_word [gtnsc],w0                  ; 
        xor  w0,w0                              ; reset flag for dec point found} zer gtndf  
        mov  m_word [gtndf],w0                  ; 
        xor  w0,w0                              ; reset flag for digits found} zer gtnrd  
        mov  m_word [gtnrd],w0                  ; 
        movsd ra,[reav0]                        ; zero real accum in case real} ldr reav0  
        add  xr,cfp_f                           ; point to argument characters} plc xr  
gtn01:
        xor  w0,w0                              ; load first character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        cmp  wb,ch_d0                           ; jump if not digit} blt wb =ch_d0 gtn02
        jb   gtn02                              ; 
        cmp  wb,ch_d9                           ; jump if first char is a digit} ble wb =ch_d9 gtn06
        jbe  gtn06                              ; 
gtn02:
        cmp  wb,ch_bl                           ; jump if non-blank} bne wb =ch_bl gtn03
        jne  gtn03                              ; 
gtna2:
        dec  wa                                 ; else decr count and loop back} bct wa gtn01 
        jnz  gtn01                              ; 
        jmp  gtn07                              ; jump to return zero if all blanks} brn gtn07  
gtn03:
        cmp  wb,ch_pl                           ; jump if plus sign} beq wb =ch_pl gtn04
        je   gtn04                              ; 
        cmp  wb,ch_ht                           ; horizontal tab equiv to blank} beq wb =ch_ht gtna2
        je   gtna2                              ; 
        cmp  wb,ch_mn                           ; jump if not minus (may be real)} bne wb =ch_mn gtn12
        jne  gtn12                              ; 
        mov  m_word [gtnnf],xs                  ; if minus sign, set negative flag} mnz gtnnf  
gtn04:
        dec  wa                                 ; jump if chars left} bct wa gtn05 
        jnz  gtn05                              ; 
        jmp  gtn36                              ; else error} brn gtn36  
gtn05:
        xor  w0,w0                              ; load next character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        cmp  wb,ch_d0                           ; jump if not a digit} blt wb =ch_d0 gtn08
        jb   gtn08                              ; 
        cmp  wb,ch_d9                           ; jump if not a digit} bgt wb =ch_d9 gtn08
        ja   gtn08                              ; 
gtn06:
        mov  m_word [gtnsi],ia                  ; save current value} sti gtnsi  
        mov  w0,ia                              ; current*10-(new dig) jump if ovflow} cvm gtn35  
        imul w0,10                              ; 
        jo   gtn35                              ; 
        sub  wb,ch_d0                           ; 
        sub  w0,wb                              ; 
        mov  ia,w0                              ; 
        jo   gtn35                              ; 
        mov  m_word [gtnrd],xs                  ; set digit read flag} mnz gtnrd  
        dec  wa                                 ; else loop back if more chars} bct wa gtn05 
        jnz  gtn05                              ; 
gtn07:
        cmp  m_word [gtnnf],0                   ; jump if negative (all set)} bnz gtnnf gtn32 
        jnz  gtn32                              ; 
        neg  ia                                 ; else negate} ngi   
        jno  gtn32                              ; jump if no overflow} ino gtn32  
        jmp  gtn36                              ; else signal error} brn gtn36  
gtn08:
        cmp  wb,ch_bl                           ; jump if a blank} beq wb =ch_bl gtna9
        je   gtna9                              ; 
        cmp  wb,ch_ht                           ; jump if horizontal tab} beq wb =ch_ht gtna9
        je   gtna9                              ; 
        pxor ra,ra                              ; else convert integer to real} itr   
        cvtsi2sd ra,ia                          ; 
        movsd xmm0,m_real [zeron]               ; negate to get positive value} ngr   
        pxor ra,xmm0                            ; 
        jmp  gtn12                              ; jump to try for real} brn gtn12  
gtn09:
        xor  w0,w0                              ; get next char} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        cmp  wb,ch_ht                           ; jump if horizontal tab} beq wb =ch_ht gtna9
        je   gtna9                              ; 
        cmp  wb,ch_bl                           ; error if non-blank} bne wb =ch_bl gtn36
        jne  gtn36                              ; 
gtna9:
        dec  wa                                 ; loop back if more chars to check} bct wa gtn09 
        jnz  gtn09                              ; 
        jmp  gtn07                              ; return integer if all blanks} brn gtn07  
gtn10:
        xor  w0,w0                              ; load next character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        cmp  wb,ch_d0                           ; jump if non-numeric} blt wb =ch_d0 gtn12
        jb   gtn12                              ; 
        cmp  wb,ch_d9                           ; jump if non-numeric} bgt wb =ch_d9 gtn12
        ja   gtn12                              ; 
gtn11:
        sub  wb,ch_d0                           ; convert digit to number} sub wb =ch_d0 
        ldmxcsr [mxcsr_set]                     ; multiply real by 10.0} mlr reavt  
        mulsd ra,[reavt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0447                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0447:                                         ; 
        call do_chk_real_inf                    ; convert error if overflow} rov gtn36  
        jnz  gtn36                              ; 
        movsd [gtnsr],ra                        ; save result} str gtnsr  
        mov  ia,wb                              ; get new digit as integer} mti wb  
        pxor ra,ra                              ; convert new digit to real} itr   
        cvtsi2sd ra,ia                          ; 
        ldmxcsr [mxcsr_set]                     ; add to get new total} adr gtnsr  
        addsd ra,[gtnsr]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0448                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0448:                                         ; 
        mov  w0,m_word [gtndf]                  ; increment scale if after dec point} add gtnsc gtndf 
        add  m_word [gtnsc],w0                  ; 
        mov  m_word [gtnrd],xs                  ; set digit found flag} mnz gtnrd  
        dec  wa                                 ; loop back if more chars} bct wa gtn10 
        jnz  gtn10                              ; 
        jmp  gtn22                              ; else jump to scale} brn gtn22  
gtn12:
        cmp  wb,ch_dt                           ; jump if not dec point} bne wb =ch_dt gtn13
        jne  gtn13                              ; 
        cmp  m_word [gtndf],0                   ; if dec point, error if one already} bnz gtndf gtn36 
        jnz  gtn36                              ; 
        mov  m_word [gtndf],num01               ; else set flag for dec point} mov gtndf =num01 
        dec  wa                                 ; loop back if more chars} bct wa gtn10 
        jnz  gtn10                              ; 
        jmp  gtn22                              ; else jump to scale} brn gtn22  
gtn13:
        cmp  wb,ch_le                           ; jump if e for exponent} beq wb =ch_le gtn15
        je   gtn15                              ; 
        cmp  wb,ch_ld                           ; jump if d for exponent} beq wb =ch_ld gtn15
        je   gtn15                              ; 
        cmp  wb,ch_ue                           ; jump if e for exponent} beq wb =ch_ue gtn15
        je   gtn15                              ; 
        cmp  wb,ch_ud                           ; jump if d for exponent} beq wb =ch_ud gtn15
        je   gtn15                              ; 
gtn14:
        cmp  wb,ch_bl                           ; jump if blank} beq wb =ch_bl gtnb4
        je   gtnb4                              ; 
        cmp  wb,ch_ht                           ; jump if horizontal tab} beq wb =ch_ht gtnb4
        je   gtnb4                              ; 
        jmp  gtn36                              ; error if non-blank} brn gtn36  
gtnb4:
        xor  w0,w0                              ; get next character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        dec  wa                                 ; loop back to check if more} bct wa gtn14 
        jnz  gtn14                              ; 
        jmp  gtn22                              ; else jump to scale} brn gtn22  
gtn15:
        xor  w0,w0                              ; set exponent sign positive} zer gtnes  
        mov  m_word [gtnes],w0                  ; 
        mov  ia,m_word [intv0]                  ; initialize exponent to zero} ldi intv0  
        mov  m_word [gtndf],xs                  ; reset no dec point indication} mnz gtndf  
        dec  wa                                 ; jump skipping past e or d} bct wa gtn16 
        jnz  gtn16                              ; 
        jmp  gtn36                              ; error if null exponent} brn gtn36  
gtn16:
        xor  w0,w0                              ; load first exponent character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        cmp  wb,ch_pl                           ; jump if plus sign} beq wb =ch_pl gtn17
        je   gtn17                              ; 
        cmp  wb,ch_mn                           ; else jump if not minus sign} bne wb =ch_mn gtn19
        jne  gtn19                              ; 
        mov  m_word [gtnes],xs                  ; set sign negative if minus sign} mnz gtnes  
gtn17:
        dec  wa                                 ; jump if chars left} bct wa gtn18 
        jnz  gtn18                              ; 
        jmp  gtn36                              ; else error} brn gtn36  
gtn18:
        xor  w0,w0                              ; load next character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
gtn19:
        cmp  wb,ch_d0                           ; jump if not digit} blt wb =ch_d0 gtn20
        jb   gtn20                              ; 
        cmp  wb,ch_d9                           ; jump if not digit} bgt wb =ch_d9 gtn20
        ja   gtn20                              ; 
        mov  w0,ia                              ; else current*10, subtract new digit} cvm gtn36  
        imul w0,10                              ; 
        jo   gtn36                              ; 
        sub  wb,ch_d0                           ; 
        sub  w0,wb                              ; 
        mov  ia,w0                              ; 
        jo   gtn36                              ; 
        dec  wa                                 ; loop back if more chars} bct wa gtn18 
        jnz  gtn18                              ; 
        jmp  gtn21                              ; jump if exponent field is exhausted} brn gtn21  
gtn20:
        cmp  wb,ch_bl                           ; jump if blank} beq wb =ch_bl gtnc0
        je   gtnc0                              ; 
        cmp  wb,ch_ht                           ; jump if horizontal tab} beq wb =ch_ht gtnc0
        je   gtnc0                              ; 
        jmp  gtn36                              ; error if non-blank} brn gtn36  
gtnc0:
        xor  w0,w0                              ; get next character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        dec  wa                                 ; loop back till all blanks scanned} bct wa gtn20 
        jnz  gtn20                              ; 
gtn21:
        mov  m_word [gtnex],ia                  ; save collected exponent} sti gtnex  
        cmp  m_word [gtnes],0                   ; jump if it was negative} bnz gtnes gtn22 
        jnz  gtn22                              ; 
        neg  ia                                 ; else complement} ngi   
        jo   gtn36                              ; error if overflow} iov gtn36  
        mov  m_word [gtnex],ia                  ; and store positive exponent} sti gtnex  
gtn22:
        cmp  m_word [gtnrd],0                   ; error if not digits collected} bze gtnrd gtn36 
        jz   gtn36                              ; 
        cmp  m_word [gtndf],0                   ; error if no exponent or dec point} bze gtndf gtn36 
        jz   gtn36                              ; 
        mov  ia,m_word [gtnsc]                  ; else load scale as integer} mti gtnsc  
        sub  ia,m_word [gtnex]                  ; subtract exponent} sbi gtnex  
        jo   gtn36                              ; error if overflow} iov gtn36  
        cmp  ia,0                               ; jump if we must scale up} ilt gtn26  
        jl   gtn26                              ; 
        test ia,ia                              ; load scale factor, err if ovflow} mfi wa gtn36 
        js   gtn36                              ; 
        mov  wa,ia                              ; 
gtn23:
        cmp  wa,num10                           ; jump if 10 or less to go} ble wa =num10 gtn24
        jbe  gtn24                              ; 
        ldmxcsr [mxcsr_set]                     ; else divide by 10**10} dvr reatt  
        divsd ra,[reatt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0449                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0449:                                         ; 
        sub  wa,num10                           ; decrement scale} sub wa =num10 
        jmp  gtn23                              ; and loop back} brn gtn23  
gtn24:
        test wa,wa                              ; jump if scaled} bze wa gtn30 
        jz   gtn30                              ; 
        mov  wb,cfp_r                           ; else get indexing factor} lct wb =cfp_r 
        mov  xr,reav1                           ; point to powers of ten table} mov xr =reav1 
        sal  wa,log_cfp_b                       ; convert remaining scale to byte ofs} wtb wa  
gtn25:
        add  xr,wa                              ; bump pointer} add xr wa 
        dec  wb                                 ; once for each value word} bct wb gtn25 
        jnz  gtn25                              ; 
        ldmxcsr [mxcsr_set]                     ; scale down as required} dvr (xr)  
        divsd ra,[xr]                           ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0450                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0450:                                         ; 
        jmp  gtn30                              ; and jump} brn gtn30  
gtn26:
        neg  ia                                 ; get absolute value of exponent} ngi   
        jo   gtn36                              ; error if overflow} iov gtn36  
        test ia,ia                              ; acquire scale, error if ovflow} mfi wa gtn36 
        js   gtn36                              ; 
        mov  wa,ia                              ; 
gtn27:
        cmp  wa,num10                           ; jump if 10 or less to go} ble wa =num10 gtn28
        jbe  gtn28                              ; 
        ldmxcsr [mxcsr_set]                     ; else multiply by 10**10} mlr reatt  
        mulsd ra,[reatt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0451                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0451:                                         ; 
        call do_chk_real_inf                    ; error if overflow} rov gtn36  
        jnz  gtn36                              ; 
        sub  wa,num10                           ; else decrement scale} sub wa =num10 
        jmp  gtn27                              ; and loop back} brn gtn27  
gtn28:
        test wa,wa                              ; jump if scaled} bze wa gtn30 
        jz   gtn30                              ; 
        mov  wb,cfp_r                           ; else get indexing factor} lct wb =cfp_r 
        mov  xr,reav1                           ; point to powers of ten table} mov xr =reav1 
        sal  wa,log_cfp_b                       ; convert remaining scale to byte ofs} wtb wa  
gtn29:
        add  xr,wa                              ; bump pointer} add xr wa 
        dec  wb                                 ; once for each word in value} bct wb gtn29 
        jnz  gtn29                              ; 
        ldmxcsr [mxcsr_set]                     ; scale up} mlr (xr)  
        mulsd ra,[xr]                           ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0452                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0452:                                         ; 
        call do_chk_real_inf                    ; error if overflow} rov gtn36  
        jnz  gtn36                              ; 
gtn30:
        cmp  m_word [gtnnf],0                   ; jump if positive} bze gtnnf gtn31 
        jz   gtn31                              ; 
        movsd xmm0,m_real [zeron]               ; else negate} ngr   
        pxor ra,xmm0                            ; 
gtn31:
        call rcbld                              ; build real block} jsr rcbld  
        jmp  gtn33                              ; merge to exit} brn gtn33  
gtn32:
        call icbld                              ; build icblk} jsr icbld  
gtn33:
        mov  wa,m_word [xr]                     ; load first word of result block} mov wa (xr) 
        add  xs,cfp_b                           ; pop argument off stack} ica xs  
gtn34:
        mov  m_word [_rc_],0                    ; return to gtnum caller} exi   
        ret                                     ; 
gtn35:
        dec  xr                                 ; reload current character} lch wb -(xr) 
        xor  w0,w0                              ; 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        xor  w0,w0                              ; bump character pointer} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        mov  ia,m_word [gtnsi]                  ; reload integer so far} ldi gtnsi  
        pxor ra,ra                              ; convert to real} itr   
        cvtsi2sd ra,ia                          ; 
        movsd xmm0,m_real [zeron]               ; make value positive} ngr   
        pxor ra,xmm0                            ; 
        jmp  gtn11                              ; merge with real circuit} brn gtn11  
gtn36:
        pop  xr                                 ; reload original argument} mov xr (xs)+ 
        mov  m_word [_rc_],1                    ; take convert-error exit} exi 1  
        ret                                     ; 
                                                ; end procedure gtnum} enp   
gtnvr:
                                                ; entry point} prc e 1 
        cmp  m_word [xr],b_nml                  ; jump if not name} bne (xr) =b_nml gnv02
        jne  gnv02                              ; 
        mov  xr,m_word [(cfp_b*nmbas)+xr]       ; else load name base if name} mov xr nmbas(xr) 
        cmp  xr,m_word [state]                  ; skip if vrblk (in static region)} blo xr state gnv07
        jb   gnv07                              ; 
gnv01:
        mov  m_word [_rc_],1                    ; take convert-error exit} exi 1  
        ret                                     ; 
gnv02:
        mov  m_word [gnvsa],wa                  ; save wa} mov gnvsa wa 
        mov  m_word [gnvsb],wb                  ; save wb} mov gnvsb wb 
        push xr                                 ; stack argument for gtstg} mov -(xs) xr 
        call gtstg                              ; convert argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_237                           ; 
        dec  m_word [_rc_]                      ; jump if conversion error} ppm gnv01  
        jns  _l0453                             ; 
        jmp  gnv01                              ; 
_l0453:                                         ; 
call_237:                                       ; 
        test wa,wa                              ; null string is an error} bze wa gnv01 
        jz   gnv01                              ; 
        call flstg                              ; fold upper case to lower case} jsr flstg  
        push xl                                 ; save xl} mov -(xs) xl 
        push xr                                 ; stack string ptr for later} mov -(xs) xr 
        mov  wb,xr                              ; copy string pointer} mov wb xr 
        add  wb,cfp_b*schar                     ; point to characters of string} add wb *schar 
        mov  m_word [gnvst],wb                  ; save pointer to characters} mov gnvst wb 
        mov  wb,wa                              ; copy length} mov wb wa 
        add  wb,(cfp_c-1)+cfp_c*0               ; get number of words in name} ctw wb 0 
        shr  wb,log_cfp_c                       ; 
        mov  m_word [gnvnw],wb                  ; save for later} mov gnvnw wb 
        call hashs                              ; compute hash index for string} jsr hashs  
        mov  r10,m_word [hshnb]                 ; compute hash offset by taking mod} rmi hshnb  
        call do_rmi                             ; 
        mov  wc,ia                              ; get as offset} mfi wc  
        sal  wc,log_cfp_b                       ; convert offset to bytes} wtb wc  
        add  wc,m_word [hshtb]                  ; point to proper hash chain} add wc hshtb 
        sub  wc,cfp_b*vrnxt                     ; subtract offset to merge into loop} sub wc *vrnxt 
gnv03:
        mov  xl,wc                              ; copy hash chain pointer} mov xl wc 
        mov  xl,m_word [(cfp_b*vrnxt)+xl]       ; point to next vrblk on chain} mov xl vrnxt(xl) 
        test xl,xl                              ; jump if end of chain} bze xl gnv08 
        jz   gnv08                              ; 
        mov  wc,xl                              ; save pointer to this vrblk} mov wc xl 
        cmp  m_word [(cfp_b*vrlen)+xl],0        ; jump if not system variable} bnz vrlen(xl) gnv04 
        jnz  gnv04                              ; 
        mov  xl,m_word [(cfp_b*vrsvp)+xl]       ; else point to svblk} mov xl vrsvp(xl) 
        sub  xl,cfp_b*vrsof                     ; adjust offset for merge} sub xl *vrsof 
gnv04:
        cmp  wa,m_word [(cfp_b*vrlen)+xl]       ; back for next vrblk if lengths ne} bne wa vrlen(xl) gnv03
        jne  gnv03                              ; 
        add  xl,cfp_b*vrchs                     ; else point to chars of chain entry} add xl *vrchs 
        mov  wb,m_word [gnvnw]                  ; get word counter to control loop} lct wb gnvnw 
        mov  xr,m_word [gnvst]                  ; point to chars of new name} mov xr gnvst 
gnv05:
        mov  w0,m_word [xl]                     ; jump if no match for next vrblk} cne (xr) (xl) gnv03
        cmp  m_word [xr],w0                     ; 
        jnz  gnv03                              ; 
        add  xr,cfp_b                           ; bump new name pointer} ica xr  
        add  xl,cfp_b                           ; bump vrblk in chain name pointer} ica xl  
        dec  wb                                 ; else loop till all compared} bct wb gnv05 
        jnz  gnv05                              ; 
        mov  xr,wc                              ; we have found a match, get vrblk} mov xr wc 
gnv06:
        mov  wa,m_word [gnvsa]                  ; restore wa} mov wa gnvsa 
        mov  wb,m_word [gnvsb]                  ; restore wb} mov wb gnvsb 
        add  xs,cfp_b                           ; pop string pointer} ica xs  
        pop  xl                                 ; restore xl} mov xl (xs)+ 
gnv07:
        mov  m_word [_rc_],0                    ; return to gtnvr caller} exi   
        ret                                     ; 
gnv08:
        xor  xr,xr                              ; clear garbage xr pointer} zer xr  
        mov  m_word [gnvhe],wc                  ; save ptr to end of hash chain} mov gnvhe wc 
        cmp  wa,num09                           ; cannot be system var if length gt 9} bgt wa =num09 gnv14
        ja   gnv14                              ; 
        mov  xl,wa                              ; else copy length} mov xl wa 
        sal  xl,log_cfp_b                       ; convert to byte offset} wtb xl  
        mov  xl,m_word [vsrch+xl]               ; point to first svblk of this length} mov xl vsrch(xl) 
gnv09:
        mov  m_word [gnvsp],xl                  ; save table pointer} mov gnvsp xl 
        lods_w                                  ; load svbit bit string} mov wc (xl)+ 
        mov  wc,w0                              ; 
        lods_w                                  ; load length from table entry} mov wb (xl)+ 
        mov  wb,w0                              ; 
        cmp  wa,wb                              ; jump if end of right length entries} bne wa wb gnv14
        jne  gnv14                              ; 
        mov  wb,m_word [gnvnw]                  ; get word counter to control loop} lct wb gnvnw 
        mov  xr,m_word [gnvst]                  ; point to chars of new name} mov xr gnvst 
gnv10:
        mov  w0,m_word [xl]                     ; jump if name mismatch} cne (xr) (xl) gnv11
        cmp  m_word [xr],w0                     ; 
        jnz  gnv11                              ; 
        add  xr,cfp_b                           ; else bump new name pointer} ica xr  
        add  xl,cfp_b                           ; bump svblk pointer} ica xl  
        dec  wb                                 ; else loop until all checked} bct wb gnv10 
        jnz  gnv10                              ; 
        xor  wc,wc                              ; set vrlen value zero} zer wc  
        mov  wa,cfp_b*vrsi_                     ; set standard size} mov wa *vrsi_ 
        jmp  gnv15                              ; jump to build vrblk} brn gnv15  
gnv11:
        add  xl,cfp_b                           ; bump past word of chars} ica xl  
        dec  wb                                 ; loop back if more to go} bct wb gnv11 
        jnz  gnv11                              ; 
        shr  wc,svnbt                           ; remove uninteresting bits} rsh wc svnbt 
gnv12:
        mov  wb,m_word [bits1]                  ; load bit to test} mov wb bits1 
        and  wb,wc                              ; test for word present} anb wb wc 
        test wb,wb                              ; jump if not present} zrb wb gnv13 
        jz   gnv13                              ; 
        add  xl,cfp_b                           ; else bump table pointer} ica xl  
gnv13:
        shr  wc,1                               ; remove bit already processed} rsh wc 1 
        test wc,wc                              ; loop back if more bits to test} nzb wc gnv12 
        jnz  gnv12                              ; 
        jmp  gnv09                              ; else loop back for next svblk} brn gnv09  
gnv14:
        mov  wc,wa                              ; copy vrlen value} mov wc wa 
        mov  wa,vrchs                           ; load standard size -chars} mov wa =vrchs 
        add  wa,m_word [gnvnw]                  ; adjust for chars of name} add wa gnvnw 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
gnv15:
        call alost                              ; allocate space for vrblk (static)} jsr alost  
        mov  wb,xr                              ; save vrblk pointer} mov wb xr 
        mov  xl,stnvr                           ; point to model variable block} mov xl =stnvr 
        mov  wa,cfp_b*vrlen                     ; set length of standard fields} mov wa *vrlen 
        shr  wa,log_cfp_b                       ; set initial fields of new block} mvw   
        rep  movs_w                             ; 
        mov  xl,m_word [gnvhe]                  ; load pointer to end of hash chain} mov xl gnvhe 
        mov  m_word [(cfp_b*vrnxt)+xl],wb       ; add new block to end of chain} mov vrnxt(xl) wb 
        mov  w0,wc                              ; set vrlen field, bump ptr} mov (xr)+ wc 
        stos_w                                  ; 
        mov  wa,m_word [gnvnw]                  ; get length in words} mov wa gnvnw 
        sal  wa,log_cfp_b                       ; convert to length in bytes} wtb wa  
        test wc,wc                              ; jump if system variable} bze wc gnv16 
        jz   gnv16                              ; 
        mov  xl,m_word [xs]                     ; point back to string name} mov xl (xs) 
        add  xl,cfp_b*schar                     ; point to chars of name} add xl *schar 
        shr  wa,log_cfp_b                       ; move characters into place} mvw   
        rep  movs_w                             ; 
        mov  xr,wb                              ; restore vrblk pointer} mov xr wb 
        jmp  gnv06                              ; jump back to exit} brn gnv06  
gnv16:
        mov  xl,m_word [gnvsp]                  ; load pointer to svblk} mov xl gnvsp 
        mov  m_word [xr],xl                     ; set svblk ptr in vrblk} mov (xr) xl 
        mov  xr,wb                              ; restore vrblk pointer} mov xr wb 
        mov  wb,m_word [(cfp_b*svbit)+xl]       ; load bit indicators} mov wb svbit(xl) 
        add  xl,cfp_b*svchs                     ; point to characters of name} add xl *svchs 
        add  xl,wa                              ; point past characters} add xl wa 
        mov  wc,m_word [btknm]                  ; load test bit} mov wc btknm 
        and  wc,wb                              ; and to test} anb wc wb 
        test wc,wc                              ; jump if no keyword number} zrb wc gnv17 
        jz   gnv17                              ; 
        add  xl,cfp_b                           ; else bump pointer} ica xl  
gnv17:
        mov  wc,m_word [btfnc]                  ; get test bit} mov wc btfnc 
        and  wc,wb                              ; and to test} anb wc wb 
        test wc,wc                              ; skip if no system function} zrb wc gnv18 
        jz   gnv18                              ; 
        mov  m_word [(cfp_b*vrfnc)+xr],xl       ; else point vrfnc to svfnc field} mov vrfnc(xr) xl 
        add  xl,cfp_b*num02                     ; and bump past svfnc, svnar fields} add xl *num02 
gnv18:
        mov  wc,m_word [btlbl]                  ; get test bit} mov wc btlbl 
        and  wc,wb                              ; and to test} anb wc wb 
        test wc,wc                              ; jump if bit is off (no system labl)} zrb wc gnv19 
        jz   gnv19                              ; 
        mov  m_word [(cfp_b*vrlbl)+xr],xl       ; else point vrlbl to svlbl field} mov vrlbl(xr) xl 
        add  xl,cfp_b                           ; bump past svlbl field} ica xl  
gnv19:
        mov  wc,m_word [btval]                  ; load test bit} mov wc btval 
        and  wc,wb                              ; and to test} anb wc wb 
        test wc,wc                              ; all done if no value} zrb wc gnv06 
        jz   gnv06                              ; 
        mov  w0,m_word [xl]                     ; else set initial value} mov vrval(xr) (xl) 
        mov  m_word [(cfp_b*vrval)+xr],w0       ; 
        mov  m_word [(cfp_b*vrsto)+xr],b_vre    ; set error store access} mov vrsto(xr) =b_vre 
        jmp  gnv06                              ; merge back to exit to caller} brn gnv06  
                                                ; end procedure gtnvr} enp   
gtpat:
                                                ; entry point} prc e 1 
        cmp  m_word [xr],p_aaa                  ; jump if pattern already} bhi (xr) =p_aaa gtpt5
        ja   gtpt5                              ; 
        mov  m_word [gtpsb],wb                  ; save wb} mov gtpsb wb 
        push xr                                 ; stack argument for gtstg} mov -(xs) xr 
        call gtstg                              ; convert argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_238                           ; 
        dec  m_word [_rc_]                      ; jump if impossible} ppm gtpt2  
        jns  _l0454                             ; 
        jmp  gtpt2                              ; 
_l0454:                                         ; 
call_238:                                       ; 
        test wa,wa                              ; jump if non-null} bnz wa gtpt1 
        jnz  gtpt1                              ; 
        mov  xr,ndnth                           ; point to nothen node} mov xr =ndnth 
        jmp  gtpt4                              ; jump to exit} brn gtpt4  
gtpt1:
        mov  wb,p_str                           ; load pcode for multi-char string} mov wb =p_str 
        cmp  wa,num01                           ; jump if multi-char string} bne wa =num01 gtpt3
        jne  gtpt3                              ; 
        add  xr,cfp_f                           ; point to character} plc xr  
        xor  w0,w0                              ; load character} lch wa (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        mov  xr,wa                              ; set as parm1} mov xr wa 
        mov  wb,p_ans                           ; point to pcode for 1-char any} mov wb =p_ans 
        jmp  gtpt3                              ; jump to build node} brn gtpt3  
gtpt2:
        mov  wb,p_exa                           ; set pcode for expression in case} mov wb =p_exa 
        cmp  m_word [xr],b_e__                  ; jump to build node if expression} blo (xr) =b_e__ gtpt3
        jb   gtpt3                              ; 
        mov  m_word [_rc_],1                    ; take convert error exit} exi 1  
        ret                                     ; 
gtpt3:
        call pbild                              ; call routine to build pattern node} jsr pbild  
gtpt4:
        mov  wb,m_word [gtpsb]                  ; restore wb} mov wb gtpsb 
gtpt5:
        mov  m_word [_rc_],0                    ; return to gtpat caller} exi   
        ret                                     ; 
                                                ; end procedure gtpat} enp   
gtrea:
                                                ; entry point} prc e 1 
        mov  wa,m_word [xr]                     ; get first word of block} mov wa (xr) 
        cmp  wa,b_rcl                           ; jump if real} beq wa =b_rcl gtre2
        je   gtre2                              ; 
        call gtnum                              ; else convert argument to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_239                           ; 
        dec  m_word [_rc_]                      ; jump if unconvertible} ppm gtre3  
        jns  _l0455                             ; 
        jmp  gtre3                              ; 
_l0455:                                         ; 
call_239:                                       ; 
        cmp  wa,b_rcl                           ; jump if real was returned} beq wa =b_rcl gtre2
        je   gtre2                              ; 
gtre1:
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer} ldi icval(xr)  
        pxor ra,ra                              ; convert to real} itr   
        cvtsi2sd ra,ia                          ; 
        call rcbld                              ; build rcblk} jsr rcbld  
gtre2:
        mov  m_word [_rc_],0                    ; return to gtrea caller} exi   
        ret                                     ; 
gtre3:
        mov  m_word [_rc_],1                    ; take convert error exit} exi 1  
        ret                                     ; 
                                                ; end procedure gtrea} enp   
gtsmi:
        pop  m_word [prc_+cfp_b*5]              ; entry point} prc n 2 
        pop  xr                                 ; load argument} mov xr (xs)+ 
        cmp  m_word [xr],b_icl                  ; skip if already an integer} beq (xr) =b_icl gtsm1
        je   gtsm1                              ; 
        call gtint                              ; convert argument to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_240                           ; 
        dec  m_word [_rc_]                      ; jump if convert is impossible} ppm gtsm2  
        jns  _l0456                             ; 
        jmp  gtsm2                              ; 
_l0456:                                         ; 
call_240:                                       ; 
gtsm1:
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer value} ldi icval(xr)  
        test ia,ia                              ; move as one word, jump if ovflow} mfi wc gtsm3 
        js   gtsm3                              ; 
        mov  wc,ia                              ; 
        cmp  wc,m_word [mxlen]                  ; or if too large} bgt wc mxlen gtsm3
        ja   gtsm3                              ; 
        mov  xr,wc                              ; copy result to xr} mov xr wc 
        mov  m_word [_rc_],0                    ; return to gtsmi caller} exi   
        mov  w0,m_word [prc_+cfp_b*5]           ; 
        jmp  w0                                 ; 
gtsm2:
        mov  m_word [_rc_],1                    ; take non-integer error exit} exi 1  
        mov  w0,m_word [prc_+cfp_b*5]           ; 
        jmp  w0                                 ; 
gtsm3:
        mov  m_word [_rc_],2                    ; take out-of-range error exit} exi 2  
        mov  w0,m_word [prc_+cfp_b*5]           ; 
        jmp  w0                                 ; 
                                                ; end procedure gtsmi} enp   
gtstg:
        pop  m_word [prc_+cfp_b*6]              ; entry point} prc n 1 
        pop  xr                                 ; load argument, pop stack} mov xr (xs)+ 
        cmp  m_word [xr],b_scl                  ; jump if already a string} beq (xr) =b_scl gts30
        je   gts30                              ; 
gts01:
        push xr                                 ; restack argument in case error} mov -(xs) xr 
        push xl                                 ; save xl} mov -(xs) xl 
        mov  m_word [gtsvb],wb                  ; save wb} mov gtsvb wb 
        mov  m_word [gtsvc],wc                  ; save wc} mov gtsvc wc 
        mov  wa,m_word [xr]                     ; load first word of block} mov wa (xr) 
        cmp  wa,b_icl                           ; jump to convert integer} beq wa =b_icl gts05
        je   gts05                              ; 
        cmp  wa,b_rcl                           ; jump to convert real} beq wa =b_rcl gts10
        je   gts10                              ; 
        cmp  wa,b_nml                           ; jump to convert name} beq wa =b_nml gts03
        je   gts03                              ; 
gts02:
        pop  xl                                 ; restore xl} mov xl (xs)+ 
        pop  xr                                 ; reload input argument} mov xr (xs)+ 
        mov  m_word [_rc_],1                    ; take convert error exit} exi 1  
        mov  w0,m_word [prc_+cfp_b*6]           ; 
        jmp  w0                                 ; 
gts03:
        mov  xl,m_word [(cfp_b*nmbas)+xr]       ; load name base} mov xl nmbas(xr) 
        cmp  xl,m_word [state]                  ; error if not natural var (static)} bhi xl state gts02
        ja   gts02                              ; 
        add  xl,cfp_b*vrsof                     ; else point to possible string name} add xl *vrsof 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; load length} mov wa sclen(xl) 
        test wa,wa                              ; jump if not system variable} bnz wa gts04 
        jnz  gts04                              ; 
        mov  xl,m_word [(cfp_b*vrsvo)+xl]       ; else point to svblk} mov xl vrsvo(xl) 
        mov  wa,m_word [(cfp_b*svlen)+xl]       ; and load name length} mov wa svlen(xl) 
gts04:
        xor  wb,wb                              ; set offset to zero} zer wb  
        call sbstr                              ; use sbstr to copy string} jsr sbstr  
        jmp  gts29                              ; jump to exit} brn gts29  
gts05:
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load integer value} ldi icval(xr)  
        mov  m_word [gtssf],num01               ; set sign flag negative} mov gtssf =num01 
        cmp  ia,0                               ; skip if integer is negative} ilt gts06  
        jl   gts06                              ; 
        neg  ia                                 ; else negate integer} ngi   
        xor  w0,w0                              ; and reset negative flag} zer gtssf  
        mov  m_word [gtssf],w0                  ; 
gts06:
        mov  xr,m_word [gtswk]                  ; point to result work area} mov xr gtswk 
        mov  wb,nstmx                           ; initialize counter to max length} mov wb =nstmx 
        lea  xr,[cfp_f+xr+wb]                   ; prepare to store (right-left)} psc xr wb 
gts07:
        mov  r10,ia                             ; convert one digit into wa} cvd   
        mov  w0,7378697629483820647             ; 
        imul r10                                ; 
        mov  w0,r10                             ; 
        sar  w0,63                              ; 
        sar  wc,2                               ; 
        sub  wc,w0                              ; 
        lea  w0,[wc+wc*4]                       ; 
        mov  ia,wc                              ; 
        add  w0,w0                              ; 
        sub  w0,r10                             ; 
        add  w0,48                              ; 
        mov  wa,w0                              ; 
        dec  xr                                 ; store in work area} sch wa -(xr) 
        mov  m_char [xr],cl                     ; 
        dec  wb                                 ; decrement counter} dcv wb  
        cmp  ia,0                               ; loop if more digits to go} ine gts07  
        jne  gts07                              ; 
gts08:
        mov  wa,nstmx                           ; get max number of characters} mov wa =nstmx 
        sub  wa,wb                              ; compute length of result} sub wa wb 
        mov  xl,wa                              ; remember length for move later on} mov xl wa 
        add  wa,m_word [gtssf]                  ; add one for negative sign if needed} add wa gtssf 
        call alocs                              ; allocate string for result} jsr alocs  
        mov  wc,xr                              ; save result pointer for the moment} mov wc xr 
        add  xr,cfp_f                           ; point to chars of result block} psc xr  
        cmp  m_word [gtssf],0                   ; skip if positive} bze gtssf gts09 
        jz   gts09                              ; 
        mov  wa,ch_mn                           ; else load negative sign} mov wa =ch_mn 
        mov  al,cl                              ; and store it} sch wa (xr)+ 
        stos_b                                  ; 
gts09:
        mov  wa,xl                              ; recall length to move} mov wa xl 
        mov  xl,m_word [gtswk]                  ; point to result work area} mov xl gtswk 
        lea  xl,[cfp_f+xl+wb]                   ; point to first result character} plc xl wb 
        rep                                     ; move chars to result string} mvc   
        movs_b                                  ; 
        mov  xr,wc                              ; restore result pointer} mov xr wc 
        jmp  gts29                              ; jump to exit} brn gts29  
gts10:
        movsd ra,[(cfp_b*rcval)+xr]             ; load real} ldr rcval(xr)  
        xor  w0,w0                              ; reset negative flag} zer gtssf  
        mov  m_word [gtssf],w0                  ; 
        pxor xmm0,xmm0                          ; skip if zero} req gts31  
        ucomisd ra,xmm0                         ; 
        je   gts31                              ; 
        pxor xmm0,xmm0                          ; jump if real is positive} rge gts11  
        ucomisd ra,xmm0                         ; 
        jae  gts11                              ; 
        mov  m_word [gtssf],num01               ; else set negative flag} mov gtssf =num01 
        movsd xmm0,m_real [zeron]               ; and get absolute value of real} ngr   
        pxor ra,xmm0                            ; 
gts11:
        mov  ia,m_word [intv0]                  ; initialize exponent to zero} ldi intv0  
gts12:
        movsd [gtsrs],ra                        ; save real value} str gtsrs  
        ldmxcsr [mxcsr_set]                     ; subtract 0.1 to compare} sbr reap1  
        subsd ra,[reap1]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0458                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0458:                                         ; 
        pxor xmm0,xmm0                          ; jump if scale up not required} rge gts13  
        ucomisd ra,xmm0                         ; 
        jae  gts13                              ; 
        movsd ra,[gtsrs]                        ; else reload value} ldr gtsrs  
        ldmxcsr [mxcsr_set]                     ; multiply by 10**10} mlr reatt  
        mulsd ra,[reatt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0459                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0459:                                         ; 
        sub  ia,m_word [intvt]                  ; decrement exponent by 10} sbi intvt  
        jmp  gts12                              ; loop back to test again} brn gts12  
gts13:
        movsd ra,[gtsrs]                        ; reload value} ldr gtsrs  
        ldmxcsr [mxcsr_set]                     ; subtract 1.0} sbr reav1  
        subsd ra,[reav1]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0460                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0460:                                         ; 
        pxor xmm0,xmm0                          ; jump if no scale down required} rlt gts17  
        ucomisd ra,xmm0                         ; 
        jb   gts17                              ; 
        movsd ra,[gtsrs]                        ; else reload value} ldr gtsrs  
gts14:
        ldmxcsr [mxcsr_set]                     ; subtract 10**10 to compare} sbr reatt  
        subsd ra,[reatt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0461                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0461:                                         ; 
        pxor xmm0,xmm0                          ; jump if large step not required} rlt gts15  
        ucomisd ra,xmm0                         ; 
        jb   gts15                              ; 
        movsd ra,[gtsrs]                        ; else restore value} ldr gtsrs  
        ldmxcsr [mxcsr_set]                     ; divide by 10**10} dvr reatt  
        divsd ra,[reatt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0462                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0462:                                         ; 
        movsd [gtsrs],ra                        ; store new value} str gtsrs  
        add  ia,m_word [intvt]                  ; increment exponent by 10} adi intvt  
        jmp  gts14                              ; loop back} brn gts14  
gts15:
        mov  xr,reav1                           ; point to powers of ten table} mov xr =reav1 
gts16:
        movsd ra,[gtsrs]                        ; reload value} ldr gtsrs  
        add  ia,m_word [intv1]                  ; increment exponent} adi intv1  
        add  xr,cfp_b*cfp_r                     ; point to next entry in table} add xr *cfp_r 
        ldmxcsr [mxcsr_set]                     ; subtract it to compare} sbr (xr)  
        subsd ra,[xr]                           ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0463                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0463:                                         ; 
        pxor xmm0,xmm0                          ; loop till we find a larger entry} rge gts16  
        ucomisd ra,xmm0                         ; 
        jae  gts16                              ; 
        movsd ra,[gtsrs]                        ; then reload the value} ldr gtsrs  
        ldmxcsr [mxcsr_set]                     ; and complete scaling} dvr (xr)  
        divsd ra,[xr]                           ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0464                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0464:                                         ; 
        movsd [gtsrs],ra                        ; store value} str gtsrs  
gts17:
        movsd ra,[gtsrs]                        ; get value again} ldr gtsrs  
        ldmxcsr [mxcsr_set]                     ; add rounding factor} adr gtsrn  
        addsd ra,[gtsrn]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0465                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0465:                                         ; 
        movsd [gtsrs],ra                        ; store result} str gtsrs  
        ldmxcsr [mxcsr_set]                     ; subtract 1.0 to compare} sbr reav1  
        subsd ra,[reav1]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0466                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0466:                                         ; 
        pxor xmm0,xmm0                          ; skip if ok} rlt gts18  
        ucomisd ra,xmm0                         ; 
        jb   gts18                              ; 
        add  ia,m_word [intv1]                  ; else increment exponent} adi intv1  
        movsd ra,[gtsrs]                        ; reload value} ldr gtsrs  
        ldmxcsr [mxcsr_set]                     ; divide by 10.0 to rescale} dvr reavt  
        divsd ra,[reavt]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0467                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0467:                                         ; 
        jmp  gts19                              ; jump to merge} brn gts19  
gts18:
        movsd ra,[gtsrs]                        ; reload rounded value} ldr gtsrs  
gts19:
        mov  xl,cfp_s                           ; set num dec digits = cfp_s} mov xl =cfp_s 
        mov  m_word [gtses],ch_mn               ; set exponent sign negative} mov gtses =ch_mn 
        cmp  ia,0                               ; all set if exponent is negative} ilt gts21  
        jl   gts21                              ; 
        mov  wa,ia                              ; else fetch exponent} mfi wa  
        cmp  wa,cfp_s                           ; skip if we can use special format} ble wa =cfp_s gts20
        jbe  gts20                              ; 
        mov  ia,wa                              ; else restore exponent} mti wa  
        neg  ia                                 ; set negative for cvd} ngi   
        mov  m_word [gtses],ch_pl               ; set plus sign for exponent sign} mov gtses =ch_pl 
        jmp  gts21                              ; jump to generate exponent} brn gts21  
gts20:
        sub  xl,wa                              ; compute digits after decimal point} sub xl wa 
        mov  ia,m_word [intv0]                  ; reset exponent to zero} ldi intv0  
gts21:
        mov  xr,m_word [gtswk]                  ; point to work area} mov xr gtswk 
        mov  wb,nstmx                           ; set character ctr to max length} mov wb =nstmx 
        lea  xr,[cfp_f+xr+wb]                   ; prepare to store (right to left)} psc xr wb 
        cmp  ia,0                               ; skip exponent if it is zero} ieq gts23  
        je   gts23                              ; 
gts22:
        mov  r10,ia                             ; convert a digit into wa} cvd   
        mov  w0,7378697629483820647             ; 
        imul r10                                ; 
        mov  w0,r10                             ; 
        sar  w0,63                              ; 
        sar  wc,2                               ; 
        sub  wc,w0                              ; 
        lea  w0,[wc+wc*4]                       ; 
        mov  ia,wc                              ; 
        add  w0,w0                              ; 
        sub  w0,r10                             ; 
        add  w0,48                              ; 
        mov  wa,w0                              ; 
        dec  xr                                 ; store in work area} sch wa -(xr) 
        mov  m_char [xr],cl                     ; 
        dec  wb                                 ; decrement counter} dcv wb  
        cmp  ia,0                               ; loop back if more digits to go} ine gts22  
        jne  gts22                              ; 
        mov  wa,m_word [gtses]                  ; load exponent sign} mov wa gtses 
        dec  xr                                 ; store in work area} sch wa -(xr) 
        mov  m_char [xr],cl                     ; 
        mov  wa,ch_le                           ; get character letter e} mov wa =ch_le 
        dec  xr                                 ; store in work area} sch wa -(xr) 
        mov  m_char [xr],cl                     ; 
        sub  wb,num02                           ; decrement counter for sign and e} sub wb =num02 
gts23:
        ldmxcsr [mxcsr_set]                     ; convert real to integer (10**cfp_s)} mlr gtssc  
        mulsd ra,[gtssc]                        ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0468                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0468:                                         ; 
        cvttsd2si ia,ra                         ; get integer (overflow impossible)} rti   
        neg  ia                                 ; negate as required by cvd} ngi   
gts24:
        test xl,xl                              ; jump if no digits left to do} bze xl gts27 
        jz   gts27                              ; 
        mov  r10,ia                             ; else convert one digit} cvd   
        mov  w0,7378697629483820647             ; 
        imul r10                                ; 
        mov  w0,r10                             ; 
        sar  w0,63                              ; 
        sar  wc,2                               ; 
        sub  wc,w0                              ; 
        lea  w0,[wc+wc*4]                       ; 
        mov  ia,wc                              ; 
        add  w0,w0                              ; 
        sub  w0,r10                             ; 
        add  w0,48                              ; 
        mov  wa,w0                              ; 
        cmp  wa,ch_d0                           ; jump if not a zero} bne wa =ch_d0 gts26
        jne  gts26                              ; 
        dec  xl                                 ; decrement counter} dcv xl  
        jmp  gts24                              ; loop back for next digit} brn gts24  
gts25:
        mov  r10,ia                             ; convert a digit into wa} cvd   
        mov  w0,7378697629483820647             ; 
        imul r10                                ; 
        mov  w0,r10                             ; 
        sar  w0,63                              ; 
        sar  wc,2                               ; 
        sub  wc,w0                              ; 
        lea  w0,[wc+wc*4]                       ; 
        mov  ia,wc                              ; 
        add  w0,w0                              ; 
        sub  w0,r10                             ; 
        add  w0,48                              ; 
        mov  wa,w0                              ; 
gts26:
        dec  xr                                 ; store digit} sch wa -(xr) 
        mov  m_char [xr],cl                     ; 
        dec  wb                                 ; decrement counter} dcv wb  
        dec  xl                                 ; decrement counter} dcv xl  
        test xl,xl                              ; loop back if more to go} bnz xl gts25 
        jnz  gts25                              ; 
gts27:
        mov  wa,ch_dt                           ; load decimal point} mov wa =ch_dt 
        dec  xr                                 ; store in work area} sch wa -(xr) 
        mov  m_char [xr],cl                     ; 
        dec  wb                                 ; decrement counter} dcv wb  
gts28:
        mov  r10,ia                             ; convert a digit into wa} cvd   
        mov  w0,7378697629483820647             ; 
        imul r10                                ; 
        mov  w0,r10                             ; 
        sar  w0,63                              ; 
        sar  wc,2                               ; 
        sub  wc,w0                              ; 
        lea  w0,[wc+wc*4]                       ; 
        mov  ia,wc                              ; 
        add  w0,w0                              ; 
        sub  w0,r10                             ; 
        add  w0,48                              ; 
        mov  wa,w0                              ; 
        dec  xr                                 ; store in work area} sch wa -(xr) 
        mov  m_char [xr],cl                     ; 
        dec  wb                                 ; decrement counter} dcv wb  
        cmp  ia,0                               ; loop back if more to go} ine gts28  
        jne  gts28                              ; 
        jmp  gts08                              ; else jump back to exit} brn gts08  
gts29:
        pop  xl                                 ; restore xl} mov xl (xs)+ 
        add  xs,cfp_b                           ; pop argument} ica xs  
        mov  wb,m_word [gtsvb]                  ; restore wb} mov wb gtsvb 
        mov  wc,m_word [gtsvc]                  ; restore wc} mov wc gtsvc 
gts30:
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; load string length} mov wa sclen(xr) 
        mov  m_word [_rc_],0                    ; return to caller} exi   
        mov  w0,m_word [prc_+cfp_b*6]           ; 
        jmp  w0                                 ; 
gts31:
        mov  xl,scre0                           ; point to string} mov xl =scre0 
        mov  wa,num02                           ; 2 chars} mov wa =num02 
        xor  wb,wb                              ; zero offset} zer wb  
        call sbstr                              ; copy string} jsr sbstr  
        jmp  gts29                              ; return} brn gts29  
                                                ; end procedure gtstg} enp   
gtvar:
                                                ; entry point} prc e 1 
        cmp  m_word [xr],b_nml                  ; jump if not a name} bne (xr) =b_nml gtvr2
        jne  gtvr2                              ; 
        mov  wa,m_word [(cfp_b*nmofs)+xr]       ; else load name offset} mov wa nmofs(xr) 
        mov  xl,m_word [(cfp_b*nmbas)+xr]       ; load name base} mov xl nmbas(xr) 
        cmp  m_word [xl],b_evt                  ; error if expression variable} beq (xl) =b_evt gtvr1
        je   gtvr1                              ; 
        cmp  m_word [xl],b_kvt                  ; all ok if not keyword variable} bne (xl) =b_kvt gtvr3
        jne  gtvr3                              ; 
gtvr1:
        mov  m_word [_rc_],1                    ; take convert error exit} exi 1  
        ret                                     ; 
gtvr2:
        mov  m_word [gtvrc],wc                  ; save wc} mov gtvrc wc 
        call gtnvr                              ; locate vrblk if possible} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_241                           ; 
        dec  m_word [_rc_]                      ; jump if convert error} ppm gtvr1  
        jns  _l0469                             ; 
        jmp  gtvr1                              ; 
_l0469:                                         ; 
call_241:                                       ; 
        mov  xl,xr                              ; else copy vrblk name base} mov xl xr 
        mov  wa,cfp_b*vrval                     ; and set offset} mov wa *vrval 
        mov  wc,m_word [gtvrc]                  ; restore wc} mov wc gtvrc 
gtvr3:
        cmp  xl,m_word [state]                  ; all ok if not natural variable} bhi xl state gtvr4
        ja   gtvr4                              ; 
        cmp  m_word [(cfp_b*vrsto)+xl],b_vre    ; error if protected variable} beq vrsto(xl) =b_vre gtvr1
        je   gtvr1                              ; 
gtvr4:
        mov  m_word [_rc_],0                    ; return to caller} exi   
        ret                                     ; 
                                                ; end procedure gtvar} enp   
hashs:
                                                ; entry point} prc e 0 
        mov  wc,e_hnw                           ; get number of words to use} mov wc =e_hnw 
        test wc,wc                              ; branch if one character per word} bze wc hshsa 
        jz   hshsa                              ; 
        mov  wc,m_word [(cfp_b*sclen)+xr]       ; load string length in characters} mov wc sclen(xr) 
        mov  wb,wc                              ; initialize with length} mov wb wc 
        test wc,wc                              ; jump if null string} bze wc hshs3 
        jz   hshs3                              ; 
        nop                                     ; correct byte ordering if necessary} zgb wb  
        add  wc,(cfp_c-1)+cfp_c*0               ; get number of words of chars} ctw wc 0 
        shr  wc,log_cfp_c                       ; 
        add  xr,cfp_b*schar                     ; point to characters of string} add xr *schar 
        cmp  wc,e_hnw                           ; use whole string if short} blo wc =e_hnw hshs1
        jb   hshs1                              ; 
        mov  wc,e_hnw                           ; else set to involve first e_hnw wds} mov wc =e_hnw 
hshs1:
                                                ; set counter to control loop} lct wc wc 
hshs2:
        xor  wb,m_word [xr]                     ; exclusive or next word of chars} xob wb (xr)+ 
        lea  xr,[xr+cfp_b]                      ; 
        dec  wc                                 ; loop till all processed} bct wc hshs2 
        jnz  hshs2                              ; 
hshs3:
        nop                                     ; zeroise undefined bits} zgb wb  
        and  wb,m_word [bitsm]                  ; ensure in range 0 to cfp_m} anb wb bitsm 
        mov  ia,wb                              ; move result as integer} mti wb  
        xor  xr,xr                              ; clear garbage value in xr} zer xr  
        ret                                     ; return to hashs caller} exi   
hshsa:
        mov  wc,m_word [(cfp_b*sclen)+xr]       ; load string length in characters} mov wc sclen(xr) 
        mov  wb,wc                              ; initialize with length} mov wb wc 
        test wc,wc                              ; jump if null string} bze wc hshs3 
        jz   hshs3                              ; 
        nop                                     ; correct byte ordering if necessary} zgb wb  
        add  wc,(cfp_c-1)+cfp_c*0               ; get number of words of chars} ctw wc 0 
        shr  wc,log_cfp_c                       ; 
        add  xr,cfp_f                           ; } plc xr  
        push xl                                 ; save xl} mov -(xs) xl 
        mov  xl,wc                              ; load length for branch} mov xl wc 
        cmp  xl,num25                           ; use first characters if longer} bge xl =num25 hsh24
        jae  hsh24                              ; 
        jmp  m_word [_l0470+xl*cfp_b]           ; merge to compute hash} bsw xl 25 
        segment .data                           ; 
_l0470:                                         ; 
        d_word hsh00                            ; } iff 0 hsh00 
        d_word hsh01                            ; } iff 1 hsh01 
        d_word hsh02                            ; } iff 2 hsh02 
        d_word hsh03                            ; } iff 3 hsh03 
        d_word hsh04                            ; } iff 4 hsh04 
        d_word hsh05                            ; } iff 5 hsh05 
        d_word hsh06                            ; } iff 6 hsh06 
        d_word hsh07                            ; } iff 7 hsh07 
        d_word hsh08                            ; } iff 8 hsh08 
        d_word hsh09                            ; } iff 9 hsh09 
        d_word hsh10                            ; } iff 10 hsh10 
        d_word hsh11                            ; } iff 11 hsh11 
        d_word hsh12                            ; } iff 12 hsh12 
        d_word hsh13                            ; } iff 13 hsh13 
        d_word hsh14                            ; } iff 14 hsh14 
        d_word hsh15                            ; } iff 15 hsh15 
        d_word hsh16                            ; } iff 16 hsh16 
        d_word hsh17                            ; } iff 17 hsh17 
        d_word hsh18                            ; } iff 18 hsh18 
        d_word hsh19                            ; } iff 19 hsh19 
        d_word hsh20                            ; } iff 20 hsh20 
        d_word hsh21                            ; } iff 21 hsh21 
        d_word hsh22                            ; } iff 22 hsh22 
        d_word hsh23                            ; } iff 23 hsh23 
        d_word hsh24                            ; } iff 24 hsh24 
        segment .text                           ; } esw   
hsh24:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,24                              ; shift for hash} lsh wc 24 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh23:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,16                              ; shift for hash} lsh wc 16 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh22:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,8                               ; shift for hash} lsh wc 8 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh21:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh20:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,24                              ; shift for hash} lsh wc 24 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh19:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,16                              ; shift for hash} lsh wc 16 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh18:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,8                               ; shift for hash} lsh wc 8 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh17:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh16:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,24                              ; shift for hash} lsh wc 24 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh15:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,16                              ; shift for hash} lsh wc 16 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh14:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,8                               ; shift for hash} lsh wc 8 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh13:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh12:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,24                              ; shift for hash} lsh wc 24 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh11:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,16                              ; shift for hash} lsh wc 16 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh10:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,8                               ; shift for hash} lsh wc 8 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh09:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh08:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,24                              ; shift for hash} lsh wc 24 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh07:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,16                              ; shift for hash} lsh wc 16 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh06:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,8                               ; shift for hash} lsh wc 8 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh05:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh04:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,24                              ; shift for hash} lsh wc 24 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh03:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,16                              ; shift for hash} lsh wc 16 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh02:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        shl  wc,8                               ; shift for hash} lsh wc 8 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh01:
        xor  w0,w0                              ; load next character} lch wc (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        inc  xr                                 ; 
        xor  wb,wc                              ; hash character} xob wb wc 
hsh00:
        pop  xl                                 ; restore xl} mov xl (xs)+ 
        jmp  hshs3                              ; merge to complete hash} brn hshs3  
                                                ; end procedure hashs} enp   
icbld:
                                                ; entry point} prc e 0 
        test ia,ia                              ; copy small integers} mfi xr icbl1 
        js   icbl1                              ; 
        mov  xr,ia                              ; 
        cmp  xr,num02                           ; jump if 0,1 or 2} ble xr =num02 icbl3
        jbe  icbl3                              ; 
icbl1:
        mov  xr,m_word [dnamp]                  ; load pointer to next available loc} mov xr dnamp 
        add  xr,cfp_b*icsi_                     ; point past new icblk} add xr *icsi_ 
        cmp  xr,m_word [dname]                  ; jump if there is room} blo xr dname icbl2
        jb   icbl2                              ; 
        mov  wa,cfp_b*icsi_                     ; else load length of icblk} mov wa *icsi_ 
        call alloc                              ; use standard allocator to get block} jsr alloc  
        add  xr,wa                              ; point past block to merge} add xr wa 
icbl2:
        mov  m_word [dnamp],xr                  ; set new pointer} mov dnamp xr 
        sub  xr,cfp_b*icsi_                     ; point back to start of block} sub xr *icsi_ 
        mov  m_word [xr],b_icl                  ; store type word} mov (xr) =b_icl 
        mov  m_word [(cfp_b*icval)+xr],ia       ; store integer value in icblk} sti icval(xr)  
        ret                                     ; return to icbld caller} exi   
icbl3:
        sal  xr,log_cfp_b                       ; convert integer to offset} wtb xr  
        mov  xr,m_word [intab+xr]               ; point to pre-built icblk} mov xr intab(xr) 
        ret                                     ; return} exi   
                                                ; end procedure icbld} enp   
ident:
                                                ; entry point} prc e 1 
        cmp  xr,xl                              ; jump if same pointer (ident)} beq xr xl iden7
        je   iden7                              ; 
        mov  wc,m_word [xr]                     ; else load arg 1 type word} mov wc (xr) 
        cmp  wc,m_word [xl]                     ; differ if arg 2 type word differ} bne wc (xl) iden1
        jne  iden1                              ; 
        cmp  wc,b_scl                           ; jump if strings} beq wc =b_scl iden2
        je   iden2                              ; 
        cmp  wc,b_icl                           ; jump if integers} beq wc =b_icl iden4
        je   iden4                              ; 
        cmp  wc,b_rcl                           ; jump if reals} beq wc =b_rcl iden5
        je   iden5                              ; 
        cmp  wc,b_nml                           ; jump if names} beq wc =b_nml iden6
        je   iden6                              ; 
iden1:
        mov  m_word [_rc_],0                    ; take differ exit} exi   
        ret                                     ; 
iden2:
        mov  wc,m_word [(cfp_b*sclen)+xr]       ; load arg 1 length} mov wc sclen(xr) 
        cmp  wc,m_word [(cfp_b*sclen)+xl]       ; differ if lengths differ} bne wc sclen(xl) iden1
        jne  iden1                              ; 
idn2a:
        add  xr,cfp_b*schar                     ; point to chars of arg 1} add xr *schar 
        add  xl,cfp_b*schar                     ; point to chars of arg 2} add xl *schar 
        add  wc,(cfp_c-1)+cfp_c*0               ; get number of words in strings} ctw wc 0 
        shr  wc,log_cfp_c                       ; 
iden3:
        mov  w0,m_word [xl]                     ; differ if chars do not match} cne (xr) (xl) iden8
        cmp  m_word [xr],w0                     ; 
        jnz  iden8                              ; 
        add  xr,cfp_b                           ; else bump arg one pointer} ica xr  
        add  xl,cfp_b                           ; bump arg two pointer} ica xl  
        dec  wc                                 ; loop back till all checked} bct wc iden3 
        jnz  iden3                              ; 
        xor  xl,xl                              ; clear garbage value in xl} zer xl  
        xor  xr,xr                              ; clear garbage value in xr} zer xr  
        mov  m_word [_rc_],1                    ; take ident exit} exi 1  
        ret                                     ; 
iden4:
        mov  ia,m_word [(cfp_b*icval)+xr]       ; load arg 1} ldi icval(xr)  
        sub  ia,m_word [(cfp_b*icval)+xl]       ; subtract arg 2 to compare} sbi icval(xl)  
        jo   iden1                              ; differ if overflow} iov iden1  
        cmp  ia,0                               ; differ if result is not zero} ine iden1  
        jne  iden1                              ; 
        mov  m_word [_rc_],1                    ; take ident exit} exi 1  
        ret                                     ; 
iden5:
        movsd ra,[(cfp_b*rcval)+xr]             ; load arg 1} ldr rcval(xr)  
        ldmxcsr [mxcsr_set]                     ; subtract arg 2 to compare} sbr rcval(xl)  
        subsd ra,[(cfp_b*rcval)+xl]             ; 
        stmxcsr [mxcsr]                         ; 
        test m_word [mxcsr],0x0010              ; 
        jz   _l0471                             ; 
        pxor ra,ra                              ; 
        ldmxcsr [mxcsr_set]                     ; 
_l0471:                                         ; 
        call do_chk_real_inf                    ; differ if overflow} rov iden1  
        jnz  iden1                              ; 
        pxor xmm0,xmm0                          ; differ if result is not zero} rne iden1  
        ucomisd ra,xmm0                         ; 
        jne  iden1                              ; 
        mov  m_word [_rc_],1                    ; take ident exit} exi 1  
        ret                                     ; 
iden6:
        mov  w0,m_word [(cfp_b*nmofs)+xl]       ; differ if different offset} bne nmofs(xr) nmofs(xl) iden1
        cmp  m_word [(cfp_b*nmofs)+xr],w0       ; 
        jne  iden1                              ; 
        mov  w0,m_word [(cfp_b*nmbas)+xl]       ; differ if different base} bne nmbas(xr) nmbas(xl) iden1
        cmp  m_word [(cfp_b*nmbas)+xr],w0       ; 
        jne  iden1                              ; 
iden7:
        mov  m_word [_rc_],1                    ; take ident exit} exi 1  
        ret                                     ; 
iden8:
        xor  xr,xr                              ; clear garbage ptr in xr} zer xr  
        xor  xl,xl                              ; clear garbage ptr in xl} zer xl  
        mov  m_word [_rc_],0                    ; return to caller (differ)} exi   
        ret                                     ; 
                                                ; end procedure ident} enp   
inout:
                                                ; entry point} prc e 0 
        push wb                                 ; stack trblk type} mov -(xs) wb 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; get name length} mov wa sclen(xl) 
        xor  wb,wb                              ; point to start of name} zer wb  
        call sbstr                              ; build a proper scblk} jsr sbstr  
        call gtnvr                              ; build vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_242                           ; 
        dec  m_word [_rc_]                      ; no error return} ppm   
        jns  _l0472                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0472:                                         ; 
call_242:                                       ; 
        mov  wc,xr                              ; save vrblk pointer} mov wc xr 
        pop  wb                                 ; get trter field} mov wb (xs)+ 
        xor  xl,xl                              ; zero trfpt} zer xl  
        call trbld                              ; build trblk} jsr trbld  
        mov  xl,wc                              ; recall vrblk pointer} mov xl wc 
        mov  w0,m_word [(cfp_b*vrsvp)+xl]       ; store svblk pointer} mov trter(xr) vrsvp(xl) 
        mov  m_word [(cfp_b*trter)+xr],w0       ; 
        mov  m_word [(cfp_b*vrval)+xl],xr       ; store trblk ptr in vrblk} mov vrval(xl) xr 
        mov  m_word [(cfp_b*vrget)+xl],b_vra    ; set trapped access} mov vrget(xl) =b_vra 
        mov  m_word [(cfp_b*vrsto)+xl],b_vrv    ; set trapped store} mov vrsto(xl) =b_vrv 
        ret                                     ; return to caller} exi   
                                                ; end procedure inout} enp   
insta:
                                                ; entry point} prc e 0 
        mov  wc,m_word [prlen]                  ; no. of chars in print bfr} mov wc prlen 
        mov  m_word [prbuf],xr                  ; print bfr is put at static start} mov prbuf xr 
        mov  w0,b_scl                           ; store string type code} mov (xr)+ =b_scl 
        stos_w                                  ; 
        mov  w0,wc                              ; and string length} mov (xr)+ wc 
        stos_w                                  ; 
        add  wc,(cfp_c-1)+cfp_c*0               ; get number of words in buffer} ctw wc 0 
        shr  wc,log_cfp_c                       ; 
        mov  m_word [prlnw],wc                  ; store for buffer clear} mov prlnw wc 
inst1:
        mov  w0,m_word [nullw]                  ; store blank} mov (xr)+ nullw 
        stos_w                                  ; 
        dec  wc                                 ; loop} bct wc inst1 
        jnz  inst1                              ; 
        mov  wa,nstmx                           ; get max num chars in output number} mov wa =nstmx 
        add  wa,(cfp_b-1)+cfp_b*scsi_           ; no of bytes needed} ctb wa scsi_ 
        and  wa,-cfp_b                          ; 
        mov  m_word [gtswk],xr                  ; store bfr adrs} mov gtswk xr 
        add  xr,wa                              ; bump for work bfr} add xr wa 
        mov  m_word [kvalp],xr                  ; save alphabet pointer} mov kvalp xr 
        mov  m_word [xr],b_scl                  ; string blk type} mov (xr) =b_scl 
        mov  wc,cfp_a                           ; no of chars in alphabet} mov wc =cfp_a 
        mov  m_word [(cfp_b*sclen)+xr],wc       ; store as string length} mov sclen(xr) wc 
        mov  wb,wc                              ; copy char count} mov wb wc 
        add  wb,(cfp_b-1)+cfp_b*scsi_           ; no. of bytes needed} ctb wb scsi_ 
        and  wb,-cfp_b                          ; 
        add  wb,xr                              ; current end address for static} add wb xr 
        mov  wa,wb                              ; save adrs past alphabet string} mov wa wb 
        add  xr,cfp_f                           ; point to chars of string} psc xr  
        xor  wb,wb                              ; set initial character value} zer wb  
inst2:
        mov  al,bl                              ; store next code} sch wb (xr)+ 
        stos_b                                  ; 
        inc  wb                                 ; bump code value} icv wb  
        dec  wc                                 ; loop till all stored} bct wc inst2 
        jnz  inst2                              ; 
        mov  xr,wa                              ; return current static ptr} mov xr wa 
        ret                                     ; return to caller} exi   
                                                ; end procedure insta} enp   
iofcb:
        pop  m_word [prc_+cfp_b*7]              ; entry point} prc n 3 
        call gtstg                              ; get arg as string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_243                           ; 
        dec  m_word [_rc_]                      ; fail} ppm iofc2  
        jns  _l0473                             ; 
        jmp  iofc2                              ; 
_l0473:                                         ; 
call_243:                                       ; 
        mov  xl,xr                              ; copy string ptr} mov xl xr 
        call gtnvr                              ; get as natural variable} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_244                           ; 
        dec  m_word [_rc_]                      ; fail if null} ppm iofc3  
        jns  _l0474                             ; 
        jmp  iofc3                              ; 
_l0474:                                         ; 
call_244:                                       ; 
        mov  wb,xl                              ; copy string pointer again} mov wb xl 
        mov  xl,xr                              ; copy vrblk ptr for return} mov xl xr 
        xor  wa,wa                              ; in case no trblk found} zer wa  
iofc1:
        mov  xr,m_word [(cfp_b*vrval)+xr]       ; get possible trblk ptr} mov xr vrval(xr) 
        cmp  m_word [xr],b_trt                  ; fail if end of chain} bne (xr) =b_trt iofc4
        jne  iofc4                              ; 
        cmp  m_word [(cfp_b*trtyp)+xr],trtfc    ; loop if not file arg trblk} bne trtyp(xr) =trtfc iofc1
        jne  iofc1                              ; 
        mov  wa,m_word [(cfp_b*trfpt)+xr]       ; get fcblk ptr} mov wa trfpt(xr) 
        mov  xr,wb                              ; copy arg} mov xr wb 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*7]           ; 
        jmp  w0                                 ; 
iofc2:
        mov  m_word [_rc_],1                    ; fail} exi 1  
        mov  w0,m_word [prc_+cfp_b*7]           ; 
        jmp  w0                                 ; 
iofc3:
        mov  m_word [_rc_],2                    ; null arg return} exi 2  
        mov  w0,m_word [prc_+cfp_b*7]           ; 
        jmp  w0                                 ; 
iofc4:
        mov  m_word [_rc_],3                    ; file not found return} exi 3  
        mov  w0,m_word [prc_+cfp_b*7]           ; 
        jmp  w0                                 ; 
                                                ; end procedure iofcb} enp   
ioppf:
        pop  m_word [prc_+cfp_b*8]              ; entry point} prc n 0 
        xor  wb,wb                              ; to count fields extracted} zer wb  
iopp1:
        mov  xl,iodel                           ; get delimiter} mov xl =iodel 
        mov  wc,xl                              ; copy it} mov wc xl 
        xor  wa,wa                              ; retain leading blanks in filearg2} zer wa  
        call xscan                              ; get next field} jsr xscan  
        push xr                                 ; stack it} mov -(xs) xr 
        inc  wb                                 ; increment count} icv wb  
        test wa,wa                              ; loop} bnz wa iopp1 
        jnz  iopp1                              ; 
        mov  wc,wb                              ; count of fields} mov wc wb 
        mov  wb,m_word [ioptt]                  ; i/o marker} mov wb ioptt 
        mov  wa,m_word [r_iof]                  ; fcblk ptr or 0} mov wa r_iof 
        mov  xr,m_word [r_io2]                  ; file arg2 ptr} mov xr r_io2 
        mov  xl,m_word [r_io1]                  ; filearg1} mov xl r_io1 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*8]           ; 
        jmp  w0                                 ; 
                                                ; end procedure ioppf} enp   
ioput:
        pop  m_word [prc_+cfp_b*9]              ; entry point} prc n 7 
        xor  w0,w0                              ; in case no trtrf block used} zer r_iot  
        mov  m_word [r_iot],w0                  ; 
        xor  w0,w0                              ; in case no fcblk alocated} zer r_iof  
        mov  m_word [r_iof],w0                  ; 
        xor  w0,w0                              ; in case sysio fails} zer r_iop  
        mov  m_word [r_iop],w0                  ; 
        mov  m_word [ioptt],wb                  ; store i/o trace type} mov ioptt wb 
        call xscni                              ; prepare to scan filearg2} jsr xscni  
        dec  m_word [_rc_]                      ; 
        js   call_245                           ; 
        dec  m_word [_rc_]                      ; fail} ppm iop13  
        jns  _l0475                             ; 
        jmp  iop13                              ; 
_l0475:                                         ; 
        dec  m_word [_rc_]                      ; null file arg2} ppm iopa0  
        jns  _l0476                             ; 
        jmp  iopa0                              ; 
_l0476:                                         ; 
call_245:                                       ; 
iopa0:
        mov  m_word [r_io2],xr                  ; keep file arg2} mov r_io2 xr 
        mov  xl,wa                              ; copy length} mov xl wa 
        call gtstg                              ; convert filearg1 to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_246                           ; 
        dec  m_word [_rc_]                      ; fail} ppm iop14  
        jns  _l0477                             ; 
        jmp  iop14                              ; 
_l0477:                                         ; 
call_246:                                       ; 
        mov  m_word [r_io1],xr                  ; keep filearg1 ptr} mov r_io1 xr 
        call gtnvr                              ; convert to natural variable} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_247                           ; 
        dec  m_word [_rc_]                      ; jump if null} ppm iop00  
        jns  _l0478                             ; 
        jmp  iop00                              ; 
_l0478:                                         ; 
call_247:                                       ; 
        jmp  iop04                              ; jump to process non-null args} brn iop04  
iop00:
        test xl,xl                              ; skip if both args null} bze xl iop01 
        jz   iop01                              ; 
        call ioppf                              ; process filearg2} jsr ioppf  
        call sysfc                              ; call for filearg2 check} jsr sysfc  
        dec  m_word [_rc_]                      ; 
        js   call_248                           ; 
        dec  m_word [_rc_]                      ; fail} ppm iop16  
        jns  _l0479                             ; 
        jmp  iop16                              ; 
_l0479:                                         ; 
        dec  m_word [_rc_]                      ; fail} ppm iop26  
        jns  _l0480                             ; 
        jmp  iop26                              ; 
_l0480:                                         ; 
call_248:                                       ; 
        jmp  iop11                              ; complete file association} brn iop11  
iop01:
        mov  wb,m_word [ioptt]                  ; get trace type} mov wb ioptt 
        mov  xr,m_word [r_iot]                  ; get 0 or trtrf ptr} mov xr r_iot 
        call trbld                              ; build trblk} jsr trbld  
        mov  wc,xr                              ; copy trblk pointer} mov wc xr 
        pop  xr                                 ; get variable from stack} mov xr (xs)+ 
        push wc                                 ; make trblk collectable} mov -(xs) wc 
        call gtvar                              ; point to variable} jsr gtvar  
        dec  m_word [_rc_]                      ; 
        js   call_249                           ; 
        dec  m_word [_rc_]                      ; fail} ppm iop15  
        jns  _l0481                             ; 
        jmp  iop15                              ; 
_l0481:                                         ; 
call_249:                                       ; 
        pop  wc                                 ; recover trblk pointer} mov wc (xs)+ 
        mov  m_word [r_ion],xl                  ; save name pointer} mov r_ion xl 
        mov  xr,xl                              ; copy name pointer} mov xr xl 
        add  xr,wa                              ; point to variable} add xr wa 
        sub  xr,cfp_b*vrval                     ; subtract offset,merge into loop} sub xr *vrval 
iop02:
        mov  xl,xr                              ; copy blk ptr} mov xl xr 
        mov  xr,m_word [(cfp_b*vrval)+xr]       ; load ptr to next trblk} mov xr vrval(xr) 
        cmp  m_word [xr],b_trt                  ; jump if not trapped} bne (xr) =b_trt iop03
        jne  iop03                              ; 
        mov  w0,m_word [ioptt]                  ; loop if not same assocn} bne trtyp(xr) ioptt iop02
        cmp  m_word [(cfp_b*trtyp)+xr],w0       ; 
        jne  iop02                              ; 
        mov  xr,m_word [(cfp_b*trnxt)+xr]       ; get value and delete old trblk} mov xr trnxt(xr) 
iop03:
        mov  m_word [(cfp_b*vrval)+xl],wc       ; link to this trblk} mov vrval(xl) wc 
        mov  xl,wc                              ; copy pointer} mov xl wc 
        mov  m_word [(cfp_b*trnxt)+xl],xr       ; store value in trblk} mov trnxt(xl) xr 
        mov  xr,m_word [r_ion]                  ; restore possible vrblk pointer} mov xr r_ion 
        mov  wb,wa                              ; keep offset to name} mov wb wa 
        call setvr                              ; if vrblk, set vrget,vrsto} jsr setvr  
        mov  xr,m_word [r_iot]                  ; get 0 or trtrf ptr} mov xr r_iot 
        test xr,xr                              ; jump if trtrf block exists} bnz xr iop19 
        jnz  iop19                              ; 
        mov  m_word [_rc_],0                    ; return to caller} exi   
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop04:
        xor  wa,wa                              ; in case no fcblk found} zer wa  
iop05:
        mov  wb,xr                              ; remember blk ptr} mov wb xr 
        mov  xr,m_word [(cfp_b*vrval)+xr]       ; chain along} mov xr vrval(xr) 
        cmp  m_word [xr],b_trt                  ; jump if end of trblk chain} bne (xr) =b_trt iop06
        jne  iop06                              ; 
        cmp  m_word [(cfp_b*trtyp)+xr],trtfc    ; loop if more to go} bne trtyp(xr) =trtfc iop05
        jne  iop05                              ; 
        mov  m_word [r_iot],xr                  ; point to file arg1 trblk} mov r_iot xr 
        mov  wa,m_word [(cfp_b*trfpt)+xr]       ; get fcblk ptr from trblk} mov wa trfpt(xr) 
iop06:
        mov  m_word [r_iof],wa                  ; keep possible fcblk ptr} mov r_iof wa 
        mov  m_word [r_iop],wb                  ; keep preceding blk ptr} mov r_iop wb 
        call ioppf                              ; process filearg2} jsr ioppf  
        call sysfc                              ; see if fcblk required} jsr sysfc  
        dec  m_word [_rc_]                      ; 
        js   call_250                           ; 
        dec  m_word [_rc_]                      ; fail} ppm iop16  
        jns  _l0482                             ; 
        jmp  iop16                              ; 
_l0482:                                         ; 
        dec  m_word [_rc_]                      ; fail} ppm iop26  
        jns  _l0483                             ; 
        jmp  iop26                              ; 
_l0483:                                         ; 
call_250:                                       ; 
        test wa,wa                              ; skip if no new fcblk wanted} bze wa iop12 
        jz   iop12                              ; 
        cmp  wc,num02                           ; jump if fcblk in dynamic} blt wc =num02 iop6a
        jb   iop6a                              ; 
        call alost                              ; get it in static} jsr alost  
        jmp  iop6b                              ; skip} brn iop6b  
iop6a:
        call alloc                              ; get space for fcblk} jsr alloc  
iop6b:
        mov  xl,xr                              ; point to fcblk} mov xl xr 
        mov  wb,wa                              ; copy its length} mov wb wa 
        shr  wb,log_cfp_b                       ; get count as words (sgd apr80)} btw wb  
iop07:
        xor  w0,w0                              ; clear a word} zer (xr)+  
        stos_w                                  ; 
        dec  wb                                 ; loop} bct wb iop07 
        jnz  iop07                              ; 
        cmp  wc,num02                           ; skip if in static - dont set fields} beq wc =num02 iop09
        je   iop09                              ; 
        mov  m_word [xl],b_xnt                  ; store xnblk code in case} mov (xl) =b_xnt 
        mov  m_word [(cfp_b*num01)+xl],wa       ; store length} mov num01(xl) wa 
        test wc,wc                              ; jump if xnblk wanted} bnz wc iop09 
        jnz  iop09                              ; 
        mov  m_word [xl],b_xrt                  ; xrblk code requested} mov (xl) =b_xrt 
iop09:
        mov  xr,m_word [r_iot]                  ; get possible trblk ptr} mov xr r_iot 
        mov  m_word [r_iof],xl                  ; store fcblk ptr} mov r_iof xl 
        test xr,xr                              ; jump if trblk already found} bnz xr iop10 
        jnz  iop10                              ; 
        mov  wb,trtfc                           ; trtyp for fcblk trap blk} mov wb =trtfc 
        call trbld                              ; make the block} jsr trbld  
        mov  m_word [r_iot],xr                  ; copy trtrf ptr} mov r_iot xr 
        mov  xl,m_word [r_iop]                  ; point to preceding blk} mov xl r_iop 
        mov  w0,m_word [(cfp_b*vrval)+xl]       ; copy value field to trblk} mov vrval(xr) vrval(xl) 
        mov  m_word [(cfp_b*vrval)+xr],w0       ; 
        mov  m_word [(cfp_b*vrval)+xl],xr       ; link new trblk into chain} mov vrval(xl) xr 
        mov  xr,xl                              ; point to predecessor blk} mov xr xl 
        call setvr                              ; set trace intercepts} jsr setvr  
        mov  xr,m_word [(cfp_b*vrval)+xr]       ; recover trblk ptr} mov xr vrval(xr) 
        jmp  iop1a                              ; store fcblk ptr} brn iop1a  
iop10:
        xor  w0,w0                              ; do not release if sysio fails} zer r_iop  
        mov  m_word [r_iop],w0                  ; 
iop1a:
        mov  w0,m_word [r_iof]                  ; store fcblk ptr} mov trfpt(xr) r_iof 
        mov  m_word [(cfp_b*trfpt)+xr],w0       ; 
iop11:
        mov  wa,m_word [r_iof]                  ; copy fcblk ptr or 0} mov wa r_iof 
        mov  wb,m_word [ioptt]                  ; get input/output flag} mov wb ioptt 
        mov  xr,m_word [r_io2]                  ; get file arg2} mov xr r_io2 
        mov  xl,m_word [r_io1]                  ; get file arg1} mov xl r_io1 
        call sysio                              ; associate to the file} jsr sysio  
        dec  m_word [_rc_]                      ; 
        js   call_251                           ; 
        dec  m_word [_rc_]                      ; fail} ppm iop17  
        jns  _l0484                             ; 
        jmp  iop17                              ; 
_l0484:                                         ; 
        dec  m_word [_rc_]                      ; fail} ppm iop18  
        jns  _l0485                             ; 
        jmp  iop18                              ; 
_l0485:                                         ; 
call_251:                                       ; 
        cmp  m_word [r_iot],0                   ; not std input if non-null trtrf blk} bnz r_iot iop01 
        jnz  iop01                              ; 
        cmp  m_word [ioptt],0                   ; jump if output} bnz ioptt iop01 
        jnz  iop01                              ; 
        test wc,wc                              ; no change to standard read length} bze wc iop01 
        jz   iop01                              ; 
        mov  m_word [cswin],wc                  ; store new read length for std file} mov cswin wc 
        jmp  iop01                              ; merge to finish the task} brn iop01  
iop12:
        test xl,xl                              ; jump if private fcblk} bnz xl iop09 
        jnz  iop09                              ; 
        jmp  iop11                              ; finish the association} brn iop11  
iop13:
        mov  m_word [_rc_],1                    ; 3rd arg not a string} exi 1  
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop14:
        mov  m_word [_rc_],2                    ; 2nd arg unsuitable} exi 2  
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop15:
        add  xs,cfp_b                           ; discard trblk pointer} ica xs  
        mov  m_word [_rc_],3                    ; 1st arg unsuitable} exi 3  
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop16:
        mov  m_word [_rc_],4                    ; file spec wrong} exi 4  
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop26:
        mov  m_word [_rc_],7                    ; fcblk in use} exi 7  
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop17:
        mov  xr,m_word [r_iop]                  ; is there a trblk to release} mov xr r_iop 
        test xr,xr                              ; if not} bze xr iopa7 
        jz   iopa7                              ; 
        mov  xl,m_word [(cfp_b*vrval)+xr]       ; point to trblk} mov xl vrval(xr) 
        mov  w0,m_word [(cfp_b*vrval)+xl]       ; unsplice it} mov vrval(xr) vrval(xl) 
        mov  m_word [(cfp_b*vrval)+xr],w0       ; 
        call setvr                              ; adjust trace intercepts} jsr setvr  
iopa7:
        mov  m_word [_rc_],5                    ; i/o file does not exist} exi 5  
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop18:
        mov  xr,m_word [r_iop]                  ; is there a trblk to release} mov xr r_iop 
        test xr,xr                              ; if not} bze xr iopa7 
        jz   iopa7                              ; 
        mov  xl,m_word [(cfp_b*vrval)+xr]       ; point to trblk} mov xl vrval(xr) 
        mov  w0,m_word [(cfp_b*vrval)+xl]       ; unsplice it} mov vrval(xr) vrval(xl) 
        mov  m_word [(cfp_b*vrval)+xr],w0       ; 
        call setvr                              ; adjust trace intercepts} jsr setvr  
iopa8:
        mov  m_word [_rc_],6                    ; i/o file cannot be read/written} exi 6  
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
iop19:
        mov  wc,m_word [r_ion]                  ; wc = name base, wb = name offset} mov wc r_ion 
iop20:
        mov  xr,m_word [(cfp_b*trtrf)+xr]       ; next link of chain} mov xr trtrf(xr) 
        test xr,xr                              ; not found} bze xr iop21 
        jz   iop21                              ; 
        cmp  wc,m_word [(cfp_b*ionmb)+xr]       ; no match} bne wc ionmb(xr) iop20
        jne  iop20                              ; 
        cmp  wb,m_word [(cfp_b*ionmo)+xr]       ; exit if matched} beq wb ionmo(xr) iop22
        je   iop22                              ; 
        jmp  iop20                              ; loop} brn iop20  
iop21:
        mov  wa,cfp_b*num05                     ; space needed} mov wa *num05 
        call alloc                              ; get it} jsr alloc  
        mov  m_word [xr],b_xrt                  ; store xrblk code} mov (xr) =b_xrt 
        mov  m_word [(cfp_b*num01)+xr],wa       ; store length} mov num01(xr) wa 
        mov  m_word [(cfp_b*ionmb)+xr],wc       ; store name base} mov ionmb(xr) wc 
        mov  m_word [(cfp_b*ionmo)+xr],wb       ; store name offset} mov ionmo(xr) wb 
        mov  xl,m_word [r_iot]                  ; point to trtrf blk} mov xl r_iot 
        mov  wa,m_word [(cfp_b*trtrf)+xl]       ; get ptr field contents} mov wa trtrf(xl) 
        mov  m_word [(cfp_b*trtrf)+xl],xr       ; store ptr to new block} mov trtrf(xl) xr 
        mov  m_word [(cfp_b*trtrf)+xr],wa       ; complete the linking} mov trtrf(xr) wa 
iop22:
        cmp  m_word [r_iof],0                   ; skip if no fcblk} bze r_iof iop25 
        jz   iop25                              ; 
        mov  xl,m_word [r_fcb]                  ; ptr to head of existing chain} mov xl r_fcb 
iop23:
        test xl,xl                              ; not on if end of chain} bze xl iop24 
        jz   iop24                              ; 
        mov  w0,m_word [r_iof]                  ; dont duplicate if find it} beq num03(xl) r_iof iop25
        cmp  m_word [(cfp_b*num03)+xl],w0       ; 
        je   iop25                              ; 
        mov  xl,m_word [(cfp_b*num02)+xl]       ; get next link} mov xl num02(xl) 
        jmp  iop23                              ; loop} brn iop23  
iop24:
        mov  wa,cfp_b*num04                     ; space needed} mov wa *num04 
        call alloc                              ; get it} jsr alloc  
        mov  m_word [xr],b_xrt                  ; store block code} mov (xr) =b_xrt 
        mov  m_word [(cfp_b*num01)+xr],wa       ; store length} mov num01(xr) wa 
        mov  w0,m_word [r_fcb]                  ; store previous link in this node} mov num02(xr) r_fcb 
        mov  m_word [(cfp_b*num02)+xr],w0       ; 
        mov  w0,m_word [r_iof]                  ; store fcblk ptr} mov num03(xr) r_iof 
        mov  m_word [(cfp_b*num03)+xr],w0       ; 
        mov  m_word [r_fcb],xr                  ; insert node into fcblk chain} mov r_fcb xr 
iop25:
        mov  m_word [_rc_],0                    ; return to caller} exi   
        mov  w0,m_word [prc_+cfp_b*9]           ; 
        jmp  w0                                 ; 
                                                ; end procedure ioput} enp   
ktrex:
                                                ; entry point (recursive)} prc r 0 
        test xl,xl                              ; immediate exit if keyword untraced} bze xl ktrx3 
        jz   ktrx3                              ; 
        cmp  m_word [kvtra],0                   ; immediate exit if trace = 0} bze kvtra ktrx3 
        jz   ktrx3                              ; 
        dec  m_word [kvtra]                     ; else decrement trace} dcv kvtra  
        push xr                                 ; save xr} mov -(xs) xr 
        mov  xr,xl                              ; copy trblk pointer} mov xr xl 
        mov  xl,m_word [(cfp_b*trkvr)+xr]       ; load vrblk pointer (nmbas)} mov xl trkvr(xr) 
        mov  wa,cfp_b*vrval                     ; set name offset} mov wa *vrval 
        cmp  m_word [(cfp_b*trfnc)+xr],0        ; jump if print trace} bze trfnc(xr) ktrx1 
        jz   ktrx1                              ; 
        call trxeq                              ; else execute full trace} jsr trxeq  
        jmp  ktrx2                              ; and jump to exit} brn ktrx2  
ktrx1:
        push xl                                 ; stack vrblk ptr for kwnam} mov -(xs) xl 
        push wa                                 ; stack offset for kwnam} mov -(xs) wa 
        call prtsn                              ; print statement number} jsr prtsn  
        mov  wa,ch_am                           ; load ampersand} mov wa =ch_am 
        call prtch                              ; print ampersand} jsr prtch  
        call prtnm                              ; print keyword name} jsr prtnm  
        mov  xr,tmbeb                           ; point to blank-equal-blank} mov xr =tmbeb 
        call prtst                              ; print blank-equal-blank} jsr prtst  
        call kwnam                              ; get keyword pseudo-variable name} jsr kwnam  
        mov  m_word [dnamp],xr                  ; reset ptr to delete kvblk} mov dnamp xr 
        call acess                              ; get keyword value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_252                           ; 
        dec  m_word [_rc_]                      ; failure is impossible} ppm   
        jns  _l0486                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0486:                                         ; 
call_252:                                       ; 
        call prtvl                              ; print keyword value} jsr prtvl  
        call prtnl                              ; terminate print line} jsr prtnl  
ktrx2:
        pop  xr                                 ; restore entry xr} mov xr (xs)+ 
ktrx3:
        ret                                     ; return to ktrex caller} exi   
                                                ; end procedure ktrex} enp   
kwnam:
        pop  m_word [prc_+cfp_b*10]             ; entry point} prc n 0 
        add  xs,cfp_b                           ; ignore name offset} ica xs  
        pop  xr                                 ; load name base} mov xr (xs)+ 
        cmp  xr,m_word [state]                  ; jump if not natural variable name} bge xr state kwnm1
        jae  kwnm1                              ; 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; error if not system variable} bnz vrlen(xr) kwnm1 
        jnz  kwnm1                              ; 
        mov  xr,m_word [(cfp_b*vrsvp)+xr]       ; else point to svblk} mov xr vrsvp(xr) 
        mov  wa,m_word [(cfp_b*svbit)+xr]       ; load bit mask} mov wa svbit(xr) 
        and  wa,m_word [btknm]                  ; and with keyword bit} anb wa btknm 
        test wa,wa                              ; error if no keyword association} zrb wa kwnm1 
        jz   kwnm1                              ; 
        mov  wa,m_word [(cfp_b*svlen)+xr]       ; else load name length in characters} mov wa svlen(xr) 
        add  wa,(cfp_b-1)+cfp_b*svchs           ; compute offset to field we want} ctb wa svchs 
        and  wa,-cfp_b                          ; 
        add  xr,wa                              ; point to svknm field} add xr wa 
        mov  wb,m_word [xr]                     ; load svknm value} mov wb (xr) 
        mov  wa,cfp_b*kvsi_                     ; set size of kvblk} mov wa *kvsi_ 
        call alloc                              ; allocate kvblk} jsr alloc  
        mov  m_word [xr],b_kvt                  ; store type word} mov (xr) =b_kvt 
        mov  m_word [(cfp_b*kvnum)+xr],wb       ; store keyword number} mov kvnum(xr) wb 
        mov  m_word [(cfp_b*kvvar)+xr],trbkv    ; set dummy trblk pointer} mov kvvar(xr) =trbkv 
        mov  xl,xr                              ; copy kvblk pointer} mov xl xr 
        mov  wa,cfp_b*kvvar                     ; set proper offset} mov wa *kvvar 
        mov  m_word [_rc_],0                    ; return to kvnam caller} exi   
        mov  w0,m_word [prc_+cfp_b*10]          ; 
        jmp  w0                                 ; 
kwnm1:
        mov  m_word [_rc_],251                  ; } erb 251 keyword operand is not name of defined keyword 
        jmp  err_                               ; 
                                                ; end procedure kwnam} enp   
lcomp:
        pop  m_word [prc_+cfp_b*11]             ; entry point} prc n 5 
        call gtstg                              ; convert second arg to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_253                           ; 
        dec  m_word [_rc_]                      ; jump if second arg not string} ppm lcmp6  
        jns  _l0487                             ; 
        jmp  lcmp6                              ; 
_l0487:                                         ; 
call_253:                                       ; 
        mov  xl,xr                              ; else save pointer} mov xl xr 
        mov  wc,wa                              ; and length} mov wc wa 
        call gtstg                              ; convert first argument to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_254                           ; 
        dec  m_word [_rc_]                      ; jump if not string} ppm lcmp5  
        jns  _l0488                             ; 
        jmp  lcmp5                              ; 
_l0488:                                         ; 
call_254:                                       ; 
        mov  wb,wa                              ; save arg 1 length} mov wb wa 
        add  xr,cfp_f                           ; point to chars of arg 1} plc xr  
        add  xl,cfp_f                           ; point to chars of arg 2} plc xl  
        cmp  wa,wc                              ; jump if arg 1 length is smaller} blo wa wc lcmp1
        jb   lcmp1                              ; 
        mov  wa,wc                              ; else set arg 2 length as smaller} mov wa wc 
lcmp1:
        test wa,wa                              ; if null string, compare lengths} bze wa lcmp7 
        jz   lcmp7                              ; 
        repe cmps_b                             ; compare strings, jump if unequal} cmc lcmp4 lcmp3 
        mov  xl,0                               ; 
        mov  xr,xl                              ; 
        ja   lcmp3                              ; 
        jb   lcmp4                              ; 
lcmp7:
        cmp  wb,wc                              ; if equal, jump if lengths unequal} bne wb wc lcmp2
        jne  lcmp2                              ; 
        mov  m_word [_rc_],4                    ; else identical strings, leq exit} exi 4  
        mov  w0,m_word [prc_+cfp_b*11]          ; 
        jmp  w0                                 ; 
lcmp2:
        cmp  wb,wc                              ; jump if arg 1 length gt arg 2 leng} bhi wb wc lcmp4
        ja   lcmp4                              ; 
lcmp3:
        mov  m_word [_rc_],3                    ; take llt exit} exi 3  
        mov  w0,m_word [prc_+cfp_b*11]          ; 
        jmp  w0                                 ; 
lcmp4:
        mov  m_word [_rc_],5                    ; take lgt exit} exi 5  
        mov  w0,m_word [prc_+cfp_b*11]          ; 
        jmp  w0                                 ; 
lcmp5:
        mov  m_word [_rc_],1                    ; take bad first arg exit} exi 1  
        mov  w0,m_word [prc_+cfp_b*11]          ; 
        jmp  w0                                 ; 
lcmp6:
        mov  m_word [_rc_],2                    ; take bad second arg error exit} exi 2  
        mov  w0,m_word [prc_+cfp_b*11]          ; 
        jmp  w0                                 ; 
                                                ; end procedure lcomp} enp   
listr:
                                                ; entry point} prc e 0 
        cmp  m_word [cnttl],0                   ; jump if -title or -stitl} bnz cnttl list5 
        jnz  list5                              ; 
        cmp  m_word [lstpf],0                   ; immediate exit if already listed} bnz lstpf list4 
        jnz  list4                              ; 
        mov  w0,m_word [lstnp]                  ; jump if no room} bge lstlc lstnp list6
        cmp  m_word [lstlc],w0                  ; 
        jae  list6                              ; 
list0:
        mov  xr,m_word [r_cim]                  ; load pointer to current image} mov xr r_cim 
        test xr,xr                              ; jump if no image to print} bze xr list4 
        jz   list4                              ; 
        add  xr,cfp_f                           ; point to characters} plc xr  
        xor  w0,w0                              ; load first character} lch wa (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        mov  xr,m_word [lstsn]                  ; load statement number} mov xr lstsn 
        test xr,xr                              ; jump if no statement number} bze xr list2 
        jz   list2                              ; 
        mov  ia,xr                              ; else get stmnt number as integer} mti xr  
        cmp  m_word [stage],stgic               ; skip if execute time} bne stage =stgic list1
        jne  list1                              ; 
        cmp  wa,ch_as                           ; no stmnt number list if comment} beq wa =ch_as list2
        je   list2                              ; 
        cmp  wa,ch_mn                           ; no stmnt no. if control card} beq wa =ch_mn list2
        je   list2                              ; 
list1:
        call prtin                              ; else print statement number} jsr prtin  
        xor  w0,w0                              ; and clear for next time in} zer lstsn  
        mov  m_word [lstsn],w0                  ; 
list2:
        mov  xr,m_word [lstid]                  ; include depth of image} mov xr lstid 
        test xr,xr                              ; if not from an include file} bze xr list8 
        jz   list8                              ; 
        mov  wa,stnpd                           ; position for start of statement} mov wa =stnpd 
        sub  wa,num03                           ; position to place include depth} sub wa =num03 
        mov  m_word [profs],wa                  ; set as starting position} mov profs wa 
        mov  ia,xr                              ; include depth as integer} mti xr  
        call prtin                              ; print include depth} jsr prtin  
list8:
        mov  m_word [profs],stnpd               ; point past statement number} mov profs =stnpd 
        mov  xr,m_word [r_cim]                  ; load pointer to current image} mov xr r_cim 
        call prtst                              ; print it} jsr prtst  
        inc  m_word [lstlc]                     ; bump line counter} icv lstlc  
        cmp  m_word [erlst],0                   ; jump if error copy to int.ch.} bnz erlst list3 
        jnz  list3                              ; 
        call prtnl                              ; terminate line} jsr prtnl  
        cmp  m_word [cswdb],0                   ; jump if -single mode} bze cswdb list3 
        jz   list3                              ; 
        call prtnl                              ; else add a blank line} jsr prtnl  
        inc  m_word [lstlc]                     ; and bump line counter} icv lstlc  
list3:
        mov  m_word [lstpf],xs                  ; set flag for line printed} mnz lstpf  
list4:
        ret                                     ; return to listr caller} exi   
list5:
        xor  w0,w0                              ; clear flag} zer cnttl  
        mov  m_word [cnttl],w0                  ; 
list6:
        call prtps                              ; eject} jsr prtps  
        cmp  m_word [prich],0                   ; skip if listing to regular printer} bze prich list7 
        jz   list7                              ; 
        cmp  m_word [r_ttl],nulls               ; terminal listing omits null title} beq r_ttl =nulls list0
        je   list0                              ; 
list7:
        call listt                              ; list title} jsr listt  
        jmp  list0                              ; merge} brn list0  
                                                ; end procedure listr} enp   
listt:
                                                ; entry point} prc e 0 
        mov  xr,m_word [r_ttl]                  ; point to source listing title} mov xr r_ttl 
        call prtst                              ; print title} jsr prtst  
        mov  w0,m_word [lstpo]                  ; set offset} mov profs lstpo 
        mov  m_word [profs],w0                  ; 
        mov  xr,lstms                           ; set page message} mov xr =lstms 
        call prtst                              ; print page message} jsr prtst  
        inc  m_word [lstpg]                     ; bump page number} icv lstpg  
        mov  ia,m_word [lstpg]                  ; load page number as integer} mti lstpg  
        call prtin                              ; print page number} jsr prtin  
        call prtnl                              ; terminate title line} jsr prtnl  
        add  m_word [lstlc],num02               ; count title line and blank line} add lstlc =num02 
        mov  xr,m_word [r_stl]                  ; load pointer to sub-title} mov xr r_stl 
        test xr,xr                              ; jump if no sub-title} bze xr lstt1 
        jz   lstt1                              ; 
        call prtst                              ; else print sub-title} jsr prtst  
        call prtnl                              ; terminate line} jsr prtnl  
        inc  m_word [lstlc]                     ; bump line count} icv lstlc  
lstt1:
        call prtnl                              ; print a blank line} jsr prtnl  
        ret                                     ; return to caller} exi   
                                                ; end procedure listt} enp   
newfn:
                                                ; entry point} prc e 0 
        push xr                                 ; save new name} mov -(xs) xr 
        mov  xl,m_word [r_sfc]                  ; load previous name} mov xl r_sfc 
        call ident                              ; check for equality} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_255                           ; 
        dec  m_word [_rc_]                      ; jump if identical} ppm nwfn1  
        jns  _l0489                             ; 
        jmp  nwfn1                              ; 
_l0489:                                         ; 
call_255:                                       ; 
        pop  xr                                 ; different, restore name} mov xr (xs)+ 
        mov  m_word [r_sfc],xr                  ; record current file name} mov r_sfc xr 
        mov  wb,m_word [cmpsn]                  ; get current statement} mov wb cmpsn 
        mov  ia,wb                              ; convert to integer} mti wb  
        call icbld                              ; build icblk for stmt number} jsr icbld  
        mov  xl,m_word [r_sfn]                  ; file name table} mov xl r_sfn 
        mov  wb,xs                              ; lookup statement number by name} mnz wb  
        call tfind                              ; allocate new teblk} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_256                           ; 
        dec  m_word [_rc_]                      ; always possible to allocate block} ppm   
        jns  _l0490                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0490:                                         ; 
call_256:                                       ; 
        mov  w0,m_word [r_sfc]                  ; record file name as entry value} mov teval(xl) r_sfc 
        mov  m_word [(cfp_b*teval)+xl],w0       ; 
        ret                                     ; } exi   
nwfn1:
        add  xs,cfp_b                           ; pop stack} ica xs  
        ret                                     ; } exi   
nexts:
                                                ; entry point} prc e 0 
        cmp  m_word [cswls],0                   ; jump if -nolist} bze cswls nxts2 
        jz   nxts2                              ; 
        mov  xr,m_word [r_cim]                  ; point to image} mov xr r_cim 
        test xr,xr                              ; jump if no image} bze xr nxts2 
        jz   nxts2                              ; 
        add  xr,cfp_f                           ; get char ptr} plc xr  
        xor  w0,w0                              ; get first char} lch wa (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        cmp  wa,ch_mn                           ; jump if not ctrl card} bne wa =ch_mn nxts1
        jne  nxts1                              ; 
        cmp  m_word [cswpr],0                   ; jump if -noprint} bze cswpr nxts2 
        jz   nxts2                              ; 
nxts1:
        call listr                              ; list line} jsr listr  
nxts2:
        mov  xr,m_word [r_cni]                  ; point to next image} mov xr r_cni 
        mov  m_word [r_cim],xr                  ; set as next image} mov r_cim xr 
        mov  w0,m_word [rdnln]                  ; set as current line number} mov rdcln rdnln 
        mov  m_word [rdcln],w0                  ; 
        mov  w0,m_word [cnind]                  ; set as current include depth} mov lstid cnind 
        mov  m_word [lstid],w0                  ; 
        xor  w0,w0                              ; clear next image pointer} zer r_cni  
        mov  m_word [r_cni],w0                  ; 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; get input image length} mov wa sclen(xr) 
        mov  wb,m_word [cswin]                  ; get max allowable length} mov wb cswin 
        cmp  wa,wb                              ; skip if not too long} blo wa wb nxts3
        jb   nxts3                              ; 
        mov  wa,wb                              ; else truncate} mov wa wb 
nxts3:
        mov  m_word [scnil],wa                  ; use as record length} mov scnil wa 
        xor  w0,w0                              ; reset scnse} zer scnse  
        mov  m_word [scnse],w0                  ; 
        xor  w0,w0                              ; set line not listed yet} zer lstpf  
        mov  m_word [lstpf],w0                  ; 
        ret                                     ; return to nexts caller} exi   
                                                ; end procedure nexts} enp   
patin:
        pop  m_word [prc_+cfp_b*12]             ; entry point} prc n 2 
        mov  xl,wa                              ; preserve expression arg pcode} mov xl wa 
        call gtsmi                              ; try to convert arg as small integer} jsr gtsmi  
        dec  m_word [_rc_]                      ; 
        js   call_257                           ; 
        dec  m_word [_rc_]                      ; jump if not integer} ppm ptin2  
        jns  _l0491                             ; 
        jmp  ptin2                              ; 
_l0491:                                         ; 
        dec  m_word [_rc_]                      ; jump if out of range} ppm ptin3  
        jns  _l0492                             ; 
        jmp  ptin3                              ; 
_l0492:                                         ; 
call_257:                                       ; 
ptin1:
        call pbild                              ; build pattern node} jsr pbild  
        mov  m_word [_rc_],0                    ; return to caller} exi   
        mov  w0,m_word [prc_+cfp_b*12]          ; 
        jmp  w0                                 ; 
ptin2:
        mov  wb,xl                              ; copy expr arg case pcode} mov wb xl 
        cmp  m_word [xr],b_e__                  ; all ok if expression arg} blo (xr) =b_e__ ptin1
        jb   ptin1                              ; 
        mov  m_word [_rc_],1                    ; else take error exit for wrong type} exi 1  
        mov  w0,m_word [prc_+cfp_b*12]          ; 
        jmp  w0                                 ; 
ptin3:
        mov  m_word [_rc_],2                    ; take out-of-range error exit} exi 2  
        mov  w0,m_word [prc_+cfp_b*12]          ; 
        jmp  w0                                 ; 
                                                ; end procedure patin} enp   
patst:
        pop  m_word [prc_+cfp_b*13]             ; entry point} prc n 1 
        call gtstg                              ; convert argument as string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_258                           ; 
        dec  m_word [_rc_]                      ; jump if not string} ppm pats7  
        jns  _l0493                             ; 
        jmp  pats7                              ; 
_l0493:                                         ; 
call_258:                                       ; 
        test wa,wa                              ; jump if null string (catspaw)} bze wa pats7 
        jz   pats7                              ; 
        cmp  wa,num01                           ; jump if not one char string} bne wa =num01 pats2
        jne  pats2                              ; 
        test wb,wb                              ; treat as multi-char if evals call} bze wb pats2 
        jz   pats2                              ; 
        add  xr,cfp_f                           ; point to character} plc xr  
        xor  w0,w0                              ; load character} lch xr (xr) 
        mov  al,m_char [xr]                     ; 
        mov  xr,w0                              ; 
pats1:
        call pbild                              ; call routine to build node} jsr pbild  
        mov  m_word [_rc_],0                    ; return to patst caller} exi   
        mov  w0,m_word [prc_+cfp_b*13]          ; 
        jmp  w0                                 ; 
pats2:
        push xl                                 ; save multi-char pcode} mov -(xs) xl 
        mov  wc,m_word [ctmsk]                  ; load current mask bit} mov wc ctmsk 
        cmp  xr,m_word [r_cts]                  ; jump if same as last string c3.738} beq xr r_cts pats6
        je   pats6                              ; 
        push xr                                 ; save string pointer} mov -(xs) xr 
        shl  wc,1                               ; shift to next position} lsh wc 1 
        test wc,wc                              ; skip if position left in this tbl} nzb wc pats4 
        jnz  pats4                              ; 
        mov  wa,cfp_b*ctsi_                     ; set size of ctblk} mov wa *ctsi_ 
        call alloc                              ; allocate ctblk} jsr alloc  
        mov  m_word [r_ctp],xr                  ; store ptr to new ctblk} mov r_ctp xr 
        mov  w0,b_ctt                           ; store type code, bump ptr} mov (xr)+ =b_ctt 
        stos_w                                  ; 
        mov  wb,cfp_a                           ; set number of words to clear} lct wb =cfp_a 
        mov  wc,m_word [bits0]                  ; load all zero bits} mov wc bits0 
pats3:
        mov  w0,wc                              ; move word of zero bits} mov (xr)+ wc 
        stos_w                                  ; 
        dec  wb                                 ; loop till all cleared} bct wb pats3 
        jnz  pats3                              ; 
        mov  wc,m_word [bits1]                  ; set initial bit position} mov wc bits1 
pats4:
        mov  m_word [ctmsk],wc                  ; save parm2 (new bit position)} mov ctmsk wc 
        pop  xl                                 ; restore pointer to argument string} mov xl (xs)+ 
        mov  m_word [r_cts],xl                  ; save for next time   c3.738} mov r_cts xl 
        mov  wb,m_word [(cfp_b*sclen)+xl]       ; load string length} mov wb sclen(xl) 
        test wb,wb                              ; jump if null string case} bze wb pats6 
        jz   pats6                              ; 
        add  xl,cfp_f                           ; point to characters in argument} plc xl  
pats5:
        xor  w0,w0                              ; load next character} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        sal  wa,log_cfp_b                       ; convert to byte offset} wtb wa  
        mov  xr,m_word [r_ctp]                  ; point to ctblk} mov xr r_ctp 
        add  xr,wa                              ; point to ctblk entry} add xr wa 
        mov  wa,wc                              ; copy bit mask} mov wa wc 
        or   wa,m_word [(cfp_b*ctchs)+xr]       ; or in bits already set} orb wa ctchs(xr) 
        mov  m_word [(cfp_b*ctchs)+xr],wa       ; store resulting bit string} mov ctchs(xr) wa 
        dec  wb                                 ; loop till all bits set} bct wb pats5 
        jnz  pats5                              ; 
pats6:
        mov  xr,m_word [r_ctp]                  ; load ctblk ptr as parm1 for pbild} mov xr r_ctp 
        xor  xl,xl                              ; clear garbage ptr in xl} zer xl  
        pop  wb                                 ; load pcode for multi-char str case} mov wb (xs)+ 
        jmp  pats1                              ; back to exit (wc=bitstring=parm2)} brn pats1  
pats7:
        mov  wb,wc                              ; set pcode for expression argument} mov wb wc 
        cmp  m_word [xr],b_e__                  ; jump to exit if expression arg} blo (xr) =b_e__ pats1
        jb   pats1                              ; 
        mov  m_word [_rc_],1                    ; else take wrong type error exit} exi 1  
        mov  w0,m_word [prc_+cfp_b*13]          ; 
        jmp  w0                                 ; 
                                                ; end procedure patst} enp   
pbild:
                                                ; entry point} prc e 0 
        push xr                                 ; stack possible parm1} mov -(xs) xr 
        mov  xr,wb                              ; copy pcode} mov xr wb 
        movzx xr,byte [xr-1]                    ; load entry point id (bl_px)} lei xr  
        cmp  xr,bl_p1                           ; jump if one parameter} beq xr =bl_p1 pbld1
        je   pbld1                              ; 
        cmp  xr,bl_p0                           ; jump if no parameters} beq xr =bl_p0 pbld3
        je   pbld3                              ; 
        mov  wa,cfp_b*pcsi_                     ; set size of p2blk} mov wa *pcsi_ 
        call alloc                              ; allocate block} jsr alloc  
        mov  m_word [(cfp_b*parm2)+xr],wc       ; store second parameter} mov parm2(xr) wc 
        jmp  pbld2                              ; merge with one parm case} brn pbld2  
pbld1:
        mov  wa,cfp_b*pbsi_                     ; set size of p1blk} mov wa *pbsi_ 
        call alloc                              ; allocate node} jsr alloc  
pbld2:
        mov  w0,m_word [xs]                     ; store first parameter} mov parm1(xr) (xs) 
        mov  m_word [(cfp_b*parm1)+xr],w0       ; 
        jmp  pbld4                              ; merge with no parameter case} brn pbld4  
pbld3:
        mov  wa,cfp_b*pasi_                     ; set size of p0blk} mov wa *pasi_ 
        call alloc                              ; allocate node} jsr alloc  
pbld4:
        mov  m_word [xr],wb                     ; store pcode} mov (xr) wb 
        add  xs,cfp_b                           ; pop first parameter} ica xs  
        mov  m_word [(cfp_b*pthen)+xr],ndnth    ; set nothen successor pointer} mov pthen(xr) =ndnth 
        ret                                     ; return to pbild caller} exi   
                                                ; end procedure pbild} enp   
pconc:
                                                ; entry point} prc e 0 
        push 0                                  ; make room for one entry at bottom} zer -(xs)  
        mov  wc,xs                              ; store pointer to start of list} mov wc xs 
        push ndnth                              ; stack nothen node as old node} mov -(xs) =ndnth 
        push xl                                 ; store right arg as copy of nothen} mov -(xs) xl 
        mov  xl,xs                              ; initialize pointer to stack entries} mov xt xs 
        call pcopy                              ; copy first node of left arg} jsr pcopy  
        mov  m_word [(cfp_b*num02)+xl],wa       ; store as result under list} mov num02(xt) wa 
pcnc1:
        cmp  xl,xs                              ; jump if all entries processed} beq xt xs pcnc2
        je   pcnc2                              ; 
        lea  xl,[xl-cfp_b]                      ; else load next old address} mov xr -(xt) 
        mov  xr,m_word [xl]                     ; 
        mov  xr,m_word [(cfp_b*pthen)+xr]       ; load pointer to successor} mov xr pthen(xr) 
        call pcopy                              ; copy successor node} jsr pcopy  
        lea  xl,[xl-cfp_b]                      ; load pointer to new node (copy)} mov xr -(xt) 
        mov  xr,m_word [xl]                     ; 
        mov  m_word [(cfp_b*pthen)+xr],wa       ; store ptr to new successor} mov pthen(xr) wa 
        cmp  m_word [xr],p_alt                  ; loop back if not} bne (xr) =p_alt pcnc1
        jne  pcnc1                              ; 
        mov  xr,m_word [(cfp_b*parm1)+xr]       ; else load pointer to alternative} mov xr parm1(xr) 
        call pcopy                              ; copy it} jsr pcopy  
        mov  xr,m_word [xl]                     ; restore ptr to new node} mov xr (xt) 
        mov  m_word [(cfp_b*parm1)+xr],wa       ; store ptr to copied alternative} mov parm1(xr) wa 
        jmp  pcnc1                              ; loop back for next entry} brn pcnc1  
pcnc2:
        mov  xs,wc                              ; restore stack pointer} mov xs wc 
        pop  xr                                 ; load pointer to copy} mov xr (xs)+ 
        ret                                     ; return to pconc caller} exi   
                                                ; end procedure pconc} enp   
pcopy:
        pop  m_word [prc_+cfp_b*14]             ; entry point} prc n 0 
        mov  wb,xl                              ; save xl} mov wb xt 
        mov  xl,wc                              ; point to start of list} mov xt wc 
pcop1:
        sub  xl,cfp_b                           ; point to next entry on list} dca xt  
        cmp  xr,m_word [xl]                     ; jump if match} beq xr (xt) pcop2
        je   pcop2                              ; 
        sub  xl,cfp_b                           ; else skip over copied address} dca xt  
        cmp  xl,xs                              ; loop back if more to test} bne xt xs pcop1
        jne  pcop1                              ; 
        mov  wa,m_word [xr]                     ; load first word of block} mov wa (xr) 
        call blkln                              ; get length of block} jsr blkln  
        mov  xl,xr                              ; save pointer to old node} mov xl xr 
        call alloc                              ; allocate space for copy} jsr alloc  
        push xl                                 ; store old address on list} mov -(xs) xl 
        push xr                                 ; store new address on list} mov -(xs) xr 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0494                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0494:                                         ; 
        shr  wa,log_cfp_b                       ; move words from old block to copy} mvw   
        rep  movs_w                             ; 
        mov  wa,m_word [xs]                     ; load pointer to copy} mov wa (xs) 
        jmp  pcop3                              ; jump to exit} brn pcop3  
pcop2:
        lea  xl,[xl-cfp_b]                      ; load address of copy from list} mov wa -(xt) 
        mov  wa,m_word [xl]                     ; 
pcop3:
        mov  xl,wb                              ; restore xl} mov xt wb 
        mov  m_word [_rc_],0                    ; return to pcopy caller} exi   
        mov  w0,m_word [prc_+cfp_b*14]          ; 
        jmp  w0                                 ; 
                                                ; end procedure pcopy} enp   
prflr:
                                                ; } prc e 0 
        cmp  m_word [pfdmp],0                   ; no printing if no profiling done} bze pfdmp prfl4 
        jz   prfl4                              ; 
        push xr                                 ; preserve entry xr} mov -(xs) xr 
        mov  m_word [pfsvw],wb                  ; and also wb} mov pfsvw wb 
        call prtpg                              ; eject} jsr prtpg  
        mov  xr,pfms1                           ; load msg /program profile/} mov xr =pfms1 
        call prtst                              ; and print it} jsr prtst  
        call prtnl                              ; followed by newline} jsr prtnl  
        call prtnl                              ; and another} jsr prtnl  
        mov  xr,pfms2                           ; point to first hdr} mov xr =pfms2 
        call prtst                              ; print it} jsr prtst  
        call prtnl                              ; new line} jsr prtnl  
        mov  xr,pfms3                           ; second hdr} mov xr =pfms3 
        call prtst                              ; print it} jsr prtst  
        call prtnl                              ; new line} jsr prtnl  
        call prtnl                              ; and another blank line} jsr prtnl  
        xor  wb,wb                              ; initial stmt count} zer wb  
        mov  xr,m_word [pftbl]                  ; point to table origin} mov xr pftbl 
        add  xr,cfp_b*xndta                     ; bias past xnblk header (sgd07)} add xr *xndta 
prfl1:
        inc  wb                                 ; bump stmt nr} icv wb  
        mov  ia,m_word [xr]                     ; load nr of executions} ldi (xr)  
        cmp  ia,0                               ; no printing if zero} ieq prfl3  
        je   prfl3                              ; 
        mov  m_word [profs],pfpd1               ; point where to print} mov profs =pfpd1 
        call prtin                              ; and print it} jsr prtin  
        xor  w0,w0                              ; back to start of line} zer profs  
        mov  m_word [profs],w0                  ; 
        mov  ia,wb                              ; load stmt nr} mti wb  
        call prtin                              ; print it there} jsr prtin  
        mov  m_word [profs],pfpd2               ; and pad past count} mov profs =pfpd2 
        mov  ia,m_word [(cfp_b*cfp_i)+xr]       ; load total exec time} ldi cfp_i(xr)  
        call prtin                              ; print that too} jsr prtin  
        mov  ia,m_word [(cfp_b*cfp_i)+xr]       ; reload time} ldi cfp_i(xr)  
        imul ia,m_word [intth]                  ; convert to microsec} mli intth  
        jo   prfl2                              ; omit next bit if overflow} iov prfl2  
        mov  r10,m_word [xr]                    ; divide by executions} dvi (xr)  
        call do_dvi                             ; 
        mov  m_word [profs],pfpd3               ; pad last print} mov profs =pfpd3 
        call prtin                              ; and print mcsec/execn} jsr prtin  
prfl2:
        call prtnl                              ; thats another line} jsr prtnl  
prfl3:
        add  xr,cfp_b*pf_i2                     ; bump index ptr (sgd07)} add xr *pf_i2 
        cmp  wb,m_word [pfnte]                  ; loop if more stmts} blt wb pfnte prfl1
        jb   prfl1                              ; 
        pop  xr                                 ; restore callers xr} mov xr (xs)+ 
        mov  wb,m_word [pfsvw]                  ; and wb too} mov wb pfsvw 
prfl4:
        ret                                     ; return} exi   
                                                ; end of prflr} enp   
prflu:
                                                ; } prc e 0 
        cmp  m_word [pffnc],0                   ; skip if just entered function} bnz pffnc pflu4 
        jnz  pflu4                              ; 
        push xr                                 ; preserve entry xr} mov -(xs) xr 
        mov  m_word [pfsvw],wa                  ; save wa (sgd07)} mov pfsvw wa 
        cmp  m_word [pftbl],0                   ; branch if table allocated} bnz pftbl pflu2 
        jnz  pflu2                              ; 
        sub  m_word [pfnte],num01               ; adjust for extra count (sgd07)} sub pfnte =num01 
        mov  ia,m_word [pfi2a]                  ; convrt entry size to int} mti pfi2a  
        mov  m_word [pfste],ia                  ; and store safely for later} sti pfste  
        mov  ia,m_word [pfnte]                  ; load table length as integer} mti pfnte  
        imul ia,m_word [pfste]                  ; multiply by entry size} mli pfste  
        mov  wa,ia                              ; get back address-style} mfi wa  
        add  wa,num02                           ; add on 2 word overhead} add wa =num02 
        sal  wa,log_cfp_b                       ; convert the whole lot to bytes} wtb wa  
        call alost                              ; gimme the space} jsr alost  
        mov  m_word [pftbl],xr                  ; save block pointer} mov pftbl xr 
        mov  w0,b_xnt                           ; put block type and ...} mov (xr)+ =b_xnt 
        stos_w                                  ; 
        mov  w0,wa                              ; ... length into header} mov (xr)+ wa 
        stos_w                                  ; 
        mov  wa,ia                              ; get back nr of wds in data area} mfi wa  
pflu1:
        xor  w0,w0                              ; blank a word} zer (xr)+  
        stos_w                                  ; 
        dec  wa                                 ; and alllllll the rest} bct wa pflu1 
        jnz  pflu1                              ; 
pflu2:
        mov  ia,m_word [kvstn]                  ; load nr of stmt just ended} mti kvstn  
        sub  ia,m_word [intv1]                  ; make into index offset} sbi intv1  
        imul ia,m_word [pfste]                  ; make offset of table entry} mli pfste  
        mov  wa,ia                              ; convert to address} mfi wa  
        sal  wa,log_cfp_b                       ; get as baus} wtb wa  
        add  wa,cfp_b*num02                     ; offset includes table header} add wa *num02 
        mov  xr,m_word [pftbl]                  ; get table start} mov xr pftbl 
        cmp  wa,m_word [(cfp_b*num01)+xr]       ; if out of table, skip it} bge wa num01(xr) pflu3
        jae  pflu3                              ; 
        add  xr,wa                              ; else point to entry} add xr wa 
        mov  ia,m_word [xr]                     ; get nr of executions so far} ldi (xr)  
        add  ia,m_word [intv1]                  ; nudge up one} adi intv1  
        mov  m_word [xr],ia                     ; and put back} sti (xr)  
        call systm                              ; get time now} jsr systm  
        mov  m_word [pfetm],ia                  ; stash ending time} sti pfetm  
        sub  ia,m_word [pfstm]                  ; subtract start time} sbi pfstm  
        add  ia,m_word [(cfp_b*cfp_i)+xr]       ; add cumulative time so far} adi cfp_i(xr)  
        mov  m_word [(cfp_b*cfp_i)+xr],ia       ; and put back new total} sti cfp_i(xr)  
        mov  ia,m_word [pfetm]                  ; load end time of this stmt ...} ldi pfetm  
        mov  m_word [pfstm],ia                  ; ... which is start time of next} sti pfstm  
pflu3:
        pop  xr                                 ; restore callers xr} mov xr (xs)+ 
        mov  wa,m_word [pfsvw]                  ; restore saved reg} mov wa pfsvw 
        ret                                     ; and return} exi   
pflu4:
        xor  w0,w0                              ; reset the condition flag} zer pffnc  
        mov  m_word [pffnc],w0                  ; 
        ret                                     ; and immediate return} exi   
                                                ; end of procedure prflu} enp   
prpar:
                                                ; entry point} prc e 0 
        test wc,wc                              ; jump to associate terminal} bnz wc prpa8 
        jnz  prpa8                              ; 
        call syspp                              ; get print parameters} jsr syspp  
        test wb,wb                              ; jump if lines/page specified} bnz wb prpa1 
        jnz  prpa1                              ; 
        mov  wb,m_word [mxint]                  ; else use a large value} mov wb mxint 
        shr  wb,1                               ; but not too large} rsh wb 1 
prpa1:
        mov  m_word [lstnp],wb                  ; store number of lines/page} mov lstnp wb 
        mov  m_word [lstlc],wb                  ; pretend page is full initially} mov lstlc wb 
        xor  w0,w0                              ; clear page number} zer lstpg  
        mov  m_word [lstpg],w0                  ; 
        mov  wb,m_word [prlen]                  ; get prior length if any} mov wb prlen 
        test wb,wb                              ; skip if no length} bze wb prpa2 
        jz   prpa2                              ; 
        cmp  wa,wb                              ; skip storing if too big} bgt wa wb prpa3
        ja   prpa3                              ; 
prpa2:
        mov  m_word [prlen],wa                  ; store value} mov prlen wa 
prpa3:
        mov  wb,m_word [bits3]                  ; bit 3 mask} mov wb bits3 
        and  wb,wc                              ; get -nolist bit} anb wb wc 
        test wb,wb                              ; skip if clear} zrb wb prpa4 
        jz   prpa4                              ; 
        xor  w0,w0                              ; set -nolist} zer cswls  
        mov  m_word [cswls],w0                  ; 
prpa4:
        mov  wb,m_word [bits1]                  ; bit 1 mask} mov wb bits1 
        and  wb,wc                              ; get bit} anb wb wc 
        mov  m_word [erich],wb                  ; store int. chan. error flag} mov erich wb 
        mov  wb,m_word [bits2]                  ; bit 2 mask} mov wb bits2 
        and  wb,wc                              ; get bit} anb wb wc 
        mov  m_word [prich],wb                  ; flag for std printer on int. chan.} mov prich wb 
        mov  wb,m_word [bits4]                  ; bit 4 mask} mov wb bits4 
        and  wb,wc                              ; get bit} anb wb wc 
        mov  m_word [cpsts],wb                  ; flag for compile stats suppressn.} mov cpsts wb 
        mov  wb,m_word [bits5]                  ; bit 5 mask} mov wb bits5 
        and  wb,wc                              ; get bit} anb wb wc 
        mov  m_word [exsts],wb                  ; flag for exec stats suppression} mov exsts wb 
        mov  wb,m_word [bits6]                  ; bit 6 mask} mov wb bits6 
        and  wb,wc                              ; get bit} anb wb wc 
        mov  m_word [precl],wb                  ; extended/compact listing flag} mov precl wb 
        sub  wa,num08                           ; point 8 chars from line end} sub wa =num08 
        test wb,wb                              ; jump if not extended} zrb wb prpa5 
        jz   prpa5                              ; 
        mov  m_word [lstpo],wa                  ; store for listing page headings} mov lstpo wa 
prpa5:
        mov  wb,m_word [bits7]                  ; bit 7 mask} mov wb bits7 
        and  wb,wc                              ; get bit 7} anb wb wc 
        mov  m_word [cswex],wb                  ; set -noexecute if non-zero} mov cswex wb 
        mov  wb,m_word [bit10]                  ; bit 10 mask} mov wb bit10 
        and  wb,wc                              ; get bit 10} anb wb wc 
        mov  m_word [headp],wb                  ; pretend printed to omit headers} mov headp wb 
        mov  wb,m_word [bits9]                  ; bit 9 mask} mov wb bits9 
        and  wb,wc                              ; get bit 9} anb wb wc 
        mov  m_word [prsto],wb                  ; keep it as std listing option} mov prsto wb 
        mov  wb,wc                              ; copy flags} mov wb wc 
        shr  wb,12                              ; right justify bit 13} rsh wb 12 
        and  wb,m_word [bits1]                  ; get bit} anb wb bits1 
        mov  m_word [kvcas],wb                  ; set -case} mov kvcas wb 
        mov  wb,m_word [bit12]                  ; bit 12 mask} mov wb bit12 
        and  wb,wc                              ; get bit 12} anb wb wc 
        mov  m_word [cswer],wb                  ; keep it as errors/noerrors option} mov cswer wb 
        test wb,wb                              ; skip if clear} zrb wb prpa6 
        jz   prpa6                              ; 
        mov  wa,m_word [prlen]                  ; get print buffer length} mov wa prlen 
        sub  wa,num08                           ; point 8 chars from line end} sub wa =num08 
        mov  m_word [lstpo],wa                  ; store page offset} mov lstpo wa 
prpa6:
        mov  wb,m_word [bit11]                  ; bit 11 mask} mov wb bit11 
        and  wb,wc                              ; get bit 11} anb wb wc 
        mov  m_word [cswpr],wb                  ; set -print if non-zero} mov cswpr wb 
        and  wc,m_word [bits8]                  ; see if terminal to be activated} anb wc bits8 
        test wc,wc                              ; jump if terminal required} bnz wc prpa8 
        jnz  prpa8                              ; 
        cmp  m_word [initr],0                   ; jump if no terminal to detach} bze initr prpa9 
        jz   prpa9                              ; 
        mov  xl,v_ter                           ; ptr to /terminal/} mov xl =v_ter 
        call gtnvr                              ; get vrblk pointer} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_259                           ; 
        dec  m_word [_rc_]                      ; cant fail} ppm   
        jns  _l0495                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0495:                                         ; 
call_259:                                       ; 
        mov  m_word [(cfp_b*vrval)+xr],nulls    ; clear value of terminal} mov vrval(xr) =nulls 
        call setvr                              ; remove association} jsr setvr  
        jmp  prpa9                              ; return} brn prpa9  
prpa8:
        mov  m_word [initr],xs                  ; note terminal associated} mnz initr  
        cmp  m_word [dnamb],0                   ; cant if memory not organised} bze dnamb prpa9 
        jz   prpa9                              ; 
        mov  xl,v_ter                           ; point to terminal string} mov xl =v_ter 
        mov  wb,trtou                           ; output trace type} mov wb =trtou 
        call inout                              ; attach output trblk to vrblk} jsr inout  
        push xr                                 ; stack trblk ptr} mov -(xs) xr 
        mov  xl,v_ter                           ; point to terminal string} mov xl =v_ter 
        mov  wb,trtin                           ; input trace type} mov wb =trtin 
        call inout                              ; attach input trace blk} jsr inout  
        pop  m_word [(cfp_b*vrval)+xr]          ; add output trblk to chain} mov vrval(xr) (xs)+ 
prpa9:
        ret                                     ; return} exi   
                                                ; end procedure prpar} enp   
prtch:
                                                ; entry point} prc e 0 
        push xr                                 ; save xr} mov -(xs) xr 
        mov  w0,m_word [prlen]                  ; jump if room in buffer} bne profs prlen prch1
        cmp  m_word [profs],w0                  ; 
        jne  prch1                              ; 
        call prtnl                              ; else print this line} jsr prtnl  
prch1:
        mov  xr,m_word [prbuf]                  ; point to print buffer} mov xr prbuf 
        add  xr,cfp_f                           ; point to next character location} psc xr profs 
        add  xr,m_word [profs]                  ; 
        mov  m_char [xr],cl                     ; store new character} sch wa (xr) 
        inc  m_word [profs]                     ; bump pointer} icv profs  
        pop  xr                                 ; restore entry xr} mov xr (xs)+ 
        ret                                     ; return to prtch caller} exi   
                                                ; end procedure prtch} enp   
prtic:
                                                ; entry point} prc e 0 
        push xr                                 ; save xr} mov -(xs) xr 
        mov  xr,m_word [prbuf]                  ; point to buffer} mov xr prbuf 
        mov  wa,m_word [profs]                  ; no of chars} mov wa profs 
        call syspi                              ; print} jsr syspi  
        dec  m_word [_rc_]                      ; 
        js   call_260                           ; 
        dec  m_word [_rc_]                      ; fail return} ppm prtc2  
        jns  _l0496                             ; 
        jmp  prtc2                              ; 
_l0496:                                         ; 
call_260:                                       ; 
prtc1:
        pop  xr                                 ; restore xr} mov xr (xs)+ 
        ret                                     ; return} exi   
prtc2:
        xor  w0,w0                              ; prevent looping} zer erich  
        mov  m_word [erich],w0                  ; 
        mov  m_word [_rc_],252                  ; } erb 252 error on printing to interactive channel 
        jmp  err_                               ; 
        jmp  prtc1                              ; return} brn prtc1  
                                                ; procedure prtic} enp   
prtis:
                                                ; entry point} prc e 0 
        cmp  m_word [prich],0                   ; jump if standard printer is int.ch.} bnz prich prts1 
        jnz  prts1                              ; 
        cmp  m_word [erich],0                   ; skip if not doing int. error reps.} bze erich prts1 
        jz   prts1                              ; 
        call prtic                              ; print to interactive channel} jsr prtic  
prts1:
        call prtnl                              ; print to standard printer} jsr prtnl  
        ret                                     ; return} exi   
                                                ; end procedure prtis} enp   
prtin:
                                                ; entry point} prc e 0 
        push xr                                 ; save xr} mov -(xs) xr 
        call icbld                              ; build integer block} jsr icbld  
        cmp  xr,m_word [dnamb]                  ; jump if icblk below dynamic} blo xr dnamb prti1
        jb   prti1                              ; 
        cmp  xr,m_word [dnamp]                  ; jump if above dynamic} bhi xr dnamp prti1
        ja   prti1                              ; 
        mov  m_word [dnamp],xr                  ; immediately delete it} mov dnamp xr 
prti1:
        push xr                                 ; stack ptr for gtstg} mov -(xs) xr 
        call gtstg                              ; convert to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_261                           ; 
        dec  m_word [_rc_]                      ; convert error is impossible} ppm   
        jns  _l0497                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0497:                                         ; 
call_261:                                       ; 
        mov  m_word [dnamp],xr                  ; reset pointer to delete scblk} mov dnamp xr 
        call prtst                              ; print integer string} jsr prtst  
        pop  xr                                 ; restore entry xr} mov xr (xs)+ 
        ret                                     ; return to prtin caller} exi   
                                                ; end procedure prtin} enp   
prtmi:
                                                ; entry point} prc e 0 
        call prtst                              ; print string message} jsr prtst  
        mov  m_word [profs],prtmf               ; set column offset} mov profs =prtmf 
        call prtin                              ; print integer} jsr prtin  
        call prtnl                              ; print line} jsr prtnl  
        ret                                     ; return to prtmi caller} exi   
                                                ; end procedure prtmi} enp   
prtmm:
                                                ; } prc e 0 
        mov  wa,m_word [dnamp]                  ; next available loc} mov wa dnamp 
        sub  wa,m_word [statb]                  ; minus start} sub wa statb 
        mov  ia,wa                              ; convert to integer} mti wa  
        mov  xr,encm1                           ; point to /memory used (words)/} mov xr =encm1 
        call prtmi                              ; print message} jsr prtmi  
        mov  wa,m_word [dname]                  ; end of memory} mov wa dname 
        sub  wa,m_word [dnamp]                  ; minus next available loc} sub wa dnamp 
        mov  ia,wa                              ; convert to integer} mti wa  
        mov  xr,encm2                           ; point to /memory available (words)/} mov xr =encm2 
        call prtmi                              ; print line} jsr prtmi  
        ret                                     ; return to prtmm caller} exi   
                                                ; end of procedure prtmm} enp   
prtmx:
                                                ; entry point} prc e 0 
        call prtst                              ; print string message} jsr prtst  
        mov  m_word [profs],prtmf               ; set column offset} mov profs =prtmf 
        call prtin                              ; print integer} jsr prtin  
        call prtis                              ; print line} jsr prtis  
        ret                                     ; return} exi   
                                                ; end procedure prtmx} enp   
prtnl:
                                                ; entry point} prc r 0 
        cmp  m_word [headp],0                   ; were headers printed} bnz headp prnl0 
        jnz  prnl0                              ; 
        call prtps                              ; no - print them} jsr prtps  
prnl0:
        push xr                                 ; save entry xr} mov -(xs) xr 
        mov  m_word [prtsa],wa                  ; save wa} mov prtsa wa 
        mov  m_word [prtsb],wb                  ; save wb} mov prtsb wb 
        mov  xr,m_word [prbuf]                  ; load pointer to buffer} mov xr prbuf 
        mov  wa,m_word [profs]                  ; load number of chars in buffer} mov wa profs 
        call syspr                              ; call system print routine} jsr syspr  
        dec  m_word [_rc_]                      ; 
        js   call_262                           ; 
        dec  m_word [_rc_]                      ; jump if failed} ppm prnl2  
        jns  _l0498                             ; 
        jmp  prnl2                              ; 
_l0498:                                         ; 
call_262:                                       ; 
        mov  wa,m_word [prlnw]                  ; load length of buffer in words} lct wa prlnw 
        add  xr,cfp_b*schar                     ; point to chars of buffer} add xr *schar 
        mov  wb,m_word [nullw]                  ; get word of blanks} mov wb nullw 
prnl1:
        mov  w0,wb                              ; store word of blanks, bump ptr} mov (xr)+ wb 
        stos_w                                  ; 
        dec  wa                                 ; loop till all blanked} bct wa prnl1 
        jnz  prnl1                              ; 
        mov  wb,m_word [prtsb]                  ; restore wb} mov wb prtsb 
        mov  wa,m_word [prtsa]                  ; restore wa} mov wa prtsa 
        pop  xr                                 ; restore entry xr} mov xr (xs)+ 
        xor  w0,w0                              ; reset print buffer pointer} zer profs  
        mov  m_word [profs],w0                  ; 
        ret                                     ; return to prtnl caller} exi   
prnl2:
        cmp  m_word [prtef],0                   ; jump if not first time} bnz prtef prnl3 
        jnz  prnl3                              ; 
        mov  m_word [prtef],xs                  ; mark first occurrence} mnz prtef  
        mov  m_word [_rc_],253                  ; } erb 253 print limit exceeded on standard output channel 
        jmp  err_                               ; 
prnl3:
        mov  wb,nini8                           ; ending code} mov wb =nini8 
        mov  wa,m_word [kvstn]                  ; statement number} mov wa kvstn 
        mov  xl,m_word [r_fcb]                  ; get fcblk chain head} mov xl r_fcb 
        call sysej                              ; stop} jsr sysej  
                                                ; end procedure prtnl} enp   
prtnm:
                                                ; entry point (recursive, see prtvl)} prc r 0 
        push wa                                 ; save wa (offset is collectable)} mov -(xs) wa 
        push xr                                 ; save entry xr} mov -(xs) xr 
        push xl                                 ; save name base} mov -(xs) xl 
        cmp  xl,m_word [state]                  ; jump if not natural variable} bhi xl state prn02
        ja   prn02                              ; 
        mov  xr,xl                              ; point to vrblk} mov xr xl 
        call prtvn                              ; print name of variable} jsr prtvn  
prn01:
        pop  xl                                 ; restore name base} mov xl (xs)+ 
        pop  xr                                 ; restore entry value of xr} mov xr (xs)+ 
        pop  wa                                 ; restore wa} mov wa (xs)+ 
        ret                                     ; return to prtnm caller} exi   
prn02:
        mov  wb,wa                              ; copy name offset} mov wb wa 
        cmp  m_word [xl],b_pdt                  ; jump if array or table} bne (xl) =b_pdt prn03
        jne  prn03                              ; 
        mov  xr,m_word [(cfp_b*pddfp)+xl]       ; load pointer to dfblk} mov xr pddfp(xl) 
        add  xr,wa                              ; add name offset} add xr wa 
        mov  xr,m_word [(cfp_b*pdfof)+xr]       ; load vrblk pointer for field} mov xr pdfof(xr) 
        call prtvn                              ; print field name} jsr prtvn  
        mov  wa,ch_pp                           ; load left paren} mov wa =ch_pp 
        call prtch                              ; print character} jsr prtch  
prn03:
        cmp  m_word [xl],b_tet                  ; jump if we got there (or not te)} bne (xl) =b_tet prn04
        jne  prn04                              ; 
        mov  xl,m_word [(cfp_b*tenxt)+xl]       ; else move out on chain} mov xl tenxt(xl) 
        jmp  prn03                              ; and loop back} brn prn03  
prn04:
        mov  xr,m_word [prnmv]                  ; point to vrblk we found last time} mov xr prnmv 
        mov  wa,m_word [hshtb]                  ; point to hash table in case not} mov wa hshtb 
        jmp  prn07                              ; jump into search for special check} brn prn07  
prn05:
        mov  xr,wa                              ; copy slot pointer} mov xr wa 
        add  wa,cfp_b                           ; bump slot pointer} ica wa  
        sub  xr,cfp_b*vrnxt                     ; introduce standard vrblk offset} sub xr *vrnxt 
prn06:
        mov  xr,m_word [(cfp_b*vrnxt)+xr]       ; point to next vrblk on hash chain} mov xr vrnxt(xr) 
prn07:
        mov  wc,xr                              ; copy vrblk pointer} mov wc xr 
        test wc,wc                              ; jump if chain end (or prnmv zero)} bze wc prn09 
        jz   prn09                              ; 
prn08:
        mov  xr,m_word [(cfp_b*vrval)+xr]       ; load value} mov xr vrval(xr) 
        cmp  m_word [xr],b_trt                  ; loop if that was a trblk} beq (xr) =b_trt prn08
        je   prn08                              ; 
        cmp  xr,xl                              ; jump if this matches the name base} beq xr xl prn10
        je   prn10                              ; 
        mov  xr,wc                              ; else point back to that vrblk} mov xr wc 
        jmp  prn06                              ; and loop back} brn prn06  
prn09:
        cmp  wa,m_word [hshte]                  ; loop back if more to go} blt wa hshte prn05
        jb   prn05                              ; 
        mov  xr,xl                              ; else not found, copy value pointer} mov xr xl 
        call prtvl                              ; print value} jsr prtvl  
        jmp  prn11                              ; and merge ahead} brn prn11  
prn10:
        mov  xr,wc                              ; copy vrblk pointer} mov xr wc 
        mov  m_word [prnmv],xr                  ; save for next time in} mov prnmv xr 
        call prtvn                              ; print variable name} jsr prtvn  
prn11:
        mov  wc,m_word [xl]                     ; load first word of name base} mov wc (xl) 
        cmp  wc,b_pdt                           ; jump if not program defined} bne wc =b_pdt prn13
        jne  prn13                              ; 
        mov  wa,ch_rp                           ; load right paren, merge} mov wa =ch_rp 
prn12:
        call prtch                              ; print final character} jsr prtch  
        mov  wa,wb                              ; restore name offset} mov wa wb 
        jmp  prn01                              ; merge back to exit} brn prn01  
prn13:
        mov  wa,ch_bb                           ; load left bracket} mov wa =ch_bb 
        call prtch                              ; and print it} jsr prtch  
        mov  xl,m_word [xs]                     ; restore block pointer} mov xl (xs) 
        mov  wc,m_word [xl]                     ; load type word again} mov wc (xl) 
        cmp  wc,b_tet                           ; jump if not table} bne wc =b_tet prn15
        jne  prn15                              ; 
        mov  xr,m_word [(cfp_b*tesub)+xl]       ; load subscript value} mov xr tesub(xl) 
        mov  xl,wb                              ; save name offset} mov xl wb 
        call prtvl                              ; print subscript value} jsr prtvl  
        mov  wb,xl                              ; restore name offset} mov wb xl 
prn14:
        mov  wa,ch_rb                           ; load right bracket} mov wa =ch_rb 
        jmp  prn12                              ; merge back to print it} brn prn12  
prn15:
        mov  wa,wb                              ; copy name offset} mov wa wb 
        shr  wa,log_cfp_b                       ; convert to words} btw wa  
        cmp  wc,b_art                           ; jump if arblk} beq wc =b_art prn16
        je   prn16                              ; 
        sub  wa,vcvlb                           ; adjust for standard fields} sub wa =vcvlb 
        mov  ia,wa                              ; move to integer accum} mti wa  
        call prtin                              ; print linear subscript} jsr prtin  
        jmp  prn14                              ; merge back for right bracket} brn prn14  
prn16:
        mov  wc,m_word [(cfp_b*arofs)+xl]       ; load length of bounds info} mov wc arofs(xl) 
        add  wc,cfp_b                           ; adjust for arpro field} ica wc  
        shr  wc,log_cfp_b                       ; convert to words} btw wc  
        sub  wa,wc                              ; get linear zero-origin subscript} sub wa wc 
        mov  ia,wa                              ; get integer value} mti wa  
        mov  wa,m_word [(cfp_b*arndm)+xl]       ; set num of dimensions as loop count} lct wa arndm(xl) 
        add  xl,m_word [(cfp_b*arofs)+xl]       ; point past bounds information} add xl arofs(xl) 
        sub  xl,cfp_b*arlbd                     ; set ok offset for proper ptr later} sub xl *arlbd 
prn17:
        sub  xl,cfp_b*ardms                     ; point to next set of bounds} sub xl *ardms 
        mov  m_word [prnsi],ia                  ; save current offset} sti prnsi  
        mov  r10,m_word [(cfp_b*ardim)+xl]      ; get remainder on dividing by dimens} rmi ardim(xl)  
        call do_rmi                             ; 
        push ia                                 ; store on stack (one word)} mfi -(xs)  
        mov  ia,m_word [prnsi]                  ; reload argument} ldi prnsi  
        mov  r10,m_word [(cfp_b*ardim)+xl]      ; divide to get quotient} dvi ardim(xl)  
        call do_dvi                             ; 
        dec  wa                                 ; loop till all stacked} bct wa prn17 
        jnz  prn17                              ; 
        xor  xr,xr                              ; set offset to first set of bounds} zer xr  
        mov  wb,m_word [(cfp_b*arndm)+xl]       ; load count of dims to control loop} lct wb arndm(xl) 
        jmp  prn19                              ; jump into print loop} brn prn19  
prn18:
        mov  wa,ch_cm                           ; load a comma} mov wa =ch_cm 
        call prtch                              ; print it} jsr prtch  
prn19:
        pop  ia                                 ; load subscript offset as integer} mti (xs)+  
        add  xl,xr                              ; point to current lbd} add xl xr 
        add  ia,m_word [(cfp_b*arlbd)+xl]       ; add lbd to get signed subscript} adi arlbd(xl)  
        sub  xl,xr                              ; point back to start of arblk} sub xl xr 
        call prtin                              ; print subscript} jsr prtin  
        add  xr,cfp_b*ardms                     ; bump offset to next bounds} add xr *ardms 
        dec  wb                                 ; loop back till all printed} bct wb prn18 
        jnz  prn18                              ; 
        jmp  prn14                              ; merge back to print right bracket} brn prn14  
                                                ; end procedure prtnm} enp   
prtnv:
                                                ; entry point} prc e 0 
        call prtnm                              ; print argument name} jsr prtnm  
        push xr                                 ; save entry xr} mov -(xs) xr 
        push wa                                 ; save name offset (collectable)} mov -(xs) wa 
        mov  xr,tmbeb                           ; point to blank equal blank} mov xr =tmbeb 
        call prtst                              ; print it} jsr prtst  
        mov  xr,xl                              ; copy name base} mov xr xl 
        add  xr,wa                              ; point to value} add xr wa 
        mov  xr,m_word [xr]                     ; load value pointer} mov xr (xr) 
        call prtvl                              ; print value} jsr prtvl  
        call prtnl                              ; terminate line} jsr prtnl  
        pop  wa                                 ; restore name offset} mov wa (xs)+ 
        pop  xr                                 ; restore entry xr} mov xr (xs)+ 
        ret                                     ; return to caller} exi   
                                                ; end procedure prtnv} enp   
prtpg:
                                                ; entry point} prc e 0 
        cmp  m_word [stage],stgxt               ; jump if execution time} beq stage =stgxt prp01
        je   prp01                              ; 
        cmp  m_word [lstlc],0                   ; return if top of page already} bze lstlc prp06 
        jz   prp06                              ; 
        xor  w0,w0                              ; clear line count} zer lstlc  
        mov  m_word [lstlc],w0                  ; 
prp01:
        push xr                                 ; preserve xr} mov -(xs) xr 
        cmp  m_word [prstd],0                   ; eject if flag set} bnz prstd prp02 
        jnz  prp02                              ; 
        cmp  m_word [prich],0                   ; jump if interactive listing channel} bnz prich prp03 
        jnz  prp03                              ; 
        cmp  m_word [precl],0                   ; jump if compact listing} bze precl prp03 
        jz   prp03                              ; 
prp02:
        call sysep                              ; eject} jsr sysep  
        jmp  prp04                              ; merge} brn prp04  
prp03:
        mov  xr,m_word [headp]                  ; remember headp} mov xr headp 
        mov  m_word [headp],xs                  ; set to avoid repeated prtpg calls} mnz headp  
        call prtnl                              ; print blank line} jsr prtnl  
        call prtnl                              ; print blank line} jsr prtnl  
        call prtnl                              ; print blank line} jsr prtnl  
        mov  m_word [lstlc],num03               ; count blank lines} mov lstlc =num03 
        mov  m_word [headp],xr                  ; restore header flag} mov headp xr 
prp04:
        cmp  m_word [headp],0                   ; jump if header listed} bnz headp prp05 
        jnz  prp05                              ; 
        mov  m_word [headp],xs                  ; mark headers printed} mnz headp  
        push xl                                 ; keep xl} mov -(xs) xl 
        mov  xr,headr                           ; point to listing header} mov xr =headr 
        call prtst                              ; place it} jsr prtst  
        call sysid                              ; get system identification} jsr sysid  
        call prtst                              ; append extra chars} jsr prtst  
        call prtnl                              ; print it} jsr prtnl  
        mov  xr,xl                              ; extra header line} mov xr xl 
        call prtst                              ; place it} jsr prtst  
        call prtnl                              ; print it} jsr prtnl  
        call prtnl                              ; print a blank} jsr prtnl  
        call prtnl                              ; and another} jsr prtnl  
        add  m_word [lstlc],num04               ; four header lines printed} add lstlc =num04 
        pop  xl                                 ; restore xl} mov xl (xs)+ 
prp05:
        pop  xr                                 ; restore xr} mov xr (xs)+ 
prp06:
        ret                                     ; return} exi   
                                                ; end procedure prtpg} enp   
prtps:
                                                ; entry point} prc e 0 
        mov  w0,m_word [prsto]                  ; copy option flag} mov prstd prsto 
        mov  m_word [prstd],w0                  ; 
        call prtpg                              ; print page} jsr prtpg  
        xor  w0,w0                              ; clear flag} zer prstd  
        mov  m_word [prstd],w0                  ; 
        ret                                     ; return} exi   
                                                ; end procedure prtps} enp   
prtsn:
                                                ; entry point} prc e 0 
        push xr                                 ; save entry xr} mov -(xs) xr 
        mov  m_word [prsna],wa                  ; save entry wa} mov prsna wa 
        mov  xr,tmasb                           ; point to asterisks} mov xr =tmasb 
        call prtst                              ; print asterisks} jsr prtst  
        mov  m_word [profs],num04               ; point into middle of asterisks} mov profs =num04 
        mov  ia,m_word [kvstn]                  ; load statement number as integer} mti kvstn  
        call prtin                              ; print integer statement number} jsr prtin  
        mov  m_word [profs],prsnf               ; point past asterisks plus blank} mov profs =prsnf 
        mov  xr,m_word [kvfnc]                  ; get fnclevel} mov xr kvfnc 
        mov  wa,ch_li                           ; set letter i} mov wa =ch_li 
prsn1:
        test xr,xr                              ; jump if all set} bze xr prsn2 
        jz   prsn2                              ; 
        call prtch                              ; else print an i} jsr prtch  
        dec  xr                                 ; decrement counter} dcv xr  
        jmp  prsn1                              ; loop back} brn prsn1  
prsn2:
        mov  wa,ch_bl                           ; get blank} mov wa =ch_bl 
        call prtch                              ; print blank} jsr prtch  
        mov  wa,m_word [prsna]                  ; restore entry wa} mov wa prsna 
        pop  xr                                 ; restore entry xr} mov xr (xs)+ 
        ret                                     ; return to prtsn caller} exi   
                                                ; end procedure prtsn} enp   
prtst:
                                                ; entry point} prc r 0 
        cmp  m_word [headp],0                   ; were headers printed} bnz headp prst0 
        jnz  prst0                              ; 
        call prtps                              ; no - print them} jsr prtps  
prst0:
        mov  m_word [prsva],wa                  ; save wa} mov prsva wa 
        mov  m_word [prsvb],wb                  ; save wb} mov prsvb wb 
        xor  wb,wb                              ; set chars printed count to zero} zer wb  
prst1:
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; load string length} mov wa sclen(xr) 
        sub  wa,wb                              ; subtract count of chars already out} sub wa wb 
        test wa,wa                              ; jump to exit if none left} bze wa prst4 
        jz   prst4                              ; 
        push xl                                 ; else stack entry xl} mov -(xs) xl 
        push xr                                 ; save argument} mov -(xs) xr 
        mov  xl,xr                              ; copy for eventual move} mov xl xr 
        mov  xr,m_word [prlen]                  ; load print buffer length} mov xr prlen 
        sub  xr,m_word [profs]                  ; get chars left in print buffer} sub xr profs 
        test xr,xr                              ; skip if room left on this line} bnz xr prst2 
        jnz  prst2                              ; 
        call prtnl                              ; else print this line} jsr prtnl  
        mov  xr,m_word [prlen]                  ; and set full width available} mov xr prlen 
prst2:
        cmp  wa,xr                              ; jump if room for rest of string} blo wa xr prst3
        jb   prst3                              ; 
        mov  wa,xr                              ; else set to fill line} mov wa xr 
prst3:
        mov  xr,m_word [prbuf]                  ; point to print buffer} mov xr prbuf 
        lea  xl,[cfp_f+xl+wb]                   ; point to location in string} plc xl wb 
        add  xr,cfp_f                           ; point to location in buffer} psc xr profs 
        add  xr,m_word [profs]                  ; 
        add  wb,wa                              ; bump string chars count} add wb wa 
        add  m_word [profs],wa                  ; bump buffer pointer} add profs wa 
        mov  m_word [prsvc],wb                  ; preserve char counter} mov prsvc wb 
        rep                                     ; move characters to buffer} mvc   
        movs_b                                  ; 
        mov  wb,m_word [prsvc]                  ; recover char counter} mov wb prsvc 
        pop  xr                                 ; restore argument pointer} mov xr (xs)+ 
        pop  xl                                 ; restore entry xl} mov xl (xs)+ 
        jmp  prst1                              ; loop back to test for more} brn prst1  
prst4:
        mov  wb,m_word [prsvb]                  ; restore entry wb} mov wb prsvb 
        mov  wa,m_word [prsva]                  ; restore entry wa} mov wa prsva 
        ret                                     ; return to prtst caller} exi   
                                                ; end procedure prtst} enp   
prttr:
                                                ; entry point} prc e 0 
        push xr                                 ; save xr} mov -(xs) xr 
        call prtic                              ; print buffer contents} jsr prtic  
        mov  xr,m_word [prbuf]                  ; point to print bfr to clear it} mov xr prbuf 
        mov  wa,m_word [prlnw]                  ; get buffer length} lct wa prlnw 
        add  xr,cfp_b*schar                     ; point past scblk header} add xr *schar 
        mov  wb,m_word [nullw]                  ; get blanks} mov wb nullw 
prtt1:
        mov  w0,wb                              ; clear a word} mov (xr)+ wb 
        stos_w                                  ; 
        dec  wa                                 ; loop} bct wa prtt1 
        jnz  prtt1                              ; 
        xor  w0,w0                              ; reset profs} zer profs  
        mov  m_word [profs],w0                  ; 
        pop  xr                                 ; restore xr} mov xr (xs)+ 
        ret                                     ; return} exi   
                                                ; end procedure prttr} enp   
prtvl:
                                                ; entry point, recursive} prc r 0 
        push xl                                 ; save entry xl} mov -(xs) xl 
        push xr                                 ; save argument} mov -(xs) xr 
        cmp  xs,m_word [lowspminx]              ; check for stack overflow} chk   
        jae  _l0500                             ; 
        mov  m_word [lowspminx],xs              ; 
        cmp  xs,m_word [lowspmin]               ; 
        jb   sec06                              ; 
_l0500:                                         ; 
prv01:
        mov  w0,m_word [(cfp_b*idval)+xr]       ; copy idval (if any)} mov prvsi idval(xr) 
        mov  m_word [prvsi],w0                  ; 
        mov  xl,m_word [xr]                     ; load first word of block} mov xl (xr) 
        movzx xl,byte [xl-1]                    ; load entry point id} lei xl  
        cmp  xl,bl__t                           ; switch on block type} bsw xl bl__t prv02
        jge  prv02                              ; 
        jmp  m_word [_l0501+xl*cfp_b]           ; 
        segment .data                           ; 
_l0501:                                         ; 
        d_word prv05                            ; arblk} iff bl_ar prv05 
        d_word prv02                            ; } iff 1 prv02 
        d_word prv02                            ; } iff 2 prv02 
        d_word prv08                            ; icblk} iff bl_ic prv08 
        d_word prv09                            ; nmblk} iff bl_nm prv09 
        d_word prv02                            ; } iff 5 prv02 
        d_word prv02                            ; } iff 6 prv02 
        d_word prv02                            ; } iff 7 prv02 
        d_word prv08                            ; rcblk} iff bl_rc prv08 
        d_word prv11                            ; scblk} iff bl_sc prv11 
        d_word prv12                            ; seblk} iff bl_se prv12 
        d_word prv13                            ; tbblk} iff bl_tb prv13 
        d_word prv13                            ; vcblk} iff bl_vc prv13 
        d_word prv02                            ; } iff 13 prv02 
        d_word prv02                            ; } iff 14 prv02 
        d_word prv02                            ; } iff 15 prv02 
        d_word prv10                            ; pdblk} iff bl_pd prv10 
        d_word prv04                            ; trblk} iff bl_tr prv04 
        segment .text                           ; end of switch on block type} esw   
prv02:
        call dtype                              ; get datatype name} jsr dtype  
        call prtst                              ; print datatype name} jsr prtst  
prv03:
        pop  xr                                 ; reload argument} mov xr (xs)+ 
        pop  xl                                 ; restore xl} mov xl (xs)+ 
        ret                                     ; return to prtvl caller} exi   
prv04:
        mov  xr,m_word [(cfp_b*trval)+xr]       ; load real value} mov xr trval(xr) 
        jmp  prv01                              ; and loop back} brn prv01  
prv05:
        mov  xl,xr                              ; preserve argument} mov xl xr 
        mov  xr,scarr                           ; point to datatype name (array)} mov xr =scarr 
        call prtst                              ; print it} jsr prtst  
        mov  wa,ch_pp                           ; load left paren} mov wa =ch_pp 
        call prtch                              ; print left paren} jsr prtch  
        add  xl,m_word [(cfp_b*arofs)+xl]       ; point to prototype} add xl arofs(xl) 
        mov  xr,m_word [xl]                     ; load prototype} mov xr (xl) 
        call prtst                              ; print prototype} jsr prtst  
prv06:
        mov  wa,ch_rp                           ; load right paren} mov wa =ch_rp 
        call prtch                              ; print right paren} jsr prtch  
prv07:
        mov  wa,ch_bl                           ; load blank} mov wa =ch_bl 
        call prtch                              ; print it} jsr prtch  
        mov  wa,ch_nm                           ; load number sign} mov wa =ch_nm 
        call prtch                              ; print it} jsr prtch  
        mov  ia,m_word [prvsi]                  ; get idval} mti prvsi  
        call prtin                              ; print id number} jsr prtin  
        jmp  prv03                              ; back to exit} brn prv03  
prv08:
        push xr                                 ; stack argument for gtstg} mov -(xs) xr 
        call gtstg                              ; convert to string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_263                           ; 
        dec  m_word [_rc_]                      ; error return is impossible} ppm   
        jns  _l0502                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0502:                                         ; 
call_263:                                       ; 
        call prtst                              ; print the string} jsr prtst  
        mov  m_word [dnamp],xr                  ; delete garbage string from storage} mov dnamp xr 
        jmp  prv03                              ; back to exit} brn prv03  
prv09:
        mov  xl,m_word [(cfp_b*nmbas)+xr]       ; load name base} mov xl nmbas(xr) 
        mov  wa,m_word [xl]                     ; load first word of block} mov wa (xl) 
        cmp  wa,b_kvt                           ; just print name if keyword} beq wa =b_kvt prv02
        je   prv02                              ; 
        cmp  wa,b_evt                           ; just print name if expression var} beq wa =b_evt prv02
        je   prv02                              ; 
        mov  wa,ch_dt                           ; else get dot} mov wa =ch_dt 
        call prtch                              ; and print it} jsr prtch  
        mov  wa,m_word [(cfp_b*nmofs)+xr]       ; load name offset} mov wa nmofs(xr) 
        call prtnm                              ; print name} jsr prtnm  
        jmp  prv03                              ; back to exit} brn prv03  
prv10:
        call dtype                              ; get datatype name} jsr dtype  
        call prtst                              ; print datatype name} jsr prtst  
        jmp  prv07                              ; merge back to print id} brn prv07  
prv11:
        mov  wa,ch_sq                           ; load single quote} mov wa =ch_sq 
        call prtch                              ; print quote} jsr prtch  
        call prtst                              ; print string value} jsr prtst  
        call prtch                              ; print another quote} jsr prtch  
        jmp  prv03                              ; back to exit} brn prv03  
prv12:
        mov  wa,ch_as                           ; load asterisk} mov wa =ch_as 
        call prtch                              ; print asterisk} jsr prtch  
        mov  xr,m_word [(cfp_b*sevar)+xr]       ; load variable pointer} mov xr sevar(xr) 
        call prtvn                              ; print variable name} jsr prtvn  
        jmp  prv03                              ; jump back to exit} brn prv03  
prv13:
        mov  xl,xr                              ; preserve argument} mov xl xr 
        call dtype                              ; get datatype name} jsr dtype  
        call prtst                              ; print datatype name} jsr prtst  
        mov  wa,ch_pp                           ; load left paren} mov wa =ch_pp 
        call prtch                              ; print left paren} jsr prtch  
        mov  wa,m_word [(cfp_b*tblen)+xl]       ; load length of block (=vclen)} mov wa tblen(xl) 
        shr  wa,log_cfp_b                       ; convert to word count} btw wa  
        sub  wa,tbsi_                           ; allow for standard fields} sub wa =tbsi_ 
        cmp  m_word [xl],b_tbt                  ; jump if table} beq (xl) =b_tbt prv14
        je   prv14                              ; 
        add  wa,vctbd                           ; for vcblk, adjust size} add wa =vctbd 
prv14:
        mov  ia,wa                              ; move as integer} mti wa  
        call prtin                              ; print integer prototype} jsr prtin  
        jmp  prv06                              ; merge back for rest} brn prv06  
                                                ; end procedure prtvl} enp   
prtvn:
                                                ; entry point} prc e 0 
        push xr                                 ; stack vrblk pointer} mov -(xs) xr 
        add  xr,cfp_b*vrsof                     ; point to possible string name} add xr *vrsof 
        cmp  m_word [(cfp_b*sclen)+xr],0        ; jump if not system variable} bnz sclen(xr) prvn1 
        jnz  prvn1                              ; 
        mov  xr,m_word [(cfp_b*vrsvo)+xr]       ; point to svblk with name} mov xr vrsvo(xr) 
prvn1:
        call prtst                              ; print string name of variable} jsr prtst  
        pop  xr                                 ; restore vrblk pointer} mov xr (xs)+ 
        ret                                     ; return to prtvn caller} exi   
                                                ; end procedure prtvn} enp   
rcbld:
                                                ; entry point} prc e 0 
        mov  xr,m_word [dnamp]                  ; load pointer to next available loc} mov xr dnamp 
        add  xr,cfp_b*rcsi_                     ; point past new rcblk} add xr *rcsi_ 
        cmp  xr,m_word [dname]                  ; jump if there is room} blo xr dname rcbl1
        jb   rcbl1                              ; 
        mov  wa,cfp_b*rcsi_                     ; else load rcblk length} mov wa *rcsi_ 
        call alloc                              ; use standard allocator to get block} jsr alloc  
        add  xr,wa                              ; point past block to merge} add xr wa 
rcbl1:
        mov  m_word [dnamp],xr                  ; set new pointer} mov dnamp xr 
        sub  xr,cfp_b*rcsi_                     ; point back to start of block} sub xr *rcsi_ 
        mov  m_word [xr],b_rcl                  ; store type word} mov (xr) =b_rcl 
        movsd [(cfp_b*rcval)+xr],ra             ; store real value in rcblk} str rcval(xr)  
        ret                                     ; return to rcbld caller} exi   
                                                ; end procedure rcbld} enp   
readr:
                                                ; entry point} prc e 0 
        mov  xr,m_word [r_cni]                  ; get ptr to next image} mov xr r_cni 
        test xr,xr                              ; exit if already read} bnz xr read3 
        jnz  read3                              ; 
        cmp  m_word [cnind],0                   ; if within include file} bnz cnind reada 
        jnz  reada                              ; 
        cmp  m_word [stage],stgic               ; exit if not initial compile} bne stage =stgic read3
        jne  read3                              ; 
reada:
        mov  wa,m_word [cswin]                  ; max read length} mov wa cswin 
        xor  xl,xl                              ; clear any dud value in xl} zer xl  
        call alocs                              ; allocate buffer} jsr alocs  
        call sysrd                              ; read input image} jsr sysrd  
        dec  m_word [_rc_]                      ; 
        js   call_264                           ; 
        dec  m_word [_rc_]                      ; jump if eof or new file name} ppm read4  
        jns  _l0503                             ; 
        jmp  read4                              ; 
_l0503:                                         ; 
call_264:                                       ; 
        inc  m_word [rdnln]                     ; increment next line number} icv rdnln  
        dec  m_word [polct]                     ; test if time to poll interface} dcv polct  
        cmp  m_word [polct],0                   ; not yet} bnz polct read0 
        jnz  read0                              ; 
        xor  wa,wa                              ; =0 for poll} zer wa  
        mov  wb,m_word [rdnln]                  ; line number} mov wb rdnln 
        call syspl                              ; allow interactive access} jsr syspl  
        dec  m_word [_rc_]                      ; 
        js   call_265                           ; 
        dec  m_word [_rc_]                      ; } err 320 user interrupt 
        jns  _l0504                             ; 
        mov  m_word [_rc_],320                  ; 
        jmp  err_                               ; 
_l0504:                                         ; 
        dec  m_word [_rc_]                      ; single step} ppm   
        jns  _l0505                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0505:                                         ; 
        dec  m_word [_rc_]                      ; expression evaluation} ppm   
        jns  _l0506                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0506:                                         ; 
call_265:                                       ; 
        mov  m_word [polcs],wa                  ; new countdown start value} mov polcs wa 
        mov  m_word [polct],wa                  ; new counter value} mov polct wa 
read0:
        mov  w0,m_word [cswin]                  ; use smaller of string lnth ...} ble sclen(xr) cswin read1
        cmp  m_word [(cfp_b*sclen)+xr],w0       ; 
        jbe  read1                              ; 
        mov  w0,m_word [cswin]                  ; ... and xxx of -inxxx} mov sclen(xr) cswin 
        mov  m_word [(cfp_b*sclen)+xr],w0       ; 
read1:
        mov  wb,xs                              ; set trimr to perform trim} mnz wb  
        call trimr                              ; trim trailing blanks} jsr trimr  
read2:
        mov  m_word [r_cni],xr                  ; store copy of pointer} mov r_cni xr 
read3:
        ret                                     ; return to readr caller} exi   
read4:
        cmp  m_word [(cfp_b*sclen)+xr],0        ; jump if true end of file} bze sclen(xr) read5 
        jz   read5                              ; 
        xor  wb,wb                              ; new source file name} zer wb  
        mov  m_word [rdnln],wb                  ; restart line counter for new file} mov rdnln wb 
        call trimr                              ; remove unused space in block} jsr trimr  
        call newfn                              ; record new file name} jsr newfn  
        jmp  reada                              ; now reissue read for record data} brn reada  
read5:
        mov  m_word [dnamp],xr                  ; pop unused scblk} mov dnamp xr 
        cmp  m_word [cnind],0                   ; jump if not within an include file} bze cnind read6 
        jz   read6                              ; 
        xor  xl,xl                              ; eof within include file} zer xl  
        call sysif                              ; switch stream back to previous file} jsr sysif  
        dec  m_word [_rc_]                      ; 
        js   call_266                           ; 
        dec  m_word [_rc_]                      ; } ppm   
        jns  _l0507                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0507:                                         ; 
call_266:                                       ; 
        mov  wa,m_word [cnind]                  ; restore prev line number, file name} mov wa cnind 
        add  wa,vcvlb                           ; vector offset in words} add wa =vcvlb 
        sal  wa,log_cfp_b                       ; convert to bytes} wtb wa  
        mov  xr,m_word [r_ifa]                  ; file name array} mov xr r_ifa 
        add  xr,wa                              ; ptr to element} add xr wa 
        mov  w0,m_word [xr]                     ; change source file name} mov r_sfc (xr) 
        mov  m_word [r_sfc],w0                  ; 
        mov  m_word [xr],nulls                  ; release scblk} mov (xr) =nulls 
        mov  xr,m_word [r_ifl]                  ; line number array} mov xr r_ifl 
        add  xr,wa                              ; ptr to element} add xr wa 
        mov  xl,m_word [xr]                     ; icblk containing saved line number} mov xl (xr) 
        mov  ia,m_word [(cfp_b*icval)+xl]       ; line number integer} ldi icval(xl)  
        mov  m_word [rdnln],ia                  ; change source line number} mfi rdnln  
        mov  m_word [xr],inton                  ; release icblk} mov (xr) =inton 
        dec  m_word [cnind]                     ; decrement nesting level} dcv cnind  
        mov  wb,m_word [cmpsn]                  ; current statement number} mov wb cmpsn 
        inc  wb                                 ; anticipate end of previous stmt} icv wb  
        mov  ia,wb                              ; convert to integer} mti wb  
        call icbld                              ; build icblk for stmt number} jsr icbld  
        mov  xl,m_word [r_sfn]                  ; file name table} mov xl r_sfn 
        mov  wb,xs                              ; lookup statement number by name} mnz wb  
        call tfind                              ; allocate new teblk} jsr tfind  
        dec  m_word [_rc_]                      ; 
        js   call_267                           ; 
        dec  m_word [_rc_]                      ; always possible to allocate block} ppm   
        jns  _l0508                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0508:                                         ; 
call_267:                                       ; 
        mov  w0,m_word [r_sfc]                  ; record file name as entry value} mov teval(xl) r_sfc 
        mov  m_word [(cfp_b*teval)+xl],w0       ; 
        cmp  m_word [stage],stgic               ; if initial compile, reissue read} beq stage =stgic reada
        je   reada                              ; 
        cmp  m_word [cnind],0                   ; still reading from include file} bnz cnind reada 
        jnz  reada                              ; 
        mov  xl,m_word [r_ici]                  ; restore code argument string} mov xl r_ici 
        xor  w0,w0                              ; release original string} zer r_ici  
        mov  m_word [r_ici],w0                  ; 
        mov  wa,m_word [cnsil]                  ; get length of string} mov wa cnsil 
        mov  wb,m_word [cnspt]                  ; offset of characters left} mov wb cnspt 
        sub  wa,wb                              ; number of characters left} sub wa wb 
        mov  m_word [scnil],wa                  ; set new scan length} mov scnil wa 
        xor  w0,w0                              ; scan from start of substring} zer scnpt  
        mov  m_word [scnpt],w0                  ; 
        call sbstr                              ; create substring of remainder} jsr sbstr  
        mov  m_word [r_cim],xr                  ; set scan image} mov r_cim xr 
        jmp  read2                              ; return} brn read2  
read6:
        xor  xr,xr                              ; zero ptr as result} zer xr  
        jmp  read2                              ; merge} brn read2  
                                                ; end procedure readr} enp   
sbstr:
                                                ; entry point} prc e 0 
        test wa,wa                              ; jump if null substring} bze wa sbst2 
        jz   sbst2                              ; 
        call alocs                              ; else allocate scblk} jsr alocs  
        mov  wa,wc                              ; move number of characters} mov wa wc 
        mov  wc,xr                              ; save ptr to new scblk} mov wc xr 
        lea  xl,[cfp_f+xl+wb]                   ; prepare to load chars from old blk} plc xl wb 
        add  xr,cfp_f                           ; prepare to store chars in new blk} psc xr  
        rep                                     ; move characters to new string} mvc   
        movs_b                                  ; 
        mov  xr,wc                              ; then restore scblk pointer} mov xr wc 
sbst1:
        xor  xl,xl                              ; clear garbage pointer in xl} zer xl  
        ret                                     ; return to sbstr caller} exi   
sbst2:
        mov  xr,nulls                           ; set null string as result} mov xr =nulls 
        jmp  sbst1                              ; return} brn sbst1  
                                                ; end procedure sbstr} enp   
stgcc:
                                                ; } prc e 0 
        mov  wa,m_word [polcs]                  ; assume no profiling or stcount tracing} mov wa polcs 
        mov  wb,num01                           ; poll each time polcs expires} mov wb =num01 
        mov  ia,m_word [kvstl]                  ; get stmt limit} ldi kvstl  
        cmp  m_word [kvpfl],0                   ; jump if profiling enabled} bnz kvpfl stgc1 
        jnz  stgc1                              ; 
        cmp  ia,0                               ; no stcount tracing if negative} ilt stgc3  
        jl   stgc3                              ; 
        cmp  m_word [r_stc],0                   ; jump if not stcount tracing} bze r_stc stgc2 
        jz   stgc2                              ; 
stgc1:
        mov  wb,wa                              ; count polcs times within stmg} mov wb wa 
        mov  wa,num01                           ; break out of stmgo on each stmt} mov wa =num01 
        jmp  stgc3                              ; } brn stgc3  
stgc2:
        mov  ia,wa                              ; breakout count start value} mti wa  
        sub  ia,m_word [kvstl]                  ; proposed stmcs minus stmt limit} sbi kvstl  
        cmp  ia,0                               ; jump if stmt count does not limit} ile stgc3  
        jle  stgc3                              ; 
        mov  ia,m_word [kvstl]                  ; stlimit limits breakcount count} ldi kvstl  
        mov  wa,ia                              ; use it instead} mfi wa  
stgc3:
        mov  m_word [stmcs],wa                  ; update breakout count start value} mov stmcs wa 
        mov  m_word [stmct],wa                  ; reset breakout counter} mov stmct wa 
        mov  m_word [polct],wb                  ; } mov polct wb 
        ret                                     ; } exi   
tfind:
                                                ; entry point} prc e 1 
        push wb                                 ; save name/value indicator} mov -(xs) wb 
        push xr                                 ; save subscript value} mov -(xs) xr 
        push xl                                 ; save table pointer} mov -(xs) xl 
        mov  wa,m_word [(cfp_b*tblen)+xl]       ; load length of tbblk} mov wa tblen(xl) 
        shr  wa,log_cfp_b                       ; convert to word count} btw wa  
        sub  wa,tbbuk                           ; get number of buckets} sub wa =tbbuk 
        mov  ia,wa                              ; convert to integer value} mti wa  
        mov  m_word [tfnsi],ia                  ; save for later} sti tfnsi  
        mov  xl,m_word [xr]                     ; load first word of subscript} mov xl (xr) 
        movzx xl,byte [xl-1]                    ; load block entry id (bl_xx)} lei xl  
        cmp  xl,bl__d                           ; switch on block type} bsw xl bl__d tfn00
        jge  tfn00                              ; 
        jmp  m_word [_l0510+xl*cfp_b]           ; 
        segment .data                           ; 
_l0510:                                         ; 
        d_word tfn00                            ; } iff 0 tfn00 
        d_word tfn00                            ; } iff 1 tfn00 
        d_word tfn00                            ; } iff 2 tfn00 
        d_word tfn02                            ; jump if integer} iff bl_ic tfn02 
        d_word tfn04                            ; jump if name} iff bl_nm tfn04 
        d_word tfn03                            ; jump if pattern} iff bl_p0 tfn03 
        d_word tfn03                            ; jump if pattern} iff bl_p1 tfn03 
        d_word tfn03                            ; jump if pattern} iff bl_p2 tfn03 
        d_word tfn02                            ; real} iff bl_rc tfn02 
        d_word tfn05                            ; jump if string} iff bl_sc tfn05 
        d_word tfn00                            ; } iff 10 tfn00 
        d_word tfn00                            ; } iff 11 tfn00 
        d_word tfn00                            ; } iff 12 tfn00 
        d_word tfn00                            ; } iff 13 tfn00 
        d_word tfn00                            ; } iff 14 tfn00 
        d_word tfn00                            ; } iff 15 tfn00 
        d_word tfn00                            ; } iff 16 tfn00 
        segment .text                           ; end switch on block type} esw   
tfn00:
        mov  wa,m_word [(cfp_b*1)+xr]           ; load second word} mov wa 1(xr) 
tfn01:
        mov  ia,wa                              ; convert to integer} mti wa  
        jmp  tfn06                              ; jump to merge} brn tfn06  
tfn02:
        mov  ia,m_word [(cfp_b*1)+xr]           ; load value as hash source} ldi 1(xr)  
        cmp  ia,0                               ; ok if positive or zero} ige tfn06  
        jge  tfn06                              ; 
        neg  ia                                 ; make positive} ngi   
        jo   tfn06                              ; clear possible overflow} iov tfn06  
        jmp  tfn06                              ; merge} brn tfn06  
tfn03:
        mov  wa,m_word [xr]                     ; load first word as hash source} mov wa (xr) 
        jmp  tfn01                              ; merge back} brn tfn01  
tfn04:
        mov  wa,m_word [(cfp_b*nmofs)+xr]       ; load offset as hash source} mov wa nmofs(xr) 
        jmp  tfn01                              ; merge back} brn tfn01  
tfn05:
        call hashs                              ; call routine to compute hash} jsr hashs  
tfn06:
        mov  r10,m_word [tfnsi]                 ; compute hash index by remaindering} rmi tfnsi  
        call do_rmi                             ; 
        mov  wc,ia                              ; get as one word integer} mfi wc  
        sal  wc,log_cfp_b                       ; convert to byte offset} wtb wc  
        mov  xl,m_word [xs]                     ; get table ptr again} mov xl (xs) 
        add  xl,wc                              ; point to proper bucket} add xl wc 
        mov  xr,m_word [(cfp_b*tbbuk)+xl]       ; load first teblk pointer} mov xr tbbuk(xl) 
        cmp  xr,m_word [xs]                     ; jump if no teblks on chain} beq xr (xs) tfn10
        je   tfn10                              ; 
tfn07:
        mov  wb,xr                              ; save teblk pointer} mov wb xr 
        mov  xr,m_word [(cfp_b*tesub)+xr]       ; load subscript value} mov xr tesub(xr) 
        mov  xl,m_word [(cfp_b*1)+xs]           ; load input argument subscript val} mov xl 1(xs) 
        call ident                              ; compare them} jsr ident  
        dec  m_word [_rc_]                      ; 
        js   call_268                           ; 
        dec  m_word [_rc_]                      ; jump if equal (ident)} ppm tfn08  
        jns  _l0511                             ; 
        jmp  tfn08                              ; 
_l0511:                                         ; 
call_268:                                       ; 
        mov  xl,wb                              ; restore teblk pointer} mov xl wb 
        mov  xr,m_word [(cfp_b*tenxt)+xl]       ; point to next teblk on chain} mov xr tenxt(xl) 
        cmp  xr,m_word [xs]                     ; jump if there is one} bne xr (xs) tfn07
        jne  tfn07                              ; 
        mov  wc,cfp_b*tenxt                     ; set offset to link field (xl base)} mov wc *tenxt 
        jmp  tfn11                              ; jump to merge} brn tfn11  
tfn08:
        mov  xl,wb                              ; restore teblk pointer} mov xl wb 
        mov  wa,cfp_b*teval                     ; set teblk name offset} mov wa *teval 
        mov  wb,m_word [(cfp_b*2)+xs]           ; restore name/value indicator} mov wb 2(xs) 
        test wb,wb                              ; jump if called by name} bnz wb tfn09 
        jnz  tfn09                              ; 
        call acess                              ; else get value} jsr acess  
        dec  m_word [_rc_]                      ; 
        js   call_269                           ; 
        dec  m_word [_rc_]                      ; jump if reference fails} ppm tfn12  
        jns  _l0512                             ; 
        jmp  tfn12                              ; 
_l0512:                                         ; 
call_269:                                       ; 
        xor  wb,wb                              ; restore name/value indicator} zer wb  
tfn09:
        add  xs,cfp_b*num03                     ; pop stack entries} add xs *num03 
        mov  m_word [_rc_],0                    ; return to tfind caller} exi   
        ret                                     ; 
tfn10:
        add  wc,cfp_b*tbbuk                     ; get offset to bucket ptr} add wc *tbbuk 
        mov  xl,m_word [xs]                     ; set tbblk ptr as base} mov xl (xs) 
tfn11:
        mov  xr,m_word [xs]                     ; tbblk pointer} mov xr (xs) 
        mov  xr,m_word [(cfp_b*tbinv)+xr]       ; load default value in case} mov xr tbinv(xr) 
        mov  wb,m_word [(cfp_b*2)+xs]           ; load name/value indicator} mov wb 2(xs) 
        test wb,wb                              ; exit with default if value call} bze wb tfn09 
        jz   tfn09                              ; 
        mov  wb,xr                              ; copy default value} mov wb xr 
        mov  wa,cfp_b*tesi_                     ; set size of teblk} mov wa *tesi_ 
        call alloc                              ; allocate teblk} jsr alloc  
        add  xl,wc                              ; point to hash link} add xl wc 
        mov  m_word [xl],xr                     ; link new teblk at end of chain} mov (xl) xr 
        mov  m_word [xr],b_tet                  ; store type word} mov (xr) =b_tet 
        mov  m_word [(cfp_b*teval)+xr],wb       ; set default as initial value} mov teval(xr) wb 
        pop  m_word [(cfp_b*tenxt)+xr]          ; set tbblk ptr to mark end of chain} mov tenxt(xr) (xs)+ 
        pop  m_word [(cfp_b*tesub)+xr]          ; store subscript value} mov tesub(xr) (xs)+ 
        pop  wb                                 ; restore name/value indicator} mov wb (xs)+ 
        mov  xl,xr                              ; copy teblk pointer (name base)} mov xl xr 
        mov  wa,cfp_b*teval                     ; set offset} mov wa *teval 
        mov  m_word [_rc_],0                    ; return to caller with new teblk} exi   
        ret                                     ; 
tfn12:
        mov  m_word [_rc_],1                    ; alternative return} exi 1  
        ret                                     ; 
                                                ; end procedure tfind} enp   
tmake:
                                                ; } prc e 0 
        mov  wa,wc                              ; copy number of headers} mov wa wc 
        add  wa,tbsi_                           ; adjust for standard fields} add wa =tbsi_ 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        call alloc                              ; allocate space for tbblk} jsr alloc  
        mov  wb,xr                              ; copy pointer to tbblk} mov wb xr 
        mov  w0,b_tbt                           ; store type word} mov (xr)+ =b_tbt 
        stos_w                                  ; 
        xor  w0,w0                              ; zero id for the moment} zer (xr)+  
        stos_w                                  ; 
        mov  w0,wa                              ; store length (tblen)} mov (xr)+ wa 
        stos_w                                  ; 
        mov  w0,xl                              ; store initial lookup value} mov (xr)+ xl 
        stos_w                                  ; 
tma01:
        mov  w0,wb                              ; store tbblk ptr in bucket header} mov (xr)+ wb 
        stos_w                                  ; 
        dec  wc                                 ; loop till all stored} bct wc tma01 
        jnz  tma01                              ; 
        mov  xr,wb                              ; recall pointer to tbblk} mov xr wb 
        ret                                     ; } exi   
                                                ; } enp   
vmake:
                                                ; entry point} prc e 1 
        mov  wb,wa                              ; copy elements for loop later on} lct wb wa 
        add  wa,vcsi_                           ; add space for standard fields} add wa =vcsi_ 
        sal  wa,log_cfp_b                       ; convert length to bytes} wtb wa  
        cmp  wa,m_word [mxlen]                  ; fail if too large} bgt wa mxlen vmak2
        ja   vmak2                              ; 
        call alloc                              ; allocate space for vcblk} jsr alloc  
        mov  m_word [xr],b_vct                  ; store type word} mov (xr) =b_vct 
        xor  w0,w0                              ; initialize idval} zer idval(xr)  
        mov  m_word [(cfp_b*idval)+xr],w0       ; 
        mov  m_word [(cfp_b*vclen)+xr],wa       ; set length} mov vclen(xr) wa 
        mov  wc,xl                              ; copy default value} mov wc xl 
        mov  xl,xr                              ; copy vcblk pointer} mov xl xr 
        add  xl,cfp_b*vcvls                     ; point to first element value} add xl *vcvls 
vmak1:
        mov  m_word [xl],wc                     ; store one value} mov (xl)+ wc 
        lea  xl,[xl+cfp_b]                      ; 
        dec  wb                                 ; loop till all stored} bct wb vmak1 
        jnz  vmak1                              ; 
        mov  m_word [_rc_],0                    ; success return} exi   
        ret                                     ; 
vmak2:
        mov  m_word [_rc_],1                    ; fail return} exi 1  
        ret                                     ; 
                                                ; } enp   
scane:
                                                ; entry point} prc e 0 
        xor  w0,w0                              ; reset blanks flag} zer scnbl  
        mov  m_word [scnbl],w0                  ; 
        mov  m_word [scnsa],wa                  ; save wa} mov scnsa wa 
        mov  m_word [scnsb],wb                  ; save wb} mov scnsb wb 
        mov  m_word [scnsc],wc                  ; save wc} mov scnsc wc 
        cmp  m_word [scnrs],0                   ; jump if no rescan} bze scnrs scn03 
        jz   scn03                              ; 
        mov  xl,m_word [scntp]                  ; set previous returned scan type} mov xl scntp 
        mov  xr,m_word [r_scp]                  ; set previous returned pointer} mov xr r_scp 
        xor  w0,w0                              ; reset rescan switch} zer scnrs  
        mov  m_word [scnrs],w0                  ; 
        jmp  scn13                              ; jump to exit} brn scn13  
scn01:
        call readr                              ; read next image} jsr readr  
        mov  wb,cfp_b*dvubs                     ; set wb for not reading name} mov wb *dvubs 
        test xr,xr                              ; treat as semi-colon if none} bze xr scn30 
        jz   scn30                              ; 
        add  xr,cfp_f                           ; else point to first character} plc xr  
        xor  w0,w0                              ; load first character} lch wc (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wc,w0                              ; 
        cmp  wc,ch_dt                           ; jump if dot for continuation} beq wc =ch_dt scn02
        je   scn02                              ; 
        cmp  wc,ch_pl                           ; else treat as semicolon unless plus} bne wc =ch_pl scn30
        jne  scn30                              ; 
scn02:
        call nexts                              ; acquire next source image} jsr nexts  
        mov  m_word [scnpt],num01               ; set scan pointer past continuation} mov scnpt =num01 
        mov  m_word [scnbl],xs                  ; set blanks flag} mnz scnbl  
scn03:
        mov  wa,m_word [scnpt]                  ; load current offset} mov wa scnpt 
        cmp  wa,m_word [scnil]                  ; check continuation if end} beq wa scnil scn01
        je   scn01                              ; 
        mov  xl,m_word [r_cim]                  ; point to current line} mov xl r_cim 
        lea  xl,[cfp_f+xl+wa]                   ; point to current character} plc xl wa 
        mov  m_word [scnse],wa                  ; set start of element location} mov scnse wa 
        mov  wc,opdvs                           ; point to operator dv list} mov wc =opdvs 
        mov  wb,cfp_b*dvubs                     ; set constant for operator circuit} mov wb *dvubs 
        jmp  scn06                              ; start scanning} brn scn06  
scn05:
        test wb,wb                              ; jump if trailing} bze wb scn10 
        jz   scn10                              ; 
        inc  m_word [scnse]                     ; increment start of element} icv scnse  
        cmp  wa,m_word [scnil]                  ; jump if end of image} beq wa scnil scn01
        je   scn01                              ; 
        mov  m_word [scnbl],xs                  ; note blanks seen} mnz scnbl  
scn06:
        xor  w0,w0                              ; get next character} lch xr (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  xr,w0                              ; 
        inc  xl                                 ; 
        inc  wa                                 ; bump scan offset} icv wa  
        mov  m_word [scnpt],wa                  ; store offset past char scanned} mov scnpt wa 
        cmp  xr,cfp_u                           ; switch on scanned character} bsw xr cfp_u scn07
        jge  scn07                              ; 
        jmp  m_word [_l0513+xr*cfp_b]           ; 
        segment .data                           ; 
_l0513:                                         ; 
        d_word scn07                            ; } iff 0 scn07 
        d_word scn07                            ; } iff 1 scn07 
        d_word scn07                            ; } iff 2 scn07 
        d_word scn07                            ; } iff 3 scn07 
        d_word scn07                            ; } iff 4 scn07 
        d_word scn07                            ; } iff 5 scn07 
        d_word scn07                            ; } iff 6 scn07 
        d_word scn07                            ; } iff 7 scn07 
        d_word scn07                            ; } iff 8 scn07 
        d_word scn05                            ; horizontal tab} iff ch_ht scn05 
        d_word scn07                            ; } iff 10 scn07 
        d_word scn07                            ; } iff 11 scn07 
        d_word scn07                            ; } iff 12 scn07 
        d_word scn07                            ; } iff 13 scn07 
        d_word scn07                            ; } iff 14 scn07 
        d_word scn07                            ; } iff 15 scn07 
        d_word scn07                            ; } iff 16 scn07 
        d_word scn07                            ; } iff 17 scn07 
        d_word scn07                            ; } iff 18 scn07 
        d_word scn07                            ; } iff 19 scn07 
        d_word scn07                            ; } iff 20 scn07 
        d_word scn07                            ; } iff 21 scn07 
        d_word scn07                            ; } iff 22 scn07 
        d_word scn07                            ; } iff 23 scn07 
        d_word scn07                            ; } iff 24 scn07 
        d_word scn07                            ; } iff 25 scn07 
        d_word scn07                            ; } iff 26 scn07 
        d_word scn07                            ; } iff 27 scn07 
        d_word scn07                            ; } iff 28 scn07 
        d_word scn07                            ; } iff 29 scn07 
        d_word scn07                            ; } iff 30 scn07 
        d_word scn07                            ; } iff 31 scn07 
        d_word scn05                            ; blank} iff ch_bl scn05 
        d_word scn37                            ; exclamation mark} iff ch_ex scn37 
        d_word scn17                            ; double quote} iff ch_dq scn17 
        d_word scn41                            ; number sign} iff ch_nm scn41 
        d_word scn36                            ; dollar} iff ch_dl scn36 
        d_word scn38                            ; percent} iff ch_pc scn38 
        d_word scn44                            ; ampersand} iff ch_am scn44 
        d_word scn16                            ; single quote} iff ch_sq scn16 
        d_word scn25                            ; left paren} iff ch_pp scn25 
        d_word scn26                            ; right paren} iff ch_rp scn26 
        d_word scn49                            ; asterisk} iff ch_as scn49 
        d_word scn33                            ; plus} iff ch_pl scn33 
        d_word scn31                            ; comma} iff ch_cm scn31 
        d_word scn34                            ; minus} iff ch_mn scn34 
        d_word scn32                            ; dot} iff ch_dt scn32 
        d_word scn40                            ; slash} iff ch_sl scn40 
        d_word scn08                            ; digit 0} iff ch_d0 scn08 
        d_word scn08                            ; digit 1} iff ch_d1 scn08 
        d_word scn08                            ; digit 2} iff ch_d2 scn08 
        d_word scn08                            ; digit 3} iff ch_d3 scn08 
        d_word scn08                            ; digit 4} iff ch_d4 scn08 
        d_word scn08                            ; digit 5} iff ch_d5 scn08 
        d_word scn08                            ; digit 6} iff ch_d6 scn08 
        d_word scn08                            ; digit 7} iff ch_d7 scn08 
        d_word scn08                            ; digit 8} iff ch_d8 scn08 
        d_word scn08                            ; digit 9} iff ch_d9 scn08 
        d_word scn29                            ; colon} iff ch_cl scn29 
        d_word scn30                            ; semi-colon} iff ch_sm scn30 
        d_word scn28                            ; left bracket} iff ch_bb scn28 
        d_word scn46                            ; equal} iff ch_eq scn46 
        d_word scn27                            ; right bracket} iff ch_rb scn27 
        d_word scn45                            ; question mark} iff ch_qu scn45 
        d_word scn42                            ; at} iff ch_at scn42 
        d_word scn09                            ; shifted a} iff ch_ua scn09 
        d_word scn09                            ; shifted b} iff ch_ub scn09 
        d_word scn09                            ; shifted c} iff ch_uc scn09 
        d_word scn09                            ; shifted d} iff ch_ud scn09 
        d_word scn09                            ; shifted e} iff ch_ue scn09 
        d_word scn20                            ; shifted f} iff ch_uf scn20 
        d_word scn09                            ; shifted g} iff ch_ug scn09 
        d_word scn09                            ; shifted h} iff ch_uh scn09 
        d_word scn09                            ; shifted i} iff ch_ui scn09 
        d_word scn09                            ; shifted j} iff ch_uj scn09 
        d_word scn09                            ; shifted k} iff ch_uk scn09 
        d_word scn09                            ; shifted l} iff ch_ul scn09 
        d_word scn09                            ; shifted m} iff ch_um scn09 
        d_word scn09                            ; shifted n} iff ch_un scn09 
        d_word scn09                            ; shifted o} iff ch_uo scn09 
        d_word scn09                            ; shifted p} iff ch_up scn09 
        d_word scn09                            ; shifted q} iff ch_uq scn09 
        d_word scn09                            ; shifted r} iff ch_ur scn09 
        d_word scn21                            ; shifted s} iff ch_us scn21 
        d_word scn09                            ; shifted t} iff ch_ut scn09 
        d_word scn09                            ; shifted u} iff ch_uu scn09 
        d_word scn09                            ; shifted v} iff ch_uv scn09 
        d_word scn09                            ; shifted w} iff ch_uw scn09 
        d_word scn09                            ; shifted x} iff ch_ux scn09 
        d_word scn09                            ; shifted y} iff ch_uy scn09 
        d_word scn09                            ; shifted z} iff ch_uz scn09 
        d_word scn28                            ; left bracket} iff ch_ob scn28 
        d_word scn07                            ; } iff 92 scn07 
        d_word scn27                            ; right bracket} iff ch_cb scn27 
        d_word scn37                            ; up arrow} iff ch_ey scn37 
        d_word scn24                            ; underline} iff ch_u_ scn24 
        d_word scn07                            ; } iff 96 scn07 
        d_word scn09                            ; letter a} iff ch_la scn09 
        d_word scn09                            ; letter b} iff ch_lb scn09 
        d_word scn09                            ; letter c} iff ch_lc scn09 
        d_word scn09                            ; letter d} iff ch_ld scn09 
        d_word scn09                            ; letter e} iff ch_le scn09 
        d_word scn20                            ; letter f} iff ch_lf scn20 
        d_word scn09                            ; letter g} iff ch_lg scn09 
        d_word scn09                            ; letter h} iff ch_lh scn09 
        d_word scn09                            ; letter i} iff ch_li scn09 
        d_word scn09                            ; letter j} iff ch_lj scn09 
        d_word scn09                            ; letter k} iff ch_lk scn09 
        d_word scn09                            ; letter l} iff ch_ll scn09 
        d_word scn09                            ; letter m} iff ch_lm scn09 
        d_word scn09                            ; letter n} iff ch_ln scn09 
        d_word scn09                            ; letter o} iff ch_lo scn09 
        d_word scn09                            ; letter p} iff ch_lp scn09 
        d_word scn09                            ; letter q} iff ch_lq scn09 
        d_word scn09                            ; letter r} iff ch_lr scn09 
        d_word scn21                            ; letter s} iff ch_ls scn21 
        d_word scn09                            ; letter t} iff ch_lt scn09 
        d_word scn09                            ; letter u} iff ch_lu scn09 
        d_word scn09                            ; letter v} iff ch_lv scn09 
        d_word scn09                            ; letter w} iff ch_lw scn09 
        d_word scn09                            ; letter x} iff ch_lx scn09 
        d_word scn09                            ; letter y} iff ch_ly scn09 
        d_word scn09                            ; letter z} iff ch_l_ scn09 
        d_word scn07                            ; } iff 123 scn07 
        d_word scn43                            ; vertical bar} iff ch_br scn43 
        d_word scn07                            ; } iff 125 scn07 
        d_word scn35                            ; not} iff ch_nt scn35 
        d_word scn07                            ; } iff 127 scn07 
        segment .text                           ; end switch on character} esw   
scn07:
        test wb,wb                              ; jump if scanning name or constant} bze wb scn10 
        jz   scn10                              ; 
        mov  m_word [_rc_],230                  ; } erb 230 syntax error: illegal character 
        jmp  err_                               ; 
scn08:
        test wb,wb                              ; keep scanning if name/constant} bze wb scn09 
        jz   scn09                              ; 
        xor  wc,wc                              ; else set flag for scanning constant} zer wc  
scn09:
        cmp  wa,m_word [scnil]                  ; jump if end of image} beq wa scnil scn11
        je   scn11                              ; 
        xor  wb,wb                              ; set flag for scanning name/const} zer wb  
        jmp  scn06                              ; merge back to continue scan} brn scn06  
scn10:
        dec  wa                                 ; reset offset to point to delimiter} dcv wa  
scn11:
        mov  m_word [scnpt],wa                  ; store updated scan offset} mov scnpt wa 
        mov  wb,m_word [scnse]                  ; point to start of element} mov wb scnse 
        sub  wa,wb                              ; get number of characters} sub wa wb 
        mov  xl,m_word [r_cim]                  ; point to line image} mov xl r_cim 
        test wc,wc                              ; jump if name} bnz wc scn15 
        jnz  scn15                              ; 
        call sbstr                              ; get string for constant} jsr sbstr  
        mov  m_word [dnamp],xr                  ; delete from storage (not needed)} mov dnamp xr 
        call gtnum                              ; convert to numeric} jsr gtnum  
        dec  m_word [_rc_]                      ; 
        js   call_270                           ; 
        dec  m_word [_rc_]                      ; jump if conversion failure} ppm scn14  
        jns  _l0514                             ; 
        jmp  scn14                              ; 
_l0514:                                         ; 
call_270:                                       ; 
scn12:
        mov  xl,t_con                           ; set result type of constant} mov xl =t_con 
scn13:
        mov  wa,m_word [scnsa]                  ; restore wa} mov wa scnsa 
        mov  wb,m_word [scnsb]                  ; restore wb} mov wb scnsb 
        mov  wc,m_word [scnsc]                  ; restore wc} mov wc scnsc 
        mov  m_word [r_scp],xr                  ; save xr in case rescan} mov r_scp xr 
        mov  m_word [scntp],xl                  ; save xl in case rescan} mov scntp xl 
        xor  w0,w0                              ; reset possible goto flag} zer scngo  
        mov  m_word [scngo],w0                  ; 
        ret                                     ; return to scane caller} exi   
scn14:
        mov  m_word [_rc_],231                  ; } erb 231 syntax error: invalid numeric item 
        jmp  err_                               ; 
scn15:
        call sbstr                              ; build string name of variable} jsr sbstr  
        cmp  m_word [scncc],0                   ; return if cncrd call} bnz scncc scn13 
        jnz  scn13                              ; 
        call gtnvr                              ; locate/build vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_271                           ; 
        dec  m_word [_rc_]                      ; dummy (unused) error return} ppm   
        jns  _l0515                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0515:                                         ; 
call_271:                                       ; 
        mov  xl,t_var                           ; set type as variable} mov xl =t_var 
        jmp  scn13                              ; back to exit} brn scn13  
scn16:
        test wb,wb                              ; terminator if scanning name or cnst} bze wb scn10 
        jz   scn10                              ; 
        mov  wb,ch_sq                           ; set terminator as single quote} mov wb =ch_sq 
        jmp  scn18                              ; merge} brn scn18  
scn17:
        test wb,wb                              ; terminator if scanning name or cnst} bze wb scn10 
        jz   scn10                              ; 
        mov  wb,ch_dq                           ; set double quote terminator, merge} mov wb =ch_dq 
scn18:
        cmp  wa,m_word [scnil]                  ; error if end of image} beq wa scnil scn19
        je   scn19                              ; 
        xor  w0,w0                              ; else load next character} lch wc (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wc,w0                              ; 
        inc  xl                                 ; 
        inc  wa                                 ; bump offset} icv wa  
        cmp  wc,wb                              ; loop back if not terminator} bne wc wb scn18
        jne  scn18                              ; 
        mov  wb,m_word [scnpt]                  ; point to first character} mov wb scnpt 
        mov  m_word [scnpt],wa                  ; save offset past final quote} mov scnpt wa 
        dec  wa                                 ; point back past last character} dcv wa  
        sub  wa,wb                              ; get number of characters} sub wa wb 
        mov  xl,m_word [r_cim]                  ; point to input image} mov xl r_cim 
        call sbstr                              ; build substring value} jsr sbstr  
        jmp  scn12                              ; back to exit with constant result} brn scn12  
scn19:
        mov  m_word [scnpt],wa                  ; set updated scan pointer} mov scnpt wa 
        mov  m_word [_rc_],232                  ; } erb 232 syntax error: unmatched string quote 
        jmp  err_                               ; 
scn20:
        mov  xr,t_fgo                           ; set return code for fail goto} mov xr =t_fgo 
        jmp  scn22                              ; jump to merge} brn scn22  
scn21:
        mov  xr,t_sgo                           ; set success goto as return code} mov xr =t_sgo 
scn22:
        cmp  m_word [scngo],0                   ; treat as normal letter if not goto} bze scngo scn09 
        jz   scn09                              ; 
scn23:
        test wb,wb                              ; jump if end of name/constant} bze wb scn10 
        jz   scn10                              ; 
        mov  xl,xr                              ; else copy code} mov xl xr 
        jmp  scn13                              ; and jump to exit} brn scn13  
scn24:
        test wb,wb                              ; part of name if scanning name} bze wb scn09 
        jz   scn09                              ; 
        jmp  scn07                              ; else illegal} brn scn07  
scn25:
        mov  xr,t_lpr                           ; set left paren return code} mov xr =t_lpr 
        test wb,wb                              ; return left paren unless name} bnz wb scn23 
        jnz  scn23                              ; 
        test wc,wc                              ; delimiter if scanning constant} bze wc scn10 
        jz   scn10                              ; 
        mov  wb,m_word [scnse]                  ; point to start of name} mov wb scnse 
        mov  m_word [scnpt],wa                  ; set pointer past left paren} mov scnpt wa 
        dec  wa                                 ; point back past last char of name} dcv wa  
        sub  wa,wb                              ; get name length} sub wa wb 
        mov  xl,m_word [r_cim]                  ; point to input image} mov xl r_cim 
        call sbstr                              ; get string name for function} jsr sbstr  
        call gtnvr                              ; locate/build vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_272                           ; 
        dec  m_word [_rc_]                      ; dummy (unused) error return} ppm   
        jns  _l0516                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0516:                                         ; 
call_272:                                       ; 
        mov  xl,t_fnc                           ; set code for function call} mov xl =t_fnc 
        jmp  scn13                              ; back to exit} brn scn13  
scn26:
        mov  xr,t_rpr                           ; right paren, set code} mov xr =t_rpr 
        jmp  scn23                              ; take special character exit} brn scn23  
scn27:
        mov  xr,t_rbr                           ; right bracket, set code} mov xr =t_rbr 
        jmp  scn23                              ; take special character exit} brn scn23  
scn28:
        mov  xr,t_lbr                           ; left bracket, set code} mov xr =t_lbr 
        jmp  scn23                              ; take special character exit} brn scn23  
scn29:
        mov  xr,t_col                           ; colon, set code} mov xr =t_col 
        jmp  scn23                              ; take special character exit} brn scn23  
scn30:
        mov  xr,t_smc                           ; semi-colon, set code} mov xr =t_smc 
        jmp  scn23                              ; take special character exit} brn scn23  
scn31:
        mov  xr,t_cma                           ; comma, set code} mov xr =t_cma 
        jmp  scn23                              ; take special character exit} brn scn23  
scn32:
        test wb,wb                              ; dot can be part of name or constant} bze wb scn09 
        jz   scn09                              ; 
        add  wc,wb                              ; else bump pointer} add wc wb 
scn33:
        test wc,wc                              ; plus can be part of constant} bze wc scn09 
        jz   scn09                              ; 
        test wb,wb                              ; plus cannot be part of name} bze wb scn48 
        jz   scn48                              ; 
        add  wc,wb                              ; else bump pointer} add wc wb 
scn34:
        test wc,wc                              ; minus can be part of constant} bze wc scn09 
        jz   scn09                              ; 
        test wb,wb                              ; minus cannot be part of name} bze wb scn48 
        jz   scn48                              ; 
        add  wc,wb                              ; else bump pointer} add wc wb 
scn35:
        add  wc,wb                              ; not} add wc wb 
scn36:
        add  wc,wb                              ; dollar} add wc wb 
scn37:
        add  wc,wb                              ; exclamation} add wc wb 
scn38:
        add  wc,wb                              ; percent} add wc wb 
scn39:
        add  wc,wb                              ; asterisk} add wc wb 
scn40:
        add  wc,wb                              ; slash} add wc wb 
scn41:
        add  wc,wb                              ; number sign} add wc wb 
scn42:
        add  wc,wb                              ; at sign} add wc wb 
scn43:
        add  wc,wb                              ; vertical bar} add wc wb 
scn44:
        add  wc,wb                              ; ampersand} add wc wb 
scn45:
        add  wc,wb                              ; question mark} add wc wb 
scn46:
        test wb,wb                              ; operator terminates name/constant} bze wb scn10 
        jz   scn10                              ; 
        mov  xr,wc                              ; else copy dv pointer} mov xr wc 
        xor  w0,w0                              ; load next character} lch wc (xl) 
        mov  al,m_char [xl]                     ; 
        mov  wc,w0                              ; 
        mov  xl,t_bop                           ; set binary op in case} mov xl =t_bop 
        cmp  wa,m_word [scnil]                  ; should be binary if image end} beq wa scnil scn47
        je   scn47                              ; 
        cmp  wc,ch_bl                           ; should be binary if followed by blk} beq wc =ch_bl scn47
        je   scn47                              ; 
        cmp  wc,ch_ht                           ; jump if horizontal tab} beq wc =ch_ht scn47
        je   scn47                              ; 
        cmp  wc,ch_sm                           ; semicolon can immediately follow =} beq wc =ch_sm scn47
        je   scn47                              ; 
        cmp  wc,ch_cl                           ; colon can immediately follow =} beq wc =ch_cl scn47
        je   scn47                              ; 
        cmp  wc,ch_rp                           ; right paren can immediately follow =} beq wc =ch_rp scn47
        je   scn47                              ; 
        cmp  wc,ch_rb                           ; right bracket can immediately follow =} beq wc =ch_rb scn47
        je   scn47                              ; 
        cmp  wc,ch_cb                           ; right bracket can immediately follow =} beq wc =ch_cb scn47
        je   scn47                              ; 
        add  xr,cfp_b*dvbs_                     ; point to dv for unary op} add xr *dvbs_ 
        mov  xl,t_uop                           ; set type for unary operator} mov xl =t_uop 
        cmp  m_word [scntp],t_uok               ; ok unary if ok preceding element} ble scntp =t_uok scn13
        jbe  scn13                              ; 
scn47:
        cmp  m_word [scnbl],0                   ; all ok if preceding blanks, exit} bnz scnbl scn13 
        jnz  scn13                              ; 
scn48:
        mov  m_word [_rc_],233                  ; } erb 233 syntax error: invalid use of operator 
        jmp  err_                               ; 
scn49:
        test wb,wb                              ; end of name if scanning name} bze wb scn10 
        jz   scn10                              ; 
        cmp  wa,m_word [scnil]                  ; not ** if * at image end} beq wa scnil scn39
        je   scn39                              ; 
        mov  xr,wa                              ; else save offset past first *} mov xr wa 
        mov  m_word [scnof],wa                  ; save another copy} mov scnof wa 
        xor  w0,w0                              ; load next character} lch wa (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        inc  xl                                 ; 
        cmp  wa,ch_as                           ; not ** if next char not *} bne wa =ch_as scn50
        jne  scn50                              ; 
        inc  xr                                 ; else step offset past second *} icv xr  
        cmp  xr,m_word [scnil]                  ; ok exclam if end of image} beq xr scnil scn51
        je   scn51                              ; 
        xor  w0,w0                              ; else load next character} lch wa (xl) 
        mov  al,m_char [xl]                     ; 
        mov  wa,w0                              ; 
        cmp  wa,ch_bl                           ; exclamation if blank} beq wa =ch_bl scn51
        je   scn51                              ; 
        cmp  wa,ch_ht                           ; exclamation if horizontal tab} beq wa =ch_ht scn51
        je   scn51                              ; 
scn50:
        mov  wa,m_word [scnof]                  ; recover stored offset} mov wa scnof 
        mov  xl,m_word [r_cim]                  ; point to line again} mov xl r_cim 
        lea  xl,[cfp_f+xl+wa]                   ; point to current char} plc xl wa 
        jmp  scn39                              ; merge with unary *} brn scn39  
scn51:
        mov  m_word [scnpt],xr                  ; save scan pointer past 2nd *} mov scnpt xr 
        mov  wa,xr                              ; copy scan pointer} mov wa xr 
        jmp  scn37                              ; merge with exclamation} brn scn37  
                                                ; end procedure scane} enp   
scngf:
                                                ; entry point} prc e 0 
        call scane                              ; scan initial element} jsr scane  
        cmp  xl,t_lpr                           ; skip if left paren (normal goto)} beq xl =t_lpr scng1
        je   scng1                              ; 
        cmp  xl,t_lbr                           ; skip if left bracket (direct goto)} beq xl =t_lbr scng2
        je   scng2                              ; 
        mov  m_word [_rc_],234                  ; } erb 234 syntax error: goto field incorrect 
        jmp  err_                               ; 
scng1:
        mov  wb,num01                           ; set expan flag for normal goto} mov wb =num01 
        call expan                              ; analyze goto field} jsr expan  
        mov  wa,opdvn                           ; point to opdv for complex goto} mov wa =opdvn 
        cmp  xr,m_word [statb]                  ; jump if not in static (sgd15)} ble xr statb scng3
        jbe  scng3                              ; 
        cmp  xr,m_word [state]                  ; jump to exit if simple label name} blo xr state scng4
        jb   scng4                              ; 
        jmp  scng3                              ; complex goto - merge} brn scng3  
scng2:
        mov  wb,num02                           ; set expan flag for direct goto} mov wb =num02 
        call expan                              ; scan goto field} jsr expan  
        mov  wa,opdvd                           ; set opdv pointer for direct goto} mov wa =opdvd 
scng3:
        push wa                                 ; stack operator dv pointer} mov -(xs) wa 
        push xr                                 ; stack pointer to expression tree} mov -(xs) xr 
        call expop                              ; pop operator off} jsr expop  
        pop  xr                                 ; reload new expression tree pointer} mov xr (xs)+ 
scng4:
        ret                                     ; return to caller} exi   
                                                ; end procedure scngf} enp   
setvr:
                                                ; entry point} prc e 0 
        cmp  xr,m_word [state]                  ; exit if not natural variable} bhi xr state setv1
        ja   setv1                              ; 
        mov  xl,xr                              ; copy vrblk pointer} mov xl xr 
        mov  m_word [(cfp_b*vrget)+xr],b_vrl    ; store normal get value} mov vrget(xr) =b_vrl 
        cmp  m_word [(cfp_b*vrsto)+xr],b_vre    ; skip if protected variable} beq vrsto(xr) =b_vre setv1
        je   setv1                              ; 
        mov  m_word [(cfp_b*vrsto)+xr],b_vrs    ; store normal store value} mov vrsto(xr) =b_vrs 
        mov  xl,m_word [(cfp_b*vrval)+xl]       ; point to next entry on chain} mov xl vrval(xl) 
        cmp  m_word [xl],b_trt                  ; jump if end of trblk chain} bne (xl) =b_trt setv1
        jne  setv1                              ; 
        mov  m_word [(cfp_b*vrget)+xr],b_vra    ; store trapped routine address} mov vrget(xr) =b_vra 
        mov  m_word [(cfp_b*vrsto)+xr],b_vrv    ; set trapped routine address} mov vrsto(xr) =b_vrv 
setv1:
        ret                                     ; return to setvr caller} exi   
                                                ; end procedure setvr} enp   
sorta:
        pop  m_word [prc_+cfp_b*15]             ; entry point} prc n 1 
        mov  m_word [srtsr],wa                  ; sort/rsort indicator} mov srtsr wa 
        mov  m_word [srtst],cfp_b*num01         ; default stride of 1} mov srtst *num01 
        xor  w0,w0                              ; default zero offset to sort key} zer srtof  
        mov  m_word [srtof],w0                  ; 
        mov  m_word [srtdf],nulls               ; clear datatype field name} mov srtdf =nulls 
        pop  m_word [r_sxr]                     ; unstack argument 2} mov r_sxr (xs)+ 
        pop  xr                                 ; get first argument} mov xr (xs)+ 
        mov  wa,xs                              ; use key/values of table entries} mnz wa  
        call gtarr                              ; convert to array} jsr gtarr  
        dec  m_word [_rc_]                      ; 
        js   call_273                           ; 
        dec  m_word [_rc_]                      ; signal that table is empty} ppm srt18  
        jns  _l0517                             ; 
        jmp  srt18                              ; 
_l0517:                                         ; 
        dec  m_word [_rc_]                      ; error if non-convertable} ppm srt16  
        jns  _l0518                             ; 
        jmp  srt16                              ; 
_l0518:                                         ; 
call_273:                                       ; 
        push xr                                 ; stack ptr to resulting key array} mov -(xs) xr 
        push xr                                 ; another copy for copyb} mov -(xs) xr 
        call copyb                              ; get copy array for sorting into} jsr copyb  
        dec  m_word [_rc_]                      ; 
        js   call_274                           ; 
        dec  m_word [_rc_]                      ; cant fail} ppm   
        jns  _l0519                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0519:                                         ; 
call_274:                                       ; 
        push xr                                 ; stack pointer to sort array} mov -(xs) xr 
        mov  xr,m_word [r_sxr]                  ; get second arg} mov xr r_sxr 
        mov  xl,m_word [(cfp_b*num01)+xs]       ; get ptr to key array} mov xl num01(xs) 
        cmp  m_word [xl],b_vct                  ; jump if arblk} bne (xl) =b_vct srt02
        jne  srt02                              ; 
        cmp  xr,nulls                           ; jump if null second arg} beq xr =nulls srt01
        je   srt01                              ; 
        call gtnvr                              ; get vrblk ptr for it} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_275                           ; 
        dec  m_word [_rc_]                      ; } err 257 erroneous 2nd arg in sort/rsort of vector 
        jns  _l0520                             ; 
        mov  m_word [_rc_],257                  ; 
        jmp  err_                               ; 
_l0520:                                         ; 
call_275:                                       ; 
        mov  m_word [srtdf],xr                  ; store datatype field name vrblk} mov srtdf xr 
srt01:
        mov  wc,cfp_b*vclen                     ; offset to a(0)} mov wc *vclen 
        mov  wb,cfp_b*vcvls                     ; offset to first item} mov wb *vcvls 
        mov  wa,m_word [(cfp_b*vclen)+xl]       ; get block length} mov wa vclen(xl) 
        sub  wa,cfp_b*vcsi_                     ; get no. of entries, n (in bytes)} sub wa *vcsi_ 
        jmp  srt04                              ; merge} brn srt04  
srt02:
        mov  ia,m_word [(cfp_b*ardim)+xl]       ; get possible dimension} ldi ardim(xl)  
        mov  wa,ia                              ; convert to short integer} mfi wa  
        sal  wa,log_cfp_b                       ; further convert to baus} wtb wa  
        mov  wb,cfp_b*arvls                     ; offset to first value if one} mov wb *arvls 
        mov  wc,cfp_b*arpro                     ; offset before values if one dim.} mov wc *arpro 
        cmp  m_word [(cfp_b*arndm)+xl],num01    ; jump in fact if one dim.} beq arndm(xl) =num01 srt04
        je   srt04                              ; 
        cmp  m_word [(cfp_b*arndm)+xl],num02    ; fail unless two dimens} bne arndm(xl) =num02 srt16
        jne  srt16                              ; 
        mov  ia,m_word [(cfp_b*arlb2)+xl]       ; get lower bound 2 as default} ldi arlb2(xl)  
        cmp  xr,nulls                           ; jump if default second arg} beq xr =nulls srt03
        je   srt03                              ; 
        call gtint                              ; convert to integer} jsr gtint  
        dec  m_word [_rc_]                      ; 
        js   call_276                           ; 
        dec  m_word [_rc_]                      ; fail} ppm srt17  
        jns  _l0521                             ; 
        jmp  srt17                              ; 
_l0521:                                         ; 
call_276:                                       ; 
        mov  ia,m_word [(cfp_b*icval)+xr]       ; get actual integer value} ldi icval(xr)  
srt03:
        sub  ia,m_word [(cfp_b*arlb2)+xl]       ; subtract low bound} sbi arlb2(xl)  
        jo   srt17                              ; fail if overflow} iov srt17  
        cmp  ia,0                               ; fail if below low bound} ilt srt17  
        jl   srt17                              ; 
        sub  ia,m_word [(cfp_b*ardm2)+xl]       ; check against dimension} sbi ardm2(xl)  
        cmp  ia,0                               ; fail if too large} ige srt17  
        jge  srt17                              ; 
        add  ia,m_word [(cfp_b*ardm2)+xl]       ; restore value} adi ardm2(xl)  
        mov  wa,ia                              ; get as small integer} mfi wa  
        sal  wa,log_cfp_b                       ; offset within row to key} wtb wa  
        mov  m_word [srtof],wa                  ; keep offset} mov srtof wa 
        mov  ia,m_word [(cfp_b*ardm2)+xl]       ; second dimension is row length} ldi ardm2(xl)  
        mov  wa,ia                              ; convert to short integer} mfi wa  
        mov  xr,wa                              ; copy row length} mov xr wa 
        sal  wa,log_cfp_b                       ; convert to bytes} wtb wa  
        mov  m_word [srtst],wa                  ; store as stride} mov srtst wa 
        mov  ia,m_word [(cfp_b*ardim)+xl]       ; get number of rows} ldi ardim(xl)  
        mov  wa,ia                              ; as a short integer} mfi wa  
        sal  wa,log_cfp_b                       ; convert n to baus} wtb wa  
        mov  wc,m_word [(cfp_b*arlen)+xl]       ; offset past array end} mov wc arlen(xl) 
        sub  wc,wa                              ; adjust, giving space for n offsets} sub wc wa 
        sub  wc,cfp_b                           ; point to a(0)} dca wc  
        mov  wb,m_word [(cfp_b*arofs)+xl]       ; offset to word before first item} mov wb arofs(xl) 
        add  wb,cfp_b                           ; offset to first item} ica wb  
srt04:
        cmp  wa,cfp_b*num01                     ; return if only a single item} ble wa *num01 srt15
        jbe  srt15                              ; 
        mov  m_word [srtsn],wa                  ; store number of items (in baus)} mov srtsn wa 
        mov  m_word [srtso],wc                  ; store offset to a(0)} mov srtso wc 
        mov  wc,m_word [(cfp_b*arlen)+xl]       ; length of array or vec (=vclen)} mov wc arlen(xl) 
        add  wc,xl                              ; point past end of array or vector} add wc xl 
        mov  m_word [srtsf],wb                  ; store offset to first row} mov srtsf wb 
        add  xl,wb                              ; point to first item in key array} add xl wb 
srt05:
        mov  xr,m_word [xl]                     ; get an entry} mov xr (xl) 
srt06:
        cmp  m_word [xr],b_trt                  ; jump out if not trblk} bne (xr) =b_trt srt07
        jne  srt07                              ; 
        mov  xr,m_word [(cfp_b*trval)+xr]       ; get value field} mov xr trval(xr) 
        jmp  srt06                              ; loop} brn srt06  
srt07:
        mov  m_word [xl],xr                     ; store as array entry} mov (xl)+ xr 
        lea  xl,[xl+cfp_b]                      ; 
        cmp  xl,wc                              ; loop if not done} blt xl wc srt05
        jb   srt05                              ; 
        mov  xl,m_word [xs]                     ; get adrs of sort array} mov xl (xs) 
        mov  xr,m_word [srtsf]                  ; initial offset to first key} mov xr srtsf 
        mov  wb,m_word [srtst]                  ; get stride} mov wb srtst 
        add  xl,m_word [srtso]                  ; offset to a(0)} add xl srtso 
        add  xl,cfp_b                           ; point to a(1)} ica xl  
        mov  wc,m_word [srtsn]                  ; get n} mov wc srtsn 
        shr  wc,log_cfp_b                       ; convert from bytes} btw wc  
        mov  m_word [srtnr],wc                  ; store as row count} mov srtnr wc 
srt08:
        mov  m_word [xl],xr                     ; store an offset} mov (xl)+ xr 
        lea  xl,[xl+cfp_b]                      ; 
        add  xr,wb                              ; bump offset by stride} add xr wb 
        dec  wc                                 ; loop through rows} bct wc srt08 
        jnz  srt08                              ; 
srt09:
        mov  wa,m_word [srtsn]                  ; get n} mov wa srtsn 
        mov  wc,m_word [srtnr]                  ; get number of rows} mov wc srtnr 
        shr  wc,1                               ; i = n / 2 (wc=i, index into array)} rsh wc 1 
        sal  wc,log_cfp_b                       ; convert back to bytes} wtb wc  
srt10:
        call sorth                              ; sorth(i,n)} jsr sorth  
        sub  wc,cfp_b                           ; i = i - 1} dca wc  
        test wc,wc                              ; loop if i gt 0} bnz wc srt10 
        jnz  srt10                              ; 
        mov  wc,wa                              ; i = n} mov wc wa 
srt11:
        sub  wc,cfp_b                           ; i = i - 1 (n - 1 initially)} dca wc  
        test wc,wc                              ; jump if done} bze wc srt12 
        jz   srt12                              ; 
        mov  xr,m_word [xs]                     ; get sort array address} mov xr (xs) 
        add  xr,m_word [srtso]                  ; point to a(0)} add xr srtso 
        mov  xl,xr                              ; a(0) address} mov xl xr 
        add  xl,wc                              ; a(i) address} add xl wc 
        mov  wb,m_word [(cfp_b*num01)+xl]       ; copy a(i+1)} mov wb num01(xl) 
        mov  w0,m_word [(cfp_b*num01)+xr]       ; move a(1) to a(i+1)} mov num01(xl) num01(xr) 
        mov  m_word [(cfp_b*num01)+xl],w0       ; 
        mov  m_word [(cfp_b*num01)+xr],wb       ; complete exchange of a(1), a(i+1)} mov num01(xr) wb 
        mov  wa,wc                              ; n = i for sorth} mov wa wc 
        mov  wc,cfp_b*num01                     ; i = 1 for sorth} mov wc *num01 
        call sorth                              ; sorth(1,n)} jsr sorth  
        mov  wc,wa                              ; restore wc} mov wc wa 
        jmp  srt11                              ; loop} brn srt11  
srt12:
        mov  xr,m_word [xs]                     ; base adrs of key array} mov xr (xs) 
        mov  wc,xr                              ; copy it} mov wc xr 
        add  wc,m_word [srtso]                  ; offset of a(0)} add wc srtso 
        add  xr,m_word [srtsf]                  ; adrs of first row of sort array} add xr srtsf 
        mov  wb,m_word [srtst]                  ; get stride} mov wb srtst 
srt13:
        add  wc,cfp_b                           ; adrs of next of sorted offsets} ica wc  
        mov  xl,wc                              ; copy it for access} mov xl wc 
        mov  xl,m_word [xl]                     ; get offset} mov xl (xl) 
        add  xl,m_word [(cfp_b*num01)+xs]       ; add key array base adrs} add xl num01(xs) 
        mov  wa,wb                              ; get count of characters in row} mov wa wb 
        shr  wa,log_cfp_b                       ; copy a complete row} mvw   
        rep  movs_w                             ; 
        dec  m_word [srtnr]                     ; decrement row count} dcv srtnr  
        cmp  m_word [srtnr],0                   ; repeat till all rows done} bnz srtnr srt13 
        jnz  srt13                              ; 
srt15:
        pop  xr                                 ; pop result array ptr} mov xr (xs)+ 
        add  xs,cfp_b                           ; pop key array ptr} ica xs  
        xor  w0,w0                              ; clear junk} zer r_sxl  
        mov  m_word [r_sxl],w0                  ; 
        xor  w0,w0                              ; clear junk} zer r_sxr  
        mov  m_word [r_sxr],w0                  ; 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*15]          ; 
        jmp  w0                                 ; 
srt16:
        mov  m_word [_rc_],256                  ; } erb 256 sort/rsort 1st arg not suitable array or table 
        jmp  err_                               ; 
srt17:
        mov  m_word [_rc_],258                  ; } erb 258 sort/rsort 2nd arg out of range or non-integer 
        jmp  err_                               ; 
srt18:
        mov  m_word [_rc_],1                    ; return indication of null table} exi 1  
        mov  w0,m_word [prc_+cfp_b*15]          ; 
        jmp  w0                                 ; 
                                                ; end procudure sorta} enp   
sortc:
                                                ; entry point} prc e 1 
        mov  m_word [srts1],wa                  ; save offset 1} mov srts1 wa 
        mov  m_word [srts2],wb                  ; save offset 2} mov srts2 wb 
        mov  m_word [srtsc],wc                  ; save wc} mov srtsc wc 
        add  xl,m_word [srtof]                  ; add offset to comparand field} add xl srtof 
        mov  xr,xl                              ; copy base + offset} mov xr xl 
        add  xl,wa                              ; add key1 offset} add xl wa 
        add  xr,wb                              ; add key2 offset} add xr wb 
        mov  xl,m_word [xl]                     ; get key1} mov xl (xl) 
        mov  xr,m_word [xr]                     ; get key2} mov xr (xr) 
        cmp  m_word [srtdf],nulls               ; jump if datatype field name used} bne srtdf =nulls src12
        jne  src12                              ; 
src01:
        mov  wc,m_word [xl]                     ; get type code} mov wc (xl) 
        cmp  wc,m_word [xr]                     ; skip if not same datatype} bne wc (xr) src02
        jne  src02                              ; 
        cmp  wc,b_scl                           ; jump if both strings} beq wc =b_scl src09
        je   src09                              ; 
        cmp  wc,b_icl                           ; jump if both integers} beq wc =b_icl src14
        je   src14                              ; 
src02:
        mov  m_word [r_sxl],xl                  ; keep arg1} mov r_sxl xl 
        mov  m_word [r_sxr],xr                  ; keep arg2} mov r_sxr xr 
        cmp  wc,b_scl                           ; do not allow conversion to number} beq wc =b_scl src11
        je   src11                              ; 
        cmp  m_word [xr],b_scl                  ; if either arg is a string} beq (xr) =b_scl src11
        je   src11                              ; 
src14:
        push xl                                 ; stack} mov -(xs) xl 
        push xr                                 ; args} mov -(xs) xr 
        call acomp                              ; compare objects} jsr acomp  
        dec  m_word [_rc_]                      ; 
        js   call_277                           ; 
        dec  m_word [_rc_]                      ; not numeric} ppm src10  
        jns  _l0522                             ; 
        jmp  src10                              ; 
_l0522:                                         ; 
        dec  m_word [_rc_]                      ; not numeric} ppm src10  
        jns  _l0523                             ; 
        jmp  src10                              ; 
_l0523:                                         ; 
        dec  m_word [_rc_]                      ; key1 less} ppm src03  
        jns  _l0524                             ; 
        jmp  src03                              ; 
_l0524:                                         ; 
        dec  m_word [_rc_]                      ; keys equal} ppm src08  
        jns  _l0525                             ; 
        jmp  src08                              ; 
_l0525:                                         ; 
        dec  m_word [_rc_]                      ; key1 greater} ppm src05  
        jns  _l0526                             ; 
        jmp  src05                              ; 
_l0526:                                         ; 
call_277:                                       ; 
src03:
        cmp  m_word [srtsr],0                   ; jump if rsort} bnz srtsr src06 
        jnz  src06                              ; 
src04:
        mov  wc,m_word [srtsc]                  ; restore wc} mov wc srtsc 
        mov  m_word [_rc_],1                    ; return} exi 1  
        ret                                     ; 
src05:
        cmp  m_word [srtsr],0                   ; jump if rsort} bnz srtsr src04 
        jnz  src04                              ; 
src06:
        mov  wc,m_word [srtsc]                  ; restore wc} mov wc srtsc 
        mov  m_word [_rc_],0                    ; return} exi   
        ret                                     ; 
src07:
        cmp  xl,xr                              ; item first created is less} blt xl xr src03
        jb   src03                              ; 
        cmp  xl,xr                              ; addresses rise in order of creation} bgt xl xr src05
        ja   src05                              ; 
src08:
        mov  w0,m_word [srts2]                  ; test offsets or key addrss instead} blt srts1 srts2 src04
        cmp  m_word [srts1],w0                  ; 
        jb   src04                              ; 
        jmp  src06                              ; offset 1 greater} brn src06  
src09:
        push xl                                 ; stack} mov -(xs) xl 
        push xr                                 ; args} mov -(xs) xr 
        call lcomp                              ; compare objects} jsr lcomp  
        dec  m_word [_rc_]                      ; 
        js   call_278                           ; 
        dec  m_word [_rc_]                      ; cant} ppm   
        jns  _l0527                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0527:                                         ; 
        dec  m_word [_rc_]                      ; fail} ppm   
        jns  _l0528                             ; 
        mov  m_word [_rc_],299                  ; 
        jmp  err_                               ; 
_l0528:                                         ; 
        dec  m_word [_rc_]                      ; key1 less} ppm src03  
        jns  _l0529                             ; 
        jmp  src03                              ; 
_l0529:                                         ; 
        dec  m_word [_rc_]                      ; keys equal} ppm src08  
        jns  _l0530                             ; 
        jmp  src08                              ; 
_l0530:                                         ; 
        dec  m_word [_rc_]                      ; key1 greater} ppm src05  
        jns  _l0531                             ; 
        jmp  src05                              ; 
_l0531:                                         ; 
call_278:                                       ; 
src10:
        mov  xl,m_word [r_sxl]                  ; get arg1} mov xl r_sxl 
        mov  xr,m_word [r_sxr]                  ; get arg2} mov xr r_sxr 
        mov  wc,m_word [xl]                     ; get type of key1} mov wc (xl) 
        cmp  wc,m_word [xr]                     ; jump if keys of same type} beq wc (xr) src07
        je   src07                              ; 
src11:
        mov  xl,wc                              ; get block type word} mov xl wc 
        mov  xr,m_word [xr]                     ; get block type word} mov xr (xr) 
        movzx xl,byte [xl-1]                    ; entry point id for key1} lei xl  
        movzx xr,byte [xr-1]                    ; entry point id for key2} lei xr  
        cmp  xl,xr                              ; jump if key1 gt key2} bgt xl xr src05
        ja   src05                              ; 
        jmp  src03                              ; key1 lt key2} brn src03  
src12:
        call sortf                              ; call routine to find field 1} jsr sortf  
        push xl                                 ; stack item pointer} mov -(xs) xl 
        mov  xl,xr                              ; get key2} mov xl xr 
        call sortf                              ; find field 2} jsr sortf  
        mov  xr,xl                              ; place as key2} mov xr xl 
        pop  xl                                 ; recover key1} mov xl (xs)+ 
        jmp  src01                              ; merge} brn src01  
                                                ; procedure sortc} enp   
sortf:
                                                ; entry point} prc e 0 
        cmp  m_word [xl],b_pdt                  ; return if not pdblk} bne (xl) =b_pdt srtf3
        jne  srtf3                              ; 
        push xr                                 ; keep xr} mov -(xs) xr 
        mov  xr,m_word [srtfd]                  ; get possible former dfblk ptr} mov xr srtfd 
        test xr,xr                              ; jump if not} bze xr srtf4 
        jz   srtf4                              ; 
        cmp  xr,m_word [(cfp_b*pddfp)+xl]       ; jump if not right datatype} bne xr pddfp(xl) srtf4
        jne  srtf4                              ; 
        mov  w0,m_word [srtff]                  ; jump if not right field name} bne srtdf srtff srtf4
        cmp  m_word [srtdf],w0                  ; 
        jne  srtf4                              ; 
        add  xl,m_word [srtfo]                  ; add offset to required field} add xl srtfo 
srtf1:
        mov  xl,m_word [xl]                     ; get item from field} mov xl (xl) 
srtf2:
        pop  xr                                 ; restore xr} mov xr (xs)+ 
srtf3:
        ret                                     ; return} exi   
srtf4:
        mov  xr,xl                              ; copy original pointer} mov xr xl 
        mov  xr,m_word [(cfp_b*pddfp)+xr]       ; point to dfblk} mov xr pddfp(xr) 
        mov  m_word [srtfd],xr                  ; keep a copy} mov srtfd xr 
        mov  wc,m_word [(cfp_b*fargs)+xr]       ; get number of fields} mov wc fargs(xr) 
        sal  wc,log_cfp_b                       ; convert to bytes} wtb wc  
        add  xr,m_word [(cfp_b*dflen)+xr]       ; point past last field} add xr dflen(xr) 
srtf5:
        sub  wc,cfp_b                           ; count down} dca wc  
        sub  xr,cfp_b                           ; point in front} dca xr  
        mov  w0,m_word [srtdf]                  ; skip out if found} beq (xr) srtdf srtf6
        cmp  m_word [xr],w0                     ; 
        je   srtf6                              ; 
        test wc,wc                              ; loop} bnz wc srtf5 
        jnz  srtf5                              ; 
        jmp  srtf2                              ; return - not found} brn srtf2  
srtf6:
        mov  w0,m_word [xr]                     ; keep field name ptr} mov srtff (xr) 
        mov  m_word [srtff],w0                  ; 
        add  wc,cfp_b*pdfld                     ; add offset to first field} add wc *pdfld 
        mov  m_word [srtfo],wc                  ; store as field offset} mov srtfo wc 
        add  xl,wc                              ; point to field} add xl wc 
        jmp  srtf1                              ; return} brn srtf1  
                                                ; procedure sortf} enp   
sorth:
        pop  m_word [prc_+cfp_b*16]             ; entry point} prc n 0 
        mov  m_word [srtsn],wa                  ; save n} mov srtsn wa 
        mov  m_word [srtwc],wc                  ; keep wc} mov srtwc wc 
        mov  xl,m_word [xs]                     ; sort array base adrs} mov xl (xs) 
        add  xl,m_word [srtso]                  ; add offset to a(0)} add xl srtso 
        add  xl,wc                              ; point to a(j)} add xl wc 
        mov  w0,m_word [xl]                     ; get offset to root} mov srtrt (xl) 
        mov  m_word [srtrt],w0                  ; 
        add  wc,wc                              ; double j - cant exceed n} add wc wc 
srh01:
        cmp  wc,m_word [srtsn]                  ; done if j gt n} bgt wc srtsn srh03
        ja   srh03                              ; 
        cmp  wc,m_word [srtsn]                  ; skip if j equals n} beq wc srtsn srh02
        je   srh02                              ; 
        mov  xr,m_word [xs]                     ; sort array base adrs} mov xr (xs) 
        mov  xl,m_word [(cfp_b*num01)+xs]       ; key array base adrs} mov xl num01(xs) 
        add  xr,m_word [srtso]                  ; point to a(0)} add xr srtso 
        add  xr,wc                              ; adrs of a(j)} add xr wc 
        mov  wa,m_word [(cfp_b*num01)+xr]       ; get a(j+1)} mov wa num01(xr) 
        mov  wb,m_word [xr]                     ; get a(j)} mov wb (xr) 
        call sortc                              ; compare keys - lt(a(j+1),a(j))} jsr sortc  
        dec  m_word [_rc_]                      ; 
        js   call_279                           ; 
        dec  m_word [_rc_]                      ; a(j+1) lt a(j)} ppm srh02  
        jns  _l0532                             ; 
        jmp  srh02                              ; 
_l0532:                                         ; 
call_279:                                       ; 
        add  wc,cfp_b                           ; point to greater son, a(j+1)} ica wc  
srh02:
        mov  xl,m_word [(cfp_b*num01)+xs]       ; key array base adrs} mov xl num01(xs) 
        mov  xr,m_word [xs]                     ; get sort array address} mov xr (xs) 
        add  xr,m_word [srtso]                  ; adrs of a(0)} add xr srtso 
        mov  wb,xr                              ; copy this adrs} mov wb xr 
        add  xr,wc                              ; adrs of greater son, a(j)} add xr wc 
        mov  wa,m_word [xr]                     ; get a(j)} mov wa (xr) 
        mov  xr,wb                              ; point back to a(0)} mov xr wb 
        mov  wb,m_word [srtrt]                  ; get root} mov wb srtrt 
        call sortc                              ; compare them - lt(a(j),root)} jsr sortc  
        dec  m_word [_rc_]                      ; 
        js   call_280                           ; 
        dec  m_word [_rc_]                      ; father exceeds sons - done} ppm srh03  
        jns  _l0533                             ; 
        jmp  srh03                              ; 
_l0533:                                         ; 
call_280:                                       ; 
        mov  xr,m_word [xs]                     ; get sort array adrs} mov xr (xs) 
        add  xr,m_word [srtso]                  ; point to a(0)} add xr srtso 
        mov  xl,xr                              ; copy it} mov xl xr 
        mov  wa,wc                              ; copy j} mov wa wc 
        shr  wc,log_cfp_b                       ; convert to words} btw wc  
        shr  wc,1                               ; get j/2} rsh wc 1 
        sal  wc,log_cfp_b                       ; convert back to bytes} wtb wc  
        add  xl,wa                              ; point to a(j)} add xl wa 
        add  xr,wc                              ; adrs of a(j/2)} add xr wc 
        mov  w0,m_word [xl]                     ; a(j/2) = a(j)} mov (xr) (xl) 
        mov  m_word [xr],w0                     ; 
        mov  wc,wa                              ; recover j} mov wc wa 
        add  wc,wc                              ; j = j*2. done if too big} aov wc wc srh03
        jc   srh03                              ; 
        jmp  srh01                              ; loop} brn srh01  
srh03:
        shr  wc,log_cfp_b                       ; convert to words} btw wc  
        shr  wc,1                               ; j = j/2} rsh wc 1 
        sal  wc,log_cfp_b                       ; convert back to bytes} wtb wc  
        mov  xr,m_word [xs]                     ; sort array adrs} mov xr (xs) 
        add  xr,m_word [srtso]                  ; adrs of a(0)} add xr srtso 
        add  xr,wc                              ; adrs of a(j/2)} add xr wc 
        mov  w0,m_word [srtrt]                  ; a(j/2) = root} mov (xr) srtrt 
        mov  m_word [xr],w0                     ; 
        mov  wa,m_word [srtsn]                  ; restore wa} mov wa srtsn 
        mov  wc,m_word [srtwc]                  ; restore wc} mov wc srtwc 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*16]          ; 
        jmp  w0                                 ; 
                                                ; end procedure sorth} enp   
trace:
        pop  m_word [prc_+cfp_b*17]             ; entry point} prc n 2 
        call gtstg                              ; get trace type string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_281                           ; 
        dec  m_word [_rc_]                      ; jump if not string} ppm trc15  
        jns  _l0534                             ; 
        jmp  trc15                              ; 
_l0534:                                         ; 
call_281:                                       ; 
        add  xr,cfp_f                           ; else point to string} plc xr  
        xor  w0,w0                              ; load first character} lch wa (xr) 
        mov  al,m_char [xr]                     ; 
        mov  wa,w0                              ; 
        cmp  cl,'A'                             ; fold to lower case} flc wa  
        jb   _l0535                             ; 
        cmp  cl,'Z'                             ; 
        ja   _l0535                             ; 
        add  cl,32                              ; 
_l0535             :                            ; 
        mov  xr,m_word [xs]                     ; load name argument} mov xr (xs) 
        mov  m_word [xs],xl                     ; stack trblk ptr or zero} mov (xs) xl 
        mov  wc,trtac                           ; set trtyp for access trace} mov wc =trtac 
        cmp  wa,ch_la                           ; jump if a (access)} beq wa =ch_la trc10
        je   trc10                              ; 
        mov  wc,trtvl                           ; set trtyp for value trace} mov wc =trtvl 
        cmp  wa,ch_lv                           ; jump if v (value)} beq wa =ch_lv trc10
        je   trc10                              ; 
        cmp  wa,ch_bl                           ; jump if blank (value)} beq wa =ch_bl trc10
        je   trc10                              ; 
        cmp  wa,ch_lf                           ; jump if f (function)} beq wa =ch_lf trc01
        je   trc01                              ; 
        cmp  wa,ch_lr                           ; jump if r (return)} beq wa =ch_lr trc01
        je   trc01                              ; 
        cmp  wa,ch_ll                           ; jump if l (label)} beq wa =ch_ll trc03
        je   trc03                              ; 
        cmp  wa,ch_lk                           ; jump if k (keyword)} beq wa =ch_lk trc06
        je   trc06                              ; 
        cmp  wa,ch_lc                           ; else error if not c (call)} bne wa =ch_lc trc15
        jne  trc15                              ; 
trc01:
        call gtnvr                              ; point to vrblk for name} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_282                           ; 
        dec  m_word [_rc_]                      ; jump if bad name} ppm trc16  
        jns  _l0536                             ; 
        jmp  trc16                              ; 
_l0536:                                         ; 
call_282:                                       ; 
        add  xs,cfp_b                           ; pop stack} ica xs  
        mov  xr,m_word [(cfp_b*vrfnc)+xr]       ; point to function block} mov xr vrfnc(xr) 
        cmp  m_word [xr],b_pfc                  ; error if not program function} bne (xr) =b_pfc trc17
        jne  trc17                              ; 
        cmp  wa,ch_lr                           ; jump if r (return)} beq wa =ch_lr trc02
        je   trc02                              ; 
        mov  m_word [(cfp_b*pfctr)+xr],xl       ; set/reset call trace} mov pfctr(xr) xl 
        cmp  wa,ch_lc                           ; exit with null if c (call)} beq wa =ch_lc exnul
        je   exnul                              ; 
trc02:
        mov  m_word [(cfp_b*pfrtr)+xr],xl       ; set/reset return trace} mov pfrtr(xr) xl 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc03:
        call gtnvr                              ; point to vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_283                           ; 
        dec  m_word [_rc_]                      ; jump if bad name} ppm trc16  
        jns  _l0537                             ; 
        jmp  trc16                              ; 
_l0537:                                         ; 
call_283:                                       ; 
        mov  xl,m_word [(cfp_b*vrlbl)+xr]       ; load label pointer} mov xl vrlbl(xr) 
        cmp  m_word [xl],b_trt                  ; jump if no old trace} bne (xl) =b_trt trc04
        jne  trc04                              ; 
        mov  xl,m_word [(cfp_b*trlbl)+xl]       ; else delete old trace association} mov xl trlbl(xl) 
trc04:
        cmp  xl,stndl                           ; error if undefined label} beq xl =stndl trc16
        je   trc16                              ; 
        pop  wb                                 ; get trblk ptr again} mov wb (xs)+ 
        test wb,wb                              ; jump if stoptr case} bze wb trc05 
        jz   trc05                              ; 
        mov  m_word [(cfp_b*vrlbl)+xr],wb       ; else set new trblk pointer} mov vrlbl(xr) wb 
        mov  m_word [(cfp_b*vrtra)+xr],b_vrt    ; set label trace routine address} mov vrtra(xr) =b_vrt 
        mov  xr,wb                              ; copy trblk pointer} mov xr wb 
        mov  m_word [(cfp_b*trlbl)+xr],xl       ; store real label in trblk} mov trlbl(xr) xl 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc05:
        mov  m_word [(cfp_b*vrlbl)+xr],xl       ; store label ptr back in vrblk} mov vrlbl(xr) xl 
        mov  m_word [(cfp_b*vrtra)+xr],b_vrg    ; store normal transfer address} mov vrtra(xr) =b_vrg 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc06:
        call gtnvr                              ; point to vrblk} jsr gtnvr  
        dec  m_word [_rc_]                      ; 
        js   call_284                           ; 
        dec  m_word [_rc_]                      ; error if not natural var} ppm trc16  
        jns  _l0538                             ; 
        jmp  trc16                              ; 
_l0538:                                         ; 
call_284:                                       ; 
        cmp  m_word [(cfp_b*vrlen)+xr],0        ; error if not system var} bnz vrlen(xr) trc16 
        jnz  trc16                              ; 
        add  xs,cfp_b                           ; pop stack} ica xs  
        test xl,xl                              ; jump if stoptr case} bze xl trc07 
        jz   trc07                              ; 
        mov  m_word [(cfp_b*trkvr)+xl],xr       ; store vrblk ptr in trblk for ktrex} mov trkvr(xl) xr 
trc07:
        mov  xr,m_word [(cfp_b*vrsvp)+xr]       ; point to svblk} mov xr vrsvp(xr) 
        cmp  xr,v_ert                           ; jump if errtype} beq xr =v_ert trc08
        je   trc08                              ; 
        cmp  xr,v_stc                           ; jump if stcount} beq xr =v_stc trc09
        je   trc09                              ; 
        cmp  xr,v_fnc                           ; else error if not fnclevel} bne xr =v_fnc trc17
        jne  trc17                              ; 
        mov  m_word [r_fnc],xl                  ; set/reset fnclevel trace} mov r_fnc xl 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc08:
        mov  m_word [r_ert],xl                  ; set/reset errtype trace} mov r_ert xl 
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc09:
        mov  m_word [r_stc],xl                  ; set/reset stcount trace} mov r_stc xl 
        call stgcc                              ; update countdown counters} jsr stgcc  
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc10:
        call gtvar                              ; locate variable} jsr gtvar  
        dec  m_word [_rc_]                      ; 
        js   call_285                           ; 
        dec  m_word [_rc_]                      ; error if not appropriate name} ppm trc16  
        jns  _l0539                             ; 
        jmp  trc16                              ; 
_l0539:                                         ; 
call_285:                                       ; 
        pop  wb                                 ; get new trblk ptr again} mov wb (xs)+ 
        add  wa,xl                              ; point to variable location} add wa xl 
        mov  xr,wa                              ; copy variable pointer} mov xr wa 
trc11:
        mov  xl,m_word [xr]                     ; point to next entry} mov xl (xr) 
        cmp  m_word [xl],b_trt                  ; jump if not trblk} bne (xl) =b_trt trc13
        jne  trc13                              ; 
        cmp  wc,m_word [(cfp_b*trtyp)+xl]       ; jump if too far out on chain} blt wc trtyp(xl) trc13
        jb   trc13                              ; 
        cmp  wc,m_word [(cfp_b*trtyp)+xl]       ; jump if this matches our type} beq wc trtyp(xl) trc12
        je   trc12                              ; 
        add  xl,cfp_b*trnxt                     ; else point to link field} add xl *trnxt 
        mov  xr,xl                              ; copy pointer} mov xr xl 
        jmp  trc11                              ; and loop back} brn trc11  
trc12:
        mov  xl,m_word [(cfp_b*trnxt)+xl]       ; get ptr to next block or value} mov xl trnxt(xl) 
        mov  m_word [xr],xl                     ; store to delete this trblk} mov (xr) xl 
trc13:
        test wb,wb                              ; jump if stoptr case} bze wb trc14 
        jz   trc14                              ; 
        mov  m_word [xr],wb                     ; else link new trblk in} mov (xr) wb 
        mov  xr,wb                              ; copy trblk pointer} mov xr wb 
        mov  m_word [(cfp_b*trnxt)+xr],xl       ; store forward pointer} mov trnxt(xr) xl 
        mov  m_word [(cfp_b*trtyp)+xr],wc       ; store appropriate trap type code} mov trtyp(xr) wc 
trc14:
        mov  xr,wa                              ; recall possible vrblk pointer} mov xr wa 
        sub  xr,cfp_b*vrval                     ; point back to vrblk} sub xr *vrval 
        call setvr                              ; set fields if vrblk} jsr setvr  
        mov  m_word [_rc_],0                    ; return} exi   
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc15:
        mov  m_word [_rc_],2                    ; take bad trace type error exit} exi 2  
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
trc16:
        add  xs,cfp_b                           ; pop stack} ica xs  
trc17:
        mov  m_word [_rc_],1                    ; take bad name error exit} exi 1  
        mov  w0,m_word [prc_+cfp_b*17]          ; 
        jmp  w0                                 ; 
                                                ; end procedure trace} enp   
trbld:
                                                ; entry point} prc e 0 
        push xr                                 ; stack trtag (or trfnm)} mov -(xs) xr 
        mov  wa,cfp_b*trsi_                     ; set size of trblk} mov wa *trsi_ 
        call alloc                              ; allocate trblk} jsr alloc  
        mov  m_word [xr],b_trt                  ; store first word} mov (xr) =b_trt 
        mov  m_word [(cfp_b*trfnc)+xr],xl       ; store trfnc (or trfpt)} mov trfnc(xr) xl 
        pop  m_word [(cfp_b*trtag)+xr]          ; store trtag (or trfnm)} mov trtag(xr) (xs)+ 
        mov  m_word [(cfp_b*trtyp)+xr],wb       ; store type} mov trtyp(xr) wb 
        mov  m_word [(cfp_b*trval)+xr],nulls    ; for now, a null value} mov trval(xr) =nulls 
        ret                                     ; return to caller} exi   
                                                ; end procedure trbld} enp   
trimr:
                                                ; entry point} prc e 0 
        mov  xl,xr                              ; copy string pointer} mov xl xr 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; load string length} mov wa sclen(xr) 
        test wa,wa                              ; jump if null input} bze wa trim2 
        jz   trim2                              ; 
        lea  xl,[cfp_f+xl+wa]                   ; else point past last character} plc xl wa 
        test wb,wb                              ; jump if no trim} bze wb trim3 
        jz   trim3                              ; 
        mov  wc,ch_bl                           ; load blank character} mov wc =ch_bl 
trim0:
        dec  xl                                 ; load next character} lch wb -(xl) 
        xor  w0,w0                              ; 
        mov  al,m_char [xl]                     ; 
        mov  wb,w0                              ; 
        cmp  wb,ch_ht                           ; jump if horizontal tab} beq wb =ch_ht trim1
        je   trim1                              ; 
        cmp  wb,wc                              ; jump if non-blank found} bne wb wc trim3
        jne  trim3                              ; 
trim1:
        dec  wa                                 ; else decrement character count} dcv wa  
        test wa,wa                              ; loop back if more to check} bnz wa trim0 
        jnz  trim0                              ; 
trim2:
        mov  m_word [dnamp],xr                  ; wipe out input string block} mov dnamp xr 
        mov  xr,nulls                           ; load null result} mov xr =nulls 
        jmp  trim5                              ; merge to exit} brn trim5  
trim3:
        mov  m_word [(cfp_b*sclen)+xr],wa       ; set new length} mov sclen(xr) wa 
        mov  xl,xr                              ; copy string pointer} mov xl xr 
        lea  xl,[cfp_f+xl+wa]                   ; ready for storing blanks} psc xl wa 
        add  wa,(cfp_b-1)+cfp_b*schar           ; get length of block in bytes} ctb wa schar 
        and  wa,-cfp_b                          ; 
        add  wa,xr                              ; point past new block} add wa xr 
        mov  m_word [dnamp],wa                  ; set new top of storage pointer} mov dnamp wa 
        mov  wa,cfp_c                           ; get count of chars in word} lct wa =cfp_c 
        xor  wc,wc                              ; set zero char} zer wc  
trim4:
        mov  m_char [xl],dl                     ; store zero character} sch wc (xl)+ 
        inc  xl                                 ; 
        dec  wa                                 ; loop back till all stored} bct wa trim4 
        jnz  trim4                              ; 
trim5:
        xor  xl,xl                              ; clear garbage xl pointer} zer xl  
        ret                                     ; return to caller} exi   
                                                ; end procedure trimr} enp   
trxeq:
                                                ; entry point (recursive)} prc r 0 
        mov  wc,m_word [r_cod]                  ; load code block pointer} mov wc r_cod 
        mov  wb,r13                             ; get current code pointer} scp wb  
        sub  wb,wc                              ; make code pointer into offset} sub wb wc 
        push m_word [kvtra]                     ; stack trace keyword value} mov -(xs) kvtra 
        push xr                                 ; stack trblk pointer} mov -(xs) xr 
        push xl                                 ; stack name base} mov -(xs) xl 
        push wa                                 ; stack name offset} mov -(xs) wa 
        push wc                                 ; stack code block pointer} mov -(xs) wc 
        push wb                                 ; stack code pointer offset} mov -(xs) wb 
        push m_word [flptr]                     ; stack old failure pointer} mov -(xs) flptr 
        push 0                                  ; set dummy fail offset} zer -(xs)  
        mov  m_word [flptr],xs                  ; set new failure pointer} mov flptr xs 
        xor  w0,w0                              ; reset trace keyword to zero} zer kvtra  
        mov  m_word [kvtra],w0                  ; 
        mov  wc,trxdc                           ; load new (dummy) code blk pointer} mov wc =trxdc 
        mov  m_word [r_cod],wc                  ; set as code block pointer} mov r_cod wc 
        mov  r13,wc                             ; and new code pointer} lcp wc  
        mov  wb,wa                              ; save name offset} mov wb wa 
        mov  wa,cfp_b*nmsi_                     ; load nmblk size} mov wa *nmsi_ 
        call alloc                              ; allocate space for nmblk} jsr alloc  
        mov  m_word [xr],b_nml                  ; set type word} mov (xr) =b_nml 
        mov  m_word [(cfp_b*nmbas)+xr],xl       ; store name base} mov nmbas(xr) xl 
        mov  m_word [(cfp_b*nmofs)+xr],wb       ; store name offset} mov nmofs(xr) wb 
        mov  xl,m_word [(cfp_b*6)+xs]           ; reload pointer to trblk} mov xl 6(xs) 
        push xr                                 ; stack nmblk pointer (1st argument)} mov -(xs) xr 
        push m_word [(cfp_b*trtag)+xl]          ; stack trace tag (2nd argument)} mov -(xs) trtag(xl) 
        mov  xl,m_word [(cfp_b*trfnc)+xl]       ; load trace vrblk pointer} mov xl trfnc(xl) 
        mov  xl,m_word [(cfp_b*vrfnc)+xl]       ; load trace function pointer} mov xl vrfnc(xl) 
        cmp  xl,stndf                           ; jump if not a defined function} beq xl =stndf trxq2
        je   trxq2                              ; 
        mov  wa,num02                           ; set number of arguments to two} mov wa =num02 
        jmp  cfunc                              ; jump to call function} brn cfunc  
trxq1:
        mov  xs,m_word [flptr]                  ; point back to our stack entries} mov xs flptr 
        add  xs,cfp_b                           ; pop off garbage fail offset} ica xs  
        pop  m_word [flptr]                     ; restore old failure pointer} mov flptr (xs)+ 
        pop  wb                                 ; reload code offset} mov wb (xs)+ 
        pop  wc                                 ; load old code base pointer} mov wc (xs)+ 
        mov  xr,wc                              ; copy cdblk pointer} mov xr wc 
        mov  w0,m_word [(cfp_b*cdstm)+xr]       ; restore stmnt no} mov kvstn cdstm(xr) 
        mov  m_word [kvstn],w0                  ; 
        pop  wa                                 ; reload name offset} mov wa (xs)+ 
        pop  xl                                 ; reload name base} mov xl (xs)+ 
        pop  xr                                 ; reload trblk pointer} mov xr (xs)+ 
        pop  m_word [kvtra]                     ; restore trace keyword value} mov kvtra (xs)+ 
        add  wb,wc                              ; recompute absolute code pointer} add wb wc 
        mov  r13,wb                             ; restore code pointer} lcp wb  
        mov  m_word [r_cod],wc                  ; and code block pointer} mov r_cod wc 
        ret                                     ; return to trxeq caller} exi   
trxq2:
        mov  m_word [_rc_],197                  ; } erb 197 trace fourth arg is not function name or null 
        jmp  err_                               ; 
                                                ; end procedure trxeq} enp   
xscan:
                                                ; entry point} prc e 0 
        mov  m_word [xscwb],wb                  ; preserve wb} mov xscwb wb 
        push wa                                 ; record blank skip flag} mov -(xs) wa 
        push wa                                 ; and second copy} mov -(xs) wa 
        mov  xr,m_word [r_xsc]                  ; point to argument string} mov xr r_xsc 
        mov  wa,m_word [(cfp_b*sclen)+xr]       ; load string length} mov wa sclen(xr) 
        mov  wb,m_word [xsofs]                  ; load current offset} mov wb xsofs 
        sub  wa,wb                              ; get number of remaining characters} sub wa wb 
        test wa,wa                              ; jump if no characters left} bze wa xscn3 
        jz   xscn3                              ; 
        lea  xr,[cfp_f+xr+wb]                   ; point to current character} plc xr wb 
xscn1:
        xor  w0,w0                              ; load next character} lch wb (xr)+ 
        mov  al,m_char [xr]                     ; 
        mov  wb,w0                              ; 
        inc  xr                                 ; 
        cmp  wb,wc                              ; jump if delimiter one found} beq wb wc xscn4
        je   xscn4                              ; 
        cmp  wb,xl                              ; jump if delimiter two found} beq wb xl xscn5
        je   xscn5                              ; 
        cmp  m_word [xs],0                      ; jump if not skipping blanks} bze (xs) xscn2 
        jz   xscn2                              ; 
        inc  m_word [xsofs]                     ; assume blank and delete it} icv xsofs  
        cmp  wb,ch_ht                           ; jump if horizontal tab} beq wb =ch_ht xscn2
        je   xscn2                              ; 
        cmp  wb,ch_bl                           ; jump if blank} beq wb =ch_bl xscn2
        je   xscn2                              ; 
        dec  m_word [xsofs]                     ; undelete non-blank character} dcv xsofs  
        xor  w0,w0                              ; and discontinue blank checking} zer (xs)  
        mov  m_word [xs],w0                     ; 
xscn2:
        dec  wa                                 ; decrement count of chars left} dcv wa  
        test wa,wa                              ; loop back if more chars to go} bnz wa xscn1 
        jnz  xscn1                              ; 
xscn3:
        mov  xl,m_word [r_xsc]                  ; point to string block} mov xl r_xsc 
        mov  wa,m_word [(cfp_b*sclen)+xl]       ; get string length} mov wa sclen(xl) 
        mov  wb,m_word [xsofs]                  ; load offset} mov wb xsofs 
        sub  wa,wb                              ; get substring length} sub wa wb 
        xor  w0,w0                              ; clear string ptr for collector} zer r_xsc  
        mov  m_word [r_xsc],w0                  ; 
        xor  w0,w0                              ; set zero (runout) return code} zer xscrt  
        mov  m_word [xscrt],w0                  ; 
        jmp  xscn7                              ; jump to exit} brn xscn7  
xscn4:
        mov  m_word [xscrt],num01               ; set return code} mov xscrt =num01 
        jmp  xscn6                              ; jump to merge} brn xscn6  
xscn5:
        mov  m_word [xscrt],num02               ; set return code} mov xscrt =num02 
xscn6:
        mov  xl,m_word [r_xsc]                  ; reload pointer to string} mov xl r_xsc 
        mov  wc,m_word [(cfp_b*sclen)+xl]       ; get original length of string} mov wc sclen(xl) 
        sub  wc,wa                              ; minus chars left = chars scanned} sub wc wa 
        mov  wa,wc                              ; move to reg for sbstr} mov wa wc 
        mov  wb,m_word [xsofs]                  ; set offset} mov wb xsofs 
        sub  wa,wb                              ; compute length for sbstr} sub wa wb 
        inc  wc                                 ; adjust new cursor past delimiter} icv wc  
        mov  m_word [xsofs],wc                  ; store new offset} mov xsofs wc 
xscn7:
        xor  xr,xr                              ; clear garbage character ptr in xr} zer xr  
        call sbstr                              ; build sub-string} jsr sbstr  
        add  xs,cfp_b                           ; remove copy of blank flag} ica xs  
        pop  wb                                 ; original blank skip/trim flag} mov wb (xs)+ 
        cmp  m_word [(cfp_b*sclen)+xr],0        ; cannot trim the null string} bze sclen(xr) xscn8 
        jz   xscn8                              ; 
        call trimr                              ; trim trailing blanks if requested} jsr trimr  
xscn8:
        mov  wa,m_word [xscrt]                  ; load return code} mov wa xscrt 
        mov  wb,m_word [xscwb]                  ; restore wb} mov wb xscwb 
        ret                                     ; return to xscan caller} exi   
                                                ; end procedure xscan} enp   
xscni:
        pop  m_word [prc_+cfp_b*18]             ; entry point} prc n 2 
        call gtstg                              ; fetch argument as string} jsr gtstg  
        dec  m_word [_rc_]                      ; 
        js   call_286                           ; 
        dec  m_word [_rc_]                      ; jump if not convertible} ppm xsci1  
        jns  _l0540                             ; 
        jmp  xsci1                              ; 
_l0540:                                         ; 
call_286:                                       ; 
        mov  m_word [r_xsc],xr                  ; else store scblk ptr for xscan} mov r_xsc xr 
        xor  w0,w0                              ; set offset to zero} zer xsofs  
        mov  m_word [xsofs],w0                  ; 
        test wa,wa                              ; jump if null string} bze wa xsci2 
        jz   xsci2                              ; 
        mov  m_word [_rc_],0                    ; return to xscni caller} exi   
        mov  w0,m_word [prc_+cfp_b*18]          ; 
        jmp  w0                                 ; 
xsci1:
        mov  m_word [_rc_],1                    ; take not-string error exit} exi 1  
        mov  w0,m_word [prc_+cfp_b*18]          ; 
        jmp  w0                                 ; 
xsci2:
        mov  m_word [_rc_],2                    ; take null-string error exit} exi 2  
        mov  w0,m_word [prc_+cfp_b*18]          ; 
        jmp  w0                                 ; 
                                                ; end procedure xscni} enp   
                                                ; start of stack overflow section} sec   
        global sec06                            ; 
sec06:  nop                                     ; 
        add  m_word [errft],num04               ; force conclusive fatal error} add errft =num04 
        mov  xs,m_word [flptr]                  ; pop stack to avoid more fails} mov xs flptr 
        cmp  m_word [gbcfl],0                   ; jump if garbage collecting} bnz gbcfl stak1 
        jnz  stak1                              ; 
        mov  m_word [_rc_],246                  ; } erb 246 stack overflow 
        jmp  err_                               ; 
stak1:
        mov  xr,endso                           ; point to message} mov xr =endso 
        xor  w0,w0                              ; memory is undumpable} zer kvdmp  
        mov  m_word [kvdmp],w0                  ; 
        jmp  stopr                              ; give up} brn stopr  
                                                ; start of error section} sec   
        global sec07                            ; 
sec07:                                          ; 
err_:   xchg wa,m_word [_rc_]                   ; 
error:
        cmp  m_word [r_cim],cmlab               ; jump if error in scanning label} beq r_cim =cmlab cmple
        je   cmple                              ; 
        mov  m_word [kvert],wa                  ; save error code} mov kvert wa 
        xor  w0,w0                              ; reset rescan switch for scane} zer scnrs  
        mov  m_word [scnrs],w0                  ; 
        xor  w0,w0                              ; reset goto switch for scane} zer scngo  
        mov  m_word [scngo],w0                  ; 
        mov  m_word [polcs],num01               ; reset poll count} mov polcs =num01 
        mov  m_word [polct],num01               ; reset poll count} mov polct =num01 
        mov  xr,m_word [stage]                  ; load current stage} mov xr stage 
        jmp  m_word [_l0541+xr*cfp_b]           ; jump to appropriate error circuit} bsw xr stgno 
        segment .data                           ; 
_l0541:                                         ; 
        d_word err01                            ; initial compile} iff stgic err01 
        d_word err04                            ; execute time compile} iff stgxc err04 
        d_word err04                            ; eval compiling expr.} iff stgev err04 
        d_word err05                            ; execute time} iff stgxt err05 
        d_word err01                            ; compile - after end} iff stgce err01 
        d_word err04                            ; xeq compile-past end} iff stgxe err04 
        d_word err04                            ; eval evaluating expr} iff stgee err04 
        segment .text                           ; end switch on error type} esw   
err01:
        mov  xs,m_word [cmpxs]                  ; reset stack pointer} mov xs cmpxs 
                                                ; restore s-r stack ptr for cmpil} ssl cmpss  
        cmp  m_word [errsp],0                   ; jump if error suppress flag set} bnz errsp err03 
        jnz  err03                              ; 
        mov  wc,m_word [cmpsn]                  ; current statement} mov wc cmpsn 
        call filnm                              ; obtain file name for this statement} jsr filnm  
        mov  wb,m_word [scnse]                  ; column number} mov wb scnse 
        mov  wc,m_word [rdcln]                  ; line number} mov wc rdcln 
        mov  xr,m_word [stage]                  ; } mov xr stage 
        call sysea                              ; advise system of error} jsr sysea  
        dec  m_word [_rc_]                      ; 
        js   call_287                           ; 
        dec  m_word [_rc_]                      ; if system does not want print} ppm erra3  
        jns  _l0542                             ; 
        jmp  erra3                              ; 
_l0542:                                         ; 
call_287:                                       ; 
        push xr                                 ; save any provided print message} mov -(xs) xr 
        mov  w0,m_word [erich]                  ; set flag for listr} mov erlst erich 
        mov  m_word [erlst],w0                  ; 
        call listr                              ; list line} jsr listr  
        call prtis                              ; terminate listing} jsr prtis  
        xor  w0,w0                              ; clear listr flag} zer erlst  
        mov  m_word [erlst],w0                  ; 
        mov  wa,m_word [scnse]                  ; load scan element offset} mov wa scnse 
        test wa,wa                              ; skip if not set} bze wa err02 
        jz   err02                              ; 
        mov  wb,wa                              ; loop counter} lct wb wa 
        inc  wa                                 ; increase for ch_ex} icv wa  
        mov  xl,m_word [r_cim]                  ; point to bad statement} mov xl r_cim 
        call alocs                              ; string block for error flag} jsr alocs  
        mov  wa,xr                              ; remember string ptr} mov wa xr 
        add  xr,cfp_f                           ; ready for character storing} psc xr  
        add  xl,cfp_f                           ; ready to get chars} plc xl  
erra1:
        xor  w0,w0                              ; get next char} lch wc (xl)+ 
        mov  al,m_char [xl]                     ; 
        mov  wc,w0                              ; 
        inc  xl                                 ; 
        cmp  wc,ch_ht                           ; skip if tab} beq wc =ch_ht erra2
        je   erra2                              ; 
        mov  wc,ch_bl                           ; get a blank} mov wc =ch_bl 
erra2:
        mov  al,dl                              ; store char} sch wc (xr)+ 
        stos_b                                  ; 
        dec  wb                                 ; loop} bct wb erra1 
        jnz  erra1                              ; 
        mov  xl,ch_ex                           ; exclamation mark} mov xl =ch_ex 
        mov  w0,xl                              ; store at end of error line} sch xl (xr) 
        mov  [xr],al                            ; 
        mov  m_word [profs],stnpd               ; allow for statement number} mov profs =stnpd 
        mov  xr,wa                              ; point to error line} mov xr wa 
        call prtst                              ; print error line} jsr prtst  
err02:
        call prtis                              ; print blank line} jsr prtis  
        pop  xr                                 ; restore any sysea message} mov xr (xs)+ 
        test xr,xr                              ; did sysea provide message to print} bze xr erra0 
        jz   erra0                              ; 
        call prtst                              ; print sysea message} jsr prtst  
erra0:
        call ermsg                              ; generate flag and error message} jsr ermsg  
        add  m_word [lstlc],num03               ; bump page ctr for blank, error, blk} add lstlc =num03 
erra3:
        xor  xr,xr                              ; in case of fatal error} zer xr  
        cmp  m_word [errft],num03               ; pack up if several fatals} bhi errft =num03 stopr
        ja   stopr                              ; 
        inc  m_word [cmerc]                     ; bump error count} icv cmerc  
        mov  w0,m_word [cswer]                  ; inhibit xeq if -noerrors} add noxeq cswer 
        add  m_word [noxeq],w0                  ; 
        cmp  m_word [stage],stgic               ; special return if after end line} bne stage =stgic cmp10
        jne  cmp10                              ; 
err03:
        mov  xr,m_word [r_cim]                  ; point to start of image} mov xr r_cim 
        add  xr,cfp_f                           ; point to first char} plc xr  
        xor  w0,w0                              ; get first char} lch xr (xr) 
        mov  al,m_char [xr]                     ; 
        mov  xr,w0                              ; 
        cmp  xr,ch_mn                           ; jump if error in control card} beq xr =ch_mn cmpce
        je   cmpce                              ; 
        xor  w0,w0                              ; clear rescan flag} zer scnrs  
        mov  m_word [scnrs],w0                  ; 
        mov  m_word [errsp],xs                  ; set error suppress flag} mnz errsp  
        call scane                              ; scan next element} jsr scane  
        cmp  xl,t_smc                           ; loop back if not statement end} bne xl =t_smc err03
        jne  err03                              ; 
        xor  w0,w0                              ; clear error suppress flag} zer errsp  
        mov  m_word [errsp],w0                  ; 
        mov  m_word [cwcof],cfp_b*cdcod         ; reset offset in ccblk} mov cwcof *cdcod 
        mov  wa,ocer_                           ; load compile error call} mov wa =ocer_ 
        call cdwrd                              ; generate it} jsr cdwrd  
        mov  w0,m_word [cwcof]                  ; set success fill in offset} mov cmsoc(xs) cwcof 
        mov  m_word [(cfp_b*cmsoc)+xs],w0       ; 
        mov  m_word [(cfp_b*cmffc)+xs],xs       ; set failure fill in flag} mnz cmffc(xs)  
        call cdwrd                              ; generate succ. fill in word} jsr cdwrd  
        jmp  cmpse                              ; merge to generate error as cdfal} brn cmpse  
err04:
        cmp  m_word [errft],num03               ; abort if too many fatal errors} bge errft =num03 labo1
        jae  labo1                              ; 
        cmp  m_word [kvert],nm320               ; treat user interrupt specially} beq kvert =nm320 err06
        je   err06                              ; 
        xor  w0,w0                              ; forget garbage code block} zer r_ccb  
        mov  m_word [r_ccb],w0                  ; 
        mov  m_word [cwcof],cfp_b*cccod         ; set initial offset (mbe catspaw)} mov cwcof *cccod 
                                                ; restore main prog s-r stack ptr} ssl iniss  
        call ertex                              ; get fail message text} jsr ertex  
        sub  xs,cfp_b                           ; ensure stack ok on loop start} dca xs  
erra4:
        add  xs,cfp_b                           ; pop stack} ica xs  
        cmp  xs,m_word [flprt]                  ; jump if prog defined fn call found} beq xs flprt errc4
        je   errc4                              ; 
        cmp  xs,m_word [gtcef]                  ; loop if not eval or code call yet} bne xs gtcef erra4
        jne  erra4                              ; 
        mov  m_word [stage],stgxt               ; re-set stage for execute} mov stage =stgxt 
        mov  w0,m_word [r_gtc]                  ; recover code ptr} mov r_cod r_gtc 
        mov  m_word [r_cod],w0                  ; 
        mov  m_word [flptr],xs                  ; restore fail pointer} mov flptr xs 
        xor  w0,w0                              ; forget possible image} zer r_cim  
        mov  m_word [r_cim],w0                  ; 
        xor  w0,w0                              ; forget possible include} zer cnind  
        mov  m_word [cnind],w0                  ; 
errb4:
        cmp  m_word [kverl],0                   ; jump if errlimit non-zero} bnz kverl err07 
        jnz  err07                              ; 
        jmp  exfal                              ; fail} brn exfal  
errc4:
        mov  xs,m_word [flptr]                  ; restore stack from flptr} mov xs flptr 
        jmp  errb4                              ; merge} brn errb4  
err05:
                                                ; restore main prog s-r stack ptr} ssl iniss  
        cmp  m_word [dmvch],0                   ; jump if in mid-dump} bnz dmvch err08 
        jnz  err08                              ; 
err06:
        cmp  m_word [kverl],0                   ; abort if errlimit is zero} bze kverl labo1 
        jz   labo1                              ; 
        call ertex                              ; get fail message text} jsr ertex  
err07:
        cmp  m_word [errft],num03               ; abort if too many fatal errors} bge errft =num03 labo1
        jae  labo1                              ; 
        dec  m_word [kverl]                     ; decrement errlimit} dcv kverl  
        mov  xl,m_word [r_ert]                  ; load errtype trace pointer} mov xl r_ert 
        call ktrex                              ; generate errtype trace if required} jsr ktrex  
        mov  wa,m_word [r_cod]                  ; get current code block} mov wa r_cod 
        mov  m_word [r_cnt],wa                  ; set cdblk ptr for continuation} mov r_cnt wa 
        mov  wb,r13                             ; current code pointer} scp wb  
        sub  wb,wa                              ; offset within code block} sub wb wa 
        mov  m_word [stxoc],wb                  ; save code ptr offset for scontinue} mov stxoc wb 
        mov  xr,m_word [flptr]                  ; set ptr to failure offset} mov xr flptr 
        mov  w0,m_word [xr]                     ; save failure offset for continue} mov stxof (xr) 
        mov  m_word [stxof],w0                  ; 
        mov  xr,m_word [r_sxc]                  ; load setexit cdblk pointer} mov xr r_sxc 
        test xr,xr                              ; continue if no setexit trap} bze xr lcnt1 
        jz   lcnt1                              ; 
        xor  w0,w0                              ; else reset trap} zer r_sxc  
        mov  m_word [r_sxc],w0                  ; 
        mov  m_word [stxvr],nulls               ; reset setexit arg to null} mov stxvr =nulls 
        mov  xl,m_word [xr]                     ; load ptr to code block routine} mov xl (xr) 
        jmp  xl                                 ; execute first trap statement} bri xl  
err08:
        mov  xr,m_word [dmvch]                  ; chain head for affected vrblks} mov xr dmvch 
        test xr,xr                              ; done if zero} bze xr err06 
        jz   err06                              ; 
        mov  w0,m_word [xr]                     ; set next link as chain head} mov dmvch (xr) 
        mov  m_word [dmvch],w0                  ; 
        call setvr                              ; restore vrget field} jsr setvr  
s_yyy:
        jmp  err08                              ; loop through chain} brn err08  
        section .note.GNU-stack noalloc noexec nowrite progbits; end macro-spitbol assembly} end   
