Artifact 0a7859a076621ab369f9765a5b312c29eab92fd8fb2e4c5740d10d31ae51ca2e:
- File
psl-1983/3-1/util/mini-support.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: 15295) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/mini-support.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: 15295) [annotate] [blame] [check-ins using]
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % % % % % MINI % % (A SMALL META SYSTEM) % % % % % % Copyright (c) Robert R. Kessler 1979 % % Mods: MLG, Feb 1981 % % % This file is the support routines. % % The file MINI.MIN contains the MINI % % system self definition and MINI.SL % % is the Standard LISP translation % % of MINI.MIN. % % % %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% GLOBAL '(!#KEY!# !#DIP!# !*MDEFN !#STACK!# !#STACK!-ELE!# !#TOK!# !#TOKTYPE!# !#NTOK!# !#LABLIST!# SINGLEOP!* FAILURE!* INDEXLIST!* !#RT!# !#GT!# !#RTNOW!# !#GTNOW!# !#IDTYPE!# !#NUMTYPE!# !#STRTYPE!# !#GENLABLIST!#); % Global description: % !#DIP!# - List of diphthongs for grammar being defined. % FAILURE!* - Value of failed match in pattern matcher. % !#GENLABLIST!# - List of generated labels used in push/pop lab. % !#GT!# - List of grammar terminators for invoked grammar. % !#GTNOW!# - List of grammar terminators for grammar being def. % !#IDTYPE!# - The value of toktype for id's (0) % INDEXLIST!* - List of number value pairs for pattern matcher. % !#KEY!# - List of key workds for grammar being defined. % !#LABLIST!# - The list of gensymed labels ($n). % !*MDEFN - Flag to MPRINT (ON) or EVAL (OFF) defined rule. % !#NUMTYPE!# - The value of toktype for numbers (2) % !#NTOK!# - Next token, used for diphthong checking. % !#RT!# - List of rule terminators for invoked grammar. % !#RTNOW!# - List of rule terminators for grammar being defined. % SINGLEOP!* - The operator for any match pattern (&). % !#STACK!# - The stack list: push +, pop #n , ref ##n % !#STACK!-ELE!# - Used to pass info between stack operations % !#SPECTYPE!# - The value of toktype for specials (3) % !#STRTYPE!# - The value of toktype for strings (1) % !#TOK!# - The current token % !#TOKTYPE!# - The type of the token from rSYMBOLIC Parser % (0-id, 1-str, 2-num, 3-special) % A grammar is defined by calling the function MINI with argument of % the name of the goal rule. i.e. MINI 'RUL redefines MINI itself. % Then to invoke a grammar, you use INVOKE goal rule name.(INVOKE 'RUL). SYMBOLIC PROCEDURE MINI U; << INVOKE 'RUL; RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE KEYS), LIST('QUOTE, !#KEY!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE DIPS), LIST('QUOTE, !#DIP!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE RTS), LIST('QUOTE, !#RT!#)); RULE!-DEFINE LIST ('PUT, LIST('QUOTE, U), '(QUOTE GTS), LIST('QUOTE, !#GT!#)); NIL >>; % Invoke starts execution of a previously defined grammar. SYMBOLIC PROCEDURE INVOKE U; BEGIN SCALAR X; !#IDTYPE!# := 0; !#NUMTYPE!# := 2; !#STRTYPE!# := 1; FLAG (GET (U, 'KEYS), 'KEY); DIPBLD (GET (U, 'DIPS)); !#RTNOW!# := GET (U, 'RTS); !#GTNOW!# := GET (U, 'GTS); !#DIP!# := !#KEY!# := !#RT!# := !#GT!# := !#GENLABLIST!# := NIL; L: !#STACK!# := NIL; NEXT!-TOK(); X := APPLY (U, NIL); IF NULL X THEN << ERROR!-PRINT(); IF SCAN!-TERM() THEN <<PRIN2 ("Resuming scan"); TERPRI(); GOTO L>> >>; REMFLAG (GET (U, 'KEYS), 'KEY) END; % The following errs out if its argument is NIL SYMBOLIC PROCEDURE FAIL!-NOT U; U OR <<ERROR!-PRINT(); ERROR(997,"Failure scanning a concatenation.")>>; % This procedure is called when a rule is defined. If ON MDEFN then the % value is MPRINTed, otherwise, it is evaled. SYMBOLIC PROCEDURE RULE!-DEFINE U; << IF !*MDEFN THEN MPRINT U ELSE EVAL U>>; % Mprint is used so it may be redefined if something other than PRINT % is desired when ON MDEFN is used. SYMBOLIC PROCEDURE MPRINT U; << TERPRI(); PRINT U>>; % Error-print is called when the major loop returns a NIL. SYMBOLIC PROCEDURE ERROR!-PRINT; <<PRIN2 "ERROR in grammar, current token is "; PRIN2 !#TOK!#; PRIN2 " and stack is "; PRIN2 !#STACK!#; TERPRI() >>; % Scan for a rule terminator or grammar terminator by fetching tokens. % Returns T if a rule terminator is found and NIL for a grammar term. % The rule terminator causes processing to continue after the terminator. % The grammar terminator ceases processing. SYMBOLIC PROCEDURE SCAN!-TERM; BEGIN SCALAR X; PRIN2 ("Scanning for rule terminator: "); PRIN2 !#RTNOW!#; PRIN2 (" or grammar terminator: "); PRIN2 !#GTNOW!#; TERPRI(); L: X := NEXT!-TOK(); IF MEMQ (X, !#GTNOW!#) THEN RETURN NIL ELSE IF MEMQ (X, !#RTNOW!#) THEN RETURN T ELSE GOTO L END; % Add the argument to the current key list, if not already there. SYMBOLIC PROCEDURE ADDKEY U; <<IF NOT MEMQ (U, !#KEY!#) THEN !#KEY!# := U . !#KEY!#; T>>; % Add the argument to the current grammar terminator list. SYMBOLIC PROCEDURE ADDGTERM U; <<IF NOT MEMQ (U, !#GT!#) THEN !#GT!# := U . !#GT!#; T>>; % Add the argument to the current rule terminator list. SYMBOLIC PROCEDURE ADDRTERM U; <<IF NOT MEMQ (U, !#RT!#) THEN !#RT!# := U . !#RT!#; T>>; % This procedure will take a list of identifiers and flag them as % diphthongs (2 character max). SYMBOLIC PROCEDURE DIPBLD U; BEGIN SCALAR W, X, Y; FOR EACH X IN U DO << IF NOT MEMQ (X, !#DIP!#) THEN !#DIP!# := X . !#DIP!#; Y := EXPLODE X; Y := STRIP!! Y; % Take out the escapes; W := GET (CAR Y, 'FOLLOW); % Property follow is list of legal dip terms; PUT (CAR Y, 'FOLLOW, (LIST (CADR Y, X)) . W) >>; RETURN T END; SYMBOLIC PROCEDURE UNDIPBLD U; BEGIN SCALAR W, X, Y; FOR EACH X IN U DO << Y := EXPLODE X; Y := STRIP!! Y; % Take out the escapes; REMPROP(CAR Y, 'FOLLOW) >>; RETURN T END; % Following procedure will eliminate the escapes in a list SYMBOLIC PROCEDURE STRIP!! U; IF PAIRP U THEN IF CAR U EQ '!! THEN CADR U . STRIP!! CDDR U ELSE CAR U . STRIP!! CDR U ELSE NIL; % Push something onto the stack; SYMBOLIC PROCEDURE PUSH U; !#STACK!# := U . !#STACK!#; % Reference a stack element SYMBOLIC PROCEDURE REF U; SCAN!-STACK (U, !#STACK!#); % Stack underflow is called then that error happens. Right now, it errors % out. Future enhancement is to make it more friendly to the user. SYMBOLIC PROCEDURE STACK!-UNDERFLOW; ERROR (4000, "Stack underflow"); % Like above, a stack error has occured, so quit the game. SYMBOLIC PROCEDURE STACK!-ERROR; ERROR (4001, "Error in stack access"); % Search stack for the element U elements from the top (1 is top). SYMBOLIC PROCEDURE SCAN!-STACK (U, STK); IF NULL STK THEN STACK!-UNDERFLOW () ELSE IF U = 1 THEN CAR STK ELSE SCAN!-STACK (U-1, CDR STK); % Remove the Uth element from the stack (1 is the top). SYMBOLIC PROCEDURE EXTRACT U; << !#STACK!# := FETCH!-STACK (U, !#STACK!#); !#STACK!-ELE!# >>; % Return the value found; % Recursive routine to remove the Uth element from the stack. SYMBOLIC PROCEDURE FETCH!-STACK (U, STK); BEGIN SCALAR X; IF NULL STK THEN STACK!-UNDERFLOW () ELSE IF U EQ 1 THEN <<!#STACK!-ELE!# := CAR STK; RETURN CDR STK>> ELSE RETURN CAR STK . FETCH!-STACK (U-1, CDR STK) END; % Retrieve the length of the stack. This is used to build a single % list used in repetition. It takes the top of the stack down to % the stack length at the beginning to build the list. Therefore, % STK!-LENGTH must be called prior to calling BUILD!-REPEAT, which % must be passed the value returned by the call to STK!-LENGTH. SYMBOLIC PROCEDURE STK!-LENGTH; LENGTH !#STACK!#; % The procedure to handle repetition by building a list out of the % top n values on the stack. SYMBOLIC PROCEDURE BUILD!-REPEAT U; BEGIN SCALAR V; V := STK!-LENGTH(); IF U > V THEN STACK!-ERROR() ELSE IF U = V THEN PUSH NIL ELSE IF U < V THEN BEGIN SCALAR L, I; % Build it for the top V-U elements L := NIL; FOR I := 1:(V-U) DO L := (EXTRACT 1) . L; PUSH L END; RETURN T END; % Actually get the next token, if !#NTOK!# has a value then use that, % else call your favorite token routine. % This routine must return an identifier, string or number. % If U is T then don't break up a quoted list right now. SYMBOLIC PROCEDURE GET!-TOK U; BEGIN SCALAR X; IF !#NTOK!# THEN << X := !#NTOK!#; !#NTOK!# := NIL; RETURN X >> ELSE << X := !%SCAN(); % Scan sets the following codes: % 0 - ID, and thus was escapeed % 1 - STRING % 2 - Integer % 3 - Special (;, (, ), etc.) % Therefore, it is important to distinguish between % the special and ID for key words. IF (X EQ 2) OR (X EQ 1) THEN RETURN (X . SCNVAL) ELSE RETURN (0 . INTERN SCNVAL) >> %//Ignore ESCAPE for now END; % Fetch the next token, if a diphthong, turn into an identifier SYMBOLIC PROCEDURE NEXT!-TOK; BEGIN SCALAR X,Y; !#TOK!# := GET!-TOK(NIL); !#TOKTYPE!# := CAR !#TOK!#; !#TOK!# := CDR !#TOK!#; IF (Y:=GET(!#TOK!#, 'FOLLOW)) THEN << !#NTOK!# := 0 . READCH(); % Use READCH since white space IF X := ATSOC(CDR !#NTOK!#, Y) THEN % within diphthong is illegal << !#TOK!# := CADR X; !#TOKTYPE!# := !#IDTYPE!# >> ELSE UNREADCH CDR !#NTOK!#; % Push the character back for the !#NTOK!# := NIL >>; % scanner if not part of diphthong RETURN !#TOK!# END; SYMBOLIC PROCEDURE T!-NTOK; <<NEXT!-TOK(); 'T>>; SYMBOLIC PROCEDURE EQTOK(X); % Test Token Value EQUAL(!#TOK!#,X); % maybe use EQ? SYMBOLIC PROCEDURE EQTOK!-NEXT(X); EQTOK(X) AND T!-NTOK(); % See if current token is an identifier and not a keyword. If it is, % then push onto the stack and fetch the next token. SYMBOLIC PROCEDURE ID; IF !#TOKTYPE!# EQ !#IDTYPE!# AND NOT FLAGP(!#TOK!#,'KEY) THEN <<PUSH !#TOK!#; IF NOT (MEMQ (!#TOK!#, !#GTNOW!#) OR MEMQ(!#TOK!#, !#RTNOW!#)) THEN NEXT!-TOK(); T>> ELSE NIL; % See if current token is an id whether or not it is a keyword. SYMBOLIC PROCEDURE ANYID; IF (!#TOKTYPE!# EQ !#IDTYPE!#) THEN % (!#TOKTYPE!# EQ !#SPECTYPE!#) OR FLAGP(!#TOK!#, 'KEY) THEN ANYTOK() ELSE NIL; % Always succeeds by pushing the current token onto the stack. SYMBOLIC PROCEDURE ANYTOK; <<PUSH !#TOK!#; NEXT!-TOK(); T>>; % Tests to see if the current token is a number, if so it pushes the % number onto the stack and fetches the next token. SYMBOLIC PROCEDURE NUM; IF (!#TOKTYPE!# EQ !#NUMTYPE!#) THEN ANYTOK() ELSE NIL; % Same as NUM, except for strings. SYMBOLIC PROCEDURE STR; IF (!#TOKTYPE!# EQ !#STRTYPE!#) THEN ANYTOK() ELSE NIL; % Generate a label. If the label has been previously generated, the % return the old value. (used by $n). SYMBOLIC PROCEDURE GENLAB U; BEGIN SCALAR X; IF X:=ASSOC(U, !#LABLIST!#) THEN RETURN CADR X; X:=INTERN GENSYM(); !#LABLIST!# := LIST(U, X) . !#LABLIST!#; RETURN X END; % Push the current label lists so we don't get any conflicts. LISP PROCEDURE PUSH!-LAB; << !#GENLABLIST!# := !#LABLIST!# . !#GENLABLIST!#; !#LABLIST!# := NIL; T>>; % Pop label lists. LISP PROCEDURE POP!-LAB; <<!#LABLIST!# := CAR !#GENLABLIST!#; !#GENLABLIST!# := CDR !#GENLABLIST!#; T>>; GLOBAL '(!*DO!#); ON DO!#; FLUID '(NEWENV!*); % RBMATCH will accept a list of rules and subject list and % search for a match on one of the rules. Upon finding the % match, the body will be executed. SYMBOLIC PROCEDURE RBMATCH (SUBLIST, RULESLIST, INITENV); BEGIN SCALAR TEMP, ENVLIST, RULFOUND, RVAL, TRYAGAIN, SN; % IF NUMARGS() EQ 4 THEN TRYAGAIN := T ELSE TRYAGAIN := NIL; % IF NUMARGS() > 2 THEN INITENV := ARGUMENT(3) ELSE INITENV:=NIL; RVAL := FAILURE!*; WHILE RULESLIST DO << RULFOUND := CAR RULESLIST; RULESLIST := CDR RULESLIST; ENVLIST := LIST (LIST (0, SUBLIST)); IF INITENV THEN ENVLIST := APPEND (ENVLIST, INITENV); IF (NEWENV!* := PEVAL (CAR RULFOUND, SUBLIST, ENVLIST)) NEQ FAILURE!* THEN IF (TEMP := EVAL (LIST (CDR RULFOUND, 'NEWENV!*, NIL, NIL, NIL))) NEQ FAILURE!* THEN IF TEMP EQ 'FAIL THEN <<RVAL := NIL; RETURN NIL>> ELSE IF TRYAGAIN THEN << PRIN2T ("Success, will try again"); RVAL := APPEND (TEMP, RVAL) >> ELSE <<RVAL := TEMP; RETURN TEMP >> >>; RETURN RVAL END RBMATCH; % % PEVAL accepts a subjectlist, a pattern and an environment. % It then determines if the subjectlist matches the pattern % with the particular environment. The pattern may contain % lists or variable expressions. The variable expressions are % of two form: & "ATOM" which will match a single list or % ATOM and & & "ATOM" which will test to see if the match is % equal to a previously matched item. %; SINGLEOP!* := '&; FAILURE!* := NIL; SYMBOLIC PROCEDURE PEVAL(P, S, ENV); IF P EQ S THEN LIST ENV ELSE IF EQCAR (S, '!#) AND !*DO!# THEN TST!#(P, S, ENV) ELSE IF ATOM P THEN NIL ELSE IF CAR P EQ SINGLEOP!* THEN TST!-SINGLE(P, S, ENV) ELSE IF ATOM S THEN NIL ELSE BEGIN SCALAR ENVL; ENVL := PEVAL (CAR P, CAR S, ENV); RETURN PEVALL (CDR P, CDR S, ENVL) END; SYMBOLIC PROCEDURE PEVALL (P, S, ENVL); IF NULL ENVL THEN NIL ELSE IF NULL CDR ENVL THEN PEVAL (P, S, CAR ENVL) ELSE APPEND (PEVAL(P, S, CAR ENVL), PEVALL(P, S, CDR ENVL)); SYMBOLIC PROCEDURE TST!-SINGLE (P, S, ENV); BEGIN SCALAR IDX; IF LENGTH (IDX := CDR P) NEQ 1 THEN << IF CAR IDX EQ SINGLEOP!* THEN (IF EQUAL (S, CADR ASSOC (CADR IDX, ENV)) THEN RETURN LIST (ENV)) ELSE IF MEMBER (S, CAR IDX) THEN RETURN LIST (LIST(CADR IDX, S) . ENV); RETURN FAILURE!* >>; RETURN LIST (LIST (CAR IDX, S) . ENV) END; SYMBOLIC PROCEDURE TST!# (P, S, ENV); BEGIN SCALAR OLST, N, ENVL, CLST, X; OLST := CADR S; N := CADDR S; ENVL := NIL; L: IF NULL OLST THEN RETURN ENVL; CLST := CAR OLST; X := PEVAL (P, CLST, ENV); OLST := CDR OLST; FOR EACH Y IN X DO ENVL := (LIST (N, CLST) . Y) . ENVL; GO TO L END; END;