Artifact 767d0232b898957455c9ccd3dd6ecf502acbf9c2f0f6cf06652ae976ed5eb0b5:
- File
psl-1983/3-1/util/zmacro.lsp
— 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: 23285) [annotate] [blame] [check-ins using] [more...]
- File
psl-1983/util/zmacro.lsp
— 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: 23285) [annotate] [blame] [check-ins using]
(!* "ZMACRO contains two macro packages -- (1) YMACS -- basically useful macros and fexprs. (2) YSAIMACS -- macros used to simulate many SAIL constructs. ") (!* " YMACS -- USEFUL MACROS AND FEXPRS (see also YSAIMAC) * ( X:any ): NIL MACRO ** ( X:list ) MACRO NEQ ( X:any Y:any ):boolean MACRO NEQN ( X:any Y:any ):boolean MACRO NEQUAL ( X:any Y:any ):boolean MACRO MAKE ( variable template ) MACRO SETQQ ( variable value ) MACRO EXTEND ( function series ) MACRO DREVERSE( list ):list MACRO APPENDL ( lists ) MACRO NCONCL ( lists ) MACRO NCONC1 ( lst exp1 ... expn ): any MACRO SELECTQ ( exp cases last-resort ) MACRO WHILE ( test body ) MACRO REPEAT ( body test ) MACRO FOREACH ( var in/of lst do/collect exp ) MACRO SAY ( test expressions ) MACRO DIVERT ( channel expressions ) MACRO CAT ( list of any ):string MACRO CAT-ID ( list of any ):<uninterned id> MACRO TTY ( L:list ):NIL MACRO TTY-TX ( L:list ):NIL MACRO TTY-XT ( L:list ):NIL MACRO TTY-TT ( L:list ):NIL MACRO ERRSET ( expression label ) MACRO GRAB ( file ) MACRO GRABFNS ( ids file-dscr ) MACRO DUMP ( file-dscr ) MACRO DUMPFNS ( ids file-dscr ) MACRO used to expand macros: XP#SELECTQ (#L#) EXPR XP#WHILE (#BOOL #BODY) EXPR XP#FOREACH (#VAR #MOD #LST #ACTION #BODY) EXPR XP#SAY1 ( expression ) EXPR ") (GLOBAL '(!#SELECTQ G!:SHOW!:ERRORS G!:SHOW!:TRACE)) (!* "In ZBOOT, not needed here." (CDM !* (!#X) NIL) ) (!* "*( X:any ): NIL MACRO ===> NIL For comments--doesn't evaluate anything. Returns NIL. Note: expressions starting with * which are read by the lisp scanner must obey all the normal syntax rules.") (!* "**( X:list ) MACRO ===> (PROGN <lists>) For comments--all atoms are ignored, lists evaluated as in PROGN.") (CDM !*!* (!#X) (CONS 'PROGN (ABSTRACT (FUNCTION PAIRP) (CDR !#X)))) (!* "NEQ( X:any Y:any ):boolean MACRO ===> (NOT (EQ X Y)) ") (!* "Changed to CDM because NEQ in PSL means NOT EQUAL. We hope to change that situation, however.") (CDM NEQ (!#X) (LIST 'NOT (CONS 'EQ (CDR !#X)))) (!* "NEQN( X:any Y:any ):boolean MACRO ===> (NOT (EQN X Y)) ") (DM NEQN (!#X) (LIST 'NOT (CONS 'EQN (CDR !#X)))) (!* "NEQUAL( X:any Y:any ):boolean MACRO ===> (NOT (EQUAL X Y)) ") (DM NEQUAL (!#X) (LIST 'NOT (CONS 'EQUAL (CDR !#X)))) (!* "MAKE( variable template ) MACRO ===> (SETQ <var> <some form using var>) To change the value of a variable depending upon template. Uses similar format for template as editor MBD. There are 3 cases. 1) template is numerical: (MAKE VARIABLE 3) = (SETQ VARIABLE (PLUS VARIABLE 3)) 2) Template is a series, whose first element is an atom: (MAKE VARIABLE ASSOC ITEM) = (SETQ VARIABLE (ASSOC ITEM VARIABLE)) 3) Otherwise, variable is substituted for occurrences of * in template. (MAKE VARIABLE (ASSOC (CADR *) (CDDR *)) = (SETQ VARIABLE (ASSOC (CADR VARIABLE) (CDDR VARIABLE))") (CDM MAKE (!#X) (PROGN (SETQ !#X (CDR !#X)) (LIST 'SETQ (CAR !#X) (COND ((NUMBERP (CADR !#X)) (CONS 'PLUS !#X)) ((ATOM (CADR !#X)) (APPEND (CDR !#X) (LIST (CAR !#X)))) (T (SUBST (CAR !#X) '!* (CADR !#X))))))) (!* "SETQQ( variable value ) MACRO ===> (SETQ VARIABLE 'VALUE) ") (CDM SETQQ (!#X) (LIST 'SETQ (CADR !#X) (MKQUOTE (CADDR !#X)))) (!* "EXTEND( function series ) MACRO ===> (FN ELT1 (FN ELT2 ... (FN ELTn-1 ELTn))) Applies 2-place function to series, similarly to PLUS. E.g.: (EXTEND SETQ A B C D 5) = (SETQ A (SETQ B (SETQ C (SETQ D 5))))") (CDM EXTEND (!#X) (EXPAND (CDDR !#X) (CADR !#X))) (!* "DREVERSE( L: list ):list MACRO ===> (REVERSIP L) Synonym for REVERSIP.") (DM DREVERSE (!#X) (CONS 'REVERSIP (CDR !#X))) (!* "APPENDL( lists ) MACRO ===> (APPEND LIST1 (APPEND LIST2 ....)) EXPAND's APPEND to a list of arguments instead of just 2.") (CDM APPENDL (!#X) (EXPAND (CDR !#X) 'APPEND)) (!* "NCONCL( lists ) MACRO ===> (NCONC LST1 (NCONC LST2 ....)) EXPAND's NCONC to a list of arguments instead of just 2.") (CDM NCONCL (!#X) (EXPAND (CDR !#X) 'NCONC)) (!* "NCONC1( lst exp1 ... expn ): any MACRO ===> (NCONC LST (LIST EXP1 ... EXPn)) Destructively add exp1 ... exp-n to the end of lst.") (CDM NCONC1 (!#X) (LIST 'NCONC (CADR !#X) (CONS 'LIST (CDDR !#X)))) (!* "SELECTQ( exp cases last-resort ) MACRO ===> (COND ...) Exp is a lisp expression to be evaluated. Each case-i is of the form (key-i exp1 exp2...expm). Last-resort is a lisp expression to be evaluated. Generates a COND statement: If key-i is an atom, case-i becomes the cond-pair: ((EQUAL exp key-i) (PROGN exp1 exp2 ... expm)) If key-i is a list, case-i becomes the cond-pair: ((MEMBER exp key-i) (PROGN exp1 exp2 ... expm)) Last-resort becomes the final cond-pair: (T last-resort) If exp is non-atomic, it should not be re-evaluated in each clause, so a dummy variable (#SELECTQ) is set to the value of exp in the first test and that dummy variable is used in all successive tests. Note: (1) A FEXPR version of SELECTQ would forbid use of RETURN and GO. (2) The form created must NOT have a prog or lambda wrapped around the cond expression, as this would also forbid RETURN and GO. Since #SELECTQ can't be lambda-bound by any means whatsoever and remain consistent with the standard-lisp report (if GO or RETURN appears inside a consequent), there is no way we can make SELECTQ re-entrant. If you go into a break with ^B or ^H and execute another SELECTQ you will clobber the one and only incarnation of #SELECTQ, and if it happened to be in the middle of deciding which consequent to execute, then when you continue the computation it won't work correctly. Update -- IMSSS break pkg now tries to protect #SELECTQ. Update -- uses XP#SELECTQ which can be compiled to speed up macro expansion. ") (CDM SELECTQ (!#SLQ) (XP!#SELECTQ (CDR !#SLQ))) (DE XP!#SELECTQ (!#L!#) (PROG (!#FIRSTCL !#RESTCL !#RSLT) (SETQ !#RSLT (NCONS 'COND)) (COND ((ATOM (CAR !#L!#)) (SETQ !#FIRSTCL (SETQ !#RESTCL (CAR !#L!#)))) ((EQ (CAAR !#L!#) 'SETQ) (PROGN (SETQ !#FIRSTCL (CAR !#L!#)) (SETQ !#RESTCL (CADAR !#L!#)))) (T (SETQ !#FIRSTCL (LIST 'SETQ (SETQ !#RESTCL '!#SELECTQ) (CAR !#L!#))))) LP (COND ((CDR (SETQ !#L!# (CDR !#L!#))) (PROGN (NCONC !#RSLT (NCONS (CONS (LIST (COND ((ATOM (CAAR !#L!#)) 'EQUAL) (T 'MEMBER)) !#FIRSTCL (LIST 'QUOTE (CAAR !#L!#))) (COND ((NULL (CDDAR !#L!#)) (CDAR !#L!#)) (T (NCONS (CONS 'PROGN (CDAR !#L!#)))))))) (SETQ !#FIRSTCL !#RESTCL) (GO LP)))) (NCONC !#RSLT (NCONS (CONS T !#L!#))) (RETURN !#RSLT))) (!* "WHILE( test body ) MACRO ===> (PROG ...) <while loop> While test is true do body.") (!* (CDM WHILE (!#X) (XP!#WHILE (CADR !#X) (CDDR !#X))) (DE XP!#WHILE (!#BOOL !#BODY) (PROG (!#LAB) (SETQ !#LAB (GENSYM)) (RETURN (NCONC (LIST 'PROG NIL !#LAB (LIST 'COND (LIST (LIST 'NOT !#BOOL) (LIST 'RETURN NIL)))) (APPEND !#BODY (LIST (LIST 'GO !#LAB))))))) ) (!* (!* "REPEAT( body test ) MACRO ===> (PROG ...) <repeat loop> Repeat body until test is true. Jim found that this fn as we had it was causing compiler errors. The BODY was (CDDR U) and the BOOL was (CADR U). Question: Does the fact that Utah was unable to reproduce our compiler errors lie in this fact. Does function until test becomes non-NIL.") (CDM REPEAT (!#X) (XP!#REPEAT (CADR !#X) (CADDR !#X))) (DE XP!#REPEAT (!#BODY !#BOOL) (PROG (!#LAB) (SETQ !#LAB (GENSYM)) (RETURN (LIST 'PROG NIL !#LAB !#BODY (LIST 'COND (LIST (LIST 'NOT !#BOOL) (LIST 'GO !#LAB))))))) ) (!* (!* "FOREACH( var in/of lst do/collect exp ) MACRO ===> (MAPxx LST (FUNCTION (LAMBDA (VAR) EXP))) Undocumented FOREACH supplied by Utah. Required by compiler. Update: modified to call xp#foreach which can be compiled to speed up macro expansion.") (CDM FOREACH (!#X) (XP!#FOREACH (CADR !#X) (CADDR !#X) (CAR (SETQ !#X (CDDDR !#X))) (CADR !#X) (CADDR !#X))) (DE XP!#FOREACH (!#VAR !#MOD !#LST !#ACTION !#BODY) (PROG (!#FN) (SETQ !#FN (COND ((EQ !#ACTION 'DO) (COND ((EQ !#MOD 'IN) 'MAPC) (T 'MAP))) ((EQ !#MOD 'IN) 'MAPCAR) (T 'MAPLIST))) (RETURN (LIST !#FN !#LST (LIST 'FUNCTION (LIST 'LAMBDA (LIST !#VAR) !#BODY)))))) ) (!* "SAY( test expressions ) MACRO ===> (COND (<test> (PROGN (PRIN2 ...) (PRIN2 ...) ...))) If test is true then evaluate and prin2 all expressions. Exceptions: the value of printing functions, those flaged with SAY:PRINT (including: PRINT PRIN1 PRIN2 PRINC TYO PPRINT TERPRI POSN DOHOME DORIGH DOLEFT DOUP DODOWN DPYNCH DPYCHR SETCUR MOVECUR) are just evaluated. E.g.: (In the example @ is used for quotes) (SAY T @this @ (PRIN1 '!!AND!!) @ that@) appears as: this !!AND!! that ") (DM SAY (!#X) (LIST 'COND (LIST (CADR !#X) (CONS 'PROGN (MAPCAR (CDDR !#X) (FUNCTION XP!#SAY1)))))) (DE XP!#SAY1 (!#Y) (COND ((AND (PAIRP !#Y) (EQ (CAR !#Y) 'PRINTER)) (CADR !#Y)) ((AND (PAIRP !#Y) (FLAGP (CAR !#Y) 'SAY!:PRINT)) !#Y) (T (LIST 'Q!-PRIN2 !#Y)))) (FLAG '(Q!-PRINT Q!-PRIN1 Q!-PRIN2 Q!-PRINC SETCUR Q!-TYO PPRINT POSN PPOS TTY) 'SAY!:PRINT) (!* "DIVERT( channel expressions ) MACRO ===> (PROG (ochan) <select given chan> <eval exps> <select ochan>) Yields PROG that selects channel for output, evaluates each expression, and then reselects prior channel.") (CDM DIVERT (!#L) (CONS 'PROG (CONS (LIST 'OLD!#CHAN) (CONS (LIST 'SETQ 'OLD!#CHAN (LIST 'WRS (CADR !#L))) (APPEND (CDDR !#L) (LIST (LIST 'WRS 'OLD!#CHAN))))))) (!* "CAT( list of any ):string MACRO ===> (CAT-DE (LIST <list>)) Evaluates all arguments given and forms a string from the concatenation of their prin2 names. ") (CDM CAT (!#X) (LIST 'CAT!-DE (CONS 'LIST (CDR !#X)))) (!* "CAT-ID( list of any ):<uninterned id> MACRO ===> (CAT-ID-DE (LIST <list>)) Evaluates all arguments given and forms an id from the concatenation of their prin2 names. ") (CDM CAT!-ID (!#X) (LIST 'CAT!-ID!-DE (CONS 'LIST (CDR !#X)))) (!* "TTY ( L:list ):NIL MACRO TTY-TX( L:list ):NIL MACRO TTY-XT( L:list ):NIL MACRO TTY-TT( L:list ):NIL MACRO ===> (TTY-xx-DE (LIST <list>)) TTY is selected for output, then each elt of list is evaluated and PRIN2'ed, except for $EOL$'s, which cause a TERPRI. Then prior output channel is reselected. TTY-TX adds leading TERPRI. TTY-XT adds trailing TERPRI. TTY-TT adds leading and trailing TERPRI's. ") (!* "CDMs were making all of the following unloadable into existing QDRIVER.SAV core image. I flushed the 'C' July 27") (!* "TTY-DE now takes two extra arguments, for the number of TERPRIs to preceed and follow the other printed material.") (DM TTY (!#X) (LIST 'TTY!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-TX (!#X) (LIST 'TTY!-TX!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-XT (!#X) (LIST 'TTY!-XT!-DE (CONS 'LIST (CDR !#X)))) (DM TTY!-TT (!#X) (LIST 'TTY!-TT!-DE (CONS 'LIST (CDR !#X)))) (!* "ERRSET (expression label) MACRO ===> (ERRSET-DE 'exp 'label) Named errset. If error matches label, then acts like errorset. Otherwise propagates error upward. Matching: Every label stops errors NIL, $EOF$. Label 'ERRORX stops any error. Other labels stop errors whose first arg is EQ to them.") (CDM ERRSET (!#X) (LIST 'ERRSET!-DE (MKQUOTE (CADR !#X)) (MKQUOTE (CADDR !#X)))) (!* "GRAB( <file description> ) MACRO ===> (GRABBER NIL '<file-dscr>) Reads in entire file, whose system name is created using conventions described in FORM-FILE.") (DM GRAB (!#X) (LIST 'GRABBER NIL (MKQUOTE (CDR !#X)))) (!* "GRABFNS( <ids> . <file description> ) MACRO ===> (GRABBER FNS <file-dscr>) Like grab, but only reads in specified fns/vars.") (DM GRABFNS (!#X) (LIST 'GRABBER (CADR !#X) (MKQUOTE (CDDR !#X)))) (!* "DUMP( <file description> ) MACRO ===> (DUMPER '<file-dscr>) Dumps file onto disk. Filename as in GRAB. Prettyprints.") (DM DUMP (!#X) (LIST 'DUMPER (MKQUOTE (CDR !#X)))) (!* "DUMPFNS( <ids> . <file dscr> ) MACRO ===> (DUMPFNS-DE <fns> '<file-dscr>) Like DUMP, but copies old file, inserting new defs for specified fns/vars") (DM DUMPFNS (!#X) (LIST 'DUMPFNS!-DE (CADR !#X) (MKQUOTE (CDDR !#X)))) (!* " We are currently defining these to be macros everywhere, but might want them to be exprs while interpreted, in which case use the following to get compile-time macros.") (!* PUT 'NEQ 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQ !#X !#Y)))) (!* PUT 'NEQN 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQN !#X !#Y)))) (!* PUT 'NEQUAL 'CMACRO '(LAMBDA (!#X !#Y) (NOT (EQUAL !#X !#Y)))) (!* " YSAIMAC -- MACROS used to simulate SAIL constructs. macros: DO-UNTIL SAI-IF SAI2-IF SAI-DONE SAI-CONTINUE SAI-WHILE SAI-FOREACH SAI-FOR SAI-BEGIN PBEGIN PRETURN SAI-ASSIGN MSETQ SAI-COLLECT IFC OUTSTR SAI-SAY SAI-& SAI-LENGTH CVSEST CVSEN CVS SUBSTRING-FOR SUBSTRING-TO PUSHES PUSHVARS SLIST SAI-MAPC SAI-EQU auxiliary exprs used to expand macros: XP#SAY-IF XP#SAI-WHILE XP#SAI-FOREACH XP#SAI-FOR XP#SUBSTRING-TO ") (DM DO!-UNTIL (FORM) (LIST 'PROG NIL 'L (CADR FORM) (LIST 'COND (LIST (CADDDR FORM) NIL) (LIST 1 '(GO L))))) (!* "SAI-IF ( sailish if-expression ) MACRO (IF test1 THEN exp1 [ ELSEIF testi THEN expi ] [ELSE expn]) ===> (COND (test1 exp1) ... (testi expi) ... (T expn)) Embedded expressions do not cause embedded COND's, (unlike ALGOL!). Examples: (IF (ATOM Y) THEN (CAR X)) (IF (ATOM Y) THEN (CAR X) ELSE (CADR X)) (IF (ATOM Y) THEN (CAR X) ELSEIF (ATOM Z) THEN (CADR X)) ") (DM SAI!-IF (IF!#X) (XP!#SAI!-IF (CDR IF!#X))) (DM SAI2!-IF (IF!#X) (XP!#SAI!-IF (CDR IF!#X))) (DE XP!#SAI!-IF (IF!#X) (PROG (!#ANTE !#CONSEQ !#TEMP !#ANS) (SETQ !#ANS NIL) (PROG NIL WHTAG(COND (IF!#X (PROGN (SETQ !#ANTE (CAR IF!#X)) (SETQ IF!#X (CDR IF!#X)) (COND ((EQ (SETQ !#TEMP (CAR IF!#X)) 'THEN) (SETQ IF!#X (CDR IF!#X)))) (SETQ !#CONSEQ NIL) (PROG NIL WHTAG(COND (IF!#X (PROGN (SETQ !#TEMP (CAR IF!#X)) (COND ((OR (EQ !#TEMP 'ELSE) (EQ !#TEMP 'ELSEIF) (EQ !#TEMP 'EF)) (RETURN NIL))) (SETQ !#CONSEQ (CONS !#TEMP !#CONSEQ)) (SETQ IF!#X (CDR IF!#X)) (GO WHTAG))))) (SETQ !#ANS (CONS (CONS !#ANTE (REVERSE !#CONSEQ)) !#ANS)) (COND ((NOT IF!#X) (RETURN NIL))) (SETQ !#TEMP (CAR IF!#X)) (SETQ IF!#X (CDR IF!#X)) (COND ((EQ !#TEMP 'ELSE) (PROGN (SETQ !#ANS (CONS (CONS 'T IF!#X) !#ANS)) (RETURN NIL)))) (!* " MUST BE ELSEIF") (GO WHTAG))))) (RETURN (CONS 'COND (REVERSE !#ANS))))) (DM SAI!-DONE (C!#X) '(RETURN NIL)) (DM SAI!-CONTINUE (C!#X) '(GO CONTINUE!:)) (!* "SAI-WHILE ( sailish while-expression ) MACRO (WHILE b DO e1 e2 ... en) does e1,..., en as long as b is non-nil. ===> (PROG NIL CONTINUE: (COND ((NULL b) (RETURN NIL))) e1 ... en (GO CONTINUE:)) N.B. (WHILE b DO ... (RETURN e)) has the RETURN relative to the PROG in the expansion. As in SAIL, (CONTINUE) and DONE work as statements. (They are also macros.) ") (DM SAI!-WHILE (WH!#X) (XP!#SAI!-WHILE WH!#X)) (DE XP!#SAI!-WHILE (WH!#X) (APPENDL (LIST 'PROG NIL 'CONTINUE!: (LIST 'COND (LIST (LIST 'NOT (CADR WH!#X)) (LIST 'RETURN NIL)))) (SAI!-IF (EQ (CADDR WH!#X) 'DO) THEN (CDDDR WH!#X) ELSE (CDDR WH!#X)) '((GO CONTINUE!:)))) (DM SAI!-FOREACH (FOREACH!#X) (XP!#SAI!-FOREACH FOREACH!#X)) (DE XP!#SAI!-FOREACH (FORE!#X) (APPENDL (LIST 'PROG '(FORE!#TEMP) (LIST 'SETQ 'FORE!#TEMP (CADDDR FORE!#X)) 'CONTINUE!: '(SAI!-IF (NULL FORE!#TEMP) THEN (RETURN NIL)) (LIST 'SETQ (CADR FORE!#X) '(CAR FORE!#TEMP)) '(SETQ FORE!#TEMP (CDR FORE!#TEMP))) (CDR (CDDDDR FORE!#X)) '((GO CONTINUE!:)))) (DM SAI!-FOR (FOR!#X) (XP!#SAI!-FOR FOR!#X)) (DE XP!#SAI!-FOR (FOR!#X) (CONS 'PROG (CONS NIL (CONS (LIST 'SETQ (CADR FOR!#X) (CADDDR FOR!#X)) (CONS 'FOR!#LOOP!: (CONS (LIST 'SAI!-IF (LIST (COND ((GREATERP (EVAL (CADR (CDDDDR FOR!#X))) 0) 'GREATERP) (T 'LESSP)) (CADR FOR!#X) (CADDDR (CDDDDR FOR!#X))) 'THEN '(RETURN NIL)) (APPEND (CDR (CDDDDR (CDDDDR FOR!#X))) (LIST 'CONTINUE!: (LIST 'SETQ (CADR FOR!#X) (LIST 'PLUS (CADR FOR!#X) (CADR (CDDDDR FOR!#X)))) '(GO FOR!#LOOP!:))))))))) (DM SAI!-BEGIN (BEG!#X) (CONS 'DO (CDR BEG!#X))) (DM PBEGIN (PBEG!#X) (LIST 'CATCH (KWOTE (CONS 'PROG (CDR PBEG!#X))) ''!$PLAB)) (DM PRETURN (PRET!#X) (LIST 'THROW (KWOTE (CADR PRET!#X)) (KWOTE '!$PLAB))) (DM SAI!-ASSIGN (!#X) (LIST 'SETQ (CADR !#X) (CADDR !#X))) (DM MSETQ (MSETQ!#X) (CONS 'PROG (CONS '(!#!#RESULT) (CONS (LIST 'SETQ '!#!#RESULT (CADDR MSETQ!#X)) (MAPCAR (CADR MSETQ!#X) (FUNCTION (LAMBDA (X) (LIST 'SETQ X '(POP !#!#RESULT))))))))) (DM SAI!-COLLECT (X) (LIST 'SETQ (CADDDR X) (LIST 'CONS (CADR X) (CADDDR X)))) (DM IFC (X) (COND ((EVAL (CADR X)) (CADDDR X)) ((EQ (CAR (CDDDDR X)) 'ELSEC) (CADR (CDDDDR X))) (T NIL))) (DM OUTSTR (!#X) (CONS 'TTY (CDR !#X))) (!* DE TTYMSG (!#X) (MAPC !#X (FUNCTION (LAMBDA (!#ELT) (COND ((STRINGP !#ELT) (PRIN2 !#ELT)) ((EQ !#ELT 'T) (TERPRI)) (T (PRINT (EVAL !#ELT)))))))) (DM SAI!-SAY (!#X) (CONS 'TTY (CDR !#X))) (DM SAI!-!& (!#X) (CONS 'CAT (CDR !#X))) (DM SAI!-LENGTH (!#X) (CONS 'FLATSIZE2 (CDR !#X))) (DM CVSEST (!#X) (CADR !#X)) (DM CVSEN (!#X) (CADR !#X)) (DM CVS (!#X) (CADR !#X)) (DM SUBSTRING!-FOR (!#L) (LIST 'SUBSTR (CADR !#L) (LIST 'SUB1 (CADDR !#L)) (CADDDR !#L))) (!* "REM is planning on cleaning this up so it works in all cases... The form that (SUBSTRING-TO stringexpr low high) should expand into is ((LAMBDA (#STRING) (SUBSTR #STRING low high)) stringexpr) except that low and high have been modified to replace INF by explicit calls to (FLATSIZE2 #STRING). Thus things like (SUBSTRING-TO (READ) 2 (SUB1 INF)) should work without requiring the user to type the same string twice. Probably that inner (SUBSTR ...) should simply be ((LAMBDA (INF) (SUBSTR #STRING low high)) (FLATSIZE2 #STRING)) where we don't have to internally modify low or high at all!") (DM SUBSTRING!-TO (!#L) (XP!#SUBSTRING!-TO (CDR !#L))) (DE XP!#SUBSTRING!-TO (!#L) (PROG (STREXP LOWEXP HIEXP IN!:LOW!:BOUND INNER!:INF!:BOUND OUTER!:STRING!:BOUND OLDRES NEWRES) (SETQ STREXP (CAR !#L)) (SETQ LOWEXP (CADR !#L)) (SETQ HIEXP (CADDR !#L)) (SETQ IN!:LOW!:BOUND (LIST (LIST 'LAMBDA '(!#LOW !#HIGH) '(SUBSTR !#STRING !#LOW (DIFFERENCE !#HIGH !#LOW))) (LIST 'SUB1 (LIST 'MAX 1 LOWEXP)) HIEXP)) (SETQ INNER!:INF!:BOUND (LIST (LIST 'LAMBDA '(INF) IN!:LOW!:BOUND) '(FLATSIZE2 !#STRING))) (SETQ OUTER!:STRING!:BOUND (LIST (LIST 'LAMBDA '(!#STRING) INNER!:INF!:BOUND) STREXP)) (RETURN OUTER!:STRING!:BOUND))) (DM PUSHES (!#X) NIL) (DM PUSHVARS (!#X) NIL) (DM SLIST (!#X) (CONS 'LIST (CDR !#X))) (DM SAI!-MAPC (!#L) (LIST 'MAPC (CADDR !#L) (CADR !#L))) (DM SAI!-EQU (!#L) (CONS 'EQUAL (CDR !#L)))