Programmer 7500/MAX_PROGRAMMERS.iso/INFO/PASCAL/PT03.ZIP/MACRO.AR

Text File | 1983-09-06 | 20.3 KB | 864 lines

-h- cscopy.mac 247
{ cscopy -- copy cb[i]... to string s }
procedure cscopy (var cb : charbuf; i : charpos;
  var s : string);
var
 j : integer;
begin
 j := 1;
 while (cb[i] <> ENDSTR) do begin
  s[j] := cb[i];
  i := i + 1;
  j := j + 1
 end;
 s[j] := ENDSTR
end;

-h- defcons.mac 268
{ defcons -- const declarations for define }
const
 BUFSIZE = 500;  { size of pushback buffer }
 MAXCHARS = 5000; { size of name-defn table }
 MAXDEF = MAXSTR; { max chars in a defn }
 MAXTOK = MAXSTR; { max chars in a token }
 HASHSIZE = 53;  { size of hash table }

-h- define.mac 764
{ define -- simple string replacement macro processor }
procedure define;
$include:"defcons.p"
$include:"deftype.p"
$include:"defvar.p"
 defn : string;
 token : string;
 toktype : sttype; { type returned by lookup }
 defname : string; { value is 'define' }
 null : string;  { value is '' }
$include:"defproc.p"
begin
 null[1] := ENDSTR;
 initdef;
 install(defname, null, DEFTYPE);
 while (gettok(token, MAXTOK) <> ENDFILE) do
  if (not isletter(token[1])) then
   putstr(token, STDOUT)
  else if (not lookup(token, defn, toktype)) then
   putstr(token, STDOUT) { undefined }
  else if (toktype = DEFTYPE) then begin { defn }
   getdef(token, MAXTOK, defn, MAXDEF);
   install(token, defn, MACTYPE)
  end
  else
   pbstr(defn) { push replacement onto input }
end;

-h- defproc.mac 308
{ defproc -- procedures needed by define }
$include:"cscopy.p"
$include:"sccopy.p"
$include:"putback.p"
$include:"getpbc.p"
$include:"pbstr.p"
$include:"gettok.p"
$include:"getdef.p"
$include:"inithash.p"
$include:"hash.p"
$include:"hashfind.p"
$include:"install.p"
$include:"lookup.p"
$include:"initdef.p"

-h- deftype.mac 346
{ deftype -- type definitions for define }
type
 charpos = 1..MAXCHARS;
 charbuf = array [1..MAXCHARS] of character;
 sttype = (DEFTYPE, MACTYPE); { symbol table types }
 ndptr = ^ndblock; { pointer to a name-defn block }
 ndblock =
  record  { name-defn block }
   name : charpos;
   defn : charpos;
   kind : sttype;
   nextptr : ndptr
  end;

-h- defvar.mac 275
{ defvar -- var declarations for define }
var
 hashtab : array [1..HASHSIZE] of ndptr;
 ndtable : charbuf;
 nexttab : charpos; { first free position in ndtable }
 buf : array [1..BUFSIZE] of character; { for pushback }
 bp : 0..BUFSIZE; { next available character; init=0 }

-h- dochq.mac 402
{ dochq -- change quote characters }
procedure dochq (var argstk : posbuf; i, j : integer);
var
 temp : string;
 n : integer;
begin
 cscopy(evalstk, argstk[i+2], temp);
 n := length(temp);
 if (n <= 0) then begin
  lquote := ord(GRAVE);
  rquote := ord(ACUTE)
 end
 else if (n = 1) then begin
  lquote := temp[1];
  rquote := lquote
 end
 else begin
  lquote := temp[1];
  rquote := temp[2]
 end
end;

-h- dodef.mac 279
{ dodef -- install definition in table }
procedure dodef (var argstk : posbuf; i, j : integer);
var
 temp1, temp2 : string;
begin
 if (j - i > 2) then begin
  cscopy(evalstk, argstk[i+2], temp1);
  cscopy(evalstk, argstk[i+3], temp2);
  install(temp1, temp2, MACTYPE)
 end
end;

-h- doexpr.mac 225
{ doexpr -- evaluate arithmetic expressions }
procedure doexpr (var argstk : posbuf; i, j : integer);
var
 temp : string;
 junk : integer;
