-- file Define.mesa
-- last modified by Satterthwaite,  9-Mar-82 14:23:33

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];

Define: 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]])]};

 -- 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]};
    

-- insert main proc here
 
  define: PROC = {
    LPAREN: character = ord['(];
    COMMA: character = ord[',];
    RPAREN: character = ord[')];
    
    BUFSIZE: NAT = MAXSTR;	-- size of pushback buffer
    MAXCHARS: NAT = 3000;	-- size of name-defn table
    MAXDEF: NAT = MAXSTR;	-- max chars in a defn
    MAXTOK: NAT = MAXSTR;	-- max chars in a token
    HASHSIZE: NAT = 53;		-- size of hash table
    
    sttype: TYPE = {DEFTYPE, MACTYPE};	-- symbol table types
    
    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};
    
    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["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["define: 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]]};
	
    getdef: PROC [token: POINTER TO string, toksize: INTEGER,
        defn: POINTER TO string, defsize: INTEGER] = {
      -- getdef: get name and definition
      c: character;
      token[1] ← ENDSTR;	-- in case of bad input
      defn[1] ← ENDSTR;
      IF (getpbc[@c] # LPAREN) THEN
        message["define: missing left paren"L]
      ELSE IF (~isletter[gettok[token, toksize]]) THEN
        message["define: non-alphanumeric name"L]
      ELSE IF (getpbc[@c] # COMMA) THEN
        message["define: missing comma in define"]
      ELSE {	-- got '(name,' so far
        nlpar: INTEGER ← 0;
	i: INTEGER ← 1;
	WHILE (getpbc[@c] = BLANK) DO
	  NULL ENDLOOP;	-- skip leading blanks
	putback[c];	-- went one too far
	WHILE (nlpar >= 0) DO
	  IF (i >= defsize) THEN
	    error["define: definition too long"L]
	  ELSE IF (getpbc[@defn[i]] = ENDFILE) THEN
	    error["define: missing right paren"L]
	  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
	  ENDLOOP;
	defn[i-1] ← ENDSTR}};
	
    charpos: TYPE = [1..MAXCHARS];
    charbuf: TYPE = ARRAY [1..MAXCHARS] OF character;
    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: charbuf;
    nexttab: charpos ← 1;	-- first free position in ndtable

    inithash: PROC = INLINE {
      -- initialize hash table
      NULL};
      
    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};

    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};
    
    defn: string;
    token: string;
    toktype: sttype;	-- type returned by lookup
    defname: string;	-- value is 'define'
    null: string;	-- value is ''

    initdef: PROC = INLINE {
      -- initdef: initialize variables for define
      setstring[@defname, "define"L];
      inithash[]};
    
    resetdef: PROC = INLINE {
      -- resetdef: release heap storage
      resethash[]};
      
    null[1] ← ENDSTR;
    initdef[];
    install[@defname, @null, DEFTYPE];
    WHILE (gettok[@token, MAXTOK] # ENDFILE) DO
      IF (~isletter[token[1]]) THEN
        putstr[@token, STDOUT]
      ELSE IF (~lookup[@token, @defn, @toktype]) THEN
        putstr[@token, STDOUT]	-- undefined
      ELSE IF (toktype = DEFTYPE) THEN {	-- defn
        getdef[@token, MAXTOK, @defn, MAXDEF];
	install[@token, @defn, MACTYPE]}
      ELSE
        pbstr[@defn]	-- put replacement onto input
      ENDLOOP};
  
  
 -- 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[];
    define[ ! exit => {CONTINUE}];
    endcmd[]};
  
  Exec.AddCommand["Define.~"L, main];
  
  }.