Artifact 1fc7f561d9c18bb7c0ef4491f9570105c1ce5d36340847c588b5286c63db02df:
- Executable file
r37/packages/gentran/gparser.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7239) [annotate] [blame] [check-ins using] [more...]
- Executable file
r38/packages/gentran/gparser.red
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 7239) [annotate] [blame] [check-ins using]
module gparser; %% GENTRAN Parser Module %% %% Author: Barbara L. Gates %% %% December 1986 %% % Entry Point: GentranParse symbolic$ % GENTRAN Global Variable % global '(!*reservedops!*)$ !*reservedops!* := '(and rblock cond difference equal expt for geq go greaterp leq lessp mat minus neq not or plus procedure progn quotient read recip repeat return setq times while write)$ %reserved operators symbolic procedure gentranparse forms; begin scalar found_error; for each f in forms do if not(gpstmtp f or gpexpp f or gpdefnp f) then << gentranerr('e, f, "CANNOT BE TRANSLATED", nil); % If we are processing a template (for example) then this will % not result in a hard error, so make Gentran aware that % something went wrong: found_error := 't; >>; return not found_error; end$ procedure gpexpp exp; % exp ::= id | number | (PLUS exp exp') | (MINUS exp) | % % (DIFFERENCE exp exp) | (TIMES exp exp exp') | % % (RECIP exp) |(QUOTIENT exp exp) | (EXPT exp exp) | (id arg') % if atom exp then idp exp or numberp exp else if car exp memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then t else if car exp eq 'plus then length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp else if car exp memq '(minus recip) then length exp=2 and gpexpp cadr exp else if car exp memq '(difference quotient expt) then length exp=3 and gpexpp cadr exp and gpexpp caddr exp else if car exp eq 'times then length exp >= 3 and gpexpp cadr exp and gpexpp caddr exp and gpexp1p cdddr exp else if car exp eq '!:rd!: then t else if car exp memq '(!:cr!: !:crn!: !:gi!:) then t else if unresidp car exp then gparg1p cdr exp$ procedure gpexp1p exp; % exp' ::= exp exp' | eps % null exp or (gpexpp car exp and gpexp1p cdr exp)$ procedure gplogexpp exp; % logexp ::= id | (EQUAL exp exp) | (NEQ exp exp) | % % (GREATERP exp exp) |(GEQ exp exp) | (LESSP exp exp) | % % (LEQ exp exp) | (NOT logexp) | (AND logexp logexp logexp')% % | (OR logexp logexp logexp') | (id arg') % if atom exp then idp exp else if car exp memq '(equal neq greaterp geq lessp leq) then length exp=3 and gpexpp cadr exp and gpexpp caddr exp else if car exp eq 'not then length exp=2 and gplogexpp cadr exp else if car exp memq '(and or) then length exp >= 3 and gplogexpp cadr exp and gplogexpp caddr exp and gplogexp1p cdddr exp else if unresidp car exp then gparg1p cdr exp$ procedure gplogexp1p exp; % logexp' ::= logexp logexp' | eps % null exp or (gplogexpp car exp and gplogexp1p cdr exp)$ procedure gpargp exp; % arg ::= string | exp | logexp % stringp exp or gpexpp exp or gplogexpp exp$ procedure gparg1p exp; % arg' ::= arg arg' | eps % null exp or (gpargp car exp and gparg1p cdr exp)$ procedure gpvarp exp; % var ::= id | (id exp exp') % if atom exp then idp exp else if unresidp car exp then length exp >= 2 and gpexpp cadr exp and gpexp1p cddr exp$ procedure gplistp exp; % list ::= (exp exp') % if pairp exp then length exp >= 1 and gpexpp car exp and gpexp1p cdr exp$ procedure gplist1p exp; % list' ::= list list' | eps % null exp or (gplistp car exp and gplist1p cdr exp)$ procedure gpid1p exp; % id' ::= id id' | eps % null exp or (idp car exp and gpid1p cdr exp)$ procedure gpstmtp exp; % stmt ::= id | (SETQ setq') | (COND cond') | (WHILE logexp stmt) | % % (REPEAT stmt logexp) | (FOR var (exp exp exp) DO stmt) | % % (GO id) | (RETURN arg) | (WRITE arg arg') | % % (PROGN stmt stmt') | (BLOCK (id') stmt') | (id arg') % if atom exp then idp exp else if car exp memq '(!:rd!: !:cr!: !:crn!: !:gi!:) then nil else if car exp eq 'setq then gpsetq1p cdr exp else if car exp eq 'cond then gpcond1p cdr exp else if car exp eq 'while then length exp=3 and gplogexpp cadr exp and gpstmtp caddr exp else if car exp eq 'repeat then length exp=3 and gpstmtp cadr exp and gplogexpp caddr exp else if car exp eq 'for then length exp=5 and gpvarp cadr exp and pairp caddr exp and (length caddr exp=3 and gpexpp car caddr exp and gpexpp cadr caddr exp and gpexpp caddr caddr exp) and cadddr exp eq 'do and gpstmtp car cddddr exp else if car exp eq 'go then length exp=2 and idp cadr exp else if car exp eq 'return then length exp=2 and gpargp cadr exp else if car exp eq 'write then length exp >= 2 and gpargp cadr exp and gparg1p cddr exp else if car exp eq 'progn then length exp >= 2 and gpstmtp cadr exp and gpstmt1p cddr exp else if car exp eq 'rblock then length exp >= 2 and gpid1p cadr exp and gpstmt1p cddr exp else if unresidp car exp then gparg1p cdr exp$ procedure gpsetq1p exp; % setq' ::= id setq'' | (id exp exp') setq''' % if exp and length exp=2 then if atom car exp then idp car exp and gpsetq2p cdr exp else (length car exp >= 2 and idp car car exp and unresidp car car exp and gpexpp cadr car exp and gpexp1p cddr car exp) and gpsetq3p cdr exp$ procedure gpsetq2p exp; % setq'' ::= (MAT list list') | setq''' % if exp then if eqcar(car exp, 'mat) then onep length exp and (gplistp cadar exp and gplist1p cddar exp) else gpsetq3p exp$ procedure gpsetq3p exp; % setq''' ::= (FOR var (exp exp exp) forop exp) | (READ) | exp | logexp if exp and onep length exp then gpexpp car exp or gplogexpp car exp or (if caar exp eq 'for then length car exp=5 and gpvarp cadar exp and (pairp caddar exp and length caddar exp=3 and gpexpp car caddar exp and gpexpp cadr caddar exp and gpexpp caddr caddar exp) and gpforopp car cdddar exp and gpexpp cadr cdddar exp else if caar exp eq 'read then onep length car exp)$ procedure gpforopp exp; % forop ::= SUM | PRODUCT % exp memq '(sum product)$ procedure gpcond1p exp; % cond' ::= (logexp stmt) cond' | eps % null exp or (pairp car exp and length car exp=2 and gplogexpp caar exp and gpstmtp cadar exp and gpcond1p cdr exp)$ procedure gpstmt1p exp; % stmt' ::= stmt stmt' | eps % null exp or (gpstmtp car exp and gpstmt1p cdr exp)$ procedure gpdefnp exp; % defn ::= (PROCEDURE id NIL EXPR (id') stmt) % eqcar(exp, 'procedure) and length exp=6 and idp cadr exp and null caddr exp and atom cadddr exp and gpid1p car cddddr exp and gpstmtp cadr cddddr exp and not idp cadr cddddr exp$ %% %% %% Predicates %% %% %% procedure unresidp id; not (id memq !*reservedops!*)$ endmodule; end;