File psl-1983/3-1/util/mini-support.red artifact 0a7859a076 part of check-in 5f584e9b52


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


REDUCE Historical
REDUCE Sourceforge Project | Historical SVN Repository | GitHub Mirror | SourceHut Mirror | NotABug Mirror | Chisel Mirror | Chisel RSS ]