Artifact 5ee5e62cd502d5c5fe00422518770b04f8c7f573101fbe200da69eb242f4e057:
- File
psl-1983/comp/syslisp-syntax.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: 6222) [annotate] [blame] [check-ins using] [more...]
% % SYSLISP-SYNTAX.RED - SMacros and redefinition of arithmetic operators % and other syslisp syntax % % Author: Eric Benson and M. L. griss % Symbolic Computation Group % Computer Science Dept. % University of Utah % Date: 11 July 1981 % Copyright (c) 1981 University of Utah % fluid '(!*SYSLISP); % <PSL.COMP>SYSLISP-SYNTAX.RED.3, 5-May-82 11:33:48, Edit by BENSON % Wrapped if GetD 'BEGIN1 around parser calls % New WDECLARE constructs % Modify ***** [] vector syntax for PREFIX and INFIX forms % At lower prec SYMBOLIC PROCEDURE ParseLVEC(VNAME,VEXPR); IF OP EQ '!*RVEC!* THEN <<OP :=SCAN(); LIST('INDX,VNAME,VEXPR)>> ELSE PARERR("Missing ] in index expression "); % Use normal parsing, then CLEAN SYMBOLIC PROCEDURE ParseWDEC0(FN,DMODES,DLIST); BEGIN SCALAR PLIST; IF EQCAR(DLIST,'!*COMMA!*) THEN DLIST:=REVERSE CDR DLIST ELSE DLIST:=LIST DLIST; PLIST:=FOR EACH DEC IN DLIST COLLECT ParseWDEC1(FN,DEC); RETURN ('WDECLARE . DMODES . FN . REVERSE PLIST); END; SYMBOLIC PROCEDURE ParseWDEC1(FN,DEC); % Process each WDEC to check legal modes if EqCar(DEC,'EQUAL) THEN AConc(ParseWDEC2(FN,CADR DEC), ParseWDEC3(FN,CADDR DEC)) ELSE AConc(ParseWDEC2(FN,DEC), NIL); SYMBOLIC PROCEDURE ParseWDEC2(FN,X); % Remove INDXs from LHS of = IF IDP X THEN list(X, NIL) ELSE IF EQCAR(X,'INDX) THEN LIST(CADR X,CADDR X) ELSE PARERR "Only [] allowed on LHS of WDECLARATION"; SYMBOLIC PROCEDURE ParseWDEC3(FN,X); % Remove INDX's from RHS of = IF IDP X THEN X ELSE IF EQCAR(X,'INDX) THEN (IF CADR X EQ '!*PREFIXVECT!* THEN REMCOM(CADDR X) ELSE PARERR("Only [...] is legal INIT in WDECLARE")) ELSE X; if not FUnBoundP 'BEGIN1 then << % kludge #+Rlisp DEFINEBOP('!*LVEC!*,121,5,ParseLVEC); DEFINEROP('!*LVEC!*,5,ParseLVEC('!*PREFIXVECT!*,X)); DEFINEBOP('!*RVEC!*,4,5); DEFINEROP('WCONST,1,ParseWDEC0('WCONST,'DEFAULT,X)); DEFINEROP('WVAR,1,ParseWDEC0('WVAR,'DEFAULT,X)); DEFINEROP('WARRAY,1,ParseWDEC0('WARRAY,'DEFAULT,X)); DEFINEROP('WSTRING,1,ParseWDEC0('WSTRING,'DEFAULT,X)); DEFINEBOP('WCONST,1,1,ParseWDEC0('WCONST,X,Y)); DEFINEBOP('WVAR,1,1,ParseWDEC0('WVAR,X,Y)); DEFINEBOP('WARRAY,1,1,ParseWDEC0('WARRAY,X,Y)); DEFINEBOP('WSTRING,1,1,ParseWDEC0('WSTRING,X,Y)); % Operators @ for GetMem, & for Loc put('!@, 'NewNam, 'GetMem); put('!&, 'NewNam, 'Loc); >>; % SysName hooks for REFORM REMFLAG('(REFORM),'LOSE); SYMBOLIC PROCEDURE REFORM U; IF ATOM U OR CAR U MEMQ '(QUOTE WCONST) THEN U ELSE IF CAR U EQ 'COND THEN 'COND . REFORM CDR U ELSE IF CAR U EQ 'PROG THEN PROGN(RPLCDX(CDR U,REFORMLIS CDDR U),U) ELSE IF CAR U EQ 'LAMBDA THEN PROGN(RPLACA(CDDR U,REFORM CADDR U),U) ELSE IF CAR U EQ 'FUNCTION AND ATOM CADR U THEN BEGIN SCALAR X; IF NULL !*CREF AND (X:= GET(CADR U,'SMACRO)) THEN RETURN LIST('FUNCTION,X) ELSE IF GET(CADR U,'NMACRO) OR MACROP CADR U THEN REDERR "MACRO USED AS FUNCTION" ELSE RETURN U END % ELSE IF CAR U EQ 'MAT THEN RPLCDX(U,MAPC2(CDR U,FUNCTION REFORM)) ELSE IF ATOM CAR U THEN BEGIN SCALAR X,Y,FN; FN := CAR U; IF (Y := GETD FN) AND CAR Y EQ 'MACRO AND EXPANDQ FN THEN RETURN REFORM APPLY(CDR Y,LIST U); X := REFORMLIS CDR U; IF NULL IDP FN THEN RETURN(FN . X); IF !*SYSLISP AND (Y:=GET(FN,'SYSNAME)) THEN <<FN:=Y;U:=FN.CDR U>>; IF (NULL !*CREF OR EXPANDQ FN) AND (Y:= GET(FN,'NMACRO)) THEN RETURN APPLY(Y,IF FLAGP(FN,'NOSPREAD) THEN LIST X ELSE X) ELSE IF (NULL !*CREF OR EXPANDQ FN) AND (Y:= GET(FN,'SMACRO)) THEN RETURN SUBLIS(PAIR(CADR Y,X),CADDR Y) %we could use an atom SUBLIS here (eg, SUBLA); ELSE RETURN PROGN(RPLCDX(U,X),U) END ELSE REFORM CAR U . REFORMLIS CDR U; RemFlag('(Plus Times), 'NARY)$ DefList('((Plus WPlus2) (Plus2 WPlus2) (Minus WMinus) (Difference WDifference) (Times WTimes2) (Times2 WTimes2) (Quotient WQuotient) (Remainder WRemainder) (Mod WRemainder) (Land WAnd) (Lor WOr) (Lxor WXor) (Lnot WNot) (LShift WShift) (LSH WShift)), 'SysName); DefList('((Neq WNeq) (Equal WEq) (Eqn WEq) (Eq WEq) (Greaterp WGreaterp) (Lessp WLessp) (Geq WGeq) (Leq WLeq) (Getv WGetv) (Indx WGetv) (Putv WPutv) (SetIndx WPutv)), 'SysName); % modification to arithmetic FOR loop for SysLisp LISP PROCEDURE MKSYSFOR U; BEGIN SCALAR ACTION,BODY,EXP,INCR,LAB1,LAB2,RESULT,TAIL,VAR,X; VAR := second second U; INCR := cddr second U; if FixP third Incr or WConstEvaluable third Incr then return ConstantIncrementFor U; ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; X := LIST('WDIFFERENCE,first INCR,VAR); IF second INCR NEQ 1 THEN X := LIST('WTIMES2,second INCR,X); IF NOT ACTION EQ 'DO THEN REDERR "Only do expected in SysLisp FOR"; LAB1 := GENSYM(); LAB2 := GENSYM(); RESULT := NCONC(RESULT, LAB1 . LIST('COND,LIST(LIST('WLESSP,X,0),LIST('GO,LAB2))) . BODY . LIST('SETQ,VAR,LIST('WPLUS2,VAR,second INCR)) . LIST('GO,LAB1) . LAB2 . TAIL); RETURN MKPROG(VAR . EXP,RESULT) END; LISP PROCEDURE ConstantIncrementFor U; BEGIN SCALAR ACTION,BODY,EXP,INCR,LAB1,RESULT,VAR,X, StepValue, Limit; VAR := second second U; INCR := cddr second U; ACTION := first third U; BODY := second third U; RESULT := LIST LIST('SETQ,VAR,CAR INCR); INCR := CDR INCR; StepValue := if FixP second Incr then second Incr else WConstEvaluable second Incr; Limit := first Incr; IF NOT ACTION EQ 'DO THEN REDERR "Only do expected in SysLisp FOR"; LAB1 := GENSYM(); RESULT := NCONC(RESULT, LAB1 . LIST('COND,LIST(LIST(if MinusP StepValue then 'WLessP else 'WGreaterP, Var, Limit),'(return 0))) . BODY . LIST('SETQ,VAR,LIST('WPLUS2,VAR,StepValue)) . LIST('GO,LAB1) . NIL); RETURN MKPROG(VAR . EXP,RESULT) END; LISP PROCEDURE MKFOR1 U; IF !*SYSLISP THEN MKSYSFOR U ELSE MKLISPFOR U; PUTD('MKLISPFOR,'EXPR,CDR GETD 'FOR); % grab old FOR definition macro procedure For U; MkFor1 U; % redefine FOR END;