Artifact 0daa262c75e9dcc9e3e8f5db05a6b81eb1f38ea78742b1d527c6a8d10dce30dd:

• File perq-pascal-lisp-project/poltok.red — part of check-in [eb17ceb7f6] at 2020-04-21 19:40:01 on branch master — Add Reduce 3.0 to the historical section of the archive, and some more
  files relating to version sof PSL from the early 1980s. Thanks are due to
  Paul McJones and Nelson Beebe for these, as well as to all the original
  authors.

  git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/historical@5328 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 2796) [annotate] [blame] [check-ins using] [more...]

LISP$
% Simple TOKEN scanner to Debug POLY. RED;
% Griss and Morrison

GLOBAL '(CURCHARTYPE!* CURCHAR!* TOK!*);

SYMBOLIC PROCEDURE CLEARTOKEN;              %. Clear token scanner
 <<CURCHARTYPE!* := 'WHITE; CURCHAR!* := '! >>;

SYMBOLIC PROCEDURE NTOKEN;		%. get next token
BEGIN SCALAR TOK;
  WHILE CURCHARTYPE!* MEMQ '(WHITE COMMENT) DO
    IF CURCHARTYPE!* EQ 'WHITE THEN
      READCHAR()
    ELSE << % Skip the comment
      REPEAT
	READCHAR()
      UNTIL CURCHAR!* MEMQ COMMENTEND!*;
    READCHAR() >>;
  IF CURCHARTYPE!* EQ 'DIGIT THEN <<
    WHILE CURCHARTYPE!* EQ 'DIGIT DO <<
      TOK := CURCHAR!* . TOK;
      READCHAR() >>;
    TOK!* := COMPRESS REVERSIP TOK >>
  ELSE IF CURCHARTYPE!* MEMQ '(LETTER ESCAPE) THEN <<
    WHILE CURCHARTYPE!* MEMQ '(LETTER ESCAPE) DO <<
      IF CURCHARTYPE!* EQ 'ESCAPE THEN <<
	TOK := '!! . TOK;
	READCHAR() >>;
      TOK := CURCHAR!* . TOK;
      READCHAR() >>;
    TOK!* := INTERN COMPRESS REVERSIP TOK >>
  ELSE IF CURCHARTYPE!* EQ 'DELIMITER THEN <<
    TOK!* := CURCHAR!*;
    READCHAR();TOK!* >>
  ELSE IF CURCHARTYPE!* EQ 'TERMINATOR THEN <<
     TOK!* := CURCHAR!*;    CLEARTOKEN();   TOK!*>>
  ELSE
    ERROR(1010,
	  LIST( "Illegal character `",COMPRESS LIST('!!,CURCHAR!*),
			          "' in input stream -- NTOKEN") );
END NTOKEN;

SYMBOLIC PROCEDURE READCHAR;	%. Get next char and classify
<< CURCHAR!* := READCH();
   CURCHARTYPE!* := GET(CURCHAR!*,'CHARACTERTYPE) >>;

SYMBOLIC PROCEDURE INITTOKEN;	%. Initialise TOKEN scan
 BEGIN
DEFLIST('(
 (A LETTER)
 (B LETTER)
 (C LETTER)
 (D LETTER)
 (E LETTER)
 (F LETTER)
 (G LETTER)
 (H LETTER)
 (I LETTER)
 (J LETTER)
 (K LETTER)
 (L LETTER)
 (M LETTER)
 (N LETTER)
 (O LETTER)
 (P LETTER)
 (Q LETTER)
 (R LETTER)
 (S LETTER)
 (T LETTER)
 (U LETTER)
 (V LETTER)
 (W LETTER)
 (X LETTER)
 (Y LETTER)
 (Z LETTER)
 (a LETTER)
 (b LETTER)
 (c LETTER)
 (d LETTER)
 (e LETTER)
 (f LETTER)
 (g LETTER)
 (h LETTER)
 (i LETTER)
 (j LETTER)
 (k LETTER)
 (l LETTER)
 (m LETTER)
 (n LETTER)
 (o LETTER)
 (p LETTER)
 (q LETTER)
 (r LETTER)
 (s LETTER)
 (t LETTER)
 (u LETTER)
 (v LETTER)
 (w LETTER)
 (x LETTER)
 (y LETTER)
 (z LETTER)
 (!_ LETTER)
 (!. LETTER)
 (!0 DIGIT)
 (!1 DIGIT)
 (!2 DIGIT)
 (!3 DIGIT)
 (!4 DIGIT)
 (!5 DIGIT)
 (!6 DIGIT)
 (!7 DIGIT)
 (!8 DIGIT)
 (!9 DIGIT)
 (!+ DELIMITER)
 (!- DELIMITER)
 (!* DELIMITER)
 (!/ DELIMITER)
 (!^ DELIMITER)
 (!' DELIMITER)
 (!( DELIMITER)
 (!) DELIMITER)
 (!, DELIMITER)
 (!; TERMINATOR)
 (!! ESCAPE)
 (!  WHITE)     % Blank
 (!	 WHITE)	% Tab
 (!
 WHITE)	% Carriage Return
 (!
 WHITE)	% Line Feed
 (! WHITE)	% Form Feed
 (!% COMMENT)
   ), 'CHARACTERTYPE);
	PUT(!$EOL!$,'CHARACTERTYPE,'WHITE);
	COMMENTEND!* := LIST !$EOL!$;
	CLEARTOKEN();
END;

INITTOKEN();

SYMBOLIC PROCEDURE XAPPLY(FN,ARGS);     %. Interface for PLISP
   APPLY(FN,ARGS)$

END$