begin
 cscopy(evalstk, argstk[i+2], temp);
 junk := 1;
 pbnum(expr(temp, junk))
end;

-h- doif.mac 435
{ doif -- select one of two arguments }
procedure doif (var argstk : posbuf; i, j : integer);
var
 temp1, temp2, temp3 : string;
begin
 if (j - i >= 4) then begin
  cscopy(evalstk, argstk[i+2], temp1);
  cscopy(evalstk, argstk[i+3], temp2);
  if (equal(temp1, temp2)) then
   cscopy(evalstk, argstk[i+4], temp3)
  else if (j - i >= 5) then
   cscopy(evalstk, argstk[i+5], temp3)
  else
   temp3[1] := ENDSTR;
  pbstr(temp3)
 end
end;

-h- dolen.mac 234
{ dolen -- return length of argument }
procedure dolen(var argstk : posbuf; i, j : integer);
var
 temp : string;
begin
 if (j - i > 1) then begin
  cscopy(evalstk, argstk[i+2], temp);
  pbnum(length(temp))
 end
 else
  pbnum(0)
end;

-h- dosub.mac 663
{ dosub -- select substring }
procedure dosub (var argstk : posbuf; i, j : integer);
var
 ap, fc, k, nc : integer;
 temp1, temp2 : string;
begin
 if (j - i >= 3) then begin
  if (j - i < 4) then
   nc := MAXTOK
  else begin
   cscopy(evalstk, argstk[i+4], temp1);
   k := 1;
   nc := expr(temp1, k)
  end;
  cscopy(evalstk, argstk[i+3], temp1); { origin }
  ap := argstk[i+2]; { target string }
  k := 1;
  fc := ap + expr(temp1, k) - 1; { first char }
  cscopy(evalstk, ap, temp2);
  if (fc >= ap) and (fc < ap+length(temp2)) then begin
   cscopy(evalstk, fc, temp1);
   for k := fc+imin(nc,length(temp1))-1 downto fc do
    putback(evalstk[k])
  end
 end
end;

-h- eval.mac 1007
{ eval -- expand args i..j: do built-in or push back defn }
procedure eval (var argstk : posbuf; td : sttype;
  i, j : integer);
var
 argno, k, t : integer;
 temp : string;
begin
 t := argstk[i];
 if (td = DEFTYPE) then
  dodef(argstk, i, j)
 else if (td = EXPRTYPE) then
  doexpr(argstk, i, j)
 else if (td = SUBTYPE) then
  dosub(argstk, i, j)
 else if (td = IFTYPE) then
  doif(argstk, i, j)
 else if (td = LENTYPE) then
  dolen(argstk, i, j)
 else if (td = CHQTYPE) then
  dochq(argstk, i, j)
 else begin
  k := t;
  while (evalstk[k] <> ENDSTR) do
   k := k + 1;
  k := k - 1; { last character of defn }
  while (k > t) do begin
   if (evalstk[k-1] <> ARGFLAG) then
    putback(evalstk[k])
   else begin
    argno := ord(evalstk[k]) - ord('0');
    if (argno >= 0) and (argno < j-i) then begin
     cscopy(evalstk, argstk[i+argno+1], temp);
     pbstr(temp)
    end;
    k := k - 1 { skip over $ }
   end;
   k := k - 1
  end;
  if (k = t) then  { do last character }
   putback(evalstk[k])
 end
end;

-h- expr.mac 402
{ expr -- recursive expression evaluation }
function expr (var s : string; var i : integer) : integer;
var
 v : integer;
 t : character;
{$include:'gnbchar.mac'}
{$include:'term.mac'   }
begin
 v := term(s, i);
 t := gnbchar(s, i);
 while (t in [PLUS, MINUS]) do begin
  i := i + 1;
  if (t = PLUS) then
   v := v + term(s, i)
  else
   v := v - term(s, i);
  t := gnbchar(s, i)
 end;
 expr := v
end;

-h- factor.mac 342
{ factor -- evaluate factor of arithmetic expression }
function factor (var s : string; var i : integer)
   : integer;
begin
 if (gnbchar(s, i) = LPAREN) then begin
  i := i + 1;
  factor := expr(s, i);
  if (gnbchar(s, i) = RPAREN) then
   i := i + 1
  else
   message('macro: missing paren in expr')
 end
 else
  factor := ctoi(s, i)
