home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / misc / bcpl.ark / LOADB.MAC < prev    next >
Encoding:
Text File  |  1988-11-27  |  66.5 KB  |  3,155 lines
  1.     aseg
  2.     org    0100h
  3. ;*******************************************************************
  4. ;* Loader.                                                         *
  5. ;* Inputs one or more code files, and builds COM file image in     *
  6. ;* memory. If a second filename is provided, the image is saved    *
  7. ;* otherwise it is executed. The runtime memory map is:            *
  8. ;*                                                                 *
  9. ;* run-time & library : Global vector : program : stack            *
  10. ;*                                                                 *
  11. ;*******************************************************************
  12.  
  13. nolabs        equ    400    ;labels allowed in loader
  14. nofiles        equ    20    ;max number of input files to loader
  15. clifcb1        equ    05ch    ;where ccp puts fcbs
  16. clifcb2        equ    06ch
  17.  
  18.         jp    loader
  19.         ds    1    ;keep the next bits aligned for PATCH
  20.  
  21. noglobs:    dw    200            ;size of global vector
  22. stacksize:    dw    2000            ;size of stack
  23. curfcb:        ds    2            ;workspace
  24. lastfcb:    ds    2
  25. firstfcb:    ds    2
  26. labeltab:    ds    2
  27. nloc:        ds    2
  28. realaddr:    ds    2
  29. imageglobs:    ds    2
  30. symtab:        ds    2
  31. sobuff:        ds    2
  32. soptr:        ds    1
  33. comfile:    ds    1
  34. symfile:    ds    1
  35. bpnt:        ds    1
  36. errflg:        ds    1
  37. glbovf:        ds    1
  38. labovf:        ds    1
  39. filecnt:    ds    1
  40. newflg:        ds    1
  41.     
  42.         page
  43. ;*******************************************************************
  44. ;*         Instruction table                                       *
  45. ;* Four bytes for each code-stream small integer.               *
  46. ;* The first has a 0-3 length field in bits 0-1, and argument type *
  47. ;* in bits 6-4, the argument types are:                            *
  48. ;* 0 : no argument                                                 *
  49. ;* 1 : word: copy 16b from stream after instruction                *
  50. ;* 2 : byte: copy 8b from stream                                   *
  51. ;* 3 : mlabel: 16b from stream is label no. put machine address    *
  52. ;*             of label after instruction                          *
  53. ;* 4 : blabel: as above, but BCPL address of label                 *
  54. ;* 5 : mglobal : 16b from stream, is global number, replace with   *
  55. ;*               machine address of global                         *
  56. ;* 6 : bglobal : as above, but BCPL address                        *
  57. ;* 7 : reljp   : same as mlabel, except that a relative jump can   *
  58. ;*               be used here if in range.                         *
  59. ;* Next three bytes are intruction, 0-3 of these are copied,       *
  60. ;* depending on length field.                                      *
  61. ;*                                                                 *
  62. ;* THIS TABLE MUST BE KEPT CONSISTENT WITH COMPHDR                 *
  63. ;*******************************************************************
  64.  
  65. word    equ    010h        ;Argument types for intruction table
  66. byte    equ    020h
  67. mlabel    equ    030h
  68. blabel    equ    040h
  69. mglobal    equ    050h
  70. bglobal    equ    060h
  71. reljp      equ    070h
  72.  
  73. endfile        equ    0
  74. labdef        equ    1    ;Special icodes
  75. gorg        equ    2
  76. walign        equ    3
  77. needs        equ    4
  78. section        equ    5
  79. startsec    equ    6
  80. startfile    equ    7
  81. globsym        equ    8
  82. labsym        equ    9
  83. newlab        equ    10
  84. jumpinst    equ     72    ;The number of JPLAB, so we can do
  85.                 ;branch shorting. Update if you change JPLAB
  86.  
  87. itable:    db    0+word,0,0,0        ;S.DW:"DW 0%X4H"
  88.     db    0+mlabel,0,0,0        ;S.DWLAB:"DW L%D"
  89.     db    0+byte,0,0,0        ;S.DB:"DB 0%X2H"
  90.     db    1+byte,006h,0,0        ;S.LIMB:"LD B,0%X2H"
  91.     db    1+word,011h,0,0        ;S.LIMDE:"LD DE,0%X4H"
  92.     db    1+word,001h,0,0        ;S.LIMBC:"LD BC,0%X4H"
  93.     db    1+word,021h,0,0        ;S.LIMHL:"LD HL,0%X4H"
  94.     db    1,0cfh,0,0        ;S.RTAP:"RST 08H"
  95.     db    2+word,0fdh,021h,0    ;S.LIMIY:"LD IY,0%X4H"
  96.     db    3,0c3h            ;S.GOTO:"JP GOTO"
  97.     dw    goto
  98.     db    1,029h,0,0        ;S.ADDHH:"ADD HL,HL"
  99.     db    1,019h,0,0        ;S.PLUS:"ADD HL,DE"
  100.         db      1,06eh,0,0        ;S.LDBYTE:"LD L,(HL)"
  101.         db      1+byte,026h,0,0        ;S.LDHIM:"LD H,0%X2H"
  102.     db    1+byte,0cbh,0,0        ;S.BIT:"BIT N,(HL)"
  103.     db    2,0ddh,02bh,0        ;S.DECIX:"DEC IX"
  104.     db    1,0c9h,0,0        ;S.RET:"RET"
  105.     db    3,0c3h            ;S.FINISH:"JP FINISH"
  106.     dw    finish
  107.     db    2,0fdh,039h,0        ;S.ADDIYSP:"ADD IY,SP"
  108.     db    1,0b7h,0,0        ;S.ORA:"OR A"
  109.     db    1,0b4h,0,0        ;S.ORH:"OR H"
  110.     db    2,0edh,052h,0        ;S.MINUS:"SBC HL,DE"
  111.     db    1,07dh,0,0        ;S.LDAL:"LD A,L"
  112.     db    1+reljp,0cah,0,0    ;S.JPZ:"JP Z,L%D"
  113.     db    1+reljp,0c2h,0,0    ;S.JPNZ:"JP NZ,L%D"
  114.     db    1+reljp,0dah,0,0    ;S.JPC:"JP C,L%D"
  115.     db    1+reljp,0d2h,0,0    ;S.JPNC:"JP NC,L%D"
  116.     db    1+mlabel,0e2h,0,0    ;S.JPPO:"JP PO,L%D"
  117.     db    1+mlabel,0eah,0,0    ;S.JPPE:"JP PE,L%D"
  118.     db    1,03dh,0,0        ;S.DECA:"DEC A"
  119.     db    1+byte,0d6h,0,0        ;S.SUBA:"SUB %X2H"
  120.     db    3,0cdh            ;S.SWITCHON:"CALL SWITCH"
  121.     dw    switch
  122.     db    1,0e5h,0,0        ;S.PUSHHL:"PUSH HL"
  123.     db    1,0e1h,0,0        ;S.POPHL:"POP HL"
  124.     db    1,0d5h,0,0        ;S.PUSHDE:"PUSH DE"
  125.     db    1,0d1h,0,0        ;S.POPDE:"POP DE"
  126.     db    3,0cdh            ;S.NEG:"CALL NEG"
  127.     dw    neg
  128.     db    3,0cdh            ;S.ABS:"CALL ABS"
  129.     dw    abs
  130.     db    3,0cdh            ;S.NOT:"CALL NOT"
  131.     dw    not
  132.     db    1,0dfh,0,0        ;S.RV:"RST 18"
  133.     db    1+reljp,0c3h,0,0    ;S.JPLAB:"JP L%D"
  134.     db    2+byte,0ddh,06eh,0    ;S.LDLIX:"LD L,(IX+%D)"
  135.     db    2+byte,0ddh,075h,0    ;S.STLIX:"LD (IX+%D),L"
  136.     db    2+byte,0ddh,066h,0    ;S.LDHIX:"LD H,(IX+%D)"
  137.     db    2+byte,0ddh,074h,0    ;S.STHIX:"LD (IX+%D),H"
  138.     db    2+byte,0ddh,05eh,0    ;S.LDEIX:"LD E,(IX+%D)"
  139.     db    1,09h,0,0        ;S.ADDHB:"ADD HL,BC"
  140.     db    2+byte,0ddh,056h,0    ;S.LDDIX:"LD D,(IX+%D)"
  141.     db    3,0cdh            ;S.OFRV:"CALL OFRV"
  142.     dw    ofrv
  143.     db    1+mglobal,02ah,0,0    ;S.LDHLGLB:"LD HL,(GLOBS+<n>*2)"
  144.     db    1+mglobal,022h,0,0    ;S.STHLGLB:"LD (GLOBS+<n>*2),HL"
  145.     db    2+mglobal,0edh,05bh,0    ;S.LDDEGLB:"LD DE,(GLOBS+<n>*2)"
  146.     db    3,0cdh            ;S.OFLV:"CALL OFLV"
  147.     dw    oflv
  148.     db    1+mlabel,02ah,0,0    ;S.LDHLLAB:"LD HL,(L%D)"
  149.     db    1+mlabel,022h,0,0    ;S.STHLLAB:"LD (L%D),HL"
  150.     db    2+mlabel,0edh,05bh,0    ;S.LDDELAB:"LD DE,(L%D)"
  151.     db    3,0cdh            ;S.VEC:"CALL VECTOR"
  152.     dw    vector
  153.     db    3,0cdh            ;S.BYTEAP:"CALL GETBYTE"
  154.     dw    getbyte
  155.     db    3,0cdh            ;S.DIV:"CALL DIV"
  156.     dw    div
  157.     db    3,0cdh            ;S.REM:"CALL REM"
  158.     dw    rem
  159.     db    3,0cdh            ;S.MULT:"CALL MULT"
  160.     dw    mult
  161.     db    3,0cdh            ;S.LS:"CALL LESS"
  162.     dw    less
  163.     db    3,0cdh            ;S.GR:"CALL GREATER"
  164.     dw    greater
  165.     db    3,0cdh            ;S.LE:"CALL LESSEQ"
  166.     dw    lesseq
  167.     db    3,0cdh            ;S.GE:"CALL GREATEQ"
  168.     dw    greateq
  169.     db    3,0cdh            ;S.EQ:"CALL EQUALS"
  170.     dw    equals
  171.     db    3,0cdh            ;S.NE:"CALL NEQ"
  172.     dw    neq
  173.     db    3,0cdh            ;S.LSHIFT:"CALL LSHIFT"
  174.     dw    lshift
  175.     db    3,0cdh            ;S.RSHIFT:"CALL RSHIFT"
  176.     dw    rshift
  177.     db    2+byte,0ddh,0b6h,0    ;S.ORIX:"OR (IX+%N)"
  178.     db    3,0cdh            ;S.LOGAND:"CALL LOGAND"
  179.     dw    logand
  180.     db    3,0cdh            ;S.LOGOR:"CALL LOGOR"
  181.     dw    logor
  182.     db    3,0cdh            ;S.EQV:"CALL EQV"
  183.     dw    eqv
  184.     db    3,0cdh            ;S.NEQV:"CALL NEQV"
  185.     dw    neqv
  186.     db    3,0cdh            ;S.LOCADDR:"CALL LOCADDR"
  187.     dw    locaddr
  188.     db    1+bglobal,021h,0,0    ;S.GLBADDR:"LD HL,GLOBALS/2+<n>"
  189.     db    1+blabel,021h,0,0    ;S.LABADDR:"LD HL,L%D/2"
  190.     db    1+blabel,011h,0,0    ;S.LABDEADR:"LD DE,L%D/2"
  191.     db    1,0ebh,0,0        ;S.EXCHG:"EX DE,HL"
  192.     db    1,073h,0,0        ;S.STBYTE:"LD (HL),E"
  193.     db    1,0e7h,0,0        ;S.STIND:"RST 20"
  194.     db    1,023h,0,0        ;S.INCHL:"INC HL"
  195.     db    1,02bh,0,0        ;S.DECHL:"DEC HL"
  196.     db    1,013h,0,0        ;S.INCDE:"INC DE"
  197.     db    1,01bh,0,0        ;S.DECDE:"DEC DE"
  198.     db    2,0edh,062h,0        ;S.SUBHH:"SBC HL,HL"
  199.     db    1+mlabel,0fah,0,0    ;S.JPM:"JP M,L%D"
  200.     db    1+mlabel,0f2h,0,0    ;S.JPP:"JP P,L%D"
  201.     db    2,0fdh,0f9h,0        ;S.LDSPIY:"LD SP,IY"
  202.     db    2,020h,003h,0        ;S.SKIP:"JR NZ,$+5"
  203.     db    2+byte,0ddh,034h,0    ;S.INCLOC:"INC (IX+%N)"
  204.     db    1,0d7h,0,0        ;S.SRTAP:"RST 10"
  205.         db    3,0cdh            ;S.TWODIV:"CALL TWODIV"
  206.     dw    twodiv
  207.     db    2,0ddh,09h,0        ;S.ADDIXBC:"ADD IX,BC"
  208.         db    1+mglobal,03ah,0,0    ;S.LDAGLB:"LD A,(GLOB N)"
  209.         db     1+mlabel,03ah,0,0    ;S.LDALAB:"LD A,(LAB N)"
  210.         db    1+byte,03eh,0,0        ;S.LIMA:"LD A,0%X2H"
  211.         db    2+byte,0ddh,07eh,0    ;S.LDAIX:"LD A,(IX+%N)"
  212.         db    1,077h,0,0        ;S.STBYTEA:"LD (HL),A"
  213.     db    1+byte,036h,0,0        ;S.STBYTIM:"LD (HL),0%X2H"
  214.     db    2+word,0ddh,036h,0    ;S.LDIXIM:"LD (IX+%N),0%X2H"
  215.     db    2,0edh,042h,0        ;S.SUBHB:"SBC HL,BC"
  216.     db    2,028h,01h,0        ;S.SKIPZ:"JR Z,$+3"
  217.     db    2,0ddh,023h,0        ;S.INCIX:"INC IX"
  218.  
  219.     page    
  220. ;********************************
  221. ;* global vector.               *
  222. ;********************************
  223.  
  224. ; used by the loader to initialise the global vector in the
  225. ; program image it is building
  226.  
  227. globtab:
  228.     dw    globund        ;START, filled in later
  229.     dw    wrch        ;global 1
  230.     dw    rdch        ;   "   2
  231.     dw    endtoinput    ;   "   3
  232.     dw    binaryoutput    ;   "    4
  233.     dw    binaryinput    ;   "    5
  234.     dw    selectinput    ;   "    6
  235.     dw    selectoutput    ;   "    7
  236.     dw    endread        ;   "   8
  237.     dw    endwrite    ;   "    9
  238.     dw    findinput    ;   "    10
  239.     dw    findoutput    ;   "    11
  240.     dw    longjump    ;   "   12
  241.     dw    unrdch        ;   "    13
  242.     dw    input        ;   "    14
  243.     dw    output        ;   "   15
  244.     dw    level1        ;   "   16
  245.     dw    level2        ;   "   17
  246.     dw    rewind        ;   "   18
  247.     dw    stackavail    ;   "   19
  248.     dw    callbdos    ;   "   20
  249.     dw    parse        ;   "   21
  250.     dw    muldiv        ;   "   22
  251.     dw    in        ;   "   23
  252.     dw    out        ;   "   24
  253.     dw    createco    ;   "   25
  254.     dw    currentco    ;   "   26
  255.     dw    callco        ;   "   27
  256.     dw    cowait          ;   "   28
  257.         dw      resumeco        ;   "   29
  258.     dw    colongjump    ;   "   30
  259.     dw    deleteco    ;   "   31
  260.     dw    getvec        ;   "   32
  261.     dw    freevec        ;   "   33
  262.     dw    maxvec        ;   "   34
  263.     dw    intkey        ;   "   35
  264.     dw    memcpy        ;   "   36
  265.     dw    removeinput    ;   "   37
  266.     dw    removeoutput    ;   "   38
  267.     dw    0        ; marks the end
  268.  
  269.     page
  270.  
  271. ;*************************************************
  272. ;* Run time system routines:                     *
  273. ;* Names and addresses of the runtime system     *
  274. ;* components, so that we can put them in the    *
  275. ;* symbol file. Note that the names must not be  *
  276. ;* legal BCPL names, to avoid clashes. We use    *
  277. ;* either a trailing period, or [] to do this.   *
  278. ;*************************************************
  279. rtnames:dw    locaddr
  280.     db    'LOCADDR.',0
  281.     dw    vector
  282.     db    'VECTOR.',0
  283.     dw    getbyte
  284.     db    'GETBYTE.',0
  285.     dw    switch
  286.     db    'SWITCH.',0
  287.     dw    goto
  288.     db    'GOTO.',0
  289.     dw    oflv
  290.     db    'OFLV.',0
  291.     dw    ofrv
  292.     db    'OFRV.',0
  293.     dw    rshift
  294.     db    '[>>]',0
  295.     dw    lshift
  296.     db    '[<<]',0
  297.     dw    logand
  298.     db    '[&]',0
  299.     dw    logor
  300.     db    '[|]',0
  301.     dw    neqv
  302.     db    'NEQV.',0
  303.     dw    eqv
  304.     db    'EQV.',0
  305.     dw    not
  306.     db    'NOT.',0
  307.     dw    abs
  308.     db    'ABS.',0
  309.     dw    neg
  310.     db    'NEG.',0
  311.     dw    lesseq
  312.     db    '[<=]',0
  313.     dw    less
  314.     db    '[<]',0
  315.     dw    greateq
  316.     db    '[>=]',0
  317.     dw    greater
  318.     db    '[>]',0
  319.     dw    equals
  320.     db    '[=]',0
  321.     dw    neq
  322.     db    '[~=]',0
  323.     dw    mult
  324.     db    '[*]',0
  325.     dw    div
  326.     db    '[/]',0
  327.     dw    rem
  328.     db    'REM.',0
  329.     dw    twodiv
  330.     db    'TWODIV.',0
  331.     dw    finish
  332.     db    'FINISH.',0
  333.     dw    0            ;mark the end
  334.  
  335.     page
  336. ;**************************************************
  337. ;* Loader.                                        *
  338. ;**************************************************
  339.  
  340. loader:    ld    hl,(6)            ;get top of memory
  341.     dec    hl
  342.     ld    sp,hl            ;put stack at top of memory
  343.     ld    de,signon        ;say hello
  344.     ld    c,bprtstrng
  345.     call    5
  346.     ld    de,ssstring        ;say how big the stack will be
  347.     ld    c,bprtstrng
  348.     call    5
  349.     ld    bc,(stacksize)
  350.     call    decout
  351.     ld    de,gsstring        ;and the global vector
  352.     ld    c,bprtstrng
  353.     call    5
  354.     ld    bc,(noglobs)
  355.     call    decout
  356.     ld    de,estring
  357.     ld    c,bprtstrng
  358.     call    5
  359.     ld    hl,-(nofiles*33+200)    ;make room for stack and fcbs
  360.     add    hl,sp
  361.     ld    (curfcb),hl        ;first fcb is there
  362.     ld    (firstfcb),hl
  363.     push    hl
  364.     ld    de,33            ;point to last fcb
  365.     add    hl,de
  366.     ld    (lastfcb),hl
  367.     pop    hl
  368.     ld    de,(noglobs)        ;save one byte for each global
  369.     or    a            ;to stamp on duplicate symbols
  370.     sbc    hl,de
  371.     ld    (symtab),hl
  372.     push    hl
  373. zerosyms:
  374.     ld    (hl),0            ;set them to zero
  375.     dec    de
  376.     inc    hl
  377.     ld    a,e
  378.     or    d
  379.     jr    nz,zerosyms
  380.     pop    hl
  381.     ld    de,-128            ;save 128 bytes as output buffer
  382.     add    hl,de            ;for symbol file
  383.     ld    (sobuff),hl
  384.     ld    de,-nolabs*4        ;make room for the label table
  385.     add    hl,de
  386.     ld    (labeltab),hl
  387.     ld    a,(clifcb1+1)        ;do we have 1 source file?
  388.     cp    ' '
  389.     jr    nz,sffound
  390.     ld    a,(clifcb1+9)
  391.     cp    ' '
  392.     jr    nz,sffound
  393.     ld    de,clifcb1        ;copy in default BCPL.OUT
  394.     ld    hl,defname
  395.     ld    bc,14
  396.     ldir
  397. sffound:
  398.     ld    a,0            ;clear the bits in the two fcbs
  399.     ld    (clifcb1+12),a
  400.     ld    (clifcb1+14),a
  401.     ld    (clifcb1+32),a
  402.     ld    de,(firstfcb)        ;fcb1 is first input fcb
  403.     ld    hl,clifcb1
  404.     ld    bc,33
  405.     ldir                ;so copy it there
  406.     ld    hl,clifcb2        ;move second fcb to 1st pos
  407.     ld    de,clifcb1        ;for output
  408.     ld    bc,12
  409.     ldir
  410.     ld    (clifcb1+12),a        ;and zero it's bits
  411.     ld    (clifcb1+14),a
  412.     ld    (clifcb1+32),a
  413.     ld    a,0
  414.     ld    (comfile),a        ;assume no .COM output
  415.     ld    (symfile),a        ;and no .SYM
  416.     ld    a,(clifcb1+1)        ;is there a second filename?
  417.     cp    ' '
  418.     jr    z,nosym            ;if not it will be loadgo
  419.     ld    a,1            ;there will be a codefile
  420.     ld    (comfile),a
  421.     ld    a,(clifcb1+9)        ;is there an extension?
  422.     cp    ' '
  423.     jr    nz,nosym        ;if so just use it
  424.     ld    a,1
  425.     ld    (symfile),a        ;if not invent .COM and .SYM 
  426.     ld    a,'S'
  427.     ld    (clifcb1+9),a
  428.     ld    a,'Y'            ;put the .SYM in
  429.     ld    (clifcb1+10),a
  430.     ld    a,'M'
  431.     ld    (clifcb1+11),a
  432.     ld    de,clifcb1        ;now open the sym file
  433.     ld    c,bdel
  434.     call    5
  435.     ld    de,clifcb1
  436.     ld    c,bmake
  437.     call    5
  438.     inc    a
  439.     jp    z,dirfull
  440. nosym:    ld    a,0            ;clear the buffer pointer
  441.     ld    (soptr),a
  442.     ld    (errflg),a        ;no errors yet
  443.     ld    de,rtnames        ;output the symbols for the
  444. bi:    ld    a,(de)            ;run-time system
  445.     ld    l,a
  446.     inc    de
  447.     ld    a,(de)
  448.     inc    de
  449.     ld    h,a
  450.     or    l            ;zero marks the end
  451.     jp    z,bifin
  452.     ld    b,4            ;print address
  453. bi1:    ld    a,3            ;this code stolen from other
  454.     add    hl,hl            ;symbol stuff
  455.     rla
  456.     add    hl,hl
  457.     rla
  458.     add    hl,hl
  459.     rla
  460.     add    hl,hl
  461.     rla
  462.     cp    '9'+1
  463.     jr    c,bi2
  464.     add    a,7
  465. bi2:    call    symout
  466.     djnz    bi1
  467.     ld    a,' '
  468.     call     symout
  469. bi4:    ld    a,(de)
  470.     inc    de
  471.     or    a
  472.     jr    z,bi3
  473.     call    symout
  474.     jr    bi4
  475. bi3:    ld    a,CR
  476.     call    symout
  477.     ld    a,LF
  478.     call    symout
  479.     jp    bi            ;next one
  480.  
  481. bifin:    ld    de,0fffeh and progend+1    ;global vector must be aligned
  482.     ld    (offsetglob),de        ;store in the program image
  483.     ld    hl,offset
  484.     add    hl,de            ;add in the offset
  485.     ld    (nloc),hl        ;set up nloc
  486.     ld    (imageglobs),hl        ;save image address
  487.     ld    a,1
  488.     ld    (filecnt),a        ;we have one file so far
  489.     ld    bc,(noglobs)
  490.     ld    hl,globtab
  491. ginit1:    ld    e,(hl)
  492.     inc    hl            ;get a global from table
  493.     ld    a,(hl)            ;until zero
  494.     or    e
  495.     jr    z,glbinit        ;fill the rest with undefined
  496.     ld    a,e
  497.     call    outbyte
  498.     ld    a,(hl)
  499.     call    outbyte
  500.     dec    bc            ;include these in the total
  501.     inc    hl
  502.     jr    ginit1
  503. glbinit:ld    a,low globund        ;now fill in the rest with
  504.     call    outbyte            ;the address of an error
  505.     ld    a,high globund        ;routine, in case they 
  506.     call    outbyte            ;get called accidentaly
  507.     dec    bc
  508.     ld    a,b
  509.     or    c
  510.     jr    nz,glbinit
  511. filelp:    ld    de,(curfcb)        ;open the file
  512.     ld    c,bopen
  513.     call    5
  514.     cp    0ffh            ;found?
  515.     jp    nz,openok
  516.     ld    de,fnfmess        ;send an error message
  517. perr:    ld    c,bprtstrng
  518.     call    5
  519.     ld    hl,(curfcb)
  520.     inc    hl            ;print the file name
  521.     ld    b,8
  522. fnf:    ld    a,(hl)
  523.     inc    hl
  524.     call    mout
  525.     djnz    fnf
  526.     ld    a,'.'
  527.     call    mout
  528.     ld    b,3
  529. fnf1:    ld    a,(hl)
  530.     inc    hl
  531.     call    mout
  532.     djnz    fnf1
  533.     call    sp4e            ;CRLF
  534.     ld    a,1            ;remember we had an error
  535.     ld    (errflg),a
  536.     jp    nextfile        ;get the next one
  537. defname:
  538.     db    0,'BCPL    OUT'        ;default source file
  539. fnfmess:
  540.     db    'File not found: $'
  541. signon:    db    CR,LF,'Z80 BCPL Loader starting....',CR,LF,LF,'$'
  542. ssstring:
  543.     db    'Stack size will be $'
  544. gsstring:
  545.     db    ' words',CR,LF,'Global vector will be $'
  546. estring:    
  547.     db    ' words',CR,LF,CR,LF,'$'
  548. mout:    push    hl
  549.     push    bc
  550.     cp    ' '            ;don't print spaces
  551.     jr    z,mout1
  552.     ld    e,a
  553.     ld    c,bconout
  554.     call    5
  555. mout1:    pop    bc
  556.     pop    hl
  557.     ret
  558. openok:    ld    a,128            ;clear buffer pointer
  559.     ld    (bpnt),a
  560.     call    nxtbyte            ;make sure it's an object file
  561.     cp    startfile
  562.     jr    z,openok1        ;branch if so
  563.     ld    de,fmtmess        ;or do error
  564.     jp    perr
  565. fmtmess:
  566.     db    'Format error: $'
  567. openok1:
  568.     call    rdcode            ;read the file
  569. nextfile:
  570.     ld    hl,(curfcb)
  571.     ld    de,33            ;do next one
  572.     add    hl,de
  573.     ld    (curfcb),hl        ;done all files?
  574.     ld    de,(lastfcb)
  575.     or    a
  576.     sbc    hl,de
  577.     jr    z,savecode        ;if so save it
  578.     jp    filelp
  579. savecode:
  580.     call    newline
  581.     ld    a,(errflg)        ;quit if there were errors
  582.     or    a
  583.     jr    z,sc1
  584.     ld    a,(symfile)        ;on error, delete our op files
  585.     or    a
  586.     jr    z,abrt1
  587.     ld    de,clifcb1
  588.     ld    c,bdel
  589.     call    5            ;delete the .SYM file
  590.     ld    a,'C'            ;now make file name xx.COM
  591.     ld    (clifcb1+9),a        ;for the next stage
  592.     ld    a,'O'
  593.     ld    (clifcb1+10),a
  594.     ld    a,'M'
  595.     ld    (clifcb1+11),a
  596. abrt1:    ld    a,(comfile)
  597.     or    a
  598.     jr    z,abrt2
  599.     ld    de,clifcb1        ;if we were going to make
  600.     ld    c,bdel            ;a .COM file, delete a possible
  601.     call    5            ;pre-existing one.
  602. abrt2:    call    nsaveprn        ;op a message
  603.     call    newline
  604.     jp    0            ;and abort
  605. newline:ld    e,CR
  606.     ld    c,bconout
  607.     call    5
  608.     ld    e,LF
  609.     ld    c,bconout
  610.     call    5
  611.     ret
  612. sc1:    ld    hl,(nloc)        ;get real addr of program end
  613.     ld    de,offset
  614.     or    a
  615.     sbc    hl,de
  616.     inc    hl            ;word align
  617.     ld    a,l
  618.     and    0feh
  619.     ld    l,a
  620.     ld    (offsetstack),hl    ;and put it in the image
  621.     ld    de,(stacksize)        ;now find real addr of end
  622.     ex    de,hl
  623.     add    hl,hl            ;stacksize is in words
  624.     add    hl,de
  625.     ld    (offsetstend),hl    ;out in the image
  626.     ld    a,(symfile)        ;are we doing a symbol file?
  627.     or    a
  628.     jr    z,sc2            ;branch if not
  629.     ld    a,EOF            ;put end of file on symbols
  630.     call    symout
  631.     ld    a,(soptr)        ;is there buffered data?
  632.     or    a
  633.     jr    z,endsym1        ;branch if not
  634.     ld    de,(sobuff)        ;else write last sector
  635.     ld    c,bsetdma
  636.     call    5
  637.     ld    de,clifcb1
  638.     ld    c,bwrtseq
  639.     call    5
  640.     or    a
  641.     jp    nz,dfull
  642. endsym1:ld    de,clifcb1        ;close up the file
  643.     ld    c,bclose
  644.     call    5
  645.     ld    a,'C'            ;now make file name xx.COM
  646.     ld    (clifcb1+9),a        ;for the next stage
  647.     ld    a,'O'
  648.     ld    (clifcb1+10),a
  649.     ld    a,'M'
  650.     ld    (clifcb1+11),a
  651.     ld    a,0            ;and reset odds n sods
  652.     ld    (clifcb1+12),a
  653.     ld    (clifcb1+14),a
  654.     ld    (clifcb1+32),a
  655. sc2:    ld    a,(comfile)        ;is it loadgo?
  656.     or    a
  657.     jr    nz,savecode1        ;branch to save file
  658.     ld    a,' '            ;ensure the image finds
  659.     ld    (clifcb1+1),a        ;no file names
  660.     ld    (clifcb1+9),a
  661.     ld    (clifcb2+1),a
  662.     ld    (clifcb2+9),a
  663.     ld    a,0edh            ;put a ldir intruction at 0feh
  664.     ld    (0feh),a
  665.     ld    a,0b0h
  666.     ld    (0ffh),a
  667.     ld    de,0100h        ;move to 100 hex
  668.     ld    hl,(nloc)
  669.     ld    bc,startimage        ;get length
  670.     or    a
  671.     sbc    hl,bc
  672.     push    hl
  673.     pop    bc
  674.     ld    hl,startimage        ;and source
  675.     jp    0feh            ;and do move, and jump in
  676. savecode1:
  677.     ld    de,clifcb1        ;second filename is here
  678.     ld    c,bdel
  679.     call    5
  680.     ld    de,clifcb1
  681.     ld    c,bmake
  682.     call    5
  683.     inc    a
  684.     jp    z,dirfull
  685.     ld    de,startimage        ;start of image
  686. saloop:    push     de
  687.     ld    c,bsetdma
  688.     call    5
  689.     ld    de,clifcb1
  690.     ld    c,bwrtseq
  691.     call    5
  692.     or    a
  693.     jr    nz,dfull        ;disk full
  694.     pop    de
  695.     ld    hl,080h
  696.     add    hl,de
  697.     push    hl
  698.     pop    de
  699.     ld    bc,(nloc)
  700.     or    a
  701.     sbc    hl,bc
  702.     jr    c,saloop
  703.     ld    de,clifcb1
  704.     ld    c,bclose
  705.     call    5
  706.     jp    0            ;finish
  707. dfull:    call    nsaveprn
  708.     ld    de,dfullmess
  709. dfull1:    ld    c,bprtstrng
  710.     call    5
  711.     jp    0            ;finish
  712. dirfull:call    nsaveprn
  713.     ld    de,dirfullmess
  714.     jp    dfull1
  715. nsaveprn:
  716.     ld    de,nsave
  717.     ld    c,bprtstrng
  718.     call    5
  719.     ret
  720. nsave:
  721.     db    'Output not saved$'
  722. dfullmess:
  723.     db    ': disk full',CR,LF,'$'
  724. dirfullmess:
  725.     db    ': directory full',CR,LF,'$'
  726.  
  727. rdcode:    call    nxtbyte
  728.     cp    endfile
  729.     ret    z
  730.     call    oneinst
  731.     jr    rdcode
  732.  
  733. oneinst:ld    l,a            ;save
  734.     and    0e0h            ;icode=>32 ->instruction
  735.     ld    a,l
  736.     jp    z,special        ;else special
  737.     sub    32
  738.     ld    l,a            ;put icode in l
  739.     ld    h,0
  740.     add    hl,hl            ;multiply by four to index table
  741.     add    hl,hl
  742.     ld    bc,itable        ;add base address
  743.     add    hl,bc
  744.     ld    a,(hl)            ;get flags byte
  745.     ld    c,a            ;save it
  746.     and    003h            ;get length
  747.     jr    z,noinst        ;skip if length zero
  748.     ld    b,a
  749. loadlp:    inc    hl            ;point to next byte
  750.     ld    a,(hl)
  751.     call    outbyte            ;output the byte
  752.     djnz    loadlp            ;loop round
  753. noinst:    ld    a,c            ;flags back
  754.     and    070h            ;get arg flag
  755.     ret    z            ;if zero, no argument
  756.     cp    word            ;word arg.
  757.     jr    nz,inst1
  758.     call    nxtbyte            ;copy the word arg
  759.     call    outbyte
  760. instbt:    call    nxtbyte
  761.     call    outbyte
  762.     ret                ;and return
  763. inst1:    cp    byte
  764.     jr    z,instbt        ;copy 1 byte
  765.     cp    mlabel            ;machine address of label
  766.     jp    nz,inst2
  767.     call    getlnp            ;get the arg
  768.     ld    a,(hl)            ;look at baddr chain
  769.     inc    hl
  770.     cp    0ffh
  771.     jr    nz,mforwrd        ;don't know the address yet
  772.     ld    a,(hl)
  773.     cp    0ffh
  774.     jr    nz,mforwrd
  775. outmad:    inc    hl            ;baddr if FFFF, maddr has addr
  776.     ld    a,(hl)            ;load it, and output
  777.     call    outbyte
  778.     inc    hl
  779.     ld    a,(hl)
  780.     call    outbyte            ;sent address, all done
  781.     ret
  782. mforwrd:ld    de,(nloc)
  783.     call    outmad            ;put link address there
  784.     ld    (hl),d            ;de has address where we're 
  785.     dec    hl            ;putting it
  786.     ld    (hl),e
  787.     ret
  788. inst2:     cp    reljp            ;machine label, instruction with
  789.     jp    nz,inst2a        ;relative version.
  790.     call    getlnp            ;get the label number
  791.     ld    a,(hl)
  792.     inc    hl
  793.     cp    0ffh            ;if forward ref, must use absolute
  794.     jr    nz,mforwrd
  795.     ld    a,(hl)
  796.     cp    0ffh
  797.     jr    nz,mforwrd
  798.     inc    hl            ;we know the address
  799.     ld    e,(hl)            ;into DE
  800.     inc    hl
  801.     ld    d,(hl)
  802. relarg:    ld    hl,(nloc)        ;find the span
  803.     ld    bc,offset
  804.     or     a
  805.     sbc    hl,bc            ;real value of pc
  806.     sbc    hl,de            ;span in HL
  807.     ld    a,h
  808.     or    a    
  809.     jp    nz,notrel        ;not in range
  810.     bit    7,l
  811.     jp    nz,notrel
  812.     ld    de,(nloc)        ;can use relative, modify
  813.     dec    de            ;the instruction (hack, hack)
  814.     ld    a,(de)
  815.     cp    0c3h            ;jp
  816.     jr    nz,condrel        ;else must be conditional
  817.     ld    a,0fah            ;jr XOR 0e2h
  818. condrel:xor    0e2h            ;this goes jp cc, -> jr cc,
  819.     ld    (de),a
  820.     ld    a,l            ;get the span
  821.     cpl                ;negative
  822.     call    outbyte
  823.     ret
  824. notrel:    ld    a,e
  825.     call    outbyte
  826.     ld    a,d
  827.     call    outbyte
  828.     ret
  829. getlnp:
  830. ;* likegetn, but follow proxys
  831.     call    getln
  832.     ret    c            ;if error
  833. getlnp1:ld    a,(hl)
  834.     cp    01
  835.     jr    nz,gp1            ;return if this label not proxy
  836.     inc    hl
  837.     ld    a,(hl)
  838.     cp    00
  839.     jr    z,gotprox
  840.     dec    hl
  841. gp1:    or    a            ;no error
  842.     ret
  843. gotprox:inc    hl            ;follow proxy pointer and retry
  844.     ld    a,(hl)
  845.     inc    hl
  846.     ld    h,(hl)
  847.     ld    l,a
  848.     jr    getlnp1
  849. getln:    call    nxtbyte            ;get address of label record
  850.     ld    l,a            ;with checking
  851.     call    nxtbyte
  852.     ld    h,a
  853.     ld    bc,nolabs        ;see if it's too big
  854.     or    a
  855.     sbc    hl,bc
  856.     jr    nc,getln1        ;branch if so
  857.     add    hl,bc            ;restore original
  858.     add    hl,hl            ;multiply by four
  859.     add    hl,hl
  860.     ld    bc,(labeltab)        ;add in base address
  861.     add    hl,bc
  862.     or    a            ;clear carry if ok
  863.     ret
  864. getln1:    ld    hl,(labeltab)        ;substitute 0
  865.     ld    a,(labovf)
  866.     or    a            ;do nothing else second time
  867.     scf                ;error
  868.     ret    nz
  869.     ld    a,1            ;set flags
  870.     ld    (labovf),a
  871.     ld    (errflg),a
  872.     ld    de,laberr        ;print error message
  873.     ld    c,bprtstrng
  874.     call    5 
  875.     ld    hl,(labeltab)
  876.     scf
  877.     ret
  878. laberr:
  879.     db    'Too many internal labels; '
  880.     db    'use smaller sections.',0dh,0ah,'$'
  881. inst2a:    cp    blabel            ;bcpl address of label
  882.     jr    nz,inst3
  883.     call    getlnp            ;get label no.
  884.     ld    a,(hl)            ;look at baddr chain
  885.     inc    hl
  886.     cp    0ffh            ;if it is FFFF we know the addr
  887.     jr    nz,bforwrd        ;if not, forward reference
  888.     ld    a,(hl)
  889.     cp    0ffh
  890.     jr    nz,bforwrd
  891.     inc    hl            ;get the mach. addr from maddr
  892.     ld    c,(hl)
  893.     inc    hl
  894.     ld    b,(hl)            ;into bc
  895.     srl    b            ;divide by two for bcpl addr
  896.     rr    c
  897.     ld    a,c            ;and output it
  898.     call    outbyte
  899.     ld    a,b
  900.     call    outbyte
  901.     ret
  902. bforwrd:dec     hl            ;put it on the ptr chain
  903.     ld    bc,(nloc)
  904.     ld    a,(hl)
  905.     call    outbyte
  906.     inc    hl
  907.     ld    a,(hl)
  908.     call     outbyte
  909.     ld    (hl),b
  910.     dec    hl
  911.     ld    (hl),c
  912.     ret
  913. inst3:    cp    mglobal            ;machine address of global
  914.     jr    nz,inst4
  915.     call    nxtbyte
  916.     ld    l,a            ;get arg
  917.     call    nxtbyte
  918.     ld    h,a
  919.     call    chkglb            ;check it
  920.     add    hl,hl            ;multiply by 2 for machine addr
  921.     ld    bc,(offsetglob)        ;add in the base
  922.     add    hl,bc
  923.     ld    a,l
  924.     call     outbyte            ;output it
  925.     ld    a,h
  926.     call    outbyte
  927.     ret
  928. inst4:    cp    bglobal            ;bcpl address of global
  929.     ret     nz
  930.     call    nxtbyte
  931.     ld    l,a
  932.     call    nxtbyte
  933.     ld    h,a
  934.     call    chkglb
  935.     ld    bc,(offsetglob)
  936.     srl    b            ;get BCPL address
  937.     rr    c
  938.     add    hl,bc
  939.     ld    a,l
  940.     call    outbyte
  941.     ld    a,h
  942.     call    outbyte
  943.     ret
  944.  
  945. chkglb:    push    hl            ;save the no
  946.     ld    de,(noglobs)        ;return c=1 if error
  947.     or    a
  948.     inc    hl
  949.     ex    de,hl
  950.     sbc    hl,de
  951.     pop    hl
  952.     ret    nc            ;return no error
  953.     ld    hl,0            ;use zero
  954.     ld    a,(glbovf)        ;have we already hit an error?
  955.     or    a
  956.     ccf                ;make c=1 for error
  957.     ret    nz            ;return if so
  958.     ld    a,1            ;else set global overflow flag
  959.     ld    (glbovf),a
  960.     ld    (errflg),a        ;and general error
  961.     ld    de,glberr        ;print error
  962.     ld    c,bprtstrng
  963.     call    5
  964.     ld    hl,0            ;use zero
  965.     or    a            ;c=1
  966.     ccf
  967.     ret
  968. glberr:    db    'Global vector too small.',0dh,0ah,'$'
  969.  
  970. followlabel:
  971. ;Two consecutive labels have been found, make the first one act as the
  972. ;second. We do this in the hope that the second will have a branch following
  973. ;it, which can be shorted, or possibly elided.
  974.     ex    de,hl            ;first label in de    
  975.     call    getln            ;get the number of the second label
  976.     ret    c            ;all bets of if it's bad
  977.     ex    de,hl            
  978.     ld    (hl),01            ;0001 means this is a proxy
  979.     inc    hl            ;note we assume the BChain is empty
  980.         ld    (hl),00
  981.     inc    hl
  982.     ld    c,(hl)            ;get a possible chain to move to the 
  983.         ld    (hl),e            
  984.     inc    hl            ;target
  985.     ld    b,(hl)
  986.     ld    (hl),d            ;and put in the proxy label
  987.     ld    h,d
  988.     ld    l,e
  989.     inc    hl    
  990.     inc    hl            ;chase down the targets MChain
  991. fl2:    ld    a,(hl)
  992.     inc    hl
  993.     or    (hl)            ;marked by zero
  994.     jr    z,fl1
  995.     dec    hl
  996.     ld    a,(hl)            ;not found yet, onwards
  997.     inc    hl
  998.     ld    h,(hl)
  999.     ld    l,a
  1000.     jr    fl2
  1001. fl1:    ld    (hl),b
  1002.     dec    hl            ;got the end, put proxys chain on
  1003.     ld    (hl),c
  1004.     ex    de,hl            ;target label in HL
  1005.     jp    dolab1            ;it may now be a proxy
  1006.  
  1007. followjump:
  1008. ;A jump following a label, make the source label a proxy for the 
  1009. ;destination, and elide the jump if there if no other route to it
  1010.     ex    de,hl
  1011.     call    getln
  1012.     ret    c
  1013. fj2:    or    a
  1014.     sbc    hl,de            ;is dest a proxy of source?
  1015.     jr    z,foundloop        ;if so found and infinite loop
  1016.     add    hl,de            ;restore HL
  1017.     ld    a,(hl)            ;what is the status of dest.
  1018.     cp    01
  1019.     inc    hl
  1020.     jr    nz,fj1
  1021.     ld    a,(hl)
  1022.     cp    0            ;already a proxy
  1023.     jr    nz,fj1
  1024.     inc    hl
  1025.     ld    a,(hl)            ;try again if so
  1026.     inc    hl
  1027.     ld    h,(hl)
  1028.     ld    l,a
  1029.     jr    fj2    
  1030.  
  1031. foundloop:
  1032. ; Ok we have that the dest of our jump is a proxy of it's source.
  1033. ; We could complain, but we do our best to deliver what is asked for.
  1034. ; Assemble a jump to self, and instantiate the source label to break
  1035. ; the loop
  1036.     ld    a,018h            ;JR instruction
  1037.     call    outbyte
  1038.     ld    a,-2            ;self
  1039.     call    outbyte
  1040.     ex    de,hl            ;put Lx in HL
  1041.     call    nxtbyte            ;for resolve
  1042.     jp    resolve
  1043.  
  1044. fj1:    dec    hl
  1045.     ld    a,(hl)            ;already defined?
  1046.     cp    0ffh
  1047.     inc    hl
  1048.     jp    nz,fj3
  1049.     ld    a,(hl)
  1050.     cp    0ffh
  1051.     jp    nz,fj3
  1052. ;OK, we have Lx: JMP Ly and we know where Ly is.
  1053. ;Give Lx the value of Ly, and output the jump if control
  1054. ;can fall through to here
  1055.     push    de
  1056.     inc    hl
  1057.     ld    e,(hl)            ;get Ly in DE for relarg
  1058.     inc    hl
  1059.     ld    d,(hl)     
  1060.     ld    a,(newflg)
  1061.     or    a            ;can we elide the jump?
  1062.     push    de
  1063.     jr    nz,fj4    
  1064.     ld    a,0c3h            ;Z80 JP instruction
  1065.     call    outbyte
  1066.     call    relarg            ;and argument
  1067. fj4:    pop    bc            ;address of Ly
  1068.     pop    hl            ;now have Lx in HL
  1069.     push    bc            ;and address of Ly in BC
  1070.     srl    b            ;BCPL address
  1071.     rr    c
  1072.     push    hl
  1073.     call    labloop            ;fill it in
  1074.     pop    hl
  1075.     ld    (hl),0ffh        ;mark as known
  1076.     inc    hl
  1077.     ld    (hl),0ffh
  1078.     inc    hl
  1079.     pop    bc            ;get machine address
  1080.     jp    labloop            ;and do that
  1081.  
  1082. fj3:            
  1083. ;Here, we have Lx JMP Ly, but we don't yet know the value of Ly.
  1084. ;Set up Lx as a proxy of Ly, and emit an incomplete JP unless
  1085. ;it can be elided.
  1086.  
  1087.     dec    hl
  1088.     ex    de,hl            
  1089.     ld    (hl),01            ;0001 means this is a proxy
  1090.     inc    hl            ;note we assume the BChain is empty
  1091.         ld    (hl),00
  1092.     inc    hl
  1093.     ld    c,(hl)            ;get a possible chain to move to the 
  1094.         ld    (hl),e            
  1095.     inc    hl            ;target
  1096.     ld    b,(hl)
  1097.     ld    (hl),d            ;and put in the proxy label
  1098.     ld    h,d
  1099.     ld    l,e
  1100.     inc    hl    
  1101.     inc    hl            ;chase down the targets MChain
  1102. fj5:    ld    a,(hl)
  1103.     inc    hl
  1104.     or    (hl)            ;marked by zero
  1105.     jr    z,fj6
  1106.     dec    hl
  1107.     ld    a,(hl)            ;not found yet, onwards
  1108.     inc    hl
  1109.     ld    h,(hl)
  1110.     ld    l,a
  1111.     jr    fj5
  1112. fj6:    ld    (hl),b
  1113.     dec    hl            ;got the end, put proxys chain on
  1114.     ld    (hl),c
  1115.     ld    a,(newflg)        ;can we elide the jump
  1116.     or    a
  1117.     ret    nz
  1118.     ex    de,hl            ;target label in HL
  1119.     inc    hl            ;for mforwrd
  1120.     ld    a,0c3h            ;Z80 JP inst
  1121.     call    outbyte
  1122.     jp    mforwrd            ;this does the unknown dest    
  1123.  
  1124. special:                ;special pseudo-ops come here
  1125.     cp    walign
  1126.     jr    nz,sp1
  1127.     ld    hl,(nloc)        ;word align code stream
  1128.     ld    de,offset
  1129.     or    a
  1130.     sbc    hl,de
  1131.     rr    l
  1132.     ret    nc            ;ok if nloc-offset is even
  1133.     ld    a,0            ;else pad with zero
  1134.     call    outbyte
  1135.     ret
  1136. sp1:    cp    labdef            ;define label as this location
  1137.     ld    l,0            ;flag
  1138.     jr    z,dolab
  1139.     cp    newlab
  1140.     jr    nz,sp2
  1141.     ld    l,1            ;flag
  1142. dolab:    ld    a,l
  1143.     ld    (newflg),a        ;one if a newlab, zero otherwise
  1144.     ld    hl,(nloc)
  1145.     ld    de,offset        ;work out current real address
  1146.     or    a
  1147.     sbc    hl,de
  1148.     ld    (realaddr),hl
  1149.     call    getln            ;get labelno, and form index
  1150.     ret    c            ;quit if label out of range
  1151. dolab1:    call    nxtbyte            ;get the following instruction
  1152.     cp     labdef            ;if it's labdef or jump, we wish
  1153.     jp    z,followlabel        ;to play around
  1154.     cp    jumpinst
  1155.     jp    z,followjump
  1156. resolve:push    af            ;else save the instruction we stole
  1157.     ld    bc,(realaddr)        ;now resolve Bchain
  1158.     srl    b            ;BCPL address of nloc
  1159.     rr    c
  1160.     push    hl            ;save address in btab
  1161.     call    labloop            ;resolve forward refs
  1162. bcend:    pop    hl            ;get orignal btab address back
  1163.     ld    (hl),0ffh        ;set to ffff, we know the addr
  1164.     inc    hl
  1165.     ld    (hl),0ffh
  1166.     inc    hl            ;now point at maddr
  1167.     ld    bc,(realaddr)        ;do the same with mach. addr
  1168.     call    labloop
  1169.     pop    af            ;get back our inst
  1170.     jp    oneinst            ;and do it
  1171. labloop:ld    e,(hl)
  1172.     inc    hl            ;follow chain, bomb out at zero
  1173.     ld    d,(hl)
  1174.     ld    (hl),b
  1175.     dec    hl
  1176.     ld    (hl),c
  1177.     ld    a,e
  1178.     or    d            ;was this pointer zero?
  1179.     ret    z            ;chain end
  1180.     ex    de,hl            ;not zero, put in hl and loop
  1181.     jr    labloop
  1182. sp2:    cp    gorg            ;set global?
  1183.     jp    nz,sp3
  1184.     ld    bc,(nloc)        ;save nloc
  1185.     push    bc
  1186.     call    nxtbyte            ;get global no.
  1187.     ld    l,a
  1188.     call    nxtbyte
  1189.     ld    h,a            ;compute address of global
  1190.     call    chkglb            ;make sure its legal
  1191.     jr    c,badglob        ;else treat next inst
  1192.     push    hl            ;save global number
  1193.     add    hl,hl            ;as ordinary
  1194.     ld    bc,(imageglobs)
  1195.     add    hl,bc
  1196.     pop    bc            ;get global number in BC
  1197.     ld    a,(hl)            ;see if it's been set before
  1198.     cp    low globund
  1199.     jr    nz,glbrdef
  1200.     inc    hl
  1201.     ld    a,(hl)
  1202.     dec    hl
  1203.     cp    high globund        ;error if so
  1204.     jr    nz,glbrdef
  1205.     ld    (nloc),hl        ;and put it in nloc
  1206.     call    nxtbyte            ;do one instruction
  1207.     call    oneinst
  1208. badglob:pop    bc            ;then restore nloc
  1209.     ld    (nloc),bc
  1210.     ret
  1211. glbrdef:ld    a,1            ;remember
  1212.     ld    (errflg),a
  1213.     push    bc            ;save global number
  1214.     ld    de,glb1mess
  1215.     ld    c,bprtstrng
  1216.     call    5
  1217.     pop    bc            ;restore global number
  1218.     call    decout
  1219.      ld    de,glb2mess
  1220.     ld    c,bprtstrng
  1221.     call    5
  1222.     jr    badglob
  1223. decout:    ld    a,0            ;print BC in decimal
  1224.     ld    (bpnti),a        ;supress leading zeros
  1225.     ld    de,10000
  1226.     call    dig
  1227.     ld     de,1000
  1228.     call    dig
  1229.     ld    de,100
  1230.     call    dig
  1231.     ld    de,10
  1232.     call    dig
  1233.     ld    de,1
  1234.     call    dig
  1235.     ld    a,(bpnti)
  1236.     or    a
  1237.     ret    nz            ;Must be at least one digit
  1238.     ld    e,030h
  1239.     ld    c,bconout
  1240.     call    5
  1241.     ret
  1242. dig:    push    bc            ;print one digit, powers
  1243.     pop    hl            ;of ten in de
  1244.     ld    a,030h
  1245. dloop:    or    a
  1246.     sbc    hl,de
  1247.     jr    c,outd
  1248.     inc    a
  1249.     push    hl
  1250.     pop    bc
  1251.     jr    dloop
  1252. outd:    cp    030h
  1253.     jr    nz,notz
  1254.     ld    a,(bpnti)        ;not leading zero
  1255.     or    a
  1256.     ret    z
  1257.     ld    a,030h
  1258. notz:    push    bc
  1259.     push    hl
  1260.     ld    (bpnti),a        ;suppress leading zeros
  1261.     ld    e,a
  1262.     ld    c,bconout
  1263.     call    5
  1264.     pop    hl
  1265.     pop    bc
  1266.     ret
  1267.  
  1268. bpnti:    db    0
  1269. glb1mess:
  1270.     db    'Global $'
  1271. glb2mess:
  1272.         db    ' has been initialised twice.',0dh,0ah,'$'
  1273.  
  1274. sp3:    cp    startsec        ;clear all labels at start
  1275.     jr    nz,sp4
  1276.     ld    hl,(labeltab)
  1277.     ld    (hl),0            ;clear to zero
  1278.     ld    de,(labeltab)
  1279.     inc    de            ;by copying zero through
  1280.     ld    bc,nolabs*4-1
  1281.     ldir
  1282.     ld    a,0
  1283.     ld    (glbovf),a        ;no global error in this section
  1284.     ld    (labovf),a
  1285.     ret
  1286. sp4:    cp    section            ;section name. print it
  1287.     jr    nz,sp5
  1288.     ld    de,sectmess
  1289.     ld    c,bprtstrng
  1290.     call    5
  1291. sp4l:    call    nxtbyte
  1292.     or    a            ;output name, until zero
  1293.     jr    z,sp4e
  1294.     ld    e,a
  1295.     ld    c,bconout
  1296.     call    5
  1297.     jr    sp4l
  1298. sp4e:    ld    e,CR
  1299.     ld    c,bconout
  1300.     call    5
  1301.     ld    e,LF
  1302.     ld    c,bconout
  1303.     call    5
  1304.     ret
  1305. sectmess:
  1306.     db    'Loading section $'
  1307. sp5:    cp    needs
  1308.     jp    nz,sp6
  1309.     ld    b,12            ;length of filename
  1310.     ld    hl,(lastfcb)        ;point to start of buffer
  1311. fn1:    call    nxtbyte
  1312.     ld    (hl),a            ;stuff it in
  1313.     inc    hl
  1314.     djnz    fn1            ;round unless >20 chars
  1315.     ld    b,21
  1316.     ld    a,0            ;clear other fcb fields
  1317. fn2:    ld    (hl),a
  1318.     inc    hl
  1319.     djnz    fn2
  1320.     ld    hl,(firstfcb)        ;now see if we've had this
  1321.     push    hl
  1322. fn4:    pop    hl
  1323.     push    hl
  1324.     ld    de,(lastfcb)        ;filename before
  1325.     ld    b,11            ;compare 11 bytes of name
  1326. fn3:    inc    hl            ;skip over drive first
  1327.     inc    de
  1328.     ld    a,(de)
  1329.     ld    c,(hl)            ;compare a byte
  1330.     cp    c
  1331.     jr    nz,nextfcb        ;not the same
  1332.     djnz    fn3            ;loop round
  1333.     pop    hl
  1334.     ret                ;same, do not need this
  1335.  
  1336. nextfcb:
  1337.     pop    hl            ;go to next fcb
  1338.     ld    bc,33
  1339.     add    hl,bc
  1340.     push    hl
  1341.     or    a            ;clear carry
  1342.     ld    de,(lastfcb)        ;see if we've got to the end
  1343.     sbc    hl,de
  1344.     jr    nz,fn4            ;if not,check this one
  1345.     pop    hl
  1346.     ld    hl,33            ;if so save this fcb
  1347.     add    hl,de
  1348.     ld    (lastfcb),hl
  1349.     ld    a,(filecnt)        ;see how many files we have
  1350.     inc    a
  1351.     ld    (filecnt),a
  1352.     cp    nofiles            ;always need one spare
  1353.     ret    nz            ;return if ok
  1354.     ld    de,fileerr        ;else print error and quit
  1355.     ld    c,bprtstrng
  1356.     call    5
  1357.     jp    0
  1358. fileerr:db    'Error, too many input files.',CR,LF,'$'
  1359.  
  1360. sp6:    cp    labsym            ;label def with symbol
  1361.     jp    nz,sp7
  1362.     ld    hl,(nloc)        ;do normal stuff for a label
  1363.     ld    de,offset
  1364.     or    a
  1365.     sbc    hl,de
  1366.     ld    (realaddr),hl
  1367.     call    getlnp
  1368.     jr    c,symrec        ;quit if wrong
  1369.     ld    bc,(realaddr)
  1370.     srl    b
  1371.     rr    c
  1372.     push    hl
  1373.     call    labloop
  1374.     pop    hl
  1375.     ld    (hl),0ffh
  1376.     inc    hl
  1377.     ld    (hl),0ffh
  1378.     inc    hl
  1379.     ld    bc,(realaddr)
  1380.     call    labloop
  1381.     ld    hl,(realaddr)        ;get its address
  1382. symrec:                    ;put into symbol file as hex
  1383.     ld    b,4            ;four hex digits
  1384. hex2:    ld    a,3            ;'0'>>4
  1385.     add    hl,hl            ;shift 4 bits from hl into a
  1386.     rla
  1387.     add    hl,hl
  1388.     rla
  1389.     add    hl,hl
  1390.     rla
  1391.     add    hl,hl
  1392.     rla
  1393.     cp    '9'+1            ;is it >9?
  1394.     jr    c,hex1
  1395.     add    a,7            ;if so adjust -> A-F
  1396. hex1:    call    symout            ;output char
  1397.     djnz    hex2
  1398.     ld    a,' '            ;space delimiter
  1399.     call    symout
  1400. sp6b:    call    nxtbyte            ;copy symbol name over
  1401.     or    a            ;zero marks the end
  1402.     jr    z,sp6a
  1403.     call    symout
  1404.     jr    sp6b
  1405. sp6a:    ld    a,CR            ;one symbol per line
  1406.     call    symout
  1407.     ld    a,LF
  1408.     jp    symout            ;and return
  1409.  
  1410. sp7:    cp    globsym            ;name of global
  1411.     jr    nz,sp8
  1412.     call    nxtbyte            ;get global number
  1413.     ld    l,a
  1414.     call    nxtbyte
  1415.     ld    h,a
  1416.     push    hl            ;save it
  1417.     ld    bc,(symtab)        ;see if we've already found
  1418.     add    hl,bc            ;a symbol for this global
  1419.     ld    a,(hl)
  1420.     ld    (hl),0ffh        ;remember this one
  1421.     or    a
  1422.     pop    hl            ;restore global number
  1423.     jr    nz,throw        ;if done already, throw it away
  1424.     add    hl,hl            ;get address of global
  1425.     ld    bc,(offsetglob)
  1426.     add    hl,bc
  1427.     jp    symrec            ;put in symbol file
  1428. throw:    call    nxtbyte            ;throw away symbol if not needed
  1429.     or    a
  1430.     jr    nz,throw
  1431.     ret
  1432.  
  1433. symout:    push    de
  1434.     push    hl
  1435.     push    bc
  1436.     ld    e,a            ;save char
  1437.     ld    a,(soptr)
  1438.     ld    c,a
  1439.     ld    b,0
  1440.     ld    hl,(sobuff)
  1441.     add    hl,bc            ;get address of nxt byte in buf
  1442.     ld    (hl),e            ;store the byte
  1443.     inc    a
  1444.     ld    (soptr),a
  1445.     cp    128            ;at end?
  1446.     jr    nz,symout1
  1447.     ld    a,0
  1448.     ld    (soptr),a        ;zero the pointer
  1449.     ld    a,(symfile)        ;are we doing a symbol file?
  1450.     or    a
  1451.     jr    z,symout1        ;skip if not
  1452.     ld    de,(sobuff)        ;and write it out
  1453.     ld    c,bsetdma
  1454.     call    5
  1455.     ld    de,clifcb1
  1456.     ld    c,bwrtseq
  1457.     call    5
  1458.     or    a            ;abort on full disk
  1459.     jp    nz,dfull
  1460. symout1:pop    bc
  1461.     pop    hl
  1462.     pop    de
  1463.     ret
  1464.  
  1465. sp8:    ld    de,fmtmess        ;anything else is an 
  1466.     jp    perr            ;internal error
  1467.  
  1468. outbyte:
  1469.     push    hl            ;save hl
  1470.     push    de
  1471.     ld    hl,(nloc)
  1472.     ld    (hl),a            ;stuff byte in
  1473.     inc    hl
  1474.     ld    (nloc),hl
  1475.     ld    de,(labeltab)        ;see if we've collided with
  1476.     or    a            ;label table
  1477.     sbc    hl,de
  1478.     pop    de
  1479.     pop    hl
  1480.     ret    nz            ;return if not
  1481.     ld    de,memerr        ;print message
  1482.     ld    c,bprtstrng
  1483.     call    5
  1484.     jp    0            ;abort
  1485. memerr:    db    'Error, out of memory.',CR,LF,'$'
  1486. nxtbyte:
  1487.     push    de
  1488.     push    hl
  1489. nb1:    ld    a,(bpnt)
  1490.     ld    e,a
  1491.     ld    d,0
  1492.     cp    128
  1493.     jr    z,nxtsect        ;get the next sector
  1494.     inc    a            ;increment pointer
  1495.     ld    (bpnt),a
  1496.     ld    hl,conbuff
  1497.     add    hl,de            ;else form address
  1498.     ld    a,(hl)
  1499.     pop    hl
  1500.     pop    de
  1501.     ret
  1502. nxtsect:
  1503.     push    bc
  1504.     ld    de,conbuff
  1505.     ld    c,bsetdma
  1506.     call    5
  1507.     ld    de,(curfcb)        ;read from current file
  1508.     ld    c,brdseq
  1509.     call    5
  1510.     ld    a,0
  1511.     ld    (bpnt),a
  1512.     pop    bc
  1513.     jr    nb1
  1514.  
  1515.  
  1516.     page
  1517. ;*********************************************************
  1518. ;* Machine level support for Z80-CP/M BCPL.              *
  1519. ;* S. Kelley.    Autumn 1987.                            *
  1520. ;*********************************************************
  1521. startimage    equ    $
  1522. offsetstack    equ    $+3        
  1523. offsetglob    equ    $+5        ;offset addresses of
  1524. offsetstend    equ    $+7        ;important bits
  1525.  
  1526.         .phase    0100h
  1527.  
  1528. ;flags in fcb flag byte
  1529. binf        equ    1    ;binary mode on this stream
  1530. eoff        equ    2    ;this stream at eof
  1531. biosdevice    equ    0    ;high for an input stream
  1532. coninf        equ    3    ;high for console in
  1533.  
  1534. ;bdos functions
  1535. bconout        equ    2
  1536. blstout        equ    5
  1537. bconin        equ    1
  1538. bconstat    equ    11
  1539. bprtstrng     equ    9
  1540. bgetlin        equ    10
  1541. bsetdma        equ    26
  1542. brdseq        equ    20
  1543. bwrtseq        equ    21
  1544. bclose        equ    16
  1545. bopen        equ    15
  1546. bdel        equ    19
  1547. bmake        equ    22
  1548. bpunout        equ    4
  1549. brdrin        equ    3
  1550.  
  1551. ;misc manifests
  1552. CR        equ    00dh    ;ascii codes
  1553. LF        equ    00ah
  1554. EOF        equ    01ah    ;ctrl-z
  1555. QUIT        equ    003h    ;ctrl-c
  1556. true        equ    0ffffh
  1557. false        equ    0h
  1558. endstreamch     equ    0ffffh
  1559. conbuff        equ    080h    ;use cpm buffer for console stuff
  1560.  
  1561. ;***********
  1562. ;* Storage *
  1563. ;***********
  1564.         jp    bcplstart
  1565.  
  1566. stackstart:    ds    2    ;last program address
  1567. globalbase:    ds    2    ;start of global vector
  1568. stackend:    ds    2    ;end of stack, start of heap
  1569.         db    0    ;align
  1570. currco:        dw    mainco    ;current coroutine
  1571. mainco:        ds    2    ;Main co save area, MUST BE ALIGNED
  1572.         dw    -1    ;non-zero as main is always active
  1573. outstream:    dw    1    ;default to CON
  1574. instream:    dw    1    ;ditto
  1575. outfile:    dw    0    ;output file at startup
  1576. concount:    db    0ffh    ;chars taken from console buffer
  1577. infcbs:        db    9    ;biosdevice=1, coninf=1
  1578.         db    bconin    ;bdos function
  1579.         db    1    ;biosdevice=1
  1580.         db    brdrin
  1581. outfcbs:    db    1    ;console out
  1582.         db    bconout
  1583.         db    1
  1584.         db    bpunout
  1585.         db    1
  1586.         db    blstout
  1587.  
  1588.         page
  1589. ;****************************************************************
  1590. ;* BCPL runtime support. this code is copied to loc 8, and      *
  1591. ;* called by restarts in compiled code.                         *
  1592. ;****************************************************************
  1593. restart:
  1594.     ld    (ix+0),e    ;RST 8; RTAP
  1595.     ld    (ix+1),d
  1596.     jp    (hl)
  1597.     nop
  1598.     jp    (hl)        ;RST 10; SRTAP
  1599.     nop
  1600.     nop
  1601.     nop
  1602.     nop
  1603.     nop
  1604.     nop
  1605.     nop
  1606.     add    hl,hl        ;RST 18; RV
  1607.     ld    e,(hl)
  1608.     inc    hl
  1609.     ld    h,(hl)        ;return result in DE as well
  1610.     ld    l,e
  1611.     ld    d,h
  1612.     ret
  1613.     nop
  1614.     add    hl,hl        ;RST 20; STIND
  1615.     ld    (hl),e        ;DE -> (HL)
  1616.     inc    hl
  1617.     ld    (hl),d
  1618.     ret
  1619.     nop
  1620.     nop
  1621.     nop
  1622.  
  1623. ; NB    Restart locations 28H and 38H are left free for 
  1624. ;       ZSID breakpoints and Z80 mode 1 interupts respectively
  1625.  
  1626. ;****************************************************************
  1627. ;* BCPL runtime support. calls to these routines are compiled   *
  1628. ;* directly into code by the compiler.                          *
  1629. ;****************************************************************
  1630.  
  1631. locaddr:
  1632.     push    ix        ;Frame pointer
  1633.     pop    hl
  1634.     add    hl,bc        ;add in const
  1635.     srl    h        ;get bcpl addr
  1636.     rr    l
  1637.     ret
  1638.     
  1639. vector:                ;alocate space for a vector
  1640.     pop    de        ;save return address
  1641.     add    hl,sp        ;get new SP
  1642.     jr    nc,stckovflw    ;gross overflow.
  1643.     push    ix
  1644.     pop    bc        ;check for stack overflow
  1645.     or    a
  1646.     sbc    hl,bc
  1647.     jr    c,stckovflw
  1648.     add    hl,bc        ;get new sp back
  1649.     ld    sp,hl
  1650.     srl    h        ;return word address
  1651.     rr    l
  1652.     push    de        ;put return addr back
  1653.     ret            ;and go
  1654. stckovflw:
  1655.     ld    de,ovflw
  1656.     jp    rntmerr        ;print message and quit
  1657.  
  1658. getbyte:
  1659.     add    hl,hl        ;double it for machine
  1660.     add    hl,de        ;add in byte offset
  1661.     ld    l,(hl)        ;get the byte
  1662.     ld    h,0        ;zero top half
  1663.     ret
  1664.  
  1665. switch:    pop    de        ;get address of table (left
  1666. swlp:     ld    a,(de)        ;by call instruction)
  1667.     inc    de        ;HL has switch value
  1668.     cp    l        ;B is no cases
  1669.     ld    a,(de)
  1670.     inc    de        
  1671.     jr    nz,nfnd
  1672.     cp    h
  1673.     jr    z,fnd
  1674. nfnd:    inc    de        ;skip address
  1675.     inc    de
  1676.     djnz    swlp        ;if we fall through, default
  1677. fnd:    ld    a,(de)
  1678.     ld    l,a
  1679.     inc    de
  1680.     ld    a,(de)
  1681.     ld    h,a
  1682.     jp    (hl)
  1683.  
  1684. goto:
  1685.     inc    hl        ;get the operand of the ld hl
  1686.     ld    c,(hl)        ;instruction at our target
  1687.     inc    hl
  1688.     ld    b,(hl)        ;to do a relative adjust on SP
  1689.     inc    hl        ;HL now points to next instr
  1690.     add    iy,bc        ;IY set on entry
  1691.     add    iy,sp        ;calculate new SP
  1692.     ld    sp,iy
  1693.     jp    (hl)        ;off we go
  1694.  
  1695. oflv:                ;assign to bitfield
  1696.     or    a        ;shift count in a
  1697. oflv2:    jr    z,oflv1
  1698.     sla    e        ;shift left
  1699.     rl    d
  1700.     dec    a
  1701.     jr    oflv2
  1702. oflv1:    ld    a,e        ;mask off desired field
  1703.     and    c
  1704.     ld    e,a
  1705.     ld    a,d
  1706.     and    b
  1707.     ld    d,a
  1708.     add    hl,hl        ;get machine address
  1709.     ld    a,c        ;complement mask to zero old field
  1710.     cpl    
  1711.     and    (hl)        ;get old value
  1712.     or    e        ;new field goes in
  1713.     ld    (hl),a        ;put it back
  1714.     inc    hl
  1715.     ld    a,b
  1716.     cpl
  1717.     and    (hl)
  1718.     or    d
  1719.     ld    (hl),a
  1720.     ret
  1721.  
  1722. ofrv:                ;extract bitfield
  1723.     push    af        ;save shift count
  1724.     add    hl,hl        ;machine addr
  1725.     ld    a,(hl)        ;get value
  1726.     and    c        ;mask
  1727.     ld    c,a
  1728.     inc    hl
  1729.     ld    a,(hl)
  1730.     and    b
  1731.     ld    h,a
  1732.     ld    l,c        ;result in HL
  1733.     pop    af        ;get shift count back
  1734.     or    a
  1735. ofrv1:    ret    z
  1736.     srl     h
  1737.     rr    l
  1738.     dec    a
  1739.     jr    ofrv1
  1740.  
  1741. rshift:    ld    a,e        ;HL >> DE
  1742.     and     01fh        ;short large shifts
  1743.     ret    z        ;return if nothing to do
  1744.     ld    b,a
  1745. rs1:    srl    h
  1746.     rr    l
  1747.     djnz    rs1
  1748.     ret
  1749.  
  1750. lshift:    ld    a,e        ;HL << DE
  1751.     and    01fh
  1752.     ret    z
  1753.     ld    b,a
  1754. ls1:    add    hl,hl
  1755.     djnz    ls1
  1756.     ret
  1757.  
  1758. logand:    ld    a,l
  1759.     and    e
  1760.     ld    l,a
  1761.     ld    a,h
  1762.     and    d
  1763.     ld    h,a
  1764.     ret
  1765.  
  1766. logor:    ld    a,l
  1767.     or    e
  1768.     ld    l,a
  1769.     ld    a,h
  1770.     or    d
  1771.     ld    h,a
  1772.     ret
  1773.  
  1774. neqv:    ld    a,l    
  1775.     xor    e
  1776.     ld    l,a
  1777.     ld    a,h
  1778.     xor    d
  1779.     ld    h,a
  1780.     ret
  1781.  
  1782. eqv:    ld    a,l
  1783.     xor    e
  1784.     cpl
  1785.     ld    l,a
  1786.     ld    a,h
  1787.     xor    d
  1788.     cpl
  1789.     ld    h,a
  1790.     ret
  1791.  
  1792. not:    ld    a,l
  1793.     cpl
  1794.     ld    l,a
  1795.     ld    a,h
  1796.     cpl
  1797.     ld    h,a
  1798.     ret
  1799.  
  1800. abs:    bit    7,h
  1801.     ret    z
  1802. neg:    call    not
  1803.     inc    hl
  1804.     ret    
  1805.  
  1806. ;result in Carry flag
  1807. ;for <,<=,>,>=
  1808. lesseq:                
  1809.     or    a        ;c := (hl <= de)
  1810.     sbc    hl,de
  1811.     jr    nz,le2
  1812.     ccf            ;cy := 1 for equals
  1813.     ret
  1814. le2:    jp    po,le1        ;branch if no overflow
  1815.     rl    h        ;cy := sign we want neg := true
  1816.     ccf            ;but reverse if overflow
  1817.     ret
  1818.  
  1819. less:                ;c := (hl < de)
  1820.     or    a        ;this is as above, but don't check
  1821.     sbc    hl,de        ;for zero (equality)
  1822.     jp    po,le1
  1823. ge1:    rl    h
  1824.     ccf
  1825.     ret
  1826.  
  1827. greateq:            ;c := (hl >= de)
  1828.     or    a        ;return true if positive
  1829.     sbc    hl,de
  1830.     jp    po,ge1
  1831. le1:    rl    h        ;use inverted if ovf
  1832.     ret
  1833.  
  1834. greater:            ;c := (hl > de)
  1835.     or    a        ;return true if pos unless zero
  1836.     sbc    hl,de
  1837.     ret    z        ;return hl := 0 and cy := 0
  1838.     jp    po,ge1
  1839.     rl    h
  1840.     ret
  1841.  
  1842. equals:
  1843.     or    a        ;equals and ne return hl =0,ffff
  1844.     sbc    hl,de
  1845.     jp    z,zero
  1846.     ld    hl,0
  1847.     ret
  1848. zero:    dec    hl
  1849.     ret
  1850.  
  1851. neq:
  1852.     or    a
  1853.     sbc    hl,de
  1854.     ret    z
  1855.     ld    hl,0ffffh
  1856.     ret
  1857.  
  1858. mult:                ;multiply de by hl and return in hl
  1859.     ld    b,h
  1860.     ld    c,l
  1861.     ld    hl,0
  1862. mult1:    srl    b
  1863.     rr    c
  1864.     jr    nc,mult2
  1865.     add    hl,de
  1866. mult2:    ld    a,c
  1867.     or    b
  1868.     ret    z
  1869.     sla    e
  1870.     rl    d
  1871.     ld    a,d
  1872.     or    e
  1873.     jr    nz,mult1
  1874.     ret
  1875.  
  1876. rem:    
  1877.     ld    a,h
  1878.     xor    d
  1879.     scf            ;carry set to return rem
  1880.     jr    div1
  1881. div:                ;divide hl by de, return quot in hl
  1882.         ld    a,h        ;find sign of result
  1883.     xor    d        ;clear carry
  1884. div1:    push    af        ;and save it
  1885.     xor    d
  1886.     call    m,neg        ;make quotient positive
  1887.     call    absde        ;and divisor
  1888.     ld    c,h        ;quotient lives in CA
  1889.     ld    a,l
  1890.     ld    hl,0000
  1891.     ld    b,16
  1892. div2:    sla    a
  1893.     rl    c        ;shift quot and remainder left
  1894.     adc    hl,hl
  1895.     sbc    hl,de        ;carry is reset
  1896.     jp    p,div3
  1897.     add    hl,de        ;restore trial subtraction
  1898.     djnz    div2        ;loop
  1899.     jr    div4
  1900. div3:    or    1
  1901.     djnz    div2
  1902. div4:    ld    d,c
  1903.     ld    e,a        ;get the answer
  1904.     pop    af        ;is it negative
  1905.     jr    c,div5        ;branch for rem
  1906.     ex    de,hl        ;get div result into HL
  1907. div5:    ret    p        ;return if ok
  1908.     call    not        ;or negate it
  1909.     inc    hl
  1910.     ret
  1911.  
  1912. absde:    ld    a,d        ;get abs de and check for zero
  1913.     or    a
  1914.     jp    p,absde1
  1915.     cpl
  1916.         ld    d,a
  1917.     ld    a,e
  1918.     cpl
  1919.     ld    e,a
  1920.     inc    de
  1921.     ret
  1922. absde1:    or    e        ;check for zero if positive
  1923.     ret    nz
  1924.     ld    de,zeroerr
  1925.     jp    rntmerr
  1926.  
  1927. twodiv:                ;cheap divide by two with the same
  1928.     bit    7,h        ;action as div, ie round to zero
  1929.     jr    z,twodiv1    ;is it positive?
  1930.     inc    hl        ;increment if not for correct rounding
  1931. twodiv1:
  1932.     sra    h        ;shift right arithmetic
  1933.     rr    l
  1934.     ret
  1935.  
  1936.     page
  1937. ;*****************************
  1938. ;* Machine language library. *
  1939. ;*****************************
  1940.  
  1941. bcplstart:
  1942.     ld    hl,restart    ;copy restart code to location 8
  1943.     ld    de,8
  1944.     ld    bc,020h        ;four routines (leave RST 28H and 38H)
  1945.     ldir            ;copy them in
  1946.     ld    ix,(stackstart)    ;set up the stack after the program
  1947.     ld    hl,(stackend)    ;end of stack, start of heap
  1948.     ld    sp,hl
  1949.     ld    de,(6)        ;get the top of memory
  1950.     dec    de        ;reserve a few
  1951.     dec    de
  1952.     ld    a,e        ;word align
  1953.     and    0feh
  1954.     ld    e,a        ;de has end of heap
  1955.     ex    de,hl        ;now hl
  1956.     ld    (hl),1        ;last block is used, length zero
  1957.     inc    hl
  1958.     ld    (hl),0
  1959.     dec    hl
  1960.     or    a
  1961.     sbc    hl,de        ;get length in hl, start in de
  1962.     ex     de,hl        ;swap
  1963.     ld    (hl),e
  1964.     inc    hl
  1965.     ld    (hl),d        ;put in length of the one block
  1966.     ld    a,(clifcb1+1)    ;see if we have file parsed by the ccp
  1967.     cp    ' '        ;if not blank, we do
  1968.     jr    nz,gotfile1
  1969.     ld    a,(clifcb1+9)
  1970.     cp    ' '
  1971.     jr    z,callstart    ;if no name
  1972. gotfile1:
  1973.     call    allocfcb    ;get a fcb for the input file
  1974.     ld    de,clifcb1    ;get the fcb address
  1975.     call    copyfcb        ;and copy it in
  1976.     call    openin        ;open it for input
  1977.     ld    (instream),hl    ;set up the input stream
  1978.     ld    a,(clifcb2+1)    ;do the same for a possible output file
  1979.     cp    ' '
  1980.     jr    nz,gotfile2
  1981.     ld    a,(clifcb2+9)
  1982.     cp    ' '
  1983.     jr    z,callstart    ;if not
  1984. gotfile2:
  1985.     call    allocfcb
  1986.     ld    de,clifcb2    ;get the fcb sorted
  1987.     call    copyfcb
  1988.     call    openout        ;open it
  1989.     ld    (outstream),hl
  1990.     ld    (outfile),hl    ;remember it's open
  1991. callstart:
  1992.     ld    hl,(globalbase)    ;to global zero
  1993.     ld    a,(hl)
  1994.     inc     hl
  1995.     ld    h,(hl)
  1996.     ld    l,a
  1997.     call    bcplcall    ;do it
  1998. finish:                ;close any open o/p files
  1999.     ld    hl,(outfile)    ;did we open a file?
  2000.     ld    a,h
  2001.     or    l
  2002.     call    nz,closeup    ;close it if so
  2003.     jp    0        ;then warmstart CP/M
  2004.  
  2005. bcplcall:
  2006.     jp    (hl)        ;call a BCPL routine
  2007.  
  2008. globund:            ;come here if we call an undef'd global
  2009.     ld    de,undmess
  2010. rntmerr:
  2011.     push      de
  2012.     ld    de,rnerr
  2013.     ld    c,bprtstrng
  2014.     call    bdos
  2015.     pop    de
  2016.     ld    c,bprtstrng
  2017.     call    bdos
  2018.     jp    0        ;abort
  2019.  
  2020. rnerr:    db    CR,LF,'Runtime Error: $'
  2021. undmess:db    'called undefined global.',CR,LF,'$'
  2022. nsop:    db    'no selected output in WRCH.',CR,LF,'$'
  2023. nsip:   db    'no selected input in RDCH.',CR,LF,'$'
  2024. dferr:    db    'disk full.',CR,LF,'$'
  2025. zeroerr:db    'division by zero.',CR,LF,'$'
  2026. coerr:    db    'coroutine fault.',CR,LF,'$'
  2027. ovflw:    db      'stack overflow.',CR,LF,'$'
  2028.  
  2029. ;**************************
  2030. ;* selectinput()  input() *
  2031. ;**************************
  2032. selectinput:
  2033.     ld    l,(ix+0)
  2034.     ld    h,(ix+1)
  2035.     ld    (instream),hl
  2036.     ret
  2037. input:
  2038.     ld    hl,(instream)
  2039.     ret
  2040. getins:    
  2041.     ld    hl,(instream)    ;get pointer to current out stream
  2042.     ld    a,h        ;if >256, must be file
  2043.     or    a
  2044.     ret    nz
  2045.     adc    hl,hl        ;multiply by two
  2046.     ret    z        ;quit if zero
  2047.     ld    bc,infcbs-2    ;add offset
  2048.     add    hl,bc        ;return z flag as well
  2049.     ret
  2050.  
  2051. ;****************************
  2052. ;* selectoutput() output()  *
  2053. ;****************************
  2054. selectoutput:
  2055.     ld    l,(ix+0)
  2056.     ld    h,(ix+1)
  2057.     ld    (outstream),hl
  2058.     ret
  2059. output:
  2060.     ld    hl,(outstream)
  2061.     ret
  2062. getouts:
  2063.     ld    hl,(outstream)    ;get pointer to current out stream
  2064.     ld    a,h        ;if >256, must be file
  2065.     or    a
  2066.     ret    nz
  2067.     adc    hl,hl        ;multiply by two
  2068.     ret    z        ;quit if zero
  2069.     ld    bc,outfcbs-2    ;add offset
  2070.     add    hl,bc        ;return z flag as well
  2071.     ret
  2072.  
  2073. ;*************************
  2074. ;* Wrch:                 *
  2075. ;*************************
  2076. wrch:    
  2077.     call    getouts        ;get pointer to outstream
  2078.     jr    nz,wrch1    ;check OK
  2079.     ld    de,nsop        ;runtime error if unselected
  2080.     jp    rntmerr
  2081. wrch1:    ld    a,(ix+0)    ;get char
  2082.     bit    binf,(hl)    ;binary stream
  2083.     jr    nz,binary    ;branch if so
  2084.     and    07fh        ;else clear top bit
  2085.     cp    LF        ;*N?
  2086.     jr    nz,binary    
  2087.     ld    a,CR        ;translate to CR,LF
  2088.     push    hl
  2089.     call    binary
  2090.     ld    a,LF
  2091.     pop    hl
  2092. binary:    bit    biosdevice,(hl)    ;real device?
  2093.     jr    z,fileout    ;no, do a file
  2094.     ld    e,a        ;char to bios in E
  2095.     inc    hl        ;get function
  2096.     ld    c,(hl)
  2097.     jp    bdos        ;do it
  2098. fileout:inc    hl        ;point at buffer pointer
  2099.     push    hl        ;save fcb pointer
  2100.     ld    c,(hl)        ;get buffer pointer
  2101.     inc    (hl)        ;and inc buffer pointer
  2102.     inc     hl        ;point hl at buffer
  2103.     ld    b,0        ;calculate address
  2104.     add    hl,bc
  2105.     ld    (hl),a        ;store in char
  2106.     ld    a,c        ;buffer pointer into a
  2107.     pop    hl        ;restore fcb pointer
  2108.     cp    127        ;buffer full?
  2109.     ret     nz        ;return if not
  2110. wrtbuff:ld    a,0        ;clear pointer
  2111.     ld    (hl),a
  2112.     inc    hl        ;point hl at buffer
  2113.     push    hl
  2114.     ex    de,hl        ;to de for bdos
  2115.     ld    c,bsetdma    ;set dma addr
  2116.     call    bdos
  2117.     pop     hl        ;restore buffer addr
  2118.     ld    de,128        ;find cpm fcb addr
  2119.     add    hl,de
  2120.     ex    de,hl
  2121.     ld    c,bwrtseq    ;write seq.
  2122.     call    bdos
  2123.     or    a        ;test for disk full
  2124.     ret    z        ;return if ok
  2125.     ld    de,dferr    ;otherwise runtime error
  2126.     jp    rntmerr
  2127.  
  2128.  
  2129. ;**************
  2130. ;* rdch:      *
  2131. ;**************        
  2132. rdch:
  2133.     call    getins
  2134.     jr    nz,rd1
  2135.     ld    de,nsip        ;no selected ip runtime error
  2136.     jp    rntmerr
  2137. rd1:    bit    biosdevice,(hl)
  2138.     jp    z,filein
  2139.     bit    binf,(hl)
  2140.     jr    z,notbin
  2141. rdrchr:    inc    hl        ;get bdos function
  2142.     ld    c,(hl)
  2143.     call    bdos
  2144. nob1:    ld    l,a        ;char to HL and return
  2145.     ld    h,0
  2146.     ret
  2147. notbin:    call    getchr
  2148.     and    07fh        ;clear top bit
  2149.     cp    CR        ;ditch CRs
  2150.     jr    z,notbin
  2151.     cp    EOF        ;ctrl-z -> endstreamch
  2152.     jr    nz,nob1
  2153.     ld    hl,endstreamch
  2154.     ret
  2155. getchr:    push    hl
  2156.     bit    coninf,(hl)
  2157.     jr    nz,cooked    ;if console, cook it
  2158.     call    rdrchr        ;else get char from rdr
  2159.     pop    hl
  2160.     ret
  2161. getlnz:    ld    de,conbuff    ;point to buffer
  2162.     ld    a,120        ;max no chars
  2163.     ld     (de),a        ;plant in buffer
  2164.     ld    c,bgetlin    ;read console buffer
  2165.     call    bdos
  2166.     ld    a,0        ;clear counter
  2167.     ld    (concount),a
  2168.     ld    e,LF        ;put out LF
  2169.     ld    c,bconout
  2170.     call     bdos
  2171. cooked:    ld    a,(concount)    ;get counter
  2172.     cp    0ffh        ;do we need another line?
  2173.     jr    z,getlnz    ;branch if so
  2174.     ld    c,a
  2175.     ld    a,(conbuff+1)    ;no chars
  2176.     cp    c        ;see if the same
  2177.     jr    z,eol        ;if so, end line
  2178.     ld    hl,conbuff+2    ;calculate address of next char
  2179.     ld    b,0
  2180.     add    hl,bc
  2181.     inc    c        ;inc the counter
  2182.     ld    a,c
  2183.     ld    (concount),a
  2184.     ld    a,(hl)        ;get it
  2185.     pop    hl
  2186.     ret
  2187. eol:    ld    a,0ffh        ;mark we need a new line nextime
  2188.     ld    (concount),a
  2189.     ld    a,LF        ;and send *N
  2190.     pop    hl
  2191.     ret
  2192. filein:    bit    eoff,(hl)    ;previous eof?
  2193.     jr    nz,eof1        ;branch if so
  2194. another:push     hl    
  2195.     inc    hl        ;then point hl at the buffer pointer
  2196.     ld    a,(hl)        ;get bp into a
  2197.     cp    127        ;buffer empty?
  2198.     jr    nz,notebuff    ;branch if not
  2199.     inc    hl        ;point hl at the buffer
  2200.     ex    de,hl        ;into de for bdos
  2201.     ld    c,bsetdma    ;set up dma address
  2202.     call    bdos
  2203.     pop    hl        ;get buffaddr-2
  2204.     push    hl
  2205.     ld    de,130        ;form FCB address
  2206.     add    hl,de
  2207.     ex    de,hl
  2208.     ld    c,brdseq    ;do read sequential
  2209.     call    bdos
  2210.     pop    hl        ;get flag address
  2211.     or    a        ;test for EOF
  2212.     jr    z,noteof1    ;branch if not
  2213. doeof:
  2214.     set    eoff,(hl)    ;set the eofone
  2215. eof1:    ld    hl,endstreamch    ;return endstreamch
  2216.     ret
  2217. noteof1:
  2218.     push    hl
  2219.     inc    hl        ;point at buffer pointer
  2220.     ld    a,0ffh        ;clear buffer pointer
  2221.     ld    (hl),a        ;when incremented
  2222. notebuff:
  2223.     inc    (hl)        ;increment buffer pointer
  2224.     ld    a,(hl)
  2225.     inc    hl        ;point hl at buffer
  2226.     ld    c,a        ;pointer to bc
  2227.     ld    b,0
  2228.     add    hl,bc        ;now have address of char
  2229.     ld    a,(hl)        ;get it
  2230.     pop    hl
  2231.     bit    binf,(hl)    ;binary mode
  2232.     jr    nz,binin    ;all done if so
  2233.     and    07fh        ;clear top bit unless binary
  2234.     cp    CR        ;carriage return?
  2235.     jr    z,another    ;ignore, (get another)
  2236.     cp    EOF        ;ctrl-z?
  2237.     jr    z,doeof        ;do so
  2238. binin:    
  2239.     ld    l,a        ;return char
  2240.     ld    h,0
  2241.     ret
  2242.  
  2243.  
  2244. ;************
  2245. ;* unrdch() *
  2246. ;************
  2247. unrdch:                ;cheap 'n cheerul unrdch, only works
  2248.     call    getins        ;on buffered streams, ie files and
  2249.     bit    biosdevice,(hl)    ;and buffered con
  2250.     jr    nz,unrdcon    ;high byte zero must be con
  2251.     inc    hl        ;must be file
  2252.     ld    a,(hl)        ;get buffer pointer
  2253.     cp    0ffh        ;at start?
  2254.     jr    z,unrdfail    ;nocando if so
  2255.     dec    (hl)        ;decrement buffer pointer
  2256.     ld    hl,0ffffh    ;done ok
  2257.     ret
  2258. unrdcon:bit    coninf,(hl)    ;make sure it is con:
  2259.     jr    z,unrdfail    ;fail if not
  2260.     bit    binf,(hl)    ;must not be binary
  2261.     jr    nz,unrdfail
  2262.     ld    a,(concount)    ;get count
  2263.     dec    a
  2264.     cp    0feh        ;special case if at end of line
  2265.     jr    nz,nreinstate
  2266.     ld    a,(conbuff+1)    ;back to getting *n
  2267. nreinstate:
  2268.     ld    (concount),a
  2269.     ld    hl,0ffffh    ;ok
  2270.     ret
  2271. unrdfail:
  2272.     ld    hl,0
  2273.     ret
  2274.  
  2275. ;***********************************
  2276. ;* binaryoutput(b)  binaryinput(b) *
  2277. ;***********************************
  2278. binaryinput:
  2279.     call    getins
  2280.     jr    bo3
  2281. binaryoutput:
  2282.     call    getouts
  2283. bo3:    ret    z        ;quit if no stream
  2284.     ld    a,(ix+0)    ;get flag in a
  2285.     or    (ix+1)
  2286.     ld    de,0        ;assume result false
  2287.     bit    binf,(hl)
  2288.     jr    z,bo1
  2289.     dec    de        ;result is true
  2290. bo1:    res    binf,(hl)    ;assume new value zero
  2291.     or    a        ;get flag
  2292.     jr    z,bo2
  2293.     set    binf,(hl)
  2294. bo2:    ex    de,hl        ;result into HL
  2295.     ret
  2296.  
  2297.  
  2298. ;******************
  2299. ;* endread()      *
  2300. ;******************
  2301. endread:
  2302.     call    getins    
  2303.     jr    z,endrdfail    ;quit if no stream
  2304.     ld    de,0        ;unselect input stream
  2305.     ld    (instream),de
  2306.     bit    biosdevice,(hl)
  2307.     call    z,freevec1
  2308.     ld    hl,true        ;return true always
  2309.     ret
  2310. endrdfail:
  2311.     ld    hl,false
  2312.     ret
  2313.  
  2314. ;******************
  2315. ;* endwrite()     *
  2316. ;******************
  2317. endwrite:
  2318.     call    getouts
  2319.     jr    z,endrdfail
  2320.     ld    de,0        ;zero COS
  2321.     ld    (outstream),de
  2322.     bit    biosdevice,(hl)
  2323.     jr    nz,endret    ;return if a device
  2324.     call    closeup        ;close the file
  2325.     call    freevec1
  2326. endret:    ld    hl,true    
  2327.     ret
  2328. closeup:call    sysout
  2329.     inc    hl        ;point at count
  2330.     push    hl
  2331.     ld    a,(hl)        ;if the buffer is empty, no need to write
  2332.     or    a
  2333.     jr    z,noz
  2334.     ld    c,a        ;fill the buffer to the end
  2335.     ld    b,0        ;with EOF
  2336.     add    hl,bc
  2337. noz1:    inc    hl
  2338.     ld    (hl),EOF
  2339.     inc    a
  2340.     cp    128
  2341.     jr    nz,noz1
  2342.     pop    hl        ;restore FCB+1
  2343.     push    hl
  2344.     call    wrtbuff        ;write the final buffer
  2345.     pop    hl
  2346. noz:    push    hl
  2347.     ld    de,129        ;get cpm fcb addr
  2348.     add    hl,de
  2349.     ex    de,hl
  2350.     ld    c,bclose    ;close a file
  2351.     call    bdos
  2352.     pop    hl
  2353.     dec    hl
  2354.     ret
  2355. sysout:
  2356.     ld    bc,(outfile)    ;is it the one opened on
  2357.     or    a        ;program invocation?
  2358.     sbc    hl,bc
  2359.     jr    nz,ew1
  2360.     ld    (outfile),hl    ;don't have to close it later then.    
  2361. ew1:    add    hl,bc        ;restore HL
  2362.     ret
  2363.  
  2364. ;***********************************
  2365. ;* removeinput()    removeoutput() *    
  2366. ;***********************************
  2367. removeoutput:
  2368.     call    getouts
  2369.     jr    z,remfail
  2370.     ld    de,0        ;zero COS
  2371.     ld    (outstream),de
  2372.     call    sysout
  2373. rmcom:    bit    biosdevice,(hl)
  2374.     jr    nz,endrem    ;return if a device
  2375.     ex    de,hl
  2376.     ld    hl,130
  2377.     add    hl,de        ;get CPM FCB into DE
  2378.     ex    de,hl
  2379.     push    hl
  2380.     ld    c,bdel        ;delete the fail
  2381.     call    bdos
  2382.     pop    hl
  2383.     call    freevec1
  2384. endrem:    ld    hl,true
  2385.     ret
  2386.  
  2387. removeinput:
  2388.     call    getins
  2389.     jr    z,remfail
  2390.     ld    de,0
  2391.     ld    (instream),de
  2392.     jr    rmcom
  2393. remfail:ld    hl,false
  2394.     ret
  2395.  
  2396. ;************************************************************
  2397. ;* parsefname: given string pointer in DE, FCB addr in HL   *
  2398. ;*             and CPM FCB addr in IY, build an FCB         *
  2399. ;* parse(name, fcb) is a BCPL callable version              *
  2400. ;************************************************************
  2401. parse:
  2402.     ld    e,(ix+0)    ;get args
  2403.     ld    d,(ix+1)
  2404.     ld    l,(ix+2)
  2405.     ld    h,(ix+3)
  2406.     add    hl,hl        ;make FCB a machine pointer
  2407.     push    hl        ;into IY
  2408.     pop    iy        ;HL is nz, so next test fails
  2409. parsefname:
  2410.     ld    a,h        ;quit if allocfcb failed
  2411.     or    l
  2412.     ret    z
  2413.     push    iy        ;must preserve IY
  2414.     sla    e
  2415.     rl    d        ;string to machine address
  2416.     ld    a,(de)        ;init string size counter
  2417.     ld    c,a
  2418.     inc    de        ;point to first char
  2419.     call    getnext        ;get first char
  2420.     push    af        ;save it
  2421.     call    getnext        ;and second
  2422.     cp    ':'        ;if second char colon, have drivespec
  2423.     jr    nz,defdrv    ;branch if using default
  2424.     pop    af        ;get first back
  2425.     sub    'A'
  2426.     cp    16        ;in range?
  2427.     jr    nc,defdrv1    ;else treat as if no drivespec
  2428.     inc    a
  2429.     ld    (iy+0),a    ;put in the drive position
  2430.     call    getnext        ;put in the first two chars
  2431.     ld    (iy+1),a
  2432.     call    getnext
  2433.     ld    (iy+2),a
  2434.     jr    ndef
  2435. defdrv1:add    a,'A'
  2436.     push    af
  2437.     ld    a,':'
  2438. defdrv:    ld    (iy+0),0    ;default drive
  2439.     ld    (iy+2),a    ;put in first two chars
  2440.     pop    af
  2441.     ld    (iy+1),a
  2442. ndef:    inc    iy
  2443.     inc    iy
  2444.     ld    b,6        ;get next six chars
  2445.     call    getsect
  2446. nsect:    ld    a,c        ;out of chars
  2447.     or    a
  2448.     jr    z,ext        ;nothing to do if so
  2449.     ld    a,(de)        ;skip to find . or end
  2450.     inc    de
  2451.     dec    c
  2452.     cp    '.'
  2453.     jr    nz,nsect
  2454. ext:    ld    b,3        ;read extension
  2455.     call    getsect
  2456.     pop    iy
  2457.     ret
  2458. getsect:inc    iy
  2459.     call    getnext
  2460.     ld    (iy+0),a
  2461.     djnz    getsect
  2462.     ret
  2463. getnext:ld    a,c        ;at end
  2464.     or    a
  2465.     jr    z,gn3        ;return space if so
  2466.     ld    a,(de)
  2467.     cp    '.'        ;at end of section
  2468.     jr    nz,gn1
  2469. gn3:    ld    a,' '        ;also return space
  2470.     ret
  2471. gn1:    cp    '*'        ;wildcard to expand?
  2472.     jr    nz,gn2
  2473.     ld    a,'?'        ;expand it
  2474.     ret
  2475. gn2:    inc    de        ;onto next char
  2476.     dec    c
  2477.     cp    ' '        ;get another if space or control
  2478.     jr    c,getnext
  2479.     cp    'a'        ;lc -> uc
  2480.     ret    c
  2481.     cp    'z'+1
  2482.     ret    nc
  2483.     sub    020h
  2484.     ret
  2485.  
  2486. ;**********************************************************************
  2487. ;* allocfcb, getvec an FCB, return machine pointer in HL, and pointer *
  2488. ;* to CPM FCB in IY.                                                  *
  2489. ;* copyfcb, copy CPM fcb pointed to by DE into BCPL FCB in HL and IY  *
  2490. ;* zerofcb, clear required fields in FCB, and check that the filename *
  2491. ;* is unambiguous                                                     *
  2492. ;**********************************************************************
  2493. allocfcb:
  2494.     ld    iy,82        ;size of fcb in words
  2495.     call    getvec1        ;find an fcb in hl
  2496.     add    hl,hl        ;machine address
  2497.     push    hl
  2498.     pop    iy
  2499.     ld    bc,130        ;find address of cpm part
  2500.     add    iy,bc
  2501.     ret
  2502.  
  2503. copyfcb:
  2504.      push    hl        ;save hl
  2505.     push    iy
  2506.     pop    hl
  2507.     ex    de,hl
  2508.     ld    bc,12
  2509.     ldir
  2510.     pop    hl
  2511.     ret
  2512.  
  2513. zerofcb:
  2514.     ld    a,l        ;abort if allocfcb failed
  2515.     or    h
  2516.     ret    z
  2517.     ld    (iy+12),0    ;clear ex
  2518.     ld    (iy+14),0    ;and s2
  2519.     ld    (iy+32),0    ;and cr
  2520.     push    iy        ;copy into DE for the BDOS
  2521.     pop    de
  2522.     ld    b,11        ;check for ambiguous filename
  2523. sf1:    inc    iy
  2524.     ld    a,(iy+0)
  2525.     cp    '?'
  2526.     jr    z,oerr        ;free store and return zero
  2527.     djnz    sf1
  2528.     ret
  2529.  
  2530. ;***************
  2531. ;* findinput() *
  2532. ;***************
  2533. findinput:
  2534.     call    allocfcb    ;get store
  2535.     ld    e,(ix+0)
  2536.     ld    d,(ix+1)
  2537.     call    parsefname
  2538. openin:
  2539.     call    zerofcb
  2540.     ld    a,l
  2541.     or    h
  2542.     ret    z        ;quit if no buffer
  2543.     res    binf,(hl)    ;don't reset binary mode on rewind
  2544. openin1:
  2545.     push    hl
  2546.     inc    hl        ;clear buffer pointer
  2547.     ld    (hl),127
  2548.     ld    c,bopen        ;open it
  2549.     call    bdos
  2550.     pop    hl        ;get bcpl fcb addr back
  2551.     inc    a        ;check for error
  2552.     jr    z,oerr
  2553.     res    eoff,(hl)    ;not at end of file
  2554.     res    biosdevice,(hl)    ;read file
  2555.     ret
  2556. oerr:    call    freevec1    ;free store and
  2557.     ld    hl,0        ;return zero if nocando
  2558.     ret
  2559.  
  2560. ;********************
  2561. ;* findoutput()     *
  2562. ;********************
  2563. findoutput:
  2564.     call    allocfcb
  2565.     ld    e,(ix+0)
  2566.     ld    d,(ix+1)
  2567.     call    parsefname
  2568. openout:
  2569.     call    zerofcb        ;do all the fcb stuff
  2570.     ld    a,l
  2571.     or    h
  2572.     ret    z        ;quit if no buffer
  2573.     res    binf,(hl)
  2574.     push    hl
  2575.     inc    hl        ;clear pointer
  2576.     ld    (hl),0
  2577.     push    de
  2578.     ld    c,bdel        ;delete pre-existing file
  2579.     call    bdos
  2580.     pop    de
  2581.     ld    c,bmake        ;make a file
  2582.     call    bdos
  2583.     pop    hl
  2584.     inc    a
  2585.     jr    z,oerr        ;branch if no dir space
  2586.     res    biosdevice,(hl)    ;and write flag
  2587.     res     eoff,(hl)
  2588.     ret
  2589.  
  2590. ;************
  2591. ;* rewind() *
  2592. ;************
  2593. rewind:
  2594.     ld    hl,(instream)
  2595.     ld    a,h        ;is it a file?
  2596.     or    a
  2597.     jr    z,rewerr    ;error if not
  2598. reopen:    push    hl
  2599.     pop    iy
  2600.     ld    bc,130
  2601.     add    iy,bc
  2602.     call    zerofcb        ;clear bits and get cpm fcb in de
  2603.     call    openin1        ;open it again
  2604.     ld    a,h        ;make result boolean
  2605.     or    l
  2606.     jr    z,rewerr
  2607.     ld    hl,0ffffh
  2608.     ret
  2609. rewerr:
  2610.     ld    hl,0
  2611.     ld    (instream),hl
  2612.     ret
  2613.  
  2614. ;**********************
  2615. ;* endtoinput()       *
  2616. ;**********************
  2617. endtoinput:
  2618.     ld    hl,(outstream)
  2619.     ld    de,0        ;unselect op
  2620.     ld    (outstream),de
  2621.     ld    a,h        ;is it file?
  2622.     or    a
  2623.     jr    z,rewerr    ;error if not
  2624.     push    hl
  2625.     call    closeup        ;close file
  2626.     pop    hl
  2627.     ld    (instream),hl    ;make it the input stream
  2628.     jp    reopen        ;and open it for input
  2629.  
  2630. ;*********************
  2631. ;* bdos(func, arg)   *
  2632. ;*********************
  2633. callbdos:
  2634.     ld    c,(ix+0)
  2635.     ld    e,(ix+2)
  2636.     ld    d,(ix+3)
  2637. bdos:    push    ix        ;save IX incase BDOS doesn't
  2638.     call    5
  2639.     pop    ix
  2640.     ret
  2641.  
  2642. ;*****************************************
  2643. ;* intkey() return true if ctl-c pressed *
  2644. ;*****************************************
  2645. intkey:
  2646.     ld    c,bconstat    ;char typed?
  2647.     call    bdos
  2648.     or    a
  2649.     jr    z,intf        ;return false if not
  2650.     ld    c,bconin    ;get it
  2651.     call    bdos
  2652.     cp    QUIT        ;ctl-c?
  2653.     jr    nz,intf        ;return false if not
  2654.     ld    hl,true
  2655.     ret
  2656. intf:    ld    hl,false
  2657.     ret
  2658.     
  2659. ;************
  2660. ;* level1() *
  2661. ;************
  2662. level1:
  2663.     ld    hl,2;        ;return the sp for the calling
  2664.     add    hl,sp        ;proc.
  2665.     ret
  2666.  
  2667. ;************
  2668. ;* level2() *
  2669. ;************
  2670. level2:
  2671.     push    ix        ;return P pointer of calling proc.
  2672.     pop    hl
  2673.     ret
  2674.  
  2675. ;***********************************
  2676. ;* longjump(level1, level2, label) *
  2677. ;***********************************
  2678. longjump:
  2679.     ld    l,(ix+0)
  2680.     ld    h,(ix+1)
  2681.     ld    sp,hl        ;restore
  2682.     ld    l,(ix+2)    ;put label in hl
  2683.     ld    h,(ix+3)
  2684.     push    hl        ;put new ix on the stack
  2685.     ld    l,(ix+4)
  2686.     ld    h,(ix+5)
  2687.     pop    ix
  2688.     jp    (hl)        ;and call the label
  2689.  
  2690. ;****************
  2691. ;* stackavail() *
  2692. ;****************
  2693. stackavail:
  2694.     push    ix        ;return free memory (in words)
  2695.     pop    de
  2696.     ld    hl,0        ;sp in hl
  2697.     add    hl,sp
  2698.     or    a
  2699.     sbc    hl,de        ;difference is answer
  2700.     srl    h
  2701.     rr    l        ;make into words
  2702.     ret
  2703.  
  2704. ;*******************************
  2705. ;* result = muldiv(x, y, z)    *
  2706. ;*******************************
  2707. muldiv:
  2708.     push    ix        ;we corrupt ix, so save
  2709.     ld    a,(ix+1)    ;determine sign of final result
  2710.     xor    (ix+3)
  2711.     xor    (ix+5)
  2712.     push    af        ;and save it
  2713.     ld    l,(ix+4)    ;save z on stack before we corrupt ix
  2714.     ld    h,(ix+5)
  2715.     push    hl
  2716.     ld    l,(ix+0)    ;take abs of x and y
  2717.     ld    h,(ix+1)
  2718.     call    abs
  2719.     ld    c,l
  2720.     ld    b,h        ;put abs x in BC
  2721.     ld    l,(ix+2)
  2722.     ld    h,(ix+3)
  2723.     call    abs
  2724.     ld    e,l
  2725.     ld    d,h        ;multipy x and y into IX and IY
  2726.     ld    hl,0
  2727.     ld    ix,0
  2728.     ld    iy,0
  2729. md1:    srl    b
  2730.     rr    c
  2731.     jr    nc,md2
  2732.     add    ix,de        ;add into partial result
  2733.     ex    de,hl        ;get high part of partial prod in de
  2734.     jr    nc,md1a
  2735.     inc    iy
  2736. md1a:    add    iy,de
  2737.     ex    de,hl        ;restore hl and de
  2738. md2:    sla    e
  2739.     rl    d
  2740.     adc    hl,hl        ;shift up partials
  2741.     ld    a,c
  2742.     or    b
  2743.     jr    nz,md1
  2744.     pop    de        ;get abs z and check for zero
  2745.     call    absde
  2746.     push    ix
  2747.     pop    hl
  2748.     ld    c,h        ;quotient lives in CA and on the stack
  2749.     ld    a,l
  2750.     push    iy
  2751.     ld    hl,0000
  2752.     ld    b,32
  2753. md3:    sla    a
  2754.     rl    c        ;shift quot and remainder left
  2755.     ex    (sp),hl
  2756.     adc    hl,hl
  2757.     ex    (sp),hl
  2758.     adc    hl,hl
  2759.     or    a
  2760.     sbc    hl,de        ;carry is reset
  2761.     jp    p,md4
  2762.     add    hl,de        ;restore trial subtraction
  2763.     djnz    md3        ;loop
  2764.     jr    md5
  2765. md4:    or    1
  2766.     djnz    md3
  2767. md5:    pop    de
  2768.     ld    h,c
  2769.     ld    l,a        ;get the answer
  2770.     pop    af        ;is it negative
  2771.     pop    ix        ;restore ix
  2772.     jp    m,neg        ;do it if so
  2773.     ret
  2774.  
  2775. ;*********************
  2776. ;* in(addr) do input *
  2777. ;*********************
  2778. in:    ld    c,(ix+0)
  2779.     ld    b,(ix+1)    ;do 16 bit address
  2780.     in    l,(c)
  2781.     ld    h,0
  2782.     ret
  2783.  
  2784. ;*****************************
  2785. ;* out(addr, byte) do output *
  2786. ;*****************************
  2787. out:    ld    c,(ix+0)
  2788.     ld    b,(ix+1)
  2789.     ld    a,(ix+2)
  2790.     out    (c),a
  2791.     ret
  2792.  
  2793. ;*************************
  2794. ;* memcpy(src, dst, len) *
  2795. ;*************************
  2796. memcpy:    ld    l,(ix+0)    ;source
  2797.     ld    h,(ix+1)
  2798.     add    hl,hl        ;Make byte address
  2799.     ld    e,(ix+2)
  2800.     ld    d,(ix+3)
  2801.     sla    e
  2802.     rl    d
  2803.     ld    c,(ix+4)
  2804.     ld    b,(ix+5)
  2805.     sla    c
  2806.     rl    b
  2807.     ld    a,b
  2808.     or    c        ;check for zero length
  2809.     ret    z        ;nothing to do if so
  2810.     ldir            ;do the move
  2811.     ret
  2812.  
  2813. ;************************************************
  2814. ;* c := createco(func, size) create a coroutine *
  2815. ;************************************************
  2816. createco:
  2817.     ld    l,(ix+2)    ;pass size to getvec
  2818.     ld    h,(ix+3)
  2819.     push    hl
  2820.     pop    iy        ;in IY!
  2821.     call    getvec1
  2822.     ld    a,l        ;check for zero
  2823.     or    h
  2824.     ret    z
  2825.     push    hl        ;save to return
  2826.     ld    e,(ix+2)    ;size in DE
  2827.     ld    d,(ix+3)
  2828.     ex    de,hl        ;size in HL, length in DE
  2829.     add    hl,de        ;end into HL
  2830.     add    hl,hl        ;machine address
  2831.     ex    de,hl        ;start in HL, end in DE
  2832.     add    hl,hl        ;machine address
  2833.     ld    c,l
  2834.     ld    b,h        ;start+6 for initial P pointer
  2835.     inc    bc
  2836.     inc    bc
  2837.     inc    bc
  2838.     inc    bc
  2839.     inc    bc
  2840.     inc    bc
  2841.     ex    de,hl        ;end in HL, start in DE
  2842.     dec    hl
  2843.     ld    (hl),high costart
  2844.     dec    hl        ;put PC onto proto-stack
  2845.     ld    (hl),low costart
  2846.     dec    hl
  2847.     ld    (hl),b        ;and P pointer
  2848.     dec    hl
  2849.     ld    (hl),c        ;now have proto-SP in HL
  2850.     ex    de,hl        ;now DE
  2851.     ld    (hl),e        ;put in save area at start
  2852.     inc    hl
  2853.     ld    (hl),d
  2854.     inc    hl
  2855.     ld    (hl),0        ;zero means inactive
  2856.     inc    hl
  2857.     ld    (hl),0
  2858.     inc    hl        ;now to our function
  2859.     ld    a,(ix+0)    ;copy it in
  2860.     ld    (hl),a
  2861.     inc    hl
  2862.     ld    a,(ix+1)
  2863.     ld    (hl),a
  2864.     pop    hl        ;get start back
  2865.     ret
  2866.     
  2867. coloop:    ld    (ix+0),l    ;result of func is arg
  2868.     ld    (ix+1),h    ;of cowait
  2869.     call    cowait
  2870. costart:ld    (ix+0),l    ;result of cowait is arg
  2871.     ld    (ix+1),h    ;of func
  2872.     ld    iy,(currco)
  2873.     ld    l,(iy+4)    ;get our coroutines function
  2874.     ld    h,(iy+5)
  2875.     ld    de,coloop    ;func returns to top of loop
  2876.     push    de
  2877.     jp    (hl)        ;call it
  2878.  
  2879. ;********************************************
  2880. ;* deleteco() delete coroutine              *
  2881. ;********************************************
  2882. deleteco:
  2883.     ld    l,(ix+0)    ;check its inactive
  2884.     ld    h,(ix+1)
  2885.     inc    hl        ;get address of link
  2886.     add    hl,hl
  2887.     ld    a,(hl)
  2888.     inc    hl
  2889.     or    (hl)
  2890.     jr    nz,pcoerr    ;if its not zero, error
  2891.     jp    freevec        ;now free up the store
  2892.  
  2893. ;********************************************
  2894. ;* c = currentco() return current coroutine *
  2895. ;********************************************
  2896. currentco:
  2897.     ld    hl,(currco)
  2898.     srl    h        ;make it a BCPL address
  2899.     rr    l
  2900.     ret
  2901.  
  2902. ;*********************************
  2903. ;* callco(c, arg) call coroutine *
  2904. ;*********************************
  2905. callco:
  2906.     push    ix        ;save P pointer on stack
  2907.     call    savesp
  2908. callco1:
  2909.     ld    l,(ix+0)    ;now get save area of new coroutine
  2910.     ld    h,(ix+1)
  2911.     add    hl,hl        ;to machine pointer
  2912.     ld    (currco),hl    ;put new one in
  2913.     ld    e,(hl)        ;get new cr's SP
  2914.     inc    hl
  2915.     ld    d,(hl)
  2916.     inc    hl
  2917.     ld    a,(hl)
  2918.     ld    (hl),c        ;save link back to parent
  2919.     inc    hl
  2920.     or    (hl)
  2921.     jr    z,callco2
  2922. pcoerr:    ld    de,coerr    ;if old link wasn't zero, error
  2923.     jp    rntmerr
  2924. callco2:
  2925.     ld    (hl),b
  2926.     ex    de,hl        ;new SP into HL
  2927.     ld    sp,hl        ;then home
  2928.     ld    l,(ix+2)    ;return ARG in HL
  2929.     ld    h,(ix+3)
  2930.     pop    ix        ;get IX from our new stack
  2931.     ret            ;and PC
  2932. savesp:
  2933.     ld    hl,2        ;get our current SP
  2934.     add    hl,sp
  2935.     ex    de,hl        ;into de
  2936.     ld    hl,(currco)    ;get address of current save area
  2937.     ld    (hl),e        ;save SP there
  2938.     inc    hl
  2939.     ld    (hl),d
  2940.     ld    bc,(currco)    ;get current save area again
  2941.     ret
  2942.  
  2943. ;*********************************
  2944. ;* cowait(arg) suspend coroutine *
  2945. ;*********************************
  2946. cowait:
  2947.     push    ix
  2948.     call    getcoandsp    ;get currco in HL and check
  2949.     ld    e,(hl)        ;get parents save area
  2950.     ld    (hl),0        ;zero to indicate inactive
  2951.     inc    hl
  2952.     ld    d,(hl)
  2953.     ld    (hl),0
  2954.     ex    de,hl        ;into hl
  2955.     ld    (currco),hl    ;parent becomes current again
  2956.     ld    e,(hl)        ;get parents SP
  2957.     inc    hl
  2958.     ld    d,(hl)
  2959.     ex    de,hl        ;SP into HL
  2960.     ld    sp,hl        ;then SP
  2961.     ld    l,(ix+0)    ;return ARG in HL
  2962.     ld    h,(ix+1)
  2963.     pop    ix        ;get parents IX
  2964.     ret            ;an PC
  2965.  
  2966. ;********************
  2967. ;* resumeco(c, arg) *
  2968. ;********************
  2969. resumeco:
  2970.     push    ix        ;put P pointer on stack
  2971.     call    getcoandsp
  2972.     ld    c,(hl)        ;get parent
  2973.     ld    (hl),0        ;and zero
  2974.     inc    hl
  2975.     ld    b,(hl)
  2976.     ld    (hl),0
  2977.     jp    callco1        ;save link and restore SP
  2978. getcoandsp:
  2979.     ld    de,(currco)    ;get current coroutine
  2980.     ld    hl,mainco    ;check we're not COWAITing in main
  2981.     or    a
  2982.     sbc    hl,de
  2983.     jp    z,pcoerr
  2984.     ld    hl,2        ;compensate for return address
  2985.     add    hl,sp        ;callee SP in HL
  2986.     ex    de,hl        ;now DE, and currco in HL
  2987.     ld    (hl),e        ;save SP
  2988.     inc    hl
  2989.     ld    (hl),d
  2990.     inc    hl        ;leave HL pointing at parent link
  2991.     ret
  2992.     
  2993. ;****************************************
  2994. ;* colongjump(c, level1, level2, label) *
  2995. ;****************************************
  2996. colongjump:
  2997.     push    ix
  2998.     call    savesp        ;save SP and get currco in BC
  2999. colj2:    ld    l,(ix+0)
  3000.     ld    h,(ix+1)
  3001.     add    hl,hl
  3002.     or    a
  3003.     sbc    hl,bc        ;is it our target?
  3004.     jr    z,colj1        ;branch if so
  3005.     ld    hl,mainco    ;if at end, error
  3006.     or    a
  3007.     sbc    hl,bc
  3008.     jp    z,pcoerr    ;print an error
  3009.     ld    l,c        ;if not make inactive and to next
  3010.     ld    h,b
  3011.     inc    hl
  3012.     inc    hl
  3013.     ld    c,(hl)        ;get next one
  3014.     ld     (hl),0        ;this one inactive now
  3015.     inc    hl
  3016.     ld    b,(hl)
  3017.     ld    (hl),0
  3018.     jr    colj2
  3019. colj1:    ld    (currco),bc    ;new currco
  3020.     inc    ix
  3021.     inc    ix        ;set up args for longjump
  3022.     jp    longjump
  3023.  
  3024. ;***************************************************************
  3025. ;* getvec(words)   claim heap storage.                         *
  3026. ;* The heap is based on the one in R&W-S, but we use byte      *
  3027. ;* addresses and lengths and keep the freebit in the low bit.  *
  3028. ;***************************************************************
  3029. maxvec:    
  3030.     push    ix        ;preserve ix, we use it here.
  3031.     ld    iy,0        ;maxvec returns largest available 
  3032.     ld    ix,0        ;block
  3033.     jr    getvec2
  3034. getvec:    
  3035.     ld    l,(ix+0)    ;put len in IY
  3036.     ld    h,(ix+1)
  3037.     inc    hl        ;getvec gets n+1 words
  3038.     push    hl
  3039.     pop    iy
  3040. getvec1:            ;assembly callable job, length in IY    
  3041.     inc    iy        ;need one control word
  3042. getvec2:
  3043.     ld    bc,(stackend)    ;BC has base of the current block 
  3044. newblk:    ld    de,0        ;DE has length of that block
  3045. amalg1:    ld    h,b        ;get address of block length in HL
  3046.     ld    l,c
  3047.     add    hl,de
  3048.     bit    0,(hl)        ;is it free?
  3049.     jr    z,unused    ;branch if so
  3050.     ld    a,(hl)        ;else on to the next one
  3051.     and     0feh        ;mask off inusebit
  3052.     ld    e,a
  3053.     inc    hl
  3054.     ld    d,(hl)
  3055.     dec    hl
  3056.     or    d        ;at end
  3057.     jr    z,gvfail    ;branch if so
  3058.     add    hl,de        ;now have next block in HL
  3059.     ld    b,h
  3060.     ld    c,l        ;in BC where it belongs
  3061.     jr    newblk
  3062. unused:    ld    a,(hl)        ;an unused block to add.
  3063.     inc    hl        ;get the length
  3064.     ld    h,(hl)
  3065.     ld    l,a
  3066.     add    hl,de        ;add into de
  3067.     ld    d,h
  3068.     ld    e,l
  3069.     push    iy        ;get length required
  3070.     pop     hl
  3071.     or    a
  3072.     adc    hl,hl        ;in bytes, with zero flag
  3073.     jr    z,maxvec1    ;if zero, we're in maxvec
  3074.     ex    de,hl
  3075.     or    a
  3076.     sbc    hl,de
  3077.     jr    c,amalg        ;if not big enough, keep trying
  3078.     jr    z,exact        ;branch if an exact fit.
  3079.     ex    de,hl        ;get length into hl, residue in de
  3080.     ld    a,l        ;put new length in our block
  3081.     ld    (bc),a
  3082.     inc    bc
  3083.     ld    a,h
  3084.     ld    (bc),a
  3085.     dec    bc
  3086.     add    hl,bc        ;find address of end
  3087.     ld    (hl),e        ;de has address of block to be created
  3088.     inc    hl
  3089.     ld    (hl),d
  3090. exact:    ld    h,b
  3091.     ld    l,c
  3092.     set    0,(hl)        ;set used bit
  3093.     srl    h        ;get word address
  3094.     rr    l
  3095.     inc    hl        ;skip control
  3096.     ret
  3097. amalg:    add    hl,de        ;restore length in DE
  3098.     ex    de,hl
  3099. amalg2:    ld    a,e
  3100.     ld    (bc),a        ;put new length in block start
  3101.     inc    bc        ;so that we can go quicker
  3102.     ld    a,d        ;next time round
  3103.     ld    (bc),a
  3104.     dec    bc
  3105.     jr    amalg1
  3106. gvfail:    push    iy        ;are we in maxvec
  3107.     pop    hl
  3108.     ld    a,l
  3109.     or    h
  3110.     jr    nz,gvfail1    ;branch if not (really failed)
  3111.     push    ix        ;else return what we found
  3112.     pop    hl
  3113.     srl    h        ;in words
  3114.     rr    l
  3115.     dec    hl        ;less one for control
  3116.     dec    hl        ;and another 'cause we allocate
  3117.     pop    ix        ;one extra
  3118.     ret
  3119. gvfail1:ld    hl,0        ;return 0 if failure
  3120.     ret
  3121. maxvec1:
  3122.     push    ix        ;see if this block is biggest
  3123.     pop    hl
  3124.     or    a
  3125.     sbc    hl,de
  3126.     jr    nc,amalg2    ;branch if not
  3127.     push    de
  3128.     pop    ix        ;record if so
  3129.     jr    amalg2
  3130.  
  3131. ;*****************
  3132. ;* freevec(addr) *
  3133. ;*****************
  3134. freevec:
  3135.     ld    l,(ix+0)
  3136.     ld    h,(ix+1)
  3137.     ld    a,h        ;if zero, quit
  3138.     or    l
  3139.     ret    z
  3140.     add    hl,hl        ;to byte address
  3141. freevec1:
  3142.     dec    hl        ;back to control word
  3143.     dec    hl
  3144.     res    0,(hl)        ;free it
  3145.     ret
  3146.  
  3147. progend    equ    $
  3148.     .dephase
  3149.  
  3150. ;calculate the difference between where the image is at load time
  3151. ;and at run time
  3152.  
  3153. offset    equ    $-progend    
  3154.     end
  3155.