From 51d6f9077a6296e085a260ce0971f57fc1defcfe Mon Sep 17 00:00:00 2001 From: Tim Daly Date: Thu, 18 Jun 2015 16:01:21 -0400 Subject: [PATCH] src/interp/i-code.lisp common lisp cleanup Goal: move toward Common Lisp, rewrite compiler output --- changelog | 2 + patch | 2 +- src/axiom-website/patches.html | 2 + src/interp/i-code.lisp.pamphlet | 511 +++++++++++++++++++-------------------- 4 files changed, 257 insertions(+), 260 deletions(-) diff --git a/changelog b/changelog index 6456102..5ca5ad8 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +20150618 tpd src/axiom-website/patches.html 20150618.02.tpd.patch +20150618 tpd src/interp/i-code.lisp common lisp cleanup 20150618 tpd src/axiom-website/patches.html 20150618.01.tpd.patch 20150618 tpd src/interp/br-con.lisp common lisp cleanup 20150603 tpd src/axiom-website/patches.html 20150603.01.tpd.patch diff --git a/patch b/patch index e3bd821..d422a44 100644 --- a/patch +++ b/patch @@ -1,4 +1,4 @@ -src/interp/br-con.lisp common lisp cleanup +src/interp/i-code.lisp common lisp cleanup Goal: move toward Common Lisp, rewrite compiler output diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 227dc74..327343a 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -5084,6 +5084,8 @@ src/interp/vmlisp remove lasttail
src/interp/vmlisp.lisp remove lispelt
20150618.01.tpd.patch src/interp/br-con.lisp common lisp cleanup
+20150618.02.tpd.patch +src/interp/i-code.lisp common lisp cleanup
diff --git a/src/interp/i-code.lisp.pamphlet b/src/interp/i-code.lisp.pamphlet index 63b18e0..cb74ede 100755 --- a/src/interp/i-code.lisp.pamphlet +++ b/src/interp/i-code.lisp.pamphlet @@ -81,211 +81,209 @@ ; -- 2. Set up a failure point otherwise ; intCodeGenCoerce1(val,t1,t2) -(DEFUN |intCodeGenCOERCE| (|triple| |t2|) - (PROG (|t1| |val| |trip| |ISTMP#3| |t0| |LETTMP#1| |val0| |l| |label| - |lastCode| |conds| |p| |v| |t1'| |ISTMP#2| |val'| - |ISTMP#1| |pred| |code|) - (DECLARE (SPECIAL |$Integer| |$OutputForm| |$mapName| +(defun |intCodeGenCOERCE| (triple t2) + (prog (t1 val trip tmp3 t0 let1 val0 z label + lastCode conds p v t1q tmp2 valq + tmp1 pred code) + (declare (special |$Integer| |$OutputForm| |$mapName| |$NoValueMode| |$Boolean| |$compilingMap| |$Void| |$EmptyMode|)) - (RETURN - (SEQ (PROGN - (setq |t1| (|objMode| |triple|)) - (COND - ((BOOT-EQUAL |t1| |$EmptyMode|) NIL) - ((BOOT-EQUAL |t1| |t2|) |triple|) - ('T (setq |val| (|objVal| |triple|)) - (COND - ((AND (CONSP |val|) - (EQ (QCAR |val|) '|coerceOrCroak|) - (PROGN - (setq |ISTMP#1| (QCDR |val|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |trip| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |t1'| - (QCAR |ISTMP#2|)) - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL))))))) - (setq |t0| (|objCodeMode| |trip|)) - (PROGN - (setq |LETTMP#1| (|objCodeVal| |trip|)) - (setq |val0| (CADR |LETTMP#1|)) - |LETTMP#1|) - (OR (BOOT-EQUAL |t1| |$Void|) - (|canCoerceFrom| (|removeQuote| |t0|) |t2|))) + (return + (seq (progn + (setq t1 (|objMode| triple)) + (cond + ((boot-equal t1 |$EmptyMode|) nil) + ((boot-equal t1 t2) triple) + (t (setq val (|objVal| triple)) + (cond + ((and (consp val) + (eq (qcar val) '|coerceOrCroak|) + (progn + (setq tmp1 (qcdr val)) + (and (consp tmp1) + (progn + (setq trip (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (consp tmp2) + (progn + (setq t1q + (qcar tmp2)) + (setq tmp3 + (qcdr tmp2)) + (and (consp tmp3) + (eq (qcdr tmp3) nil))))))) + (setq t0 (|objCodeMode| trip)) + (progn + (setq let1 (|objCodeVal| trip)) + (setq val0 (CADR let1)) + let1) + (or (boot-equal t1 |$Void|) + (|canCoerceFrom| (|removeQuote| t0) t2))) (|intCodeGenCOERCE| - (mkObj |val0| (|removeQuote| |t0|)) |t2|)) - ((AND (CONSP |val|) (EQ (QCAR |val|) 'THROW) + (mkObj val0 (|removeQuote| t0)) t2)) + ((and (consp val) (eq (qcar val) 'throw) (PROGN - (setq |ISTMP#1| (QCDR |val|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |label| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (setq |code| - (QCAR |ISTMP#2|)) - 'T)))))) - (COND - ((AND (CONSP |label|) (EQ (QCAR |label|) 'QUOTE) - (PROGN - (setq |ISTMP#1| (QCDR |label|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |l| (QCAR |ISTMP#1|)) - 'T)))) - (setq |label| |l|))) - (COND - ((OR (NULL |$compilingMap|) - (NEQUAL |label| (|mapCatchName| |$mapName|))) + (setq tmp1 (qcdr val)) + (and (consp tmp1) + (progn + (setq label (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (consp tmp2) + (eq (qcdr tmp2) nil) + (progn + (setq code + (qcar tmp2)) + t)))))) + (cond + ((and (consp label) (eq (qcar label) 'QUOTE) + (progn + (setq tmp1 (qcdr label)) + (and (consp tmp1) + (eq (qcdr tmp1) nil) + (progn + (setq z (qcar tmp1)) + t)))) + (setq label z))) + (cond + ((or (null |$compilingMap|) + (nequal label (|mapCatchName| |$mapName|))) (mkObj - (CONS 'THROW - (CONS |label| - (CONS + (cons 'throw + (cons label + (cons (|wrapped2Quote| (|objVal| (|intCodeGenCOERCE| - (mkObj |code| |t1|) |t2|))) - NIL))) - |t2|)) - ('T (mkObj |val| |t2|)))) - ((AND (CONSP |val|) (EQ (QCAR |val|) 'PROGN) - (PROGN - (setq |ISTMP#1| (QCDR |val|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |ISTMP#2| - (REVERSE |ISTMP#1|)) - 'T) - (CONSP |ISTMP#2|) - (PROGN - (setq |lastCode| (QCAR |ISTMP#2|)) - (setq |code| (QCDR |ISTMP#2|)) - 'T) - (PROGN - (setq |code| (NREVERSE |code|)) - 'T)))) + (mkObj code t1) t2))) + nil))) + t2)) + (t (mkObj val t2)))) + ((and (consp val) (eq (qcar val) 'progn) + (progn + (setq tmp1 (qcdr val)) + (and (consp tmp1) + (progn + (setq tmp2 + (reverse tmp1)) + t) + (consp tmp2) + (progn + (setq lastCode (qcar tmp2)) + (setq code (qcdr tmp2)) + t) + (progn + (setq code (nreverse code)) + t)))) (mkObj - (CONS 'PROGN - (APPEND |code| - (CONS + (cons 'progn + (append code + (cons (|wrapped2Quote| (|objVal| (|intCodeGenCOERCE| - (mkObj |lastCode| |t1|) - |t2|))) - NIL))) - |t2|)) - ((AND (CONSP |val|) (EQ (QCAR |val|) 'COND) - (PROGN (setq |conds| (QCDR |val|)) 'T)) + (mkObj lastCode t1) + t2))) + nil))) + t2)) + ((and (consp val) (eq (qcar val) 'cond) + (progn (setq conds (qcdr val)) t)) (mkObj - (CONS 'COND - (PROG (G166151) - (setq G166151 NIL) - (RETURN - (DO ((G166157 |conds| - (CDR G166157)) - (G166119 NIL)) - ((OR (ATOM G166157) - (PROGN - (SETQ G166119 - (CAR G166157)) - NIL) - (PROGN - (PROGN - (setq |p| - (CAR G166119)) - (setq |v| - (CADR G166119)) - G166119) - NIL)) - (NREVERSE0 G166151)) - (SEQ - (EXIT - (SETQ G166151 - (CONS - (CONS |p| - (CONS + (cons 'cond + (prog (g1) + (setq g1 nil) + (return + (do ((g2 conds (cdr g2)) (g3 nil)) + ((or (atom g2) + (progn + (setq g3 + (car g2)) + nil) + (progn + (progn + (setq p + (car g3)) + (setq v + (cadr g3)) + g3) + nil)) + (nreverse0 g1)) + (seq + (exit + (setq g1 + (cons + (cons p + (cons (|wrapped2Quote| (|objVal| (|intCodeGenCOERCE| - (mkObj |v| |t1|) |t2|))) - NIL)) - G166151)))))))) - |t2|)) - ((|absolutelyCanCoerceByCheating| |t1| |t2|) - (mkObj |val| |t2|)) - ((BOOT-EQUAL |t2| '(|Any|)) + (mkObj v t1) t2))) + nil)) + g1)))))))) + t2)) + ((|absolutelyCanCoerceByCheating| t1 t2) + (mkObj val t2)) + ((boot-equal t2 '(|Any|)) (mkObj - (CONS 'CONS (CONS (MKQ |t1|) (CONS |val| NIL))) - |t2|)) - ((AND (BOOT-EQUAL |t1| '(|Any|)) (CONSP |val|) - (EQUAL (QCAR |val|) 'CONS) - (PROGN - (setq |ISTMP#1| (QCDR |val|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |t1'| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (setq |val'| - (QCAR |ISTMP#2|)) - 'T)))))) + (cons 'cons (cons (mkq t1) (cons val nil))) + t2)) + ((and (boot-equal t1 '(|Any|)) (consp val) + (equal (qcar val) 'cons) + (progn + (setq tmp1 (qcdr val)) + (and (consp tmp1) + (progn + (setq t1q (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (consp tmp2) + (eq (qcdr tmp2) nil) + (progn + (setq valq + (qcar tmp2)) + t)))))) (|intCodeGenCOERCE| - (mkObj |val'| (|removeQuote| |t1'|)) |t2|)) - ((AND (CONSP |t1|) (EQ (QCAR |t1|) '|Equation|) - (BOOT-EQUAL |t2| |$Boolean|)) - (|coerceByFunction| |triple| |t2|)) - ((AND (BOOT-EQUAL |t1| '|$NoValueMode|) (CONSP |val|) - (EQ (QCAR |val|) 'COND) - (PROGN - (setq |ISTMP#1| (QCDR |val|)) - (AND (CONSP |ISTMP#1|) - (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |pred| (QCAR |ISTMP#1|)) - 'T)))) - (setq |code| - (CONS 'COND - (CONS |pred| - (CONS - (CONS (MKQ 'T) - (CONS - (CONS '|throwKeyedMsg| - (CONS (MKQ + (mkObj valq (|removeQuote| t1q)) t2)) + ((and (consp t1) (eq (qcar t1) '|Equation|) + (boot-equal t2 |$Boolean|)) + (|coerceByFunction| triple t2)) + ((and (boot-equal t1 '|$NoValueMode|) (consp val) + (eq (qcar val) 'cond) + (progn + (setq tmp1 (qcdr val)) + (and (consp tmp1) + (eq (qcdr tmp1) nil) + (progn + (setq pred (qcar tmp1)) + t)))) + (setq code + (cons 'cond + (cons pred + (cons + (cons (mkq t) + (cons + (cons '|throwKeyedMsg| + (cons (mkq (format nil "The user-defined function %1p has branched to an undefined branch in ~ conditional processing.")) - (CONS (MKQ |$mapName|) - NIL))) - NIL)) - NIL)))) - (mkObj |code| |t2|)) - ((BOOT-EQUAL |t2| |$OutputForm|) - (|coerceByFunction| |triple| |t2|)) - ((|isSubDomain| |t1| |$Integer|) - (|intCodeGenCOERCE| (mkObj |val| |$Integer|) - |t2|)) - ((AND (NULL (|containsVariables| |t2|)) - (|canCoerceByFunction| |t1| |t2|)) - (COND - ((AND (NULL (|canCoerceByMap| |t1| |t2|)) - (setq |code| - (|coerceByFunction| |triple| |t2|))) - |code|) - ('T (|intCodeGenCoerce1| |val| |t1| |t2|)))) - ('T (|intCodeGenCoerce1| |val| |t1| |t2|)))))))))) + (cons (mkq |$mapName|) + nil))) + nil)) + nil)))) + (mkObj code t2)) + ((boot-equal t2 |$OutputForm|) + (|coerceByFunction| triple t2)) + ((|isSubDomain| t1 |$Integer|) + (|intCodeGenCOERCE| (mkObj val |$Integer|) + t2)) + ((and (null (|containsVariables| t2)) + (|canCoerceByFunction| t1 t2)) + (cond + ((and (null (|canCoerceByMap| t1 t2)) + (setq code + (|coerceByFunction| triple t2))) + code) + (t (|intCodeGenCoerce1| val t1 t2)))) + (t (|intCodeGenCoerce1| val t1 t2)))))))))) ;intCodeGenCoerce1(val,t1,t2) == ; -- Internal function to previous one @@ -294,13 +292,13 @@ ; objNew(['coerceOrCroak,mkObjCode(['wrap,val],t1), ; MKQ t2, MKQ $mapName],t2) -(DEFUN |intCodeGenCoerce1| (|val| |t1| |t2|) - (DECLARE (SPECIAL |$mapName|)) +(defun |intCodeGenCoerce1| (val t1 t2) + (declare (special |$mapName|)) (mkObj - (CONS '|coerceOrCroak| - (CONS (mkObjCode (CONS '|wrap| (CONS |val| NIL)) |t1|) - (CONS (MKQ |t2|) (CONS (MKQ |$mapName|) NIL)))) - |t2|)) + (cons '|coerceOrCroak| + (cons (mkObjCode (cons '|wrap| (cons val nil)) t1) + (cons (mkq t2) (cons (mkq |$mapName|) nil)))) + t2)) ;--% Map components ;wrapMapBodyWithCatch body == @@ -317,78 +315,73 @@ ; '"bad CATCH for in function form"]) ; else ['CATCH,MKQ mapCatchName $mapName,body] -(DEFUN |wrapMapBodyWithCatch| (|body|) - (PROG (|trip| |ISTMP#4| |targ| |ISTMP#5| |mapn| |ISTMP#1| |v| - |ISTMP#2| |m| |ISTMP#3| |e|) - (DECLARE (SPECIAL |$mapName| |$mapThrowCount|)) - (RETURN - (COND - ((EQL |$mapThrowCount| 0) |body|) - ((AND (CONSP |body|) (EQ (QCAR |body|) '|failCheck|) - (PROGN - (setq |ISTMP#1| (QCDR |body|)) - (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) - (PROGN - (setq |ISTMP#2| (QCAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCAR |ISTMP#2|) '|coerceOrFail|) - (PROGN - (setq |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (PROGN - (setq |trip| (QCAR |ISTMP#3|)) - (setq |ISTMP#4| - (QCDR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (PROGN - (setq |targ| - (QCAR |ISTMP#4|)) - (setq |ISTMP#5| - (QCDR |ISTMP#4|)) - (AND (CONSP |ISTMP#5|) - (EQ (QCDR |ISTMP#5|) NIL) - (PROGN - (setq |mapn| - (QCAR |ISTMP#5|)) - 'T)))))))))))) - (COND - ((AND (CONSP |trip|) (EQ (QCAR |trip|) 'LIST) - (PROGN - (setq |ISTMP#1| (QCDR |trip|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |v| (QCAR |ISTMP#1|)) - (setq |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |m| (QCAR |ISTMP#2|)) - (setq |ISTMP#3| (QCDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (QCDR |ISTMP#3|) NIL) - (PROGN - (setq |e| (QCAR |ISTMP#3|)) - 'T)))))))) - (CONS '|failCheck| - (CONS (CONS '|coerceOrFail| - (CONS (CONS 'LIST - (CONS - (CONS 'CATCH - (CONS - (MKQ +(defun |wrapMapBodyWithCatch| (body) + (prog (trip tmp4 targ tmp5 mapn tmp1 v tmp2 m tmp3 e) + (declare (special |$mapName| |$mapThrowCount|)) + (return + (cond + ((eql |$mapThrowCount| 0) body) + ((and (consp body) (eq (qcar body) '|failCheck|) + (progn + (setq tmp1 (qcdr body)) + (and (consp tmp1) (eq (qcdr tmp1) nil) + (progn + (setq tmp2 (qcar tmp1)) + (and (consp tmp2) + (eq (qcar tmp2) '|coerceOrFail|) + (progn + (setq tmp3 (qcdr tmp2)) + (and (consp tmp3) + (progn + (setq trip (qcar tmp3)) + (setq tmp4 (qcdr tmp3)) + (and (consp tmp4) + (progn + (setq targ (qcar tmp4)) + (setq tmp5 (qcdr tmp4)) + (and (consp tmp5) + (eq (qcdr tmp5) nil) + (progn + (setq mapn (qcar tmp5)) + t)))))))))))) + (cond + ((and (consp trip) (eq (qcar trip) 'list) + (progn + (setq tmp1 (qcdr trip)) + (and (consp tmp1) + (progn + (setq v (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (consp tmp2) + (progn + (setq m (qcar tmp2)) + (setq tmp3 (qcdr tmp2)) + (and (consp tmp3) + (eq (qcdr tmp3) nil) + (progn + (setq e (qcar tmp3)) + t)))))))) + (cons '|failCheck| + (cons (cons '|coerceOrFail| + (cons (cons 'list + (cons + (cons 'catch + (cons + (mkq (|mapCatchName| |$mapName|)) - (CONS |v| NIL))) - (CONS |m| (CONS |e| NIL)))) - (CONS |targ| (CONS |mapn| NIL)))) - NIL))) - ('T + (cons v nil))) + (cons m (cons e nil)))) + (cons targ (cons mapn nil)))) + nil))) + (t (|keyedSystemError| "Unexpected error or improper call to system function %1: %2" - (CONS "wrapMapBodyWithCatch" - (CONS "bad CATCH for in function form" NIL)))))) - ('T - (CONS 'CATCH - (CONS (MKQ (|mapCatchName| |$mapName|)) - (CONS |body| NIL)))))))) + (cons "wrapMapBodyWithCatch" + (cons "bad CATCH for in function form" nil)))))) + (t + (cons 'catch + (cons (mkq (|mapCatchName| |$mapName|)) + (cons body nil)))))))) \end{chunk} \eject -- 1.7.5.4