end;

-h- getdef.mac 1044
{ getdef -- get name and definition }
procedure getdef (var token : string; toksize : integer;
  var defn : string; defsize : integer);
var
 i, nlpar : integer;
 c : character;
begin
 token[1] := ENDSTR; { in case of bad input }
 defn[1] := ENDSTR;
 if (getpbc(c) <> LPAREN) then
  message('define: missing left paren')
 else if (not isletter(gettok(token, toksize))) then
  message('define: non-alphanumeric name')
 else if (getpbc(c) <> COMMA) then
  message('define: missing comma in define')
 else begin { got '(name,' so far }
  while (getpbc(c) = BLANK) do
   ; { skip leading blanks }
  putback(c); { went one too far }
  nlpar := 0;
  i := 1;
  while (nlpar >= 0) do begin
   if (i >= defsize) then
    error('define: definition too long')
   else if (getpbc(defn[i]) = ENDFILE) then
    error('define: missing right paren')
   else if (defn[i] = LPAREN) then
    nlpar := nlpar + 1
   else if (defn[i] = RPAREN) then
    nlpar := nlpar - 1;
   { else normal character in defn[i] }
   i := i + 1
  end;
  defn[i-1] := ENDSTR
 end
end;

-h- getpbc.mac 250
{ getpbc -- get a (possibly pushed back) character }
function getpbc (var c : character) : character;
begin
 if (bp > 0) then
  c := buf[bp]
 else begin
  bp := 1;
  buf[bp] := getc(c)
 end;
 if (c <> ENDFILE) then
  bp := bp - 1;
 getpbc := c
end;

-h- gettok.mac 567
{ gettok -- get token for define }
function gettok (var token : string; toksize : integer)
  : character;
var
 i : integer;
 done : boolean;
 c : character;
begin
 i := 1;
 done := false;
 while (not done) and (i < toksize) do begin
  token[i] := getpbc(c);
  if (isalphanum(c)) then
   i := i + 1
  else
   done := true;
 end;
 if (i >= toksize) then
  error('define: token too long');
 if (i > 1) then begin { some alpha was seen }
  c := token[i];
  putback(c);
  i := i - 1
 end;
 { else single non-alphanumeric }
 token[i+1] := ENDSTR;
 gettok := token[1]
end;

-h- gnbchar.mac 195
{ gnbchar -- get next non-blank character }
function gnbchar (var s : string; var i : integer)
  : character;
begin
 while (s[i] in [BLANK, TAB, NEWLINE]) do
  i := i + 1;
 gnbchar := s[i]
end;

-h- hash.mac 216
{ hash -- compute hash function of a name }
function hash (var name : string) : integer;
var
 i, h : integer;
begin
 h := 0;
 for i := 1 to length(name) do
  h := (3 * h + name[i]) mod HASHSIZE;
 hash := h + 1
end;

-h- hashfind.mac 376
{ hashfind -- find name in hash table }
function hashfind (var name : string) : ndptr;
var
 p : ndptr;
 tempname : string;
 found : boolean;
begin
 found := false;
 p := hashtab[hash(name)];
 while (not found) and (p <> nil) do begin
  cscopy(ndtable, p^.name, tempname);
  if (equal(name, tempname)) then
   found := true
  else
   p := p^.nextptr
 end;
 hashfind := p
end;

-h- initdef.mac 341
{ initdef -- initialize variables for define }
procedure initdef;
begin
 { setstring(defname, 'define'); }
  defname[1] := ord('d');
  defname[2] := ord('e');
  defname[3] := ord('f');
  defname[4] := ord('i');
  defname[5] := ord('n');
  defname[6] := ord('e');
  defname[7] := ENDSTR;
 bp := 0; { pushback buffer pointer }
 inithash
end;

-h- inithash.mac 190
{ inithash -- initialize hash table to nil }
procedure inithash;
var
 i : 1..HASHSIZE;
begin
 nexttab := 1; { first free slot in table }
 for i := 1 to HASHSIZE do
  hashtab[i] := nil
end;

