Copyright © 1993 Digital Equipment Corporation.
Distributed only by permission.
See the file COPYRIGHT for a full description.
Last modified on Thu Feb 2 13:54:05 PST 1995 by kalsow
modified on Mon Aug 2 16:21:04 PDT 1993 by mhb
modified on Mon Jun 21 11:15:48 PDT 1993 by wobber
modified on Fri Jun 4 15:49:01 PDT 1993 by meehan
modified on Thu Feb 18 09:03:27 PST 1993 by mjordan
<* PRAGMA LL *>
<* PRAGMA EXPORTED *>
MODULE Sx;
IMPORT Atom, FloatMode, Fmt, Lex, Rd, RdClass, RdUtils, RefList, Text, Thread,
Wr;
CONST
MinBoxedInt = -100;
MaxBoxedInt = 100;
SLASH = '\\';
BAR = '|';
SQUOTE = '\'';
DQUOTE = '"';
DIGITS = SET OF CHAR {'0'.. '9'};
LETTERS = SET OF CHAR {'a'.. 'z', 'A'.. 'Z'};
ALPHANUMERICS = LETTERS + DIGITS;
BLANKS = SET OF CHAR {'\f', '\r', ' ', '\n', '\t', '\013'};
NOREADMACROS = BLANKS + SET OF CHAR {';'};
EXCEPTION SetReadMacroError;
<* FATAL SetReadMacroError *>
VAR
BoxedInts := ARRAY [MinBoxedInt .. MaxBoxedInt] OF REF INTEGER {NIL, ..};
BoxedChars := ARRAY CHAR OF REF CHAR {NIL, ..};
BoxedReals := ARRAY [-1 .. 1] OF REF REAL {NIL, ..};
BoxedLongReals := ARRAY [-1 .. 1] OF REF LONGREAL {NIL, ..};
BoxedExtendeds := ARRAY [-1 .. 1] OF REF EXTENDED {NIL, ..};
<* EXPORTED *>
PROCEDURE FromInt (i: INTEGER): REF INTEGER =
BEGIN
IF MinBoxedInt <= i AND i <= MaxBoxedInt THEN
RETURN BoxedInts [i]
ELSE
VAR r := NEW (REF INTEGER);
BEGIN
r^ := i;
RETURN r
END
END
END FromInt;
<* EXPORTED *>
PROCEDURE FromChar (c: CHAR): REF CHAR =
BEGIN
RETURN BoxedChars [c]
END FromChar;
<* EXPORTED *>
PROCEDURE FromBool (b: BOOLEAN): Atom.T =
BEGIN
IF b THEN RETURN True ELSE RETURN False END
END FromBool;
<* EXPORTED *>
PROCEDURE FromReal (x: REAL): REF REAL =
BEGIN
IF x = -1.0E0 THEN
RETURN BoxedReals [-1]
ELSIF x = 0.0E0 THEN
RETURN BoxedReals [0]
ELSIF x = 1.0E0 THEN
RETURN BoxedReals [1]
ELSE
VAR r := NEW (REF REAL);
BEGIN
r^ := x;
RETURN r
END
END
END FromReal;
<* EXPORTED *>
PROCEDURE FromLongReal(x: LONGREAL): REF LONGREAL=
BEGIN
IF x = -1.0D0 THEN
RETURN BoxedLongReals [-1]
ELSIF x = 0.0D0 THEN
RETURN BoxedLongReals [0]
ELSIF x = 1.0D0 THEN
RETURN BoxedLongReals [1]
ELSE
VAR r := NEW (REF LONGREAL);
BEGIN
r^ := x;
RETURN r
END
END
END FromLongReal;
<* EXPORTED *>
PROCEDURE FromExtended (x: EXTENDED): REF EXTENDED =
BEGIN
IF x = -1.0X0 THEN
RETURN BoxedExtendeds [-1]
ELSIF x = 0.0X0 THEN
RETURN BoxedExtendeds [0]
ELSIF x = 1.0X0 THEN
RETURN BoxedExtendeds [1]
ELSE
VAR r := NEW (REF EXTENDED);
BEGIN
r^ := x;
RETURN r
END
END
END FromExtended;
REVEAL
Syntax = MUTEX BRANDED OBJECT
<* LL = SELF *>
map := SET OF CHAR {};
mlist: MList := NIL;
END;
Invariant for Syntax:
forall (c, c IN SELF.map iff
exists (item in SELF.mlist, item.ch = c))
TYPE
MList = REF RECORD
ch : CHAR;
m : ReadMacro;
next: MList := NIL
END;
VAR Standard := NEW (Syntax);
<* EXPORTED *>
PROCEDURE Read (rd: Rd.T; syntax: Syntax := NIL): T
RAISES {ReadError, Rd.EndOfFile, Thread.Alerted} =
VAR
c: CHAR;
s := syntax;
a: RefList.T;
m: ReadMacro;
BEGIN
IF s = NIL THEN s := Standard END;
TRY
LOOP
LOOP
Lex.Skip (rd, BLANKS);
c := Rd.GetChar (rd);
IF c # ';' THEN EXIT END;
REPEAT c := Rd.GetChar (rd) UNTIL c = '\n'
END;
m := NIL;
LOCK s DO IF c IN s.map THEN m := Syn (s, c).m END END;
IF m # NIL THEN
a := m.read (rd, syntax);
IF a = NIL THEN (* skip *)
ELSIF a.tail = NIL THEN
RETURN a.head
ELSE
RAISE ReadError (
Fmt.F ("Read-macro for '%s' produced %s results",
Text.FromChar (c), Fmt.Int (RefList.Length (a))))
END
ELSE
RETURN ReadToken (rd, c, syntax)
END
END
EXCEPT
| Rd.Failure (ref) => RAISE ReadError (RdUtils.FailureText (ref))
END
END Read;
<* EXPORTED *>
PROCEDURE ReadDelimitedList (rd: Rd.T; delim: CHAR; syntax: Syntax := NIL):
RefList.T RAISES {ReadError, Thread.Alerted} =
VAR
c : CHAR;
s := syntax;
a : RefList.T;
m : ReadMacro;
res: RefList.T := NIL;
BEGIN
IF s = NIL THEN s := Standard END;
TRY
LOOP
LOOP
Lex.Skip (rd, BLANKS);
c := Rd.GetChar (rd);
IF c # ';' THEN EXIT END;
REPEAT c := Rd.GetChar (rd) UNTIL c = '\n'
END;
m := NIL;
LOCK s DO IF c IN s.map THEN m := Syn (s, c).m END END;
IF m # NIL THEN
a := m.read (rd, syntax);
(* res := RefList.AppendD (res, RefList.Reverse (a)); *)
WHILE a # NIL DO
res := RefList.Cons (a.head, res);
a := a.tail
END
ELSIF c = delim THEN
RETURN RefList.ReverseD (res)
ELSE
res := RefList.Cons (ReadToken (rd, c, syntax), res)
END
END
EXCEPT
| Rd.EndOfFile => RAISE ReadError ("End-of-file in ReadDelimitedList")
| Rd.Failure (ref) => RAISE ReadError (RdUtils.FailureText (ref))
END
END ReadDelimitedList;
CONST
ATOM_CHARS = SET OF
CHAR {
'!', '#', '$', '%', '&', '*', '+', '-', '.', '/', ':', '<',
'=', '>', '?', '@', '[', ']', '^', '_', '{', '}', '~'};
ID_CHARS = ALPHANUMERICS + SET OF CHAR {'_'};
PROCEDURE ReadToken (rd: Rd.T; c: CHAR; s: Syntax): T
RAISES {Rd.EndOfFile, Rd.Failure, ReadError, Thread.Alerted} =
BEGIN
IF c = DQUOTE THEN
RETURN ReadDelimitedText (rd, c)
ELSIF c = SQUOTE THEN
RETURN FromChar (ReadCharLiteral (rd))
ELSIF c = '(' THEN
RETURN ReadDelimitedList (rd, ')', s)
ELSIF c = BAR THEN
RETURN Atom.FromText (ReadDelimitedText (rd, BAR))
ELSIF c IN LETTERS THEN
RETURN ReadAtom (rd, c, ID_CHARS)
ELSIF c = '+' OR c = '-' OR c = '.' THEN (* ambiguous *)
IF Rd.EOF (rd) THEN
RETURN Atom.FromText (Text.FromChar (c))
ELSE
VAR d := Rd.GetChar (rd);
BEGIN
IF d IN DIGITS THEN
RETURN ReadNumber (rd, d, c)
ELSIF d IN ATOM_CHARS THEN
RETURN Atom.FromText (Text.FromChar (c) & Text.FromChar (d)
& Lex.Scan (rd, ATOM_CHARS))
ELSE
Rd.UnGetChar (rd);
RETURN Atom.FromText (Text.FromChar (c))
END
END
END
ELSIF c IN DIGITS THEN
RETURN ReadNumber (rd, c, c)
ELSIF c IN ATOM_CHARS THEN
RETURN ReadAtom (rd, c, ATOM_CHARS)
ELSE
RAISE ReadError (Fmt.F ("Bad character '%s'", Text.FromChar (c)))
END
END ReadToken;
PROCEDURE ReadAtom (rd: Rd.T; c: CHAR; READONLY cs: SET OF CHAR): Atom.T
RAISES {Rd.Failure, Thread.Alerted} =
BEGIN
RETURN Atom.FromText (Text.FromChar (c) & Lex.Scan (rd, cs))
END ReadAtom;
TYPE
RefArrayReader = Rd.T OBJECT
mu: MUTEX
METHODS
init (): RefArrayReader := Init;
putChar (ch: CHAR) RAISES {ReadError} := PutChar;
OVERRIDES
length := Length;
seek := Seek;
close := Close
END;
This is a simple class of reader with one buff, pre-allocated.
Invariants: rd.lo = 0 and rd.length() = rd.hi.
We use this because we have to scan ahead to determine what type
of number we've got. As we scan, we store the digits in the buffer.
When we reach the end of the number, we pass the reader to the
appropriate procedure in Lex (Int, Real, LongReal, or Extended).
CONST MAXLEN = 4000;
VAR
Reader := NEW (RefArrayReader, mu := NEW (MUTEX),
buff := NEW (REF ARRAY OF CHAR, MAXLEN), lo := 0, st := 0,
seekable := TRUE, intermittent := FALSE);
PROCEDURE Init (rd: RefArrayReader): RefArrayReader =
BEGIN
rd.cur := 0;
rd.hi := 0;
rd.closed := FALSE;
RETURN rd
END Init;
PROCEDURE Seek (rd: RefArrayReader; pos: CARDINAL;
<* UNUSED *> dontBlock: BOOLEAN):
RdClass.SeekResult =
BEGIN
rd.cur := pos;
IF pos < rd.hi THEN
RETURN RdClass.SeekResult.Ready
ELSE
RETURN RdClass.SeekResult.Eof
END
END Seek;
PROCEDURE Length (rd: RefArrayReader): INTEGER =
BEGIN
RETURN rd.hi
END Length;
PROCEDURE Close (<* UNUSED *> rd: RefArrayReader) =
BEGIN
END Close;
PROCEDURE PutChar (rd: RefArrayReader; ch: CHAR)
RAISES {ReadError} =
BEGIN
IF rd.hi >= MAXLEN THEN
RAISE ReadError("Sx: Text literal or numeric too long")
END;
rd.buff[rd.hi] := ch;
INC(rd.hi);
END PutChar;
PROCEDURE ReadNumber (rd: Rd.T; c: CHAR; prev: CHAR): T
RAISES {Rd.EndOfFile, Rd.Failure, ReadError, Thread.Alerted} =
CONST HEX_DIGITS = SET OF CHAR {'0'.. '9', 'a'.. 'f', 'A'.. 'F'};
VAR wr := Reader;
PROCEDURE scanExp (): Rd.T
RAISES {Rd.EndOfFile, Rd.Failure, ReadError, Thread.Alerted} =
BEGIN
wr.putChar (c);
c := Rd.GetChar (rd);
IF c = '+' OR c = '-' THEN wr.putChar (c); c := Rd.GetChar (rd) END;
IF NOT c IN DIGITS THEN RAISE ReadError ("Illegal exponent") END;
REPEAT wr.putChar (c); c := Rd.GetChar (rd) UNTIL NOT c IN DIGITS;
Rd.UnGetChar (rd);
RETURN wr
END scanExp;
PROCEDURE scanFloat (): T RAISES {Lex.Error, FloatMode.Trap, Rd.EndOfFile,
Rd.Failure, ReadError, Thread.Alerted} =
BEGIN
IF c = 'e' OR c = 'E' THEN
RETURN FromReal (Lex.Real (scanExp ()))
ELSIF c = 'd' OR c = 'D' THEN
RETURN FromLongReal (Lex.LongReal (scanExp ()))
ELSIF c = 'x' OR c = 'X' THEN
RETURN FromExtended (Lex.Extended (scanExp ()))
ELSE
Rd.UnGetChar (rd);
RETURN FromReal (Lex.Real (wr))
END
END scanFloat;
BEGIN
TRY
LOCK wr.mu DO
EVAL wr.init ();
IF NOT prev IN DIGITS THEN wr.putChar (prev) END; (* + - . *)
REPEAT wr.putChar (c); c := Rd.GetChar (rd) UNTIL NOT c IN DIGITS;
IF prev = '.' THEN
RETURN scanFloat ()
ELSIF c = '_' THEN
wr.putChar (c);
c := Rd.GetChar (rd);
IF NOT c IN HEX_DIGITS THEN RAISE ReadError ("Illegal integer") END;
REPEAT
wr.putChar (c);
c := Rd.GetChar (rd)
UNTIL NOT c IN HEX_DIGITS;
Rd.UnGetChar (rd);
RETURN FromInt (Lex.Int (wr))
ELSIF c = '.' THEN
REPEAT wr.putChar (c); c := Rd.GetChar (rd) UNTIL NOT c IN DIGITS;
RETURN scanFloat ()
ELSE
Rd.UnGetChar (rd);
RETURN FromInt (Lex.Int (wr))
END
END
EXCEPT
| Lex.Error, FloatMode.Trap => RAISE ReadError ("Bad Format in number")
END
END ReadNumber;
PROCEDURE ReadDelimitedText (rd: Rd.T; delim: CHAR): TEXT
RAISES {Rd.EndOfFile, Rd.Failure, ReadError, Thread.Alerted} =
VAR
wr := Reader;
c : CHAR;
BEGIN
LOCK wr.mu DO
EVAL wr.init ();
LOOP
c := Rd.GetChar (rd);
IF c = delim THEN
RETURN Text.FromChars (SUBARRAY (wr.buff^, 0, wr.hi))
ELSIF c = SLASH THEN
wr.putChar (ReadEscapeSequence (rd, delim))
ELSIF ISO_Latin_printing (c) THEN
wr.putChar (c)
ELSE
RAISE ReadError ("Illegal character in Text literal")
END
END
END
END ReadDelimitedText;
PROCEDURE ISO_Latin_printing (ch: CHAR): BOOLEAN =
BEGIN
RETURN ' ' <= ch AND ch <= '~' OR '\241' <= ch AND ch <= '\377'
END ISO_Latin_printing;
PROCEDURE ReadCharLiteral (rd: Rd.T): CHAR
RAISES {Rd.EndOfFile, Rd.Failure, ReadError, Thread.Alerted} =
VAR c := Rd.GetChar (rd);
BEGIN
IF c = SQUOTE OR NOT ISO_Latin_printing (c) THEN
RAISE ReadError ("Illegal character literal")
END;
IF c = SLASH THEN c := ReadEscapeSequence (rd, SQUOTE) END;
IF Rd.GetChar (rd) = SQUOTE THEN
RETURN c
ELSE
RAISE ReadError ("Illegal character literal")
END
END ReadCharLiteral;
PROCEDURE ReadEscapeSequence (rd: Rd.T; delim: CHAR): CHAR
RAISES {Rd.EndOfFile, Rd.Failure, ReadError, Thread.Alerted} =
(* Note that for reading, \' is allowed but unnecessary in text literals,
and \" is allowed but unnecessary in character literals. *)
CONST OCTAL_CODES = ARRAY ['0' .. '7'] OF INTEGER {0, 1, 2, 3, 4, 5, 6, 7};
VAR
c := Rd.GetChar (rd);
sum: [0 .. 8_377];
BEGIN
IF c = 'n' THEN
RETURN '\n'
ELSIF c = 'r' THEN
RETURN '\r'
ELSIF c = 't' THEN
RETURN '\t'
ELSIF c = 'f' THEN
RETURN '\f'
ELSIF c = SLASH OR c = delim OR c = DQUOTE OR c = SQUOTE THEN
RETURN c
ELSIF '0' <= c AND c <= '3' THEN
sum := OCTAL_CODES [c];
c := Rd.GetChar (rd);
IF '0' <= c AND c <= '7' THEN
sum := 8 * sum + OCTAL_CODES [c];
c := Rd.GetChar (rd);
IF '0' <= c AND c <= '7' THEN
sum := 8 * sum + OCTAL_CODES [c];
RETURN VAL (sum, CHAR)
END
END
END;
RAISE ReadError ("Illegal escape sequence")
END ReadEscapeSequence;
<* EXPORTED *>
PROCEDURE Print (wr : Wr.T;
sx : T;
maxDepth : CARDINAL := LAST (CARDINAL);
maxLength: CARDINAL := LAST (CARDINAL) )
RAISES {PrintError, Wr.Failure, Thread.Alerted} =
CONST
DEPTH_ELLIPSIS = "...";
LENGTH_ELLIPSIS = "...";
BEGIN
TYPECASE sx OF
| NULL => Wr.PutText (wr, "()")
| REF INTEGER (r) => Wr.PutText (wr, Fmt.Int (r^))
| REF CHAR (r) =>
Wr.PutChar (wr, SQUOTE);
PrintChar (wr, r^, SQUOTE);
Wr.PutChar (wr, SQUOTE)
| REF REAL (r) =>
(* Wr.PutText (wr, Fmt.Real (r^, modula := TRUE)) *)
Wr.PutText (wr, Fmt.Real (r^, Fmt.Style.Auto, literal := TRUE))
| REF LONGREAL (r) =>
(* Wr.PutText (wr, Fmt.LongReal (r^, modula := TRUE)) *)
Wr.PutText (wr, Fmt.LongReal (r^, Fmt.Style.Auto, literal := TRUE))
| REF EXTENDED (r) =>
(* Wr.PutText (wr, Fmt.Extended (r^, modula := TRUE)) *)
Wr.PutText (wr, Fmt.Extended (r^, Fmt.Style.Auto, literal := TRUE))
| TEXT (t) =>
Wr.PutChar (wr, DQUOTE);
FOR i := 0 TO Text.Length (t) - 1 DO
PrintChar (wr, Text.GetChar (t, i), DQUOTE)
END;
Wr.PutChar (wr, DQUOTE)
| Atom.T (a) =>
VAR name := Atom.ToText (a);
BEGIN
IF NeedsBars (name) THEN
Wr.PutChar (wr, BAR);
FOR i := 0 TO Text.Length (name) - 1 DO
PrintChar (wr, Text.GetChar (name, i), BAR)
END;
Wr.PutChar (wr, BAR)
ELSE
Wr.PutText (wr, name)
END
END
| RefList.T (list) =>
IF maxDepth = 0 THEN
Wr.PutText (wr, DEPTH_ELLIPSIS)
ELSE
VAR len := maxLength;
BEGIN
Wr.PutChar (wr, '(');
DEC (maxDepth);
LOOP
Print (wr, list.head, maxDepth, maxLength);
list := list.tail;
IF list = NIL THEN EXIT END;
Wr.PutChar (wr, ' ');
IF len = 0 THEN Wr.PutText (wr, LENGTH_ELLIPSIS); EXIT END;
DEC (len)
END;
Wr.PutChar (wr, ')')
END
END
ELSE
RAISE PrintError ("Unprintable S-expression")
END
END Print;
PROCEDURE PrintChar (wr: Wr.T; ch: CHAR; delim: CHAR)
RAISES {Wr.Failure, Thread.Alerted} =
BEGIN
IF ch = '\n' THEN
Wr.PutText (wr, "\\n")
ELSIF ch = '\t' THEN
Wr.PutText (wr, "\\t")
ELSIF ch = '\r' THEN
Wr.PutText (wr, "\\r")
ELSIF ch = '\f' THEN
Wr.PutText (wr, "\\f")
ELSIF ch = SLASH THEN
Wr.PutText (wr, "\\\\")
ELSIF ch = delim THEN
Wr.PutChar (wr, SLASH);
Wr.PutChar (wr, ch)
ELSIF ISO_Latin_printing (ch) THEN
Wr.PutText (wr, Text.FromChar (ch))
ELSE
Wr.PutText (wr, Fmt.F ("\\%03s", Fmt.Int (ORD (ch), 8)))
END
END PrintChar;
PROCEDURE NeedsBars (t: TEXT): BOOLEAN =
VAR
len := Text.Length (t);
c : CHAR;
BEGIN
IF len = 0 THEN RETURN TRUE END; (* || *)
c := Text.GetChar (t, 0);
IF c IN LETTERS THEN
FOR i := 1 TO len - 1 DO
c := Text.GetChar (t, i);
IF NOT c IN ID_CHARS THEN RETURN TRUE END
END;
RETURN FALSE
ELSIF c IN ATOM_CHARS THEN
FOR i := 1 TO len - 1 DO
c := Text.GetChar (t, i);
IF NOT c IN ATOM_CHARS THEN RETURN TRUE END
END;
RETURN FALSE
ELSE
RETURN TRUE
END
END NeedsBars;
<* EXPORTED *>
PROCEDURE CopySyntax (s: Syntax := NIL): Syntax =
VAR
new := NEW (Syntax);
oldml: MList;
BEGIN
IF s # NIL THEN
new.map := s.map;
LOCK s DO
oldml := s.mlist;
WHILE oldml # NIL DO
new.mlist :=
NEW (MList, ch := oldml.ch, m := oldml.m, next := new.mlist);
oldml := oldml.next
END
END
END;
RETURN new
END CopySyntax;
PROCEDURE Syn (s: Syntax; ch: CHAR): MList = <* LL = s *>
VAR ml := s.mlist;
BEGIN
LOOP IF ml.ch = ch THEN RETURN ml ELSE ml := ml.next END END
END Syn;
<* EXPORTED *>
PROCEDURE SetReadMacro (s: Syntax; ch: CHAR; m: ReadMacro) =
PROCEDURE remove (VAR ml: MList) = (* My favorite use of
VAR *)
BEGIN
IF ml.ch = ch THEN
ml := ml.next
ELSE
remove (ml.next)
END
END remove;
BEGIN
IF s = NIL THEN RAISE SetReadMacroError END;
LOCK s DO
IF ch IN NOREADMACROS THEN RAISE SetReadMacroError END;
IF ch IN s.map THEN
IF m = NIL THEN
VAR tmp := SET OF CHAR {ch}; BEGIN (* Win32 code generator bug *)
s.map := s.map - tmp;
END;
remove (s.mlist)
ELSE
Syn (s, ch).m := m
END
ELSIF m # NIL THEN
VAR tmp := SET OF CHAR {ch}; BEGIN (* Win32 code generator bug *)
s.map := s.map + tmp;
END;
s.mlist :=
NEW (MList, ch := ch, m := m, next := s.mlist)
END
END
END SetReadMacro;
BEGIN
True := Atom.FromText ("TRUE");
False := Atom.FromText ("FALSE");
FOR i := MinBoxedInt TO MaxBoxedInt DO
BoxedInts [i] := NEW (REF INTEGER);
BoxedInts [i]^ := i
END;
FOR c := FIRST (CHAR) TO LAST (CHAR) DO
BoxedChars [c] := NEW (REF CHAR);
BoxedChars [c]^ := c
END;
FOR i := -1 TO +1 DO
BoxedReals [i] := NEW (REF REAL);
BoxedReals [i]^ := FLOAT (i, REAL);
BoxedLongReals [i] := NEW (REF LONGREAL);
BoxedLongReals [i]^ := FLOAT (i, LONGREAL);
BoxedExtendeds [i] := NEW (REF EXTENDED);
BoxedExtendeds [i]^ := FLOAT (i, EXTENDED)
END
END Sx.