Artifact a16a15658ef39e0f4c789f3df32cd65fc2528a56cddf7bb594ccbdd49bbe8595:
- File
psl-1983/util/rlisp-parser.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: 33886) [annotate] [blame] [check-ins using] [more...]
% % RLISP-PARSER.RED - RLISP parser based on Nordstrom and Pratt model % % Author: Martin Griss and Eric Benson % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: May 1981 % Copyright (c) 1981 University of Utah % % Known Bugs and Problems: % Procedure TEMPLATES parsed at wrong precendence, so % procedure x/y; is ok % procedure (x/Y) fails! % % IF a Then B; ELSE c; parses badly, doesnt catch ELSE % QUOTIENT(A,B) parses as RECIP(A) % % Edit by Cris Perdue, 28 Jan 1983 2038-PST % Occurrences of "dipthong" changed to "diphthong" % <PSL.UTIL.NEWVERSIONS>RLISP-PARSER.RED.4, 16-Dec-82 12:11:15, Edit by KESSLER % Make SEMIC!* a Global (as in rlisp-support), so it won't be made fluid in % compilation of Scan. % <PSL.UTIL>RLISP-PARSER.RED.3, 13-Dec-82 13:14:36, Edit by OTHMER % Flagged EMB as 'FTYPE so debug functions will work % <PSL.UTIL>RLISP-PARSER.RED.42, 17-Mar-82 02:36:14, Edit by BENSON % Finally infix as prefix works!!! % <PSL.UTIL>RLISP-PARSER.RED.25, 14-Jan-82 13:16:34, Edit by BENSON % Added JOIN to for each % <PSL.UTIL>RLISP-PARSER.RED.24, 30-Dec-81 01:01:30, Edit by BENSON % Unfixed infix as prefix. Have to check to make sure the thing is an arglist % <PSL.UTIL>RLISP-PARSER.RED.21, 28-Dec-81 15:22:37, Edit by BENSON % fixed LAMBDA();... % <PSL.UTIL>RLISP-PARSER.RED.21, 28-Dec-81 15:21:43, Edit by BENSON % Infix operators used as prefix are parsed correctly % <PSL.UTIL>RLISP-PARSER.RED.19, 28-Dec-81 14:44:47, Edit by BENSON % Removed assign-op in favor of SetF % <PSL.UTIL>RLISP-PARSER.RED.36, 5-Feb-82 07:17:34, Edit by GRISS % Add NE as infix CompileTime flag('(DefineBOpX DefineROpX DoInfixAsPrefix IsOpOp DoPrefix DoInfix MakeLocals MkQuotList PrecSet InfixOp PrefixOp RlispRead RemSemicol SymErr RAtomHook CommentPart), 'InternalFunction); FLUID '(CURSYM!* !*InsideStructureRead); CURSYM!*:='! ; global '(Semic!* TokType!*); lisp procedure SymErr(X, Y); StdError BldMsg("Syntax error %r", X); SYMBOLIC PROCEDURE SCAN; BEGIN SCALAR X; A: CURSYM!* := RATOMHOOK(); IF TOKTYPE!* EQ 3 THEN %/ Also a R, (IF CURSYM!* EQ '!' THEN CURSYM!* := LIST('QUOTE, RLISPREAD()) ELSE IF (X:=GET(CURSYM!*,'NeWNAM!-OP))THEN <<IF X EQ '!*SEMICOL!* THEN SEMIC!* := CURSYM!*; CURSYM!*:=X >> ); IF (X:=(GET(CURSYM!*,'NEWNAM))) THEN CURSYM!*:=X; IF CURSYM!* EQ 'COMMENT THEN << WHILE NOT (READCH() MEMQ '(!; !$)) DO ; GOTO A >>; RETURN CURSYM!*; END; SYMBOLIC PROCEDURE RESETPARSER; CURSYM!*:= '! ; %----------------------------------------------------------------- %--- Boot strap functions, move to build file-----; FLUID '( %. Name of Grammer being defined DEFPREFIX DEFINFIX GRAMPREFIX GRAMINFIX ); %. Name of grammer running DEFPREFIX := 'RLISPPREFIX; %. Key for Grammer being defined DEFINFIX := 'RLISPINFIX; %. Key for Grammer being defined GRAMPREFIX := 'RLISPPREFIX; %. Key for Grammer being defined GRAMINFIX := 'RLISPINFIX; %. Key for Grammer being defined SYMBOLIC FEXPR PROCEDURE DEFINEBOP U; DEFINEBOPX U; SYMBOLIC PROCEDURE DEFINEBOPX U; % u=(opname, lprec, rprec,function) BEGIN SCALAR W,Y; W := EVAL CAR U; % Opname; Remove ' which used to suppress OP props Y := EVAL CADR U % Lprec . EVAL CADDR U % Rprec . IF NULL CDDDR U THEN NIL % Default function is NIL ELSE IF ATOM CADDDR U THEN CADDDR U ELSE LIST('LAMBDA,'(X Y),CADDDR U); PUT(W,DEFINFIX,Y) % Binop in CAR END; SYMBOLIC PROCEDURE INFIXOP U; % Used also in REDUCE GET(U,GRAMINFIX); SYMBOLIC PROCEDURE INFIXPREC U; % Used in REDUCE MathPrint BEGIN SCALAR V; IF NULL(V:=INFIXOP U) THEN RETURN NIL; IF PAIRP V AND NUMBERP CAR V THEN RETURN CAR V; RETURN NIL; END; SYMBOLIC FEXPR PROCEDURE DEFINEROP U; DEFINEROPX U; SYMBOLIC PROCEDURE DEFINEROPX U; % u=(opname,lprec,function) BEGIN SCALAR W,Y; W := EVAL CAR U; % Name, remove ' mark Y := EVAL CADR U % Lprec . IF NULL CDDR U THEN NIL % Default is NIL ELSE IF ATOM CADDR U THEN CADDR U % function name ELSE LIST('LAMBDA,'(X),CADDR U); % PUT(W,DEFPREFIX,Y) END; SYMBOLIC PROCEDURE PREFIXOP U; GET(U,GRAMPREFIX); FLUID '(OP); %. Current TOKEN being studied % ***** General Parser Functions *****; SYMBOLIC PROCEDURE PARSE0(RP,PRESCAN); %. Collect Phrase to LP<RP BEGIN SCALAR CURSYM,U; %/ IF COMPR!* AND CURSYM!* EQ CAAR COMPR!* %/ THEN <<CURSYM := CAR COMPR!*; COMPR!* := CDR COMPR!*>>; OP := IF PRESCAN THEN SCAN() ELSE CURSYM!*; %/ IF PRESCAN AND COMPR!* AND CURSYM!* EQ CAAR COMPR!* %/ THEN <<CURSYM := CAR COMPR!*; COMPR!* := CDR COMPR!*>>; U := RDRIGHT(RP,OP); %/ IF CURSYM THEN RPLACA(CURSYM,U); RETURN U END; SYMBOLIC PROCEDURE RDRIGHT(RP,Y); %. Collect phrase until OP with LP<RP % Y is starting TOKEN. % RP=NIL - Caller applies Function to Y, without collecting RHS subphrase BEGIN SCALAR TEMP,OP1,TEMPSCAN, TEMPOP, !*InsideStructureRead; !*InsideStructureRead := T; IF NULL RP THEN RETURN Y %/ ELSE IF IDFLAG THEN OP := SCAN() % Set IDFLAG if not Operator ELSE IF RP=0 AND Y EQ '!*SEMICOL!* THEN RETURN NIL %/ Toplevel ; or $? ELSE IF (TEMP:=PREFIXOP Y) THEN << TEMPSCAN := SCAN(); IF STRONGERINFIXOP(TEMPSCAN, Y, CAR TEMP) THEN OP := TEMPSCAN ELSE Y := DOPREFIX(CDR TEMP,Y,RDRIGHT(CAR TEMP,TEMPSCAN)) >> ELSE IF NOT INFIXOP Y THEN OP := SCAN() %/ Binary OP in Prefix Position ELSE IF ISOPOP(OP,RP,Y) THEN <<OP := Y; Y := NIL>> ELSE OP := SCAN();% Y:=DoINFIXasPREFIX(Y,OP:=SCAN()); RDLEFT: IF %/IDFLAG OR NOT (TEMP := INFIXOP OP) THEN IF NULL OP THEN <<Y := LIST(Y,NIL); OP := SCAN()>> ELSE Y := REPCOM(Y,RDRIGHT(99,OP)) %. Do as PREFIX ELSE IF RP>CAR TEMP THEN RETURN Y ELSE <<OP1:=OP; %/ !*ORD PROBLEM? TEMPSCAN := SCAN(); IF TEMPSCAN = '!*LPAR!* AND NOT FUNBOUNDP OP1 THEN << OP := TEMPSCAN; %/ kludge to allow infix/prefix TEMPSCAN := RDRIGHT(CADR TEMP, OP); IF EQCAR(TEMPSCAN, '!*COMMA!*) THEN Y := LIST(Y, REPCOM(OP1, TEMPSCAN)) ELSE Y := DOINFIX(CDDR TEMP,Y,OP1,TEMPSCAN) >> ELSE IF STRONGERINFIXOP(TEMPSCAN, OP1, CADR TEMP) THEN << Y := LIST(Y, OP1); OP := TEMPSCAN >> ELSE Y := DOINFIX(CDDR TEMP,Y,OP1,RDRIGHT(CADR TEMP,TEMPSCAN))>>; GO TO RDLEFT END; SYMBOLIC PROCEDURE STRONGERINFIXOP(NEXTOP, LASTOP, LASTPREC); BEGIN SCALAR TEMPOP, MATCHER; RETURN NOT PREFIXOP NEXTOP AND (TEMPOP := INFIXOP NEXTOP) AND NUMBERP LASTPREC AND NUMBERP CAR TEMPOP AND CAR TEMPOP <= 6 AND CAR TEMPOP <= LASTPREC AND NOT ((MATCHER := GET(LASTOP, 'CLOSER)) AND MATCHER EQ NEXTOP) AND NOT ISOPOP(NEXTOP, LASTPREC, LASTOP); END; DefList('((BEGIN END) (!*LPAR!* !*RPAR!*) (!*LSQB!* !*RSQB!*) (!*LVEC!* !*RVEC!*)), 'CLOSER); SYMBOLIC PROCEDURE DoINFIXasPREFIX(LHS,BOP); REPCOM(LHS,RDRIGHT(99,BOP)); %. Note that PREFIX functions have next token SCANed, and get an argument, %. "X", that is either this TOKEN, or a complete parsed Phrase SYMBOLIC PROCEDURE DOPREFIX(ACT,ROP,RHS); IF NULL ACT THEN LIST(ROP,RHS) ELSE APPLY(ACT,LIST RHS); %. Note that INFIX functions have next token SCANed, and get two arguments, %. "X" and "Y"; "X" is LHS phrase, %. "Y" is either the scanned TOKEN, or a complete parsed Phrase SYMBOLIC PROCEDURE DOINFIX(ACT,LHS,BOP,RHS); IF NULL ACT THEN LIST(BOP,LHS,RHS) ELSE APPLY(ACT,LIST(LHS,RHS)); SYMBOLIC PROCEDURE ISOPOP(XOP,RP,Y); %. Test for legal OP-> <-OP IF RP=2 THEN Y EQ '!*RPAR!* % LPAR scans for LP 2 ELSE IF RP=0 AND XOP EQ 'END AND Y MEMBER '(!*SEMICOL!* !*COLON!* !*RSQB!* END) THEN T ELSE IF Y MEMQ '(!*SEMICOL!* END !*RSQB!*) % Special cases in BEGIN-END THEN RP= -2 OR XOP MEMQ '(!*SEMICOL!* !*COLON!* !*RSQB!*) ELSE NIL; SYMBOLIC PROCEDURE PARERR(X,Y); StdError X; SYMBOLIC PROCEDURE REMCOM X; %. (, x y z) -> (x y z) IF EQCAR(X,'!*COMMA!*) THEN CDR X ELSE LIST X; SYMBOLIC PROCEDURE REMSEMICOL X; %. (; x y z) -> (x y z) IF EQCAR(X,'!*SEMICOL!*) THEN CDR X ELSE LIST X; SYMBOLIC PROCEDURE REPCOM(TYPE,X); %. Create ARGLIST IF EQCAR(X,'!*COMMA!*) THEN (TYPE . CDR X) ELSE IF X EQ '!*EMPTY!* THEN LIST(TYPE) ELSE LIST(TYPE,X); %SYMBOLIC PROCEDURE SELF RHS; %. Prefix Operator returns RHS % RHS; SYMBOLIC PROCEDURE ParseNOOP X; <<OP:=SCAN();X>>; DEFINEROP('NOOP,NIL,ParseNOOP); %. Prevent TOKEN from being an OP SYMBOLIC PROCEDURE MKQUOTLIST U; %this could be replaced by MKQUOTE in most cases; 'LIST . FOR EACH X IN U COLLECT IF CONSTANTP X THEN X ELSE MKQUOTE X; SYMBOLIC PROCEDURE NARY(XOP,LHS,RHS); %. Remove repeated NARY ops IF EQCAR(LHS,XOP) THEN ACONC(LHS,RHS) ELSE LIST(XOP,LHS,RHS); % ***** Tables for Various Infix Operators *****; SYMBOLIC PROCEDURE ParseCOMMA(X,Y); NARY('!*COMMA!*,X,Y); DEFINEBOP('!*COMMA!*,5,6,ParseCOMMA ); SYMBOLIC PROCEDURE ParseSEMICOL(X,Y); NARY('!*SEMICOL!*,X,Y); DEFINEBOP('!*SEMICOL!*, - 1,0,ParseSEMICOL ); SYMBOLIC PROCEDURE ParseSETQ(LHS,RHS); %. Extended SETQ LIST(IF ATOM LHS THEN 'SETQ ELSE 'SETF, LHS, RHS); DEFINEBOP('SETQ,7,6,ParseSETQ); DEFINEBOP('CONS,23,21); SYMBOLIC PROCEDURE ParsePLUS2(X,Y); NARY('PLUS,X,Y); DEFINEBOP('PLUS,17,18,ParsePLUS2); %SYMBOLIC PROCEDURE ParsePLUS1(X); % IF EQCAR(X,'!*COMMA!*) THEN REPCOM('PLUS,X) ELSE X; % %DEFINEROP('PLUS,26,ParsePLUS1); %/ **** Prefix + sign... DEFINEROP('MINUS,26); SYMBOLIC PROCEDURE ParseDIFFERENCE(X); IF NUMBERP X THEN (0 - X ) ELSE IF EQCAR(X,'!*COMMA!*) THEN REPCOM('DIFFERENCE,X) ELSE LIST('MINUS,X); DEFINEROP('DIFFERENCE,26,ParseDIFFERENCE ); DEFINEBOP('DIFFERENCE,17,18); DEFINEBOP('TIMES,19,20); SYMBOLIC PROCEDURE ParseQUOTIENT(X); IF NOT EQCAR(X,'!*COMMA!*) THEN LIST('RECIP,X) ELSE REPCOM('QUOTIENT,X); DEFINEROP('QUOTIENT,26,ParseQUOTIENT); DEFINEBOP('QUOTIENT,19,20); DEFINEROP('RECIP,26); DEFINEBOP('EXPT,23,24); SYMBOLIC PROCEDURE ParseOR(X,Y); NARY('OR,X,Y); DEFINEBOP('OR,9,10,ParseOR); %/DEFINEROP('OR,26,REPCOM('OR,X)); SYMBOLIC PROCEDURE ParseAND(X,Y); NARY('AND,X,Y); DEFINEBOP('AND,11,12,ParseAND); %/DEFINEROP('AND,26,REPCOM('AND,X)); DEFINEROP('NOT,14); DEFINEBOP('MEMBER,15,16); %/DEFINEROP('MEMBER,26,REPCOM('MEMBER,X)); DEFINEBOP('MEMQ,15,16); %/DEFINEROP('MEMQ,26,REPCOM('MEMQ,X)); DEFINEBOP('EQ,15,16); %/DEFINEROP('EQ,26,REPCOM('EQ,X)); DEFINEBOP('EQUAL,15,16); DEFINEBOP('GEQ,15,16); DEFINEBOP('GREATERP,15,16); DEFINEBOP('LEQ,15,16); DEFINEBOP('LESSP,15,16); DEFINEBOP('NEQ,15,16); DEFINEBOP('NE,15,16); % ***** Tables and Definitions for Particular Parsing Constructs *****; % ***** IF Expression *****; DEFINEROP('IF,4,ParseIF); DEFINEBOP('THEN,3,6); DEFINEBOP('ELSE,3,6); SYMBOLIC PROCEDURE ParseIF X; BEGIN SCALAR Y,Z; IF OP EQ 'THEN THEN Y := PARSE0(6,T) ELSE PARERR("IF missing THEN",T); IF OP EQ 'ELSE THEN Z := LIST PARSE0(6,T); RETURN 'COND . LIST(X,Y) . IF Z THEN IF EQCAR(CAR Z,'COND) THEN CDAR Z ELSE LIST (T . Z) ELSE NIL END; SYMBOLIC PROCEDURE ParseCASE(X); %. Parser function BEGIN IF NOT (OP EQ 'OF) THEN PARERR("CASE Missing OF",T); RETURN 'CASE . X . CASELIST() END; DEFINEBOP('OF,3,6); DEFINEBOP('TO,8,9); DEFINEROP('CASE,4,ParseCASE); SYMBOLIC PROCEDURE CASELIST; BEGIN SCALAR TG,BOD,TAGLIST,BODLIST; L1: OP := SCAN(); % Drop OF, : , etc IF OP EQ 'END THEN GOTO L2; % For optional ; before END TG := PARSETAGS(); % The TAG expressions BOD:= PARSE0(6,T); % The expression BODLIST:=LIST(TG,BOD) . BODLIST; IF OP EQ '!*SEMICOL!* THEN GOTO L1; IF OP NEQ 'END THEN PARERR("Expect END after CASE list",T); L2: OP:=SCAN(); % Skip 'END RETURN REVERSE BODLIST; END; SYMBOLIC PROCEDURE PARSETAGS(); % Collects a single CASE-tag form; OP prescanned BEGIN SCALAR TG,TGLST; TG:=PARSE0(6,NIL); % , and : below 6 IF EQCAR(TG,'TO) THEN TG:='RANGE . CDR TG; % TO is infix OP IF TG MEMQ '(OTHERWISE DEFAULT) THEN RETURN <<IF OP NEQ '!*COLON!* THEN PARERR("OTHERWISE in CASE must be SINGLE tag",T); NIL>>; IF OP EQ '!*COLON!* THEN RETURN LIST(TG); IF OP EQ '!*COMMA!* THEN RETURN <<OP:=SCAN(); TGLST:=PARSETAGS(); IF NULL TGLST THEN PARERR("OTHERWISE in CASE must be SINGLE tag",T); TG . TGLST>>; PARERR("Expect one or more tags before : in CASE",T); END; % ***** Block Expression *****; fluid '(BlockEnders!*); BlockEnders!* :='(END !*RPAR!* !*SEMICOL!* ELSE UNTIL !*RSQB!*); SYMBOLIC PROCEDURE ParseBEGIN(X); ParseBEGIN1(REMSEMICOL X, COMMENTPART(SCAN(),BlockEnders!*)); DEFINEROP('BEGIN,-2,ParseBEGIN); DEFINEBOP('END,-3,-2); SYMBOLIC PROCEDURE ParseGO X; IF X EQ 'TO THEN LIST('GO,PARSE0(6,T)) % Why not Just SCAN? ELSE <<OP := SCAN(); LIST('GO,X)>>; DEFINEROP('GO,NIL,ParseGO ); SYMBOLIC PROCEDURE ParseGOTO X; <<OP := SCAN(); LIST('GO,X)>>; DEFINEROP('GOTO,NIL,ParseGOTO ); SYMBOLIC PROCEDURE ParseRETURN X; Begin Scalar XOP; RETURN LIST('RETURN, IF (XOP := INFIXOP X) AND NUMBERP CAR XOP AND CAR XOP <= 1 THEN <<OP := X; NIL>> ELSE RDRIGHT(6,X)); END; DEFINEROP('RETURN,NIL,ParseRETURN); SYMBOLIC PROCEDURE ParseEXIT X; Begin Scalar XOP; RETURN LIST('EXIT, IF (XOP := INFIXOP X) AND NUMBERP CAR XOP AND CAR XOP <= 1 THEN <<OP := X; NIL>> ELSE RDRIGHT(6,X)); END; DEFINEROP('EXIT,NIL,ParseEXIT); DEFINEBOP('!*COLON!*,1,0 ); SYMBOLIC PROCEDURE COMMENTPART(A,L); IF A MEMQ L THEN <<OP := A; NIL>> ELSE A . COMMENTPART(SCAN(),L); SYMBOLIC PROCEDURE ParseBEGIN1(L,COMPART); BEGIN SCALAR DECLS,S; % Look for Sequence of Decls after Block Header A: IF NULL L THEN GO TO ND %/ SCAN(); %/ IF CURSYM!* MEMQ '(INTEGER REAL SCALAR) %/ THEN <<Z1:=REPCOM(CURSYM!*,PARSE0(0,NIL))>>; % Arg Decl; ELSE IF NULL CAR L THEN <<L := CDR L; GO TO A>> ELSE IF EQCAR(CAR L,'DECLARE) THEN <<DECLS :=APPEND(CDAR L, DECLS); % Reverse order collection L := CDR L>> ELSE <<S:=L; GO TO B>>; % Hold Body for Rescan GO TO A; B: IF NULL L THEN GO TO ND ELSE IF EQCAR(CAR L,'DECLARE) THEN PARERR("DECLARATION invalid in BEGIN body",NIL) ELSE IF EQCAR(CAR L,'!*COLON!*) THEN <<RPLACD(CDDAR L,CDR L); RPLACD(L,CDDAR L); RPLACA(L,CADAR L)>> ELSE IF CDR L AND NULL CADR L THEN <<RPLACD(L,CDDR L); L := NIL . L>>; L := CDR L; GO TO B; ND: RETURN ('PROG . MAKELOCALS(DECLS) . S); END; SYMBOLIC PROCEDURE MAKELOCALS(U); %. Remove Types from Reversed DECLARE IF NULL U THEN NIL ELSE APPEND(CDAR U,MAKELOCALS CDR U); % ***** Procedure Expression *****; GLOBAL '(!*MODE); !*MODE := 'SYMBOLIC; SYMBOLIC PROCEDURE NMODESTAT VV; % Parses TOP-LEVEL mode ....; BEGIN SCALAR TMODE,X; X:= CURSYM!*; % SCAN(); IF CURSYM!* EQ '!*SEMICOL!* THEN RETURN <<NEWMODE VV; OP:='!*SEMICOL!*;NIL>>; IF FLAGP(CURSYM!*,'DELIM) THEN RETURN <<NEWMODE VV; OP:='!*SEMICOL!*;NIL>>; TMODE := !*MODE; !*MODE := VV; % Local MODE change for MKPROC X := ERRORSET('(PARSE0 0 NIL),T,!*BACKTRACE); !*MODE := TMODE; RETURN IF ATOM X OR CDR X THEN NIL ELSE CAR X END; SYMBOLIC PROCEDURE NEWMODE VV; <<PRINT LIST('NEWMODE,LIST('QUOTE,VV)); IF NULL VV THEN VV:='SYMBOLIC; !*MODE := VV>>; CommentOutCode << fluid '(FTypes!*); FTYPES!* := '(EXPR FEXPR MACRO); SYMBOLIC PROCEDURE OLDPROCSTAT; BEGIN SCALAR BOOL,U,TYPE,X,Y,Z; IF FNAME!* THEN GO TO B ELSE IF CURSYM!* EQ 'PROCEDURE THEN TYPE := 'EXPR ELSE PROGN(TYPE := CURSYM!*,SCAN()); IF NOT CURSYM!* EQ 'PROCEDURE THEN GO TO C; X := ERRORSET('(PARSE0 0 T),T,!*BACKTRACE); IF ATOM X OR CDR X THEN GO TO A ELSE IF ATOM (X := CAR X) THEN X := LIST X; %no arguments; FNAME!* := CAR X; %function name; IF IDP FNAME!* %AND NOT(TYPE MEMQ FTYPES!*); THEN IF NULL FNAME!* OR (Z := GETTYPE FNAME!*) AND NOT Z MEMQ '(PROCEDURE OPERATOR) THEN GO TO D ELSE IF NOT GETD FNAME!* THEN FLAG(LIST FNAME!*,'FNC); %to prevent invalid use of function name in body; U := CDR X; Y := ERRORSET(LIST('FLAGTYPE,MKQUOTE U,MKQUOTE 'SCALAR), T,!*BACKTRACE); IF ATOM Y OR CDR Y THEN Y := NIL ELSE Y := CAR Y; X := CAR X . Y; A: Z := ERRORSET('(PARSE0 0 T),T,!*BACKTRACE); IF NOT ATOM Z AND NULL CDR Z THEN Z := CAR Z; IF NULL ERFG!* THEN Z:=PROCSTAT1(X,Z,TYPE); REMTYPE Y; REMFLAG(LIST FNAME!*,'FNC); FNAME!*:=NIL; IF NOT BOOL AND ERFG!* THEN REDERR "ERROR TERMINATION"; RETURN Z; B: BOOL := T; C: ERRORSET('(SYMERR (QUOTE PROCEDURE) T),T,!*BACKTRACE); GO TO A; D: LPRIE LIST(Z,FNAME!*,"INVALID AS PROCEDURE"); GO TO A END; >>; % Some OLD Crap looks at 'STAT values!!! DEFLIST ('((PROCEDURE PROCSTAT) (EXPR PROCSTAT) (FEXPR PROCSTAT) (EMB PROCSTAT) (MACRO PROCSTAT) (NMACRO PROCSTAT) (SMACRO PROCSTAT)), 'STAT); DEFLIST ('((ALGEBRAIC MODESTAT) (SYMBOLIC MODESTAT) (SYSLSP MODESTAT) ), 'STAT); %/ STAT used for OLD style BEGIN KEY search DEFLIST('((LISP SYMBOLIC)),'NEWNAM); DEFINEROP('SYMBOLIC,NIL,NMODESTAT('SYMBOLIC)); % Make it a Prefix OP DEFINEROP('ALGEBRAIC,NIL,NMODESTAT('ALGEBRAIC)); % Make it a Prefix OP DEFINEROP('SYSLSP,NIL,NMODESTAT('SYMBOLIC)); % Make it a Prefix OP DEFINEBOP('PROCEDURE,1,NIL,ParsePROCEDURE); % Pick up MODE -- will go DEFINEROP('PROCEDURE,NIL,ParsePROCEDURE('EXPR,X)); %/ Unary, use DEFAULT mode? SYMBOLIC PROCEDURE ParsePROCEDURE2(NAME,VARLIS,BODY,TYPE); BEGIN SCALAR Y; % IF FLAGP(NAME,'LOSE) AND (!*LOSE OR NULL !*DEFN) % THEN RETURN PROGN(LPRIM LIST(NAME, % "Not defined (LOSE Flag)"), % NIL); if (Y := get(Type, 'FunctionDefiningFunction)) then Body := list(Y, Name, VarLis, Body) else if (Y := get(Type, 'ImmediateDefiningFunction)) then return Apply(Y, list(Name, VarLis, Body)) ELSE BODY := LIST('PUTC, MKQUOTE NAME, MKQUOTE TYPE, MKQUOTE LIST('LAMBDA,VARLIS, REFORM BODY)); RETURN IF !*MODE NEQ 'ALGEBRAIC THEN BODY %/ ELSE LIST('PROGN, %/ LIST('FLAG,MKQUOTE LIST NAME,MKQUOTE 'OPFN), %/ BODY) END; DefList('((Expr DE) (FExpr DF) (Macro DM) (NExpr DN) (SMacro DS)), 'FunctionDefiningFunction); put('Emb, 'ImmediateDefiningFunction, 'EmbFn); SYMBOLIC PROCEDURE ParsePROCEDURE1(NAM,ARGS,BODY,ARGTYPE,TYPES); %/ Crude conversion of PROC to PUTD. Need make Etypes and Ftypes %/ Keywords also. BEGIN SCALAR ETYPE,FTYPE; ETYPE:=!*MODE; FTYPE:='EXPR; IF NOT PAIRP TYPES THEN TYPES:=TYPES . NIL; FOR EACH Z IN TYPES DO IF FLAGP(Z,'ETYPE) THEN ETYPE:=Z ELSE IF FLAGP(Z,'FTYPE) THEN FTYPE:=Z; RETURN ParsePROCEDURE2(NAM,ARGS,BODY,FTYPE); END; FLAG('(EXPR FEXPR NEXPR NFEXPR MACRO SMACRO NMACRO EMB),'FTYPE); FLAG('(SYMBOLIC ALGEBRAIC LISP SYSLISP SYSLSP),'ETYPE); SYMBOLIC PROCEDURE ParsePROCEDURE(EFTYPES,Y); BEGIN SCALAR OP1,Z,Z1; OP := OP1 := SCAN(); IF OP1 EQ '!*SEMICOL!* THEN Y := LIST Y ELSE IF INFIXOP OP1 THEN Y := LIST(OP1,Y,PARSE0(8,T)) % Binary as Prefix ELSE Y := REPCOM(Y,PARSE0(8,NIL)); %/ Why 8 IF OP NEQ '!*SEMICOL!* THEN PARERR("PROCEDURE missing terminator after template",T); %/ SCAN(); %/ IF CURSYM!* MEMQ '(INTEGER REAL SCALAR) %/ THEN <<Z1:=REPCOM(CURSYM!*,PARSE0(0,NIL))>>; % Arg Decl; Z := PARSE0(0,T); IF EQCAR(Z,'DECLARE) THEN <<Z1 := Z; Z := PARSE0(0,T)>>; % repeated DECL? RETURN ParsePROCEDURE1(CAR Y,CDR Y,Z,Z1,EFTYPES); % Nam, args, body, arg decl, E/Fmode END; % ***** Left and Right Parentheses Handling *****; DEFINEROP('!*LPAR!*,NIL,ParseLPAR); DEFINEBOP('!*RPAR!*,1,0); SYMBOLIC PROCEDURE ParseLPAR X; BEGIN SCALAR RES; IF X EQ '!*RPAR!* THEN <<OP := X; RES := '!*EMPTY!*>> ELSE RES:= RDRIGHT(2,X); IF OP EQ '!*RPAR!* THEN OP := SCAN() ELSE PARERR("Missing ) after argument list",NIL); RETURN RES END; % ***** Left and Right << and >> Handling *****; DEFINEROP('!*LSQB!*,-2,ParseRSQB); SYMBOLIC PROCEDURE ParseRSQB(X); IF OP EQ '!*RSQB!* THEN <<OP := SCAN(); 'PROGN . REMSEMICOL X>> ELSE PARERR("Missing right >> after Group",NIL); DEFINEBOP('!*RSQB!*,-3,0); %COMMENT ***** [] vector syntax; REMPROP('![,'NEWNAM); REMPROP('!],'NEWNAM); % ***** [] vector syntax; DEFINEBOP('!*LVEC!*,121,6,ParseLVEC); SYMBOLIC PROCEDURE ParseLVEC(X,Y); IF OP EQ '!*RVEC!* THEN <<OP :=SCAN(); LIST('INDX,X,Y)>> ELSE PARERR("Missing ] in index expression ",NIL); % INDX is used for both Vectors and Strings in PSL. You will need to % have INDX map to GETV in vanilla Standard Lisp DEFINEBOP('!*RVEC!*,5,7); % ***** Lambda Expression *****; DEFINEROP('LAMBDA,0,ParseLAMBDA); SYMBOLIC PROCEDURE ParseLAMBDA X; LIST('LAMBDA,IF X AND X NEQ '!*EMPTY!* THEN REMCOM X ELSE NIL, PARSE0(6,T)); % ***** Repeat Expression *****; DEFINEROP('REPEAT,4,ParseREPEAT); SYMBOLIC PROCEDURE ParseREPEAT X; LIST('REPEAT,X, IF OP EQ 'UNTIL THEN PARSE0(6,T) ELSE PARERR("REPEAT missing UNTIL clause",T)) ; DEFINEBOP('UNTIL,3,6); % ***** While Expression *****; DEFINEROP('WHILE,4, ParseWHILE); SYMBOLIC PROCEDURE ParseWHILE X; LIST('WHILE,X, IF OP EQ 'DO THEN PARSE0(6,T) ELSE PARERR("WHILE missing DO clause",T)) ; DEFINEBOP('DO,3,6); % ***** Declare Expression *****; DEFINEROP('DECLARE,2,ParseDECL); DEFINEROP('DCL,2,ParseDECL); SYMBOLIC PROCEDURE ParseDECL X; BEGIN SCALAR Y,Z; A: IF OP NEQ '!*COLON!* THEN PARERR("DECLARE needs : before mode",T); IF (Z := SCAN()) MEMQ '(INTEGER REAL SCALAR) THEN OP := SCAN() ELSE Z := PARSE0(6,NIL); Y := ACONC(Y,Z . REMCOM X); IF OP EQ '!*SEMICOL!* THEN RETURN 'DECLARE . Y ELSE IF OP NEQ '!*COMMA!* THEN PARERR("DECLAREd variables separated by ,",T); X := PARSE0(2,T); GO TO A END; SYMBOLIC FEXPR PROCEDURE DECLARE U; %to take care of top level declarations; <<LPRIM "Declarations are not permitted at the top level"; NMODESTAT U>>; % ***** For Expression *****; DEFINEROP('FOR,NIL,ParseFOR); DEFINEBOP('STEP,3,6); DEFINEBOP('SUM,3,6); DEFINEBOP('PRODUCT,3,6); SYMBOLIC PROCEDURE ParseFOR X; BEGIN SCALAR INIT,STP,UNTL,ACTION,ACTEXPR; IF X EQ 'EACH THEN RETURN ParseFOREACH SCAN() ELSE IF X EQ 'ALL THEN RETURN ParseFORALL PARSE0(4,T) ELSE IF (OP := SCAN()) EQ 'SETQ THEN INIT := PARSE0(6,T) ELSE PARERR("FOR missing loop VAR assignment",T); IF OP EQ '!*COLON!* THEN <<STP := 1; OP := 'UNTIL>> ELSE IF OP EQ 'STEP THEN STP := PARSE0(6,T) ELSE PARERR("FOR missing : or STEP clause",T); IF OP EQ 'UNTIL THEN UNTL := PARSE0(6,T) ELSE PARERR("FOR missing UNTIL clause",T); ACTION := OP; IF ACTION MEMQ '(DO SUM PRODUCT) THEN ACTEXPR := PARSE0(6,T) ELSE PARERR("FOR missing action keyword",T); RETURN LIST('FOR, LIST('FROM,X,INIT,UNTL,STP), LIST(ACTION,ACTEXPR)) END; % ***** Foreach Expression *****; DEFINEROP('FOREACH,NIL,ParseFOREACH); DEFINEBOP('COLLECT,3,6); DEFINEBOP('CONC,3,6); DEFINEBOP('JOIN,3,6); SYMBOLIC PROCEDURE ParseFOREACH X; BEGIN SCALAR L,INON,ACTION; IF NOT ((INON := SCAN()) EQ 'IN OR INON EQ 'ON) THEN PARERR("FOR EACH missing iterator clause",T); L := PARSE0(6,T); IF NOT ((ACTION := OP) MEMBER '(DO COLLECT CONC JOIN)) THEN PARERR("FOR EACH missing action clause",T); RETURN LIST('FOREACH,X,INON,L,ACTION,PARSE0(6,T)) END; % ***** Let Expression *****; DEFINEBOP('LET,1,0,ParseLET); DEFINEROP('LET,0,ParseLET(NIL . NIL,X) ); DEFINEBOP('CLEAR,0,1,ParseCLEAR); DEFINEROP('CLEAR,0,ParseCLEAR(NIL . NIL,X)); DEFINEBOP('SUCH,3,6); SYMBOLIC PROCEDURE ParseLET(X,Y); ParseLET1(X,Y,NIL); SYMBOLIC PROCEDURE ParseCLEAR(X,Y); ParseLET1(X,Y,T); SYMBOLIC PROCEDURE ParseLET1(X,Y,Z); LIST('LET!*,CAR X,REMCOM Y,CDR X,NIL,Z); SYMBOLIC PROCEDURE ParseFORALL X; BEGIN SCALAR BOOL; IF OP EQ 'SUCH THEN IF SCAN() EQ 'THAT THEN BOOL := PARSE0(6,T) ELSE PARERR("FOR ALL missing SUCH THAT clause",T); IF NOT OP MEMQ '(LET CLEAR) THEN PARERR("FOR ALL missing ACTION",T); RETURN REMCOM X . BOOL END; % ******** Standard Qoted LIST collectors SYMBOLIC PROCEDURE RLISF(U,V,W); %. Used to Collect a list of IDs to %. FLAG with Something BEGIN V := RDRIGHT(0,V); V := IF EQCAR(V,'!*COMMA!*) THEN CDR V ELSE IF V THEN LIST V ELSE V; RETURN FLAG(V,U) END; SYMBOLIC PROCEDURE FLAGOP U; %. Declare U as Flagger RLISTAT(U,'FLAGOP); SYMBOLIC PROCEDURE RLISTAT(OPLIST,B); %. Declare els of OPLIST to be RLIS FOR EACH U IN OPLIST DO DEFINEROPX LIST(MKQUOTE U,NIL, LIST(IF B EQ 'FLAGOP THEN 'RLISF ELSE 'RLIS1, MKQUOTE U,'X,MKQUOTE B)); SYMBOLIC PROCEDURE RLIS1(U,V,W); %. parse LIST of args, maybe quoted % U=funcname, V=following Phrase, W=arg treatment BEGIN IF V EQ '!*SEMICOL!* THEN RETURN <<OP := V; IF W = 'NOQUOTE THEN LIST U ELSE LIST(U, NIL) >> ELSE V := RDRIGHT(0,V); V := IF EQCAR(V,'!*COMMA!*) THEN CDR V ELSE IF V THEN LIST V ELSE V; IF W EQ 'IO THEN V := MAPCAR(V,FUNCTION (LAMBDA J; NEWMKFIL J)); RETURN IF W EQ 'NOQUOTE THEN U . V ELSE LIST(U,MKQUOTLIST V) END; % ***** Parsing Rules For Various IO Expressions *****; RLISTAT('(IN OUT SHUT),'NOQUOTE); RLISTAT('(TR UNTR BR UNBR),'NOQUOTE); % for mini-trace in PSL RLISTAT('(LOAD HELP), 'NOQUOTE); FLAG('(IN OUT SHUT ON OFF TR UNTR UNTRST TRST),'NOCHANGE); % No REVAL of args DEFINEROP('FSLEND,NIL,ESTAT('FasLEND)); DEFINEROP('FaslEND,NIL,ESTAT('FaslEND)); RLISTAT('(WRITE),'NOQUOTE); RLISTAT('(ARRAY),1); % 2.11.3 ON/OFF STATEMENTS RLISTAT('(ON OFF), 'NOQUOTE); % ***** Parsing Rules for INTEGER/SCALAR/REAL *****; % These will eventually be removed in favor of DECLARE; DEFINEROP('INTEGER,0,ParseINTEGER); SYMBOLIC PROCEDURE ParseINTEGER X; LIST('DECLARE,REPCOM('INTEGER,X)); DEFINEROP('REAL,0,ParseREAL); SYMBOLIC PROCEDURE ParseREAL X; LIST('DECLARE,REPCOM('REAL,X)); DEFINEROP('SCALAR,0,ParseSCALAR); SYMBOLIC PROCEDURE ParseSCALAR X; LIST('DECLARE,REPCOM('SCALAR,X)); %/ Cuase problems in INTEGER procedure foo;... SYMBOLIC PROCEDURE COMM1 U; %. general Comment Parser BEGIN IF U EQ 'END THEN SCAN(); A: IF CURSYM!* EQ '!*SEMICOL!* OR U EQ 'END AND CURSYM!* MEMQ '(END ELSE UNTIL !*RPAR!* !*RSQB!*) THEN RETURN NIL; SCAN(); GOTO A; END; SYMBOLIC PROCEDURE ESTAT(FN); %. returns (FN), dropping till semicol ; BEGIN WHILE CURSYM!* NEQ '!*SEMICOL!* DO SCAN(); OP := '!*SEMICOL!*; RETURN LIST(FN); END; SYMBOLIC PROCEDURE ENDSTAT; %This procedure can also be used for any key-words which take no %arguments; BEGIN SCALAR X; X := OP; COMM1 'END; OP := '!*SEMICOL!*; RETURN LIST X END; % Some useful ESTATs: DEFINEROP('QUIT,NIL,ESTAT('QUIT)); DEFINEROP('PAUSE,NIL,ESTAT('PAUSE)); DEFINEROP('CONT,NIL,ESTAT('CONT)); DEFINEROP('RECLAIM,NIL,ESTAT('RECLAIM)); DEFINEROP('RETRY,NIL,ESTAT('RETRY)); DEFINEROP('SHOWTIME,NIL,ESTAT('SHOWTIME)); FLAG('(FSLEND CONT RECLAIM RETRY SHOWTIME QUIT PAUSE),'OPFN); % Symbolic OPS, or could use NOCHANGE RLISTAT('(FLAGOP),1); CommentOutCode << SYMBOLIC PROCEDURE INFIX X; % Makes Left ASSOC, not like CONS FOR EACH Y IN X DO DEFINEBOPX LIST(MKQUOTE Y,8,9,NIL); >>; FLAG('(NEWTOK),'EVAL); SYMBOLIC PROCEDURE PRECEDENCE U; PRECSET(CAR U,CADR U); SYMBOLIC PROCEDURE PRECSET(U,V); BEGIN SCALAR Z; IF NULL (Z := INFIXOP V) OR NULL (Z := CDR Z) THEN REDERR LIST(V,"NOT INFIX") ELSE DEFINEBOPX LIST(MKQUOTE U,CAR Z,CADR Z,NIL) END; RLISTAT('(INFIX PRECEDENCE),3); REMPROP('SHOWTIME,'STAT); %********************************************************************* % DEFINE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE ParseDEFINE(X); % X is following Token BEGIN SCALAR Y,Z; B: IF X EQ '!*SEMICOL!* THEN RETURN <<OP:='!*SEMICOL!*; MKPROG(NIL,Z)>> ELSE IF X EQ '!*COMMA!* THEN <<X:=SCAN(); %/ Should use SCAN0 GO TO B>> ELSE IF NOT IDP X THEN GO TO ER; Y := SCAN(); IF NOT (Y EQ 'EQUAL) THEN GO TO ER; Z := ACONC(Z,LIST('PUT,MKQUOTE X,MKQUOTE 'NEWNAM, MKQUOTE PARSE0(6,T))); % So doesnt include , X := CURSYM!*; GO TO B; ER: SYMERR('DEFINE,T) END; DEFINEROP('DEFINE,NIL,ParseDEFINE); FLAG('(DEFINE),'EVAL); %********************************************************************* % 3.2.4 WRITE STATEMENT %********************************************************************; SYMBOLIC PROCEDURE ParseWRITE(X); BEGIN SCALAR Y,Z; X := REMCOM XREAD1 'LAMBDA; A: IF NULL X THEN RETURN MKPROG(NIL,'(TERPRI) . Y); Z := LIST('PRIN2,CAR X); IF NULL CDR X THEN Z := LIST('RETURN,Z); B: Y := ACONC(Y,Z); X := CDR X; GO TO A; END; DEFINEROP('WRITE,NIL,ParseWRITE); %********************************************************************* % VARIOUS DECLARATIONS %********************************************************************; SYMBOLIC PROCEDURE ParseOPERATOR(X); BEGIN SCALAR Y; Y := REMCOM PARSE0(0,NIL); RETURN IF !*MODE EQ 'SYMBOLIC THEN MKPROG(NIL,LIST LIST('FLAG,MKQUOTE Y,MKQUOTE 'OPFN)) ELSE IF X NEQ 'OPERATOR THEN IF EQCAR(CAR Y,'PROG) THEN CAR Y ELSE X . MAPCAR(LIST Y,FUNCTION MKARG) ELSE IF KEY!* NEQ 'OPERATOR AND GET(KEY!*,'FN) THEN (LAMBDA K; MKPROG(NIL,MAPCAR(Y,FUNCTION (LAMBDA J; LIST('FLAG,LIST('LIST,MKQUOTE J), K,K))))) MKQUOTE GET(KEY!*,'FN) ELSE MKPROG(NIL, LIST LIST('OPERATOR,MKQUOTE Y)) END; SYMBOLIC PROCEDURE OPERATOR U; MAPCAR(U,FUNCTION MKOP); DEFINEROP('OPERATOR,NIL,ParseOPERATOR); %. Diphthongs and READtable Changes Symbolic Procedure ChangeCharType(TBL,Ch,Ty); %. Set Character type begin scalar IDNum; If IDP Ch and (IDNum := ID2Int Ch) < 128 and Numberp Ty and Ty >=0 and Ty <=19 then PutV(TBL,IDNum,Ty) Else Error(99,"Cant Set ReadTable"); end; Symbolic Procedure MakeDiphthong(TBL,DipIndicator,StartCh, FollowCh, Diphthong); If IDP Startch and IDP FollowCh and IDP Diphthong then <<ChangeCharType(TBL,StartCh,13); PUT(StartCh,DipIndicator, (FollowCh . Diphthong) . GET(StartCh,DipIndicator))>> else Error(99, "Cant Declare Diphthong"); SYMBOLIC PROCEDURE MYNEWTOK(X,REPLACE,PRTCHARS); BEGIN SCALAR Y; PUT(X,'NEWNAM!-OP,REPLACE); IF NULL PRTCHARS THEN Y:=LIST(X,X) ELSE IF IDP PRTCHARS THEN Y:=LIST(PRTCHARS,X) ELSE Y:=PRTCHARS; PUT(REPLACE,'PRTCH,Y); END; MYNEWTOK('!;,'!*SEMICOL!*,NIL)$ MYNEWTOK('!$,'!*SEMICOL!*,NIL)$ MYNEWTOK('!,,'!*COMMA!*,NIL)$ MYNEWTOK('!.,'CONS,NIL)$ MYNEWTOK('!:!=,'SETQ,'! !:!=! )$ MYNEWTOK('!+,'PLUS,'! !+! )$ MYNEWTOK('!-,'DIFFERENCE,'! !-! )$ MYNEWTOK('!*,'TIMES,NIL)$ MYNEWTOK('!/,'QUOTIENT,NIL)$ MYNEWTOK('!*!*,'EXPT,NIL)$ MYNEWTOK('!^,'EXPT,NIL)$ MYNEWTOK('!=,'EQUAL,NIL)$ MYNEWTOK('!:,'!*COLON!*,NIL)$ MYNEWTOK('!(,'!*LPAR!*,NIL)$ MYNEWTOK('!),'!*RPAR!*,NIL)$ MYNEWTOK('!{,'!*LSQB!*,NIL)$ MYNEWTOK('!},'!*RSQB!*,NIL)$ MYNEWTOK('!<!<,'!*LSQB!*,NIL)$ MYNEWTOK('!>!>,'!*RSQB!*,NIL)$ MYNEWTOK('![,'!*LVEC!*,NIL)$ MYNEWTOK('!],'!*RVEC!*,NIL)$ MYNEWTOK('!<,'LESSP,NIL)$ MYNEWTOK('!<!=,'LEQ,NIL)$ MYNEWTOK('!>!=,'GEQ,NIL)$ MYNEWTOK('!>,'GREATERP,NIL)$ fluid '(RLispScanTable!* RLispReadScanTable!*); RLispReadScanTable!* := ' [17 11 11 11 11 11 11 11 11 17 17 11 17 17 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 11 17 14 15 11 11 12 11 11 11 11 13 19 11 18 20 11 0 1 2 3 4 5 6 7 8 9 13 11 13 11 13 11 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 16 11 11 10 11 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 10 11 11 11 11 11 LispDiphthong]; RLispScanTable!* := TotalCopy RLispReadScanTable!*; PutV(RLispScanTable!*, 128, 'RLISPDIPHTHONG); ChangeCharType(RLispScanTable!*, '!-, 11); ChangeCharType(RLispScanTable!*, '!+, 11); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!:,'!=,'!:!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!<,'!=,'!<!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!>,'!=,'!>!= ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!<,'!<,'!<!< ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!>,'!>,'!>!> ); MAKEDIPHTHONG(RLISPSCANTABLE!*,'RLISPDIPHTHONG,'!*,'!*,'!*!* ); Symbolic Procedure XReadEof(Channel,Ef); if !*InsideStructureRead then StdError BldMsg("Unexpected EOF while parsing on channel %r", Channel) else Throw('!$ERROR!$, list !$EOF!$); % embarrasingly gross kludge Put(Int2ID char EOF, 'RlispReadMacro, 'XReadEOF); Symbolic Procedure RatomHOOK(); %. To get READ MACRO', EG EOF ChannelReadTokenWithHooks IN!*; lisp procedure RlispChannelRead Channel; %. Parse S-expression from channel begin scalar CurrentScanTable!*, CurrentReadMacroIndicator!*, CurrentDiphthongIndicator!*; CurrentScanTable!* := RLispReadScanTable!*; CurrentReadMacroIndicator!* := 'LispReadMacro; CurrentDiphthongIndicator!* := 'LispDiphthong; return ChannelReadTokenWithHooks Channel; end; lisp procedure RlispRead(); %. Parse S-expr from current input RlispChannelRead IN!*; END;