-h- initmacr.mac 1375
{ initmacro -- initialize variables for macro }
procedure initmacro;
begin
 null[1] := ENDSTR;
 { setstring(defname, 'define'); }
  defname[1] := ord('d');
  defname[2] := ord('e');
  defname[3] := ord('f');
  defname[4] := ord('i');
  defname[5] := ord('n');
  defname[6] := ord('e');
  defname[7] := ENDSTR;
 { setstring(subname, 'substr'); }
  subname[1] := ord('s');
  subname[2] := ord('u');
  subname[3] := ord('b');
  subname[4] := ord('s');
  subname[5] := ord('t');
  subname[6] := ord('r');
  subname[7] := ENDSTR;
 { setstring(exprname, 'expr'); }
  exprname[1] := ord('e');
  exprname[2] := ord('x');
  exprname[3] := ord('p');
  exprname[4] := ord('r');
  exprname[5] := ENDSTR;
 { setstring(ifname, 'ifelse'); }
  ifname[1] := ord('i');
  ifname[2] := ord('f');
  ifname[3] := ord('e');
  ifname[4] := ord('l');
  ifname[5] := ord('s');
  ifname[6] := ord('e');
  ifname[7] := ENDSTR;
 { setstring(lenname, 'len'); }
  lenname[1] := ord('l');
  lenname[2] := ord('e');
  lenname[3] := ord('n');
  lenname[4] := ENDSTR;
 { setstring(chqname, 'changeq'); }
  chqname[1] := ord('c');
  chqname[2] := ord('h');
  chqname[3] := ord('a');
  chqname[4] := ord('n');
  chqname[5] := ord('g');
  chqname[6] := ord('e');
  chqname[7] := ord('q');
  chqname[8] := ENDSTR;
 bp := 0; { pushback buffer pointer }
 inithash;
 lquote := ord(GRAVE);
 rquote := ord(ACUTE)
end;

-h- install.mac 656
{ install -- add name, definition and type to table }
procedure install (var name, defn : string; t : sttype);
var
 h, dlen, nlen : integer;
 p : ndptr;
begin
 nlen := length(name) + 1; { 1 for ENDSTR }
 dlen := length(defn) + 1;
 if (nexttab + nlen + dlen > MAXCHARS) then begin
  putstr(name, STDERR);
  error(': too many definitions')
 end
 else begin { put it at front of chain }
  h := hash(name);
  new(p);
  p^.nextptr := hashtab[h];
  hashtab[h] := p;
  p^.name := nexttab;
  sccopy(name, ndtable, nexttab);
  nexttab := nexttab + nlen;
  p^.defn := nexttab;
  sccopy(defn, ndtable, nexttab);
  nexttab := nexttab + dlen;
  p^.kind := t
 end
end;

-h- lookup.mac 298
{ lookup -- locate name, get defn and type from table }
function lookup (var name, defn : string; var t : sttype)
  : boolean;
var
 p : ndptr;
begin
 p := hashfind(name);
 if (p = nil) then
  lookup := false
 else begin
  lookup := true;
  cscopy(ndtable, p^.defn, defn);
  t := p^.kind
 end
end;

-h- maccons.mac 422
{ maccons -- const declarations for macro }
const
 BUFSIZE = 1000;  { size of pushback buffer }
 MAXCHARS = 5000; { size of name-defn table }
 MAXPOS = 500;    { size of position arrays }
 CALLSIZE = MAXPOS;
 ARGSIZE = MAXPOS;
 EVALSIZE = MAXCHARS;
 MAXDEF = MAXSTR; { max chars in a defn }
 MAXTOK = MAXSTR; { max chars in a token }
 HASHSIZE = 53;  { size of hash table }
 ARGFLAG = DOLLAR; { macro invocation character }

-h- macproc.mac 661
{ macproc -- procedures for macro }
{$include:'cscopy.mac'  }
{$include:'sccopy.mac'  }
{$include:'putback.mac' }
{$include:'getpbc.mac'  }
{$include:'pbstr.mac'   }
{$include:'pbnum.mac'   }
{$include:'gettok.mac'  }
{$include:'inithash.mac'}
{$include:'hash.mac'    }
{$include:'hashfind.mac'}
{$include:'install.mac' }
{$include:'lookup.mac'  }
{$include:'push.mac'    }
{$include:'putchr.mac'  }
{$include:'puttok.mac'  }
{$include:'expr.mac'    }
{$include:'dodef.mac'   }
{$include:'doif.mac'    }
{$include:'doexpr.mac'  }
{$include:'dolen.mac'   }
{$include:'dochq.mac'   }
{$include:'dosub.mac'   }
{$include:'eval.mac'    }
{$include:'initmacr.mac'}

