From 289dce48c33cf53e76baac40c35fa5dd814490f5 Mon Sep 17 00:00:00 2001 From: Tim Daly Date: Sun, 21 Jun 2015 07:45:14 -0400 Subject: [PATCH] src/interp/interop.lisp merge and purge code Goal: move toward Literate The interop.lisp file contained code to handle a prior representation of Scratchpad code. That representation no longer exists so compiling the code was a waste of time. Functions that checked for the prior representation always returned false, wasting runtime. Some of the code was used elsewhere and it was moved or merged into the interpreter book (5), the rest was deleted. The interop.lisp file was removed. --- books/bookvol5.pamphlet | 14 +- changelog | 11 + patch | 13 +- src/axiom-website/patches.html | 2 + src/interp/Makefile.pamphlet | 2 +- src/interp/functor.lisp.pamphlet | 5 +- src/interp/g-util.lisp.pamphlet | 9 - src/interp/hashcode.lisp.pamphlet | 1 - src/interp/i-coerce.lisp.pamphlet | 80 +++ src/interp/i-util.lisp.pamphlet | 2 - src/interp/interop.lisp.pamphlet | 1021 ------------------------------------- src/interp/nrunfast.lisp.pamphlet | 18 - src/interp/template.lisp.pamphlet | 2 - 13 files changed, 117 insertions(+), 1063 deletions(-) delete mode 100644 src/interp/interop.lisp.pamphlet diff --git a/books/bookvol5.pamphlet b/books/bookvol5.pamphlet index 5063bb2..9cf41d4 100644 --- a/books/bookvol5.pamphlet +++ b/books/bookvol5.pamphlet @@ -3225,8 +3225,6 @@ untraceDomainConstructor,keepTraced?} (cond ((|constructor?| |d|) (setq |$constructors| (cons |d| |$constructors|))) - ((|isDomain| |d|) - (setq |$domains| (cons (|devaluate| |d|) |$domains|))) ((|isDomainOrPackage| |d|) (setq |$packages| (cons (|devaluate| |d|) |$packages|))))) @@ -3272,7 +3270,7 @@ untraceDomainConstructor,keepTraced?} (progn (setq d (qcar x)) (setq l (qcdr x)) t) (|isDomainOrPackage| d)) (progn - (setq suffix (cond ((|isDomain| d) "domain") (t "package"))) + (setq suffix "package") (|sayBrightly| `(" Functions traced in " ,suffix ,(|devaluate| d) ":")) (dolist (x (|orderBySlotNumber| l)) @@ -45027,11 +45025,18 @@ database format. \calls{compiledLookup}{NRTevalDomain} \begin{chunk}{defun compiledLookup} (defun |compiledLookup| (op sig dollar) - (unless (|isDomain| dollar) (setq dollar (|NRTevalDomain| dollar))) + (setq dollar (|NRTevalDomain| dollar)) (|basicLookup| op sig dollar dollar)) \end{chunk} +\defmacro{hashCode?} +\begin{chunk}{defmacro hashCode? 0} +(defmacro |hashCode?| (x) + `(integerp ,x)) + +\end{chunk} + \defun{basicLookup}{basicLookup} \calls{basicLookup}{spadcall} \calls{basicLookup}{hashCode?} @@ -59767,6 +59772,7 @@ There are 8 parts of an htPage: \getchunk{defmacro getMsgTag 0} \getchunk{defmacro getMsgTag? 0} \getchunk{defmacro getMsgText 0} +\getchunk{defmacro hashCode? 0} \getchunk{defmacro qcsize 0} \getchunk{defmacro qsabsval 0} \getchunk{defmacro qsadd1 0} diff --git a/changelog b/changelog index 5ca5ad8..3c8bacb 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,14 @@ +20150621 tpd src/axiom-website/patches.html 20150621.01.tpd.patch +20150621 tpd books/bookvol5 merge and purge interop.lisp +20150621 tpd src/interp/Makefile merge and purge interop.lisp +20150621 tpd src/interp/functor.lisp merge and purge interop.lisp +20150621 tpd src/interp/g-util.lisp merge and purge interop.lisp +20150621 tpd src/interp/hashcode.lisp merge and purge interop.lisp +20150621 tpd src/interp/i-coerce.lisp merge and purge interop.lisp +20150621 tpd src/interp/i-util.lisp merge and purge interop.lisp +20150621 tpd src/interp/nrunfast.lisp merge and purge interop.lisp +20150621 tpd src/interp/template.lisp merge and purge interop.lisp +20150621 tpd src/interp/interop.lisp merge and purge interop.lisp 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 diff --git a/patch b/patch index d422a44..1b85b00 100644 --- a/patch +++ b/patch @@ -1,6 +1,15 @@ -src/interp/i-code.lisp common lisp cleanup +src/interp/interop.lisp merge and purge code + +Goal: move toward Literate + +The interop.lisp file contained code to handle a prior representation +of Scratchpad code. That representation no longer exists so compiling +the code was a waste of time. Functions that checked for the prior +representation always returned false, wasting runtime. Some of the +code was used elsewhere and it was moved or merged into the interpreter +book (5), the rest was deleted. The interop.lisp file was removed. + -Goal: move toward Common Lisp, rewrite compiler output diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 327343a..eced09b 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -5086,6 +5086,8 @@ src/interp/vmlisp.lisp remove lispelt
src/interp/br-con.lisp common lisp cleanup
20150618.02.tpd.patch src/interp/i-code.lisp common lisp cleanup
+20150621.01.tpd.patch +src/interp/interop.lisp merge and purge code
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index f72655a..f9c7b53 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -197,7 +197,7 @@ for various parts of the system. The {\bf patches.lisp} \cite{5} file contains last-minute changes to various functions and constants. \begin{chunk}{environment} -INOBJS= ${OUT}/interop.${O} ${OUT}/patches.${O} +INOBJS= ${OUT}/patches.${O} \end{chunk} diff --git a/src/interp/functor.lisp.pamphlet b/src/interp/functor.lisp.pamphlet index 93f2660..ca7db70 100644 --- a/src/interp/functor.lisp.pamphlet +++ b/src/interp/functor.lisp.pamphlet @@ -17,8 +17,7 @@ ; isDomain a => CDAR a.4 ; a -(DEFUN |keyItem| (|a|) - (COND ((|isDomain| |a|) (CDAR (ELT |a| 4))) ('T |a|))) +(DEFUN |keyItem| (a) a) ; --The item that domain checks on ; @@ -149,7 +148,7 @@ (declare (special |$WhereList| |$Sublis|)) (RETURN (SEQ (COND - ((AND (REFVECP D) (NULL (|isDomain| D))) (|PacPrint| D)) + ((REFVECP D) (|PacPrint| D)) ('T (COND ((REFVECP D) (setq D (ELT D 4)))) (setq |Sublis| (APPEND (PROG (G166124) diff --git a/src/interp/g-util.lisp.pamphlet b/src/interp/g-util.lisp.pamphlet index dee5ab3..5d04c9d 100644 --- a/src/interp/g-util.lisp.pamphlet +++ b/src/interp/g-util.lisp.pamphlet @@ -1119,15 +1119,6 @@ ('T (INTERN |x|)))) ('T |x|))) -;isDomain a == -; CONSP a and VECP(CAR a) and -; MEMBER(CAR(a).0, $domainTypeTokens) - -(DEFUN |isDomain| (|a|) - (DECLARE (SPECIAL |$domainTypeTokens|)) - (AND (CONSP |a|) (VECP (CAR |a|)) - (|member| (ELT (CAR |a|) 0) |$domainTypeTokens|))) - ;$htHash := MAKE_-HASH_-TABLE() (setq |$htHash| (MAKE-HASH-TABLE)) diff --git a/src/interp/hashcode.lisp.pamphlet b/src/interp/hashcode.lisp.pamphlet index dc496b4..77f733d 100644 --- a/src/interp/hashcode.lisp.pamphlet +++ b/src/interp/hashcode.lisp.pamphlet @@ -96,7 +96,6 @@ (setq |type2| (QCAR |ISTMP#2|)) 'T)))))) (|hashType| |type2| |percentHash|)) - ((|isDomain| |type|) (|getDomainHash| |type|)) ('T (setq |op| (CAR |type|)) (setq |args| (CDR |type|)) (setq |hash| (|hashString| (SYMBOL-NAME |op|))) diff --git a/src/interp/i-coerce.lisp.pamphlet b/src/interp/i-coerce.lisp.pamphlet index 10281ef..e638b34 100644 --- a/src/interp/i-coerce.lisp.pamphlet +++ b/src/interp/i-coerce.lisp.pamphlet @@ -4132,6 +4132,86 @@ Interpreter Coercion Query Functions (APPEND (NREVERSE |perms|) (|permuteToOrder| |p| |n| (+ |start| 1)))))))))) +;coerceConvertMmSelection(funName,m1,m2) == +; -- calls selectMms with $Coerce=NIL and tests for required +; -- target type. funName is either 'coerce or 'convert. +; $declaredMode : local:= NIL +; $reportBottomUpFlag : local:= NIL +; l := selectMms1(funName,m2,[m1],[m1],NIL) +; mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and +; hasCorrectTarget(m2,sig) and sig is [dc,targ,oarg] and oarg = m1] +; mmS and CAR mmS + +(defun |coerceConvertMmSelection| (&rest g1) + (let (g3) + (cond + ((setq g3 (hget |coerceConvertMmSelection;AL| g1)) + (|CDRwithIncrement| g3)) + (t + (cdr (hput |coerceConvertMmSelection;AL| g1 + (cons 1 (apply #'|coerceConvertMmSelection;| g1)))))))) + + +(defun |coerceConvertMmSelection;| (funName m1 m2) + (prog (|$declaredMode| |$reportBottomUpFlag| z sig tmp3 arg pred dc tmp1 + targ tmp2 oarg mmS g1) + (declare (special |$declaredMode| |$reportBottomUpFlag|)) + (return + (seq + (progn + (setq |$declaredMode| nil) + (setq |$reportBottomUpFlag| nil) + (setq z (|selectMms1| funName m2 (cons m1 nil) (cons m1 nil) nil)) + (setq mmS + (do ((g2 z (cdr g2)) (x nil)) + ((or (atom g2) (progn (setq x (car g2)) nil)) (nreverse0 g1)) + (SEQ (EXIT + (cond + ((and (consp x) + (progn + (setq sig (qcar x)) + (setq tmp1 (qcdr x)) + (and (consp tmp1) + (progn + (setq tmp2 (qcar tmp1)) + (and (consp tmp2) + (progn + (setq tmp3 (qcdr tmp2)) + (and (consp tmp3) + (eq (qcdr tmp3) nil) + (progn (setq arg (qcar tmp3)) T))))) + (progn + (setq pred (qcdr tmp1)) + t))) + (|hasCorrectTarget| m2 sig) + (consp sig) + (progn + (setq dc (qcar sig)) + (setq tmp1 (qcdr sig)) + (and (consp tmp1) + (progn + (setq targ (qcar tmp1)) + (setq tmp2 (qcdr tmp1)) + (and (consp tmp2) + (eq (qcdr tmp2) nil) + (progn + (setq oarg (qcar tmp2)) + t))))) + (boot-equal oarg m1)) + (setq g1 + (cons + (cons sig (cons (cons targ (cons arg nil)) pred)) + g1)))))))) + (and mms (car mmS))))))) + +(put '|coerceConvertMmSelection| '|cacheInfo| + '(|coerceConvertMmSelection| |coerceConvertMmSelection;AL| + |hash-tableWithCounts| + (setq |coerceConvertMmSelection;AL| (make-hashtable 'uequal)) + (|hashCount| |coerceConvertMmSelection;AL|))) + +(setq |coerceConvertMmSelection;AL| (make-hashtable 'uequal)) + ;coerceIntTest(t1,t2) == ; -- looks whether there exists a table entry or a coercion function ; -- thus the type can be bubbled before coerceIntTableOrFunction is called diff --git a/src/interp/i-util.lisp.pamphlet b/src/interp/i-util.lisp.pamphlet index 91bd14b..9e7b762 100644 --- a/src/interp/i-util.lisp.pamphlet +++ b/src/interp/i-util.lisp.pamphlet @@ -312,8 +312,6 @@ lisp code is unwrapped. (PROG (|ISTMP#1| |d'|) (RETURN (COND - ((|isDomain| |d|) - (|DNameToSExpr| (SPADCALL (CDR |d|) (ELT (CAR |d|) 1)))) ((NULL (REFVECP |d|)) |d|) ((AND (QSGREATERP (QVSIZE |d|) 5) (PROGN diff --git a/src/interp/interop.lisp.pamphlet b/src/interp/interop.lisp.pamphlet deleted file mode 100644 index a36608d..0000000 --- a/src/interp/interop.lisp.pamphlet +++ /dev/null @@ -1,1021 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp interop.lisp} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{chunk}{*} -(IN-PACKAGE "BOOT" ) - -;-- note domainObjects are now (dispatchVector hashCode . domainVector) -;-- lazy oldAxiomDomainObjects are (dispatchVector hashCode (Call form) . backptr), -;-- pre oldAxiomCategory is (dispatchVector . (cat form)) -;-- oldAxiomCategory objects are (dispatchVector . ( (cat form) hash defaultpack parentlist)) -;hashCode? x == INTEGERP x - -(DEFUN |hashCode?| (|x|) (INTEGERP |x|)) - -;$domainTypeTokens := ['lazyOldAxiomDomain, 'oldAxiomDomain, 'oldAxiomPreCategory, -; 'oldAxiomCategory, 0] - -(setq |$domainTypeTokens| - (CONS '|lazyOldAxiomDomain| - (CONS '|oldAxiomDomain| - (CONS '|oldAxiomPreCategory| - (CONS '|oldAxiomCategory| (CONS 0 NIL)))))) - -;-- The name game. -;-- The compiler produces names that are of the form: -;-- a) cons(0, ) -;-- b) cons(1, type-name, arg-names...) -;-- c) cons(2, arg-names...) -;-- d) cons(3, value) -;-- NB: (c) is for tuple-ish constructors, -;-- and (d) is for dependent types. -;DNameStringID := 0 - -(setq |DNameStringID| 0) - -;DNameApplyID := 1 - -(setq |DNameApplyID| 1) - -;DNameTupleID := 2 - -(setq |DNameTupleID| 2) - -;DNameOtherID := 3 - -(setq |DNameOtherID| 3) - -;DNameToSExpr1 dname == -; NULL dname => error "unexpected domain name" -; CAR dname = DNameStringID => -; INTERN(CompStrToString CDR dname) -; name0 := DNameToSExpr1 CAR CDR dname -; args := CDR CDR dname -; name0 = '_-_> => -; froms := CAR args -; froms := MAPCAR(function DNameToSExpr, CDR froms) -; ret := CAR CDR args -- a tuple -; ret := DNameToSExpr CAR CDR ret -- contents -; CONS('Mapping, CONS(ret, froms)) -; name0 = 'Union or name0 = 'Record => -; sxs := MAPCAR(function DNameToSExpr, CDR CAR args) -; CONS(name0, sxs) -; name0 = 'Enumeration => -; CONS(name0, MAPCAR(function DNameFixEnum, CDR CAR args)) -; CONS(name0, MAPCAR(function DNameToSExpr, args)) - -(DEFUN |DNameToSExpr1| (|dname|) - (PROG (|name0| |args| |froms| |ret| |sxs|) - (RETURN - (COND - ((NULL |dname|) (|error| '|unexpected domain name|)) - ((BOOT-EQUAL (CAR |dname|) |DNameStringID|) - (INTERN (|CompStrToString| (CDR |dname|)))) - ('T (setq |name0| (|DNameToSExpr1| (CAR (CDR |dname|)))) - (setq |args| (CDR (CDR |dname|))) - (COND - ((BOOT-EQUAL |name0| '->) (setq |froms| (CAR |args|)) - (setq |froms| - (MAPCAR #'|DNameToSExpr| (CDR |froms|))) - (setq |ret| (CAR (CDR |args|))) - (setq |ret| (|DNameToSExpr| (CAR (CDR |ret|)))) - (CONS '|Mapping| (CONS |ret| |froms|))) - ((OR (BOOT-EQUAL |name0| '|Union|) - (BOOT-EQUAL |name0| '|Record|)) - (setq |sxs| - (MAPCAR #'|DNameToSExpr| - (CDR (CAR |args|)))) - (CONS |name0| |sxs|)) - ((BOOT-EQUAL |name0| '|Enumeration|) - (CONS |name0| - (MAPCAR #'|DNameFixEnum| - (CDR (CAR |args|))))) - ('T - (CONS |name0| (MAPCAR #'|DNameToSExpr| |args|))))))))) - -;DNameToSExpr dname == -; CAR dname = DNameOtherID => -; CDR dname -; sx := DNameToSExpr1 dname -; CONSP sx => sx -; LIST sx - -(DEFUN |DNameToSExpr| (|dname|) - (PROG (|sx|) - (RETURN - (COND - ((BOOT-EQUAL (CAR |dname|) |DNameOtherID|) (CDR |dname|)) - ('T (setq |sx| (|DNameToSExpr1| |dname|)) - (COND ((CONSP |sx|) |sx|) ('T (LIST |sx|)))))))) - -;DNameFixEnum arg == CompStrToString CDR arg - -(DEFUN |DNameFixEnum| (|arg|) (|CompStrToString| (CDR |arg|))) - -;SExprToDName(sexpr, cosigVal) == -; -- is it a non-type valued object? -; NOT cosigVal => [DNameOtherID, :sexpr] -; if CAR sexpr = '_: then sexpr := CAR CDR CDR sexpr -; CAR sexpr = 'Mapping => -; args := [ SExprToDName(sx, 'T) for sx in CDR sexpr] -; [DNameApplyID, -; [DNameStringID,: StringToCompStr '"->"], -; [DNameTupleID, : CDR args], -; [DNameTupleID, CAR args]] -; name0 := [DNameStringID, : StringToCompStr SYMBOL_-NAME CAR sexpr] -; CAR sexpr = 'Union or CAR sexpr = 'Record => -; [DNameApplyID, name0, -; [DNameTupleID,: [ SExprToDName(sx, 'T) for sx in CDR sexpr]]] -; newCosig := CDR GETDATABASE(CAR sexpr, QUOTE COSIG) -; [DNameApplyID, name0, -; : MAPCAR(function SExprToDName, CDR sexpr, newCosig)] - -(DEFUN |SExprToDName| (|sexpr| |cosigVal|) - (PROG (|args| |name0| |newCosig|) - (RETURN - (SEQ (COND - ((NULL |cosigVal|) (CONS |DNameOtherID| |sexpr|)) - ('T - (COND - ((BOOT-EQUAL (CAR |sexpr|) '|:|) - (setq |sexpr| (CAR (CDR (CDR |sexpr|)))))) - (COND - ((BOOT-EQUAL (CAR |sexpr|) '|Mapping|) - (setq |args| - (PROG (G166087) - (setq G166087 NIL) - (RETURN - (DO ((G166092 (CDR |sexpr|) - (CDR G166092)) - (|sx| NIL)) - ((OR (ATOM G166092) - (PROGN - (SETQ |sx| (CAR G166092)) - NIL)) - (NREVERSE0 G166087)) - (SEQ (EXIT - (SETQ G166087 - (CONS (|SExprToDName| |sx| 'T) - G166087)))))))) - (CONS |DNameApplyID| - (CONS (CONS |DNameStringID| - (|StringToCompStr| - "->")) - (CONS (CONS |DNameTupleID| (CDR |args|)) - (CONS - (CONS |DNameTupleID| - (CONS (CAR |args|) NIL)) - NIL))))) - ('T - (setq |name0| - (CONS |DNameStringID| - (|StringToCompStr| - (SYMBOL-NAME (CAR |sexpr|))))) - (COND - ((OR (BOOT-EQUAL (CAR |sexpr|) '|Union|) - (BOOT-EQUAL (CAR |sexpr|) '|Record|)) - (CONS |DNameApplyID| - (CONS |name0| - (CONS (CONS |DNameTupleID| - (PROG (G166102) - (setq G166102 NIL) - (RETURN - (DO - ((G166107 (CDR |sexpr|) - (CDR G166107)) - (|sx| NIL)) - ((OR (ATOM G166107) - (PROGN - (SETQ |sx| - (CAR G166107)) - NIL)) - (NREVERSE0 G166102)) - (SEQ - (EXIT - (SETQ G166102 - (CONS - (|SExprToDName| |sx| - 'T) - G166102)))))))) - NIL)))) - ('T - (setq |newCosig| - (CDR (GETDATABASE (CAR |sexpr|) 'COSIG))) - (CONS |DNameApplyID| - (CONS |name0| - (MAPCAR #'|SExprToDName| - (CDR |sexpr|) |newCosig|))))))))))))) - -;-- local garbage because Compiler strings are null terminated -;StringToCompStr(str) == -; CONCATENATE(QUOTE STRING, str, STRING (CODE_-CHAR 0)) - -(DEFUN |StringToCompStr| (|str|) - (CONCATENATE 'STRING |str| (STRING (CODE-CHAR 0)))) - -;CompStrToString(str) == -; SUBSTRING(str, 0, (LENGTH str - 1)) - -(DEFUN |CompStrToString| (|str|) - (SUBSTRING |str| 0 (- (LENGTH |str|) 1))) - -;-- local garbage ends -;runOldAxiomFunctor(:allArgs) == -; [:args,env] := allArgs -; GETDATABASE(env, 'CONSTRUCTORKIND) = 'category => -; [$oldAxiomPreCategoryDispatch,: [env, :args]] -; dom:=APPLY(env, args) -; makeOldAxiomDispatchDomain dom - -(DEFUN |runOldAxiomFunctor| (&REST G166140 &AUX |allArgs|) - (DSETQ |allArgs| G166140) - (PROG (|LETTMP#1| |env| |args| |dom|) - (declare (special |$oldAxiomPreCategoryDispatch|)) - (RETURN - (PROGN - (setq |LETTMP#1| (REVERSE |allArgs|)) - (setq |env| (CAR |LETTMP#1|)) - (setq |args| (NREVERSE (CDR |LETTMP#1|))) - (COND - ((BOOT-EQUAL (GETDATABASE |env| 'CONSTRUCTORKIND) - '|category|) - (CONS |$oldAxiomPreCategoryDispatch| (CONS |env| |args|))) - ('T (setq |dom| (APPLY |env| |args|)) - (|makeOldAxiomDispatchDomain| |dom|))))))) - -;makeLazyOldAxiomDispatchDomain domform == -; attribute? domform => -; [$attributeDispatch, domform, hashString(SYMBOL_-NAME domform)] -; GETDATABASE(opOf domform, 'CONSTRUCTORKIND) = 'category => -; [$oldAxiomPreCategoryDispatch,: domform] -; dd := [$lazyOldAxiomDomainDispatch, hashTypeForm(domform,0), domform] -; NCONC(dd,dd) -- installs back pointer to head of domain. -; dd - -(DEFUN |makeLazyOldAxiomDispatchDomain| (|domform|) - (PROG (|dd|) - (declare (special |$lazyOldAxiomDomainDispatch| |$attributeDispatch| - |$oldAxiomPreCategoryDispatch|)) - (RETURN - (COND - ((|attribute?| |domform|) - (CONS |$attributeDispatch| - (CONS |domform| - (CONS (|hashString| (SYMBOL-NAME |domform|)) NIL)))) - ((BOOT-EQUAL (GETDATABASE (|opOf| |domform|) 'CONSTRUCTORKIND) - '|category|) - (CONS |$oldAxiomPreCategoryDispatch| |domform|)) - ('T - (setq |dd| - (CONS |$lazyOldAxiomDomainDispatch| - (CONS (|hashTypeForm| |domform| 0) - (CONS |domform| NIL)))) - (NCONC |dd| |dd|) |dd|))))) - -;makeOldAxiomDispatchDomain dom == -; CONSP dom => dom -; [$oldAxiomDomainDispatch,hashTypeForm(dom.0,0),:dom] - -(DEFUN |makeOldAxiomDispatchDomain| (|dom|) - (declare (special |$oldAxiomDomainDispatch|)) - (COND - ((CONSP |dom|) |dom|) - ('T - (CONS |$oldAxiomDomainDispatch| - (CONS (|hashTypeForm| (ELT |dom| 0) 0) |dom|))))) - -;closeOldAxiomFunctor(name) == -; [function runOldAxiomFunctor,:SYMBOL_-FUNCTION name] - -(DEFUN |closeOldAxiomFunctor| (|name|) - (CONS #'|runOldAxiomFunctor| (SYMBOL-FUNCTION |name|))) - -;lazyOldAxiomDomainLookupExport(domenv, self, op, sig, box, skipdefaults, env) == -; dom := instantiate domenv -; SPADCALL(CDR dom, self, op, sig, box, skipdefaults, CAR(dom).3) - -(DEFUN |lazyOldAxiomDomainLookupExport| - (|domenv| |self| |op| |sig| |box| |skipdefaults| |env|) - (declare (ignore |env|)) - (PROG (|dom|) - (RETURN - (PROGN - (setq |dom| (|instantiate| |domenv|)) - (SPADCALL (CDR |dom|) |self| |op| |sig| |box| |skipdefaults| - (ELT (CAR |dom|) 3)))))) - -;lazyOldAxiomDomainHashCode(domenv, env) == CAR domenv - -(DEFUN |lazyOldAxiomDomainHashCode| (|domenv| |env|) - (declare (ignore |env|)) - (CAR |domenv|)) - -;lazyOldAxiomDomainDevaluate(domenv, env) == -; dom := instantiate domenv -; SPADCALL(CDR dom, CAR(dom).1) - -(DEFUN |lazyOldAxiomDomainDevaluate| (|domenv| |env|) - (declare (ignore |env|)) - (PROG (|dom|) - (RETURN - (PROGN - (setq |dom| (|instantiate| |domenv|)) - (SPADCALL (CDR |dom|) (ELT (CAR |dom|) 1)))))) - -;lazyOldAxiomAddChild(domenv, kid, env) == -; CONS($lazyOldAxiomDomainDispatch,domenv) - -(DEFUN |lazyOldAxiomAddChild| (|domenv| |kid| |env|) - (declare (ignore |kid| |env|)) - (declare (special |$lazyOldAxiomDomainDispatch|)) - (CONS |$lazyOldAxiomDomainDispatch| |domenv|)) - -;$lazyOldAxiomDomainDispatch := -; VECTOR('lazyOldAxiomDomain, -; [function lazyOldAxiomDomainDevaluate], -; [nil], -; [function lazyOldAxiomDomainLookupExport], -; [function lazyOldAxiomDomainHashCode], -; [function lazyOldAxiomAddChild]) - -(setq |$lazyOldAxiomDomainDispatch| - (VECTOR '|lazyOldAxiomDomain| - (CONS #'|lazyOldAxiomDomainDevaluate| NIL) - (CONS NIL NIL) - (CONS #'|lazyOldAxiomDomainLookupExport| - NIL) - (CONS #'|lazyOldAxiomDomainHashCode| NIL) - (CONS #'|lazyOldAxiomAddChild| NIL))) - -;-- old Axiom pre category objects are just (dispatch . catform) -;-- where catform is ('categoryname,: evaluated args) -;-- old Axiom category objects are (dispatch . [catform, hashcode, defaulting package, parent vector, dom]) -;oldAxiomPreCategoryBuild(catform, dom, env) == -; pack := oldAxiomCategoryDefaultPackage(catform, dom) -; CONS($oldAxiomCategoryDispatch, -; [catform, hashTypeForm(catform,0), pack, oldAxiomPreCategoryParents(catform,dom), dom]) - -(DEFUN |oldAxiomPreCategoryBuild| (|catform| |dom| |env|) - (declare (ignore |env|)) - (PROG (|pack|) - (declare (special |$oldAxiomCategoryDispatch|)) - (RETURN - (PROGN - (setq |pack| - (|oldAxiomCategoryDefaultPackage| |catform| |dom|)) - (CONS |$oldAxiomCategoryDispatch| - (CONS |catform| - (CONS (|hashTypeForm| |catform| 0) - (CONS |pack| - (CONS (|oldAxiomPreCategoryParents| - |catform| |dom|) - (CONS |dom| NIL)))))))))) - -;oldAxiomPreCategoryHashCode(catform, env) == hashTypeForm(catform,0) - -(DEFUN |oldAxiomPreCategoryHashCode| (|catform| |env|) - (declare (ignore |env|)) - (|hashTypeForm| |catform| 0)) - -;oldAxiomCategoryDefaultPackage(catform, dom) == -; hasDefaultPackage opOf catform - -(DEFUN |oldAxiomCategoryDefaultPackage| (|catform| |dom|) - (declare (ignore |dom|)) - (|hasDefaultPackage| (|opOf| |catform|))) - -;oldAxiomPreCategoryDevaluate([op,:args], env) == -; SExprToDName([op,:devaluateList args], T) - -(DEFUN |oldAxiomPreCategoryDevaluate| (G166180 |env|) - (declare (ignore |env|)) - (PROG (|op| |args| T$) - (RETURN - (PROGN - (setq |op| (CAR G166180)) - (setq |args| (CDR G166180)) - (|SExprToDName| (CONS |op| (|devaluateList| |args|)) T$))))) - -;$oldAxiomPreCategoryDispatch := -; VECTOR('oldAxiomPreCategory, -; [function oldAxiomPreCategoryDevaluate], -; [nil], -; [nil], -; [function oldAxiomPreCategoryHashCode], -; [function oldAxiomPreCategoryBuild], -; [nil]) - -(setq |$oldAxiomPreCategoryDispatch| - (VECTOR '|oldAxiomPreCategory| - (CONS #'|oldAxiomPreCategoryDevaluate| NIL) - (CONS NIL NIL) (CONS NIL NIL) - (CONS #'|oldAxiomPreCategoryHashCode| NIL) - (CONS #'|oldAxiomPreCategoryBuild| NIL) - (CONS NIL NIL))) - -;oldAxiomCategoryDevaluate([[op,:args],:.], env) == -; SExprToDName([op,:devaluateList args], T) - -(DEFUN |oldAxiomCategoryDevaluate| (G166194 |env|) - (declare (ignore |env|)) - (PROG (|op| |args|) - (RETURN - (PROGN - (setq |op| (CAAR G166194)) - (setq |args| (CDAR G166194)) - (|SExprToDName| (CONS |op| (|devaluateList| |args|)) T$))))) - -;oldAxiomPreCategoryParents(catform,dom) == -; vars := ["$",:rest GETDATABASE(opOf catform, 'CONSTRUCTORFORM)] -; vals := [dom,:rest catform] -; -- parents := GETDATABASE(opOf catform, 'PARENTS) -; parents := parentsOf opOf catform -; PROGV(vars, vals, -; LIST2VEC -; [EVAL quoteCatOp cat for [cat,:pred] in parents | EVAL pred]) - -(DEFUN |oldAxiomPreCategoryParents| (|catform| |dom|) - (PROG (|vars| |vals| |parents| |cat| |pred|) - (RETURN - (SEQ (PROGN - (setq |vars| - (CONS '$ - (CDR (GETDATABASE (|opOf| |catform|) - 'CONSTRUCTORFORM)))) - (setq |vals| (CONS |dom| (CDR |catform|))) - (setq |parents| (|parentsOf| (|opOf| |catform|))) - (PROGV |vars| |vals| - (LIST2VEC - (PROG (G166219) - (setq G166219 NIL) - (RETURN - (DO ((G166226 |parents| (CDR G166226)) - (G166208 NIL)) - ((OR (ATOM G166226) - (PROGN - (SETQ G166208 (CAR G166226)) - NIL) - (PROGN - (PROGN - (setq |cat| (CAR G166208)) - (setq |pred| (CDR G166208)) - G166208) - NIL)) - (NREVERSE0 G166219)) - (SEQ (EXIT (COND - ((EVAL |pred|) - (SETQ G166219 - (CONS - (EVAL (|quoteCatOp| |cat|)) - G166219)))))))))))))))) - -;quoteCatOp cat == -; atom cat => MKQ cat -; ['LIST, MKQ CAR cat,: CDR cat] - -(DEFUN |quoteCatOp| (|cat|) - (COND - ((ATOM |cat|) (MKQ |cat|)) - ('T (CONS 'LIST (CONS (MKQ (CAR |cat|)) (CDR |cat|)))))) - -;oldAxiomCategoryLookupExport(catenv, self, op, sig, box, env) == -; [catform,hash, pack,:.] := catenv -; opIsHasCat op => if EQL(sig, hash) then [self] else nil -; NULL(pack) => nil -; if not VECP pack then -; pack:=apply(pack, CONS(self, rest catform)) -; RPLACA(CDDR catenv, pack) -; fun := basicLookup(op, sig, pack, self) => [fun] -; nil - -(DEFUN |oldAxiomCategoryLookupExport| (|catenv| |self| |op| |sig| |box| |env|) - (declare (ignore |env| |box|)) - (PROG (|catform| |hash| |pack| |fun|) - (RETURN - (PROGN - (setq |catform| (CAR |catenv|)) - (setq |hash| (CADR |catenv|)) - (setq |pack| (CADDR |catenv|)) - (COND - ((|opIsHasCat| |op|) - (COND ((EQL |sig| |hash|) (CONS |self| NIL)) ('T NIL))) - ((NULL |pack|) NIL) - ('T - (COND - ((NULL (VECP |pack|)) - (setq |pack| - (APPLY |pack| (CONS |self| (CDR |catform|)))) - (RPLACA (CDDR |catenv|) |pack|))) - (COND - ((setq |fun| (|basicLookup| |op| |sig| |pack| |self|)) - (CONS |fun| NIL)) - ('T NIL)))))))) - -;oldAxiomCategoryParentCount([.,.,.,parents,.], env) == LENGTH parents - -(DEFUN |oldAxiomCategoryParentCount| (G166260 |env|) - (declare (ignore |env|)) - (PROG (|parents|) - (RETURN - (PROGN - (setq |parents| (CADDDR G166260)) - (LENGTH |parents|))))) - -;oldAxiomCategoryNthParent([.,.,.,parvec,dom], n, env) == -; catform := ELT(parvec, n-1) -; VECTORP KAR catform => catform -; newcat := oldAxiomPreCategoryBuild(catform,dom,nil) -; SETELT(parvec, n-1, newcat) -; newcat - -(DEFUN |oldAxiomCategoryNthParent| (G166272 |n| |env|) - (declare (ignore |env|)) - (PROG (|parvec| |dom| |catform| |newcat|) - (RETURN - (PROGN - (setq |parvec| (CADDDR G166272)) - (setq |dom| (CAR (CDDDDR G166272))) - (setq |catform| (ELT |parvec| (- |n| 1))) - (COND - ((VECTORP (ifcar |catform|)) |catform|) - ('T - (setq |newcat| - (|oldAxiomPreCategoryBuild| |catform| |dom| NIL)) - (SETELT |parvec| (- |n| 1) |newcat|) |newcat|)))))) - -;oldAxiomCategoryBuild([catform,:.], dom, env) == -; oldAxiomPreCategoryBuild(catform,dom, env) - -(DEFUN |oldAxiomCategoryBuild| (G166288 |dom| |env|) - (PROG (|catform|) - (RETURN - (PROGN - (setq |catform| (CAR G166288)) - (|oldAxiomPreCategoryBuild| |catform| |dom| |env|))))) - -;oldAxiomCategoryHashCode([.,hash,:.], env) == hash - -(DEFUN |oldAxiomCategoryHashCode| (G166299 |env|) - (declare (ignore |env|)) - (PROG (|hash|) - (RETURN (PROGN (setq |hash| (CADR G166299)) |hash|)))) - -;$oldAxiomCategoryDispatch := -; VECTOR('oldAxiomCategory, -; [function oldAxiomCategoryDevaluate], -; [nil], -; [function oldAxiomCategoryLookupExport], -; [function oldAxiomCategoryHashCode], -; [function oldAxiomCategoryBuild], -- builder ?? -; [function oldAxiomCategoryParentCount], -; [function oldAxiomCategoryNthParent]) -- 1 indexed - -(setq |$oldAxiomCategoryDispatch| - (VECTOR '|oldAxiomCategory| - (CONS #'|oldAxiomCategoryDevaluate| NIL) - (CONS NIL NIL) - (CONS #'|oldAxiomCategoryLookupExport| NIL) - (CONS #'|oldAxiomCategoryHashCode| NIL) - (CONS #'|oldAxiomCategoryBuild| NIL) - (CONS #'|oldAxiomCategoryParentCount| NIL) - (CONS #'|oldAxiomCategoryNthParent| NIL))) - -;attributeDevaluate(attrObj, env) == -; [name, hash] := attrObj -; StringToCompStr SYMBOL_-NAME name - -(DEFUN |attributeDevaluate| (|attrObj| |env|) - (declare (ignore |env|)) - (PROG (|name| |hash|) - (RETURN - (PROGN - (setq |name| (CAR |attrObj|)) - (setq |hash| (CADR |attrObj|)) - (|StringToCompStr| (SYMBOL-NAME |name|)))))) - -;attributeLookupExport(attrObj, self, op, sig, box, env) == -; [name, hash] := attrObj -; opIsHasCat op => if EQL(hash, sig) then [self] else nil - -(DEFUN |attributeLookupExport| (|attrObj| |self| |op| |sig| |box| |env|) - (declare (ignore |env| |box|)) - (PROG (|name| |hash|) - (RETURN - (PROGN - (setq |name| (CAR |attrObj|)) - (setq |hash| (CADR |attrObj|)) - (COND - ((|opIsHasCat| |op|) - (COND ((EQL |hash| |sig|) (CONS |self| NIL)) ('T NIL)))))))) - -;attributeHashCode(attrObj, env) == -; [name, hash] := attrObj -; hash - -(DEFUN |attributeHashCode| (|attrObj| |env|) - (declare (ignore |env|)) - (PROG (|name| |hash|) - (RETURN - (PROGN - (setq |name| (CAR |attrObj|)) - (setq |hash| (CADR |attrObj|)) - |hash|)))) - -;attributeCategoryBuild(attrObj, dom, env) == -; [name, hash] := attrObj -; [$attributeDispatch, name, hash] - -(DEFUN |attributeCategoryBuild| (|attrObj| |dom| |env|) - (declare (ignore |env| |dom|)) - (PROG (|name| |hash|) - (declare (special |$attributeDispatch|)) - (RETURN - (PROGN - (setq |name| (CAR |attrObj|)) - (setq |hash| (CADR |attrObj|)) - (CONS |$attributeDispatch| (CONS |name| (CONS |hash| NIL))))))) - -;attributeCategoryParentCount(attrObj, env) == 0 - -(DEFUN |attributeCategoryParentCount| (|attrObj| |env|) - (declare (special |attrObj| |env|)) - 0) - -;attributeNthParent(attrObj, env) == nil - -(DEFUN |attributeNthParent| (|attrObj| |env|) - (declare (ignore |env| |attrObj|)) - NIL) - -;$attributeDispatch := -; VECTOR('attribute, -; [function attributeDevaluate], -; [nil], -; [function attributeLookupExport], -; [function attributeHashCode], -; [function attributeCategoryBuild], -- builder ?? -; [function attributeCategoryParentCount], -; [function attributeNthParent]) -- 1 indexed - -(setq |$attributeDispatch| - (VECTOR '|attribute| - (CONS #'|attributeDevaluate| NIL) - (CONS NIL NIL) - (CONS #'|attributeLookupExport| NIL) - (CONS #'|attributeHashCode| NIL) - (CONS #'|attributeCategoryBuild| NIL) - (CONS #'|attributeCategoryParentCount| NIL) - (CONS #'|attributeNthParent| NIL))) - -;orderedDefaults(conform,domform) == -; $depthAssocCache : local := MAKE_-HASHTABLE 'ID -; conList := [x for x in orderCatAnc (op := opOf conform) | hasDefaultPackage op] -; acc := nil -; ancestors := ancestorsOf(conform,domform) -; for x in conList repeat -; for y in ancestors | x = CAAR y repeat acc := [y,:acc] -; NREVERSE acc - -(DEFUN |orderedDefaults| (|conform| |domform|) - (PROG (|$depthAssocCache| |op| |conList| |ancestors| |acc|) - (DECLARE (SPECIAL |$depthAssocCache|)) - (RETURN - (SEQ (PROGN - (setq |$depthAssocCache| (MAKE-HASHTABLE 'ID)) - (setq |conList| - (PROG (G166358) - (setq G166358 NIL) - (RETURN - (DO ((G166364 - (|orderCatAnc| - (setq |op| (|opOf| |conform|))) - (CDR G166364)) - (|x| NIL)) - ((OR (ATOM G166364) - (PROGN - (SETQ |x| (CAR G166364)) - NIL)) - (NREVERSE0 G166358)) - (SEQ (EXIT (COND - ((|hasDefaultPackage| |op|) - (SETQ G166358 - (CONS |x| G166358)))))))))) - (setq |acc| NIL) - (setq |ancestors| (|ancestorsOf| |conform| |domform|)) - (DO ((G166373 |conList| (CDR G166373)) (|x| NIL)) - ((OR (ATOM G166373) - (PROGN (SETQ |x| (CAR G166373)) NIL)) - NIL) - (SEQ (EXIT (DO ((G166383 |ancestors| (CDR G166383)) - (|y| NIL)) - ((OR (ATOM G166383) - (PROGN - (SETQ |y| (CAR G166383)) - NIL)) - NIL) - (SEQ (EXIT (COND - ((BOOT-EQUAL |x| (CAAR |y|)) - (setq |acc| - (CONS |y| |acc|)))))))))) - (NREVERSE |acc|)))))) - -;instantiate domenv == -; -- following is a patch for a bug in runtime.as -; -- has a lazy dispatch vector with an instantiated domenv -; VECTORP CDR domenv => [$oldAxiomDomainDispatch ,: domenv] -; callForm := CADR domenv -; oldDom := CDDR domenv -; [functor,:args] := callForm -;-- if null(fn := GET(functor,'instantiate)) then -;-- ofn := SYMBOL_-FUNCTION functor -;-- loadFunctor functor -;-- fn := SYMBOL_-FUNCTION functor -;-- SETF(SYMBOL_-FUNCTION functor, ofn) -;-- PUT(functor, 'instantiate, fn) -;-- domvec := APPLY(fn, args) -; domvec := APPLY(functor, args) -; RPLACA(oldDom, $oldAxiomDomainDispatch) -; RPLACD(oldDom, [CADR oldDom,: domvec]) -; oldDom - -(DEFUN |instantiate| (|domenv|) - (PROG (|callForm| |oldDom| |functor| |args| |domvec|) - (declare (special |$oldAxiomDomainDispatch|)) - (RETURN - (COND - ((VECTORP (CDR |domenv|)) - (CONS |$oldAxiomDomainDispatch| |domenv|)) - ('T (setq |callForm| (CADR |domenv|)) - (setq |oldDom| (CDDR |domenv|)) - (setq |functor| (CAR |callForm|)) - (setq |args| (CDR |callForm|)) - (setq |domvec| (APPLY |functor| |args|)) - (RPLACA |oldDom| |$oldAxiomDomainDispatch|) - (RPLACD |oldDom| (CONS (CADR |oldDom|) |domvec|)) |oldDom|))))) - -;hashTypeForm([fn,: args], percentHash) == -; hashType([fn,:devaluateList args], percentHash) - -(DEFUN |hashTypeForm| (G166413 |percentHash|) - (PROG (|fn| |args|) - (RETURN - (PROGN - (setq |fn| (CAR G166413)) - (setq |args| (CDR G166413)) - (|hashType| (CONS |fn| (|devaluateList| |args|)) |percentHash|))))) - -;$hashOp1 := hashString '"1" - -(setq |$hashOp1| (|hashString| "1")) - -;$hashOp0 := hashString '"0" - -(setq |$hashOp0| (|hashString| "0")) - -;$hashOpApply := hashString '"apply" - -(setq |$hashOpApply| (|hashString| "apply")) - -;$hashOpSet := hashString '"set!" - -(setq |$hashOpSet| (|hashString| "set!")) - -;$hashSeg := hashString '".." - -(setq |$hashSeg| (|hashString| "..")) - -;$hashPercent := hashString '"%" - -(setq |$hashPercent| (|hashString| "%")) - -;oldAxiomDomainLookupExport _ -; (domenv, self, op, sig, box, skipdefaults, env) == -; domainVec := CDR domenv -; if hashCode? op then -; EQL(op, $hashOp1) => op := 'One -; EQL(op, $hashOp0) => op := 'Zero -; EQL(op, $hashOpApply) => op := 'elt -; EQL(op, $hashOpSet) => op := 'setelt -; EQL(op, $hashSeg) => op := 'SEGMENT -; constant := nil -; if hashCode? sig and self and EQL(sig, getDomainHash self) then -; sig := '($) -; constant := true -; val := -; skipdefaults => -; oldCompLookupNoDefaults(op, sig, domainVec, self) -; oldCompLookup(op, sig, domainVec, self) -; null val => val -; if constant then val := SPADCALL val -; RPLACA(box, val) -; box - -(DEFUN |oldAxiomDomainLookupExport| - (|domenv| |self| |op| |sig| |box| |skipdefaults| |env|) - (declare (ignore |env|)) - (PROG (|domainVec| |constant| |val|) - (declare (special |$hashOp1| |$hashOp0| |$hashOpApply| |$hashOpSet| - |$hashSeg|)) - (RETURN - (PROGN - (setq |domainVec| (CDR |domenv|)) - (COND - ((|hashCode?| |op|) - (COND - ((EQL |op| |$hashOp1|) (setq |op| '|One|)) - ((EQL |op| |$hashOp0|) (setq |op| '|Zero|)) - ((EQL |op| |$hashOpApply|) (setq |op| '|elt|)) - ((EQL |op| |$hashOpSet|) (setq |op| '|setelt|)) - ((EQL |op| |$hashSeg|) (setq |op| 'SEGMENT))))) - (setq |constant| NIL) - (COND - ((AND (|hashCode?| |sig|) |self| - (EQL |sig| (|getDomainHash| |self|))) - (setq |sig| '($)) (setq |constant| 'T))) - (setq |val| - (COND - (|skipdefaults| - (|oldCompLookupNoDefaults| |op| |sig| - |domainVec| |self|)) - ('T (|oldCompLookup| |op| |sig| |domainVec| |self|)))) - (COND - ((NULL |val|) |val|) - ('T (COND (|constant| (setq |val| (SPADCALL |val|)))) - (RPLACA |box| |val|) |box|)))))) - -;oldAxiomDomainHashCode(domenv, env) == CAR domenv - -(DEFUN |oldAxiomDomainHashCode| (|domenv| |env|) - (declare (ignore |env|)) - (CAR |domenv|)) - -;oldAxiomDomainHasCategory(domenv, cat, env) == -; HasAttribute(domvec := CDR domenv, cat) or -; HasCategory(domvec, devaluate cat) - -(DEFUN |oldAxiomDomainHasCategory| (|domenv| |cat| |env|) - (declare (ignore |env|)) - (PROG (|domvec|) - (RETURN - (OR (|HasAttribute| (setq |domvec| (CDR |domenv|)) |cat|) - (|HasCategory| |domvec| (|devaluate| |cat|)))))) - -;oldAxiomDomainDevaluate(domenv, env) == -; SExprToDName(CDR(domenv).0, 'T) - -(DEFUN |oldAxiomDomainDevaluate| (|domenv| |env|) - (declare (ignore |env|)) - (|SExprToDName| (ELT (CDR |domenv|) 0) 'T)) - -;oldAxiomAddChild(domenv, child, env) == CONS($oldAxiomDomainDispatch, domenv) - -(DEFUN |oldAxiomAddChild| (|domenv| |child| |env|) - (declare (special |$oldAxiomDomainDispatch|) (ignore |child| |env|)) - (CONS |$oldAxiomDomainDispatch| |domenv|)) - -;$oldAxiomDomainDispatch := -; VECTOR('oldAxiomDomain, -; [function oldAxiomDomainDevaluate], -; [nil], -; [function oldAxiomDomainLookupExport], -; [function oldAxiomDomainHashCode], -; [function oldAxiomAddChild]) - -(setq |$oldAxiomDomainDispatch| - (VECTOR '|oldAxiomDomain| - (CONS #'|oldAxiomDomainDevaluate| NIL) - (CONS NIL NIL) - (CONS #'|oldAxiomDomainLookupExport| NIL) - (CONS #'|oldAxiomDomainHashCode| NIL) - (CONS #'|oldAxiomAddChild| NIL))) - -;coerceConvertMmSelection(funName,m1,m2) == -; -- calls selectMms with $Coerce=NIL and tests for required -; -- target type. funName is either 'coerce or 'convert. -; $declaredMode : local:= NIL -; $reportBottomUpFlag : local:= NIL -; l := selectMms1(funName,m2,[m1],[m1],NIL) -; mmS := [[sig,[targ,arg],:pred] for x in l | x is [sig,[.,arg],:pred] and -; hasCorrectTarget(m2,sig) and sig is [dc,targ,oarg] and oarg = m1] -; mmS and CAR mmS - -(DEFUN |coerceConvertMmSelection| (&REST G166559 &AUX G166554) - (DSETQ G166554 G166559) - (PROG () - (RETURN - (PROG (G166555) - (RETURN - (COND - ((SETQ G166555 - (HGET |coerceConvertMmSelection;AL| G166554)) - (|CDRwithIncrement| G166555)) - ('T - (CDR (HPUT |coerceConvertMmSelection;AL| G166554 - (CONS 1 - (APPLY #'|coerceConvertMmSelection;| - G166554))))))))))) - - -(DEFUN |coerceConvertMmSelection;| (|funName| |m1| |m2|) - (PROG (|$declaredMode| |$reportBottomUpFlag| |l| |sig| |ISTMP#3| - |arg| |pred| |dc| |ISTMP#1| |targ| |ISTMP#2| |oarg| |mmS|) - (DECLARE (SPECIAL |$declaredMode| |$reportBottomUpFlag|)) - (RETURN - (SEQ (PROGN - (setq |$declaredMode| NIL) - (setq |$reportBottomUpFlag| NIL) - (setq |l| - (|selectMms1| |funName| |m2| (CONS |m1| NIL) - (CONS |m1| NIL) NIL)) - (setq |mmS| - (PROG (G166519) - (setq G166519 NIL) - (RETURN - (DO ((G166525 |l| (CDR G166525)) - (|x| NIL)) - ((OR (ATOM G166525) - (PROGN - (SETQ |x| (CAR G166525)) - NIL)) - (NREVERSE0 G166519)) - (SEQ (EXIT (COND - ((AND (CONSP |x|) - (PROGN - (setq |sig| (QCAR |x|)) - (setq |ISTMP#1| - (QCDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |ISTMP#2| - (QCAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (setq |ISTMP#3| - (QCDR |ISTMP#2|)) - (AND - (CONSP |ISTMP#3|) - (EQ - (QCDR |ISTMP#3|) - NIL) - (PROGN - (setq |arg| - (QCAR |ISTMP#3|)) - 'T))))) - (PROGN - (setq |pred| - (QCDR |ISTMP#1|)) - 'T))) - (|hasCorrectTarget| |m2| - |sig|) - (CONSP |sig|) - (PROGN - (setq |dc| - (QCAR |sig|)) - (setq |ISTMP#1| - (QCDR |sig|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (setq |targ| - (QCAR |ISTMP#1|)) - (setq |ISTMP#2| - (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) - NIL) - (PROGN - (setq |oarg| - (QCAR |ISTMP#2|)) - 'T))))) - (BOOT-EQUAL |oarg| |m1|)) - (SETQ G166519 - (CONS - (CONS |sig| - (CONS - (CONS |targ| - (CONS |arg| NIL)) - |pred|)) - G166519)))))))))) - (AND |mmS| (CAR |mmS|))))))) - -(PUT '|coerceConvertMmSelection| '|cacheInfo| - '(|coerceConvertMmSelection| |coerceConvertMmSelection;AL| - |hash-tableWithCounts| - (SETQ |coerceConvertMmSelection;AL| (MAKE-HASHTABLE 'UEQUAL)) - (|hashCount| |coerceConvertMmSelection;AL|))) - -(SETQ |coerceConvertMmSelection;AL| (MAKE-HASHTABLE 'UEQUAL)) - -\end{chunk} -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/nrunfast.lisp.pamphlet b/src/interp/nrunfast.lisp.pamphlet index a870926..eb5c981 100644 --- a/src/interp/nrunfast.lisp.pamphlet +++ b/src/interp/nrunfast.lisp.pamphlet @@ -1978,11 +1978,6 @@ (AND (BOOT-EQUAL (ifcar |s|) (QCAR (ELT |d| 0))) (|lazyMatchArgDollarCheck| |s| (ELT |d| 0) (ELT |dollar| 0) |domainArg|))))) - ((|isDomain| |d|) (setq |dhash| (|getDomainHash| |d|)) - (BOOT-EQUAL |dhash| - (COND - ((|hashCode?| |s|) |s|) - ('T (|hashType| |s| |dhash|))))) ('T (|lazyMatch| |s| |d| |dollar| |domain|)))) ((BOOT-EQUAL |a| '$) (BOOT-EQUAL |s| (|devaluate| |dollar|))) ((BOOT-EQUAL |a| '$$) @@ -2394,7 +2389,6 @@ (RETURN (COND ((VECP |lazyt|) (ELT |lazyt| 0)) - ((|isDomain| |lazyt|) (|devaluate| |lazyt|)) ((ATOM |lazyt|) |lazyt|) ((AND (CONSP |lazyt|) (PROGN @@ -2988,12 +2982,6 @@ ((VECP |domain|) (|hashType| (ELT |domain| 0) 0)) ('T (|hashType| |domain| 0)))) (COND - ((|isDomain| |domain|) - (COND - ((integerp (ELT (CAR |domain|) 0)) - (|basicLookup| '%% (|hashType| |attrib| |hashPercent|) - |domain| |domain|)) - ('T (|HasAttribute| (CDDR |domain|) |attrib|)))) ((|isNewWorldDomain| |domain|) (|newHasAttribute| |domain| |attrib|)) ('T @@ -3130,12 +3118,6 @@ (AND (CONSP |ISTMP#1|) (EQ (QCDR |ISTMP#1|) NIL) (PROGN (setq |f| (QCAR |ISTMP#1|)) 'T)))) (|HasAttribute| |domain| |f|)) - ((|isDomain| |domain|) - (COND - ((integerp (ELT (CAR |domain|) 0)) - (setq |catform'| (|devaluate| |catform'|)) - (|basicLookup| '%% |catform'| |domain| |domain|)) - ('T (|HasCategory| (CDDR |domain|) |catform'|)))) ('T (setq |catform| (|devaluate| |catform'|)) (COND ((|isNewWorldDomain| |domain|) diff --git a/src/interp/template.lisp.pamphlet b/src/interp/template.lisp.pamphlet index 4aa8d2f..4ab9a98 100644 --- a/src/interp/template.lisp.pamphlet +++ b/src/interp/template.lisp.pamphlet @@ -160,13 +160,11 @@ (setq $ |dollar|) (setq |$lookupDefaults| NIL) (COND - ((|isDomain| |u|) |u|) ((BOOT-EQUAL |u| '$) |dollar|) ((BOOT-EQUAL |u| '$$) |dollar|) ((integerp |u|) (COND ((VECP (setq |y| (ELT |dollar| |u|))) |y|) - ((|isDomain| |y|) |y|) ((AND (CONSP |y|) (EQ (QCAR |y|) 'SETELT)) (|eval| |y|)) ((AND (CONSP |y|) -- 1.7.5.4