diff --git a/changelog b/changelog index fcede04..5684b11 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,10 @@ +20100826 tpd src/axiom-website/patches.html 20100826.03.tpd.patch +20100826 tpd src/interp/Makefile remove nspadaux,mark,pspad1,pspad2 +20100826 tpd src/interp/compiler.lisp merge needed defvars +20100826 tpd src/interp/pspad1.lisp removed +20100826 tpd src/interp/pspad2.lisp removed +20100826 tpd src/interp/mark.lisp removed +20100826 tpd src/interp/nspadaux.lisp removed 20100826 tpd src/axiom-website/patches.html 20100826.02.tpd.patch 20100826 tpd src/interp/Makefile remove wi2.lisp 20100826 tpd src/interp/wi2.lisp removed diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index f41ddf0..235b323 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3085,5 +3085,7 @@ src/interp/ptrop.lisp merged and removed
src/interp/wi1.lisp removed
20100826.02.tpd.patch src/interp/wi2.lisp removed
+20100826.03.tpd.patch +src/interp/Makefile remove nspadaux,mark,pspad1,pspad2
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 9aadaca..b45b5cf 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -233,15 +233,6 @@ BROBJS= ${AUTO}/bc-matrix.${O} \ ${AUTO}/topics.${O} @ -The {\bf TRANOBJS} list contains files only used by the {\bf boot} -to Common Lisp translator and are probably never used by anyone -but the developers. These files should probably be autoloaded. -\verb|${AUTO}/wi1.${O} ${AUTO}/wi2.${O} | -<>= -TRANOBJS= ${AUTO}/pspad1.${O} \ - ${AUTO}/pspad2.${O} ${AUTO}/mark.${O} ${AUTO}/nspadaux.${O} - -@ The {\bf NAGBROBJS} list contains files used to access the Numerical Algorithms Group (NAG) fortran libraries. @@ -666,7 +657,7 @@ ${SAVESYS}: ${DEPSYS} ${OBJS} ${OUT}/bookvol5.${O} ${OUT}/util.${O} \ ${OUT}/nocompil.${LISP} ${OUT}/sys-pkg.${LISP} \ ${OUTINTERP} ${BROBJS} \ ${OUT}/database.date ${INOBJS} ${ASCOMP} ${ASAUTO} \ - ${NAGBROBJS} ${TRANOBJS} \ + ${NAGBROBJS} \ ${LOADSYS} \ ${SRC}/doc/msgs/s2-us.msgs \ ${INT}/algebra/warm.data @@ -699,7 +690,7 @@ ${SAVESYS}: ${DEPSYS} ${OBJS} ${OUT}/bookvol5.${O} ${OUT}/util.${O} \ nil \ nil \ '(quote ($(patsubst %, "%", ${BROBJS})))' \ - '(quote ($(patsubst %, "%", ${TRANOBJS})))' \ + nil \ '(quote ($(patsubst %, "%", ${NAGBROBJS})))' \ '(quote ($(patsubst %, "%", ${ASAUTO})))' \ '"${SPAD}" "${LSP}" "${SRC}" "${INT}"' \ @@ -954,41 +945,6 @@ ${MID}/nocompil.lisp: ${IN}/nocompil.lisp.pamphlet @ -\subsection{nspadaux.lisp \cite{28}} -<>= -${AUTO}/nspadaux.${O}: ${OUT}/nspadaux.${O} - @ echo 89 making ${AUTO}/nspadaux.${O} from ${OUT}/nspadaux.${O} - @ cp ${OUT}/nspadaux.${O} ${AUTO} - -@ -<>= -${OUT}/nspadaux.${O}: ${MID}/nspadaux.lisp - @ echo 90 making ${OUT}/nspadaux.${O} from ${MID}/nspadaux.lisp - @ ( cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/nspadaux.lisp"' \ - ':output-file "${OUT}/nspadaux.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/nspadaux.lisp"' \ - ':output-file "${OUT}/nspadaux.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${OUT}/nspadaux.${LISP}: ${MID}/nspadaux.lisp - @ echo 91 making ${OUT}/nspadaux.${LISP} from ${MID}/nspadaux.lisp - @cp ${MID}/nspadaux.lisp ${OUT}/nspadaux.${LISP} - -@ -<>= -${MID}/nspadaux.lisp: ${IN}/nspadaux.lisp.pamphlet - @ echo 92 making ${MID}/nspadaux.lisp from ${IN}/nspadaux.lisp.pamphlet - @ ( cd ${MID} ; \ - ${TANGLE} ${IN}/nspadaux.lisp.pamphlet >nspadaux.lisp ) - -@ - \subsection{parsing.lisp \cite{29}} <>= ${AUTO}/parsing.${O}: ${OUT}/parsing.${O} @@ -1709,7 +1665,7 @@ ${MID}/clam.lisp: ${IN}/clam.lisp.pamphlet @ <>= ${OUT}/clam.lisp: ${IN}/clam.lisp.pamphlet - @ echo 221 making ${OUT}/clam.lisp from ${IN}/clam.boot.pamphlet + @ echo 221 making ${OUT}/clam.lisp from ${IN}/clam.lisp.pamphlet @ rm -f ${OUT}/clam.${O} @( cd ${OUT} ; \ ${TANGLE} ${IN}/clam.lisp.pamphlet >clam.lisp ) @@ -1927,7 +1883,7 @@ ${MID}/g-boot.lisp: ${IN}/g-boot.lisp.pamphlet @ <>= ${OUT}/g-boot.lisp: ${IN}/g-boot.lisp.pamphlet - @ echo 221 making ${OUT}/g-boot.lisp from ${IN}/g-boot.boot.pamphlet + @ echo 221 making ${OUT}/g-boot.lisp from ${IN}/g-boot.lisp.pamphlet @ rm -f ${OUT}/g-boot.${O} @( cd ${OUT} ; \ ${TANGLE} ${IN}/g-boot.lisp.pamphlet >g-boot.lisp ) @@ -2051,7 +2007,7 @@ ${MID}/g-util.lisp: ${IN}/g-util.lisp.pamphlet @ <>= ${OUT}/g-util.lisp: ${IN}/g-util.lisp.pamphlet - @ echo 221 making ${OUT}/g-util.lisp from ${IN}/g-util.boot.pamphlet + @ echo 221 making ${OUT}/g-util.lisp from ${IN}/g-util.lisp.pamphlet @ rm -f ${OUT}/g-util.${O} @( cd ${OUT} ; \ ${TANGLE} ${IN}/g-util.lisp.pamphlet >g-util.lisp ) @@ -2969,7 +2925,7 @@ ${MID}/as.lisp: ${IN}/as.lisp.pamphlet @ -\subsection{bc-matrix.boot} +\subsection{bc-matrix.lisp} <>= ${AUTO}/bc-matrix.${O}: ${OUT}/bc-matrix.${O} @ echo 422 making ${AUTO}/bc-matrix.${O} from ${OUT}/bc-matrix.${O} @@ -3000,7 +2956,7 @@ ${MID}/bc-matrix.lisp: ${IN}/bc-matrix.lisp.pamphlet @ -\subsection{ht-util.boot} +\subsection{ht-util.lisp} <>= ${AUTO}/ht-util.${O}: ${OUT}/ht-util.${O} @ echo 422 making ${AUTO}/ht-util.${O} from ${OUT}/ht-util.${O} @@ -3077,7 +3033,7 @@ ${MID}/htcheck.lisp: ${IN}/htcheck.lisp.pamphlet @ -\subsection{ax.boot} +\subsection{ax.lisp} <>= ${AUTO}/ax.${O}: ${OUT}/ax.${O} @ echo 465 making ${AUTO}/ax.${O} from ${OUT}/ax.${O} @@ -3107,7 +3063,6 @@ ${MID}/ax.lisp: ${IN}/ax.lisp.pamphlet @ \subsection{br-con.lisp} -\subsection{br-con.boot} <>= ${AUTO}/br-con.${O}: ${OUT}/br-con.${O} @ echo 465 making ${AUTO}/br-con.${O} from ${OUT}/br-con.${O} @@ -3136,7 +3091,7 @@ ${MID}/br-con.lisp: ${IN}/br-con.lisp.pamphlet @ -\subsection{topics.boot} +\subsection{topics.lisp} <>= ${AUTO}/topics.${O}: ${OUT}/topics.${O} @ echo 465 making ${AUTO}/topics.${O} from ${OUT}/topics.${O} @@ -3303,72 +3258,6 @@ ${MID}/interop.lisp: ${IN}/interop.lisp.pamphlet @ -\subsection{pspad1.boot} -<>= -${AUTO}/pspad1.${O}: ${MID}/pspad1.lisp - @ echo 598 making ${AUTO}/pspad1.${O} from ${MID}/pspad1.lisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/pspad1.lisp"' \ - ':output-file "${AUTO}/pspad1.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/pspad1.lisp"' \ - ':output-file "${AUTO}/pspad1.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/pspad1.lisp: ${IN}/pspad1.lisp.pamphlet - @ echo 599 making ${MID}/pspad1.lisp from ${IN}/pspad1.lisp.pamphlet - @ ${TANGLE} ${IN}/pspad1.lisp.pamphlet >${MID}/pspad1.lisp - -@ - -\subsection{pspad2.boot} -<>= -${AUTO}/pspad2.${O}: ${MID}/pspad2.lisp - @ echo 598 making ${AUTO}/pspad2.${O} from ${MID}/pspad2.lisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/pspad2.lisp"' \ - ':output-file "${AUTO}/pspad2.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/pspad2.lisp"' \ - ':output-file "${AUTO}/pspad2.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/pspad2.lisp: ${IN}/pspad2.lisp.pamphlet - @ echo 599 making ${MID}/pspad2.lisp from ${IN}/pspad2.lisp.pamphlet - @ ${TANGLE} ${IN}/pspad2.lisp.pamphlet >${MID}/pspad2.lisp - -@ - -\subsection{mark.boot} -<>= -${AUTO}/mark.${O}: ${MID}/mark.lisp - @ echo 598 making ${AUTO}/mark.${O} from ${MID}/mark.lisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/mark.lisp"' \ - ':output-file "${AUTO}/mark.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/mark.lisp"' \ - ':output-file "${AUTO}/mark.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/mark.lisp: ${IN}/mark.lisp.pamphlet - @ echo 599 making ${MID}/mark.lisp from ${IN}/mark.lisp.pamphlet - @ ${TANGLE} ${IN}/mark.lisp.pamphlet >${MID}/mark.lisp - -@ - \subsection{axext\_l.lisp} <>= # .lisp files for AXIOM-XL support @@ -3646,9 +3535,6 @@ clean: <> <> -<> -<> - <> <> @@ -3742,11 +3628,6 @@ clean: <> <> -<> -<> -<> -<> - <> <> @@ -3767,12 +3648,6 @@ clean: <> <> -<> -<> - -<> -<> - <> <> diff --git a/src/interp/compiler.lisp.pamphlet b/src/interp/compiler.lisp.pamphlet index f9b7ccd..80c3ecf 100644 --- a/src/interp/compiler.lisp.pamphlet +++ b/src/interp/compiler.lisp.pamphlet @@ -15,6 +15,8 @@ (defvar |$NoValueMode| '|NoValueMode|) (defvar |$ValueMode| '|ValueMode|) +(defvar |$globalMacroStack| nil) +(defvar |$abbreviationStack| nil) ;compTopLevel(x,m,e) == ;--+ signals that target is derived from lhs-- see NRTmakeSlot1Info diff --git a/src/interp/mark.lisp.pamphlet b/src/interp/mark.lisp.pamphlet deleted file mode 100644 index 630e725..0000000 --- a/src/interp/mark.lisp.pamphlet +++ /dev/null @@ -1,6584 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp mark.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} - -HOW THE TRANSLATOR WORKS - -Unit of code is markedUp as follows (unit= item in a capsule pile, e.g.) - (WI/.. a b) means source code a --> markedUpCode b - (REPPER/.. . . a) means source code for a ---> (rep a) or (per a) -Source code is extracted, modified from markedUpCode, and stacked -Entire constructor is then assembled and prettyprinted - -\end{verbatim} -<<*>>= -(IN-PACKAGE "BOOT" ) - -;REMPROP("and",'parseTran) - -(REMPROP '|and| '|parseTran|) - -;REMPROP("or",'parseTran) - -(REMPROP '|or| '|parseTran|) - -;REMPROP("not",'parseTran) - -(REMPROP '|not| '|parseTran|) - -;MAKEPROP("and",'special,'compAnd) - -(MAKEPROP '|and| '|special| '|compAnd|) - -;MAKEPROP("or",'special,'compOr) - -(MAKEPROP '|or| '|special| '|compOr|) - -;MAKEPROP("not",'special,'compNot) - -(MAKEPROP '|not| '|special| '|compNot|) - -;SETQ($monitorWI,nil) - -(SETQ |$monitorWI| NIL) - -;SETQ($monitorCoerce,nil) - -(SETQ |$monitorCoerce| NIL) - -;SETQ($markPrimitiveNumbers,nil) -- '(Integer SmallInteger)) - -(SETQ |$markPrimitiveNumbers| NIL) - -;SETQ($markNumberTypes,'(Integer SmallInteger PositiveInteger NonNegativeInteger)) - -(SETQ |$markNumberTypes| - '(|Integer| |SmallInteger| |PositiveInteger| - |NonNegativeInteger|)) - -;--====================================================================== -;-- Master Markup Function -;--====================================================================== -; -;WI(a,b) == b - -;;; *** WI REDEFINED - -(DEFUN WI (|a| |b|) - (declare (ignore |a|)) - |b|) - -;mkWi(fn,:r) == -;-- if $monitorWI and r isnt ['WI,:.] and not (r is ['AUTOSUBSET,p,.,y] and(MEMQ(KAR p,'(NonNegativeInteger PositiveInteger)) or y='_$fromCoerceable_$)) then -;-- if $monitorWI and r isnt ['WI,:.] then -;-- sayBrightlyNT ['"From ",fn,'": "] -;-- pp r -; r is ['WI,a,b] => -; a = b => a --don't bother -; b is ['WI,=a,.] => b -; r -; r - -(DEFUN |mkWi| (&REST G166093 &AUX |r| |fn|) - (DSETQ (|fn| . |r|) G166093) - (PROG (|a| |b| |ISTMP#1| |ISTMP#2|) - (RETURN - (COND - ((AND (PAIRP |r|) (EQ (QCAR |r|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |r|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T)))))) - (COND - ((BOOT-EQUAL |a| |b|) |a|) - ((AND (PAIRP |b|) (EQ (QCAR |b|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) (EQUAL (QCAR |ISTMP#1|) |a|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL)))))) - |b|) - ('T |r|))) - ('T |r|))))) - -;--====================================================================== -;-- Capsule Function Transformations -;--====================================================================== -;tcheck T == -; if T isnt [.,.,.] then systemError 'tcheck -; T - -(DEFUN |tcheck| (T$) - (PROG (|ISTMP#1| |ISTMP#2|) - (RETURN - (PROGN - (COND - ((NULL (AND (PAIRP T$) - (PROGN - (SPADLET |ISTMP#1| (QCDR T$)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL))))))) - (|systemError| '|tcheck|))) - T$)))) - -;markComp(x,T) == --for comp -; tcheck T -; x ^= CAR T => [mkWi('comp,'WI,x,CAR T),:CDR T] -; T - -(DEFUN |markComp| (|x| T$) - (PROGN - (|tcheck| T$) - (COND - ((NEQUAL |x| (CAR T$)) - (CONS (|mkWi| '|comp| 'WI |x| (CAR T$)) (CDR T$))) - ('T T$)))) - -;markAny(key,x,T) == -; tcheck T -; x ^= CAR T => [mkWi(key,'WI,x,CAR T),:CDR T] -; T - -(DEFUN |markAny| (|key| |x| T$) - (PROGN - (|tcheck| T$) - (COND - ((NEQUAL |x| (CAR T$)) - (CONS (|mkWi| |key| 'WI |x| (CAR T$)) (CDR T$))) - ('T T$)))) - -;markConstruct(x,T) == -; tcheck T -; markComp(x,T) - -(DEFUN |markConstruct| (|x| T$) - (PROGN (|tcheck| T$) (|markComp| |x| T$))) - -;markParts(x,T) == --x is ['PART,n,y] --for compNoStacking -; tcheck T -; [mkWi('makeParts,'WI,x,CAR T),:CDR T] - -(DEFUN |markParts| (|x| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|makeParts| 'WI |x| (CAR T$)) (CDR T$)))) - -;yumyum kind == kind - -(DEFUN |yumyum| (|kind|) |kind|) - -;markCoerce(T,T',kind) == --for coerce -; tcheck T -; tcheck T' -; if kind = 'AUTOSUBSET then yumyum(kind) -; STRINGP T.mode and T'.mode = '(String) => T' -; markKillAll T.mode = T'.mode => T' -; -- reduce (AUTOSUBSET a b (WI c (AUTOSUBSET b a c))) ==> c -; u := -; $partExpression is [.,.,y] and T.expr = y => ['WI,y,$partExpression] -; T.expr -; res := [markCoerceChk mkWi('coerce,kind,T.mode,T'.mode, -; mkWi('coerce,'WI,u,T'.expr)),:CDR T'] -; res - -(DEFUN |markCoerce| (T$ |T'| |kind|) - (PROG (|ISTMP#1| |ISTMP#2| |y| |u| |res|) - (declare (special |$partExpression|)) - (RETURN - (PROGN - (|tcheck| T$) - (|tcheck| |T'|) - (COND ((BOOT-EQUAL |kind| 'AUTOSUBSET) (|yumyum| |kind|))) - (COND - ((AND (STRINGP (CADR T$)) - (BOOT-EQUAL (CADR |T'|) '(|String|))) - |T'|) - ((BOOT-EQUAL (|markKillAll| (CADR T$)) (CADR |T'|)) |T'|) - ('T - (SPADLET |u| - (COND - ((AND (PAIRP |$partExpression|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |$partExpression|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - 'T))))) - (BOOT-EQUAL (CAR T$) |y|)) - (CONS 'WI - (CONS |y| (CONS |$partExpression| NIL)))) - ('T (CAR T$)))) - (SPADLET |res| - (CONS (|markCoerceChk| - (|mkWi| '|coerce| |kind| (CADR T$) - (CADR |T'|) - (|mkWi| '|coerce| 'WI |u| - (CAR |T'|)))) - (CDR |T'|))) - |res|)))))) - -;markCoerceChk x == -; x is ['AUTOSUBSET,a,b,['WI,c,['AUTOSUBSET,=b, =a, =c]]] => c -; x - -(DEFUN |markCoerceChk| (|x|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |ISTMP#4| |ISTMP#5| |c| - |ISTMP#6| |ISTMP#7| |ISTMP#8| |ISTMP#9| |ISTMP#10|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'AUTOSUBSET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |ISTMP#4| - (QCAR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCAR |ISTMP#4|) 'WI) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (PROGN - (SPADLET |c| - (QCAR |ISTMP#5|)) - (SPADLET |ISTMP#6| - (QCDR |ISTMP#5|)) - (AND (PAIRP |ISTMP#6|) - (EQ (QCDR |ISTMP#6|) NIL) - (PROGN - (SPADLET |ISTMP#7| - (QCAR |ISTMP#6|)) - (AND (PAIRP |ISTMP#7|) - (EQ (QCAR |ISTMP#7|) - 'AUTOSUBSET) - (PROGN - (SPADLET |ISTMP#8| - (QCDR |ISTMP#7|)) - (AND (PAIRP |ISTMP#8|) - (EQUAL - (QCAR |ISTMP#8|) - |b|) - (PROGN - (SPADLET |ISTMP#9| - (QCDR |ISTMP#8|)) - (AND - (PAIRP |ISTMP#9|) - (EQUAL - (QCAR |ISTMP#9|) - |a|) - (PROGN - (SPADLET - |ISTMP#10| - (QCDR - |ISTMP#9|)) - (AND - (PAIRP - |ISTMP#10|) - (EQ - (QCDR - |ISTMP#10|) - NIL) - (EQUAL - (QCAR - |ISTMP#10|) - |c|)))))))))))))))))))))) - |c|) - ('T |x|))))) - -;markMultipleExplicit(nameList, valList, T) == -; tcheck T -; [mkWi('setqMultipleExplicit, 'WI, -; ['LET, ['Tuple,:nameList], ['Tuple,:valList]], -; T.expr), :CDR T] - -(DEFUN |markMultipleExplicit| (|nameList| |valList| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|setqMultipleExplicit| 'WI - (CONS 'LET - (CONS (CONS '|Tuple| |nameList|) - (CONS (CONS '|Tuple| |valList|) NIL))) - (CAR T$)) - (CDR T$)))) - -;markRetract(x,T) == -; tcheck T -; [mkWi('smallIntegerStep,'RETRACT,nil,['REPLACE,['retract,x]],T.expr),:CDR T] - -(DEFUN |markRetract| (|x| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|smallIntegerStep| 'RETRACT NIL - (CONS 'REPLACE - (CONS (CONS '|retract| (CONS |x| NIL)) NIL)) - (CAR T$)) - (CDR T$)))) - -;markSimpleReduce(x,T) == -; tcheck T -; [mkWi('compreduce,'LAMBDA, nil, ["REPLACE",x], T.expr), :CDR T] - -(DEFUN |markSimpleReduce| (|x| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|compreduce| 'LAMBDA NIL - (CONS 'REPLACE (CONS |x| NIL)) (CAR T$)) - (CDR T$)))) - -;markCompAtom(x,T) == --for compAtom -; tcheck T -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; [mkWi('compAtom,'ATOM,nil,['REPLACE,[x]],T.expr),:CDR T] -; T - -(DEFUN |markCompAtom| (|x| T$) - (declare (special |$convert2NewCompiler|)) - (PROGN - (|tcheck| T$) - (COND - ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) - (CONS (|mkWi| '|compAtom| 'ATOM NIL - (CONS 'REPLACE (CONS (CONS |x| NIL) NIL)) - (CAR T$)) - (CDR T$))) - ('T T$)))) - -;markCase(x, tag, T) == -; tcheck T -; [mkWi('compCase1, 'LAMBDA, nil, ["REPLACE",["case",x,tag]], T.expr), -; :CDR T] - -(DEFUN |markCase| (|x| |tag| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|compCase1| 'LAMBDA NIL - (CONS 'REPLACE - (CONS (CONS '|case| - (CONS |x| (CONS |tag| NIL))) - NIL)) - (CAR T$)) - (CDR T$)))) - -;markCaseWas(x,T) == -; tcheck T -; [mkWi('compCase1,'WI,x,T.expr),:CDR T] - -(DEFUN |markCaseWas| (|x| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|compCase1| 'WI |x| (CAR T$)) (CDR T$)))) - -;markAutoWas(x,T) == -; tcheck T -; [mkWi('autoCoerce,'WI,x,T.expr),:CDR T] - -(DEFUN |markAutoWas| (|x| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|autoCoerce| 'WI |x| (CAR T$)) (CDR T$)))) - -;markCallCoerce(x,m,T) == -; tcheck T -; [mkWi("call",'WI,["::",x,m], T.expr),: CDR T] - -(DEFUN |markCallCoerce| (|x| |m| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|call| 'WI (CONS '|::| (CONS |x| (CONS |m| NIL))) - (CAR T$)) - (CDR T$)))) - -;markCoerceByModemap(x,source,target,T, killColonColon?) == -; tcheck T -; source is ["Union",:l] and MEMBER(target,l) => -; tag := genCaseTag(target, l, 1) or return nil -; markAutoCoerceDown(x, tag, markAutoWas(x,T), killColonColon?) -; target is ["Union",:l] and MEMBER(source,l) => -; markAutoCoerceUp(x,markAutoWas(x, T)) -; [mkWi('markCoerceByModemap,'WI,x,T.expr),:CDR T] - -(DEFUN |markCoerceByModemap| - (|x| |source| |target| T$ |killColonColon?|) - (PROG (|tag| |l|) - (RETURN - (PROGN - (|tcheck| T$) - (COND - ((AND (PAIRP |source|) (EQ (QCAR |source|) '|Union|) - (PROGN (SPADLET |l| (QCDR |source|)) 'T) - (|member| |target| |l|)) - (SPADLET |tag| - (OR (|genCaseTag| |target| |l| 1) (RETURN NIL))) - (|markAutoCoerceDown| |x| |tag| (|markAutoWas| |x| T$) - |killColonColon?|)) - ((AND (PAIRP |target|) (EQ (QCAR |target|) '|Union|) - (PROGN (SPADLET |l| (QCDR |target|)) 'T) - (|member| |source| |l|)) - (|markAutoCoerceUp| |x| (|markAutoWas| |x| T$))) - ('T - (CONS (|mkWi| '|markCoerceByModemap| 'WI |x| (CAR T$)) - (CDR T$)))))))) - -;markAutoCoerceDown(x,tag,T,killColonColon?) == -; tcheck T -; patch := ["dot",getSourceWI x,tag] -; if killColonColon? then patch := ["REPLACE",["UNCOERCE",patch]] -; [mkWi('coerceExtraHard,'LAMBDA, nil,patch,T.expr), :CDR T] - -(DEFUN |markAutoCoerceDown| (|x| |tag| T$ |killColonColon?|) - (PROG (|patch|) - (RETURN - (PROGN - (|tcheck| T$) - (SPADLET |patch| - (CONS '|dot| - (CONS (|getSourceWI| |x|) (CONS |tag| NIL)))) - (COND - (|killColonColon?| - (SPADLET |patch| - (CONS 'REPLACE - (CONS (CONS 'UNCOERCE (CONS |patch| NIL)) - NIL))))) - (CONS (|mkWi| '|coerceExtraHard| 'LAMBDA NIL |patch| (CAR T$)) - (CDR T$)))))) - -;markAutoCoerceUp(x,T) == -;-- y := getSourceWI x -;-- y := -;-- STRINGP y => INTERN y -;-- y -; tcheck T -; [mkWi('coerceExtraHard,'LAMBDA, nil,["REPLACE",['construct, "##1"]],T.expr), -; -----want to capture by ##1 what is there ------11/2/94 -; :CDR T] - -(DEFUN |markAutoCoerceUp| (|x| T$) - (declare (ignore |x|)) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|coerceExtraHard| 'LAMBDA NIL - (CONS 'REPLACE - (CONS (CONS '|construct| (CONS '|##1| NIL)) - NIL)) - (CAR T$)) - (CDR T$)))) - -;markCompSymbol(x,T) == --for compSymbol -; tcheck T -; [mkWi('compSymbol,'ATOM,nil,['REPLACE,["@",x,$Symbol]],T.expr),:CDR T] - -(DEFUN |markCompSymbol| (|x| T$) - (declare (special |$Symbol|)) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|compSymbol| 'ATOM NIL - (CONS 'REPLACE - (CONS (CONS '@ (CONS |x| (CONS |$Symbol| NIL))) - NIL)) - (CAR T$)) - (CDR T$)))) - -;markStepSI(ostep,nstep) == --for compIterator -; ['STEP,:r] := ostep -; ['ISTEP,i,:s] := nstep -;--$localLoopVariables := insert(i,$localLoopVariables) -; markImport 'SmallInteger -; mkWi('markStepSI,'WI,ostep,['ISTEP, -; mkWi('markStep,'FREESI,nil,['REPLACE, ['PAREN,['free,i]]],i),:s]) - -(DEFUN |markStepSI| (|ostep| |nstep|) - (PROG (|r| |i| |s|) - (RETURN - (PROGN - (SPADLET |r| (CDR |ostep|)) - (SPADLET |i| (CADR |nstep|)) - (SPADLET |s| (CDDR |nstep|)) - (|markImport| '|SmallInteger|) - (|mkWi| '|markStepSI| 'WI |ostep| - (CONS 'ISTEP - (CONS (|mkWi| '|markStep| 'FREESI NIL - (CONS 'REPLACE - (CONS - (CONS 'PAREN - (CONS - (CONS '|free| (CONS |i| NIL)) - NIL)) - NIL)) - |i|) - |s|))))))) - -;-- i],i),:s]) -;markStep(i) == mkWi('markStep,'FREE,nil,['REPLACE, ['PAREN,['free,i]]],i) - -(DEFUN |markStep| (|i|) - (|mkWi| '|markStep| 'FREE NIL - (CONS 'REPLACE - (CONS (CONS 'PAREN - (CONS (CONS '|free| (CONS |i| NIL)) NIL)) - NIL)) - |i|)) - -;-- i],i) -;markPretend(T,T') == -; tcheck T -; tcheck T' -; [mkWi('pretend,'COLON,"pretend",T.mode,T.expr),:CDR T'] - -(DEFUN |markPretend| (T$ |T'|) - (PROGN - (|tcheck| T$) - (|tcheck| |T'|) - (CONS (|mkWi| '|pretend| 'COLON '|pretend| (CADR T$) (CAR T$)) - (CDR |T'|)))) - -;markAt(T) == -; tcheck T -; [mkWi('compAtom,'COLON,"@",T.mode,T.expr),:CDR T] - -(DEFUN |markAt| (T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|compAtom| 'COLON '@ (CADR T$) (CAR T$)) (CDR T$)))) - -;markCompColonInside(op,T) == --for compColonInside -; tcheck T -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; [mkWi('compColonInside,'COLON,op,T.mode,T.expr),:CDR T] -; T - -(DEFUN |markCompColonInside| (|op| T$) - (declare (special |$convert2NewCompiler|)) - (PROGN - (|tcheck| T$) - (COND - ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) - (CONS (|mkWi| '|compColonInside| 'COLON |op| (CADR T$) (CAR T$)) - (CDR T$))) - ('T T$)))) - -;markLisp(T,m) == --for compForm1 -; tcheck T -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; [mkWi('compForm1,'COLON,'Lisp,T.mode,T.expr),:CDR T] -; T - -(DEFUN |markLisp| (T$ |m|) - (declare (special |$convert2NewCompiler|) (ignore |m|)) - (PROGN - (|tcheck| T$) - (COND - ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) - (CONS (|mkWi| '|compForm1| 'COLON '|Lisp| (CADR T$) (CAR T$)) - (CDR T$))) - ('T T$)))) - -;markLambda(vl,body,mode,T) == --for compWithMappingMode -; tcheck T -; if mode isnt ['Mapping,:ml] then error '"markLambda" -; args := [[":",$PerCentVariableList.i,t] for i in 0.. for t in rest ml] -; left := [":",['PAREN,:args],first ml] -; fun := ['_+_-_>,left,SUBLISLIS($PerCentVariableList,vl,body)] -; [mkWi('compWithMappingMode,'LAMBDA,nil,['REPLACE,fun],T.expr),:CDR T] - -(DEFUN |markLambda| (|vl| |body| |mode| T$) - (PROG (|ml| |args| |left| |fun|) - (declare (special |$PerCentVariableList|)) - (RETURN - (SEQ (PROGN - (|tcheck| T$) - (COND - ((NULL (AND (PAIRP |mode|) (EQ (QCAR |mode|) '|Mapping|) - (PROGN (SPADLET |ml| (QCDR |mode|)) 'T))) - (|error| "markLambda"))) - (SPADLET |args| - (PROG (G166421) - (SPADLET G166421 NIL) - (RETURN - (DO ((|i| 0 (QSADD1 |i|)) - (G166427 (CDR |ml|) (CDR G166427)) - (|t| NIL)) - ((OR (ATOM G166427) - (PROGN - (SETQ |t| (CAR G166427)) - NIL)) - (NREVERSE0 G166421)) - (SEQ (EXIT (SETQ G166421 - (CONS - (CONS '|:| - (CONS - (ELT |$PerCentVariableList| - |i|) - (CONS |t| NIL))) - G166421)))))))) - (SPADLET |left| - (CONS '|:| - (CONS (CONS 'PAREN |args|) - (CONS (CAR |ml|) NIL)))) - (SPADLET |fun| - (CONS '+-> - (CONS |left| - (CONS (SUBLISLIS - |$PerCentVariableList| |vl| - |body|) - NIL)))) - (CONS (|mkWi| '|compWithMappingMode| 'LAMBDA NIL - (CONS 'REPLACE (CONS |fun| NIL)) (CAR T$)) - (CDR T$))))))) - -;markMacro(before,after) == --for compMacro -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; if before is [x] then before := x -; $def := ['MDEF,before,'(NIL),'(NIL),after] -; if $insideFunctorIfTrue -; then $localMacroStack := [[before,:after],:$localMacroStack] -; else $globalMacroStack:= [[before,:after],:$globalMacroStack] -; mkWi('macroExpand,'MI,before,after) -; after - -(DEFUN |markMacro| (|before| |after|) - (PROG (|x|) - (declare (special |$globalMacroStack| |$localMacroStack| |$def| - |$insideFunctorIfTrue| |$convert2NewCompiler|)) - (RETURN - (COND - ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) - (COND - ((AND (PAIRP |before|) (EQ (QCDR |before|) NIL) - (PROGN (SPADLET |x| (QCAR |before|)) 'T)) - (SPADLET |before| |x|))) - (SPADLET |$def| - (CONS 'MDEF - (CONS |before| - (CONS '(NIL) - (CONS '(NIL) (CONS |after| NIL)))))) - (COND - (|$insideFunctorIfTrue| - (SPADLET |$localMacroStack| - (CONS (CONS |before| |after|) - |$localMacroStack|))) - ('T - (SPADLET |$globalMacroStack| - (CONS (CONS |before| |after|) |$globalMacroStack|)))) - (|mkWi| '|macroExpand| 'MI |before| |after|)) - ('T |after|))))) - -;markInValue(y ,e) == -; y1 := markKillAll y -; [y', m, e] := T := comp(y1, $EmptyMode, e) or return nil -; markImport m -; m = "$" and LASSOC('value,getProplist('Rep,e)) is [a,:.] and -; MEMQ(opOf a,'(List Vector)) => [markRepper('rep, y'), 'Rep, e] -; T - -(DEFUN |markInValue| (|y| |e|) - (PROG (|y1| T$ |y'| |m| |ISTMP#1| |a|) - (declare (special |$EmptyMode|)) - (RETURN - (PROGN - (SPADLET |y1| (|markKillAll| |y|)) - (SPADLET T$ (OR (|comp| |y1| |$EmptyMode| |e|) (RETURN NIL))) - (SPADLET |y'| (CAR T$)) - (SPADLET |m| (CADR T$)) - (SPADLET |e| (CADDR T$)) - (|markImport| |m|) - (COND - ((AND (BOOT-EQUAL |m| '$) - (PROGN - (SPADLET |ISTMP#1| - (LASSOC '|value| (|getProplist| '|Rep| |e|))) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) - (MEMQ (|opOf| |a|) '(|List| |Vector|))) - (CONS (|markRepper| '|rep| |y'|) - (CONS '|Rep| (CONS |e| NIL)))) - ('T T$)))))) - -;markReduceIn(it, pr) == markReduceIterator("in",it,pr) - -(DEFUN |markReduceIn| (|it| |pr|) - (|markReduceIterator| '|in| |it| |pr|)) - -;markReduceStep(it, pr) == markReduceIterator("step", it, pr) - -(DEFUN |markReduceStep| (|it| |pr|) - (|markReduceIterator| '|step| |it| |pr|)) - -;markReduceWhile(it, pr) == markReduceIterator("while", it, pr) - -(DEFUN |markReduceWhile| (|it| |pr|) - (|markReduceIterator| '|while| |it| |pr|)) - -;markReduceUntil(it, pr) == markReduceIterator("until", it, pr) - -(DEFUN |markReduceUntil| (|it| |pr|) - (|markReduceIterator| '|until| |it| |pr|)) - -;markReduceSuchthat(it, pr) == markReduceIterator("suchthat", it, pr) - -(DEFUN |markReduceSuchthat| (|it| |pr|) - (|markReduceIterator| '|suchthat| |it| |pr|)) - -;markReduceIterator(kind, it, pr) == [mkWi(kind, 'WI, it, CAR pr), :CDR pr] - -(DEFUN |markReduceIterator| (|kind| |it| |pr|) - (CONS (|mkWi| |kind| 'WI |it| (CAR |pr|)) (CDR |pr|))) - -;markReduceBody(body,T) == -; tcheck T -; [mkWi("reduceBody",'WI,body,CAR T), :CDR T] - -(DEFUN |markReduceBody| (|body| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|reduceBody| 'WI |body| (CAR T$)) (CDR T$)))) - -;markReduce(form, T) == -; tcheck T -; [SETQ($funk,mkWi("reduce", 'WI,form,CAR T)), :CDR T] - -(DEFUN |markReduce| (|form| T$) - (declare (special |$funk|)) - (PROGN - (|tcheck| T$) - (CONS (SETQ |$funk| (|mkWi| '|reduce| 'WI |form| (CAR T$))) - (CDR T$)))) - -;markRepeatBody(body,T) == -; tcheck T -; [mkWi("repeatBody",'WI,body,CAR T), :CDR T] - -(DEFUN |markRepeatBody| (|body| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|repeatBody| 'WI |body| (CAR T$)) (CDR T$)))) - -;markRepeat(form, T) == -; tcheck T -; [mkWi("repeat", 'WI,form,CAR T), :CDR T] - -(DEFUN |markRepeat| (|form| T$) - (PROGN - (|tcheck| T$) - (CONS (|mkWi| '|repeat| 'WI |form| (CAR T$)) (CDR T$)))) - -;markTran(form,form',[dc,:sig],env) == --from compElt/compFormWithModemap -; dc ^= 'Rep or ^MEMQ('_$,sig) => mkWi('markTran,'WI,form,['call,:form']) -; argl := [u for t in rest sig for arg in rest form'] where u == -; t='_$ => -; argSource := getSourceWI arg -; IDENTP argSource and getmode(argSource,env) = 'Rep => arg -; markRepper('rep,arg) -; arg -; form' := ['call,CAR form',:argl] -; wi := mkWi('markTran,'WI,form,form') -; CAR sig = '_$ => markRepper('per,wi) -; wi - -(DEFUN |markTran| (|form| |form'| G166513 |env|) - (PROG (|dc| |sig| |argSource| |argl| |wi|) - (RETURN - (SEQ (PROGN - (SPADLET |dc| (CAR G166513)) - (SPADLET |sig| (CDR G166513)) - (COND - ((OR (NEQUAL |dc| '|Rep|) (NULL (MEMQ '$ |sig|))) - (|mkWi| '|markTran| 'WI |form| (CONS '|call| |form'|))) - ('T - (SPADLET |argl| - (PROG (G166527) - (SPADLET G166527 NIL) - (RETURN - (DO ((G166533 (CDR |sig|) - (CDR G166533)) - (|t| NIL) - (G166534 (CDR |form'|) - (CDR G166534)) - (|arg| NIL)) - ((OR (ATOM G166533) - (PROGN - (SETQ |t| (CAR G166533)) - NIL) - (ATOM G166534) - (PROGN - (SETQ |arg| (CAR G166534)) - NIL)) - (NREVERSE0 G166527)) - (SEQ (EXIT - (SETQ G166527 - (CONS - (COND - ((BOOT-EQUAL |t| '$) - (SPADLET |argSource| - (|getSourceWI| |arg|)) - (COND - ((AND (IDENTP |argSource|) - (BOOT-EQUAL - (|getmode| |argSource| - |env|) - '|Rep|)) - |arg|) - ('T - (|markRepper| '|rep| - |arg|)))) - ('T |arg|)) - G166527)))))))) - (SPADLET |form'| - (CONS '|call| (CONS (CAR |form'|) |argl|))) - (SPADLET |wi| (|mkWi| '|markTran| 'WI |form| |form'|)) - (COND - ((BOOT-EQUAL (CAR |sig|) '$) - (|markRepper| '|per| |wi|)) - ('T |wi|))))))))) - -;markRepper(key,form) == ['REPPER,nil,key,form] - -(DEFUN |markRepper| (|key| |form|) - (CONS 'REPPER (CONS NIL (CONS |key| (CONS |form| NIL))))) - -;markDeclaredImport d == markImport(d,true) - -(DEFUN |markDeclaredImport| (|d|) (|markImport| |d| 'T)) - -;markImport(d,:option) == --from compFormWithModemap/genDeltaEntry/compImport -; if CONTAINED('PART,d) then pause d -; declared? := IFCAR option -; null d or d = $Representation => nil -; d is [op,:.] and MEMQ(op,'(Boolean Mapping Void Segment UniversalSegment)) => nil -; STRINGP d or (IDENTP d and (PNAME d).0 = char '_#) => nil -; MEMQ(d,'(_$ _$NoValueMode _$EmptyMode Void)) => nil -;-------=======+> WHY DOESN'T THIS WORK???????????? -;--if (d' := macroExpand(d,$e)) ^= d then markImport(d',declared?) -; dom := markMacroTran d -;--if IDENTP dom and dom = d and not getmode(dom,$e) then dom := ['MyENUM, d] -; categoryForm? dom => nil -; $insideCapsuleFunctionIfTrue => -; $localImportStack := insert(dom,$localImportStack) -; if IFCAR option then $localDeclareStack := insert(dom,$localDeclareStack) -; if BOUNDP '$globalImportStack then -; $globalImportStack := insert(dom,$globalImportStack) -; if IFCAR option then $globalDeclareStack := insert(dom,$globalDeclareStack) - -(DEFUN |markImport| (&REST G166572 &AUX |option| |d|) - (DSETQ (|d| . |option|) G166572) - (PROG (|declared?| |op| |dom|) - (declare (special |$globalDeclareStack| |$globalImportStack| - |$localDeclareStack| |$localImportStack| - |$insideCapsuleFunctionIfTrue| |$Representation|)) - (RETURN - (PROGN - (COND ((CONTAINED 'PART |d|) (|pause| |d|))) - (SPADLET |declared?| (IFCAR |option|)) - (COND - ((OR (NULL |d|) (BOOT-EQUAL |d| |$Representation|)) NIL) - ((AND (PAIRP |d|) (PROGN (SPADLET |op| (QCAR |d|)) 'T) - (MEMQ |op| - '(|Boolean| |Mapping| |Void| |Segment| - |UniversalSegment|))) - NIL) - ((OR (STRINGP |d|) - (AND (IDENTP |d|) - (BOOT-EQUAL (ELT (PNAME |d|) 0) (|char| '|#|)))) - NIL) - ((MEMQ |d| '($ |$NoValueMode| |$EmptyMode| |Void|)) NIL) - ('T (SPADLET |dom| (|markMacroTran| |d|)) - (COND - ((|categoryForm?| |dom|) NIL) - (|$insideCapsuleFunctionIfTrue| - (SPADLET |$localImportStack| - (|insert| |dom| |$localImportStack|)) - (COND - ((IFCAR |option|) - (SPADLET |$localDeclareStack| - (|insert| |dom| |$localDeclareStack|))) - ('T NIL))) - ((BOUNDP '|$globalImportStack|) - (SPADLET |$globalImportStack| - (|insert| |dom| |$globalImportStack|)) - (COND - ((IFCAR |option|) - (SPADLET |$globalDeclareStack| - (|insert| |dom| |$globalDeclareStack|))) - ('T NIL))) - ('T NIL)))))))) - -;markMacroTran name == --called by markImport -; ATOM name => name -; u := or/[x for [x,:y] in $globalMacroStack | y = name] => u -; u := or/[x for [x,:y] in $localMacroStack | y = name] => u -; [op,:argl] := name -; MEMQ(op,'(Record Union)) => -;-- pp ['"Cannot find: ",name] -; name -; [op,:[markMacroTran x for x in argl]] - -(DEFUN |markMacroTran| (|name|) - (PROG (|x| |y| |u| |op| |argl|) - (declare (special |$localMacroStack| |$globalMacroStack|)) - (RETURN - (SEQ (COND - ((ATOM |name|) |name|) - ((SPADLET |u| - (PROG (G166585) - (SPADLET G166585 NIL) - (RETURN - (DO ((G166593 NIL G166585) - (G166594 |$globalMacroStack| - (CDR G166594)) - (G166573 NIL)) - ((OR G166593 (ATOM G166594) - (PROGN - (SETQ G166573 (CAR G166594)) - NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR G166573)) - (SPADLET |y| (CDR G166573)) - G166573) - NIL)) - G166585) - (SEQ (EXIT (COND - ((BOOT-EQUAL |y| |name|) - (SETQ G166585 - (OR G166585 |x|)))))))))) - |u|) - ((SPADLET |u| - (PROG (G166602) - (SPADLET G166602 NIL) - (RETURN - (DO ((G166610 NIL G166602) - (G166611 |$localMacroStack| - (CDR G166611)) - (G166577 NIL)) - ((OR G166610 (ATOM G166611) - (PROGN - (SETQ G166577 (CAR G166611)) - NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR G166577)) - (SPADLET |y| (CDR G166577)) - G166577) - NIL)) - G166602) - (SEQ (EXIT (COND - ((BOOT-EQUAL |y| |name|) - (SETQ G166602 - (OR G166602 |x|)))))))))) - |u|) - ('T (SPADLET |op| (CAR |name|)) - (SPADLET |argl| (CDR |name|)) - (COND - ((MEMQ |op| '(|Record| |Union|)) |name|) - ('T - (CONS |op| - (PROG (G166623) - (SPADLET G166623 NIL) - (RETURN - (DO ((G166628 |argl| (CDR G166628)) - (|x| NIL)) - ((OR (ATOM G166628) - (PROGN - (SETQ |x| (CAR G166628)) - NIL)) - (NREVERSE0 G166623)) - (SEQ (EXIT (SETQ G166623 - (CONS (|markMacroTran| |x|) - G166623)))))))))))))))) - -;markSetq(originalLet,T) == --for compSetq -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; $coerceList : local := nil -; ['LET,form,originalBody] := originalLet -; id := markLhs form -; not $insideCapsuleFunctionIfTrue => -; $from : local := '"Setq" -; code := T.expr -; markEncodeChanges(code,nil) -; noriginalLet := markSpliceInChanges originalBody -; if IDENTP id then $domainLevelVariableList := insert(id,$domainLevelVariableList) -; nlet := ['LET,id,noriginalLet] -; entry := [originalLet,:nlet] -; $importStack := [nil,:$importStack] -; $freeStack := [nil,:$freeStack] -; capsuleStack('"Setq", entry) -;-- [markKillMI T.expr,:CDR T] -; [code,:CDR T] -; if MEMQ(id,$domainLevelVariableList) then -; $markFreeStack := insert(id,$markFreeStack) -; T -; T - -(DEFUN |markSetq| (|originalLet| T$) - (PROG (|$coerceList| |$from| |form| |originalBody| |id| |code| - |noriginalLet| |nlet| |entry|) - (DECLARE (SPECIAL |$coerceList| |$from| |$markFreeStack| |$importStack| - |$domainLevelVariableList| |$freeStack| - |$insideCapsuleFunctionIfTrue| |$convert2NewCompiler|)) - (RETURN - (COND - ((AND (BOUNDP '|$convert2NewCompiler|) |$convert2NewCompiler|) - (SPADLET |$coerceList| NIL) - (SPADLET |form| (CADR |originalLet|)) - (SPADLET |originalBody| (CADDR |originalLet|)) - (SPADLET |id| (|markLhs| |form|)) - (COND - ((NULL |$insideCapsuleFunctionIfTrue|) - (SPADLET |$from| "Setq") - (SPADLET |code| (CAR T$)) (|markEncodeChanges| |code| NIL) - (SPADLET |noriginalLet| - (|markSpliceInChanges| |originalBody|)) - (COND - ((IDENTP |id|) - (SPADLET |$domainLevelVariableList| - (|insert| |id| |$domainLevelVariableList|)))) - (SPADLET |nlet| - (CONS 'LET (CONS |id| (CONS |noriginalLet| NIL)))) - (SPADLET |entry| (CONS |originalLet| |nlet|)) - (SPADLET |$importStack| (CONS NIL |$importStack|)) - (SPADLET |$freeStack| (CONS NIL |$freeStack|)) - (|capsuleStack| "Setq" |entry|) - (CONS |code| (CDR T$))) - ('T - (COND - ((MEMQ |id| |$domainLevelVariableList|) - (SPADLET |$markFreeStack| - (|insert| |id| |$markFreeStack|)))) - T$))) - ('T T$))))) - -;markCapsuleExpression(originalExpr, T) == -; $coerceList: local := nil -; $from: local := '"Capsule expression" -; code := T.expr -; markEncodeChanges(code, nil) -; noriginal := markSpliceInChanges originalExpr -; nexpr := noriginal -; entry := [originalExpr,:nexpr] -; $importStack := [nil,:$importStack] -; $freeStack := [nil,:$freeStack] -; capsuleStack('"capsuleExpression", entry) -; [code,:CDR T] - -(DEFUN |markCapsuleExpression| (|originalExpr| T$) - (PROG (|$coerceList| |$from| |code| |noriginal| |nexpr| |entry|) - (DECLARE (SPECIAL |$coerceList| |$from| |$freeStack| |$importStack|)) - (RETURN - (PROGN - (SPADLET |$coerceList| NIL) - (SPADLET |$from| "Capsule expression") - (SPADLET |code| (CAR T$)) - (|markEncodeChanges| |code| NIL) - (SPADLET |noriginal| (|markSpliceInChanges| |originalExpr|)) - (SPADLET |nexpr| |noriginal|) - (SPADLET |entry| (CONS |originalExpr| |nexpr|)) - (SPADLET |$importStack| (CONS NIL |$importStack|)) - (SPADLET |$freeStack| (CONS NIL |$freeStack|)) - (|capsuleStack| "capsuleExpression" |entry|) - (CONS |code| (CDR T$)))))) - -;markLhs x == -; x is [":",a,.] => a -; atom x => x -; x --ignore - -(DEFUN |markLhs| (|x|) - (PROG (|ISTMP#1| |a| |ISTMP#2|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL)))))) - |a|) - ((ATOM |x|) |x|) - ('T |x|))))) - -;capsuleStack(name,entry) == -;-- if $monitorWI then -;-- sayBrightlyNT ['"Stacking ",name,'": "] -;-- pp entry -; $capsuleStack := [COPY entry,:$capsuleStack] -; $predicateStack := [$predl, :$predicateStack] -; signature := -; $insideCapsuleFunctionIfTrue => $signatureOfForm -; nil -; $signatureStack := [signature, :$signatureStack] - -(DEFUN |capsuleStack| (|name| |entry|) - (declare (ignore |name|)) - (PROG (|signature|) - (declare (special |$signatureStack| |$signatureOfForm| |$capsuleStack| - |$insideCapsuleFunctionIfTrue| |$predicateStack| |$predl|)) - (RETURN - (PROGN - (SPADLET |$capsuleStack| (CONS (COPY |entry|) |$capsuleStack|)) - (SPADLET |$predicateStack| (CONS |$predl| |$predicateStack|)) - (SPADLET |signature| - (COND - (|$insideCapsuleFunctionIfTrue| |$signatureOfForm|) - ('T NIL))) - (SPADLET |$signatureStack| - (CONS |signature| |$signatureStack|)))))) - -;foobar(x) == x - -(DEFUN |foobar| (|x|) |x|) - -;foobum(x) == x --from doIT - -(DEFUN |foobum| (|x|) |x|) - -;--====================================================================== -;-- Capsule Function Transformations -;--====================================================================== -;--called from compDefineCapsuleFunction -;markChanges(originalDef,T,sig) == -; BOUNDP '$convert2NewCompiler and $convert2NewCompiler => -; if $insideCategoryIfTrue and $insideFunctorIfTrue then -; originalDef := markCatsub(originalDef) -; T := [markCatsub(T.expr), -; markCatsub(T.mode),T.env] -; sig := markCatsub(sig) -; $importStack := markCatsub($importStack) -;-- T := coerce(T,first sig) ---> needed to wrap a "per" around a Rep type -; code := T.expr -; $e : local := T.env -; $coerceList : local := nil -; $hoho := code -; ['DEF,form,.,.,originalBody] := originalDef -; signature := markFindOriginalSignature(form,sig) -; $from : local := '"compDefineFunctor1" -; markEncodeChanges(code,nil) -; frees := -; null $markFreeStack => nil -; [['free,:mySort REMDUP $markFreeStack]] -; noriginalBody := markSpliceInChanges originalBody -; nbody := augmentBodyByLoopDecls noriginalBody -; ndef := ['DEF,form,signature,[nil for x in form],nbody] -; $freeStack := [frees,:$freeStack] -; --------------------> import code <------------------ -; imports := $localImportStack -; subtractions := UNION($localDeclareStack,UNION($globalDeclareStack, -; UNION($globalImportStack,signature))) -; if $insideCategoryIfTrue and $insideFunctorIfTrue then -; imports := markCatsub imports -; subtractions := markCatsub subtractions -; imports := [markMacroTran d for d in imports] -; subtractions := [markMacroTran d for d in subtractions] -; subtractions := UNION(subtractions, getImpliedImports imports) -; $importStack := [reduceImports SETDIFFERENCE(imports,subtractions),:$importStack] -; -------------------> import code <------------------ -; entry := [originalDef,:ndef] -; capsuleStack('"Def",entry) -; nil - -(DEFUN |markChanges| (|originalDef| T$ |sig|) - (PROG (|$e| |$coerceList| |$from| |code| |form| |originalBody| - |signature| |frees| |noriginalBody| |nbody| |ndef| - |imports| |subtractions| |entry|) - (DECLARE (SPECIAL |$e| |$coerceList| |$from| |$importStack| |$hoho| - |$insideCategoryIfTrue| |$insideFunctorIfTrue| - |$globalImportStack| |$globalDeclareStack| - |$localDeclareStack| |$localImportStack| |$freeStack| - |$markFreeStack| |$convert2NewCompiler|)) - (RETURN - (SEQ (COND - ((AND (BOUNDP '|$convert2NewCompiler|) - |$convert2NewCompiler|) - (COND - ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) - (SPADLET |originalDef| (|markCatsub| |originalDef|)) - (SPADLET T$ - (CONS (|markCatsub| (CAR T$)) - (CONS (|markCatsub| (CADR T$)) - (CONS (CADDR T$) NIL)))) - (SPADLET |sig| (|markCatsub| |sig|)) - (SPADLET |$importStack| (|markCatsub| |$importStack|)))) - (SPADLET |code| (CAR T$)) (SPADLET |$e| (CADDR T$)) - (SPADLET |$coerceList| NIL) (SPADLET |$hoho| |code|) - (SPADLET |form| (CADR |originalDef|)) - (SPADLET |originalBody| (CAR (CDDDDR |originalDef|))) - (SPADLET |signature| - (|markFindOriginalSignature| |form| |sig|)) - (SPADLET |$from| "compDefineFunctor1") - (|markEncodeChanges| |code| NIL) - (SPADLET |frees| - (COND - ((NULL |$markFreeStack|) NIL) - ('T - (CONS (CONS '|free| - (|mySort| - (REMDUP |$markFreeStack|))) - NIL)))) - (SPADLET |noriginalBody| - (|markSpliceInChanges| |originalBody|)) - (SPADLET |nbody| - (|augmentBodyByLoopDecls| |noriginalBody|)) - (SPADLET |ndef| - (CONS 'DEF - (CONS |form| - (CONS |signature| - (CONS - (PROG (G166734) - (SPADLET G166734 NIL) - (RETURN - (DO - ((G166739 |form| - (CDR G166739)) - (|x| NIL)) - ((OR (ATOM G166739) - (PROGN - (SETQ |x| - (CAR G166739)) - NIL)) - (NREVERSE0 G166734)) - (SEQ - (EXIT - (SETQ G166734 - (CONS NIL G166734))))))) - (CONS |nbody| NIL)))))) - (SPADLET |$freeStack| (CONS |frees| |$freeStack|)) - (SPADLET |imports| |$localImportStack|) - (SPADLET |subtractions| - (|union| |$localDeclareStack| - (|union| |$globalDeclareStack| - (|union| |$globalImportStack| - |signature|)))) - (COND - ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) - (SPADLET |imports| (|markCatsub| |imports|)) - (SPADLET |subtractions| (|markCatsub| |subtractions|)))) - (SPADLET |imports| - (PROG (G166749) - (SPADLET G166749 NIL) - (RETURN - (DO ((G166754 |imports| (CDR G166754)) - (|d| NIL)) - ((OR (ATOM G166754) - (PROGN - (SETQ |d| (CAR G166754)) - NIL)) - (NREVERSE0 G166749)) - (SEQ (EXIT (SETQ G166749 - (CONS (|markMacroTran| |d|) - G166749)))))))) - (SPADLET |subtractions| - (PROG (G166764) - (SPADLET G166764 NIL) - (RETURN - (DO ((G166769 |subtractions| - (CDR G166769)) - (|d| NIL)) - ((OR (ATOM G166769) - (PROGN - (SETQ |d| (CAR G166769)) - NIL)) - (NREVERSE0 G166764)) - (SEQ (EXIT (SETQ G166764 - (CONS (|markMacroTran| |d|) - G166764)))))))) - (SPADLET |subtractions| - (|union| |subtractions| - (|getImpliedImports| |imports|))) - (SPADLET |$importStack| - (CONS (|reduceImports| - (SETDIFFERENCE |imports| - |subtractions|)) - |$importStack|)) - (SPADLET |entry| (CONS |originalDef| |ndef|)) - (|capsuleStack| "Def" |entry|)) - ('T NIL)))))) - -;reduceImports x == -; [k, o] := reduceImports1 x -; SETDIFFERENCE(o,k) - -(DEFUN |reduceImports| (|x|) - (PROG (|LETTMP#1| |k| |o|) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (|reduceImports1| |x|)) - (SPADLET |k| (CAR |LETTMP#1|)) - (SPADLET |o| (CADR |LETTMP#1|)) - (SETDIFFERENCE |o| |k|))))) - -;reduceImports1 x == -; kills := nil -; others:= nil -; for y in x repeat -; y is ['List,a] => -; [k,o] := reduceImports1 [a] -; kills := UNION(y,UNION(k,kills)) -; others:= UNION(o, others) -; RASSOC(y,$globalImportDefAlist) => kills := insert(y,kills) -; others := insert(y, others) -; [kills, others] - -(DEFUN |reduceImports1| (|x|) - (PROG (|ISTMP#1| |a| |LETTMP#1| |k| |o| |kills| |others|) - (declare (special |$globalImportDefAlist|)) - (RETURN - (SEQ (PROGN - (SPADLET |kills| NIL) - (SPADLET |others| NIL) - (DO ((G166848 |x| (CDR G166848)) (|y| NIL)) - ((OR (ATOM G166848) - (PROGN (SETQ |y| (CAR G166848)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |y|) (EQ (QCAR |y|) '|List|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - 'T)))) - (SPADLET |LETTMP#1| - (|reduceImports1| (CONS |a| NIL))) - (SPADLET |k| (CAR |LETTMP#1|)) - (SPADLET |o| (CADR |LETTMP#1|)) - (SPADLET |kills| - (|union| |y| - (|union| |k| |kills|))) - (SPADLET |others| (|union| |o| |others|))) - ((|rassoc| |y| |$globalImportDefAlist|) - (SPADLET |kills| (|insert| |y| |kills|))) - ('T - (SPADLET |others| (|insert| |y| |others|))))))) - (CONS |kills| (CONS |others| NIL))))))) - -;getImpliedImports x == -; x is [[op,:r],:y] => -; MEMQ(op, '(List Enumeration)) => UNION(r, getImpliedImports y) -; getImpliedImports y -; nil - -(DEFUN |getImpliedImports| (|x|) - (PROG (|ISTMP#1| |op| |r| |y|) - (RETURN - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |op| (QCAR |ISTMP#1|)) - (SPADLET |r| (QCDR |ISTMP#1|)) - 'T))) - (PROGN (SPADLET |y| (QCDR |x|)) 'T)) - (COND - ((MEMQ |op| '(|List| |Enumeration|)) - (|union| |r| (|getImpliedImports| |y|))) - ('T (|getImpliedImports| |y|)))) - ('T NIL))))) - -;augmentBodyByLoopDecls body == -; null $localLoopVariables => body -; lhs := -; $localLoopVariables is [.] => first $localLoopVariables -; ['LISTOF,:$localLoopVariables] -; form := [":",lhs,$SmallInteger] -; body is ['SEQ,:r] => ['SEQ,form,:r] -; ['SEQ,form,['exit,1,body]] - -(DEFUN |augmentBodyByLoopDecls| (|body|) - (PROG (|lhs| |form| |r|) - (declare (special |$SmallInteger| |$localLoopVariables|)) - (RETURN - (COND - ((NULL |$localLoopVariables|) |body|) - ('T - (SPADLET |lhs| - (COND - ((AND (PAIRP |$localLoopVariables|) - (EQ (QCDR |$localLoopVariables|) NIL)) - (CAR |$localLoopVariables|)) - ('T (CONS 'LISTOF |$localLoopVariables|)))) - (SPADLET |form| - (CONS '|:| (CONS |lhs| (CONS |$SmallInteger| NIL)))) - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) 'SEQ) - (PROGN (SPADLET |r| (QCDR |body|)) 'T)) - (CONS 'SEQ (CONS |form| |r|))) - ('T - (CONS 'SEQ - (CONS |form| - (CONS (CONS '|exit| (CONS 1 (CONS |body| NIL))) - NIL)))))))))) - -;markFindOriginalSignature(form,sig) == -; target := $originalTarget -; id := opOf form -; n := #form -; cat := -; target is ['Join,:.,u] => u -; target -; target isnt ['CATEGORY,.,:v] => sig -; or/[sig' for x in v | x is ['SIGNATURE,=id,sig'] and #sig' = n -; and markFindCompare(sig',sig)] or sig - -(DEFUN |markFindOriginalSignature| (|form| |sig|) - (PROG (|target| |id| |n| |u| |cat| |v| |ISTMP#1| |ISTMP#2| |sig'|) - (declare (special |$originalTarget|)) - (RETURN - (SEQ (PROGN - (SPADLET |target| |$originalTarget|) - (SPADLET |id| (|opOf| |form|)) - (SPADLET |n| (|#| |form|)) - (SPADLET |cat| - (COND - ((AND (PAIRP |target|) - (EQ (QCAR |target|) '|Join|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |u| (QCAR |ISTMP#2|)) - 'T)))) - |u|) - ('T |target|))) - (COND - ((NULL (AND (PAIRP |target|) - (EQ (QCAR |target|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |target|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |v| (QCDR |ISTMP#1|)) - 'T))))) - |sig|) - ('T - (OR (PROG (G166915) - (SPADLET G166915 NIL) - (RETURN - (DO ((G166922 NIL G166915) - (G166923 |v| (CDR G166923)) (|x| NIL)) - ((OR G166922 (ATOM G166923) - (PROGN - (SETQ |x| (CAR G166923)) - NIL)) - G166915) - (SEQ (EXIT (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) 'SIGNATURE) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQUAL (QCAR |ISTMP#1|) - |id|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |sig'| - (QCAR |ISTMP#2|)) - 'T))))) - (BOOT-EQUAL (|#| |sig'|) |n|) - (|markFindCompare| |sig'| - |sig|)) - (SETQ G166915 - (OR G166915 |sig'|))))))))) - |sig|)))))))) - -;markFindCompare(sig',sig) == -; macroExpand(sig',$e) = sig - -(DEFUN |markFindCompare| (|sig'| |sig|) - (declare (special |$e|)) - (BOOT-EQUAL (|macroExpand| |sig'| |$e|) |sig|)) - -;--====================================================================== -;-- Capsule Function: Encode Changes on $coerceList -;--====================================================================== -;--(WI a b) mean Was a Is b -;--(WI c (WI d e) b) means Was d Is b -;--(AUTOxxx p q (WI a b)) means a::q for reason xxx=SUBSET or HARD -;--(ATOM nil (REPLACE (x)) y) means replace y by x -;--(COLON :: A B) means rewrite as A :: B (or A @ B or A : B) -;--(LAMBDA nil (REPLACE fn) y)means replace y by fn -;--(REPPER nil per form) means replace form by per(form) -;--(FREESI nil (REPLACE decl) y) means replace y by fn -;markEncodeChanges(x,s) == -;--x is a piece of target code -;--s is a stack [a, b, ..., c] such that a < b < ... -;--calls ..markPath.. to find the location of i in a in c (the orig expression), -;-- where i is derived from x (it is the source component of x); -;-- if markPath fails to find a path for i in c, then x is wrong! -;--first time only: put ORIGNAME on property list of operators with a ; in name -; if null s then markOrigName x -; x is [fn,a,b,c] and MEMQ(fn,$markChoices) => -; x is ['ATOM,.,['REPLACE,[y],:.],:.] and MEMQ(y,'(false true)) => 'skip -; ---------------------------------------------------------------------- -; if c then ----> special case: DON'T STACK A nil!!!! -; i := getSourceWI c -; t := getTargetWI c -; -- sayBrightly ['"=> ",i,'" ---> "] -; -- sayBrightly ['" from ",a,'" to ",b] -; s := [i,:s] -;-- pp '"===========" -;-- pp x -; markRecord(a,b,s) -; markEncodeChanges(t,s) -; x is ['WI,p,q] or x is ['MI,p,q] => -; i := getSourceWI p -; r := getTargetWI q -; r is [fn,a,b,c] and MEMQ(fn,$markChoices) => -; t := getTargetWI c -;-- sayBrightly ['"==> ",i,'" ---> "] -;-- sayBrightly ['" from ",a,'" to ",b] -; s := [i,:s] -; markRecord(a,b,s) -; markEncodeChanges(t,s) -; i is [fn,:.] and MEMQ(fn, '(REPEAT COLLECT)) => markEncodeLoop(i,r,s) -; t := getTargetWI r -; markEncodeChanges(t,[i,:s]) -; x is ['PROGN,a,:.] and s is [[op,:.],:.] and MEMQ(op,'(REPEAT COLLECT)) => -; markEncodeChanges(a,s) -; x is ['TAGGEDreturn,a,[y,:.]] => markEncodeChanges(y,s) -; x is ['CATCH,a,y] => markEncodeChanges(y,s) -; atom x => nil -;-- CAR x = IFCAR IFCAR s => -;-- for y in x for r in CAR s repeat markEncodeChanges(y,[r,:s]) -; for y in x repeat markEncodeChanges(y,s) - -(DEFUN |markEncodeChanges| (|x| |s|) - (PROG (|ISTMP#4| |ISTMP#5| |p| |q| |i| |r| |b| |c| |fn| |t| |op| - |ISTMP#3| |ISTMP#1| |a| |ISTMP#2| |y|) - (declare (special |$markChoices|)) - (RETURN - (SEQ (PROGN - (COND ((NULL |s|) (|markOrigName| |x|))) - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |fn| (QCAR |x|)) - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T))))))) - (MEMQ |fn| |$markChoices|)) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'ATOM) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) 'REPLACE) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |ISTMP#5| - (QCAR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) - NIL) - (PROGN - (SPADLET |y| - (QCAR |ISTMP#5|)) - 'T))))))))))) - (MEMQ |y| '(|false| |true|))) - '|skip|) - ('T - (COND - (|c| (SPADLET |i| (|getSourceWI| |c|)) - (SPADLET |t| (|getTargetWI| |c|)) - (SPADLET |s| (CONS |i| |s|)))) - (|markRecord| |a| |b| |s|) - (|markEncodeChanges| |t| |s|)))) - ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |q| (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |q| (QCAR |ISTMP#2|)) - 'T))))))) - (SPADLET |i| (|getSourceWI| |p|)) - (SPADLET |r| (|getTargetWI| |q|)) - (COND - ((AND (PAIRP |r|) - (PROGN - (SPADLET |fn| (QCAR |r|)) - (SPADLET |ISTMP#1| (QCDR |r|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| - (QCAR |ISTMP#3|)) - 'T))))))) - (MEMQ |fn| |$markChoices|)) - (SPADLET |t| (|getTargetWI| |c|)) - (SPADLET |s| (CONS |i| |s|)) - (|markRecord| |a| |b| |s|) - (|markEncodeChanges| |t| |s|)) - ((AND (PAIRP |i|) - (PROGN (SPADLET |fn| (QCAR |i|)) 'T) - (MEMQ |fn| '(REPEAT COLLECT))) - (|markEncodeLoop| |i| |r| |s|)) - ('T (SPADLET |t| (|getTargetWI| |r|)) - (|markEncodeChanges| |t| (CONS |i| |s|))))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PROGN) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) - (PAIRP |s|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |s|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |op| (QCAR |ISTMP#1|)) 'T))) - (MEMQ |op| '(REPEAT COLLECT))) - (|markEncodeChanges| |a| |s|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|TAGGEDreturn|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#3|)) - 'T)))))))) - (|markEncodeChanges| |y| |s|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'CATCH) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - 'T)))))) - (|markEncodeChanges| |y| |s|)) - ((ATOM |x|) NIL) - ('T - (DO ((G167169 |x| (CDR G167169)) (|y| NIL)) - ((OR (ATOM G167169) - (PROGN (SETQ |y| (CAR G167169)) NIL)) - NIL) - (SEQ (EXIT (|markEncodeChanges| |y| |s|))))))))))) - -;markOrigName x == -; x is [op,:r] => -; op = 'TAGGEDreturn and x is [.,a,[y,:.]] => markOrigName y -; for y in r repeat markOrigName y -; IDENTP op => -; s := PNAME op -; k := charPosition(char '_;, s, 0) -; k > MAXINDEX s => nil -; origName := INTERN SUBSTRING(s, k + 1, nil) -; MAKEPROP(op, 'ORIGNAME, origName) -; REMPROP(op,'PNAME) -; markOrigName op -; nil - -(DEFUN |markOrigName| (|x|) - (PROG (|op| |r| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |y| |s| |k| - |origName|) - (RETURN - (SEQ (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |r| (QCDR |x|)) - 'T)) - (COND - ((AND (BOOT-EQUAL |op| '|TAGGEDreturn|) (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#3|)) - 'T)))))))) - (|markOrigName| |y|)) - ('T - (DO ((G167263 |r| (CDR G167263)) (|y| NIL)) - ((OR (ATOM G167263) - (PROGN (SETQ |y| (CAR G167263)) NIL)) - NIL) - (SEQ (EXIT (|markOrigName| |y|)))) - (COND - ((IDENTP |op|) (SPADLET |s| (PNAME |op|)) - (SPADLET |k| (|charPosition| (|char| '|;|) |s| 0)) - (COND - ((> |k| (MAXINDEX |s|)) NIL) - ('T - (SPADLET |origName| - (INTERN (SUBSTRING |s| (PLUS |k| 1) - NIL))) - (MAKEPROP |op| 'ORIGNAME |origName|) - (REMPROP |op| 'PNAME)))) - ('T (|markOrigName| |op|)))))) - ('T NIL)))))) - -;markEncodeLoop(i, r, s) == -; [.,:itl1, b1] := i --op is REPEAT or COLLECT -; if r is ['LET,.,a] then r := a -; r is [op1,:itl2,b2] and MEMQ(op1, '(REPEAT COLLECT)) => -; for it1 in itl1 for it2 in itl2 repeat markEncodeChanges(it2,[it1,:s]) -; markEncodeChanges(b2, [b1,:s]) -; markEncodeChanges(r, [i,:s]) - -(DEFUN |markEncodeLoop| (|i| |r| |s|) - (PROG (|LETTMP#1| |b1| |itl1| |a| |op1| |ISTMP#1| |ISTMP#2| |b2| - |itl2|) - (RETURN - (SEQ (PROGN - (SPADLET |LETTMP#1| (REVERSE (CDR |i|))) - (SPADLET |b1| (CAR |LETTMP#1|)) - (SPADLET |itl1| (NREVERSE (CDR |LETTMP#1|))) - (COND - ((AND (PAIRP |r|) (EQ (QCAR |r|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |r|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |r| |a|))) - (COND - ((AND (PAIRP |r|) - (PROGN - (SPADLET |op1| (QCAR |r|)) - (SPADLET |ISTMP#1| (QCDR |r|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b2| (QCAR |ISTMP#2|)) - (SPADLET |itl2| (QCDR |ISTMP#2|)) - 'T) - (PROGN - (SPADLET |itl2| (NREVERSE |itl2|)) - 'T))) - (MEMQ |op1| '(REPEAT COLLECT))) - (DO ((G167324 |itl1| (CDR G167324)) (|it1| NIL) - (G167325 |itl2| (CDR G167325)) (|it2| NIL)) - ((OR (ATOM G167324) - (PROGN (SETQ |it1| (CAR G167324)) NIL) - (ATOM G167325) - (PROGN (SETQ |it2| (CAR G167325)) NIL)) - NIL) - (SEQ (EXIT (|markEncodeChanges| |it2| - (CONS |it1| |s|))))) - (|markEncodeChanges| |b2| (CONS |b1| |s|))) - ('T (|markEncodeChanges| |r| (CONS |i| |s|))))))))) - -;getSourceWI x == -;--Subfunction of markEncodeChanges -; x is ['WI,a,b] or x is ['MI,a,b] => -; a is ['WI,:.] or a is ['MI,:.] => getSourceWI a -; markRemove a -; markRemove x - -(DEFUN |getSourceWI| (|x|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (COND - ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))))) - (COND - ((OR (AND (PAIRP |a|) (EQ (QCAR |a|) 'WI)) - (AND (PAIRP |a|) (EQ (QCAR |a|) 'MI))) - (|getSourceWI| |a|)) - ('T (|markRemove| |a|)))) - ('T (|markRemove| |x|)))))) - -;markRemove x == -; atom x => x -; x is ['WI,a,b] or x is ['MI,a,b] => markRemove a -; x is [fn,a,b,c] and MEMQ(fn,$markChoices) => -; markRemove c -;--x is ['TAGGEDreturn,:.] => x -; x is ['TAGGEDreturn,a,[x,m,t]] => ['TAGGEDreturn,a,[markRemove x,m,t]] -; [markRemove y for y in x] - -(DEFUN |markRemove| (|x|) - (PROG (|fn| |b| |c| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |ISTMP#4| |m| - |ISTMP#5| |t|) - (declare (special |$markChoices|)) - (RETURN - (SEQ (COND - ((ATOM |x|) |x|) - ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))))) - (|markRemove| |a|)) - ((AND (PAIRP |x|) - (PROGN - (SPADLET |fn| (QCAR |x|)) - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T))))))) - (MEMQ |fn| |$markChoices|)) - (|markRemove| |c|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|TAGGEDreturn|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |m| (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |t| - (QCAR |ISTMP#5|)) - 'T)))))))))))) - (CONS '|TAGGEDreturn| - (CONS |a| - (CONS (CONS (|markRemove| |x|) - (CONS |m| (CONS |t| NIL))) - NIL)))) - ('T - (PROG (G167551) - (SPADLET G167551 NIL) - (RETURN - (DO ((G167556 |x| (CDR G167556)) (|y| NIL)) - ((OR (ATOM G167556) - (PROGN (SETQ |y| (CAR G167556)) NIL)) - (NREVERSE0 G167551)) - (SEQ (EXIT (SETQ G167551 - (CONS (|markRemove| |y|) - G167551))))))))))))) - -;getTargetWI x == -;--Subfunction of markEncodeChanges -; x is ['WI,a,b] or x is ['MI,a,b] => getTargetWI b -; x is ['PART,.,a] => getTargetWI a -; x - -(DEFUN |getTargetWI| (|x|) - (PROG (|b| |ISTMP#1| |ISTMP#2| |a|) - (RETURN - (COND - ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'WI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |x|) (EQ (QCAR |x|) 'MI) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))))) - (|getTargetWI| |b|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#2|)) 'T)))))) - (|getTargetWI| |a|)) - ('T |x|))))) - -;markRecord(source,target,u) == -;--Record changes on $coerceList -; if source='_$ and target='Rep then -; target := 'rep -; if source='Rep and target='_$ then -; target := 'per -; item := first u -; FIXP item or item = $One or item = $Zero => nil -; item is ["-",a] and (FIXP a or a = $One or a = $Zero) => nil -; STRINGP item => nil -; item is [op,.,t] and MEMQ(op,'( _:_: _@ _pretend)) -; and macroExpand(t,$e) = target => nil -; $source: local := source -; $target: local := target -; path := markPath u or return nil -----> early exit -; path := -; path = 0 => nil --wrap the WHOLE thing -; path -; if BOUNDP '$shout2 and $shout2 then -; pp '"=========" -; pp path -; ipath := reverse path -; for x in u repeat -; pp x -; ipath => -; pp first ipath -; ipath := rest ipath -; entry := [source,target,:path] -; if $monitorCoerce then -; sayBrightlyNT ['"From ",$from,'": "] -; pp entry -; $coerceList := [COPY entry,:$coerceList] - -(DEFUN |markRecord| (|source| |target| |u|) - (PROG (|$source| |$target| |item| |a| |op| |ISTMP#1| |ISTMP#2| |t| - |path| |ipath| |entry|) - (DECLARE (SPECIAL |$source| |$target| |$coerceList| |$from| |$e| |$Zero| - |$monitorCoerce| |$shout2| |$target| |$source| |$One|)) - (RETURN - (SEQ (PROGN - (COND - ((AND (BOOT-EQUAL |source| '$) - (BOOT-EQUAL |target| '|Rep|)) - (SPADLET |target| '|rep|))) - (COND - ((AND (BOOT-EQUAL |source| '|Rep|) - (BOOT-EQUAL |target| '$)) - (SPADLET |target| '|per|))) - (SPADLET |item| (CAR |u|)) - (COND - ((OR (integerp |item|) (BOOT-EQUAL |item| |$One|) - (BOOT-EQUAL |item| |$Zero|)) - NIL) - ((AND (PAIRP |item|) (EQ (QCAR |item|) '-) - (PROGN - (SPADLET |ISTMP#1| (QCDR |item|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) - (OR (integerp |a|) (BOOT-EQUAL |a| |$One|) - (BOOT-EQUAL |a| |$Zero|))) - NIL) - ((STRINGP |item|) NIL) - ((AND (PAIRP |item|) - (PROGN - (SPADLET |op| (QCAR |item|)) - (SPADLET |ISTMP#1| (QCDR |item|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |op| '(|::| @ |pretend|)) - (BOOT-EQUAL (|macroExpand| |t| |$e|) |target|)) - NIL) - ('T (SPADLET |$source| |source|) - (SPADLET |$target| |target|) - (SPADLET |path| (OR (|markPath| |u|) (RETURN NIL))) - (SPADLET |path| - (COND ((EQL |path| 0) NIL) ('T |path|))) - (COND - ((AND (BOUNDP '|$shout2|) |$shout2|) - (|pp| "=========") (|pp| |path|) - (SPADLET |ipath| (REVERSE |path|)) - (DO ((G167681 |u| (CDR G167681)) (|x| NIL)) - ((OR (ATOM G167681) - (PROGN (SETQ |x| (CAR G167681)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (|pp| |x|) - (COND - (|ipath| - (PROGN - (|pp| (CAR |ipath|)) - (SPADLET |ipath| (CDR |ipath|))))))))))) - (SPADLET |entry| - (CONS |source| (CONS |target| |path|))) - (COND - (|$monitorCoerce| - (|sayBrightlyNT| - (CONS "From " - (CONS |$from| - (CONS ": " NIL)))) - (|pp| |entry|))) - (SPADLET |$coerceList| - (CONS (COPY |entry|) |$coerceList|))))))))) - -;--====================================================================== -;-- Capsule Function: Find dewey decimal path across a list -;--====================================================================== -;markPath u == --u has nested structure: u0 < u1 < u2 ... -; whole := LAST u -; part := first u -; $path := u -; u is [.] => 0 --means THE WHOLE THING -; v := REVERSE markPath1 u -;-- pp '"======mark path======" -;-- foobar v -;-- pp v -;-- pp markKillAll part -;-- pp markKillAll whole -;-- pp $source -;-- pp $target -; null v => nil -; $pathStack := [[v,:u],:$pathStack] -;-- pp '"----------------------------" -;-- ppFull v -;-- pp '"----------------------------" -; v - -(DEFUN |markPath| (|u|) - (PROG (|whole| |part| |v|) - (declare (special |$pathStack| |$path|)) - (RETURN - (PROGN - (SPADLET |whole| (|last| |u|)) - (SPADLET |part| (CAR |u|)) - (SPADLET |$path| |u|) - (COND - ((AND (PAIRP |u|) (EQ (QCDR |u|) NIL)) 0) - ('T (SPADLET |v| (REVERSE (|markPath1| |u|))) - (COND - ((NULL |v|) NIL) - ('T - (SPADLET |$pathStack| (CONS (CONS |v| |u|) |$pathStack|)) - |v|)))))))) - -;markPath1 u == -;-- u is a list [a, b, ... c] -;-- This function calls markGetPath(a,b) to find the location of a in b, etc. -;-- The result is the successful path from a to c -;-- A error printout occurs if no such path can be found -; u is [a,b,:r] => -- a < b < ... -; a = b => markPath1 CDR u ---> allow duplicates on path -; path := markGetPath(a,b) or return nil -----> early exit -; if BOUNDP '$shout1 and $shout1 then -; pp '"=========" -; pp path -; pp a -; pp b -; [:first path,:markPath1 CDR u] -; nil - -(DEFUN |markPath1| (|u|) - (PROG (|a| |ISTMP#1| |b| |r| |path|) - (declare (special |$shout1|)) - (RETURN - (COND - ((AND (PAIRP |u|) - (PROGN - (SPADLET |a| (QCAR |u|)) - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |r| (QCDR |ISTMP#1|)) - 'T)))) - (COND - ((BOOT-EQUAL |a| |b|) (|markPath1| (CDR |u|))) - ('T - (SPADLET |path| (OR (|markGetPath| |a| |b|) (RETURN NIL))) - (COND - ((AND (BOUNDP '|$shout1|) |$shout1|) - (|pp| "=========") (|pp| |path|) (|pp| |a|) - (|pp| |b|))) - (APPEND (CAR |path|) (|markPath1| (CDR |u|)))))) - ('T NIL))))) - -;markGetPath(x,y) == -- x < y ---> find its location -; u := markGetPaths(x,y) -; u is [w] => u -; $amb := [u,x,y] -; key := -; null u => '"no match" -; '"ambiguous" -; sayBrightly ['"-----",key,'"--------"] -; if not BOUNDP '$pathErrorStack then SETQ($pathErrorStack,nil) -; SETQ($pathErrorStack,[$path,:$pathErrorStack]) -; pp "CAUTION: this can cause RPLAC errors" -; pp "Paths are: " -; pp u -; for p in $path for i in 1..3 repeat pp p -; $x: local := x -; $y: local := y -; pp '"---------------------" -; pp x -; pp y -; foobar key -;-- pp [key, $amb] -; null u => [1729] --return something that will surely fail if no path -; [first u] - -(DEFUN |markGetPath| (|x| |y|) - (PROG (|$x| |$y| |u| |w| |key|) - (DECLARE (SPECIAL |$x| |$y| |$path| |$pathErrorStack| |$amb|)) - (RETURN - (SEQ (PROGN - (SPADLET |u| (|markGetPaths| |x| |y|)) - (COND - ((AND (PAIRP |u|) (EQ (QCDR |u|) NIL) - (PROGN (SPADLET |w| (QCAR |u|)) 'T)) - |u|) - ('T - (SPADLET |$amb| (CONS |u| (CONS |x| (CONS |y| NIL)))) - (SPADLET |key| - (COND - ((NULL |u|) "no match") - ('T "ambiguous"))) - (|sayBrightly| - (CONS "-----" - (CONS |key| - (CONS "--------" NIL)))) - (COND - ((NULL (BOUNDP '|$pathErrorStack|)) - (SETQ |$pathErrorStack| NIL))) - (SETQ |$pathErrorStack| - (CONS |$path| |$pathErrorStack|)) - (|pp| '|CAUTION: this can cause RPLAC errors|) - (|pp| '|Paths are: |) (|pp| |u|) - (DO ((G167751 |$path| (CDR G167751)) (|p| NIL) - (|i| 1 (QSADD1 |i|))) - ((OR (ATOM G167751) - (PROGN (SETQ |p| (CAR G167751)) NIL) - (QSGREATERP |i| 3)) - NIL) - (SEQ (EXIT (|pp| |p|)))) - (SPADLET |$x| |x|) (SPADLET |$y| |y|) - (|pp| "---------------------") (|pp| |x|) - (|pp| |y|) (|foobar| |key|) - (COND - ((NULL |u|) (CONS 1729 NIL)) - ('T (CONS (CAR |u|) NIL)))))))))) - -;markTryPaths() == markGetPaths($x,$y) - -(DEFUN |markTryPaths| () - (declare (special |$x| |$y|)) - (|markGetPaths| |$x| |$y|)) - -;markPaths(x,y,s) == --x < y; find location s of x in y (initially s=nil) -;--NOTES: This location is what it will be in the source program with -;-- all PART information removed. -; if BOUNDP '$shout and $shout then -; pp '"-----" -; pp x -; pp y -; pp s -; x = y => s --found it! exit -; markPathsEqual(x,y) => s -; y is [['elt,.,op],:r] and (u := markPaths(x,[op,:r],s)) => u -; x is ['elt,:r] and (u := markPaths(r,y,s)) => u -; y is ['elt,:r] and (u := markPaths(x,r,s)) => u -; x is [op,:u] and MEMQ(op,'(LIST VECTOR)) and y is ['construct,:v] and -; (p := markPaths(['construct,:u],y,s)) => p -; atom y => nil -; y is ['LET,a,b] and IDENTP a => -; markPaths(x,b,markCons(2,s)) --and IDENTP x -; y is ['LET,a,b] and GENSYMP a => markPaths(x,b,s) --for loops -; y is ['IF,a,b,:.] and GENSYMP a => markPaths(x,b,s) --for loops -; y is ['IF,a,b,c] and (p := (markPathsEqual(x,b) => 2; -; markPathsEqual(x,c) => 3; -; nil)) => markCons(p,s) -;-- x is ['exit,a,b] and y is ['exit,a,c] and (p := mymy markPathsEqual(b,c)) => -;-- markCons(p,s) -; y is ['call,:r] => markPaths(x,r,s) --for loops -; y is [fn,m,y1] and MEMQ(fn,'(PART CATCH THROW)) => markPaths(x,y1,s) or -; "APPEND"/[markPaths(x,u,markCons(i,s)) for u in y1 for i in 0..] -; "APPEND"/[markPaths(x,u,markCons(i,s)) for u in y for i in 0..] - -(DEFUN |markPaths| (|x| |y| |s|) - (PROG (|op| |u| |v| |a| |b| |ISTMP#3| |c| |p| |r| |fn| |ISTMP#1| |m| - |ISTMP#2| |y1|) - (declare (special |$shout|)) - (RETURN - (SEQ (PROGN - (COND - ((AND (BOUNDP '|$shout|) |$shout|) - (|pp| "-----") (|pp| |x|) (|pp| |y|) - (|pp| |s|))) - (COND - ((BOOT-EQUAL |x| |y|) |s|) - ((|markPathsEqual| |x| |y|) |s|) - ((AND (PAIRP |y|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |y|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|elt|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |op| (QCAR |ISTMP#3|)) - 'T))))))) - (PROGN (SPADLET |r| (QCDR |y|)) 'T) - (SPADLET |u| - (|markPaths| |x| (CONS |op| |r|) |s|))) - |u|) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) - (PROGN (SPADLET |r| (QCDR |x|)) 'T) - (SPADLET |u| (|markPaths| |r| |y| |s|))) - |u|) - ((AND (PAIRP |y|) (EQ (QCAR |y|) '|elt|) - (PROGN (SPADLET |r| (QCDR |y|)) 'T) - (SPADLET |u| (|markPaths| |x| |r| |s|))) - |u|) - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |u| (QCDR |x|)) - 'T) - (MEMQ |op| '(LIST VECTOR)) (PAIRP |y|) - (EQ (QCAR |y|) '|construct|) - (PROGN (SPADLET |v| (QCDR |y|)) 'T) - (SPADLET |p| - (|markPaths| (CONS '|construct| |u|) |y| - |s|))) - |p|) - ((ATOM |y|) NIL) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (IDENTP |a|)) - (|markPaths| |x| |b| (|markCons| 2 |s|))) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (GENSYMP |a|)) - (|markPaths| |x| |b| |s|)) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (GENSYMP |a|)) - (|markPaths| |x| |b| |s|)) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T))))))) - (SPADLET |p| - (COND - ((|markPathsEqual| |x| |b|) 2) - ((|markPathsEqual| |x| |c|) 3) - ('T NIL)))) - (|markCons| |p| |s|)) - ((AND (PAIRP |y|) (EQ (QCAR |y|) '|call|) - (PROGN (SPADLET |r| (QCDR |y|)) 'T)) - (|markPaths| |x| |r| |s|)) - ((AND (PAIRP |y|) - (PROGN - (SPADLET |fn| (QCAR |y|)) - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |m| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y1| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |fn| '(PART CATCH THROW))) - (OR (|markPaths| |x| |y1| |s|) - (PROG (G167904) - (SPADLET G167904 NIL) - (RETURN - (DO ((G167910 |y1| (CDR G167910)) (|u| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM G167910) - (PROGN - (SETQ |u| (CAR G167910)) - NIL)) - G167904) - (SEQ (EXIT (SETQ G167904 - (APPEND G167904 - (|markPaths| |x| |u| - (|markCons| |i| |s|))))))))))) - ('T - (PROG (G167916) - (SPADLET G167916 NIL) - (RETURN - (DO ((G167922 |y| (CDR G167922)) (|u| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM G167922) - (PROGN (SETQ |u| (CAR G167922)) NIL)) - G167916) - (SEQ (EXIT (SETQ G167916 - (APPEND G167916 - (|markPaths| |x| |u| - (|markCons| |i| |s|)))))))))))))))) - -;mymy x == x - -(DEFUN |mymy| (|x|) |x|) - -;markCons(i,s) == [[i,:x] for x in s] - -(DEFUN |markCons| (|i| |s|) - (PROG () - (RETURN - (SEQ (PROG (G167979) - (SPADLET G167979 NIL) - (RETURN - (DO ((G167984 |s| (CDR G167984)) (|x| NIL)) - ((OR (ATOM G167984) - (PROGN (SETQ |x| (CAR G167984)) NIL)) - (NREVERSE0 G167979)) - (SEQ (EXIT (SETQ G167979 - (CONS (CONS |i| |x|) G167979))))))))))) - -;markPathsEqual(x,y) == -; x = y => true -; x is ["::",.,a] and y is ["::",.,b] and -; a = '(Integer) and b = '(NonNegativeInteger) => true -; y is [fn,.,z] and MEMQ(fn,'(PART CATCH THROW)) and markPathsEqual(x,z) => true -; y is ['LET,a,b] and GENSYMP a and markPathsEqual(x,b) => true -; y is ['IF,a,b,:.] and GENSYMP a => markPathsEqual(x,b) -------> ??? -; y is ['call,:r] => markPathsEqual(IFCDR x,r) -; x is ['REDUCE,.,.,c,:.] and c is ['COLLECT,:u] and -; y is ['PROGN,.,repeet,:.] and repeet is ['REPEAT,:v] => markPathsEqual(u,v) -; atom y or atom x => -; IDENTP y and IDENTP x and y = GET(x,'ORIGNAME) => true --> see -;-- IDENTP y and IDENTP x and anySubstring?(PNAME y,PNAME x,0) => true -; IDENTP y and (z := markPathsMacro y) => markPathsEqual(x,z) -; false -; "and"/[markPathsEqual(u,v) for u in x for v in y] - -(DEFUN |markPathsEqual| (|x| |y|) - (PROG (|fn| |a| |b| |r| |ISTMP#3| |c| |u| |ISTMP#1| |ISTMP#2| - |repeet| |v| |z|) - (RETURN - (SEQ (COND - ((BOOT-EQUAL |x| |y|) 'T) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|::|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - 'T))))) - (PAIRP |y|) (EQ (QCAR |y|) '|::|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (BOOT-EQUAL |a| '(|Integer|)) - (BOOT-EQUAL |b| '(|NonNegativeInteger|))) - 'T) - ((AND (PAIRP |y|) - (PROGN - (SPADLET |fn| (QCAR |y|)) - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |z| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |fn| '(PART CATCH THROW)) - (|markPathsEqual| |x| |z|)) - 'T) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (GENSYMP |a|) (|markPathsEqual| |x| |b|)) - 'T) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (GENSYMP |a|)) - (|markPathsEqual| |x| |b|)) - ((AND (PAIRP |y|) (EQ (QCAR |y|) '|call|) - (PROGN (SPADLET |r| (QCDR |y|)) 'T)) - (|markPathsEqual| (IFCDR |x|) |r|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'REDUCE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T))))))) - (PAIRP |c|) (EQ (QCAR |c|) 'COLLECT) - (PROGN (SPADLET |u| (QCDR |c|)) 'T) (PAIRP |y|) - (EQ (QCAR |y|) 'PROGN) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |repeet| (QCAR |ISTMP#2|)) - 'T))))) - (PAIRP |repeet|) (EQ (QCAR |repeet|) 'REPEAT) - (PROGN (SPADLET |v| (QCDR |repeet|)) 'T)) - (|markPathsEqual| |u| |v|)) - ((OR (ATOM |y|) (ATOM |x|)) - (COND - ((AND (IDENTP |y|) (IDENTP |x|) - (BOOT-EQUAL |y| (GETL |x| 'ORIGNAME))) - 'T) - ((AND (IDENTP |y|) - (SPADLET |z| (|markPathsMacro| |y|))) - (|markPathsEqual| |x| |z|)) - ('T NIL))) - ('T - (PROG (G168093) - (SPADLET G168093 'T) - (RETURN - (DO ((G168100 NIL (NULL G168093)) - (G168101 |x| (CDR G168101)) (|u| NIL) - (G168102 |y| (CDR G168102)) (|v| NIL)) - ((OR G168100 (ATOM G168101) - (PROGN (SETQ |u| (CAR G168101)) NIL) - (ATOM G168102) - (PROGN (SETQ |v| (CAR G168102)) NIL)) - G168093) - (SEQ (EXIT (SETQ G168093 - (AND G168093 - (|markPathsEqual| |u| |v|)))))))))))))) - -;markPathsMacro y == -; LASSOC(y,$localMacroStack) or LASSOC(y,$globalMacroStack) - -(DEFUN |markPathsMacro| (|y|) - (declare (special |$localMacroStack| |$globalMacroStack|)) - (OR (LASSOC |y| |$localMacroStack|) (LASSOC |y| |$globalMacroStack|))) - -;--====================================================================== -;-- Capsule Function: DO the transformations -;--====================================================================== -;--called by markChanges (inside capsule), markSetq (outside capsule) -;markSpliceInChanges body == -;-- pp '"before---->" -;-- pp $coerceList -; $coerceList := REVERSE SORTBY('CDDR,$coerceList) -;-- pp '"after----->" -;-- pp $coerceList -; $cl := $coerceList -;--if CONTAINED('REPLACE,$cl) then hoho $cl -; body := -; body is ['WI,:.] => -;-- hehe body -; markKillAll body -; markKillAll body -;--NOTE!! Important that $coerceList be processed in this order -;--since it must operate from the inside out. For example, a progression -;--u --> u::Rep --> u :: Rep :: $ can only be correct. Here successive -;--entries can have duplicate codes -; for [code,target,:loc] in $coerceList repeat -; $data: local := [code, target, loc] -; if BOUNDP '$hohum and $hohum then -; pp '"---------->>>>>" -; pp $data -; pp body -; pp '"-------------------------->" -; body := markInsertNextChange body -; body - -(DEFUN |markSpliceInChanges| (|body|) - (PROG (|$data| |code| |target| |loc|) - (declare (special |$data|)) - (DECLARE (SPECIAL |$data| |$hohum| |$coerceList| |$cl|)) - (RETURN - (SEQ (PROGN - (SPADLET |$coerceList| - (REVERSE (SORTBY 'CDDR |$coerceList|))) - (SPADLET |$cl| |$coerceList|) - (SPADLET |body| - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) 'WI)) - (|markKillAll| |body|)) - ('T (|markKillAll| |body|)))) - (DO ((G168164 |$coerceList| (CDR G168164)) - (G168151 NIL)) - ((OR (ATOM G168164) - (PROGN (SETQ G168151 (CAR G168164)) NIL) - (PROGN - (PROGN - (SPADLET |code| (CAR G168151)) - (SPADLET |target| (CADR G168151)) - (SPADLET |loc| (CDDR G168151)) - G168151) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |$data| - (CONS |code| - (CONS |target| (CONS |loc| NIL)))) - (COND - ((AND (BOUNDP '|$hohum|) |$hohum|) - (|pp| "---------->>>>>") - (|pp| |$data|) (|pp| |body|) - (|pp| "-------------------------->"))) - (SPADLET |body| - (|markInsertNextChange| |body|)))))) - |body|))))) - -;--pause() == 12 -;markInsertNextChange body == -;-- if BOUNDP '$sayChanges and $sayChanges then -;-- sayBrightlyNT '"Inserting change: " -;-- pp $data -;-- pp body -;-- pause() -; [code, target, loc] := $data -; markInsertChanges(code,body,target,loc) - -(DEFUN |markInsertNextChange| (|body|) - (PROG (|code| |target| |loc|) - (declare (special |$data|)) - (RETURN - (PROGN - (SPADLET |code| (CAR |$data|)) - (SPADLET |target| (CADR |$data|)) - (SPADLET |loc| (CADDR |$data|)) - (|markInsertChanges| |code| |body| |target| |loc|))))) - -;markInsertChanges(code,form,t,loc) == -;--RePLACe x at location "loc" in form as follows: -;-- t is ['REPLACE,r]: by r -;-- t is 'rep/per: by (rep x) or (per x) -;-- code is @ : :: by (@ x t) (: x t) (:: x t) -;-- code is Lisp by (pretend form t) -;-- otherwise by (:: form t) -; loc is [i,:r] => -; x := form -; for j in 0..(i-1) repeat -; if not atom x then x := CDR x -; atom x => -; pp '"Translator RPLACA error" -; pp $data -; foobum form -; form -; if BOUNDP '$hohum and $hohum then pp [i, '" >>> ", x] -; SETQ($CHANGE,COPY x) -; if x is ['elt,:y] and r then x := y -; RPLACA(x,markInsertChanges(code,CAR x,t,rest loc)) -; chk(x,100) -; form -;-- pp ['"Making change: ",code,form,t] -; t is ['REPLACE,r] => SUBST(form,"##1",r) -; form is ['SEQ,:y,['exit,1,z]] => -; ['SEQ,:[markInsertSeq(code,x,t) for x in y], -; ['exit,1,markInsertChanges(code,z,t,nil)]] -; code = '_pretend or code = '_: => -; form is [op,a,.] and MEMQ(op,'(_@ _: _:_: _pretend)) => ['_pretend,a,t] -; [code,form,t] -; MEMQ(code,'(_@ _:_: _pretend)) => -; form is [op,a,b] and MEMQ(op,'(_@ _: _:_: _pretend)) => -; MEMQ(op,'(_: _pretend)) => form -; op = code and b = t => form -; markNumCheck(code,form,t) -; FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t] -; [code,form,t] -; MEMQ(code,'(_@ _:_: _:)) and form is [op,a] and -; (op='rep and t = 'Rep or op='per and t = "$") => form -; code = 'Lisp => -; t = $EmptyMode => form -; ["pretend",form,t] -; MEMQ(t,'(rep per)) => -; t = 'rep and EQCAR(form,'per) => CADR form -; t = 'per and EQCAR(form,'rep) => CADR form -; [t,form] -; code is [op,x,t1] and MEMQ(op,'(_@ _: _:_: _pretend)) and t1 = t => form -; FIXP form and MEMQ(opOf t,$markPrimitiveNumbers) => ['_@,form,t] -; markNumCheck("::",form,t) - -(DEFUN |markInsertChanges| (|code| |form| |t| |loc|) - (PROG (|i| |r| |ISTMP#3| |ISTMP#4| |ISTMP#5| |z| |y| |b| |a| |op| - |ISTMP#1| |x| |ISTMP#2| |t1|) - (declare (special |$markPrimitiveNumbers| |$EmptyMode| $CHANGE |$hohum| - |$data|)) - (RETURN - (SEQ (COND - ((AND (PAIRP |loc|) - (PROGN - (SPADLET |i| (QCAR |loc|)) - (SPADLET |r| (QCDR |loc|)) - 'T)) - (SPADLET |x| |form|) - (DO ((G168320 (SPADDIFFERENCE |i| 1)) - (|j| 0 (QSADD1 |j|))) - ((QSGREATERP |j| G168320) NIL) - (SEQ (EXIT (COND - ((NULL (ATOM |x|)) - (SPADLET |x| (CDR |x|))) - ('T NIL))))) - (COND - ((ATOM |x|) - (|pp| "Translator RPLACA error") - (|pp| |$data|) (|foobum| |form|) |form|) - ('T - (COND - ((AND (BOUNDP '|$hohum|) |$hohum|) - (|pp| (CONS |i| - (CONS " >>> " - (CONS |x| NIL)))))) - (SETQ $CHANGE (COPY |x|)) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) - (PROGN (SPADLET |y| (QCDR |x|)) 'T) |r|) - (SPADLET |x| |y|))) - (RPLACA |x| - (|markInsertChanges| |code| (CAR |x|) |t| - (CDR |loc|))) - (|chk| |x| 100) |form|))) - ((AND (PAIRP |t|) (EQ (QCAR |t|) 'REPLACE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |t|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |r| (QCAR |ISTMP#1|)) 'T)))) - (MSUBST |form| '|##1| |r|)) - ((AND (PAIRP |form|) (EQ (QCAR |form|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) '|exit|) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQUAL (QCAR |ISTMP#4|) 1) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |z| (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN (SPADLET |y| (QCDR |ISTMP#2|)) 'T) - (PROGN (SPADLET |y| (NREVERSE |y|)) 'T)))) - (CONS 'SEQ - (APPEND (PROG (G168328) - (SPADLET G168328 NIL) - (RETURN - (DO ((G168333 |y| (CDR G168333)) - (|x| NIL)) - ((OR (ATOM G168333) - (PROGN - (SETQ |x| (CAR G168333)) - NIL)) - (NREVERSE0 G168328)) - (SEQ (EXIT - (SETQ G168328 - (CONS - (|markInsertSeq| |code| |x| - |t|) - G168328))))))) - (CONS (CONS '|exit| - (CONS 1 - (CONS - (|markInsertChanges| |code| - |z| |t| NIL) - NIL))) - NIL)))) - ((OR (BOOT-EQUAL |code| '|pretend|) - (BOOT-EQUAL |code| '|:|)) - (COND - ((AND (PAIRP |form|) - (PROGN - (SPADLET |op| (QCAR |form|)) - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL))))) - (MEMQ |op| '(@ |:| |::| |pretend|))) - (CONS '|pretend| (CONS |a| (CONS |t| NIL)))) - ('T (CONS |code| (CONS |form| (CONS |t| NIL)))))) - ((MEMQ |code| '(@ |::| |pretend|)) - (COND - ((AND (PAIRP |form|) - (PROGN - (SPADLET |op| (QCAR |form|)) - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |op| '(@ |:| |::| |pretend|))) - (COND - ((MEMQ |op| '(|:| |pretend|)) |form|) - ((AND (BOOT-EQUAL |op| |code|) (BOOT-EQUAL |b| |t|)) - |form|) - ('T (|markNumCheck| |code| |form| |t|)))) - ((AND (integerp |form|) - (MEMQ (|opOf| |t|) |$markPrimitiveNumbers|)) - (CONS '@ (CONS |form| (CONS |t| NIL)))) - ('T (CONS |code| (CONS |form| (CONS |t| NIL)))))) - ((AND (MEMQ |code| '(@ |::| |:|)) (PAIRP |form|) - (PROGN - (SPADLET |op| (QCAR |form|)) - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T))) - (OR (AND (BOOT-EQUAL |op| '|rep|) - (BOOT-EQUAL |t| '|Rep|)) - (AND (BOOT-EQUAL |op| '|per|) - (BOOT-EQUAL |t| '$)))) - |form|) - ((BOOT-EQUAL |code| '|Lisp|) - (COND - ((BOOT-EQUAL |t| |$EmptyMode|) |form|) - ('T (CONS '|pretend| (CONS |form| (CONS |t| NIL)))))) - ((MEMQ |t| '(|rep| |per|)) - (COND - ((AND (BOOT-EQUAL |t| '|rep|) (EQCAR |form| '|per|)) - (CADR |form|)) - ((AND (BOOT-EQUAL |t| '|per|) (EQCAR |form| '|rep|)) - (CADR |form|)) - ('T (CONS |t| (CONS |form| NIL))))) - ((AND (PAIRP |code|) - (PROGN - (SPADLET |op| (QCAR |code|)) - (SPADLET |ISTMP#1| (QCDR |code|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t1| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |op| '(@ |:| |::| |pretend|)) - (BOOT-EQUAL |t1| |t|)) - |form|) - ((AND (integerp |form|) - (MEMQ (|opOf| |t|) |$markPrimitiveNumbers|)) - (CONS '@ (CONS |form| (CONS |t| NIL)))) - ('T (|markNumCheck| '|::| |form| |t|))))))) - -;markNumCheck(op,form,t) == -; op = "::" and MEMQ(opOf t,'(Integer)) => -; s := form = $One and 1 or form = $Zero and 0 => ['DOLLAR, s , t] -; FIXP form => ["@", form, t] -; form is ["-", =$One] => ['DOLLAR, -1, t] -; form is ["-", n] and FIXP n => ["@", MINUS n, t] -; [op, form, t] -; [op,form,t] - -(DEFUN |markNumCheck| (|op| |form| |t|) - (PROG (|s| |ISTMP#1| |n|) - (declare (special |$One| |$Zero|)) - (RETURN - (COND - ((AND (BOOT-EQUAL |op| '|::|) (MEMQ (|opOf| |t|) '(|Integer|))) - (COND - ((SPADLET |s| - (OR (AND (BOOT-EQUAL |form| |$One|) 1) - (AND (BOOT-EQUAL |form| |$Zero|) 0))) - (CONS 'DOLLAR (CONS |s| (CONS |t| NIL)))) - ((integerp |form|) (CONS '@ (CONS |form| (CONS |t| NIL)))) - ((AND (PAIRP |form|) (EQ (QCAR |form|) '-) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (EQUAL (QCAR |ISTMP#1|) |$One|)))) - (CONS 'DOLLAR (CONS (SPADDIFFERENCE 1) (CONS |t| NIL)))) - ((AND (PAIRP |form|) (EQ (QCAR |form|) '-) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |n| (QCAR |ISTMP#1|)) 'T))) - (integerp |n|)) - (CONS '@ (CONS (MINUS |n|) (CONS |t| NIL)))) - ('T (CONS |op| (CONS |form| (CONS |t| NIL)))))) - ('T (CONS |op| (CONS |form| (CONS |t| NIL)))))))) - -;markInsertSeq(code,x,t) == -; x is ['exit,y] => ['exit,markInsertChanges(code,y,t,nil)] -; atom x => x -; [markInsertSeq(code,y,t) for y in x] - -(DEFUN |markInsertSeq| (|code| |x| |t|) - (PROG (|ISTMP#1| |y|) - (RETURN - (SEQ (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|exit|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#1|)) 'T)))) - (CONS '|exit| - (CONS (|markInsertChanges| |code| |y| |t| NIL) NIL))) - ((ATOM |x|) |x|) - ('T - (PROG (G168400) - (SPADLET G168400 NIL) - (RETURN - (DO ((G168405 |x| (CDR G168405)) (|y| NIL)) - ((OR (ATOM G168405) - (PROGN (SETQ |y| (CAR G168405)) NIL)) - (NREVERSE0 G168400)) - (SEQ (EXIT (SETQ G168400 - (CONS - (|markInsertSeq| |code| |y| |t|) - G168400))))))))))))) - -;--====================================================================== -;-- Prettyprint of translated program -;--====================================================================== -;markFinish(body,T) == -;--called by compDefineCategory2, compDefineFunctor1 (early jumpout) -; SETQ($cs,$capsuleStack) -; SETQ($ps,$predicateStack) -; SETQ($ss,$signatureStack) -; SETQ($os,$originalTarget) -; SETQ($gis,$globalImportStack) -; SETQ($gds,$globalDeclareStack) -; SETQ($gms,$globalMacroStack) -; SETQ($as, $abbreviationStack) -; SETQ($lms,$localMacroStack) -; SETQ($map,$macrosAlreadyPrinted) -; SETQ($gs,$importStack) -; SETQ($fs,$freeStack) -; SETQ($b,body) -; SETQ($t,T) -; SETQ($e,T.env) -;--if $categoryTranForm then SETQ($t,$categoryTranForm . 1) -; atom CDDR T => systemError() -; RPLACA(CDDR T,$EmptyEnvironment) -; chk(CDDR T,101) -; markFinish1() -; T - -(DEFUN |markFinish| (|body| T$) - (declare (special |$cs| |$capsuleStack| |$ps| |$predicateStack| |$ss| - |$signatureStack| |$os| |$originalTarget| |$gis| |$globalImportStack| - |$gds| |$globalDeclareStack| |$gms| |$globalMacroStack| |$as| - |$abbreviationStack| |$lms| |$localMacroStack| |$map| - |$macrosAlreadyPrinted| |$gs| |$importStack| |$fs| |$freeStack| |$b| - |body| |$t| |$e| |$EmptyEnvironment|)) - (PROGN - (SETQ |$cs| |$capsuleStack|) - (SETQ |$ps| |$predicateStack|) - (SETQ |$ss| |$signatureStack|) - (SETQ |$os| |$originalTarget|) - (SETQ |$gis| |$globalImportStack|) - (SETQ |$gds| |$globalDeclareStack|) - (SETQ |$gms| |$globalMacroStack|) - (SETQ |$as| |$abbreviationStack|) - (SETQ |$lms| |$localMacroStack|) - (SETQ |$map| |$macrosAlreadyPrinted|) - (SETQ |$gs| |$importStack|) - (SETQ |$fs| |$freeStack|) - (SETQ |$b| |body|) - (SETQ |$t| T$) - (SETQ |$e| (CADDR T$)) - (COND - ((ATOM (CDDR T$)) (|systemError|)) - ('T (RPLACA (CDDR T$) |$EmptyEnvironment|) (|chk| (CDDR T$) 101) - (|markFinish1|) T$)))) - -;reFinish() == -; $importStack := $gs -; $freeStack := $fs -; $capsuleStack := $cs -; $predicateStack := $ps -; $signatureStack := $ss -; $originalTarget := $os -; $globalMacroStack := $gms -; $abbreviationStack:= $as -; $globalImportStack := $gis -; $globalDeclareStack := $gds -; $localMacroStack := $lms -; $macrosAlreadyPrinted := $map -; $abbreviationsAlreadyPrinted := nil -; markFinish1() - -(DEFUN |reFinish| () - (declare (special |$importStack| |$gs| |$freeStack| |$fs| |$capsuleStack| - |$cs| |$predicateStack| |$ps| |$signatureStack| |$ss| |$originalTarget| - |$os| |$globalMacroStack| |$gms| |$abbreviationStack| |$as| - |$globalImportStack| |$gis| |$globalDeclareStack| |$gds| - |$localMacroStack| |$lms| |$macrosAlreadyPrinted| |$map| - |$abbreviationsAlreadyPrinted|)) - (PROGN - (SPADLET |$importStack| |$gs|) - (SPADLET |$freeStack| |$fs|) - (SPADLET |$capsuleStack| |$cs|) - (SPADLET |$predicateStack| |$ps|) - (SPADLET |$signatureStack| |$ss|) - (SPADLET |$originalTarget| |$os|) - (SPADLET |$globalMacroStack| |$gms|) - (SPADLET |$abbreviationStack| |$as|) - (SPADLET |$globalImportStack| |$gis|) - (SPADLET |$globalDeclareStack| |$gds|) - (SPADLET |$localMacroStack| |$lms|) - (SPADLET |$macrosAlreadyPrinted| |$map|) - (SPADLET |$abbreviationsAlreadyPrinted| NIL) - (|markFinish1|))) - -;markFinish1() == -; body := $b -; T := $t -; $predGensymAlist: local := nil -;--$capsuleStack := $cs -;--$predicateStack := $ps -; form := T. expr -; ['Mapping,:sig] := T.mode -; if $insideCategoryIfTrue and $insideFunctorIfTrue then -; $importStack := [DELETE($categoryNameForDollar,x) for x in $importStack] -; $globalImportStack := DELETE($categoryNameForDollar,$globalImportStack) -; $commonImports : local := getCommonImports() -; globalImports := -; REVERSE orderByContainment REMDUP [:$commonImports,:$globalImportStack] -; $finalImports: local := SETDIFFERENCE(globalImports,$globalDeclareStack) -; $capsuleStack := -; [mkNewCapsuleItem(freepart,imports,x) for freepart in $freeStack -; for imports in $importStack for x in $capsuleStack] -; $extraDefinitions := combineDefinitions() -; addDomain := nil -; initbody := -; $b is ['add,a,b] => -; addDomain := a -; b -; $b is [op,:.] and constructor? op => -; addDomain := $b -; nil -; $b -; body := markFinishBody initbody -; importCode := [['import,x] for x in $finalImports] -; leadingMacros := markExtractLeadingMacros(globalImports,body) -; body := markRemImportsAndLeadingMacros(leadingMacros,body) -; initcapsule := -; body => ['CAPSULE,:leadingMacros,:importCode,:body] -; nil -; capsule := -;-- null initcapsule => addDomain -; addDomain => ['add,addDomain,initcapsule] -; initcapsule -; nsig := -; $categoryPart => sig -; ['Type,:rest sig] -; for x in REVERSE $abbreviationStack |not MEMBER(x,$abbreviationsAlreadyPrinted) repeat -; markPrintAbbreviation x -; $abbreviationsAlreadyPrinted := insert(x,$abbreviationsAlreadyPrinted) -; for x in REVERSE $globalMacroStack|not MEMBER(x,$macrosAlreadyPrinted) repeat -; $def := ['MDEF,first x,'(NIL),'(NIL),rest x] -; markPrint(true) -; $macrosAlreadyPrinted := insert(x,$macrosAlreadyPrinted) -; if $insideCategoryIfTrue and not $insideFunctorIfTrue then -; markPrintAttributes $b -; $def := ['DEF,form,nsig,[nil for x in form],capsule] -; markPrint() - -(DEFUN |markFinish1| () - (PROG (|$predGensymAlist| |$commonImports| |$finalImports| T$ |form| - |LETTMP#1| |sig| |globalImports| |ISTMP#1| |a| |ISTMP#2| - |b| |op| |addDomain| |initbody| |importCode| - |leadingMacros| |body| |initcapsule| |capsule| |nsig|) - (DECLARE (SPECIAL |$predGensymAlist| |$commonImports| |$def| |$b| - |$finalImports| |$insideFunctorIfTrue| - |$insideCategoryIfTrue| |$macrosAlreadyPrinted| - |$globalMacroStack| |$abbreviationsAlreadyPrinted| - |$abbreviationStack| |$categoryPart| |$finalImports| - |$extraDefinitions| |$capsuleStack| |$importStack| - |$freeStack| |$globalDeclareStack| |$globalImportStack| - |$commonImports| |$categoryNameForDollar| |$t|)) - (RETURN - (SEQ (PROGN - (SPADLET |body| |$b|) - (SPADLET T$ |$t|) - (SPADLET |$predGensymAlist| NIL) - (SPADLET |form| (CAR T$)) - (SPADLET |LETTMP#1| (CADR T$)) - (SPADLET |sig| (CDR |LETTMP#1|)) - (COND - ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) - (SPADLET |$importStack| - (PROG (G168473) - (SPADLET G168473 NIL) - (RETURN - (DO ((G168478 |$importStack| - (CDR G168478)) - (|x| NIL)) - ((OR (ATOM G168478) - (PROGN - (SETQ |x| (CAR G168478)) - NIL)) - (NREVERSE0 G168473)) - (SEQ (EXIT - (SETQ G168473 - (CONS - (|delete| - |$categoryNameForDollar| |x|) - G168473)))))))) - (SPADLET |$globalImportStack| - (|delete| |$categoryNameForDollar| - |$globalImportStack|)))) - (SPADLET |$commonImports| (|getCommonImports|)) - (SPADLET |globalImports| - (REVERSE (|orderByContainment| - (REMDUP - (APPEND |$commonImports| - |$globalImportStack|))))) - (SPADLET |$finalImports| - (SETDIFFERENCE |globalImports| - |$globalDeclareStack|)) - (SPADLET |$capsuleStack| - (PROG (G168490) - (SPADLET G168490 NIL) - (RETURN - (DO ((G168497 |$freeStack| (CDR G168497)) - (|freepart| NIL) - (G168498 |$importStack| - (CDR G168498)) - (|imports| NIL) - (G168499 |$capsuleStack| - (CDR G168499)) - (|x| NIL)) - ((OR (ATOM G168497) - (PROGN - (SETQ |freepart| (CAR G168497)) - NIL) - (ATOM G168498) - (PROGN - (SETQ |imports| (CAR G168498)) - NIL) - (ATOM G168499) - (PROGN - (SETQ |x| (CAR G168499)) - NIL)) - (NREVERSE0 G168490)) - (SEQ (EXIT (SETQ G168490 - (CONS - (|mkNewCapsuleItem| |freepart| - |imports| |x|) - G168490)))))))) - (SPADLET |$extraDefinitions| (|combineDefinitions|)) - (SPADLET |addDomain| NIL) - (SPADLET |initbody| - (COND - ((AND (PAIRP |$b|) (EQ (QCAR |$b|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |$b|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |addDomain| |a|) |b|) - ((AND (PAIRP |$b|) - (PROGN (SPADLET |op| (QCAR |$b|)) 'T) - (|constructor?| |op|)) - (SPADLET |addDomain| |$b|) NIL) - ('T |$b|))) - (SPADLET |body| (|markFinishBody| |initbody|)) - (SPADLET |importCode| - (PROG (G168515) - (SPADLET G168515 NIL) - (RETURN - (DO ((G168520 |$finalImports| - (CDR G168520)) - (|x| NIL)) - ((OR (ATOM G168520) - (PROGN - (SETQ |x| (CAR G168520)) - NIL)) - (NREVERSE0 G168515)) - (SEQ (EXIT (SETQ G168515 - (CONS - (CONS '|import| - (CONS |x| NIL)) - G168515)))))))) - (SPADLET |leadingMacros| - (|markExtractLeadingMacros| |globalImports| - |body|)) - (SPADLET |body| - (|markRemImportsAndLeadingMacros| |leadingMacros| - |body|)) - (SPADLET |initcapsule| - (COND - (|body| (CONS 'CAPSULE - (APPEND |leadingMacros| - (APPEND |importCode| |body|)))) - ('T NIL))) - (SPADLET |capsule| - (COND - (|addDomain| - (CONS '|add| - (CONS |addDomain| - (CONS |initcapsule| NIL)))) - ('T |initcapsule|))) - (SPADLET |nsig| - (COND - (|$categoryPart| |sig|) - ('T (CONS '|Type| (CDR |sig|))))) - (DO ((G168532 (REVERSE |$abbreviationStack|) - (CDR G168532)) - (|x| NIL)) - ((OR (ATOM G168532) - (PROGN (SETQ |x| (CAR G168532)) NIL)) - NIL) - (SEQ (EXIT (COND - ((NULL (|member| |x| - |$abbreviationsAlreadyPrinted|)) - (PROGN - (|markPrintAbbreviation| |x|) - (SPADLET |$abbreviationsAlreadyPrinted| - (|insert| |x| - |$abbreviationsAlreadyPrinted|)))))))) - (DO ((G168545 (REVERSE |$globalMacroStack|) - (CDR G168545)) - (|x| NIL)) - ((OR (ATOM G168545) - (PROGN (SETQ |x| (CAR G168545)) NIL)) - NIL) - (SEQ (EXIT (COND - ((NULL (|member| |x| - |$macrosAlreadyPrinted|)) - (PROGN - (SPADLET |$def| - (CONS 'MDEF - (CONS (CAR |x|) - (CONS '(NIL) - (CONS '(NIL) - (CONS (CDR |x|) NIL)))))) - (|markPrint| 'T) - (SPADLET |$macrosAlreadyPrinted| - (|insert| |x| - |$macrosAlreadyPrinted|)))))))) - (COND - ((AND |$insideCategoryIfTrue| - (NULL |$insideFunctorIfTrue|)) - (|markPrintAttributes| |$b|))) - (SPADLET |$def| - (CONS 'DEF - (CONS |form| - (CONS |nsig| - (CONS - (PROG (G168555) - (SPADLET G168555 NIL) - (RETURN - (DO - ((G168560 |form| - (CDR G168560)) - (|x| NIL)) - ((OR (ATOM G168560) - (PROGN - (SETQ |x| - (CAR G168560)) - NIL)) - (NREVERSE0 G168555)) - (SEQ - (EXIT - (SETQ G168555 - (CONS NIL G168555))))))) - (CONS |capsule| NIL)))))) - (|markPrint|)))))) - -;stop x == x - -(DEFUN |stop| (|x|) |x|) - -;getNumberTypesInScope() == -; UNION([y for x in $localImportStack | MEMQ(y := opOf x,$markNumberTypes)], -; [y for x in $globalImportStack| MEMQ(y := opOf x,$markNumberTypes)]) - -(DEFUN |getNumberTypesInScope| () - (PROG (|y|) - (declare (special |$markNumberTypes| |$globalImportStack| - |$localImportStack|)) - (RETURN - (SEQ (|union| (PROG (G168620) - (SPADLET G168620 NIL) - (RETURN - (DO ((G168626 |$localImportStack| - (CDR G168626)) - (|x| NIL)) - ((OR (ATOM G168626) - (PROGN - (SETQ |x| (CAR G168626)) - NIL)) - (NREVERSE0 G168620)) - (SEQ (EXIT (COND - ((MEMQ - (SPADLET |y| (|opOf| |x|)) - |$markNumberTypes|) - (SETQ G168620 - (CONS |y| G168620))))))))) - (PROG (G168637) - (SPADLET G168637 NIL) - (RETURN - (DO ((G168643 |$globalImportStack| - (CDR G168643)) - (|x| NIL)) - ((OR (ATOM G168643) - (PROGN - (SETQ |x| (CAR G168643)) - NIL)) - (NREVERSE0 G168637)) - (SEQ (EXIT (COND - ((MEMQ - (SPADLET |y| (|opOf| |x|)) - |$markNumberTypes|) - (SETQ G168637 - (CONS |y| G168637)))))))))))))) - -;getCommonImports() == -; importList := [x for x in $importStack for y in $capsuleStack | -; KAR KAR y = 'DEF] -; hash := MAKE_-HASHTABLE 'EQUAL -; for x in importList repeat -; for y in x repeat HPUT(hash,y,1 + (HGET(hash,y) or 0)) -; threshold := FLOOR (.5 * #importList) -; [x for x in HKEYS hash | HGET(hash,x) >= threshold] - -(DEFUN |getCommonImports| () - (PROG (|importList| |hash| |threshold|) - (declare (special |$capsuleStack| |$importStack|)) - (RETURN - (SEQ (PROGN - (SPADLET |importList| - (PROG (G168663) - (SPADLET G168663 NIL) - (RETURN - (DO ((G168670 |$importStack| - (CDR G168670)) - (|x| NIL) - (G168671 |$capsuleStack| - (CDR G168671)) - (|y| NIL)) - ((OR (ATOM G168670) - (PROGN - (SETQ |x| (CAR G168670)) - NIL) - (ATOM G168671) - (PROGN - (SETQ |y| (CAR G168671)) - NIL)) - (NREVERSE0 G168663)) - (SEQ (EXIT (COND - ((BOOT-EQUAL (KAR (KAR |y|)) - 'DEF) - (SETQ G168663 - (CONS |x| G168663)))))))))) - (SPADLET |hash| (MAKE-HASHTABLE 'EQUAL)) - (DO ((G168683 |importList| (CDR G168683)) (|x| NIL)) - ((OR (ATOM G168683) - (PROGN (SETQ |x| (CAR G168683)) NIL)) - NIL) - (SEQ (EXIT (DO ((G168692 |x| (CDR G168692)) - (|y| NIL)) - ((OR (ATOM G168692) - (PROGN - (SETQ |y| (CAR G168692)) - NIL)) - NIL) - (SEQ (EXIT (HPUT |hash| |y| - (PLUS 1 - (OR (HGET |hash| |y|) 0))))))))) - (SPADLET |threshold| - (FLOOR (TIMES 0.5 (|#| |importList|)))) - (PROG (G168703) - (SPADLET G168703 NIL) - (RETURN - (DO ((G168709 (HKEYS |hash|) (CDR G168709)) - (|x| NIL)) - ((OR (ATOM G168709) - (PROGN (SETQ |x| (CAR G168709)) NIL)) - (NREVERSE0 G168703)) - (SEQ (EXIT (COND - ((>= (HGET |hash| |x|) |threshold|) - (SETQ G168703 (CONS |x| G168703)))))))))))))) - -;markPrintAttributes addForm == -; capsule := -; addForm is ['add,a,:.] => -; a is ['CATEGORY,:.] => a -; a is ['Join,:.] => CAR LASTNODE a -; CAR LASTNODE addForm -; addForm -; if capsule is ['CAPSULE,:r] then -; capsule := CAR LASTNODE r -; capsule isnt ['CATEGORY,.,:lst] => nil -; for x in lst | x is ['ATTRIBUTE,att] repeat -; markSay(form2String att) -; markSay('": Category == with") -; markTerpri() -; markTerpri() - -(DEFUN |markPrintAttributes| (|addForm|) - (PROG (|a| |r| |capsule| |lst| |ISTMP#1| |att|) - (RETURN - (SEQ (PROGN - (SPADLET |capsule| - (COND - ((AND (PAIRP |addForm|) - (EQ (QCAR |addForm|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |addForm|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - 'T)))) - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'CATEGORY)) - |a|) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|Join|)) - (CAR (LASTNODE |a|))) - ('T (CAR (LASTNODE |addForm|))))) - ('T |addForm|))) - (COND - ((AND (PAIRP |capsule|) (EQ (QCAR |capsule|) 'CAPSULE) - (PROGN (SPADLET |r| (QCDR |capsule|)) 'T)) - (SPADLET |capsule| (CAR (LASTNODE |r|))))) - (COND - ((NULL (AND (PAIRP |capsule|) - (EQ (QCAR |capsule|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |capsule|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |lst| (QCDR |ISTMP#1|)) - 'T))))) - NIL) - ('T - (DO ((G168747 |lst| (CDR G168747)) (|x| NIL)) - ((OR (ATOM G168747) - (PROGN (SETQ |x| (CAR G168747)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) 'ATTRIBUTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |att| - (QCAR |ISTMP#1|)) - 'T)))) - (PROGN - (|markSay| (|form2String| |att|)) - (|markSay| - ": Category == with") - (|markTerpri|) - (|markTerpri|)))))))))))))) - -;getCommons u == -; common := KAR u -; while common and u is [x,:u] repeat common := INTERSECTION(x,common) -; common - -(DEFUN |getCommons| (|u|) - (PROG (|x| |common|) - (RETURN - (SEQ (PROGN - (SPADLET |common| (KAR |u|)) - (DO () - ((NULL (AND |common| (PAIRP |u|) - (PROGN - (SPADLET |x| (QCAR |u|)) - (SPADLET |u| (QCDR |u|)) - 'T))) - NIL) - (SEQ (EXIT (SPADLET |common| - (|intersection| |x| |common|))))) - |common|))))) - -;markExtractLeadingMacros(globalImports,body) == -; [x for x in body | x is ['MDEF,[a],:.] and MEMBER(a,globalImports)] - -(DEFUN |markExtractLeadingMacros| (|globalImports| |body|) - (PROG (|ISTMP#1| |ISTMP#2| |a|) - (RETURN - (SEQ (PROG (G168797) - (SPADLET G168797 NIL) - (RETURN - (DO ((G168803 |body| (CDR G168803)) (|x| NIL)) - ((OR (ATOM G168803) - (PROGN (SETQ |x| (CAR G168803)) NIL)) - (NREVERSE0 G168797)) - (SEQ (EXIT (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'MDEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#2|)) - 'T))))) - (|member| |a| |globalImports|)) - (SETQ G168797 (CONS |x| G168797))))))))))))) - -;markRemImportsAndLeadingMacros(leadingMacros,body) == -; [x for x in body | x isnt ['import,:.] and not MEMBER(x,leadingMacros)] - -(DEFUN |markRemImportsAndLeadingMacros| (|leadingMacros| |body|) - (PROG () - (RETURN - (SEQ (PROG (G168821) - (SPADLET G168821 NIL) - (RETURN - (DO ((G168827 |body| (CDR G168827)) (|x| NIL)) - ((OR (ATOM G168827) - (PROGN (SETQ |x| (CAR G168827)) NIL)) - (NREVERSE0 G168821)) - (SEQ (EXIT (COND - ((AND (NULL - (AND (PAIRP |x|) - (EQ (QCAR |x|) '|import|))) - (NULL - (|member| |x| |leadingMacros|))) - (SETQ G168821 (CONS |x| G168821))))))))))))) - -;mkNewCapsuleItem(frees,i,x) == -; [originalDef,:ndef] := x -; imports := REVERSE orderByContainment REMDUP SETDIFFERENCE(i,$finalImports) -; importPart := [['import,d] for d in imports] -; nbody := -; ndef is ['LET,.,x] => x -; ndef is ['DEF,.,.,.,x] => x -; ndef -; newerBody := -; newPart := [:frees,:importPart] => -; nbody is ['SEQ,:y] => ['SEQ,:newPart,:y] -; ['SEQ,:newPart,['exit,1,nbody]] -; nbody -; newerDef := -; ndef is ['LET,a,x] => ['LET,a,newerBody] -; ndef is ['DEF,a,b,c,x] => ['DEF,a,b,c,newerBody] -; newerBody -; entry := [originalDef,:newerDef] -; entry - -(DEFUN |mkNewCapsuleItem| (|frees| |i| |x|) - (PROG (|originalDef| |ndef| |imports| |importPart| |nbody| |newPart| - |y| |newerBody| |ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c| - |ISTMP#4| |newerDef| |entry|) - (declare (special |$finalImports|)) - (RETURN - (SEQ (PROGN - (SPADLET |originalDef| (CAR |x|)) - (SPADLET |ndef| (CDR |x|)) - (SPADLET |imports| - (REVERSE (|orderByContainment| - (REMDUP - (SETDIFFERENCE |i| |$finalImports|))))) - (SPADLET |importPart| - (PROG (G168961) - (SPADLET G168961 NIL) - (RETURN - (DO ((G168966 |imports| (CDR G168966)) - (|d| NIL)) - ((OR (ATOM G168966) - (PROGN - (SETQ |d| (CAR G168966)) - NIL)) - (NREVERSE0 G168961)) - (SEQ (EXIT (SETQ G168961 - (CONS - (CONS '|import| - (CONS |d| NIL)) - G168961)))))))) - (SPADLET |nbody| - (COND - ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |ndef|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#2|)) - 'T)))))) - |x|) - ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |ndef|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#4|)) - 'T)))))))))) - |x|) - ('T |ndef|))) - (SPADLET |newerBody| - (COND - ((SPADLET |newPart| - (APPEND |frees| |importPart|)) - (COND - ((AND (PAIRP |nbody|) - (EQ (QCAR |nbody|) 'SEQ) - (PROGN - (SPADLET |y| (QCDR |nbody|)) - 'T)) - (CONS 'SEQ (APPEND |newPart| |y|))) - ('T - (CONS 'SEQ - (APPEND |newPart| - (CONS - (CONS '|exit| - (CONS 1 (CONS |nbody| NIL))) - NIL)))))) - ('T |nbody|))) - (SPADLET |newerDef| - (COND - ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |ndef|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#2|)) - 'T)))))) - (CONS 'LET (CONS |a| (CONS |newerBody| NIL)))) - ((AND (PAIRP |ndef|) (EQ (QCAR |ndef|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |ndef|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |c| - (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#4|)) - 'T)))))))))) - (CONS 'DEF - (CONS |a| - (CONS |b| - (CONS |c| (CONS |newerBody| NIL)))))) - ('T |newerBody|))) - (SPADLET |entry| (CONS |originalDef| |newerDef|)) - |entry|))))) - -;markFinishBody capsuleBody == -; capsuleBody is ['CAPSULE,:itemlist] => -; if $insideCategoryIfTrue and $insideFunctorIfTrue then -; itemlist := markCatsub itemlist -; [:[markFinishItem x for x in itemlist],:$extraDefinitions] -; nil - -(DEFUN |markFinishBody| (|capsuleBody|) - (PROG (|itemlist|) - (declare (special |$extraDefinitions| |$insideFunctorIfTrue| - |$insideCategoryIfTrue|)) - (RETURN - (SEQ (COND - ((AND (PAIRP |capsuleBody|) - (EQ (QCAR |capsuleBody|) 'CAPSULE) - (PROGN - (SPADLET |itemlist| (QCDR |capsuleBody|)) - 'T)) - (COND - ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) - (SPADLET |itemlist| (|markCatsub| |itemlist|)))) - (APPEND (PROG (G169012) - (SPADLET G169012 NIL) - (RETURN - (DO ((G169017 |itemlist| (CDR G169017)) - (|x| NIL)) - ((OR (ATOM G169017) - (PROGN - (SETQ |x| (CAR G169017)) - NIL)) - (NREVERSE0 G169012)) - (SEQ (EXIT (SETQ G169012 - (CONS (|markFinishItem| |x|) - G169012))))))) - |$extraDefinitions|)) - ('T NIL)))))) - -;markCatsub x == SUBST("$",$categoryNameForDollar,x) - -(DEFUN |markCatsub| (|x|) - (declare (special |$categoryNameForDollar|)) - (MSUBST '$ |$categoryNameForDollar| |x|)) - -;markFinishItem x == -; $macroAlist : local := [:$localMacroStack,:$globalMacroStack] -; if $insideCategoryIfTrue and $insideFunctorIfTrue then -; $macroAlist := [["$",:$categoryNameForDollar],:$macroAlist] -; x is ['DEF,form,.,.,body] => -; "or"/[new for [old,:new] in $capsuleStack | -; old is ['DEF,oform,.,.,obody] -; and markCompare(form,oform) and markCompare(body,obody)] or -; pp '"------------MISSING----------------" -; $f := form -; $b := body -; newform := "or"/[x for [old,:new] in $capsuleStack | -; old is ['DEF,oform,.,.,obody] and oform = $f] -; $ob:= (newform => obody; nil) -; pp $f -; pp $b -; pp $ob -; foobum x -; pp x -; x -; x is ['LET,lhs,rhs] => -; "or"/[new for [old,:new] in $capsuleStack | -; old is ['LET,olhs,orhs] -; and markCompare(lhs,olhs) and markCompare(rhs,orhs)] -; or x -; x is ['IF,p,a,b] => ['IF,p,markFinishItem a,markFinishItem b] -; x is ['SEQ,:l,['exit,n,a]] => -; ['SEQ,:[markFinishItem y for y in l],['exit,n,markFinishItem a]] -; "or"/[new for [old,:new] in $capsuleStack | markCompare(x,old)] => -; new -; x - -(DEFUN |markFinishItem| (|x|) - (PROG (|$macroAlist| |form| |body| |oform| |obody| |newform| |lhs| - |rhs| |olhs| |orhs| |p| |b| |ISTMP#1| |ISTMP#2| |ISTMP#3| - |ISTMP#4| |n| |ISTMP#5| |a| |l| |old| |new|) - (DECLARE (SPECIAL |$macroAlist| |$capsuleStack| |$ob| |$b| |$f| - |$categoryNameForDollar| |$insideFunctorIfTrue| - |$insideCategoryIfTrue| |$globalMacroStack| - |$localMacroStack|)) - (RETURN - (SEQ (PROGN - (SPADLET |$macroAlist| - (APPEND |$localMacroStack| |$globalMacroStack|)) - (COND - ((AND |$insideCategoryIfTrue| |$insideFunctorIfTrue|) - (SPADLET |$macroAlist| - (CONS (CONS '$ |$categoryNameForDollar|) - |$macroAlist|)))) - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |form| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#4|)) - 'T)))))))))) - (OR (PROG (G169273) - (SPADLET G169273 NIL) - (RETURN - (DO ((G169281 NIL G169273) - (G169282 |$capsuleStack| - (CDR G169282)) - (G169108 NIL)) - ((OR G169281 (ATOM G169282) - (PROGN - (SETQ G169108 (CAR G169282)) - NIL) - (PROGN - (PROGN - (SPADLET |old| (CAR G169108)) - (SPADLET |new| (CDR G169108)) - G169108) - NIL)) - G169273) - (SEQ (EXIT (COND - ((AND (PAIRP |old|) - (EQ (QCAR |old|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |old|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |oform| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ - (QCDR |ISTMP#4|) - NIL) - (PROGN - (SPADLET |obody| - (QCAR - |ISTMP#4|)) - 'T))))))))) - (|markCompare| |form| |oform|) - (|markCompare| |body| |obody|)) - (SETQ G169273 - (OR G169273 |new|))))))))) - (PROGN - (|pp| "------------MISSING----------------") - (SPADLET |$f| |form|) - (SPADLET |$b| |body|) - (SPADLET |newform| - (PROG (G169290) - (SPADLET G169290 NIL) - (RETURN - (DO - ((G169298 NIL G169290) - (G169299 |$capsuleStack| - (CDR G169299)) - (G169150 NIL)) - ((OR G169298 (ATOM G169299) - (PROGN - (SETQ G169150 - (CAR G169299)) - NIL) - (PROGN - (PROGN - (SPADLET |old| - (CAR G169150)) - (SPADLET |new| - (CDR G169150)) - G169150) - NIL)) - G169290) - (SEQ - (EXIT - (COND - ((AND (PAIRP |old|) - (EQ (QCAR |old|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |old|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |oform| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (PROGN - (SPADLET - |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND - (PAIRP - |ISTMP#4|) - (EQ - (QCDR - |ISTMP#4|) - NIL) - (PROGN - (SPADLET - |obody| - (QCAR - |ISTMP#4|)) - 'T))))))))) - (BOOT-EQUAL |oform| |$f|)) - (SETQ G169290 - (OR G169290 |x|)))))))))) - (SPADLET |$ob| - (COND (|newform| |obody|) ('T NIL))) - (|pp| |$f|) - (|pp| |$b|) - (|pp| |$ob|) - (|foobum| |x|) - (|pp| |x|) - |x|))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |lhs| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |rhs| (QCAR |ISTMP#2|)) - 'T)))))) - (OR (PROG (G169307) - (SPADLET G169307 NIL) - (RETURN - (DO ((G169315 NIL G169307) - (G169316 |$capsuleStack| - (CDR G169316)) - (G169188 NIL)) - ((OR G169315 (ATOM G169316) - (PROGN - (SETQ G169188 (CAR G169316)) - NIL) - (PROGN - (PROGN - (SPADLET |old| (CAR G169188)) - (SPADLET |new| (CDR G169188)) - G169188) - NIL)) - G169307) - (SEQ (EXIT (COND - ((AND (PAIRP |old|) - (EQ (QCAR |old|) 'LET) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |old|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |olhs| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (SPADLET |orhs| - (QCAR |ISTMP#2|)) - 'T))))) - (|markCompare| |lhs| |olhs|) - (|markCompare| |rhs| |orhs|)) - (SETQ G169307 - (OR G169307 |new|))))))))) - |x|)) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#3|)) - 'T)))))))) - (CONS 'IF - (CONS |p| - (CONS (|markFinishItem| |a|) - (CONS (|markFinishItem| |b|) NIL))))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) '|exit|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN (SPADLET |l| (QCDR |ISTMP#2|)) 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) - (CONS 'SEQ - (APPEND (PROG (G169328) - (SPADLET G169328 NIL) - (RETURN - (DO ((G169333 |l| (CDR G169333)) - (|y| NIL)) - ((OR (ATOM G169333) - (PROGN - (SETQ |y| (CAR G169333)) - NIL)) - (NREVERSE0 G169328)) - (SEQ - (EXIT - (SETQ G169328 - (CONS (|markFinishItem| |y|) - G169328))))))) - (CONS (CONS '|exit| - (CONS |n| - (CONS (|markFinishItem| |a|) NIL))) - NIL)))) - ((PROG (G169339) - (SPADLET G169339 NIL) - (RETURN - (DO ((G169347 NIL G169339) - (G169348 |$capsuleStack| (CDR G169348)) - (G169268 NIL)) - ((OR G169347 (ATOM G169348) - (PROGN - (SETQ G169268 (CAR G169348)) - NIL) - (PROGN - (PROGN - (SPADLET |old| (CAR G169268)) - (SPADLET |new| (CDR G169268)) - G169268) - NIL)) - G169339) - (SEQ (EXIT (COND - ((|markCompare| |x| |old|) - (SETQ G169339 - (OR G169339 |new|))))))))) - |new|) - ('T |x|))))))) - -;markCompare(x,y) == -; markKillAll(SUBLIS($macroAlist,x)) = markKillAll(SUBLIS($macroAlist,y)) - -(DEFUN |markCompare| (|x| |y|) - (declare (special |$macroAlist|)) - (BOOT-EQUAL (|markKillAll| (SUBLIS |$macroAlist| |x|)) - (|markKillAll| (SUBLIS |$macroAlist| |y|)))) - -;diffCompare(x,y) == diff(SUBLIS($macroAlist,x),markKillAll(SUBLIS($macroAlist,y))) - -(DEFUN |diffCompare| (|x| |y|) - (declare (special |$macroAlist|)) - (|diff| (SUBLIS |$macroAlist| |x|) - (|markKillAll| (SUBLIS |$macroAlist| |y|)))) - -;--====================================================================== -;-- Print functions -;--====================================================================== -;markPrint(:options) == --print $def -; noTrailingSemicolonIfTrue := IFCAR options -;--$insideCategoryIfTrue and $insideFunctorIfTrue => nil -; $DEFdepth : local := 0 -; [op,form,sig,sclist,body] := markKillAll $def -; if $insideCategoryIfTrue then -; if op = 'DEF and $insideFunctorIfTrue then -; T := $categoryTranForm . 1 -; form := T . expr -; sig := rest (T . mode) -; form := SUBLISLIS(rest markConstructorForm opOf form, -; $TriangleVariableList,form) -; sig := SUBLISLIS(rest markConstructorForm opOf form, -; $TriangleVariableList,sig) -; nbody := body -; if $insideCategoryIfTrue then -; if $insideFunctorIfTrue then -; nbody := replaceCapsulePart body -; nbody := -; $catAddForm => ['withDefault, $catAddForm, nbody] -; nbody -; else -; ['add,a,:r] := $originalBody -; xtraLines := -; "append"/[[STRCONC(name,'": Category == with"),'""] -; for name in markCheckForAttributes a] -; nbody := -; $originalBody is ['add,a,b] => -; b isnt ['CAPSULE,:c] => error(false) -; [:l,x] := c -; [:markTranCategory a,['default,['SEQ,:l,['exit,1,x]]]] -; markTranCategory $originalBody -; signature := -; $insideFunctorIfTrue => [markTranJoin $originalTarget,:rest sig] -; $insideCategoryIfTrue => ['Category,:rest sig] -; '(NIL) -; $bootForm:= -; op = 'MDEF => [op,form,signature,sclist,body] -; [op,form,signature,sclist,nbody] -; bootLines:= lisp2Boot $bootForm -; $bootLines:= [:xtraLines,:bootLines] -; moveAroundLines() -; markSay $bootLines -; markTerpri() -; 'done - -(DEFUN |markPrint| (&REST G169522 &AUX |options|) - (DSETQ |options| G169522) - (PROG (|$DEFdepth| |noTrailingSemicolonIfTrue| |op| |sclist| |body| - T$ |form| |sig| |r| |xtraLines| |ISTMP#1| |a| |ISTMP#2| |b| - |c| |LETTMP#1| |x| |l| |nbody| |signature| |bootLines|) - (DECLARE (SPECIAL |$DEFdepth| |$bootLines| |$bootForm| - |$insideCategoryIfTrue| |$originalTarget| |$def| - |$insideFunctorIfTrue| |$originalBody| |$catAddForm| - |$TriangleVariableList| |$categoryTranForm|)) - (RETURN - (SEQ (PROGN - (SPADLET |noTrailingSemicolonIfTrue| (IFCAR |options|)) - (SPADLET |$DEFdepth| 0) - (SPADLET |LETTMP#1| (|markKillAll| |$def|)) - (SPADLET |op| (CAR |LETTMP#1|)) - (SPADLET |form| (CADR |LETTMP#1|)) - (SPADLET |sig| (CADDR |LETTMP#1|)) - (SPADLET |sclist| (CADDDR |LETTMP#1|)) - (SPADLET |body| (CAR (CDDDDR |LETTMP#1|))) - (COND - (|$insideCategoryIfTrue| - (COND - ((AND (BOOT-EQUAL |op| 'DEF) - |$insideFunctorIfTrue|) - (SPADLET T$ (ELT |$categoryTranForm| 1)) - (SPADLET |form| (CAR T$)) - (SPADLET |sig| (CDR (CADR T$))))) - (SPADLET |form| - (SUBLISLIS - (CDR (|markConstructorForm| - (|opOf| |form|))) - |$TriangleVariableList| |form|)) - (SPADLET |sig| - (SUBLISLIS - (CDR (|markConstructorForm| - (|opOf| |form|))) - |$TriangleVariableList| |sig|)))) - (SPADLET |nbody| |body|) - (COND - (|$insideCategoryIfTrue| - (COND - (|$insideFunctorIfTrue| - (SPADLET |nbody| - (|replaceCapsulePart| |body|)) - (SPADLET |nbody| - (COND - (|$catAddForm| - (CONS '|withDefault| - (CONS |$catAddForm| - (CONS |nbody| NIL)))) - ('T |nbody|)))) - ('T (SPADLET |a| (CADR |$originalBody|)) - (SPADLET |r| (CDDR |$originalBody|)) - (SPADLET |xtraLines| - (PROG (G169473) - (SPADLET G169473 NIL) - (RETURN - (DO - ((G169478 - (|markCheckForAttributes| |a|) - (CDR G169478)) - (|name| NIL)) - ((OR (ATOM G169478) - (PROGN - (SETQ |name| (CAR G169478)) - NIL)) - G169473) - (SEQ - (EXIT - (SETQ G169473 - (APPEND G169473 - (CONS - (STRCONC |name| - ": Category == with") - (CONS "" NIL)))))))))) - (SPADLET |nbody| - (COND - ((AND (PAIRP |$originalBody|) - (EQ (QCAR |$originalBody|) - '|add|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |$originalBody|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((NULL - (AND (PAIRP |b|) - (EQ (QCAR |b|) 'CAPSULE) - (PROGN - (SPADLET |c| (QCDR |b|)) - 'T))) - (|error| NIL)) - ('T - (SPADLET |LETTMP#1| (REVERSE |c|)) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |l| - (NREVERSE (CDR |LETTMP#1|))) - (APPEND (|markTranCategory| |a|) - (CONS - (CONS '|default| - (CONS - (CONS 'SEQ - (APPEND |l| - (CONS - (CONS '|exit| - (CONS 1 (CONS |x| NIL))) - NIL))) - NIL)) - NIL))))) - ('T - (|markTranCategory| |$originalBody|)))))))) - (SPADLET |signature| - (COND - (|$insideFunctorIfTrue| - (CONS (|markTranJoin| |$originalTarget|) - (CDR |sig|))) - (|$insideCategoryIfTrue| - (CONS '|Category| (CDR |sig|))) - ('T '(NIL)))) - (SPADLET |$bootForm| - (COND - ((BOOT-EQUAL |op| 'MDEF) - (CONS |op| - (CONS |form| - (CONS |signature| - (CONS |sclist| (CONS |body| NIL)))))) - ('T - (CONS |op| - (CONS |form| - (CONS |signature| - (CONS |sclist| - (CONS |nbody| NIL)))))))) - (SPADLET |bootLines| (|lisp2Boot| |$bootForm|)) - (SPADLET |$bootLines| (APPEND |xtraLines| |bootLines|)) - (|moveAroundLines|) - (|markSay| |$bootLines|) - (|markTerpri|) - '|done|))))) - -;replaceCapsulePart body == -; body isnt ['add,['CAPSULE,:c]] => body -; $categoryTranForm . 0 isnt ['add,exports,['CAPSULE,:.]] => error(false) -; [:l,x] := c -; [:markTranCategory exports,['default,['SEQ,:l,['exit,1,x]]]] - -(DEFUN |replaceCapsulePart| (|body|) - (PROG (|c| |ISTMP#1| |ISTMP#2| |exports| |ISTMP#3| |ISTMP#4| - |LETTMP#1| |x| |l|) - (declare (special |$categoryTranForm|)) - (RETURN - (COND - ((NULL (AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) 'CAPSULE) - (PROGN - (SPADLET |c| (QCDR |ISTMP#2|)) - 'T))))))) - |body|) - ((NULL (PROGN - (SPADLET |ISTMP#1| (ELT |$categoryTranForm| 0)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|add|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |exports| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |ISTMP#4| - (QCAR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCAR |ISTMP#4|) 'CAPSULE)))))))))) - (|error| NIL)) - ('T (SPADLET |LETTMP#1| (REVERSE |c|)) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) - (APPEND (|markTranCategory| |exports|) - (CONS (CONS '|default| - (CONS (CONS 'SEQ - (APPEND |l| - (CONS - (CONS '|exit| - (CONS 1 (CONS |x| NIL))) - NIL))) - NIL)) - NIL))))))) - -;foo(:x) == -; arg := IFCAR x or $bootForm -; markSay lisp2Boot arg - -(DEFUN |foo| (&REST G169584 &AUX |x|) - (DSETQ |x| G169584) - (PROG (|arg|) - (declare (special |$bootForm|)) - (RETURN - (PROGN - (SPADLET |arg| (OR (IFCAR |x|) |$bootForm|)) - (|markSay| (|lisp2Boot| |arg|)))))) - -;markPrintAbbreviation [kind,a,:b] == -; markSay '"--)abbrev " -; markSay kind -; markSay '" " -; markSay a -; markSay '" " -; markSay b -; markTerpri() - -(DEFUN |markPrintAbbreviation| (G169586) - (PROG (|kind| |a| |b|) - (RETURN - (PROGN - (SPADLET |kind| (CAR G169586)) - (SPADLET |a| (CADR G169586)) - (SPADLET |b| (CDDR G169586)) - (|markSay| "--)abbrev ") - (|markSay| |kind|) - (|markSay| " ") - (|markSay| |a|) - (|markSay| " ") - (|markSay| |b|) - (|markTerpri|))))) - -;markSay s == -; null atom s => -; for x in s repeat -; (markSay(lispStringList2String x); markTerpri()) -; PRINTEXP s -; if $outStream then PRINTEXP(s,$outStream) - -(DEFUN |markSay| (|s|) - (declare (special |$outStream|)) - (SEQ (COND - ((NULL (ATOM |s|)) - (DO ((G169610 |s| (CDR G169610)) (|x| NIL)) - ((OR (ATOM G169610) - (PROGN (SETQ |x| (CAR G169610)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (|markSay| (|lispStringList2String| |x|)) - (|markTerpri|)))))) - ('T (PRINTEXP |s|) - (COND (|$outStream| (PRINTEXP |s| |$outStream|)) ('T NIL)))))) - -;markTerpri() == -; TERPRI() -; if $outStream then TERPRI($outStream) - -(DEFUN |markTerpri| () - (declare (special |$outStream|)) - (PROGN - (TERPRI) - (COND (|$outStream| (TERPRI |$outStream|)) ('T NIL)))) - -;markTranJoin u == --subfunction of markPrint -; u is ['Join,:.] => markTranCategory u -; u - -(DEFUN |markTranJoin| (|u|) - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|)) - (|markTranCategory| |u|)) - ('T |u|))) - -;markTranCategory cat == -; cat is ['CATEGORY,:.] => cat -; cat is ['Join,:r] => -; r is [:s,b] and b is ['CATEGORY,k,:t] => ['CATEGORY,k,:s,:markSigTran t] -; ['CATEGORY,'domain,:markSigTran r] -; ['CATEGORY,'domain,cat] - -(DEFUN |markTranCategory| (|cat|) - (PROG (|r| |b| |s| |ISTMP#1| |k| |t|) - (RETURN - (COND - ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'CATEGORY)) |cat|) - ((AND (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) - (PROGN (SPADLET |r| (QCDR |cat|)) 'T)) - (COND - ((AND (PAIRP |r|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |r|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |s| (QCDR |ISTMP#1|)) - 'T) - (PROGN (SPADLET |s| (NREVERSE |s|)) 'T) (PAIRP |b|) - (EQ (QCAR |b|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |k| (QCAR |ISTMP#1|)) - (SPADLET |t| (QCDR |ISTMP#1|)) - 'T)))) - (CONS 'CATEGORY - (CONS |k| (APPEND |s| (|markSigTran| |t|))))) - ('T (CONS 'CATEGORY (CONS '|domain| (|markSigTran| |r|)))))) - ('T (CONS 'CATEGORY (CONS '|domain| (CONS |cat| NIL)))))))) - -;markSigTran t == [markElt2Apply x for x in t] - -(DEFUN |markSigTran| (|t|) - (PROG () - (RETURN - (SEQ (PROG (G169655) - (SPADLET G169655 NIL) - (RETURN - (DO ((G169660 |t| (CDR G169660)) (|x| NIL)) - ((OR (ATOM G169660) - (PROGN (SETQ |x| (CAR G169660)) NIL)) - (NREVERSE0 G169655)) - (SEQ (EXIT (SETQ G169655 - (CONS (|markElt2Apply| |x|) - G169655))))))))))) - -;markElt2Apply x == -; x is ["SIGNATURE", "elt", :r] => ['SIGNATURE, 'apply, :r] -; x - -(DEFUN |markElt2Apply| (|x|) - (PROG (|ISTMP#1| |r|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SIGNATURE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|elt|) - (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) - (CONS 'SIGNATURE (CONS '|apply| |r|))) - ('T |x|))))) - -;markCheckForAttributes cat == --subfunction of markPrint -; cat is ['Join,:r] => markCheckForAttributes last r -; cat is ['CATEGORY,.,:r] => [u for x in r | u := fn(x)] where fn(x) == -; x is ['ATTRIBUTE,form,:.] => -; name := opOf form -; MEMQ(name,$knownAttributes) => nil -; $knownAttributes := [name,:$knownAttributes] -; name -; nil -; nil - -(DEFUN |markCheckForAttributes,fn| (|x|) - (PROG (|ISTMP#1| |form| |name|) - (declare (special |$knownAttributes|)) - (RETURN - (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) 'ATTRIBUTE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |form| (QCAR |ISTMP#1|)) - 'T)))) - (EXIT (SEQ (SPADLET |name| (|opOf| |form|)) - (IF (MEMQ |name| |$knownAttributes|) - (EXIT NIL)) - (SPADLET |$knownAttributes| - (CONS |name| |$knownAttributes|)) - (EXIT |name|)))) - (EXIT NIL))))) - -(DEFUN |markCheckForAttributes| (|cat|) - (PROG (|ISTMP#1| |r| |u|) - (RETURN - (SEQ (COND - ((AND (PAIRP |cat|) (EQ (QCAR |cat|) '|Join|) - (PROGN (SPADLET |r| (QCDR |cat|)) 'T)) - (|markCheckForAttributes| (|last| |r|))) - ((AND (PAIRP |cat|) (EQ (QCAR |cat|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |cat|)) - (AND (PAIRP |ISTMP#1|) - (PROGN (SPADLET |r| (QCDR |ISTMP#1|)) 'T)))) - (PROG (G169704) - (SPADLET G169704 NIL) - (RETURN - (DO ((G169710 |r| (CDR G169710)) (|x| NIL)) - ((OR (ATOM G169710) - (PROGN (SETQ |x| (CAR G169710)) NIL)) - (NREVERSE0 G169704)) - (SEQ (EXIT (COND - ((SPADLET |u| - (|markCheckForAttributes,fn| - |x|)) - (SETQ G169704 (CONS |u| G169704)))))))))) - ('T NIL)))))) - -;--====================================================================== -;-- Put in PARTs in code -;--====================================================================== -;$partChoices := '(construct IF) - -(SPADLET |$partChoices| '(|construct| IF)) - -;$partSkips := '(CAPSULE with add) - -(SPADLET |$partSkips| '(CAPSULE |with| |add|)) - -;unpart x == -; x is ['PART,.,y] => y -; x - -(DEFUN |unpart| (|x|) - (PROG (|ISTMP#1| |ISTMP#2| |y|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'PART) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |y| (QCAR |ISTMP#2|)) 'T)))))) - |y|) - ('T |x|))))) - -;markInsertParts df == -; $partNumber := 0 -; ["DEF",form,a,b,body] := df -;--if form is [op,:r] and (u := LASSOC(op,$opRenameAlist)) -;-- then form := [u,:r] -; ['DEF,form,a,b,markInsertBodyParts body] - -(DEFUN |markInsertParts| (|df|) - (PROG (|form| |a| |b| |body|) - (declare (special |$partNumber|)) - (RETURN - (PROGN - (SPADLET |$partNumber| 0) - (COND ((EQ (CAR |df|) 'DEF) (CAR |df|))) - (SPADLET |form| (CADR |df|)) - (SPADLET |a| (CADDR |df|)) - (SPADLET |b| (CADDDR |df|)) - (SPADLET |body| (CAR (CDDDDR |df|))) - (CONS 'DEF - (CONS |form| - (CONS |a| - (CONS |b| - (CONS (|markInsertBodyParts| |body|) - NIL))))))))) - -;markInsertBodyParts u == -; u is ['Join,:.] or u is ['CATEGORY,:.] => u -; u is ['DEF,f,a,b,body] => ['DEF,f,a,b,markInsertBodyParts body] -; u is ['SEQ,:l,['exit,n,x]] => -; ['SEQ,:[markInsertBodyParts y for y in l], -; ['exit,n,markInsertBodyParts x]] -; u is [op,:l] and MEMQ(op,'(REPEAT COLLECT)) => markInsertRepeat u -; u is ['LET,['Tuple,:s],b] => -; ['LET,['Tuple,:[markWrapPart x for x in s]],markInsertBodyParts b] -;--u is ['LET,a,b] and constructor? opOf b => u -; u is ['LET,a,b] and a is [op,:.] => -; ['LET,[markWrapPart x for x in a],markInsertBodyParts b] -; u is [op,a,b] and MEMQ(op,'(_add _with IN LET)) => -; [op,markInsertBodyParts a,markInsertBodyParts b] -; u is [op,a,b] and MEMQ(op,'(_: _:_: _pretend _@)) => -; [op,markInsertBodyParts a,b] -; u is [op,a,:x] and MEMQ(op,'(STEP return leave exit reduce)) => -; [op,a,:[markInsertBodyParts y for y in x]] -; u is [op,:x] and markPartOp? op => [op,:[markWrapPart y for y in x]] -; u is [op,:.] and constructor? op => u -; atom u => markWrapPart u -; ------------ <--------------94/10/11 -; [markInsertBodyParts x for x in u] - -(DEFUN |markInsertBodyParts| (|u|) - (PROG (|f| |body| |ISTMP#4| |n| |ISTMP#5| |l| |s| |ISTMP#3| |ISTMP#2| - |b| |ISTMP#1| |a| |x| |op|) - (RETURN - (SEQ (COND - ((OR (AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|)) - (AND (PAIRP |u|) (EQ (QCAR |u|) 'CATEGORY))) - |u|) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'DEF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |f| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |body| - (QCAR |ISTMP#4|)) - 'T)))))))))) - (CONS 'DEF - (CONS |f| - (CONS |a| - (CONS |b| - (CONS - (|markInsertBodyParts| |body|) - NIL)))))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) '|exit|) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |x| (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN (SPADLET |l| (QCDR |ISTMP#2|)) 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) - (CONS 'SEQ - (APPEND (PROG (G169963) - (SPADLET G169963 NIL) - (RETURN - (DO ((G169968 |l| (CDR G169968)) - (|y| NIL)) - ((OR (ATOM G169968) - (PROGN - (SETQ |y| (CAR G169968)) - NIL)) - (NREVERSE0 G169963)) - (SEQ (EXIT - (SETQ G169963 - (CONS - (|markInsertBodyParts| |y|) - G169963))))))) - (CONS (CONS '|exit| - (CONS |n| - (CONS - (|markInsertBodyParts| |x|) - NIL))) - NIL)))) - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |l| (QCDR |u|)) - 'T) - (MEMQ |op| '(REPEAT COLLECT))) - (|markInsertRepeat| |u|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) '|Tuple|) - (PROGN - (SPADLET |s| (QCDR |ISTMP#2|)) - 'T))) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#3|)) - 'T)))))) - (CONS 'LET - (CONS (CONS '|Tuple| - (PROG (G169978) - (SPADLET G169978 NIL) - (RETURN - (DO - ((G169983 |s| (CDR G169983)) - (|x| NIL)) - ((OR (ATOM G169983) - (PROGN - (SETQ |x| (CAR G169983)) - NIL)) - (NREVERSE0 G169978)) - (SEQ - (EXIT - (SETQ G169978 - (CONS (|markWrapPart| |x|) - G169978)))))))) - (CONS (|markInsertBodyParts| |b|) NIL)))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (PAIRP |a|) (PROGN (SPADLET |op| (QCAR |a|)) 'T)) - (CONS 'LET - (CONS (PROG (G169993) - (SPADLET G169993 NIL) - (RETURN - (DO ((G169998 |a| (CDR G169998)) - (|x| NIL)) - ((OR (ATOM G169998) - (PROGN - (SETQ |x| (CAR G169998)) - NIL)) - (NREVERSE0 G169993)) - (SEQ (EXIT - (SETQ G169993 - (CONS (|markWrapPart| |x|) - G169993))))))) - (CONS (|markInsertBodyParts| |b|) NIL)))) - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |op| '(|add| |with| IN LET))) - (CONS |op| - (CONS (|markInsertBodyParts| |a|) - (CONS (|markInsertBodyParts| |b|) NIL)))) - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |op| '(|:| |::| |pretend| @))) - (CONS |op| - (CONS (|markInsertBodyParts| |a|) (CONS |b| NIL)))) - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |x| (QCDR |ISTMP#1|)) - 'T))) - (MEMQ |op| '(STEP |return| |leave| |exit| |reduce|))) - (CONS |op| - (CONS |a| - (PROG (G170008) - (SPADLET G170008 NIL) - (RETURN - (DO ((G170013 |x| (CDR G170013)) - (|y| NIL)) - ((OR (ATOM G170013) - (PROGN - (SETQ |y| (CAR G170013)) - NIL)) - (NREVERSE0 G170008)) - (SEQ (EXIT - (SETQ G170008 - (CONS - (|markInsertBodyParts| |y|) - G170008)))))))))) - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |x| (QCDR |u|)) - 'T) - (|markPartOp?| |op|)) - (CONS |op| - (PROG (G170023) - (SPADLET G170023 NIL) - (RETURN - (DO ((G170028 |x| (CDR G170028)) (|y| NIL)) - ((OR (ATOM G170028) - (PROGN - (SETQ |y| (CAR G170028)) - NIL)) - (NREVERSE0 G170023)) - (SEQ (EXIT (SETQ G170023 - (CONS (|markWrapPart| |y|) - G170023))))))))) - ((AND (PAIRP |u|) (PROGN (SPADLET |op| (QCAR |u|)) 'T) - (|constructor?| |op|)) - |u|) - ((ATOM |u|) (|markWrapPart| |u|)) - ('T - (PROG (G170038) - (SPADLET G170038 NIL) - (RETURN - (DO ((G170043 |u| (CDR G170043)) (|x| NIL)) - ((OR (ATOM G170043) - (PROGN (SETQ |x| (CAR G170043)) NIL)) - (NREVERSE0 G170038)) - (SEQ (EXIT (SETQ G170038 - (CONS (|markInsertBodyParts| |x|) - G170038))))))))))))) - -;markPartOp? op == -; MEMQ(op,$partChoices) => true -; MEMQ(op,$partSkips) => false -; if op is ['elt,.,o] then op := o -; GET(op,'special) => false -; true - -(DEFUN |markPartOp?| (|op|) - (PROG (|ISTMP#1| |ISTMP#2| |o|) - (declare (special |$partSkips| |$partChoices|)) - (RETURN - (COND - ((MEMQ |op| |$partChoices|) 'T) - ((MEMQ |op| |$partSkips|) NIL) - ('T - (COND - ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |o| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |op| |o|))) - (COND ((GETL |op| '|special|) NIL) ('T 'T))))))) - -;markWrapPart y == -;----------------new definition----------94/10/11 -; atom y => -; y = 'noBranch => y -; GET(y, 'SPECIAL) => y -; $partNumber := $partNumber + 1 -; ['PART,$partNumber, y] -; ['PART,$partNumber := $partNumber + 1,markInsertBodyParts y] - -(DEFUN |markWrapPart| (|y|) - (declare (special |$partNumber|)) - (COND - ((ATOM |y|) - (COND - ((BOOT-EQUAL |y| '|noBranch|) |y|) - ((GETL |y| 'SPECIAL) |y|) - ('T (SPADLET |$partNumber| (PLUS |$partNumber| 1)) - (CONS 'PART (CONS |$partNumber| (CONS |y| NIL)))))) - ('T - (CONS 'PART - (CONS (SPADLET |$partNumber| (PLUS |$partNumber| 1)) - (CONS (|markInsertBodyParts| |y|) NIL)))))) - -;markInsertRepeat [op,:itl,body] == -; nitl := [markInsertIterator x for x in itl] -; nbody := -;--->IDENTP body => markWrapPart body -;----------------new definition----------94/10/11 -; markInsertBodyParts body -; [op,:nitl,nbody] - -(DEFUN |markInsertRepeat| (G170130) - (PROG (|op| |LETTMP#1| |body| |itl| |nitl| |nbody|) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR G170130)) - (SPADLET |LETTMP#1| (REVERSE (CDR G170130))) - (SPADLET |body| (CAR |LETTMP#1|)) - (SPADLET |itl| (NREVERSE (CDR |LETTMP#1|))) - (SPADLET |nitl| - (PROG (G170147) - (SPADLET G170147 NIL) - (RETURN - (DO ((G170152 |itl| (CDR G170152)) - (|x| NIL)) - ((OR (ATOM G170152) - (PROGN - (SETQ |x| (CAR G170152)) - NIL)) - (NREVERSE0 G170147)) - (SEQ (EXIT (SETQ G170147 - (CONS - (|markInsertIterator| |x|) - G170147)))))))) - (SPADLET |nbody| (|markInsertBodyParts| |body|)) - (CONS |op| (APPEND |nitl| (CONS |nbody| NIL)))))))) - -;markInsertIterator x == -; x is ['STEP,k,:r] => ['STEP,markWrapPart k,:[markWrapPart x for x in r]] -; x is ['IN,p,q] => ['IN,markWrapPart p,markWrapPart q] -; x is ["|",p] => ["|",markWrapPart p] -; x is ['WHILE,p] => ['WHILE,markWrapPart p] -; x is ['UNTIL,p] => ['UNTIL,markWrapPart p] -; systemError() - -(DEFUN |markInsertIterator| (|x|) - (PROG (|k| |r| |ISTMP#2| |q| |ISTMP#1| |p|) - (RETURN - (SEQ (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'STEP) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |k| (QCAR |ISTMP#1|)) - (SPADLET |r| (QCDR |ISTMP#1|)) - 'T)))) - (CONS 'STEP - (CONS (|markWrapPart| |k|) - (PROG (G170209) - (SPADLET G170209 NIL) - (RETURN - (DO ((G170214 |r| (CDR G170214)) - (|x| NIL)) - ((OR (ATOM G170214) - (PROGN - (SETQ |x| (CAR G170214)) - NIL)) - (NREVERSE0 G170209)) - (SEQ (EXIT - (SETQ G170209 - (CONS (|markWrapPart| |x|) - G170209)))))))))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IN) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |q| (QCAR |ISTMP#2|)) - 'T)))))) - (CONS 'IN - (CONS (|markWrapPart| |p|) - (CONS (|markWrapPart| |q|) NIL)))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|\||) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) - (CONS '|\|| (CONS (|markWrapPart| |p|) NIL))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'WHILE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) - (CONS 'WHILE (CONS (|markWrapPart| |p|) NIL))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'UNTIL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |p| (QCAR |ISTMP#1|)) 'T)))) - (CONS 'UNTIL (CONS (|markWrapPart| |p|) NIL))) - ('T (|systemError|))))))) - -;--====================================================================== -;-- Kill Function: MarkedUpCode --> Code -;--====================================================================== -;markKillExpr m == --used to kill all but PART information for compilation -; m is [op,:.] => -; MEMQ(op,'(MI WI)) => markKillExpr CADDR m -; MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillExpr CADDDR m -; m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillExpr x,m,e]] -; [markKillExpr x for x in m] -; m - -(DEFUN |markKillExpr| (|m|) - (PROG (|op| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |x| |ISTMP#4| |ISTMP#5| - |e|) - (RETURN - (SEQ (COND - ((AND (PAIRP |m|) (PROGN (SPADLET |op| (QCAR |m|)) 'T)) - (COND - ((MEMQ |op| '(MI WI)) (|markKillExpr| (CADDR |m|))) - ((MEMQ |op| '(AUTOHARD AUTOSUBSET AUTOREP)) - (|markKillExpr| (CADDDR |m|))) - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|TAGGEDreturn|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |m| - (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |e| - (QCAR |ISTMP#5|)) - 'T)))))))))))) - (CONS '|TAGGEDreturn| - (CONS |a| - (CONS (CONS (|markKillExpr| |x|) - (CONS |m| (CONS |e| NIL))) - NIL)))) - ('T - (PROG (G170317) - (SPADLET G170317 NIL) - (RETURN - (DO ((G170322 |m| (CDR G170322)) (|x| NIL)) - ((OR (ATOM G170322) - (PROGN (SETQ |x| (CAR G170322)) NIL)) - (NREVERSE0 G170317)) - (SEQ (EXIT (SETQ G170317 - (CONS (|markKillExpr| |x|) - G170317)))))))))) - ('T |m|)))))) - -;markKillButIfs m == --used to kill all but PART information for compilation -; m is [op,:.] => -; op = 'IF => m -; op = 'PART => markKillButIfs CADDR m -; MEMQ(op,'(MI WI)) => markKillButIfs CADDR m -; MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillButIfs CADDDR m -; m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillButIfs x,m,e]] -; [markKillButIfs x for x in m] -; m - -(DEFUN |markKillButIfs| (|m|) - (PROG (|op| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |x| |ISTMP#4| |ISTMP#5| - |e|) - (RETURN - (SEQ (COND - ((AND (PAIRP |m|) (PROGN (SPADLET |op| (QCAR |m|)) 'T)) - (COND - ((BOOT-EQUAL |op| 'IF) |m|) - ((BOOT-EQUAL |op| 'PART) - (|markKillButIfs| (CADDR |m|))) - ((MEMQ |op| '(MI WI)) (|markKillButIfs| (CADDR |m|))) - ((MEMQ |op| '(AUTOHARD AUTOSUBSET AUTOREP)) - (|markKillButIfs| (CADDDR |m|))) - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|TAGGEDreturn|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |m| - (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |e| - (QCAR |ISTMP#5|)) - 'T)))))))))))) - (CONS '|TAGGEDreturn| - (CONS |a| - (CONS (CONS (|markKillButIfs| |x|) - (CONS |m| (CONS |e| NIL))) - NIL)))) - ('T - (PROG (G170422) - (SPADLET G170422 NIL) - (RETURN - (DO ((G170427 |m| (CDR G170427)) (|x| NIL)) - ((OR (ATOM G170427) - (PROGN (SETQ |x| (CAR G170427)) NIL)) - (NREVERSE0 G170422)) - (SEQ (EXIT (SETQ G170422 - (CONS (|markKillButIfs| |x|) - G170422)))))))))) - ('T |m|)))))) - -;markKillAll m == --used to prepare code for compilation -; m is [op,:.] => -; op = 'PART => markKillAll CADDR m -; MEMQ(op,'(MI WI)) => markKillAll CADDR m -; MEMQ(op,'(AUTOHARD AUTOSUBSET AUTOREP)) => markKillAll CADDDR m -; m is ['TAGGEDreturn,a,[x,m,e]] => ['TAGGEDreturn, a, [markKillAll x,m,e]] -; [markKillAll x for x in m] -; m - -(DEFUN |markKillAll| (|m|) - (PROG (|op| |ISTMP#1| |a| |ISTMP#2| |ISTMP#3| |x| |ISTMP#4| |ISTMP#5| - |e|) - (RETURN - (SEQ (COND - ((AND (PAIRP |m|) (PROGN (SPADLET |op| (QCAR |m|)) 'T)) - (COND - ((BOOT-EQUAL |op| 'PART) (|markKillAll| (CADDR |m|))) - ((MEMQ |op| '(MI WI)) (|markKillAll| (CADDR |m|))) - ((MEMQ |op| '(AUTOHARD AUTOSUBSET AUTOREP)) - (|markKillAll| (CADDDR |m|))) - ((AND (PAIRP |m|) (EQ (QCAR |m|) '|TAGGEDreturn|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |m|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |m| - (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |e| - (QCAR |ISTMP#5|)) - 'T)))))))))))) - (CONS '|TAGGEDreturn| - (CONS |a| - (CONS (CONS (|markKillAll| |x|) - (CONS |m| (CONS |e| NIL))) - NIL)))) - ('T - (PROG (G170527) - (SPADLET G170527 NIL) - (RETURN - (DO ((G170532 |m| (CDR G170532)) (|x| NIL)) - ((OR (ATOM G170532) - (PROGN (SETQ |x| (CAR G170532)) NIL)) - (NREVERSE0 G170527)) - (SEQ (EXIT (SETQ G170527 - (CONS (|markKillAll| |x|) - G170527)))))))))) - ('T |m|)))))) - -;--====================================================================== -;-- Moving lines up/down -;--====================================================================== -;moveAroundLines() == -; changeToEqualEqual $bootLines -; $bootLines := moveImportsAfterDefinitions $bootLines - -(DEFUN |moveAroundLines| () - (declare (special |$bootLines|)) - (PROGN - (|changeToEqualEqual| |$bootLines|) - (SPADLET |$bootLines| (|moveImportsAfterDefinitions| |$bootLines|)))) - -;changeToEqualEqual lines == -;--rewrite A := B as A == B whenever A is an identifier and -;-- B is a constructor name (after macro exp.) -; origLines := lines -; while lines is [x, :lines] repeat -; N := MAXINDEX x -; (n := charPosition($blank, x, 8)) > N => nil -; n = 0 => nil -; not ALPHA_-CHAR_-P (x . (n - 1)) => nil -; not substring?('":= ", x, n+1) => nil -; m := n + 3 -; while (m := m + 1) <= N and ALPHA_-CHAR_-P (x . m) repeat nil -; m = n + 2 => nil -; not UPPER_-CASE_-P (x . (n + 4)) => nil -; word := INTERN SUBSTRING(x, n + 4, m - n - 4) -; expandedWord := macroExpand(word,$e) -; not (MEMQ(word, '(Record Union Mapping)) -; or GETDATABASE(opOf expandedWord,'CONSTRUCTORFORM)) => nil -; sayMessage '"Converting input line:" -; sayMessage ['"WAS: ", x] -; x . (n + 1) := char '_= ; -; sayMessage ['"IS: ", x] -; TERPRI() -; origLines - -(DEFUN |changeToEqualEqual| (|lines|) - (PROG (|origLines| |x| N |n| |m| |word| |expandedWord|) - (declare (special |$e| |$blank|)) - (RETURN - (SEQ (PROGN - (SPADLET |origLines| |lines|) - (DO () - ((NULL (AND (PAIRP |lines|) - (PROGN - (SPADLET |x| (QCAR |lines|)) - (SPADLET |lines| (QCDR |lines|)) - 'T))) - NIL) - (SEQ (EXIT (PROGN - (SPADLET N (MAXINDEX |x|)) - (COND - ((> (SPADLET |n| - (|charPosition| |$blank| |x| - 8)) - N) - NIL) - ((EQL |n| 0) NIL) - ((NULL (ALPHA-CHAR-P - (ELT |x| (SPADDIFFERENCE |n| 1)))) - NIL) - ((NULL (|substring?| ":= " - |x| (PLUS |n| 1))) - NIL) - ('T (SPADLET |m| (PLUS |n| 3)) - (DO () - ((NULL - (AND - (<= (SPADLET |m| (PLUS |m| 1)) N) - (ALPHA-CHAR-P (ELT |x| |m|)))) - NIL) - (SEQ (EXIT NIL))) - (COND - ((BOOT-EQUAL |m| (PLUS |n| 2)) NIL) - ((NULL (UPPER-CASE-P - (ELT |x| (PLUS |n| 4)))) - NIL) - ('T - (SPADLET |word| - (INTERN - (SUBSTRING |x| (PLUS |n| 4) - (SPADDIFFERENCE - (SPADDIFFERENCE |m| |n|) - 4)))) - (SPADLET |expandedWord| - (|macroExpand| |word| |$e|)) - (COND - ((NULL - (OR - (MEMQ |word| - '(|Record| |Union| |Mapping|)) - (GETDATABASE - (|opOf| |expandedWord|) - 'CONSTRUCTORFORM))) - NIL) - ('T - (|sayMessage| - "Converting input line:") - (|sayMessage| - (CONS "WAS: " - (CONS |x| NIL))) - (SETELT |x| (PLUS |n| 1) - (|char| '=)) - (|sayMessage| - (CONS "IS: " - (CONS |x| NIL))) - (TERPRI))))))))))) - |origLines|))))) - -;sayMessage x == -; u := -; ATOM x => ['">> ", x] -; ['">> ",: x] -; sayBrightly u - -(DEFUN |sayMessage| (|x|) - (PROG (|u|) - (RETURN - (PROGN - (SPADLET |u| - (COND - ((ATOM |x|) - (CONS ">> " (CONS |x| NIL))) - ('T (CONS ">> " |x|)))) - (|sayBrightly| |u|))))) - -;moveImportsAfterDefinitions lines == -; al := nil -; for x in lines for i in 0.. repeat -; N := MAXINDEX x -; m := firstNonBlankPosition x -; m < 0 => nil -; ((n := charPosition($blank ,x,1 + m)) < N) and -; substring?('"== ", x, n+1) => -; name := SUBSTRING(x, m, n - m) -; defineAlist := [[name, :i], :defineAlist] -; (k := leadingSubstring?('"import from ",x, 0)) => -; importAlist := [[SUBSTRING(x,k + 12,nil), :i], :importAlist] -;-- pp defineAlist -;-- pp importAlist -; for [name, :i] in defineAlist repeat -; or/[fn for [imp, :j] in importAlist] where fn == -; substring?(name,imp,0) => -; moveAlist := [[i,:j], :moveAlist] -; nil -; null moveAlist => lines -; moveLinesAfter(mySort moveAlist, lines) - -(DEFUN |moveImportsAfterDefinitions| (|lines|) - (PROG (|al| N |m| |n| |defineAlist| |k| |importAlist| |name| |i| - |imp| |j| |moveAlist|) - (declare (special |$blank|)) - (RETURN - (SEQ (PROGN - (SPADLET |al| NIL) - (DO ((G170617 |lines| (CDR G170617)) (|x| NIL) - (|i| 0 (QSADD1 |i|))) - ((OR (ATOM G170617) - (PROGN (SETQ |x| (CAR G170617)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET N (MAXINDEX |x|)) - (SPADLET |m| (|firstNonBlankPosition| |x|)) - (COND - ((MINUSP |m|) NIL) - ((AND (> N - (SPADLET |n| - (|charPosition| |$blank| |x| - (PLUS 1 |m|)))) - (|substring?| "== " - |x| (PLUS |n| 1))) - (SPADLET |name| - (SUBSTRING |x| |m| - (SPADDIFFERENCE |n| |m|))) - (SPADLET |defineAlist| - (CONS (CONS |name| |i|) - |defineAlist|))) - ((SPADLET |k| - (|leadingSubstring?| - "import from " - |x| 0)) - (SPADLET |importAlist| - (CONS - (CONS - (SUBSTRING |x| (PLUS |k| 12) - NIL) - |i|) - |importAlist|)))))))) - (DO ((G170630 |defineAlist| (CDR G170630)) - (G170605 NIL)) - ((OR (ATOM G170630) - (PROGN (SETQ G170605 (CAR G170630)) NIL) - (PROGN - (PROGN - (SPADLET |name| (CAR G170605)) - (SPADLET |i| (CDR G170605)) - G170605) - NIL)) - NIL) - (SEQ (EXIT (PROG (G170637) - (SPADLET G170637 NIL) - (RETURN - (DO ((G170644 NIL G170637) - (G170645 |importAlist| - (CDR G170645)) - (G170597 NIL)) - ((OR G170644 (ATOM G170645) - (PROGN - (SETQ G170597 (CAR G170645)) - NIL) - (PROGN - (PROGN - (SPADLET |imp| (CAR G170597)) - (SPADLET |j| (CDR G170597)) - G170597) - NIL)) - G170637) - (SEQ (EXIT - (SETQ G170637 - (OR G170637 - (COND - ((|substring?| |name| |imp| - 0) - (SPADLET |moveAlist| - (CONS (CONS |i| |j|) - |moveAlist|))) - ('T NIL)))))))))))) - (COND - ((NULL |moveAlist|) |lines|) - ('T (|moveLinesAfter| (|mySort| |moveAlist|) |lines|)))))))) - -;leadingSubstring?(part, whole, :options) == -; after := IFCAR options or 0 -; substring?(part, whole, k := firstNonBlankPosition(whole, after)) => k -; false - -(DEFUN |leadingSubstring?| - (&REST G170676 &AUX |options| |whole| |part|) - (DSETQ (|part| |whole| . |options|) G170676) - (PROG (|after| |k|) - (RETURN - (PROGN - (SPADLET |after| (OR (IFCAR |options|) 0)) - (COND - ((|substring?| |part| |whole| - (SPADLET |k| (|firstNonBlankPosition| |whole| |after|))) - |k|) - ('T NIL)))))) - -;stringIsWordOf?(s, t, startpos) == -; maxindex := MAXINDEX t -; (n := stringPosition(s, t, startpos)) > maxindex => nil -; wordDelimiter? t . (n - 1) -; n = maxindex or wordDelimiter? t . (n + #s) - -(DEFUN |stringIsWordOf?| (|s| |t| |startpos|) - (PROG (|maxindex| |n|) - (RETURN - (PROGN - (SPADLET |maxindex| (MAXINDEX |t|)) - (COND - ((> (SPADLET |n| (|stringPosition| |s| |t| |startpos|)) - |maxindex|) - NIL) - ('T (|wordDelimiter?| (ELT |t| (SPADDIFFERENCE |n| 1))) - (OR (BOOT-EQUAL |n| |maxindex|) - (|wordDelimiter?| (ELT |t| (PLUS |n| (|#| |s|))))))))))) - -;wordDelimiter? c == or/[CHAR_=(c,('"() ,;").i) for i in 0..4] - -(DEFUN |wordDelimiter?| (|c|) - (PROG () - (RETURN - (SEQ (PROG (G170683) - (SPADLET G170683 NIL) - (RETURN - (DO ((G170689 NIL G170683) (|i| 0 (QSADD1 |i|))) - ((OR G170689 (QSGREATERP |i| 4)) G170683) - (SEQ (EXIT (SETQ G170683 - (OR G170683 - (CHAR= |c| - (ELT "() ,;" |i|))))))))))))) - -;moveLinesAfter(alist, lines) == -; n := #lines -; acc := nil -; for i in 0..(n - 1) for x in lines repeat -; (p := ASSOC(i, alist)) and STRINGP CDR p => acc := [CDR p, x, :acc] -; (p := lookupRight(i, alist)) and (CAR p) > i => RPLACD(p, x) -; acc := [x, :acc] -; REVERSE acc - -(DEFUN |moveLinesAfter| (|alist| |lines|) - (PROG (|n| |p| |acc|) - (RETURN - (SEQ (PROGN - (SPADLET |n| (|#| |lines|)) - (SPADLET |acc| NIL) - (DO ((G170704 (SPADDIFFERENCE |n| 1)) - (|i| 0 (QSADD1 |i|)) - (G170705 |lines| (CDR G170705)) (|x| NIL)) - ((OR (QSGREATERP |i| G170704) (ATOM G170705) - (PROGN (SETQ |x| (CAR G170705)) NIL)) - NIL) - (SEQ (EXIT (COND - ((AND (SPADLET |p| (|assoc| |i| |alist|)) - (STRINGP (CDR |p|))) - (SPADLET |acc| - (CONS (CDR |p|) (CONS |x| |acc|)))) - ((AND (SPADLET |p| - (|lookupRight| |i| |alist|)) - (> (CAR |p|) |i|)) - (RPLACD |p| |x|)) - ('T (SPADLET |acc| (CONS |x| |acc|))))))) - (REVERSE |acc|)))))) - -;lookupRight(x, al) == -; al is [p, :al] => -; x = CDR p => p -; lookupRight(x, al) -; nil - -(DEFUN |lookupRight| (|x| |al|) - (PROG (|p|) - (RETURN - (COND - ((AND (PAIRP |al|) - (PROGN - (SPADLET |p| (QCAR |al|)) - (SPADLET |al| (QCDR |al|)) - 'T)) - (COND - ((BOOT-EQUAL |x| (CDR |p|)) |p|) - ('T (|lookupRight| |x| |al|)))) - ('T NIL))))) - -;--====================================================================== -;-- Utility Functions -;--====================================================================== -; -;ppEnv [ce,:.] == -; for env in ce repeat -; for contour in env repeat -; pp contour - -(DEFUN |ppEnv| (G170731) - (PROG (|ce|) - (RETURN - (SEQ (PROGN - (SPADLET |ce| (CAR G170731)) - (DO ((G170741 |ce| (CDR G170741)) (|env| NIL)) - ((OR (ATOM G170741) - (PROGN (SETQ |env| (CAR G170741)) NIL)) - NIL) - (SEQ (EXIT (DO ((G170750 |env| (CDR G170750)) - (|contour| NIL)) - ((OR (ATOM G170750) - (PROGN - (SETQ |contour| (CAR G170750)) - NIL)) - NIL) - (SEQ (EXIT (|pp| |contour|)))))))))))) - -;diff(x,y) == -; for [p,q] in (r := diff1(x,y)) repeat -; pp '"------------" -; pp p -; pp q -; #r - -(DEFUN |diff| (|x| |y|) - (PROG (|r| |p| |q|) - (RETURN - (SEQ (PROGN - (DO ((G170773 (SPADLET |r| (|diff1| |x| |y|)) - (CDR G170773)) - (G170761 NIL)) - ((OR (ATOM G170773) - (PROGN (SETQ G170761 (CAR G170773)) NIL) - (PROGN - (PROGN - (SPADLET |p| (CAR G170761)) - (SPADLET |q| (CADR G170761)) - G170761) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (|pp| "------------") - (|pp| |p|) - (|pp| |q|))))) - (|#| |r|)))))) - -;diff1(x,y) == -; x = y => nil -; ATOM x or ATOM y => [[x,y]] -; #x ^= #y => [x,y] -; "APPEND"/[diff1(u,v) for u in x for v in y] - -(DEFUN |diff1| (|x| |y|) - (PROG () - (RETURN - (SEQ (COND - ((BOOT-EQUAL |x| |y|) NIL) - ((OR (ATOM |x|) (ATOM |y|)) - (CONS (CONS |x| (CONS |y| NIL)) NIL)) - ((NEQUAL (|#| |x|) (|#| |y|)) (CONS |x| (CONS |y| NIL))) - ('T - (PROG (G170787) - (SPADLET G170787 NIL) - (RETURN - (DO ((G170793 |x| (CDR G170793)) (|u| NIL) - (G170794 |y| (CDR G170794)) (|v| NIL)) - ((OR (ATOM G170793) - (PROGN (SETQ |u| (CAR G170793)) NIL) - (ATOM G170794) - (PROGN (SETQ |v| (CAR G170794)) NIL)) - G170787) - (SEQ (EXIT (SETQ G170787 - (APPEND G170787 - (|diff1| |u| |v|)))))))))))))) - -;markConstructorForm name == --------> same as getConstructorForm -; name = 'Union => '(Union (_: a A) (_: b B)) -; name = 'UntaggedUnion => '(Union A B) -; name = 'Record => '(Record (_: a A) (_: b B)) -; name = 'Mapping => '(Mapping T S) -; GETDATABASE(name,'CONSTRUCTORFORM) - -(DEFUN |markConstructorForm| (|name|) - (COND - ((BOOT-EQUAL |name| '|Union|) '(|Union| (|:| |a| A) (|:| |b| B))) - ((BOOT-EQUAL |name| '|UntaggedUnion|) '(|Union| A B)) - ((BOOT-EQUAL |name| '|Record|) '(|Record| (|:| |a| A) (|:| |b| B))) - ((BOOT-EQUAL |name| '|Mapping|) '(|Mapping| T S)) - ('T (GETDATABASE |name| 'CONSTRUCTORFORM)))) - -;--====================================================================== -;-- new path functions -;--====================================================================== -; -;markGetPaths(x,y) == -; BOUNDP '$newPaths and $newPaths => -;-- res := reverseDown mkGetPaths(x, y) -; res := mkGetPaths(x, y) -;-- oldRes := markPaths(x,y,[nil]) -;-- if res ^= oldRes then $badStack := [[x, :y], :$badStack] -;-- oldRes -; markPaths(x,y,[nil]) - -(DEFUN |markGetPaths| (|x| |y|) - (PROG (|res|) - (declare (special |$newPaths|)) - (RETURN - (COND - ((AND (BOUNDP '|$newPaths|) |$newPaths|) - (SPADLET |res| (|mkGetPaths| |x| |y|))) - ('T (|markPaths| |x| |y| (CONS NIL NIL))))))) - -;mkCheck() == -; for [x, :y] in REMDUP $badStack repeat -; pp '"!!-------------------------------!!" -; res := mkGetPaths(x, y) -; oldRes := markPaths(x, y, [nil]) -; pp x -; pp y -; sayBrightlyNT '"new: " -; pp res -; sayBrightlyNT '"old: " -; pp oldRes - -(DEFUN |mkCheck| () - (PROG (|x| |y| |res| |oldRes|) - (declare (special |$badStack|)) - (RETURN - (SEQ (DO ((G170834 (REMDUP |$badStack|) (CDR G170834)) - (G170817 NIL)) - ((OR (ATOM G170834) - (PROGN (SETQ G170817 (CAR G170834)) NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR G170817)) - (SPADLET |y| (CDR G170817)) - G170817) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (|pp| "!!-------------------------------!!") - (SPADLET |res| (|mkGetPaths| |x| |y|)) - (SPADLET |oldRes| - (|markPaths| |x| |y| (CONS NIL NIL))) - (|pp| |x|) - (|pp| |y|) - (|sayBrightlyNT| "new: ") - (|pp| |res|) - (|sayBrightlyNT| "old: ") - (|pp| |oldRes|))))))))) - -;reverseDown u == [REVERSE x for x in u] - -(DEFUN |reverseDown| (|u|) - (PROG () - (RETURN - (SEQ (PROG (G170852) - (SPADLET G170852 NIL) - (RETURN - (DO ((G170857 |u| (CDR G170857)) (|x| NIL)) - ((OR (ATOM G170857) - (PROGN (SETQ |x| (CAR G170857)) NIL)) - (NREVERSE0 G170852)) - (SEQ (EXIT (SETQ G170852 - (CONS (REVERSE |x|) G170852))))))))))) - -;mkCheckRun() == -; for [x, :y] in REMDUP $badStack repeat -; pp mkGetPaths(x,y) - -(DEFUN |mkCheckRun| () - (PROG (|x| |y|) - (declare (special |$badStack|)) - (RETURN - (SEQ (DO ((G170875 (REMDUP |$badStack|) (CDR G170875)) - (G170867 NIL)) - ((OR (ATOM G170875) - (PROGN (SETQ G170867 (CAR G170875)) NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR G170867)) - (SPADLET |y| (CDR G170867)) - G170867) - NIL)) - NIL) - (SEQ (EXIT (|pp| (|mkGetPaths| |x| |y|))))))))) - -;mkGetPaths(x,y) == -; u := REMDUP mkPaths(x,y) => getLocationsOf(u,y,nil) -; nil - -(DEFUN |mkGetPaths| (|x| |y|) - (PROG (|u|) - (RETURN - (COND - ((SPADLET |u| (REMDUP (|mkPaths| |x| |y|))) - (|getLocationsOf| |u| |y| NIL)) - ('T NIL))))) - -;mkPaths(x,y) == --x < y; find location s of x in y (initially s=nil) -; markPathsEqual(x,y) => [y] -; atom y => nil -; x is [op, :u] and MEMQ(op,'(LIST VECTOR)) and y is ['construct,:v] -; and markPathsEqual(['construct,:u],y) => [y] -; (y is ['LET,a,b] or y is ['IF,a,b,:.]) and GENSYMP a and markPathsEqual(x,b) => [y] -; y is ['call,:r] => -;-- markPathsEqual(x,y1) => [y] -; mkPaths(x,r) => [y] -; y is ['PART,.,y1] => mkPaths(x,y1) -; y is [fn,.,y1] and MEMQ(fn,'(CATCH THROW)) => -;-- markPathsEqual(x,y1) => [y] -; mkPaths(x,y1) => [y] -; y is [['elt,.,op],:r] and (u := mkPaths(x,[op,:r])) => u -; x is ['elt,:r] and (u := mkPaths(r,y)) => u -; y is ['elt,:r] and (u := mkPaths(x,r)) => u -; "APPEND"/[u for z in y | u := mkPaths(x,z)] - -(DEFUN |mkPaths| (|x| |y|) - (PROG (|v| |a| |b| |fn| |y1| |ISTMP#1| |ISTMP#2| |ISTMP#3| |op| |r| - |u|) - (RETURN - (SEQ (COND - ((|markPathsEqual| |x| |y|) (CONS |y| NIL)) - ((ATOM |y|) NIL) - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |u| (QCDR |x|)) - 'T) - (MEMQ |op| '(LIST VECTOR)) (PAIRP |y|) - (EQ (QCAR |y|) '|construct|) - (PROGN (SPADLET |v| (QCDR |y|)) 'T) - (|markPathsEqual| (CONS '|construct| |u|) |y|)) - (CONS |y| NIL)) - ((AND (OR (AND (PAIRP |y|) (EQ (QCAR |y|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (AND (PAIRP |y|) (EQ (QCAR |y|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T))))))) - (GENSYMP |a|) (|markPathsEqual| |x| |b|)) - (CONS |y| NIL)) - ((AND (PAIRP |y|) (EQ (QCAR |y|) '|call|) - (PROGN (SPADLET |r| (QCDR |y|)) 'T)) - (COND ((|mkPaths| |x| |r|) (EXIT (CONS |y| NIL))))) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'PART) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y1| (QCAR |ISTMP#2|)) - 'T)))))) - (|mkPaths| |x| |y1|)) - ((AND (PAIRP |y|) - (PROGN - (SPADLET |fn| (QCAR |y|)) - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y1| (QCAR |ISTMP#2|)) - 'T))))) - (MEMQ |fn| '(CATCH THROW))) - (COND ((|mkPaths| |x| |y1|) (EXIT (CONS |y| NIL))))) - ((AND (PAIRP |y|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |y|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|elt|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |op| (QCAR |ISTMP#3|)) - 'T))))))) - (PROGN (SPADLET |r| (QCDR |y|)) 'T) - (SPADLET |u| (|mkPaths| |x| (CONS |op| |r|)))) - |u|) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) - (PROGN (SPADLET |r| (QCDR |x|)) 'T) - (SPADLET |u| (|mkPaths| |r| |y|))) - |u|) - ((AND (PAIRP |y|) (EQ (QCAR |y|) '|elt|) - (PROGN (SPADLET |r| (QCDR |y|)) 'T) - (SPADLET |u| (|mkPaths| |x| |r|))) - |u|) - ('T - (PROG (G170973) - (SPADLET G170973 NIL) - (RETURN - (DO ((G170979 |y| (CDR G170979)) (|z| NIL)) - ((OR (ATOM G170979) - (PROGN (SETQ |z| (CAR G170979)) NIL)) - G170973) - (SEQ (EXIT (COND - ((SPADLET |u| (|mkPaths| |x| |z|)) - (SETQ G170973 - (APPEND G170973 |u|))))))))))))))) - -;getLocationsOf(u,y,s) == [getLocOf(x,y,s) for x in u] - -(DEFUN |getLocationsOf| (|u| |y| |s|) - (PROG () - (RETURN - (SEQ (PROG (G171023) - (SPADLET G171023 NIL) - (RETURN - (DO ((G171028 |u| (CDR G171028)) (|x| NIL)) - ((OR (ATOM G171028) - (PROGN (SETQ |x| (CAR G171028)) NIL)) - (NREVERSE0 G171023)) - (SEQ (EXIT (SETQ G171023 - (CONS (|getLocOf| |x| |y| |s|) - G171023))))))))))) - -;getLocOf(x,y,s) == -; x = y or x is ['elt,:r] and r = y => s -; y is ['PART,.,y1] => getLocOf(x,y1,s) -; if y is ['elt,:r] then y := r -; atom y => nil -; or/[getLocOf(x,z,[i, :s]) for i in 0.. for z in y] - -(DEFUN |getLocOf| (|x| |y| |s|) - (PROG (|ISTMP#1| |ISTMP#2| |y1| |r|) - (RETURN - (SEQ (COND - ((OR (BOOT-EQUAL |x| |y|) - (AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) - (PROGN (SPADLET |r| (QCDR |x|)) 'T) - (BOOT-EQUAL |r| |y|))) - |s|) - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'PART) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y1| (QCAR |ISTMP#2|)) - 'T)))))) - (|getLocOf| |x| |y1| |s|)) - ('T - (COND - ((AND (PAIRP |y|) (EQ (QCAR |y|) '|elt|) - (PROGN (SPADLET |r| (QCDR |y|)) 'T)) - (SPADLET |y| |r|))) - (COND - ((ATOM |y|) NIL) - ('T - (PROG (G171049) - (SPADLET G171049 NIL) - (RETURN - (DO ((G171056 NIL G171049) - (|i| 0 (QSADD1 |i|)) - (G171057 |y| (CDR G171057)) (|z| NIL)) - ((OR G171056 (ATOM G171057) - (PROGN (SETQ |z| (CAR G171057)) NIL)) - G171049) - (SEQ (EXIT (SETQ G171049 - (OR G171049 - (|getLocOf| |x| |z| - (CONS |i| |s|))))))))))))))))) - -;--====================================================================== -;-- Combine Multiple Definitions Into One -;--====================================================================== -;combineDefinitions() == -;--$capsuleStack has form (def1 def2 ..) -;--$signatureStack has form (sig1 sig2 ..) where sigI = nil if not a def -;--$predicateStack has form (pred1 pred2 ..) -;--record in $hash: alist of form [[sig, [predl, :body],...],...] under each op -; $hash := MAKE_-HASH_-TABLE() -; for defs in $capsuleStack -; for sig in $signatureStack -; for predl in $predicateStack | sig repeat -;-- pp [defs, sig, predl] -; [["DEF",form,:.],:.] := defs -; item := [predl, :defs] -; op := opOf form -; oldAlist := HGET($hash,opOf form) -; pair := ASSOC(sig, oldAlist) => RPLACD(pair, [item,:CDR pair]) -; HPUT($hash, op, [[sig, item], :oldAlist]) -;--extract and combine multiple definitions -; Xdeflist := nil -; for op in HKEYS $hash repeat -; $acc: local := nil -; for [sig,:items] in HGET($hash,op) | (k := #items) > 1 repeat -; for i in 1.. for item in items repeat -; [predl,.,:def] := item -; ['DEF, form, :.] := def -; ops := PNAME op -; opName := INTERN(STRCONC(ops,'"X",STRINGIMAGE i)) -; RPLACA(form, opName) -;-- rplacaSubst(op, opName, def) -; $acc := [[form,:predl], :$acc] -; Xdeflist := [buildNewDefinition(op,sig,$acc),:Xdeflist] -; REVERSE Xdeflist - -(DEFUN |combineDefinitions| () - (PROG (|$acc| |item| |op| |oldAlist| |pair| |sig| |items| |k| |predl| - |def| |form| |ops| |opName| |Xdeflist|) - (DECLARE (SPECIAL |$acc| |$hash| |$predicateStack| |$signatureStack| - |$capsuleStack|)) - (RETURN - (SEQ (PROGN - (SPADLET |$hash| (MAKE-HASH-TABLE)) - (DO ((G171103 |$capsuleStack| (CDR G171103)) - (|defs| NIL) - (G171104 |$signatureStack| (CDR G171104)) - (|sig| NIL) - (G171105 |$predicateStack| (CDR G171105)) - (|predl| NIL)) - ((OR (ATOM G171103) - (PROGN (SETQ |defs| (CAR G171103)) NIL) - (ATOM G171104) - (PROGN (SETQ |sig| (CAR G171104)) NIL) - (ATOM G171105) - (PROGN (SETQ |predl| (CAR G171105)) NIL)) - NIL) - (SEQ (EXIT (COND - (|sig| (PROGN - (COND - ((EQ (CAAR |defs|) 'DEF) - (CAAR |defs|))) - (SPADLET |form| (CADAR |defs|)) - (SPADLET |item| - (CONS |predl| |defs|)) - (SPADLET |op| (|opOf| |form|)) - (SPADLET |oldAlist| - (HGET |$hash| (|opOf| |form|))) - (COND - ((SPADLET |pair| - (|assoc| |sig| |oldAlist|)) - (RPLACD |pair| - (CONS |item| (CDR |pair|)))) - ('T - (HPUT |$hash| |op| - (CONS - (CONS |sig| - (CONS |item| NIL)) - |oldAlist|)))))))))) - (SPADLET |Xdeflist| NIL) - (DO ((G171134 (HKEYS |$hash|) (CDR G171134)) - (|op| NIL)) - ((OR (ATOM G171134) - (PROGN (SETQ |op| (CAR G171134)) NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |$acc| NIL) - (DO ((G171154 (HGET |$hash| |op|) - (CDR G171154)) - (G171085 NIL)) - ((OR (ATOM G171154) - (PROGN - (SETQ G171085 (CAR G171154)) - NIL) - (PROGN - (PROGN - (SPADLET |sig| - (CAR G171085)) - (SPADLET |items| - (CDR G171085)) - G171085) - NIL)) - NIL) - (SEQ (EXIT - (COND - ((> (SPADLET |k| (|#| |items|)) - 1) - (PROGN - (DO - ((|i| 1 (QSADD1 |i|)) - (G171172 |items| - (CDR G171172)) - (|item| NIL)) - ((OR (ATOM G171172) - (PROGN - (SETQ |item| - (CAR G171172)) - NIL)) - NIL) - (SEQ - (EXIT - (PROGN - (SPADLET |predl| - (CAR |item|)) - (SPADLET |def| - (CDDR |item|)) - (SPADLET |form| - (CADR |def|)) - (SPADLET |ops| - (PNAME |op|)) - (SPADLET |opName| - (INTERN - (STRCONC |ops| - "X" - (STRINGIMAGE |i|)))) - (RPLACA |form| |opName|) - (SPADLET |$acc| - (CONS - (CONS |form| |predl|) - |$acc|)))))) - (SPADLET |Xdeflist| - (CONS - (|buildNewDefinition| |op| - |sig| |$acc|) - |Xdeflist|)))))))))))) - (REVERSE |Xdeflist|)))))) - -;rplacaSubst(x, y, u) == (fn(x, y, u); u) where fn(x,y,u) == -; atom u => nil -; while u is [p, :q] repeat -; if EQ(p, x) then RPLACA(u, y) -; if null atom p then fn(x, y, p) -; u := q - -(DEFUN |rplacaSubst,fn| (|x| |y| |u|) - (PROG (|p| |q|) - (RETURN - (SEQ (IF (ATOM |u|) (EXIT NIL)) - (EXIT (DO () - ((NULL (AND (PAIRP |u|) - (PROGN - (SPADLET |p| (QCAR |u|)) - (SPADLET |q| (QCDR |u|)) - 'T))) - NIL) - (SEQ (IF (EQ |p| |x|) (RPLACA |u| |y|) NIL) - (IF (NULL (ATOM |p|)) - (|rplacaSubst,fn| |x| |y| |p|) NIL) - (EXIT (SPADLET |u| |q|))))))))) - - -(DEFUN |rplacaSubst| (|x| |y| |u|) - (PROGN (|rplacaSubst,fn| |x| |y| |u|) |u|)) - -;buildNewDefinition(op,theSig,formPredAlist) == -; newAlist := [fn for item in formPredAlist] where fn == -; [form,:predl] := item -; pred := -; null predl => 'T -; boolBin simpHasPred markKillAll MKPF(predl,"and") -; [pred, :form] -; --make sure that T comes as last predicate -; outerPred := boolBin simpHasPred MKPF(ASSOCLEFT newAlist,"or") -; theForm := CDAR newAlist -; alist := moveTruePred2End newAlist -; theArgl := CDR theForm -; theAlist := [[pred, CAR form, :theArgl] for [pred,:form] in alist] -; theNils := [nil for x in theForm] -; thePred := -; MEMBER(outerPred, '(T (QUOTE T))) => nil -; outerPred -; def := ['DEF, theForm, theSig, theNils, ifize theAlist] -; value := -; thePred => ['IF, thePred, def, 'noBranch] -; def -; stop value -; value - -(DEFUN |buildNewDefinition| (|op| |theSig| |formPredAlist|) - (declare (ignore |op|)) - (PROG (|predl| |newAlist| |outerPred| |theForm| |alist| |theArgl| - |pred| |form| |theAlist| |theNils| |thePred| |def| - |value|) - (RETURN - (SEQ (PROGN - (SPADLET |newAlist| - (PROG (G171247) - (SPADLET G171247 NIL) - (RETURN - (DO ((G171256 |formPredAlist| - (CDR G171256)) - (|item| NIL)) - ((OR (ATOM G171256) - (PROGN - (SETQ |item| (CAR G171256)) - NIL)) - (NREVERSE0 G171247)) - (SEQ (EXIT (SETQ G171247 - (CONS - (PROGN - (SPADLET |form| - (CAR |item|)) - (SPADLET |predl| - (CDR |item|)) - (SPADLET |pred| - (COND - ((NULL |predl|) 'T) - ('T - (|boolBin| - (|simpHasPred| - (|markKillAll| - (MKPF |predl| '|and|))))))) - (CONS |pred| |form|)) - G171247)))))))) - (SPADLET |outerPred| - (|boolBin| - (|simpHasPred| - (MKPF (ASSOCLEFT |newAlist|) '|or|)))) - (SPADLET |theForm| (CDAR |newAlist|)) - (SPADLET |alist| (|moveTruePred2End| |newAlist|)) - (SPADLET |theArgl| (CDR |theForm|)) - (SPADLET |theAlist| - (PROG (G171267) - (SPADLET G171267 NIL) - (RETURN - (DO ((G171273 |alist| (CDR G171273)) - (G171232 NIL)) - ((OR (ATOM G171273) - (PROGN - (SETQ G171232 (CAR G171273)) - NIL) - (PROGN - (PROGN - (SPADLET |pred| (CAR G171232)) - (SPADLET |form| (CDR G171232)) - G171232) - NIL)) - (NREVERSE0 G171267)) - (SEQ (EXIT (SETQ G171267 - (CONS - (CONS |pred| - (CONS (CAR |form|) |theArgl|)) - G171267)))))))) - (SPADLET |theNils| - (PROG (G171284) - (SPADLET G171284 NIL) - (RETURN - (DO ((G171289 |theForm| (CDR G171289)) - (|x| NIL)) - ((OR (ATOM G171289) - (PROGN - (SETQ |x| (CAR G171289)) - NIL)) - (NREVERSE0 G171284)) - (SEQ (EXIT (SETQ G171284 - (CONS NIL G171284)))))))) - (SPADLET |thePred| - (COND - ((|member| |outerPred| '(T 'T)) NIL) - ('T |outerPred|))) - (SPADLET |def| - (CONS 'DEF - (CONS |theForm| - (CONS |theSig| - (CONS |theNils| - (CONS (|ifize| |theAlist|) - NIL)))))) - (SPADLET |value| - (COND - (|thePred| - (CONS 'IF - (CONS |thePred| - (CONS |def| - (CONS '|noBranch| NIL))))) - ('T |def|))) - (|stop| |value|) - |value|))))) - -;boolBin x == -; x is [op,:argl] => -; MEMQ(op,'(AND OR)) and argl is [a, b, :c] and c => boolBin [op, boolBin [op, a, b], :c] -; [boolBin y for y in x] -; x - -(DEFUN |boolBin| (|x|) - (PROG (|op| |argl| |a| |ISTMP#1| |b| |c|) - (RETURN - (SEQ (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |argl| (QCDR |x|)) - 'T)) - (COND - ((AND (MEMQ |op| '(AND OR)) (PAIRP |argl|) - (PROGN - (SPADLET |a| (QCAR |argl|)) - (SPADLET |ISTMP#1| (QCDR |argl|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |c| (QCDR |ISTMP#1|)) - 'T))) - |c|) - (|boolBin| - (CONS |op| - (CONS (|boolBin| - (CONS |op| - (CONS |a| (CONS |b| NIL)))) - |c|)))) - ('T - (PROG (G171339) - (SPADLET G171339 NIL) - (RETURN - (DO ((G171344 |x| (CDR G171344)) (|y| NIL)) - ((OR (ATOM G171344) - (PROGN (SETQ |y| (CAR G171344)) NIL)) - (NREVERSE0 G171339)) - (SEQ (EXIT (SETQ G171339 - (CONS (|boolBin| |y|) - G171339)))))))))) - ('T |x|)))))) - -;ifize [[pred,:value],:r] == -; null r => value -; ['IF, pred, value, ifize r] - -(DEFUN |ifize| (G171361) - (PROG (|pred| |value| |r|) - (RETURN - (PROGN - (SPADLET |pred| (CAAR G171361)) - (SPADLET |value| (CDAR G171361)) - (SPADLET |r| (CDR G171361)) - (COND - ((NULL |r|) |value|) - ('T - (CONS 'IF - (CONS |pred| (CONS |value| (CONS (|ifize| |r|) NIL)))))))))) - -;moveTruePred2End alist == -; truthPair := or/[pair for pair in alist | pair is ["T",:.]] => -; [:DELETE(truthPair, alist), truthPair] -; [:a, [lastPair, lastValue]] := alist -; [:a, ["T", lastValue]] - -(DEFUN |moveTruePred2End| (|alist|) - (PROG (|truthPair| |LETTMP#1| |lastPair| |lastValue| |a|) - (RETURN - (SEQ (COND - ((SPADLET |truthPair| - (PROG (G171384) - (SPADLET G171384 NIL) - (RETURN - (DO ((G171391 NIL G171384) - (G171392 |alist| (CDR G171392)) - (|pair| NIL)) - ((OR G171391 (ATOM G171392) - (PROGN - (SETQ |pair| (CAR G171392)) - NIL)) - G171384) - (SEQ (EXIT (COND - ((AND (PAIRP |pair|) - (EQ (QCAR |pair|) 'T)) - (SETQ G171384 - (OR G171384 |pair|)))))))))) - (APPEND (|delete| |truthPair| |alist|) - (CONS |truthPair| NIL))) - ('T (SPADLET |LETTMP#1| (REVERSE |alist|)) - (SPADLET |lastPair| (CAAR |LETTMP#1|)) - (SPADLET |lastValue| (CADAR |LETTMP#1|)) - (SPADLET |a| (NREVERSE (CDR |LETTMP#1|))) - (APPEND |a| (CONS (CONS 'T (CONS |lastValue| NIL)) NIL)))))))) - -;PE e == -; for x in CAAR e for i in 1.. repeat -; ppf [i, :x] - -(DEFUN PE (|e|) - (SEQ (DO ((G171412 (CAAR |e|) (CDR G171412)) (|x| NIL) - (|i| 1 (QSADD1 |i|))) - ((OR (ATOM G171412) - (PROGN (SETQ |x| (CAR G171412)) NIL)) - NIL) - (SEQ (EXIT (|ppf| (CONS |i| |x|))))))) - -;ppf x == -; _*PRETTYPRINT_* : local := true -; PRINT_-FULL x - -(DEFUN |ppf| (|x|) - (PROG (*PRETTYPRINT*) - (declare (special *prettyprint*)) - (RETURN (PROGN (SPADLET *PRETTYPRINT* 'T) (PRINT-FULL |x|))))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nspadaux.lisp.pamphlet b/src/interp/nspadaux.lisp.pamphlet deleted file mode 100644 index 1b27222..0000000 --- a/src/interp/nspadaux.lisp.pamphlet +++ /dev/null @@ -1,139 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp nspadaux.lisp} -\author{Timothy Daly} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= -;; Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -;; All rights reserved. -;; -;; Redistribution and use in source and binary forms, with or without -;; modification, are permitted provided that the following conditions are -;; met: -;; -;; - Redistributions of source code must retain the above copyright -;; notice, this list of conditions and the following disclaimer. -;; -;; - Redistributions in binary form must reproduce the above copyright -;; notice, this list of conditions and the following disclaimer in -;; the documentation and/or other materials provided with the -;; distribution. -;; -;; - Neither the name of The Numerical ALgorithms Group Ltd. nor the -;; names of its contributors may be used to endorse or promote products -;; derived from this software without specific prior written permission. -;; -;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -;; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -;; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A -;; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER -;; OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, -;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR -;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF -;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING -;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS -;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -(in-package "BOOT") - -(defvar |$DEFdepth| 0) -(defvar |$localMacroStack| nil) -(defvar |$globalMacroStack| nil) -(defvar |$abbreviationStack| nil) -(defvar |$knownAttributes| nil "cumulative list of known attributes of a file") - -(setq |$underscoreChar| (|char| '_)) -(defvar |$back| nil) - -(setq |$markChoices| '(ATOM COLON LAMBDA AUTOSUBSET AUTOHARD AUTOREP REPPER FREESI RETRACT)) -(setq |$convert2NewCompiler| 'T) -(setq |$AnalyzeOnly| NIL) -(setq |$categoryPart| 'T) -(setq |$insideCAPSULE| nil) -(setq |$insideEXPORTS| nil) -(setq |$originalSignature| nil) -(setq |$insideDEF| nil) -(setq |$insideTypeExpression| nil) -(setq |$spadTightList| '(\.\. \# \' \:\ \: \:\:)) - -(setq |$PerCentVariableList| '(%1 %2 %3 %4 %5 %6 %7 %8 %9 %10)) -(makeprop '_^ '|parseTran| '|parseNot|) - -(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'SPECIAL (CADR X))) - '((PART |compPART|) - (WI |compWI|) - (MI |compWI|))) - -(mapcar #'(lambda (X) (MAKEPROP (CAR X) 'PSPAD (CADR X))) - '((|default| |formatDefault|) - (|local| |formatLocal|) - (COMMENT |formatCOMMENT|) - (CAPSULE |formatCAPSULE|) - (LISTOF |formatPAREN|) - (DEF |formatDEF|) - (SEQ |formatSEQ|) - (LET |formatLET|) - (\: |formatColon|) - (ELT |formatELT|) - (QUOTE |formatQUOTE|) - (SEGMENT |formatSEGMENT|) - (DOLLAR |formatDOLLAR|) - (BRACE |formatBrace|) - (|dot| |formatDot|) - (MDEF |formatMDEF|) - (|free| |formatFree|) - (|elt| |formatElt|) - (PAREN |formatPAREN|) - (PROGN |formatPROGN|) - (|exit| |formatExit|) - (|leave| |formatLeave|) - (|void| |formatvoid|) - (MI |formatMI|) - (IF |formatIF|) - (\=\> |formatFATARROW|) - (\+\-\> |formatMap|) - (|Enumeration| |formatEnumeration|) - (|import| |formatImport|) - (UNCOERCE |formatUNCOERCE|) - (CATEGORY |formatCATEGORY|) - (SIGNATURE |formatSIGNATURE|) - (|where| |formatWHERE|) - (COLLECT |formatCOLLECT|) - (|MyENUM| |formatENUM|) - (REDUCE |formatREDUCE|) - (REPEAT |formatREPEAT|) - (ATTRIBUTE |formatATTRIBUTE|) - (CONS |formatCONS|) - (|construct| |formatConstruct|) - (|Union| |formatUnion|) - (|Record| |formatRecord|) - (|Mapping| |formatMapping|) - (|Tuple| |formatTuple|) - (|with| |formatWith|) - (|withDefault| |formatWithDefault|) - (|defaultDefs| |formatDefaultDefs|) - (|add| |formatAdd|))) - -(remprop 'cons '|Led|) -(remprop 'append 'format) -(remprop 'cons 'format) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pspad1.lisp.pamphlet b/src/interp/pspad1.lisp.pamphlet deleted file mode 100644 index e16f62b..0000000 --- a/src/interp/pspad1.lisp.pamphlet +++ /dev/null @@ -1,2614 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pspad1.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<<*>>= - -(IN-PACKAGE "BOOT" ) - -;$escapeWords := ["always", "assert", "but", "define", -; "delay", "do", "except", "export", "extend", "fix", "fluid", -; "from", "generate", "goto", "import", "inline", "never", "select", -; "try", "yield"] - -(SPADLET |$escapeWords| - (CONS '|always| - (CONS '|assert| - (CONS '|but| - (CONS '|define| - (CONS '|delay| - (CONS '|do| - (CONS '|except| - (CONS '|export| - (CONS '|extend| - (CONS '|fix| - (CONS '|fluid| - (CONS '|from| - (CONS '|generate| - (CONS '|goto| - (CONS '|import| - (CONS '|inline| - (CONS '|never| - (CONS '|select| - (CONS '|try| - (CONS '|yield| - NIL))))))))))))))))))))) - -;$pileStyle := false - -(SPADLET |$pileStyle| NIL) - -;$commentIndentation := 8 - -(SPADLET |$commentIndentation| 8) - -;$braceIndentation := 8 - -(SPADLET |$braceIndentation| 8) - -;$doNotResetMarginIfTrue := true - -(SPADLET |$doNotResetMarginIfTrue| t) - -;$marginStack := nil - -(SPADLET |$marginStack| NIL) - -;$numberOfSpills := 0 - -(SPADLET |$numberOfSpills| 0) - -;$lineFragmentBuffer:= nil - -(SPADLET |$lineFragmentBuffer| NIL) - -;$pspadRelationAlist := '((_= . _~_=) (_< . _>_=) (_<_= . _>)(_~_= . _=)(_>_= . _<) (_> . _<_=)) - -(SPADLET |$pspadRelationAlist| - '((= . ~=) (< . >=) (<= . >) (~= . =) (>= . <) (> . <=))) - -;$lineBuffer := nil - -(SPADLET |$lineBuffer| NIL) - -;$formatForcePren := nil - -(SPADLET |$formatForcePren| NIL) - -;$underScore := char ('__) - -(SPADLET |$underScore| (|char| '_)) - -;$rightBraceFlag := nil - -(SPADLET |$rightBraceFlag| NIL) - -;$semicolonFlag := nil - -(SPADLET |$semicolonFlag| NIL) - -;$newLineWritten := nil - -(SPADLET |$newLineWritten| NIL) - -;$comments := nil - -(SPADLET |$comments| NIL) - -;$noColonDeclaration := false - -(SPADLET |$noColonDeclaration| NIL) - -;$renameAlist := '( -; (SmallInteger . SingleInteger) -; (SmallFloat . DoubleFloat) -; (Void . _(_)) -; (xquo . exquo) -; (setelt . set_!) -; (_$ . _%) -; (_$_$ . _$) -; (_*_* . _^) -; (_^_= . _~_=) -; (_^ . _~)) - -(SPADLET |$renameAlist| - '((|SmallInteger| . |SingleInteger|) - (|SmallFloat| . |DoubleFloat|) (|Void| . |()|) - (|xquo| . |exquo|) (|setelt| . |set!|) ($ . %) ($$ . $) - (** . ^) (^= . ~=) (^ . ~))) - -;--$opRenameAlist := '( -;-- (and . AND) -;-- (or . OR) -;-- (not . NOT)) -;--====================================================================== -;-- Main Translator Function -;--====================================================================== -;--% lisp-fragment to boot-fragment functions -;lisp2Boot x == -; --entry function -; $fieldNames := nil -; $eltIfNil: local --changes NEW META to generate ELTs for infix dot -; $pilesAreOkHere: local:= true -; $commentsToPrint: local:= nil -; $lineBuffer: local := nil -; $braceStack: local := nil -; $marginStack: local:= [0] -; --$autoLine is true except when inside a try---if true, lines are allowed to break -; $autoLine:= true -; $lineFragmentBuffer:= nil -; $bc:=0 --brace count -; $m:= 0 -; $c:= $m -; $numberOfSpills:= 0 -; $lineLength:= 80 -; format x -; formatOutput REVERSE $lineFragmentBuffer -; [fragmentsToLine y for y in REVERSE $lineBuffer] - -(DEFUN |lisp2Boot| (|x|) - (PROG (|$eltIfNil| |$pilesAreOkHere| |$commentsToPrint| |$lineBuffer| - |$braceStack| |$marginStack|) - (DECLARE (SPECIAL |$eltIfNil| |$pilesAreOkHere| |$commentsToPrint| |$bc| - |$lineBuffer| |$braceStack| |$marginStack| |$m| |$c| - |$lineFragmentBuffer| |$lineLength| |$autoLine| - |$fieldNames| |$numberOfSpills|)) - (RETURN - (SEQ (PROGN - (SPADLET |$fieldNames| NIL) - (SPADLET |$eltIfNil| NIL) - (SPADLET |$pilesAreOkHere| 'T) - (SPADLET |$commentsToPrint| NIL) - (SPADLET |$lineBuffer| NIL) - (SPADLET |$braceStack| NIL) - (SPADLET |$marginStack| (CONS 0 NIL)) - (SPADLET |$autoLine| 'T) - (SPADLET |$lineFragmentBuffer| NIL) - (SPADLET |$bc| 0) - (SPADLET |$m| 0) - (SPADLET |$c| |$m|) - (SPADLET |$numberOfSpills| 0) - (SPADLET |$lineLength| 80) - (|format| |x|) - (|formatOutput| (REVERSE |$lineFragmentBuffer|)) - (PROG (G166062) - (SPADLET G166062 NIL) - (RETURN - (DO ((G166067 (REVERSE |$lineBuffer|) - (CDR G166067)) - (|y| NIL)) - ((OR (ATOM G166067) - (PROGN (SETQ |y| (CAR G166067)) NIL)) - (NREVERSE0 G166062)) - (SEQ (EXIT (SETQ G166062 - (CONS (|fragmentsToLine| |y|) - G166062)))))))))))) - -;fragmentsToLine fragments == -; string:= lispStringList2String fragments -; line:= GETSTR 240 -; for i in 0..MAXINDEX string repeat line:= SUFFIX(string.i,line) -; line - -(DEFUN |fragmentsToLine| (|fragments|) - (PROG (|string| |line|) - (RETURN - (SEQ (PROGN - (SPADLET |string| (|lispStringList2String| |fragments|)) - (SPADLET |line| (GETSTR 240)) - (DO ((G166107 (MAXINDEX |string|)) (|i| 0 (QSADD1 |i|))) - ((QSGREATERP |i| G166107) NIL) - (SEQ (EXIT (SPADLET |line| - (SUFFIX (ELT |string| |i|) |line|))))) - |line|))))) - -;lispStringList2String x == -; null x => '"" -; atom x => STRINGIMAGE x -; CDR x => APPLY(function STRCONC,MAPCAR(function lispStringList2String,x)) -; lispStringList2String CAR x - -(DEFUN |lispStringList2String| (|x|) - (COND - ((NULL |x|) "") - ((ATOM |x|) (STRINGIMAGE |x|)) - ((CDR |x|) - (APPLY (|function| STRCONC) - (MAPCAR (|function| |lispStringList2String|) |x|))) - ('T (|lispStringList2String| (CAR |x|))))) - -;--% routines for buffer and margin adjustment -; -;formatOutput x == -; for [currentColumn,start,end,stack] in REVERSE $commentsToPrint repeat -; startY:= rest start -; for [loc,comment] in stack repeat -; commentY:= rest loc -; gap:= startY-commentY -; gap>0 => before:= [[commentY,first loc,gap,comment],:before] -; gap=0 => same:= [[startY,1,gap,comment],:same] -; true => after:= [[startY,first loc,-gap,comment],:after] -; if before then putOut before -; if same then -; [y,:extraLines]:= "append"/[mkCommentLines u for u in orderList same] -; line:= fragmentsToLine x -; x:= -; #line+#y>$lineLength => -; (y:= STRCONC(nBlanks $m,y); extraLines:= [y,:extraLines]; x) -; [line,y] -; consLineBuffer x -; for y in extraLines repeat consLineBuffer LIST y -; if after then putOut after -; $commentsToPrint:= nil - -(DEFUN |formatOutput| (|x|) - (PROG (|currentColumn| |start| |end| |stack| |startY| |loc| |comment| - |commentY| |gap| |before| |same| |after| |LETTMP#1| |line| - |y| |extraLines|) - (declare (special |$commentsToPrint| |$m| |$lineLength|)) - (RETURN - (SEQ (PROGN - (DO ((G166156 (REVERSE |$commentsToPrint|) - (CDR G166156)) - (G166127 NIL)) - ((OR (ATOM G166156) - (PROGN (SETQ G166127 (CAR G166156)) NIL) - (PROGN - (PROGN - (SPADLET |currentColumn| (CAR G166127)) - (SPADLET |start| (CADR G166127)) - (SPADLET |end| (CADDR G166127)) - (SPADLET |stack| (CADDDR G166127)) - G166127) - NIL)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |startY| (CDR |start|)) - (DO ((G166170 |stack| (CDR G166170)) - (G166122 NIL)) - ((OR (ATOM G166170) - (PROGN - (SETQ G166122 (CAR G166170)) - NIL) - (PROGN - (PROGN - (SPADLET |loc| - (CAR G166122)) - (SPADLET |comment| - (CADR G166122)) - G166122) - NIL)) - NIL) - (SEQ (EXIT - (PROGN - (SPADLET |commentY| (CDR |loc|)) - (SPADLET |gap| - (SPADDIFFERENCE |startY| - |commentY|)) - (COND - ((> |gap| 0) - (SPADLET |before| - (CONS - (CONS |commentY| - (CONS (CAR |loc|) - (CONS |gap| - (CONS |comment| NIL)))) - |before|))) - ((EQL |gap| 0) - (SPADLET |same| - (CONS - (CONS |startY| - (CONS 1 - (CONS |gap| - (CONS |comment| NIL)))) - |same|))) - ('T - (SPADLET |after| - (CONS - (CONS |startY| - (CONS (CAR |loc|) - (CONS - (SPADDIFFERENCE |gap|) - (CONS |comment| NIL)))) - |after|)))))))))))) - (COND (|before| (|putOut| |before|))) - (COND - (|same| (SPADLET |LETTMP#1| - (PROG (G166177) - (SPADLET G166177 NIL) - (RETURN - (DO - ((G166182 (|orderList| |same|) - (CDR G166182)) - (|u| NIL)) - ((OR (ATOM G166182) - (PROGN - (SETQ |u| (CAR G166182)) - NIL)) - G166177) - (SEQ - (EXIT - (SETQ G166177 - (APPEND G166177 - (|mkCommentLines| |u|))))))))) - (SPADLET |y| (CAR |LETTMP#1|)) - (SPADLET |extraLines| (CDR |LETTMP#1|)) - (SPADLET |line| (|fragmentsToLine| |x|)) - (SPADLET |x| - (COND - ((> (PLUS (|#| |line|) (|#| |y|)) - |$lineLength|) - (SPADLET |y| - (STRCONC (|nBlanks| |$m|) |y|)) - (SPADLET |extraLines| - (CONS |y| |extraLines|)) - |x|) - ('T (CONS |line| (CONS |y| NIL))))))) - (|consLineBuffer| |x|) - (DO ((G166191 |extraLines| (CDR G166191)) (|y| NIL)) - ((OR (ATOM G166191) - (PROGN (SETQ |y| (CAR G166191)) NIL)) - NIL) - (SEQ (EXIT (|consLineBuffer| (LIST |y|))))) - (COND (|after| (|putOut| |after|))) - (SPADLET |$commentsToPrint| NIL)))))) - -;consLineBuffer x == $lineBuffer := [x,:$lineBuffer] - -(DEFUN |consLineBuffer| (|x|) - (declare (special |$lineBuffer|)) - (SPADLET |$lineBuffer| (CONS |x| |$lineBuffer|))) - -;putOut x == -; eject ("min"/[gap for [.,.,gap,:.] in x]) -; for u in orderList x repeat addComment u - -(DEFUN |putOut| (|x|) - (PROG (|gap|) - (RETURN - (SEQ (PROGN - (|eject| (PROG (G166229 G166230) - (SPADLET G166229 'G166229) - (RETURN - (DO ((G166238 |x| (CDR G166238)) - (G166225 NIL)) - ((OR (ATOM G166238) - (PROGN - (SETQ G166225 (CAR G166238)) - NIL) - (PROGN - (PROGN - (SPADLET |gap| - (CADDR G166225)) - G166225) - NIL)) - (THETACHECK G166229 'G166229 '|min|)) - (SEQ (EXIT (PROGN - (SPADLET G166230 |gap|) - (SETQ G166229 - (COND - ((EQ G166229 'G166229) - G166230) - ('T - (|min| G166229 - G166230))))))))))) - (DO ((G166248 (|orderList| |x|) (CDR G166248)) - (|u| NIL)) - ((OR (ATOM G166248) - (PROGN (SETQ |u| (CAR G166248)) NIL)) - NIL) - (SEQ (EXIT (|addComment| |u|))))))))) - -;eject n == for i in 2..n repeat consLineBuffer nil - -(DEFUN |eject| (|n|) - (SEQ (DO ((|i| 2 (QSADD1 |i|))) ((QSGREATERP |i| |n|) NIL) - (SEQ (EXIT (|consLineBuffer| NIL)))))) - -;addComment u == -; for x in mkCommentLines u repeat consLineBuffer LIST x - -(DEFUN |addComment| (|u|) - (SEQ (DO ((G166272 (|mkCommentLines| |u|) (CDR G166272)) - (|x| NIL)) - ((OR (ATOM G166272) - (PROGN (SETQ |x| (CAR G166272)) NIL)) - NIL) - (SEQ (EXIT (|consLineBuffer| (LIST |x|))))))) - -;mkCommentLines [.,n,.,s] == -; lines:= breakComments s -; lines1:= [fragmentsToLine [nBlanks n,"_{",first lines],:rest lines] -; [:l,last]:= lines1 -; [:l,fragmentsToLine [last,"_}"]] - -(DEFUN |mkCommentLines| (G166286) - (PROG (|n| |s| |lines| |lines1| |LETTMP#1| |last| |l|) - (RETURN - (PROGN - (SPADLET |n| (CADR G166286)) - (SPADLET |s| (CADDDR G166286)) - (SPADLET |lines| (|breakComments| |s|)) - (SPADLET |lines1| - (CONS (|fragmentsToLine| - (CONS (|nBlanks| |n|) - (CONS '{ (CONS (CAR |lines|) NIL)))) - (CDR |lines|))) - (SPADLET |LETTMP#1| (REVERSE |lines1|)) - (SPADLET |last| (CAR |LETTMP#1|)) - (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) - (APPEND |l| - (CONS (|fragmentsToLine| (CONS |last| (CONS '} NIL))) - NIL)))))) - -;breakComments s == -; n:= containsString(s,PNAME "ENDOFLINECHR") => -; #s>n+12 => [SUBSTRING(s,0,n),:breakComments SUBSTRING(s,n+12,NIL)] -; LIST SUBSTRING(s,0,n) -; LIST s - -(DEFUN |breakComments| (|s|) - (PROG (|n|) - (RETURN - (COND - ((SPADLET |n| (|containsString| |s| (PNAME 'ENDOFLINECHR))) - (COND - ((> (|#| |s|) (PLUS |n| 12)) - (CONS (SUBSTRING |s| 0 |n|) - (|breakComments| (SUBSTRING |s| (PLUS |n| 12) NIL)))) - ('T (LIST (SUBSTRING |s| 0 |n|))))) - ('T (LIST |s|)))))) - -;containsString(x,y) == -; --if string x contains string y, return start index -; for i in 0..MAXINDEX x-MAXINDEX y repeat -; and/[x.(i+j)=y.j for j in 0..MAXINDEX y] => return i - -(DEFUN |containsString| (|x| |y|) - (PROG () - (RETURN - (SEQ (DO ((G166318 - (SPADDIFFERENCE (MAXINDEX |x|) (MAXINDEX |y|))) - (|i| 0 (QSADD1 |i|))) - ((QSGREATERP |i| G166318) NIL) - (SEQ (EXIT (COND - ((PROG (G166322) - (SPADLET G166322 'T) - (RETURN - (DO ((G166328 NIL (NULL G166322)) - (G166329 (MAXINDEX |y|)) - (|j| 0 (QSADD1 |j|))) - ((OR G166328 - (QSGREATERP |j| G166329)) - G166322) - (SEQ (EXIT - (SETQ G166322 - (AND G166322 - (BOOT-EQUAL - (ELT |x| (PLUS |i| |j|)) - (ELT |y| |j|))))))))) - (EXIT (RETURN |i|))))))))))) - -;--====================================================================== -;-- Character/String Buffer Functions -;--====================================================================== -;consBuffer item == -; if item = '"failed" then item := 'failed -; n:= -; STRINGP item => 2+#item -; IDENTP item => #PNAME item -; #STRINGIMAGE item -; columnsLeft:= $lineLength-$c -; if columnsLeft <= 0 and isCloseDelimiter item then $lineLength := $lineLength + 2 -; columnsLeft:= $lineLength-$c -; --cheat for semicolons, strings, and delimiters: they are NEVER too long -; not isSpecialBufferItem item and (n>columnsLeft or columnsLeft < 0) => -; $autoLine => -; --is true except within try -; formatOutput REVERSE $lineFragmentBuffer -; $c:= REMAINDER($m+2*($numberOfSpills:= $numberOfSpills+1), $lineLength) -; $lineFragmentBuffer:= LIST nBlanks $c -; consBuffer item -; nil -; $lineFragmentBuffer:= -; ^item or IDENTP item => [PNAME item,:$lineFragmentBuffer] -; NUMBERP item or CHARP item => [STRINGIMAGE item,:$lineFragmentBuffer] -; STRINGP item => ["_"",string2PrintImage item,"_"",:$lineFragmentBuffer] -; sayBrightly ['"Unexpected line buffer item: ", STRINGIMAGE item] -; $lineFragmentBuffer -; $rightBraceFlag := item = "}" -; $semicolonFlag := item = "; " --prevents consecutive semicolons -; $c:= $c+n - -(DEFUN |consBuffer| (|item|) - (PROG (|n| |columnsLeft|) - (declare (special |$c| |$semicolonFlag| |$rightBraceFlag| |$m| |$autoLine| - |$lineFragmentBuffer| |$lineLength| |$numberOfSpills|)) - (RETURN - (PROGN - (COND - ((BOOT-EQUAL |item| "failed") - (SPADLET |item| '|failed|))) - (SPADLET |n| - (COND - ((STRINGP |item|) (PLUS 2 (|#| |item|))) - ((IDENTP |item|) (|#| (PNAME |item|))) - ('T (|#| (STRINGIMAGE |item|))))) - (SPADLET |columnsLeft| (SPADDIFFERENCE |$lineLength| |$c|)) - (COND - ((AND (<= |columnsLeft| 0) (|isCloseDelimiter| |item|)) - (SPADLET |$lineLength| (PLUS |$lineLength| 2)))) - (SPADLET |columnsLeft| (SPADDIFFERENCE |$lineLength| |$c|)) - (COND - ((AND (NULL (|isSpecialBufferItem| |item|)) - (OR (> |n| |columnsLeft|) (MINUSP |columnsLeft|))) - (COND - (|$autoLine| - (|formatOutput| (REVERSE |$lineFragmentBuffer|)) - (SPADLET |$c| - (REMAINDER - (PLUS |$m| - (TIMES 2 - (SPADLET |$numberOfSpills| - (PLUS |$numberOfSpills| 1)))) - |$lineLength|)) - (SPADLET |$lineFragmentBuffer| - (LIST (|nBlanks| |$c|))) - (|consBuffer| |item|)) - ('T NIL))) - ('T - (SPADLET |$lineFragmentBuffer| - (COND - ((OR (NULL |item|) (IDENTP |item|)) - (CONS (PNAME |item|) |$lineFragmentBuffer|)) - ((OR (NUMBERP |item|) (CHARP |item|)) - (CONS (STRINGIMAGE |item|) - |$lineFragmentBuffer|)) - ((STRINGP |item|) - (CONS '|"| - (CONS (|string2PrintImage| |item|) - (CONS '|"| |$lineFragmentBuffer|)))) - ('T - (|sayBrightly| - (CONS "Unexpected line buffer item: " - (CONS (STRINGIMAGE |item|) NIL))) - |$lineFragmentBuffer|))) - (SPADLET |$rightBraceFlag| (BOOT-EQUAL |item| '})) - (SPADLET |$semicolonFlag| (BOOT-EQUAL |item| '|; |)) - (SPADLET |$c| (PLUS |$c| |n|)))))))) - -;isSpecialBufferItem item == -; item = "; " or STRINGP item => true -; false - -(DEFUN |isSpecialBufferItem| (|item|) - (COND ((OR (BOOT-EQUAL |item| '|; |) (STRINGP |item|)) 'T) ('T NIL))) - -;isCloseDelimiter item == EQ(item,")") or EQ(item,"]") or EQ(item,"}") - -(DEFUN |isCloseDelimiter| (|item|) - (OR (EQ |item| '|)|) (EQ |item| ']) (EQ |item| '}))) - -;--====================================================================== -;-- Formatting/Line Control Functions -;--====================================================================== -;newLine() == -; null $autoLine => nil -; $newLineWritten := true -; formatOutput REVERSE $lineFragmentBuffer -; $lineFragmentBuffer:= LIST nBlanks $m -; $c:= $m - -(DEFUN |newLine| () - (declare (special |$c| |$m| |$lineFragmentBuffer| |$newLineWritten| - |$autoLine|)) - (COND - ((NULL |$autoLine|) NIL) - ('T (SPADLET |$newLineWritten| 'T) - (|formatOutput| (REVERSE |$lineFragmentBuffer|)) - (SPADLET |$lineFragmentBuffer| (LIST (|nBlanks| |$m|))) - (SPADLET |$c| |$m|)))) - -;optNewLine() == -; $newLineWritten => newLine() -; $c - -(DEFUN |optNewLine| () - (declare (special |$newLineWritten| |$c|)) - (COND (|$newLineWritten| (|newLine|)) ('T |$c|))) - -;spillLine() == -; null $autoLine => nil -; formatOutput REVERSE $lineFragmentBuffer -; $c:= $m+2*($numberOfSpills:= $numberOfSpills+1) -; $lineFragmentBuffer:= LIST nBlanks $c -; $c - -(DEFUN |spillLine| () - (declare (special |$c| |$lineFragmentBuffer| |$numberOfSpills| |$m| - |$autoLine|)) - (COND - ((NULL |$autoLine|) NIL) - ('T (|formatOutput| (REVERSE |$lineFragmentBuffer|)) - (SPADLET |$c| - (PLUS |$m| - (TIMES 2 - (SPADLET |$numberOfSpills| - (PLUS |$numberOfSpills| 1))))) - (SPADLET |$lineFragmentBuffer| (LIST (|nBlanks| |$c|))) |$c|))) - -;indent() == -; $m:= $m+2*($numberOfSpills+1) -; $marginStack:= [$m,:$marginStack] -; $numberOfSpills:= 0 -; $m - -(DEFUN |indent| () - (declare (special |$m| |$marginStack| |$numberOfSpills|)) - (PROGN - (SPADLET |$m| (PLUS |$m| (TIMES 2 (PLUS |$numberOfSpills| 1)))) - (SPADLET |$marginStack| (CONS |$m| |$marginStack|)) - (SPADLET |$numberOfSpills| 0) - |$m|)) - -;undent() == -;-- $doNotResetMarginIfTrue=true => -;-- pp '"hoho" -;-- $c -; $marginStack is [m,:r] => -; $marginStack := r -; $m := m -; 0 - -(DEFUN |undent| () - (PROG (|m| |r|) - (declare (special |$m| |$marginStack|)) - (RETURN - (COND - ((AND (PAIRP |$marginStack|) - (PROGN - (SPADLET |m| (QCAR |$marginStack|)) - (SPADLET |r| (QCDR |$marginStack|)) - 'T)) - (SPADLET |$marginStack| |r|) (SPADLET |$m| |m|)) - ('T 0))))) - -;spill(fn,a) == -; u := try FUNCALL(fn,a) => u -; (nearMargin() or spillLine()) and FUNCALL(fn,a) - -(DEFUN |spill| (|fn| |a|) - (PROG (|u|) - (RETURN - (COND - ((SPADLET |u| (|try| (FUNCALL |fn| |a|))) |u|) - ('T (AND (OR (|nearMargin|) (|spillLine|)) (FUNCALL |fn| |a|))))))) - -;formatSpill(fn,a) == -; u := try FUNCALL(fn,a) => u -; v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,a) -; w := stay or undent() -; v and w - -(DEFUN |formatSpill| (|fn| |a|) - (PROG (|u| |stay| |v| |w|) - (RETURN - (COND - ((SPADLET |u| (|try| (FUNCALL |fn| |a|))) |u|) - ('T - (SPADLET |v| - (AND (SPADLET |stay| - (OR (|nearMargin|) - (AND (|indent|) (|newLine|)))) - (FUNCALL |fn| |a|))) - (SPADLET |w| (OR |stay| (|undent|))) (AND |v| |w|)))))) - -;formatSpill2(fn,f,a) == -; u := try FUNCALL(fn,f,a) => u -; v := (stay:= nearMargin() or indent() and newLine()) and FUNCALL(fn,f,a) -; w := stay or undent() -; v and w - -(DEFUN |formatSpill2| (|fn| |f| |a|) - (PROG (|u| |stay| |v| |w|) - (RETURN - (COND - ((SPADLET |u| (|try| (FUNCALL |fn| |f| |a|))) |u|) - ('T - (SPADLET |v| - (AND (SPADLET |stay| - (OR (|nearMargin|) - (AND (|indent|) (|newLine|)))) - (FUNCALL |fn| |f| |a|))) - (SPADLET |w| (OR |stay| (|undent|))) (AND |v| |w|)))))) - -;nearMargin() == -; $c=$m or $c=$m+1 => $c - -(DEFUN |nearMargin| () - (declare (special |$c| |$m|)) - (SEQ (COND - ((OR (BOOT-EQUAL |$c| |$m|) (BOOT-EQUAL |$c| (PLUS |$m| 1))) - (EXIT |$c|))))) - -;--====================================================================== -;-- Main Formatting Functions -;--====================================================================== -;format(x,:options) == -; oldC:= $c -; qualification := IFCAR options -; newCOrNil:= -; x is [op,:argl] => -; if op = 'return then argl := rest argl -; n := #argl -; op is ['elt,y,"construct"] => formatDollar(y,'construct,argl) -; op is ['elt,name,p] and UPPER_-CASE_-P (STRINGIMAGE opOf name).0 => -; formatDollar(name,p,argl) -; op = 'elt and UPPER_-CASE_-P (STRINGIMAGE opOf CAR argl).0 => -; formatDollar1(CAR argl,CADR argl) -; fn:= GET(op,"PSPAD") => formatFn(fn,x,$m,$c) -; if MEMQ(op,'(AND OR NOT)) then op:= DOWNCASE op -; n=1 and GET(op,'Nud) and (lbp:= formatOpBindingPower(op,"Nud","left")) => -; formatPrefix(op,first argl,lbp,formatOpBindingPower(op,"Nud","right"),qualification) -; n=2 and (op = '_$ or getOp(op,'Led)) and (lbp:= formatOpBindingPower(op,"Led","left")) => -; formatInfix(op,argl,lbp,formatOpBindingPower(op,"Led","right"),qualification) -; formatForm x -; formatAtom x -; null newCOrNil => ($c:= oldC; nil) -; null FIXP newCOrNil => error() -; $c:= newCOrNil - -(DEFUN |format| (&REST G166482 &AUX |options| |x|) - (DSETQ (|x| . |options|) G166482) - (PROG (|oldC| |qualification| |argl| |n| |y| |ISTMP#1| |name| - |ISTMP#2| |p| |fn| |op| |lbp| |newCOrNil|) - (declare (special |$c| |$m|)) - (RETURN - (PROGN - (SPADLET |oldC| |$c|) - (SPADLET |qualification| (IFCAR |options|)) - (SPADLET |newCOrNil| - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |argl| (QCDR |x|)) - 'T)) - (COND - ((BOOT-EQUAL |op| '|return|) - (SPADLET |argl| (CDR |argl|)))) - (SPADLET |n| (|#| |argl|)) - (COND - ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQ (QCAR |ISTMP#2|) - '|construct|)))))) - (|formatDollar| |y| '|construct| |argl|)) - ((AND (PAIRP |op|) (EQ (QCAR |op|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |name| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |p| (QCAR |ISTMP#2|)) - 'T))))) - (UPPER-CASE-P - (ELT (STRINGIMAGE (|opOf| |name|)) 0))) - (|formatDollar| |name| |p| |argl|)) - ((AND (BOOT-EQUAL |op| '|elt|) - (UPPER-CASE-P - (ELT (STRINGIMAGE - (|opOf| (CAR |argl|))) - 0))) - (|formatDollar1| (CAR |argl|) (CADR |argl|))) - ((SPADLET |fn| (GETL |op| 'PSPAD)) - (|formatFn| |fn| |x| |$m| |$c|)) - ('T - (COND - ((MEMQ |op| '(AND OR NOT)) - (SPADLET |op| (DOWNCASE |op|)))) - (COND - ((AND (EQL |n| 1) (GETL |op| '|Nud|) - (SPADLET |lbp| - (|formatOpBindingPower| |op| - '|Nud| '|left|))) - (|formatPrefix| |op| (CAR |argl|) |lbp| - (|formatOpBindingPower| |op| '|Nud| - '|right|) - |qualification|)) - ((AND (EQL |n| 2) - (OR (BOOT-EQUAL |op| '$) - (|getOp| |op| '|Led|)) - (SPADLET |lbp| - (|formatOpBindingPower| |op| - '|Led| '|left|))) - (|formatInfix| |op| |argl| |lbp| - (|formatOpBindingPower| |op| '|Led| - '|right|) - |qualification|)) - ('T (|formatForm| |x|)))))) - ('T (|formatAtom| |x|)))) - (COND - ((NULL |newCOrNil|) (SPADLET |$c| |oldC|) NIL) - ((NULL (integerp |newCOrNil|)) (|error|)) - ('T (SPADLET |$c| |newCOrNil|))))))) - -;getOp(op,kind) == -; kind = 'Led => -; MEMQ(op,'(_div _exquo)) => nil -; GET(op,'Led) -; GET(op,'Nud) - -(DEFUN |getOp| (|op| |kind|) - (COND - ((BOOT-EQUAL |kind| '|Led|) - (COND ((MEMQ |op| '(|div| |exquo|)) NIL) ('T (GETL |op| '|Led|)))) - ('T (GETL |op| '|Nud|)))) - -;formatDollar(name,p,argl) == -; name := markMacroTran name -; n := #argl -; kind := (n=1 => "Nud"; "Led") -; IDENTP name and GET(p,kind) => format([p,:argl],name) -; formatForcePren [p,:argl] and -; (try (format "$$" and formatForcePren name) -; or (indent() and format "$__" and formatForcePren name and undent())) - -(DEFUN |formatDollar| (|name| |p| |argl|) - (PROG (|n| |kind|) - (RETURN - (PROGN - (SPADLET |name| (|markMacroTran| |name|)) - (SPADLET |n| (|#| |argl|)) - (SPADLET |kind| (COND ((EQL |n| 1) '|Nud|) ('T '|Led|))) - (COND - ((AND (IDENTP |name|) (GETL |p| |kind|)) - (|format| (CONS |p| |argl|) |name|)) - ('T - (AND (|formatForcePren| (CONS |p| |argl|)) - (OR (|try| (AND (|format| '$$) - (|formatForcePren| |name|))) - (AND (|indent|) (|format| '$_) - (|formatForcePren| |name|) (|undent|)))))))))) - -;formatMacroCheck name == -; ATOM name => name -; u := or/[x for [x,:y] in $globalMacroStack | y = name] => u -; u := or/[x for [x,:y] in $localMacroStack | y = name] => u -; [op,:argl] := name -; MEMQ(op,'(Record Union)) => -; pp ['"Cannot find: ",name] -; name -; [op,:[formatMacroCheck x for x in argl]] - -(DEFUN |formatMacroCheck| (|name|) - (PROG (|x| |y| |u| |op| |argl|) - (declare (special |$localMacroStack| |$globalMacroStack|)) - (RETURN - (SEQ (COND - ((ATOM |name|) |name|) - ((SPADLET |u| - (PROG (G166509) - (SPADLET G166509 NIL) - (RETURN - (DO ((G166517 NIL G166509) - (G166518 |$globalMacroStack| - (CDR G166518)) - (G166496 NIL)) - ((OR G166517 (ATOM G166518) - (PROGN - (SETQ G166496 (CAR G166518)) - NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR G166496)) - (SPADLET |y| (CDR G166496)) - G166496) - NIL)) - G166509) - (SEQ (EXIT (COND - ((BOOT-EQUAL |y| |name|) - (SETQ G166509 - (OR G166509 |x|)))))))))) - |u|) - ((SPADLET |u| - (PROG (G166526) - (SPADLET G166526 NIL) - (RETURN - (DO ((G166534 NIL G166526) - (G166535 |$localMacroStack| - (CDR G166535)) - (G166500 NIL)) - ((OR G166534 (ATOM G166535) - (PROGN - (SETQ G166500 (CAR G166535)) - NIL) - (PROGN - (PROGN - (SPADLET |x| (CAR G166500)) - (SPADLET |y| (CDR G166500)) - G166500) - NIL)) - G166526) - (SEQ (EXIT (COND - ((BOOT-EQUAL |y| |name|) - (SETQ G166526 - (OR G166526 |x|)))))))))) - |u|) - ('T (SPADLET |op| (CAR |name|)) - (SPADLET |argl| (CDR |name|)) - (COND - ((MEMQ |op| '(|Record| |Union|)) - (|pp| (CONS "Cannot find: " - (CONS |name| NIL))) - |name|) - ('T - (CONS |op| - (PROG (G166547) - (SPADLET G166547 NIL) - (RETURN - (DO ((G166552 |argl| (CDR G166552)) - (|x| NIL)) - ((OR (ATOM G166552) - (PROGN - (SETQ |x| (CAR G166552)) - NIL)) - (NREVERSE0 G166547)) - (SEQ (EXIT (SETQ G166547 - (CONS (|formatMacroCheck| |x|) - G166547)))))))))))))))) - -;formatDOLLAR ['DOLLAR,x,y] == formatDollar1(y, x) - -(DEFUN |formatDOLLAR| (G166572) - (PROG (|x| |y|) - (RETURN - (PROGN - (SPADLET |x| (CADR G166572)) - (SPADLET |y| (CADDR G166572)) - (|formatDollar1| |y| |x|))))) - -;formatDollar1(name,arg) == -; id := -; IDENTP name => name -; name is [p] and GET(p,'NILADIC) => p -; name -; format arg and format "$$" and formatForcePren id - -(DEFUN |formatDollar1| (|name| |arg|) - (PROG (|p| |id|) - (RETURN - (PROGN - (SPADLET |id| - (COND - ((IDENTP |name|) |name|) - ((AND (PAIRP |name|) (EQ (QCDR |name|) NIL) - (PROGN (SPADLET |p| (QCAR |name|)) 'T) - (GETL |p| 'NILADIC)) - |p|) - ('T |name|))) - (AND (|format| |arg|) (|format| '$$) (|formatForcePren| |id|)))))) - -;formatForcePren x == -; $formatForcePren: local := true -; format x - -(DEFUN |formatForcePren| (|x|) - (PROG (|$formatForcePren|) - (DECLARE (SPECIAL |$formatForcePren|)) - (RETURN (PROGN (SPADLET |$formatForcePren| 'T) (|format| |x|))))) - -;formatAtom(x,:options) == -; if u := LASSOC(x,$renameAlist) then x := u -; null x or isIdentifier x => -; if MEMQ(x,$escapeWords) then -; consBuffer $underScore -; consBuffer ident2PrintImage PNAME x -; consBuffer x - -(DEFUN |formatAtom| (&REST G166607 &AUX |options| |x|) - (DSETQ (|x| . |options|) G166607) - (PROG (|u|) - (declare (special |$underScore| |$escapeWords| |$renameAlist|)) - (RETURN - (PROGN - (COND - ((SPADLET |u| (LASSOC |x| |$renameAlist|)) (SPADLET |x| |u|))) - (COND - ((OR (NULL |x|) (|isIdentifier| |x|)) - (COND - ((MEMQ |x| |$escapeWords|) (|consBuffer| |$underScore|))) - (|consBuffer| (|ident2PrintImage| (PNAME |x|)))) - ('T (|consBuffer| |x|))))))) - -;formatFn(fn,x,$m,$c) == FUNCALL(fn,x) - -(DEFUN |formatFn| (|fn| |x| |$m| |$c|) - (DECLARE (SPECIAL |$m| |$c|)) - (FUNCALL |fn| |x|)) - -;formatFree(['free,:u]) == -; format 'free and format " " and formatComma u - -(DEFUN |formatFree| (G166612) - (PROG (|u|) - (RETURN - (PROGN - (SPADLET |u| (CDR G166612)) - (AND (|format| '|free|) (|format| '| |) (|formatComma| |u|)))))) - -;formatUnion(['Union,:r]) == -; $count : local := 0 -; formatFormNoColonDecl formatTestForPartial ['Union,:[fn x for x in r]] where fn x == -; x is [":",y,'Branch] => fn STRINGIMAGE y -; STRINGP x => [":", INTERN x, ['Enumeration,x]] -; x is [":",:.] => x -; tag := INTERN STRCONC("value",STRINGIMAGE ($count := $count + 1)) -; [":", tag, x] - -(DEFUN |formatUnion,fn| (|x|) - (PROG (|ISTMP#1| |y| |ISTMP#2| |tag|) - (declare (special |$count|)) - (RETURN - (SEQ (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |y| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQ (QCAR |ISTMP#2|) '|Branch|)))))) - (EXIT (|formatUnion,fn| (STRINGIMAGE |y|)))) - (IF (STRINGP |x|) - (EXIT (CONS '|:| - (CONS (INTERN |x|) - (CONS (CONS '|Enumeration| - (CONS |x| NIL)) - NIL))))) - (IF (AND (PAIRP |x|) (EQ (QCAR |x|) '|:|)) (EXIT |x|)) - (SPADLET |tag| - (INTERN (STRCONC '|value| - (STRINGIMAGE - (SPADLET |$count| - (PLUS |$count| 1)))))) - (EXIT (CONS '|:| (CONS |tag| (CONS |x| NIL)))))))) - -(DEFUN |formatUnion| (G166644) - (PROG (|$count| |r|) - (DECLARE (SPECIAL |$count|)) - (RETURN - (SEQ (PROGN - (SPADLET |r| (CDR G166644)) - (SPADLET |$count| 0) - (|formatFormNoColonDecl| - (|formatTestForPartial| - (CONS '|Union| - (PROG (G166655) - (SPADLET G166655 NIL) - (RETURN - (DO ((G166660 |r| (CDR G166660)) - (|x| NIL)) - ((OR (ATOM G166660) - (PROGN - (SETQ |x| (CAR G166660)) - NIL)) - (NREVERSE0 G166655)) - (SEQ (EXIT - (SETQ G166655 - (CONS (|formatUnion,fn| |x|) - G166655))))))))))))))) - -;formatTestForPartial u == -; u is ['Union,a,b] and b is [":","failed",:.] and a is [":",.,S] => -; ['Partial, S] -; u - -(DEFUN |formatTestForPartial| (|u|) - (PROG (|a| |b| |ISTMP#1| |ISTMP#2| S) - (RETURN - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Union|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T))))) - (PAIRP |b|) (EQ (QCAR |b|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|failed|))) - (PAIRP |a|) (EQ (QCAR |a|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET S (QCAR |ISTMP#2|)) 'T)))))) - (CONS '|Partial| (CONS S NIL))) - ('T |u|))))) - -;formatEnumeration(y is ['Enumeration,:r]) == -; r is [x] => format "'" and format INTERN STRINGIMAGE x and format "'" -; formatForm y - -(DEFUN |formatEnumeration| (|y|) - (PROG (|r| |x|) - (RETURN - (PROGN - (SPADLET |r| (CDR |y|)) - (COND - ((AND (PAIRP |r|) (EQ (QCDR |r|) NIL) - (PROGN (SPADLET |x| (QCAR |r|)) 'T)) - (AND (|format| '|'|) (|format| (INTERN (STRINGIMAGE |x|))) - (|format| '|'|))) - ('T (|formatForm| |y|))))))) - -;formatRecord(u) == formatFormNoColonDecl u - -(DEFUN |formatRecord| (|u|) (|formatFormNoColonDecl| |u|)) - -;formatFormNoColonDecl u == -; $noColonDeclaration: local := true -; formatForm u - -(DEFUN |formatFormNoColonDecl| (|u|) - (PROG (|$noColonDeclaration|) - (DECLARE (SPECIAL |$noColonDeclaration|)) - (RETURN - (PROGN (SPADLET |$noColonDeclaration| 'T) (|formatForm| |u|))))) - -;formatElt(u) == -; u is ["elt",a,b] => formatApplication rest u -; formatForm u - -(DEFUN |formatElt| (|u|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T)))))) - (|formatApplication| (CDR |u|))) - ('T (|formatForm| |u|)))))) - -;formatForm (u) == -; [op,:argl] := u -; if MEMQ(op, '(Record Union)) then -; $fieldNames := UNION(getFieldNames argl,$fieldNames) -; MEMQ(op,'((QUOTE T) true)) => format "true" -; MEMQ(op,'(false nil)) => format op -; u='(Zero) => format 0 -; u='(One) => format 1 -; 1=#argl => formatApplication u -; formatFunctionCall u - -(DEFUN |formatForm| (|u|) - (PROG (|op| |argl|) - (declare (special |$fieldNames|)) - (RETURN - (PROGN - (SPADLET |op| (CAR |u|)) - (SPADLET |argl| (CDR |u|)) - (COND - ((MEMQ |op| '(|Record| |Union|)) - (SPADLET |$fieldNames| - (|union| (|getFieldNames| |argl|) |$fieldNames|)))) - (COND - ((MEMQ |op| '('T |true|)) (|format| '|true|)) - ((MEMQ |op| '(|false| |nil|)) (|format| |op|)) - ((BOOT-EQUAL |u| '(|Zero|)) (|format| 0)) - ((BOOT-EQUAL |u| '(|One|)) (|format| 1)) - ((EQL 1 (|#| |argl|)) (|formatApplication| |u|)) - ('T (|formatFunctionCall| |u|))))))) - -;formatFunctionCall u == -; $pilesAreOkHere: local := nil -; spill("formatFunctionCall1",u) - -(DEFUN |formatFunctionCall| (|u|) - (PROG (|$pilesAreOkHere|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (SPADLET |$pilesAreOkHere| NIL) - (|spill| '|formatFunctionCall1| |u|))))) - -;formatFunctionCall1 [op,:argl] == -;--null argl and getConstructorProperty(op,'niladic) => formatOp op -; null argl => -; GET(op,'NILADIC) => formatOp op -; formatOp op and format "()" -; formatOp op and formatFunctionCallTail argl - -(DEFUN |formatFunctionCall1| (G166781) - (PROG (|op| |argl|) - (RETURN - (PROGN - (SPADLET |op| (CAR G166781)) - (SPADLET |argl| (CDR G166781)) - (COND - ((NULL |argl|) - (COND - ((GETL |op| 'NILADIC) (|formatOp| |op|)) - ('T (AND (|formatOp| |op|) (|format| '|()|))))) - ('T - (AND (|formatOp| |op|) (|formatFunctionCallTail| |argl|)))))))) - -;formatFunctionCallTail argl == format "_(" and formatComma argl and format "_)" - -(DEFUN |formatFunctionCallTail| (|argl|) - (AND (|format| '|(|) (|formatComma| |argl|) (|format| '|)|))) - -;formatComma argl == -; format first argl and (and/[format "," and formatCut x for x in rest argl]) and $c - -(DEFUN |formatComma| (|argl|) - (PROG () - (declare (special |$c|)) - (RETURN - (SEQ (AND (|format| (CAR |argl|)) - (PROG (G166798) - (SPADLET G166798 'T) - (RETURN - (DO ((G166804 NIL (NULL G166798)) - (G166805 (CDR |argl|) (CDR G166805)) - (|x| NIL)) - ((OR G166804 (ATOM G166805) - (PROGN (SETQ |x| (CAR G166805)) NIL)) - G166798) - (SEQ (EXIT (SETQ G166798 - (AND G166798 - (AND (|format| '|,|) - (|formatCut| |x|))))))))) - |$c|))))) - -;formatOp op == -; atom op => formatAtom op -; formatPren op - -(DEFUN |formatOp| (|op|) - (COND ((ATOM |op|) (|formatAtom| |op|)) ('T (|formatPren| |op|)))) - -;formatApplication u == -; [op,a] := u -; MEMQ(a, $fieldNames) => formatSelection u -; atom op => -; formatHasDotLeadOp a => formatOpPren(op,a) -; formatApplication0 u -; formatSelection u - -(DEFUN |formatApplication| (|u|) - (PROG (|op| |a|) - (declare (special |$fieldNames|)) - (RETURN - (PROGN - (SPADLET |op| (CAR |u|)) - (SPADLET |a| (CADR |u|)) - (COND - ((MEMQ |a| |$fieldNames|) (|formatSelection| |u|)) - ((ATOM |op|) - (COND - ((|formatHasDotLeadOp| |a|) (|formatOpPren| |op| |a|)) - ('T (|formatApplication0| |u|)))) - ('T (|formatSelection| |u|))))))) - -;formatHasDotLeadOp u == -; u is [op,:.] and (op = "." or not atom op) - -(DEFUN |formatHasDotLeadOp| (|u|) - (PROG (|op|) - (RETURN - (AND (PAIRP |u|) (PROGN (SPADLET |op| (QCAR |u|)) 'T) - (OR (BOOT-EQUAL |op| (INTERN "." "BOOT")) - (NULL (ATOM |op|))))))) - -;formatApplication0 u == -;--format as f(x) as f x if possible -; $pilesAreOkHere: local := nil -; formatSpill("formatApplication1",u) - -(DEFUN |formatApplication0| (|u|) - (PROG (|$pilesAreOkHere|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (SPADLET |$pilesAreOkHere| NIL) - (|formatSpill| '|formatApplication1| |u|))))) - -;formatApplication1 u == -; [op,x] := u -; formatHasDollarOp x or $formatForcePren or -; pspadBindingPowerOf("left",x) < 1000 => formatOpPren(op,x) -; try (formatOp op and format " ") and -; (try formatApplication2 x or -; format "(" and formatApplication2 x and format ")") - -(DEFUN |formatApplication1| (|u|) - (PROG (|op| |x|) - (declare (special |$formatForcePren|)) - (RETURN - (PROGN - (SPADLET |op| (CAR |u|)) - (SPADLET |x| (CADR |u|)) - (COND - ((OR (|formatHasDollarOp| |x|) |$formatForcePren| - (> 1000 (|pspadBindingPowerOf| '|left| |x|))) - (|formatOpPren| |op| |x|)) - ('T - (AND (|try| (AND (|formatOp| |op|) (|format| '| |))) - (OR (|try| (|formatApplication2| |x|)) - (AND (|format| '|(|) (|formatApplication2| |x|) - (|format| '|)|)))))))))) - -;formatHasDollarOp x == -; x is ["elt",a,b] and isTypeProbably? a - -(DEFUN |formatHasDollarOp| (|x|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (AND (PAIRP |x|) (EQ (QCAR |x|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T))))) - (|isTypeProbably?| |a|))))) - -;isTypeProbably? x == -; IDENTP x and UPPER_-CASE_-P (PNAME x).0 - -(DEFUN |isTypeProbably?| (|x|) - (AND (IDENTP |x|) (UPPER-CASE-P (ELT (PNAME |x|) 0)))) - -;formatOpPren(op,x) == formatOp op and formatPren x - -(DEFUN |formatOpPren| (|op| |x|) - (AND (|formatOp| |op|) (|formatPren| |x|))) - -;formatApplication2 x == -; leadOp := -; x is [['elt,.,y],:.] => y -; opOf x -; MEMQ(leadOp,'(COLLECT LIST construct)) or -; pspadBindingPowerOf("left",x)<1000 => formatPren x -; format x - -(DEFUN |formatApplication2| (|x|) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |y| |leadOp|) - (RETURN - (PROGN - (SPADLET |leadOp| - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCAR |ISTMP#1|) '|elt|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |y| - (QCAR |ISTMP#3|)) - 'T)))))))) - |y|) - ('T (|opOf| |x|)))) - (COND - ((OR (MEMQ |leadOp| '(COLLECT LIST |construct|)) - (> 1000 (|pspadBindingPowerOf| '|left| |x|))) - (|formatPren| |x|)) - ('T (|format| |x|))))))) - -;formatDot ["dot",a,x] == -; try (formatOp a and format ".") and -; ATOM x => format x -; formatPren x - -(DEFUN |formatDot| (G166908) - (PROG (|a| |x|) - (RETURN - (PROGN - (COND ((EQ (CAR G166908) '|dot|) (CAR G166908))) - (SPADLET |a| (CADR G166908)) - (SPADLET |x| (CADDR G166908)) - (AND (|try| (AND (|formatOp| |a|) - (|format| (INTERN "." "BOOT")))) - (COND - ((ATOM |x|) (|format| |x|)) - ('T (|formatPren| |x|)))))))) - -;formatSelection u == -; $pilesAreOkHere: local := nil -; formatSpill("formatSelection1",u) - -(DEFUN |formatSelection| (|u|) - (PROG (|$pilesAreOkHere|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (SPADLET |$pilesAreOkHere| NIL) - (|formatSpill| '|formatSelection1| |u|))))) - -;formatSelection1 [f,x] == formatSelectionOp f and format "." and -; ATOM x => format x -; formatPren x - -(DEFUN |formatSelection1| (G166932) - (PROG (|f| |x|) - (RETURN - (PROGN - (SPADLET |f| (CAR G166932)) - (SPADLET |x| (CADR G166932)) - (AND (|formatSelectionOp| |f|) (|format| (INTERN "." "BOOT")) - (COND - ((ATOM |x|) (|format| |x|)) - ('T (|formatPren| |x|)))))))) - -;formatSelectionOp op == -; op is [f,.] and not GET(f,'Nud) or -; 1000 < pspadBindingPowerOf("right",op) => formatSelectionOp1 op -; formatPren1("formatSelectionOp1",op) - -(DEFUN |formatSelectionOp| (|op|) - (PROG (|f| |ISTMP#1|) - (RETURN - (COND - ((OR (AND (PAIRP |op|) - (PROGN - (SPADLET |f| (QCAR |op|)) - (SPADLET |ISTMP#1| (QCDR |op|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL))) - (NULL (GETL |f| '|Nud|))) - (> (|pspadBindingPowerOf| '|right| |op|) 1000)) - (|formatSelectionOp1| |op|)) - ('T (|formatPren1| '|formatSelectionOp1| |op|)))))) - -;formatSelectionOp1 f == -; f is [op,:argl] => -; argl is [a] => -; not ATOM op and ATOM a => formatSelection1 [op,a] -; formatPren f -; format f -; formatOp f - -(DEFUN |formatSelectionOp1| (|f|) - (PROG (|op| |argl| |a|) - (RETURN - (COND - ((AND (PAIRP |f|) - (PROGN - (SPADLET |op| (QCAR |f|)) - (SPADLET |argl| (QCDR |f|)) - 'T)) - (COND - ((AND (PAIRP |argl|) (EQ (QCDR |argl|) NIL) - (PROGN (SPADLET |a| (QCAR |argl|)) 'T)) - (COND - ((AND (NULL (ATOM |op|)) (ATOM |a|)) - (|formatSelection1| (CONS |op| (CONS |a| NIL)))) - ('T (|formatPren| |f|)))) - ('T (|format| |f|)))) - ('T (|formatOp| |f|)))))) - -;formatPren a == -; $pilesAreOkHere: local := nil -; formatSpill("formatPrenAux",a) - -(DEFUN |formatPren| (|a|) - (PROG (|$pilesAreOkHere|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (SPADLET |$pilesAreOkHere| NIL) - (|formatSpill| '|formatPrenAux| |a|))))) - -;formatPrenAux a == format "_(" and format a and format "_)" - -(DEFUN |formatPrenAux| (|a|) - (AND (|format| '|(|) (|format| |a|) (|format| '|)|))) - -;formatPren1(f,a) == -; $pilesAreOkHere: local := nil -; formatSpill2("formatPren1Aux",f,a) - -(DEFUN |formatPren1| (|f| |a|) - (PROG (|$pilesAreOkHere|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (SPADLET |$pilesAreOkHere| NIL) - (|formatSpill2| '|formatPren1Aux| |f| |a|))))) - -;formatPren1Aux(f,a) == format "_(" and FUNCALL(f,a) and format "_)" - -(DEFUN |formatPren1Aux| (|f| |a|) - (AND (|format| '|(|) (FUNCALL |f| |a|) (|format| '|)|))) - -;formatLeft(fn,x,op,key) == -; lbp:= formatOpBindingPower(op,key,"left") -; formatOpBindingPower(opOf x,key,"right") formatPren1(fn,x) -; FUNCALL(fn,x) - -(DEFUN |formatLeft| (|fn| |x| |op| |key|) - (PROG (|lbp|) - (RETURN - (PROGN - (SPADLET |lbp| (|formatOpBindingPower| |op| |key| '|left|)) - (COND - ((> |lbp| - (|formatOpBindingPower| (|opOf| |x|) |key| '|right|)) - (|formatPren1| |fn| |x|)) - ('T (FUNCALL |fn| |x|))))))) - -;formatRight(fn,x,op,key) == -; --are there exceptional cases where piles are ok? -; x is ['LET,:.] => FUNCALL(fn,x) -; --decide on basis of binding power whether prens are needed -; rbp := formatOpBindingPower(op,key,"right") -; lbp := formatOpBindingPower(opOf x,key,"left") -; lbp < rbp => formatPren1(fn,x) -; FUNCALL(fn,x) - -(DEFUN |formatRight| (|fn| |x| |op| |key|) - (PROG (|rbp| |lbp|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'LET)) (FUNCALL |fn| |x|)) - ('T - (SPADLET |rbp| (|formatOpBindingPower| |op| |key| '|right|)) - (SPADLET |lbp| - (|formatOpBindingPower| (|opOf| |x|) |key| '|left|)) - (COND - ((> |rbp| |lbp|) (|formatPren1| |fn| |x|)) - ('T (FUNCALL |fn| |x|)))))))) - -;formatCut a == formatSpill("format",a) - -(DEFUN |formatCut| (|a|) (|formatSpill| '|format| |a|)) - -;--====================================================================== -;-- Prefix/Infix Operators -;--====================================================================== -;formatPrefix(op,arg,lbp,rbp,:options) == -; qualification := IFCAR options -; $pilesAreOkHere: local := nil -; formatPrefixOp(op,qualification) and -; (rbp>formatGetBindingPowerOf("left",arg) => formatPren arg; format arg) - -(DEFUN |formatPrefix| - (&REST G167012 &AUX |options| |rbp| |lbp| |arg| |op|) - (DSETQ (|op| |arg| |lbp| |rbp| . |options|) G167012) - (PROG (|$pilesAreOkHere| |qualification|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (SPADLET |qualification| (IFCAR |options|)) - (SPADLET |$pilesAreOkHere| NIL) - (AND (|formatPrefixOp| |op| |qualification|) - (COND - ((> |rbp| (|formatGetBindingPowerOf| '|left| |arg|)) - (|formatPren| |arg|)) - ('T (|format| |arg|)))))))) - -;formatPrefixOp(op,:options) == -; qualification := IFCAR options -; op=char '" " => format " =" -; qualification or GET(op,"Nud") and ^MEMQ(op,$spadTightList) => -; formatQual(op,qualification) and format " " -; format op - -(DEFUN |formatPrefixOp| (&REST G167018 &AUX |options| |op|) - (DSETQ (|op| . |options|) G167018) - (PROG (|qualification|) - (declare (special |$spadTightList|)) - (RETURN - (PROGN - (SPADLET |qualification| (IFCAR |options|)) - (COND - ((BOOT-EQUAL |op| (|char| " ")) - (|format| '| =|)) - ((OR |qualification| - (AND (GETL |op| '|Nud|) - (NULL (MEMQ |op| |$spadTightList|)))) - (AND (|formatQual| |op| |qualification|) (|format| '| |))) - ('T (|format| |op|))))))) - -;formatQual(op,D) == -; null D => format op -; format op and format "$$" and format D - -(DEFUN |formatQual| (|op| D) - (COND - ((NULL D) (|format| |op|)) - ('T (AND (|format| |op|) (|format| '$$) (|format| D))))) - -;formatInfix(op,[a,b],lbp,rbp,:options) == -; qualification := IFCAR options -; $pilesAreOkHere: local := nil -; (if formatGetBindingPowerOf("right",a)formatGetBindingPowerOf("left",b) -; then formatPren b else format b) - -(DEFUN |formatInfix| - (&REST G167042 &AUX |options| |rbp| |lbp| G167024 |op|) - (DSETQ (|op| G167024 |lbp| |rbp| . |options|) G167042) - (PROG (|$pilesAreOkHere| |a| |b| |qualification|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (SPADLET |a| (CAR G167024)) - (SPADLET |b| (CADR G167024)) - (SPADLET |qualification| (IFCAR |options|)) - (SPADLET |$pilesAreOkHere| NIL) - (AND (COND - ((> |lbp| (|formatGetBindingPowerOf| '|right| |a|)) - (|formatPren| |a|)) - ('T (|format| |a|))) - (|formatInfixOp| |op| |qualification|) - (COND - ((> |rbp| (|formatGetBindingPowerOf| '|left| |b|)) - (|formatPren| |b|)) - ('T (|format| |b|)))))))) - -;formatGetBindingPowerOf(leftOrRight,x) == -;-- this function is nearly identical with getBindingPowerOf -;-- leftOrRight = "left" => 0 -;-- 1 -; pspadBindingPowerOf(leftOrRight,x) - -(DEFUN |formatGetBindingPowerOf| (|leftOrRight| |x|) - (|pspadBindingPowerOf| |leftOrRight| |x|)) - -;pspadBindingPowerOf(key,x) == -; --binding powers can be found in file NEWAUX LISP -; x is ['REDUCE,:.] => (key='left => 130; key='right => 0) -; x is ["REPEAT",:.] => (key="left" => 130; key="right" => 0) -; x is ["COND",:.] => (key="left" => 130; key="right" => 0) -; x is [op,:argl] => -; if op is [a,:.] then op:= a -; op = 'SLASH => pspadBindingPowerOf(key,["/",:argl]) - 1 -; op = 'OVER => pspadBindingPowerOf(key,["/",:argl]) -; (n:= #argl)=1 => -; key="left" and (m:= pspadOpBindingPower(op,"Nud","left")) => m -; key="right" and (m:= pspadOpBindingPower(op,"Nud","right")) => m -; 1000 -; n>1 => -; key="left" and (m:= pspadOpBindingPower(op,"Led","left")) => m -; key="right" and (m:= pspadOpBindingPower(op,"Led","right")) => m -; op="ELT" => 1002 -; 1000 -; 1000 -; 1002 - -(DEFUN |pspadBindingPowerOf| (|key| |x|) - (PROG (|argl| |a| |op| |n| |m|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'REDUCE)) - (COND - ((BOOT-EQUAL |key| '|left|) 130) - ((BOOT-EQUAL |key| '|right|) 0))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'REPEAT)) - (COND - ((BOOT-EQUAL |key| '|left|) 130) - ((BOOT-EQUAL |key| '|right|) 0))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'COND)) - (COND - ((BOOT-EQUAL |key| '|left|) 130) - ((BOOT-EQUAL |key| '|right|) 0))) - ((AND (PAIRP |x|) - (PROGN - (SPADLET |op| (QCAR |x|)) - (SPADLET |argl| (QCDR |x|)) - 'T)) - (COND - ((AND (PAIRP |op|) (PROGN (SPADLET |a| (QCAR |op|)) 'T)) - (SPADLET |op| |a|))) - (COND - ((BOOT-EQUAL |op| 'SLASH) - (SPADDIFFERENCE - (|pspadBindingPowerOf| |key| (CONS '/ |argl|)) 1)) - ((BOOT-EQUAL |op| 'OVER) - (|pspadBindingPowerOf| |key| (CONS '/ |argl|))) - ((EQL (SPADLET |n| (|#| |argl|)) 1) - (COND - ((AND (BOOT-EQUAL |key| '|left|) - (SPADLET |m| - (|pspadOpBindingPower| |op| '|Nud| - '|left|))) - |m|) - ((AND (BOOT-EQUAL |key| '|right|) - (SPADLET |m| - (|pspadOpBindingPower| |op| '|Nud| - '|right|))) - |m|) - ('T 1000))) - ((> |n| 1) - (COND - ((AND (BOOT-EQUAL |key| '|left|) - (SPADLET |m| - (|pspadOpBindingPower| |op| '|Led| - '|left|))) - |m|) - ((AND (BOOT-EQUAL |key| '|right|) - (SPADLET |m| - (|pspadOpBindingPower| |op| '|Led| - '|right|))) - |m|) - ((BOOT-EQUAL |op| 'ELT) 1002) - ('T 1000))) - ('T 1000))) - ('T 1002))))) - -;pspadOpBindingPower(op,LedOrNud,leftOrRight) == -; if op in '(SLASH OVER) then op := "/" -; MEMQ(op,'(_:)) and LedOrNud = 'Led => -; leftOrRight = 'left => 195 -; 196 -; exception:= -; leftOrRight="left" => 0 -; 105 -; bp:= -; leftOrRight="left" => leftBindingPowerOf(op,LedOrNud) -; rightBindingPowerOf(op,LedOrNud) -; bp^=exception => bp -; 1000 - -(DEFUN |pspadOpBindingPower| (|op| |LedOrNud| |leftOrRight|) - (PROG (|exception| |bp|) - (RETURN - (PROGN - (COND ((|member| |op| '(SLASH OVER)) (SPADLET |op| '/))) - (COND - ((AND (MEMQ |op| '(|:|)) (BOOT-EQUAL |LedOrNud| '|Led|)) - (COND ((BOOT-EQUAL |leftOrRight| '|left|) 195) ('T 196))) - ('T - (SPADLET |exception| - (COND - ((BOOT-EQUAL |leftOrRight| '|left|) 0) - ('T 105))) - (SPADLET |bp| - (COND - ((BOOT-EQUAL |leftOrRight| '|left|) - (|leftBindingPowerOf| |op| |LedOrNud|)) - ('T (|rightBindingPowerOf| |op| |LedOrNud|)))) - (COND ((NEQUAL |bp| |exception|) |bp|) ('T 1000)))))))) - -;formatOpBindingPower(op,key,leftOrRight) == -; if op in '(SLASH OVER) then op := "/" -; op = '_$ => 1002 -; MEMQ(op,'(_:)) and key = 'Led => -; leftOrRight = 'left => 195 -; 196 -; MEMQ(op,'(_^_= _>_=)) => 400 -; op = "not" and key = "Nud" => -; leftOrRight = 'left => 1000 -; 1001 -; GET(op,key) is [.,.,:r] => -; leftOrRight = 'left => KAR r or 0 -; KAR KDR r or 1 -; 1000 - -(DEFUN |formatOpBindingPower| (|op| |key| |leftOrRight|) - (PROG (|ISTMP#1| |ISTMP#2| |r|) - (RETURN - (PROGN - (COND ((|member| |op| '(SLASH OVER)) (SPADLET |op| '/))) - (COND - ((BOOT-EQUAL |op| '$) 1002) - ((AND (MEMQ |op| '(|:|)) (BOOT-EQUAL |key| '|Led|)) - (COND ((BOOT-EQUAL |leftOrRight| '|left|) 195) ('T 196))) - ((MEMQ |op| '(^= >=)) 400) - ((AND (BOOT-EQUAL |op| '|not|) (BOOT-EQUAL |key| '|Nud|)) - (COND ((BOOT-EQUAL |leftOrRight| '|left|) 1000) ('T 1001))) - ((PROGN - (SPADLET |ISTMP#1| (GETL |op| |key|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN (SPADLET |r| (QCDR |ISTMP#2|)) 'T))))) - (COND - ((BOOT-EQUAL |leftOrRight| '|left|) (OR (KAR |r|) 0)) - ('T (OR (KAR (KDR |r|)) 1)))) - ('T 1000)))))) - -;formatInfixOp(op,:options) == -; qualification := IFCAR options -; qualification or -; (op ^= '_$) and ^MEMQ(op,$spadTightList) => format " " and formatQual(op,qualification) and format " " -; format op - -(DEFUN |formatInfixOp| (&REST G167104 &AUX |options| |op|) - (DSETQ (|op| . |options|) G167104) - (PROG (|qualification|) - (declare (special |$spadTightList|)) - (RETURN - (PROGN - (SPADLET |qualification| (IFCAR |options|)) - (COND - ((OR |qualification| - (AND (NEQUAL |op| '$) - (NULL (MEMQ |op| |$spadTightList|)))) - (AND (|format| '| |) (|formatQual| |op| |qualification|) - (|format| '| |))) - ('T (|format| |op|))))))) - -;--====================================================================== -;-- Special Handlers: DEF forms -;--====================================================================== -;formatDEF def == formatDEF0(def,$DEFdepth + 1) - -(DEFUN |formatDEF| (|def|) - (declare (special |$DEFdepth|)) - (|formatDEF0| |def| (PLUS |$DEFdepth| 1))) - -;formatDEF0(["DEF",form,tlist,sclist,body],$DEFdepth) == -; if not MEMQ(KAR form,'(Exports Implementation)) then -; $form := -; form is [":",a,:.] => a -; form -; con := opOf $form -; $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) -; $abb :local := constructor? opOf $form -; if $DEFdepth < 2 then -; condoc := (u := LASSOC('constructor,$comments)) and KDR KAR u or ['""] -; $numberOfSpills := -1 -; consComments(condoc,'"+++ ") -; form := formatDeftranForm(form,tlist) -; u := ["DEF",form,tlist,sclist,body] -; v := formatDEF1 u => v -; $insideDEF: local := $DEFdepth > 1 -; $DEFdepth = 1 => -; exname := 'Exports -; impname := 'Implementation -; form is [":",.,=exname] or body = impname => nil -; exports := -; form is [":",a,b] => -; form := a -; [["MDEF",exname,'(NIL),'(NIL),b]] -; nil -; [op,:argl] := form -;-- decls := [x for x in argl | x is [":",:.]] -;-- form := [op,:[(a is [":",b,t] => b; a) for a in argl]] -;-- $DEFdepth := $DEFdepth - 1 -; formatWHERE(["where", -; ["DEF",[":",form,exname],[nil for x in form],sclist,impname], -; ['PROGN,:exports,["MDEF",impname,'(NIL),'(NIL),body]]]) -; $insideTypeExpression: local := true -; body := formatDeftran(body,false) -; body is ["add",a,:b] => formatAddDef(form,a,b) -;--body is ["with",a,:b] => formatWithDef(form,a,b) -; tryBreakNB(format form and format " == ",body,"==","Led") - -(DEFUN |formatDEF0| (G167151 |$DEFdepth|) - (DECLARE (SPECIAL |$DEFdepth|)) - (PROG (|$comments| |$abb| |$insideDEF| |$insideTypeExpression| - |tlist| |sclist| |con| |condoc| |u| |v| |exname| |impname| - |ISTMP#2| |form| |exports| |op| |argl| |body| |ISTMP#1| |a| - |b|) - (DECLARE (SPECIAL |$comments| |$abb| |$insideDEF| |$numberOfSpills| - |$insideTypeExpression| |$form|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G167151) 'DEF) (CAR G167151))) - (SPADLET |form| (CADR G167151)) - (SPADLET |tlist| (CADDR G167151)) - (SPADLET |sclist| (CADDDR G167151)) - (SPADLET |body| (CAR (CDDDDR G167151))) - (COND - ((NULL (MEMQ (KAR |form|) '(|Exports| |Implementation|))) - (SPADLET |$form| - (COND - ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - 'T)))) - |a|) - ('T |form|))))) - (SPADLET |con| (|opOf| |$form|)) - (SPADLET |$comments| - (MSUBST '$ '% (GETDATABASE |con| 'DOCUMENTATION))) - (SPADLET |$abb| (|constructor?| (|opOf| |$form|))) - (COND - ((> 2 |$DEFdepth|) - (SPADLET |condoc| - (OR (AND (SPADLET |u| - (LASSOC '|constructor| - |$comments|)) - (KDR (KAR |u|))) - (CONS "" NIL))) - (SPADLET |$numberOfSpills| (SPADDIFFERENCE 1)) - (|consComments| |condoc| "+++ "))) - (SPADLET |form| (|formatDeftranForm| |form| |tlist|)) - (SPADLET |u| - (CONS 'DEF - (CONS |form| - (CONS |tlist| - (CONS |sclist| - (CONS |body| NIL)))))) - (COND - ((SPADLET |v| (|formatDEF1| |u|)) |v|) - ('T (SPADLET |$insideDEF| (> |$DEFdepth| 1)) - (COND - ((EQL |$DEFdepth| 1) (SPADLET |exname| '|Exports|) - (SPADLET |impname| '|Implementation|) - (COND - ((OR (AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (EQUAL (QCAR |ISTMP#2|) - |exname|)))))) - (BOOT-EQUAL |body| |impname|)) - NIL) - ('T - (SPADLET |exports| - (COND - ((AND (PAIRP |form|) - (EQ (QCAR |form|) '|:|) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |form| |a|) - (CONS (CONS 'MDEF - (CONS |exname| - (CONS '(NIL) - (CONS '(NIL) (CONS |b| NIL))))) - NIL)) - ('T NIL))) - (SPADLET |op| (CAR |form|)) - (SPADLET |argl| (CDR |form|)) - (|formatWHERE| - (CONS '|where| - (CONS (CONS 'DEF - (CONS - (CONS '|:| - (CONS |form| - (CONS |exname| NIL))) - (CONS - (PROG (G167193) - (SPADLET G167193 NIL) - (RETURN - (DO - ((G167198 |form| - (CDR G167198)) - (|x| NIL)) - ((OR (ATOM G167198) - (PROGN - (SETQ |x| - (CAR G167198)) - NIL)) - (NREVERSE0 G167193)) - (SEQ - (EXIT - (SETQ G167193 - (CONS NIL G167193))))))) - (CONS |sclist| - (CONS |impname| NIL))))) - (CONS - (CONS 'PROGN - (APPEND |exports| - (CONS - (CONS 'MDEF - (CONS |impname| - (CONS '(NIL) - (CONS '(NIL) - (CONS |body| NIL))))) - NIL))) - NIL))))))) - ('T (SPADLET |$insideTypeExpression| 'T) - (SPADLET |body| (|formatDeftran| |body| NIL)) - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |b| (QCDR |ISTMP#1|)) - 'T)))) - (|formatAddDef| |form| |a| |b|)) - ('T - (|tryBreakNB| - (AND (|format| |form|) (|format| '| == |)) - |body| '== '|Led|)))))))))))) - -;formatDEF1 ["DEF",form,tlist,b,body] == -; $insideDEF: local := $DEFdepth > 1 -; $insideEXPORTS: local := form = 'Exports -; $insideTypeExpression: local := true -; form := formatDeftran(form,false) -; body := formatDeftran(body,false) -; ---------> terrible, hideous, but temporary, hack -; if not $insideDEF and body is ['SEQ,:.] then body := ["add", body] -; prefix := (opOf tlist = 'Category => "define "; nil) -; body is ["add",a,b] => formatAddDef(form,a,b) -; body is ["with",a,:b] => formatWithDef(form,a,b,"==",prefix) -; prefix => -; tryBreak(format prefix and format form and format " == ",body,"==","Led") -; tryBreak(format form and format " == ",body,"==","Led") - -(DEFUN |formatDEF1| (G167277) - (PROG (|$insideDEF| |$insideEXPORTS| |$insideTypeExpression| |tlist| - |form| |body| |prefix| |ISTMP#2| |ISTMP#1| |a| |b|) - (DECLARE (SPECIAL |$insideDEF| |$insideEXPORTS| |$DEFdepth| - |$insideTypeExpression|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167277) 'DEF) (CAR G167277))) - (SPADLET |form| (CADR G167277)) - (SPADLET |tlist| (CADDR G167277)) - (SPADLET |b| (CADDDR G167277)) - (SPADLET |body| (CAR (CDDDDR G167277))) - (SPADLET |$insideDEF| (> |$DEFdepth| 1)) - (SPADLET |$insideEXPORTS| (BOOT-EQUAL |form| '|Exports|)) - (SPADLET |$insideTypeExpression| 'T) - (SPADLET |form| (|formatDeftran| |form| NIL)) - (SPADLET |body| (|formatDeftran| |body| NIL)) - (COND - ((AND (NULL |$insideDEF|) (PAIRP |body|) - (EQ (QCAR |body|) 'SEQ)) - (SPADLET |body| (CONS '|add| (CONS |body| NIL))))) - (SPADLET |prefix| - (COND - ((BOOT-EQUAL (|opOf| |tlist|) '|Category|) - '|define |) - ('T NIL))) - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) '|add|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (|formatAddDef| |form| |a| |b|)) - ((AND (PAIRP |body|) (EQ (QCAR |body|) '|with|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |b| (QCDR |ISTMP#1|)) - 'T)))) - (|formatWithDef| |form| |a| |b| '== |prefix|)) - (|prefix| - (|tryBreak| - (AND (|format| |prefix|) (|format| |form|) - (|format| '| == |)) - |body| '== '|Led|)) - ('T - (|tryBreak| (AND (|format| |form|) (|format| '| == |)) - |body| '== '|Led|))))))) - -;formatDefForm(form,:options) == -; prefix := IFCAR options -; $insideTypeExpression : local := true -; form is [":",form1,["with",a,:b]] => formatWithDef(form1,a,b,":",prefix) -; prefix => format prefix and format form -; format form - -(DEFUN |formatDefForm| (&REST G167392 &AUX |options| |form|) - (DSETQ (|form| . |options|) G167392) - (PROG (|$insideTypeExpression| |prefix| |ISTMP#1| |form1| |ISTMP#2| - |ISTMP#3| |ISTMP#4| |a| |b|) - (DECLARE (SPECIAL |$insideTypeExpression|)) - (RETURN - (PROGN - (SPADLET |prefix| (IFCAR |options|)) - (SPADLET |$insideTypeExpression| 'T) - (COND - ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |form1| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) '|with|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |a| - (QCAR |ISTMP#4|)) - (SPADLET |b| - (QCDR |ISTMP#4|)) - 'T)))))))))) - (|formatWithDef| |form1| |a| |b| '|:| |prefix|)) - (|prefix| (AND (|format| |prefix|) (|format| |form|))) - ('T (|format| |form|))))))) - -;formatAddDef(form,a,b) == -; $insideCAPSULE : local := true -; $insideDEF : local := false -; formatDefForm form or return nil -; $marginStack := [0] -; $m := $c := 0 -; $insideTypeExpression : local := false -; cap := (b => b; "") -; tryBreakNB(newLine() and format "== " and formatLeft("format",a,"add","Led") -; and format " add ", cap,"add","Led") - -(DEFUN |formatAddDef| (|form| |a| |b|) - (PROG (|$insideCAPSULE| |$insideDEF| |$insideTypeExpression| |cap|) - (DECLARE (SPECIAL |$insideCAPSULE| |$insideDEF| |$c| |$m| - |$insideTypeExpression| |$marginStack|)) - (RETURN - (PROGN - (SPADLET |$insideCAPSULE| 'T) - (SPADLET |$insideDEF| NIL) - (OR (|formatDefForm| |form|) (RETURN NIL)) - (SPADLET |$marginStack| (CONS 0 NIL)) - (SPADLET |$m| (SPADLET |$c| 0)) - (SPADLET |$insideTypeExpression| NIL) - (SPADLET |cap| (COND (|b| |b|) ('T '||))) - (|tryBreakNB| - (AND (|newLine|) (|format| '|== |) - (|formatLeft| '|format| |a| '|add| '|Led|) - (|format| '| add |)) - |cap| '|add| '|Led|))))) - -;formatWithDef(form,a,b,separator,:options) == -; prefix := IFCAR options -; $insideEXPORTS : local := true -; $insideCAPSULE : local := true -; $insideDEF : local := false -; $insideTypeExpression : local := false -; a1 := formatWithKillSEQ a -; b => tryBreakNB(formatDefForm(form,prefix) and format separator and format " with " and formatLeft("format",a,"with","Led") -; and format " with ",first b,"with","Led") -; tryBreak(formatDefForm(form,prefix) and format separator and format " with ",a1,"with","Nud") - -(DEFUN |formatWithDef| - (&REST G167429 &AUX |options| |separator| |b| |a| |form|) - (DSETQ (|form| |a| |b| |separator| . |options|) G167429) - (PROG (|$insideEXPORTS| |$insideCAPSULE| |$insideDEF| - |$insideTypeExpression| |prefix| |a1|) - (DECLARE (SPECIAL |$insideEXPORTS| |$insideCAPSULE| |$insideDEF| - |$insideTypeExpression|)) - (RETURN - (PROGN - (SPADLET |prefix| (IFCAR |options|)) - (SPADLET |$insideEXPORTS| 'T) - (SPADLET |$insideCAPSULE| 'T) - (SPADLET |$insideDEF| NIL) - (SPADLET |$insideTypeExpression| NIL) - (SPADLET |a1| (|formatWithKillSEQ| |a|)) - (COND - (|b| (|tryBreakNB| - (AND (|formatDefForm| |form| |prefix|) - (|format| |separator|) (|format| '| with |) - (|formatLeft| '|format| |a| '|with| '|Led|) - (|format| '| with |)) - (CAR |b|) '|with| '|Led|)) - ('T - (|tryBreak| - (AND (|formatDefForm| |form| |prefix|) - (|format| |separator|) (|format| '| with |)) - |a1| '|with| '|Nud|))))))) - -;formatWithKillSEQ x == -; x is ['SEQ,['exit,.,y]] => ['BRACE, y] -; x - -(DEFUN |formatWithKillSEQ| (|x|) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| |y|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) '|exit|) - (PROGN - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#4|)) - 'T)))))))))) - (CONS 'BRACE (CONS |y| NIL))) - ('T |x|))))) - -;formatBrace ['BRACE, x] == format "{" and format x and format "}" - -(DEFUN |formatBrace| (G167467) - (PROG (|x|) - (RETURN - (PROGN - (SPADLET |x| (CADR G167467)) - (AND (|format| '{) (|format| |x|) (|format| '})))))) - -;formatWith ["with",a,:b] == -; $pilesAreOkHere: local := true -; b => -; tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") -; tryBreak(format "with ",a,"with","Nud") - -(DEFUN |formatWith| (G167479) - (PROG (|$pilesAreOkHere| |a| |b|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167479) '|with|) (CAR G167479))) - (SPADLET |a| (CADR G167479)) - (SPADLET |b| (CDDR G167479)) - (SPADLET |$pilesAreOkHere| 'T) - (COND - (|b| (|tryBreakNB| - (AND (|formatLeft| '|format| |a| '|with| '|Led|) - (|format| '| with |)) - (CAR |b|) '|with| '|Led|)) - ('T (|tryBreak| (|format| '|with |) |a| '|with| '|Nud|))))))) - -;formatWithDefault ["withDefault",a,b] == -; if a is ['with,:init,["SEQ",:items,["exit",.,x]]] then -; part2 := ["SEQ",:items,x,["exit", nil,["defaultDefs", b]]] -; if IFCAR init then -; a:= IFCAR init -; b:= [part2] -; else -; a := part2 -; b := nil -; $pilesAreOkHere: local := true -; b => -; tryBreakNB(formatLeft("format",a,"with","Led") and format " with ",first b,"with","Led") -; tryBreak(format "with ",a,"with","Nud") - -(DEFUN |formatWithDefault| (G167580) - (PROG (|$pilesAreOkHere| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| - |ISTMP#5| |ISTMP#6| |ISTMP#7| |ISTMP#8| |x| |items| |init| - |part2| |a| |b|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167580) '|withDefault|) (CAR G167580))) - (SPADLET |a| (CADR G167580)) - (SPADLET |b| (CADDR G167580)) - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|with|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) 'SEQ) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |ISTMP#5| - (REVERSE |ISTMP#4|)) - 'T) - (PAIRP |ISTMP#5|) - (PROGN - (SPADLET |ISTMP#6| - (QCAR |ISTMP#5|)) - (AND (PAIRP |ISTMP#6|) - (EQ (QCAR |ISTMP#6|) '|exit|) - (PROGN - (SPADLET |ISTMP#7| - (QCDR |ISTMP#6|)) - (AND (PAIRP |ISTMP#7|) - (PROGN - (SPADLET |ISTMP#8| - (QCDR |ISTMP#7|)) - (AND (PAIRP |ISTMP#8|) - (EQ (QCDR |ISTMP#8|) NIL) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#8|)) - 'T))))))) - (PROGN - (SPADLET |items| - (QCDR |ISTMP#5|)) - 'T) - (PROGN - (SPADLET |items| - (NREVERSE |items|)) - 'T))))) - (PROGN (SPADLET |init| (QCDR |ISTMP#2|)) 'T) - (PROGN (SPADLET |init| (NREVERSE |init|)) 'T)))) - (SPADLET |part2| - (CONS 'SEQ - (APPEND |items| - (CONS |x| - (CONS - (CONS '|exit| - (CONS NIL - (CONS - (CONS '|defaultDefs| - (CONS |b| NIL)) - NIL))) - NIL))))) - (COND - ((IFCAR |init|) (SPADLET |a| (IFCAR |init|)) - (SPADLET |b| (CONS |part2| NIL))) - ('T (SPADLET |a| |part2|) (SPADLET |b| NIL))))) - (SPADLET |$pilesAreOkHere| 'T) - (COND - (|b| (|tryBreakNB| - (AND (|formatLeft| '|format| |a| '|with| '|Led|) - (|format| '| with |)) - (CAR |b|) '|with| '|Led|)) - ('T (|tryBreak| (|format| '|with |) |a| '|with| '|Nud|))))))) - -;formatDefaultDefs ["default",a, :b] == -; $insideCAPSULE : local := true -; $insideDEF : local := false -; $insideTypeExpression : local := false -; b => -; tryBreak(formatLeft("format",a,"default","Led") and -; format " default ", first b,"default","Led") -; tryBreak(format "default ",a,"default","Nud") - -(DEFUN |formatDefaultDefs| (G167644) - (PROG (|$insideCAPSULE| |$insideDEF| |$insideTypeExpression| |a| |b|) - (DECLARE (SPECIAL |$insideCAPSULE| |$insideDEF| - |$insideTypeExpression|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167644) '|default|) (CAR G167644))) - (SPADLET |a| (CADR G167644)) - (SPADLET |b| (CDDR G167644)) - (SPADLET |$insideCAPSULE| 'T) - (SPADLET |$insideDEF| NIL) - (SPADLET |$insideTypeExpression| NIL) - (COND - (|b| (|tryBreak| - (AND (|formatLeft| '|format| |a| '|default| '|Led|) - (|format| '| default |)) - (CAR |b|) '|default| '|Led|)) - ('T - (|tryBreak| (|format| '|default |) |a| '|default| '|Nud|))))))) - -;--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace -;formatAdd ["add",a,:b] == -; $insideCAPSULE : local := true -; $insideDEF : local := false -; $insideTypeExpression : local := false -; b => -; tryBreakNB(formatLeft("format",a,"and","Led") and -; format " and ", first b,"and","Led") -; tryBreakNB(format "add ",a,"and","Nud") - -(DEFUN |formatAdd| (G167670) - (PROG (|$insideCAPSULE| |$insideDEF| |$insideTypeExpression| |a| |b|) - (DECLARE (SPECIAL |$insideCAPSULE| |$insideDEF| - |$insideTypeExpression|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167670) '|add|) (CAR G167670))) - (SPADLET |a| (CADR G167670)) - (SPADLET |b| (CDDR G167670)) - (SPADLET |$insideCAPSULE| 'T) - (SPADLET |$insideDEF| NIL) - (SPADLET |$insideTypeExpression| NIL) - (COND - (|b| (|tryBreakNB| - (AND (|formatLeft| '|format| |a| '|and| '|Led|) - (|format| '| and |)) - (CAR |b|) '|and| '|Led|)) - ('T (|tryBreakNB| (|format| '|add |) |a| '|and| '|Nud|))))))) - -;--format "add " and formatRight("formatPreferPile",a,"add","Nud") --==> brace -;formatMDEF ["MDEF",form,.,.,body] == -; form is '(Rep) => formatDEF ["DEF",form,.,.,body] -; $insideEXPORTS: local := form = 'Exports -; $insideTypeExpression: local := true -; body := formatDeftran(body,false) -; name := opOf form -; tryBreakNB(format name and format " ==> ",body,"==","Led") -; and ($insideCAPSULE and $c or format(";")) - -(DEFUN |formatMDEF| (G167696) - (PROG (|$insideEXPORTS| |$insideTypeExpression| |form| |body| |name|) - (DECLARE (SPECIAL |$insideEXPORTS| |$insideTypeExpression| - |$insideCAPSULE| |$c|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167696) 'MDEF) (CAR G167696))) - (SPADLET |form| (CADR G167696)) - (SPADLET |body| (CAR (CDDDDR G167696))) - (COND - ((EQUAL |form| '(|Rep|)) - (|formatDEF| - (CONS 'DEF - (CONS |form| - (CONS '|.| (CONS '|.| (CONS |body| NIL))))))) - ('T (SPADLET |$insideEXPORTS| (BOOT-EQUAL |form| '|Exports|)) - (SPADLET |$insideTypeExpression| 'T) - (SPADLET |body| (|formatDeftran| |body| NIL)) - (SPADLET |name| (|opOf| |form|)) - (AND (|tryBreakNB| - (AND (|format| |name|) (|format| '| ==> |)) |body| - '== '|Led|) - (OR (AND |$insideCAPSULE| |$c|) (|format| '|;|))))))))) - -;insideCat() == $insideCategoryIfTrue and not $insideFunctorIfTrue -; or $noColonDeclaration - -(DEFUN |insideCat| () - (declare (special |$noColonDeclaration| |$insideCategoryIfTrue| - |$insideFunctorIfTrue|)) - (OR (AND |$insideCategoryIfTrue| (NULL |$insideFunctorIfTrue|)) - |$noColonDeclaration|)) - -;formatImport ["import",a] == -; addFieldNames a -; addFieldNames macroExpand(a,$e) -; format "import from " and formatLocal1 a - -(DEFUN |formatImport| (G167724) - (PROG (|a|) - (declare (special |$e|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167724) '|import|) (CAR G167724))) - (SPADLET |a| (CADR G167724)) - (|addFieldNames| |a|) - (|addFieldNames| (|macroExpand| |a| |$e|)) - (AND (|format| '|import from |) (|formatLocal1| |a|)))))) - -;addFieldNames a == -; a is [op,:r] and MEMQ(op,'(Record Union)) => -; $fieldNames := UNION(getFieldNames r,$fieldNames) -; a is ['List,:b] => addFieldNames b -; nil - -(DEFUN |addFieldNames| (|a|) - (PROG (|op| |r| |b|) - (declare (special |$fieldNames|)) - (RETURN - (COND - ((AND (PAIRP |a|) - (PROGN - (SPADLET |op| (QCAR |a|)) - (SPADLET |r| (QCDR |a|)) - 'T) - (MEMQ |op| '(|Record| |Union|))) - (SPADLET |$fieldNames| - (|union| (|getFieldNames| |r|) |$fieldNames|))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|List|) - (PROGN (SPADLET |b| (QCDR |a|)) 'T)) - (|addFieldNames| |b|)) - ('T NIL))))) - -;getFieldNames r == -; r is [[":",a,b],:r] => [a,:getFieldNames r] -; nil - -(DEFUN |getFieldNames| (|r|) - (PROG (|ISTMP#1| |ISTMP#2| |a| |ISTMP#3| |b|) - (RETURN - (COND - ((AND (PAIRP |r|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |r|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCAR |ISTMP#1|) '|:|) - (PROGN - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#3|)) - 'T))))))) - (PROGN (SPADLET |r| (QCDR |r|)) 'T)) - (CONS |a| (|getFieldNames| |r|))) - ('T NIL))))) - -;formatLocal ["local",a] == format "local " and formatLocal1 a - -(DEFUN |formatLocal| (G167783) - (PROG (|a|) - (RETURN - (PROGN - (COND ((EQ (CAR G167783) '|local|) (CAR G167783))) - (SPADLET |a| (CADR G167783)) - (AND (|format| '|local |) (|formatLocal1| |a|)))))) - -;formatLocal1 a == -; $insideTypeExpression: local := true -; format a - -(DEFUN |formatLocal1| (|a|) - (PROG (|$insideTypeExpression|) - (DECLARE (SPECIAL |$insideTypeExpression|)) - (RETURN - (PROGN (SPADLET |$insideTypeExpression| 'T) (|format| |a|))))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/pspad2.lisp.pamphlet b/src/interp/pspad2.lisp.pamphlet deleted file mode 100644 index 335518f..0000000 --- a/src/interp/pspad2.lisp.pamphlet +++ /dev/null @@ -1,3212 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp pspad2.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -<<*>>= -(IN-PACKAGE "BOOT" ) - -;--====================================================================== -;-- Constructor Transformation Functions -;--====================================================================== -;formatDeftranForm(form,tlist) == -; [ttype,:atypeList] := tlist -; if form is [":",f,t] then -; form := f -; ttype := t -; if form is ['elt,a,b] then ----> a.b ====> apply(b,a) -; form := -; isTypeProbably? a => -; atypeList := REVERSE atypeList -; ["$$", b, a] -; ["apply",a, b] -; op := KAR form -; argl := KDR form -; if or/[t for t in atypeList] then -; form := [op,:[(t => [":",a,t]; a) for a in argl for t in atypeList]] -; if ttype then form := [":",form,ttype] -; form - -(DEFUN |formatDeftranForm| (|form| |tlist|) - (PROG (|f| |t| |ttype| |ISTMP#1| |a| |ISTMP#2| |b| |atypeList| |op| - |argl|) - (RETURN - (SEQ (PROGN - (SPADLET |ttype| (CAR |tlist|)) - (SPADLET |atypeList| (CDR |tlist|)) - (COND - ((AND (PAIRP |form|) (EQ (QCAR |form|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |f| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |form| |f|) (SPADLET |ttype| |t|))) - (COND - ((AND (PAIRP |form|) (EQ (QCAR |form|) '|elt|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |form|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |form| - (COND - ((|isTypeProbably?| |a|) - (SPADLET |atypeList| (REVERSE |atypeList|)) - (CONS '$$ (CONS |b| (CONS |a| NIL)))) - ('T - (CONS '|apply| (CONS |a| (CONS |b| NIL)))))))) - (SPADLET |op| (KAR |form|)) - (SPADLET |argl| (KDR |form|)) - (COND - ((PROG (G166097) - (SPADLET G166097 NIL) - (RETURN - (DO ((G166103 NIL G166097) - (G166104 |atypeList| (CDR G166104)) - (|t| NIL)) - ((OR G166103 (ATOM G166104) - (PROGN (SETQ |t| (CAR G166104)) NIL)) - G166097) - (SEQ (EXIT (SETQ G166097 (OR G166097 |t|))))))) - (SPADLET |form| - (CONS |op| - (PROG (G166116) - (SPADLET G166116 NIL) - (RETURN - (DO - ((G166122 |argl| (CDR G166122)) - (|a| NIL) - (G166123 |atypeList| - (CDR G166123)) - (|t| NIL)) - ((OR (ATOM G166122) - (PROGN - (SETQ |a| (CAR G166122)) - NIL) - (ATOM G166123) - (PROGN - (SETQ |t| (CAR G166123)) - NIL)) - (NREVERSE0 G166116)) - (SEQ - (EXIT - (SETQ G166116 - (CONS - (COND - (|t| - (CONS '|:| - (CONS |a| (CONS |t| NIL)))) - ('T |a|)) - G166116))))))))))) - (COND - (|ttype| (SPADLET |form| - (CONS '|:| - (CONS |form| (CONS |ttype| NIL)))))) - |form|))))) - -;formatDeftran(u,SEQflag) == -; u is ['Join,:x] => formatDeftranJoin(u,SEQflag) -; u is ['CATEGORY,kind,:l,x] => formatDeftran(['with,['SEQ,:l,['exit,n,x]]],SEQflag) -; u is ['CAPSULE,:l,x] => formatDeftranCapsule(l,x,SEQflag) -; u is [op,:.] and MEMQ(op,'(rep per)) => formatDeftranRepper(u,SEQflag) -; u is [op,:.] and MEMQ(op,'(_: _:_: _pretend _@)) => -; formatDeftranColon(u,SEQflag) -; u is ['PROGN,:l,x] => formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) -; u is ['SEQ,:l,[.,n,x]] => -; v := [:l,x] -; a := "APPEND"/[formatDeftranSEQ(x,true) for x in l] -; b := formatDeftranSEQ(x,false) -; if b is [:.,c] and c = '(void) then b := DROP(-1, b) -; [:m,y] := [:a,:b] -; ['SEQ,:m,['exit,n,y]] -;-- u is ['not,arg] and (op := LASSOC(KAR arg,'((_= . _^_=) (_< . _>_=)))) => -;-- formatDeftran([op,:CDR arg],nil) -; u is ["^",a] => formatDeftran(['not,a],SEQflag) -; u is ["exquo",a,b] => formatDeftran(['xquo,a,b],SEQflag) -; u is ['IF,a,b,c] => -; a := formatDeftran(a,nil) -; b := formatDeftran(b,nil) -; c := formatDeftran(c,nil) -; null SEQflag and $insideDEF => -; [:y,last] := formatDeftranIf(a,b,c) -; ['SEQ,:y,['exit,1,last]] -; ['IF,a,b,c] -; u is ['Union,:argl] => -; ['Union,:[x for a in argl -; | x := (STRINGP a => [":",INTERN a,'Branch]; formatDeftran(a,nil))]] -; u is [op,:itl,body] and MEMQ(op,'(REPEAT COLLECT)) and -; ([nitl,:nbody] := formatDeftranREPEAT(itl,body)) => -; formatDeftran([op,:nitl,nbody],SEQflag) -; u is [":",a,b] => [":",formatDeftran(a,nil),formatDeftran(markMacroTran(b),nil)] -; u is ["DEF",:.] => formatCapsuleFunction(u) -; u is [op,:argl]=>[formatDeftran(op,nil),:[formatDeftran(x,nil) for x in argl]] -; u = 'nil => 'empty -; u - -(DEFUN |formatDeftran| (|u| |SEQflag|) - (PROG (|kind| |ISTMP#4| |n| |ISTMP#5| |l| |v| |m| |ISTMP#3| |c| - |LETTMP#2| |last| |y| |x| |body| |itl| |LETTMP#1| - |nitl| |nbody| |ISTMP#1| |a| |ISTMP#2| |b| |op| |argl|) - (declare (special |$insideDEF|)) - (RETURN - (SEQ (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Join|) - (PROGN (SPADLET |x| (QCDR |u|)) 'T)) - (|formatDeftranJoin| |u| |SEQflag|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |kind| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (REVERSE |ISTMP#2|)) - 'T) - (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#3|)) - (SPADLET |l| (QCDR |ISTMP#3|)) - 'T) - (PROGN - (SPADLET |l| (NREVERSE |l|)) - 'T)))))) - (|formatDeftran| - (CONS '|with| - (CONS (CONS 'SEQ - (APPEND |l| - (CONS - (CONS '|exit| - (CONS |n| (CONS |x| NIL))) - NIL))) - NIL)) - |SEQflag|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'CAPSULE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#2|)) - (SPADLET |l| (QCDR |ISTMP#2|)) - 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) - (|formatDeftranCapsule| |l| |x| |SEQflag|)) - ((AND (PAIRP |u|) (PROGN (SPADLET |op| (QCAR |u|)) 'T) - (MEMQ |op| '(|rep| |per|))) - (|formatDeftranRepper| |u| |SEQflag|)) - ((AND (PAIRP |u|) (PROGN (SPADLET |op| (QCAR |u|)) 'T) - (MEMQ |op| '(|:| |::| |pretend| @))) - (|formatDeftranColon| |u| |SEQflag|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'PROGN) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#2|)) - (SPADLET |l| (QCDR |ISTMP#2|)) - 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) - (|formatDeftran| - (CONS 'SEQ - (APPEND |l| - (CONS (CONS '|exit| - (CONS 1 (CONS |x| NIL))) - NIL))) - |SEQflag|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |x| (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN (SPADLET |l| (QCDR |ISTMP#2|)) 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) - (SPADLET |v| (APPEND |l| (CONS |x| NIL))) - (SPADLET |a| - (PROG (G166380) - (SPADLET G166380 NIL) - (RETURN - (DO ((G166385 |l| (CDR G166385)) - (|x| NIL)) - ((OR (ATOM G166385) - (PROGN - (SETQ |x| (CAR G166385)) - NIL)) - G166380) - (SEQ (EXIT (SETQ G166380 - (APPEND G166380 - (|formatDeftranSEQ| |x| 'T))))))))) - (SPADLET |b| (|formatDeftranSEQ| |x| NIL)) - (COND - ((AND (PAIRP |b|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |b|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN (SPADLET |c| (QCAR |ISTMP#1|)) 'T) - (BOOT-EQUAL |c| '(|void|))) - (SPADLET |b| (DROP (SPADDIFFERENCE 1) |b|)))) - (SPADLET |LETTMP#1| (APPEND |a| |b|)) - (SPADLET |LETTMP#2| (REVERSE |LETTMP#1|)) - (SPADLET |y| (CAR |LETTMP#2|)) - (SPADLET |m| (NREVERSE (CDR |LETTMP#2|))) - (CONS 'SEQ - (APPEND |m| - (CONS (CONS '|exit| - (CONS |n| (CONS |y| NIL))) - NIL)))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '^) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |a| (QCAR |ISTMP#1|)) 'T)))) - (|formatDeftran| (CONS '|not| (CONS |a| NIL)) |SEQflag|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|exquo|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (|formatDeftran| (CONS '|xquo| (CONS |a| (CONS |b| NIL))) - |SEQflag|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T)))))))) - (SPADLET |a| (|formatDeftran| |a| NIL)) - (SPADLET |b| (|formatDeftran| |b| NIL)) - (SPADLET |c| (|formatDeftran| |c| NIL)) - (COND - ((AND (NULL |SEQflag|) |$insideDEF|) - (SPADLET |LETTMP#1| (|formatDeftranIf| |a| |b| |c|)) - (SPADLET |LETTMP#2| (REVERSE |LETTMP#1|)) - (SPADLET |last| (CAR |LETTMP#2|)) - (SPADLET |y| (NREVERSE (CDR |LETTMP#2|))) - (CONS 'SEQ - (APPEND |y| - (CONS (CONS '|exit| - (CONS 1 (CONS |last| NIL))) - NIL)))) - ('T (CONS 'IF (CONS |a| (CONS |b| (CONS |c| NIL))))))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|Union|) - (PROGN (SPADLET |argl| (QCDR |u|)) 'T)) - (CONS '|Union| - (PROG (G166396) - (SPADLET G166396 NIL) - (RETURN - (DO ((G166402 |argl| (CDR G166402)) - (|a| NIL)) - ((OR (ATOM G166402) - (PROGN - (SETQ |a| (CAR G166402)) - NIL)) - (NREVERSE0 G166396)) - (SEQ (EXIT (COND - ((SPADLET |x| - (COND - ((STRINGP |a|) - (CONS '|:| - (CONS (INTERN |a|) - (CONS '|Branch| NIL)))) - ('T - (|formatDeftran| |a| NIL)))) - (SETQ G166396 - (CONS |x| G166396))))))))))) - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |body| (QCAR |ISTMP#2|)) - (SPADLET |itl| (QCDR |ISTMP#2|)) - 'T) - (PROGN (SPADLET |itl| (NREVERSE |itl|)) 'T))) - (MEMQ |op| '(REPEAT COLLECT)) - (PROGN - (SPADLET |LETTMP#1| - (|formatDeftranREPEAT| |itl| |body|)) - (SPADLET |nitl| (CAR |LETTMP#1|)) - (SPADLET |nbody| (CDR |LETTMP#1|)) - |LETTMP#1|)) - (|formatDeftran| - (CONS |op| (APPEND |nitl| (CONS |nbody| NIL))) - |SEQflag|)) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|:|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (CONS '|:| - (CONS (|formatDeftran| |a| NIL) - (CONS (|formatDeftran| (|markMacroTran| |b|) - NIL) - NIL)))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'DEF)) - (|formatCapsuleFunction| |u|)) - ((AND (PAIRP |u|) - (PROGN - (SPADLET |op| (QCAR |u|)) - (SPADLET |argl| (QCDR |u|)) - 'T)) - (CONS (|formatDeftran| |op| NIL) - (PROG (G166412) - (SPADLET G166412 NIL) - (RETURN - (DO ((G166417 |argl| (CDR G166417)) - (|x| NIL)) - ((OR (ATOM G166417) - (PROGN - (SETQ |x| (CAR G166417)) - NIL)) - (NREVERSE0 G166412)) - (SEQ (EXIT (SETQ G166412 - (CONS (|formatDeftran| |x| NIL) - G166412))))))))) - ((BOOT-EQUAL |u| '|nil|) '|empty|) - ('T |u|)))))) - -;formatCapsuleFunction ["DEF",form,tlist,b,body] == -; $insideDEF : local := true -; ["DEF", formatDeftran(form,nil),tlist,b,formatDeftran(body,nil)] - -(DEFUN |formatCapsuleFunction| (G166505) - (PROG (|$insideDEF| |form| |tlist| |b| |body|) - (DECLARE (SPECIAL |$insideDEF|)) - (RETURN - (PROGN - (COND ((EQ (CAR G166505) 'DEF) (CAR G166505))) - (SPADLET |form| (CADR G166505)) - (SPADLET |tlist| (CADDR G166505)) - (SPADLET |b| (CADDDR G166505)) - (SPADLET |body| (CAR (CDDDDR G166505))) - (SPADLET |$insideDEF| 'T) - (CONS 'DEF - (CONS (|formatDeftran| |form| NIL) - (CONS |tlist| - (CONS |b| - (CONS (|formatDeftran| |body| NIL) NIL))))))))) - -;formatDeftranCapsule(l,x,SEQflag) == -; $insideCAPSULE: local := true -; formatDeftran(['SEQ,:l,['exit,1,x]],SEQflag) - -(DEFUN |formatDeftranCapsule| (|l| |x| |SEQflag|) - (PROG (|$insideCAPSULE|) - (DECLARE (SPECIAL |$insideCAPSULE|)) - (RETURN - (PROGN - (SPADLET |$insideCAPSULE| 'T) - (|formatDeftran| - (CONS 'SEQ - (APPEND |l| - (CONS (CONS '|exit| (CONS 1 (CONS |x| NIL))) - NIL))) - |SEQflag|))))) - -;formatDeftranRepper([op,a],SEQflag) == -; a is [op1,b] and MEMQ(op1,'(rep per)) => -; op = op1 => formatDeftran(a,SEQflag) -; formatDeftran(b,SEQflag) -; a is ["::",b,t] => -; b := formatDeftran(b,SEQflag) -; t := formatDeftran(t,SEQflag) -; a := ["::",b,t] -; op = 'per and t = "$" or op = 'rep and t = 'Rep => a -; [op,a] -; a is ['SEQ,:r] => ['SEQ,:[formatSeqRepper(op,x) for x in r]] -; a is ['IF,p,b,c] => -; formatDeftran(['IF,p,[op,b],[op, c]], SEQflag) -; a is ['LET,a,b] => formatDeftran(['LET,a,[op,b]],SEQflag) -; a is ['not,[op,a,b]] and (op1 := LASSOC(op,$pspadRelationAlist)) => -; formatDeftran [op1,a,b] -; a is ['return,n,r] => -; MEMQ(opOf r,'(true false)) => a -; ['return,n,[op,formatDeftran(r,SEQflag)]] -; a is ['error,:.] => a -; [op,formatDeftran(a,SEQflag)] - -(DEFUN |formatDeftranRepper| (G166678 |SEQflag|) - (PROG (|t| |p| |c| |op| |ISTMP#3| |a| |ISTMP#4| |b| |op1| |ISTMP#1| - |n| |ISTMP#2| |r|) - (declare (special |$pspadRelationAlist|)) - (RETURN - (SEQ (PROGN - (SPADLET |op| (CAR G166678)) - (SPADLET |a| (CADR G166678)) - (COND - ((AND (PAIRP |a|) - (PROGN - (SPADLET |op1| (QCAR |a|)) - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) 'T))) - (MEMQ |op1| '(|rep| |per|))) - (COND - ((BOOT-EQUAL |op| |op1|) - (|formatDeftran| |a| |SEQflag|)) - ('T (|formatDeftran| |b| |SEQflag|)))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|::|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t| (QCAR |ISTMP#2|)) - 'T)))))) - (SPADLET |b| (|formatDeftran| |b| |SEQflag|)) - (SPADLET |t| (|formatDeftran| |t| |SEQflag|)) - (SPADLET |a| (CONS '|::| (CONS |b| (CONS |t| NIL)))) - (COND - ((OR (AND (BOOT-EQUAL |op| '|per|) - (BOOT-EQUAL |t| '$)) - (AND (BOOT-EQUAL |op| '|rep|) - (BOOT-EQUAL |t| '|Rep|))) - |a|) - ('T (CONS |op| (CONS |a| NIL))))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'SEQ) - (PROGN (SPADLET |r| (QCDR |a|)) 'T)) - (CONS 'SEQ - (PROG (G166741) - (SPADLET G166741 NIL) - (RETURN - (DO ((G166746 |r| (CDR G166746)) - (|x| NIL)) - ((OR (ATOM G166746) - (PROGN - (SETQ |x| (CAR G166746)) - NIL)) - (NREVERSE0 G166741)) - (SEQ (EXIT (SETQ G166741 - (CONS - (|formatSeqRepper| |op| |x|) - G166741))))))))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |p| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T)))))))) - (|formatDeftran| - (CONS 'IF - (CONS |p| - (CONS (CONS |op| (CONS |b| NIL)) - (CONS (CONS |op| (CONS |c| NIL)) - NIL)))) - |SEQflag|)) - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'LET) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (|formatDeftran| - (CONS 'LET - (CONS |a| - (CONS (CONS |op| (CONS |b| NIL)) NIL))) - |SEQflag|)) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|not|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |op| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#3|)) - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (EQ (QCDR |ISTMP#4|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#4|)) - 'T))))))))) - (SPADLET |op1| - (LASSOC |op| |$pspadRelationAlist|))) - (|formatDeftran| - (CONS |op1| (CONS |a| (CONS |b| NIL))))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|return|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |r| (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((MEMQ (|opOf| |r|) '(|true| |false|)) |a|) - ('T - (CONS '|return| - (CONS |n| - (CONS (CONS |op| - (CONS - (|formatDeftran| |r| |SEQflag|) - NIL)) - NIL)))))) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|error|)) |a|) - ('T - (CONS |op| (CONS (|formatDeftran| |a| |SEQflag|) NIL))))))))) - -;formatDeftranColon([op,a,t],SEQflag) == --op is one of : :: pretend @ -; a := formatDeftran(a,SEQflag) -; t := formatDeftran(t,SEQflag) -; a is ["UNCOERCE",b] => b -; a is [op1,b,t1] and t1 = t and MEMQ(op,'(_: _:_: _pretend _@)) => -; op1 = "pretend" or op = "pretend" => ["pretend",b,t] -; null SEQflag and op1 = ":" or op = ":" => ["pretend",b,t] -; a -; a is [=op,b,t1] => -; t1 = t => a -; [op,b,t] -; t = "$" => -; a is ['rep,b] => b -; a is ['per,b] => a -; [op,a,t] -; t = "Rep" => -; a is ['per,b] => b -; a is ['rep,b] => a -; [op,a,t] -; [op,a,t] - -(DEFUN |formatDeftranColon| (G166856 |SEQflag|) - (PROG (|op| |a| |t| |op1| |ISTMP#2| |t1| |ISTMP#1| |b|) - (RETURN - (PROGN - (SPADLET |op| (CAR G166856)) - (SPADLET |a| (CADR G166856)) - (SPADLET |t| (CADDR G166856)) - (SPADLET |a| (|formatDeftran| |a| |SEQflag|)) - (SPADLET |t| (|formatDeftran| |t| |SEQflag|)) - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'UNCOERCE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) 'T)))) - |b|) - ((AND (PAIRP |a|) - (PROGN - (SPADLET |op1| (QCAR |a|)) - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t1| (QCAR |ISTMP#2|)) - 'T))))) - (BOOT-EQUAL |t1| |t|) - (MEMQ |op| '(|:| |::| |pretend| @))) - (COND - ((OR (BOOT-EQUAL |op1| '|pretend|) - (BOOT-EQUAL |op| '|pretend|)) - (CONS '|pretend| (CONS |b| (CONS |t| NIL)))) - ((OR (AND (NULL |SEQflag|) (BOOT-EQUAL |op1| '|:|)) - (BOOT-EQUAL |op| '|:|)) - (CONS '|pretend| (CONS |b| (CONS |t| NIL)))) - ('T |a|))) - ((AND (PAIRP |a|) (EQUAL (QCAR |a|) |op|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |t1| (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((BOOT-EQUAL |t1| |t|) |a|) - ('T (CONS |op| (CONS |b| (CONS |t| NIL)))))) - ((BOOT-EQUAL |t| '$) - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|rep|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) 'T)))) - |b|) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|per|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) 'T)))) - |a|) - ('T (CONS |op| (CONS |a| (CONS |t| NIL)))))) - ((BOOT-EQUAL |t| '|Rep|) - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|per|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) 'T)))) - |b|) - ((AND (PAIRP |a|) (EQ (QCAR |a|) '|rep|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#1|)) 'T)))) - |a|) - ('T (CONS |op| (CONS |a| (CONS |t| NIL)))))) - ('T (CONS |op| (CONS |a| (CONS |t| NIL))))))))) - -;formatSeqRepper(op,x) == -; x is ['exit,n,y] => ['exit,n,[op,formatDeftran(y,nil)]] -; x is ["=>",a,b] => ["=>",formatDeftran(a,nil),[op,formatDeftran(b,nil)]] -; atom x => x -; [formatSeqRepper(op,y) for y in x] - -(DEFUN |formatSeqRepper| (|op| |x|) - (PROG (|n| |y| |ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (SEQ (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) '|exit|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - 'T)))))) - (CONS '|exit| - (CONS |n| - (CONS (CONS |op| - (CONS (|formatDeftran| |y| NIL) - NIL)) - NIL)))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) '=>) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - 'T)))))) - (CONS '=> - (CONS (|formatDeftran| |a| NIL) - (CONS (CONS |op| - (CONS (|formatDeftran| |b| NIL) - NIL)) - NIL)))) - ((ATOM |x|) |x|) - ('T - (PROG (G166966) - (SPADLET G166966 NIL) - (RETURN - (DO ((G166971 |x| (CDR G166971)) (|y| NIL)) - ((OR (ATOM G166971) - (PROGN (SETQ |y| (CAR G166971)) NIL)) - (NREVERSE0 G166966)) - (SEQ (EXIT (SETQ G166966 - (CONS (|formatSeqRepper| |op| |y|) - G166966))))))))))))) - -;formatDeftranJoin(u,SEQflag) == -; ['Join,:cats,lastcat] := u -; lastcat is ['CATEGORY,kind,:l,x] => -; cat := -; CDR cats => ['Join,:cats] -; first cats -; formatDeftran(['with,cat,['SEQ,:l,['exit,1,x]]],SEQflag) -; u - -(DEFUN |formatDeftranJoin| (|u| |SEQflag|) - (PROG (|LETTMP#1| |lastcat| |cats| |ISTMP#1| |kind| |ISTMP#2| - |ISTMP#3| |x| |l| |cat|) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (REVERSE (CDR |u|))) - (SPADLET |lastcat| (CAR |LETTMP#1|)) - (SPADLET |cats| (NREVERSE (CDR |LETTMP#1|))) - (COND - ((AND (PAIRP |lastcat|) (EQ (QCAR |lastcat|) 'CATEGORY) - (PROGN - (SPADLET |ISTMP#1| (QCDR |lastcat|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |kind| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (REVERSE |ISTMP#2|)) - 'T) - (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#3|)) - (SPADLET |l| (QCDR |ISTMP#3|)) - 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))))) - (SPADLET |cat| - (COND - ((CDR |cats|) (CONS '|Join| |cats|)) - ('T (CAR |cats|)))) - (|formatDeftran| - (CONS '|with| - (CONS |cat| - (CONS (CONS 'SEQ - (APPEND |l| - (CONS - (CONS '|exit| - (CONS 1 (CONS |x| NIL))) - NIL))) - NIL))) - |SEQflag|)) - ('T |u|)))))) - -;formatENUM ['MyENUM, x] == format "'" and format x and format "'" - -(DEFUN |formatENUM| (G167044) - (PROG (|x|) - (RETURN - (PROGN - (SPADLET |x| (CADR G167044)) - (AND (|format| '|'|) (|format| |x|) (|format| '|'|)))))) - -;formatDeftranREPEAT(itl,body) == -;--do nothing unless "itl" contains UNTIL statements -; u := [x for x in itl | x is ["UNTIL",p]] or return nil -; nitl := SETDIFFERENCE(itl,u) -; pred := MKPF([p for ['UNTIL,p] in u],'or) -; cond := ['IF,pred,['leave,n,nil],'noBranch] -; nbody := -; body is ['SEQ,:l,[.,n,x]] => ['SEQ,:l,x,['exit,n,cond]] -; ['SEQ,body,['exit,n,cond]] -; [nitl,:nbody] - -(DEFUN |formatDeftranREPEAT| (|itl| |body|) - (PROG (|u| |nitl| |p| |pred| |cond| |ISTMP#1| |ISTMP#2| |ISTMP#3| - |ISTMP#4| |n| |ISTMP#5| |x| |l| |nbody|) - (RETURN - (SEQ (PROGN - (SPADLET |u| - (OR (PROG (G167111) - (SPADLET G167111 NIL) - (RETURN - (DO ((G167117 |itl| (CDR G167117)) - (|x| NIL)) - ((OR (ATOM G167117) - (PROGN - (SETQ |x| (CAR G167117)) - NIL)) - (NREVERSE0 G167111)) - (SEQ (EXIT - (COND - ((AND (PAIRP |x|) - (EQ (QCAR |x|) 'UNTIL) - (PROGN - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |p| - (QCAR |ISTMP#1|)) - 'T)))) - (SETQ G167111 - (CONS |x| G167111))))))))) - (RETURN NIL))) - (SPADLET |nitl| (SETDIFFERENCE |itl| |u|)) - (SPADLET |pred| - (MKPF (PROG (G167128) - (SPADLET G167128 NIL) - (RETURN - (DO ((G167134 |u| (CDR G167134)) - (G167059 NIL)) - ((OR (ATOM G167134) - (PROGN - (SETQ G167059 - (CAR G167134)) - NIL) - (PROGN - (PROGN - (SPADLET |p| - (CADR G167059)) - G167059) - NIL)) - (NREVERSE0 G167128)) - (SEQ (EXIT - (SETQ G167128 - (CONS |p| G167128))))))) - '|or|)) - (SPADLET |cond| - (CONS 'IF - (CONS |pred| - (CONS (CONS '|leave| - (CONS |n| (CONS NIL NIL))) - (CONS '|noBranch| NIL))))) - (SPADLET |nbody| - (COND - ((AND (PAIRP |body|) (EQ (QCAR |body|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |body|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| - (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |n| - (QCAR |ISTMP#4|)) - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |x| - (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN - (SPADLET |l| (QCDR |ISTMP#2|)) - 'T) - (PROGN - (SPADLET |l| (NREVERSE |l|)) - 'T)))) - (CONS 'SEQ - (APPEND |l| - (CONS |x| - (CONS - (CONS '|exit| - (CONS |n| (CONS |cond| NIL))) - NIL))))) - ('T - (CONS 'SEQ - (CONS |body| - (CONS - (CONS '|exit| - (CONS |n| (CONS |cond| NIL))) - NIL)))))) - (CONS |nitl| |nbody|)))))) - -;formatDeftranSEQ(x,flag) == -; u := formatDeftran(x,flag) -; u is ['SEQ,:.] => rest u -; [u] - -(DEFUN |formatDeftranSEQ| (|x| |flag|) - (PROG (|u|) - (RETURN - (PROGN - (SPADLET |u| (|formatDeftran| |x| |flag|)) - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'SEQ)) (CDR |u|)) - ('T (CONS |u| NIL))))))) - -;formatDeftranIf(a,b,c) == -; b = 'noBranch => -; a is [op,:r] and (al := '((_= . _~_=) (_< . _>_=) (_> . _<_=)); -; iop := LASSOC(op, al) or RASSOC(op, al)) => -; [["=>",[iop, :r],c]] -; a is [op,r] and MEMQ(op,'(NOT not NULL null)) => -; [["=>", r, c]] -; [["=>", ['not, a], c]] -; post := -; c = 'noBranch => nil -; c is ['SEQ,:.] => CDR c -; [c] -; [["=>",a,b],:post] - -(DEFUN |formatDeftranIf| (|a| |b| |c|) - (PROG (|al| |iop| |op| |ISTMP#1| |r| |post|) - (RETURN - (COND - ((BOOT-EQUAL |b| '|noBranch|) - (COND - ((AND (PAIRP |a|) - (PROGN - (SPADLET |op| (QCAR |a|)) - (SPADLET |r| (QCDR |a|)) - 'T) - (PROGN - (SPADLET |al| '((= . ~=) (< . >=) (> . <=))) - (SPADLET |iop| - (OR (LASSOC |op| |al|) - (|rassoc| |op| |al|))))) - (CONS (CONS '=> (CONS (CONS |iop| |r|) (CONS |c| NIL))) - NIL)) - ((AND (PAIRP |a|) - (PROGN - (SPADLET |op| (QCAR |a|)) - (SPADLET |ISTMP#1| (QCDR |a|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |r| (QCAR |ISTMP#1|)) 'T))) - (MEMQ |op| '(NOT |not| NULL |null|))) - (CONS (CONS '=> (CONS |r| (CONS |c| NIL))) NIL)) - ('T - (CONS (CONS '=> - (CONS (CONS '|not| (CONS |a| NIL)) - (CONS |c| NIL))) - NIL)))) - ('T - (SPADLET |post| - (COND - ((BOOT-EQUAL |c| '|noBranch|) NIL) - ((AND (PAIRP |c|) (EQ (QCAR |c|) 'SEQ)) (CDR |c|)) - ('T (CONS |c| NIL)))) - (CONS (CONS '=> (CONS |a| (CONS |b| NIL))) |post|)))))) - -;formatWHERE ["where",a,b] == -; $insideTypeExpression: local := nil -; $insideCAPSULE: local := false -; tryBreak(formatLeft("format",a,"where","Led") and format " where ",b,"where","Led") - -(DEFUN |formatWHERE| (G167196) - (PROG (|$insideTypeExpression| |$insideCAPSULE| |a| |b|) - (DECLARE (SPECIAL |$insideTypeExpression| |$insideCAPSULE|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167196) '|where|) (CAR G167196))) - (SPADLET |a| (CADR G167196)) - (SPADLET |b| (CADDR G167196)) - (SPADLET |$insideTypeExpression| NIL) - (SPADLET |$insideCAPSULE| NIL) - (|tryBreak| - (AND (|formatLeft| '|format| |a| '|where| '|Led|) - (|format| '| where |)) - |b| '|where| '|Led|))))) - -;--====================================================================== -;-- Special Handlers: Categories -;--====================================================================== -;formatATTRIBUTE ['ATTRIBUTE,att] == format att - -(DEFUN |formatATTRIBUTE| (G167218) - (PROG (|att|) - (RETURN (PROGN (SPADLET |att| (CADR G167218)) (|format| |att|))))) - -;formatDeftranCategory ['CATEGORY,kind,:items,item] == ["SEQ",:items,["exit",1,item]] - -(DEFUN |formatDeftranCategory| (G167229) - (PROG (|kind| |LETTMP#1| |item| |items|) - (RETURN - (PROGN - (SPADLET |kind| (CADR G167229)) - (SPADLET |LETTMP#1| (REVERSE (CDDR G167229))) - (SPADLET |item| (CAR |LETTMP#1|)) - (SPADLET |items| (NREVERSE (CDR |LETTMP#1|))) - (CONS 'SEQ - (APPEND |items| - (CONS (CONS '|exit| (CONS 1 (CONS |item| NIL))) - NIL))))))) - -;formatCategory ['Category] == format " " and format "Category" - -(DEFUN |formatCategory| (G167249) - (declare (ignore G167249)) - (AND (|format| '| |) (|format| '|Category|))) - -;formatCATEGORY cat == -; con := opOf $form -; $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) -; $insideEXPORTS : local := true -; format ["with",formatDeftranCategory cat] - -(DEFUN |formatCATEGORY| (|cat|) - (PROG (|$comments| |$insideEXPORTS| |con|) - (DECLARE (SPECIAL |$comments| |$insideEXPORTS| |$form|)) - (RETURN - (PROGN - (SPADLET |con| (|opOf| |$form|)) - (SPADLET |$comments| - (MSUBST '$ '% (GETDATABASE |con| 'DOCUMENTATION))) - (SPADLET |$insideEXPORTS| 'T) - (|format| - (CONS '|with| (CONS (|formatDeftranCategory| |cat|) NIL))))))) - -;formatSIGNATURE ['SIGNATURE,op,types,:r] == -; MEMQ('constant,r) => format op and format ": " and (u := format first types) and -; formatSC() and formatComments(u,op,types) -; format op and format ": " and (u := format ['Mapping,:types]) and formatSC() and -; formatComments(u,op,types) - -(DEFUN |formatSIGNATURE| (G167268) - (PROG (|op| |types| |r| |u|) - (RETURN - (PROGN - (SPADLET |op| (CADR G167268)) - (SPADLET |types| (CADDR G167268)) - (SPADLET |r| (CDDDR G167268)) - (COND - ((MEMQ '|constant| |r|) - (AND (|format| |op|) (|format| '|: |) - (SPADLET |u| (|format| (CAR |types|))) (|formatSC|) - (|formatComments| |u| |op| |types|))) - ('T - (AND (|format| |op|) (|format| '|: |) - (SPADLET |u| (|format| (CONS '|Mapping| |types|))) - (|formatSC|) (|formatComments| |u| |op| |types|)))))))) - -;formatDefault ["default",a] == -; $insideCategoryIfTrue : local := false -; $insideCAPSULE: local := true -; $insideTypeExpression: local := false -; tryBreak(format "default ",a,"with","Nud") - -(DEFUN |formatDefault| (G167288) - (PROG (|$insideCategoryIfTrue| |$insideCAPSULE| - |$insideTypeExpression| |a|) - (DECLARE (SPECIAL |$insideCategoryIfTrue| |$insideCAPSULE| - |$insideTypeExpression|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167288) '|default|) (CAR G167288))) - (SPADLET |a| (CADR G167288)) - (SPADLET |$insideCategoryIfTrue| NIL) - (SPADLET |$insideCAPSULE| 'T) - (SPADLET |$insideTypeExpression| NIL) - (|tryBreak| (|format| '|default |) |a| '|with| '|Nud|))))) - -;--====================================================================== -;-- Special Handlers: Control Structures -;--====================================================================== -;formatUNCOERCE ['UNCOERCE,x] == format x - -(DEFUN |formatUNCOERCE| (G167310) - (PROG (|x|) - (RETURN (PROGN (SPADLET |x| (CADR G167310)) (|format| |x|))))) - -;formatIF ['IF,a,b,c] == -; c = 'noBranch => formatIF2(a,b,"if ") -; b = 'noBranch => formatIF ['IF,['not,a],c,'noBranch] -; formatIF2(a,b,"if ") and newLine() and formatIF3 c - -(DEFUN |formatIF| (G167322) - (PROG (|a| |b| |c|) - (RETURN - (PROGN - (SPADLET |a| (CADR G167322)) - (SPADLET |b| (CADDR G167322)) - (SPADLET |c| (CADDDR G167322)) - (COND - ((BOOT-EQUAL |c| '|noBranch|) (|formatIF2| |a| |b| '|if |)) - ((BOOT-EQUAL |b| '|noBranch|) - (|formatIF| - (CONS 'IF - (CONS (CONS '|not| (CONS |a| NIL)) - (CONS |c| (CONS '|noBranch| NIL)))))) - ('T - (AND (|formatIF2| |a| |b| '|if |) (|newLine|) - (|formatIF3| |c|)))))))) - -;formatIF2(a,b,prefix) == -; tryBreakNB(format prefix and format a and format " then ",b,"then","Nud") - -(DEFUN |formatIF2| (|a| |b| |prefix|) - (|tryBreakNB| - (AND (|format| |prefix|) (|format| |a|) (|format| '| then |)) |b| - '|then| '|Nud|)) - -;formatIF3 x == -; x is ['IF,a,b,c] => -; c = 'noBranch => tryBreak(format "else if " -; and format a and format " then ",b,"then","Nud") -; formatIF2(a,b,"else if ") and newLine() and formatIF3 c -; tryBreak(format "else ",x,"else","Nud") - -(DEFUN |formatIF3| (|x|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b| |ISTMP#3| |c|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'IF) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (SPADLET |c| (QCAR |ISTMP#3|)) - 'T)))))))) - (COND - ((BOOT-EQUAL |c| '|noBranch|) - (|tryBreak| - (AND (|format| '|else if |) (|format| |a|) - (|format| '| then |)) - |b| '|then| '|Nud|)) - ('T - (AND (|formatIF2| |a| |b| '|else if |) (|newLine|) - (|formatIF3| |c|))))) - ('T (|tryBreak| (|format| '|else |) |x| '|else| '|Nud|)))))) - -;formatBlock(l,x) == -; null l => format x -; $pilesAreOkHere: local := nil -; format "{ " and format first l and -; (and/[formatSC() and format y for y in rest l]) -; and formatSC() and format x and format " }" - -(DEFUN |formatBlock| (|l| |x|) - (PROG (|$pilesAreOkHere|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (SEQ (COND - ((NULL |l|) (|format| |x|)) - ('T (SPADLET |$pilesAreOkHere| NIL) - (AND (|format| '|{ |) (|format| (CAR |l|)) - (PROG (G167388) - (SPADLET G167388 'T) - (RETURN - (DO ((G167394 NIL (NULL G167388)) - (G167395 (CDR |l|) (CDR G167395)) - (|y| NIL)) - ((OR G167394 (ATOM G167395) - (PROGN (SETQ |y| (CAR G167395)) NIL)) - G167388) - (SEQ (EXIT (SETQ G167388 - (AND G167388 - (AND (|formatSC|) (|format| |y|))))))))) - (|formatSC|) (|format| |x|) (|format| '| }|)))))))) - -;formatExit ["exit",.,u] == format u - -(DEFUN |formatExit| (G167409) - (PROG (|u|) - (RETURN - (PROGN - (COND ((EQ (CAR G167409) '|exit|) (CAR G167409))) - (SPADLET |u| (CADDR G167409)) - (|format| |u|))))) - -;formatvoid ["void"] == format "()" - -(DEFUN |formatvoid| (G167422) - (PROGN - (COND ((EQ (CAR G167422) '|void|) (CAR G167422))) - (|format| '|()|))) - -;formatLeave ["leave",.,u] == format "break" - -(DEFUN |formatLeave| (G167432) - (PROG (|u|) - (RETURN - (PROGN - (COND ((EQ (CAR G167432) '|leave|) (CAR G167432))) - (SPADLET |u| (CADDR G167432)) - (|format| '|break|))))) - -;formatCOLLECT u == formatSpill("formatCOLLECT1",u) - -(DEFUN |formatCOLLECT| (|u|) (|formatSpill| '|formatCOLLECT1| |u|)) - -;formatCOLLECT1 ["COLLECT",:iteratorList,body] == -; $pilesAreOkHere: local := nil -; format "[" and format body and format " " and -; formatSpill("formatIteratorTail",iteratorList) - -(DEFUN |formatCOLLECT1| (G167449) - (PROG (|$pilesAreOkHere| |LETTMP#1| |body| |iteratorList|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167449) 'COLLECT) (CAR G167449))) - (SPADLET |LETTMP#1| (REVERSE (CDR G167449))) - (SPADLET |body| (CAR |LETTMP#1|)) - (SPADLET |iteratorList| (NREVERSE (CDR |LETTMP#1|))) - (SPADLET |$pilesAreOkHere| NIL) - (AND (|format| '[) (|format| |body|) (|format| '| |) - (|formatSpill| '|formatIteratorTail| |iteratorList|)))))) - -;formatIteratorTail iteratorList == -; formatIterator first iteratorList and -; (and/[format " " and formatIterator x for x in rest iteratorList]) and format "]" - -(DEFUN |formatIteratorTail| (|iteratorList|) - (PROG () - (RETURN - (SEQ (AND (|formatIterator| (CAR |iteratorList|)) - (PROG (G167471) - (SPADLET G167471 'T) - (RETURN - (DO ((G167477 NIL (NULL G167471)) - (G167478 (CDR |iteratorList|) - (CDR G167478)) - (|x| NIL)) - ((OR G167477 (ATOM G167478) - (PROGN (SETQ |x| (CAR G167478)) NIL)) - G167471) - (SEQ (EXIT (SETQ G167471 - (AND G167471 - (AND (|format| '| |) - (|formatIterator| |x|))))))))) - (|format| '])))))) - -;--====================================================================== -;-- Special Handlers: Keywords -;--====================================================================== -; -;formatColon [":",a,b] == -; b is ['with,c,:d] => formatColonWith(a,c,d) -; if not $insideTypeExpression then -; insideCat() => nil -; format -; $insideDEF => "local " -; "default " -; op := -; $insideCAPSULE and not $insideDEF => ": " -; insideCat() => ": " -; ":" -; b := (atom b => b; markMacroTran b) -; a is ['LISTOF,:c] => formatComma c and format ": " and formatLocal1 b -; formatInfix(op,[a, b],formatOpBindingPower(":","Led","left"), -; formatOpBindingPower(":","Led","right")) - -(DEFUN |formatColon| (G167502) - (PROG (|a| |ISTMP#1| |d| |op| |b| |c|) - (declare (special |$insideDEF| |$insideCAPSULE| |$insideTypeExpression|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167502) '|:|) (CAR G167502))) - (SPADLET |a| (CADR G167502)) - (SPADLET |b| (CADDR G167502)) - (COND - ((AND (PAIRP |b|) (EQ (QCAR |b|) '|with|) - (PROGN - (SPADLET |ISTMP#1| (QCDR |b|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |c| (QCAR |ISTMP#1|)) - (SPADLET |d| (QCDR |ISTMP#1|)) - 'T)))) - (|formatColonWith| |a| |c| |d|)) - ('T - (COND - ((NULL |$insideTypeExpression|) - (COND - ((|insideCat|) NIL) - ('T - (|format| - (COND (|$insideDEF| '|local |) ('T '|default |))))))) - (SPADLET |op| - (COND - ((AND |$insideCAPSULE| (NULL |$insideDEF|)) - '|: |) - ((|insideCat|) '|: |) - ('T '|:|))) - (SPADLET |b| - (COND ((ATOM |b|) |b|) ('T (|markMacroTran| |b|)))) - (COND - ((AND (PAIRP |a|) (EQ (QCAR |a|) 'LISTOF) - (PROGN (SPADLET |c| (QCDR |a|)) 'T)) - (AND (|formatComma| |c|) (|format| '|: |) - (|formatLocal1| |b|))) - ('T - (|formatInfix| |op| (CONS |a| (CONS |b| NIL)) - (|formatOpBindingPower| '|:| '|Led| '|left|) - (|formatOpBindingPower| '|:| '|Led| '|right|)))))))))) - -;formatColonWith(form,a,b) == -; con := opOf $form -; $comments: local := SUBST('_$,'_%,GETDATABASE(con,'DOCUMENTATION)) -; $insideEXPORTS : local := true -; $pilesAreOkHere: local := true -; $insideTypeExpression : local := false -; b => tryBreak(formatDefForm form and format ": " -; and format a and format " with ",first b,"with","Led") -; tryBreak(formatDefForm form and format ": with ",a,"with","Nud") - -(DEFUN |formatColonWith| (|form| |a| |b|) - (PROG (|$comments| |$insideEXPORTS| |$pilesAreOkHere| - |$insideTypeExpression| |con|) - (DECLARE (SPECIAL |$comments| |$insideEXPORTS| |$pilesAreOkHere| - |$insideTypeExpression| |$form|)) - (RETURN - (PROGN - (SPADLET |con| (|opOf| |$form|)) - (SPADLET |$comments| - (MSUBST '$ '% (GETDATABASE |con| 'DOCUMENTATION))) - (SPADLET |$insideEXPORTS| 'T) - (SPADLET |$pilesAreOkHere| 'T) - (SPADLET |$insideTypeExpression| NIL) - (COND - (|b| (|tryBreak| - (AND (|formatDefForm| |form|) (|format| '|: |) - (|format| |a|) (|format| '| with |)) - (CAR |b|) '|with| '|Led|)) - ('T - (|tryBreak| - (AND (|formatDefForm| |form|) (|format| '|: with |)) |a| - '|with| '|Nud|))))))) - -;formatCOND ["COND",:l] == -; originalC:= $c -; and/[x is [a,[.,.,b]] for x in l] => -; (originalC=$m or indent() and newLine()) and first l is [a,[.,.,b]] and -; formatIfExit(a,b) and -; (and/[newLine() and formatIfExit(a,b) for [a,[.,.,b]] in rest l]) and (originalC=$m or undent()) and originalC -; formatIfThenElse l - -(DEFUN |formatCOND| (G167644) - (PROG (|l| |originalC| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| - |ISTMP#5| |a| |b|) - (declare (special |$m| |$c|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G167644) 'COND) (CAR G167644))) - (SPADLET |l| (CDR G167644)) - (SPADLET |originalC| |$c|) - (COND - ((PROG (G167680) - (SPADLET G167680 'T) - (RETURN - (DO ((G167697 NIL (NULL G167680)) - (G167698 |l| (CDR G167698)) (|x| NIL)) - ((OR G167697 (ATOM G167698) - (PROGN (SETQ |x| (CAR G167698)) NIL)) - G167680) - (SEQ (EXIT (SETQ G167680 - (AND G167680 - (AND (PAIRP |x|) - (PROGN - (SPADLET |a| (QCAR |x|)) - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ - (QCDR |ISTMP#4|) - NIL) - (PROGN - (SPADLET |b| - (QCAR - |ISTMP#4|)) - 'T))))))))))))))))) - (AND (OR (BOOT-EQUAL |originalC| |$m|) - (AND (|indent|) (|newLine|))) - (PROGN - (SPADLET |ISTMP#1| (CAR |l|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#5|)) - 'T))))))))))) - (|formatIfExit| |a| |b|) - (PROG (G167705) - (SPADLET G167705 'T) - (RETURN - (DO ((G167712 NIL (NULL G167705)) - (G167713 (CDR |l|) (CDR G167713)) - (G167639 NIL)) - ((OR G167712 (ATOM G167713) - (PROGN - (SETQ G167639 (CAR G167713)) - NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR G167639)) - (SPADLET |b| - (CAR (CDDADR G167639))) - G167639) - NIL)) - G167705) - (SEQ (EXIT (SETQ G167705 - (AND G167705 - (AND (|newLine|) - (|formatIfExit| |a| |b|))))))))) - (OR (BOOT-EQUAL |originalC| |$m|) (|undent|)) - |originalC|)) - ('T (|formatIfThenElse| |l|)))))))) - -;formatPROGN ["PROGN",:l] == -; l is [:u,x] => formatPiles(u,x) -; error '"formatPROGN" - -(DEFUN |formatPROGN| (G167747) - (PROG (|l| |ISTMP#1| |x| |u|) - (RETURN - (PROGN - (COND ((EQ (CAR G167747) 'PROGN) (CAR G167747))) - (SPADLET |l| (CDR G167747)) - (COND - ((AND (PAIRP |l|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |l|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |u| (QCDR |ISTMP#1|)) - 'T) - (PROGN (SPADLET |u| (NREVERSE |u|)) 'T)) - (|formatPiles| |u| |x|)) - ('T (|error| "formatPROGN"))))))) - -;formatELT ["ELT",a,b] == formatApplication [a,b] - -(DEFUN |formatELT| (G167771) - (PROG (|a| |b|) - (RETURN - (PROGN - (COND ((EQ (CAR G167771) 'ELT) (CAR G167771))) - (SPADLET |a| (CADR G167771)) - (SPADLET |b| (CADDR G167771)) - (|formatApplication| (CONS |a| (CONS |b| NIL))))))) - -;formatCONS ["CONS",a,b] == -; $pilesAreOkHere: local := nil -; format "[" and formatConstructItem a and formatTail b - -(DEFUN |formatCONS| (G167788) - (PROG (|$pilesAreOkHere| |a| |b|) - (DECLARE (SPECIAL |$pilesAreOkHere|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167788) 'CONS) (CAR G167788))) - (SPADLET |a| (CADR G167788)) - (SPADLET |b| (CADDR G167788)) - (SPADLET |$pilesAreOkHere| NIL) - (AND (|format| '[) (|formatConstructItem| |a|) - (|formatTail| |b|)))))) - -;formatTail x == -; null x => format "]" -; format "," and formatTail1 x - -(DEFUN |formatTail| (|x|) - (COND - ((NULL |x|) (|format| '])) - ('T (AND (|format| '|,|) (|formatTail1| |x|))))) - -;formatTail1 x == -; x is ["CONS",a,b] => formatConstructItem a and formatTail b -; x is ["APPEND",a,b] => -; null b => formatConstructItem a and format "]" -; format ":" and formatConstructItem a and formatTail b -; format ":" and formatConstructItem x and format "]" - -(DEFUN |formatTail1| (|x|) - (PROG (|ISTMP#1| |a| |ISTMP#2| |b|) - (RETURN - (COND - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'CONS) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T)))))) - (AND (|formatConstructItem| |a|) (|formatTail| |b|))) - ((AND (PAIRP |x|) (EQ (QCAR |x|) 'APPEND) - (PROGN - (SPADLET |ISTMP#1| (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) (EQ (QCDR |ISTMP#2|) NIL) - (PROGN (SPADLET |b| (QCAR |ISTMP#2|)) 'T)))))) - (COND - ((NULL |b|) (AND (|formatConstructItem| |a|) (|format| ']))) - ('T - (AND (|format| '|:|) (|formatConstructItem| |a|) - (|formatTail| |b|))))) - ('T - (AND (|format| '|:|) (|formatConstructItem| |x|) - (|format| ']))))))) - -;-- x = "." => format " " -;formatConstructItem x == format x - -(DEFUN |formatConstructItem| (|x|) (|format| |x|)) - -;formatLET ["LET",a,b] == -; $insideTypeExpression: local := true -; a = "Rep" or atom a and constructor? opOf b => -; tryBreakNB(formatAtom a and format " == ",b,":=","Led") -; tryBreakNB((IDENTP a => formatAtom a; format a) and format " := ",b,":=","Led") - -(DEFUN |formatLET| (G167861) - (PROG (|$insideTypeExpression| |a| |b|) - (DECLARE (SPECIAL |$insideTypeExpression|)) - (RETURN - (PROGN - (COND ((EQ (CAR G167861) 'LET) (CAR G167861))) - (SPADLET |a| (CADR G167861)) - (SPADLET |b| (CADDR G167861)) - (SPADLET |$insideTypeExpression| 'T) - (COND - ((OR (BOOT-EQUAL |a| '|Rep|) - (AND (ATOM |a|) (|constructor?| (|opOf| |b|)))) - (|tryBreakNB| (AND (|formatAtom| |a|) (|format| '| == |)) - |b| '|:=| '|Led|)) - ('T - (|tryBreakNB| - (AND (COND - ((IDENTP |a|) (|formatAtom| |a|)) - ('T (|format| |a|))) - (|format| '| := |)) - |b| '|:=| '|Led|))))))) - -;formatIfExit(a,b) == -; --called from SCOND or COND only -; $numberOfSpills: local:= 0 -; curMargin:= $m -; curMarginStack:= $currentMarginStack -; $doNotResetMarginIfTrue:= true -; format a and format " => " and formatRight("formatCut",b,"=>","Led") => -; ($currentMarginStack:= curMarginStack; $m:= curMargin) - -(DEFUN |formatIfExit| (|a| |b|) - (PROG (|$numberOfSpills| |curMargin| |curMarginStack|) - (DECLARE (SPECIAL |$numberOfSpills| |$m| |$currentMarginStack| - |$doNotResetMarginIfTrue|)) - (RETURN - (PROGN - (SPADLET |$numberOfSpills| 0) - (SPADLET |curMargin| |$m|) - (SPADLET |curMarginStack| |$currentMarginStack|) - (SPADLET |$doNotResetMarginIfTrue| 'T) - (COND - ((AND (|format| |a|) (|format| '| => |) - (|formatRight| '|formatCut| |b| '=> '|Led|)) - (PROGN - (SPADLET |$currentMarginStack| |curMarginStack|) - (SPADLET |$m| |curMargin|)))))))) - -;formatIfThenElse x == formatSpill("formatIf1",x) - -(DEFUN |formatIfThenElse| (|x|) (|formatSpill| '|formatIf1| |x|)) - -;formatIf1 x == -; x is [[a,:r],:c] and null c => -; b:= -; r is [:l,s] and l => ['SEQ,:l,['exit,.,s]] -; first r -; isTrue a => format b -; format "if " and format a and format " then " and format b -; format "if " and format a and -; (try -; (format " then " and format b and format " else " -; and formatIfThenElse c) or spillLine() -; and format " then " and format b and -;-- ($c:= $m:= $m+6) and -; ($numberOfSpills:= $numberOfSpills-1) -; and spillLine() and format " else " and formatIfThenElse c) - -(DEFUN |formatIf1| (|x|) - (PROG (|a| |r| |c| |ISTMP#1| |s| |l| |b|) - (declare (special |$numberOfSpills|)) - (RETURN - (COND - ((AND (PAIRP |x|) - (PROGN - (SPADLET |ISTMP#1| (QCAR |x|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |r| (QCDR |ISTMP#1|)) - 'T))) - (PROGN (SPADLET |c| (QCDR |x|)) 'T) (NULL |c|)) - (SPADLET |b| - (COND - ((AND (PAIRP |r|) - (PROGN (SPADLET |ISTMP#1| (REVERSE |r|)) 'T) - (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |s| (QCAR |ISTMP#1|)) - (SPADLET |l| (QCDR |ISTMP#1|)) - 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T) |l|) - (CONS 'SEQ - (APPEND |l| - (CONS - (CONS '|exit| - (CONS '|.| (CONS |s| NIL))) - NIL)))) - ('T (CAR |r|)))) - (COND - ((|isTrue| |a|) (|format| |b|)) - ('T - (AND (|format| '|if |) (|format| |a|) (|format| '| then |) - (|format| |b|))))) - ('T - (AND (|format| '|if |) (|format| |a|) - (OR (|try| (AND (|format| '| then |) (|format| |b|) - (|format| '| else |) - (|formatIfThenElse| |c|))) - (AND (|spillLine|) (|format| '| then |) - (|format| |b|) - (SPADLET |$numberOfSpills| - (SPADDIFFERENCE |$numberOfSpills| 1)) - (|spillLine|) (|format| '| else |) - (|formatIfThenElse| |c|))))))))) - -;formatQUOTE ["QUOTE",x] == format "('" and format x and format ")" - -(DEFUN |formatQUOTE| (G167923) - (PROG (|x|) - (RETURN - (PROGN - (COND ((EQ (CAR G167923) 'QUOTE) (CAR G167923))) - (SPADLET |x| (CADR G167923)) - (AND (|format| '|('|) (|format| |x|) (|format| '|)|)))))) - -;formatMI ["MI",a,b] == format a - -(DEFUN |formatMI| (G167936) - (PROG (|a| |b|) - (RETURN - (PROGN - (COND ((EQ (CAR G167936) 'MI) (CAR G167936))) - (SPADLET |a| (CADR G167936)) - (SPADLET |b| (CADDR G167936)) - (|format| |a|))))) - -;formatMapping ['Mapping,target,:sources] == -; $noColonDeclaration: local := true -; formatTuple ['Tuple,:sources] and format " -> " and format target - -(DEFUN |formatMapping| (G167953) - (PROG (|$noColonDeclaration| |target| |sources|) - (DECLARE (SPECIAL |$noColonDeclaration|)) - (RETURN - (PROGN - (SPADLET |target| (CADR G167953)) - (SPADLET |sources| (CDDR G167953)) - (SPADLET |$noColonDeclaration| 'T) - (AND (|formatTuple| (CONS '|Tuple| |sources|)) - (|format| '| -> |) (|format| |target|)))))) - -;formatTuple ['Tuple,:types] == -; null types => format "()" -; null rest types => format first types -; formatFunctionCallTail types - -(DEFUN |formatTuple| (G167971) - (PROG (|types|) - (RETURN - (PROGN - (SPADLET |types| (CDR G167971)) - (COND - ((NULL |types|) (|format| '|()|)) - ((NULL (CDR |types|)) (|format| (CAR |types|))) - ('T (|formatFunctionCallTail| |types|))))))) - -;formatConstruct(['construct,:u]) == -; format "[" and (null u or format first u and -; "and"/[format "," and formatCut x for x in rest u]) and format "]" - -(DEFUN |formatConstruct| (G167982) - (PROG (|u|) - (RETURN - (SEQ (PROGN - (SPADLET |u| (CDR G167982)) - (AND (|format| '[) - (OR (NULL |u|) - (AND (|format| (CAR |u|)) - (PROG (G167989) - (SPADLET G167989 'T) - (RETURN - (DO ((G167995 NIL (NULL G167989)) - (G167996 (CDR |u|) - (CDR G167996)) - (|x| NIL)) - ((OR G167995 (ATOM G167996) - (PROGN - (SETQ |x| (CAR G167996)) - NIL)) - G167989) - (SEQ (EXIT - (SETQ G167989 - (AND G167989 - (AND (|format| '|,|) - (|formatCut| |x|))))))))))) - (|format| ']))))))) - -;formatNextConstructItem x == -; try format x or ($m := $m + 2) and newLine() and format x - -(DEFUN |formatNextConstructItem| (|x|) - (declare (special |$m|)) - (OR (|try| (|format| |x|)) - (AND (SPADLET |$m| (PLUS |$m| 2)) (|newLine|) (|format| |x|)))) - -;formatREPEAT ["REPEAT",:iteratorList,body] == -; tryBreakNB(null iteratorList or (formatIterator first iteratorList and -; (and/[format " " and formatIterator x for x in rest iteratorList]) and format " ") -; and format "repeat ",body,"repeat","Led") - -(DEFUN |formatREPEAT| (G168012) - (PROG (|LETTMP#1| |body| |iteratorList|) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G168012) 'REPEAT) (CAR G168012))) - (SPADLET |LETTMP#1| (REVERSE (CDR G168012))) - (SPADLET |body| (CAR |LETTMP#1|)) - (SPADLET |iteratorList| (NREVERSE (CDR |LETTMP#1|))) - (|tryBreakNB| - (OR (NULL |iteratorList|) - (AND (|formatIterator| (CAR |iteratorList|)) - (PROG (G168025) - (SPADLET G168025 'T) - (RETURN - (DO ((G168031 NIL (NULL G168025)) - (G168032 (CDR |iteratorList|) - (CDR G168032)) - (|x| NIL)) - ((OR G168031 (ATOM G168032) - (PROGN - (SETQ |x| (CAR G168032)) - NIL)) - G168025) - (SEQ (EXIT - (SETQ G168025 - (AND G168025 - (AND (|format| '| |) - (|formatIterator| |x|))))))))) - (|format| '| |) (|format| '|repeat |))) - |body| '|repeat| '|Led|)))))) - -;formatFATARROW ["=>",a,b] == tryBreak(format a and format " => ",b,"=>","Led") - -(DEFUN |formatFATARROW| (G168046) - (PROG (|a| |b|) - (RETURN - (PROGN - (COND ((EQ (CAR G168046) '=>) (CAR G168046))) - (SPADLET |a| (CADR G168046)) - (SPADLET |b| (CADDR G168046)) - (|tryBreak| (AND (|format| |a|) (|format| '| => |)) |b| '=> - '|Led|))))) - -;formatMap ["+->",a,b] == -; $noColonDeclaration: local := true -; tryBreak(format a and format " +-> ", b, "+->","Led") - -(DEFUN |formatMap| (G168063) - (PROG (|$noColonDeclaration| |a| |b|) - (DECLARE (SPECIAL |$noColonDeclaration|)) - (RETURN - (PROGN - (COND ((EQ (CAR G168063) '+->) (CAR G168063))) - (SPADLET |a| (CADR G168063)) - (SPADLET |b| (CADDR G168063)) - (SPADLET |$noColonDeclaration| 'T) - (|tryBreak| (AND (|format| |a|) (|format| '| +-> |)) |b| '+-> - '|Led|))))) - -;formatREDUCE ["REDUCE",op,.,u] == formatReduce1(op,u) - -(DEFUN |formatREDUCE| (G168082) - (PROG (|op| |u|) - (RETURN - (PROGN - (COND ((EQ (CAR G168082) 'REDUCE) (CAR G168082))) - (SPADLET |op| (CADR G168082)) - (SPADLET |u| (CADDDR G168082)) - (|formatReduce1| |op| |u|))))) - -;formatreduce ["reduce",op,u] == formatReduce1(op,u) - -(DEFUN |formatreduce| (G168098) - (PROG (|op| |u|) - (RETURN - (PROGN - (COND ((EQ (CAR G168098) '|reduce|) (CAR G168098))) - (SPADLET |op| (CADR G168098)) - (SPADLET |u| (CADDR G168098)) - (|formatReduce1| |op| |u|))))) - -;formatReduce1(op,u) == -; if STRINGP op then op := INTERN op -; id := LASSOC(op, -; '((_+ Zero)(_* One)(append . NIL)(gcd Zero) (lcm One) (strconc . "")(lcm One))) -; formatFunctionCall -; id => ['reduce,op,u,id] -; ['reduce,op,u] - -(DEFUN |formatReduce1| (|op| |u|) - (PROG (|id|) - (RETURN - (PROGN - (COND ((STRINGP |op|) (SPADLET |op| (INTERN |op|)))) - (SPADLET |id| - (LASSOC |op| - '((+ |Zero|) (* |One|) (|append|) - (|gcd| |Zero|) (|lcm| |One|) - (|strconc| . "") (|lcm| |One|)))) - (|formatFunctionCall| - (COND - (|id| (CONS '|reduce| - (CONS |op| (CONS |u| (CONS |id| NIL))))) - ('T (CONS '|reduce| (CONS |op| (CONS |u| NIL)))))))))) - -;formatIterator u == -; $noColonDeclaration : local := true -; u is ["IN",x,y] => -; format "for " and formatLeft("format",x,"in","Led") and format " in " and -; formatRight("format",y,"in","Led") -; u is ["WHILE",x] => format "while " and formatRight("format",x,"while","Nud") -; u is ["UNTIL",x] => format "until " and formatRight("format",x,"until","Nud") -; u is ["|",x] => format "| " and formatRight("format",x,"|","Led") -; u is ["STEP",i,init,step,:v] => -; final := IFCAR v -; format "for " and formatLeft("format",i,"in","Led") and format " in " and -; (seg := ['SEGMENT,init,final]) and (formatStepOne? step => format seg; formatBy ['by,seg,step]) -; error "formatIterator" - -(DEFUN |formatIterator| (|u|) - (PROG (|$noColonDeclaration| |y| |x| |ISTMP#1| |i| |ISTMP#2| |init| - |ISTMP#3| |step| |v| |final| |seg|) - (DECLARE (SPECIAL |$noColonDeclaration|)) - (RETURN - (PROGN - (SPADLET |$noColonDeclaration| 'T) - (COND - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'IN) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |x| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |y| (QCAR |ISTMP#2|)) - 'T)))))) - (AND (|format| '|for |) - (|formatLeft| '|format| |x| '|in| '|Led|) - (|format| '| in |) - (|formatRight| '|format| |y| '|in| '|Led|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'WHILE) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) 'T)))) - (AND (|format| '|while |) - (|formatRight| '|format| |x| '|while| '|Nud|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'UNTIL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) 'T)))) - (AND (|format| '|until |) - (|formatRight| '|format| |x| '|until| '|Nud|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) '|\||) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN (SPADLET |x| (QCAR |ISTMP#1|)) 'T)))) - (AND (|format| '|\| |) - (|formatRight| '|format| |x| '|\|| '|Led|))) - ((AND (PAIRP |u|) (EQ (QCAR |u|) 'STEP) - (PROGN - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |i| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |init| (QCAR |ISTMP#2|)) - (SPADLET |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |step| - (QCAR |ISTMP#3|)) - (SPADLET |v| (QCDR |ISTMP#3|)) - 'T)))))))) - (SPADLET |final| (IFCAR |v|)) - (AND (|format| '|for |) - (|formatLeft| '|format| |i| '|in| '|Led|) - (|format| '| in |) - (SPADLET |seg| - (CONS 'SEGMENT - (CONS |init| (CONS |final| NIL)))) - (COND - ((|formatStepOne?| |step|) (|format| |seg|)) - ('T - (|formatBy| - (CONS '|by| (CONS |seg| (CONS |step| NIL)))))))) - ('T (|error| '|formatIterator|))))))) - -;formatStepOne? step == -; step = 1 or step = '(One) => true -; step is [op,n,.] and MEMQ(op,'(_:_: _@)) => n = 1 or n = '(One) -; false - -(DEFUN |formatStepOne?| (|step|) - (PROG (|op| |ISTMP#1| |n| |ISTMP#2|) - (RETURN - (COND - ((OR (EQL |step| 1) (BOOT-EQUAL |step| '(|One|))) 'T) - ((AND (PAIRP |step|) - (PROGN - (SPADLET |op| (QCAR |step|)) - (SPADLET |ISTMP#1| (QCDR |step|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |n| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL))))) - (MEMQ |op| '(|::| @))) - (OR (EQL |n| 1) (BOOT-EQUAL |n| '(|One|)))) - ('T NIL))))) - -;formatBy ['by,seg,step] == format seg and format " by " and format step - -(DEFUN |formatBy| (G168243) - (PROG (|seg| |step|) - (RETURN - (PROGN - (SPADLET |seg| (CADR G168243)) - (SPADLET |step| (CADDR G168243)) - (AND (|format| |seg|) (|format| '| by |) (|format| |step|)))))) - -;formatSCOND ["SCOND",:l] == -; $pilesAreOkHere => -; --called from formatPileLine or formatBlock -; --if from formatPileLine -; initialC:= $c -; and/[x is [a,["exit",.,b]] for x in l] => -; first l is [a,["exit",.,b]] and formatIfExit(a,b) and -; (and/[newLine() and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and initialC -; formatIfThenElse l and initialC -; and/[x is [a,["exit",.,b]] for x in l] => -; first l is [a,["exit",.,b]] and formatIfExit(a,b) and -; (and/[format "; " and formatIfExit(a,b) for [a,["exit",.,b]] in rest l]) and $c -; --warning: and/(...) returns T if there are no entries -; formatIfThenElse l - -(DEFUN |formatSCOND| (G168449) - (PROG (|l| |initialC| |ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| - |ISTMP#5| |a| |b|) - (declare (special |$c| |$pilesAreOkHere|)) - (RETURN - (SEQ (PROGN - (COND ((EQ (CAR G168449) 'SCOND) (CAR G168449))) - (SPADLET |l| (CDR G168449)) - (COND - (|$pilesAreOkHere| (SPADLET |initialC| |$c|) - (COND - ((PROG (G168512) - (SPADLET G168512 'T) - (RETURN - (DO ((G168529 NIL (NULL G168512)) - (G168530 |l| (CDR G168530)) - (|x| NIL)) - ((OR G168529 (ATOM G168530) - (PROGN - (SETQ |x| (CAR G168530)) - NIL)) - G168512) - (SEQ (EXIT (SETQ G168512 - (AND G168512 - (AND (PAIRP |x|) - (PROGN - (SPADLET |a| (QCAR |x|)) - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) - '|exit|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ - (QCDR |ISTMP#4|) - NIL) - (PROGN - (SPADLET |b| - (QCAR - |ISTMP#4|)) - 'T))))))))))))))))) - (AND (PROGN - (SPADLET |ISTMP#1| (CAR |l|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) '|exit|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#5|)) - 'T))))))))))) - (|formatIfExit| |a| |b|) - (PROG (G168537) - (SPADLET G168537 'T) - (RETURN - (DO ((G168544 NIL (NULL G168537)) - (G168545 (CDR |l|) - (CDR G168545)) - (G168348 NIL)) - ((OR G168544 (ATOM G168545) - (PROGN - (SETQ G168348 (CAR G168545)) - NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR G168348)) - (SPADLET |b| - (CAR (CDDADR G168348))) - G168348) - NIL)) - G168537) - (SEQ (EXIT - (SETQ G168537 - (AND G168537 - (AND (|newLine|) - (|formatIfExit| |a| |b|))))))))) - |initialC|)) - ('T (AND (|formatIfThenElse| |l|) |initialC|)))) - ((PROG (G168553) - (SPADLET G168553 'T) - (RETURN - (DO ((G168570 NIL (NULL G168553)) - (G168571 |l| (CDR G168571)) (|x| NIL)) - ((OR G168570 (ATOM G168571) - (PROGN (SETQ |x| (CAR G168571)) NIL)) - G168553) - (SEQ (EXIT (SETQ G168553 - (AND G168553 - (AND (PAIRP |x|) - (PROGN - (SPADLET |a| (QCAR |x|)) - (SPADLET |ISTMP#1| - (QCDR |x|)) - (AND (PAIRP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (SPADLET |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) - '|exit|) - (PROGN - (SPADLET |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND - (PAIRP |ISTMP#4|) - (EQ - (QCDR |ISTMP#4|) - NIL) - (PROGN - (SPADLET |b| - (QCAR - |ISTMP#4|)) - 'T))))))))))))))))) - (AND (PROGN - (SPADLET |ISTMP#1| (CAR |l|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |a| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (PAIRP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ISTMP#3| - (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (EQ (QCAR |ISTMP#3|) '|exit|) - (PROGN - (SPADLET |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |b| - (QCAR |ISTMP#5|)) - 'T))))))))))) - (|formatIfExit| |a| |b|) - (PROG (G168578) - (SPADLET G168578 'T) - (RETURN - (DO ((G168585 NIL (NULL G168578)) - (G168586 (CDR |l|) (CDR G168586)) - (G168444 NIL)) - ((OR G168585 (ATOM G168586) - (PROGN - (SETQ G168444 (CAR G168586)) - NIL) - (PROGN - (PROGN - (SPADLET |a| (CAR G168444)) - (SPADLET |b| - (CAR (CDDADR G168444))) - G168444) - NIL)) - G168578) - (SEQ (EXIT (SETQ G168578 - (AND G168578 - (AND (|format| '|; |) - (|formatIfExit| |a| |b|))))))))) - |$c|)) - ('T (|formatIfThenElse| |l|)))))))) - -;formatSEGMENT ["SEGMENT",a,b] == -; $pilesAreOkHere: local := nil -; (if pspadBindingPowerOf("right",a)<750 then formatPren a else format a) and -; formatInfixOp ".." and -; (null b and $c or -; (if 750>pspadBindingPowerOf("left",b) then formatPren b else format b)) - -(DEFUN |formatSEGMENT| (G168634) - (PROG (|$pilesAreOkHere| |a| |b|) - (DECLARE (SPECIAL |$pilesAreOkHere| |$c|)) - (RETURN - (PROGN - (COND ((EQ (CAR G168634) 'SEGMENT) (CAR G168634))) - (SPADLET |a| (CADR G168634)) - (SPADLET |b| (CADDR G168634)) - (SPADLET |$pilesAreOkHere| NIL) - (AND (COND - ((> 750 (|pspadBindingPowerOf| '|right| |a|)) - (|formatPren| |a|)) - ('T (|format| |a|))) - (|formatInfixOp| (INTERN ".." "BOOT")) - (OR (AND (NULL |b|) |$c|) - (COND - ((> 750 (|pspadBindingPowerOf| '|left| |b|)) - (|formatPren| |b|)) - ('T (|format| |b|))))))))) - -;formatSexpr x == -; atom x => -; null x or IDENTP x => consBuffer ident2PrintImage PNAME x -; consBuffer x -; spill("formatNonAtom",x) - -(DEFUN |formatSexpr| (|x|) - (COND - ((ATOM |x|) - (COND - ((OR (NULL |x|) (IDENTP |x|)) - (|consBuffer| (|ident2PrintImage| (PNAME |x|)))) - ('T (|consBuffer| |x|)))) - ('T (|spill| '|formatNonAtom| |x|)))) - -;formatNonAtom x == -; format "_(" and formatSexpr first x and -; (and/[format " " and formatSexpr y for y in rest x]) -; and (y:= LASTATOM x => format " . " -; and formatSexpr y; true) and format "_)" - -(DEFUN |formatNonAtom| (|x|) - (PROG (|y|) - (RETURN - (SEQ (AND (|format| '|(|) (|formatSexpr| (CAR |x|)) - (PROG (G168659) - (SPADLET G168659 'T) - (RETURN - (DO ((G168665 NIL (NULL G168659)) - (G168666 (CDR |x|) (CDR G168666)) - (|y| NIL)) - ((OR G168665 (ATOM G168666) - (PROGN (SETQ |y| (CAR G168666)) NIL)) - G168659) - (SEQ (EXIT (SETQ G168659 - (AND G168659 - (AND (|format| '| |) - (|formatSexpr| |y|))))))))) - (COND - ((SPADLET |y| (LASTATOM |x|)) - (AND (|format| '| . |) (|formatSexpr| |y|))) - ('T 'T)) - (|format| '|)|)))))) - -;formatCAPSULE ['CAPSULE,:l,x] == -; $insideCAPSULE: local := true -; try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - -(DEFUN |formatCAPSULE| (G168679) - (PROG (|$insideCAPSULE| |LETTMP#1| |x| |l|) - (DECLARE (SPECIAL |$insideCAPSULE|)) - (RETURN - (PROGN - (SPADLET |LETTMP#1| (REVERSE (CDR G168679))) - (SPADLET |x| (CAR |LETTMP#1|)) - (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) - (SPADLET |$insideCAPSULE| 'T) - (OR (|try| (|formatBlock| |l| |x|)) (|formatPiles| |l| |x|) - (AND (|spillLine|) (|formatBlock| |l| |x|))))))) - -;formatPAREN [.,:argl] == formatFunctionCallTail argl - -(DEFUN |formatPAREN| (G168699) - (PROG (|argl|) - (RETURN - (PROGN - (SPADLET |argl| (CDR G168699)) - (|formatFunctionCallTail| |argl|))))) - -;formatSEQ ["SEQ",:l,[.,.,x]] == -; try formatBlock(l,x) or formatPiles(l,x) or spillLine() and formatBlock(l,x) - -(DEFUN |formatSEQ| (G168710) - (PROG (|LETTMP#1| |x| |l|) - (RETURN - (PROGN - (COND ((EQ (CAR G168710) 'SEQ) (CAR G168710))) - (SPADLET |LETTMP#1| (REVERSE (CDR G168710))) - (SPADLET |x| (CADDAR |LETTMP#1|)) - (SPADLET |l| (NREVERSE (CDR |LETTMP#1|))) - (OR (|try| (|formatBlock| |l| |x|)) (|formatPiles| |l| |x|) - (AND (|spillLine|) (|formatBlock| |l| |x|))))))) - -;--====================================================================== -;-- Comment Handlers -;--====================================================================== -;formatCOMMENT ["COMMENT",x,marg,startXY,endXY,commentStack] == -; $commentsToPrint:= [[marg,startXY,endXY,commentStack],:$commentsToPrint] -; format x - -(DEFUN |formatCOMMENT| (G168730) - (PROG (|x| |marg| |startXY| |endXY| |commentStack|) - (declare (special |$commentsToPrint|)) - (RETURN - (PROGN - (COND ((EQ (CAR G168730) 'COMMENT) (CAR G168730))) - (SPADLET |x| (CADR G168730)) - (SPADLET |marg| (CADDR G168730)) - (SPADLET |startXY| (CADDDR G168730)) - (SPADLET |endXY| (CAR (CDDDDR G168730))) - (SPADLET |commentStack| (CADR (CDDDDR G168730))) - (SPADLET |$commentsToPrint| - (CONS (CONS |marg| - (CONS |startXY| - (CONS |endXY| - (CONS |commentStack| NIL)))) - |$commentsToPrint|)) - (|format| |x|))))) - -;formatComments(u,op,types) == -; $numberOfSpills :local := $commentIndentation/2 - 1 -; not $insideEXPORTS => u -; alist := LASSOC(op,$comments) or -; sayBrightly ['"No documentation for ",op] -; return u -; ftypes := SUBLISLIS($FormalMapVariableList,rest $form,types) -; consComments(LASSOC(ftypes,alist),'"++ ") -; u - -(DEFUN |formatComments| (|u| |op| |types|) - (PROG (|$numberOfSpills| |alist| |ftypes|) - (DECLARE (SPECIAL |$numberOfSpills| |$form| |$FormalMapVariableList| - |$comments| |$insideEXPORTS| |$commentIndentation|)) - (RETURN - (PROGN - (SPADLET |$numberOfSpills| - (SPADDIFFERENCE (QUOTIENT |$commentIndentation| 2) 1)) - (COND - ((NULL |$insideEXPORTS|) |u|) - ('T - (SPADLET |alist| - (OR (LASSOC |op| |$comments|) - (PROGN - (|sayBrightly| - (CONS "No documentation for " - (CONS |op| NIL))) - (RETURN |u|)))) - (SPADLET |ftypes| - (SUBLISLIS |$FormalMapVariableList| (CDR |$form|) - |types|)) - (|consComments| (LASSOC |ftypes| |alist|) - "++ ") - |u|)))))) - -;consComments(s,plusPlus) == -; s is [word,:r] and null atom r => consComments(r, plusPlus) -; s := first s -; null s => nil -; s := consCommentsTran s -; indent() and newLine() or return nil -; columnsLeft := $lineLength - $m - 2 -; while (m := MAXINDEX s) >= columnsLeft repeat -; k := or/[i for i in (columnsLeft - 1)..1 by -1 | s.i = $charBlank] -; k := (k => k + 1; columnsLeft) -; piece := SUBSTRING(s,0,k) -; formatDoCommentLine [plusPlus,piece] -; s := SUBSTRING(s,k,nil) -; formatDoCommentLine [plusPlus,s] -; undent() -; $m - -(DEFUN |consComments| (|s| |plusPlus|) - (PROG (|word| |r| |columnsLeft| |m| |k| |piece|) - (declare (special |$m| |$charBlank| |$lineLength|)) - (RETURN - (SEQ (COND - ((AND (PAIRP |s|) - (PROGN - (SPADLET |word| (QCAR |s|)) - (SPADLET |r| (QCDR |s|)) - 'T) - (NULL (ATOM |r|))) - (|consComments| |r| |plusPlus|)) - ('T (SPADLET |s| (CAR |s|)) - (COND - ((NULL |s|) NIL) - ('T (SPADLET |s| (|consCommentsTran| |s|)) - (OR (AND (|indent|) (|newLine|)) (RETURN NIL)) - (SPADLET |columnsLeft| - (SPADDIFFERENCE - (SPADDIFFERENCE |$lineLength| |$m|) 2)) - (DO () - ((NULL (>= (SPADLET |m| (MAXINDEX |s|)) - |columnsLeft|)) - NIL) - (SEQ (EXIT (PROGN - (SPADLET |k| - (PROG (G168783) - (SPADLET G168783 NIL) - (RETURN - (DO - ((G168790 NIL - G168783) - (G168791 - (SPADDIFFERENCE 1)) - (|i| - (SPADDIFFERENCE - |columnsLeft| 1) - (+ |i| G168791))) - ((OR G168790 - (IF (MINUSP G168791) - (< |i| 1) (> |i| 1))) - G168783) - (SEQ - (EXIT - (COND - ((BOOT-EQUAL - (ELT |s| |i|) - |$charBlank|) - (SETQ G168783 - (OR G168783 |i|)))))))))) - (SPADLET |k| - (COND - (|k| (PLUS |k| 1)) - ('T |columnsLeft|))) - (SPADLET |piece| (SUBSTRING |s| 0 |k|)) - (|formatDoCommentLine| - (CONS |plusPlus| - (CONS |piece| NIL))) - (SPADLET |s| (SUBSTRING |s| |k| NIL)))))) - (|formatDoCommentLine| - (CONS |plusPlus| (CONS |s| NIL))) - (|undent|) |$m|)))))))) - -;consCommentsTran s == -; m := MAXINDEX s -; k := or/[i for i in 0..(m - 7) | substring?('"\spad{",s,i)] => -; r := charPosition(char '_},s,k + 6) -; r = m + 1 => s -; STRCONC(SUBSTRING(s,0,k),'"`",SUBSTRING(s,k+6,r-k-6),'"'",consCommentsTran SUBSTRING(s,r+1,nil)) -; s - -(DEFUN |consCommentsTran| (|s|) - (PROG (|m| |k| |r|) - (RETURN - (SEQ (PROGN - (SPADLET |m| (MAXINDEX |s|)) - (COND - ((SPADLET |k| - (PROG (G168812) - (SPADLET G168812 NIL) - (RETURN - (DO ((G168819 NIL G168812) - (G168820 (SPADDIFFERENCE |m| 7)) - (|i| 0 (QSADD1 |i|))) - ((OR G168819 - (QSGREATERP |i| G168820)) - G168812) - (SEQ (EXIT - (COND - ((|substring?| - "\\spad{" |s| - |i|) - (SETQ G168812 - (OR G168812 |i|)))))))))) - (SPADLET |r| - (|charPosition| (|char| '}) |s| (PLUS |k| 6))) - (COND - ((BOOT-EQUAL |r| (PLUS |m| 1)) |s|) - ('T - (STRCONC (SUBSTRING |s| 0 |k|) "`" - (SUBSTRING |s| (PLUS |k| 6) - (SPADDIFFERENCE - (SPADDIFFERENCE |r| |k|) 6)) - "'" - (|consCommentsTran| - (SUBSTRING |s| (PLUS |r| 1) NIL)))))) - ('T |s|))))))) - -;formatDoCommentLine line == -; $lineBuffer := consLineBuffer [nBlanks $c,:line] -; $c := $m+2*$numberOfSpills - -(DEFUN |formatDoCommentLine| (|line|) - (declare (special |$numberOfSpills| |$lineBuffer| |$c| |$m|)) - (PROGN - (SPADLET |$lineBuffer| - (|consLineBuffer| (CONS (|nBlanks| |$c|) |line|))) - (SPADLET |$c| (PLUS |$m| (TIMES 2 |$numberOfSpills|))))) - -;--====================================================================== -;-- Pile Handlers -;--====================================================================== -;formatPreferPile y == -; y is ["SEQ",:l,[.,.,x]] => -; (u:= formatPiles(l,x)) => u -; formatSpill("format",y) -; formatSpill("format",y) - -(DEFUN |formatPreferPile| (|y|) - (PROG (|ISTMP#1| |ISTMP#2| |ISTMP#3| |ISTMP#4| |ISTMP#5| |x| |l| |u|) - (RETURN - (COND - ((AND (PAIRP |y|) (EQ (QCAR |y|) 'SEQ) - (PROGN - (SPADLET |ISTMP#1| (QCDR |y|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (PAIRP |ISTMP#2|) - (PROGN - (SPADLET |ISTMP#3| (QCAR |ISTMP#2|)) - (AND (PAIRP |ISTMP#3|) - (PROGN - (SPADLET |ISTMP#4| (QCDR |ISTMP#3|)) - (AND (PAIRP |ISTMP#4|) - (PROGN - (SPADLET |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (PAIRP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (SPADLET |x| (QCAR |ISTMP#5|)) - 'T))))))) - (PROGN (SPADLET |l| (QCDR |ISTMP#2|)) 'T) - (PROGN (SPADLET |l| (NREVERSE |l|)) 'T)))) - (COND - ((SPADLET |u| (|formatPiles| |l| |x|)) |u|) - ('T (|formatSpill| '|format| |y|)))) - ('T (|formatSpill| '|format| |y|)))))) - -;formatPiles(l,x) == -; $insideTypeExpression : local := false -; not $pilesAreOkHere => nil -; originalC:= $c -; lines:= [:l,x] -; --piles must begin at margin -; originalC=$m or indent() and newLine() or return nil -; null (formatPileLine($m,first lines,false)) => nil -; not (and/[formatPileLine($m,y,true) for y in rest lines]) => nil -; (originalC=$m or undent()) and originalC --==> brace - -(DEFUN |formatPiles| (|l| |x|) - (PROG (|$insideTypeExpression| |originalC| |lines|) - (DECLARE (SPECIAL |$insideTypeExpression| |$m| |$c| |$pilesAreOkHere|)) - (RETURN - (SEQ (PROGN - (SPADLET |$insideTypeExpression| NIL) - (COND - ((NULL |$pilesAreOkHere|) NIL) - ('T (SPADLET |originalC| |$c|) - (SPADLET |lines| (APPEND |l| (CONS |x| NIL))) - (OR (BOOT-EQUAL |originalC| |$m|) - (AND (|indent|) (|newLine|)) (RETURN NIL)) - (COND - ((NULL (|formatPileLine| |$m| (CAR |lines|) NIL)) - NIL) - ((NULL (PROG (G168887) - (SPADLET G168887 'T) - (RETURN - (DO ((G168893 NIL (NULL G168887)) - (G168894 (CDR |lines|) - (CDR G168894)) - (|y| NIL)) - ((OR G168893 (ATOM G168894) - (PROGN - (SETQ |y| (CAR G168894)) - NIL)) - G168887) - (SEQ (EXIT - (SETQ G168887 - (AND G168887 - (|formatPileLine| |$m| |y| 'T))))))))) - NIL) - ('T - (AND (OR (BOOT-EQUAL |originalC| |$m|) (|undent|)) - |originalC|)))))))))) - -;formatPileLine($m,x,newLineIfTrue) == -; if newLineIfTrue then newLine() or return nil -; $numberOfSpills: local:= 0 -; $newLineWritten := nil -; format x and (x is ['SIGNATURE,:.] or $rightBraceFlag => $c; formatSC()) -; and (x is ['DEF,:.] and optNewLine() or $c) - -(DEFUN |formatPileLine| (|$m| |x| |newLineIfTrue|) - (DECLARE (SPECIAL |$m|)) - (PROG (|$numberOfSpills|) - (DECLARE (SPECIAL |$numberOfSpills| |$c| |$rightBraceFlag| - |$newLineWritten| |$numberOfSpills|)) - (RETURN - (PROGN - (COND (|newLineIfTrue| (OR (|newLine|) (RETURN NIL)))) - (SPADLET |$numberOfSpills| 0) - (SPADLET |$newLineWritten| NIL) - (AND (|format| |x|) - (COND - ((OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'SIGNATURE)) - |$rightBraceFlag|) - |$c|) - ('T (|formatSC|))) - (OR (AND (PAIRP |x|) (EQ (QCAR |x|) 'DEF) (|optNewLine|)) - |$c|)))))) - -;--====================================================================== -;-- Utility Functions -;--====================================================================== -;nBlanks m == "STRCONC"/[char('_ ) for i in 1..m] - -(DEFUN |nBlanks| (|m|) - (PROG () - (RETURN - (SEQ (PROG (G168920) - (SPADLET G168920 "") - (RETURN - (DO ((|i| 1 (QSADD1 |i|))) - ((QSGREATERP |i| |m|) G168920) - (SEQ (EXIT (SETQ G168920 - (STRCONC G168920 (|char| '| |)))))))))))) - -;isNewspadOperator op == GET(op,"Led") or GET(op,"Nud") - -(DEFUN |isNewspadOperator| (|op|) - (OR (GETL |op| '|Led|) (GETL |op| '|Nud|))) - -;isTrue x == x="true" or x is '(QUOTE T) - -(DEFUN |isTrue| (|x|) (OR (BOOT-EQUAL |x| '|true|) (EQUAL |x| ''T))) - -;nary2Binary(u,op) == -; u is [a,b,:t] => (t => nary2Binary([[op,a,b],:t],op); [op,a,b]) -; errhuh() - -(DEFUN |nary2Binary| (|u| |op|) - (PROG (|a| |ISTMP#1| |b| |t|) - (RETURN - (COND - ((AND (PAIRP |u|) - (PROGN - (SPADLET |a| (QCAR |u|)) - (SPADLET |ISTMP#1| (QCDR |u|)) - (AND (PAIRP |ISTMP#1|) - (PROGN - (SPADLET |b| (QCAR |ISTMP#1|)) - (SPADLET |t| (QCDR |ISTMP#1|)) - 'T)))) - (COND - (|t| (|nary2Binary| - (CONS (CONS |op| (CONS |a| (CONS |b| NIL))) |t|) - |op|)) - ('T (CONS |op| (CONS |a| (CONS |b| NIL)))))) - ('T (|errhuh|)))))) - -;string2PrintImage s == -; u:= GETSTR (2*SIZE s) -; for i in 0..MAXINDEX s repeat -; (if MEMQ(s.i,'(_( _{ _) _} _! _")) then -; SUFFIX('__,u); u:= SUFFIX(s.i,u)) -; u - -(DEFUN |string2PrintImage| (|s|) - (PROG (|u|) - (RETURN - (SEQ (PROGN - (SPADLET |u| (GETSTR (TIMES 2 (SIZE |s|)))) - (DO ((G168968 (MAXINDEX |s|)) (|i| 0 (QSADD1 |i|))) - ((QSGREATERP |i| G168968) NIL) - (SEQ (EXIT (PROGN - (COND - ((MEMQ (ELT |s| |i|) - '(|(| { |)| } ! |"|)) - (SUFFIX '_ |u|))) - (SPADLET |u| (SUFFIX (ELT |s| |i|) |u|)))))) - |u|))))) - -;ident2PrintImage s == -; m := MAXINDEX s -; if m > 1 and s.(m - 1) = $underScore then s := STRCONC(SUBSTRING(s,0,m-1),s.m) -; u:= GETSTR (2*SIZE s) -; if not (ALPHA_-CHAR_-P s.(0) or s.(0)=char '"$") then SUFFIX('__,u) -; u:= SUFFIX(s.(0),u) -; for i in 1..MAXINDEX s repeat -; if not (DIGITP s.i or ALPHA_-CHAR_-P s.i or ((c := s.i) = char '?) -; or (c = char '!)) then SUFFIX('__,u) -; u:= SUFFIX(s.i,u) -; INTERN u - -(DEFUN |ident2PrintImage| (|s|) - (PROG (|m| |c| |u|) - (declare (special |$underScore|)) - (RETURN - (SEQ (PROGN - (SPADLET |m| (MAXINDEX |s|)) - (COND - ((AND (> |m| 1) - (BOOT-EQUAL (ELT |s| (SPADDIFFERENCE |m| 1)) - |$underScore|)) - (SPADLET |s| - (STRCONC (SUBSTRING |s| 0 - (SPADDIFFERENCE |m| 1)) - (ELT |s| |m|))))) - (SPADLET |u| (GETSTR (TIMES 2 (SIZE |s|)))) - (COND - ((NULL (OR (ALPHA-CHAR-P (ELT |s| 0)) - (BOOT-EQUAL (ELT |s| 0) - (|char| "$")))) - (SUFFIX '_ |u|))) - (SPADLET |u| (SUFFIX (ELT |s| 0) |u|)) - (DO ((G168984 (MAXINDEX |s|)) (|i| 1 (QSADD1 |i|))) - ((QSGREATERP |i| G168984) NIL) - (SEQ (EXIT (PROGN - (COND - ((NULL (OR (DIGITP (ELT |s| |i|)) - (ALPHA-CHAR-P (ELT |s| |i|)) - (BOOT-EQUAL - (SPADLET |c| (ELT |s| |i|)) - (|char| '?)) - (BOOT-EQUAL |c| (|char| '!)))) - (SUFFIX '_ |u|))) - (SPADLET |u| (SUFFIX (ELT |s| |i|) |u|)))))) - (INTERN |u|)))))) - -;isIdentifier x == -; IDENTP x => -; s:= PNAME x -; #s = 0 => nil -; ALPHA_-CHAR_-P s.(0) => and/[s.i^=char '" " for i in 1..MAXINDEX s] -; #s>1 => -; or/[ALPHA_-CHAR_-P s.i for i in 1..(m:= MAXINDEX s)] => -; and/[s.i^=char '" " for i in 1..m] => true - -(DEFUN |isIdentifier| (|x|) - (PROG (|s| |m|) - (RETURN - (SEQ (COND - ((IDENTP |x|) - (EXIT (PROGN - (SPADLET |s| (PNAME |x|)) - (SEQ (COND - ((EQL (|#| |s|) 0) NIL) - ((ALPHA-CHAR-P (ELT |s| 0)) - (PROG (G168998) - (SPADLET G168998 'T) - (RETURN - (DO ((G169004 NIL (NULL G168998)) - (G169005 (MAXINDEX |s|)) - (|i| 1 (QSADD1 |i|))) - ((OR G169004 - (QSGREATERP |i| G169005)) - G168998) - (SEQ - (EXIT - (SETQ G168998 - (AND G168998 - (NEQUAL (ELT |s| |i|) - (|char| " ")))))))))) - ('T - (COND - ((> (|#| |s|) 1) - (COND - ((PROG (G169010) - (SPADLET G169010 NIL) - (RETURN - (DO - ((G169016 NIL G169010) - (G169017 - (SPADLET |m| (MAXINDEX |s|))) - (|i| 1 (QSADD1 |i|))) - ((OR G169016 - (QSGREATERP |i| G169017)) - G169010) - (SEQ - (EXIT - (SETQ G169010 - (OR G169010 - (ALPHA-CHAR-P - (ELT |s| |i|))))))))) - (EXIT - (COND - ((PROG (G169022) - (SPADLET G169022 'T) - (RETURN - (DO - ((G169028 NIL - (NULL G169022)) - (|i| 1 (QSADD1 |i|))) - ((OR G169028 - (QSGREATERP |i| |m|)) - G169022) - (SEQ - (EXIT - (SETQ G169022 - (AND G169022 - (NEQUAL (ELT |s| |i|) - (|char| - " "))))))))) - (EXIT 'T))))))))))))))))))) - -;isGensym x == -; s := STRINGIMAGE x -; n := MAXINDEX s -; s.0 = char '_G and and/[DIGITP s.i for i in 1..n] - -(DEFUN |isGensym| (|x|) - (PROG (|s| |n|) - (RETURN - (SEQ (PROGN - (SPADLET |s| (STRINGIMAGE |x|)) - (SPADLET |n| (MAXINDEX |s|)) - (AND (BOOT-EQUAL (ELT |s| 0) (|char| 'G)) - (PROG (G169042) - (SPADLET G169042 'T) - (RETURN - (DO ((G169048 NIL (NULL G169042)) - (|i| 1 (QSADD1 |i|))) - ((OR G169048 (QSGREATERP |i| |n|)) - G169042) - (SEQ (EXIT (SETQ G169042 - (AND G169042 - (DIGITP (ELT |s| |i|))))))))))))))) - -;--====================================================================== -;-- Macro Helpers -;--====================================================================== -;tryToFit(s,x) == -;--% try to format on current line; see macro try in file PSPADAUX LISP -; --returns nil if unable to format stuff in x on a single line -; x => ($back:= rest $back; $c) -; restoreState() -; nil - -(DEFUN |tryToFit| (|s| |x|) - (declare (special |$back| |$c|) (ignore |s|)) - (COND - (|x| (SPADLET |$back| (CDR |$back|)) |$c|) - ('T (|restoreState|) NIL))) - -;restoreState(:options) == -; back := IFCAR options or $back -; [ -; [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, -; $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :back] -; := back -; if null options then $back := back -; [$newLineWritten, $autoLine, $rightBraceFlag, -; $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, -; $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, -; $doNotResetMarginIfTrue,$noColonDeclaration] -; := flags -; nil - -(DEFUN |restoreState| (&REST G169139 &AUX |options|) - (DSETQ |options| G169139) - (PROG (|LETTMP#1| |flags| |back|) - (declare (special |$noColonDeclaration| |$doNotResetMarginIfTrue| - |$insideCategoryIfTrue| |$insideCAPSULE| - |$insideEXPORTS| |$pilesAreOkHere| |$insideTypeExpression| - |$insideDEF| |$semicolonFlag| |$rightBraceFlag| - |$autoLine| |$newLineWritten| |$back| |$numberOfSpills| - |$commentsToPrint| |$m| |$c| |$bc| |$DEFdepth| - |$braceStack| |$marginStack| |$comments| |$lineBuffer| - |$lineFragmentBuffer|)) - (RETURN - (PROGN - (SPADLET |back| (OR (IFCAR |options|) |$back|)) - (SPADLET |LETTMP#1| |back|) - (SPADLET |$lineBuffer| (CAAR |LETTMP#1|)) - (SPADLET |$lineFragmentBuffer| (CADAR |LETTMP#1|)) - (SPADLET |$comments| (CADDAR |LETTMP#1|)) - (SPADLET |$marginStack| (CAR (CDDDAR |LETTMP#1|))) - (SPADLET |$braceStack| (CADR (CDDDAR |LETTMP#1|))) - (SPADLET |$DEFdepth| (CADDR (CDDDAR |LETTMP#1|))) - (SPADLET |$bc| (CADDDR (CDDDAR |LETTMP#1|))) - (SPADLET |$c| (CAR (CDDDDR (CDDDAR |LETTMP#1|)))) - (SPADLET |$m| (CADR (CDDDDR (CDDDAR |LETTMP#1|)))) - (SPADLET |$commentsToPrint| - (CADDR (CDDDDR (CDDDAR |LETTMP#1|)))) - (SPADLET |$numberOfSpills| - (CADDDR (CDDDDR (CDDDAR |LETTMP#1|)))) - (SPADLET |flags| (CAR (CDDDDR (CDDDDR (CDDDAR |LETTMP#1|))))) - (SPADLET |back| (CDR |LETTMP#1|)) - (COND ((NULL |options|) (SPADLET |$back| |back|))) - (SPADLET |$newLineWritten| (CAR |flags|)) - (SPADLET |$autoLine| (CADR |flags|)) - (SPADLET |$rightBraceFlag| (CADDR |flags|)) - (SPADLET |$semicolonFlag| (CADDDR |flags|)) - (SPADLET |$insideDEF| (CAR (CDDDDR |flags|))) - (SPADLET |$insideTypeExpression| (CADR (CDDDDR |flags|))) - (SPADLET |$pilesAreOkHere| (CADDR (CDDDDR |flags|))) - (SPADLET |$insideEXPORTS| (CADDDR (CDDDDR |flags|))) - (SPADLET |$insideCAPSULE| (CAR (CDDDDR (CDDDDR |flags|)))) - (SPADLET |$insideCategoryIfTrue| - (CADR (CDDDDR (CDDDDR |flags|)))) - (SPADLET |$doNotResetMarginIfTrue| - (CADDR (CDDDDR (CDDDDR |flags|)))) - (SPADLET |$noColonDeclaration| - (CADDDR (CDDDDR (CDDDDR |flags|)))) - NIL)))) - -;saveState(:options) == -; flags := -; [$newLineWritten, $autoLine, $rightBraceFlag, -; $semicolonFlag,$insideDEF,$insideTypeExpression,$pilesAreOkHere, -; $insideEXPORTS, $insideCAPSULE, $insideCategoryIfTrue, -; $doNotResetMarginIfTrue,$noColonDeclaration] -; newState := -; [ -; [$lineBuffer, $lineFragmentBuffer,$comments,$marginStack,$braceStack,$DEFdepth, -; $bc,$c,$m,$commentsToPrint,$numberOfSpills,flags], :$back] -; if not KAR options then $back := newState -; newState - -(DEFUN |saveState| (&REST G169147 &AUX |options|) - (DSETQ |options| G169147) - (PROG (|flags| |newState|) - (declare (special |$back| |$numberOfSpills| |$commentsToPrint| |$m| |$c| - |$bc| |$DEFdepth| |$braceStack| |$marginStack| - |$comments| |$lineFragmentBuffer| |$lineBuffer| - |$newLineWritten| |$autoLine| |$rightBraceFlag| - |$semicolonFlag| |$insideDEF| |$insideTypeExpression| - |$pilesAreOkHere| |$insideEXPORTS| |$insideCAPSULE| - |$doNotResetMarginIfTrue| |$noColonDeclaration|)) - (RETURN - (PROGN - (SPADLET |flags| - (CONS |$newLineWritten| - (CONS |$autoLine| - (CONS |$rightBraceFlag| - (CONS |$semicolonFlag| - (CONS |$insideDEF| - (CONS |$insideTypeExpression| - (CONS |$pilesAreOkHere| - (CONS |$insideEXPORTS| - (CONS |$insideCAPSULE| - (CONS |$insideCategoryIfTrue| - (CONS - |$doNotResetMarginIfTrue| - (CONS |$noColonDeclaration| - NIL))))))))))))) - (SPADLET |newState| - (CONS (CONS |$lineBuffer| - (CONS |$lineFragmentBuffer| - (CONS |$comments| - (CONS |$marginStack| - (CONS |$braceStack| - (CONS |$DEFdepth| - (CONS |$bc| - (CONS |$c| - (CONS |$m| - (CONS |$commentsToPrint| - (CONS |$numberOfSpills| - (CONS |flags| NIL)))))))))))) - |$back|)) - (COND ((NULL (KAR |options|)) (SPADLET |$back| |newState|))) - |newState|)))) - -;formatSC() == -; $pileStyle or $semicolonFlag => $c -; format "; " - -(DEFUN |formatSC| () - (declare (special |$pileStyle| |$semicolonFlag| |$c|)) - (COND - ((OR |$pileStyle| |$semicolonFlag|) |$c|) - ('T (|format| '|; |)))) - -;wrapBraces(x,y,z) == y - -(DEFUN |wrapBraces| (|x| |y| |z|) - (declare (ignore |x| |z|)) - |y|) - -;formatLB() == -; $pileStyle => $c -; $numberOfSpills := -; $c > $lineLength / 2 => $braceIndentation/3 - 1 -; $braceIndentation/2 - 1 -; format "{" - -(DEFUN |formatLB| () - (declare (special |$braceIndentation| |$lineLength| |$numberOfSpills| |$c| - |$pileStyle|)) - (COND - (|$pileStyle| |$c|) - ('T - (SPADLET |$numberOfSpills| - (COND - ((> |$c| (QUOTIENT |$lineLength| 2)) - (SPADDIFFERENCE (QUOTIENT |$braceIndentation| 3) 1)) - ('T - (SPADDIFFERENCE (QUOTIENT |$braceIndentation| 2) 1)))) - (|format| '{)))) - -;restoreC() == --used by macro "embrace" -; originalC := CAR $braceStack -; $braceStack := CDR $braceStack -; formatRB originalC - -(DEFUN |restoreC| () - (PROG (|originalC|) - (declare (special |$braceStack|)) - (RETURN - (PROGN - (SPADLET |originalC| (CAR |$braceStack|)) - (SPADLET |$braceStack| (CDR |$braceStack|)) - (|formatRB| |originalC|))))) - -;saveC() == --used by macro "embrace" -; $braceStack := [$c,:$braceStack] - -(DEFUN |saveC| () - (declare (special |$braceStack| |$c|)) - (SPADLET |$braceStack| (CONS |$c| |$braceStack|))) - -;saveD() == --used by macro "embrace" -; $braceStack := [$c,:$braceStack] - -(DEFUN |saveD| () - (declare (special |$braceStack| |$c|)) - (SPADLET |$braceStack| (CONS |$c| |$braceStack|))) - -;restoreD() == --used by macro "indentNB" -; originalC := CAR $braceStack -; $braceStack := CDR $braceStack -; originalC - -(DEFUN |restoreD| () - (PROG (|originalC|) - (declare (special |$braceStack|)) - (RETURN - (PROGN - (SPADLET |originalC| (CAR |$braceStack|)) - (SPADLET |$braceStack| (CDR |$braceStack|)) - |originalC|)))) - -;formatRB(originalC) == --called only by restoreC -; while $marginStack and $m > originalC repeat undent() -; if $m < originalC then $marginStack := [originalC,:$marginStack] -; $m := originalC -; $pileStyle => $m -; newLine() and format "}" and $m --==> brace - -(DEFUN |formatRB| (|originalC|) - (declare (special |$m| |$pileStyle| |$marginStack|)) - (SEQ (PROGN - (DO () ((NULL (AND |$marginStack| (> |$m| |originalC|))) NIL) - (SEQ (EXIT (|undent|)))) - (COND - ((> |originalC| |$m|) - (SPADLET |$marginStack| (CONS |originalC| |$marginStack|)))) - (SPADLET |$m| |originalC|) - (COND - (|$pileStyle| |$m|) - ('T (AND (|newLine|) (|format| '}) |$m|)))))) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}