-h- macro.mac 2335
{ macro -- expand macros with arguments }
procedure macro;
{$include:'maccons.mac'}
{$include:'mactype.mac'}
{$include:'macvar.mac' }
 defn : string;
 token : string;
 toktype : sttype;
 t : character;
 nlpar : integer;
{$include:'macproc.mac'}
begin
 initmacro;
 install(defname, null, DEFTYPE);
 install(exprname, null, EXPRTYPE);
 install(subname, null, SUBTYPE);
 install(ifname, null, IFTYPE);
 install(lenname, null, LENTYPE);
 install(chqname, null, CHQTYPE);

 cp := 0;
 ap := 1;
 ep := 1;
 while (gettok(token, MAXTOK) <> ENDFILE) do
  if (isletter(token[1])) then begin
   if (not lookup(token, defn, toktype)) then
    puttok(token)
   else begin { defined; put it in eval stack }
    cp := cp + 1;
    if (cp > CALLSIZE) then
     error('macro: call stack overflow');
    callstk[cp] := ap;
    typestk[cp] := toktype;
    ap := push(ep, argstk, ap);
    puttok(defn); { push definition }
    putchr(ENDSTR);
    ap := push(ep, argstk, ap);
    puttok(token); { stack name }
    putchr(ENDSTR);
    ap := push(ep, argstk, ap);
    t := gettok(token, MAXTOK); { peek at next }
    pbstr(token);
    if (t <> LPAREN) then begin { add () }
     putback(RPAREN);
     putback(LPAREN)
    end;
    plev[cp] := 0
   end
  end
  else if (token[1] = lquote) then begin { strip quotes }
   nlpar := 1;
   repeat
    t := gettok(token, MAXTOK);
    if (t = rquote) then
     nlpar := nlpar - 1
    else if (t = lquote) then
     nlpar := nlpar + 1
    else if (t = ENDFILE) then
     error('macro: missing right quote');
    if (nlpar > 0) then
     puttok(token)
   until (nlpar = 0)
  end
  else if (cp = 0) then  { not in a macro at all }
   puttok(token)
  else if (token[1] = LPAREN) then begin
   if (plev[cp] > 0) then
    puttok(token);
   plev[cp] := plev[cp] + 1
  end
  else if (token[1] = RPAREN) then begin
   plev[cp] := plev[cp] - 1;
   if (plev[cp] > 0) then
    puttok(token)
   else begin { end of argument list }
    putchr(ENDSTR);
    eval(argstk, typestk[cp], callstk[cp], ap-1);
    ap := callstk[cp]; { pop eval stack }
    ep := argstk[ap];
    cp := cp - 1
   end
  end
  else if (token[1]=COMMA) and (plev[cp]=1) then begin
   putchr(ENDSTR); { new argument }
   ap := push(ep, argstk, ap)
  end
  else
   puttok(token); { just stack it }
 if (cp <> 0) then
  error('macro: unexpected end of input')
end;

-h- mactype.mac 397
{ mactype -- type declarations for macro }
type
 charpos = 1..MAXCHARS;
 charbuf = array [1..MAXCHARS] of character;
 posbuf = array [1..MAXPOS] of charpos;
 pos = 0..MAXPOS;
 sttype = (DEFTYPE, MACTYPE, IFTYPE, SUBTYPE,
  EXPRTYPE, LENTYPE, CHQTYPE); { symbol table types }
 ndptr = ^ndblock;
 ndblock =
  record
   name : charpos;
   defn : charpos;
   kind : sttype;
   nextptr : ndptr
  end;

