home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / ENTERPRS / CPM / UTILS / S / TUTOR.ARC / CHAPTER8.PAS < prev   
Pascal/Delphi Source File  |  1992-11-30  |  13KB  |  605 lines
  1.  
  2. {chapter8.pas}
  3.  
  4. {
  5.         copyright (c) 1981
  6.         by:     bell telephone laboratories, inc. and
  7.                 whitesmith's ltd.,
  8.  
  9.         this software is derived from the book
  10.                 "software tools in pascal", by
  11.                 brian w. kernighan and p. j. plauger
  12.                 addison-wesley, 1981
  13.                 isbn 0-201-10342-7
  14.  
  15.         right is hereby granted to freely distribute or duplicate this
  16.         software, providing distribution or duplication is not for profit
  17.         or other commercial gain and that this copyright notice remains
  18.         intact.
  19. }
  20.  
  21. procedure macro;
  22. const
  23.   bufsize=1000;
  24.   maxchars=500;
  25.   maxpos=500;
  26.   callsize=maxpos;
  27.   argsize=maxpos;
  28.   evalsize=maxchars;
  29.   maxdef=maxstr;
  30.   maxtok=maxstr;
  31.   hashsize=53;
  32.   argflag=dollar;
  33. type
  34.   charpos=1..maxchars;
  35.   charbuf=array[1..maxchars]of character;
  36.   posbuf=array[1..maxpos]of charpos;
  37.   pos=0..maxpos;
  38.   sttype=(deftype,mactype,iftype,subtype,
  39.   exprtype,lentype,chqtype);
  40.   ndptr=^ndblock;
  41.   ndblock=record
  42.     name:charpos;
  43.     defn:charpos;
  44.     kind:sttype;
  45.     nextptr:ndptr
  46.    end;
  47.  
  48. var
  49.   buf:array[1..bufsize]of character;
  50.   bp:0..bufsize;
  51.   hashtab:array[1..hashsize]of ndptr;
  52.   ndtable:charbuf;
  53.   nexttab:charpos;
  54.   callstk:posbuf;
  55.   cp:pos;
  56.   typestk:array[1..callsize]of sttype;
  57.   plev:array[1..callsize]of integer;
  58.   argstk:posbuf;
  59.   ap:pos;
  60.   evalstk:charbuf;
  61.   ep:charpos;
  62.   (*builtins*)
  63.   defname:xstring;
  64.   exprname:xstring;
  65.   subname,ifname,lenname,chqname:xstring;
  66.   null:xstring;
  67.   lquote,rquote:character;
  68.   defn,token:xstring;
  69.   toktype:sttype;
  70.   t:character;
  71.   nlpar:integer;
  72. procedure putchr(c:character);
  73. begin
  74.   if(cp<=0) then
  75.     putc(c)
  76.   else begin
  77.     if(ep>evalsize)then
  78.       error('macro:evaluation stack overflow');
  79.     evalstk[ep]:=c;
  80.     ep:=ep+1
  81.   end
  82. end;
  83.  
  84. procedure puttok(var s:xstring);
  85. var
  86.   i:integer;
  87. begin
  88.   i:=1;
  89.   while(s[i]<>endstr) do begin
  90.     putchr(s[i]);
  91.     i:=i+1
  92.   end
  93. end;
  94.  
  95.  
  96. function push(ep:integer;var argstk:posbuf;ap:integer):integer;
  97. begin
  98.   if(ap>argsize)then
  99.     error('macro:argument stack overflow');
  100.   argstk[ap]:=ep;
  101.   push:=ap+1
  102. end;
  103.  
  104. procedure sccopy(var s:xstring;var cb:charbuf;
  105. i:charpos);
  106. var j:integer;
  107. begin
  108.   j:=1;
  109.   while(s[j]<>endstr)do begin
  110.     cb[i]:=s[j];
  111.     j:=j+1;
  112.     i:=i+1
  113.   end;
  114.   cb[i]:=endstr
  115. end;
  116.  
  117. procedure cscopy(var cb:charbuf;i:charpos;
  118.   var s:xstring);
  119. var j:integer;
  120. begin
  121.   j:=1;
  122.   while(cb[i]<>endstr)do begin
  123.     s[j]:=cb[i];
  124.     i:=i+1;
  125.     j:=j+1
  126.   end;
  127.   s[j]:=endstr
  128. end;
  129.  
  130.  
  131. procedure putback(c:character);
  132. begin
  133.   if(bp>=bufsize)then
  134.     writeln('too many characters pushed back');
  135.   bp:=bp+1;
  136.   buf[bp]:=c
  137. end;
  138.  
  139. function getpbc(var c:character):character;
  140. begin
  141.   if(bp>0)then
  142.     c:=buf[bp]
  143.   else begin
  144.     bp:=1;
  145.     buf[bp]:=getc(c)
  146.   end;
  147.   if(c<>endfile)then
  148.     bp:=bp-1;
  149.   getpbc:=c
  150. end;
  151.  
  152. function gettok(var token:xstring;toksize:integer):
  153.   character;
  154. var i:integer;
  155.     done:boolean;
  156. begin
  157.   i:=1;
  158.   done:=false;
  159.   while(not done) and (i<toksize) do
  160.     if(isalphanum(getpbc(token[i]))) then
  161.       i:=i+1
  162.     else
  163.       done:=true;
  164.   if(i>=toksize)then
  165.     writeln('define:token too long');
  166.   if(i>1) then begin (*some alpha was seen*)
  167.     putback(token[i]);
  168.     i:=i-1
  169.   end;
  170.   (*else single non-alphanumeric*)
  171.   token[i+1]:=endstr;
  172.   gettok:=token[1]
  173. end;
  174.  
  175. procedure pbstr (var s:xstring);
  176. var i:integer;
  177. begin
  178.   for i:=xlength(s) downto 1 do
  179.     putback(s[i])
  180. end;
  181.  
  182.  
  183. function hash(var name:xstring):integer;
  184. var
  185.   i,h:integer;
  186. begin
  187.   h:=0;
  188.   for i:=1 to xlength(name) do
  189.     h:=(3*h+name[i]) mod hashsize;
  190.   hash:=h+1
  191. end;
  192.  
  193. function hashfind(var name:xstring):ndptr;
  194. var
  195.   p:ndptr;
  196.   tempname:xstring;
  197.   found:boolean;
  198. begin
  199.   found:=false;
  200.   p:=hashtab[hash(name)];
  201.   while (not found) and (p<>nil) do begin
  202.     cscopy(ndtable,p^.name,tempname);
  203.     if(equal(name,tempname)) then
  204.       found:=true
  205.     else
  206.       p:=p^.nextptr
  207.   end;
  208.   hashfind:=p
  209. end;
  210.  
  211. procedure inithash;
  212. var i:1..hashsize;
  213. begin
  214.   nexttab:=1;
  215.   for i:=1 to hashsize do
  216.     hashtab[i]:=nil
  217. end;
  218.  
  219. function lookup(var name,defn:xstring; var t:sttype)
  220.  :boolean;
  221. var p:ndptr;
  222. begin
  223.   p:=hashfind(name);
  224.   if(p=nil)then
  225.     lookup:=false
  226.   else begin
  227.     lookup:=true;
  228.     cscopy(ndtable,p^.defn,defn);
  229.     t:=p^.kind
  230.   end
  231. end;
  232.  
  233.  
  234. procedure install(var name,defn:xstring;t:sttype);
  235. var
  236.   h,dlen,nlen:integer;
  237.   p:ndptr;
  238. begin
  239.   nlen:=xlength(name)+1;
  240.   dlen:=xlength(defn)+1;
  241.   if(nexttab + nlen +dlen > maxchars) then begin
  242.     putstr(name,stderr);
  243.     error(':too many definitions')
  244.   end
  245.   else begin
  246.     h:=hash(name);
  247.     new(p);
  248.     p^.nextptr:=hashtab[h];
  249.     hashtab[h]:=p;
  250.     p^.name:=nexttab;
  251.     sccopy(name,ndtable,nexttab);
  252.     nexttab:=nexttab+nlen;
  253.     p^.defn:=nexttab;
  254.     sccopy(defn,ndtable,nexttab);
  255.     nexttab:=nexttab+dlen;
  256.     p^.kind:=t
  257.   end
  258. end;
  259.  
  260.  
  261.  
  262. procedure dodef(var argstk:posbuf;i,j:integer);
  263. var
  264.   temp1,temp2 : xstring;
  265. begin
  266.   if(j-i>2) then begin
  267.     cscopy(evalstk,argstk[i+2],temp1);
  268.     cscopy(evalstk,argstk[i+3],temp2);
  269.     install(temp1,temp2,mactype)
  270.   end
  271. end;
  272.   
  273.  
  274. procedure doif(var argstk:posbuf;i,j:integer);
  275. var
  276.   temp1,temp2,temp3:xstring;
  277. begin
  278.   if(j-i>=4) then begin
  279.     cscopy(evalstk,argstk[i+2],temp1);
  280.     cscopy(evalstk,argstk[i+3],temp2);
  281.     if(equal(temp1,temp2))then
  282.       cscopy(evalstk,argstk[i+4],temp3)
  283.     else if (j-i>=5) then
  284.       cscopy(evalstk,argstk[i+5],temp3)
  285.     else
  286.       temp3[i]:=endstr;
  287.     pbstr(temp3)
  288.   end
  289. end;
  290.  
  291. procedure pbnum(n:integer);
  292. var
  293.   temp:xstring;
  294.   junk:integer;
  295. begin
  296.   junk:=itoc(n,temp,1);
  297.   pbstr(temp)
  298. end;
  299. function expr(var s:xstring;var i:integer):integer;forward;
  300.  
  301. procedure doexpr(var argstk:posbuf;i,j:integer);
  302. var
  303.   junk:integer;
  304.   temp:xstring;
  305. begin
  306.   cscopy(evalstk,argstk[i+2],temp);
  307.   junk:=1;
  308.   pbnum(expr(temp,junk))
  309. end;
  310.  
  311. function expr;
  312. var
  313.   v:integer;
  314.   t:character;
  315.   
  316. function gnbchar(var s:xstring;var i:integer):character;
  317. begin
  318.   while(s[i]in[blank,tab,newline])do
  319.     i:=i+1;
  320.   gnbchar:=s[i]
  321. end;
  322.  
  323. function term(var s:xstring;var i:integer):integer;
  324. var
  325.   v:integer;
  326.   t:character;
  327.  
  328. function factor (var s:xstring;var i:integer):
  329.   integer;
  330. begin
  331.   if(gnbchar(s,i)=lparen) then begin
  332.     i:=i+1;
  333.     factor:=expr(s,i);
  334.     if(gnbchar(s,i)=rparen) then
  335.       i:=i+1
  336.     else
  337.       writeln('macro:missing paren in expr')
  338.   end
  339.   else
  340.     factor:=ctoi(s,i)
  341. end;(*factor*)
  342.  
  343. begin(*term*)
  344.   v:=factor(s,i);
  345.   t:=gnbchar(s,i);
  346.   while(t in [star,slash,percent]) do begin
  347.     i:=i+1;
  348.     case t of
  349.       star:v:=v*factor(s,i);
  350.     slash:
  351.       v:=v div factor(s,i);
  352.     percent:
  353.       v:=v mod factor(s,i)
  354.     end;
  355.     t:=gnbchar(s,i)
  356.   end;
  357.   term:=v
  358. end;(*term*)
  359.  
  360. begin(*expr*)
  361.   v:=term(s,i);
  362.   t:=gnbchar(s,i);
  363.   while(t in [plus,minus])do begin
  364.     i:=i+1;
  365.     if(t in [plus]) then
  366.       v:=v+term(s,i)
  367.     else(*minus*)
  368.       v:=v-term(s,i);
  369.     t:=gnbchar(s,i)
  370.   end;
  371.   expr:=v
  372. end;
  373.  
  374. procedure dolen(var argstk:posbuf;i,j:integer);
  375. var
  376.   temp:xstring;
  377. begin
  378.   if(j-i>1)then begin
  379.     cscopy(evalstk,argstk[i+2],temp);
  380.     pbnum(xlength(temp))
  381.   end
  382.   else
  383.     pbnum(0)
  384. end;
  385.   
  386.  
  387. procedure dosub(var argstk:posbuf;i,j:integer);
  388. var
  389.   ap,fc,k,nc:integer;
  390.   temp1,temp2:xstring;
  391. begin
  392.   if(j-i>=3) then begin
  393.     if(j-i<4) then
  394.       nc:=maxtok
  395.     else begin
  396.       cscopy(evalstk,argstk[i+4],temp1);
  397.       k:=1;
  398.       nc:=expr(temp1,k)
  399.     end;
  400.     cscopy(evalstk,argstk[i+3],temp1);
  401.     ap:=argstk[i+2];
  402.     k:=1;
  403.     fc:=ap+expr(temp1,k)-1;
  404.     cscopy(evalstk,ap,temp2);
  405.     if(fc>=ap) and (fc<ap+xlength(temp2)) then begin
  406.       cscopy(evalstk,fc,temp1);
  407.       for k:=fc+min(nc,xlength(temp1))-1 downto fc do
  408.         putback(evalstk[k])
  409.       end
  410.     end
  411.   end;
  412.   
  413.   procedure dochq(var argstk:posbuf;i,j:integer);
  414.   var
  415.     temp:xstring;
  416.     n:integer;
  417.   begin
  418.     cscopy(evalstk,argstk[i+2],temp);
  419.     n:=xlength(temp);
  420.     if(n<=0)then begin
  421.       lquote:=ord(less);
  422.       rquote:=ord(greater)
  423.     end
  424.     else if (n=1) then begin
  425.       lquote:=temp[1];
  426.       rquote:=lquote
  427.     end
  428.     else begin
  429.       lquote:=temp[1];
  430.       rquote:=temp[2]
  431.     end
  432.   end;
  433.   
  434.   
  435. procedure eval(var argstk:posbuf;td:sttype;
  436.   i,j:integer);
  437. var
  438.   argno,k,t:integer;
  439.   temp:xstring;
  440. begin
  441.   t:=argstk[i];
  442.   if(td=deftype)then
  443.     dodef(argstk,i,j)
  444.   else if (td=exprtype)then
  445.     doexpr(argstk,i,j)
  446.   else if (td=subtype) then
  447.     dosub(argstk,i,j)
  448.   else if (td=iftype) then
  449.     doif(argstk,i,j)
  450.   else if (td=lentype) then
  451.     dolen(argstk,i,j)
  452.   else if (td=chqtype) then
  453.     dochq(argstk,i,j)
  454.   else begin
  455.     k:=t;
  456.     while(evalstk[k]<>endstr) do
  457.       k:=k+1;
  458.     k:=k-1;
  459.     while(k>t) do begin
  460.       if(evalstk[k-1] <> argflag) then
  461.         putback(evalstk[k])
  462.       else begin
  463.         argno:=ord(evalstk[k])-ord('0');
  464.         if(argno>=0) and (argno <j-i)then begin
  465.           cscopy(evalstk,argstk[i+argno+1],temp);
  466.           pbstr(temp)
  467.         end;
  468.         k:=k-1
  469.       end;
  470.       k:=k-1
  471.     end;
  472.     if(k=t)then
  473.       putback(evalstk[k])
  474.     end
  475.   end;
  476. procedure initmacro;
  477.   begin
  478.     null[1]:=endstr;
  479.       defname[1]:=ord('d');
  480.       defname[2]:=ord('e');
  481.       defname[3]:=ord('f');
  482.       defname[4]:=ord('i');
  483.       defname[5]:=ord('n');
  484.       defname[6]:=ord('e');
  485.       defname[7]:=endstr;
  486.       subname[1]:=ord('s');
  487.       subname[2]:=ord('u');
  488.       subname[3]:=ord('b');
  489.       subname[4]:=ord('s');
  490.       subname[5]:=ord('t');
  491.       subname[6]:=ord('r');
  492.       subname[7]:=endstr;
  493.       exprname[1]:=ord('e');
  494.       exprname[2]:=ord('x');
  495.       exprname[3]:=ord('p');
  496.       exprname[4]:=ord('r');
  497.       exprname[5]:=endstr;
  498.       ifname[1]:=ord('i');
  499.       ifname[2]:=ord('f');
  500.       ifname[3]:=ord('e');
  501.       ifname[4]:=ord('l');
  502.       ifname[5]:=ord('s');
  503.       ifname[6]:=ord('e');
  504.       ifname[7]:=endstr;
  505.       lenname[1]:=ord('l');
  506.       lenname[2]:=ord('e');
  507.       lenname[3]:=ord('n');
  508.       lenname[4]:=endstr;
  509.       chqname[1]:=ord('c');
  510.       chqname[2]:=ord('h');
  511.       chqname[3]:=ord('a');
  512.       chqname[4]:=ord('n');
  513.       chqname[5]:=ord('g');
  514.       chqname[6]:=ord('e');
  515.       chqname[7]:=ord('q');
  516.       chqname[8]:=endstr;
  517.     bp:=0;
  518.     inithash;
  519.     lquote:=ord('`');
  520.     rquote:=ord('''')
  521.   end;
  522.   
  523.       
  524.  
  525.   
  526. begin
  527.   initmacro;
  528.   install(defname,null,deftype);
  529.   install(exprname,null,exprtype);
  530.   install(subname,null,subtype);
  531.   install(ifname,null,iftype);
  532.   install(lenname,null,lentype);
  533.   install(chqname,null,chqtype);
  534.   
  535.   cp:=0;ap:=1;ep:=1;
  536.   
  537.   while(gettok(token,maxtok)<>endfile)do
  538.     if(isletter(token[1]))then begin
  539.       if(not lookup(token,defn,toktype))then
  540.         puttok(token)
  541.       else begin
  542.         cp:=cp+1;
  543.         if(cp>callsize)then
  544.           error('macro:call stack overflow');
  545.         callstk[cp]:=ap;
  546.         typestk[cp]:=toktype;
  547.         ap:=push(ep,argstk,ap);
  548.         puttok(defn);
  549.         putchr(endstr);
  550.         ap:=push(ep,argstk,ap);
  551.         puttok(token);
  552.         putchr(endstr);
  553.         ap:=push(ep,argstk,ap);
  554.         t:=gettok(token,maxtok);
  555.         pbstr(token);
  556.         if(t<>lparen)then begin
  557.           putback(rparen);
  558.           putback(lparen)
  559.         end;
  560.         plev[cp]:=0
  561.       end
  562.     end
  563.     else if(token[1]=lquote) then begin
  564.       nlpar:=1;
  565.       repeat
  566.         t:=gettok(token,maxtok);
  567.         if(t=rquote)then
  568.           nlpar:=nlpar-1
  569.         else if (t=lquote)then
  570.           nlpar:=nlpar+1
  571.         else if (t=endfile) then
  572.           error('macro:missing right quote');
  573.         if(nlpar>0) then
  574.           puttok(token)
  575.       until(nlpar=0)
  576.     end
  577.     else if (cp=0)then
  578.       puttok(token)
  579.     else if (token[1]=lparen) then begin
  580.       if(plev[cp]>0)then
  581.         puttok(token);
  582.       plev[cp]:=plev[cp]+1
  583.     end
  584.     else if (token[1]=rparen)then begin
  585.       plev[cp]:=plev[cp]-1;
  586.       if(plev[cp]>0)then
  587.         puttok(token)
  588.       else begin
  589.         putchr(endstr);
  590.         eval(argstk,typestk[cp],callstk[cp],ap-1);
  591.         ap:=callstk[cp];
  592.         ep:=argstk[ap];
  593.         cp:=cp-1
  594.       end
  595.     end
  596.     else if (token[1]=comma) and (plev[cp]=1)then begin
  597.       putchr(endstr);
  598.       ap:=push(ep,argstk,ap)
  599.     end
  600.     else
  601.       puttok(token);
  602.   if(cp<>0)then
  603.     error('macro:unexpected end of input')
  604. end;
  605.