-- file Macro.mesa
-- last edited by Satterthwaite,  9-Mar-82 14:18:58

DIRECTORY
  Ascii: TYPE USING [CR, SP, TAB],
  DCSFileTypes: TYPE USING [tLeaderPage],
  Directory: TYPE USING [CreateFile, Error, Lookup, UpdateDates, ignore],
  Exec: TYPE USING [AddCommand, commandLine, w],
  File: TYPE USING [Capability, Permissions, delete, grow, read, shrink, write],
  FileStream: TYPE USING [Create, EndOf],
  Heap: TYPE USING [systemMDSZone],
  Stream: TYPE USING [Handle, Delete, GetChar, PutChar],
  TTY: TYPE USING [Handle, GetLine, LineOverflow, PutChar, Rubout];

Macro: PROGRAM
    IMPORTS Directory, Exec, FileStream, Heap, Stream, TTY = {

 -- characters and strings
 
  MAXCHAR: NAT = LAST[CHARACTER] - 0c;
  MAXSTR: NAT = 100;
  
  character: TYPE = [-1..MAXCHAR];
  string: TYPE = --PACKED-- ARRAY [1..MAXSTR] OF character;
  
  ENDFILE:   character = -1;
  ENDSTR:    character =  0;
  BACKSPACE: character =  9;
  TAB:       character =  9;
  NEWLINE:   character = 13;
  BLANK:     character = 32;
  ESCAPE:    character = ord['@];
  
 -- file descriptors and io-related stuff
 
  MAXOPEN: NAT = 10;
  
  filedesc: TYPE = [0..MAXOPEN];
  
  IOERROR: filedesc = 0;
  STDIN:   filedesc = 1;
  STDOUT:  filedesc = 2;
  STDERR:  filedesc = 3;
  
  IOREAD:  INTEGER = 1;
  IOWRITE: INTEGER = 2;
  IOBOTH:  INTEGER = 3;  
  

-- standard (Pascal) procedures
   
  ord: PROC [c: CHARACTER] RETURNS [character] = INLINE {RETURN [c - 0c]};
  chr: PROC [c: character] RETURNS [CHARACTER] = INLINE {RETURN [c + 0c]};
  
  
-- storage primitives

  zone: MDSZone;	-- for NEW
  
-- file primitives
   
  tty: TTY.Handle;
 
  kbdline: STRING _ [MAXSTR];
  kbdx: CARDINAL;
  kbdend: BOOLEAN;
  
  
  readkbd: PROC = {
    IF (kbdend) THEN
      kbdline.length _ 0
    ELSE {
      ENABLE {
	TTY.LineOverflow => {
	  putcf[NEWLINE, STDERR];
	  message["*** line too long"L];
	  putcf[NEWLINE, STDERR];
	  RETRY};
	TTY.Rubout => {
	  IF (kbdline.length) > 0 THEN
	    RESUME
	  ELSE {
	    kbdend _ TRUE;
	    CONTINUE}}};
      IF (kbdline.length > 0)
       AND (kbdline[kbdline.length-1] = Ascii.CR) THEN
        kbdline.length _ kbdline.length - 1;	-- for ESC
      tty.GetLine[kbdline];
      IF kbdline.length >= kbdline.maxlength THEN
        [] _ ERROR TTY.LineOverflow[kbdline];
      kbdline[kbdline.length] _ Ascii.CR;
      kbdline.length _ kbdline.length + 1};
    kbdx _ 0};
	   
    
    
  filerec: TYPE = RECORD [
    type: {none, stream, tty} _ none,
    handle: Stream.Handle _ NIL];
    
  filetab: ARRAY filedesc OF filerec;
  
  accessmap: PROC [mode: INTEGER] RETURNS [File.Permissions] = {
    RETURN [SELECT mode FROM
      IOREAD => File.read,
      IOWRITE => File.write + File.grow + File.shrink + File.delete,
      IOBOTH => File.read + File.write + File.grow + File.shrink + File.delete,
      ENDCASE => File.read]};
    
  fdalloc: PROC RETURNS [fd: filedesc] = {
    -- find a free slot in filetab
    FOR fd IN (STDERR .. MAXOPEN] DO
      IF (filetab[fd].type = none) THEN EXIT
      REPEAT
        FINISHED => fd _ IOERROR; 
      ENDLOOP;
    RETURN};
  
  fileerror: ERROR = CODE;
  
  findfile: PROC [name: STRING, access: File.Permissions]
      RETURNS [File.Capability] = {
    cap: File.Capability;
    old: BOOLEAN _ (access = File.read);
    IF ~old THEN { 
      cap _ Directory.CreateFile[name, DCSFileTypes.tLeaderPage, 0
	      ! Directory.Error => {
		 IF type = fileAlreadyExists THEN GOTO fileExists 
		 ELSE GO TO fileProblem}];
      EXITS
        fileExists => old _ TRUE};
    IF old THEN
       cap _ Directory.Lookup[fileName: name, permissions: Directory.ignore
	! Directory.Error => {GO TO fileProblem}];
    RETURN [Directory.UpdateDates[cap, access]]
    EXITS
      fileProblem => ERROR fileerror};
  
  makestream: PROC [name: POINTER TO string, mode: INTEGER, fd: filedesc] = {
    i: INTEGER _ 0;
    intname: STRING _ [MAXSTR];
    WHILE (name[i+1] # ENDSTR) DO
      intname[i] _ chr[name[i+1]];
      i _ i + 1;
      ENDLOOP;
    intname.length _ i;
    filetab[fd] _ [
	type: stream,
	handle: FileStream.Create[findfile[intname, accessmap[mode]]]]};
  

  open: PROC [name: POINTER TO string, mode: INTEGER] RETURNS [fd: filedesc] = {
    fd _ fdalloc[];
    IF fd # IOERROR THEN {
      makestream[name, mode, fd ! fileerror => {GOTO fail}];
      EXITS fail => {filetab[fd] _ [type: none]; fd _ IOERROR}};
    RETURN};

  create: PROC [name: POINTER TO string, mode: INTEGER] RETURNS [filedesc] = open;
    -- check positioning of files opened for output
    
  close: PROC [fd: filedesc] = {
    SELECT filetab[fd].type FROM
      stream => {
        h: Stream.Handle = filetab[fd].handle;
	Stream.Delete[h]};
      tty => NULL;
      ENDCASE => NULL;
    filetab[fd] _ [type: none]};

  remove: PROC [s: POINTER TO string] = {
    -- this version just prints a message
    message["If we had remove, we would be deleting "L];
    putcf[TAB, STDERR];
    putstr[s, STDERR];
    putcf[NEWLINE, STDERR]};

  getc: PROC [c: POINTER TO character] RETURNS [character] = INLINE {
    RETURN [getcf[c, STDIN]]};

  getcf: PROC [c: POINTER TO character, fd: filedesc] RETURNS [character] = {
    SELECT filetab[fd].type FROM
      stream => {
        h: Stream.Handle = filetab[fd].handle;
	c^ _ IF FileStream.EndOf[h] THEN ENDFILE ELSE ord[h.GetChar[]]};
      tty =>
        IF (kbdx < kbdline.length) THEN {
	  c^ _ ord[kbdline[kbdx]];
	  kbdx _ kbdx + 1}
	ELSE {
	  readkbd[];
	  IF (kbdline.length = 0) THEN	-- iff kbdend
	    c^ _ ENDFILE
	  ELSE {
	    c^ _ ord[kbdline[kbdx]];
	    kbdx _ kbdx + 1}};
      ENDCASE => error["bad file descriptor"L];
    RETURN [c^]};

  getline: PROC [s: POINTER TO string, fd: filedesc, maxsize: INTEGER _ MAXSTR]
      RETURNS [BOOLEAN] = {
    i: INTEGER _ 1;
    c: character;
    DO
      s[i] _ getcf[@c, fd];
      i _ i + 1;
      IF (c = ENDFILE) OR (c = NEWLINE) OR (i >= maxsize) THEN EXIT
      ENDLOOP;
    IF (c = ENDFILE) THEN	-- went one too far
      i _ i - 1;
    s[i] _ ENDSTR;
    RETURN [c # ENDFILE]};


  putc: PROC [c: character] = INLINE {putcf[c, STDOUT]};

  putcf: PROC [c: character, fd: filedesc] = {
    SELECT filetab[fd].type FROM
      stream => {
        h: Stream.Handle = filetab[fd].handle;
	h.PutChar[chr[c]]};
      tty => tty.PutChar[chr[c]];
      ENDCASE => error["bad file descriptor"L]};

  putstr: PROC [s: POINTER TO string, fd: filedesc] = {
    i: INTEGER _ 1;
    WHILE (s[i] # ENDSTR) DO
      putcf[s[i], fd];
      i _ i + 1
      ENDLOOP};
      

-- string utilities

  setstring: PROC [s: POINTER TO string, text: STRING] = {
    FOR i: CARDINAL IN [1 .. text.length] DO
      s[i] _ ord[text[i-1]] ENDLOOP;
    s[text.length+1] _ ENDSTR};
  
  
-- errors and messages

  message: PROC [msg: STRING] = {
    FOR i: CARDINAL IN [0 .. msg.length) DO
      putcf[ord[msg[i]], STDERR] ENDLOOP};

  exit: ERROR = CODE;
  
  error: PROC [msg: STRING] = {
    message[msg];  ERROR exit};
   

-- command arg primitives

  MAXCMD: NAT = 20;

  cmdargs: [0 .. MAXCMD];
  cmd: ARRAY [1 .. MAXCMD] OF RECORD [idx, len: CARDINAL];
  
  getarg: PROC [n: INTEGER, str: POINTER TO string, maxsize: INTEGER]
      RETURNS [BOOLEAN] = {
    b: BOOLEAN _ ((n > 0) AND (n <= cmdargs));
    IF (b) THEN
      commandstr[cmd[n].idx, cmd[n].len, str, 1, maxsize];
    RETURN [b]};

  nargs: PROC RETURNS [INTEGER] = {RETURN [cmdargs]};
  
  commandstr: PROC [i, n: INTEGER,
      dest: POINTER TO string, j: INTEGER, maxsize: INTEGER] = {
    WHILE (n > 0) AND (j < maxsize) DO
      dest[j] _ ord[Exec.commandLine.s[i]];
      i _ i + 1;
      j _ j + 1;
      n _ n - 1;
      ENDLOOP;
    dest[j] _ ENDSTR}; 
  

-- utilities

 -- equal: test two strings for equality
  equal: PROC [str1, str2: POINTER TO string] RETURNS [BOOLEAN] = {
    i: INTEGER _ 1;
    WHILE (str1[i] = str2[i]) AND (str1[i] # ENDSTR) DO
      i _ i + 1 ENDLOOP;
    RETURN [str1[i] = str2[i]]};
    
 -- isalphanum: true if c is a letter or digit
  isalphanum: PROC [c: character] RETURNS [BOOLEAN] = {
    RETURN [
      (c IN [ord['a] .. ord['z]])
       OR (c IN [ord['A] .. ord['Z]])
       OR (c IN [ord['0] .. ord['9]])]};

 -- isletter: true if c is a letter of either case
  isletter: PROC [c: character] RETURNS [BOOLEAN] = INLINE {
    RETURN [
      (c IN [ord['a] .. ord['z]])
       OR (c IN [ord['A] .. ord['Z]])]};

 -- isdigit: true if c is a digit
  isdigit: PROC [c: character] RETURNS [BOOLEAN] = INLINE {
    RETURN [c IN [ord['0] .. ord['9]]]};

 -- itoc: convert integer n to char string in s[i] ...
  itoc: PROC [n: INTEGER, s: POINTER TO string, i: INTEGER] RETURNS [next: INTEGER] = {
    IF (n < 0) THEN {
      s[i] _ ord['-];
      next _ itoc[-n, s, i+1]}
    ELSE {
      IF (n >= 10) THEN
	i _ itoc[n/10, s, i];
      s[i] _ n MOD 10 + ord['0];
      s[i+1] _ ENDSTR;
      next _ i+1};
    RETURN};
   
 -- length: compute length of string
  length: PROC [s: POINTER TO string] RETURNS [INTEGER] = {
    n: INTEGER _ 1;
    WHILE (s[n] # ENDSTR) DO
      n _ n + 1 ENDLOOP;
    RETURN [n - 1]};
    
 -- ctoi: convert string at s[i] to integer, increment i
  ctoi: PROC [s: POINTER TO string, i: POINTER TO INTEGER] RETURNS [INTEGER] = {
    n, sign: INTEGER;
    WHILE (s[i^] = BLANK) OR (s[i^] = TAB) DO
      i^ _ i^ + 1 ENDLOOP;
    sign _ IF s[i^] = ord['-] THEN -1 ELSE 1;
    IF (s[i^] = ord['+]) OR (s[i^] = ord['-]) THEN
      i^ _ i^ + 1;
    n _ 0;
    WHILE (isdigit[s[i^]]) DO
      n _ 10*n + (s[i^] - ord['0]);
      i^ _ i^ + 1;
      ENDLOOP;
    RETURN [sign * n]};
     

-- macro: expand macros with argmuments
  macro: PROC = {
    LPAREN: character = ord['(];
    COMMA: character = ord[',];
    RPAREN: character = ord[')];

    sttype: TYPE = {DEFTYPE, MACTYPE, IFTYPE, SUBTYPE,
      EXPRTYPE, LENTYPE, CHQTYPE};	-- symbol table types
    
    BUFSIZE: NAT = 1000;		-- size of pushback buffer
    MAXCHARS: NAT = 3000;		-- size of name-defn table
    MAXPOS: NAT = 500;			-- size of position arrays
    CALLSIZE: NAT = MAXPOS;
    ARGSIZE: NAT = CALLSIZE;
    EVALSIZE: NAT = MAXCHARS;
    MAXDEF: NAT = MAXSTR;		-- max chars in a defn
    MAXTOK: NAT = MAXSTR;		-- max chars in a token
    HASHSIZE: NAT = 53;			-- size of hash table
    ARGFLAG: character = ord['$];	-- macro invocation character

    buf: ARRAY [1..BUFSIZE] OF character;	-- for pushback
    bp: [0..BUFSIZE] _ 0;		-- next available character
    
    putback: PROC [c: character] = {
      -- putback: push character back onto input
      IF (bp >= BUFSIZE) THEN
        error["macro: too many characters pushed back"L];
      bp _ bp + 1;
      buf[bp] _ c};
      
    getpbc: PROC [c: POINTER TO character] RETURNS [character] = {
      -- getpbc: get a (possibly pushed back) character
      IF (bp > 0) THEN
        c^ _ buf[bp]
      ELSE {
        bp _ 1;
	buf[bp] _ getc[c]};
      IF (c^ # ENDFILE) THEN
        bp _ bp - 1;
      RETURN [c^]};
      
    pbstr: PROC [s: POINTER TO string] = {
      -- pbstr: push string back onto input
      FOR i: INTEGER DECREASING IN [1 .. length[s]] DO
        putback[s[i]] ENDLOOP};

    gettok: PROC [token: POINTER TO string, toksize: INTEGER]
        RETURNS [character] = {
      -- gettok: get token for define
      i: INTEGER _ 1;
      done: BOOLEAN _ FALSE;
      WHILE (~done) AND (i < toksize) DO
        IF (isalphanum[getpbc[@token[i]]]) THEN
	  i _ i + 1
	ELSE
	  done _ TRUE
	ENDLOOP;
      IF (i >= toksize) THEN
	error["macro: token too long"L];
      IF (i > 1) THEN {	-- some alpha was seen
	putback[token[i]];
	i _ i - 1};
      -- else single non-alphanumeric
      token[i+1] _ ENDSTR;
      RETURN [token[1]]};
	
    charpos: TYPE = [1..MAXCHARS];
    charbuf: TYPE = ARRAY charpos OF character;

    cscopy: PROC [cb: POINTER TO charbuf, i: charpos,
        s: POINTER TO string] = {
      -- sccopy: copy cb[i] to string s
      j: INTEGER _ 1;
      WHILE (cb[i] # ENDSTR) DO
	s[j] _ cb[i];
	i _ i + 1;
	j _ j + 1
	ENDLOOP;
      s[j] _ ENDSTR};
	
    sccopy: PROC [s: POINTER TO string, cb: POINTER TO charbuf,
        i: charpos] = {
      -- sccopy: copy string s to cb[i]
      j: INTEGER _ 1;
      WHILE (s[j] # ENDSTR) DO
	cb[i] _ s[j];
	j _ j + 1;
	i _ i + 1
	ENDLOOP;
      cb[i] _ ENDSTR};
    
    ndptr: TYPE = POINTER TO ndblock;	-- pointer to name-defn block
    ndblock: TYPE = RECORD [	-- name-defn block
      name: charpos,
      defn: charpos,
      kind: sttype,
      nextptr: ndptr];

    hashtab: ARRAY [1..HASHSIZE] OF ndptr _ ALL[NIL];
    ndtable: POINTER TO charbuf;
    nexttab: charpos _ 1;	-- first free position in ndtable

    inithash: PROC = INLINE {
      -- initialize hash table
      ndtable _ zone.NEW[charbuf]};
      
    resethash: PROC = INLINE {
      -- reset hash table
      FOR i: INTEGER IN [1 .. HASHSIZE] DO
        p: ndptr _ hashtab[i];
	WHILE p # NIL DO
	  q: ndptr = p.nextptr;
	  zone.FREE[@p];
	  p _ q;
	  ENDLOOP;
	ENDLOOP;
      zone.FREE[@ndtable]};

    hash: PROC [name: POINTER TO string] RETURNS [INTEGER] = {
      h: INTEGER _ 0;
      FOR i: INTEGER IN [1 .. length[name]] DO
        h _ (3*h + name[i]) MOD HASHSIZE ENDLOOP;
      RETURN [h+1]};
    
    hashfind: PROC [name: POINTER TO string] RETURNS [p: ndptr] = {
      -- hashfind: find name in hash table
      found: BOOLEAN _ FALSE;
      p _ hashtab[hash[name]];
      WHILE (~found) AND (p # NIL) DO
        tempname: string;
	cscopy[ndtable, p^.name, @tempname];
	IF (equal[name, @tempname]) THEN
	  found _ TRUE
	ELSE p _ p^.nextptr
	ENDLOOP;
      RETURN};
      
    install: PROC [name, defn: POINTER TO string, t: sttype] = {
      -- install: add name, definition and type to table
      nlen: INTEGER = length[name] + 1;		-- 1 for ENDSTR
      dlen: INTEGER = length[defn] + 1;
      IF (nexttab + nlen + dlen > MAXCHARS) THEN {
        putstr[name, STDERR];
	error[": too many definitions"L]}
      ELSE {	-- put it at front of chain
        h: INTEGER = hash[name];
	p: ndptr = zone.NEW[ndblock];
	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}};
    
    lookup: PROC [name, defn: POINTER TO string, t: POINTER TO sttype]
        RETURNS [found: BOOLEAN] = {
      -- lookup: locate name, get defn and type from table
      p: ndptr = hashfind[name];
      IF (p = NIL) THEN
        found _ FALSE
      ELSE {
        found _ TRUE;
	cscopy[ndtable, p^.defn, defn];
	t^ _ p^.kind};
      RETURN};
    
    posbuf: TYPE = ARRAY [1..MAXPOS] OF charpos;
    pos: TYPE = [0..MAXPOS];
    
    callstk: POINTER TO posbuf;		-- call stack
    cp: pos _ 0;			-- current call stack position
    typestk: ARRAY [1..CALLSIZE] OF sttype;	-- type
    plev: ARRAY [1..CALLSIZE] OF INTEGER;	-- paren level
    argstk: POINTER TO posbuf;		-- argument stack for this call
    ap: pos _ 1;			-- current argument position

    push: PROC [ep: INTEGER, argstk: POINTER TO posbuf,
        ap: INTEGER] RETURNS [INTEGER] = {
      -- push: push ep onto argstk, return new position ap
      IF (ap > ARGSIZE) THEN
	error["macro: argument stack overflow"L];
      argstk[ap] _ ep;
      RETURN [ap + 1]};
    
    evalstk: POINTER TO charbuf;	-- evaluation stack
    ep: charpos _ 1;			-- first character unused in evalstk
    
    puttok: PROC [s: POINTER TO string] = {
      -- put token on output or evaluation stack
      i: INTEGER _ 1;
      WHILE (s[i] # ENDSTR) DO
        putchr[s[i]];
	i _ i + 1
	ENDLOOP};
	
    putchr: PROC [c: character] = {
      -- putchr: put single char on output or evaluation stack
      IF (cp <= 0) THEN
        putc[c]
      ELSE {
        IF (ep > EVALSIZE) THEN
	  error["macro: evaluation stack overflow"L];
	evalstk[ep] _ c;
	ep _ ep + 1}};
	
    eval: PROC [argstk: POINTER TO posbuf, td: sttype,
        i, j: INTEGER] = {
      -- eval: expand args i..j; do built-in or push back defn
      t: INTEGER = 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 {	-- process normal macro
        k: INTEGER _ t;
	WHILE (evalstk[k] # ENDSTR) DO
	  k _ k + 1 ENDLOOP;
	k _ k - 1;	-- last character of defn
	WHILE (k > t) DO
	  IF (evalstk[k-1] # ARGFLAG) THEN
	    putback[evalstk[k]]
	  ELSE {
	    argno: INTEGER = evalstk[k] - ord['0];
	    IF (argno >= 0) AND (argno < j-i) THEN {
	      temp: string;
	      cscopy[evalstk, argstk[i+argno+1], @temp];
	      pbstr[@temp]};
	    k _ k - 1};	-- skip over $
	  k _ k - 1
	  ENDLOOP;
	IF (k = t) THEN	-- do last character
	  putback[evalstk[k]]}};
	 
    dodef: PROC [argstk: POINTER TO posbuf, i, j: INTEGER] = {
      -- dodef: install definition in table
      IF (j - i > 2) THEN {
        temp1, temp2: string;
	cscopy[evalstk, argstk[i+2], @temp1];
	cscopy[evalstk, argstk[i+3], @temp2];
	install[@temp1, @temp2, MACTYPE]}};
	
    doif: PROC [argstk: POINTER TO posbuf, i, j: INTEGER] = {
      -- doif: select one of two arguments
      IF (j - i >= 4) THEN {
        temp1, temp2, temp3: string;
	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]}};
	
    doexpr: PROC [argstk: POINTER TO posbuf, i, j: INTEGER] = {
      -- doexpr: evaluate arithmetic expressions
      temp: string;
      junk: INTEGER _ 1;
      cscopy[evalstk, argstk[i+2], @temp];
      pbnum[expr[@temp, @junk]]};

    pbnum: PROC [n: INTEGER] = {
      -- pbnum: convert number to string, push back on input
      temp: string;
      [] _ itoc[n, @temp, 1];
      pbstr[@temp]};

    expr: PROC [s: POINTER TO string, i: POINTER TO INTEGER]
        RETURNS [INTEGER] = {
      -- expr: recursive expression evaluation
      PLUS: character = ord['+];
      MINUS: character = ord['-];
      STAR: character = ord['*];
      SLASH: character = ord['/];
      PERCENT: character = ord['%];
      LPAREN: character = ord['(];
      RPAREN: character = ord[')];

      gnbchar: PROC [s: POINTER TO string, i: POINTER TO INTEGER]
	  RETURNS [character] = {
	-- gnbchar: get next non-blank character
	WHILE (s[i^] = BLANK) OR (s[i^] = TAB) OR (s[i^] = NEWLINE) DO
	  i^ _ i^ + 1  ENDLOOP;
	RETURN [s[i^]]};

      term: PROC [s: POINTER TO string, i: POINTER TO INTEGER]
	  RETURNS [INTEGER] = {
	-- term: evaluate term of arithmetic expression
	
	factor: PROC [s: POINTER TO string, i: POINTER TO INTEGER]
	    RETURNS [v: INTEGER] = {
	  -- factor: evaluate factor of arithmetic expression
	  IF (gnbchar[s, i] = LPAREN) THEN {
	    i^ _ i^ + 1;
	    v _ expr[s, i];
	    IF (gnbchar[s, i] = RPAREN) THEN
	      i^ _ i^ + 1
	    ELSE
	      message["macro: missing paren in expr"L]}
	  ELSE
	    v _ ctoi[s, i];
	  RETURN};

	v: INTEGER _ factor[s, i];
	t: character _ gnbchar[s, i];
	WHILE (t = STAR) OR (t = SLASH) OR (t = PERCENT) DO
	  i^ _ i^ + 1;
	  SELECT t FROM
	    STAR =>
	      v _ v * factor[s, i];
	    SLASH =>
	      v _ v / factor[s, i];
	    PERCENT =>
	      v _ v MOD factor[s, i];
	    ENDCASE;
	  t _ gnbchar[s, i]
	  ENDLOOP;
	RETURN [v]};

      v: INTEGER _ term[s, i];
      t: character _ gnbchar[s, i];
      WHILE (t = PLUS) OR (t = MINUS) DO
	i^ _ i^ + 1;
	IF (t = PLUS) THEN
	  v _ v + term[s, i]
	ELSE
	  v _ v - term[s, i];
	t _ gnbchar[s, i]
	ENDLOOP;
      RETURN [v]};

    dolen: PROC [argstk: POINTER TO posbuf, i, j: INTEGER] = {
      -- dolen: return length of argument
      IF (j - i > 1) THEN {
        temp: string;
	cscopy[evalstk, argstk[i+2], @temp];
	pbnum[length[@temp]]}
      ELSE
	pbnum[0]};

    dosub: PROC [argstk: POINTER TO posbuf, i, j: INTEGER] = {
      -- dosub: select substring
      IF (j - i >= 3) THEN {
        ap, fc, k, nc: INTEGER;
	temp1, temp2: string;
	IF (j - i < 4) THEN
	  nc _ MAXTOK
	ELSE {
	  cscopy[evalstk, argstk[i+4], @temp1];
	  k _ 1;
	  nc _ expr[@temp1, @k]};
	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 {
	  cscopy[evalstk, fc, @temp1];
	  FOR k: INTEGER DECREASING IN [fc .. fc + MIN[nc, length[@temp1]]) DO
	    putback[evalstk[k]] ENDLOOP}}};
	
    dochq: PROC [argstk: POINTER TO posbuf, i, j: INTEGER] = {
      -- dochq: change quote characters
      temp: string;
      n: INTEGER;
      cscopy[evalstk, argstk[i+2], @temp];
      n _ length[@temp];
      IF (n <= 0) THEN {
        lquote _ ord['<];
	rquote _ ord['>]}
      ELSE IF (n = 1) THEN
        lquote _ rquote _ temp[1]
      ELSE {
        lquote _ temp[1];
	rquote _ temp[2]}};
	
    null: string;		-- value is ''
    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'

    lquote: character;		-- left quote character
    rquote: character;		-- right quote character
    
    defn: string;
    token: string;
    toktype: sttype;
    t: character;
    nlpar: INTEGER;

    initmacro: PROC = {
      -- initmacro: initialize variables for macro
      evalstk _ zone.NEW[charbuf];
      argstk _ zone.NEW[posbuf];
      callstk _ zone.NEW[posbuf];
      null[1] _ ENDSTR;
      setstring[@defname, "define"L];
      setstring[@subname, "substr"L];
      setstring[@exprname, "expr"L];
      setstring[@ifname, "ifelse"L];
      setstring[@lenname, "len"L];
      setstring[@chqname, "changeq"L];
      inithash[];
      lquote _ ord['<];
      rquote _ ord['>]};
      
    resetmacro: PROC = INLINE {
      -- resetmacro: reset macro storage
      resethash[];
      zone.FREE[@callstk];
      zone.FREE[@argstk];
      zone.FREE[@evalstk]};
      
    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];
    
    WHILE (gettok[@token, MAXTOK] # ENDFILE) DO
      IF (isletter[token[1]]) THEN {
        IF (~lookup[@token, @defn, @toktype]) THEN
	  puttok[@token]
	ELSE {	-- defined; put it in eval stack
	  cp _ cp + 1;
	  IF (cp > CALLSIZE) THEN
	    error["macro: call stack overflow"L];
	  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 {	-- add ()
	    putback[RPAREN];
	    putback[LPAREN]};
	  plev[cp] _ 0}}
      ELSE IF (token[1] = lquote) THEN {	-- strip quotes
	nlpar _ 1;
	DO
	  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"L];
	  IF (nlpar > 0) THEN
	    puttok[@token];
	  IF (nlpar = 0) THEN EXIT
	  ENDLOOP}
      ELSE IF (cp = 0) THEN			-- not in macro at all
	puttok[@token]
      ELSE IF (token[1] = LPAREN) THEN {
	IF (plev[cp] > 0) THEN
	  puttok[@token];
	plev[cp] _ plev[cp] + 1}
      ELSE IF (token[1] = RPAREN) THEN {
	plev [cp] _ plev[cp] - 1;
	IF (plev[cp] > 0) THEN
	  puttok[@token]
	ELSE {	-- 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}}
      ELSE IF (token[1] = COMMA) AND (plev[cp]=1) THEN {
	putchr[ENDSTR];	-- new argument
	ap _ push[ep, argstk, ap]}
      ELSE
	puttok[@token];	-- just stack it
      ENDLOOP;
    IF (cp # 0) THEN
      error["macro: unexpected end of input"L];
    resetmacro[]};
    

 -- here begins the shell
 
  initcmd: PROC = {
    idx: CARDINAL _ Exec.commandLine.i;
    limx: CARDINAL =
      IF Exec.commandLine.s = NIL THEN 0 ELSE Exec.commandLine.s.length-1;
    zone _ Heap.systemMDSZone;
    tty _ Exec.w;
    kbdx _ kbdline.length _ 0;
    kbdend _ FALSE;
    filetab[STDIN].type _ filetab[STDOUT].type _ filetab[STDERR].type _ tty;
    cmdargs _ 0;
    WHILE (idx < limx) DO
      WHILE (Exec.commandLine.s[idx] = Ascii.SP) AND (idx < limx) DO
        idx _ idx + 1 ENDLOOP;
      IF (idx < limx) THEN {
        startidx: CARDINAL = idx;
	WHILE (idx < limx)
	 AND (Exec.commandLine.s[idx] # Ascii.SP)
	 AND (Exec.commandLine.s[idx] # Ascii.TAB) DO
	  idx _ idx + 1 ENDLOOP;
	SELECT Exec.commandLine.s[startidx] FROM
	  '< => {
	    name: string;
	    commandstr[startidx+1, idx - (startidx+1), @name, 1, MAXSTR];
	    close[STDIN];
	    makestream[@name, IOREAD, STDIN]};
	  '> => {
	    name: string;
	    commandstr[startidx+1, idx - (startidx+1), @name, 1, MAXSTR];
	    close[STDOUT];
	    makestream[@name, IOWRITE, STDOUT]};
	  ENDCASE => {
	    cmdargs _ cmdargs + 1;
	    IF cmdargs > MAXCMD THEN {
	      putcf[NEWLINE, STDERR];
	      message["*** too many arguments"L];
	      putcf[NEWLINE, STDERR]}
	    ELSE
	      cmd[cmdargs] _ [idx: startidx, len: idx - startidx]}};
      ENDLOOP;
    putcf[NEWLINE, STDERR]};
      
   endcmd: PROC = {
     FOR fd: filedesc IN (IOERROR .. MAXOPEN] DO
       close[fd] ENDLOOP;
     IF Exec.commandLine.s # NIL THEN
       Exec.commandLine.i _ Exec.commandLine.s.length};
       
  main: PROC = {
    initcmd[];
    macro[ ! exit => {CONTINUE}];
    endcmd[]};
  
  Exec.AddCommand["Macro.~"L, main];
  
  }.