-h- macvar.mac 1035
{ macvar -- var declarations for macro }
var
 buf : array [1..BUFSIZE] of character; { for pushback }
 bp : 0..BUFSIZE; { next available character; init=0 }

 hashtab : array [1..HASHSIZE] of ndptr;
 ndtable : charbuf;
 nexttab : charpos; { first free position in ndtable }

 callstk : posbuf; { call stack }
 cp : pos;   { current call stack position }
 typestk : array[1..CALLSIZE] of sttype; { type }
 plev : array [1..CALLSIZE] of integer; { paren level }
 argstk : posbuf; { argument stack for this call }
 ap : pos;   { current argument position }
 evalstk : charbuf; { evaluation stack }
 ep : charpos;    { first character unused in evalstk }

 { built-ins: }
 defname : string; { value is 'define' }
 exprname : string; { value is 'expr' }
 subname : string; { value is 'substr' }
 ifname : string; { value is 'ifelse' }
 lenname : string; { value is 'len' }
 chqname : string; { value is 'changeq' }

 null : string;  { value is '' }
 lquote : character; { left quote character }
 rquote : character; { right quote character }

-h- pbnum.mac 178
{ pbnum -- convert number to string, push back on input }
procedure pbnum (n : integer);
var
 temp : string;
 junk : integer;
begin
 junk := itoc(n, temp, 1);
 pbstr(temp)
end;

-h- pbstr.mac 153
{ pbstr -- push string back onto input }
procedure pbstr (var s : string);
var
 i : integer;
begin
 for i := length(s) downto 1 do
  putback(s[i])
end;

-h- push.mac 247
{ push -- push ep onto argstk, return new position ap }
function push (ep : integer; var argstk : posbuf;
  ap : integer) : integer;
begin
 if (ap > ARGSIZE) then
  error('macro: argument stack overflow');
 argstk[ap] := ep;
 push := ap + 1
end;

-h- putback.mac 191
{ putback -- push character back onto input }
procedure putback (c : character);
begin
 if (bp >= BUFSIZE) then
  error('too many characters pushed back');
 bp := bp + 1;
 buf[bp] := c
end;

-h- putchr.mac 259
{ putchr -- put single char on output or evaluation stack }
procedure putchr (c : character);
begin
 if (cp <= 0) then
  putc(c)
 else begin
  if (ep > EVALSIZE) then
   error('macro: evaluation stack overflow');
  evalstk[ep] := c;
  ep := ep + 1
 end
end;

-h- puttok.mac 195
{ puttok -- put token on output or evaluation stack }
procedure puttok (var s : string);
var
 i : integer;
begin
 i := 1;
 while (s[i] <> ENDSTR) do begin
  putchr(s[i]);
  i := i + 1
 end
end;

-h- sccopy.mac 247
{ sccopy -- copy string s to cb[i]... }
procedure sccopy (var s : string; var cb : charbuf;
  i : charpos);
var
 j : integer;
begin
 j := 1;
 while (s[j] <> ENDSTR) do begin
  cb[i] := s[j];
  j := j + 1;
  i := i + 1
 end;
 cb[i] := ENDSTR
end;

-h- term.mac 446
{ term -- evaluate term of arithmetic expression }
function term (var s : string; var i : integer) : integer;
var
 v : integer;
 t : character;
{$include:'factor.mac'}
begin
 v := factor(s, i);
 t := gnbchar(s, i);
 while (t in [STAR, SLASH, PERCENT]) do begin
  i := i + 1;
  case t of
  STAR:
   v := v * factor(s, i);
  SLASH:
   v := v div factor(s, i);
  PERCENT:
   v := v mod factor(s, i)
  end;
  t := gnbchar(s, i)
 end;
 term := v
end;
-h- macro.pas 533
{$debug-}
program outer (input,output);

{$include:'globcons.inc'}
{$include:'globtyps.inc'}

{$include:'initio.dcl'}
{$include:'flush.dcl' }

{$include:'isletter.dcl'}
{$include:'isalphan.dcl'}
{$include:'error.dcl'   }
{$include:'getc.dcl'    }
{$include:'putc.dcl'    }
{$include:'putstr.dcl'  }
{$include:'imin.dcl'    }
{$include:'itoc.dcl'    }
{$include:'ctoi.dcl'    }
{$include:'length.dcl'  }
{$include:'equal.dcl'   }
{$include:'message.dcl' }

{$include:'macro.mac'   }
BEGIN
  minitio; initio;
  macro;
  flush(0);
END.
-h- macro.mak 119
macro+initio+getfcb+flush+error+isletter+isalphan+getc+
length+itoc+ctoi+equal+message+putstr+imin+putc+putcf+
isdigit