home *** CD-ROM | disk | FTP | other *** search
/ norge.freeshell.org (192.94.73.8) / 192.94.73.8.tar / 192.94.73.8 / pub / computers / cpm / alphatronic / DRIPAK.ZIP / CPM_3-0 / SOURCES / GENCPM.PLM < prev    next >
Text File  |  1982-12-31  |  43KB  |  1,479 lines
  1. $title('CP/M 3 System Generation')
  2. gencpm:
  3. do;
  4.  
  5. /*
  6.   Copyright (C) 1982
  7.   Digital Research
  8.   P.O. Box 579
  9.   Pacific Grove, CA 93950
  10. */
  11.  
  12. /*
  13.     Revised:
  14.       02 Dec 82  by Bruce Skidmore
  15. */
  16.  
  17.   declare true literally '0FFH';
  18.   declare false literally '0';
  19.   declare forever literally 'while true';
  20.   declare boolean literally 'byte';
  21.   declare cr literally '0dh';
  22.   declare lf literally '0ah';
  23.  
  24.   mon1:
  25.     procedure (func,info) external;
  26.       declare func byte;
  27.       declare info address;
  28.     end mon1;
  29.  
  30.   mon2:
  31.     procedure (func,info) byte external;
  32.       declare func byte;
  33.       declare info address;
  34.     end mon2;
  35.  
  36.   relfix:
  37.     procedure byte external;
  38.     end relfix;
  39.  
  40.   setbuf:
  41.     procedure external;
  42.     end setbuf;
  43.  
  44.   getdef:
  45.     procedure external;
  46.     end getdef;
  47.  
  48.   crtdef:
  49.    procedure external;
  50.    end crtdef;
  51.  
  52.   declare reset label external;
  53.  
  54.   declare fcb (1) byte external;
  55.   declare fcb16 (1) byte external;
  56.   declare tbuff (1) byte external;
  57.   declare maxb address external;
  58.   declare bitmap (128) byte external;
  59.  
  60.   declare FCBin address public;
  61.  
  62.   declare bios$fcb (36) byte initial (
  63.     0,'BNKBIOS3','SPR',0,0,0,0,0,0,0,0,
  64.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  65.  
  66.   declare res$fcb (36) byte initial (
  67.     0,'RESBDOS3','SPR',0,0,0,0,0,0,0,0,
  68.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  69.  
  70.   declare bnk$fcb (36) byte initial (
  71.     0,'BNKBDOS3','SPR',0,0,0,0,0,0,0,0,
  72.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  73.  
  74.   declare FCBout (36) byte initial (
  75.     0,'CPM3    ','SYS',0,0,0,0,0,0,0,0,
  76.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  77.  
  78.   declare data$fcb (36) byte public initial (
  79.     0,'GENCPM  ','DAT',0,0,0,0,0,0,0,0,
  80.     0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0);
  81.  
  82.   declare offset byte public;
  83.   declare prgsiz address public;
  84.   declare bufsiz address public;
  85.   declare codsiz address public;
  86.   declare bios$pg byte public;
  87.   declare scb$pg byte public;
  88.   declare res$pg byte public;
  89.   declare bnk$pg byte public;
  90.   declare bnk$off byte public;
  91.   declare res$len byte public;
  92.   declare non$bnk byte public;
  93.   declare dma address public;
  94.  
  95.   declare hexASCII (16) byte public data (
  96.     '0123456789ABCDEF');
  97.  
  98.   declare lnbfr (14) byte public initial (12);
  99.  
  100.   declare sctbfr (1) structure (
  101.     record (128) byte) public at (.memory);
  102.  
  103.   declare fcb$msg (13) byte initial ('        .   $');
  104.  
  105.   declare query boolean public;
  106.  
  107. /*
  108.      B D O S    P r o c e d u r e   &   F u n c t i o n    C a l l s
  109. */
  110.  
  111.   system$reset:
  112.     procedure public;
  113.       call mon1 (0,0);
  114.     end system$reset;
  115.  
  116.   write$console:
  117.     procedure (char) public;
  118.       declare char byte;
  119.       if display then
  120.         call mon1 (2,char);
  121.     end write$console;
  122.  
  123.   print$console$buffer:
  124.     procedure (buffer$address) public;
  125.       declare buffer$address address;
  126.       if display then
  127.         call mon1 (9,buffer$address);
  128.     end print$console$buffer;
  129.  
  130.   read$console$buffer:
  131.     procedure (buffer$address) public;
  132.       declare buffer$address address;
  133.       declare buf based buffer$address (1) byte;
  134.       buf(1) = 0;
  135.       if automatic then 
  136.         do;
  137.           if not query then
  138.             return;
  139.         end;
  140.       call mon1 (10,buffer$address);
  141.       buf(buf(1)+2) = 0;
  142.     end read$console$buffer;
  143.  
  144.   crlf:
  145.     procedure public;
  146.       call write$console (cr);
  147.       call write$console (lf);
  148.     end crlf;
  149.  
  150.   error:
  151.     procedure(term$code,err$type,err$msg$adr) public;
  152.       declare (term$code,err$type) byte;
  153.       declare err$msg$adr address;
  154.       display = true;
  155.       call print$console$buffer (.(cr,lf,
  156.           'ERROR:  $'));
  157.       call print$console$buffer (err$msg$adr);
  158.       if err$type = 1 then
  159.         call print$console$buffer(.fcb$msg);
  160.       call crlf;
  161.       if term$code then
  162.         call system$reset;
  163.       if automatic and not query then
  164.         do;
  165.           fcb(1),
  166.           fcb16(1) = ' ';
  167.           goto reset;
  168.         end;
  169.    end error;
  170.  
  171.   open$file:
  172.     procedure (fcb$address) byte public;
  173.       declare fcb$address address;
  174.       declare fcb based fcb$address (1) byte;
  175.       fcb(12),      /* ex = 0 */
  176.       fcb(32) = 0;  /* cr = 0 */
  177.       return mon2 (15,fcb$address);
  178.     end open$file;
  179.  
  180.   close$file:
  181.     procedure (fcb$address) public;
  182.       declare fcb$address address;
  183.       call mon1 (16,fcb$address);
  184.     end close$file;
  185.  
  186.   delete$file:
  187.     procedure (fcb$address) public;
  188.       declare fcb$address address;
  189.       call mon1 (19,fcb$address);
  190.     end delete$file;
  191.  
  192.   read$record:
  193.     procedure (fcb$address) public;
  194.       declare fcb$address address;
  195.       if mon2 (20,fcb$address) <> 0 then
  196.       do;
  197.         call error(true,1,.(
  198.           'Reading file:  $'));
  199.       end;
  200.     end read$record;
  201.  
  202.   write$record:
  203.     procedure (fcb$address) public;
  204.       declare fcb$address address;
  205.       if mon2 (21,fcb$address) <> 0 then
  206.       do;
  207.         call error(true,1,.(
  208.           'Writing file:  ','$'));
  209.       end;
  210.     end write$record;
  211.  
  212.   create$file:
  213.     procedure (fcb$address) public;
  214.       declare fcb$address address;
  215.       declare fcb based fcb$address (1) byte;
  216.       if mon2 (22,fcb$address) = 255 then
  217.       do;
  218.         call error(true,0,.(
  219.           'Directory full','$'));
  220.       end;
  221.       fcb(32) = 0;  /* set cr = 0 */
  222.     end create$file;
  223.  
  224.   set$DMA$address:
  225.     procedure (DMA$address) public;
  226.       declare DMA$address address;
  227.       call mon1 (26,DMA$address);
  228.     end set$DMA$address;
  229.  
  230.   read$random$record:
  231.     procedure (fcb$address) public;
  232.       declare fcb$address address;
  233.       if mon2 (33,fcb$address) <> 0 then
  234.       do;
  235.         call error(true,1,.(
  236.           'Reading file: ','$'));
  237.       end;
  238.     end read$random$record;
  239.  
  240.   write$random$record:
  241.     procedure (fcb$address) public;
  242.       declare fcb$address address;
  243.       if mon2 (34,fcb$address) <> 0 then
  244.       do;
  245.         call error(true,1,.(
  246.           'Writing file:  ','$'));
  247.       end;
  248.     end write$random$record;
  249.  
  250.   set$random$record:
  251.     procedure (fcb$address) public;
  252.       declare fcb$address address;
  253.       call mon1 (36,fcb$address);
  254.     end set$random$record;
  255.  
  256.  
  257. /*
  258.     D a t a    S t r u c t u r e s
  259. */
  260.   
  261.  
  262.   declare automatic boolean;
  263.   declare display boolean public;
  264.  
  265.   declare nmb$sect address;
  266.  
  267.   declare link address at (.memory);
  268.  
  269.   declare bios$atts(3) address public;
  270.   declare res$atts(3) address public;
  271.   declare bnk$atts(3) address public;
  272.  
  273.   declare res$bios$len byte public;
  274.   declare res$base byte public;
  275.   declare pg$dif byte public;
  276.   declare xmove$implemented boolean public;
  277.   declare os$top address;
  278.  
  279.   declare system$data (256) byte;
  280.  
  281.   declare common$len byte public at (.system$data(1));
  282.   declare banked$len byte public at (.system$data(3));
  283.   declare sys$entry address public at (.system$data(4));
  284.  
  285.   declare prt$msg$ptr byte;
  286.  
  287.   declare dont$hash boolean;
  288.  
  289.   declare wordadr address;
  290.   declare word based wordadr address;
  291.  
  292.   declare len byte;
  293.   declare off address;
  294.   declare res$flg byte;
  295.   declare save$mem$top byte;
  296.  
  297.   declare drvtbl$adr address public;
  298.   declare drvtbl based drvtbl$adr (16) address;
  299.  
  300.   declare dph$adr address public;
  301.   declare dph based dph$adr structure (
  302.     xlt         address,
  303.     scratch1(4) address,
  304.     scratch2    byte,
  305.     mf          byte,
  306.     dpb         address,
  307.     csv         address,
  308.     alv         address,
  309.     dirbcb      address,
  310.     dtabcb      address,
  311.     hash        address,
  312.     hbank       byte);
  313.  
  314.   declare dpb$adr address public;
  315.   declare dpb based dpb$adr structure (
  316.     spt         address,
  317.     bsh         byte,
  318.     blm         byte,
  319.     exm         byte,
  320.     dsm         address,
  321.     drm         address,
  322.     al0         byte,
  323.     al1         byte,
  324.     cks         address,
  325.     off         address,
  326.     psh         byte,
  327.     phm         byte);
  328.  
  329.   declare bnk$swt boolean external;
  330.   declare dbl$alv boolean external;
  331.   declare mem$top byte external;
  332.   declare bnk$top byte external;
  333.   declare lerror boolean external;
  334.   declare bdrive byte external;
  335.   declare con$wid byte external;
  336.   declare con$pag byte external;
  337.   declare bck$spc boolean external;
  338.   declare rubout boolean external;
  339.   declare prt$msg boolean external;
  340.   declare hash(16) boolean external;
  341.   declare num$seg byte external;
  342.   declare crdatf boolean external;
  343.  
  344.   declare mem$tbl (17) structure(
  345.     base        byte,
  346.     len         byte,
  347.     bank        byte,
  348.     attr        address) external;
  349.  
  350.   declare record(16) structure(
  351.     size        address,
  352.     attr        byte,
  353.     altbnks     byte,
  354.     no$dirrecs  byte,
  355.     no$dtarecs  byte,
  356.     ovlydir$dr  byte,
  357.     ovlydta$dr  byte,
  358.     dir$resp    byte,
  359.     dta$resp    byte) external;
  360.  
  361.   declare quest(157) boolean external;
  362.  
  363.   declare hash$data(16) address public;
  364.   declare hash$space address public;
  365.   declare alloc(16) address public;
  366.   declare alloc$space address public;
  367.   declare chk(16) address public;
  368.   declare chk$space address public;
  369.  
  370. /*
  371.       L o c a l    P r o c e d u r e s
  372. */
  373.  
  374.   movef:
  375.     procedure (count,source$adr,dest$adr) public;
  376.       declare count byte;
  377.       declare (source$adr,dest$adr) address;
  378.  
  379.       if count = 0
  380.       then return;
  381.       else call move (count,source$adr,dest$adr);
  382.  
  383.     end movef;
  384.  
  385.   shift$left:
  386.     procedure (pattern, count) address public;
  387.       declare count byte;
  388.       declare pattern address;
  389.  
  390.       if count = 0
  391.       then return pattern;
  392.       else return shl(pattern,count);
  393.  
  394.    end shift$left;
  395.  
  396.   upper:
  397.     procedure(b) byte public;
  398.       declare b byte;
  399.   
  400.       if b < ' ' then return cr; /* all non-graphics */
  401.       /* translate alpha to upper case */
  402.       if b >= 'a' and b <= 'z' then
  403.         b = b and 101$1111b; /* upper case */
  404.       return b;
  405.     end upper;
  406.  
  407.   valid$drive:
  408.     procedure(drv) boolean public;
  409.       declare drv byte;
  410.       if (drv >= 0) and (drv <= 15) then
  411.         return true;
  412.       call error(false,0,.('Invalid drive.$'));
  413.       return false;
  414.     end valid$drive;
  415.  
  416.   get$response:
  417.     procedure (val$adr) public;
  418.       declare val$adr address;
  419.       declare val based val$adr byte;
  420.       call write$console ('(');
  421.       if val = 0ffh
  422.         then call write$console ('Y');
  423.         else call write$console ('N');
  424.       call print$console$buffer (.(') ? ','$'));
  425.       call read$console$buffer (.lnbfr);
  426.       if lnbfr(1) = 0 
  427.         then return;  /* accept default */
  428.       val = (upper(lnbfr(2)) = 'Y');
  429.     end get$response;
  430.  
  431.   dsply$hex:
  432.     procedure (val) public;
  433.       declare val byte;
  434.       call write$console (hexASCII(shr (val,4)));
  435.       call write$console (hexASCII(val and 0fh));
  436.     end dsply$hex;
  437.  
  438.   dsply$hex$adr:
  439.     procedure (val) public;
  440.       declare val address;
  441.       call write$console (' ');
  442.       call dsply$hex (high (val));
  443.       call dsply$hex (low (val));
  444.       call write$console ('H');
  445.     end dsply$hex$adr;
  446.  
  447.   dsply$hex$high$adr:
  448.     procedure (val) public;
  449.       declare val byte;
  450.       call dsply$hex$adr (double (val)*256);
  451.     end dsply$hex$high$adr;
  452.  
  453.   dsply$dec$adr:
  454.     procedure (val) public;
  455.       declare val address;
  456.       declare big address;
  457.       declare (digit,i) byte;
  458.       declare pdigit boolean;
  459.  
  460.       pdigit = false;
  461.       digit = '0';
  462.       big = 10000;
  463.       if val = 0 then
  464.         call write$console(digit);
  465.       else
  466.         do;
  467.           do i = 0 to 4;
  468.             do while val >= big;
  469.               pdigit = true;
  470.               digit = digit + 1;
  471.               val = val - big;
  472.             end;
  473.             if pdigit then
  474.               do;
  475.                 call write$console(digit);
  476.                 digit = '0';
  477.               end;
  478.             big = big / 10;
  479.           end;
  480.         end;
  481.     end dsply$dec$adr;
  482.     
  483.   dsply$param:
  484.     procedure (val,base) public;
  485.       declare (val,base) byte;
  486.       call write$console ('(');
  487.       if base = 10 then
  488.       do;
  489.         call write$console ('#');
  490.         call dsply$dec$adr(double(val));
  491.       end;
  492.       else
  493.       do;
  494.         call dsply$hex (val);
  495.       end;
  496.       call print$console$buffer (.(') ? ','$'));
  497.     end dsply$param;
  498.  
  499.   get$param:
  500.     procedure (string$adr,val$adr,pbase) public;
  501.       declare (string$adr,val$adr) address;
  502.       declare pbase byte;
  503.       declare base byte;
  504.       declare val based val$adr byte;
  505.       declare string based string$adr (1) byte;
  506.       declare char byte;
  507.       declare lbindx byte;
  508.  
  509.       prompt$read:
  510.         procedure;
  511.           call print$console$buffer (string$adr);
  512.           if string(0) = ' ' then
  513.           do;
  514.             call write$console ('(');
  515.             call dsply$hex (val);
  516.             do lbindx = 1 to 2;
  517.               val$adr = val$adr + 1;
  518.               if (lbindx=2) and (not bnk$swt) then
  519.               do;
  520.                 val = 0;
  521.               end;
  522.               else
  523.               do;
  524.                 call write$console (',');
  525.                 call dsply$hex (val);
  526.               end;
  527.             end;
  528.             val$adr = val$adr - 2;
  529.             call print$console$buffer (.(') ? ','$'));
  530.           end;
  531.           else
  532.           do;
  533.             call dsply$param (val,pbase);
  534.           end;
  535.           base = 16;
  536.           lbindx = 1;
  537.           call read$console$buffer (.lnbfr);
  538.         end prompt$read;
  539.  
  540.       call prompt$read;
  541.       if lnbfr(1) = 0 then
  542.       do;
  543.         /* accept default value */
  544.         call crlf;
  545.         return;
  546.       end;
  547.       val = 0;
  548.       do while (char := upper(lnbfr(lbindx:=lbindx+1))) <> cr;
  549.         if char = ',' then
  550.         do;
  551.           val$adr = val$adr + 1;
  552.           val = 0;
  553.           base = 16;
  554.         end;
  555.         else
  556.         do;
  557.           if char = '#' then
  558.           do;
  559.             base = 10;
  560.           end;
  561.           else
  562.           do;
  563.             char = char - '0';
  564.             if (base = 16) and (char > 9) then
  565.             do;
  566.               if char > 16
  567.                 then char = char - 7;
  568.                 else char = 255;
  569.             end;
  570.             if char < base then
  571.             do;
  572.               val = val*base + char;
  573.             end;
  574.             else
  575.             do;
  576.               char,
  577.               val = 0;
  578.               call error (false,0,.(
  579.                 'Bad character, re-enter $'));
  580.               call prompt$read;
  581.               val = 0;
  582.             end;
  583.           end;
  584.         end;
  585.       end;
  586.       call crlf;
  587.     end get$param;
  588.  
  589.   get$seg:
  590.     procedure(type,record$size) byte public;
  591.  
  592.       declare (type,k,seg$no) byte;
  593.       declare (record$size,max$attr) address;
  594.   
  595.       if not bnk$swt then
  596.         return 0;
  597.  
  598.       seg$no = 0ffh;
  599.       max$attr = 0ffffh;
  600.       do k = 1 to num$seg;
  601.         if mem$tbl(k).attr >= record$size then
  602.           if type = 1 then
  603.             do;
  604.               if (mem$tbl(k).bank = 0) and
  605.                    (mem$tbl(k).attr < max$attr) then
  606.                 do;
  607.                   seg$no = k;
  608.                   max$attr = mem$tbl(k).attr;
  609.                 end;
  610.             end;
  611.           else
  612.             do;
  613.               if (mem$tbl(k).bank <> 0) and
  614.                    (mem$tbl(k).attr < max$attr) then
  615.                 do;
  616.                   seg$no = k;
  617.                   max$attr = mem$tbl(k).attr;
  618.                 end;
  619.             end;
  620.       end;
  621.       if (seg$no = 0ffh) and (type = 2) then
  622.         do k = 1 to num$seg;
  623.           if (mem$tbl(k).attr >= record$size) and
  624.              (mem$tbl(k).bank = 0)            and
  625.              (mem$tbl(k).attr < max$attr)     then
  626.             do;
  627.                seg$no = k;
  628.                max$attr = mem$tbl(k).attr;
  629.              end;
  630.         end;
  631.       return seg$no;
  632.  
  633.     end get$seg;
  634.      
  635. plm: 
  636.   procedure public;
  637.  
  638.   st$ascii$hex:
  639.     procedure(string$adr,val);
  640.      declare string$adr address;
  641.      declare string based string$adr (6) byte;
  642.      declare val address;
  643.      declare i byte;
  644.      string(0) = ' ';
  645.      string(1) = ' ';
  646.      string(2) = hexASCII(shr(high(val),4));
  647.      string(3) = hexASCII(high(val) and 0fh);
  648.      string(4) = hexASCII(shr(low(val),4));
  649.      string(5) = hexASCII(low(val) and 0fh);
  650.    end st$ascii$hex;
  651.  
  652.   setup$scb:
  653.     procedure;
  654.       declare scb$adr address;
  655.       declare scb$dat based scb$adr (100) byte;
  656.  
  657.       scb$adr = .memory + shl(double(scb$pg-res$pg),8) + 09ch;
  658.  
  659.       scb$dat(13h) = bdrive;
  660.       scb$dat(1ah) = con$wid;
  661.       scb$dat(1ch) = con$pag;
  662.       scb$dat(2eh) = bck$spc;
  663.       scb$dat(2fh) = rubout;
  664.       call movef(5,.(012h,07h,0,0,0),.scb$dat(58h)); /* December 15, 1982 */
  665.       if not lerror then
  666.         scb$dat(57h) = scb$dat(57h) and 7fh;
  667.       if not dbl$alv and not bnk$swt then
  668.         scb$dat(57h) = scb$dat(57h) or 0100$0000B;
  669.       else
  670.         scb$dat(57h) = scb$dat(57h) and 1011$1111B;
  671.       scb$dat(5eh) = bnk$top;
  672.       
  673.     end setup$scb;
  674.  
  675.   get$drvtbl$adr:
  676.     procedure address;
  677.       declare temp$adr address;
  678.       declare temp2 based temp$adr address;
  679.       declare temp3 address;
  680.  
  681.       temp$adr = .memory(43h);
  682.       temp3 = temp2 + 1 + .memory;
  683.       temp$adr = temp3;
  684.       if temp2 = 0fffeh
  685.       then res$flg = 2;
  686.       else res$flg = 0;
  687.       if temp2 < 0fffeh
  688.       then return temp2 + .memory;
  689.       else return 0ffffh;
  690.     end get$drvtbl$adr;
  691.  
  692.   page$chop:
  693.     procedure;
  694.       declare i byte;
  695.  
  696.       drvtbl$adr = get$drvtbl$adr;
  697.  
  698.       dont$hash = true;
  699.       if (drvtbl$adr <> 0ffffh) then
  700.         do;
  701.           do i = 0 to 15;
  702.             if drvtbl(i) <> 0 then
  703.               do;
  704.                 dph$adr = drvtbl(i) + .memory;
  705.                 if dph.hash <> 0ffffh then
  706.                   dont$hash = false;
  707.               end;
  708.           end;
  709.           if dont$hash and not bnk$swt then
  710.             res$flg = 2;
  711.           else
  712.             res$flg = 0;
  713.         end;
  714.  
  715.     end page$chop;
  716.  
  717.   get$xmove:
  718.     procedure boolean;
  719.       declare xmove$adr address;
  720.       declare xmove$val based xmove$adr byte;
  721.  
  722.       call movef(2,.memory(58h),.xmove$adr);
  723.       xmove$adr = xmove$adr + .memory;
  724.       if xmove$val = 0c9h /* ret instr. */ then
  725.         return false;
  726.       else
  727.         return true;
  728.     end get$xmove;
  729.  
  730.   display$layout:
  731.     procedure(string$adr,base,length);
  732.       declare string$adr address;
  733.       declare base address;
  734.       declare length byte;
  735.  
  736.       call print$console$buffer (.(cr,lf,' ','$'));
  737.       call print$console$buffer (string$adr);
  738.       call write$console(' ');
  739.       call dsply$hex$adr (base);
  740.       call write$console(' ');
  741.       call dsply$hex$high$adr (length);
  742.       if prt$msg then
  743.        do;
  744.          call movef(12,string$adr,.system$data(prt$msg$ptr));
  745.          prt$msg$ptr = prt$msg$ptr + 12;
  746.          call st$ascii$hex(.system$data(prt$msg$ptr),base);
  747.          prt$msg$ptr = prt$msg$ptr + 6;
  748.          call st$ascii$hex(.system$data(prt$msg$ptr),
  749.                             double(length)*256);
  750.          prt$msg$ptr = prt$msg$ptr + 6;
  751.          call movef(3,.(cr,lf,' '),.system$data(prt$msg$ptr));
  752.          prt$msg$ptr = prt$msg$ptr + 3;
  753.        end;
  754.    end display$layout;
  755.  
  756.   reloc$module:
  757.     procedure (fcb$adr);
  758.       declare fcb$adr address;
  759.       FCBin = fcb$adr;
  760.       if relfix <> 0 then
  761.       do;
  762.         call error(true,1,.('Disk read error:  $'));
  763.       end;
  764.       call close$file(fcb$adr);
  765.     end reloc$module;
  766.  
  767.   load:
  768.     procedure (fcb$adr,atts$adr);
  769.       declare fcb$adr address;
  770.       declare atts$adr address;
  771.       declare atts based atts$adr (3) address;
  772.       declare (i,rdcnt) byte;
  773.  
  774.       prgsiz = atts(0);
  775.       bufsiz = atts(1);
  776.       codsiz = atts(2);
  777.       call movef(8,fcb$adr+1,.fcb$msg);
  778.       call movef(3,fcb$adr+9,.fcb$msg+9);
  779.       if shr(prgsiz+255,7) > nmb$sect then
  780.       do;
  781.         call error(true,1,.('File cannot fit into GENCPM buffer:  ','$'));
  782.       end;
  783.       rdcnt = low(shr(prgsiz-1,7)) + 1;
  784.       i = 0;
  785.       do while (i < rdcnt);
  786.         call set$dma$address(dma:=.sctbfr(i));
  787.         call read$record(fcb$adr);
  788.         i = i + 1;
  789.       end;
  790.       call movef(128,dma,.bitmap);  /* copy the last sector read, into */
  791.                                     /* the bitmap buffer, relocation   */
  792.                                     /* info might be that last sector  */
  793.       dma = prgsiz + .memory;
  794.   end load;
  795.  
  796.   wrtbuf:
  797.     procedure (wrtlen,wrtoff$adr);
  798.       declare (i,wrtlen,wrtcnt) byte;
  799.       declare wrtoff$adr address;
  800.       declare wrtoff based wrtoff$adr address;
  801.       if wrtlen <> 0 then
  802.         do;
  803.            call movef(8,.FCBout+1,.fcb$msg);
  804.            call movef(3,.FCBout+9,.fcb$msg+9);
  805.            FCBout(33) = low(wrtoff);
  806.            FCBout(34) = high(wrtoff);
  807.            call write$random$record(.FCBout);
  808.            dma = dma + low(256 - low(dma - .memory));
  809.            wrtcnt = wrtlen * 2 - 1;
  810.            do i = 0 to wrtcnt;
  811.              call set$dma$address(dma:=dma-80h);
  812.              call write$record(.FCBout);
  813.            end;
  814.            call set$random$record(.FCBout);
  815.            call movef(2,.FCBout(33),wrtoff$adr);
  816.         end;
  817.     end wrtbuf;
  818.  
  819.   get$file$info:
  820.     procedure;
  821.       declare fcb$adr address;
  822.       declare atts$adr address; 
  823.       declare file$atts based atts$adr(3) address;
  824.       declare header$record structure (
  825.         fill1 byte,  
  826.         psize address,
  827.         fill2 byte,
  828.         dsize address,
  829.         fill3 (4) byte,
  830.         csize address,
  831.         fill4 (116) byte) at (.memory);
  832.  
  833.  
  834.     get$atts:
  835.       procedure;
  836.         call movef(8,fcb$adr+1,.fcb$msg);
  837.         call movef(3,fcb$adr+9,.fcb$msg+9);
  838.         if open$file(fcb$adr) = 0ffh
  839.         then call error(true,1,.('Unable to open:  $'));
  840.         call set$dma$address(.header$record);
  841.         call read$record(fcb$adr);
  842.         file$atts(0) = header$record.psize;
  843.         file$atts(1) = header$record.dsize;
  844.         file$atts(2) = header$record.csize;
  845.         call read$record(fcb$adr);
  846.       end get$atts;
  847.  
  848.     if not bnk$swt then
  849.       do;
  850.         call movef(8,.('BDOS3   '),.res$fcb+1);
  851.         call movef(8,.('BIOS3   '),.bios$fcb+1);
  852.       end;
  853.     else 
  854.       do;
  855.          fcb$adr = .bnk$fcb;
  856.          atts$adr = .bnk$atts;
  857.          call get$atts;
  858.       end;
  859.     fcb$adr = .bios$fcb;
  860.     atts$adr = .bios$atts;
  861.     call get$atts;
  862.     fcb$adr = .res$fcb;
  863.     atts$adr = .res$atts;
  864.     call get$atts;
  865.   end get$file$info;
  866.  
  867.   need$tbl:
  868.     procedure byte;
  869.      declare (all$some,i) byte;
  870.  
  871.      all$some = false;
  872.  
  873.      if drvtbl$adr = 0ffffh
  874.      then return false;
  875.      else 
  876.        do i = 0 to 15;
  877.          if drvtbl(i) <> 0 then
  878.            do;
  879.               dph$adr = drvtbl(i) + .memory;
  880.               /* zero the reserved bytes in the DPH */
  881.               call movef(9,.(0,0,0,0,0,0,0,0,0),dph$adr+2);
  882.               if (dph.dirbcb = 0fffeh) or (dph.dtabcb = 0fffeh) or
  883.                  (dph.hash = 0fffeh) or (dph.alv = 0fffeh) or
  884.                  (dph.csv = 0fffeh)
  885.               then all$some = true;
  886.            end;
  887.        end;
  888.      return all$some;
  889.  
  890.   end need$tbl;
  891.  
  892.   setup$hash:
  893.     procedure;
  894.       declare (i,j,printed,seg$no,seg0$no,h$bank,hohash) byte;
  895.       declare (size,h$attr,max$attr,max0$attr) address;
  896.       declare nohash boolean;
  897.  
  898.       printed = false;
  899.       nohash = true;
  900.  
  901.       do i = 0 to 15;
  902.         dph$adr = drvtbl(i) + .memory;
  903.         if drvtbl(i) <> 0 then
  904.           do;
  905.             if dph.hash < 0fffeh then
  906.               nohash = false;
  907.             if dph.hash = 0fffeh then
  908.               do;
  909.                 if not printed then
  910.                   do;
  911.                     printed = true;
  912.                     call print$console$buffer(.
  913.                        (lf,cr,'Setting up directory hash tables:',
  914.                         lf,cr,'$'));
  915.                   end;
  916.                 query = quest(27 + i);
  917.                 dpb$adr = dph.dpb + .memory;
  918.                 size = shl(dpb.drm+1,2);
  919.                 call print$console$buffer(.
  920.                      (' Enable hashing for drive $'));
  921.                 call write$console('A'+i);
  922.                 call print$console$buffer(.(': $'));
  923.                 call get$response(.hash(i));
  924.                 call crlf;
  925.                 if not hash(i) then
  926.                   do;
  927.                     dph.hash = 0ffffh;
  928.                   end;
  929.                 else
  930.                   if not bnk$swt then
  931.                     do;
  932.                       nohash = false;
  933.                       hash$data(i) = size;
  934.                       hash$space = hash$space + size;
  935.                     end;
  936.                   else
  937.                     do;
  938.                       if (seg$no := get$seg(2,size)) = 0ffh then
  939.                         call error(false,0,.(
  940.                               'Unable to allocate space for hash table.$'));
  941.                       else
  942.                         do;
  943.                           dph.hbank = mem$tbl(seg$no).bank;
  944.                           dph.hash = shl(double(mem$tbl(seg$no).base),8) +
  945.                                      (shl(double(mem$tbl(seg$no).len),8) -
  946.                                       mem$tbl(seg$no).attr);
  947.                           mem$tbl(seg$no).attr = mem$tbl(seg$no).attr - size;
  948.                         end;
  949.                     end; 
  950.               end;
  951.           end;
  952.       end;
  953.       if (not bnk$swt) and (nohash) then
  954.        do;
  955.          res$flg = 2;
  956.          scb$pg = scb$pg + 2;
  957.          res$pg = res$pg + 2;
  958.        end;
  959.     end setup$hash;
  960.  
  961.   get$alloc$chk:
  962.     procedure;
  963.       declare (i,dbl$alloc) byte;
  964.       declare printed boolean;
  965.  
  966.       do i = 0 to 15;
  967.         alloc(i) = 0;
  968.         chk(i) = 0;
  969.       end;
  970.  
  971.       if not dbl$alv and not bnk$swt then
  972.         dbl$alloc = 1;
  973.       else
  974.         dbl$alloc = 2;
  975.  
  976.       alloc$space = 0;
  977.       chk$space = 0;
  978.       printed = false;
  979.       do i = 0 to 15;
  980.         if drvtbl(i) <> 0 then
  981.           do;
  982.             dph$adr = drvtbl(i) + .memory;
  983.             dpb$adr = dph.dpb + .memory;
  984.             if dph.alv = 0fffeh then
  985.               do;
  986.                 call print$console$buffer(.(cr,lf,
  987.                      'Setting up Allocation vector for drive $'));
  988.                 call write$console('A'+i);
  989.                 call write$console(':');
  990.                 printed = true;
  991.                 alloc(i) = (dpb.dsm/8 + 1) * dbl$alloc;
  992.                 alloc$space = alloc$space + alloc(i);
  993.               end;
  994.             if dph.csv = 0fffeh then
  995.               do;
  996.                 call print$console$buffer(.(cr,lf,
  997.                      'Setting up Checksum vector for drive $'));
  998.                 call write$console('A'+i);
  999.                 call write$console(':');
  1000.                 printed = true;
  1001.                 chk(i) = (dpb.drm + 4)/4;
  1002.                 chk$space = chk$space + chk(i);
  1003.                 dpb.cks = (dpb.cks and 8000h) or chk(i);
  1004.               end;
  1005.           end;
  1006.       end;
  1007.       if printed then
  1008.         call crlf;
  1009.     end get$alloc$chk;
  1010.  
  1011.   setup$mem$seg$tbl:
  1012.     procedure;
  1013.       declare (i,j,ok,accept,mlow,mhigh,tlow,thigh) byte;
  1014.       declare mem$temp address;
  1015.  
  1016.       /* Create first memory segment table entry */
  1017.       mem$tbl(0).base = bnk$pg;
  1018.       mem$tbl(0).len = bnk$top - bnk$pg;
  1019.       mem$tbl(0).attr = 0;
  1020.       mem$tbl(0).bank = 0;
  1021.  
  1022.       accept = false;
  1023.  
  1024.       call print$console$buffer(
  1025.                  .(lf,cr,
  1026.                   '*** Bank 1 and Common are not included ***',
  1027.                    lf,cr,
  1028.                   '*** in the memory segment table.       ***',
  1029.                    lf,cr,lf,cr,'$'));
  1030.       query = quest(10);
  1031.       call get$param (.('Number of memory segments $'),
  1032.                       .num$seg,10);
  1033.       call print$console$buffer(.(cr,lf,
  1034.               'CP/M 3 Base,size,bank ($'));
  1035.       call dsply$hex(mem$tbl(0).base);
  1036.       call write$console(',');
  1037.       call dsply$hex(mem$tbl(0).len);
  1038.       call write$console(',');
  1039.       call dsply$hex(mem$tbl(0).bank);
  1040.       call print$console$buffer(.(')',lf,cr,'$'));
  1041.  
  1042.       do while not accept;  
  1043.         /* Bank switched memory segment table input */
  1044.         call print$console$buffer (.(cr,lf,
  1045.               'Enter memory segment table:',lf,cr,'$'));
  1046.         do j = 1 to num$seg;
  1047.           ok = false;
  1048.           do while not ok;
  1049.             query = quest(11 + j - 1);
  1050.             call get$param (.(' Base,size,bank ','$'),
  1051.                             .mem$tbl(j),16);
  1052.             mem$tbl(j).attr = shl(double(mem$tbl(j).len),8);
  1053.             if mem$tbl(j).len = 0 then
  1054.               do;
  1055.                  call error(false,0,.(
  1056.                       'Zero length segment not allowed.$'));
  1057.               end;
  1058.             else
  1059.               if mem$tbl(j).bank = 1 then
  1060.                 do;
  1061.                   call error(false,0,.(
  1062.                        'Bank one not allowed.$'));
  1063.                 end;
  1064.               else
  1065.                 do;
  1066.                   tlow = mem$tbl(j).base;
  1067.                   mem$temp = double(tlow) + double(mem$tbl(j).len);
  1068.                   if (high(mem$temp) <> 0) or (low(mem$temp) > bnk$top) then
  1069.                     do;
  1070.                        call print$console$buffer(.(cr,lf,'ERROR:  ',
  1071.                                'Memory conflict - segment trimmed.',
  1072.                                 cr,lf,'$'));
  1073.                        mem$tbl(j).len = bnk$top - tlow;
  1074.                        mem$tbl(j).attr = shl(double(bnk$top - tlow),8);
  1075.                     end;
  1076.                   else
  1077.                     do;
  1078.                       thigh = low(mem$temp);
  1079.                       i = 0;
  1080.                       ok = true;
  1081.                       do while ((i < j) and ok);
  1082.                         mlow = mem$tbl(i).base;
  1083.                         mhigh = mlow + mem$tbl(i).len;
  1084.                         if mem$tbl(i).bank = mem$tbl(j).bank then
  1085.                           do;
  1086.                             if (mhigh >= thigh) and (tlow >= mlow) then
  1087.                               do;
  1088.                                 call error(false,0,.(
  1089.                                      'Memory conflict - cannot trim segment.$'));
  1090.                                 ok = false;
  1091.                               end;
  1092.                             else
  1093.                               if ((thigh > mhigh) and (mhigh > tlow)) then
  1094.                                 do;
  1095.                                   call print$console$buffer(.(cr,lf,'ERROR:  ',
  1096.                                        'Memory conflict - segment trimmed.',
  1097.                                         cr,lf,'$'));
  1098.                                   mem$tbl(j).base = mhigh;
  1099.                                   ok = false;
  1100.                                 end;
  1101.                               else
  1102.                                 if ((thigh > mlow) and (mlow > tlow)) then
  1103.                                   do;
  1104.                                      call print$console$buffer(.(cr,lf,'ERROR:  ',
  1105.                                          'Memory conflict - segment trimmed.',
  1106.                                           cr,lf,'$'));
  1107.                                      mem$tbl(j).len = mlow - tlow;
  1108.                                      mem$tbl(j).attr = shl(double(mlow-tlow),8);
  1109.                                      ok = false;
  1110.                                   end;
  1111.                           end;
  1112.                           i = i + 1;
  1113.                       end;
  1114.                     end;
  1115.                 end;
  1116.           end;
  1117.         end;
  1118.         call crlf;
  1119.         do j = 0 to num$seg;
  1120.           if j = 0 then
  1121.             call print$console$buffer   (.(' CP/M 3 Sys   ','$'));
  1122.           else
  1123.             do;
  1124.               call print$console$buffer (.(' Memseg No. ','$'));
  1125.               call dsply$hex(j-1);
  1126.             end;
  1127.           call dsply$hex$high$adr (mem$tbl(j).base);
  1128.           call dsply$hex$high$adr (mem$tbl(j).len);
  1129.           if bnk$swt then
  1130.             do;
  1131.               call print$console$buffer (.('  Bank ','$'));
  1132.               call dsply$hex (mem$tbl(j).bank);
  1133.             end;
  1134.           call crlf;
  1135.         end;
  1136.         query = false;
  1137.         accept = true;
  1138.         call print$console$buffer (.(cr,lf,
  1139.           'Accept new memory segment table entries ','$'));
  1140.         call get$response (.accept);
  1141.       end; /* do while not accept */
  1142.       call crlf;
  1143.     end setup$mem$seg$tbl;
  1144.  
  1145.   get$default$file:
  1146.     procedure;
  1147.       declare ret byte;
  1148.  
  1149.       call print$console$buffer(.(
  1150.         'Default entries are shown in (parens).',cr,lf,
  1151.         'Default base is Hex, precede entry with # for decimal',
  1152.         cr,lf,'$'));
  1153.       if (ret:=open$file(.data$fcb)) <> 255 then
  1154.         do;
  1155.           call movef(8,.data$fcb+1,.fcb$msg);
  1156.           call movef(3,.data$fcb+9,.fcb$msg+9);
  1157.           call print$console$buffer(.(
  1158.             cr,lf,'Use GENCPM.DAT for defaults $'));
  1159.           ret = 0ffh;
  1160.           call get$response(.ret);
  1161.           call crlf;
  1162.           if ret then
  1163.             call getdef;
  1164.           call close$file(.data$fcb);
  1165.         end;
  1166.       else
  1167.         do;
  1168.           display = true;
  1169.           automatic = false;
  1170.         end;
  1171.  
  1172.     end get$default$file;
  1173.  
  1174.   setup$system$dat:
  1175.     procedure;
  1176.       declare (i,j,ok,temp) byte;
  1177.       ok = false;
  1178.       call get$default$file;
  1179.       do while not ok;
  1180.         query = quest(155);
  1181.         call crlf;
  1182.         call print$console$buffer(.('Create a new GENCPM.DAT file $'));
  1183.         call get$response(.crdatf);
  1184.         query = quest(0);
  1185.         call crlf;
  1186.         call crlf;
  1187.         call print$console$buffer(.('Display Load Map at Cold Boot $'));
  1188.         call get$response(.prt$msg);
  1189.         call crlf;
  1190.         call crlf;
  1191.         query = quest(1);
  1192.         con$wid = con$wid + 1;
  1193.         call get$param (.('Number of console columns $'),
  1194.                         .con$wid,10);
  1195.         con$wid = con$wid - 1;
  1196.         query = quest(2);
  1197.         con$pag = con$pag + 1;
  1198.         call get$param (.('Number of lines in console page $'),
  1199.                         .con$pag,10);
  1200.         con$pag = con$pag - 1;
  1201.         query = quest(3);
  1202.         call print$console$buffer(.
  1203.                    ('Backspace echoes erased character $'));
  1204.         call get$response (.bck$spc);
  1205.         call crlf;
  1206.         query = quest(4);
  1207.         call print$console$buffer(.
  1208.                    ('Rubout echoes erased character $'));
  1209.         call get$response (.rubout);
  1210.         call crlf;
  1211.         call crlf;
  1212.         query = quest(5);
  1213.    err1:
  1214.         call print$console$buffer(.('Initial default drive ($'));
  1215.         call write$console('A'+bdrive);
  1216.         call print$console$buffer(.(':) ? $'));
  1217.         call read$console$buffer(.lnbfr);
  1218.         if lnbfr(1) <> 0 then
  1219.           do;
  1220.             temp = upper(lnbfr(2))-'A';
  1221.             if not valid$drive(temp) then
  1222.               goto err1;
  1223.             bdrive = temp;
  1224.           end;
  1225.         call crlf;
  1226.         call crlf;
  1227.         query = quest(6);
  1228.         call get$param (.('Top page of memory $'),
  1229.                         .mem$top,16);
  1230.         os$top = shl(double(mem$top),8) + 100h;
  1231.         query = quest(7);
  1232.         call print$console$buffer(.('Bank switched memory $'));
  1233.         call get$response (.bnk$swt);
  1234.         call crlf;
  1235.         non$bnk = not bnk$swt;
  1236.         if bnk$swt then
  1237.           do;
  1238.             query = quest(8);
  1239.             call get$param (.('Common memory base page $'),
  1240.                             .bnk$top,16);
  1241.             call crlf;
  1242.             query = quest(9);
  1243.             call print$console$buffer(.('Long error messages $'));
  1244.             call get$response(.lerror);
  1245.             call crlf;
  1246.           end;            
  1247.         else
  1248.           do;
  1249.             query = quest(156);
  1250.             call crlf;
  1251.             call print$console$buffer(.('Double allocation vectors $'));
  1252.             call get$response(.dbl$alv);
  1253.             call crlf;
  1254.             bnk$top = 0;
  1255.           end;
  1256.         query = false;
  1257.         ok = true;
  1258.         call crlf;
  1259.         call print$console$buffer(.('Accept new system definition $'));
  1260.         call get$response(.ok);
  1261.         call crlf;
  1262.       end;
  1263.       save$mem$top = mem$top;
  1264.       mem$top = mem$top + 1;
  1265.       rubout = not rubout;
  1266.     end setup$system$dat;
  1267.  
  1268.   setup$CPM80$sys:
  1269.     procedure;
  1270.     declare i byte;
  1271.       call print$console$buffer (.(  cr,lf,lf,
  1272.         'CP/M 3.0 System Generation',cr,lf,
  1273.         'Copyright (C) 1982, Digital Research',
  1274.         cr,lf,cr,lf,'$'));
  1275.       call delete$file (.fcbout);
  1276.       call create$file (.fcbout);
  1277.       FCBout(32) = 0;
  1278.       do i = 0 to 127;
  1279.         system$data(i) = 0;
  1280.       end;
  1281.       do i = 128 to 255;
  1282.         system$data(i) = '$';
  1283.       end;
  1284.       prt$msg$ptr = 128;
  1285.       call movef(3,.(cr,lf,' '),.system$data(prt$msg$ptr));
  1286.       prt$msg$ptr = 131;
  1287.       call movef(8,.FCBout+1,.fcb$msg);
  1288.       call movef(3,.FCBout+9,.fcb$msg+9);
  1289.       call set$DMA$address (.sctbfr);
  1290.       call write$record (.FCBout);
  1291.       call write$record (.FCBout);
  1292.     end setup$CPM80$sys;
  1293.  
  1294.   initialization:
  1295.     procedure;
  1296.       declare i byte;
  1297.  
  1298.       nmb$sect = shr ((maxb-.sctbfr+1),7);
  1299.  
  1300.       do i = 0 to 15;
  1301.         hash$data(i) = 0;
  1302.       end;
  1303.       hash$space = 0;
  1304.  
  1305.       if fcb(1) = 'A' then
  1306.         do;
  1307.           automatic = true;
  1308.           display = false;
  1309.           do i = 0 to 154;
  1310.             quest(i) = false;
  1311.           end;
  1312.         end;
  1313.       else
  1314.         do;
  1315.          automatic = false;
  1316.          display = true;
  1317.         end;
  1318.       if fcb16(1) = 'D' then
  1319.         do;
  1320.           display = true;
  1321.         end;
  1322.       query = false;
  1323.  
  1324.     end initialization;
  1325.  
  1326.  
  1327. /*
  1328.      G E N C P M    M a i n    P r o g r a m
  1329. */
  1330.  
  1331.   res$flg = 0;
  1332.   display = true;
  1333.   call setup$CPM80$sys;
  1334.   call initialization;
  1335.   call setup$system$dat;
  1336.  
  1337.   call get$file$info;
  1338.  
  1339.   if bios$atts(2) <> 0
  1340.   then res$bios$len = high(bios$atts(2) + 255);
  1341.   else res$bios$len = high(bios$atts(0) + 255);
  1342.   bios$pg = mem$top - res$bios$len;
  1343.   bnk$off = bnk$top - (high(bios$atts(0) + 255) - res$bios$len);
  1344.   bnk$pg = bnk$off - high(bnk$atts(0) + 255);
  1345.  
  1346.   call load(.bios$fcb,.bios$atts);
  1347.  
  1348.   call page$chop;
  1349.  
  1350.  
  1351.   if not bnk$swt then
  1352.     do;
  1353.       scb$pg = bios$pg - (3 - res$flg);
  1354.       res$pg = bios$pg - high(res$atts(0) + 255) + res$flg;
  1355.     end;
  1356.   else
  1357.     do;
  1358.       scb$pg = bios$pg - 1;
  1359.       res$pg = bios$pg - high(res$atts(0) + 255);
  1360.     end;
  1361.  
  1362.   if need$tbl then
  1363.     do;
  1364.       call get$alloc$chk;
  1365.       if bnk$swt then
  1366.         do;
  1367.           bnk$off = bnk$top - (high(bios$atts(0) + alloc$space +
  1368.                                chk$space + 255) - res$bios$len);
  1369.           bnk$pg = bnk$off - high(bnk$atts(0) + 255);
  1370.           xmove$implemented = get$xmove;
  1371.           call setup$mem$seg$tbl;
  1372.           if (not xmove$implemented) then
  1373.             do len = 0 to 15;
  1374.               record(len).altbnks = false;
  1375.             end;
  1376.         end;
  1377.       else
  1378.          xmove$implemented = false;
  1379.       if not dont$hash then
  1380.         call setup$hash;
  1381.       call setbuf;
  1382.     end;
  1383.  
  1384.   res$len = res$bios$len;
  1385.  
  1386.   offset = bios$pg;
  1387.   call reloc$module(.bios$fcb);
  1388.  
  1389.   if bnk$swt
  1390.   then call display$layout(.('BNKBIOS3 SPR$'),
  1391.                            double(bios$pg)*256,res$bios$len);
  1392.   else call display$layout(.('BIOS3    SPR$'),
  1393.                            double(bios$pg)*256,res$bios$len);
  1394.   if not bnk$swt then
  1395.     do;
  1396.        len = res$bios$len;
  1397.        off = 2;
  1398.        call wrtbuf(len,.off);
  1399.        common$len = len;
  1400.        banked$len = 0;
  1401.     end;
  1402.   else
  1403.     do;
  1404.        len = high(bios$atts(0) + 255) - res$bios$len;
  1405.        off = (high(res$atts(0) + 255) + res$bios$len) * 2 + 2;
  1406.        call display$layout(.('BNKBIOS3 SPR$'),double(bnk$off)*256,len);
  1407.        call wrtbuf(len,.off);
  1408.        banked$len = len;
  1409.        len = res$bios$len;
  1410.        off = 2;
  1411.        dma = dma - 80h;
  1412.        call wrtbuf(len,.off);
  1413.        common$len = len;
  1414.     end;
  1415.  
  1416.   res$len = high(res$atts(0) + 255) - res$flg;
  1417.   offset = res$pg;
  1418.   call load(.res$fcb,.res$atts);
  1419.   call reloc$module(.res$fcb);
  1420.   call setup$scb;
  1421.   dma = dma - (res$flg * 256);
  1422.   len = high(res$atts(0) + 255) - res$flg;
  1423.   if not bnk$swt
  1424.   then call display$layout(.('BDOS3    SPR$'),double(res$pg)*256,len);
  1425.   else call display$layout(.('RESBDOS3 SPR$'),double(res$pg)*256,len);
  1426.   call wrtbuf(len,.off);
  1427.   common$len = common$len + len;
  1428.  
  1429.   if bnk$swt then
  1430.   do;
  1431.      res$len = 0ffh;
  1432.      offset = bnk$pg;
  1433.      call load(.bnk$fcb,.bnk$atts);
  1434.      call reloc$module(.bnk$fcb);
  1435.      len = high(bnk$atts(0) + 255);
  1436.      off = off + (high(bios$atts(0) + 255) - res$bios$len) * 2;
  1437.      call display$layout(.('BNKBDOS3 SPR$'),double(bnk$pg)*256,len);
  1438.      call wrtbuf(len,.off);
  1439.      banked$len = banked$len + len;
  1440.   end;
  1441.   if not prt$msg then prt$msg$ptr = prt$msg$ptr - 3;
  1442.   call movef(12,.(lf,cr,' 64K TPA',lf,cr),.system$data(prt$msg$ptr));
  1443.   res$pg = shr(res$pg,2);
  1444.   system$data(prt$msg$ptr+3) = res$pg/10 + '0';
  1445.   system$data(prt$msg$ptr+4) = res$pg mod 10 + '0';
  1446.   prt$msg$ptr = prt$msg$ptr + 12;
  1447.   sys$entry = bios$pg * 256;
  1448.   call movef(36,.('Copyright (C) 1982, Digital Research'),.system$data(10h));
  1449.   call movef(6,.memory,.system$data(35h));  /* Copy Serial No. into header */
  1450.   FCBout(33) = 0; FCBout(34) = 0; FCBout(35) = 0;
  1451.   system$data(0) = mem$top;
  1452.   system$data(2) = bnk$top;
  1453.   call movef(8,.FCBout+1,.fcb$msg);
  1454.   call movef(3,.FCBout+9,.fcb$msg+9);
  1455.   call set$DMA$address(.system$data);
  1456.   call write$random$record(.FCBout);
  1457.   FCBout(33) = 1;
  1458.   call set$DMA$address(.system$data(128));
  1459.   call write$random$record(.FCBout);
  1460.   call close$file(.fcbout);
  1461.  
  1462.   if crdatf then
  1463.     do;                        /* create a new data file for GENCPM */
  1464.       crdatf = false;
  1465.       mem$top = save$mem$top;
  1466.       rubout = not rubout;
  1467.       call movef(8,.data$fcb+1,.fcb$msg);
  1468.       call movef(3,.data$fcb+9,.fcb$msg+9);
  1469.       call crtdef;
  1470.     end;
  1471.  
  1472.   display = true;
  1473.   call print$console$buffer (.(cr,lf,lf,
  1474.     '*** CP/M 3.0 SYSTEM GENERATION DONE ***','$'));
  1475.   return;
  1476.   
  1477.  end plm;
  1478. end gencpm;
  1479.