diff --git a/books/bookvol9.pamphlet b/books/bookvol9.pamphlet index f027e8c..07c5468 100644 --- a/books/bookvol9.pamphlet +++ b/books/bookvol9.pamphlet @@ -6775,6 +6775,85 @@ constructMacro (form is [nam,[lam,vl,body]]) \end{chunk} +\defun{NRTputInTail}{NRTputInTail} +\calls{NRTputInTail}{lassoc} +\calls{NRTputInTail}{NRTassocIndex} +\calls{NRTputInTail}{rplaca} +\calls{NRTputInTail}{NRTputInHead} +\refsdollar{NRTputInTail}{elt} +\refsdollar{NRTputInTail}{devaluateList} +\begin{chunk}{defun NRTputInTail} +(defun |NRTputInTail| (x) + (let (u k) + (declare (special |$elt| |$devaluateList|)) + (maplist #'(lambda (y) + (cond + ((atom (setq u (car y))) + (cond + ((or (eq u '$) (lassoc u |$devaluateList|)) + nil) + ((setq k (|NRTassocIndex| u)) + (cond + ; u atomic means that the slot will always contain a vector + ((atom u) (rplaca y (list |$elt| '$ k))) + ; this reference must check that slot is a vector + (t (rplaca y (list 'spadcheckelt '$ k))))) + (t nil))) + (t (|NRTputInHead| u)))) + x) + x)) + +\end{chunk} + +\defun{NRTputInHead}{NRTputInHead} +\calls{NRTputInHead}{NRTputInTail} +\calls{NRTputInHead}{NRTassocIndex} +\calls{NRTputInHead}{NRTputInHead} +\calls{NRTputInHead}{lastnode} +\calls{NRTputInHead}{keyedSystemError} +\refsdollar{NRTputInHead}{elt} +\begin{chunk}{defun NRTputInHead} +(defun |NRTputInHead| (bod) + (let (fn args |elt| clauses tmp1 dom tmp2 ind k) + (declare (special |$elt|)) + (cond + ((atom bod) bod) + ((and (consp bod) (eq (qcar bod) 'spadcall) (consp (qcdr bod)) + (progn (setq tmp2 (reverse (qcdr bod))) t) (consp tmp2)) + (setq fn (qcar tmp2)) + (|NRTputInTail| (cdr bod)) + (cond + ((and (consp fn) (consp (qcdr fn)) (consp (qcdr (qcdr fn))) + (eq (qcdddr fn) nil) (null (eq (qsecond fn) '$)) + (member (qcar fn) '(elt qrefelt const))) + (when (setq k (|NRTassocIndex| (qsecond fn))) + (rplaca (lastnode bod) (list |$elt| '$ k)))) + (t (|NRTputInHead| fn) bod))) + ((and (consp bod) (eq (qcar bod) 'cond)) + (setq clauses (qcdr bod)) + (loop for cc in clauses do (|NRTputInTail| cc)) + bod) + ((and (consp bod) (eq (qcar bod) 'quote)) bod) + ((and (consp bod) (eq (qcar bod) 'closedfn)) bod) + ((and (consp bod) (eq (qcar bod) 'spadconst) (consp (qcdr bod)) + (consp (qcddr bod)) (eq (qcdddr bod) nil)) + (setq dom (qsecond bod)) + (setq ind (qthird bod)) + (rplaca bod |$elt|) + (cond + ((eq dom '$) nil) + ((setq k (|NRTassocIndex| dom)) + (rplaca (lastnode bod) (list |$elt| '$ k)) + bod) + (t + (|keyedSystemError| 'S2GE0016 + (list "NRTputInHead" "unexpected SPADCONST form"))))) + (t + (|NRTputInHead| (car bod)) + (|NRTputInTail| (cdr bod)) bod)))))) + +\end{chunk} + \defun{getArgumentModeOrMoan}{getArgumentModeOrMoan} \calls{getArgumentModeOrMoan}{getArgumentMode} \calls{getArgumentModeOrMoan}{stackSemanticError} @@ -8263,6 +8342,97 @@ where item has form \end{chunk} +\defun{NRTgetLookupFunction}{NRTgetLookupFunction} +Compute the lookup function (complete or incomplete) +\calls{NRTgetLookupFunction}{sublis} +\calls{NRTgetLookupFunction}{NRTextendsCategory1} +\calls{NRTgetLookupFunction}{getExportCategory} +\calls{NRTgetLookupFunction}{sayBrightly} +\calls{NRTgetLookupFunction}{sayBrightlyNT} +\calls{NRTgetLookupFunction}{bright} +\calls{NRTgetLookupFunction}{form2String} +\defsdollar{NRTgetLookupFunction}{why} +\refsdollar{NRTgetLookupFunction}{why} +\refsdollar{NRTgetLookupFunction}{pairlis} +\begin{chunk}{defun NRTgetLookupFunction} +(defun |NRTgetLookupFunction| (domform exCategory addForm) + (let (|$why| extends u msg v) + (declare (special |$why| |$pairlis|)) + (setq domform (sublis |$pairlis| domform)) + (setq addForm (sublis |$pairlis| addForm)) + (setq |$why| nil) + (cond + ((atom addForm) '|lookupComplete|) + (t + (setq extends + (|NRTextendsCategory1| domform exCategory (|getExportCategory| addForm))) + (cond + ((null extends) + (setq u (car |$why|)) + (setq msg (cadr |$why|)) + (setq v (cddr |$why|)) + (|sayBrightly| + "--------------non extending category----------------------") + (|sayBrightlyNT| + (cons ".." + (append (|bright| (|form2String| domform)) (list '|of cat |)))) + (print u) + (|sayBrightlyNT| (|bright| msg)) + (if v (print (car v)) (terpri)))) + (if extends + '|lookupIncomplete| + '|lookupComplete|))))) + +\end{chunk} + +\defun{NRTgetLocalIndex}{NRTgetLocalIndex} +\calls{NRTgetLocalIndex}{NRTassocIndex} +\calls{NRTgetLocalIndex}{NRTaddInner} +\calls{NRTgetLocalIndex}{compOrCroak} +\calls{NRTgetLocalIndex}{rplaca} +\refsdollar{NRTgetLocalIndex}{NRTaddForm} +\refsdollar{NRTgetLocalIndex}{formalArgList} +\refsdollar{NRTgetLocalIndex}{NRTdeltaList} +\refsdollar{NRTgetLocalIndex}{NRTdeltaListComp} +\refsdollar{NRTgetLocalIndex}{NRTdeltaLength} +\defsdollar{NRTgetLocalIndex}{NRTbase} +\defsdollar{NRTgetLocalIndex}{EmptyMode} +\defsdollar{NRTgetLocalIndex}{e} +\begin{chunk}{defun NRTgetLocalIndex} +(defun |NRTgetLocalIndex| (item) + (let (k value saveNRTdeltaListComp saveIndex compEntry) + (declare (special |$e| |$EmptyMode| |$NRTdeltaLength| |$NRTbase| + |$NRTdeltaListComp| |$NRTdeltaList| |$formalArgList| + |$NRTaddForm|)) + (cond + ((setq k (|NRTassocIndex| item)) k) + ((equal item |$NRTaddForm|) 5) + ((eq item '$) 0) + ((eq item '$$) 2) + (t + (when (member item |$formalArgList|) (setq value item)) + (cond + ((and (atom item) (null (member item '($ $$))) (null value)) + (setq |$NRTdeltaList| + (cons (cons '|domain| (cons (|NRTaddInner| item) value)) + |$NRTdeltaList|)) + (setq |$NRTdeltaListComp| (cons item |$NRTdeltaListComp|)) + (setq |$NRTdeltaLength| (1+ |$NRTdeltaLength|)) + (1- (+ |$NRTbase| |$NRTdeltaLength|))) + (t + (setq |$NRTdeltaList| + (cons (cons '|domain| (cons (|NRTaddInner| item) value)) + |$NRTdeltaList|)) + (setq saveNRTdeltaListComp + (setq |$NRTdeltaListComp| (cons nil |$NRTdeltaListComp|))) + (setq saveIndex (+ |$NRTbase| |$NRTdeltaLength|)) + (setq |$NRTdeltaLength| (1+ |$NRTdeltaLength|)) + (setq compEntry (car (|compOrCroak| item |$EmptyMode| |$e|))) + (rplaca saveNRTdeltaListComp compEntry) + saveIndex)))))) + +\end{chunk} + \defun{augmentLisplibModemapsFromFunctor}{augmentLisplibModemapsFromFunctor} \calls{augmentLisplibModemapsFromFunctor}{formal2Pattern} \calls{augmentLisplibModemapsFromFunctor}{mkAlistOfExplicitCategoryOps} @@ -10921,7 +11091,6 @@ Since we can't be sure we take the least disruptive course of action. \calls{doIt}{get} \calls{doIt}{NRTgetLocalIndex} \calls{doIt}{sublis} -\calls{doIt}{NRTgetLocalIndexClear} \calls{doIt}{compOrCroak} \calls{doIt}{sayBrightly} \calls{doIt}{formatUnabbreviated} @@ -11054,7 +11223,7 @@ Since we can't be sure we take the least disruptive course of action. ((and (consp code) (eq (qfirst code) 'let)) (rplaca item (if |$QuickCode| 'qsetrefv 'setelt)) (setq rhsCode rhsp) - (rplacd item (list '$ (|NRTgetLocalIndexClear| lhs) rhsCode))) + (rplacd item (list '$ (|NRTgetLocalIndex| lhs) rhsCode))) (t (rplaca item (car code)) (rplacd item (cdr code))))))) @@ -14049,6 +14218,35 @@ is still more than one complain else return the only signature. \end{chunk} +\defun{NRTassocIndex}{NRTassocIndex} +This function returns the index of domain entry x in the association list +\refsdollar{NRTassocIndex}{NRTaddForm} +\refsdollar{NRTassocIndex}{NRTdeltaList} +\refsdollar{NRTassocIndex}{found} +\refsdollar{NRTassocIndex}{NRTbase} +\refsdollar{NRTassocIndex}{NRTdeltaLength} +\begin{chunk}{defun NRTassocIndex} +(defun |NRTassocIndex| (x) + (let (k (i 0)) + (declare (special |$NRTdeltaLength| |$NRTbase| |$found| |$NRTdeltaList| + |$NRTaddForm|)) + (cond + ((null x) x) + ((equal x |$NRTaddForm|) 5) + ((setq k + (let (result) + (loop for y in |$NRTdeltaList| + when (and (incf i) + (eq (elt y 0) '|domain|) + (equal (elt y 1) x) + (setq |$found| y)) + do (setq result (or result i))) + result)) + (- (+ |$NRTbase| |$NRTdeltaLength|) k)) + (t nil)))) + +\end{chunk} + \defun{assignError}{assignError} \calls{assignError}{stackMessage} \begin{chunk}{defun assignError} @@ -22614,6 +22812,11 @@ The current input line. \getchunk{defun next-token} \getchunk{defun new2OldLisp} \getchunk{defun nonblankloc} +\getchunk{defun NRTassocIndex} +\getchunk{defun NRTgetLocalIndex} +\getchunk{defun NRTgetLookupFunction} +\getchunk{defun NRTputInHead} +\getchunk{defun NRTputInTail} \getchunk{defun optCall} \getchunk{defun optCallEval} diff --git a/changelog b/changelog index 84b93c3..34b2a67 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20111008 tpd src/axiom-website/patches.html 20111008.01.tpd.patch +20111008 tpd src/interp/nrunopt.lisp treeshake compiler +20111008 tpd src/interp/nruncomp.lisp treeshake compiler +20111008 tpd books/bookvol9 treeshake compiler 20110929 tpd src/axiom-website/patches.html 20110929.04.tpd.patch 20110239 tpd src/axiom-website/documentation.html bold quote 20110929 tpd src/axiom-website/patches.html 20110929.03.tpd.patch diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 372f8fa..ea43c66 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -3650,5 +3650,7 @@ src/axiom-website/documentation.html add quote
src/axiom-website/download.html update to latest release
20110929.04.tpd.patch src/axiom-website/documentation.html bold quote
+20111008.01.tpd.patch +books/bookvol9 treeshake compiler
diff --git a/src/interp/nruncomp.lisp.pamphlet b/src/interp/nruncomp.lisp.pamphlet index ea200e2..dd87bbf 100644 --- a/src/interp/nruncomp.lisp.pamphlet +++ b/src/interp/nruncomp.lisp.pamphlet @@ -672,121 +672,6 @@ (declare (special |$NRTaddForm|)) (COND ((BOOT-EQUAL |x| |$NRTaddForm|) 5) ('T (|NRTassocIndex| |x|)))) -;NRTassocIndex x == --returns index of "domain" entry x in al -; NULL x => x -; x = $NRTaddForm => 5 -; k := or/[i for i in 1.. for y in $NRTdeltaList -; | y.0 = 'domain and y.1 = x and ($found := y)] => -; $NRTbase + $NRTdeltaLength - k -; nil - -(DEFUN |NRTassocIndex| (|x|) - (PROG (|k|) - (declare (special |$NRTdeltaLength| |$NRTbase| |$found| |$NRTdeltaList| - |$NRTaddForm|)) - (RETURN - (SEQ (COND - ((NULL |x|) |x|) - ((BOOT-EQUAL |x| |$NRTaddForm|) 5) - ((SPADLET |k| - (PROG (G166410) - (SPADLET G166410 NIL) - (RETURN - (DO ((G166418 NIL G166410) - (|i| 1 (QSADD1 |i|)) - (G166419 |$NRTdeltaList| - (CDR G166419)) - (|y| NIL)) - ((OR G166418 (ATOM G166419) - (PROGN - (SETQ |y| (CAR G166419)) - NIL)) - G166410) - (SEQ (EXIT (COND - ((AND - (BOOT-EQUAL (ELT |y| 0) - '|domain|) - (BOOT-EQUAL (ELT |y| 1) - |x|) - (SPADLET |$found| |y|)) - (SETQ G166410 - (OR G166410 |i|)))))))))) - (SPADDIFFERENCE (PLUS |$NRTbase| |$NRTdeltaLength|) |k|)) - ('T NIL)))))) - -;NRTgetLocalIndexClear item == NRTgetLocalIndex1(item,true) - -(DEFUN |NRTgetLocalIndexClear| (|item|) - (|NRTgetLocalIndex1| |item| 'T)) - -;NRTgetLocalIndex item == NRTgetLocalIndex1(item,false) - -(DEFUN |NRTgetLocalIndex| (|item|) (|NRTgetLocalIndex1| |item| NIL)) - -;NRTgetLocalIndex1(item,killBindingIfTrue) == -; k := NRTassocIndex item => k -; item = $NRTaddForm => 5 -; item = '$ => 0 -; item = '_$_$ => 2 -; value:= -; MEMQ(item,$formalArgList) => item -; nil -; atom item and null MEMQ(item,'($ _$_$)) -; and null value => --give slots to atoms -; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] -; $NRTdeltaListComp:=[item,:$NRTdeltaListComp] -; $NRTdeltaLength := $NRTdeltaLength+1 -; $NRTbase + $NRTdeltaLength - 1 -; $NRTdeltaList:= [['domain,NRTaddInner item,:value],:$NRTdeltaList] -; saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] -; saveIndex := $NRTbase + $NRTdeltaLength -; $NRTdeltaLength := $NRTdeltaLength+1 -; compEntry:= compOrCroak(item,$EmptyMode,$e).expr -;-- item -; RPLACA(saveNRTdeltaListComp,compEntry) -; saveIndex - -(DEFUN |NRTgetLocalIndex1| (|item| |killBindingIfTrue|) - (declare (ignore |killBindingIfTrue|)) - (PROG (|k| |value| |saveNRTdeltaListComp| |saveIndex| |compEntry|) - (declare (special |$e| |$EmptyMode| |$NRTdeltaLength| |$NRTbase| - |$NRTdeltaListComp| |$NRTdeltaList| |$formalArgList| - |$NRTaddForm|)) - (RETURN - (COND - ((SPADLET |k| (|NRTassocIndex| |item|)) |k|) - ((BOOT-EQUAL |item| |$NRTaddForm|) 5) - ((BOOT-EQUAL |item| '$) 0) - ((BOOT-EQUAL |item| '$$) 2) - ('T - (SPADLET |value| - (COND - ((member |item| |$formalArgList|) |item|) - ('T NIL))) - (COND - ((AND (ATOM |item|) (NULL (member |item| '($ $$))) - (NULL |value|)) - (SPADLET |$NRTdeltaList| - (CONS (CONS '|domain| - (CONS (|NRTaddInner| |item|) |value|)) - |$NRTdeltaList|)) - (SPADLET |$NRTdeltaListComp| - (CONS |item| |$NRTdeltaListComp|)) - (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) - (SPADDIFFERENCE (PLUS |$NRTbase| |$NRTdeltaLength|) 1)) - ('T - (SPADLET |$NRTdeltaList| - (CONS (CONS '|domain| - (CONS (|NRTaddInner| |item|) |value|)) - |$NRTdeltaList|)) - (SPADLET |saveNRTdeltaListComp| - (SPADLET |$NRTdeltaListComp| - (CONS NIL |$NRTdeltaListComp|))) - (SPADLET |saveIndex| (PLUS |$NRTbase| |$NRTdeltaLength|)) - (SPADLET |$NRTdeltaLength| (PLUS |$NRTdeltaLength| 1)) - (SPADLET |compEntry| - (CAR (|compOrCroak| |item| |$EmptyMode| |$e|))) - (RPLACA |saveNRTdeltaListComp| |compEntry|) |saveIndex|))))))) ;NRTgetAddForm domain == ; u := HGET($Slot1DataBase,first domain) => @@ -2699,167 +2584,6 @@ (SPADLET |$elt| (COND (|$QuickCode| 'QREFELT) ('T 'ELT))) (|NRTputInHead| |bod|))))) -;NRTputInHead bod == -; atom bod => bod -;-- LASSOC(bod,$devaluateList) => nil -;-- k:= NRTassocIndex bod => [$elt,'_$,k] -;-- systemError '"unexpected position of domain reference" -;-- bod -;--bod is ['LET,var,val,:extra] and IDENTP var => -;-- NRTputInTail extra -;-- k:= NRTassocIndex var => RPLAC(CADDR bod,[$elt,'$,k]) -;-- NRTputInHead val -;-- bod -; bod is ['SPADCALL,:args,fn] => -; NRTputInTail rest bod --NOTE: args = COPY of rest bod -; -- The following test allows function-returning expressions -; fn is [elt,dom,ind] and not (dom='$) and MEMQ(elt,'(ELT QREFELT CONST)) => -; k:= NRTassocIndex dom => RPLACA(LASTNODE bod,[$elt,'_$,k]) -;-- sayBrightlyNT '"unexpected SPADCALL:" -;-- pp fn -;-- nil -;-- keyedSystemError("S2GE0016",['"NRTputInHead", -;-- '"unexpected SPADCALL form"]) -; nil -; NRTputInHead fn -; bod -; bod is ["COND",:clauses] => -; for cc in clauses repeat NRTputInTail cc -; bod -; bod is ["QUOTE",:.] => bod -; bod is ["CLOSEDFN",:.] => bod -; bod is ["SPADCONST",dom,ind] => -; RPLACA(bod,$elt) -; dom = '_$ => nil -; k:= NRTassocIndex dom => -; RPLACA(LASTNODE bod,[$elt,'_$,k]) -; bod -; keyedSystemError("S2GE0016",['"NRTputInHead", -; '"unexpected SPADCONST form"]) -; NRTputInHead first bod -; NRTputInTail rest bod -; bod - -(DEFUN |NRTputInHead| (|bod|) - (PROG (|fn| |args| |elt| |clauses| |ISTMP#1| |dom| |ISTMP#2| |ind| |k|) - (declare (special |$elt|)) - (RETURN - (SEQ (COND - ((ATOM |bod|) |bod|) - ((AND (CONSP |bod|) (EQ (QCAR |bod|) 'SPADCALL) - (PROGN - (SPADLET |ISTMP#1| (QCDR |bod|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SPADLET |ISTMP#2| (REVERSE |ISTMP#1|)) - 'T) - (CONSP |ISTMP#2|) - (PROGN - (SPADLET |fn| (QCAR |ISTMP#2|)) - (SPADLET |args| (QCDR |ISTMP#2|)) - 'T) - (PROGN - (SPADLET |args| (NREVERSE |args|)) - 'T)))) - (|NRTputInTail| (CDR |bod|)) - (COND - ((AND (CONSP |fn|) - (PROGN - (SPADLET |elt| (QCAR |fn|)) - (SPADLET |ISTMP#1| (QCDR |fn|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ind| (QCAR |ISTMP#2|)) - 'T))))) - (NULL (BOOT-EQUAL |dom| '$)) - (member |elt| '(ELT QREFELT CONST))) - (COND - ((SPADLET |k| (|NRTassocIndex| |dom|)) - (RPLACA (LASTNODE |bod|) - (CONS |$elt| (CONS '$ (CONS |k| NIL))))) - ('T NIL))) - ('T (|NRTputInHead| |fn|) |bod|))) - ((AND (CONSP |bod|) (EQ (QCAR |bod|) 'COND) - (PROGN (SPADLET |clauses| (QCDR |bod|)) 'T)) - (DO ((G167797 |clauses| (CDR G167797)) (|cc| NIL)) - ((OR (ATOM G167797) - (PROGN (SETQ |cc| (CAR G167797)) NIL)) - NIL) - (SEQ (EXIT (|NRTputInTail| |cc|)))) - |bod|) - ((AND (CONSP |bod|) (EQ (QCAR |bod|) 'QUOTE)) |bod|) - ((AND (CONSP |bod|) (EQ (QCAR |bod|) 'CLOSEDFN)) |bod|) - ((AND (CONSP |bod|) (EQ (QCAR |bod|) 'SPADCONST) - (PROGN - (SPADLET |ISTMP#1| (QCDR |bod|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SPADLET |dom| (QCAR |ISTMP#1|)) - (SPADLET |ISTMP#2| (QCDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (QCDR |ISTMP#2|) NIL) - (PROGN - (SPADLET |ind| (QCAR |ISTMP#2|)) - 'T)))))) - (RPLACA |bod| |$elt|) - (COND - ((BOOT-EQUAL |dom| '$) NIL) - ((SPADLET |k| (|NRTassocIndex| |dom|)) - (RPLACA (LASTNODE |bod|) - (CONS |$elt| (CONS '$ (CONS |k| NIL)))) - |bod|) - ('T - (|keyedSystemError| 'S2GE0016 - (CONS "NRTputInHead" - (CONS "unexpected SPADCONST form" - NIL)))))) - ('T (|NRTputInHead| (CAR |bod|)) - (|NRTputInTail| (CDR |bod|)) |bod|)))))) - -;NRTputInTail x == -; for y in tails x repeat -; atom (u := first y) => -; EQ(u,'$) or LASSOC(u,$devaluateList) => nil -; k:= NRTassocIndex u => -; atom u => RPLACA(y,[$elt,'_$,k]) -; -- u atomic means that the slot will always contain a vector -; RPLACA(y,['SPADCHECKELT,'_$,k]) -; --this reference must check that slot is a vector -; nil -; NRTputInHead u -; x - -(DEFUN |NRTputInTail| (|x|) - (PROG (|u| |k|) - (declare (special |$elt| |$devaluateList|)) - (RETURN - (SEQ (PROGN - (DO ((|y| |x| (CDR |y|))) ((ATOM |y|) NIL) - (SEQ (EXIT (COND - ((ATOM (SPADLET |u| (CAR |y|))) - (COND - ((OR (EQ |u| '$) - (LASSOC |u| |$devaluateList|)) - NIL) - ((SPADLET |k| (|NRTassocIndex| |u|)) - (COND - ((ATOM |u|) - (RPLACA |y| - (CONS |$elt| - (CONS '$ (CONS |k| NIL))))) - ('T - (RPLACA |y| - (CONS 'SPADCHECKELT - (CONS '$ (CONS |k| NIL))))))) - ('T NIL))) - ('T (|NRTputInHead| |u|)))))) - |x|))))) - \end{chunk} \eject \begin{thebibliography}{99} diff --git a/src/interp/nrunopt.lisp.pamphlet b/src/interp/nrunopt.lisp.pamphlet index 01ff0ef..47bd893 100644 --- a/src/interp/nrunopt.lisp.pamphlet +++ b/src/interp/nrunopt.lisp.pamphlet @@ -3153,55 +3153,6 @@ |sig|) |suffix|))))))))))))))) -; -;--======================================================================= -;-- Compute the lookup function (complete or incomplete) -;--======================================================================= -;NRTgetLookupFunction(domform,exCategory,addForm) == -; domform := SUBLIS($pairlis,domform) -; addForm := SUBLIS($pairlis,addForm) -; $why: local := nil -; atom addForm => 'lookupComplete -; extends := NRTextendsCategory1(domform,exCategory,getExportCategory addForm) -; if null extends then -; [u,msg,:v] := $why -; sayBrightly '"--------------non extending category----------------------" -; sayBrightlyNT ['"..",:bright form2String domform,"of cat "] -; PRINT u -; sayBrightlyNT bright msg -; if v then PRINT CAR v else TERPRI() -; extends => 'lookupIncomplete -; 'lookupComplete - -(DEFUN |NRTgetLookupFunction| (|domform| |exCategory| |addForm|) - (PROG (|$why| |extends| |u| |msg| |v|) - (DECLARE (SPECIAL |$why| |$pairlis|)) - (RETURN - (PROGN - (SPADLET |domform| (SUBLIS |$pairlis| |domform|)) - (SPADLET |addForm| (SUBLIS |$pairlis| |addForm|)) - (SPADLET |$why| NIL) - (COND - ((ATOM |addForm|) '|lookupComplete|) - ('T - (SPADLET |extends| - (|NRTextendsCategory1| |domform| |exCategory| - (|getExportCategory| |addForm|))) - (COND - ((NULL |extends|) (SPADLET |u| (CAR |$why|)) - (SPADLET |msg| (CADR |$why|)) (SPADLET |v| (CDDR |$why|)) - (|sayBrightly| - "--------------non extending category----------------------") - (|sayBrightlyNT| - (CONS ".." - (APPEND (|bright| (|form2String| |domform|)) - (CONS '|of cat | NIL)))) - (PRINT |u|) (|sayBrightlyNT| (|bright| |msg|)) - (COND (|v| (PRINT (CAR |v|))) ('T (TERPRI))))) - (COND - (|extends| '|lookupIncomplete|) - ('T '|lookupComplete|)))))))) - ;getExportCategory form == ; [op,:argl] := form ; op = 'Record => ['RecordCategory,:argl]