home *** CD-ROM | disk | FTP | other *** search
/ Freesoft 1999 February / Freesoft_1999-02_cd.bin / Recenz / Emulator / GameBoy / GBBasic / B.ASM next >
Assembly Source File  |  1997-02-15  |  118KB  |  5,950 lines
  1. ;********************************
  2. ;*     Floating-Point Basic     *
  3. ;*             for              *
  4. ;*        Z80 or GameBoy        *
  5. ;********************************
  6.  
  7. ;last edit: 15-Feb-97
  8. ; by Jeff Frohwein
  9.  
  10. percision .equ   6            ;This is the floating percision in digits.
  11.                               ;It should be an even number because the
  12.                               ;floating point routines can't handle odd.
  13.                               ;Increasing it's size increases percision
  14.                               ;but is slower & requires more ram usage.
  15.  
  16. fpsiz   .equ     (percision/2)+2        ;Size in bytes of a fp number
  17. digit   .equ     percision/2            ;fpsiz-2
  18. fpnib   .equ     percision
  19. stesiz  .equ     2+fpsiz      ;symbol table element size
  20. cr      .equ     13           ;carriage return
  21. null    .equ     0            ;null character value
  22. lf      .equ     10           ;line feed
  23. esc     .equ     3            ;escape char
  24. eof     .equ     1            ;end of file
  25. bell    .equ     7            ;bell character
  26. linlen  .equ     80           ;# of chrs in legal input line
  27. opbase  .equ     '('
  28. ftype   .equ     1            ;control stack for entry type
  29. forsz   .equ     fpsiz*2+2+2+1;'for' control stack entry size
  30. gtype   .equ     2            ;control stack gosub entry type
  31. etype   .equ     0            ;control stack underflow type
  32. uminu   .equ    31h           ;unary minus
  33. term    .equ    22h           ; 'prnt' terminator character
  34.  
  35. subit   .equ    2             ;speed up button bit for list
  36. sdbit   .equ    3             ;slow down button bit for list
  37.  
  38. linent  .equ    0eh           ;line number token
  39.  
  40. GBB_RDY .equ    1             ;Input ready command for ext terminal
  41.  
  42. #include "gb.inc"
  43.  
  44. ;    floating point ram
  45. LOBLCK(hold1,digit+1)
  46. LOBLCK(hold2,digit+1)
  47. LOBLCK(hold3,digit+1)
  48. LOBLCK(hold4,digit+1)
  49. LOBLCK(hold5,digit+1)
  50. LOBLCK(hold6,digit+1)
  51. LOBLCK(hold7,digit+1)
  52. LOBLCK(hold8,digit+1)
  53. LOBYTE(nu1)
  54. LOBYTE(erri)                   ;error flag
  55. LOBYTE(nu2)
  56. LOBLCK(buf,digit)              ;working buffer
  57. LOBYTE(sign)                   ;sign bit
  58. LOBYTE(exp)                    ;exponent
  59. LOBYTE(rctrl)                  ;rounding control flag 1=msd
  60. LOBYTE(rdigi)                  ;rounding digit
  61. signd   .equ     hold1+digit
  62. expd    .equ     hold1+digit+1
  63. ;
  64. ;    system ram
  65. ;
  66. LOBYTE(phead)
  67. LOBYTE(reltyp)
  68. LOBYTE(nullct)
  69. LOBYTE(argf)
  70. LOBYTE(dirf)
  71. LOWORD(txa)
  72. cstksz .equ      100
  73. astksz .equ      fpsiz*linlen/2
  74. LOBLCK(cstkl,cstksz)
  75. LOBLCK(astkl,astksz)
  76. LOWORD(rtxa)
  77. LOWORD(cstka)
  78. LOBLCK(sink,fpsiz-1)
  79. LOBLCK(fpsink,fpsiz)
  80. LOBLCK(ftemp,fpsiz)
  81. LOBLCK(ftem1,fpsiz)
  82. LOBLCK(ftem2,fpsiz)
  83. LOBYTE(frand)
  84. LOBYTE(ibcnt)
  85. LOWORD(ibln)
  86. LOBLCK(ibuf,linlen)
  87. LOBLCK(cnsbuf,6)             ;storage for 'cns' output
  88. LOWORD(astka)
  89. LOWORD(adds)
  90. LOWORD(addt)
  91. LOWORD(bcadd)
  92. LOBYTE(opst)
  93. LOBYTE(opstr)
  94. LOBYTE(ecnt)
  95. LOBYTE(fsign)
  96. LOBLCK(bcs,digit+2)
  97. abufsiz .equ digit*2+2
  98. LOBLCK(abuf,abufsiz)
  99. LOBYTE(xsign)
  100. LOBYTE(expo)
  101. LOBYTE(fes)
  102. LOBYTE(infes)
  103. LOWORD(maxl)
  104. LOWORD(insa)
  105. LOBYTE(callRegC)               ;Storage for C reg for USR
  106. LOBYTE(callRegB)               ;Storage for B reg for USR
  107. LOBYTE(callRegE)               ;Storage for E reg for USR
  108. LOBYTE(callRegD)               ;Storage for D reg for USR
  109. LOWORD(miscW1)                 ;temp storage for SAVE,LOAD,LIST, & PFIX
  110.  
  111. ;* Important memory pointers *
  112. MemoryPointers .equ lorambase
  113. LOWORD(bofa)                   ;start of file addr
  114. LOWORD(eofa)                   ;end of file addr
  115. LOWORD(mata)                   ;free memory for upward growing matrixs
  116. LOWORD(stb)                    ;first byte of downward growing variables
  117. LOWORD(memtop)                 ;last assigned memory location
  118.  
  119. memfree .equ lorambase
  120.  
  121. ;Basic Statements Storage Format
  122. ;  byte - Length of line (includes this length)
  123. ;  word - Line number
  124. ;   tokens & data
  125. ;  byte - CR
  126.  
  127. ;Save to backup ram format
  128. ;  byte 'B' - Basic
  129. ;  byte 'F' - File
  130. ;  byte '0' - Format 0
  131. ;  word crc
  132. ;  word length
  133. ;   byte data
  134.  
  135. ;        .org     100h
  136. ;
  137. ;    startup basic system
  138. ;
  139.  
  140. ;#include "gb.inc"
  141.  
  142.         ld      sp,stack
  143.  
  144.         ld      hl,memfree
  145.         ld      a,l
  146.         ld      (bofa),a    ;start of user assigned memory
  147.         ld      a,h
  148.         ld      (bofa+1),a
  149.  
  150.         ld      hl,0dfffh
  151.         ld      a,l
  152.         ld      (memtop),a  ;end of assigned memory pointer
  153.         ld      a,h
  154.         ld      (memtop+1),a
  155.  
  156.         ld      a,l
  157.         ld      (stb),a
  158.         ld      a,h
  159.         ld      (stb+1),a
  160.  
  161.         call    new             ;new program
  162.  
  163.         ld      a,77h           ;turn sound volume up
  164.         ld      (0ff24h),a
  165.  
  166.         xor     a               ;set sound outputs to off
  167.         ld      (0ff25h),a
  168.  
  169.         ld      a,82h           ;turn sound 2 generator on
  170.         ld      (0ff26h),a
  171.  
  172.         ld      a,84h           ;set sound duty
  173.         ld      (0ff16h),a
  174.  
  175.         ld      a,0f0h          ;set envelope
  176.         ld      (0ff17h),a
  177.  
  178.     ld    a,2*fpnib
  179.     ld    (infes),a
  180.  
  181. ; initialize random number
  182.     ld    de,frand
  183.     ld    hl,rands
  184.     call    vcopy         ;frand=random number seed
  185.  
  186.         ld      a,0ah
  187.         ld      (0),a           ;enable sram
  188.  
  189.         ld      a,(0a000h)
  190.         cp      'B'             ;is this file okay?
  191.         jr      nz,sineon       ;no
  192.  
  193.         ld      a,(0a001h)
  194.         cp      'F'             ;is this file okay?
  195.         jr      nz,sineon       ;no
  196.  
  197.         ld      a,(0a002h)
  198.         cp      '0'             ;is this file format 0?
  199.         jr      nz,sineon       ;no
  200.  
  201.         ld      a,(0a006h)
  202.         and     80h             ;is high bit set?
  203.         jr      z,sineon        ;no, don't autoload
  204.  
  205.         call    loadp           ;load file
  206.         call    crun            ;run program
  207.         jr      cmnd0
  208.  
  209. sineon:
  210.         xor     a
  211.         ld      (0),a           ;disable sram
  212.  
  213. ; print sign on message
  214.  
  215.         ld      hl,signon
  216.         call    prnt
  217. ;
  218. ;    command processor
  219. ;
  220. cmnd0:    call    crlf
  221.  
  222. cmnd1:  ld      hl,rdys      ;print 'Ok'
  223.     call    prnt
  224.  
  225.         call    crlf
  226.  
  227. cmndr:  ld      a,1          ;set direct input flag
  228.     ld    (dirf),a
  229.  
  230.         ld      sp,stack
  231.  
  232. cmnd2:
  233. ;       ld      b,GBB_RDY    ;Send input ready char.
  234. ;       call    chout        ;Only needed by external terminal.
  235.  
  236.     call    inline         ;get input line from operator
  237.     ld    hl,ibuf
  238.     ld    a,cr
  239.         cp      (hl)         ;is line blank?
  240.         jr      z,cmnd2      ;yes
  241.  
  242.         call    pp           ;pre-process it
  243.         jr      c,cmnd3
  244.  
  245.     call    line         ;line number..go edit
  246.     call    cclear
  247.         jr      cmnd2
  248.  
  249. cmnd3:
  250.     call    cmnd4
  251.  
  252.         jr      cmnd1
  253.  
  254. cmnd4:    ld    hl,ibuf         ;point to command or statement
  255.         ld      a,l
  256.         ld      (txa),a
  257.         ld      a,h
  258.         ld      (txa+1),a
  259.  
  260. cmnd5:
  261.     call    istat         ;process statement (if allowed)
  262.     call    gci
  263.     cp    ':'
  264.         jr      z,cmnd5
  265.     cp    cr
  266.     ret    z
  267.         jp      e1
  268.  
  269. ;* Error Statements *
  270.  
  271. ermbs:  .byte   "Syntax",term           ;'bs'
  272. ermba:  .byte   "Argument",term         ;'ba'
  273. ermcs:  .byte   "Control Stack",term    ;'cs'
  274. ermdi:  .byte   "Direct input",term     ;'di'
  275. ermob:  .byte   "Out of range",term     ;'ob'
  276. ermof:  .byte   "Overflow",term
  277. ermdm:  .byte   "Duplicate",term        ;'dm'
  278. ermdz:  .byte   "Divide by 0",term
  279. ermfp:  .byte   "Floating point",term   ;'fp'
  280. ermrd:  .byte   "Out of DATA",term      ;'rd'
  281. ermif:  .byte   "Illegal function call",term
  282. ermin:  .byte   "Input",term      ;'in'
  283. ermso:  .byte   "Out of memory",term    ;'so'
  284. ermll:  .byte   "Line too long",term    ;'ll'
  285. ermln:  .byte   "Undefined line number",term
  286.  
  287.  
  288. e1:     ld      hl,ermbs        ; 6273h 'bs'
  289.         jr      error
  290. e3:     ld      hl,ermba        ; 6261h 'ba'
  291.         jr      error
  292. e4:     ld      hl,ermcs        ; 6373h 'cs'
  293.         jr      error
  294. e5:     ld      hl,ermob        ; 6f62h 'ob'
  295.         jr      error
  296. e6:     ld      hl,ermdm        ; 646dh 'dm'
  297.         jr      error
  298. e7:     ld      hl,ermof
  299.  
  300. error:
  301.         push    hl
  302.         call    text_mode       ;set to text mode if not already
  303.         pop     hl
  304.  
  305.         call    prnt
  306.  
  307.     ld    hl,ers
  308. erm1:    call    prnt
  309.     ld    a,(dirf)
  310.     or    a
  311.     jp    nz,cmnd0
  312.  
  313.     ld    hl,ins
  314.     call    prnt
  315.  
  316. ; find line number
  317.         ld      a,(bofa)
  318.         ld      l,a
  319.         ld      a,(bofa+1)
  320.         ld      h,a
  321. erm2:    ld    b,h
  322.     ld    c,l
  323.     ld    e,(hl)
  324.     ld    d,0
  325.     add    hl,de
  326.  
  327.         push    hl
  328.         ld      l,e
  329.         ld      h,d
  330.         pop     de
  331.  
  332.     ld    hl,txa
  333.     call    dcmp
  334.  
  335.         push    hl
  336.         ld      l,e
  337.         ld      h,d
  338.         pop     de
  339.  
  340.     jp    c,erm2
  341.     inc    bc
  342.     ld    a,(bc)
  343.     ld    l,a
  344.     inc    bc
  345.     ld    a,(bc)
  346.     ld    h,a
  347.     ld    de,ibuf         ;use ibuf to accumulate the line line number string
  348.     call    cns
  349.     ld    a,cr
  350.     ld    (de),a
  351.     ld    hl,ibuf
  352.     call    prntcr
  353.     jp    cmnd0
  354. ;
  355. ; line editor
  356. ;
  357. line:   ld      a,(bofa)     ;check for empty file
  358.         ld      l,a
  359.         ld      a,(bofa+1)
  360.         ld      h,a
  361.  
  362. fin:    ld      a,(hl)       ;check if appending line at end
  363.     dec    a
  364.         jr      z,app
  365.  
  366.         push    hl
  367.         ld      l,e
  368.         ld      h,d
  369.         pop     de
  370.  
  371.     inc    de
  372.  
  373.         ld      a,(ibln)     ;get input line number
  374.         ld      l,a
  375.         ld      a,(ibln+1)
  376.         ld      h,a
  377.  
  378.         push    hl
  379.         ld      l,e
  380.         ld      h,d
  381.         pop     de
  382.  
  383.     call    dcmp         ;compare with file line number
  384.     dec    hl
  385.         jr      c,insr       ;less than
  386.         jr      z,insr       ;equal
  387.     ld    a,(hl)         ;length of line
  388.         call    aa2hl        ;jump forward
  389.         jr      fin
  390.  
  391. ; append line at end case
  392. app:    ld    a,(ibcnt)    ;don't append null line
  393.     cp    4
  394.     ret    z
  395.  
  396.     call    full         ;check for room in file
  397.  
  398.         ld      a,(eofa)     ;place line in file
  399.         ld      l,a
  400.         ld      a,(eofa+1)
  401.         ld      h,a
  402.  
  403.     call    imov
  404.     ld    (hl),eof
  405.  
  406.         ld      a,l
  407.         ld      (eofa),a
  408.         ld      a,h
  409.         ld      (eofa+1),a
  410.     ret
  411.  
  412. ; insert line in file case
  413. insr:    ld    b,(hl)         ;old line count
  414.         ld      a,l
  415.         ld      (insa),a     ;insert line pointer
  416.         ld      a,h
  417.         ld      (insa+1),a
  418.     ld    a,(ibcnt)    ;new line count
  419.         jr      c,lt2        ;jmp if new line # not = old line number
  420.         sub     4
  421.         jr      z,lt1        ;test if should delete null line
  422.         add     a,4
  423. lt1:    sub    b
  424.         jr      z,lin1       ;line lengths equal
  425.         jr      c,gt2
  426.  
  427. ; expand file for new or larger line
  428. lt2:    ld    b,a
  429.     ld    a,(ibcnt)
  430.     cp    4         ;don't insert null line
  431.     ret    z
  432.  
  433.     ld    a,b
  434.     call    full
  435.  
  436.         ld      a,(insa)
  437.         ld      l,a
  438.         ld      a,(insa+1)
  439.         ld      h,a
  440.  
  441.     call    nmov
  442.  
  443.         ld      a,(eofa)
  444.         ld      l,a
  445.         ld      a,(eofa+1)
  446.         ld      h,a
  447.  
  448.         push    hl
  449.         ld      l,e
  450.         ld      h,d
  451.         pop     de
  452.  
  453.         ld      a,l
  454.         ld      (eofa),a
  455.         ld      a,h
  456.         ld      (eofa+1),a
  457.  
  458.     inc    bc
  459.     call    rmov
  460.         jr      lin1
  461.  
  462. ; contract file for smaller line
  463. gt2:    cpl    
  464.     inc    a
  465.         call    aa2hl
  466.     call    nmov
  467.  
  468.         push    hl
  469.         ld      l,e
  470.         ld      h,d
  471.         pop     de
  472.  
  473.         ld      a,(insa)
  474.         ld      l,a
  475.         ld      a,(insa+1)
  476.         ld      h,a
  477.  
  478.     call    nz,lmov
  479.     ld    (hl),eof
  480.  
  481.         ld      a,l
  482.         ld      (eofa),a
  483.         ld      a,h
  484.         ld      (eofa+1),a
  485.  
  486. ; insert current line into file
  487. lin1:   ld      a,(insa)
  488.         ld      l,a
  489.         ld      a,(insa+1)
  490.         ld      h,a
  491.  
  492.     ld    a,(ibcnt)
  493.     cp    4
  494.     ret    z
  495.  
  496. ; insert current line at addr hl
  497. imov:    ld    de,ibcnt
  498.     ld    a,(de)
  499.     ld    c,a
  500.     ld    b,0
  501.  
  502. ; copy block from beginning
  503. ; hl is destin addr, de is source addr, bc is count
  504. lmov:    ld    a,(de)
  505.     ld    (hl),a
  506.     inc    de
  507.     inc    hl
  508.     dec    bc
  509.     ld    a,b
  510.     or    c
  511.         jr      nz,lmov
  512.     ret    
  513.  
  514. ; copy block starting at end
  515. ; hl is destin addr, de is source addr, bc is count
  516. rmov:    ld    a,(de)
  517.     ld    (hl),a
  518.     dec    hl
  519.     dec    de
  520.     dec    bc
  521.     ld    a,b
  522.     or    c
  523.         jr      nz,rmov
  524.     ret    
  525.  
  526. ;  compute file move count
  527. ; bc gets (eofa) - (hl), ret z set means zero count
  528. nmov:    ld    a,(eofa)
  529.     sub    l
  530.     ld    c,a
  531.     ld    a,(eofa+1)
  532.         sbc     a,h
  533.     ld    b,a
  534.     or    c
  535.         ret
  536.  
  537. ; add a to hl
  538. aa2hl:
  539.         add     a,l
  540.     ld    l,a
  541.     ret    nc
  542.     inc    h
  543.     ret    
  544.  
  545. ; check for file overflow, leaves new eofa in de
  546. ; a has increase in size
  547. full:   push    af
  548.         ld      a,(eofa)
  549.         ld      l,a
  550.         ld      a,(eofa+1)
  551.         ld      h,a
  552.         pop     af
  553.  
  554.         call    aa2hl
  555.  
  556.         ld      e,l
  557.         ld      d,h
  558.  
  559.     ld    hl,memtop
  560.     call    dcmp
  561.     jp    nc,e8
  562.  
  563.     ret
  564. ;
  565. ;    commands
  566. ;
  567. ;cls:    ld      b,26
  568. ;        jp      chout        ;clear screen
  569.  
  570. ; "new"
  571. new:    ld      a,(bofa)     
  572.         ld      (eofa),a
  573.         ld      l,a
  574.  
  575.         ld      a,(bofa+1)
  576.         ld      (eofa+1),a
  577.         ld      h,a
  578.  
  579.     ld    (hl),eof
  580.  
  581. ; "clear"
  582. cclear: ld      a,(eofa)    ;clear from eofa to memtop
  583.         ld      e,a
  584.         ld      a,(eofa+1)
  585.         ld      d,a
  586.  
  587.         inc     de
  588.  
  589.         ld      a,e
  590.         ld      (mata),a
  591.         ld      a,d
  592.         ld      (mata+1),a
  593.  
  594.     ld    hl,memtop
  595. cclr1:  xor     a
  596.         ld      (de),a
  597.     call    dcmp
  598.     inc    de
  599.         jr      nz,cclr1
  600.  
  601.         ld      a,(memtop)
  602.         ld      l,a
  603.         ld      a,(memtop+1)
  604.         ld      h,a
  605.  
  606.         ld      a,l
  607.         ld      (stb),a
  608.         ld      a,h
  609.         ld      (stb+1),a
  610.  
  611.     ld    hl,cstkl+cstksz-1
  612.     ld    (hl),etype
  613.  
  614.         ld      a,l
  615.         ld      (cstka),a
  616.         ld      a,h
  617.         ld      (cstka+1),a
  618.  
  619.     ld    hl,astkl+astksz+fpsiz-1
  620.         ld      a,l
  621.         ld      (astka),a
  622.         ld      a,h
  623.         ld      (astka+1),a
  624.     ret
  625.  
  626. ; "list"
  627. clist:
  628.         ld      a,1             ;setup list speed
  629.         ld      (miscW1),a
  630.         xor     a
  631.         ld      (miscW1+1),a
  632.  
  633.     ld    de,0
  634.     ld    bc,-1
  635.     call    gc         ;check for parameters
  636.     cp    cr
  637.         jr      z,clst3      ;no parameters
  638.  
  639.         cp      minrw        ;list -X ?
  640.         jr      z,clst1      ;yes
  641.  
  642.         call    intger       ;line number valid?
  643.         jp      c,e1         ;no
  644.  
  645.         ld      e,l          ;first line = hl
  646.         ld      d,h
  647.         ld      c,l          ;last line = hl
  648.         ld      b,h
  649.  
  650.     call    gci
  651.  
  652.         cp      cr              ;Is it just list X?
  653.         jr      z,clst3         ;yes
  654.  
  655.         cp      minrw           ;is it list X-?
  656.     jp    nz,e1
  657.  
  658.         call    gc              ;yes
  659.     ld    bc,-1
  660.         cp      cr              ;is it list X-X?
  661.         jr      z,clst3         ;no
  662.         jr      clst2
  663.  
  664. clst1:    call    gci         ;get rid of char
  665. clst2:    push    de
  666.     call    intger
  667.     pop    de
  668.     jp    c,e1
  669.  
  670.         ld      c,l
  671.         ld      b,h
  672.  
  673. clst3:  ld      a,(bofa)
  674.         ld      l,a
  675.         ld      a,(bofa+1)
  676.         ld      h,a
  677.  
  678. clst4:    ld    a,(hl)
  679.         dec     a               ;is a program present?
  680.         ret     z               ;no, exit
  681.  
  682.     inc    hl
  683.     call    dcmp
  684.     dec    hl         ;point to count char again
  685.         jp      c,clst5
  686.         jp      z,clst5
  687.  
  688. ; inc to next line
  689.     ld    a,(hl)
  690.         call    aa2hl
  691.  
  692.         jr      clst4
  693.  
  694. clst5:
  695.         ld      e,c          ;mark last line to list
  696.         ld      d,b
  697.  
  698. clst6:    inc    hl
  699.     call    dcmp
  700.     dec    hl         ;point to char count
  701.         jr      c,clstx      ;exit
  702.  
  703.     push    de
  704.     ld    de,ibuf         ;area for unprocessing
  705.     call    uppl
  706.     inc    hl
  707.     push    hl
  708.     ld    hl,ibuf
  709.     call    prntcr
  710.     call    crlf
  711.     pop    hl
  712.     pop    de
  713.  
  714.         push    hl
  715.         ld      a,(miscW1)
  716.         ld      l,a
  717.         ld      a,(miscW1+1)
  718.         ld      h,a
  719.  
  720.         call    getbuts
  721.         push    af
  722.         bit     subit,a       ;speed up button pressed?
  723.         jr      z,clst7       ;no
  724.  
  725.         dec     hl
  726.         ld      a,h
  727.         or      l             ;does hl = 1 ?
  728.         inc     hl
  729.         jr      z,clst7       ;yes, already at max speed
  730.  
  731.         srl     h             ;hl=hl/2
  732.         rr      l
  733.         
  734. clst7:
  735.         pop     af
  736.         bit     sdbit,a       ;slow down button pressed?
  737.         jr      z,clst8       ;no
  738.  
  739.         add     hl,hl         ;hl=hl*4
  740.         add     hl,hl
  741. clst8:
  742.         and     BRKBTN
  743.         cp      BRKBTN          ;break pressed?
  744.         jr      z,clst9         ;yes
  745.  
  746.         ld      a,l
  747.         ld      (miscW1),a
  748.         ld      a,h
  749.         ld      (miscW1+1),a
  750.         push    de
  751.         ld      e,l
  752.         ld      d,h
  753.         call    dely1
  754.         pop     de
  755.         pop     hl
  756.  
  757.     ld    a,(hl)
  758.         dec     a               ;end of program?
  759.         jr      nz,clst6        ;not yet
  760. clstx:
  761.     jp    bend
  762. clst9:
  763.         pop     hl
  764.         jr      clstx
  765.  
  766. ;
  767. ;
  768. ; "Locate"
  769. locat:
  770.         call    exprb   ;get y coordinate
  771.         call    pfix
  772.         ld      c,e
  773.         push    bc
  774.  
  775.         ld      b,','
  776.         call    eatc
  777.  
  778.         call    exprb   ;get x coordinate
  779.         call    pfix
  780.  
  781.         pop     bc
  782.         ld      b,e
  783.  
  784.         jp      locate
  785.  
  786. ;
  787. ; "Poke"
  788. poke:
  789.         call    exprb   ;get address
  790.         call    pfix
  791.         push    de
  792.  
  793.         ld      b,','
  794.         call    eatc
  795.  
  796.         call    exprb   ;get data
  797.         call    pfix
  798.  
  799.         ld      a,d
  800.         or      a       ;is data > 255 ?
  801.         jp      nz,e5   ;yes, Out of Range error
  802.  
  803.         ld      a,e
  804.         pop     de
  805.         ld      (de),a  ;write byte
  806.         ret
  807.  
  808. ; "load"
  809. loadp:
  810.         ld      a,0ah
  811.         ld      (0),a           ;enable sram
  812.  
  813.         ld      hl,0a007h
  814.  
  815.         ld      a,(0a005h)
  816.         ld      c,a
  817.         ld      a,(0a006h)
  818.         and     7fh             ;remove auto-run bit
  819.         ld      b,a
  820.  
  821.         call    calccrc         ;file okay?
  822.         jr      c,loaderr       ;no
  823.  
  824.         ld      a,(bofa)
  825.         ld      e,a
  826.         ld      a,(bofa+1)
  827.         ld      d,a
  828.  
  829.         call    move
  830.  
  831.         call    findeof         ;set eofa
  832.  
  833.         xor     a
  834.         ld      (0),a           ;disable ram
  835.  
  836.         jp      cclear
  837.  
  838. loaderr:
  839.         xor     a
  840.         ld      (0),a           ;disable ram
  841.  
  842.         call    ilprc
  843.         .byte   "Corrupt program",0
  844.         ret
  845.  
  846. ; "save"
  847. save:
  848.         ld      a,0ah
  849.         ld      (0),a           ;enable sram
  850.  
  851.         ld      hl,bofa
  852.         ld      de,eofa
  853.         ld      a,(de)
  854.         sub     (hl)
  855.         ld      c,a
  856.         inc     de
  857.         inc     hl
  858.         ld      a,(de)
  859.         sbc     a,(hl)
  860.         ld      b,a
  861.         inc     bc
  862.  
  863.         ld      a,c
  864.         ld      (0a005h),a
  865.         ld      a,b
  866.         ld      (0a006h),a
  867.  
  868.         ld      a,(bofa)
  869.         ld      l,a
  870.         ld      a,(bofa+1)
  871.         ld      h,a
  872.         
  873.         ld      de,0a007h
  874.  
  875.         call    move
  876.  
  877.         ld      a,'B'           ;Basic File indicator
  878.         ld      (0a000h),a
  879.         ld      a,'F'
  880.         ld      (0a001h),a
  881.         ld      a,'0'
  882.         ld      (0a002h),a
  883.  
  884.         ld      a,(miscW1)
  885.         ld      (0a003h),a
  886.         ld      a,(miscW1+1)
  887.         ld      (0a004h),a
  888.  
  889.         xor     a
  890.         ld      (0),a
  891.         ret
  892.  
  893. ;Compare file with it's crc
  894. ;Set carry if no match
  895. calccrc:
  896.         push    bc
  897.         push    hl
  898.         ld      a,(0a000h)
  899.         cp      'B'
  900.         jr      nz,calcc3       ;error
  901.         ld      a,(0a001h)
  902.         cp      'F'
  903.         jr      nz,calcc3       ;error
  904.         ld      a,(0a002h)
  905.         cp      '0'
  906.         jr      nz,calcc3       ;error
  907.  
  908.         ld      de,0
  909. calcc1: ld      a,(hl)
  910.  
  911.         push    hl
  912.         ld      l,a
  913.         ld      h,0
  914.         add     hl,de
  915.         ld      e,l
  916.         ld      d,h
  917.         pop     hl
  918.  
  919.         inc     hl
  920.         dec     bc
  921.         ld      a,b
  922.         or      c
  923.         jr      nz,calcc1
  924.  
  925.         ld      a,(0a003h)
  926.         cp      e               ;does crc check okay?
  927.         jr      nz,calcc3       ;no
  928.         ld      a,(0a004h)
  929.         cp      d               ;does crc check okay?
  930.         jr      nz,calcc3       ;no
  931.         or      a
  932.         jr      calcc4
  933.  
  934. calcc3: scf
  935. calcc4: pop     hl
  936.         pop     bc
  937.         ret
  938.  
  939. ;Move BC bytes from HL to DE
  940. move:   xor     a
  941.         ld      (miscW1),a
  942.         ld      (miscW1+1),a
  943. mov1:   ld      a,(hl)
  944.         ld      (de),a
  945.  
  946.         ld      a,(miscW1)
  947.         add     a,(hl)
  948.         ld      (miscW1),a
  949.         ld      a,(miscW1+1)
  950.         adc     a,0
  951.         ld      (miscW1+1),a
  952.  
  953.         inc     hl
  954.         inc     de
  955.         dec     bc
  956.         ld      a,b
  957.         or      c
  958.         jr      nz,mov1
  959.         ret
  960.  
  961. ; "free"
  962. free:
  963.         ld      a,(mata)        ;Upward growing matrix storage
  964.         ld      l,a
  965.         ld      a,(mata+1)
  966.         ld      h,a
  967.  
  968.         ld      a,(stb)         ;Downward growing variable storage
  969.         sub     l
  970.         ld      l,a
  971.         ld      a,(stb+1)
  972.         sbc     a,h
  973.         ld      h,a
  974.  
  975.         ld      de,cnsbuf
  976.         call    cns
  977.  
  978.         ld      a,term
  979.         ld      (de),a          ;terminate number string
  980.  
  981.         ld      hl,cnsbuf
  982.         call    prnt
  983.  
  984.         call    ilprc
  985.         .byte   " bytes left.",0
  986.         ret
  987.  
  988. ;
  989. ; "on"
  990. ;on:
  991. ;        call    exprb           ;get expression
  992. ;        call    pfix            ;convert to integer
  993. ;        ld      c,e
  994. ;
  995. ;        ld      a,d
  996. ;        or      a               ;is expr > 255?
  997. ;        jp      z,rem           ;yes, ignore rest of line
  998. ;
  999. ;        call    gci
  1000. ;        ld      b,a
  1001. ;        cp      gotorw          ;is it a goto?
  1002. ;        jr      z,on1           ;yes
  1003. ;        cp      gosubrw         ;is it a gosub?
  1004. ;        jp      nz,e1           ;no
  1005. ;
  1006. ;on1:    gln                     ;line number present?
  1007. ;        jp      c,e1            ;no, error
  1008. ;
  1009. ;        dec     c               ;have we got the right line# ?
  1010. ;        jr      z,ondo          ;yes
  1011. ;
  1012. ;        call    gc
  1013. ;        cp      ','             ;comma?
  1014. ;        ret     nz              ;no
  1015. ;
  1016. ;        call    gci
  1017. ;        jr      on1
  1018. ;
  1019. ;ondo:   ld      a,b
  1020. ;        cp      gotorw          ;goto request?
  1021. ;        jp      z,goto1         ;yes
  1022. ;
  1023. ;        
  1024. ;        ld      de,-3        ;create control stack entry
  1025. ;        call    pshcs
  1026. ;        push    hl           ;save stack addr
  1027. ;
  1028. ;        call    gln
  1029. ;        jp      c,e1         ;no line # present
  1030. ;
  1031. ;        ld      e,l          ;line number in de
  1032. ;        ld      d,h
  1033. ;
  1034. ;        call    joe
  1035. ;        ld      b,h
  1036. ;        ld      c,l
  1037. ;        pop     hl           ;stack addr
  1038. ;        ld      (hl),b       ;stack return addr returned by joe
  1039. ;        dec     hl
  1040. ;        ld      (hl),c
  1041. ;        dec     hl
  1042. ;        ld      (hl),gtype   ;make control stack entry type 'gosub'
  1043. ;        call    findln
  1044. ;        inc     hl
  1045. ;        inc     hl
  1046. ;        inc     hl
  1047. ;        jp      next6
  1048.  
  1049. ;
  1050. ; "renum"
  1051. renum:
  1052.  
  1053.         ld      a,(eofa)
  1054.         ld      e,a
  1055.         ld      a,(eofa+1)
  1056.         ld      d,a
  1057.  
  1058.         inc     de
  1059.  
  1060.         ld      a,(bofa)
  1061.         ld      l,a
  1062.         ld      a,(bofa+1)
  1063.         ld      h,a
  1064.  
  1065.     ld    a,(hl)
  1066.         dec     a               ;is there a program to renumber?
  1067.         jp      z,bend          ;no
  1068.  
  1069. ; Build lookup table
  1070. ren0:    ld    a,(hl)
  1071.         dec     a               ;have we reached end of program?
  1072.         jr      z,ren2          ;yes
  1073.  
  1074.     push    hl
  1075.         inc     hl
  1076.     call    lhli
  1077.  
  1078.         push    de
  1079.         inc     de
  1080.         inc     de
  1081.         inc     de
  1082.         inc     de
  1083.  
  1084.         push    hl
  1085.     ld    hl,memtop
  1086.         call    dcmp            ;is table too large?
  1087.         jp      nc,e8           ;yes, out of memory
  1088.  
  1089.         pop     hl
  1090.         pop     de
  1091.  
  1092.     ld    a,l
  1093.     ld    (de),a
  1094.     inc    de
  1095.     ld    a,h
  1096.     ld    (de),a
  1097.     inc    de
  1098.  
  1099.     pop    hl
  1100.  
  1101.     ld    a,(hl)
  1102.         call    aa2hl
  1103.         jr      ren0
  1104.  
  1105. ren2:   xor     a           ;end of table marker
  1106.     ld    (de),a
  1107.     inc    de
  1108.     ld    (de),a
  1109.  
  1110.     ld    bc,10
  1111.  
  1112.         ld      a,(bofa)
  1113.         ld      l,a
  1114.         ld      a,(bofa+1)
  1115.         ld      h,a
  1116.  
  1117. ren3:    ld    a,(hl)
  1118.         dec     a               ;have we renumbered whole program?
  1119.         jp      z,bend          ;yes
  1120.  
  1121.         push    hl
  1122.     inc    hl
  1123.     ld    (hl),c
  1124.     inc    hl
  1125.     ld    (hl),b
  1126.  
  1127. ren4:   inc     hl
  1128.         ld      a,(hl)
  1129.         cp      cr              ;end of line?
  1130.         jr      z,ren9          ;yes
  1131.  
  1132.         cp      linent          ;line number token?
  1133.         jr      nz,ren4         ;no
  1134.  
  1135.         inc     hl
  1136.         ld      e,(hl)
  1137.         inc     hl
  1138.         ld      d,(hl)
  1139.  
  1140.         ld      a,c             ;save line number for errors in conversion
  1141.         ld      (ibuf),a
  1142.         ld      a,b
  1143.         ld      (ibuf+1),a
  1144.  
  1145.         call    cnvtln          ;convert de
  1146.  
  1147.         ld      (hl),d
  1148.         dec     hl
  1149.         ld      (hl),e
  1150.         inc     hl
  1151.         jr      ren4
  1152.  
  1153. ren9:
  1154.         pop     hl
  1155.  
  1156.         ld      a,(hl)
  1157.         call    aa2hl
  1158.  
  1159. ;increment line number by 10
  1160.  
  1161.     ld    a,10
  1162. ren10:  inc     bc
  1163.     dec    a
  1164.         jr      nz,ren10
  1165.  
  1166.         jr      ren3
  1167.  
  1168. ; Convert de from old to new line number
  1169. cnvtln:
  1170.  
  1171.         push    bc
  1172.         push    hl
  1173.  
  1174.         ld      bc,10
  1175.  
  1176.         ld      a,(eofa)
  1177.         ld      l,a
  1178.         ld      a,(eofa+1)
  1179.         ld      h,a
  1180.  
  1181. cnvtl1:
  1182.         inc     hl
  1183.         xor     a
  1184.         cp      (hl)            ;end of table?
  1185.         jr      nz,cnvtl2       ;no
  1186.         inc     hl
  1187.         cp      (hl)
  1188.         dec     hl              ;end of table?
  1189.         jr      z,cnvtl9        ;yes
  1190.  
  1191. cnvtl2:
  1192.         ld      a,e
  1193.         cp      (hl)            ;lsb match?
  1194.         inc     hl
  1195.         jr      nz,cnvtl6       ;no
  1196.         ld      a,d
  1197.         cp      (hl)            ;msb match?
  1198.         jr      nz,cnvtl6       ;no
  1199.  
  1200.         ld      e,c
  1201.         ld      d,b
  1202.         jr      cnvtl8
  1203.  
  1204. cnvtl6:
  1205.     ld    a,10
  1206.  
  1207. cnvt17:
  1208.         inc     bc
  1209.     dec    a
  1210.         jr      nz,cnvt17
  1211.  
  1212.         jr      cnvtl1
  1213.  
  1214. cnvtl8:
  1215.         pop     hl
  1216.         pop     bc
  1217.         ret
  1218.  
  1219. ; Undefined Line Number x in x.
  1220. cnvtl9:
  1221.         push    de
  1222.         push    bc
  1223.         ld      hl,ermln
  1224.         call    prnt
  1225.         call    space
  1226.  
  1227.         ld      l,e
  1228.         ld      h,d
  1229.  
  1230.         ld      de,cnsbuf
  1231.         call    cns
  1232.         ld      a,cr
  1233.         ld      (de),a
  1234.         ld      hl,cnsbuf
  1235.         call    prntcr
  1236.  
  1237.         ld      hl,ins
  1238.         call    prnt
  1239.  
  1240.         ld      a,(ibuf)
  1241.         ld      l,a
  1242.         ld      a,(ibuf+1)
  1243.         ld      h,a
  1244.         ld      de,cnsbuf
  1245.         call    cns
  1246.     ld    a,cr
  1247.     ld    (de),a
  1248.         ld      hl,cnsbuf
  1249.     call    prntcr
  1250.  
  1251.         call    crlf
  1252.  
  1253.         pop     bc
  1254.         pop     de
  1255.         jr      cnvtl8
  1256. ;
  1257. ; "run"
  1258. crun:    call    cclear
  1259.         call    def_color       ;setup default drawing color
  1260.  
  1261.         ld      a,(bofa)
  1262.         ld      l,a
  1263.         ld      a,(bofa+1)
  1264.         ld      h,a
  1265.  
  1266.     ld    a,(hl)
  1267.     dec    a         ;check for null program
  1268.     jp    z,bend
  1269.  
  1270.         call    resto4          ;update rtxa
  1271.  
  1272.         ld      a,l
  1273.         ld      (txa),a
  1274.         ld      a,h
  1275.         ld      (txa+1),a
  1276.  
  1277.     xor    a
  1278.     ld    (dirf),a     ;clear direct flag and fall through to driver
  1279.  
  1280.         jp      iloop
  1281.  
  1282. ; interpret statement located by txa
  1283. istat:    call    gc         ;get first non blank
  1284.     cp    39         ;is it a "'" ?
  1285.     jp    z,rem         ;yes
  1286.  
  1287.         cp      128
  1288.         jp      c,let        ;must be let if not rw
  1289.  
  1290.         cp      irwlin
  1291.         jp      nc,e1        ;this token not allowed initially
  1292.  
  1293.     ld    de,cmndd     ;statement dispatch table base
  1294. ista1:    call    gci         ;advance text pointer
  1295.         and     7fh
  1296.     rlca             ;multiply by two preparing for table lookup
  1297.     ld    l,a
  1298.     ld    h,0
  1299.     add    hl,de
  1300.     call    lhli
  1301.     jp    (hl)         ;branch to statement or command
  1302.  
  1303. ;
  1304. ;    statements
  1305. ;
  1306.  
  1307. ; "let"
  1308. let:
  1309.         call    var          ;check for variable
  1310.         jp      c,e1         ;not found
  1311.  
  1312.     push    hl         ;save value address
  1313.  
  1314.     ld    b,eqrw
  1315.     call    eatc
  1316.  
  1317.     call    exprb
  1318.     pop    de         ;destination address
  1319.         jp      popa1        ;copy expr value to variable
  1320.  
  1321. ; "for"
  1322. sfor:    call    dirt
  1323.     call    var         ;control variable
  1324.         jp      c,e4            ;not found
  1325.  
  1326.     push    hl         ;control variable value address
  1327.     ld    b,eqrw
  1328.     call    eatc
  1329.  
  1330.     call    exprb         ;initial value
  1331.     pop    de         ;variable value address
  1332.     push    de         ;save
  1333.     call    popa1         ;set initial value
  1334.     ld    b,torw         ;rw for 'to'
  1335.     call    eatc
  1336.     call    exprb         ;limit value computation
  1337.     call    gc         ;check next character for possible step
  1338.     cp    steprw
  1339.         jr      z,for1
  1340.  
  1341. ; use step of 1
  1342.     ld    de,fpone
  1343.     call    psha1
  1344.         jr      for2
  1345.  
  1346. ; compute step value
  1347. for1:    call    gci         ;eat the step rw
  1348.     call    exprb         ;the step value
  1349.  
  1350. ; here the step and limit are on arg stack
  1351. for2:    ld    de,-2         ;prepare to allocate 2 bytes on control stack
  1352.     call    pshcs         ;returns address of those 2 bytes in hl
  1353.  
  1354.         push    hl
  1355.         ld      l,e
  1356.         ld      h,d
  1357.         pop     de
  1358.  
  1359.     call    joe         ;test for junk on end
  1360.     jp    c,e4         ;no "for" statement at end of program
  1361.  
  1362.         push    hl           ;de has loop text addr, hl has control stack adr
  1363.         ld      l,e
  1364.         ld      h,d
  1365.         pop     de
  1366.  
  1367.     ld    (hl),d         ;high order text address byte
  1368.     dec    hl
  1369.     ld    (hl),e         ;low   "
  1370.     ld    de,-fpsiz    ;allocate space for limit on control stack
  1371.     call    pshcs
  1372.     push    hl         ;addr on control stack for limit
  1373.     ld    de,-fpsiz    ;allocate space for step on control stack
  1374.     call    pshcs
  1375.     call    popas         ;copy step value to control stack
  1376.     pop    de         ;control stack addr for limit value
  1377.     call    popa1         ;limit value to control stack
  1378.     ld    de,-3         ;allocate space for text addr & cs entry
  1379.     call    pshcs
  1380.     pop    de         ;control variable addr
  1381.     ld    (hl),d         ;high order byte of control variable addr
  1382.     dec    hl
  1383.     ld    (hl),e         ;low   "
  1384.     dec    hl
  1385.     ld    (hl),ftype   ;set control stack entry type for 'for'
  1386.     jp    next5         ;go finish off carefully
  1387.  
  1388. ; "next"
  1389. next:    call    dirt
  1390.  
  1391.         ld      a,(cstka)    ;control stack addr
  1392.         ld      l,a
  1393.         ld      a,(cstka+1)
  1394.         ld      h,a
  1395.  
  1396.     ld    a,(hl)         ;stack entry type byte
  1397.     dec    a         ;must be for type else error
  1398.     jp    nz,e4         ;improper nesting error
  1399.  
  1400.     inc    hl         ;control stack pointer to control var addr
  1401.     push    hl
  1402.     call    var         ;check variable, in case user wants
  1403.         jr      c,next1      ;skip check if var not there
  1404.  
  1405.         push    hl
  1406.         ld      l,e
  1407.         ld      h,d
  1408.         pop     de
  1409.  
  1410.     pop    hl         ;control variable addr
  1411.     push    hl         ;save it again
  1412.     call    dcmp
  1413.     jp    nz,e4         ;improper nesting if not the same
  1414.  
  1415. next1:    pop    hl         ;control variable addr
  1416.     push    hl
  1417.     push    hl
  1418.     ld    de,fpsiz+2-1 ;compute addr to step value
  1419.     add    hl,de
  1420.         EX_SP_HL             ;now addr to var in hl
  1421.     call    lhli         ;var addr
  1422.     ld    b,h         ;copy var addr to bc
  1423.     ld    c,l
  1424.     pop    de         ;step value addr
  1425.     push    de
  1426.     call    fadd         ;do increment
  1427.     pop    hl         ;step value
  1428.     dec    hl         ;point to sign of step value
  1429.     ld    a,(hl)         ;sign 0=pos, 1=neg
  1430.     ld    de,fpsiz+1
  1431.     add    hl,de         ;puts limit addr in hl
  1432.  
  1433.         push    hl
  1434.         ld      l,e
  1435.         ld      h,d
  1436.         pop     de
  1437.  
  1438.     pop    hl         ;var addr
  1439.     call    lhli         ;get addr
  1440.     push    de         ;save control stack pointer to get text address
  1441.     or    a         ;set conditions based on sign of step value
  1442.         jr      z,next2      ;reverse test on negative step value
  1443.  
  1444.         push    hl
  1445.         ld      l,e
  1446.         ld      h,d
  1447.         pop     de
  1448.  
  1449. next2:    ld    b,h         ;set up args for compare
  1450.     ld    c,l
  1451.     call    relop         ;test <=
  1452.     pop    de         ;test addr
  1453.         jr      nc,next3     ;still smaller?
  1454.         jr      z,next3      ;jump if want to continue loop
  1455.  
  1456. ; terminate loop
  1457.     ld    hl,3         ;remove cstack entry
  1458.     add    hl,de
  1459.         ld      a,l
  1460.         ld      (cstka),a
  1461.         ld      a,h
  1462.         ld      (cstka+1),a
  1463.     ret    
  1464.  
  1465. next3:    inc    de         ;test addr
  1466.  
  1467.         push    hl
  1468.         ld      l,e
  1469.         ld      h,d
  1470.         pop     de
  1471.  
  1472.     call    lhli         ;get text address in hl
  1473.  
  1474. ; iterate, skipping normal junk on end test at iloop
  1475. next4:  push    hl           ;save new text addr in de
  1476.         ld      l,e
  1477.         ld      h,d
  1478.         pop     de
  1479.  
  1480.     call    joe
  1481.  
  1482.         push    hl
  1483.         ld      l,e
  1484.         ld      h,d
  1485.         pop     de
  1486.  
  1487. next6:  ld      a,l
  1488.         ld      (txa),a
  1489.         ld      a,h
  1490.         ld      (txa+1),a
  1491. next5:
  1492.         pop     hl
  1493.         jp      iloop        ;to dispatcher skipping joe call there
  1494.  
  1495. ; "if"
  1496. sif:    ld      b,1          ;specify principal operator is relational
  1497.     call    expb1
  1498.  
  1499.         ld      a,(astka)   ;addr of boolean value on arg stack
  1500.         ld      l,a
  1501.         ld      a,(astka+1)
  1502.         ld      h,a
  1503.  
  1504.     inc    (hl)         ;sets zero condition if relational was true
  1505.     push    af         ;save conditions to test later
  1506.     call    popas         ;remove value from arg stack copy to self
  1507.     pop    af
  1508.     jp    nz,rem         ;if test false treat rest of line as rem
  1509.  
  1510. ; test succeeded
  1511.     ld    b,thenrw
  1512.     call    eatc
  1513.  
  1514.         call    gln          ;check if line number is desired action
  1515.         jp      c,istat      ;no, must be a command
  1516.  
  1517.         jr      goto1
  1518.  
  1519. ; "goto"
  1520. sgoto:    xor    a
  1521.     ld    (dirf),a     ;clears direct statement flag
  1522.  
  1523.         call    getbuts      ;break buttons pressed?
  1524.         and     BRKBTN
  1525.         cp      BRKBTN
  1526.         jp      z,iloopb     ;yes
  1527.  
  1528.         call    gln          ;returns integer in hl if line # present
  1529.         jp      c,e1         ;syntax error - no line error
  1530.  
  1531. goto1:  ld      e,l          ;line # in de
  1532.         ld      d,h
  1533.  
  1534.     call    findln         ;returns text address points to count value
  1535. goto2:    inc    hl
  1536.     inc    hl
  1537.     inc    hl         ;advance text pointer past line # and count
  1538.     jp    next4
  1539.  
  1540. ; "gosub"
  1541. gosub:    call    dirt
  1542.     ld    de,-3         ;create control stack entry
  1543.     call    pshcs
  1544.     push    hl         ;save stack addr
  1545.  
  1546.         call    gln
  1547.         jp      c,e1         ;no line # present
  1548.  
  1549.         ld      e,l          ;line number in de
  1550.         ld      d,h
  1551.  
  1552.     call    joe
  1553.     ld    b,h
  1554.     ld    c,l
  1555.     pop    hl         ;stack addr
  1556.     ld    (hl),b         ;stack return addr returned by joe
  1557.     dec    hl
  1558.     ld    (hl),c
  1559.     dec    hl
  1560.     ld    (hl),gtype   ;make control stack entry type 'gosub'
  1561.     call    findln
  1562.     inc    hl
  1563.     inc    hl
  1564.     inc    hl
  1565.     jp    next6
  1566.  
  1567. ; "return"
  1568. retrn:    call    dirt
  1569.     ld    (dirf),a     ;clears dirf if acc is clear
  1570.  
  1571.         ld      a,(cstka)
  1572.         ld      l,a
  1573.         ld      a,(cstka+1)
  1574.         ld      h,a
  1575.  
  1576. ret1:    ld    a,(hl)
  1577.     or    a         ;check for stack empty
  1578.     jp    z,e4
  1579.  
  1580.     cp    gtype         ;check for gosub type
  1581.         jr      z,ret2
  1582.  
  1583. ; remove for type from stack
  1584.     ld    de,forsz
  1585.     add    hl,de
  1586.         jr      ret1
  1587.  
  1588. ; found a gtype stack entry
  1589. ret2:    inc    hl
  1590.     ld    e,(hl)         ;low order text address
  1591.     inc    hl
  1592.     ld    d,(hl)         ;high   "
  1593.     inc    hl         ;addr of previous control stack entry
  1594.  
  1595.         ld      a,l
  1596.         ld      (cstka),a
  1597.         ld      a,h
  1598.         ld      (cstka+1),a
  1599.  
  1600.         push    hl           ;put text addr in hl
  1601.         ld      l,e
  1602.         ld      h,d
  1603.         pop     de
  1604.  
  1605.     ld    a,(hl)         ;addr points to eof if gosub was last line
  1606.     dec    a         ;end of file?
  1607.         jp      nz,next4     ;no
  1608.  
  1609.     jp    bend
  1610.  
  1611. ; "data" and "rem"
  1612. data:    call    dirt         ;data statement illegal as direct
  1613. rem:    call    gci
  1614.     cp    cr
  1615.         jr      nz,rem
  1616.  
  1617. rem1:   dec     hl           ;backup pointer so normal joe will work
  1618.  
  1619.         ld      a,l
  1620.         ld      (txa),a
  1621.         ld      a,h
  1622.         ld      (txa+1),a
  1623.         ret
  1624.  
  1625. ; "dimension"
  1626. dim:    call    name1         ;look for variable name
  1627.         jp      c,e4            ;no variable name error
  1628.  
  1629.         ld      a,c          ;prepare turn on high bit to signify matrix
  1630.         or      80h
  1631.     ld    c,a
  1632.     call    stlk
  1633.     jp    nc,e6         ;error if name already exists
  1634.  
  1635.     push    hl         ;symbol table addr
  1636.     ld    b,lparrw
  1637.     call    eatc
  1638.     call    exprb
  1639.     ld    b,')'
  1640.     call    eatc
  1641.     call    pfix         ;return integer in de
  1642.     ld    hl,matub     ;max size for matrix
  1643.     call    dcmp
  1644.         jp      nc,e6           ;matrix too large error
  1645.  
  1646.     pop    hl         ;symbol table address
  1647.     call    dims
  1648.     call    gc         ;see if more to do
  1649.     cp    ','
  1650.     ret    nz
  1651.  
  1652.     call    gci         ;eat the comma
  1653.         jr      dim
  1654.  
  1655. ; "stop"
  1656. stop:    call    dirt
  1657. ;        call    crlf2
  1658. stop1:  ld      hl,stops
  1659.     jp    erm1
  1660.  
  1661. ; "end"
  1662. bend:   .equ     cmnd1
  1663.  
  1664. ; "read"
  1665. read:    call    dirt
  1666.  
  1667.         ld      a,(txa)
  1668.         ld      l,a
  1669.         ld      a,(txa+1)
  1670.         ld      h,a
  1671.  
  1672.     push    hl         ;save txa temporarily
  1673.         ld      a,(rtxa)     ;the 'read' txa
  1674.         ld      l,a
  1675.         ld      a,(rtxa+1)
  1676.         ld      h,a
  1677.  
  1678. read0:  ld      a,l
  1679.         ld      (txa),a
  1680.         ld      a,h
  1681.         ld      (txa+1),a
  1682.  
  1683.     call    gci
  1684.         cp      ','             ;comma?
  1685.         jr      z,read2         ;yes, process input value
  1686.     cp    datarw
  1687.         jr      z,read2
  1688.         dec     a               ;end of file?
  1689.         jr      z,read4         ;yes
  1690.  
  1691. ; skip to next line
  1692.     call    rem         ;leaves addr to last cr in hl
  1693.     inc    hl
  1694.     ld    a,(hl)
  1695.     dec    a
  1696.         jr      z,read4
  1697.  
  1698.     inc    hl
  1699.     inc    hl
  1700.     inc    hl         ;hl now points to first byte of next line
  1701.         jr      read0
  1702.  
  1703. ; process value
  1704. read2:    call    exprb
  1705.     call    gc
  1706.     cp    ','         ;skip joe test if comma
  1707.         jr      z,read3
  1708.  
  1709. ; junk on end test
  1710.     call    joe
  1711.  
  1712. read3:  ld      a,(txa)
  1713.         ld      l,a
  1714.         ld      a,(txa+1)
  1715.         ld      h,a
  1716.  
  1717.         ld      a,l
  1718.         ld      (rtxa),a     ;save new "read" text addr
  1719.         ld      a,h
  1720.         ld      (rtxa+1),a
  1721.  
  1722.     pop    hl         ;real txa
  1723.  
  1724.         ld      a,l
  1725.         ld      (txa),a
  1726.         ld      a,h
  1727.         ld      (txa+1),a
  1728.  
  1729.     call    var
  1730.     jp    c,e1
  1731.  
  1732.     call    popas         ;put read value into variable
  1733.     call    gc
  1734.     cp    ','         ;check for another variable
  1735.     ret    nz
  1736.  
  1737.     call    gci         ;eat the comma
  1738.         jr      read
  1739.  
  1740. read4:    pop    hl         ;program txa
  1741.  
  1742.         ld      a,l
  1743.         ld      (txa),a
  1744.         ld      a,h
  1745.         ld      (txa+1),a
  1746.  
  1747.         ld      hl,ermrd        ;7264h 'rd'
  1748.     jp    error
  1749.  
  1750. ; "restore"
  1751. restor:
  1752.         call    gln          ;returns integer in hl if line # present
  1753.         jp      c,resto3     ;no line number present
  1754.  
  1755. resto1  ld      e,l          ;line # in de
  1756.         ld      d,h
  1757.  
  1758.     call    findln         ;returns text address points to count value
  1759.         jr      resto4
  1760.  
  1761. resto3: ld      a,(bofa)     ;beginning of file pointer
  1762.         ld      l,a
  1763.         ld      a,(bofa+1)
  1764.         ld      h,a
  1765.  
  1766. ; update rtxa
  1767.  
  1768. resto4: inc     hl           ;advance text pointer past line # & count
  1769.     inc    hl
  1770.     inc    hl
  1771.  
  1772.         ld      a,l
  1773.         ld      (rtxa),a
  1774.         ld      a,h
  1775.         ld      (rtxa+1),a
  1776.         ret
  1777.  
  1778. ; "print"
  1779. print:    call    gc
  1780.     cp    cr         ;check for stand alone print
  1781.     jp    z,crlf
  1782.  
  1783. prin9:    cp    '"'
  1784.         jr      z,pstr       ;print the string
  1785.  
  1786.     cp    tabrw
  1787.         jr      z,ptab       ;tabulation
  1788.  
  1789.     cp    '%'
  1790.     jp    z,pform         ;set format
  1791.  
  1792.     cp    cr
  1793.     ret    z
  1794.     cp    ':'
  1795.     ret    z
  1796.  
  1797.     call    exprb         ;must be expression to print
  1798.  
  1799.     ld    de,fpsink
  1800.     call    popa1         ;pop value to fpsink
  1801.  
  1802. ;        ld      a,(phead)
  1803. ;        cp      56
  1804. ;        call    nc,crlf      ;do crlf if print head is past 56
  1805.  
  1806.     ld    hl,fpsink
  1807.     call    fpout
  1808.  
  1809.     ld    b,' '
  1810.     call    chout
  1811. pr1:    call    gc         ;get delimiter
  1812.         cp      3bh          ; ';'
  1813.     jp    nz,crlf
  1814.  
  1815. pr0:    call    gci
  1816.     call    gc
  1817.         jr      prin9
  1818.  
  1819. pstr:    call    gci         ;gobble the quote
  1820.     call    prnt         ;print up to double quote
  1821.     inc    hl         ;move pointer past double quote
  1822.  
  1823.         ld      a,l
  1824.         ld      (txa),a
  1825.         ld      a,h
  1826.         ld      (txa+1),a
  1827.  
  1828.         jr      pr1
  1829.  
  1830. pform:    ld    a,2*fpnib
  1831.     ld    (infes),a
  1832.     call    gci         ;gobble previous char
  1833. pfrm1:    call    gci
  1834.     ld    hl,infes
  1835.     cp    '%'         ;delimiter
  1836.         jr      z,pr1
  1837.  
  1838.         ld      b,80h
  1839.     cp    'z'         ;trailing zeros?
  1840.         jr      z,pf1
  1841.  
  1842.     ld    b,1
  1843.     cp    'e'         ;scientific notation?
  1844.         jr      z,pf1
  1845.  
  1846.     call    nmchk
  1847.     jp    nc,e1
  1848.  
  1849.     sub    '0'         ;number of decimal places
  1850.     rlca    
  1851.     ld    b,a
  1852.     ld    a,(hl)
  1853.         and     0c1h
  1854.     ld    (hl),a
  1855. pf1:    ld    a,(hl)
  1856.     or    b
  1857.     ld    (hl),a
  1858.         jr      pfrm1
  1859.  
  1860. ptab:    call    gci         ;gobble tab rw
  1861.     ld    b,lparrw
  1862.     call    eatc
  1863.     call    exprb
  1864.     ld    b,')'
  1865.     call    eatc
  1866.     call    pfix
  1867.  
  1868. ptab1:  ld      a,(phead)
  1869.         cp      e
  1870.         jr      nc,pr1
  1871.  
  1872.     ld    b,' '
  1873.     call    chout
  1874.         jr      ptab1
  1875.  
  1876. ; "input"
  1877. input:    call    gc
  1878.     cp    ','
  1879.     jp    z,ncrlf
  1880.  
  1881.     call    crlf
  1882. inp0:    ld    b,'?'
  1883.     call    chout
  1884. linp:    call    inline
  1885.     ld    de,ibuf
  1886. in1:    push    de         ;save for fpin
  1887.  
  1888.     call    var
  1889.     jp    c,e1
  1890.  
  1891.     pop    de
  1892.     ld    b,0
  1893.     ld    a,(de)
  1894.     cp    '+'         ;look for leading plus or minus on input
  1895.         jr      z,in2
  1896.  
  1897.     cp    '-'
  1898.         jr      nz,in3
  1899.  
  1900.     ld    b,1
  1901. in2:    inc    de
  1902. in3:    push    bc
  1903.     push    hl
  1904.     call    fpin         ;input fp number
  1905.     jp    c,inerr
  1906.  
  1907.     pop    hl
  1908.     dec    hl
  1909.     pop    af
  1910.     ld    (hl),a
  1911.     call    gc
  1912.     cp    ','
  1913.     ret    nz         ;done if no more
  1914.  
  1915.     call    gci         ;eat the comma
  1916.     ld    a,b         ;get the terminator to a
  1917.     cp    ','
  1918.         jr      z,in1        ;get the next input value from string
  1919.  
  1920. ; get new line from user
  1921.     ld    b,'?'
  1922.     call    chout
  1923.         jr      inp0
  1924.  
  1925. ncrlf:    call    gci
  1926.         jr      linp         ;now get line
  1927.  
  1928. inerr:  ld      hl,ermin        ;696eh 'in'
  1929.     jp    error
  1930.  
  1931. ;
  1932. ;    evaluate an expression from text
  1933. ; hl take op table addr of previous operator (not changed)
  1934. ; result value left on top of arg stack, argf left true
  1935. ;
  1936. exprb:    ld    b,0
  1937. expb1:    ld    hl,opbol
  1938.     xor    a
  1939.     ld    (reltyp),a
  1940.  
  1941. ; zero in b means principal operator may not be relational
  1942. expr:    push    bc
  1943.     push    hl         ;push optba
  1944.     xor    a
  1945.     ld    (argf),a
  1946. expr1:    ld    a,(argf)
  1947.     or    a
  1948.         jr      nz,expr2
  1949.  
  1950.         call    var             ;is there a variable?
  1951.         call    nc,pshas        ;yes, push onto arg stack
  1952.         jr      nc,expr2
  1953.  
  1954.         call    const           ;is there a fp constant?
  1955.         jr      nc,expr2        ;yes
  1956.  
  1957.     call    gc
  1958.         cp      lparrw          ;is there a ( ?
  1959.     ld    hl,oplpar
  1960.         jp      z,xlpar         ;yes
  1961.  
  1962. ; isn't or shouldn't be an argument
  1963. expr2:    call    gc
  1964.         cp      0e0h         ;check for reserved word operator
  1965.         jr      nc,xop          ; e0 or >
  1966.  
  1967.         cp      0c0h         ;check for built in function
  1968.         jp      nc,xbilt        ; c0 - df
  1969.  
  1970. ; illegal expression character
  1971.     pop    hl         ;get optaba
  1972.     ld    a,(argf)
  1973.     or    a
  1974.     jp    z,e1
  1975.  
  1976. xdon1:    pop    af
  1977.     ld    hl,reltyp    ;check if legal principal operation
  1978.     cp    (hl)
  1979.     ret    z
  1980.  
  1981.     jp    e1
  1982.  
  1983. xop:    and     1fh          ;cleans off rw bits
  1984.  
  1985.         push    af
  1986.         ld      a,(argf)    ;test for argf true
  1987.         ld      l,a
  1988.         ld      a,(argf+1)
  1989.         ld      h,a
  1990.         pop     af
  1991.  
  1992.     dec    l
  1993.         jr      z,xop1
  1994.  
  1995. ; argf was false, unary ops only possibility
  1996.     cp    '-'-opbase
  1997.         jr      z,xopm
  1998.  
  1999.     cp    '+'-opbase
  2000.     jp    nz,e1
  2001.  
  2002.     call    gci         ;eat the '+'
  2003.         jr      expr1
  2004.  
  2005. xopm:    ld    a,uminu-opbase
  2006. xop1:    call    opadr
  2007.     pop    de         ;previous optba
  2008.     ld    a,(de)
  2009.     cp    (hl)
  2010.         jr      nc,xdon1     ;non-increasing precedence
  2011.  
  2012. ; increasing precedence case
  2013.     push    de         ;save previous optba
  2014.     push    hl         ;save current optba
  2015.     call    gci         ;to gobble operator
  2016.     pop    hl
  2017.     push    hl
  2018.     ld    b,0         ;specify non-relational
  2019.     call    expr
  2020.     pop    hl
  2021.  
  2022. ; hl has optba addr
  2023. ; set up args and perform operation action
  2024. xop2:    push    hl
  2025.     ld    a,(hl)
  2026.  
  2027.         push    af
  2028.         ld      a,(astka)
  2029.         ld      l,a
  2030.         ld      a,(astka+1)
  2031.         ld      h,a
  2032.         pop     af
  2033.  
  2034.     ld    b,h
  2035.     ld    c,l
  2036.     and    1
  2037.         jr      nz,xop21
  2038.  
  2039. ; decrement stack pointer by one value binary case
  2040.     ld    de,fpsiz
  2041.     add    hl,de
  2042.  
  2043.         push    af
  2044.         ld      a,l
  2045.         ld      (astka),a
  2046.         ld      a,h
  2047.         ld      (astka+1),a
  2048.         pop     af
  2049.  
  2050.     ld    d,h
  2051.     ld    e,l
  2052. xop21:  ld      hl,expr1
  2053.         EX_SP_HL             ;change return link
  2054.     inc    hl         ;skip over precidence
  2055.     call    lhli         ;load action address
  2056.     jp    (hl)
  2057.  
  2058. ;
  2059. ;    action routine convention
  2060. ; de left arg and result for binary
  2061. ; bc right arg for binary, arg and result for unary
  2062. ; built in function processing
  2063. ;
  2064. xbilt:    call    gci         ;eat token
  2065.         and     3fh          ;clean off rw bits
  2066.  
  2067.         push    af
  2068.         ld      a,(argf)     ;built in function must come after operator
  2069.         ld      l,a
  2070.         ld      a,(argf+1)
  2071.         ld      h,a
  2072.         pop     af
  2073.  
  2074.     dec    l
  2075.     jp    z,e1
  2076.  
  2077.     call    opadr         ;optba to hl
  2078.  
  2079. xlpar:    push    hl
  2080.     ld    b,lparrw
  2081.     call    eatc
  2082.  
  2083.     call    exprb
  2084.  
  2085.     ld    b,')'
  2086.     call    eatc
  2087.  
  2088.     pop    hl         ;code for built-in function
  2089.         jr      xop2
  2090.  
  2091. ; compute optable address for operator in acc
  2092. opadr:    ld    c,a
  2093.     ld    b,0
  2094.     ld    hl,optab
  2095.     add    hl,bc
  2096.     add    hl,bc
  2097.     add    hl,bc         ;optab entry addr is 3*op+base
  2098.     ret    
  2099. ;
  2100. ; preprocessor, un-preprocessor
  2101. ; preprocess line in ibuf back into ibuf
  2102. ; sets carry if line has no line number
  2103. ; leaves correct length of line after preprocessing in ibcn
  2104. ; if there is a line number, it is located at ibln=ibuf-2
  2105. ; txa is clobbered
  2106. ;
  2107. pp:    ld    hl,ibuf         ;first character of input line
  2108.  
  2109.         ld      a,l
  2110.         ld      (txa),a      ;so gci will work
  2111.         ld      a,h
  2112.         ld      (txa+1),a
  2113.  
  2114.         call    intger       ;sets carry if no line number
  2115.  
  2116.     push    af         ;save state of carry bit for returning
  2117.  
  2118.         ld      a,l
  2119.         ld      (ibln),a     ;store line number value (even if none)
  2120.         ld      a,h
  2121.         ld      (ibln+1),a
  2122.  
  2123.         ld      a,(txa)      ;addr of next char in ibuf
  2124.         ld      l,a
  2125.         ld      a,(txa+1)
  2126.         ld      h,a
  2127.  
  2128.     ld    c,4         ;set up initial value for count
  2129.     ld    de,ibuf         ;initialize write pointer
  2130.  
  2131. ; come here to continue preprocessing line
  2132. ppl:    push    de
  2133.     ld    de,rwt         ;base of rwt
  2134. ppl1:    push    hl         ;save text addr
  2135.     ld    a,(de)         ;rw value for this entry in rwt
  2136.     ld    b,a         ;save in b in case of match
  2137. ppl2:    inc    de         ;advance entry pointer to next byte
  2138.         call    hl2lower
  2139.     ld    a,(de)         ;get next char from entry
  2140.     cp    (hl)         ;compare with char in text
  2141. ;        jr      z,ppl0
  2142. ;        and     0dfh         ;see if case different
  2143. ;        cp      (hl)
  2144.         jr      nz,ppl3
  2145. ppl0:   inc     hl           ;advance text pointer
  2146.         jr      ppl2         ;continue comparison
  2147.  
  2148. ; come here when comparison of byte failed
  2149. ppl3:
  2150. ;        or      20h
  2151.         cp      128
  2152.         jr      nc,ppl6       ;jump if found match
  2153.  
  2154. ; scan to beginning of next entry
  2155. ppl4:    inc    de         ;advance entry pointer
  2156.     ld    a,(de)         ;next byte is either char or rw byte
  2157.         cp      128
  2158.         jr      c,ppl4       ;keep scanning if not rw byte
  2159.  
  2160. ; now see if at end of table, and fail or return condition
  2161.     pop    hl         ;recover original text pointer
  2162.     xor    255         ;check for end of table byte
  2163.         jr      nz,ppl1      ;continue scan of table
  2164.  
  2165. ; didn't find an entry at the given text addr
  2166.     pop    de
  2167.     ld    a,(hl)         ;get text char
  2168.     cp    cr         ;check for end of line
  2169.         jr      z,ppl88      ;go clean up & return
  2170.  
  2171.     ld    (de),a
  2172.     inc    de
  2173.     inc    c
  2174.     inc    hl         ;advance text pointer
  2175.     cp    '"'         ;check for quoted string possibility
  2176.         jr      nz,ppl       ;restart rwt search at next character position
  2177.  
  2178. ; here we have a quoted string, so eat till endquote
  2179. ppl5:    ld    a,(hl)         ;next char
  2180.     cp    cr
  2181.         jr      z,ppl88      ;no string endquote, let interpreter worry
  2182.  
  2183.     ld    (de),a
  2184.     inc    de
  2185.     inc    c
  2186.     inc    hl         ;advance text pointer
  2187.     cp    '"'
  2188.         jr      z,ppl        ;begin rwt scan from new character position
  2189.         jr      ppl5
  2190.  
  2191. ; found match so put rw value in text
  2192. ppl6:    pop    af         ;remove unneeded test pointer from stack
  2193.     pop    de
  2194.     ld    a,b
  2195.     ld    (de),a
  2196.     inc    de
  2197.     inc    c
  2198.  
  2199.         cp      gotorw          ;is it a goto?
  2200.         jr      z,ppl7          ;yes
  2201.         cp      gosubrw         ;is it a gosub?
  2202.         jr      z,ppl7          ;yes
  2203.         cp      restorw         ;is it a restore?
  2204.         jr      z,ppl7          ;yes
  2205.         cp      thenrw          ;is it a then?
  2206.         jr      z,ppl7          ;yes
  2207.  
  2208.         jr      ppl
  2209.  
  2210. ;look for line number to compress
  2211. ppl7:   push    hl
  2212.  
  2213.         ld      a,l
  2214.         ld      (txa),a
  2215.         ld      a,h
  2216.         ld      (txa+1),a
  2217.  
  2218.         push    bc
  2219.         push    de
  2220.         call    intger          ;carry set if no line number
  2221.         pop     de
  2222.         pop     bc
  2223.         jr      c,ppl79
  2224.  
  2225.         pop     af
  2226.  
  2227.         ld      a,' '
  2228.         ld      (de),a
  2229.         inc     de
  2230.         inc     c
  2231.  
  2232.         ld      a,linent
  2233.         ld      (de),a
  2234.         inc     de
  2235.         inc     c
  2236.  
  2237.         ld      a,l
  2238.         ld      (de),a
  2239.         inc     de
  2240.         inc     c
  2241.  
  2242.         ld      a,h
  2243.         ld      (de),a
  2244.         inc     de
  2245.         inc     c
  2246.  
  2247.         ld      a,(txa)
  2248.         ld      l,a
  2249.         ld      a,(txa+1)
  2250.         ld      h,a
  2251.  
  2252.         ld      a,(hl)
  2253.         cp      ','     ;is this a ON x GOSUB x,x,x?
  2254.         jp      nz,ppl
  2255.  
  2256.         inc     hl
  2257.         ld      (de),a
  2258.         inc     de
  2259.         inc     c
  2260.  
  2261.         jp     ppl7
  2262.  
  2263. ;ppl8:   ld      a,(hl)
  2264. ;        inc     hl
  2265. ;        cp      cr          ;end of line?
  2266. ;        jr      z,ppl80     ;yes
  2267. ;        cp      ' '         ;space?
  2268. ;        jr      z,ppl8      ;yes
  2269. ;        cp      '1'         ;is it a line number?
  2270. ;        jr      c,ppl79     ;no
  2271. ;        cp      '9'+1       ;is it " ?
  2272. ;        jr      nc,ppl79    ;no
  2273.  
  2274.  
  2275. ppl79:  pop     hl
  2276.         jp      ppl
  2277.  
  2278. ppl80:  pop     hl
  2279.  
  2280. ; come here when done
  2281. ppl88:  ld      a,cr
  2282.     ld    (de),a
  2283.         ld      hl,ibcnt     ;set up count in case line has line number
  2284.     ld    (hl),c
  2285.     pop    af         ;restore carry condition (line number flag)
  2286.     ret    
  2287.  
  2288. hl2lower:
  2289.         ld      a,(hl)
  2290.         cp      'A'
  2291.         ret     c
  2292.         cp      'Z'+1
  2293.         ret     nc
  2294.         or      20h
  2295.         ld      (hl),a
  2296.         ret
  2297. ;
  2298. ; un-preprocess line addr in hl to de buffer
  2299. ; return source addr of cr in hl on return
  2300. ;
  2301. uppl:    inc    hl         ;skip over count byte
  2302.     push    hl         ;save source text pointer
  2303.     call    lhli         ;load line # value
  2304.         call    cns          ;convert line #
  2305.     ld    a,' '
  2306.     ld    (de),a         ;put blank after line number
  2307.     inc    de         ;increment dest pointer
  2308.     pop    hl
  2309.     inc    hl         ;     "    source  "
  2310. upp0:    inc    hl
  2311.     ld    a,(hl)         ;next token in source
  2312.         cp      128
  2313.         jr      nc,upp2      ;jump if token is rw
  2314.  
  2315.     ld    (de),a         ;put char in buffer
  2316.     cp    cr         ;check for done
  2317.     ret    z
  2318.  
  2319.         cp      linent       ;is it a line number token?
  2320.         jr      nz,upp1      ;no
  2321.  
  2322.         inc     hl
  2323.         push    hl
  2324.         call    lhli         ;load line # value
  2325.         call    cns          ; convert line #
  2326.         pop     hl
  2327.         inc     hl
  2328.         dec     de
  2329. upp1:
  2330.         inc     de           ;advance dest buffer addr
  2331.         jr      upp0
  2332.  
  2333. ; come here when rw byte detected in source
  2334. upp2:   push    hl           ;save source pointer
  2335.     ld    hl,rwt         ;base of rwt
  2336. upp3:   cp      (hl)         ;see if rw matched rwt entry
  2337.     inc    hl         ;advance rwt pointer
  2338.         jr      nz,upp3      ;continue looking if not found
  2339.  
  2340. ; found match, entry pointer locates first char
  2341. upp4:   ld      a,(hl)       ;char of rw
  2342.         cp      128          ;check for done
  2343.         jr      nc,upp5
  2344.  
  2345.     ld    (de),a
  2346.     inc    de
  2347.     inc    hl
  2348.         jr      upp4
  2349.  
  2350. ; come here if done with rw transfer
  2351. upp5:   pop     hl           ;source pointer
  2352.         jr      upp0
  2353. ;
  2354. ;    constants and tables
  2355. ;
  2356. signon: .byte   "GameBoy Basic V1.21",term
  2357. rdys:   .byte    "Ok",term
  2358. ers:    .byte    " error",term
  2359. ins:    .byte    " in ",term
  2360. stops:  .byte    "Break",term
  2361. trues:   .byte    "true",term
  2362. falses:  .byte    "false",term
  2363.  
  2364. ;
  2365.         .byte    -1           ;flags end of sine coefficient list
  2366.         .byte    0
  2367.         .byte    1*16
  2368.         .word    0
  2369.         .byte    0
  2370.  
  2371. fpone:  .byte    129          ;exponent
  2372. ;    sine coefficient list
  2373. ; note: the floating pnt 1 above is part of this table
  2374.         .byte    16h
  2375.         .byte    66h
  2376.         .byte    67h
  2377.         .byte    1
  2378.         .byte    128          ;-.166667 e 0 (-1/3)
  2379.         .byte    83h
  2380.         .byte    33h
  2381.         .byte    33h
  2382.         .byte    0
  2383.         .byte    128-2        ;.833333 e-2 (1/5)
  2384.         .byte    19h
  2385.         .byte    84h
  2386.         .byte    13h
  2387.         .byte    1
  2388.         .byte    128-3        ;-.198413 e-3 (-1/7)
  2389.         .byte    27h
  2390.         .byte    55h
  2391.         .byte    73h
  2392.         .byte    0
  2393.         .byte    128-5        ;.275573 e-5 (1/9)
  2394.         .byte    25h
  2395.         .byte    05h
  2396.         .byte    21h
  2397.         .byte    1
  2398. sinx:   .byte    128-7        ;-.250521 e-7 (-1/11)
  2399. ;    cosine coefficient list
  2400.         .byte    -1           ;marks end of list
  2401.         .byte    0
  2402.         .byte    10h
  2403.         .byte    00h
  2404.         .byte    00h
  2405.         .byte    0
  2406.         .byte    128+1        ;.100000 e 1 (1/1)
  2407.         .byte    50h
  2408.         .byte    00h
  2409.         .byte    00h
  2410.         .byte    1
  2411. matub:  .byte    128          ;-.500000 e 0 (-1/2)
  2412.         .byte    41h
  2413.         .byte    66h
  2414.         .byte    67h
  2415.         .byte    0
  2416. rands:  .byte    128-1        ;.416667 e-1 (1/4)
  2417.         .byte    13h
  2418.         .byte    88h
  2419.         .byte    89h
  2420.         .byte    1
  2421.         .byte    128-2        ;.138889 e-2 (-1/6)
  2422.         .byte    24h
  2423.         .byte    80h
  2424.         .byte    16h
  2425.         .byte    0
  2426.         .byte    128-4        ;.248016 e-4 (1/8)
  2427.         .byte    27h
  2428.         .byte    55h
  2429.         .byte    73h
  2430.         .byte    1
  2431. cosx:   .byte    128-6        ;.275573 e-6 (-1/10)
  2432.         .byte    20h
  2433.         .word    0
  2434.         .byte    0
  2435. fptwo:  .byte    129
  2436.         .byte    15h
  2437.         .byte    70h
  2438.         .byte    80h
  2439.         .byte    0
  2440. pic2:   .byte    128+1        ;pi/2 .157080 e 1
  2441.         .byte    63h
  2442.         .byte    66h
  2443.         .byte    20h
  2444.         .byte    0
  2445. pic1:   .byte    128          ;2/pi .636620 e 0
  2446. lcstka: .word    cstkl
  2447.  
  2448.         .byte    13h
  2449.         .byte    10h
  2450.         .byte    72h
  2451.         .byte    0
  2452. snd2:   .byte    128+6
  2453.  
  2454. ;
  2455. ;       statement table
  2456. ;
  2457. cmndd:  .word    let
  2458.         .word    next
  2459.         .word    sif
  2460.         .word    sgoto
  2461.         .word    gosub
  2462.         .word    retrn
  2463.         .word    read
  2464.         .word    data
  2465.         .word    sfor
  2466.         .word    print
  2467.         .word    input
  2468.         .word    dim
  2469.         .word    stop
  2470.         .word    bend
  2471.         .word    restor
  2472.         .word    rem
  2473.         .word    cclear
  2474.         .word    crun
  2475.         .word    clist
  2476.         .word    new
  2477.         .word    abc
  2478.         .word    cls
  2479.         .word    renum
  2480.         .word    locat
  2481.         .word    loadp
  2482.         .word    save
  2483.         .word    free
  2484.         .word    poke
  2485.         .word    delay
  2486.         .word    screen
  2487.         .word    set_color
  2488.         .word    draw_point
  2489.         .word    draw_line
  2490.         .word    auto
  2491.         .word    sound
  2492.         .word    servo
  2493.         .word    setLink
  2494.         .word    SetRegBC
  2495.         .word    SetRegDE
  2496.         .word    SetMemTop
  2497. ;
  2498. ; r/w word table format is reserved word followed by chr
  2499. ; of reserved word. last entry is followed by 255.
  2500. ; rw's that are substrings of other rw's (e.g. >) must
  2501. ; follow the larger word.
  2502. ;
  2503. rwt:    .byte    80h
  2504.         .byte    "let"
  2505.  
  2506.         .byte    81h
  2507.         .byte    "next"
  2508.  
  2509.         .byte    81h
  2510.         .byte    "n."
  2511.  
  2512.         .byte    82h
  2513.         .byte    "if"
  2514.  
  2515. gotorw  .equ     83h
  2516.         .byte    gotorw
  2517.         .byte    "goto"
  2518.  
  2519.         .byte    gotorw
  2520.         .byte    "g."
  2521.  
  2522. gosubrw .equ     84h
  2523.         .byte    gosubrw
  2524.         .byte    "gosub"
  2525.  
  2526.         .byte    85h
  2527.         .byte    "return"
  2528.  
  2529.         .byte    86h
  2530.         .byte    "read"
  2531.  
  2532. datarw  .equ    87h
  2533.         .byte    datarw
  2534.         .byte    "data"
  2535.  
  2536.         .byte    88h
  2537.         .byte    "for"
  2538.  
  2539.         .byte    88h
  2540.         .byte    "f."
  2541.  
  2542.         .byte    89h
  2543.         .byte    "print"
  2544.  
  2545.         .byte    89h
  2546.         .byte    "p."
  2547.  
  2548.         .byte    89h
  2549.         .byte    "?"
  2550.  
  2551.         .byte    8ah
  2552.         .byte    "input"
  2553.  
  2554.         .byte    8ah
  2555.         .byte    "i."
  2556.  
  2557.         .byte    8bh
  2558.         .byte    "dim"
  2559.  
  2560.         .byte    8ch
  2561.         .byte    "stop"
  2562.  
  2563.         .byte    8dh
  2564.         .byte    "end"
  2565.  
  2566. restorw .equ     8eh
  2567.         .byte    restorw
  2568.         .byte    "restore"
  2569.  
  2570.         .byte    8fh
  2571.         .byte    "rem"
  2572.  
  2573. clrrw   .equ    90h
  2574.         .byte    clrrw
  2575.         .byte    "clear"
  2576.  
  2577.         .byte    91h
  2578.         .byte    "run"
  2579.  
  2580.         .byte    91h
  2581.         .byte    "r."
  2582.  
  2583.         .byte    92h
  2584.         .byte    "list"
  2585.  
  2586.         .byte    92h
  2587.         .byte    "l."
  2588.  
  2589.         .byte    93h
  2590.         .byte    "new"
  2591.  
  2592.         .byte    94h
  2593.         .byte    "abc"
  2594.  
  2595.         .byte    95h
  2596.         .byte    "cls"
  2597.  
  2598.         .byte    96h
  2599.         .byte    "renum"
  2600.  
  2601.         .byte    97h
  2602.         .byte    "locate"
  2603.  
  2604.         .byte    98h
  2605.         .byte    "load"
  2606.  
  2607.         .byte    99h
  2608.         .byte    "save"
  2609.  
  2610.         .byte    9ah
  2611.         .byte    "free"
  2612.  
  2613.         .byte    9bh
  2614.         .byte    "poke"
  2615.  
  2616.         .byte    9ch
  2617.         .byte    "delay"
  2618.  
  2619.         .byte    9ch
  2620.         .byte    "d."
  2621.  
  2622.         .byte    9dh
  2623.         .byte    "screen"
  2624.  
  2625.         .byte    9eh
  2626.         .byte    "color"
  2627.  
  2628.         .byte    9fh
  2629.         .byte    "point"
  2630.  
  2631.         .byte    0a0h
  2632.         .byte    "line"
  2633.  
  2634.         .byte    0a1h
  2635.         .byte    "auto"
  2636.  
  2637.         .byte    0a2h
  2638.         .byte    "sound"
  2639.  
  2640.         .byte    0a3h
  2641.         .byte    "servo"
  2642.  
  2643.         .byte    0a4h
  2644.         .byte    "link"
  2645.  
  2646.         .byte    0a5h
  2647.         .byte    "regbc"
  2648.  
  2649.         .byte    0a6h
  2650.         .byte    "regde"
  2651.  
  2652.         .byte    0a7h
  2653.         .byte    "memtop"
  2654.  
  2655. irwlin: .equ    0b0h         ;last initial reserved word value + 1
  2656.  
  2657. steprw  .equ    0b0h
  2658.         .byte    steprw
  2659.         .byte    "step"
  2660.  
  2661. torw    .equ    0b1h
  2662.         .byte    torw
  2663.         .byte    "to"
  2664.  
  2665. thenrw  .equ    0b2h
  2666.         .byte    thenrw
  2667.         .byte    "then"
  2668.  
  2669.         .byte    thenrw
  2670.         .byte    "t."
  2671.  
  2672. tabrw   .equ    0b3h
  2673.         .byte    tabrw
  2674.         .byte    "tab"
  2675.  
  2676. lparrw  .equ     '('-opbase+0e0h
  2677.         .byte    lparrw
  2678.         .byte    "("
  2679.  
  2680.         .byte    2ah-opbase+0e0h        ;*
  2681.         .byte    "*"
  2682.  
  2683. plsrw   .equ     '+'-opbase+0e0h
  2684.         .byte    plsrw
  2685.         .byte    "+"
  2686.  
  2687. minrw   .equ     '-'-opbase+0e0h
  2688.         .byte    minrw
  2689.         .byte    "-"
  2690.  
  2691.         .byte    2fh-opbase+0e0h        ;/
  2692.         .byte    "/"
  2693.  
  2694.         .byte    37h-opbase+0e0h
  2695.         .byte    ">="
  2696.  
  2697.         .byte    38h-opbase+0e0h
  2698.         .byte    "<="
  2699.  
  2700.         .byte    39h-opbase+0e0h
  2701.         .byte    "<>"
  2702.  
  2703.         .byte    32h-opbase+0e0h
  2704.         .byte    "=>"
  2705.  
  2706.         .byte    33h-opbase+0e0h
  2707.         .byte    "=<"
  2708.  
  2709.         .byte    3ch-opbase+0e0h
  2710.         .byte    "<"
  2711.  
  2712. eqrw    .equ     3dh-opbase+0e0h
  2713.         .byte    eqrw
  2714.         .byte    "="
  2715.  
  2716.         .byte    3eh-opbase+0e0h
  2717.         .byte    ">"
  2718.  
  2719.         .byte    0c1h
  2720.         .byte    "abs"
  2721.  
  2722.         .byte    0c6h
  2723.         .byte    "int"
  2724.  
  2725.         .byte    0cdh
  2726.         .byte    "usr"
  2727.  
  2728.         .byte    0ceh
  2729.         .byte    "rnd"
  2730.  
  2731.         .byte    0d2h
  2732.         .byte    "sgn"
  2733.  
  2734.         .byte    0d3h
  2735.         .byte    "sin"
  2736.  
  2737.         .byte    0c4h
  2738.         .byte    "sqr"
  2739.  
  2740.         .byte    0d7h
  2741.         .byte    "tan"
  2742.  
  2743.         .byte    0d8h
  2744.         .byte    "cos"
  2745.  
  2746.         .byte    0d9h
  2747.         .byte    "peek"
  2748.  
  2749.         .byte    0dah
  2750.         .byte    "keypad"
  2751.  
  2752.         .byte    0ffh
  2753. ;
  2754. ;    operation table
  2755. ;
  2756. optab:  .byte    15
  2757. oplpar: .equ     optab
  2758.         .word    alpar
  2759.         .byte    15
  2760.         .word    aabs
  2761.         .byte    10
  2762.         .word    amul
  2763.         .byte    6
  2764.         .word    aadd
  2765.         .byte    15
  2766.         .word    asqr
  2767.         .byte    6
  2768.         .word    asub
  2769.         .byte    15
  2770.         .word    aint
  2771.         .byte    10
  2772.         .word    adiv
  2773. opbol:  .byte    1
  2774.         .word    0
  2775.         .byte    13
  2776.         .word    aneg
  2777.         .byte    4
  2778.         .word    age
  2779.         .byte    4
  2780.         .word    ale
  2781.         .byte    15
  2782.         .word    0             ;not used
  2783.         .byte    15
  2784.         .word    acall
  2785.         .byte    15
  2786.         .word    arnd
  2787.         .byte    4
  2788.         .word    age
  2789.         .byte    4
  2790.         .word    ale
  2791.         .byte    4
  2792.         .word    ane
  2793.         .byte    15
  2794.         .word    asgn
  2795.         .byte    15
  2796.         .word    asin
  2797.         .byte    4
  2798.         .word    alt
  2799.         .byte    4
  2800.         .word    aeq
  2801.         .byte    4
  2802.         .word    agt
  2803.         .byte    15
  2804.         .word    atan
  2805.         .byte    15
  2806.         .word    acos
  2807.         .byte    15
  2808.         .word    apeek
  2809.         .byte    15
  2810.         .word    akeypad
  2811. ;
  2812. ;    action routines for relational operators
  2813. ;
  2814. agt:    call    relop
  2815.         jr      z,rfalse
  2816.         jr      nc,rtrue
  2817.  
  2818. rfalse:    xor    a
  2819.     ld    (de),a
  2820.     ret    
  2821.  
  2822. alt:    call    relop
  2823.         jr      z,rfalse
  2824.         jr      nc,rfalse
  2825.  
  2826. rtrue:    ld    a,255
  2827.     ld    (de),a
  2828.     ret    
  2829.  
  2830. aeq:    call    relop
  2831.         jr      z,rtrue
  2832.         jr      rfalse
  2833.  
  2834. ane:    call    relop
  2835.         jr      z,rfalse
  2836.         jr      rtrue
  2837.  
  2838. age:    call    relop
  2839.         jr      z,rtrue
  2840.         jr      nc,rtrue
  2841.         jr      rfalse
  2842.  
  2843. ale:    call    relop
  2844.         jr      z,rtrue
  2845.         jr      nc,rfalse
  2846.         jr      rtrue
  2847.  
  2848. ;    common routine for relational operator action
  2849. ; left arg addr in de, saved
  2850. ; right arg addr in bc
  2851. ; on return nc = gt, zero set=equal
  2852. relop:    push    de
  2853.     dec    bc
  2854.     dec    de
  2855.     ld    h,b
  2856.     ld    l,c
  2857.     ld    a,(de)
  2858.     sub    (hl)
  2859.     inc    hl
  2860.     inc    de
  2861.         jr      nz,rlop1     ;test signs of args if different then ret
  2862.  
  2863.     ld    bc,fpsink
  2864.     call    fsub
  2865.     ld    a,(fpsink)   ;check for zero result
  2866.     or    a
  2867.         jr      z,rlop1
  2868.  
  2869.     ld    a,(fpsink-1) ;sign of fpsink
  2870.     rlca    
  2871.     dec    a
  2872. rlop1:  push    af
  2873.         cp      128
  2874.         jr      c,rlop2
  2875.  
  2876.         pop     af
  2877.         scf
  2878.         ccf
  2879.         jr      rlop3
  2880.  
  2881. rlop2:
  2882.         pop     af
  2883.         scf
  2884. rlop3:
  2885.     ld    a,1
  2886.     ld    (reltyp),a   ;set reltyp true
  2887.     pop    de
  2888.     ret    
  2889. ;
  2890. ;    action routines for arithmetic operators
  2891. ;        (code wasters)
  2892. aadd:    ld    h,b
  2893.     ld    l,c
  2894.     ld    b,d
  2895.     ld    c,e
  2896. aadd1:    call    fadd
  2897.         jr      fpetst
  2898.  
  2899. asub:    ld    h,b
  2900.     ld    l,c
  2901.     ld    b,d
  2902.     ld    c,e
  2903. asub1:    call    fsub
  2904.         jr      fpetst
  2905.  
  2906. amul:    ld    h,b
  2907.     ld    l,c
  2908.     ld    b,d
  2909.     ld    c,e
  2910. amul1:    call    fmul
  2911.         jr      fpetst
  2912.  
  2913. adiv:    ld    h,b
  2914.     ld    l,c
  2915.     ld    b,d
  2916.     ld    c,e
  2917. adiv1:    call    fdiv
  2918. fpetst:    xor    a
  2919.     ld    (reltyp),a
  2920.     ld    a,(erri)
  2921.     or    a
  2922.     ret    z
  2923.  
  2924.         ld      a,(astka)   ;zero result on underflow
  2925.         ld      l,a
  2926.         ld      a,(astka+1)
  2927.         ld      h,a
  2928.  
  2929. fpet1:    ld    (hl),0
  2930. alpar:    ret    
  2931. ;
  2932. ;    unary and built in function action routines
  2933. ;
  2934. aneg:    ld    a,(bc)
  2935.     or    a
  2936.         jr      z,aneg1
  2937.  
  2938.     dec    bc
  2939.     ld    a,(bc)
  2940.     xor    1
  2941.     ld    (bc),a
  2942. aneg1:    xor    a
  2943.     ld    (reltyp),a
  2944.     ret    
  2945.  
  2946. aabs:    dec    bc
  2947.     xor    a
  2948.     ld    (bc),a
  2949.         jr      aneg1
  2950.  
  2951. asgn:    call    aneg1
  2952.     ld    d,b
  2953.     ld    e,c
  2954.     ld    a,(bc)         ;get exponent
  2955.     or    a
  2956.         jr      nz,asgn1
  2957.     ld    (de),a         ;make argument zero
  2958.     ret    
  2959.  
  2960. asgn1:    dec    bc
  2961.     ld    a,(bc)
  2962.     or    a
  2963.     ld    hl,fpone
  2964.         jp      z,vcopy
  2965.  
  2966.     ld    hl,fpnone
  2967.     jp    vcopy
  2968. ;
  2969. ;    compute sin(x) x=top of argument stack
  2970. ;    return result in place of x
  2971. ;
  2972. asin:    call    quadc         ;compute quadrant
  2973.  
  2974.         ld      a,(astka)
  2975.         ld      l,a
  2976.         ld      a,(astka+1)
  2977.         ld      h,a
  2978.  
  2979.     ld    d,h
  2980.     ld    e,l
  2981.     ld    bc,ftemp
  2982.     call    amul1         ;ftemp=x*x
  2983.     pop    af
  2984.     push    af         ;a=quadrant
  2985.     rra    
  2986.         jr      c,sin10      ;quad odd, compute cosine
  2987.  
  2988. ;  compute x*p(x*x) -- sine
  2989.     ld    de,ftem1
  2990.  
  2991.         ld      a,(astka)
  2992.         ld      l,a
  2993.         ld      a,(astka+1)
  2994.         ld      h,a
  2995.  
  2996.     call    vcopy         ;ftem1=x*x
  2997.     ld    bc,sinx
  2998.     call    poly         ;p(x*x)
  2999.     call    prepop
  3000.     ld    hl,ftem1
  3001.     call    amul1         ;x*p(x*x)
  3002.  
  3003. ;   compute sign of result
  3004. ; positive for quadrants 0,1. negative for 2,3
  3005. ; negate above fro negative arguments
  3006. sin5:    pop    af         ;quadrant
  3007.     ld    b,a
  3008.     pop    af         ;sign
  3009.     rlca             ;sign, 2 to the 1st bit
  3010.     xor    b         ;quadrant, maybe modified for negative arg.
  3011.  
  3012.         push    af
  3013.         ld      a,(astka)
  3014.         ld      l,a
  3015.         ld      a,(astka+1)
  3016.         ld      h,a
  3017.         pop     af
  3018.  
  3019.     dec    hl         ;ptr to sign
  3020.     sub    2
  3021.         cp      128
  3022.         ret     nc           ;quadrant 0 or 1
  3023.     inc    (hl)         ;else set result negative
  3024.     ret
  3025.  
  3026. ; compute p(x*x) -- cosine
  3027. sin10:    ld    bc,cosx
  3028.     call    poly         ;p(x*x)
  3029.         jr      sin5
  3030.  
  3031. sound:
  3032.         call    exprb        ;get frequency
  3033.  
  3034.         ld      a,(astka)
  3035.         ld      l,a
  3036.         ld      a,(astka+1)
  3037.         ld      h,a
  3038.  
  3039.     ld    de,ftemp
  3040.     call    vcopy         ;save x in ftemp
  3041.  
  3042.         call    prepop
  3043.         ld      hl,snd2      ;131072
  3044.         call    vcopy        ;put 131072 on stack
  3045.  
  3046.         call    prepop
  3047.         ld      hl,ftemp     ; tos=131072/ftemp
  3048.         call    adiv1
  3049.  
  3050.         call    pfix
  3051.  
  3052.         ld      a,e          ;de = -de
  3053.         cpl
  3054.         ld      e,a
  3055.         ld      a,d
  3056.         cpl
  3057.         ld      d,a
  3058.         inc     de
  3059.  
  3060.         ld      hl,2048      ;hl = 2048 - de
  3061.         add     hl,de
  3062.         push    hl
  3063.  
  3064.         ld      b,','
  3065.         call    eatc
  3066.  
  3067.         call    exprb
  3068.         call    pfix
  3069.  
  3070.         pop     hl
  3071.  
  3072.         ld      a,d
  3073.         or      e               ;is duration 0?
  3074.         jr      z,sound1        ;yes
  3075.  
  3076. ;        ld      a,77h           ;turn sound on
  3077. ;        ld      (0ff24h),a
  3078.         ld      a,0ffh
  3079.         ld      (0ff25h),a
  3080. ;        ld      a,82h
  3081. ;        ld      (0ff26h),a
  3082.  
  3083. ;        ld      a,84h           ;set sound duty
  3084. ;        ld      (0ff16h),a
  3085.  
  3086. ;        ld      a,0f0h          ;set envelope
  3087. ;        ld      (0ff17h),a
  3088.  
  3089.         ld      a,l             ;set frequency
  3090.         ld      (0ff18h),a
  3091.         ld      a,h
  3092.         and     7
  3093.         or      80h
  3094.         ld      (0ff19h),a
  3095.  
  3096.         inc     de
  3097.         ld      a,d
  3098.         or      a               ;is duration 65535?
  3099.         jr      z,sound2        ;yes
  3100.         dec     de
  3101.  
  3102.         call    dely1           ;delay for duration
  3103. sound1:
  3104.         xor     a               ;turn all sound off
  3105.         ld      (0ff25h),a
  3106. sound2:
  3107.         ret
  3108.  
  3109. ;
  3110. ;    compute cos(x) x=top of argument stack
  3111. ; return result in place of x
  3112. ; cos(x)=sin(x+pi/2)
  3113. ;
  3114. acos:    call    prepop
  3115.     ld    hl,pic2         ;pi/2
  3116.     call    aadd1         ;tos=tos+pi/2
  3117.         jp      asin
  3118.  
  3119. ;    compute tan(x) x=top of argument stack
  3120. ; return result in place of x
  3121. ; tan(x)=sin(x)/cos(x)
  3122. ;
  3123. atan:   ld      a,(astka)
  3124.         ld      l,a
  3125.         ld      a,(astka+1)
  3126.         ld      h,a
  3127.  
  3128.     call    pshas         ;push copy of x onto arg stack
  3129.     call    acos         ;cos(x)
  3130.     ld    de,ftem2
  3131.     call    popa1         ;ftem2=cos(x)
  3132.     call    asin
  3133.     call    prepop
  3134.     ld    hl,ftem2
  3135.     jp    adiv1         ;sin(x)/cos(x)
  3136. ;
  3137. ;    compute sqr(x) x=top of argument stack
  3138. ; return result in place of x
  3139. ;
  3140. asqr:   ld      a,(astka)
  3141.         ld      l,a
  3142.         ld      a,(astka+1)
  3143.         ld      h,a
  3144.  
  3145.     ld    de,ftemp
  3146.     call    vcopy         ;save x in ftemp
  3147.  
  3148. ; compute exponent of first guess as exponent of x/2
  3149.         ld      a,(astka)
  3150.         ld      l,a
  3151.         ld      a,(astka+1)
  3152.         ld      h,a
  3153.  
  3154.     ld    a,(hl)
  3155.     or    a
  3156.     ret    z         ;x=0
  3157.  
  3158.         sub     128
  3159.         cp      128
  3160.         jr      nc,sqr5       ;negative exponent
  3161.  
  3162.     rrca
  3163.     and    127
  3164.         jr      sqr6
  3165.  
  3166. sqr5:    cpl    
  3167.     inc    a
  3168.     rrca    
  3169.     and    127
  3170.     cpl    
  3171.         inc     a
  3172. sqr6:
  3173.         add     a,128
  3174.     ld    (hl),a
  3175.  
  3176. ; test for negative argument
  3177.     dec    hl
  3178.     ld    a,(hl)
  3179.         ld      hl,ermif        ;6e61h 'na'
  3180.     or    a
  3181.     jp    nz,error     ;neg argument
  3182.  
  3183. ; do newton iterations
  3184. ; newguess =( x/oldguess + oldguess ) /2
  3185.     ld    a,6         ;do 6 iterations
  3186. sqr20:    push    af         ;set new iteration count
  3187.     ld    bc,ftem1
  3188.     ld    de,ftemp     ;ftemp is 'x'
  3189.  
  3190.         ld      a,(astka)    ;guess
  3191.         ld      l,a
  3192.         ld      a,(astka+1)
  3193.         ld      h,a
  3194.  
  3195.     call    adiv1         ;ftem1=x/guess
  3196.     ld    de,ftem1
  3197.  
  3198.         ld      a,(astka)
  3199.         ld      l,a
  3200.         ld      a,(astka+1)
  3201.         ld      h,a
  3202.  
  3203.     ld    b,h
  3204.     ld    c,l
  3205.     call    aadd1         ;tos=(x/guess)+guess
  3206.     call    prepop
  3207.     ld    hl,fptwo
  3208.     call    adiv1         ;tos=(x/guess+guess)/2
  3209.     pop    af
  3210.     dec    a         ;decrement count
  3211.         jr      nz,sqr20     ;do another iteration
  3212.     ret    
  3213. ;
  3214. ;    compute rnd(x) x=top of argument stack
  3215. ; frand is updated to new random value
  3216. ; a random number in the range 0<rnd<1 is returned in place
  3217. ;
  3218. arnd:    call    prepop
  3219.     ld    de,frand
  3220.         ld      hl,frand
  3221.     call    amul1         ;tos=frand*frand
  3222.  
  3223. ; set exponent=0
  3224.         ld      a,(astka)
  3225.         ld      l,a
  3226.         ld      a,(astka+1)
  3227.         ld      h,a
  3228.  
  3229.     ld    (hl),128     ;exponent=128 (0 in internal form)
  3230.  
  3231. ; permute digits of x as
  3232. ; 123456 into 345612
  3233.     ld    bc,-4
  3234.     add    hl,bc
  3235.     ld    b,(hl)         ;save 12
  3236.     inc    hl
  3237.     inc    hl
  3238.     call    permu         ;56=12
  3239.     call    permu         ;34=56
  3240.     call    permu         ;12=34
  3241. ; normalize number
  3242. rnd5:   ld      a,(astka)    ;tos
  3243.         ld      l,a
  3244.         ld      a,(astka+1)
  3245.         ld      h,a
  3246.  
  3247.     ld    bc,-fpsiz+1
  3248.     add    hl,bc
  3249.     ld    a,(hl)         ;first digit pair
  3250.     and    15*16
  3251.         jr      nz,rnd10     ;number is normalized
  3252.  
  3253. ; shift left one digit
  3254.         ld      a,(astka)
  3255.         ld      l,a
  3256.         ld      a,(astka+1)
  3257.         ld      h,a
  3258.  
  3259.     ld    a,(hl)         ;exponent
  3260.     dec    a
  3261.     ld    (exp),a
  3262.     call    load         ;tos into temp
  3263.     ld    b,4
  3264.     call    left         ;shift left
  3265.     call    prepop
  3266.     call    store
  3267.         jr      rnd5         ;test if normalized
  3268.  
  3269. ; save new random # in frand cell
  3270. rnd10:    ld    de,frand
  3271.  
  3272.         ld      a,(astka)
  3273.         ld      l,a
  3274.         ld      a,(astka+1)
  3275.         ld      h,a
  3276.  
  3277.         jp      vcopy        ;frand=tos
  3278.  
  3279. ; permute pair of digit pairs
  3280. permu:    ld    a,(hl)
  3281.     ld    (hl),b
  3282.     ld    b,a
  3283.     dec    hl
  3284.     ret    
  3285. ;
  3286. ;   evaluate p(x) using horners method (x is in ftemp)
  3287. ; coefficient list pointer is in bc
  3288. ; result replaces number on top of argument stack (y)
  3289. poly:   ld      a,(astka)
  3290.         ld      l,a
  3291.         ld      a,(astka+1)
  3292.         ld      h,a
  3293.  
  3294.         push    hl           ;de=ptr to y
  3295.         ld      l,e
  3296.         ld      h,d
  3297.         pop     de
  3298.  
  3299.     ld    h,b
  3300.     ld    l,c         ;hl ptr to coefficient list
  3301.     call    vcopy         ;y=first coefficient
  3302.  
  3303. ; multiply by x
  3304. poly1:    push    hl         ;save coeff list pointer
  3305.     call    prepop
  3306.     ld    hl,ftemp
  3307.     call    amul1         ;y=y*x
  3308.  
  3309. ; add next coeff
  3310.     call    prepop
  3311.     pop    hl
  3312.     push    hl         ;hl=coeff. list pointer
  3313.     call    aadd1         ;y=y+coeff.
  3314.  
  3315. ; bump pointer to next coefficient
  3316.     pop    hl         ;coeff. pointer
  3317.     ld    bc,-fpsiz-1
  3318.     add    hl,bc         ;next coef sign
  3319.     ld    a,(hl)
  3320.     inc    hl         ;ptr to exponent
  3321.         cp      128
  3322.         jr      c,poly1      ;process next coefficient
  3323.     ret             ;negative sign (-1) - ends list
  3324. ;
  3325. ; prepare for operation
  3326. ;
  3327. prepop: ld      a,(astka)
  3328.         ld      e,a
  3329.         ld      a,(astka+1)
  3330.         ld      d,a
  3331.  
  3332.     ld    b,d
  3333.     ld    c,e
  3334.     ret    
  3335. ;
  3336. ;     quadrant computation
  3337. ; pops top of argument stack
  3338. ; compute/gets sine of argument, quadrant of argument
  3339. ; and index into quadrant
  3340. ;
  3341. ;    exits with:
  3342. ; sp pointing to quadrant, mod 4
  3343. ; sp+2 pointing to sign of argument
  3344. ; top of argument stack has index into quadrant
  3345. quadc:  ld      a,(astka)
  3346.         ld      l,a
  3347.         ld      a,(astka+1)
  3348.         ld      h,a
  3349.  
  3350.     dec    hl         ;point to sign
  3351.     ld    b,(hl)
  3352.     xor    a
  3353.     ld    (hl),a         ;arg. sign=0
  3354.     ld    h,b
  3355.  
  3356.         pop     de           ;pop return addr
  3357.         push    hl           ;put sign on stack
  3358.         push    de           ;push return
  3359.  
  3360. ; compute quadrant of abs(x)
  3361.         ld      a,(astka)
  3362.         ld      l,a
  3363.         ld      a,(astka+1)
  3364.         ld      h,a
  3365.  
  3366.     call    pshas         ;put copy of arg. onto stack
  3367.     call    prepop
  3368.     ld    hl,pic1         ;2/pi
  3369.     call    amul1         ;tos=x*2/pi
  3370.     call    prepop
  3371.     call    aint         ;tos=int(x*2/pi)
  3372.  
  3373.         ld      a,(astka)
  3374.         ld      l,a
  3375.         ld      a,(astka+1)
  3376.         ld      h,a
  3377.  
  3378.     call    pshas         ;another copy
  3379.     call    pfix         ;pop tos to de
  3380.     ld    a,e
  3381.     push    af         ;quadrant
  3382.     call    prepop
  3383.     ld    hl,pic2
  3384.     call    amul1         ;tos=int(x*2/pi)
  3385.     ld    de,ftemp
  3386.     call    popa1         ;ftemp=tos
  3387.     call    prepop
  3388.     ld    hl,ftemp
  3389.     call    asub1         ;tos=tos-ftemp
  3390.     pop    af         ;a=quadrant, low order byte
  3391.     and    3         ;mod 4
  3392.     pop    hl
  3393.     push    af         ;save quadrant on stack
  3394.     jp    (hl)         ;return
  3395.  
  3396. ; "regbc"
  3397.  
  3398. SetRegBC:
  3399.         call    exprb        ;get value for DE regs for USR
  3400.         call    pfix
  3401.  
  3402.         ld      a,e
  3403.         ld      (callRegC),a
  3404.         ld      a,d
  3405.         ld      (callRegB),a
  3406.         ret
  3407.  
  3408. ; "regde"
  3409.  
  3410. SetRegDE:
  3411.         call    exprb        ;get value for DE regs for USR
  3412.         call    pfix
  3413.  
  3414.         ld      a,e
  3415.         ld      (callRegE),a
  3416.         ld      a,d
  3417.         ld      (callRegD),a
  3418.         ret
  3419.  
  3420. ; "memtop"
  3421.  
  3422. SetMemTop:
  3423.         call    exprb        ;get value for top of RAM memory
  3424.         call    pfix
  3425.  
  3426.         ld      a,e
  3427.         ld      (memtop),a
  3428.         ld      a,d
  3429.         ld      (memtop+1),a
  3430.  
  3431.         jp      cclear          ;clear all variable space
  3432.  
  3433. ; x=peek(x)
  3434. ;  return memory byte
  3435. ;
  3436. apeek:  call    pfix         ;get the address in de
  3437.  
  3438.         ld      a,(de)
  3439.  
  3440. acal2:  ld      l,a
  3441.         ld      h,0
  3442.         jr      acal3
  3443.  
  3444. ; used to call user routine
  3445. acall:  call    pfix         ;get the address
  3446.         ld      l,e
  3447.         ld      h,d
  3448.  
  3449.         ld      bc,acal3     ;return link for user routine
  3450.     push    bc
  3451.  
  3452.         ld      a,(callRegC)    ;get user arguments
  3453.         ld      c,a
  3454.         ld      a,(callRegB)
  3455.         ld      b,a
  3456.         ld      a,(callRegE)
  3457.         ld      e,a
  3458.         ld      a,(callRegD)
  3459.         ld      d,a
  3460.  
  3461.     jp    (hl)
  3462.  
  3463. ;Return HL as a floating point number on arg stack        
  3464.  
  3465. acal3:  ld      de,cnsbuf
  3466.     call    cns
  3467.     ld    a,cr
  3468.     ld    (de),a
  3469.         ld      de,cnsbuf
  3470.     ld    hl,fpsink
  3471.     call    fpin
  3472.     ld    de,fpsink
  3473.     jp    psha1         ;put the returned user value on arg stack
  3474. ;
  3475. ;   int function action routine
  3476. aint:    ld    a,(bc)
  3477.     sub    129
  3478.         cp      128
  3479.         jr      c,aint1
  3480.  
  3481. ; zero if value less than one
  3482.     xor    a
  3483.     ld    (bc),a
  3484.     ret    
  3485.  
  3486. ; exp > 0
  3487. aint1:    sub    fpnib-1
  3488.     ret    nc
  3489.     ld    d,a         ;count
  3490.     dec    bc
  3491. aint2:    dec    bc
  3492.     ld    a,(bc)
  3493.     and    0f0h
  3494.     ld    (bc),a
  3495.     inc    d
  3496.     ret    z
  3497.     xor    a
  3498.     ld    (bc),a
  3499.     inc    d
  3500.         jr      nz,aint2
  3501.     ret    
  3502. ;
  3503. ;    dimension matrix
  3504. ; symtab addr in hl, hl not clobbered
  3505. ; de contains size in # of elements
  3506. ;
  3507. dims:    push    hl
  3508.     inc    de
  3509.     push    de
  3510.     ld    hl,0
  3511.     ld    c,fpsiz
  3512.     call    radd         ;multiply nelts by bytes per value
  3513.  
  3514.         ld      e,l
  3515.         ld      d,h
  3516.  
  3517.         ld      a,(mata)
  3518.         ld      l,a
  3519.         ld      a,(mata+1)
  3520.         ld      h,a
  3521.  
  3522.     push    hl
  3523.     add    hl,de
  3524.     call    stov         ;check that storage not exhausted
  3525.  
  3526.         ld      a,l
  3527.         ld      (mata),a     ;up date matrix free pointer
  3528.         ld      a,h
  3529.         ld      (mata+1),a
  3530.  
  3531.     pop    bc         ;base addr
  3532.     pop    de         ;nelts
  3533.     pop    hl         ;symtab addr
  3534.     push    hl
  3535.     ld    (hl),d
  3536.     dec    hl
  3537.     ld    (hl),e
  3538.     dec    hl
  3539.     ld    (hl),b
  3540.     dec    hl
  3541.     ld    (hl),c         ;symtab entry now set up
  3542.     pop    hl
  3543.     ret    
  3544. ;
  3545. ;    find variable optionally subscripted in text
  3546. ; sets carry if not found
  3547. ; returns addr of variable in hl
  3548. ; updates txa if found
  3549. ;
  3550. var:    call    alpha   ;is first char a letter?
  3551.         ret     c       ;no
  3552.  
  3553.     call    name2
  3554.     call    gc
  3555.     cp    lparrw
  3556.         jr      z,var1       ;test for subscripted
  3557.  
  3558. ; must be scalar variable
  3559.     call    stlk         ;returns entry addr in hl
  3560. ;        jr      c,varsk1
  3561. ;        call    true
  3562.         or      a
  3563.         ret
  3564.  
  3565. ;varsk1:
  3566. ;        call    false
  3567. ;        or      a            ;clear carry
  3568. ;        ret 
  3569.  
  3570. ; must be subscripted
  3571. var1:    call    gci         ;gobble left parenthesis
  3572.     ld    a,80h
  3573.     or    c
  3574.     ld    c,a         ;set type to matrix
  3575.     call    stlk
  3576.     push    hl         ;symbol table
  3577.     ld    de,10         ;default matrix size
  3578.     call    c,dims         ;default dimension matrix
  3579.     call    exprb         ;evaluate subscript expression
  3580.     call    pfix         ;de now has integer
  3581.     ld    b,')'
  3582.     call    eatc         ;gobble right parenthesis
  3583.     pop    hl
  3584.     dec    hl
  3585.     call    dcmp         ;bounds check index
  3586.     jp    nc,e5
  3587.  
  3588.     dec    hl
  3589.     dec    hl
  3590.     call    lhli         ;get base addr
  3591.     ld    c,fpsiz
  3592.     inc    de         ;because base addr is to element-1
  3593.         jp      radd         ;add index, clear carry
  3594. ;
  3595. ;   junk on end of statement, test if at eof.
  3596. ; exit:    de is unaffected
  3597. ;    eats char & line count after cr
  3598. ;    leaves new txa in hl
  3599. ;    sets carry if eof
  3600. ;
  3601. joe:    call    gci
  3602.     cp    ':'
  3603.     ret    z
  3604.     cp    cr
  3605.     jp    nz,e1
  3606.  
  3607.     ld    a,(hl)
  3608.     dec    a
  3609.         jr      z,joe2
  3610.  
  3611.     inc    hl
  3612.     inc    hl
  3613.     inc    hl         ;skip over count & line #
  3614. joe1:   ld      a,l
  3615.         ld      (txa),a
  3616.         ld      a,h
  3617.         ld      (txa+1),a
  3618.     ret
  3619.  
  3620. joe2:    scf    
  3621.         jr      joe1
  3622.  
  3623. ;
  3624. ;    get name from text
  3625. ; exit:    carry set if name not found
  3626. ;    if name found, it is returned in bc.
  3627. ;    if no digit in name, c=0.
  3628. name1:    call    alpha
  3629.     ret    c
  3630. name2:    ld    b,a
  3631.     ld    c,0
  3632.     call    dig
  3633.     ccf    
  3634.     ret    nc
  3635.     ld    c,a
  3636.     or    a         ;clear carry
  3637.     ret    
  3638. ;
  3639. ;    symbol table lookup
  3640. ; bc contains name and class
  3641. ; if not found then create zero'ed entry & set carry
  3642. ; hl has address on ret
  3643. ;
  3644. stlk:
  3645.         ld      a,(memtop)
  3646.         ld      l,a
  3647.         ld      a,(memtop+1)
  3648.         ld      h,a
  3649.  
  3650.     ld    de,-stesiz   ;set up base and inc for search loop
  3651. stlk0:    ld    a,(hl)
  3652.         or      a            ;end of table ?
  3653.         jr      z,stlk2      ;yes, add to table
  3654.  
  3655.     cp    b
  3656.         jr      nz,stlk1     ;test if alpha compares
  3657.  
  3658.     dec    hl
  3659.     ld    a,(hl)         ;look for digit
  3660.     cp    c
  3661.     dec    hl
  3662.     ret    z         ;carry clear on ret
  3663.  
  3664.     inc    hl
  3665.     inc    hl
  3666. stlk1:    add    hl,de         ;didn't compare, dec pointer
  3667.         jr      stlk0
  3668.  
  3669. ; add entry to symtab
  3670. stlk2:    ld    (hl),b
  3671.     dec    hl
  3672.     ld    (hl),c
  3673.     inc    hl
  3674.  
  3675.         push    hl
  3676.         ld      l,e
  3677.         ld      h,d
  3678.         pop     de
  3679.  
  3680.         add     hl,de
  3681.  
  3682.         ld      a,l
  3683.         ld      (stb),a     ;store new end of symtab pointer
  3684.         ld      a,h
  3685.         ld      (stb+1),a
  3686.  
  3687.     dec    de
  3688.     dec    de
  3689.  
  3690.         push    hl
  3691.         ld      l,e
  3692.         ld      h,d
  3693.         pop     de
  3694.  
  3695.     scf    
  3696.     ret    
  3697. ;
  3698. ;  gobbles new text character if alphabetic
  3699. ; set carry if not
  3700. ; next char in 'a' on failure
  3701. ;
  3702. alpha:    call    gc
  3703.     cp    'a'
  3704.     ret    c
  3705.     cp    'z'+1
  3706.     ccf    
  3707.     ret    c
  3708.         jr      digt1
  3709.  
  3710. ; gobbles next text char if digit
  3711. ; sets carry if not
  3712. ; next char in 'a' on failure
  3713. dig:
  3714.     call    gc
  3715.     cp    '0'
  3716.     ret    c
  3717.     cp    '9'+1
  3718.     ccf    
  3719.     ret    c
  3720. digt1:    inc    hl
  3721.  
  3722.         push    af
  3723.         ld      a,l
  3724.         ld      (txa),a
  3725.         ld      a,h
  3726.         ld      (txa+1),a
  3727.         pop     af
  3728.  
  3729.     ret
  3730. ;
  3731. ;   copys fpsiz bytes at addr hl to addr de
  3732. ; on exit hl points to adr-1 of last byte copied
  3733. ;
  3734. vcopy:    ld    c,fpsiz
  3735. vcop1:    ld    a,(hl)
  3736.     ld    (de),a
  3737.     dec    hl
  3738.     dec    de
  3739.     dec    c
  3740.         jr      nz,vcop1
  3741.     ret    
  3742. ;
  3743. ; push value addr by hl onto arg stack
  3744. ; sets argf, clears carry
  3745. ;
  3746. pshas:  ld      e,l
  3747.         ld      d,h
  3748. psha1:  ld      a,(astka)
  3749.         ld      l,a
  3750.         ld      a,(astka+1)
  3751.         ld      h,a
  3752.  
  3753.     ld    bc,-fpsiz
  3754.     add    hl,bc
  3755.  
  3756.         ld      a,l
  3757.         ld      (astka),a    ;dec arg stack pointer
  3758.         ld      a,h
  3759.         ld      (astka+1),a
  3760.  
  3761.         push    hl           ;exchange de & hl
  3762.         ld      l,e
  3763.         ld      h,d
  3764.         pop     de
  3765.  
  3766.     call    vcopy
  3767.     ld    a,1
  3768.     ld    (argf),a     ;clear argf
  3769.     or    a         ;clear carry
  3770.     ret    
  3771. ;
  3772. ;   pop arg stack
  3773. ; hl contains addr to put popped value at
  3774. ;
  3775. popas:  push    hl
  3776.         ld      l,e
  3777.         ld      h,d
  3778.         pop     de
  3779. popa1:  ld      a,(astka)
  3780.         ld      l,a
  3781.         ld      a,(astka+1)
  3782.         ld      h,a
  3783.  
  3784.     push    hl
  3785.     ld    bc,fpsiz
  3786.     add    hl,bc
  3787.  
  3788.         ld      a,l
  3789.         ld      (astka),a    ;inc stack pointer
  3790.         ld      a,h
  3791.         ld      (astka+1),a
  3792.  
  3793.     pop    hl
  3794.     jp    vcopy
  3795. ;
  3796. ;   push frame onto control stack
  3797. ; takes minus amount to sub from cstka in de
  3798. ; does overflow test and returns old cstka-1
  3799. ;
  3800. pshcs:  ld      a,(cstka)
  3801.         ld      l,a
  3802.         ld      a,(cstka+1)
  3803.         ld      h,a
  3804.  
  3805.     push    hl
  3806.     add    hl,de
  3807.  
  3808.         ld      a,l
  3809.         ld      (cstka),a
  3810.         ld      a,h
  3811.         ld      (cstka+1),a
  3812.  
  3813.         push    hl
  3814.         ld      l,e
  3815.         ld      h,d
  3816.         pop     de
  3817.  
  3818.         ld      hl,lcstka    ;addr contains cstkl
  3819.     call    dcmp
  3820.     jp    c,e4
  3821.  
  3822.     pop    hl
  3823.     dec    hl
  3824.     ret    
  3825. ;
  3826. ;    storage overflow test
  3827. ; test that value in hl is between mata & stb
  3828. ; does not clobber hl
  3829. ;
  3830. stov:   push    hl
  3831.         ld      l,e
  3832.         ld      h,d
  3833.         pop     de
  3834.  
  3835.     ld    hl,mata
  3836.     call    dcmp
  3837.         jr      c,e8
  3838.  
  3839.         ld      hl,stb
  3840.     call    dcmp
  3841.  
  3842.         push    hl
  3843.         ld      l,e
  3844.         ld      h,d
  3845.         pop     de
  3846.  
  3847.     ret    c
  3848.  
  3849. e8:     ld      hl,ermso        ; 736fh 'so'
  3850.     jp    error
  3851. ;
  3852. ; increment txa if next non-blank char is equal to b
  3853. ; else syntax error
  3854. ;
  3855. eatc:    call    gci
  3856.     cp    b
  3857.     ret    z
  3858.     jp    e1
  3859. ;
  3860. ; put next non-blank char in 'a'
  3861. ;
  3862. gc:    call    gci
  3863.     dec    hl
  3864.  
  3865.         push    af
  3866.         ld      a,l
  3867.         ld      (txa),a
  3868.         ld      a,h
  3869.         ld      (txa+1),a
  3870.         pop     af
  3871.  
  3872.     ret
  3873.  
  3874. ;
  3875. ; get line number from program
  3876. ;
  3877. gln:
  3878.         ld      a,(txa)
  3879.         ld      l,a
  3880.         ld      a,(txa+1)
  3881.         ld      h,a
  3882.  
  3883. gln1:
  3884.         ld      a,(hl)
  3885.         inc     hl
  3886.         cp      ' '
  3887.         jr      z,gln1
  3888.  
  3889.         cp      linent          ;is this a line # token?
  3890.         jr      nz,glnerr       ;no
  3891.  
  3892.         ld      e,(hl)
  3893.         inc     hl
  3894.         ld      d,(hl)
  3895.         inc     hl
  3896.  
  3897.         ld      a,l
  3898.         ld      (txa),a
  3899.         ld      a,h
  3900.         ld      (txa+1),a
  3901.  
  3902.         ld      l,e
  3903.         ld      h,d
  3904.  
  3905.         or      a               ;clear carry flag
  3906.         ret
  3907.  
  3908. glnerr: scf
  3909.         ret
  3910.  
  3911. ;
  3912. ; put next non-blank char in 'a' & inc txa
  3913. ;
  3914. gci:    ld      a,(txa)
  3915.         ld      l,a
  3916.         ld      a,(txa+1)
  3917.         ld      h,a
  3918.  
  3919. gci0:    ld    a,(hl)
  3920.     inc    hl
  3921.     cp    ' '
  3922.         jr      z,gci0
  3923.  
  3924.         push    af
  3925.         ld      a,l
  3926.         ld      (txa),a
  3927.         ld      a,h
  3928.         ld      (txa+1),a
  3929.         pop     af
  3930.     ret
  3931. ;
  3932. ;    repeat add
  3933. ; adds de to hl c times
  3934. ;
  3935. radd:    add    hl,de
  3936.     dec    c
  3937.         jr      nz,radd
  3938.     ret    
  3939. ;
  3940. prntcr:    ld    c,cr
  3941.         jr      prn1
  3942. ;
  3943. prnt:   ld      c,term
  3944. ;
  3945. ; print message addressed by hl
  3946. ; char in c specifies terminator.
  3947. ; exit:    hl points to term addr
  3948. ;
  3949. prn1:    ld    a,(hl)         ;get next char
  3950.     ld    b,a         ;for chout
  3951.     cp    c         ;end of message test
  3952.     ret    z
  3953.  
  3954.     cp    cr
  3955.     jp    z,e1         ;never print a cr in this routine
  3956.  
  3957.     call    chout
  3958.     inc    hl
  3959.         jr      prn1
  3960.  
  3961. ;
  3962. ; 16 bit unsigned compare
  3963. ; compare de against value addressed by hl
  3964. ;
  3965. dcmp:    ld    a,e
  3966.     sub    (hl)
  3967.     inc    hl
  3968.     ld    a,d
  3969.         sbc     a,(hl)
  3970.     dec    hl
  3971.     ret    nz
  3972.  
  3973.     ld    a,e
  3974.     sub    (hl)
  3975.     or    a         ;clear carry
  3976.     ret    
  3977. ;
  3978. ; indirect load hl thru hl
  3979. ;
  3980. lhli:    push    af
  3981.     ld    a,(hl)
  3982.     inc    hl
  3983.     ld    h,(hl)
  3984.     ld    l,a
  3985.     pop    af
  3986.     ret    
  3987. ;
  3988. ; get fp constant from text
  3989. ; pushes value on arg stack & sets argf flag
  3990. ; sets carry if not found
  3991. ;
  3992. const:  ld      a,(txa)      ;prepare call fpin
  3993.         ld      l,a
  3994.         ld      a,(txa+1)
  3995.         ld      h,a
  3996.  
  3997.         push    hl
  3998.         ld      l,e
  3999.         ld      h,d
  4000.         pop     de
  4001.  
  4002.     ld    hl,fpsink
  4003.     call    fpin
  4004.     ret    c
  4005.  
  4006.     dec    de
  4007.  
  4008.         ld      a,e
  4009.         ld      (txa),a      ;now points to terminator
  4010.         ld      a,d
  4011.         ld      (txa+1),a
  4012.  
  4013.     ld    de,fpsink
  4014.     call    psha1
  4015.  
  4016.     xor    a
  4017.     inc    a         ;set a to 1 & clear carry
  4018.     ld    (argf),a
  4019.     ret    
  4020. ;
  4021. ; direct statement checking routine
  4022. ;
  4023. dirt:    ld    a,(dirf)
  4024.     or    a
  4025.     ret    z
  4026.         ld      hl,ermdi        ; 6469h 'di'
  4027.     jp    error
  4028.  
  4029. ;
  4030. ; Set eof address
  4031. ; This needs to be done after a file load
  4032. ;
  4033. findeof:
  4034.         ld      a,(bofa)
  4035.         ld      l,a
  4036.         ld      a,(bofa+1)
  4037.         ld      h,a
  4038.  
  4039.     ld    b,0
  4040. finde1: ld      c,(hl)
  4041.     ld    a,c
  4042.         cp      eof             ;at eof yet?
  4043.         jr      z,finde2        ;yes
  4044.  
  4045.     add    hl,bc
  4046.         jr      finde1
  4047.  
  4048. finde2: ld      a,l
  4049.         ld      (eofa),a
  4050.         ld      a,h
  4051.         ld      (eofa+1),a
  4052.         ret
  4053.  
  4054. ;
  4055. ; find text line with line # given in de
  4056. ; returns text addr count byte in hl
  4057. ;
  4058. findln: ld      a,(bofa)
  4059.         ld      l,a
  4060.         ld      a,(bofa+1)
  4061.         ld      h,a
  4062.  
  4063.     ld    b,0
  4064. find1:    ld    c,(hl)
  4065.     ld    a,c
  4066.     cp    eof
  4067.         jr      z,lerr
  4068.  
  4069.     inc    hl
  4070.     call    dcmp
  4071.     dec    hl
  4072.     ret    z
  4073.  
  4074.     add    hl,bc
  4075.         jr      find1
  4076.  
  4077. lerr:   ld      hl,ermln          ; 6c6eh 'ln'
  4078.     jp    error
  4079. ;
  4080. ; fix floating to positive integer
  4081. ; return integer value in de
  4082. ; fp value from top of arg stack, pop arg stack
  4083. ;
  4084. pfix:   ld      a,(astka)
  4085.         ld      l,a
  4086.         ld      a,(astka+1)
  4087.         ld      h,a
  4088.  
  4089.     ld    b,h
  4090.     ld    c,l
  4091.     push    hl
  4092.     call    aint
  4093.     ld    hl,fpsink
  4094.     call    popas
  4095.     pop    hl
  4096.     ld    c,(hl)         ;exponent
  4097.     dec    hl
  4098.     ld    a,(hl)         ;sign
  4099.     or    a
  4100.     jp    nz,e5         ;negative no good
  4101.  
  4102.     ld    de,-fpsiz+1
  4103.     add    hl,de
  4104.     ld    de,0
  4105.     ld    a,c
  4106.     or    a
  4107.     ret    z
  4108.  
  4109.     dec    c         ;set up for loop close test
  4110. pfix4:    inc    hl
  4111.     ld    a,(hl)
  4112.     rrca    
  4113.     rrca    
  4114.     rrca    
  4115.     rrca    
  4116.     call    mul10
  4117.     jp    c,e5
  4118.  
  4119.     dec    c
  4120.         ld      a,c
  4121.         cp      128
  4122.         ret     c       ;return if C is positive
  4123.  
  4124.     ld    a,(hl)
  4125.     call    mul10
  4126.     jp    c,e5
  4127.  
  4128.     dec    c
  4129.         ld      a,c
  4130.         cp      128
  4131.         jr      nc,pfix4 ;jump if C is negative
  4132.  
  4133.     ret
  4134. ;
  4135. ; take next digit in a (mask to 0fh), accumulate to de
  4136. ;
  4137. mul10:  push    af
  4138.         ld      a,l
  4139.         ld      (miscW1),a
  4140.         ld      a,h
  4141.         ld      (miscW1+1),a
  4142.         pop     af
  4143.  
  4144.     ld    h,d         ;get original value in hl
  4145.     ld    l,e
  4146.     add    hl,hl         ;double it
  4147.     ret    c
  4148.     add    hl,hl         ;quaddruple it
  4149.     ret    c
  4150.     add    hl,de         ;add original for result of 5 x
  4151.     ret    c
  4152.     add    hl,hl         ;result is 10 x
  4153.     ret    c
  4154.  
  4155.         ld      e,l
  4156.         ld      d,h
  4157.  
  4158.         push    af
  4159.         ld      a,(miscW1)
  4160.         ld      l,a
  4161.         ld      a,(miscW1+1)
  4162.         ld      h,a
  4163.         pop     af
  4164.  
  4165.     and    0fh
  4166.         add     a,e
  4167.     ld    e,a
  4168.     ld    a,d
  4169.         adc     a,0            ;propogate the carry
  4170.     ld    d,a
  4171.     ret    
  4172. ;
  4173. ; Get integer from text
  4174. ;
  4175. ; Return:
  4176. ;  set carry if not found
  4177. ;  return integer in hl
  4178. ;  return terminator in a
  4179. ;
  4180. intger:    call    dig
  4181.     ret    c
  4182.  
  4183.     ld    de,0
  4184.         jr      intg2
  4185.  
  4186. intg1:    call    dig
  4187.     ld    h,d
  4188.     ld    l,e
  4189.     ccf    
  4190.     ret    nc
  4191.  
  4192. intg2:    sub    '0'
  4193.     call    mul10
  4194.         jr      nc,intg1
  4195.  
  4196.     ret
  4197.  
  4198. ;
  4199. ; convert string to integer
  4200. ; de = addr of string
  4201. ; exit:
  4202. ; de = updated
  4203. ; hl = converted value
  4204. ;csn:
  4205. ;        ld      hl,0
  4206. ;csn1:   ld      a,(de)
  4207. ;        inc     de
  4208. ;        cp      ' '     ;is it a space?
  4209. ;        jr      z,csn1  ;yes
  4210. ;
  4211. ;        cp      '0'     ;is it a digit?
  4212. ;        jr      c
  4213.  
  4214.  
  4215. ;
  4216. ; convert integer to string
  4217. ; de = addr of string
  4218. ; hl = value to convert
  4219. ; exit:    de = updated value
  4220. ;
  4221. cns:
  4222.     xor    a         ;set for no leading zeroes
  4223.     ld    bc,-10000
  4224.     call    rsub
  4225.     ld    bc,-1000
  4226.     call    rsub
  4227.     ld    bc,-100
  4228.     call    rsub
  4229.     ld    bc,-10
  4230.     call    rsub
  4231.     ld    bc,-1
  4232.     call    rsub
  4233.     ret    nz
  4234.     ld    a,'0'
  4235.     ld    (de),a
  4236.     inc    de
  4237.     ret    
  4238. ;
  4239. ; Take value in hl sub # in bc the
  4240. ; most possible times.
  4241. ; Put value on string at de.
  4242. ; If a=0 then don't put zero on string.
  4243. ; Return non-zero if a put on string
  4244. ;
  4245. rsub:    push    de
  4246.     ld    d,-1
  4247.         di                      ;<----+
  4248. rsub1:  push    hl              ;     |
  4249.         inc     sp              ;     |
  4250.         inc     sp              ;     |
  4251.         inc     d               ;     |
  4252.         add     hl,bc           ;     +---- Kill interrupts since we're
  4253.         jr      c,rsub1         ;     |     unusually messing with stack.
  4254.                                 ;     |
  4255.         dec     sp              ;     |
  4256.         dec     sp              ;     |
  4257.         ei                      ;<----+
  4258.     pop    hl
  4259.     ld    b,d
  4260.     pop    de
  4261.     or    b         ;a gets 0 if a was 0 and b is 0
  4262.     ret    z
  4263.  
  4264.     ld    a,'0'
  4265.         add     a,b
  4266.     ld    (de),a
  4267.     inc    de
  4268.     ret    
  4269.  
  4270. ;
  4271. ;    input character from terminal
  4272. ;
  4273. ;inchar: push    bc
  4274. ;        push    de
  4275. ;        push    hl
  4276. ;vkeyin: call    $-$
  4277. ;        pop     hl
  4278. ;        pop     de
  4279. ;        pop     bc
  4280. ;        and     7fh          ;strip parity bit
  4281. ;        cp      esc
  4282. ;        jp      z,cmnd1
  4283. ;        ld      b,a
  4284. ;        ret 
  4285.  
  4286. ;
  4287. inl0:    call    crlf
  4288. inline:    ld    hl,ibuf
  4289.     ld    c,linlen
  4290. inl1:   ld      b,GBB_RDY    ;Send input ready char.
  4291.         call    chout        ;Only needed by external terminal.
  4292.  
  4293.         call    inchar
  4294.     cp    8
  4295.         jr      z,inl2       ;backspace
  4296.  
  4297.     ld    (hl),a
  4298.     call    chout         ;echo
  4299.     ld    a,b
  4300.     cp    '@'         ;line deletion
  4301.         jr      z,inl0
  4302.  
  4303.     ld    b,lf         ;in case we are done
  4304.     cp    cr
  4305.         jr      z,chout      ;do lf then return
  4306.  
  4307.     inc    hl
  4308.     dec    c
  4309.         jr      nz,inl1
  4310.  
  4311.         ld      hl,ermll        ;6c6ch 'll'
  4312.     jp    error
  4313.  
  4314. inl2:    ld    a,c
  4315. ;        ld      b,bell
  4316.     cp    linlen
  4317.         jr      z,inl1
  4318.  
  4319.     ld    b,8
  4320.         call    chout
  4321.         ld      b,' '
  4322.         call    chout
  4323.         ld      b,8
  4324.     dec    hl
  4325.     inc    c
  4326.  
  4327. inl3:    call    chout
  4328.         jr      inl1
  4329. ;
  4330. ;    output to screen
  4331. ;
  4332. chout:
  4333.         ld      a,b
  4334.         cp      10
  4335.         jr      z,chchk
  4336.  
  4337.         call    SerialTransmit
  4338.  
  4339.         cp      8               ;Is it 00 - 07 ?
  4340.         jr      c,chchk         ;yes, don't display control chars
  4341.  
  4342.         call    outch
  4343. chchk:  cp      cr
  4344.         jr      nz,chlf      ;not cr, is it lf?
  4345.     xor    a
  4346.     jp    pstor         ;return phead to zero
  4347. ;
  4348. chlf:    cp    ' '         ;no phead inc if control char
  4349.     ret    c
  4350.     ld    a,(phead)
  4351.     inc    a
  4352. pstor:    ld    (phead),a
  4353.     ret    
  4354. ;
  4355. crlf2:    call    crlf
  4356. crlf:   ld      b,13
  4357. ;        call    chout
  4358. ;        ld      b,10
  4359.         jp      chout
  4360. ;
  4361. ;    get integer from terminal
  4362. ; de contains string to print first
  4363. ; hl has 1 less than acceptable lower bound
  4364. ; this routine goes to start if bad #
  4365. ; integer value returned in hl
  4366. ;
  4367. gint:    push    hl
  4368.  
  4369.         push    hl
  4370.         ld      l,e
  4371.         ld      h,d
  4372.         pop     de
  4373.  
  4374.     ld    a,(phead)
  4375.     or    a
  4376.     call    nz,crlf
  4377.     call    prnt
  4378.     call    inline
  4379.     ld    hl,ibuf
  4380.  
  4381.         ld      a,l
  4382.         ld      (txa),a
  4383.         ld      a,h
  4384.         ld      (txa+1),a
  4385.  
  4386.     call    intger
  4387.     jp    c,start
  4388.     cp    cr
  4389.     jp    nz,start
  4390.     pop    de
  4391.  
  4392.         ld      a,l
  4393.         ld      (ibuf),a     ;use ibuf as a temp
  4394.         ld      a,h
  4395.         ld      (ibuf+1),a
  4396.  
  4397.     ld    hl,ibuf
  4398.     call    dcmp
  4399.     jp    nc,start
  4400.  
  4401.         ld      a,(ibuf)     ;get the value back to hl
  4402.         ld      l,a
  4403.         ld      a,(ibuf+1)
  4404.         ld      h,a
  4405.  
  4406.     ld    a,(hl)
  4407.     cpl    
  4408.     ld    (hl),a         ;try to store there
  4409.     cp    (hl)
  4410.     jp    nz,start     ;bad or missing memory
  4411.     ret    
  4412. ;
  4413. ;    output fp number addr by hl
  4414. ;
  4415. fpout:    ld    bc,-digit-1
  4416.     add    hl,bc
  4417.     ld    b,h
  4418.     ld    c,l
  4419.     ld    hl,abuf         ;output buffer
  4420.     ld    a,(infes)    ;output format
  4421.     ld    (fes),a         ;store it
  4422.     ld    e,digit
  4423.     ld    (hl),0         ;clear round-off overflow buffer
  4424.     inc    hl         ;abuf+1
  4425. ;
  4426. nxt:    ld    a,(bc)         ;get digit and unpack
  4427.     ld    d,a
  4428.     rra    
  4429.     rra    
  4430.     rra    
  4431.     rra    
  4432.     and    0fh         ;remove bottom digit
  4433.     ld    (hl),a         ;store top digit in output buffer (abuf)
  4434.     inc    hl
  4435.     ld    a,d         ;now get bottom digit
  4436.     and    0fh
  4437.     ld    (hl),a         ;store it
  4438.     inc    hl
  4439.     inc    bc
  4440.     dec    e
  4441.         jr      nz,nxt
  4442.  
  4443.     ld    a,(bc)
  4444.     ld    (fsign),a    ;store sign of number
  4445.     xor    a
  4446.     ld    (hl),a         ;clear round-off buffer (abuf+13) 12 digit no rnd
  4447.     ld    hl,xsign     ;exponent sign store
  4448.     ld    (hl),a         ;clear xsign
  4449. ;
  4450. fix:    inc    bc         ;get exponent
  4451.     ld    a,(bc)
  4452.     or    a         ;exponent zero?
  4453.         jr      z,zro
  4454.  
  4455.     sub    128         ;remove normalizing bias
  4456.         jr      nz,fix2
  4457.  
  4458.     inc    (hl)         ;inc xsign to negative flag (1)later zero
  4459.  
  4460. fix2:
  4461.         cp      128
  4462.         jr      c,chk13
  4463.  
  4464.     cpl             ;it's a negative exponent
  4465.     inc    (hl)         ;inc xsign to negative (1)
  4466. zro:    inc    a
  4467. chk13:    ld    hl,expo         ;exponent temp store
  4468.     ld    (hl),a
  4469.     ld    e,a
  4470.     cp    digit*2
  4471.     ld    hl,fes         ;format temp byte
  4472.         jr      c,chkxo
  4473.  
  4474. chk40:    ld    a,1         ;force exponential printout
  4475.     or    (hl)         ;set format for xout
  4476.     ld    (hl),a
  4477. ;
  4478. chkxo:    ld    a,(hl)         ;check if exponential printout
  4479.     rra    
  4480.         jr      nc,chkx3
  4481.  
  4482.     and    0fh
  4483.     cp    digit*2
  4484.         jr      c,chkx2
  4485.  
  4486.     ld    a,digit*2-1  ;max digits
  4487. chkx2:    ld    d,a
  4488.     inc    a
  4489.         jr      round
  4490. ;
  4491. chkx3:    and    0fh         ;add exponent & decimal places
  4492.     ld    d,a
  4493.         add     a,e
  4494.     cp    digit*2+1
  4495.     ld    b,a
  4496.         jr      c,chkxn
  4497.  
  4498.     ld    a,(hl)
  4499.     and    40h
  4500.         jr      nz,chk40
  4501. ;
  4502. chkxn:    ld    a,(xsign)    ;check exponent sign
  4503.     or    a
  4504.         jr      nz,xneg      ;it's negative
  4505.  
  4506.     ld    a,b
  4507.         jr      round
  4508. ;
  4509. xneg:    ld    a,d         ;sub exponent & decimal place count
  4510.     sub    e
  4511.         jr      nc,xn2
  4512.  
  4513. xn1:    ld    a,(infes)
  4514.         cp      128
  4515.         jp      c,zero
  4516.  
  4517.     and    0eh
  4518.     jp    z,zero
  4519.  
  4520.     rrca
  4521.     ld    e,a
  4522.     dec    e
  4523.     ld    c,1
  4524.     ld    hl,abuf-1
  4525.         jr      nrnd
  4526.  
  4527. xn2:    jr      z,xn1
  4528.         jr      round
  4529. ;
  4530. ;
  4531. clean:    ld    b,1fh         ;clear flags
  4532.     and    b
  4533.     cp    digit*2+1
  4534.     ret    c
  4535.  
  4536.     ld    a,digit*2+1  ;max digits out
  4537.     ret    
  4538. ;
  4539. ; this routine is used to round data to the
  4540. ; specified decimal place
  4541. round:    call    clean
  4542.     ld    c,a
  4543.     ld    b,0
  4544.     ld    hl,abuf+1
  4545.     add    hl,bc         ;get round-off addr
  4546.  
  4547.         ld      a,l
  4548.         ld      (addt),a
  4549.         ld      a,h
  4550.         ld      (addt+1),a
  4551.  
  4552.     ld    a,(hl)
  4553.     cp    5         ;round if >=5
  4554.         jr      c,trl1
  4555. ;
  4556. less1:    dec    hl
  4557.     inc    (hl)         ;round up
  4558.     ld    a,(hl)
  4559.     or    a
  4560.         jr      z,trl2
  4561.  
  4562.     cp    10         ;check if rounded number >9
  4563.         jr      nz,trail
  4564.  
  4565.     ld    (hl),0
  4566.         jr      less1
  4567. ;
  4568. ; this routine eliminates trailing zeros
  4569. trail:  ld      a,(addt)
  4570.         ld      l,a
  4571.         ld      a,(addt+1)
  4572.         ld      h,a
  4573.  
  4574. trl1:   dec     hl
  4575. trl2:    ld    a,(fes)         ;check if trailing zeros are wanted
  4576.     rla    
  4577.         jr      c,fprnt      ;yes, go print data
  4578.  
  4579. trl3:    ld    a,(hl)
  4580.     or    a         ;is it a zero?
  4581.         jr      nz,fprnt     ;no, go print
  4582.  
  4583.     dec    hl
  4584.     dec    c         ;yes, fix output digit count
  4585.         ld      a,c
  4586.         cp      128
  4587.         jp      nc,zeron     ;jump if C is negative
  4588.  
  4589.         jr      trl3
  4590. ;
  4591. ; print format routines
  4592. fprnt:    ld    hl,abuf
  4593.     ld    a,(hl)         ;check if rounded up to 1
  4594.     or    a
  4595.         jr      z,nrnd       ;jump if not
  4596.  
  4597.     ld    b,1
  4598.     ld    a,(xsign)    ;is exponent negative?
  4599.     or    a
  4600.         jr      z,posr
  4601.  
  4602.     ld    b,-1
  4603. ;
  4604. posr:    ld    a,(expo)     ;get exponent
  4605.     or    a
  4606.         jr      nz,po2       ;is it zero? (e+0)
  4607.  
  4608.     ld    (xsign),a
  4609.     ld    b,1
  4610. po2:    add     a,b          ;fix exponent count
  4611.     ld    (expo),a
  4612.     inc    e
  4613.     inc    c
  4614.     dec    hl
  4615. ;
  4616. nrnd:    inc    hl
  4617.     ld    a,c
  4618.     cp    digit*2+1    ;check for maximum digits out
  4619.         jr      nz,nrnd1
  4620.  
  4621.     dec    c
  4622. nrnd1:    ld    a,(fsign)    ;check if neg #
  4623.     rra    
  4624.         jr      nc,prin2     ;go output radix & number
  4625.  
  4626.     call    neg         ;output (-)
  4627.         jr      pri21
  4628. ;
  4629. prin2:    call    space         ;output a space
  4630. pri21:    ld    a,(fes)         ;get output format
  4631.     rra             ;check if exponential output format
  4632.         jr      c,xprin
  4633.  
  4634.     ld    a,(xsign)    ;get exp sign
  4635.     or    a         ;check if neg exp
  4636.         jr      z,posit
  4637.  
  4638.     ld    a,c
  4639.     or    a
  4640.         jr      nz,prin4     ;output radix & number
  4641.  
  4642.         jp      zero         ;no digits after radix, output zero & done
  4643. ;
  4644. prin4:    call    radix         ;print decimal point
  4645. prin6:  xor     a
  4646.     or    e
  4647.         jr      z,prin5      ;jump if no zeros to print
  4648.  
  4649.     call    zero         ;force print a zero
  4650.     dec    e
  4651.         jr      nz,prin6
  4652. ;
  4653. prin5:    call    nout         ;print ascii digit
  4654.         jr      nz,prin5
  4655.     ret    
  4656. ;
  4657. posit:    call    nout
  4658.     dec    e         ;bump exp count
  4659.         jr      nz,posit
  4660.  
  4661.     ld    a,c         ;check if more digits to output
  4662.     or    a
  4663.     ret    z         ;no, done
  4664.         cp      128
  4665.         ret     nc
  4666.  
  4667.         jr      prin4        ;now print decimal point
  4668. ;
  4669. ; exponential format output
  4670. xprin:    call    nout
  4671.         jr      z,ndec       ;integer?
  4672.  
  4673.     call    radix         ;no. print decimal point
  4674. xpri2:    call    nout
  4675.         jr      nz,xpri2
  4676. ;
  4677. ndec:    ld    b,'e'         ;print 'e'
  4678.     call    chout
  4679.     ld    a,(xsign)
  4680.     or    a
  4681.         jr      z,xpri3
  4682.  
  4683.     call    neg         ;print exp sign (-)
  4684.     ld    a,(expo)
  4685.     inc    a
  4686.         jr      xout2
  4687.  
  4688. xpri3:    ld    b,'+'         ;exp (+)
  4689.     call    chout
  4690. ;
  4691. ; convert the exponent from binary-to-ascii
  4692. ; and print the result.
  4693. xout:    ld    a,(expo)
  4694.     dec    a
  4695. xout2:    ld    c,100
  4696.     ld    d,0
  4697.     call    conv
  4698.     cp    '0'         ;skip leading zeros
  4699.         jr      z,xo21
  4700.  
  4701.     inc    d
  4702.     call    chout
  4703. xo21:    ld    a,e
  4704.     ld    c,10
  4705.     call    conv
  4706.     cp    '0'
  4707.         jr      nz,xo3
  4708.  
  4709.     dec    d
  4710.         jr      nz,xo4
  4711.  
  4712. xo3:    call    chout
  4713. xo4:    ld    a,e
  4714.         add     a,'0'          ;add ascii bias
  4715.     ld    b,a
  4716.         jp      chout
  4717. ;
  4718. conv:    ld    b,'0'-1
  4719. conv1:  inc     b
  4720.     sub    c
  4721.         jr      nc,conv1
  4722.  
  4723.         add     a,c
  4724.     ld    e,a
  4725.     ld    a,b
  4726.     ret    
  4727. ;
  4728. ; change bcd digit to ascii & print
  4729. nout:    ld    a,(hl)
  4730.         add     a,'0'
  4731.     ld    b,a
  4732.     call    chout
  4733.     inc    hl
  4734.     dec    c         ;dec total digits printed count
  4735.     ret    
  4736.  
  4737. ; print fp zero
  4738. zeron:  ld      b,' '
  4739.         call    chout
  4740.         jr      zero
  4741. ;
  4742. ; common symbol loading routines
  4743. neg:    ld    b,'-'
  4744.     jp    chout
  4745. zero:    ld    b,'0'
  4746.     jp    chout
  4747. space:    ld    b,' '
  4748.     jp    chout
  4749. radix:    ld    b,'.'
  4750.     jp    chout
  4751.  
  4752. ; converts fp string at de, update de past terminator
  4753. ; puts terminator in b, puts fp # at addr in hl
  4754. ; sets carry if not found
  4755. fpin:
  4756.         push    hl
  4757.  
  4758.         ld      l,e
  4759.         ld      h,d
  4760.  
  4761.         dec     hl
  4762.  
  4763.         ld      a,l
  4764.         ld      (adds),a
  4765.         ld      a,h
  4766.         ld      (adds+1),a
  4767.  
  4768.         call    ibscn           ;get first non-space
  4769.         cp      '&'
  4770.         jr      z,fpin6
  4771.  
  4772.         dec     hl
  4773.         call    ibscn2          ;add back to buffer
  4774.         call    fpins
  4775.         pop     hl
  4776.         jp      nc,entr3
  4777.         ret
  4778.  
  4779. ; get hex number from input
  4780. fpin6:  
  4781.         call    ibscn           ;get 'h'
  4782.         cp      'h'             ;is it hex?
  4783.         jp      nz,e1           ;no
  4784.  
  4785.         call    getnib
  4786.         jp      c,e1            ;bad hex number
  4787.  
  4788.         ld      e,a
  4789.         ld      d,0
  4790.  
  4791.         ld      b,4
  4792. fpin7:  call    getnib
  4793.         jp      c,fpin8
  4794.  
  4795.         dec     b
  4796.         jp      z,e7            ;overflow
  4797.  
  4798.         push    hl              ;de = de * 16
  4799.         ld      l,e
  4800.         ld      h,d
  4801.         add     hl,hl
  4802.         add     hl,hl
  4803.         add     hl,hl
  4804.         add     hl,hl
  4805.         ld      e,l
  4806.         ld      d,h
  4807.         pop     hl
  4808.  
  4809.         add     a,e             ;add a to de
  4810.         ld      e,a
  4811.         ld      a,0
  4812.         adc     a,d
  4813.         ld      d,a
  4814.  
  4815.         jr      fpin7
  4816.  
  4817. fpin8:
  4818.         push    hl
  4819.  
  4820.         ld      l,e             ;put hex number in hl
  4821.         ld      h,d
  4822.  
  4823.         ld      de,cnsbuf       ;convert it to a ascii decimal string
  4824.         call    cns
  4825.         ld      a,cr
  4826.         ld      (de),a
  4827.  
  4828.         ld      de,cnsbuf-1
  4829.         ld      a,e
  4830.         ld      (adds),a
  4831.         ld      a,d
  4832.         ld      (adds+1),a
  4833.         call    fpins
  4834.         pop     de
  4835.         pop     hl
  4836.         push    de
  4837.         call    entr3
  4838.         pop     de
  4839. ;        inc     de
  4840.         ld      a,(de)
  4841.         ld      b,a
  4842.         inc     de
  4843.         ret
  4844.  
  4845. getnib:
  4846.         call    ibscn
  4847.         sub     '0'
  4848.         cp      '9'+1-'0'
  4849.         ccf
  4850.         ret     nc
  4851.  
  4852.         sub     'a'-'0'
  4853.         cp      'f'+'1'-'a'-'0'
  4854.         ccf
  4855.         ret     c
  4856.         add     a,10
  4857.         ret
  4858.  
  4859. ;fpin:
  4860. ;        push    hl
  4861. ;        push    de
  4862. ;
  4863. ;        ld      l,e
  4864. ;        ld      h,d
  4865. ;
  4866. ;        dec     hl
  4867. ;
  4868. ;        ld      a,l
  4869. ;        ld      (adds),a
  4870. ;        ld      a,h
  4871. ;        ld      (adds+1),a
  4872.  
  4873. fpins:
  4874.         push    de
  4875.  
  4876.     ld    hl,opst         ;clear temporary storage areas & bc buffer
  4877.     ld    c,digit+6
  4878.     call    clear
  4879. ;
  4880. scanc:    ld    de,0
  4881.         ld      hl,bcs       ;bc=pack buffer
  4882. scan0:  ld      a,l
  4883.         ld      (bcadd),a    ;pack buffer pointer
  4884.         ld      a,h
  4885.         ld      (bcadd+1),a
  4886.  
  4887. scanp:    ld    hl,scanp
  4888.     push    hl         ;used for return from other routines
  4889.     xor    a
  4890.     ld    (xsign),a    ;clear exp sign byte
  4891. ;
  4892. scang:    call    ibscn
  4893.         jr      c,scanx      ;found a #, go pack it
  4894.     cp    '.'         ;radix?
  4895.         jr      z,scan5      ;process radix pointers
  4896.     cp    'e'         ;exp?
  4897.     jp    z,excon         ;found 'e'', go process exp #
  4898.  
  4899. ;this char not legal in #
  4900.     ld    b,a         ;move terminator to b
  4901.     ld    a,(opst)     ;check if any digits yet
  4902.     and    10h
  4903.     jp    nz,entr2
  4904.  
  4905. ;legal fp number not found
  4906. fpin1:    pop    hl         ;rid of scanp link
  4907.         pop     de           ;text pointer
  4908.     scf    
  4909.     ret    
  4910.  
  4911. ;found decimal point
  4912. scan5:    xor    a         ;found radix process radix pointers for exp
  4913.     or    d         ;any digits yet?
  4914.         jr      nz,scan6
  4915.  
  4916.         add     a,0c0h       ;set ecnt - stop counting digits
  4917.     or    e         ;no int digits, bit 7 is count (or don't) flag
  4918.     ld    e,a         ;bit 6 is negative exp flag
  4919.     ret    
  4920.  
  4921. scan6:    ld    a,80h         ;set ecnt to count digits
  4922.     or    e
  4923.     ld    e,a
  4924.     ret    
  4925. ;
  4926. scanx:    and    0fh         ;found number - remove ascii bias
  4927.     ld    b,a
  4928.     ld    hl,opst         ;set first char flag
  4929.     ld    a,30h
  4930.     or    (hl)
  4931.     ld    (hl),a
  4932.     xor    a
  4933.     or    b         ;is char zero?
  4934.         jr      nz,pack
  4935.  
  4936.     or    d         ;leading zero? ie; any int digits?
  4937.         jr      nz,pack
  4938.  
  4939.     or    e
  4940.     ld    e,a
  4941.     ret    z         ;if counting yet,
  4942.     inc    e         ;ecnt+1-count zeros for exp count
  4943.     ret    
  4944. ;
  4945. ; bcd pack digits into pair bc
  4946. ;
  4947. pack:    ld    a,e
  4948.     rla    
  4949.         jr      c,pack1
  4950.  
  4951.     inc    e
  4952. pack1:    ld    a,e
  4953.     ld    (ecnt),a     ;digit count for exp count
  4954.     inc    d         ;total digit count (d has top/bot flag bit 7)
  4955.     ld    a,d
  4956.     and    7fh         ;remove top/bot flag
  4957.     cp    digit*2+1    ;limit input digits
  4958.     ret    nc
  4959.  
  4960.         ld      a,d
  4961.         cp      128
  4962.         jr      nc,botm
  4963. ;
  4964. top:    or    80h         ;set msb for top flag
  4965.         ld      d,a
  4966.  
  4967.         ld      a,(bcadd)    ;get bc addr
  4968.         ld      l,a
  4969.         ld      a,(bcadd+1)
  4970.         ld      h,a
  4971.  
  4972.         ld      a,b
  4973.     rlca
  4974.     rlca    
  4975.     rlca    
  4976.     rlca    
  4977.     ld    (hl),a         ;save char in bc
  4978.     ret    
  4979. ;
  4980. botm:    and    7fh         ;strip msb (bottom flag)
  4981.     ld    d,a
  4982.     ld    a,b
  4983.  
  4984.         ld      a,(bcadd)
  4985.         ld      l,a
  4986.         ld      a,(bcadd+1)
  4987.         ld      h,a
  4988.  
  4989.         ld      a,b
  4990.     or    (hl)         ;or in top number
  4991.     ld    (hl),a         ;put number back in bc
  4992.     inc    hl
  4993.     pop    bc
  4994.     jp    scan0
  4995.  
  4996. ibscn:  ld      a,(adds)     ;input buffer pointer
  4997.         ld      l,a
  4998.         ld      a,(adds+1)
  4999.         ld      h,a
  5000.  
  5001. ibscn1: inc     hl           ;get next byte
  5002.     ld    a,(hl)
  5003.     cp    ' '
  5004.         jr      z,ibscn1
  5005.  
  5006. ibscn2: push    af
  5007.         ld      a,l
  5008.         ld      (adds),a
  5009.         ld      a,h
  5010.         ld      (adds+1),a
  5011.         pop     af
  5012.  
  5013. ; check for ascii numbers
  5014. nmchk:    cp    '9'+1
  5015.     ret    nc
  5016.     cp    '0'
  5017.     ccf    
  5018.     ret    
  5019. ;
  5020. ; adjust a number in bc buffer & return value
  5021. entr2:    ld    de,0
  5022. ent1:    push    bc         ;terminator
  5023.     call    fixe         ;normalize floating point #
  5024.     pop    bc         ;terminator
  5025.     pop    de         ;scanp link
  5026.     pop    de         ;old text addr
  5027.         or      a
  5028.         ret
  5029.  
  5030.  
  5031.     pop    de         ;ret addr
  5032.  
  5033. entr3:
  5034.         ld      e,l
  5035.         ld      d,h
  5036.         ld      c,digit+2
  5037.         ld      hl,bcs+digit+1
  5038.     call    vcopy
  5039.  
  5040.         push    af
  5041.         ld      a,(adds)
  5042.         ld      l,a
  5043.         ld      a,(adds+1)
  5044.         ld      h,a
  5045.         pop     af
  5046.  
  5047.         push    hl
  5048.         ld      l,e
  5049.         ld      h,d
  5050.         pop     de
  5051.  
  5052.     inc    de
  5053.     or    a
  5054.     ret
  5055.  
  5056. ; clear storage areas
  5057. ; hl = starting address
  5058. ; c = count
  5059. clear:    xor    a
  5060. clear1: ld      (hl),a
  5061.     inc    hl
  5062.     dec    c
  5063.         jr      nz,clear1
  5064.     ret    
  5065. ;
  5066. ; convert ascii exponent of number in the input buffer
  5067. ; to binary. normalize exponent according to the input
  5068. ; format of the number.
  5069. excon:    call    ibscn         ;get character
  5070.         jr      c,exc3
  5071.  
  5072.     cp    plsrw         ;check for unary sign
  5073.         jr      z,exc4
  5074.  
  5075.     cp    '+'
  5076.         jr      z,exc4
  5077.  
  5078.     cp    minrw
  5079.         jr      z,exc2
  5080.  
  5081.     cp    '-'
  5082.         jr      nz,fperr     ;no sign or number?
  5083.  
  5084. exc2:    ld    a,1
  5085.     ld    (xsign),a    ;save sign
  5086. exc4:    call    ibscn
  5087.         jr      nc,fperr     ;no number?
  5088.  
  5089. exc3:    call    ascdc         ;convert ascii to binary
  5090.         jr      ent1         ;normalize # & return
  5091. ;
  5092. ; convert ascii to binary
  5093. ; three consecutive numbers <128 may be converted
  5094. ascdc:  push    hl
  5095.         ld      l,e
  5096.         ld      h,d
  5097.         pop     de
  5098.  
  5099.     ld    hl,0
  5100. asc1:    ld    a,(de)         ;get chr from input buffer, no spaces allowed
  5101.     call    nmchk         ;check if #
  5102.         jr      nc,asc2
  5103.     sub    '0'         ;remove ascii bias
  5104.     ld    b,h
  5105.     ld    c,l
  5106.     add    hl,hl
  5107.     add    hl,hl
  5108.     add    hl,bc
  5109.     add    hl,hl
  5110.     ld    c,a
  5111.     ld    b,0
  5112.     add    hl,bc
  5113.     inc    de
  5114.         jr      asc1
  5115.  
  5116. asc2:   push    hl
  5117.         ld      l,e
  5118.         ld      h,d
  5119.         pop     de
  5120.  
  5121.     ld    b,a         ;save terminator
  5122.  
  5123.         ld      a,l
  5124.         ld      (adds),a     ;save ibuf addr
  5125.         ld      a,h
  5126.         ld      (adds+1),a
  5127.  
  5128.     ld    a,d
  5129.     or    a
  5130.         jr      nz,fperr     ;too big >255
  5131.  
  5132.     ld    a,e
  5133.     rla    
  5134.         jr      c,fperr      ;too big >127
  5135.  
  5136.     rra
  5137.     ret    
  5138.  
  5139. fperr:    pop    bc         ;ascdc ret link
  5140.     jp    fpin1
  5141. ;
  5142. ; normalize input buffer
  5143. fixe:   push    hl
  5144.         ld      l,e
  5145.         ld      h,d
  5146.         pop     de
  5147.  
  5148.         ld      a,(bcs)
  5149.     or    a         ;is it zero?
  5150.         jr      z,zz2
  5151.  
  5152.     call    chkpn         ;set exp pos/neg
  5153.         add     a,80h          ;add exp bias
  5154. zz2:    ld      (bcs+digit+1),a;store normalized exp in bc
  5155.     ret    
  5156. ;
  5157. chkpn:    ld    a,(ecnt)     ;get exp count-set in 'scan' routine
  5158.     ld    e,a
  5159.     and    3fh         ;strip bits 7&8
  5160.     ld    b,a
  5161.     ld    a,(xsign)
  5162.     or    a
  5163.         jr      z,lpos       ;exponent is positive
  5164.  
  5165.     inc    h         ;set sign in h
  5166.     ld    a,40h         ;l is neg
  5167.     and    e         ;check if e is negative
  5168.         jr      z,epos
  5169.  
  5170.     ld    a,l         ;both e&l neg
  5171.     ld    l,b
  5172.         call    bpos1
  5173.     cpl    
  5174.     inc    a
  5175.     ret             ;back to fixe
  5176. ;
  5177. epos:    ld    a,l         ;e&l neg
  5178. epos1:  cpl 
  5179.     inc    a
  5180.         add     a,b
  5181.     ret             ;to fixe
  5182. ;
  5183. lpos:    ld    a,40h         ;exponent positive
  5184.     and    e         ;is e negative?
  5185.         jr      z,bpos
  5186.  
  5187.     ld    a,b
  5188.     ld    b,l
  5189.         jr      epos1
  5190. ;
  5191. bpos:    ld    a,b         ;e&l pos
  5192. bpos1:  add     a,l
  5193.         cp      128
  5194.         ret     c
  5195.  
  5196.     pop    hl
  5197.         jr      fperr
  5198.  
  5199.         .byte    10h
  5200.         .word    0
  5201.         .byte    1
  5202. fpnone: .byte    129
  5203. ;
  5204. ;    four function floating point bcd
  5205. ;
  5206. ;        bc = de # hl
  5207. ;          # is +,-,*, or /.
  5208. ;    <bc>=address of result
  5209. ;    <de>=address of 1st argument
  5210. ;    <hl>=address of 2nd argument
  5211. ; all addresses on entry point to the exponent part of #.
  5212. ; each # consists of (2*digit) packed decimal digits,
  5213. ; a sign, and a biased binary exponent. the exponent range
  5214. ; is 10**-127 to 10**127. the number 0 is represented by
  5215. ; the exponent 0. the numbers are stored in memory as
  5216. ; digit bytes of decimal digits starting at the low order
  5217. ; address. all numbers are assumed to be normalized.
  5218. ;
  5219. ;    floating point addition
  5220. ;
  5221. fadd:    push    bc
  5222.     call    expck         ;fetch arguments
  5223.     ld    c,0
  5224. adsum:    dec    de
  5225.  
  5226.         push    hl
  5227.         ld      l,e
  5228.         ld      h,d
  5229.         pop     de
  5230.  
  5231.         ld    a,(sign)
  5232.     xor    (hl)         ;form sign of result
  5233.     ld    b,a
  5234.  
  5235.         push    hl
  5236.         ld      l,e
  5237.         ld      h,d
  5238.         pop     de
  5239.  
  5240.     ld    a,(de)
  5241.     dec    de
  5242.     xor    c
  5243.     ld    (sign),a
  5244.     ld    hl,rctrl     ;rounding control flag
  5245.     ld    a,(hl)
  5246.     or    a
  5247.     inc    hl
  5248.     ld    a,(hl)         ;get rounding digit
  5249.         jr      z,ads8
  5250.  
  5251.     rlca
  5252.     rlca    
  5253.     rlca    
  5254.     rlca    
  5255. ads8:   add     a,0b0h       ;force carry if digit > 5
  5256.     ld    a,b
  5257.     rra    
  5258.         jr      c,ads1       ;have sub
  5259.  
  5260.     rla             ;restore carry
  5261.     call    add0         ;perform addition
  5262.         jr      nc,ads2
  5263.  
  5264.     ld    b,4
  5265.     call    right
  5266.     ld    hl,exp
  5267.     inc    (hl)         ;inc exp
  5268.     jp    z,over
  5269.  
  5270. ads2:    pop    bc         ;get results addr
  5271.         jp      store        ;save results
  5272.  
  5273. zerex:    pop    hl
  5274.         jr      ads2
  5275.  
  5276. add0:    ld    hl,buf+digit-1
  5277.     ld    b,digit
  5278. add1:    ld    a,(de)
  5279.         adc     a,(hl)
  5280.     daa    
  5281.     ld    (hl),a
  5282.     dec    hl
  5283.     dec    de
  5284.     dec    b
  5285.         jr      nz,add1
  5286.  
  5287.     ret    nc
  5288.     inc    (hl)
  5289.     ret    
  5290. ;
  5291. ;    floating point subtraction
  5292. ;
  5293. fsub:    push    bc
  5294.     call    expck         ;get arguments
  5295.     ld    a,(sign)
  5296.     xor    1         ;complement sign
  5297.     ld    (sign),a
  5298.         jr      adsum
  5299.  
  5300. ads1:    rla             ;restore carry
  5301.     ccf             ;complement for rounding
  5302.     call    sub0         ;subtract arguments
  5303.     ld    hl,sign
  5304.         jr      c,ads4
  5305.  
  5306.     ld    a,(hl)         ;get sign
  5307.     xor    1         ;complement
  5308.     ld    (hl),a
  5309. ads7:    dec    hl
  5310.     ld    b,digit
  5311. ads3:    ld    a,9ah
  5312.         sbc     a,(hl)       ;complement result
  5313.         add     a,0
  5314.     daa    
  5315.     ld    (hl),a
  5316.     dec    hl
  5317.     dec    b
  5318.     ccf    
  5319.         jr      nz,ads3
  5320.  
  5321. ads4:    ld    hl,buf
  5322.     ld    bc,digit
  5323. ads5:    ld    a,(hl)
  5324.     or    a
  5325.         jr      nz,ads6
  5326.  
  5327.     inc    hl
  5328.     inc    b
  5329.     inc    b
  5330.     dec    c
  5331.         jr      nz,ads5
  5332.  
  5333.     xor    a
  5334.     ld    (exp),a
  5335.         jr      ads2
  5336.  
  5337. ads6:    cp    10h
  5338.         jr      nc,ads9
  5339.  
  5340.     inc    b
  5341. ads9:    ld    hl,exp
  5342.     ld    a,(hl)
  5343.     sub    b
  5344.     jp    z,under
  5345.     jp    c,under
  5346.  
  5347.     ld    (hl),a
  5348.     ld    a,b
  5349.     rlca    
  5350.     rlca    
  5351.     ld    b,a
  5352.     call    left
  5353.         jr      ads2
  5354.  
  5355. sub0:    ld    hl,buf+digit-1
  5356.     ld    b,digit
  5357. sub1:    ld    a,99h
  5358.         adc     a,0
  5359.     sub    (hl)
  5360.  
  5361.         push    hl
  5362.         ld      l,e
  5363.         ld      h,d
  5364.         pop     de
  5365.  
  5366.         add     a,(hl)
  5367.     daa
  5368.  
  5369.         push    hl
  5370.         ld      l,e
  5371.         ld      h,d
  5372.         pop     de
  5373.  
  5374.     ld    (hl),a
  5375.     dec    hl
  5376.     dec    de
  5377.     dec    b
  5378.         jr      nz,sub1
  5379.     ret    
  5380. ;
  5381. ;    floating point multiply
  5382. ;
  5383. fmul:    push    bc
  5384.     ld    a,(hl)
  5385.     or    a         ;argument = 0?
  5386.         jr      z,fmul1+2
  5387.  
  5388.     ld    a,(de)
  5389.     or    a         ;argument = 0?
  5390.         jr      z,fmul1+2
  5391.  
  5392.         add     a,(hl)       ;form result exponent
  5393.         jr      c,fmovr
  5394.         cp      128
  5395.         jp      c,under         ;jump if A is positive
  5396.  
  5397.         jr      fmul1
  5398.  
  5399. fmovr:
  5400.         cp      128
  5401.         jp      nc,over
  5402.  
  5403. fmul1:    sub    128         ;remove excess bias
  5404.     ld    (exp),a         ;save exponent
  5405.     dec    de
  5406.     dec    hl
  5407.     ld    a,(de)
  5408.  
  5409.     xor    (hl)         ;form result sign
  5410.     dec    hl
  5411.     dec    de
  5412.     push    hl
  5413.     ld    hl,sign         ;get sign addr
  5414.     ld    (hl),a         ;save sign
  5415.     dec    hl
  5416.     xor    a
  5417.     ld    b,digit+2
  5418. fmul2:    ld    (hl),a         ;zero working buffer
  5419.     dec    hl
  5420.     dec    b
  5421.         jr      nz,fmul2
  5422.  
  5423.     ld    a,(exp)
  5424.     or    a
  5425.     jp    z,zerex
  5426.  
  5427.     ld    c,digit
  5428.     ld    hl,hold1+digit
  5429. ; get multiplier into holding register
  5430. fmul3:    ld    a,(de)
  5431.     ld    (hl),a         ;put in register
  5432.     dec    hl
  5433.     dec    de
  5434.     dec    c
  5435.         jr      nz,fmul3
  5436.  
  5437.     ld    (hl),c
  5438.     dec    hl
  5439.     ld    b,250         ;set loop count
  5440. fmul4:    ld    de,digit+1
  5441.     ld    c,e
  5442.     add    hl,de
  5443.  
  5444.         push    hl
  5445.         ld      l,e
  5446.         ld      h,d
  5447.         pop     de
  5448.  
  5449.     add    hl,de         ;hl=next holding register
  5450.     inc    b
  5451.         ld      a,b
  5452.         cp      128
  5453.         jr      c,fmul8      ;finished
  5454.  
  5455. fmul5:    ld    a,(de)         ;get digits
  5456.         adc     a,a          ;times 2
  5457.     daa    
  5458.     ld    (hl),a         ;put in holding register
  5459.     dec    de
  5460.     dec    hl
  5461.     dec    c
  5462.         jr      nz,fmul5
  5463.  
  5464.     inc    b         ;inc loop count
  5465.         jr      nz,fmul4
  5466.  
  5467. ; form 10x by adding 8x & 2x
  5468. ; first get 8x
  5469.  
  5470.     inc    hl
  5471.     ld    de,hold5     ;next holding register
  5472.     ld    c,digit+1
  5473.     ld    b,c
  5474. fmul6:    ld    a,(hl)
  5475.     ld    (de),a
  5476.     inc    hl
  5477.     inc    de
  5478.     dec    c
  5479.         jr      nz,fmul6
  5480.  
  5481.     ld    hl,hold2+digit;get 2x
  5482.     dec    de
  5483. fmul7:    ld    a,(de)
  5484.         adc     a,(hl)       ;form 10x
  5485.     daa    
  5486.     ld    (de),a
  5487.     dec    de
  5488.     dec    hl
  5489.     dec    b
  5490.         jr      nz,fmul7
  5491.  
  5492.     ld    b,249
  5493.  
  5494.         push    hl
  5495.         ld      l,e
  5496.         ld      h,d
  5497.         pop     de
  5498.  
  5499.         jr      fmul4
  5500.  
  5501. fmul8:  push    hl
  5502.         ld      l,e
  5503.         ld      h,d
  5504.         pop     de
  5505.  
  5506.     inc    hl
  5507.  
  5508.     ld    (hl),digit+1 ;set next loop count
  5509. ; perform accumulation of product
  5510. fmul9:    pop    bc         ;get multiplier
  5511.     ld    hl,hold8+digit+1
  5512.     dec    (hl)         ;dec loop count
  5513.         jr      z,fmu14      ;finished
  5514.  
  5515.     ld    a,(bc)
  5516.     dec    bc
  5517.     push    bc
  5518.     dec    hl
  5519.  
  5520.         push    hl
  5521.         ld      l,e
  5522.         ld      h,d
  5523.         pop     de
  5524.  
  5525. fmu10:  add     a,a          ;check for bit in carry
  5526.         jr      c,fmu11      ;found a bit
  5527.         jr      z,fmu12      ;zero, finished this digit
  5528.  
  5529.     ld    hl,-digit-1
  5530.     add    hl,de         ;point to next holding register
  5531.  
  5532.         push    hl
  5533.         ld      l,e
  5534.         ld      h,d
  5535.         pop     de
  5536.  
  5537.         jr      fmu10
  5538.  
  5539. fmu11:    ld    c,a
  5540.     or    a         ;clear carry
  5541.     call    add0         ;accumulate product
  5542.     ld    a,(de)
  5543.         add     a,(hl)
  5544.     daa    
  5545.     ld    (hl),a
  5546.     ld    a,c
  5547.     dec    de
  5548.         jr      fmu10
  5549.  
  5550. ; rotate right 1 byte
  5551. fmu12:    ld    b,8
  5552.     call    right
  5553.         jr      fmul9
  5554.  
  5555. fmu14:    ld    a,(buf)
  5556.     and    0f0h         ;check if normalized
  5557.         jr      z,fmu17
  5558.  
  5559.     ld    a,d
  5560.     and    0f0h
  5561.     ld    hl,sign-1
  5562.         jr      fmu18
  5563.  
  5564. fmu17:    ld    b,4
  5565.     ld    hl,exp
  5566.     dec    (hl)
  5567.     jp    z,under
  5568.  
  5569.     call    left         ;normalize
  5570.     ld    a,d         ;get digit shifted off
  5571. ; perform rounding
  5572.     rrca    
  5573.     rrca    
  5574.     rrca    
  5575.     rrca    
  5576. fmu18:    cp    50h
  5577.         jr      c,fmu16
  5578.  
  5579.     inc    a
  5580.     and    0fh
  5581.     ld    c,digit
  5582. fmu15:  adc     a,(hl)
  5583.     daa    
  5584.     ld    (hl),a
  5585.     ld    a,0
  5586.     dec    hl
  5587.     dec    c
  5588.         jr      nz,fmu15
  5589.  
  5590. ; check for rounding overflow
  5591.     jp    nc,ads2         ;no overflow
  5592.  
  5593.     inc    hl
  5594.     ld    (hl),10h
  5595.     ld    hl,exp
  5596.     inc    (hl)
  5597.     jp    nz,ads2
  5598.     jp    over
  5599.  
  5600. ; rounding not needed
  5601. fmu16:    and    0fh
  5602.         add     a,(hl)
  5603.     ld    (hl),a
  5604.     jp    ads2
  5605. ;
  5606. ;    floating point division
  5607. ;
  5608. fdiv:    push    bc
  5609.     ld    a,(hl)         ;fetch divisor exp
  5610.     or    a         ;divide by 0?
  5611.     jp    z,divz
  5612.  
  5613.     ld    a,(de)
  5614.     or    a         ;dividend = 0?
  5615.     jp    z,insp
  5616.  
  5617.     sub    (hl)
  5618.         jr      c,divun
  5619.         cp      128
  5620.         jp      nc,over
  5621.         jr      fdi1
  5622.  
  5623. divun:  cp      128
  5624.         jp      c,under         ;jump if positive
  5625.  
  5626. fdi1:   add     a,129        ;form quotient exp
  5627.     ld    (expd),a
  5628.  
  5629.         push    hl
  5630.         ld      l,e
  5631.         ld      h,d
  5632.         pop     de
  5633.  
  5634.     push    de
  5635.     call    load         ;fetch dividend
  5636.     pop    de
  5637.  
  5638.         push    hl
  5639.         ld      l,e
  5640.         ld      h,d
  5641.         pop     de
  5642.  
  5643.     ld    a,(sign)
  5644.     dec    hl
  5645.     xor    (hl)         ;form quotient sign
  5646.     ld    (signd),a
  5647.  
  5648.         push    hl
  5649.         ld      l,e
  5650.         ld      h,d
  5651.         pop     de
  5652.  
  5653.     dec    de
  5654.     ld    bc,hold1
  5655. div0:    ld    l,digit+digit
  5656. div1:    push    bc
  5657.     push    hl
  5658.     ld    c,0         ;quotient digit = 0
  5659. div3:    scf             ;set carry
  5660.     ld    hl,buf+digit-1
  5661.     ld    b,digit
  5662. div4:    ld    a,99h
  5663.         adc     a,0
  5664.  
  5665.         push    hl
  5666.         ld      l,e
  5667.         ld      h,d
  5668.         pop     de
  5669.  
  5670.     sub    (hl)
  5671.  
  5672.         push    hl
  5673.         ld      l,e
  5674.         ld      h,d
  5675.         pop     de
  5676.  
  5677.         add     a,(hl)
  5678.     daa    
  5679.     ld    (hl),a
  5680.     dec    hl
  5681.     dec    de
  5682.     dec    b
  5683.         jr      nz,div4
  5684.  
  5685.     ld    a,(hl)
  5686.     ccf    
  5687.         sbc     a,0
  5688.     ld    (hl),a
  5689.     rra    
  5690.     ld    hl,digit
  5691.     add    hl,de
  5692.  
  5693.         push    hl
  5694.         ld      l,e
  5695.         ld      h,d
  5696.         pop     de
  5697.  
  5698.     inc    c         ;inr quotient
  5699.     rla    
  5700.         jr      nc,div3
  5701.  
  5702.     or    a         ;clear carry
  5703.     call    add0         ;restore dividend
  5704.     ld    hl,digit
  5705.     add    hl,de
  5706.  
  5707.         push    hl
  5708.         ld      l,e
  5709.         ld      h,d
  5710.         pop     de
  5711.  
  5712.     push    bc
  5713.     ld    b,4
  5714.     call    left         ;shift dividend
  5715.     pop    bc
  5716.     dec    c
  5717.     pop    hl
  5718.     ld    h,c
  5719.     pop    bc
  5720.     ld    a,l
  5721.         jr      nz,div5
  5722.  
  5723.         cp      digit+digit
  5724.         jr      nz,div5
  5725.  
  5726.     ld    hl,expd
  5727.     dec    (hl)
  5728.     call    z,under
  5729.         jr      div0
  5730.  
  5731. div5:    rra
  5732.     ld    a,h
  5733.         jr      nc,div6
  5734.  
  5735.     ld    a,(bc)
  5736.     rlca    
  5737.     rlca    
  5738.     rlca    
  5739.     rlca    
  5740.         add     a,h
  5741.     ld    (bc),a         ;store quotient
  5742.     inc    bc
  5743.         jr      div7
  5744.  
  5745. div6:    ld    (bc),a         ;store quotient
  5746. div7:    dec    l         ;dec digit count
  5747.         jr      nz,div1
  5748.  
  5749.     ld    hl,expd
  5750.     pop    bc
  5751.         jr      storo
  5752.  
  5753. ; fetch & align arguments for
  5754. ; addition & subtraction
  5755. expck:    ld    a,(de)
  5756.     sub    (hl)         ;difference of exps
  5757.     ld    c,0
  5758.         jr      nc,expc1
  5759.  
  5760.     inc    c
  5761.  
  5762.         push    hl
  5763.         ld      l,e
  5764.         ld      h,d
  5765.         pop     de
  5766.  
  5767.     cpl    
  5768.     inc    a
  5769. expc1:    ld    b,a
  5770.     ld    a,(de)
  5771.     ld    (exp),a
  5772.     ld    a,b
  5773.     cp    digit+digit
  5774.         jr      c,expc2
  5775.  
  5776.     ld    a,digit+digit
  5777. expc2:    rlca    
  5778.     rlca    
  5779.     ld    b,a
  5780.     and    4
  5781.     ld    (rctrl),a    ;set rounding control
  5782.     push    bc
  5783.     push    de
  5784.     call    load         ;load smaller value
  5785.     ld    a,8*digit+16
  5786.     sub    b
  5787.     cp    8*digit+16
  5788.         jr      z,expc3
  5789.  
  5790.     and    0f8h
  5791.     rra    
  5792.     rra    
  5793.     rra    
  5794.         add     a,e
  5795.     ld    e,a
  5796.     ld    a,d
  5797.         adc     a,0
  5798.     ld    d,a
  5799.     ld    a,(de)         ;get rounding digit
  5800.     ld    (rdigi),a    ;save
  5801. expc3:    call    right         ;align values
  5802.     pop    de
  5803.     pop    bc
  5804.     ret    
  5805.  
  5806. ; load argument into buffer
  5807. load:   ld      de,sign
  5808.         ld      c,digit+1
  5809.         dec     hl
  5810. load1:  ld      a,(hl)
  5811.         ld      (de),a
  5812.         dec     hl
  5813.         dec     de
  5814.         dec     c
  5815.         jr      nz,load1
  5816.  
  5817.         xor     a
  5818.         ld      (de),a
  5819.         dec     de
  5820.         ld      (de),a
  5821.         ld      (rdigi),a    ;zero rounding digit
  5822.         ret 
  5823.  
  5824. ; store results in memory
  5825. store:  ld      hl,exp
  5826. storo:    ld    e,digit+2
  5827. stor1:    ld    a,(hl)
  5828.     ld    (bc),a
  5829.     dec    bc
  5830.     dec    hl
  5831.     dec    e
  5832.         jr      nz,stor1
  5833.     ret    
  5834.  
  5835. ; shift right number of digits in b/4
  5836. right:    ld    c,digit+1
  5837. righ1:    ld    hl,buf-1
  5838.     ld    a,b
  5839.     sub    8         ;check if byte can be shifted
  5840.         jr      nc,righ3
  5841.  
  5842.     dec    b
  5843.         push    af
  5844.         ld      a,b
  5845.         cp      128
  5846.         jr      c,righ5
  5847.  
  5848.         pop     af
  5849.         ret
  5850.  
  5851. righ5:
  5852.         pop     af
  5853.  
  5854.     or    a
  5855. righ2:    ld    a,(hl)
  5856.     rra    
  5857.     ld    (hl),a
  5858.     inc    hl
  5859.     dec    c
  5860.         jr      nz,righ2
  5861.         jr      right
  5862.  
  5863. ; shift right one byte
  5864. righ3:    ld    b,a
  5865.     xor    a
  5866. righ4:    ld    d,(hl)
  5867.     ld    (hl),a
  5868.     ld    a,d
  5869.     inc    hl
  5870.     dec    c
  5871.         jr      nz,righ4
  5872.         jr      right
  5873.  
  5874. ; shift left number of digits in b/4
  5875. left:    ld    c,digit+1
  5876.     ld    hl,sign-1
  5877. lef1:    ld    a,b
  5878.     sub    8
  5879.         jr      nc,lef3
  5880.  
  5881.     dec    b
  5882.         push    af
  5883.         ld      a,b
  5884.         cp      128
  5885.         jr      c,lef5
  5886.  
  5887.         pop     af
  5888.         ret
  5889.  
  5890. lef5:
  5891.         pop     af
  5892.  
  5893.     or    a
  5894. lef2:    ld    a,(hl)
  5895.     rla    
  5896.     ld    (hl),a
  5897.     dec    hl
  5898.     dec    c
  5899.         jr      nz,lef2
  5900.         jr      left
  5901.  
  5902. ; shift left one byte
  5903. lef3:    ld    b,a
  5904.     xor    a
  5905. lef4:    ld    d,(hl)
  5906.     ld    (hl),a
  5907.     ld    a,d
  5908.     dec    hl
  5909.     dec    c
  5910.         jr      nz,lef4
  5911.         jr      left
  5912.  
  5913. ; set flags for overflow, underflow
  5914. ; and divide by zero
  5915. over:   ld      hl,ermfp                ;6670h 'fp'
  5916.     jp    error
  5917.  
  5918. under:  ld      a,0ffh
  5919.     ld    (erri),a
  5920. insp:    inc    sp
  5921.     inc    sp
  5922.     ret    
  5923.  
  5924. divz:   ld      hl,ermdz
  5925.         jp      error
  5926.  
  5927. ilprc:  EX_SP_HL
  5928.         push    af
  5929.         push    bc
  5930.         push    de
  5931. ilpr1:  ld      a,(hl)
  5932.         inc     hl
  5933.         or      a
  5934.         jr      z,ilprt2
  5935.         ld      b,a
  5936.         call    chout
  5937.         jr      ilpr1
  5938. ilprt2:
  5939.         call    crlf
  5940.         pop     de
  5941.         pop     bc
  5942.         pop     af
  5943.         EX_SP_HL
  5944.         ret
  5945.  
  5946.         .block  $8000-$         ;fill up whole 32768 block
  5947.  
  5948.         .end 
  5949. 
  5950.