diff --git a/changelog b/changelog index 1862c19..64e8e3d 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20090922 tpd src/axiom-website/patches.html 20090922.03.tpd.patch +20090922 tpd src/interp/apply.lisp cleanup 20090922 tpd src/axiom-website/patches.html 20090922.02.tpd.patch 20090922 tpd src/interp/c-util.lisp cleanup 20090922 tpd src/axiom-website/patches.html 20090922.01.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 045255d..812a596 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -2014,5 +2014,7 @@ Makefile stop making bootdir
src/interp/cattable.lisp cleanup
20090922.02.tpd.patch src/interp/c-util.lisp cleanup
+20090922.03.tpd.patch +src/interp/apply.lisp cleanup
diff --git a/src/interp/apply.lisp.pamphlet b/src/interp/apply.lisp.pamphlet index 09e326d..1969e16 100644 --- a/src/interp/apply.lisp.pamphlet +++ b/src/interp/apply.lisp.pamphlet @@ -28,72 +28,101 @@ ; nil (DEFUN |compAtomWithModemap| (|x| |m| |e| |v|) - (PROG (tmp1 tmp2 tmp3 tmp4 tmp5 |fn| |target| T$ |y| transimp) - (RETURN - (SEQ - (COND - ((setq transimp - (PROG (t0) - (setq t0 NIL) - (RETURN - (DO ((t1 |v| (CDR t1)) (|map| NIL)) - ((OR (ATOM t1) (PROGN (SETQ |map| (CAR t1)) NIL)) - (NREVERSE0 t0)) - (SEQ - (EXIT - (COND - ((AND (PAIRP |map|) - (PROGN - (setq tmp1 (QCAR |map|)) - (AND - (PAIRP tmp1) - (PROGN - (setq tmp2 (QCDR tmp1)) - (AND - (PAIRP tmp2) - (EQ (QCDR tmp2) NIL) - (PROGN (setq |target| (QCAR tmp2)) t))))) - (PROGN - (setq tmp3 (QCDR |map|)) - (AND - (PAIRP tmp3) - (EQ (QCDR tmp3) NIL) - (PROGN - (setq tmp4 (QCAR tmp3)) - (AND (PAIRP tmp4) - (PROGN - (setq tmp5 (QCDR tmp4)) - (AND (PAIRP tmp5) - (EQ (QCDR tmp5) NIL) - (PROGN (setq |fn| (QCAR tmp5)) t)))))))) - (SETQ t0 - (CONS - (CONS - (|transImplementation| |x| |map| |fn|) - (CONS |target| (CONS |e| NIL))) - t0)))))))))) - (EXIT - (COND - ((setq T$ (PROG (t2) (setq t2 NIL) (RETURN (DO ((t3 NIL t2) (t4 transimp (CDR t4)) (|t| NIL)) ((OR t3 (ATOM t4) (PROGN (SETQ |t| (CAR t4)) NIL) (PROGN (PROGN (setq |target| (CADR |t|)) |t|) NIL)) t2) (SEQ (EXIT (COND ((|modeEqual| |m| |target|) (SETQ t2 (OR t2 |t|)))))))))) T$) - ((EQL 1 - (|#| - (setq transimp - (PROG (t5) - (setq t5 NIL) - (RETURN - (DO ((t6 transimp (CDR t6)) (|t| NIL)) - ((OR (ATOM t6) (PROGN (SETQ |t| (CAR t6)) NIL)) - (NREVERSE0 t5)) - (SEQ - (EXIT - (COND - ((setq |y| (|convert| |t| |m|)) - (setq t5 (cons |y| t5)))))))))))) - (car transimp)) - ((and (qslessp 0 (|#| transimp)) (boot-equal |m| |$NoValueMode|)) - (car transimp)) - (t nil))))))))) - + (PROG (TMP1 TMP2 TMP3 TMP4 TMP5 |fn| |target| T$ |y| TRANSIMP) + (declare (special |$NoValueMode|)) + (RETURN + (SEQ (COND + ((SETQ TRANSIMP + (PROG (T0) + (SETQ T0 NIL) + (RETURN + (DO ((T1 |v| (CDR T1)) (|map| NIL)) + ((OR (ATOM T1) + (PROGN (SETQ |map| (CAR T1)) NIL)) + (NREVERSE0 T0)) + (SEQ (EXIT (COND + ((AND (PAIRP |map|) + (PROGN + (SETQ TMP1 (QCAR |map|)) + (AND (PAIRP TMP1) + (PROGN + (SETQ TMP2 (QCDR TMP1)) + (AND (PAIRP TMP2) + (EQ (QCDR TMP2) NIL) + (PROGN + (SETQ |target| + (QCAR TMP2)) + T))))) + (PROGN + (SETQ TMP3 (QCDR |map|)) + (AND (PAIRP TMP3) + (EQ (QCDR TMP3) NIL) + (PROGN + (SETQ TMP4 (QCAR TMP3)) + (AND (PAIRP TMP4) + (PROGN + (SETQ TMP5 + (QCDR TMP4)) + (AND (PAIRP TMP5) + (EQ (QCDR TMP5) NIL) + (PROGN + (SETQ |fn| + (QCAR TMP5)) + T)))))))) + (SETQ T0 + (CONS + (CONS + (|transImplementation| |x| + |map| |fn|) + (CONS |target| + (CONS |e| NIL))) + T0)))))))))) + (EXIT (COND + ((SETQ T$ + (PROG (T2) + (SETQ T2 NIL) + (RETURN + (DO ((T3 NIL T2) + (T4 TRANSIMP (CDR T4)) (|t| NIL)) + ((OR T3 (ATOM T4) + (PROGN (SETQ |t| (CAR T4)) NIL) + (PROGN + (PROGN + (SETQ |target| (CADR |t|)) + |t|) + NIL)) + T2) + (SEQ + (EXIT + (COND + ((|modeEqual| |m| |target|) + (SETQ T2 (OR T2 |t|)))))))))) + T$) + ((EQL 1 + (|#| (SETQ TRANSIMP + (PROG (T5) + (SETQ T5 NIL) + (RETURN + (DO + ((T6 TRANSIMP (CDR T6)) + (|t| NIL)) + ((OR (ATOM T6) + (PROGN + (SETQ |t| (CAR T6)) + NIL)) + (NREVERSE0 T5)) + (SEQ + (EXIT + (COND + ((SETQ |y| + (|convert| |t| |m|)) + (SETQ T5 + (CONS |y| T5)))))))))))) + (CAR TRANSIMP)) + ((AND (QSLESSP 0 (|#| TRANSIMP)) + (BOOT-EQUAL |m| |$NoValueMode|)) + (CAR TRANSIMP)) + (T NIL))))))))) ;transImplementation(op,map,fn) == ;--+ @@ -101,12 +130,11 @@ ; fn is ["XLAM",:.] => [fn] ; ["call",fn] -(defun |transImplementation| (op map fn) - (setq fn (|genDeltaEntry| (cons op map))) - (cond - ((and (pairp fn) (eq (qcar fn) 'xlam)) (cons fn nil)) - (t (cons '|call| (cons fn nil))))) - +(DEFUN |transImplementation| (OP MAP FN) + (SETQ FN (|genDeltaEntry| (CONS OP MAP))) + (COND + ((AND (PAIRP FN) (EQ (QCAR FN) 'XLAM)) (CONS FN NIL)) + (T (CONS '|call| (CONS FN NIL))))) ;compApply(sig,varl,body,argl,m,e) == ; argTl:= [[.,.,e]:= comp(x,$EmptyMode,e) for x in argl] @@ -118,62 +146,55 @@ ; body':= (comp(body,m',addContour(contour,e))).expr ; [code,m',e] -(defun |compApply| (sig varl body argl m e) - (let (temp1 argTl contour code mq bodyq) - (setq argTl - (prog (t0) - (setq t0 nil) - (return - (do ((t1 argl (cdr t1)) (|x| nil)) - ((or (atom t1) (progn (setq |x| (car t1)) nil)) (nreverse0 t0)) - (seq - (exit - (setq t0 - (cons - (progn - (setq temp1 (|comp| |x| |$EmptyMode| e)) - (setq e (caddr temp1)) - temp1) - t0)))))))) - (setq contour - (prog (t2) - (setq t2 NIL) - (return - (do ((t3 varl (cdr t3)) - (|x| nil) - (t4 (cdr sig) (cdr t4)) - (mq nil) - (t5 argl (cdr t5)) - (|a| nil)) - ((or (atom t3) - (progn (setq |x| (car t3)) nil) - (atom t4) - (progn (setq mq (car t4)) nil) - (atom t5) - (progn (setq |a| (car t5)) nil)) - (nreverse0 t2)) - (setq t2 - (cons - (|Pair| |x| - (cons - (cons '|mode| (cons mq nil)) - (cons - (cons '|value| (cons (|removeEnv| (|comp| |a| mq e)) nil)) - nil))) - t2)))))) - (setq code - (cons - (cons 'lambda (cons varl (cons bodyq nil))) - (prog (t6) - (setq t6 nil) - (return - (do ((t7 argTl (cdr t7)) (T$ nil)) - ((or (atom t7) (progn (setq T$ (car t7)) nil)) (nreverse0 t6)) - (setq t6 (cons (car T$) t6))))))) - (setq mq (|resolve| m (car sig))) - (setq bodyq (car (|comp| body mq (|addContour| contour e)))) - (cons code (cons mq (cons e nil))))) - +(DEFUN |compApply| (SIG VARL BODY ARGL M E) + (LET (TEMP1 ARGTL CONTOUR CODE MQ BODYQ) + (declare (special |$EmptyMode|)) + (SETQ ARGTL + (PROG (T0) + (SETQ T0 NIL) + (RETURN + (DO ((T1 ARGL (CDR T1)) (|x| NIL)) + ((OR (ATOM T1) (PROGN (SETQ |x| (CAR T1)) NIL)) + (NREVERSE0 T0)) + (SEQ (EXIT (SETQ T0 + (CONS (PROGN + (SETQ TEMP1 + (|comp| |x| |$EmptyMode| E)) + (SETQ E (CADDR TEMP1)) + TEMP1) + T0)))))))) + (SETQ CONTOUR + (PROG (T2) + (SETQ T2 NIL) + (RETURN + (DO ((T3 VARL (CDR T3)) (|x| NIL) (T4 (CDR SIG) (CDR T4)) + (MQ NIL) (T5 ARGL (CDR T5)) (|a| NIL)) + ((OR (ATOM T3) (PROGN (SETQ |x| (CAR T3)) NIL) + (ATOM T4) (PROGN (SETQ MQ (CAR T4)) NIL) + (ATOM T5) (PROGN (SETQ |a| (CAR T5)) NIL)) + (NREVERSE0 T2)) + (SETQ T2 + (CONS (|Pair| |x| + (CONS (CONS '|mode| (CONS MQ NIL)) + (CONS + (CONS '|value| + (CONS + (|removeEnv| (|comp| |a| MQ E)) + NIL)) + NIL))) + T2)))))) + (SETQ CODE + (CONS (CONS 'LAMBDA (CONS VARL (CONS BODYQ NIL))) + (PROG (T6) + (SETQ T6 NIL) + (RETURN + (DO ((T7 ARGTL (CDR T7)) (T$ NIL)) + ((OR (ATOM T7) (PROGN (SETQ T$ (CAR T7)) NIL)) + (NREVERSE0 T6)) + (SETQ T6 (CONS (CAR T$) T6))))))) + (SETQ MQ (|resolve| M (CAR SIG))) + (SETQ BODYQ (CAR (|comp| BODY MQ (|addContour| CONTOUR E)))) + (CONS CODE (CONS MQ (CONS E NIL))))) ;compToApply(op,argl,m,e) == ; T:= compNoStacking(op,$EmptyMode,e) or return nil @@ -181,8 +202,25 @@ ; T.expr is ["QUOTE", =m1] => nil ; compApplication(op,argl,m,T.env,T) -(DEFUN |compToApply| (|op| |argl| |m| |e|) (PROG (T$ |m1| tmp1 tmp2) (RETURN (PROGN (setq T$ (OR (|compNoStacking| |op| |$EmptyMode| |e|) (RETURN NIL))) (setq |m1| (CADR T$)) (COND ((PROGN (setq tmp1 (CAR T$)) (AND (PAIRP tmp1) (EQ (QCAR tmp1) (QUOTE QUOTE)) (PROGN (setq tmp2 (QCDR tmp1)) (AND (PAIRP tmp2) (EQ (QCDR tmp2) NIL) (EQUAL (QCAR tmp2) |m1|))))) NIL) (t (|compApplication| |op| |argl| |m| (CADDR T$) T$))))))) - +(DEFUN |compToApply| (|op| |argl| |m| |e|) + (PROG (T$ |m1| TMP1 TMP2) + (declare (special |$EmptyMode|)) + (RETURN + (PROGN + (SETQ T$ + (OR (|compNoStacking| |op| |$EmptyMode| |e|) + (RETURN NIL))) + (SETQ |m1| (CADR T$)) + (COND + ((PROGN + (SETQ TMP1 (CAR T$)) + (AND (PAIRP TMP1) (EQ (QCAR TMP1) 'QUOTE) + (PROGN + (SETQ TMP2 (QCDR TMP1)) + (AND (PAIRP TMP2) (EQ (QCDR TMP2) NIL) + (EQUAL (QCAR TMP2) |m1|))))) + NIL) + (T (|compApplication| |op| |argl| |m| (CADDR T$) T$))))))) ;compApplication(op,argl,m,e,T) == ; T.mode is ['Mapping, retm, :argml] => @@ -205,8 +243,121 @@ ; eltForm := ['elt, op, :argl] ; comp(eltForm, m, e) -(DEFUN |compApplication| (|op| |argl| |m| |e| T$) (PROG (tmp1 tmp2 |argml| |retm| temp1 |argTl| |nprefix| |op'| |form| |eltForm|) (RETURN (SEQ (COND ((PROGN (setq tmp1 (CADR T$)) (AND (PAIRP tmp1) (EQ (QCAR tmp1) (QUOTE |Mapping|)) (PROGN (setq tmp2 (QCDR tmp1)) (AND (PAIRP tmp2) (PROGN (setq |retm| (QCAR tmp2)) (setq |argml| (QCDR tmp2)) t))))) (COND ((NEQUAL (|#| |argl|) (|#| |argml|)) NIL) (t (setq |retm| (|resolve| |m| |retm|)) (COND ((OR (BOOT-EQUAL |retm| |$Category|) (|isCategoryForm| |retm| |e|)) NIL) (t (setq |argTl| (PROG (t0) (setq t0 NIL) (RETURN (DO ((t1 |argl| (CDR t1)) (|x| NIL) (t2 |argml| (CDR t2)) (|m| NIL)) ((OR (ATOM t1) (PROGN (SETQ |x| (CAR t1)) NIL) (ATOM t2) (PROGN (SETQ |m| (CAR t2)) NIL)) (NREVERSE0 t0)) (SEQ (EXIT (SETQ t0 (CONS (PROGN (setq temp1 (OR (|comp| |x| |m| |e|) (RETURN (QUOTE |failed|)))) (setq |e| (CADDR temp1)) temp1) t0)))))))) (COND ((BOOT-EQUAL |argTl| (QUOTE |failed|)) NIL) (t (setq |form| (COND ((AND (NULL (OR (|member| |op| |$formalArgList|) (|member| (CAR T$) |$formalArgList|))) (ATOM (CAR T$))) (setq |nprefix| (OR |$prefix| (|getAbbreviation| |$op| (|#| (CDR |$form|))))) (setq |op'| (INTERN (STRCONC (|encodeItem| |nprefix|) (QUOTE |;|) (|encodeItem| (CAR T$))))) (CONS |op'| (APPEND (PROG (t3) (setq t3 NIL) (RETURN (DO ((t4 |argTl| (CDR t4)) (|a| NIL)) ((OR (ATOM t4) (PROGN (SETQ |a| (CAR t4)) NIL)) (NREVERSE0 t3)) (SEQ (EXIT (SETQ t3 (CONS (CAR |a|) t3))))))) (CONS (QUOTE $) NIL)))) (t (CONS (QUOTE |call|) (CONS (CONS (QUOTE |applyFun|) (CONS (CAR T$) NIL)) (PROG (t5) (setq t5 NIL) (RETURN (DO ((t6 |argTl| (CDR t6)) (|a| NIL)) ((OR (ATOM t6) (PROGN (SETQ |a| (CAR t6)) NIL)) (NREVERSE0 t5)) (SEQ (EXIT (SETQ t5 (CONS (CAR |a|) t5)))))))))))) (|coerce| (CONS |form| (CONS |retm| (CONS |e| NIL))) (|resolve| |retm| |m|))))))))) ((BOOT-EQUAL |op| (QUOTE |elt|)) NIL) (t (setq |eltForm| (CONS (QUOTE |elt|) (CONS |op| |argl|))) (|comp| |eltForm| |m| |e|))))))) - +(DEFUN |compApplication| (|op| |argl| |m| |e| T$) + (PROG (TMP1 TMP2 |argml| |retm| TEMP1 |argTl| |nprefix| |op'| |form| + |eltForm|) + (declare (special |$form| |$op| |$prefix| |$formalArgList| |$Category|)) + (RETURN + (SEQ (COND + ((PROGN + (SETQ TMP1 (CADR T$)) + (AND (PAIRP TMP1) (EQ (QCAR TMP1) '|Mapping|) + (PROGN + (SETQ TMP2 (QCDR TMP1)) + (AND (PAIRP TMP2) + (PROGN + (SETQ |retm| (QCAR TMP2)) + (SETQ |argml| (QCDR TMP2)) + T))))) + (COND + ((NEQUAL (|#| |argl|) (|#| |argml|)) NIL) + (T (SETQ |retm| (|resolve| |m| |retm|)) + (COND + ((OR (BOOT-EQUAL |retm| |$Category|) + (|isCategoryForm| |retm| |e|)) + NIL) + (T (SETQ |argTl| + (PROG (T0) + (SETQ T0 NIL) + (RETURN + (DO ((T1 |argl| (CDR T1)) (|x| NIL) + (T2 |argml| (CDR T2)) (|m| NIL)) + ((OR (ATOM T1) + (PROGN + (SETQ |x| (CAR T1)) + NIL) + (ATOM T2) + (PROGN + (SETQ |m| (CAR T2)) + NIL)) + (NREVERSE0 T0)) + (SEQ + (EXIT + (SETQ T0 + (CONS + (PROGN + (SETQ TEMP1 + (OR (|comp| |x| |m| |e|) + (RETURN '|failed|))) + (SETQ |e| (CADDR TEMP1)) + TEMP1) + T0)))))))) + (COND + ((BOOT-EQUAL |argTl| '|failed|) NIL) + (T (SETQ |form| + (COND + ((AND + (NULL + (OR + (|member| |op| + |$formalArgList|) + (|member| (CAR T$) + |$formalArgList|))) + (ATOM (CAR T$))) + (SETQ |nprefix| + (OR |$prefix| + (|getAbbreviation| |$op| + (|#| (CDR |$form|))))) + (SETQ |op'| + (INTERN + (STRCONC + (|encodeItem| |nprefix|) '|;| + (|encodeItem| (CAR T$))))) + (CONS |op'| + (APPEND + (PROG (T3) + (SETQ T3 NIL) + (RETURN + (DO + ((T4 |argTl| (CDR T4)) + (|a| NIL)) + ((OR (ATOM T4) + (PROGN + (SETQ |a| (CAR T4)) + NIL)) + (NREVERSE0 T3)) + (SEQ + (EXIT + (SETQ T3 + (CONS (CAR |a|) T3))))))) + (CONS '$ NIL)))) + (T + (CONS '|call| + (CONS + (CONS '|applyFun| + (CONS (CAR T$) NIL)) + (PROG (T5) + (SETQ T5 NIL) + (RETURN + (DO + ((T6 |argTl| (CDR T6)) + (|a| NIL)) + ((OR (ATOM T6) + (PROGN + (SETQ |a| (CAR T6)) + NIL)) + (NREVERSE0 T5)) + (SEQ + (EXIT + (SETQ T5 + (CONS (CAR |a|) T5)))))))))))) + (|coerce| + (CONS |form| + (CONS |retm| (CONS |e| NIL))) + (|resolve| |retm| |m|))))))))) + ((BOOT-EQUAL |op| '|elt|) NIL) + (T (SETQ |eltForm| (CONS '|elt| (CONS |op| |argl|))) + (|comp| |eltForm| |m| |e|))))))) ;compFormWithModemap(form is [op,:argl],m,e,modemap) == ; [map:= [.,target,:.],[pred,impl]]:= modemap @@ -247,8 +398,124 @@ ; e ; convert(T,m) -(DEFUN |compFormWithModemap| (|form| |m| |e| |modemap|) (PROG (|op| |argl| |pred| |impl| |sv| |target| |cexpr| |target'| |map| temp1 |f| transimp |sl| |m'| |form'| |z| |c| tmp3 |c1| tmp1 tmp2 |x'| |e'| T$) (RETURN (SEQ (PROGN (setq |op| (CAR |form|)) (setq |argl| (CDR |form|)) (setq |map| (CAR |modemap|)) (setq |target| (CADAR |modemap|)) (setq |pred| (CAADR |modemap|)) (setq |impl| (CADADR |modemap|)) (COND ((AND (|isCategoryForm| |target| |e|) (|isFunctor| |op|)) (setq temp1 (OR (|substituteIntoFunctorModemap| |argl| |modemap| |e|) (RETURN NIL))) (setq |modemap| (CAR temp1)) (setq |e| (CADR temp1)) (setq |map| (CAR |modemap|)) (setq |target| (CADAR |modemap|)) (setq |cexpr| (CDR |modemap|)) |modemap|)) (setq |sv| (|listOfSharpVars| |map|)) (COND (|sv| (DO ((t0 |argl| (CDR t0)) (|x| NIL) (t1 |$FormalMapVariableList| (CDR t1)) (|ss| NIL)) ((OR (ATOM t0) (PROGN (SETQ |x| (CAR t0)) NIL) (ATOM t1) (PROGN (SETQ |ss| (CAR t1)) NIL)) NIL) (SEQ (EXIT (COND ((|member| |ss| |sv|) (setq |modemap| (MSUBST |x| |ss| |modemap|)) (setq |map| (CAR |modemap|)) (setq |target| (CADAR |modemap|)) (setq |cexpr| (CDR |modemap|)) |modemap|) (t NIL))))))) (COND ((NULL (setq |target'| (|coerceable| |target| |m| |e|))) NIL) (t (setq |map| (CONS |target'| (CDR |map|))) (setq temp1 (OR (|compApplyModemap| |form| |modemap| |e| NIL) (RETURN NIL))) (setq |f| (CAR temp1)) (setq transimp (CADR temp1)) (setq |sl| (CADDR temp1)) (setq |m'| (SUBLIS |sl| (ELT |map| 1))) (setq |x'| (PROGN (setq |form'| (CONS |f| (PROG (t2) (setq t2 NIL) (RETURN (DO ((t3 transimp (CDR t3)) (|t| NIL)) ((OR (ATOM t3) (PROGN (SETQ |t| (CAR t3)) NIL)) (NREVERSE0 t2)) (SEQ (EXIT (SETQ t2 (CONS (CAR |t|) t2))))))))) (COND ((OR (BOOT-EQUAL |m'| |$Category|) (|isCategoryForm| |m'| |e|)) |form'|) ((AND (BOOT-EQUAL |op| (QUOTE |elt|)) (PAIRP |f|) (EQ (QCAR |f|) (QUOTE XLAM)) (IDENTP (setq |z| (CAR |argl|))) (setq |c| (|get| |z| (QUOTE |condition|) |e|)) (PAIRP |c|) (EQ (QCDR |c|) NIL) (PROGN (setq tmp1 (QCAR |c|)) (AND (PAIRP tmp1) (EQ (QCAR tmp1) (QUOTE |case|)) (PROGN (setq tmp2 (QCDR tmp1)) (AND (PAIRP tmp2) (EQUAL (QCAR tmp2) |z|) (PROGN (setq tmp3 (QCDR tmp2)) (AND (PAIRP tmp3) (EQ (QCDR tmp3) NIL) (PROGN (setq |c1| (QCAR tmp3)) t))))))) (OR (AND (PAIRP |c1|) (EQ (QCAR |c1|) (QUOTE |:|)) (PROGN (setq tmp1 (QCDR |c1|)) (AND (PAIRP tmp1) (EQUAL (QCAR tmp1) (CADR |argl|)) (PROGN (setq tmp2 (QCDR tmp1)) (AND (PAIRP tmp2) (EQ (QCDR tmp2) NIL) (EQUAL (QCAR tmp2) |m|)))))) (EQ |c1| (CADR |argl|)))) (CONS (QUOTE CDR) (CONS |z| NIL))) (t (CONS (QUOTE |call|) |form'|))))) (setq |e'| (COND (transimp (CADDR (|last| transimp))) (t |e|))) (setq T$ (CONS |x'| (CONS |m'| (CONS |e'| NIL)))) (|convert| T$ |m|)))))))) - +(DEFUN |compFormWithModemap| (|form| |m| |e| |modemap|) + (PROG (|op| |argl| |pred| |impl| |sv| |target| |cexpr| |target'| + |map| TEMP1 |f| TRANSIMP |sl| |m'| |form'| |z| |c| TMP3 + |c1| TMP1 TMP2 |x'| |e'| T$) + (declare (special |$Category| |$FormalMapVariableList|)) + (RETURN + (SEQ (PROGN + (SETQ |op| (CAR |form|)) + (SETQ |argl| (CDR |form|)) + (SETQ |map| (CAR |modemap|)) + (SETQ |target| (CADAR |modemap|)) + (SETQ |pred| (CAADR |modemap|)) + (SETQ |impl| (CADADR |modemap|)) + (COND + ((AND (|isCategoryForm| |target| |e|) + (|isFunctor| |op|)) + (SETQ TEMP1 + (OR (|substituteIntoFunctorModemap| |argl| + |modemap| |e|) + (RETURN NIL))) + (SETQ |modemap| (CAR TEMP1)) (SETQ |e| (CADR TEMP1)) + (SETQ |map| (CAR |modemap|)) + (SETQ |target| (CADAR |modemap|)) + (SETQ |cexpr| (CDR |modemap|)) |modemap|)) + (SETQ |sv| (|listOfSharpVars| |map|)) + (COND + (|sv| (DO ((T0 |argl| (CDR T0)) (|x| NIL) + (T1 |$FormalMapVariableList| (CDR T1)) + (|ss| NIL)) + ((OR (ATOM T0) (PROGN (SETQ |x| (CAR T0)) NIL) + (ATOM T1) + (PROGN (SETQ |ss| (CAR T1)) NIL)) + NIL) + (SEQ (EXIT (COND + ((|member| |ss| |sv|) + (SETQ |modemap| + (MSUBST |x| |ss| |modemap|)) + (SETQ |map| (CAR |modemap|)) + (SETQ |target| (CADAR |modemap|)) + (SETQ |cexpr| (CDR |modemap|)) + |modemap|) + (T NIL))))))) + (COND + ((NULL (SETQ |target'| (|coerceable| |target| |m| |e|))) + NIL) + (T (SETQ |map| (CONS |target'| (CDR |map|))) + (SETQ TEMP1 + (OR (|compApplyModemap| |form| |modemap| |e| + NIL) + (RETURN NIL))) + (SETQ |f| (CAR TEMP1)) (SETQ TRANSIMP (CADR TEMP1)) + (SETQ |sl| (CADDR TEMP1)) + (SETQ |m'| (SUBLIS |sl| (ELT |map| 1))) + (SETQ |x'| + (PROGN + (SETQ |form'| + (CONS |f| + (PROG (T2) + (SETQ T2 NIL) + (RETURN + (DO + ((T3 TRANSIMP (CDR T3)) + (|t| NIL)) + ((OR (ATOM T3) + (PROGN + (SETQ |t| (CAR T3)) + NIL)) + (NREVERSE0 T2)) + (SEQ + (EXIT + (SETQ T2 + (CONS (CAR |t|) T2))))))))) + (COND + ((OR (BOOT-EQUAL |m'| |$Category|) + (|isCategoryForm| |m'| |e|)) + |form'|) + ((AND (BOOT-EQUAL |op| '|elt|) (PAIRP |f|) + (EQ (QCAR |f|) 'XLAM) + (IDENTP (SETQ |z| (CAR |argl|))) + (SETQ |c| + (|get| |z| '|condition| |e|)) + (PAIRP |c|) (EQ (QCDR |c|) NIL) + (PROGN + (SETQ TMP1 (QCAR |c|)) + (AND (PAIRP TMP1) + (EQ (QCAR TMP1) '|case|) + (PROGN + (SETQ TMP2 (QCDR TMP1)) + (AND (PAIRP TMP2) + (EQUAL (QCAR TMP2) |z|) + (PROGN + (SETQ TMP3 (QCDR TMP2)) + (AND (PAIRP TMP3) + (EQ (QCDR TMP3) NIL) + (PROGN + (SETQ |c1| (QCAR TMP3)) + T))))))) + (OR (AND (PAIRP |c1|) + (EQ (QCAR |c1|) '|:|) + (PROGN + (SETQ TMP1 (QCDR |c1|)) + (AND (PAIRP TMP1) + (EQUAL (QCAR TMP1) + (CADR |argl|)) + (PROGN + (SETQ TMP2 (QCDR TMP1)) + (AND (PAIRP TMP2) + (EQ (QCDR TMP2) NIL) + (EQUAL (QCAR TMP2) |m|)))))) + (EQ |c1| (CADR |argl|)))) + (CONS 'CDR (CONS |z| NIL))) + (T (CONS '|call| |form'|))))) + (SETQ |e'| + (COND + (TRANSIMP (CADDR (|last| TRANSIMP))) + (T |e|))) + (SETQ T$ (CONS |x'| (CONS |m'| (CONS |e'| NIL)))) + (|convert| T$ |m|)))))))) ;-- This version tends to give problems with #1 and categories ;-- applyMapping([op,:argl],m,e,ml) == @@ -301,8 +568,121 @@ ; pairlis:= [[v,:a] for a in argl' for v in $FormalMapVariableList] ; convert([form,SUBLIS(pairlis,first ml),e],m) -(DEFUN |applyMapping| (t0 |m| |e| |ml|) (PROG (|op| |argl| |ml'| temp1 |argl'| |nprefix| |op'| |form| |pairlis|) (RETURN (SEQ (PROGN (setq |op| (CAR t0)) (setq |argl| (CDR t0)) (COND ((NEQUAL (|#| |argl|) (SPADDIFFERENCE (|#| |ml|) 1)) NIL) ((|isCategoryForm| (CAR |ml|) |e|) (setq |pairlis| (PROG (t1) (setq t1 NIL) (RETURN (DO ((t2 |argl| (CDR t2)) (|a| NIL) (t3 |$FormalMapVariableList| (CDR t3)) (|v| NIL)) ((OR (ATOM t2) (PROGN (SETQ |a| (CAR t2)) NIL) (ATOM t3) (PROGN (SETQ |v| (CAR t3)) NIL)) (NREVERSE0 t1)) (SEQ (EXIT (SETQ t1 (CONS (CONS |v| |a|) t1)))))))) (setq |ml'| (SUBLIS |pairlis| |ml|)) (setq |argl'| (PROG (t4) (setq t4 NIL) (RETURN (DO ((t5 |argl| (CDR t5)) (|x| NIL) (t6 (CDR |ml'|) (CDR t6)) (|m'| NIL)) ((OR (ATOM t5) (PROGN (SETQ |x| (CAR t5)) NIL) (ATOM t6) (PROGN (SETQ |m'| (CAR t6)) NIL)) (NREVERSE0 t4)) (SEQ (EXIT (SETQ t4 (CONS (CAR (PROGN (setq temp1 (OR (|comp| |x| |m'| |e|) (RETURN (QUOTE |failed|)))) (setq |e| (CADDR temp1)) temp1)) t4)))))))) (COND ((BOOT-EQUAL |argl'| (QUOTE |failed|)) (RETURN NIL))) (setq |form| (CONS |op| |argl'|)) (|convert| (CONS |form| (CONS (CAR |ml'|) (CONS |e| NIL))) |m|)) (t (setq |argl'| (PROG (t7) (setq t7 NIL) (RETURN (DO ((t8 |argl| (CDR t8)) (|x| NIL) (t9 (CDR |ml|) (CDR t9)) (|m'| NIL)) ((OR (ATOM t8) (PROGN (SETQ |x| (CAR t8)) NIL) (ATOM t9) (PROGN (SETQ |m'| (CAR t9)) NIL)) (NREVERSE0 t7)) (SEQ (EXIT (SETQ t7 (CONS (CAR (PROGN (setq temp1 (OR (|comp| |x| |m'| |e|) (RETURN (QUOTE |failed|)))) (setq |e| (CADDR temp1)) temp1)) t7)))))))) (COND ((BOOT-EQUAL |argl'| (QUOTE |failed|)) (RETURN NIL))) (setq |form| (COND ((AND (NULL (|member| |op| |$formalArgList|)) (ATOM |op|) (NULL (|get| |op| (QUOTE |value|) |e|))) (setq |nprefix| (OR |$prefix| (|getAbbreviation| |$op| (|#| (CDR |$form|))))) (setq |op'| (INTERN (STRCONC (|encodeItem| |nprefix|) (QUOTE |;|) (|encodeItem| |op|)))) (CONS |op'| (APPEND |argl'| (CONS (QUOTE $) NIL)))) (t (CONS (QUOTE |call|) (CONS (CONS (QUOTE |applyFun|) (CONS |op| NIL)) |argl'|))))) (setq |pairlis| (PROG (t10) (setq t10 NIL) (RETURN (DO ((t11 |argl'| (CDR t11)) (|a| NIL) (t12 |$FormalMapVariableList| (CDR t12)) (|v| NIL)) ((OR (ATOM t11) (PROGN (SETQ |a| (CAR t11)) NIL) (ATOM t12) (PROGN (SETQ |v| (CAR t12)) NIL)) (NREVERSE0 t10)) (SEQ (EXIT (SETQ t10 (CONS (CONS |v| |a|) t10)))))))) (|convert| (CONS |form| (CONS (SUBLIS |pairlis| (CAR |ml|)) (CONS |e| NIL))) |m|)))))))) - +(DEFUN |applyMapping| (T0 |m| |e| |ml|) + (PROG (|op| |argl| |ml'| TEMP1 |argl'| |nprefix| |op'| |form| |pairlis|) + (declare (special |$FormalMapVariableList| |$form| |$op| |$prefix| + |$formalArgList|)) + (RETURN + (SEQ (PROGN + (SETQ |op| (CAR T0)) + (SETQ |argl| (CDR T0)) + (COND + ((NEQUAL (|#| |argl|) (SPADDIFFERENCE (|#| |ml|) 1)) + NIL) + ((|isCategoryForm| (CAR |ml|) |e|) + (SETQ |pairlis| + (PROG (T1) + (SETQ T1 NIL) + (RETURN + (DO ((T2 |argl| (CDR T2)) (|a| NIL) + (T3 |$FormalMapVariableList| (CDR T3)) + (|v| NIL)) + ((OR (ATOM T2) + (PROGN (SETQ |a| (CAR T2)) NIL) + (ATOM T3) + (PROGN (SETQ |v| (CAR T3)) NIL)) + (NREVERSE0 T1)) + (SEQ (EXIT (SETQ T1 + (CONS (CONS |v| |a|) T1)))))))) + (SETQ |ml'| (SUBLIS |pairlis| |ml|)) + (SETQ |argl'| + (PROG (T4) + (SETQ T4 NIL) + (RETURN + (DO ((T5 |argl| (CDR T5)) (|x| NIL) + (T6 (CDR |ml'|) (CDR T6)) (|m'| NIL)) + ((OR (ATOM T5) + (PROGN (SETQ |x| (CAR T5)) NIL) + (ATOM T6) + (PROGN (SETQ |m'| (CAR T6)) NIL)) + (NREVERSE0 T4)) + (SEQ (EXIT (SETQ T4 + (CONS + (CAR + (PROGN + (SETQ TEMP1 + (OR (|comp| |x| |m'| |e|) + (RETURN '|failed|))) + (SETQ |e| (CADDR TEMP1)) + TEMP1)) + T4)))))))) + (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) + (SETQ |form| (CONS |op| |argl'|)) + (|convert| + (CONS |form| (CONS (CAR |ml'|) (CONS |e| NIL))) + |m|)) + (T (SETQ |argl'| + (PROG (T7) + (SETQ T7 NIL) + (RETURN + (DO ((T8 |argl| (CDR T8)) (|x| NIL) + (T9 (CDR |ml|) (CDR T9)) (|m'| NIL)) + ((OR (ATOM T8) + (PROGN (SETQ |x| (CAR T8)) NIL) + (ATOM T9) + (PROGN (SETQ |m'| (CAR T9)) NIL)) + (NREVERSE0 T7)) + (SEQ (EXIT + (SETQ T7 + (CONS + (CAR + (PROGN + (SETQ TEMP1 + (OR (|comp| |x| |m'| |e|) + (RETURN '|failed|))) + (SETQ |e| (CADDR TEMP1)) + TEMP1)) + T7)))))))) + (COND ((BOOT-EQUAL |argl'| '|failed|) (RETURN NIL))) + (SETQ |form| + (COND + ((AND (NULL (|member| |op| |$formalArgList|)) + (ATOM |op|) + (NULL (|get| |op| '|value| |e|))) + (SETQ |nprefix| + (OR |$prefix| + (|getAbbreviation| |$op| + (|#| (CDR |$form|))))) + (SETQ |op'| + (INTERN (STRCONC + (|encodeItem| |nprefix|) '|;| + (|encodeItem| |op|)))) + (CONS |op'| (APPEND |argl'| (CONS '$ NIL)))) + (T (CONS '|call| + (CONS + (CONS '|applyFun| (CONS |op| NIL)) + |argl'|))))) + (SETQ |pairlis| + (PROG (T10) + (SETQ T10 NIL) + (RETURN + (DO ((T11 |argl'| (CDR T11)) (|a| NIL) + (T12 |$FormalMapVariableList| + (CDR T12)) + (|v| NIL)) + ((OR (ATOM T11) + (PROGN (SETQ |a| (CAR T11)) NIL) + (ATOM T12) + (PROGN (SETQ |v| (CAR T12)) NIL)) + (NREVERSE0 T10)) + (SEQ (EXIT + (SETQ T10 + (CONS (CONS |v| |a|) T10)))))))) + (|convert| + (CONS |form| + (CONS (SUBLIS |pairlis| (CAR |ml|)) + (CONS |e| NIL))) + |m|)))))))) ;--% APPLY MODEMAPS ;compApplyModemap(form,modemap,$e,sl) == @@ -337,8 +717,87 @@ ; [genDeltaEntry [op,:modemap],lt',$bindings] ; [f,lt',$bindings] -(DEFUN |compApplyModemap| (|form| |modemap| |$e| |sl|) (DECLARE (SPECIAL |$e|)) (PROG (|op| |argl| |mc| |mr| |margl| |fnsel| |g| |m'| |lt| |lt'| temp1 |f| |op1| tmp1 |d| tmp2) (RETURN (SEQ (PROGN (setq |op| (CAR |form|)) (setq |argl| (CDR |form|)) (setq |mc| (CAAR |modemap|)) (setq |mr| (CADAR |modemap|)) (setq |margl| (CDDAR |modemap|)) (setq |fnsel| (CDR |modemap|)) (COND ((NEQUAL (|#| |argl|) (|#| |margl|)) (RETURN NIL))) (setq |lt| (PROG (t0) (setq t0 NIL) (RETURN (DO ((t1 |argl| (CDR t1)) (|y| NIL) (t2 |margl| (CDR t2)) (|m| NIL)) ((OR (ATOM t1) (PROGN (SETQ |y| (CAR t1)) NIL) (ATOM t2) (PROGN (SETQ |m| (CAR t2)) NIL)) (NREVERSE0 t0)) (SEQ (EXIT (SETQ t0 (CONS (PROGN (setq |sl| (|pmatchWithSl| |m'| |m| |sl|)) (setq |g| (SUBLIS |sl| |m|)) (setq temp1 (OR (|comp| |y| |g| |$e|) (RETURN (QUOTE |failed|)))) (setq |m'| (CADR temp1)) (setq |$e| (CADDR temp1)) temp1) t0)))))))) (COND ((BOOT-EQUAL |lt| (QUOTE |failed|)) (RETURN NIL)) (t (setq |lt'| (PROG (t3) (setq t3 NIL) (RETURN (DO ((t4 |lt| (CDR t4)) (|y| NIL) (t5 (SUBLIS |sl| |margl|) (CDR t5)) (|d| NIL)) ((OR (ATOM t4) (PROGN (SETQ |y| (CAR t4)) NIL) (ATOM t5) (PROGN (SETQ |d| (CAR t5)) NIL)) (NREVERSE0 t3)) (SEQ (EXIT (SETQ t3 (CONS (OR (|coerce| |y| |d|) (RETURN (QUOTE |failed|))) t3)))))))) (COND ((BOOT-EQUAL |lt'| (QUOTE |failed|)) (RETURN NIL)) (t (setq temp1 (OR (|compMapCond| |op| |mc| |sl| |fnsel|) (RETURN NIL))) (setq |f| (CAR temp1)) (setq |$bindings| (CADR temp1)) (COND ((AND (PAIRP |f|) (PROGN (setq |op1| (QCAR |f|)) (setq tmp1 (QCDR |f|)) (AND (PAIRP tmp1) (PROGN (setq |d| (QCAR tmp1)) (setq tmp2 (QCDR tmp1)) (AND (PAIRP tmp2) (EQ (QCDR tmp2) NIL))))) (|member| |op1| (QUOTE (ELT CONST |Subsumed|)))) (CONS (|genDeltaEntry| (CONS |op| |modemap|)) (CONS |lt'| (CONS |$bindings| NIL)))) (t (CONS |f| (CONS |lt'| (CONS |$bindings| NIL)))))))))))))) - +(DEFUN |compApplyModemap| (|form| |modemap| |$e| |sl|) + (DECLARE (SPECIAL |$e|)) + (PROG (|op| |argl| |mc| |mr| |margl| |fnsel| |g| |m'| |lt| |lt'| + TEMP1 |f| |op1| TMP1 |d| TMP2) + (declare (special |$bindings| |$e|)) + (RETURN + (SEQ (PROGN + (SETQ |op| (CAR |form|)) + (SETQ |argl| (CDR |form|)) + (SETQ |mc| (CAAR |modemap|)) + (SETQ |mr| (CADAR |modemap|)) + (SETQ |margl| (CDDAR |modemap|)) + (SETQ |fnsel| (CDR |modemap|)) + (COND ((NEQUAL (|#| |argl|) (|#| |margl|)) (RETURN NIL))) + (SETQ |lt| + (PROG (T0) + (SETQ T0 NIL) + (RETURN + (DO ((T1 |argl| (CDR T1)) (|y| NIL) + (T2 |margl| (CDR T2)) (|m| NIL)) + ((OR (ATOM T1) + (PROGN (SETQ |y| (CAR T1)) NIL) + (ATOM T2) + (PROGN (SETQ |m| (CAR T2)) NIL)) + (NREVERSE0 T0)) + (SEQ (EXIT (SETQ T0 + (CONS + (PROGN + (SETQ |sl| + (|pmatchWithSl| |m'| |m| |sl|)) + (SETQ |g| (SUBLIS |sl| |m|)) + (SETQ TEMP1 + (OR (|comp| |y| |g| |$e|) + (RETURN '|failed|))) + (SETQ |m'| (CADR TEMP1)) + (SETQ |$e| (CADDR TEMP1)) + TEMP1) + T0)))))))) + (COND + ((BOOT-EQUAL |lt| '|failed|) (RETURN NIL)) + (T (SETQ |lt'| + (PROG (T3) + (SETQ T3 NIL) + (RETURN + (DO ((T4 |lt| (CDR T4)) (|y| NIL) + (T5 (SUBLIS |sl| |margl|) (CDR T5)) + (|d| NIL)) + ((OR (ATOM T4) + (PROGN (SETQ |y| (CAR T4)) NIL) + (ATOM T5) + (PROGN (SETQ |d| (CAR T5)) NIL)) + (NREVERSE0 T3)) + (SEQ (EXIT + (SETQ T3 + (CONS + (OR (|coerce| |y| |d|) + (RETURN '|failed|)) + T3)))))))) + (COND + ((BOOT-EQUAL |lt'| '|failed|) (RETURN NIL)) + (T (SETQ TEMP1 + (OR (|compMapCond| |op| |mc| |sl| |fnsel|) + (RETURN NIL))) + (SETQ |f| (CAR TEMP1)) + (SETQ |$bindings| (CADR TEMP1)) + (COND + ((AND (PAIRP |f|) + (PROGN + (SETQ |op1| (QCAR |f|)) + (SETQ TMP1 (QCDR |f|)) + (AND (PAIRP TMP1) + (PROGN + (SETQ |d| (QCAR TMP1)) + (SETQ TMP2 (QCDR TMP1)) + (AND (PAIRP TMP2) + (EQ (QCDR TMP2) NIL))))) + (|member| |op1| '(ELT CONST |Subsumed|))) + (CONS (|genDeltaEntry| (CONS |op| |modemap|)) + (CONS |lt'| (CONS |$bindings| NIL)))) + (T (CONS |f| + (CONS |lt'| (CONS |$bindings| NIL)))))))))))))) ;compMapCond(op,mc,$bindings,fnsel) == ; or/[compMapCond'(u,op,mc,$bindings) for u in fnsel] @@ -350,7 +809,6 @@ ((or t1 (atom t2) (progn (setq |u| (car t2)) nil)) t0) (setq t0 (or t0 (|compMapCond'| |u| op mc |$bindings|)))))) - ;compMapCond'([cexpr,fnexpr],op,dc,bindings) == ; compMapCond''(cexpr,dc) => compMapCondFun(fnexpr,op,dc,bindings) ; stackMessage ["not known that",'%b,dc,'%d,"has",'%b,cexpr,'%d] @@ -380,7 +838,7 @@ (defun |compMapCond''| (cexpr dc) (let (l u tmp1 tmp2) - (declare (special |$Information|)) + (declare (special |$Information| |$e|)) (cond ((boot-equal cexpr t) t) ((and (pairp cexpr)