home *** CD-ROM | disk | FTP | other *** search
/ Frostbyte's 1980s DOS Shareware Collection / floppyshareware.zip / floppyshareware / USCX / STEVEUT.ZIP / EDIT-MOD.PAS < prev    next >
Pascal/Delphi Source File  |  1984-05-19  |  21KB  |  614 lines

  1. {  $LIST+, $DEBUG+, $BRAVE+, $LINESIZE:132, $PAGESIZE:77, $OCODE+   }
  2. {  $NILCK+, $MATHCK+, $RANGECK+, $INITCK+, $INDEXCK+, $ENTRY+    }
  3. {  $LINE+, $RUNTIME+, $SYMTAB+, $WARN+, $GOTO+     }
  4. {  $TITLE:'EDITOR MODULE:  MODULE.PAS  - AEM$SCRATCH ' }
  5. {  $MESSAGE:'PASCAL - COMPILATION OPTIONS SET'     }
  6. {  $MESSAGE:'SYSTEM - COMPILATION BEGINS'          }
  7. {  $message:'PASCAL - MODULE COMPILATION LINKAGE SET' }
  8.  
  9. MODULE SUPPLEMENTAL_COMMANDS;
  10.  
  11.  
  12. const
  13.    charspernode    = 34;
  14.    debug   = true;
  15.    maxcharp1   = 201;
  16.    maxchars    = 200;
  17.    maxcommandlength    = 7;
  18.    numberlongcommands  =17;
  19.    numbershortcommands =18;
  20.    off = false;
  21.    on  = true;
  22.  
  23. type
  24.    linecharptr  =   ^linecharnode;
  25.    lineptr     =   ^lineptrnode;
  26.    lineptrnode =   record
  27.        length  :   0 .. maxchars;
  28.        nextline:   lineptr;
  29.        previousline    :   lineptr;
  30.        firstnode   : linecharptr
  31.    end;    {   record   }
  32.    linecharnode    =   record
  33.        nextnode    : linecharptr;
  34.        chars       : packed array [ 1 .. charspernode] of char
  35.    end;  { record  }
  36.    linelengthdef   = 0 .. maxchars;
  37.    linedef = record
  38.        length  : linelengthdef;
  39.        position : 0 .. maxcharp1;
  40.        chars   : array [ 1 .. maxcharp1] of char
  41.    end;   { record  }
  42.    messagetype = lstring (30);
  43.    commanddef  = record
  44.        length  : linelengthdef;
  45.        position: 0 .. maxcharp1;
  46.        chars   : packed array [ 1 .. maxcommandlength] of char
  47.    end;   { record  }
  48.    stringdef   = record
  49.        first   : 0 .. maxcharp1;
  50.        last    : linelengthdef;
  51.        length  : linelengthdef
  52.    end;
  53.    commandtable    = record
  54.        shortcommands : array [ 1 .. numbershortcommands ] of char;
  55.        longcommands  : array [ 1 .. numberlongcommands ] of
  56.                            packed array [ 1 .. maxcommandlength ] of char
  57.    end;   { record  }
  58.  
  59.  
  60.  
  61. var  [extern]
  62.    edfile : text;
  63.    currentline : lineptr;
  64.  
  65.  
  66. function min ( x, y : integer) : integer; 
  67. begin
  68.    if x < y then min := x else min := y
  69. end;   { function  }
  70.  
  71. procedure readline (var line : linedef);  
  72. begin
  73.    with line do
  74.        begin
  75.            length := 0;
  76.            while not eoln (edfile) do
  77.                begin
  78.                    length := length + 1;
  79.                    read (edfile, chars[length])
  80.                end  { eoln  }
  81.        end;   { with }
  82.    readln (edfile)
  83. end;   { procedure   }
  84.  
  85. procedure insertline (currentline, newline : lineptr); 
  86. begin
  87.    newline^.nextline := currentline^.nextline;
  88.    newline^.previousline := currentline;
  89.    newline^.nextline^.previousline := newline;
  90.    currentline^.nextline := newline
  91. end;   { insertline  }
  92.  
  93. procedure packline (line : linedef; packedline : lineptr);    
  94.  
  95. var
  96.    charnum : 1 .. charspernode;
  97.    charspacked : integer;
  98.    node, oldnode : linecharptr;
  99.  
  100. begin
  101.    packedline^.length := line.length;
  102.    if line.length <> 0 then
  103.        begin
  104.            new (node);
  105.            packedline^.firstnode := node;
  106.            for charnum := 1 to min (line.length,charspernode) do
  107.                node^.chars [charnum] := line.chars [charnum];
  108.            charspacked := charspernode;
  109.            while charspacked < line.length do
  110.                begin
  111.                    oldnode := node;
  112.                    new (node);
  113.                    oldnode^.nextnode := node;
  114.                    for charnum := 1 to min (line.length-charspacked,charspernode) do
  115.                        node^.chars [charnum] := line.chars [charspacked+charnum];
  116.                    charspacked := charspacked+charspernode
  117.                end;  { while  }
  118.            node^.nextnode := nil
  119.        end
  120.  else
  121.        packedline^.firstnode := nil
  122. end;  { procedure packline  }
  123.  
  124. procedure readfile (var currentline, sentinel : lineptr);    
  125.  
  126. var
  127.    line    : linedef;   { scratch buffer  }
  128.    newline : lineptr;   { new line to insert }
  129.  
  130. begin
  131.    reset (edfile);
  132.    new(currentline);
  133.    sentinel := currentline;
  134.    with sentinel^ do
  135.        begin
  136.            length := 0;
  137.            previousline := currentline;
  138.            nextline := currentline;
  139.            firstnode := nil
  140.        end;
  141.    while not eof (edfile) do
  142.        begin
  143.            readline (line);
  144.            new (newline);
  145.            insertline (currentline,newline);
  146.            currentline := newline;
  147.            packline (line,currentline)
  148.        end  { while  }
  149. end;    { procedure  }
  150.  
  151. procedure errormessage (var noerror : boolean; message : messagetype); 
  152. begin
  153.    writeln ('*** ',message);
  154.    noerror := false
  155. end;   {  error handler  }
  156.  
  157. procedure checkempty (sentinel : lineptr; var noerror : boolean);  
  158. begin
  159.    if noerror and (sentinel^.nextline = sentinel) then
  160.        errormessage (noerror, 'EDIT FILE EMPTY')
  161. end;   {   check empty }
  162.  
  163. procedure removetrailingblanks (var line : linedef);   
  164. var
  165.    done : boolean;
  166.  index : integer;
  167.  
  168. begin
  169.    with line do
  170.        begin
  171.            done := false;
  172.            index := 1;
  173.            while not done and (index <= length) do
  174.                if chars[index] <> ' ' then
  175.                        index := index + 1
  176.                else
  177.                    done := true;
  178.            if done then
  179.                  length := index;
  180.            position := 1;
  181.            chars[length+1] := ' ';
  182.            if (length = 0) then length := 1
  183.        end    { with  }
  184. end;   {  procedure  }
  185.  
  186. procedure readcommand (prompt : char; var line : linedef);    
  187. begin
  188.    with line do
  189.        begin
  190.            write (prompt,' ');
  191.            length := 0;    { assume null command on input  }
  192.            while not eoln do
  193.                begin
  194.                    length := length + 1;
  195.                    read (chars [length])
  196.                end;
  197.             if prompt = '>' then
  198.                 removetrailingblanks (line)     { skip proc call }
  199.    end;                                         { if inserting lines }
  200.     readln;
  201.     writeln
  202. end;   { procedure  }
  203.  
  204. procedure skipblanks (var line : linedef);   
  205. begin
  206.    with line do
  207.        begin
  208.            while (position <= length) and (chars [position] = ' ') do
  209.                position := position + 1
  210.    end  { while }
  211. end;  { procedure  }
  212.  
  213. procedure movelinepointer (var currentline : lineptr; linestomove : integer;
  214.                            sentinel : lineptr; var noerror : boolean); 
  215.  
  216. var
  217.    bottomoffile,topoffile : lineptr;
  218. begin
  219.    checkempty (sentinel, noerror);
  220.    if noerror then
  221.        begin
  222.            topoffile := sentinel^.nextline;
  223.            bottomoffile := sentinel^.previousline;
  224.            while ((currentline <> topoffile) and (linestomove < 0)) or
  225.                ((currentline <> bottomoffile) and (linestomove > 0)) do
  226.                begin
  227.                    if linestomove < 0 then
  228.                        begin
  229.                            linestomove := linestomove +1 ;
  230.                            currentline := currentline^.previousline
  231.                        end
  232.                    else
  233.                        begin
  234.                            linestomove := linestomove - 1 ;
  235.                            currentline := currentline^.nextline
  236.                        end
  237.                end; { while  }
  238.            if linestomove <> 0 then
  239.                if linestomove > 0 then
  240.                    errormessage (noerror, 'END OF INPUT FILE')
  241.                else
  242.                    errormessage (noerror, 'TOP OF INPUT FILE')
  243.        end
  244. end;   { procedure }
  245.  
  246. function numeric ( ch : char) : boolean;  
  247. begin
  248.    numeric := (ch >= '0') and (ch <= '9')
  249. end;   { function }
  250.  
  251. procedure getnumber (var line : linedef; var number : integer;
  252.                  var legalnumber : boolean);     
  253. var
  254.    sign : integer;
  255. begin
  256.    number := 0;
  257.    legalnumber := false;
  258.    skipblanks (line);
  259.    with line do
  260.        begin
  261.            if position <= length then
  262.                begin
  263.                    if chars [position] = '!' then
  264.                        begin
  265.                            position := position + 1;
  266.                            number := maxint;
  267.                            legalnumber := true
  268.                        end
  269.                     else
  270.                        begin
  271.                            sign := 1;
  272.                            if chars [position] = '-' then
  273.                                begin
  274.                                    sign := -1;
  275.                                    position := position + 1
  276.                                end
  277.                            else
  278.                                if chars [position] = '+' then
  279.                                    begin
  280.                                        sign := 1;
  281.                                        position := position + 1
  282.                                    end;
  283.                            while (position <= length) and numeric(chars[position]) do
  284.                                begin
  285.                                    number := 10*number+ord(chars[position])-ord('0');
  286.                                    position := position + 1;
  287.                                    legalnumber := true
  288.                                end;
  289.                            number := sign * number
  290.                        end
  291.                end
  292.        end
  293. end;   { procedure  }
  294.  
  295. procedure processprefix (var commandline : linedef; var currentline : lineptr;
  296.                      sentinel : lineptr; var noerror : boolean); 
  297. var
  298.    bottomoffile, topoffile : lineptr;
  299.    stillprefix,legalnumber : boolean;
  300.  number : integer;
  301. begin
  302.    bottomoffile := sentinel^.previousline;
  303.    topoffile := sentinel^.nextline;
  304.    skipblanks (commandline);
  305.    with commandline do
  306.        begin
  307.            if (position <= length) and (chars[position] <>'=') then
  308.                begin
  309.                    stillprefix := true;
  310.                    while (position <= length) and stillprefix and noerror do
  311.                        begin
  312.                            if chars [position] = '!' then
  313.                                begin
  314.                                    currentline := bottomoffile;
  315.                                    checkempty (sentinel,noerror)
  316.                                end
  317.                            else
  318.                                if (chars[position]='+') or (chars[position]='-') then
  319.                                    begin
  320.                                        getnumber(commandline,number,legalnumber);
  321.                                        if legalnumber then
  322.                                            movelinepointer(currentline,number,sentinel,noerror)
  323.                                    else
  324.                                            errormessage (noerror,'ILLEGAL SYMBOL IN PREFIX');
  325.                                        stillprefix := false
  326.                                    end
  327.                                else
  328.                                    if chars[position]='^' then
  329.                                        begin
  330.                                            checkempty(sentinel,noerror);
  331.                                            currentline := topoffile
  332.                                        end
  333.                                    else
  334.                                    if (chars[position] <> ' ') then stillprefix := false;
  335.                                if stillprefix then position := position + 1
  336.                        end
  337.                end
  338.        end
  339. end;  { procedure }
  340.  
  341. function alphabetic (ch : char) : boolean;  
  342. begin
  343.    alphabetic := (ch >= 'a') and (ch <= 'z')
  344. end;  { function }
  345.  
  346. procedure getcommand(var commandline : linedef; var command : commanddef;
  347.                      var legalcommand, noerror : boolean); 
  348. var
  349.    commandchar : integer;
  350. begin
  351.    command.length := 0;
  352.  skipblanks (commandline);
  353.    legalcommand := true;
  354.    for commandchar := 1  to maxcommandlength do
  355.            command.chars[commandchar] := ' ';
  356.    with commandline do
  357.        begin
  358.        if position > length then
  359.        begin
  360.            legalcommand := true;
  361.            command.chars [1] := 'p';  { assume null, print command }
  362.            command.length := 1
  363.        end
  364.        else
  365.            if not (alphabetic(chars[position]) or  numeric(chars[position])) then
  366.                begin
  367.                    legalcommand := true;
  368.                    command.chars[1] := 'f';   { assume delimiter, find command }
  369.                    command.length := 1
  370.            end
  371.        else if chars[position] = '=' then
  372.                begin  { process equals command  }
  373.                    legalcommand := true;
  374.                    command.chars[1] := '=';
  375.                    command.length := 1;
  376.                    position := position + 1
  377.                end
  378.            else   {  build a normal command, other than default  }
  379.                begin
  380.                    while alphabetic(chars[position]) and (position <= length) and noerror do
  381.                        begin
  382.                            if command.length < maxcommandlength then
  383.                                begin
  384.                                    command.length := command.length + 1;
  385.                                    command.chars[command.length] := chars[position];
  386.                                    position := position + 1;
  387.                                    legalcommand := true
  388.                                end
  389.                            else  { bad input line }
  390.                                errormessage (noerror, 'NO SUCH COMMAND')
  391.                    end  { while  }
  392.                end
  393.        end { with  }
  394. end;   { procedure  }
  395.  
  396. procedure commandordinal (command : commanddef; var ordinal : integer;
  397.                       var tablecommands : commandtable; var noerror : boolean); 
  398. var
  399.    index : integer;
  400. begin
  401.    index := 1;
  402.    if command.length = 1 then
  403.        begin
  404.            tablecommands.shortcommands[numbershortcommands] := command.chars[1];
  405.            while command.chars[1] <> tablecommands.shortcommands[index] do
  406.                    index := index + 1;
  407.            if index = numbershortcommands then
  408.                errormessage (noerror, 'NO SUCH COMMAND')
  409.        end
  410.    else
  411.        begin
  412.            tablecommands.longcommands[numberlongcommands] := command.chars;
  413.            while command.chars <> tablecommands.longcommands[index] do
  414.                index := index + 1;
  415.            if index = numberlongcommands then
  416.                errormessage (noerror, 'NO SUCH COMMAND')
  417.        end;  { if  }
  418.    ordinal := index
  419. end;   {  procedure  }
  420.  
  421. procedure endparse (commandline : linedef; var noerror : boolean); 
  422. begin
  423.    if noerror then
  424.    begin
  425.            skipblanks (commandline);
  426.            if commandline.position <= commandline.length then
  427.                errormessage (noerror, 'INVALID COMMAND PARAMETER')
  428.    end  { if }
  429. end;   { procedure  }
  430.  
  431. procedure getstring (var commandline : linedef; var strng : stringdef;
  432.                      var legalstring : boolean); 
  433. var
  434.    delimiter : char;
  435. begin
  436.    skipblanks (commandline);
  437.    legalstring := false;
  438.    strng.length := 0;
  439.    with commandline do
  440.        if position <= length then begin
  441.        begin
  442.            if (not alphabetic(chars[position])) and (not numeric(chars[position])) and
  443.                 (chars[position] <> '+') and (chars[position] <> '-') and (chars[position] <> '!') then
  444.                begin
  445.                    delimiter := chars[position];
  446.                    legalstring := true;
  447.                    position := position + 1;
  448.                    strng.first := position;
  449.                    while (chars[position] <> delimiter) and (position <= length) do
  450.                        position := position +1 ;
  451.                    strng.last := position -1;
  452.                    strng.length := strng.last - strng.first + 1
  453.                end
  454.        end
  455.    end; {  if position }
  456.    if strng.length = 0 then
  457.        begin
  458.            strng.first := 1;
  459.            strng.last := 0
  460.        end
  461. end;  { procedure  }
  462.  
  463. procedure unpackline(var line : linedef; pline : lineptr);
  464. var
  465.    charnum : 1 .. charspernode;
  466.    node    : linecharptr;
  467.    unpackcount : integer;
  468.  
  469. begin
  470.    with line do
  471.        begin
  472.            length := pline^.length;
  473.            if length <> 0 then
  474.                begin
  475.                    node := pline^.firstnode;
  476.                    unpackcount := 0;
  477.                    repeat
  478.                        for charnum := 1 to min(charspernode,length-unpackcount) do
  479.                            chars[unpackcount+charnum] := node^.chars[charnum];
  480.                        unpackcount := unpackcount + charspernode;
  481.                        node := node^.nextnode
  482.                    until node = nil
  483.                end  { if  }
  484.        end  { with  }
  485. end;  { procedure }
  486.  
  487. procedure stringin(var line : linedef; strng : stringdef;
  488.                    var commandline : linedef; var found : boolean);   
  489. var
  490.    done,stringthere : boolean;  index : integer;
  491. begin
  492.    line.position := 0;
  493.    if strng.length = 0 then stringthere := true
  494.    else
  495.        begin
  496.            with line do
  497.                begin
  498.                    stringthere := false;
  499.                    done := false;
  500.                    chars[length+1] := commandline.chars[strng.first];
  501.                    repeat
  502.                        position := position + 1;
  503.                        if (position+strng.length-1) > length then
  504.                            begin
  505.                                done := true
  506.                            end
  507.                        else
  508.                            begin
  509.                                stringthere := true;
  510.                                index := strng.first;
  511.                                while stringthere and (index <= strng.last) do
  512.                                    begin
  513.                                        if commandline.chars[index] <> line.chars[line.position+index-strng.first] then
  514.                                            stringthere := false
  515.                                        else index := index + 1
  516.                                    end
  517.                            end
  518.                    until done or stringthere
  519.                end  { with  }
  520.        end; { if }
  521.    found := stringthere
  522. end;  { procedure  }
  523.  
  524. procedure locate (strng : stringdef; var pline : lineptr;
  525.               var count :integer; increment : integer; sentinel : lineptr;
  526.                    var commandline : linedef; var noerror : boolean);  
  527. var
  528.    found : boolean;    scratchline : linedef;
  529. begin
  530.    found := false;
  531.    count := increment;
  532.    repeat
  533.        movelinepointer(pline,increment,sentinel,noerror);
  534.        count := count + increment;
  535.        if noerror then
  536.            begin
  537.                unpackline(scratchline,pline);
  538.                stringin(scratchline,strng,commandline,found)
  539.            end
  540.    until found or (not noerror)
  541. end;  { procedure  }
  542.  
  543. procedure getparameter(var commandline : linedef; sentinel : lineptr;
  544.                        var count : integer; var noerror : boolean);  
  545. var
  546.    legalnumber, legalstring : boolean;
  547.    sign : integer;   pline : lineptr;  strng : stringdef;
  548. begin
  549.    with commandline do
  550.        begin
  551.            if position <= length then
  552.                begin
  553.                    if chars[position]='-' then
  554.                        begin
  555.                            sign := -1;
  556.                        position := position + 1
  557.                        end
  558.                    else sign := 1;
  559.                    getstring(commandline,strng,legalstring);
  560.                    if legalstring then
  561.                        begin
  562.                            position := position + 1;
  563.                            pline := currentline;
  564.                            locate(strng,pline,count,sign,sentinel,commandline,noerror)
  565.                        end
  566.                    else
  567.                        begin
  568.                            getnumber(commandline,count,legalnumber);
  569.                            if legalnumber then count := count*sign else count := sign
  570.                        end
  571.                end
  572.            else count := 1
  573.    end
  574. end;  { procedure }
  575.  
  576. procedure printline(line : linedef); 
  577. var charnum : linelengthdef;
  578. begin
  579.    for charnum := 1 to line.length do write (line.chars[charnum]);
  580.  writeln
  581. end;
  582.  
  583. procedure printpackedline (pline : lineptr); 
  584. var
  585.    index : linelengthdef;    scratchline : linedef;
  586. begin
  587.    unpackline(scratchline,pline);
  588.  printline (scratchline)
  589. end;
  590.  
  591. procedure freetext (pline : lineptr);  
  592. var
  593.    node, nodegone : linecharptr;
  594. begin
  595.    node := pline^.firstnode;
  596.    pline^.length := 0;
  597.    pline^.firstnode := nil;
  598.    while node <> nil do
  599.        begin
  600.            nodegone := node;
  601.            node := nodegone^.nextnode;
  602.            dispose (nodegone)
  603.        end  { while }
  604. end;  { proc  }
  605.  
  606. procedure deleteline (pline : lineptr); 
  607. begin
  608.    pline^.previousline^.nextline := pline^.nextline;
  609.    pline^.nextline^.previousline := pline^.previousline;
  610.    freetext (pline);
  611.    dispose (pline)
  612. end;  { delete  }
  613. end.  { module  }
  614.