From 491eda903e80958a28a53d36688a65911a0d2978 Mon Sep 17 00:00:00 2001 From: dos-reis Date: Tue, 11 Sep 2007 21:07:16 +0000 Subject: * template.boot: New. * template.boot.pamphlet: Move content to template.boot. Remove. * termrw.boot: New. * termrw.boot.pamphlet: Move content to template.boot. Remove. * topics.boot: New. * topics.boot.pamphlet: Move content to topics.boot. Remove. * trace.boot: New. * trace.boot.pamphlet: Move content to trace.boot. Remove. * varini.boot: New. * varini.boot.pamphlet: Move content to varini.boot. Remove. * xrun.boot: New. * xrun.boot.pamphlet: Move content to xrun.boot. Remove * xruncomp.boot: New. * xruncomp.boot.pamphlet: Move content to xruncomp.boot. Remove. * Makefile.pamphlet (<>): Remove. (<>): Likewise. (<>): Likewise. (<>): Likewise. (<>): Likewise. --- src/interp/ChangeLog | 22 + src/interp/Makefile.in | 23 +- src/interp/Makefile.pamphlet | 121 +----- src/interp/interop.boot.pamphlet | 2 +- src/interp/mark.boot.pamphlet | 6 +- src/interp/parse.boot.pamphlet | 2 +- src/interp/postpar.boot.pamphlet | 2 +- src/interp/showimp.boot.pamphlet | 6 +- src/interp/template.boot | 338 +++++++++++++++ src/interp/template.boot.pamphlet | 359 ---------------- src/interp/termrw.boot | 154 +++++++ src/interp/termrw.boot.pamphlet | 197 --------- src/interp/topics.boot | 240 +++++++++++ src/interp/trace.boot | 832 ++++++++++++++++++++++++++++++++++++ src/interp/trace.boot.pamphlet | 856 -------------------------------------- src/interp/varini.boot | 254 +++++++++++ src/interp/varini.boot.pamphlet | 276 ------------ src/interp/wi2.boot.pamphlet | 2 +- src/interp/xrun.boot | 496 ++++++++++++++++++++++ src/interp/xrun.boot.pamphlet | 518 ----------------------- src/interp/xruncomp.boot | 330 +++++++++++++++ src/interp/xruncomp.boot.pamphlet | 354 ---------------- 22 files changed, 2679 insertions(+), 2711 deletions(-) create mode 100644 src/interp/template.boot delete mode 100644 src/interp/template.boot.pamphlet create mode 100644 src/interp/termrw.boot delete mode 100644 src/interp/termrw.boot.pamphlet create mode 100644 src/interp/topics.boot create mode 100644 src/interp/trace.boot delete mode 100644 src/interp/trace.boot.pamphlet create mode 100644 src/interp/varini.boot delete mode 100644 src/interp/varini.boot.pamphlet create mode 100644 src/interp/xrun.boot delete mode 100644 src/interp/xrun.boot.pamphlet create mode 100644 src/interp/xruncomp.boot delete mode 100644 src/interp/xruncomp.boot.pamphlet (limited to 'src') diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index 43c20c12..3071735f 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,3 +1,25 @@ +2007-09-11 Gabriel Dos Reis + + * template.boot: New. + * template.boot.pamphlet: Move content to template.boot. Remove. + * termrw.boot: New. + * termrw.boot.pamphlet: Move content to template.boot. Remove. + * topics.boot: New. + * topics.boot.pamphlet: Move content to topics.boot. Remove. + * trace.boot: New. + * trace.boot.pamphlet: Move content to trace.boot. Remove. + * varini.boot: New. + * varini.boot.pamphlet: Move content to varini.boot. Remove. + * xrun.boot: New. + * xrun.boot.pamphlet: Move content to xrun.boot. Remove + * xruncomp.boot: New. + * xruncomp.boot.pamphlet: Move content to xruncomp.boot. Remove. + * Makefile.pamphlet (<>): Remove. + (<>): Likewise. + (<>): Likewise. + (<>): Likewise. + (<>): Likewise. + 2007-09-10 Gabriel Dos Reis * i-output.boot.pamphlet ($defaultSpecialCharacters): Define as diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 3027455a..3f0fed26 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -6,7 +6,7 @@ DOC=$(axiom_target_docdir)/src/interp BOOK=$(axiom_target_docdir) # Command to translate Boot to Common Lisp -BOOT_TO_LISP = $(BOOTSYS) -- --translate $< +BOOT_TO_LISP = $(BOOTSYS) -- --translate --output=$@ $< # Command to translate Common Lisp to native object code COMPILE_LISP = $(DEPSYS) -- --compile --output=$@ $< @@ -821,32 +821,11 @@ setvart.clisp: setvart.boot @ echo 398 making $@ from $< @ echo '(progn (old-boot::boot "setvart.boot"))' | ${DEPSYS} -template.clisp: template.boot - @ echo 408 making $@ from $< - @ echo '(progn (old-boot::boot "template.boot"))' | ${DEPSYS} - -termrw.clisp: termrw.boot - @ echo 411 making $@ from $< - @ echo '(progn (old-boot::boot "termrw.boot"))' | ${DEPSYS} - -topics.clisp: topics.boot - @ echo 495 making $@ from $< - @ echo '(progn (old-boot::boot "topics.boot"))' | ${DEPSYS} - -trace.clisp: trace.boot - @ echo 414 making $@ from $< - @ echo '(progn (old-boot::boot "trace.boot"))' | ${DEPSYS} - ../algebra/warm.data: $(srcdir)/Makefile.pamphlet @ echo 2 building warm.data $(axiom_build_document) --tangle=warm.data --output=$@ $< -xruncomp.clisp: xruncomp.boot - @ echo 459 making $@ from $< - @ echo '(progn (old-boot::boot "xruncomp.boot"))' | ${DEPSYS} - - buildom.$(FASLEXT): buildom.boot sys-macros.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 165922ab..ad4d277d 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -56,7 +56,7 @@ DOC=$(axiom_target_docdir)/src/interp BOOK=$(axiom_target_docdir) # Command to translate Boot to Common Lisp -BOOT_TO_LISP = $(BOOTSYS) -- --translate $< +BOOT_TO_LISP = $(BOOTSYS) -- --translate --output=$@ $< # Command to translate Common Lisp to native object code COMPILE_LISP = $(DEPSYS) -- --compile --output=$@ $< @@ -1718,30 +1718,6 @@ setvart.clisp: setvart.boot @ echo '(progn (old-boot::boot "setvart.boot"))' | ${DEPSYS} @ -\subsection{template.boot} - -<>= -template.clisp: template.boot - @ echo 408 making $@ from $< - @ echo '(progn (old-boot::boot "template.boot"))' | ${DEPSYS} -@ - -\subsection{termrw.boot} - -<>= -termrw.clisp: termrw.boot - @ echo 411 making $@ from $< - @ echo '(progn (old-boot::boot "termrw.boot"))' | ${DEPSYS} -@ - -\subsection{trace.boot} - -<>= -trace.clisp: trace.boot - @ echo 414 making $@ from $< - @ echo '(progn (old-boot::boot "trace.boot"))' | ${DEPSYS} -@ - \subsection{as.boot} <>= @@ -1822,14 +1798,6 @@ htcheck.clisp: htcheck.boot @ echo '(progn (old-boot::boot "htcheck.boot"))' | ${DEPSYS} @ -\subsection{xruncomp.boot} - -<>= -xruncomp.clisp: xruncomp.boot - @ echo 459 making $@ from $< - @ echo '(progn (old-boot::boot "xruncomp.boot"))' | ${DEPSYS} -@ - \subsection{ax.boot} <>= @@ -1894,14 +1862,6 @@ br-saturn.clisp: br-saturn.boot @ echo '(progn (old-boot::boot "br-saturn.boot"))' | ${DEPSYS} @ -\subsection{topics.boot} - -<>= -topics.clisp: topics.boot - @ echo 495 making $@ from $< - @ echo '(progn (old-boot::boot "topics.boot"))' | ${DEPSYS} -@ - \subsection{br-prof.boot} <>= @@ -2173,19 +2133,8 @@ $(AUTO)/%.$(FASLEXT): %.$(FASLEXT) <> -<> - -<> - -<> - -<> - <> -<> - - buildom.$(FASLEXT): buildom.boot sys-macros.$(FASLEXT) $(BOOTSYS) -- --compile --output=$@ --load-directory=. $< @@ -2193,71 +2142,5 @@ buildom.$(FASLEXT): buildom.boot sys-macros.$(FASLEXT) <> @ -pp -\eject -\begin{thebibliography}{99} -\bibitem{1} \File{Makefile.pamphlet} -\bibitem{2} \File{src/boot/Makefile.pamphlet} -\bibitem{4} \File{src/interp/setq.lisp.pamphlet} -\bibitem{5} \File{src/interp/patches.lisp.pamphlet} -\bibitem{6} {\bf www.aldor.org} -\bibitem{7} \File{src/interp/apply.boot.pamphlet} -\bibitem{8} \File{src/interp/bits.lisp.pamphlet} -\bibitem{9} \File{src/interp/bootlex.lisp.pamphlet} -\bibitem{10} \File{src/interp/cfuns.lisp.pamphlet} -\bibitem{11} \File{src/interp/comp.lisp.pamphlet} -\bibitem{12} \File{src/interp/construc.lisp.pamphlet} -\bibitem{13} \File{src/interp/daase.lisp.pamphlet} -\bibitem{14} \File{src/interp/debug.lisp.pamphlet} -\bibitem{15} \File{src/interp/def.lisp.pamphlet} -\bibitem{16} \File{src/interp/fortcall.boot.pamphlet} -\bibitem{17} \File{src/interp/fname.lisp.pamphlet} -\bibitem{18} \File{src/interp/fnewmeta.lisp.pamphlet} -\bibitem{19} \File{src/interp/ggreater.lisp.pamphlet} -\bibitem{20} \File{src/interp/hash.lisp.pamphlet} -\bibitem{21} \File{src/interp/macros.lisp.pamphlet} -\bibitem{22} \File{src/interp/metalex.lisp.pamphlet} -\bibitem{24} \File{src/interp/monitor.lisp.pamphlet} -\bibitem{25} \File{src/interp/newaux.lisp.pamphlet} -\bibitem{26} \File{src/interp/nlib.lisp.pamphlet} -\bibitem{27} \File{src/interp/nocompil.lisp.pamphlet} -\bibitem{28} \File{src/interp/nspadaux.lisp.pamphlet} -\bibitem{29} \File{src/interp/parsing.lisp.pamphlet} -\bibitem{30} \File{src/interp/postprop.lisp.pamphlet} -\bibitem{31} \File{src/interp/preparse.lisp.pamphlet} -\bibitem{32} \File{src/interp/property.lisp.pamphlet} -\bibitem{33} \File{src/interp/sockio.lisp.pamphlet} -\bibitem{34} \File{src/interp/spad.lisp.pamphlet} -\bibitem{35} \File{src/interp/spaderror.lisp.pamphlet} -\bibitem{37} \File{src/interp/union.lisp.pamphlet} -\bibitem{38} \File{src/interp/util.lisp.pamphlet} -\bibitem{39} \File{src/interp/vmlisp.lisp.pamphlet} -\bibitem{40} \File{src/interp/alql.boot.pamphlet} -\bibitem{41} \File{src/interp/buildom.boot.pamphlet} -\bibitem{42} \File{src/interp/c-util.boot.pamphlet} -\bibitem{43} \File{src/interp/nag-c02.boot.pamphlet} -\bibitem{44} \File{src/interp/nag-c05.boot.pamphlet} -\bibitem{45} \File{src/interp/nag-c06.boot.pamphlet} -\bibitem{46} \File{src/interp/nag-d01.boot.pamphlet} -\bibitem{47} \File{src/interp/nag-d02.boot.pamphlet} -\bibitem{48} \File{src/interp/nag-d03.boot.pamphlet} -\bibitem{49} \File{src/interp/nag-e01.boot.pamphlet} -\bibitem{51} \File{src/interp/nag-e02.boot.pamphlet} -\bibitem{52} \File{src/interp/nag-e04.boot.pamphlet} -\bibitem{53} \File{src/interp/nag-f01.boot.pamphlet} -\bibitem{54} \File{src/interp/nag-f02.boot.pamphlet} -\bibitem{55} \File{src/interp/nag-f04.boot.pamphlet} -\bibitem{56} \File{src/interp/nag-f07.boot.pamphlet} -\bibitem{57} \File{src/interp/nag-s.boot.pamphlet} -\bibitem{58} \File{src/interp/category.boot.pamphlet} -\bibitem{59} \File{src/interp/cattable.boot.pamphlet} -\bibitem{60} \File{src/interp/c-doc.boot.pamphlet} -\bibitem{61} \File{src/interp/clam.boot.pamphlet} -\bibitem{62} \File{src/interp/clammed.boot.pamphlet} -\bibitem{63} \File{src/interp/compat.boot.pamphlet} -\bibitem{64} \File{src/interp/compiler.boot.pamphlet} -\bibitem{65} \File{src/interp/profile.boot.pamphlet} -\bibitem{66} \File{src/interp/compress.boot.pamphlet} -\bibitem{67} \File{src/interp/database.boot.pamphlet} -\end{thebibliography} + \end{document} diff --git a/src/interp/interop.boot.pamphlet b/src/interp/interop.boot.pamphlet index 4d346313..88d4e560 100644 --- a/src/interp/interop.boot.pamphlet +++ b/src/interp/interop.boot.pamphlet @@ -619,7 +619,7 @@ hashNewLookupInTable(op,sig,dollar,[domain,opvec],flag) == start := QSPLUS(start,QSPLUS(numTableArgs,4)) (success ^= 'failed) and success => if $monitorNewWorld then - sayLooking1('"<----",uu) where uu == + sayLooking1('"<----",uu) where uu() == PAIRP success => [first success,:devaluate rest success] success success diff --git a/src/interp/mark.boot.pamphlet b/src/interp/mark.boot.pamphlet index 83f63d2a..a72c838d 100644 --- a/src/interp/mark.boot.pamphlet +++ b/src/interp/mark.boot.pamphlet @@ -281,7 +281,7 @@ markRepeat(form, T) == markTran(form,form',[dc,:sig],env) == --from compElt/compFormWithModemap dc ^= 'Rep or ^MEMQ('_$,sig) => mkWi('markTran,'WI,form,['call,:form']) - argl := [u for t in rest sig for arg in rest form'] where u == + argl := [u for t in rest sig for arg in rest form'] where u() == t='_$ => argSource := getSourceWI arg IDENTP argSource and getmode(argSource,env) = 'Rep => arg @@ -1294,7 +1294,7 @@ moveImportsAfterDefinitions lines == -- pp defineAlist -- pp importAlist for [name, :i] in defineAlist repeat - or/[fn for [imp, :j] in importAlist] where fn == + or/[fn for [imp, :j] in importAlist] where fn() == substring?(name,imp,0) => moveAlist := [[i,:j], :moveAlist] nil @@ -1465,7 +1465,7 @@ rplacaSubst(x, y, u) == (fn(x, y, u); u) where fn(x,y,u) == u := q buildNewDefinition(op,theSig,formPredAlist) == - newAlist := [fn for item in formPredAlist] where fn == + newAlist := [fn for item in formPredAlist] where fn() == [form,:predl] := item pred := null predl => 'T diff --git a/src/interp/parse.boot.pamphlet b/src/interp/parse.boot.pamphlet index 0af415c6..b4c72963 100644 --- a/src/interp/parse.boot.pamphlet +++ b/src/interp/parse.boot.pamphlet @@ -241,7 +241,7 @@ parseTypeEvaluate form == form parseTypeEvaluateArgs(argl,argml) == - [argVal for arg in argl for md in argml for i in 1..] where argVal == + [argVal for arg in argl for md in argml for i in 1..] where argVal() == isCategoryForm(md,$CategoryFrame) => parseTypeEvaluate arg arg diff --git a/src/interp/postpar.boot.pamphlet b/src/interp/postpar.boot.pamphlet index f5f13b56..4e4d01e7 100644 --- a/src/interp/postpar.boot.pamphlet +++ b/src/interp/postpar.boot.pamphlet @@ -533,7 +533,7 @@ aplTranList x == hasAplExtension argl == or/[x is ["_!",:.] for x in argl] => - u:= [futureArg for x in argl] where futureArg == + u:= [futureArg for x in argl] where futureArg() == x is ["_!",y] => z:= deepestExpression y arglAssoc := [[g := GENVAR(),:aplTran1 z],:arglAssoc] diff --git a/src/interp/showimp.boot.pamphlet b/src/interp/showimp.boot.pamphlet index ae682ad3..49b72338 100644 --- a/src/interp/showimp.boot.pamphlet +++ b/src/interp/showimp.boot.pamphlet @@ -141,7 +141,7 @@ getDomainSigs(D,:option) == getDomainSigs1(D,first option) getDomainSigs1(D,ops) == listSort(function GLESSEQP,u) where - u == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] + u() == [x for x in getDomainOpTable(D,nil) | null ops or MEMQ(CAR x,ops)] getDomainDocs(D,:option) == domname := D.0 @@ -182,7 +182,7 @@ getCategoriesOfDomain domain == predkeyVec := domain.4.0 catforms := CADR domain.4 [fn for i in 0..MAXINDEX predkeyVec | test] where - test == predkeyVec.i and + test() == predkeyVec.i and (x := catforms . i) isnt ['DomainSubstitutionMacro,:.] fn == VECP x => devaluate x @@ -194,7 +194,7 @@ getInheritanceByDoc(D,op,sig,:options) == catList := KAR options or getExtensionsOfDomain D getDocDomainForOpSig(op,sig,devaluate D,D) or or/[fn for x in catList] or '(NIL NIL) - where fn == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) + where fn() == getDocDomainForOpSig(op,sig,substDomainArgs(D,x),D) getDocDomainForOpSig(op,sig,dollar,D) == (u := LASSOC(op,GETDATABASE(CAR dollar,'DOCUMENTATION))) diff --git a/src/interp/template.boot b/src/interp/template.boot new file mode 100644 index 00000000..06b03d7a --- /dev/null +++ b/src/interp/template.boot @@ -0,0 +1,338 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +)package "BOOT" + +getOperationAlistFromLisplib x == + -- used to be in clammed.boot. Moved on 1/24/94 +--+ +-- newType? x => GETDATABASE(x, 'OPERATIONALIST) + NRTgetOperationAlistFromLisplib x + +NRTgetOperationAlistFromLisplib x == + u := GETDATABASE(x, 'OPERATIONALIST) +-- u := removeZeroOneDestructively u + null u => u -- this can happen for Object + CAAR u = '_$unique => rest u + f:= addConsDB '(NIL T ELT) + for [op,:sigList] in u repeat + for items in tails sigList repeat + [sig,:r] := first items + if r is [.,:s] then + if s is [.,:t] then + if t is [.] then nil + else RPLACD(s,QCDDR f) + else RPLACD(r,QCDR f) + else RPLACD(first items,f) + RPLACA(items,addConsDB CAR items) + u and markUnique u + +markUnique x == + u := first x + RPLACA(x,'(_$unique)) + RPLACD(x,[u,:rest x]) + rest x + +--======================================================================= +-- Instantiation/Run-Time Operations +--======================================================================= + +stuffSlots(dollar,template) == + _$: fluid := dollar + dollarTail := [dollar] + for i in 5..MAXINDEX template | item := template.i repeat + dollar.i := + atom item => [SYMBOL_-FUNCTION item,:dollar] + item is ['QUOTE,x] => + x is [.,.,:n] and FIXP n => ['goGet,item,:dollarTail] + ['SETELT,dollar,i,['evalSlotDomain,item,dollar]] + item is ['CONS,:.] => + item is [.,'IDENTITY,['FUNCALL,a,b]] => + b = '$ => ['makeSpadConstant,eval a,dollar,i] + sayBrightlyNT '"Unexpected constant environment!!" + pp devaluate b + nil + sayBrightlyNT '"Unexpected constant format!!" + pp devaluate item + nil + sayBrightlyNT '"Unidentified stuff:" + pp item + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +--------------------> NEW DEFINITION (override in xrun.boot.pamphlet) +evalSlotDomain(u,dollar) == + $returnNowhereFromGoGet: local := false + $ : fluid := dollar + $lookupDefaults : local := nil -- new world + u = '$ => dollar + FIXP u => + VECP (y := dollar.u) => y + y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? + y is [v,:.] => + VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt] + GETDATABASE(v,'CONSTRUCTOR?) => + lazyDomainSet(y,dollar,u) --new style has lazyt + y + y + u is ['NRTEVAL,y] => eval y + u is ['QUOTE,y] => y + u is ['Record,:argl] => + FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] + for [.,tag,dom] in argl]) + u is ['Union,:argl] and first argl is ['_:,.,.] => + APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] + for [.,tag,dom] in argl]) + u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) + systemErrorHere '"evalSlotDomain" + + +--======================================================================= +-- Loadtime Operations +--======================================================================= +setLoadTime alist == + for [nam,:val] in alist repeat SET(nam,eval val) + +setLoadTimeQ alist == + for [nam,:val] in alist repeat SET(nam,val) + +makeTemplate vec == +--called at instantiation time by setLoadTime +--the form ['makeTemplate,MKQ $template] is recorded by compDefineFunctor1 +-- $template is set below in NRTdescendCodeTran and NRTaddDeltaOpt + newVec := GETREFV SIZE vec + for index in 0..MAXINDEX vec repeat + item := vec.index + null item => nil + item is ['local,:.] => nil --this information used to for display of domains + newVec.index := + atom item => item + null atom first item => + [sig,dcIndex,op,:flag] := item + code := 4*index + if dcIndex > 0 then + code := code + 2 --means "bind" + else dcIndex := -dcIndex + if flag = 'CONST then code := code + 1 --means "constant" + sourceIndex := 8192*dcIndex + code + uniqueSig:= addConsDB sig + MKQ [op,uniqueSig,:sourceIndex] + item is ['CONS,:.] => item --constant case + MKQ item + newVec + +makeOpDirect u == + [nam,[addForm,:opList]] := u + opList = 'derived => 'derived + [[op,:[fn y for y in items]] for [op,:items] in opList] where fn y == + [sig,:r] := y + uniqueSig := addConsDB sig + predCode := 0 + isConstant := false + r is [subSig,pred,'Subsumed] => [uniqueSig,'subsumed,addConsDB subSig] + if r is [n,:s] then + slot := + n is [p,:.] => p --the CDR is linenumber of function definition + n + if s is [pred,:t] then + predCode := (pred = 'T => 0; mkUniquePred pred) + if t is [='CONST,:.] then isConstant := true + index:= 8192*predCode + if NUMBERP slot and slot ^= 0 then index := index + 2*slot + if isConstant then index := index + 1 + [uniqueSig,:index] + +--======================================================================= +-- Creation of System Sig/Pred Vectors & Hash Tables +--======================================================================= + +mkUniquePred pred == putPredHash addConsDB pred + +putPredHash pred == --pred MUST have had addConsDB applied to it + if pred is [op,:u] and MEMQ(op,'(AND OR NOT)) then + for x in u repeat putPredHash x + k := HGET($predHash,pred) => k + HPUT($predHash,pred,$predVectorFrontier) + if $predVectorFrontier > MAXINDEX $predVector + then $predVector := extendVectorSize $predVector + $predVector.$predVectorFrontier := pred + $predVectorFrontier := $predVectorFrontier + 1 + $predVectorFrontier - 1 + +extendVectorSize v == + n:= MAXINDEX v + m:= (7*n)/5 -- make 40% longer + newVec := GETREFV m + for i in 0..n repeat newVec.i := v.i + newVec + +mkSigPredVectors() == + $predHash:= MAKE_-HASHTABLE 'UEQUAL + $consDB:= MAKE_-HASHTABLE 'UEQUAL + $predVectorFrontier:= 1 --slot 0 in vector will be vacant + $predVector:= GETREFV 100 + for nam in allConstructors() | + null (GETDATABASE(nam, 'CONSTRUCTORKIND) = 'package) repeat + for [op,:sigList] in GETDATABASE(nam,'OPERATIONALIST) repeat + for [sig,:r] in sigList repeat + addConsDB sig + r is [.,pred,:.] => putPredHash addConsDB pred + 'done + +list2LongerVec(u,n) == + vec := GETREFV ((7*n)/5) -- make 40% longer + for i in 0.. for x in u repeat vec.i := x + vec + +squeezeConsDB u == + fn u where fn u == + VECP u => for i in 0..MAXINDEX u repeat fn u.i + PAIRP u => + EQ(x := QCAR u,'QUOTE) => RPLAC(CADR u,addConsDB CADR u) + squeezeConsDB x + squeezeConsDB QCDR u + nil + u + +mapConsDB x == [addConsDB y for y in x] +addConsDB x == + min x where + min x == + y:=HGET($consDB,x) + y => y + PAIRP x => + for z in tails x repeat + u:=min CAR z + if not EQ(u,CAR z) then RPLACA(z,u) + HashCheck x + REFVECP x => + for i in 0..MAXINDEX x repeat + x.i:=min (x.i) + HashCheck x + STRINGP x => HashCheck x + x + HashCheck x == + y:=HGET($consDB,x) + y => y + HPUT($consDB,x,x) + x + x + +--======================================================================= +-- Functions Creating Lisplib Information +--======================================================================= +NRTdescendCodeTran(u,condList) == +--NRTbuildFunctor calls to fill $template slots with names of compiled functions + null u => nil + u is ['LIST] => nil + u is [op,.,i,a] and MEMQ(op,'(SETELT QSETREFV)) => + null condList and a is ['CONS,fn,:.] => + RPLACA(u,'LIST) + RPLACD(u,nil) + $template.i := + fn = 'IDENTITY => a + fn is ['dispatchFunction,fn'] => fn' + fn + nil --code for this will be generated by the instantiator + u is ['COND,:c] => + for [pred,:y] in c|y repeat NRTdescendCodeTran(first y,[pred,:condList]) + u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList) + nil + +--======================================================================= +-- Miscellaneous Functions +--======================================================================= +NRTaddInner x == +--called by genDeltaEntry and others that affect $NRTdeltaList + PROGN + atom x => nil + x is ['Record,:l] => + for [.,.,y] in l repeat NRTinnerGetLocalIndex y + first x in '(Union Mapping) => + for y in rest x repeat + y is [":",.,z] => NRTinnerGetLocalIndex z + NRTinnerGetLocalIndex y + x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y + getConstructorSignature x is [.,:ml] => + for y in rest x for m in ml | not (y = '$) repeat + isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y + keyedSystemError("S2NR0003",[x]) + x + +-- NRTaddInner should call following function instead of NRTgetLocalIndex +-- This would prevent putting spurious items in $NRTdeltaList +NRTinnerGetLocalIndex x == + atom x => x + -- following test should skip Unions, Records, Mapping + MEMQ(opOf x,'(Union Record Mapping)) => NRTgetLocalIndex x + constructor?(x) => NRTgetLocalIndex x + NRTaddInner x + +assignSlotToPred cond == +--called by ProcessCond + cond is ['AND,:u] => ['AND,:[assignSlotToPred x for x in u]] + cond is ['OR,:u] => ['OR,:[assignSlotToPred x for x in u]] + cond is ['NOT,u] => ['NOT,assignSlotToPred u] + thisNeedsTOBeFilledIn() + + +measure() == + pp MEASURE (f := SparseUnivariatePolynomial_;) + pp MEASURE (o := SparseUnivariatePolynomial_;opDirect) + pp MEASURE (t := SparseUnivariatePolynomial_;template) + pp measureCommon [o,t] + MEASURE [f,o,t] + +measureCommon u == +--measures bytes which ARE on $consDB + $table: local := MAKE_-HASHTABLE 'UEQUAL + fn(u,0) where fn(u,n) == n + + VECP u => +/[fn(u.i,0) for i in 0..MAXINDEX u] + HASH-TABLE-P u => + +/[fn(key,0) + fn(HGET(u,key),0) for key in HKEYS u] + PAIRP u => + HGET($table,u) => 0 + m := fn(first u,0) + fn(rest u,0) + HGET($consDB,u) => 8 + m + HPUT($table,u,'T) + m + 0 + +makeSpadConstant [fn,dollar,slot] == + val := FUNCALL(fn,dollar) + u:= dollar.slot + RPLACA(u,function IDENTITY) + RPLACD(u,val) + val + + + + + diff --git a/src/interp/template.boot.pamphlet b/src/interp/template.boot.pamphlet deleted file mode 100644 index f37828c7..00000000 --- a/src/interp/template.boot.pamphlet +++ /dev/null @@ -1,359 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp template.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -getOperationAlistFromLisplib x == - -- used to be in clammed.boot. Moved on 1/24/94 ---+ --- newType? x => GETDATABASE(x, 'OPERATIONALIST) - NRTgetOperationAlistFromLisplib x - -NRTgetOperationAlistFromLisplib x == - u := GETDATABASE(x, 'OPERATIONALIST) --- u := removeZeroOneDestructively u - null u => u -- this can happen for Object - CAAR u = '_$unique => rest u - f:= addConsDB '(NIL T ELT) - for [op,:sigList] in u repeat - for items in tails sigList repeat - [sig,:r] := first items - if r is [.,:s] then - if s is [.,:t] then - if t is [.] then nil - else RPLACD(s,QCDDR f) - else RPLACD(r,QCDR f) - else RPLACD(first items,f) - RPLACA(items,addConsDB CAR items) - u and markUnique u - -markUnique x == - u := first x - RPLACA(x,'(_$unique)) - RPLACD(x,[u,:rest x]) - rest x - ---======================================================================= --- Instantiation/Run-Time Operations ---======================================================================= - -stuffSlots(dollar,template) == - _$: fluid := dollar - dollarTail := [dollar] - for i in 5..MAXINDEX template | item := template.i repeat - dollar.i := - atom item => [SYMBOL_-FUNCTION item,:dollar] - item is ['QUOTE,x] => - x is [.,.,:n] and FIXP n => ['goGet,item,:dollarTail] - ['SETELT,dollar,i,['evalSlotDomain,item,dollar]] - item is ['CONS,:.] => - item is [.,'IDENTITY,['FUNCALL,a,b]] => - b = '$ => ['makeSpadConstant,eval a,dollar,i] - sayBrightlyNT '"Unexpected constant environment!!" - pp devaluate b - nil - sayBrightlyNT '"Unexpected constant format!!" - pp devaluate item - nil - sayBrightlyNT '"Unidentified stuff:" - pp item - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) ---------------------> NEW DEFINITION (override in xrun.boot.pamphlet) -evalSlotDomain(u,dollar) == - $returnNowhereFromGoGet: local := false - $ : fluid := dollar - $lookupDefaults : local := nil -- new world - u = '$ => dollar - FIXP u => - VECP (y := dollar.u) => y - y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? - y is [v,:.] => - VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt] - GETDATABASE(v,'CONSTRUCTOR?) => - lazyDomainSet(y,dollar,u) --new style has lazyt - y - y - u is ['NRTEVAL,y] => eval y - u is ['QUOTE,y] => y - u is ['Record,:argl] => - FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) - u is ['Union,:argl] and first argl is ['_:,.,.] => - APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) - u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) - systemErrorHere '"evalSlotDomain" - - ---======================================================================= --- Loadtime Operations ---======================================================================= -setLoadTime alist == - for [nam,:val] in alist repeat SET(nam,eval val) - -setLoadTimeQ alist == - for [nam,:val] in alist repeat SET(nam,val) - -makeTemplate vec == ---called at instantiation time by setLoadTime ---the form ['makeTemplate,MKQ $template] is recorded by compDefineFunctor1 --- $template is set below in NRTdescendCodeTran and NRTaddDeltaOpt - newVec := GETREFV SIZE vec - for index in 0..MAXINDEX vec repeat - item := vec.index - null item => nil - item is ['local,:.] => nil --this information used to for display of domains - newVec.index := - atom item => item - null atom first item => - [sig,dcIndex,op,:flag] := item - code := 4*index - if dcIndex > 0 then - code := code + 2 --means "bind" - else dcIndex := -dcIndex - if flag = 'CONST then code := code + 1 --means "constant" - sourceIndex := 8192*dcIndex + code - uniqueSig:= addConsDB sig - MKQ [op,uniqueSig,:sourceIndex] - item is ['CONS,:.] => item --constant case - MKQ item - newVec - -makeOpDirect u == - [nam,[addForm,:opList]] := u - opList = 'derived => 'derived - [[op,:[fn y for y in items]] for [op,:items] in opList] where fn y == - [sig,:r] := y - uniqueSig := addConsDB sig - predCode := 0 - isConstant := false - r is [subSig,pred,'Subsumed] => [uniqueSig,'subsumed,addConsDB subSig] - if r is [n,:s] then - slot := - n is [p,:.] => p --the CDR is linenumber of function definition - n - if s is [pred,:t] then - predCode := (pred = 'T => 0; mkUniquePred pred) - if t is [='CONST,:.] then isConstant := true - index:= 8192*predCode - if NUMBERP slot and slot ^= 0 then index := index + 2*slot - if isConstant then index := index + 1 - [uniqueSig,:index] - ---======================================================================= --- Creation of System Sig/Pred Vectors & Hash Tables ---======================================================================= - -mkUniquePred pred == putPredHash addConsDB pred - -putPredHash pred == --pred MUST have had addConsDB applied to it - if pred is [op,:u] and MEMQ(op,'(AND OR NOT)) then - for x in u repeat putPredHash x - k := HGET($predHash,pred) => k - HPUT($predHash,pred,$predVectorFrontier) - if $predVectorFrontier > MAXINDEX $predVector - then $predVector := extendVectorSize $predVector - $predVector.$predVectorFrontier := pred - $predVectorFrontier := $predVectorFrontier + 1 - $predVectorFrontier - 1 - -extendVectorSize v == - n:= MAXINDEX v - m:= (7*n)/5 -- make 40% longer - newVec := GETREFV m - for i in 0..n repeat newVec.i := v.i - newVec - -mkSigPredVectors() == - $predHash:= MAKE_-HASHTABLE 'UEQUAL - $consDB:= MAKE_-HASHTABLE 'UEQUAL - $predVectorFrontier:= 1 --slot 0 in vector will be vacant - $predVector:= GETREFV 100 - for nam in allConstructors() | - null (GETDATABASE(nam, 'CONSTRUCTORKIND) = 'package) repeat - for [op,:sigList] in GETDATABASE(nam,'OPERATIONALIST) repeat - for [sig,:r] in sigList repeat - addConsDB sig - r is [.,pred,:.] => putPredHash addConsDB pred - 'done - -list2LongerVec(u,n) == - vec := GETREFV ((7*n)/5) -- make 40% longer - for i in 0.. for x in u repeat vec.i := x - vec - -squeezeConsDB u == - fn u where fn u == - VECP u => for i in 0..MAXINDEX u repeat fn u.i - PAIRP u => - EQ(x := QCAR u,'QUOTE) => RPLAC(CADR u,addConsDB CADR u) - squeezeConsDB x - squeezeConsDB QCDR u - nil - u - -mapConsDB x == [addConsDB y for y in x] -addConsDB x == - min x where - min x == - y:=HGET($consDB,x) - y => y - PAIRP x => - for z in tails x repeat - u:=min CAR z - if not EQ(u,CAR z) then RPLACA(z,u) - HashCheck x - REFVECP x => - for i in 0..MAXINDEX x repeat - x.i:=min (x.i) - HashCheck x - STRINGP x => HashCheck x - x - HashCheck x == - y:=HGET($consDB,x) - y => y - HPUT($consDB,x,x) - x - x - ---======================================================================= --- Functions Creating Lisplib Information ---======================================================================= -NRTdescendCodeTran(u,condList) == ---NRTbuildFunctor calls to fill $template slots with names of compiled functions - null u => nil - u is ['LIST] => nil - u is [op,.,i,a] and MEMQ(op,'(SETELT QSETREFV)) => - null condList and a is ['CONS,fn,:.] => - RPLACA(u,'LIST) - RPLACD(u,nil) - $template.i := - fn = 'IDENTITY => a - fn is ['dispatchFunction,fn'] => fn' - fn - nil --code for this will be generated by the instantiator - u is ['COND,:c] => - for [pred,:y] in c|y repeat NRTdescendCodeTran(first y,[pred,:condList]) - u is ['PROGN,:c] => for x in c repeat NRTdescendCodeTran(x,condList) - nil - ---======================================================================= --- Miscellaneous Functions ---======================================================================= -NRTaddInner x == ---called by genDeltaEntry and others that affect $NRTdeltaList - PROGN - atom x => nil - x is ['Record,:l] => - for [.,.,y] in l repeat NRTinnerGetLocalIndex y - first x in '(Union Mapping) => - for y in rest x repeat - y is [":",.,z] => NRTinnerGetLocalIndex z - NRTinnerGetLocalIndex y - x is ['SubDomain,y,:.] => NRTinnerGetLocalIndex y - getConstructorSignature x is [.,:ml] => - for y in rest x for m in ml | not (y = '$) repeat - isCategoryForm(m,$CategoryFrame) => NRTinnerGetLocalIndex y - keyedSystemError("S2NR0003",[x]) - x - --- NRTaddInner should call following function instead of NRTgetLocalIndex --- This would prevent putting spurious items in $NRTdeltaList -NRTinnerGetLocalIndex x == - atom x => x - -- following test should skip Unions, Records, Mapping - MEMQ(opOf x,'(Union Record Mapping)) => NRTgetLocalIndex x - constructor?(x) => NRTgetLocalIndex x - NRTaddInner x - -assignSlotToPred cond == ---called by ProcessCond - cond is ['AND,:u] => ['AND,:[assignSlotToPred x for x in u]] - cond is ['OR,:u] => ['OR,:[assignSlotToPred x for x in u]] - cond is ['NOT,u] => ['NOT,assignSlotToPred u] - thisNeedsTOBeFilledIn() - - -measure() == - pp MEASURE (f := SparseUnivariatePolynomial_;) - pp MEASURE (o := SparseUnivariatePolynomial_;opDirect) - pp MEASURE (t := SparseUnivariatePolynomial_;template) - pp measureCommon [o,t] - MEASURE [f,o,t] - -measureCommon u == ---measures bytes which ARE on $consDB - $table: local := MAKE_-HASHTABLE 'UEQUAL - fn(u,0) where fn(u,n) == n + - VECP u => +/[fn(u.i,0) for i in 0..MAXINDEX u] - HASH-TABLE-P u => - +/[fn(key,0) + fn(HGET(u,key),0) for key in HKEYS u] - PAIRP u => - HGET($table,u) => 0 - m := fn(first u,0) + fn(rest u,0) - HGET($consDB,u) => 8 + m - HPUT($table,u,'T) - m - 0 - -makeSpadConstant [fn,dollar,slot] == - val := FUNCALL(fn,dollar) - u:= dollar.slot - RPLACA(u,function IDENTITY) - RPLACD(u,val) - val - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/termrw.boot b/src/interp/termrw.boot new file mode 100644 index 00000000..6829defc --- /dev/null +++ b/src/interp/termrw.boot @@ -0,0 +1,154 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +)package "BOOT" + +termRW(t,R) == + -- reduce t by rewrite system R + until b repeat + t0:= termRW1(t,R) + b:= EQ(t,t0) + t:= t0 + t + +termRW1(t,R) == + -- tries to do one reduction on the leftmost outermost subterm of t + t0:= term1RW(t,R) + not EQ(t0,t) or atom t => t0 + [t1,:t2]:= t + tt1:= termRW1(t1,R) + tt2:= t2 and termRW1(t2,R) + EQ(t1,tt1) and EQ(t2,tt2) => t + CONS(tt1,tt2) + +term1RW(t,R) == + -- tries to reduce t at the top node + [vars,:varRules]:= R + for r in varRules until not (SL='failed) repeat + SL:= termMatch(CAR r,t,NIL,vars) + not (SL='failed) => + t:= subCopy(copy CDR r,SL) + t + +term1RWall(t,R) == + -- same as term1RW, but returns a list + [vars,:varRules]:= R + [not (SL='failed) and subCopy(copy CDR r,SL) for r in varRules | + not EQ(SL:= termMatch(CAR r,t,NIL,vars),'failed)] + +termMatch(tp,t,SL,vars) == + -- t is a term pattern, t a term + -- then the result is the augmented substitution SL or 'failed + tp=t => SL + atom tp => + MEMQ(tp,vars) => + p:= ASSOC(tp,SL) => ( CDR p=t ) + CONS(CONS(tp,t),SL) + 'failed + atom t => 'failed + [tp1,:tp2]:= tp + [t1,:t2]:= t + SL:= termMatch(tp1,t1,SL,vars) + SL='failed => 'failed + tp2 and t2 => termMatch(tp2,t2,SL,vars) + tp2 or t2 => 'failed + SL + + +--% substitution handling + +-- isContained(v,t) == +-- -- tests (by EQ), whether v occurs in term t +-- -- v must not be NIL +-- EQ(v,t) => 'T +-- atom t => NIL +-- isContained(v,CAR t) or isContained(v,CDR t) + +augmentSub(v,t,SL) == + -- destructively adds the pair (v,t) to the substitution list SL + -- t doesn't contain any of the variables of SL + q:= CONS(v,t) + null SL => [q] +-- for p in SL repeat RPLACD(p,SUBSTQ(t,v,CDR p)) + CONS(q,SL) + +mergeSubs(S1,S2) == + -- augments S2 by each pair of S1 + -- S1 doesn't contain any of the variables of S2 + null S1 => S2 + null S2 => S1 + S3 := [p for p in S2 | not ASSQ(CAR p, S1)] +-- for p in S1 repeat S3:= augmentSub(CAR p,CDR p,S3) + APPEND(S1,S3) + +subCopy(t,SL) == + -- t is any LISP structure, SL a substitution list for sharp variables + -- then t is substituted and copied if necessary + SL=NIL => t + subCopy0(t,SL) + +subCopy0(t, SL) == + p := subCopyOrNil(t, SL) => CDR p + t + +subCopyOrNil(t,SL) == + -- the same as subCopy, but the result is NIL if nothing was copied + p:= ASSOC(t,SL) => p + atom t => NIL + [t1,:t2]:= t + t0:= subCopyOrNil(t1,SL) => + t2 => CONS(t, CONS(CDR t0, subCopy0(t2,SL))) + CONS(t,CONS(CDR t0,t2)) + t2 and ( t0:= subCopyOrNil(t2,SL) ) => CONS(t, CONS(t1,CDR t0)) + NIL + + +deepSubCopy(t,SL) == + -- t is any LISP structure, SL a substitution list for sharp variables + -- then t is substituted and copied if necessary + SL=NIL => t + deepSubCopy0(t,SL) + +deepSubCopy0(t, SL) == + p := deepSubCopyOrNil(t, SL) => CDR p + t + +deepSubCopyOrNil(t,SL) == + -- the same as subCopy, but the result is NIL if nothing was copied + p:= ASSOC(t,SL) => CONS(t, deepSubCopy0(CDR p, SL)) + atom t => NIL + [t1,:t2]:= t + t0:= deepSubCopyOrNil(t1,SL) => + t2 => CONS(t, CONS(CDR t0, deepSubCopy0(t2,SL))) + CONS(t,CONS(CDR t0,t2)) + t2 and ( t0:= deepSubCopyOrNil(t2,SL) ) => CONS(t, CONS(t1,CDR t0)) + + diff --git a/src/interp/termrw.boot.pamphlet b/src/interp/termrw.boot.pamphlet deleted file mode 100644 index bf52c465..00000000 --- a/src/interp/termrw.boot.pamphlet +++ /dev/null @@ -1,197 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp termrw.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\begin{verbatim} -Algorithms for Term Reduction - -The following assumptions are made: - -a term rewrite system is represented by a pair (varlist,varRules) where - varlist is the list of rewrite variables (test by MEMQ) and varRules - is an alist (no variables may occur in varRules) - -the following rewrite functions are available: - termRW looks for a fixpoint in applying varRules, where the outermost - leftmost is reduced first by term1RW - term1RW applies the first rule - -subCopy uses an alist (calls of ASSQ) to substitute a list structure - no left side of a pair of alist may appear on a righthand side - this means, subCopy is an idempotent function - -in both cases copying is only done if necessary to avoid destruction -this means, EQ can be used to check whether something was done - -\end{verbatim} -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -termRW(t,R) == - -- reduce t by rewrite system R - until b repeat - t0:= termRW1(t,R) - b:= EQ(t,t0) - t:= t0 - t - -termRW1(t,R) == - -- tries to do one reduction on the leftmost outermost subterm of t - t0:= term1RW(t,R) - not EQ(t0,t) or atom t => t0 - [t1,:t2]:= t - tt1:= termRW1(t1,R) - tt2:= t2 and termRW1(t2,R) - EQ(t1,tt1) and EQ(t2,tt2) => t - CONS(tt1,tt2) - -term1RW(t,R) == - -- tries to reduce t at the top node - [vars,:varRules]:= R - for r in varRules until not (SL='failed) repeat - SL:= termMatch(CAR r,t,NIL,vars) - not (SL='failed) => - t:= subCopy(copy CDR r,SL) - t - -term1RWall(t,R) == - -- same as term1RW, but returns a list - [vars,:varRules]:= R - [not (SL='failed) and subCopy(copy CDR r,SL) for r in varRules | - not EQ(SL:= termMatch(CAR r,t,NIL,vars),'failed)] - -termMatch(tp,t,SL,vars) == - -- t is a term pattern, t a term - -- then the result is the augmented substitution SL or 'failed - tp=t => SL - atom tp => - MEMQ(tp,vars) => - p:= ASSOC(tp,SL) => ( CDR p=t ) - CONS(CONS(tp,t),SL) - 'failed - atom t => 'failed - [tp1,:tp2]:= tp - [t1,:t2]:= t - SL:= termMatch(tp1,t1,SL,vars) - SL='failed => 'failed - tp2 and t2 => termMatch(tp2,t2,SL,vars) - tp2 or t2 => 'failed - SL - - ---% substitution handling - --- isContained(v,t) == --- -- tests (by EQ), whether v occurs in term t --- -- v must not be NIL --- EQ(v,t) => 'T --- atom t => NIL --- isContained(v,CAR t) or isContained(v,CDR t) - -augmentSub(v,t,SL) == - -- destructively adds the pair (v,t) to the substitution list SL - -- t doesn't contain any of the variables of SL - q:= CONS(v,t) - null SL => [q] --- for p in SL repeat RPLACD(p,SUBSTQ(t,v,CDR p)) - CONS(q,SL) - -mergeSubs(S1,S2) == - -- augments S2 by each pair of S1 - -- S1 doesn't contain any of the variables of S2 - null S1 => S2 - null S2 => S1 - S3 := [p for p in S2 | not ASSQ(CAR p, S1)] --- for p in S1 repeat S3:= augmentSub(CAR p,CDR p,S3) - APPEND(S1,S3) - -subCopy(t,SL) == - -- t is any LISP structure, SL a substitution list for sharp variables - -- then t is substituted and copied if necessary - SL=NIL => t - subCopy0(t,SL) - -subCopy0(t, SL) == - p := subCopyOrNil(t, SL) => CDR p - t - -subCopyOrNil(t,SL) == - -- the same as subCopy, but the result is NIL if nothing was copied - p:= ASSOC(t,SL) => p - atom t => NIL - [t1,:t2]:= t - t0:= subCopyOrNil(t1,SL) => - t2 => CONS(t, CONS(CDR t0, subCopy0(t2,SL))) - CONS(t,CONS(CDR t0,t2)) - t2 and ( t0:= subCopyOrNil(t2,SL) ) => CONS(t, CONS(t1,CDR t0)) - NIL - - -deepSubCopy(t,SL) == - -- t is any LISP structure, SL a substitution list for sharp variables - -- then t is substituted and copied if necessary - SL=NIL => t - deepSubCopy0(t,SL) - -deepSubCopy0(t, SL) == - p := deepSubCopyOrNil(t, SL) => CDR p - t - -deepSubCopyOrNil(t,SL) == - -- the same as subCopy, but the result is NIL if nothing was copied - p:= ASSOC(t,SL) => CONS(t, deepSubCopy0(CDR p, SL)) - atom t => NIL - [t1,:t2]:= t - t0:= deepSubCopyOrNil(t1,SL) => - t2 => CONS(t, CONS(CDR t0, deepSubCopy0(t2,SL))) - CONS(t,CONS(CDR t0,t2)) - t2 and ( t0:= deepSubCopyOrNil(t2,SL) ) => CONS(t, CONS(t1,CDR t0)) - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/topics.boot b/src/interp/topics.boot new file mode 100644 index 00000000..32a7d7bf --- /dev/null +++ b/src/interp/topics.boot @@ -0,0 +1,240 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +)package "BOOT" + +$topicsDefaults := '( + (basic elt setelt qelt qsetelt eval xRange yRange zRange map map_! qsetelt_!) + (conversion coerce convert retract) + (hidden retractIfCan Zero One) + (predicate _< _=) + (algebraic _+ _- _* _*_* _/ quo rem exquo) + (trignometric acos acot acsc asec asin atan cos cot csc sec sin tan) + (hyperbolic acosh acoth acsch asech asinh atanh cosh coth csch sech sinh tanh) + (destructive setelt qsetelt) + (extraction xRange yRange zRange elt qelt) + (transformation map map_!)) + +$topicSynonyms := '( + (b . basic) + (h . hidden) + (e . extended) + (a . algebraic) + (g . algebraic) + (c . construct) + (d . destructive) + (v . conversion) + (m . miscellaneous) + (x . extraction) + (p . predicate) + (tg . trignometric) + (hy . hyperbolic) + (t . transformation)) + +$groupAssoc := '((extended . 1) (basic . 2) (hidden . 4)) + +--======================================================================= +-- Create Hashtable of Operation Properties +--======================================================================= +--called at build-time before making DOCUMENTATION property +mkTopicHashTable() == --given $groupAssoc = ((extended . 1)(basic . 2)(xx . 4)..) + $defaultsHash := MAKE_-HASHTABLE 'ID --keys are ops, value is list of topic names + for [kind,:items] in $topicsDefaults repeat --$topicsDefaults is (( op ...) ..) + for item in items repeat + HPUT($defaultsHash,item,[kind,:HGET($defaultsHash,item)]) + $conTopicHash := MAKE_-HASHTABLE 'EQL --key is constructor name; value is + instream := OPEN '"topics.data" + while not EOFP instream repeat + line := READLINE instream + while blankLine? line repeat line := READLINE instream + m := MAXINDEX line --file "topics.data" has form: + m = -1 => 'skip --1 ConstructorName: + line.0 = char '_- => 'skip --2 constructorName or operation name + line := trimString line --3-n ... + m := MAXINDEX line -- (blank line) ... + line.m ^= (char '_:) => systemError('"wrong heading") + con := INTERN SUBSTRING(line,0,m) + alist := [lst while not EOFP instream and + not (blankLine? (line := READLINE instream)) and + line.0 ^= char '_- for i in 1.. + | lst := string2OpAlist line] + alist => HPUT($conTopicHash,con,alist) + --initialize table of topic classes + $topicHash := MAKE_-HASHTABLE 'ID --$topicHash has keys: topic and value: index + for [x,:c] in $groupAssoc repeat HPUT($topicHash,x,c) + $topicIndex := CDR LAST $groupAssoc + + --replace each property list by a topic code + --store under each construct an OR of all codes + for con in HKEYS $conTopicHash repeat + conCode := 0 + for pair in HGET($conTopicHash,con) repeat + RPLACD(pair,code := topicCode CDR pair) + conCode := LOGIOR(conCode,code) + HPUT($conTopicHash,con, + [['constructor,:conCode],:HGET($conTopicHash,con)]) + SHUT instream + +--reduce integers stored under names to 1 + its power of 2 + for key in HKEYS $topicHash repeat + HPUT($topicHash,key,INTEGER_-LENGTH HGET($topicHash,key)) + + $conTopicHash --keys are ops or 'constructor', values are codes + +blankLine? line == + MAXINDEX line = -1 or and/[line . j = (char '_ ) for j in 0..MAXINDEX line] + +string2OpAlist s == + m := #s + k := skipBlanks(s,0,m) or return nil + UPPER_-CASE_-P s.k => nil --skip constructor names + k := 0 + while (k := skipBlanks(s,k,m)) repeat + acc := [INTERN SUBSTRING(s,k,-k + (k := charPosition(char '_ ,s,k + 1))),:acc] + acc := NREVERSE acc + --now add defaults + if u := getDefaultProps first acc then acc := [first acc,:u,:rest acc] + acc + +getDefaultProps name == + u := HGET($defaultsHash,name) + if (s := PNAME name).(m := MAXINDEX s) = char '? then u := ['p,:u] + if s.m = char '_! then u := ['destructive,:u] + u + +skipBlanks(u,i,m) == + while i < m and u.i = $charBlank repeat i := i + 1 + i >= m => nil + i + +--======================================================================= +-- Compute Topic Code for Operation +--======================================================================= +topicCode lst == + u := [y for x in lst] where y() == + rename := LASSOC(x,$topicSynonyms) => rename + x + if null intersection('(basic extended hidden),u) then u := ['extended,:u] + bitIndexList := nil + for x in REMDUP u repeat + bitIndexList := [fn x,:bitIndexList] where fn x == + k := HGET($topicHash,x) => k + HPUT($topicHash,x,$topicIndex := $topicIndex * 2) + $topicIndex + code := +/[i for i in bitIndexList] + +--======================================================================= +-- Add Codes to Documentation Property +--======================================================================= +--called to modify DOCUMENTATION property for each "con" +addTopic2Documentation(con,docAlist) == + alist := HGET($conTopicHash,con) or return docAlist + [y for x in docAlist] where y() == + [op,:pairlist] := x + code := LASSOC(op,alist) or 0 + for sigDoc in pairlist repeat + sigDoc is [.,.] => RPLACD(rest sigDoc,code) + systemError sigDoc + docAlist + +--======================================================================= +-- Test: Display Topics for a given constructor +--======================================================================= +td con == + $topicClasses := ASSOCRIGHT mySort + [[HGET($topicHash,key),:key] for key in HKEYS $topicHash] + hash := MAKE_-HASHTABLE 'ID + tdAdd(con,hash) + tdPrint hash + +tdAdd(con,hash) == + v := HGET($conTopicHash,con) + u := addTopic2Documentation(con,v) +--u := GETDATABASE(con,'DOCUMENTATION) + for pair in u | FIXP (code := myLastAtom pair) and (op := CAR pair) ^= 'construct repeat + for x in (names := code2Classes code) repeat HPUT(hash,x,insert(op,HGET(hash,x))) + +tdPrint hash == + for key in mySort HKEYS hash repeat + sayBrightly [key,'":"] + sayBrightlyNT '" " + for x in HGET(hash,key) repeat sayBrightlyNT ['" ",x] + TERPRI() + +topics con == + --assumes that DOCUMENTATION property already has #s added + $topicClasses := ASSOCRIGHT mySort + [[HGET($topicHash,key),:key] for key in HKEYS $topicHash] + hash := MAKE_-HASHTABLE 'ID + tdAdd(con,hash) + for x in REMDUP [CAAR y for y in ancestorsOf(getConstructorForm con,nil)] repeat + tdAdd(x,hash) + for x in HKEYS hash repeat HPUT(hash,x,mySort HGET(hash,x)) + tdPrint hash + +code2Classes cc == + cc := 2*cc + [x while cc ^= 0 for x in $topicClasses | ODDP (cc := QUOTIENT(cc,2))] + +myLastAtom x == + while x is [.,:x] repeat nil + x + +--======================================================================= +-- Transfer Codes to opAlist +--======================================================================= + +transferClassCodes(conform,opAlist) == + transferCodeCon(opOf conform,opAlist) + for x in ancestorsOf(conform,nil) repeat + transferCodeCon(CAAR x,opAlist) + +transferCodeCon(con,opAlist) == + for pair in GETDATABASE(con,'DOCUMENTATION) + | FIXP (code := myLastAtom pair) repeat + u := ASSOC(QCAR pair,opAlist) => RPLACD(LASTNODE u,code) + +--======================================================================= +-- Filter Operation by Topic +--======================================================================= + +filterByTopic(opAlist,topic) == + bitNumber := HGET($topicHash,topic) + [x for x in opAlist + | FIXP (code := myLastAtom x) and LOGBITP(bitNumber,code)] + +listOfTopics(conname) == + doc := GETDATABASE(conname,'DOCUMENTATION) + u := ASSOC('constructor,doc) or return nil + code := myLastAtom u +--null FIXP code => nil + mySort [key for key in HKEYS($topicHash) | LOGBITP(HGET($topicHash,key),code)] + diff --git a/src/interp/trace.boot b/src/interp/trace.boot new file mode 100644 index 00000000..6cfd5d39 --- /dev/null +++ b/src/interp/trace.boot @@ -0,0 +1,832 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +--% Code for tracing functions + +-- This code supports the )trace system command and allows the +-- tracing of LISP, BOOT and SPAD functions and interpreter maps. + +SETANDFILEQ($traceNoisely,NIL) -- give trace and untrace messages + +SETANDFILEQ($reportSpadTrace,NIL) -- reports traced funs + +SETANDFILEQ($optionAlist,NIL) + +SETANDFILEQ($tracedMapSignatures, NIL) + +SETANDFILEQ($traceOptionList,'( + after _ + before _ + break_ + cond_ + count_ + depth_ + local_ + mathprint _ + nonquietly_ + nt_ + of_ + only_ + ops_ + restore_ + timer_ + varbreak _ + vars_ + within _ + )) + + +SETANDFILEQ($lastUntraced,NIL) + +trace l == traceSpad2Cmd l + +traceSpad2Cmd l == + if l is ['Tuple, l1] then l := l1 + $mapSubNameAlist:= getMapSubNames(l) + trace1 augmentTraceNames(l,$mapSubNameAlist) + traceReply() + +trace1 l == + $traceNoisely: local := NIL + if hasOption($options,'nonquietly) then $traceNoisely := true + hasOption($options,'off) => + (ops := hasOption($options,'ops)) or + (lops := hasOption($options,'local)) => + null l => throwKeyedMsg("S2IT0019",NIL) + constructor := unabbrev + atom l => l + null rest l => + atom first l => first l + first first l + NIL + not(isFunctor constructor) => throwKeyedMsg("S2IT0020",NIL) + if ops then + ops := getTraceOption ops + NIL + if lops then + lops := rest getTraceOption lops + untraceDomainLocalOps(constructor,lops) + (1 < # $options) and not hasOption($options,'nonquietly) => + throwKeyedMsg("S2IT0021",NIL) + untrace l + hasOption($options,'stats) => + (1 < # $options) => + throwKeyedMsg("S2IT0001",['")trace ... )stats"]) + [.,:opt] := CAR $options + -- look for )trace )stats to list the statistics + -- )trace )stats reset to reset them + null opt => -- list the statistics + centerAndHighlight('"Traced function execution times",78,"-") + ptimers () + SAY '" " + centerAndHighlight('"Traced function execution counts",78,"-") + pcounters () + selectOptionLC(first opt,'(reset),'optionError) + resetSpacers() + resetTimers() + resetCounters() + throwKeyedMsg("S2IT0002",NIL) + a:= hasOption($options,'restore) => + null(oldL:= $lastUntraced) => nil + newOptions:= delete(a,$options) + null l => trace1 oldL + for x in l repeat + x is [domain,:opList] and VECP domain => + sayKeyedMsg("S2IT0003",[devaluate domain]) + $options:= [:newOptions,:LASSOC(x,$optionAlist)] + trace1 LIST x + null l => nil + l is ["?"] => _?t() + traceList:= [transTraceItem x for x in l] or return nil + for x in traceList repeat $optionAlist:= + ADDASSOC(x,$options,$optionAlist) + optionList:= getTraceOptions $options + argument:= + domainList:= LASSOC("of",optionList) => + LASSOC("ops",optionList) => + throwKeyedMsg("S2IT0004",NIL) + opList:= + traceList => LIST ["ops",:traceList] + nil + varList:= + y:= LASSOC("vars",optionList) => LIST ["vars",:y] + nil + [:domainList,:opList,:varList] + optionList => [:traceList,:optionList] + traceList + _/TRACE_,0 [funName for funName in argument] + saveMapSig [funName for funName in argument] + +getTraceOptions options == + $traceErrorStack: local + optionList:= [getTraceOption x for x in options] + $traceErrorStack => + null rest $traceErrorStack => + [key,parms] := first $traceErrorStack + throwKeyedMsg(key,['"",:parms]) + throwListOfKeyedMsgs("S2IT0017",[# $traceErrorStack], + NREVERSE $traceErrorStack) + optionList + +saveMapSig(funNames) == + for name in funNames repeat + map:= rassoc(name,$mapSubNameAlist) => + $tracedMapSignatures:= ADDASSOC(name,getMapSig(map,name), + $tracedMapSignatures) + +getMapSig(mapName,subName) == + lmms:= get(mapName,'localModemap,$InteractiveFrame) => + for mm in lmms until sig repeat + CADR mm = subName => sig:= CDAR mm + sig + +getTraceOption (x is [key,:l]) == + key:= selectOptionLC(key,$traceOptionList,'traceOptionError) + x := [key,:l] + MEMQ(key,'(nonquietly timer nt)) => x + key='break => + null l => ['break,'before] + opts := [selectOptionLC(y,'(before after),NIL) for y in l] + and/[IDENTP y for y in opts] => ['break,:opts] + stackTraceOptionError ["S2IT0008",NIL] + key='restore => + null l => x + stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]] + key='only => ['only,:transOnlyOption l] + key='within => + l is [a] and IDENTP a => x + stackTraceOptionError ["S2IT0010",['")within"]] + MEMQ(key,'(cond before after)) => + key:= + key="cond" => "when" + key + l is [a] => [key,:l] + stackTraceOptionError ["S2IT0011",[STRCONC('")",object2String key)]] + key='depth => + l is [n] and FIXP n => x + stackTraceOptionError ["S2IT0012",['")depth"]] + key='count => + (null l) or (l is [n] and FIXP n) => x + stackTraceOptionError ["S2IT0012",['")count"]] + key="of" => + ["of",:[hn y for y in l]] where + hn x == + atom x and not UPPER_-CASE_-P (STRINGIMAGE x).(0) => + isDomainOrPackage EVAL x => x + stackTraceOptionError ["S2IT0013",[x]] + g:= domainToGenvar x => g + stackTraceOptionError ["S2IT0013",[x]] + MEMQ(key,'(local ops vars)) => + null l or l is ["all"] => [key,:"all"] + isListOfIdentifiersOrStrings l => x + stackTraceOptionError ["S2IT0015",[STRCONC('")",object2String key)]] + key='varbreak => + null l or l is ["all"] => ["varbreak",:"all"] + isListOfIdentifiers l => x + stackTraceOptionError ["S2IT0016",[STRCONC('")",object2String key)]] + key='mathprint => + null l => x + stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]] + key => throwKeyedMsg("S2IT0005",[key]) + +traceOptionError(opt,keys) == + null keys => stackTraceOptionError ["S2IT0007",[opt]] + commandAmbiguityError("trace option",opt,keys) + +resetTimers () == + for timer in _/TIMERLIST repeat + SET(INTERN STRCONC(timer,'"_,TIMER"),0) + +resetSpacers () == + for spacer in _/SPACELIST repeat + SET(INTERN STRCONC(spacer,'"_,SPACE"),0) + +resetCounters () == + for k in _/COUNTLIST repeat + SET(INTERN STRCONC(k,'"_,COUNT"),0) + +ptimers() == + null _/TIMERLIST => sayBrightly '" no functions are timed" + for timer in _/TIMERLIST repeat + sayBrightly [" ",:bright timer,'_:,'" ", + EVAL(INTERN STRCONC(timer,'"_,TIMER")) / float $timerTicksPerSecond,'" sec."] + +pspacers() == + null _/SPACELIST => sayBrightly '" no functions have space monitored" + for spacer in _/SPACELIST repeat + sayBrightly [" ",:bright spacer,'_:,'" ", + EVAL INTERN STRCONC(spacer,'"_,SPACE"),'" bytes"] + +pcounters() == + null _/COUNTLIST => sayBrightly '" no functions are being counted" + for k in _/COUNTLIST repeat + sayBrightly [" ",:bright k,'_:,'" ", + EVAL INTERN STRCONC(k,'"_,COUNT"),'" times"] + +transOnlyOption l == + l is [n,:y] => + FIXP n => [n,:transOnlyOption y] + MEMQ(n:= UPCASE n,'(V A C)) => [n,:transOnlyOption y] + stackTraceOptionError ["S2IT0006",[n]] + transOnlyOption y + nil + +stackTraceOptionError x == + $traceErrorStack:= [x,:$traceErrorStack] + nil + +removeOption(op,options) == + [optEntry for (optEntry:=[opt,:.]) in options | opt ^= op] + +domainToGenvar x == + $doNotAddEmptyModeIfTrue: local:= true + (y:= unabbrevAndLoad x) and GETDATABASE(opOf y,'CONSTRUCTORKIND) = 'domain => + g:= genDomainTraceName y + SET(g,evalDomain y) + g + +genDomainTraceName y == + u:= LASSOC(y,$domainTraceNameAssoc) => u + g:= GENVAR() + $domainTraceNameAssoc:= [[y,:g],:$domainTraceNameAssoc] + g + +--this is now called from trace with the )off option +untrace l == + $lastUntraced:= + null l => COPY _/TRACENAMES + l + untraceList:= [transTraceItem x for x in l] + _/UNTRACE_,0 [lassocSub(funName,$mapSubNameAlist) for + funName in untraceList] + removeTracedMapSigs untraceList + +transTraceItem x == + $doNotAddEmptyModeIfTrue: local:=true + atom x => + (value:=get(x,"value",$InteractiveFrame)) and + (objMode value in '((Mode) (Domain) (SubDomain (Domain)))) => + x := objVal value + (y:= domainToGenvar x) => y + x + UPPER_-CASE_-P (STRINGIMAGE x).(0) => + y := unabbrev x + constructor?(y) => y + PAIRP(y) and constructor?(CAR y) => CAR y + (y:= domainToGenvar x) => y + x + x + VECP first x => transTraceItem devaluate first x + y:= domainToGenvar x => y + throwKeyedMsg("S2IT0018",[x]) + +removeTracedMapSigs untraceList == + for name in untraceList repeat + REMPROP(name,$tracedMapSignatures) + +coerceTraceArgs2E(traceName,subName,args) == + MEMQ(name:= subName,$mathTraceList) => + SPADSYSNAMEP PNAME name => coerceSpadArgs2E(reverse CDR reverse args) + [["=",name,objValUnwrap coerceInteractive(objNewWrap(arg,type),$OutputForm)] + for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 ) + for arg in args for type in CDR LASSOC(subName, + $tracedMapSignatures)] + SPADSYSNAMEP PNAME name => reverse CDR reverse args + args + +coerceSpadArgs2E(args) == + -- following binding is to prevent forcing calculation of stream elements + $streamCount:local := 0 + [["=",name,objValUnwrap coerceInteractive(objNewWrap(arg,type),$OutputForm)] + for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 ) + for arg in args for type in CDR $tracedSpadModemap] + +subTypes(mm,sublist) == + ATOM mm => + (s:= LASSOC(mm,sublist)) => s + mm + [subTypes(m,sublist) for m in mm] + +coerceTraceFunValue2E(traceName,subName,value) == + MEMQ(name:= subName,$mathTraceList) => + SPADSYSNAMEP PNAME traceName => coerceSpadFunValue2E(value) + (u:=LASSOC(subName,$tracedMapSignatures)) => + objValUnwrap coerceInteractive(objNewWrap(value,CAR u),$OutputForm) + value + value + +coerceSpadFunValue2E(value) == + -- following binding is to prevent forcing calculation of stream elements + $streamCount:local := 0 + objValUnwrap coerceInteractive(objNewWrap(value,CAR $tracedSpadModemap), + $OutputForm) + +isListOfIdentifiers l == and/[IDENTP x for x in l] + +isListOfIdentifiersOrStrings l == and/[IDENTP x or STRINGP x for x in l] + +getMapSubNames(l) == + subs:= nil + for mapName in l repeat + lmm:= get(mapName,'localModemap,$InteractiveFrame) => + subs:= APPEND([[mapName,:CADR mm] for mm in lmm],subs) + union(subs,getPreviousMapSubNames UNIONQ(_/TRACENAMES, + $lastUntraced)) + +getPreviousMapSubNames(traceNames) == + subs:= nil + for mapName in ASSOCLEFT CAAR $InteractiveFrame repeat + lmm:= get(mapName,'localModemap,$InteractiveFrame) => + MEMQ(CADAR lmm,traceNames) => + for mm in lmm repeat + subs:= [[mapName,:CADR mm],:subs] + subs + +lassocSub(x,subs) == + y:= LASSQ(x,subs) => y + x + +rassocSub(x,subs) == + y:= rassoc(x,subs) => y + x + +isUncompiledMap(x) == + y:= get(x,'value,$InteractiveFrame) => + (CAAR y) = 'MAP and null get(x,'localModemap,$InteractiveFrame) + +isInterpOnlyMap(map) == + x:= get(map,'localModemap,$InteractiveFrame) => + (CAAAR x) = 'interpOnly + +augmentTraceNames(l,mapSubNames) == + res:= nil + for traceName in l repeat + mml:= get(traceName,'localModemap,$InteractiveFrame) => + res:= APPEND([CADR mm for mm in mml],res) + res:= [traceName,:res] + res + +isSubForRedundantMapName(subName) == + mapName:= rassocSub(subName,$mapSubNameAlist) => + tail:=member([mapName,:subName],$mapSubNameAlist) => + MEMQ(mapName,CDR ASSOCLEFT tail) + +untraceMapSubNames traceNames == + null($mapSubNameAlist:local:= getPreviousMapSubNames traceNames) => nil + for name in (subs:= ASSOCRIGHT $mapSubNameAlist) + | MEMQ(name,_/TRACENAMES) repeat + _/UNTRACE_,2(name,nil) + $lastUntraced:= SETDIFFERENCE($lastUntraced,subs) + +funfind("functor","opname") == + ops:= isFunctor functor + [u for u in ops | u is [[ =opname,:.],:.]] + +isDomainOrPackage dom == + REFVECP dom and #dom>0 and isFunctor opOf dom.(0) + +isTraceGensym x == GENSYMP x + +spadTrace(domain,options) == + $fromSpadTrace:= true + $tracedModemap:local:= nil + PAIRP domain and REFVECP CAR domain and (CAR domain).0 = 0 => + aldorTrace(domain,options) + not isDomainOrPackage domain => userError '"bad argument to trace" + listOfOperations:= + [g x for x in getOption("OPS",options)] where + g x == + STRINGP x => INTERN x + x + if listOfVariables := getOption("VARS",options) then + options := removeOption("VARS",options) + if listOfBreakVars := getOption("VARBREAK",options) then + options := removeOption("VARBREAK",options) + anyifTrue:= null listOfOperations + domainId:= opOf domain.(0) + currentEntry:= ASSOC(domain,_/TRACENAMES) + currentAlist:= KDR currentEntry + opStructureList:= flattenOperationAlist getOperationAlistFromLisplib domainId + sigSlotNumberAlist:= + [triple + --new form is ( ) + for [op,sig,n,.,kind] in opStructureList | kind = 'ELT + and (anyifTrue or MEMQ(op,listOfOperations)) and + FIXP n and + isTraceable(triple:= [op,sig,n],domain)] where + isTraceable(x is [.,.,n,:.],domain) == + atom domain.n => nil + functionSlot:= first domain.n + GENSYMP functionSlot => + (reportSpadTrace("Already Traced",x); nil) + null (BPINAME functionSlot) => + (reportSpadTrace("No function for",x); nil) + true + if listOfVariables then + for [.,.,n] in sigSlotNumberAlist repeat + fn := first domain.n + $letAssoc := AS_-INSERT(BPINAME fn, + listOfVariables,$letAssoc) + if listOfBreakVars then + for [.,.,n] in sigSlotNumberAlist repeat + fn := first domain.n + $letAssoc := AS_-INSERT(BPINAME fn, + [["BREAK",:listOfBreakVars]],$letAssoc) + for (pair:= [op,mm,n]) in sigSlotNumberAlist repeat + alias:= spadTraceAlias(domainId,op,n) + $tracedModemap:= subTypes(mm,constructSubst(domain.0)) + traceName:= BPITRACE(first domain.n,alias, options) + NCONC(pair,[listOfVariables,first domain.n,traceName,alias]) + RPLAC(first domain.n,traceName) + sigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x] + if $reportSpadTrace then + if $traceNoisely then printDashedLine() + for x in orderBySlotNumber sigSlotNumberAlist repeat + reportSpadTrace("TRACING",x) + if $letAssoc then SETLETPRINTFLAG true + currentEntry => + RPLAC(rest currentEntry,[:sigSlotNumberAlist,:currentAlist]) + SETQ(_/TRACENAMES,[[domain,:sigSlotNumberAlist],:_/TRACENAMES]) + spadReply() + +traceDomainLocalOps(dom,lops,options) == + sayMSG ['" ",'"The )local option has been withdrawn"] + sayMSG ['" ",'"Use )ltr to trace local functions."] + NIL +-- abb := abbreviate dom +-- loadLibIfNotLoaded abb +-- actualLops := getLocalOpsFromLisplib abb +-- null actualLops => +-- sayMSG ['" ",:bright abb,'"has no local functions to trace."] +-- lops = 'all => _/TRACE_,1(actualLops,options) +-- l := NIL +-- for lop in lops repeat +-- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop) +-- not MEMQ(internalName,actualLops) => +-- sayMSG ['" ",:bright abb,'"does not have a local", +-- '" function called",:bright lop] +-- l := cons(internalName,l) +-- l => _/TRACE_,1(l,options) +-- nil + +untraceDomainLocalOps(dom,lops) == + sayMSG ['" ",:bright abb,'"has no local functions to untrace."] + NIL +-- lops = "all" => untraceAllDomainLocalOps(dom) +-- abb := abbreviate dom +-- loadLibIfNotLoaded abb +-- actualLops := getLocalOpsFromLisplib abb +-- null actualLops => +-- sayMSG ['" ",:bright abb,'"has no local functions to untrace."] +-- l := NIL +-- for lop in lops repeat +-- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop) +-- not MEMQ(internalName,actualLops) => +-- sayMSG ['" ",:bright abb,'"does not have a local", +-- '" function called",:bright lop] +-- l := cons(internalName,l) +-- l => untrace l +-- nil + +untraceAllDomainLocalOps(dom) == NIL +-- abb := abbreviate dom +-- actualLops := getLocalOpsFromLisplib abb +-- null (l := intersection(actualLops,_/TRACENAMES)) => NIL +-- _/UNTRACE_,1(l,NIL) +-- NIL + +traceDomainConstructor(domainConstructor,options) == + -- Trace all domains built with the given domain constructor, + -- including all presently instantiated domains, and all future + -- instantiations, while domain constructor is traced. + loadFunctor domainConstructor + listOfLocalOps := getOption("LOCAL",options) + if listOfLocalOps then + traceDomainLocalOps(domainConstructor,listOfLocalOps, + [opt for opt in options | opt isnt ['LOCAL,:.]]) + listOfLocalOps and not getOption("OPS",options) => NIL + for [argl,.,:domain] in HGET($ConstructorCache,domainConstructor) + repeat spadTrace(domain,options) + SETQ(_/TRACENAMES,[domainConstructor,:_/TRACENAMES]) + innerDomainConstructor := INTERN STRCONC(domainConstructor,'";") + if FBOUNDP innerDomainConstructor then domainConstructor := innerDomainConstructor + EMBED(domainConstructor, + ['LAMBDA, ['_&REST, 'args], + ['PROG, ['domain], + ['SETQ,'domain,['APPLY,domainConstructor,'args]], + ['spadTrace,'domain,MKQ options], + ['RETURN,'domain]]] ) + +untraceDomainConstructor domainConstructor == + --untrace all the domains in domainConstructor, and unembed it + SETQ(_/TRACENAMES, + [df for df in _/TRACENAMES | keepTraced?(df, domainConstructor)]) where + keepTraced?(df, domainConstructor) == + (df is [dc,:.]) and (isDomainOrPackage dc) and + ((KAR devaluate dc) = domainConstructor) => + _/UNTRACE_,0 [dc] + false + true + untraceAllDomainLocalOps domainConstructor + innerDomainConstructor := INTERN STRCONC(domainConstructor,'";") + if FBOUNDP innerDomainConstructor then UNEMBED innerDomainConstructor + else UNEMBED domainConstructor + SETQ(_/TRACENAMES,delete(domainConstructor,_/TRACENAMES)) + +flattenOperationAlist(opAlist) == + res:= nil + for [op,:mmList] in opAlist repeat + res:=[:res,:[[op,:mm] for mm in mmList]] + res + +mapLetPrint(x,val,currentFunction) == + x:= getAliasIfTracedMapParameter(x,currentFunction) + currentFunction:= getBpiNameIfTracedMap currentFunction + letPrint(x,val,currentFunction) + +-- This is the version for use when we have no idea +-- what print representation to use for the data object + +letPrint(x,val,currentFunction) == + if $letAssoc and + ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc))) then + if (y="all" or MEMQ(x,y)) and + not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then + sayBrightlyNT [:bright x,": "] + PRIN0 shortenForPrinting val + TERPRI() + if (y:= hasPair("BREAK",y)) and + (y="all" or MEMQ(x,y) and + (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then + break [:bright currentFunction,'"breaks after",:bright x,'":= ", + shortenForPrinting val] + val + +-- This is the version for use when we have already +-- converted the data into type "Expression" +letPrint2(x,printform,currentFunction) == + $BreakMode:local + if $letAssoc and + ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc))) then + if (y="all" or MEMQ(x,y)) and + not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then + $BreakMode:='letPrint2 + flag:=nil + CATCH('letPrint2,mathprint ["=",x,printform],flag) + if flag='letPrint2 then print printform + if (y:= hasPair("BREAK",y)) and + (y="all" or MEMQ(x,y) and + (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then + break [:bright currentFunction,'"breaks after",:bright x,":= ", + printform] + x + +-- This is the version for use when we have our hands on a function +-- to convert the data into type "Expression" + +letPrint3(x,xval,printfn,currentFunction) == + $BreakMode:local + if $letAssoc and + ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc))) then + if (y="all" or MEMQ(x,y)) and + not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then + $BreakMode:='letPrint2 + flag:=nil + CATCH('letPrint2,mathprint ["=",x,SPADCALL(xval,printfn)],flag) + if flag='letPrint2 then print xval + if (y:= hasPair("BREAK",y)) and + (y="all" or MEMQ(x,y) and + (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then + break [:bright currentFunction,'"breaks after",:bright x,'":= ", + xval] + x + +getAliasIfTracedMapParameter(x,currentFunction) == + isSharpVarWithNum x => + aliasList:= get(currentFunction,'alias,$InteractiveFrame) => + aliasList.(STRING2PINT_-N(SUBSTRING(PNAME x,1,NIL),1)-1) + x + +getBpiNameIfTracedMap(name) == + lmm:= get(name,'localModemap,$InteractiveFrame) => + MEMQ(bpiName:= CADAR lmm,_/TRACENAMES) => bpiName + name + +hasPair(key,l) == + atom l => nil + l is [[ =key,:a],:.] => a + hasPair(key,rest l) + +shortenForPrinting val == + isDomainOrPackage val => devaluate val + val + +spadTraceAlias(domainId,op,n) == + INTERNL(domainId,".",op,",",STRINGIMAGE n) + +getOption(opt,l) == + y:= ASSOC(opt,l) => rest y + +reportSpadTrace(header,[op,sig,n,:t]) == + null $traceNoisely => nil + msg:= [header,'%b,op,":",'%d,rest sig," -> ",first sig," in slot ",n] + namePart:= nil --(t is (.,.,name,:.) => (" named ",name); NIL) + tracePart:= + t is [y,:.] and not null y => + (y="all" => ['%b,"all",'%d,"vars"]; [" vars: ",y]) + NIL + sayBrightly [:msg,:namePart,:tracePart] + +orderBySlotNumber l == + ASSOCRIGHT orderList [[n,:x] for (x:= [.,.,n,:.]) in l] + +_/TRACEREPLY() == + null _/TRACENAMES => MAKESTRING '" Nothing is traced." + for x in _/TRACENAMES repeat + x is [d,:.] and isDomainOrPackage d => + domainList:= [devaluate d,:domainList] + functionList:= [x,:functionList] + [:functionList,:domainList,"traced"] + +spadReply() == + [printName x for x in _/TRACENAMES] where + printName x == + x is [d,:.] and isDomainOrPackage d => devaluate d + x + +spadUntrace(domain,options) == + not isDomainOrPackage domain => userError '"bad argument to untrace" + anyifTrue:= null options + listOfOperations:= getOption("ops:",options) + domainId := devaluate domain + null (pair:= ASSOC(domain,_/TRACENAMES)) => + sayMSG ['" No functions in", + :bright prefix2String domainId,'"are now traced."] + sigSlotNumberAlist:= rest pair + for (pair:= [op,sig,n,lv,bpiPointer,traceName,alias]) in sigSlotNumberAlist | + anyifTrue or MEMQ(op,listOfOperations) repeat + BPIUNTRACE(traceName,alias) + RPLAC(first domain.n,bpiPointer) + RPLAC(CDDDR pair,nil) + if assocPair:=ASSOC(BPINAME bpiPointer,$letAssoc) then + $letAssoc := REMOVER($letAssoc,assocPair) + if null $letAssoc then SETLETPRINTFLAG nil + newSigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x] + newSigSlotNumberAlist => RPLAC(rest pair,newSigSlotNumberAlist) + SETQ(_/TRACENAMES,DELASC(domain,_/TRACENAMES)) + spadReply() + +prTraceNames() == + (for x in _/TRACENAMES repeat PRINT fn x; nil) where + fn x == + x is [d,:t] and isDomainOrPackage d => [devaluate d,:t] + x + +traceReply() == + $domains: local:= nil + $packages: local:= nil + $constructors: local:= nil + null _/TRACENAMES => + sayMessage '" Nothing is traced now." + sayBrightly '" " + for x in _/TRACENAMES repeat + x is [d,:.] and (isDomainOrPackage d) => addTraceItem d + atom x => + isFunctor x => addTraceItem x + (IS__GENVAR x => + addTraceItem EVAL x; functionList:= [x,:functionList]) + userError '"bad argument to trace" + functionList:= "append"/[[rassocSub(x,$mapSubNameAlist),'" "] + for x in functionList | ^isSubForRedundantMapName x] + if functionList then + 2 = #functionList => + sayMSG [" Function traced: ",:functionList] + (22 + sayBrightlyLength functionList) <= $LINELENGTH => + sayMSG [" Functions traced: ",:functionList] + sayBrightly " Functions traced:" + sayBrightly flowSegmentedMsg(functionList,$LINELENGTH,6) + if $domains then + displayList:= concat(prefix2String first $domains, + [:concat('",",'" ",prefix2String x) for x in rest $domains]) + if atom displayList then displayList:= [displayList] + sayBrightly '" Domains traced: " + sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6) + if $packages then + displayList:= concat(prefix2String first $packages, + [:concat(", ",prefix2String x) for x in rest $packages]) + if atom displayList then displayList:= [displayList] + sayBrightly '" Packages traced: " + sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6) + if $constructors then + displayList:= concat(abbreviate first $constructors, + [:concat(", ",abbreviate x) for x in rest $constructors]) + if atom displayList then displayList:= [displayList] + sayBrightly '" Parameterized constructors traced:" + sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6) + +addTraceItem d == + constructor? d => $constructors:=[d,:$constructors] + isDomain d => $domains:= [devaluate d,:$domains] + isDomainOrPackage d => $packages:= [devaluate d,:$packages] + +_?t() == + null _/TRACENAMES => sayMSG bright '"nothing is traced" + for x in _/TRACENAMES | atom x and not IS__GENVAR x repeat + if llm:= get(x,'localModemap,$InteractiveFrame) then + x:= (LIST (CADAR llm)) + sayMSG ['"Function",:bright rassocSub(x,$mapSubNameAlist),'"traced"] + for x in _/TRACENAMES | x is [d,:l] and isDomainOrPackage d repeat + suffix:= + isDomain d => '"domain" + '"package" + sayBrightly ['" Functions traced in ",suffix,'%b,devaluate d,'%d,":"] + for x in orderBySlotNumber l repeat reportSpadTrace(" ",take(4,x)) + TERPRI() + +tracelet(fn,vars) == + if GENSYMP fn and stupidIsSpadFunction EVAL fn then + fn := EVAL fn + if COMPILED_-FUNCTION_-P fn then fn:=BPINAME fn + fn = 'Undef => nil + vars:= + vars="all" => "all" + l:= LASSOC(fn,$letAssoc) => union(vars,l) + vars + $letAssoc:= [[fn,:vars],:$letAssoc] + if $letAssoc then SETLETPRINTFLAG true + $TRACELETFLAG : local := true + $QuickLet : local := false + ^MEMQ(fn,$traceletFunctions) and ^IS__GENVAR fn and COMPILED_-FUNCTION_-P SYMBOL_-FUNCTION fn + and not stupidIsSpadFunction fn and not GENSYMP fn => + ($traceletFunctions:= [fn,:$traceletFunctions]; compileBoot fn ; + $traceletFunctions:= delete(fn,$traceletFunctions) ) + +breaklet(fn,vars) == + --vars is "all" or a list of variables + --$letAssoc ==> (.. (=fn .. (BREAK . all))) OR (.. (=fn .. (BREAK . vl))) + if GENSYMP fn and stupidIsSpadFunction EVAL fn then + fn := EVAL fn + if COMPILED_-FUNCTION_-P fn then fn:= BPINAME fn + fn = "Undef" => nil + fnEntry:= LASSOC(fn,$letAssoc) + vars:= + pair:= ASSOC("BREAK",fnEntry) => union(vars,rest pair) + vars + $letAssoc:= + null fnEntry => [[fn,:LIST ["BREAK",:vars]],:$letAssoc] + pair => (RPLACD(pair,vars); $letAssoc) + if $letAssoc then SETLETPRINTFLAG true + $QuickLet:local := false + ^MEMQ(fn,$traceletFunctions) and not stupidIsSpadFunction fn + and not GENSYMP fn => + $traceletFunctions:= [fn,:$traceletFunctions] + compileBoot fn + $traceletFunctions:= delete(fn,$traceletFunctions) + +stupidIsSpadFunction fn == + -- returns true if the function pname has a semi-colon in it + -- eventually, this will use isSpadFunction from luke boot + STRPOS('"_;",PNAME fn,0,NIL) + +break msg == + condition:= MONITOR_,EVALTRAN(_/BREAKCONDITION,nil) + -- The next line is to try to deal with some reported cases of unwanted + -- backtraces appearing, MCD. + ENABLE_-BACKTRACE(nil) + EVAL condition => + sayBrightly msg + INTERRUPT() + +compileBoot fn == _/D_,1(LIST fn,'(_/COMP),nil,nil) + diff --git a/src/interp/trace.boot.pamphlet b/src/interp/trace.boot.pamphlet deleted file mode 100644 index 1563ea98..00000000 --- a/src/interp/trace.boot.pamphlet +++ /dev/null @@ -1,856 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/trace.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - ---% Code for tracing functions - --- This code supports the )trace system command and allows the --- tracing of LISP, BOOT and SPAD functions and interpreter maps. - -SETANDFILEQ($traceNoisely,NIL) -- give trace and untrace messages - -SETANDFILEQ($reportSpadTrace,NIL) -- reports traced funs - -SETANDFILEQ($optionAlist,NIL) - -SETANDFILEQ($tracedMapSignatures, NIL) - -SETANDFILEQ($traceOptionList,'( - after _ - before _ - break_ - cond_ - count_ - depth_ - local_ - mathprint _ - nonquietly_ - nt_ - of_ - only_ - ops_ - restore_ - timer_ - varbreak _ - vars_ - within _ - )) - - -SETANDFILEQ($lastUntraced,NIL) - -trace l == traceSpad2Cmd l - -traceSpad2Cmd l == - if l is ['Tuple, l1] then l := l1 - $mapSubNameAlist:= getMapSubNames(l) - trace1 augmentTraceNames(l,$mapSubNameAlist) - traceReply() - -trace1 l == - $traceNoisely: local := NIL - if hasOption($options,'nonquietly) then $traceNoisely := true - hasOption($options,'off) => - (ops := hasOption($options,'ops)) or - (lops := hasOption($options,'local)) => - null l => throwKeyedMsg("S2IT0019",NIL) - constructor := unabbrev - atom l => l - null rest l => - atom first l => first l - first first l - NIL - not(isFunctor constructor) => throwKeyedMsg("S2IT0020",NIL) - if ops then - ops := getTraceOption ops - NIL - if lops then - lops := rest getTraceOption lops - untraceDomainLocalOps(constructor,lops) - (1 < # $options) and not hasOption($options,'nonquietly) => - throwKeyedMsg("S2IT0021",NIL) - untrace l - hasOption($options,'stats) => - (1 < # $options) => - throwKeyedMsg("S2IT0001",['")trace ... )stats"]) - [.,:opt] := CAR $options - -- look for )trace )stats to list the statistics - -- )trace )stats reset to reset them - null opt => -- list the statistics - centerAndHighlight('"Traced function execution times",78,"-") - ptimers () - SAY '" " - centerAndHighlight('"Traced function execution counts",78,"-") - pcounters () - selectOptionLC(first opt,'(reset),'optionError) - resetSpacers() - resetTimers() - resetCounters() - throwKeyedMsg("S2IT0002",NIL) - a:= hasOption($options,'restore) => - null(oldL:= $lastUntraced) => nil - newOptions:= delete(a,$options) - null l => trace1 oldL - for x in l repeat - x is [domain,:opList] and VECP domain => - sayKeyedMsg("S2IT0003",[devaluate domain]) - $options:= [:newOptions,:LASSOC(x,$optionAlist)] - trace1 LIST x - null l => nil - l is ["?"] => _?t() - traceList:= [transTraceItem x for x in l] or return nil - for x in traceList repeat $optionAlist:= - ADDASSOC(x,$options,$optionAlist) - optionList:= getTraceOptions $options - argument:= - domainList:= LASSOC("of",optionList) => - LASSOC("ops",optionList) => - throwKeyedMsg("S2IT0004",NIL) - opList:= - traceList => LIST ["ops",:traceList] - nil - varList:= - y:= LASSOC("vars",optionList) => LIST ["vars",:y] - nil - [:domainList,:opList,:varList] - optionList => [:traceList,:optionList] - traceList - _/TRACE_,0 [funName for funName in argument] - saveMapSig [funName for funName in argument] - -getTraceOptions options == - $traceErrorStack: local - optionList:= [getTraceOption x for x in options] - $traceErrorStack => - null rest $traceErrorStack => - [key,parms] := first $traceErrorStack - throwKeyedMsg(key,['"",:parms]) - throwListOfKeyedMsgs("S2IT0017",[# $traceErrorStack], - NREVERSE $traceErrorStack) - optionList - -saveMapSig(funNames) == - for name in funNames repeat - map:= rassoc(name,$mapSubNameAlist) => - $tracedMapSignatures:= ADDASSOC(name,getMapSig(map,name), - $tracedMapSignatures) - -getMapSig(mapName,subName) == - lmms:= get(mapName,'localModemap,$InteractiveFrame) => - for mm in lmms until sig repeat - CADR mm = subName => sig:= CDAR mm - sig - -getTraceOption (x is [key,:l]) == - key:= selectOptionLC(key,$traceOptionList,'traceOptionError) - x := [key,:l] - MEMQ(key,'(nonquietly timer nt)) => x - key='break => - null l => ['break,'before] - opts := [selectOptionLC(y,'(before after),NIL) for y in l] - and/[IDENTP y for y in opts] => ['break,:opts] - stackTraceOptionError ["S2IT0008",NIL] - key='restore => - null l => x - stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]] - key='only => ['only,:transOnlyOption l] - key='within => - l is [a] and IDENTP a => x - stackTraceOptionError ["S2IT0010",['")within"]] - MEMQ(key,'(cond before after)) => - key:= - key="cond" => "when" - key - l is [a] => [key,:l] - stackTraceOptionError ["S2IT0011",[STRCONC('")",object2String key)]] - key='depth => - l is [n] and FIXP n => x - stackTraceOptionError ["S2IT0012",['")depth"]] - key='count => - (null l) or (l is [n] and FIXP n) => x - stackTraceOptionError ["S2IT0012",['")count"]] - key="of" => - ["of",:[hn y for y in l]] where - hn x == - atom x and not UPPER_-CASE_-P (STRINGIMAGE x).(0) => - isDomainOrPackage EVAL x => x - stackTraceOptionError ["S2IT0013",[x]] - g:= domainToGenvar x => g - stackTraceOptionError ["S2IT0013",[x]] - MEMQ(key,'(local ops vars)) => - null l or l is ["all"] => [key,:"all"] - isListOfIdentifiersOrStrings l => x - stackTraceOptionError ["S2IT0015",[STRCONC('")",object2String key)]] - key='varbreak => - null l or l is ["all"] => ["varbreak",:"all"] - isListOfIdentifiers l => x - stackTraceOptionError ["S2IT0016",[STRCONC('")",object2String key)]] - key='mathprint => - null l => x - stackTraceOptionError ["S2IT0009",[STRCONC('")",object2String key)]] - key => throwKeyedMsg("S2IT0005",[key]) - -traceOptionError(opt,keys) == - null keys => stackTraceOptionError ["S2IT0007",[opt]] - commandAmbiguityError("trace option",opt,keys) - -resetTimers () == - for timer in _/TIMERLIST repeat - SET(INTERN STRCONC(timer,'"_,TIMER"),0) - -resetSpacers () == - for spacer in _/SPACELIST repeat - SET(INTERN STRCONC(spacer,'"_,SPACE"),0) - -resetCounters () == - for k in _/COUNTLIST repeat - SET(INTERN STRCONC(k,'"_,COUNT"),0) - -ptimers() == - null _/TIMERLIST => sayBrightly '" no functions are timed" - for timer in _/TIMERLIST repeat - sayBrightly [" ",:bright timer,'_:,'" ", - EVAL(INTERN STRCONC(timer,'"_,TIMER")) / float $timerTicksPerSecond,'" sec."] - -pspacers() == - null _/SPACELIST => sayBrightly '" no functions have space monitored" - for spacer in _/SPACELIST repeat - sayBrightly [" ",:bright spacer,'_:,'" ", - EVAL INTERN STRCONC(spacer,'"_,SPACE"),'" bytes"] - -pcounters() == - null _/COUNTLIST => sayBrightly '" no functions are being counted" - for k in _/COUNTLIST repeat - sayBrightly [" ",:bright k,'_:,'" ", - EVAL INTERN STRCONC(k,'"_,COUNT"),'" times"] - -transOnlyOption l == - l is [n,:y] => - FIXP n => [n,:transOnlyOption y] - MEMQ(n:= UPCASE n,'(V A C)) => [n,:transOnlyOption y] - stackTraceOptionError ["S2IT0006",[n]] - transOnlyOption y - nil - -stackTraceOptionError x == - $traceErrorStack:= [x,:$traceErrorStack] - nil - -removeOption(op,options) == - [optEntry for (optEntry:=[opt,:.]) in options | opt ^= op] - -domainToGenvar x == - $doNotAddEmptyModeIfTrue: local:= true - (y:= unabbrevAndLoad x) and GETDATABASE(opOf y,'CONSTRUCTORKIND) = 'domain => - g:= genDomainTraceName y - SET(g,evalDomain y) - g - -genDomainTraceName y == - u:= LASSOC(y,$domainTraceNameAssoc) => u - g:= GENVAR() - $domainTraceNameAssoc:= [[y,:g],:$domainTraceNameAssoc] - g - ---this is now called from trace with the )off option -untrace l == - $lastUntraced:= - null l => COPY _/TRACENAMES - l - untraceList:= [transTraceItem x for x in l] - _/UNTRACE_,0 [lassocSub(funName,$mapSubNameAlist) for - funName in untraceList] - removeTracedMapSigs untraceList - -transTraceItem x == - $doNotAddEmptyModeIfTrue: local:=true - atom x => - (value:=get(x,"value",$InteractiveFrame)) and - (objMode value in '((Mode) (Domain) (SubDomain (Domain)))) => - x := objVal value - (y:= domainToGenvar x) => y - x - UPPER_-CASE_-P (STRINGIMAGE x).(0) => - y := unabbrev x - constructor?(y) => y - PAIRP(y) and constructor?(CAR y) => CAR y - (y:= domainToGenvar x) => y - x - x - VECP first x => transTraceItem devaluate first x - y:= domainToGenvar x => y - throwKeyedMsg("S2IT0018",[x]) - -removeTracedMapSigs untraceList == - for name in untraceList repeat - REMPROP(name,$tracedMapSignatures) - -coerceTraceArgs2E(traceName,subName,args) == - MEMQ(name:= subName,$mathTraceList) => - SPADSYSNAMEP PNAME name => coerceSpadArgs2E(reverse CDR reverse args) - [["=",name,objValUnwrap coerceInteractive(objNewWrap(arg,type),$OutputForm)] - for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 ) - for arg in args for type in CDR LASSOC(subName, - $tracedMapSignatures)] - SPADSYSNAMEP PNAME name => reverse CDR reverse args - args - -coerceSpadArgs2E(args) == - -- following binding is to prevent forcing calculation of stream elements - $streamCount:local := 0 - [["=",name,objValUnwrap coerceInteractive(objNewWrap(arg,type),$OutputForm)] - for name in '(arg1 arg2 arg3 arg4 arg5 arg6 arg7 arg8 arg9 arg10 arg11 arg12 arg13 arg14 arg15 arg16 arg17 arg18 arg19 ) - for arg in args for type in CDR $tracedSpadModemap] - -subTypes(mm,sublist) == - ATOM mm => - (s:= LASSOC(mm,sublist)) => s - mm - [subTypes(m,sublist) for m in mm] - -coerceTraceFunValue2E(traceName,subName,value) == - MEMQ(name:= subName,$mathTraceList) => - SPADSYSNAMEP PNAME traceName => coerceSpadFunValue2E(value) - (u:=LASSOC(subName,$tracedMapSignatures)) => - objValUnwrap coerceInteractive(objNewWrap(value,CAR u),$OutputForm) - value - value - -coerceSpadFunValue2E(value) == - -- following binding is to prevent forcing calculation of stream elements - $streamCount:local := 0 - objValUnwrap coerceInteractive(objNewWrap(value,CAR $tracedSpadModemap), - $OutputForm) - -isListOfIdentifiers l == and/[IDENTP x for x in l] - -isListOfIdentifiersOrStrings l == and/[IDENTP x or STRINGP x for x in l] - -getMapSubNames(l) == - subs:= nil - for mapName in l repeat - lmm:= get(mapName,'localModemap,$InteractiveFrame) => - subs:= APPEND([[mapName,:CADR mm] for mm in lmm],subs) - union(subs,getPreviousMapSubNames UNIONQ(_/TRACENAMES, - $lastUntraced)) - -getPreviousMapSubNames(traceNames) == - subs:= nil - for mapName in ASSOCLEFT CAAR $InteractiveFrame repeat - lmm:= get(mapName,'localModemap,$InteractiveFrame) => - MEMQ(CADAR lmm,traceNames) => - for mm in lmm repeat - subs:= [[mapName,:CADR mm],:subs] - subs - -lassocSub(x,subs) == - y:= LASSQ(x,subs) => y - x - -rassocSub(x,subs) == - y:= rassoc(x,subs) => y - x - -isUncompiledMap(x) == - y:= get(x,'value,$InteractiveFrame) => - (CAAR y) = 'MAP and null get(x,'localModemap,$InteractiveFrame) - -isInterpOnlyMap(map) == - x:= get(map,'localModemap,$InteractiveFrame) => - (CAAAR x) = 'interpOnly - -augmentTraceNames(l,mapSubNames) == - res:= nil - for traceName in l repeat - mml:= get(traceName,'localModemap,$InteractiveFrame) => - res:= APPEND([CADR mm for mm in mml],res) - res:= [traceName,:res] - res - -isSubForRedundantMapName(subName) == - mapName:= rassocSub(subName,$mapSubNameAlist) => - tail:=member([mapName,:subName],$mapSubNameAlist) => - MEMQ(mapName,CDR ASSOCLEFT tail) - -untraceMapSubNames traceNames == - null($mapSubNameAlist:local:= getPreviousMapSubNames traceNames) => nil - for name in (subs:= ASSOCRIGHT $mapSubNameAlist) - | MEMQ(name,_/TRACENAMES) repeat - _/UNTRACE_,2(name,nil) - $lastUntraced:= SETDIFFERENCE($lastUntraced,subs) - -funfind("functor","opname") == - ops:= isFunctor functor - [u for u in ops | u is [[ =opname,:.],:.]] - -isDomainOrPackage dom == - REFVECP dom and #dom>0 and isFunctor opOf dom.(0) - -isTraceGensym x == GENSYMP x - -spadTrace(domain,options) == - $fromSpadTrace:= true - $tracedModemap:local:= nil - PAIRP domain and REFVECP CAR domain and (CAR domain).0 = 0 => - aldorTrace(domain,options) - not isDomainOrPackage domain => userError '"bad argument to trace" - listOfOperations:= - [g x for x in getOption("OPS",options)] where - g x == - STRINGP x => INTERN x - x - if listOfVariables := getOption("VARS",options) then - options := removeOption("VARS",options) - if listOfBreakVars := getOption("VARBREAK",options) then - options := removeOption("VARBREAK",options) - anyifTrue:= null listOfOperations - domainId:= opOf domain.(0) - currentEntry:= ASSOC(domain,_/TRACENAMES) - currentAlist:= KDR currentEntry - opStructureList:= flattenOperationAlist getOperationAlistFromLisplib domainId - sigSlotNumberAlist:= - [triple - --new form is ( ) - for [op,sig,n,.,kind] in opStructureList | kind = 'ELT - and (anyifTrue or MEMQ(op,listOfOperations)) and - FIXP n and - isTraceable(triple:= [op,sig,n],domain)] where - isTraceable(x is [.,.,n,:.],domain) == - atom domain.n => nil - functionSlot:= first domain.n - GENSYMP functionSlot => - (reportSpadTrace("Already Traced",x); nil) - null (BPINAME functionSlot) => - (reportSpadTrace("No function for",x); nil) - true - if listOfVariables then - for [.,.,n] in sigSlotNumberAlist repeat - fn := first domain.n - $letAssoc := AS_-INSERT(BPINAME fn, - listOfVariables,$letAssoc) - if listOfBreakVars then - for [.,.,n] in sigSlotNumberAlist repeat - fn := first domain.n - $letAssoc := AS_-INSERT(BPINAME fn, - [["BREAK",:listOfBreakVars]],$letAssoc) - for (pair:= [op,mm,n]) in sigSlotNumberAlist repeat - alias:= spadTraceAlias(domainId,op,n) - $tracedModemap:= subTypes(mm,constructSubst(domain.0)) - traceName:= BPITRACE(first domain.n,alias, options) - NCONC(pair,[listOfVariables,first domain.n,traceName,alias]) - RPLAC(first domain.n,traceName) - sigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x] - if $reportSpadTrace then - if $traceNoisely then printDashedLine() - for x in orderBySlotNumber sigSlotNumberAlist repeat - reportSpadTrace("TRACING",x) - if $letAssoc then SETLETPRINTFLAG true - currentEntry => - RPLAC(rest currentEntry,[:sigSlotNumberAlist,:currentAlist]) - SETQ(_/TRACENAMES,[[domain,:sigSlotNumberAlist],:_/TRACENAMES]) - spadReply() - -traceDomainLocalOps(dom,lops,options) == - sayMSG ['" ",'"The )local option has been withdrawn"] - sayMSG ['" ",'"Use )ltr to trace local functions."] - NIL --- abb := abbreviate dom --- loadLibIfNotLoaded abb --- actualLops := getLocalOpsFromLisplib abb --- null actualLops => --- sayMSG ['" ",:bright abb,'"has no local functions to trace."] --- lops = 'all => _/TRACE_,1(actualLops,options) --- l := NIL --- for lop in lops repeat --- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop) --- not MEMQ(internalName,actualLops) => --- sayMSG ['" ",:bright abb,'"does not have a local", --- '" function called",:bright lop] --- l := cons(internalName,l) --- l => _/TRACE_,1(l,options) --- nil - -untraceDomainLocalOps(dom,lops) == - sayMSG ['" ",:bright abb,'"has no local functions to untrace."] - NIL --- lops = "all" => untraceAllDomainLocalOps(dom) --- abb := abbreviate dom --- loadLibIfNotLoaded abb --- actualLops := getLocalOpsFromLisplib abb --- null actualLops => --- sayMSG ['" ",:bright abb,'"has no local functions to untrace."] --- l := NIL --- for lop in lops repeat --- internalName := INTERN STRCONC(PNAME abb,'";",PNAME lop) --- not MEMQ(internalName,actualLops) => --- sayMSG ['" ",:bright abb,'"does not have a local", --- '" function called",:bright lop] --- l := cons(internalName,l) --- l => untrace l --- nil - -untraceAllDomainLocalOps(dom) == NIL --- abb := abbreviate dom --- actualLops := getLocalOpsFromLisplib abb --- null (l := intersection(actualLops,_/TRACENAMES)) => NIL --- _/UNTRACE_,1(l,NIL) --- NIL - -traceDomainConstructor(domainConstructor,options) == - -- Trace all domains built with the given domain constructor, - -- including all presently instantiated domains, and all future - -- instantiations, while domain constructor is traced. - loadFunctor domainConstructor - listOfLocalOps := getOption("LOCAL",options) - if listOfLocalOps then - traceDomainLocalOps(domainConstructor,listOfLocalOps, - [opt for opt in options | opt isnt ['LOCAL,:.]]) - listOfLocalOps and not getOption("OPS",options) => NIL - for [argl,.,:domain] in HGET($ConstructorCache,domainConstructor) - repeat spadTrace(domain,options) - SETQ(_/TRACENAMES,[domainConstructor,:_/TRACENAMES]) - innerDomainConstructor := INTERN STRCONC(domainConstructor,'";") - if FBOUNDP innerDomainConstructor then domainConstructor := innerDomainConstructor - EMBED(domainConstructor, - ['LAMBDA, ['_&REST, 'args], - ['PROG, ['domain], - ['SETQ,'domain,['APPLY,domainConstructor,'args]], - ['spadTrace,'domain,MKQ options], - ['RETURN,'domain]]] ) - -untraceDomainConstructor domainConstructor == - --untrace all the domains in domainConstructor, and unembed it - SETQ(_/TRACENAMES, - [df for df in _/TRACENAMES | keepTraced?(df, domainConstructor)]) where - keepTraced?(df, domainConstructor) == - (df is [dc,:.]) and (isDomainOrPackage dc) and - ((KAR devaluate dc) = domainConstructor) => - _/UNTRACE_,0 [dc] - false - true - untraceAllDomainLocalOps domainConstructor - innerDomainConstructor := INTERN STRCONC(domainConstructor,'";") - if FBOUNDP innerDomainConstructor then UNEMBED innerDomainConstructor - else UNEMBED domainConstructor - SETQ(_/TRACENAMES,delete(domainConstructor,_/TRACENAMES)) - -flattenOperationAlist(opAlist) == - res:= nil - for [op,:mmList] in opAlist repeat - res:=[:res,:[[op,:mm] for mm in mmList]] - res - -mapLetPrint(x,val,currentFunction) == - x:= getAliasIfTracedMapParameter(x,currentFunction) - currentFunction:= getBpiNameIfTracedMap currentFunction - letPrint(x,val,currentFunction) - --- This is the version for use when we have no idea --- what print representation to use for the data object - -letPrint(x,val,currentFunction) == - if $letAssoc and - ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc))) then - if (y="all" or MEMQ(x,y)) and - not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then - sayBrightlyNT [:bright x,": "] - PRIN0 shortenForPrinting val - TERPRI() - if (y:= hasPair("BREAK",y)) and - (y="all" or MEMQ(x,y) and - (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then - break [:bright currentFunction,'"breaks after",:bright x,'":= ", - shortenForPrinting val] - val - --- This is the version for use when we have already --- converted the data into type "Expression" -letPrint2(x,printform,currentFunction) == - $BreakMode:local - if $letAssoc and - ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc))) then - if (y="all" or MEMQ(x,y)) and - not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then - $BreakMode:='letPrint2 - flag:=nil - CATCH('letPrint2,mathprint ["=",x,printform],flag) - if flag='letPrint2 then print printform - if (y:= hasPair("BREAK",y)) and - (y="all" or MEMQ(x,y) and - (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then - break [:bright currentFunction,'"breaks after",:bright x,":= ", - printform] - x - --- This is the version for use when we have our hands on a function --- to convert the data into type "Expression" - -letPrint3(x,xval,printfn,currentFunction) == - $BreakMode:local - if $letAssoc and - ((y:= LASSOC(currentFunction,$letAssoc)) or (y:= LASSOC("all",$letAssoc))) then - if (y="all" or MEMQ(x,y)) and - not (IS__GENVAR(x) or isSharpVarWithNum(x) or GENSYMP x) then - $BreakMode:='letPrint2 - flag:=nil - CATCH('letPrint2,mathprint ["=",x,SPADCALL(xval,printfn)],flag) - if flag='letPrint2 then print xval - if (y:= hasPair("BREAK",y)) and - (y="all" or MEMQ(x,y) and - (not MEMQ((PNAME x).(0),'($ _#)) and not GENSYMP x)) then - break [:bright currentFunction,'"breaks after",:bright x,'":= ", - xval] - x - -getAliasIfTracedMapParameter(x,currentFunction) == - isSharpVarWithNum x => - aliasList:= get(currentFunction,'alias,$InteractiveFrame) => - aliasList.(STRING2PINT_-N(SUBSTRING(PNAME x,1,NIL),1)-1) - x - -getBpiNameIfTracedMap(name) == - lmm:= get(name,'localModemap,$InteractiveFrame) => - MEMQ(bpiName:= CADAR lmm,_/TRACENAMES) => bpiName - name - -hasPair(key,l) == - atom l => nil - l is [[ =key,:a],:.] => a - hasPair(key,rest l) - -shortenForPrinting val == - isDomainOrPackage val => devaluate val - val - -spadTraceAlias(domainId,op,n) == - INTERNL(domainId,".",op,",",STRINGIMAGE n) - -getOption(opt,l) == - y:= ASSOC(opt,l) => rest y - -reportSpadTrace(header,[op,sig,n,:t]) == - null $traceNoisely => nil - msg:= [header,'%b,op,":",'%d,rest sig," -> ",first sig," in slot ",n] - namePart:= nil --(t is (.,.,name,:.) => (" named ",name); NIL) - tracePart:= - t is [y,:.] and not null y => - (y="all" => ['%b,"all",'%d,"vars"]; [" vars: ",y]) - NIL - sayBrightly [:msg,:namePart,:tracePart] - -orderBySlotNumber l == - ASSOCRIGHT orderList [[n,:x] for (x:= [.,.,n,:.]) in l] - -_/TRACEREPLY() == - null _/TRACENAMES => MAKESTRING '" Nothing is traced." - for x in _/TRACENAMES repeat - x is [d,:.] and isDomainOrPackage d => - domainList:= [devaluate d,:domainList] - functionList:= [x,:functionList] - [:functionList,:domainList,"traced"] - -spadReply() == - [printName x for x in _/TRACENAMES] where - printName x == - x is [d,:.] and isDomainOrPackage d => devaluate d - x - -spadUntrace(domain,options) == - not isDomainOrPackage domain => userError '"bad argument to untrace" - anyifTrue:= null options - listOfOperations:= getOption("ops:",options) - domainId := devaluate domain - null (pair:= ASSOC(domain,_/TRACENAMES)) => - sayMSG ['" No functions in", - :bright prefix2String domainId,'"are now traced."] - sigSlotNumberAlist:= rest pair - for (pair:= [op,sig,n,lv,bpiPointer,traceName,alias]) in sigSlotNumberAlist | - anyifTrue or MEMQ(op,listOfOperations) repeat - BPIUNTRACE(traceName,alias) - RPLAC(first domain.n,bpiPointer) - RPLAC(CDDDR pair,nil) - if assocPair:=ASSOC(BPINAME bpiPointer,$letAssoc) then - $letAssoc := REMOVER($letAssoc,assocPair) - if null $letAssoc then SETLETPRINTFLAG nil - newSigSlotNumberAlist:= [x for x in sigSlotNumberAlist | CDDDR x] - newSigSlotNumberAlist => RPLAC(rest pair,newSigSlotNumberAlist) - SETQ(_/TRACENAMES,DELASC(domain,_/TRACENAMES)) - spadReply() - -prTraceNames() == - (for x in _/TRACENAMES repeat PRINT fn x; nil) where - fn x == - x is [d,:t] and isDomainOrPackage d => [devaluate d,:t] - x - -traceReply() == - $domains: local:= nil - $packages: local:= nil - $constructors: local:= nil - null _/TRACENAMES => - sayMessage '" Nothing is traced now." - sayBrightly '" " - for x in _/TRACENAMES repeat - x is [d,:.] and (isDomainOrPackage d) => addTraceItem d - atom x => - isFunctor x => addTraceItem x - (IS__GENVAR x => - addTraceItem EVAL x; functionList:= [x,:functionList]) - userError '"bad argument to trace" - functionList:= "append"/[[rassocSub(x,$mapSubNameAlist),'" "] - for x in functionList | ^isSubForRedundantMapName x] - if functionList then - 2 = #functionList => - sayMSG [" Function traced: ",:functionList] - (22 + sayBrightlyLength functionList) <= $LINELENGTH => - sayMSG [" Functions traced: ",:functionList] - sayBrightly " Functions traced:" - sayBrightly flowSegmentedMsg(functionList,$LINELENGTH,6) - if $domains then - displayList:= concat(prefix2String first $domains, - [:concat('",",'" ",prefix2String x) for x in rest $domains]) - if atom displayList then displayList:= [displayList] - sayBrightly '" Domains traced: " - sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6) - if $packages then - displayList:= concat(prefix2String first $packages, - [:concat(", ",prefix2String x) for x in rest $packages]) - if atom displayList then displayList:= [displayList] - sayBrightly '" Packages traced: " - sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6) - if $constructors then - displayList:= concat(abbreviate first $constructors, - [:concat(", ",abbreviate x) for x in rest $constructors]) - if atom displayList then displayList:= [displayList] - sayBrightly '" Parameterized constructors traced:" - sayBrightly flowSegmentedMsg(displayList,$LINELENGTH,6) - -addTraceItem d == - constructor? d => $constructors:=[d,:$constructors] - isDomain d => $domains:= [devaluate d,:$domains] - isDomainOrPackage d => $packages:= [devaluate d,:$packages] - -_?t() == - null _/TRACENAMES => sayMSG bright '"nothing is traced" - for x in _/TRACENAMES | atom x and not IS__GENVAR x repeat - if llm:= get(x,'localModemap,$InteractiveFrame) then - x:= (LIST (CADAR llm)) - sayMSG ['"Function",:bright rassocSub(x,$mapSubNameAlist),'"traced"] - for x in _/TRACENAMES | x is [d,:l] and isDomainOrPackage d repeat - suffix:= - isDomain d => '"domain" - '"package" - sayBrightly ['" Functions traced in ",suffix,'%b,devaluate d,'%d,":"] - for x in orderBySlotNumber l repeat reportSpadTrace(" ",take(4,x)) - TERPRI() - -tracelet(fn,vars) == - if GENSYMP fn and stupidIsSpadFunction EVAL fn then - fn := EVAL fn - if COMPILED_-FUNCTION_-P fn then fn:=BPINAME fn - fn = 'Undef => nil - vars:= - vars="all" => "all" - l:= LASSOC(fn,$letAssoc) => union(vars,l) - vars - $letAssoc:= [[fn,:vars],:$letAssoc] - if $letAssoc then SETLETPRINTFLAG true - $TRACELETFLAG : local := true - $QuickLet : local := false - ^MEMQ(fn,$traceletFunctions) and ^IS__GENVAR fn and COMPILED_-FUNCTION_-P SYMBOL_-FUNCTION fn - and not stupidIsSpadFunction fn and not GENSYMP fn => - ($traceletFunctions:= [fn,:$traceletFunctions]; compileBoot fn ; - $traceletFunctions:= delete(fn,$traceletFunctions) ) - -breaklet(fn,vars) == - --vars is "all" or a list of variables - --$letAssoc ==> (.. (=fn .. (BREAK . all))) OR (.. (=fn .. (BREAK . vl))) - if GENSYMP fn and stupidIsSpadFunction EVAL fn then - fn := EVAL fn - if COMPILED_-FUNCTION_-P fn then fn:= BPINAME fn - fn = "Undef" => nil - fnEntry:= LASSOC(fn,$letAssoc) - vars:= - pair:= ASSOC("BREAK",fnEntry) => union(vars,rest pair) - vars - $letAssoc:= - null fnEntry => [[fn,:LIST ["BREAK",:vars]],:$letAssoc] - pair => (RPLACD(pair,vars); $letAssoc) - if $letAssoc then SETLETPRINTFLAG true - $QuickLet:local := false - ^MEMQ(fn,$traceletFunctions) and not stupidIsSpadFunction fn - and not GENSYMP fn => - $traceletFunctions:= [fn,:$traceletFunctions] - compileBoot fn - $traceletFunctions:= delete(fn,$traceletFunctions) - -stupidIsSpadFunction fn == - -- returns true if the function pname has a semi-colon in it - -- eventually, this will use isSpadFunction from luke boot - STRPOS('"_;",PNAME fn,0,NIL) - -break msg == - condition:= MONITOR_,EVALTRAN(_/BREAKCONDITION,nil) - -- The next line is to try to deal with some reported cases of unwanted - -- backtraces appearing, MCD. - ENABLE_-BACKTRACE(nil) - EVAL condition => - sayBrightly msg - INTERRUPT() - -compileBoot fn == _/D_,1(LIST fn,'(_/COMP),nil,nil) - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/varini.boot b/src/interp/varini.boot new file mode 100644 index 00000000..aa70e21e --- /dev/null +++ b/src/interp/varini.boot @@ -0,0 +1,254 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +-- Variables to control whether old software calls the new compiler. +$ncConverse := NIL +$newcompMode := NIL -- )comp means new compiler. +$newComp := true -- Start workspace in new compiler. + +-- Files used by the compiler. +$erLocMsgDatabaseName := pathname '(co_-eng msgs a) +$erGlbMsgDatabaseName := pathname '(co_-eng msgs i) +$LanguageConstantFileName := pathname '(stlang input _*) +$WorkspaceProfileName := pathname '(spadprof input _*) +$OldLibraryDatabaseName := pathname '(modemap database _*) + +$SpadNcLibraryRelPath := '"lib/lang" +$SpadNcLibraryRelPathSrc := '"src/lib/lang/" +$SpadNcIncludeRelPath := '"src/include/lang/" + +--$LibrariesSearchPath := [PathnameDirectory '"./x", +-- SpadDirectory $SpadNcLibraryRelPath , +-- SpadDirectory $SpadNcLibraryRelPathSrc] + +--$IncludesSearchPath := [PathnameDirectory '"./x", +-- SpadDirectory $SpadNcIncludeRelPath] + +$warmstab := nil + +-- Variables to control phases and their output + +$ncRead := true +$ncmRead := NIL + +$ncParse := true +$ncmParse := NIL + +$ncAbsck := true +$ncmAbsck := NIL + +$ncMacro := true +$ncmMacro := NIL + +$ncScope := false +$ncmScope := NIL + +$ncAnalyze := true +$ncmSemantics := NIL + +$ncInterpretSetr := false + +$ncParseSetr := false +$ncmParseSetr := NIL + +$ncGenerateSAM := true +$ncmSAM := NIL +$ncLastSamCode := NIL + +$ncSamOptimize := false +$ncmSamOptimize := NIL +$ncLastOptimizedCode := NIL + +$ncSamPack := false +$ncmSamPack := NIL +$ncLastPackedSam := NIL + +$ncGenerateConcrete := true +$ncmConCode := NIL +$ncLastConcreteCode := NIL + +$ncLibrary := true +$ncmLibrary := NIL + +$ncGenerateMachine := true +$ncmCodeSize := NIL +$ncLastMachineCode := NIL + +$ncInterpretSam := false +$ncExecuteMachine := true + +$ncReportStep := true + +-- Variables to control debugging output +--they are manipulated in setvart boot +$debugApply := false -- trace application matching +$debugApply0 := false -- trace even more +$debugSemAnalyze := false -- trace results of semAnalyze +$debugRead := false +$debugParse := false +$debugCheck := false +$debugMacro := false +$debugScope := false +$debugParseSetr := false +$debugGenSam := false +$debugSamOpt := false +$debugSamPack := false +$debugGenCon := false +$debugGenMach := false +$debugExecute := false +$debugReport := false + +-- Variables to control what other parts of the compiler are executed. +$ncDoSpecialCases := true +$LispViaSam := false + +-- Variables to control other compiler output. + +-- note flags to control the error message facility must have +-- the prefix $ncm, since catExcpts (in ncsetvar boot) strips the +-- prefix and uses the name. ie. $ncmWarning ==> "Warning" +$ncmPhase := NIL +$ncmWarning := "T" +$ncmStatistic := NIL +$ncmRemark := "T" +$statTmSpShow := 4 +$compBugPrefix := '"Bug!" +$compUnimplPrefix := '"Unimp" +$compDebugPrefix := '"Debug" +$compStatisticPrefix :='"Stat" +$compErrorPrefix := '"Error" +$compWarningPrefix := '"Warn" +$compRemarkPrefix := '"Note" +$compSayPrefix := '"Msg" + +$charNumSymVector := NIL + +-- Modes +$FullMode := 'FullMode +$ValueMode := 'ValueMode + +--error message facility +$nopos := ['noposition] +$showKeyNum := NIL +$specificMsgTags := NIL + +--compiler option stuff +$ncCodeDebug := true +$ncCodeTrace := true +$ncSamInline := true + +-- Variables used in the SEMantic ANAlysis + +--from SEFO BOOT +$sefoDerivedAttributes := [ 'type, 'tfinfo, 'signature, 'pooled ] + +--from NCMODE BOOT +$ValueMode := 'ValueMode +$FullMode := 'FullMode + +-- Miscellaneous nonsense. +$newcompInteractiveRecovery := "T" +$newcompErrorCount := 0 +$floatdolla := ['$elt, ['BigFloat], 'bigfloat] +$floatilla := [ 'elt, ['BigFloat], 'bigfloat] +$newcompStats := NIL +$newcompAbbrevType := true +$stabLibLevelNo := -1 +$SyntheticSourcePosition := 'Synthetic +$Typeless := NIL + +$catAbTab := '( + ($ncmWarning . "warn" ) _ + ($ncmRemark . "rem" ) _ + ($ncmStatistic . "stat" ) ) +$phaseAbTab := '( + (Reading . "Rd" ) _ + (Parsing . "Pa" ) _ + (Checking . "Ck" ) _ + (Macroing . "Ma" ) _ + (Scoping . "Sc" ) _ + (Analyzing . "An" ) _ + (Interpreting . "In" ) _ + (ParseSetr . "Ps" ) _ + (GeneratingSAM . "Sg" ) _ + (SamOptimize . "So" ) _ + (SamPack . "Sp" ) _ + (GeneratingConcrete . "Cg" ) _ + (GeneratingMachine . "Mg" ) _ + (Executing . "Ex" ) _ + (Reporting . "Rp" ) ) + +-- Items from STATS BOOT +$LINELENGTH := 80 + +-- Items from MSG BOOT I +$showMsgCaller := nil --## was F +$preLength := 11 +$LOGLENGTH := $LINELENGTH - 6 +$specificMsgTags := [] + +$imPrTagGuys := ['unimple, 'bug, 'debug, 'say, 'warn] +$toWhereGuys := ['fileOnly, 'screenOnly ] +$imPrGuys := ['imPr] +$repGuys := ['noRep, 'rep] +$attrCats := ['$imPrGuys, '$toWhereGuys, '$repGuys] + + +-- Soon to be obsolete +$showConcrete1 := NIL +$showConcrete2 := NIL +$showPhases := "T" +$showSAM := NIL +$showform := NIL +$showsetr := NIL +$showval := "T" +$tafon := NIL + +-- Inits for pseudo kaf files +--$CURRENT_-DIRECTORY := fileCurrentDirectory() +$DIRECTORY_-LIST := [] + +--caching for inline code +$gotSam := nil +--$cachedInlineTable := EqTable() + +--debugging variables for Simon. +$simon := nil +$ncmTLambdaDown := nil + +$ncMsgList := nil +$oldLibraryInterface := nil -- don't consider old library information. + +--## Bug in RIOS version of KCL +NeedAtLeastOneFunctionInThisFile(x) == x diff --git a/src/interp/varini.boot.pamphlet b/src/interp/varini.boot.pamphlet deleted file mode 100644 index 14233f02..00000000 --- a/src/interp/varini.boot.pamphlet +++ /dev/null @@ -1,276 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp varini.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package "BOOT" - --- Variables to control whether old software calls the new compiler. -$ncConverse := NIL -$newcompMode := NIL -- )comp means new compiler. -$newComp := true -- Start workspace in new compiler. - --- Files used by the compiler. -$erLocMsgDatabaseName := pathname '(co_-eng msgs a) -$erGlbMsgDatabaseName := pathname '(co_-eng msgs i) -$LanguageConstantFileName := pathname '(stlang input _*) -$WorkspaceProfileName := pathname '(spadprof input _*) -$OldLibraryDatabaseName := pathname '(modemap database _*) - -$SpadNcLibraryRelPath := '"lib/lang" -$SpadNcLibraryRelPathSrc := '"src/lib/lang/" -$SpadNcIncludeRelPath := '"src/include/lang/" - ---$LibrariesSearchPath := [PathnameDirectory '"./x", --- SpadDirectory $SpadNcLibraryRelPath , --- SpadDirectory $SpadNcLibraryRelPathSrc] - ---$IncludesSearchPath := [PathnameDirectory '"./x", --- SpadDirectory $SpadNcIncludeRelPath] - -$warmstab := nil - --- Variables to control phases and their output - -$ncRead := true -$ncmRead := NIL - -$ncParse := true -$ncmParse := NIL - -$ncAbsck := true -$ncmAbsck := NIL - -$ncMacro := true -$ncmMacro := NIL - -$ncScope := false -$ncmScope := NIL - -$ncAnalyze := true -$ncmSemantics := NIL - -$ncInterpretSetr := false - -$ncParseSetr := false -$ncmParseSetr := NIL - -$ncGenerateSAM := true -$ncmSAM := NIL -$ncLastSamCode := NIL - -$ncSamOptimize := false -$ncmSamOptimize := NIL -$ncLastOptimizedCode := NIL - -$ncSamPack := false -$ncmSamPack := NIL -$ncLastPackedSam := NIL - -$ncGenerateConcrete := true -$ncmConCode := NIL -$ncLastConcreteCode := NIL - -$ncLibrary := true -$ncmLibrary := NIL - -$ncGenerateMachine := true -$ncmCodeSize := NIL -$ncLastMachineCode := NIL - -$ncInterpretSam := false -$ncExecuteMachine := true - -$ncReportStep := true - --- Variables to control debugging output ---they are manipulated in setvart boot -$debugApply := false -- trace application matching -$debugApply0 := false -- trace even more -$debugSemAnalyze := false -- trace results of semAnalyze -$debugRead := false -$debugParse := false -$debugCheck := false -$debugMacro := false -$debugScope := false -$debugParseSetr := false -$debugGenSam := false -$debugSamOpt := false -$debugSamPack := false -$debugGenCon := false -$debugGenMach := false -$debugExecute := false -$debugReport := false - --- Variables to control what other parts of the compiler are executed. -$ncDoSpecialCases := true -$LispViaSam := false - --- Variables to control other compiler output. - --- note flags to control the error message facility must have --- the prefix $ncm, since catExcpts (in ncsetvar boot) strips the --- prefix and uses the name. ie. $ncmWarning ==> "Warning" -$ncmPhase := NIL -$ncmWarning := 'T -$ncmStatistic := NIL -$ncmRemark := 'T -$statTmSpShow := 4 -$compBugPrefix := '"Bug!" -$compUnimplPrefix := '"Unimp" -$compDebugPrefix := '"Debug" -$compStatisticPrefix :='"Stat" -$compErrorPrefix := '"Error" -$compWarningPrefix := '"Warn" -$compRemarkPrefix := '"Note" -$compSayPrefix := '"Msg" - -$charNumSymVector := NIL - --- Modes -$FullMode := 'FullMode -$ValueMode := 'ValueMode - ---error message facility -$nopos := ['noposition] -$showKeyNum := NIL -$specificMsgTags := NIL - ---compiler option stuff -$ncCodeDebug := true -$ncCodeTrace := true -$ncSamInline := true - --- Variables used in the SEMantic ANAlysis - ---from SEFO BOOT -$sefoDerivedAttributes := [ 'type, 'tfinfo, 'signature, 'pooled ] - ---from NCMODE BOOT -$ValueMode := 'ValueMode -$FullMode := 'FullMode - --- Miscellaneous nonsense. -$newcompInteractiveRecovery := 'T -$newcompErrorCount := 0 -$floatdolla := ['$elt, ['BigFloat], 'bigfloat] -$floatilla := [ 'elt, ['BigFloat], 'bigfloat] -$newcompStats := NIL -$newcompAbbrevType := true -$stabLibLevelNo := -1 -$SyntheticSourcePosition := 'Synthetic -$Typeless := NIL - -$catAbTab := '( - ($ncmWarning . "warn" ) _ - ($ncmRemark . "rem" ) _ - ($ncmStatistic . "stat" ) ) -$phaseAbTab := '( - (Reading . "Rd" ) _ - (Parsing . "Pa" ) _ - (Checking . "Ck" ) _ - (Macroing . "Ma" ) _ - (Scoping . "Sc" ) _ - (Analyzing . "An" ) _ - (Interpreting . "In" ) _ - (ParseSetr . "Ps" ) _ - (GeneratingSAM . "Sg" ) _ - (SamOptimize . "So" ) _ - (SamPack . "Sp" ) _ - (GeneratingConcrete . "Cg" ) _ - (GeneratingMachine . "Mg" ) _ - (Executing . "Ex" ) _ - (Reporting . "Rp" ) ) - --- Items from STATS BOOT -$LINELENGTH := 80 - --- Items from MSG BOOT I -$showMsgCaller := nil --## was F -$preLength := 11 -$LOGLENGTH := $LINELENGTH - 6 -$specificMsgTags := [] - -$imPrTagGuys := ['unimple, 'bug, 'debug, 'say, 'warn] -$toWhereGuys := ['fileOnly, 'screenOnly ] -$imPrGuys := ['imPr] -$repGuys := ['noRep, 'rep] -$attrCats := ['$imPrGuys, '$toWhereGuys, '$repGuys] - - --- Soon to be obsolete -$showConcrete1 := NIL -$showConcrete2 := NIL -$showPhases := 'T -$showSAM := NIL -$showform := NIL -$showsetr := NIL -$showval := 'T -$tafon := NIL - --- Inits for pseudo kaf files ---$CURRENT_-DIRECTORY := fileCurrentDirectory() -$DIRECTORY_-LIST := [] - ---caching for inline code -$gotSam := nil ---$cachedInlineTable := EqTable() - ---debugging variables for Simon. -$simon := nil -$ncmTLambdaDown := nil - -$ncMsgList := nil -$oldLibraryInterface := nil -- don't consider old library information. - ---## Bug in RIOS version of KCL -NeedAtLeastOneFunctionInThisFile(x) == x -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/wi2.boot.pamphlet b/src/interp/wi2.boot.pamphlet index 38601fea..e4dd5a8a 100644 --- a/src/interp/wi2.boot.pamphlet +++ b/src/interp/wi2.boot.pamphlet @@ -791,7 +791,7 @@ genDeltaEntry opMmPair == RPLACA(saveNRTdeltaListComp,compEntry) chk(saveNRTdeltaListComp,102) u := - [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == + [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() == (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 --n + 1 since $NRTdeltaLength is 1 too large $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] diff --git a/src/interp/xrun.boot b/src/interp/xrun.boot new file mode 100644 index 00000000..b6be04c5 --- /dev/null +++ b/src/interp/xrun.boot @@ -0,0 +1,496 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +$noSubsumption:=true +--$MERGELIB := nil +------- from nrunopt.boot ----------- + +--------------------> NEW DEFINITION (see nrunopt.boot.pamphlet) +NRTmakeCategoryAlist() == + $depthAssocCache: local := MAKE_-HASHTABLE 'ID + $catAncestorAlist: local := NIL + pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] + $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] + opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) + newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] + slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) + | (k := predicateBitIndex b) ^= -1] + slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] + sixEtc := [5 + i for i in 1..#$pairlis] + formals := ASSOCRIGHT $pairlis + for x in slot1 repeat + RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,formals),CAR x)) + -----------code to make a new style slot4 ----------------- + predList := ASSOCRIGHT slot1 --is list of predicate indices + maxPredList := "MAX"/predList + catformvec := ASSOCLEFT slot1 + maxElement := "MAX"/$byteVec + ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], + ['CONS, MKQ LIST2VEC slot0, + ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], + ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] + --NOTE: this is new form: old form satisfies VECP CDDR form + +--------------------> NEW DEFINITION (see nrunopt.boot.pamphlet) +encodeCatform x == + k := NRTassocIndex x => k + atom x or atom rest x => x + [first x,:[encodeCatform y for y in rest x]] + +------- from nrunfast.boot ----------- + +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +replaceGoGetSlot env == + [thisDomain,index,:op] := env + thisDomainForm := devaluate thisDomain + bytevec := getDomainByteVector thisDomain + numOfArgs := bytevec.index + goGetDomainSlotIndex := bytevec.(index := QSADD1 index) + goGetDomain := + goGetDomainSlotIndex = 0 => thisDomain + thisDomain.goGetDomainSlotIndex + if PAIRP goGetDomain then + goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) + sig := + [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) + for i in 0..numOfArgs] + thisSlot := bytevec.(QSADD1 index) + if $monitorNewWorld then + sayLooking(concat('"%l","..",form2String thisDomainForm, + '" wants",'"%l",'" "),op,sig,goGetDomain) + slot := basicLookup(op,sig,goGetDomain,goGetDomain) + slot = nil => + $returnNowhereFromGoGet = true => + ['nowhere,:goGetDomain] --see newGetDomainOpTable + sayBrightly concat('"Function: ",formatOpSignature(op,sig), + '" is missing from domain: ",form2String goGetDomain.0) + keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) + if $monitorNewWorld then + sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) + SETELT(thisDomain,thisSlot,slot) + if $monitorNewWorld then + sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) + slot + +--======================================================= +-- Expand Signature from Encoded Slot Form +--======================================================= +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +newExpandGoGetTypeSlot(slot,dollar,domain) == + newExpandTypeSlot(slot,domain,domain) + +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +newExpandTypeSlot(slot, dollar, domain) == +--> returns domain form for dollar.slot + newExpandLocalType(sigDomainVal(dollar, domain, slot), dollar,domain) + + +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +newExpandLocalType(lazyt,dollar,domain) == + VECP lazyt => lazyt.0 + ATOM lazyt => lazyt + lazyt is [vec,.,:lazyForm] and VECP vec => --old style + newExpandLocalTypeForm(lazyForm,dollar,domain) + newExpandLocalTypeForm(lazyt,dollar,domain) --new style + +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +newExpandLocalTypeForm([functorName,:argl],dollar,domain) == + MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => + [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] + for [.,tag,dom] in argl]] + MEMQ(functorName, '(Union Mapping)) => + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] + functorName = 'QUOTE => [functorName,:argl] + coSig := GETDATABASE(functorName,'COSIG) + NULL coSig => error ["bad functorName", functorName] + [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) + for a in argl for flag in rest coSig]] + +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == + u = '$ => u + INTEGERP u => + typeFlag => newExpandTypeSlot(u, dollar,domain) + domain.u + u is ['NRTEVAL,y] => nrtEval(y,domain) + u is ['QUOTE,y] => y + u = "$$" => domain.0 + atom u => u --can be first, rest, etc. + newExpandLocalTypeForm(u,dollar,domain) + +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +nrtEval(expr,dom) == + $:fluid := dom + eval expr + +sigDomainVal(dollar,domain,index) == +--returns a domain or a lazy slot + index = 0 => "$" + index = 2 => domain + domain.index + +--------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) +lazyMatchArg2(s,a,dollar,domain,typeFlag) == + if s = '$ then +-- a = 0 => return true --needed only if extra call in newGoGet to basicLookup + s := devaluate dollar -- calls from HasCategory can have $s + INTEGERP a => + not typeFlag => s = domain.a + a = 6 and $isDefaultingPackage => s = devaluate dollar + VECP (d := domainVal(dollar,domain,a)) => + s = d.0 => true + domainArg := ($isDefaultingPackage => domain.6.0; domain.0) + KAR s = QCAR d.0 and + lazyMatchArgDollarCheck(replaceSharpCalls s,d.0,dollar.0,domainArg) + --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) + lazyMatch(replaceSharpCalls s,d,dollar,domain) --new style + a = '$ => s = devaluate dollar + a = "$$" => s = devaluate domain + STRINGP a => + STRINGP s => a = s + s is ['QUOTE,y] and PNAME y = a + IDENTP s and PNAME s = a + atom a => a = s + op := opOf a + op = 'NRTEVAL => s = nrtEval(CADR a,domain) + op = 'QUOTE => s = CADR a + lazyMatch(s,a,dollar,domain) + --above line is temporarily necessary until system is compiled 8/15/90 +--s = a + +------- from template.boot ----------- + +--------------------> NEW DEFINITION (see template.boot.pamphlet) +evalSlotDomain(u,dollar) == + $returnNowhereFromGoGet: local := false + $ : fluid := dollar + $lookupDefaults : local := nil -- new world + u = '$ => dollar + u = "$$" => dollar + FIXP u => + VECP (y := dollar.u) => y + y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? + y is [v,:.] => + VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt] + constructor? v or MEMQ(v,'(Record Union Mapping)) => + lazyDomainSet(y,dollar,u) --new style has lazyt + y + y + u is ['NRTEVAL,y] => eval y + u is ['QUOTE,y] => y + u is ['Record,:argl] => + FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] + for [.,tag,dom] in argl]) + u is ['Union,:argl] and first argl is ['_:,.,.] => + APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] + for [.,tag,dom] in argl]) + u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) + systemErrorHere '"evalSlotDomain" + + +------- from nrungo.boot ----------- + +--------------------> NEW DEFINITION (see nrungo.boot.pamphlet) +lazyCompareSigEqual(s,tslot,dollar,domain) == + tslot = '$ => s = tslot -- devaluate dollar --needed for browser + INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s => + lazyt is [.,.,.,[.,item,.]] and + item is [.,[functorName,:.]] and functorName = CAR s => + compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain) + nil + compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) + +------- from i-funsel.boot ----------- + +--------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) +findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) == + -- looks for a modemap for op with signature args1 -> tar + -- in the domain of computation dc + -- tar may be NIL (= unknown) + null isLegitimateMode(tar, nil, nil) => nil + dcName:= CAR dc + member(dcName,'(Union Record Mapping Enumeration)) => + -- First cut code that ignores args2, $Coerce and $SubDom + -- When domains no longer have to have Set, the hard coded 6 and 7 + -- should go. + op = '_= => + #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL + tar and tar ^= '(Boolean) => NIL + [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]] + op = 'coerce => + #args1 ^= 1 + dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> + [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] + args1.0 ^= dc => NIL + tar and tar ^= $Expression => NIL + [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]] + member(dcName,'(Record Union)) => + findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) + NIL + fun:= NIL + ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and + SL := constructSubst dc + -- if the arglist is homogeneous, first look for homogeneous + -- functions. If we don't find any, look at remaining ones + if isHomogeneousList args1 then + q := NIL + r := NIL + for mm in CDR p repeat + -- CDAR of mm is the signature argument list + if isHomogeneousList CDAR mm then q := [mm,:q] + else r := [mm,:r] + q := allOrMatchingMms(q,args1,tar,dc) + for mm in q repeat + fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) + r := reverse r + else r := CDR p + r := allOrMatchingMms(r,args1,tar,dc) + if not fun then -- consider remaining modemaps + for mm in r repeat + fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) + if not fun and $reportBottomUpFlag then + sayMSG concat + ['" -> no appropriate",:bright op,'"found in", + :bright prefix2String dc] + fun + +--------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) +findFunctionInDomain1(omm,op,tar,args1,args2,SL) == + dc:= CDR (dollarPair := ASSQ('$,SL)) + -- need to drop '$ from SL + mm:= subCopy(omm, SL) + -- tests whether modemap mm is appropriate for the function + -- defined by op, target type tar and argument types args + $RTC:local:= NIL + -- $RTC is a list of run-time checks to be performed + + [sig,slot,cond,y] := mm + [osig,:.] := omm + osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL)) + if CONTAINED('_#, sig) or CONTAINED('construct,sig) then + sig := [replaceSharpCalls t for t in sig] + matchMmCond cond and matchMmSig(mm,tar,args1,args2) and + EQ(y,'Subsumed) and + -- hmmmm: do Union check in following because (as in DP) + -- Unions are subsumed by total modemaps which are in the + -- mm list in findFunctionInDomain. + y := 'ELT -- if subsumed fails try it again + not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and + (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f + EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]] + EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]] + EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]] + y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]] + sayKeyedMsg("S2IF0006",[y]) + NIL + +--------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) +findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) == + -- looks for a modemap for op with signature args1 -> tar + -- in the domain of computation dc + -- tar may be NIL (= unknown) + dcName:= CAR dc + not MEMQ(dcName,'(Record Union Enumeration)) => NIL + fun:= NIL + -- cat := constructorCategory dc + makeFunc := GETL(dcName,"makeFunctionList") or + systemErrorHere '"findFunctionInCategory" + [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) + -- get list of implementations and remove sharps + maxargs := -1 + impls := nil + for [a,b,d] in funlist repeat + not EQ(a,op) => nil + d is ['XLAM,xargs,:.] => + if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) + else maxargs := MAX(maxargs,1) + impls := cons([b,nil,true,d],impls) + impls := cons([b,d,true,d],impls) + impls := NREVERSE impls + if maxargs ^= -1 then + SL:= NIL + for i in 1..maxargs repeat + impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls) + impls and + SL:= constructSubst dc + for mm in impls repeat + fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) + if not fun and $reportBottomUpFlag then + sayMSG concat + ['" -> no appropriate",:bright op,'"found in", + :bright prefix2String dc] + fun + +------- from i-eval.boot ----------- + +--------------------> NEW DEFINITION (see i-eval.boot.pamphlet) +evalForm(op,opName,argl,mmS) == + -- applies the first applicable function + for mm in mmS until form repeat + [sig,fun,cond]:= mm + (CAR sig) = 'interpOnly => form := CAR sig + #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 + form:= + $genValue or null cond => + [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig] + [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL + for x in argl for t in CDDR sig for c in cond] + form or null argl => + dc:= CAR sig + form := + dc='local => --[fun,:form] + atom fun => + fun in $localVars => ['SPADCALL,:form,fun] + [fun,:form,NIL] + ['SPADCALL,:form,fun] + dc is ["__FreeFunction__",:freeFun] => + ['SPADCALL,:form,freeFun] + fun is ['XLAM,xargs,:xbody] => + rec := first form + xbody is [['RECORDELT,.,ind,len]] => + optRECORDELT([CAAR xbody,rec,ind,len]) + xbody is [['SETRECORDELT,.,ind,len,.]] => + optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) + xbody is [['RECORDCOPY,.,len]] => + optRECORDCOPY([CAAR xbody,rec,len]) + ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] + dcVector := evalDomain dc + fun0 := + newType? CAAR mm => + mm' := first ncSigTransform mm + ncGetFunction(opName, first mm', rest mm') + NRTcompileEvalForm(opName,fun,dcVector) + null fun0 => throwKeyedMsg("S2IE0008",[opName]) + [bpi,:domain] := fun0 + EQ(bpi,function Undef) => + sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) + NIL + if $NRTmonitorIfTrue = true then + sayBrightlyNT ['"Applying ",first fun0,'" to:"] + pp [devaluateDeeply x for x in form] + _$:fluid := domain + ['SPADCALL, :form, fun0] + not form => nil +-- not form => throwKeyedMsg("S2IE0008",[opName]) + form='interpOnly => rewriteMap(op,opName,argl) + targetType := CADR sig + if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType + evalFormMkValue(op,form,targetType) + +------- from clammed.boot ----------- + +--------------------> NEW DEFINITION (see interop.boot.pamphlet) +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 + +------- from i-coerce.boot ----------- + +--------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) +coerceByFunction(T,m2) == + -- using the new modemap selection without coercions + -- should not be called by canCoerceFrom + x := objVal T + x = '_$fromCoerceable_$ => NIL + m2 is ['Union,:.] => NIL + m1 := objMode T + m2 is ['Boolean,:.] and m1 is ['Equation,ud] => + dcVector := evalDomain ud + fun := + isWrapped x => + NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector) + NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector) + [fn,:d]:= fun + isWrapped x => + x:= unwrap x + mkObjWrap(SPADCALL(CAR x,CDR x,fun),m2) + x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL) + code := ['SPADCALL, a, b, fun] + objNew(code,$Boolean) + -- If more than one function is found, any should suffice, I think -scm + if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then + mm := coerceConvertMmSelection(funName := 'convert,m1,m2) + mm => + [[dc,tar,:args],slot,.]:= mm + dcVector := evalDomain(dc) + fun:= +--+ + isWrapped x => + NRTcompiledLookup(funName,slot,dcVector) + NRTcompileEvalForm(funName,slot,dcVector) + [fn,:d]:= fun + fn = function Undef => NIL + isWrapped x => +--+ + $: fluid := dcVector + val := CATCH('coerceFailure, SPADCALL(unwrap x,fun)) + (val = $coerceFailure) => NIL + objNewWrap(val,m2) + env := fun + code := ['failCheck, ['SPADCALL, x, env]] +-- tar is ['Union,:.] => objNew(['failCheck,code],m2) + objNew(code,m2) + -- try going back to types like RN instead of QF I + m1' := eqType m1 + m2' := eqType m2 + (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2') + NIL + +--------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) +equalOne(object, domain) == + -- tries using constant One and "=" from domain + -- object should not be wrapped + algEqual(object, getConstantFromDomain('(One),domain), domain) + +--------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) +equalZero(object, domain) == + -- tries using constant Zero and "=" from domain + -- object should not be wrapped + algEqual(object, getConstantFromDomain('(Zero),domain), domain) + +--------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) +algEqual(object1, object2, domain) == + -- sees if 2 objects of the same domain are equal by using the + -- "=" from the domain + -- objects should not be wrapped +-- eqfunc := getFunctionFromDomain("=",domain,[domain,domain]) + eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain) + SPADCALL(object1,object2, eqfunc) diff --git a/src/interp/xrun.boot.pamphlet b/src/interp/xrun.boot.pamphlet deleted file mode 100644 index 9dcc9040..00000000 --- a/src/interp/xrun.boot.pamphlet +++ /dev/null @@ -1,518 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp xrun.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\section{License} -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -)package "BOOT" - -$noSubsumption:=true ---$MERGELIB := nil -------- from nrunopt.boot ----------- - ---------------------> NEW DEFINITION (see nrunopt.boot.pamphlet) -NRTmakeCategoryAlist() == - $depthAssocCache: local := MAKE_-HASHTABLE 'ID - $catAncestorAlist: local := NIL - pcAlist := [:[[x,:'T] for x in $uncondAlist],:$condAlist] - $levelAlist: local := depthAssocList [CAAR x for x in pcAlist] - opcAlist := NREVERSE SORTBY(function NRTcatCompare,pcAlist) - newPairlis := [[5 + i,:b] for [.,:b] in $pairlis for i in 1..] - slot1 := [[a,:k] for [a,:b] in SUBLIS($pairlis,opcAlist) - | (k := predicateBitIndex b) ^= -1] - slot0 := [hasDefaultPackage opOf a for [a,:b] in slot1] - sixEtc := [5 + i for i in 1..#$pairlis] - formals := ASSOCRIGHT $pairlis - for x in slot1 repeat - RPLACA(x,EQSUBSTLIST(CONS("$$",sixEtc),CONS('$,formals),CAR x)) - -----------code to make a new style slot4 ----------------- - predList := ASSOCRIGHT slot1 --is list of predicate indices - maxPredList := "MAX"/predList - catformvec := ASSOCLEFT slot1 - maxElement := "MAX"/$byteVec - ['CONS, ['makeByteWordVec2,MAX(maxPredList,1),MKQ predList], - ['CONS, MKQ LIST2VEC slot0, - ['CONS, MKQ LIST2VEC [encodeCatform x for x in catformvec], - ['makeByteWordVec2,maxElement,MKQ $byteVec]]]] - --NOTE: this is new form: old form satisfies VECP CDDR form - ---------------------> NEW DEFINITION (see nrunopt.boot.pamphlet) -encodeCatform x == - k := NRTassocIndex x => k - atom x or atom rest x => x - [first x,:[encodeCatform y for y in rest x]] - -------- from nrunfast.boot ----------- - ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -replaceGoGetSlot env == - [thisDomain,index,:op] := env - thisDomainForm := devaluate thisDomain - bytevec := getDomainByteVector thisDomain - numOfArgs := bytevec.index - goGetDomainSlotIndex := bytevec.(index := QSADD1 index) - goGetDomain := - goGetDomainSlotIndex = 0 => thisDomain - thisDomain.goGetDomainSlotIndex - if PAIRP goGetDomain then - goGetDomain := lazyDomainSet(goGetDomain,thisDomain,goGetDomainSlotIndex) - sig := - [newExpandTypeSlot(bytevec.(index := QSADD1 index),thisDomain,thisDomain) - for i in 0..numOfArgs] - thisSlot := bytevec.(QSADD1 index) - if $monitorNewWorld then - sayLooking(concat('"%l","..",form2String thisDomainForm, - '" wants",'"%l",'" "),op,sig,goGetDomain) - slot := basicLookup(op,sig,goGetDomain,goGetDomain) - slot = nil => - $returnNowhereFromGoGet = true => - ['nowhere,:goGetDomain] --see newGetDomainOpTable - sayBrightly concat('"Function: ",formatOpSignature(op,sig), - '" is missing from domain: ",form2String goGetDomain.0) - keyedSystemError("S2NR0001",[op,sig,goGetDomain.0]) - if $monitorNewWorld then - sayLooking1(['"goget stuffing slot",:bright thisSlot,'"of "],thisDomain) - SETELT(thisDomain,thisSlot,slot) - if $monitorNewWorld then - sayLooking1('"<------",[CAR slot,:devaluate CDR slot]) - slot - ---======================================================= --- Expand Signature from Encoded Slot Form ---======================================================= ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -newExpandGoGetTypeSlot(slot,dollar,domain) == - newExpandTypeSlot(slot,domain,domain) - ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -newExpandTypeSlot(slot, dollar, domain) == ---> returns domain form for dollar.slot - newExpandLocalType(sigDomainVal(dollar, domain, slot), dollar,domain) - - ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -newExpandLocalType(lazyt,dollar,domain) == - VECP lazyt => lazyt.0 - ATOM lazyt => lazyt - lazyt is [vec,.,:lazyForm] and VECP vec => --old style - newExpandLocalTypeForm(lazyForm,dollar,domain) - newExpandLocalTypeForm(lazyt,dollar,domain) --new style - ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -newExpandLocalTypeForm([functorName,:argl],dollar,domain) == - MEMQ(functorName, '(Record Union)) and first argl is [":",:.] => - [functorName,:[['_:,tag,newExpandLocalTypeArgs(dom,dollar,domain,true)] - for [.,tag,dom] in argl]] - MEMQ(functorName, '(Union Mapping)) => - [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,true) for a in argl]] - functorName = 'QUOTE => [functorName,:argl] - coSig := GETDATABASE(functorName,'COSIG) - NULL coSig => error ["bad functorName", functorName] - [functorName,:[newExpandLocalTypeArgs(a,dollar,domain,flag) - for a in argl for flag in rest coSig]] - ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -newExpandLocalTypeArgs(u,dollar,domain,typeFlag) == - u = '$ => u - INTEGERP u => - typeFlag => newExpandTypeSlot(u, dollar,domain) - domain.u - u is ['NRTEVAL,y] => nrtEval(y,domain) - u is ['QUOTE,y] => y - u = "$$" => domain.0 - atom u => u --can be first, rest, etc. - newExpandLocalTypeForm(u,dollar,domain) - ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -nrtEval(expr,dom) == - $:fluid := dom - eval expr - -sigDomainVal(dollar,domain,index) == ---returns a domain or a lazy slot - index = 0 => "$" - index = 2 => domain - domain.index - ---------------------> NEW DEFINITION (see nrunfast.boot.pamphlet) -lazyMatchArg2(s,a,dollar,domain,typeFlag) == - if s = '$ then --- a = 0 => return true --needed only if extra call in newGoGet to basicLookup - s := devaluate dollar -- calls from HasCategory can have $s - INTEGERP a => - not typeFlag => s = domain.a - a = 6 and $isDefaultingPackage => s = devaluate dollar - VECP (d := domainVal(dollar,domain,a)) => - s = d.0 => true - domainArg := ($isDefaultingPackage => domain.6.0; domain.0) - KAR s = QCAR d.0 and - lazyMatchArgDollarCheck(replaceSharpCalls s,d.0,dollar.0,domainArg) - --VECP CAR d => lazyMatch(s,CDDR d,dollar,domain) --old style (erase) - lazyMatch(replaceSharpCalls s,d,dollar,domain) --new style - a = '$ => s = devaluate dollar - a = "$$" => s = devaluate domain - STRINGP a => - STRINGP s => a = s - s is ['QUOTE,y] and PNAME y = a - IDENTP s and PNAME s = a - atom a => a = s - op := opOf a - op = 'NRTEVAL => s = nrtEval(CADR a,domain) - op = 'QUOTE => s = CADR a - lazyMatch(s,a,dollar,domain) - --above line is temporarily necessary until system is compiled 8/15/90 ---s = a - -------- from template.boot ----------- - ---------------------> NEW DEFINITION (see template.boot.pamphlet) -evalSlotDomain(u,dollar) == - $returnNowhereFromGoGet: local := false - $ : fluid := dollar - $lookupDefaults : local := nil -- new world - u = '$ => dollar - u = "$$" => dollar - FIXP u => - VECP (y := dollar.u) => y - y is ['SETELT,:.] => eval y--lazy domains need to marked; this is dangerous? - y is [v,:.] => - VECP v => lazyDomainSet(y,dollar,u) --old style has [$,code,:lazyt] - constructor? v or MEMQ(v,'(Record Union Mapping)) => - lazyDomainSet(y,dollar,u) --new style has lazyt - y - y - u is ['NRTEVAL,y] => eval y - u is ['QUOTE,y] => y - u is ['Record,:argl] => - FUNCALL('Record0,[[tag,:evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) - u is ['Union,:argl] and first argl is ['_:,.,.] => - APPLY('Union,[['_:,tag,evalSlotDomain(dom,dollar)] - for [.,tag,dom] in argl]) - u is [op,:argl] => APPLY(op,[evalSlotDomain(x,dollar) for x in argl]) - systemErrorHere '"evalSlotDomain" - - -------- from nrungo.boot ----------- - ---------------------> NEW DEFINITION (see nrungo.boot.pamphlet) -lazyCompareSigEqual(s,tslot,dollar,domain) == - tslot = '$ => s = tslot -- devaluate dollar --needed for browser - INTEGERP tslot and PAIRP(lazyt:=domain.tslot) and PAIRP s => - lazyt is [.,.,.,[.,item,.]] and - item is [.,[functorName,:.]] and functorName = CAR s => - compareSigEqual(s,(NRTevalDomain lazyt).0,dollar,domain) - nil - compareSigEqual(s,NRTreplaceLocalTypes(tslot,domain),dollar,domain) - -------- from i-funsel.boot ----------- - ---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) -findFunctionInDomain(op,dc,tar,args1,args2,$Coerce,$SubDom) == - -- looks for a modemap for op with signature args1 -> tar - -- in the domain of computation dc - -- tar may be NIL (= unknown) - null isLegitimateMode(tar, nil, nil) => nil - dcName:= CAR dc - member(dcName,'(Union Record Mapping Enumeration)) => - -- First cut code that ignores args2, $Coerce and $SubDom - -- When domains no longer have to have Set, the hard coded 6 and 7 - -- should go. - op = '_= => - #args1 ^= 2 or args1.0 ^= dc or args1.1 ^= dc => NIL - tar and tar ^= '(Boolean) => NIL - [[[dc, '(Boolean), dc, dc], ['(Boolean),'$,'$], [NIL, NIL]]] - op = 'coerce => - #args1 ^= 1 - dcName='Enumeration and (args1.0=$Symbol or tar=dc)=> - [[[dc, dc, $Symbol], ['$,$Symbol], [NIL, NIL]]] - args1.0 ^= dc => NIL - tar and tar ^= $Expression => NIL - [[[dc, $Expression, dc], [$Expression,'$], [NIL, NIL]]] - member(dcName,'(Record Union)) => - findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) - NIL - fun:= NIL - ( p := ASSQ(op,getOperationAlistFromLisplib dcName) ) and - SL := constructSubst dc - -- if the arglist is homogeneous, first look for homogeneous - -- functions. If we don't find any, look at remaining ones - if isHomogeneousList args1 then - q := NIL - r := NIL - for mm in CDR p repeat - -- CDAR of mm is the signature argument list - if isHomogeneousList CDAR mm then q := [mm,:q] - else r := [mm,:r] - q := allOrMatchingMms(q,args1,tar,dc) - for mm in q repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - r := reverse r - else r := CDR p - r := allOrMatchingMms(r,args1,tar,dc) - if not fun then -- consider remaining modemaps - for mm in r repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - if not fun and $reportBottomUpFlag then - sayMSG concat - ['" -> no appropriate",:bright op,'"found in", - :bright prefix2String dc] - fun - ---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) -findFunctionInDomain1(omm,op,tar,args1,args2,SL) == - dc:= CDR (dollarPair := ASSQ('$,SL)) - -- need to drop '$ from SL - mm:= subCopy(omm, SL) - -- tests whether modemap mm is appropriate for the function - -- defined by op, target type tar and argument types args - $RTC:local:= NIL - -- $RTC is a list of run-time checks to be performed - - [sig,slot,cond,y] := mm - [osig,:.] := omm - osig := subCopy(osig, SUBSTQ(CONS('$,'$), dollarPair, SL)) - if CONTAINED('_#, sig) or CONTAINED('construct,sig) then - sig := [replaceSharpCalls t for t in sig] - matchMmCond cond and matchMmSig(mm,tar,args1,args2) and - EQ(y,'Subsumed) and - -- hmmmm: do Union check in following because (as in DP) - -- Unions are subsumed by total modemaps which are in the - -- mm list in findFunctionInDomain. - y := 'ELT -- if subsumed fails try it again - not $SubDom and CAR sig isnt ['Union,:.] and slot is [tar,:args] and - (f := findFunctionInDomain(op,dc,tar,args,args,NIL,NIL)) => f - EQ(y,'ELT) => [[CONS(dc,sig),osig,nreverse $RTC]] - EQ(y,'CONST) => [[CONS(dc,sig),osig,nreverse $RTC]] - EQ(y,'ASCONST) => [[CONS(dc,sig),osig,nreverse $RTC]] - y is ['XLAM,:.] => [[CONS(dc,sig),y,nreverse $RTC]] - sayKeyedMsg("S2IF0006",[y]) - NIL - ---------------------> NEW DEFINITION (see i-funsel.boot.pamphlet) -findFunctionInCategory(op,dc,tar,args1,args2,$Coerce,$SubDom) == - -- looks for a modemap for op with signature args1 -> tar - -- in the domain of computation dc - -- tar may be NIL (= unknown) - dcName:= CAR dc - not MEMQ(dcName,'(Record Union Enumeration)) => NIL - fun:= NIL - -- cat := constructorCategory dc - makeFunc := GETL(dcName,"makeFunctionList") or - systemErrorHere '"findFunctionInCategory" - [funlist,.] := FUNCALL(makeFunc,"$",dc,$CategoryFrame) - -- get list of implementations and remove sharps - maxargs := -1 - impls := nil - for [a,b,d] in funlist repeat - not EQ(a,op) => nil - d is ['XLAM,xargs,:.] => - if PAIRP(xargs) then maxargs := MAX(maxargs,#xargs) - else maxargs := MAX(maxargs,1) - impls := cons([b,nil,true,d],impls) - impls := cons([b,d,true,d],impls) - impls := NREVERSE impls - if maxargs ^= -1 then - SL:= NIL - for i in 1..maxargs repeat - impls := SUBSTQ(GENSYM(),INTERNL('"#",STRINGIMAGE i),impls) - impls and - SL:= constructSubst dc - for mm in impls repeat - fun:= nconc(fun,findFunctionInDomain1(mm,op,tar,args1,args2,SL)) - if not fun and $reportBottomUpFlag then - sayMSG concat - ['" -> no appropriate",:bright op,'"found in", - :bright prefix2String dc] - fun - -------- from i-eval.boot ----------- - ---------------------> NEW DEFINITION (see i-eval.boot.pamphlet) -evalForm(op,opName,argl,mmS) == - -- applies the first applicable function - for mm in mmS until form repeat - [sig,fun,cond]:= mm - (CAR sig) = 'interpOnly => form := CAR sig - #argl ^= #CDDR sig => 'skip ---> RDJ 6/95 - form:= - $genValue or null cond => - [getArgValue2(x,t,sideEffectedArg?(t,sig,opName),opName) or return NIL - for x in argl for t in CDDR sig] - [getArgValueComp2(x,t,c,sideEffectedArg?(t,sig,opName),opName) or return NIL - for x in argl for t in CDDR sig for c in cond] - form or null argl => - dc:= CAR sig - form := - dc='local => --[fun,:form] - atom fun => - fun in $localVars => ['SPADCALL,:form,fun] - [fun,:form,NIL] - ['SPADCALL,:form,fun] - dc is ["__FreeFunction__",:freeFun] => - ['SPADCALL,:form,freeFun] - fun is ['XLAM,xargs,:xbody] => - rec := first form - xbody is [['RECORDELT,.,ind,len]] => - optRECORDELT([CAAR xbody,rec,ind,len]) - xbody is [['SETRECORDELT,.,ind,len,.]] => - optSETRECORDELT([CAAR xbody,rec,ind,len,CADDR form]) - xbody is [['RECORDCOPY,.,len]] => - optRECORDCOPY([CAAR xbody,rec,len]) - ['FUNCALL,['function , ['LAMBDA,xargs,:xbody]],:TAKE(#xargs, form)] - dcVector := evalDomain dc - fun0 := - newType? CAAR mm => - mm' := first ncSigTransform mm - ncGetFunction(opName, first mm', rest mm') - NRTcompileEvalForm(opName,fun,dcVector) - null fun0 => throwKeyedMsg("S2IE0008",[opName]) - [bpi,:domain] := fun0 - EQ(bpi,function Undef) => - sayKeyedMsg("S2IE0009",[opName,formatSignature CDR sig,CAR sig]) - NIL - if $NRTmonitorIfTrue = true then - sayBrightlyNT ['"Applying ",first fun0,'" to:"] - pp [devaluateDeeply x for x in form] - _$:fluid := domain - ['SPADCALL, :form, fun0] - not form => nil --- not form => throwKeyedMsg("S2IE0008",[opName]) - form='interpOnly => rewriteMap(op,opName,argl) - targetType := CADR sig - if CONTAINED('_#,targetType) then targetType := NRTtypeHack targetType - evalFormMkValue(op,form,targetType) - -------- from clammed.boot ----------- - ---------------------> NEW DEFINITION (see interop.boot.pamphlet) -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 - -------- from i-coerce.boot ----------- - ---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) -coerceByFunction(T,m2) == - -- using the new modemap selection without coercions - -- should not be called by canCoerceFrom - x := objVal T - x = '_$fromCoerceable_$ => NIL - m2 is ['Union,:.] => NIL - m1 := objMode T - m2 is ['Boolean,:.] and m1 is ['Equation,ud] => - dcVector := evalDomain ud - fun := - isWrapped x => - NRTcompiledLookup("=", [$Boolean, '$, '$], dcVector) - NRTcompileEvalForm("=", [$Boolean, '$, '$], dcVector) - [fn,:d]:= fun - isWrapped x => - x:= unwrap x - mkObjWrap(SPADCALL(CAR x,CDR x,fun),m2) - x isnt ['SPADCALL,a,b,:.] => keyedSystemError("S2IC0015",NIL) - code := ['SPADCALL, a, b, fun] - objNew(code,$Boolean) - -- If more than one function is found, any should suffice, I think -scm - if not (mm := coerceConvertMmSelection(funName := 'coerce,m1,m2)) then - mm := coerceConvertMmSelection(funName := 'convert,m1,m2) - mm => - [[dc,tar,:args],slot,.]:= mm - dcVector := evalDomain(dc) - fun:= ---+ - isWrapped x => - NRTcompiledLookup(funName,slot,dcVector) - NRTcompileEvalForm(funName,slot,dcVector) - [fn,:d]:= fun - fn = function Undef => NIL - isWrapped x => ---+ - $: fluid := dcVector - val := CATCH('coerceFailure, SPADCALL(unwrap x,fun)) - (val = $coerceFailure) => NIL - objNewWrap(val,m2) - env := fun - code := ['failCheck, ['SPADCALL, x, env]] --- tar is ['Union,:.] => objNew(['failCheck,code],m2) - objNew(code,m2) - -- try going back to types like RN instead of QF I - m1' := eqType m1 - m2' := eqType m2 - (m1 ^= m1') or (m2 ^= m2') => coerceByFunction(objNew(x,m1'),m2') - NIL - ---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) -equalOne(object, domain) == - -- tries using constant One and "=" from domain - -- object should not be wrapped - algEqual(object, getConstantFromDomain('(One),domain), domain) - ---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) -equalZero(object, domain) == - -- tries using constant Zero and "=" from domain - -- object should not be wrapped - algEqual(object, getConstantFromDomain('(Zero),domain), domain) - ---------------------> NEW DEFINITION (see i-coerce.boot.pamphlet) -algEqual(object1, object2, domain) == - -- sees if 2 objects of the same domain are equal by using the - -- "=" from the domain - -- objects should not be wrapped --- eqfunc := getFunctionFromDomain("=",domain,[domain,domain]) - eqfunc := compiledLookupCheck("=",[$Boolean,'$,'$],evalDomain domain) - SPADCALL(object1,object2, eqfunc) -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/xruncomp.boot b/src/interp/xruncomp.boot new file mode 100644 index 00000000..4b558a3e --- /dev/null +++ b/src/interp/xruncomp.boot @@ -0,0 +1,330 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +)package "BOOT" + +------- from info.boot ----------- + +-- modemap is of the form : ((op (targ arg1 arg2 ... argn)) pred (elt $ n)) + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +evalAndSub(domainName,viewName,functorForm,form,$e) == + $lhsOfColon: local:= domainName + isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] + --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 + if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) + opAlist:= getOperationAlist(domainName,functorForm,form) + substAlist:= substNames(domainName,viewName,functorForm,opAlist) + [substAlist,$e] + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +substNames(domainName,viewName,functorForm,opalist) == + functorForm := SUBSTQ("$$","$", functorForm) + nameForDollar := + isCategoryPackageName functorForm => CADR functorForm + domainName + + -- following calls to SUBSTQ must copy to save RPLAC's in + -- putInLocalDomainReferences + [[:SUBSTQ("$","$$",SUBSTQ(nameForDollar,"$",modemapform)), + [sel, viewName,if domainName = "$" then pos else + CADAR modemapform]] + for [:modemapform,[sel,"$",pos]] in + EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, opalist)] + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +addModemap1(op,mc,sig,pred,fn,e) == + --mc is the "mode of computation"; fn the "implementation" + if mc='Rep then +-- if fn is [kind,'Rep,.] and + -- save old sig for NRUNTIME +-- (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] + sig:= substitute("$",'Rep,sig) + currentProplist:= getProplist(op,e) or nil + newModemapList:= + mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) + newProplist:= augProplist(currentProplist,'modemap,newModemapList) + newProplist':= augProplist(newProplist,"FLUID",true) + unErrorRef op + --There may have been a warning about op having no value + addBinding(op,newProplist',e) + +--------------------> NEW DEFINITION (see modemap.boot.pamphlet) +addConstructorModemaps(name,form is [functorName,:.],e) == + $InteractiveMode: local:= nil + e:= putDomainsInScope(name,e) --frame + fn := GETL(functorName,"makeFunctionList") + [funList,e]:= FUNCALL(fn,name,form,e) + for [op,sig,opcode] in funList repeat + if opcode is [sel,dc,n] and sel='ELT then + nsig := substitute("$$$",name,sig) + nsig := substitute('$,"$$$",substitute("$$",'$,nsig)) + opcode := [sel,dc,nsig] + e:= addModemap(op,name,sig,true,opcode,e) + e + +------- from info.boot ----------- + +--------------------> NEW DEFINITION (see info.boot.pamphlet) +actOnInfo(u,$e) == + null u => $e + u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) + $e:= + put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e + ) + u is ["COND",:l] => + --there is nowhere %else that this sort of thing exists + for [ante,:conseq] in l repeat + if member(hasToInfo ante,Info) then for v in conseq repeat + $e:= actOnInfo(v,$e) + $e + u is ["ATTRIBUTE",name,att] => + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["ATTRIBUTE",att]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + --there is nowhere %else that this sort of thing exists + u is ["SIGNATURE",name,operator,modemap] => + implem:= + (implem:=ASSOC([name,:modemap],get(operator,'modemap,$e))) => + CADADR implem + name = "$" => ['ELT,name,-1] + ['ELT,name,substitute('$,name,modemap)] + $e:= addModemap(operator,name,modemap,true,implem,$e) + [vval,vmode,venv]:= GetValue name + SAY("augmenting ",name,": ",u) + key:= if CONTAINED("$",vmode) then "domain" else name + cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap]] + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + u is ["has",name,cat] => + [vval,vmode,venv]:= GetValue name + cat=vmode => $e --stating the already known + u:= compMakeCategoryObject(cat,$e) => + --we are adding information about a category + [catvec,.,$e]:= u + [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) + -- member(vmode,CAR catvec.4) => + -- JHD 82/08/08 01:40 This does not mean that we can ignore the + -- extension, since this may not be compatible with the view we + -- were passed + + --we are adding a principal descendant of what was already known + -- $e:= augModemapsFromCategory(name,name,nil,catvec,$e) + -- SAY("augmenting ",name,": ",cat) + -- put(name, "value", (vval, cat, venv), $e) + member(cat,first ocatvec.4) or + ASSOC(cat,CADR ocatvec.4) is [.,"T",.] => $e + --SAY("Category extension error: + --cat shouldn't be a join + --what was being asserted is an ancestor of what was known + if name="$" + then $e:= augModemapsFromCategory(name,name,name,cat,$e) + else + viewName:=genDomainViewName(name,cat) + genDomainView(viewName,name,cat,"HasCategory") + if not MEMQ(viewName,$functorLocalParameters) then + $functorLocalParameters:=[:$functorLocalParameters,viewName] + SAY("augmenting ",name,": ",cat) + $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) + SAY("extension of ",vval," to ",cat," ignored") + $e + systemError '"knownInfo" + +------- from nruncomp.boot ----------- + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +genDeltaEntry opMmPair == +--called from compApplyModemap +--$NRTdeltaLength=0.. always equals length of $NRTdeltaList + [.,[odc,:.],.] := opMmPair + --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) + [op,[dc,:sig],[.,cform:=[eltOrConst,.,nsig]]] := opMmPair + if $profileCompiler = true then profileRecord(dc,op,sig) + eltOrConst = 'XLAM => cform + if eltOrConst = 'Subsumed then eltOrConst := 'ELT + if atom dc then + dc = "$" => nsig := sig + if NUMBERP nsig then nsig := substitute('$,dc,substitute("$$","$",sig)) + -- following hack needed to invert Rep to $ substitution +-- if odc = 'Rep and cform is [.,.,osig] then sig:=osig + newimp := optDeltaEntry(op,nsig,dc,eltOrConst) => newimp + setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => + ['applyFun,['compiledLookupCheck,MKQ op, + mkList consSig(nsig,dc),consDomainForm(dc,nil)]] + odc := dc + if null atom dc then dc := substitute("$$",'$,dc) + -- sig := substitute('$,dc,sig) + -- cform := substitute('$,dc,cform) + opModemapPair := + [op,[dc,:[genDeltaSig x for x in nsig]],["T",cform]] -- force pred to T + if null NRTassocIndex dc and dc ^= $NRTaddForm and + (member(dc,$functorLocalParameters) or null atom dc) then + --create "domain" entry to $NRTdeltaList + $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] + saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + compEntry:= (compOrCroak(odc,$EmptyMode,$e)).expr +-- dc + RPLACA(saveNRTdeltaListComp,compEntry) + u := + [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index() == + (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 + --n + 1 since $NRTdeltaLength is 1 too large + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + 0 + u + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == + --converts a domain form to a lazy domain form; everything other than + --the operation name should be assigned a slot + null firstTime and (k:= NRTassocIndex x) => k + VECP x => systemErrorHere '"NRTencode" + PAIRP x => + QCAR x='Record or x is ['Union,['_:,a,b],:.] => + [QCAR x,:[['_:,a,encode(b,c,false)] + for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] + constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => + [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] + ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] + MEMQ(x,$formalArgList) => + v := $FormalMapVariableList.(POSN1(x,$formalArgList)) + firstTime => ["local",v] + v + x = '$ => x + x = "$$" => x + ['QUOTE,x] + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +consDomainName(x,dc) == + x = dc => ''$ + x = '$ => ''$ + x = "$$" => ['devaluate,'$] + x is [op,:argl] => + (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => + mkList [MKQ op, + :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)] + for [.,tag,dom] in argl]] + isFunctor op or op = 'Mapping or constructor? op => + -- call to constructor? needed if op was compiled in $bootStrapMode + mkList [MKQ op,:[consDomainName(y,dc) for y in argl]] + substitute('$,"$$",x) + x = [] => x + (y := LASSOC(x,$devaluateList)) => y + k:=NRTassocIndex x => + ['devaluate,['ELT,'$,k]] + get(x,'value,$e) => + isDomainForm(x,$e) => ['devaluate,x] + x + MKQ x + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +NRTassignCapsuleFunctionSlot(op,sig) == +--called from compDefineCapsuleFunction + opSig := [op,sig] + [.,.,implementation] := NRTisExported? opSig or return nil + --if opSig is not exported, it is local and need not be assigned + if $insideCategoryPackageIfTrue then + sig := substitute('$,CADR($functorForm),sig) + sig := [genDeltaSig x for x in sig] + opModemapPair := [op,['_$,:sig],["T",implementation]] + POSN1(opModemapPair,$NRTdeltaList) => nil --already there + $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] + $NRTdeltaListComp := [nil,:$NRTdeltaListComp] + $NRTdeltaLength := $NRTdeltaLength+1 + +--------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) +changeDirectoryInSlot1() == --called by NRTbuildFunctor + --3 cases: + -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs + -- otherwise called from compFunctorBody (all lookups are forwarded): + -- $NRTdeltaList = nil ===> all slot numbers become nil + $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where + sigloc [opsig,pred,fnsel] == + if pred ^= 'T then + pred := simpBool pred + $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) + fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) => + if $insideCategoryPackageIfTrue then + opsig := substitute('$,CADR($functorForm),opsig) + [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]] + [opsig,pred,fnsel] + sortedOplist := listSort(function GLESSEQP, + COPY_-LIST $lisplibOperationAlist,function CADR) + $lastPred :local := nil + $newEnv :local := $e + $domainShell.1 := [fn entry for entry in sortedOplist] where + fn [[op,sig],pred,fnsel] == + if $lastPred ^= pred then + $newEnv := deepChaseInferences(pred,$e) + $lastPred := pred + newfnsel := + fnsel is ['Subsumed,op1,sig1] => + ['Subsumed,op1,genSlotSig(sig1,"T",$newEnv)] + fnsel + [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] + +------- from compiler.boot ----------- + +--------------------> NEW DEFINITION (see compiler.boot.pamphlet) +getFormModemaps(form is [op,:argl],e) == + op is ["elt",domain,op1] => + [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] + null atom op => nil + modemapList:= get(op,"modemap",e) + if $insideCategoryPackageIfTrue then + modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ^= '$] + if op="elt" + then modemapList:= eltModemapFilter(LAST argl,modemapList,e) or return nil + else + if op="setelt" then modemapList:= + seteltModemapFilter(CADR argl,modemapList,e) or return nil + nargs:= #argl + finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs] + modemapList and null finalModemapList => + stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] + finalModemapList + +------- from functor.boot ----------- + +--------------------> NEW DEFINITION (see functor.boot.pamphlet) +LookUpSigSlots(sig,siglist) == +--+ must kill any implementations below of the form (ELT $ NIL) + if $insideCategoryPackageIfTrue then + sig := substitute('$,CADR($functorForm),sig) + siglist := $lisplibOperationAlist + REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) + and KADDR implem] + diff --git a/src/interp/xruncomp.boot.pamphlet b/src/interp/xruncomp.boot.pamphlet deleted file mode 100644 index 3d8c2c55..00000000 --- a/src/interp/xruncomp.boot.pamphlet +++ /dev/null @@ -1,354 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/xruncomp.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ -<<*>>= -<> - -------- from info.boot ----------- - --- modemap is of the form : ((op (targ arg1 arg2 ... argn)) pred (elt $ n)) - ---------------------> NEW DEFINITION (see modemap.boot.pamphlet) -evalAndSub(domainName,viewName,functorForm,form,$e) == - $lhsOfColon: local:= domainName - isCategory form => [substNames(domainName,viewName,functorForm,form.(1)),$e] - --next lines necessary-- see MPOLY for which $ is actual arg. --- RDJ 3/83 - if CONTAINED("$$",form) then $e:= put("$$","mode",get("$","mode",$e),$e) - opAlist:= getOperationAlist(domainName,functorForm,form) - substAlist:= substNames(domainName,viewName,functorForm,opAlist) - [substAlist,$e] - ---------------------> NEW DEFINITION (see modemap.boot.pamphlet) -substNames(domainName,viewName,functorForm,opalist) == - functorForm := SUBSTQ("$$","$", functorForm) - nameForDollar := - isCategoryPackageName functorForm => CADR functorForm - domainName - - -- following calls to SUBSTQ must copy to save RPLAC's in - -- putInLocalDomainReferences - [[:SUBSTQ("$","$$",SUBSTQ(nameForDollar,"$",modemapform)), - [sel, viewName,if domainName = "$" then pos else - CADAR modemapform]] - for [:modemapform,[sel,"$",pos]] in - EQSUBSTLIST(KDR functorForm,$FormalMapVariableList, opalist)] - ---------------------> NEW DEFINITION (see modemap.boot.pamphlet) -addModemap1(op,mc,sig,pred,fn,e) == - --mc is the "mode of computation"; fn the "implementation" - if mc='Rep then --- if fn is [kind,'Rep,.] and - -- save old sig for NRUNTIME --- (kind = 'ELT or kind = 'CONST) then fn:=[kind,'Rep,sig] - sig:= substitute("$",'Rep,sig) - currentProplist:= getProplist(op,e) or nil - newModemapList:= - mkNewModemapList(mc,sig,pred,fn,LASSOC('modemap,currentProplist),e,nil) - newProplist:= augProplist(currentProplist,'modemap,newModemapList) - newProplist':= augProplist(newProplist,"FLUID",true) - unErrorRef op - --There may have been a warning about op having no value - addBinding(op,newProplist',e) - ---------------------> NEW DEFINITION (see modemap.boot.pamphlet) -addConstructorModemaps(name,form is [functorName,:.],e) == - $InteractiveMode: local:= nil - e:= putDomainsInScope(name,e) --frame - fn := GETL(functorName,"makeFunctionList") - [funList,e]:= FUNCALL(fn,name,form,e) - for [op,sig,opcode] in funList repeat - if opcode is [sel,dc,n] and sel='ELT then - nsig := substitute("$$$",name,sig) - nsig := substitute('$,"$$$",substitute("$$",'$,nsig)) - opcode := [sel,dc,nsig] - e:= addModemap(op,name,sig,true,opcode,e) - e - -------- from info.boot ----------- - ---------------------> NEW DEFINITION (see info.boot.pamphlet) -actOnInfo(u,$e) == - null u => $e - u is ["PROGN",:l] => (for v in l repeat $e:= actOnInfo(v,$e); $e) - $e:= - put("$Information","special",Info:= [u,:get("$Information","special",$e)],$e - ) - u is ["COND",:l] => - --there is nowhere %else that this sort of thing exists - for [ante,:conseq] in l repeat - if member(hasToInfo ante,Info) then for v in conseq repeat - $e:= actOnInfo(v,$e) - $e - u is ["ATTRIBUTE",name,att] => - [vval,vmode,venv]:= GetValue name - SAY("augmenting ",name,": ",u) - key:= if CONTAINED("$",vmode) then "domain" else name - cat:= ["CATEGORY",key,["ATTRIBUTE",att]] - $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) - --there is nowhere %else that this sort of thing exists - u is ["SIGNATURE",name,operator,modemap] => - implem:= - (implem:=ASSOC([name,:modemap],get(operator,'modemap,$e))) => - CADADR implem - name = "$" => ['ELT,name,-1] - ['ELT,name,substitute('$,name,modemap)] - $e:= addModemap(operator,name,modemap,true,implem,$e) - [vval,vmode,venv]:= GetValue name - SAY("augmenting ",name,": ",u) - key:= if CONTAINED("$",vmode) then "domain" else name - cat:= ["CATEGORY",key,["SIGNATURE",operator,modemap]] - $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) - u is ["has",name,cat] => - [vval,vmode,venv]:= GetValue name - cat=vmode => $e --stating the already known - u:= compMakeCategoryObject(cat,$e) => - --we are adding information about a category - [catvec,.,$e]:= u - [ocatvec,.,$e]:= compMakeCategoryObject(vmode,$e) - -- member(vmode,CAR catvec.4) => - -- JHD 82/08/08 01:40 This does not mean that we can ignore the - -- extension, since this may not be compatible with the view we - -- were passed - - --we are adding a principal descendant of what was already known - -- $e:= augModemapsFromCategory(name,name,nil,catvec,$e) - -- SAY("augmenting ",name,": ",cat) - -- put(name, "value", (vval, cat, venv), $e) - member(cat,first ocatvec.4) or - ASSOC(cat,CADR ocatvec.4) is [.,'T,.] => $e - --SAY("Category extension error: - --cat shouldn't be a join - --what was being asserted is an ancestor of what was known - if name="$" - then $e:= augModemapsFromCategory(name,name,name,cat,$e) - else - viewName:=genDomainViewName(name,cat) - genDomainView(viewName,name,cat,"HasCategory") - if not MEMQ(viewName,$functorLocalParameters) then - $functorLocalParameters:=[:$functorLocalParameters,viewName] - SAY("augmenting ",name,": ",cat) - $e:= put(name,"value",[vval,mkJoin(cat,vmode),venv],$e) - SAY("extension of ",vval," to ",cat," ignored") - $e - systemError '"knownInfo" - -------- from nruncomp.boot ----------- - ---------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) -genDeltaEntry opMmPair == ---called from compApplyModemap ---$NRTdeltaLength=0.. always equals length of $NRTdeltaList - [.,[odc,:.],.] := opMmPair - --opModemapPair := SUBLIS($LocalDomainAlist,opMmPair) - [op,[dc,:sig],[.,cform:=[eltOrConst,.,nsig]]] := opMmPair - if $profileCompiler = true then profileRecord(dc,op,sig) - eltOrConst = 'XLAM => cform - if eltOrConst = 'Subsumed then eltOrConst := 'ELT - if atom dc then - dc = "$" => nsig := sig - if NUMBERP nsig then nsig := substitute('$,dc,substitute("$$","$",sig)) - -- following hack needed to invert Rep to $ substitution --- if odc = 'Rep and cform is [.,.,osig] then sig:=osig - newimp := optDeltaEntry(op,nsig,dc,eltOrConst) => newimp - setDifference(listOfBoundVars dc,$functorLocalParameters) ^= [] => - ['applyFun,['compiledLookupCheck,MKQ op, - mkList consSig(nsig,dc),consDomainForm(dc,nil)]] - odc := dc - if null atom dc then dc := substitute("$$",'$,dc) - -- sig := substitute('$,dc,sig) - -- cform := substitute('$,dc,cform) - opModemapPair := - [op,[dc,:[genDeltaSig x for x in nsig]],['T,cform]] -- force pred to T - if null NRTassocIndex dc and dc ^= $NRTaddForm and - (member(dc,$functorLocalParameters) or null atom dc) then - --create "domain" entry to $NRTdeltaList - $NRTdeltaList:= [['domain,NRTaddInner dc,:dc],:$NRTdeltaList] - saveNRTdeltaListComp:= $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - compEntry:= compOrCroak(odc,$EmptyMode,$e).expr --- dc - RPLACA(saveNRTdeltaListComp,compEntry) - u := - [eltOrConst,'$,$NRTbase+$NRTdeltaLength-index] where index == - (n:= POSN1(opModemapPair,$NRTdeltaList)) => n + 1 - --n + 1 since $NRTdeltaLength is 1 too large - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp:=[nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - 0 - u - ---------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) -NRTencode(x,y) == encode(x,y,true) where encode(x,compForm,firstTime) == - --converts a domain form to a lazy domain form; everything other than - --the operation name should be assigned a slot - null firstTime and (k:= NRTassocIndex x) => k - VECP x => systemErrorHere '"NRTencode" - PAIRP x => - QCAR x='Record or x is ['Union,['_:,a,b],:.] => - [QCAR x,:[['_:,a,encode(b,c,false)] - for [.,a,b] in QCDR x for [.,=a,c] in CDR compForm]] - constructor? QCAR x or MEMQ(QCAR x,'(Union Mapping)) => - [QCAR x,:[encode(y,z,false) for y in QCDR x for z in CDR compForm]] - ['NRTEVAL,NRTreplaceAllLocalReferences COPY_-TREE lispize compForm] - MEMQ(x,$formalArgList) => - v := $FormalMapVariableList.(POSN1(x,$formalArgList)) - firstTime => ['local,v] - v - x = '$ => x - x = "$$" => x - ['QUOTE,x] - ---------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) -consDomainName(x,dc) == - x = dc => ''$ - x = '$ => ''$ - x = "$$" => ['devaluate,'$] - x is [op,:argl] => - (op = 'Record) or (op = 'Union and argl is [[":",:.],:.]) => - mkList [MKQ op, - :[['LIST,MKQ '_:,MKQ tag,consDomainName(dom,dc)] - for [.,tag,dom] in argl]] - isFunctor op or op = 'Mapping or constructor? op => - -- call to constructor? needed if op was compiled in $bootStrapMode - mkList [MKQ op,:[consDomainName(y,dc) for y in argl]] - substitute('$,"$$",x) - x = [] => x - (y := LASSOC(x,$devaluateList)) => y - k:=NRTassocIndex x => - ['devaluate,['ELT,'$,k]] - get(x,'value,$e) => - isDomainForm(x,$e) => ['devaluate,x] - x - MKQ x - ---------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) -NRTassignCapsuleFunctionSlot(op,sig) == ---called from compDefineCapsuleFunction - opSig := [op,sig] - [.,.,implementation] := NRTisExported? opSig or return nil - --if opSig is not exported, it is local and need not be assigned - if $insideCategoryPackageIfTrue then - sig := substitute('$,CADR($functorForm),sig) - sig := [genDeltaSig x for x in sig] - opModemapPair := [op,['_$,:sig],['T,implementation]] - POSN1(opModemapPair,$NRTdeltaList) => nil --already there - $NRTdeltaList:= [opModemapPair,:$NRTdeltaList] - $NRTdeltaListComp := [nil,:$NRTdeltaListComp] - $NRTdeltaLength := $NRTdeltaLength+1 - ---------------------> NEW DEFINITION (see nruncomp.boot.pamphlet) -changeDirectoryInSlot1() == --called by NRTbuildFunctor - --3 cases: - -- if called inside NRTbuildFunctor, $NRTdeltaLength gives different locs - -- otherwise called from compFunctorBody (all lookups are forwarded): - -- $NRTdeltaList = nil ===> all slot numbers become nil - $lisplibOperationAlist := [sigloc entry for entry in $domainShell.1] where - sigloc [opsig,pred,fnsel] == - if pred ^= 'T then - pred := simpBool pred - $NRTslot1PredicateList := insert(pred,$NRTslot1PredicateList) - fnsel is [op,a,:.] and (op = 'ELT or op = 'CONST) => - if $insideCategoryPackageIfTrue then - opsig := substitute('$,CADR($functorForm),opsig) - [opsig,pred,[op,a,vectorLocation(first opsig,CADR opsig)]] - [opsig,pred,fnsel] - sortedOplist := listSort(function GLESSEQP, - COPY_-LIST $lisplibOperationAlist,function CADR) - $lastPred :local := nil - $newEnv :local := $e - $domainShell.1 := [fn entry for entry in sortedOplist] where - fn [[op,sig],pred,fnsel] == - if $lastPred ^= pred then - $newEnv := deepChaseInferences(pred,$e) - $lastPred := pred - newfnsel := - fnsel is ['Subsumed,op1,sig1] => - ['Subsumed,op1,genSlotSig(sig1,'T,$newEnv)] - fnsel - [[op, genSlotSig(sig,pred,$newEnv)] ,pred,newfnsel] - -------- from compiler.boot ----------- - ---------------------> NEW DEFINITION (see compiler.boot.pamphlet) -getFormModemaps(form is [op,:argl],e) == - op is ["elt",domain,op1] => - [x for x in getFormModemaps([op1,:argl],e) | x is [[ =domain,:.],:.]] - null atom op => nil - modemapList:= get(op,"modemap",e) - if $insideCategoryPackageIfTrue then - modemapList := [x for x in modemapList | x is [[dom,:.],:.] and dom ^= '$] - if op="elt" - then modemapList:= eltModemapFilter(LAST argl,modemapList,e) or return nil - else - if op="setelt" then modemapList:= - seteltModemapFilter(CADR argl,modemapList,e) or return nil - nargs:= #argl - finalModemapList:= [mm for (mm:= [[.,.,:sig],:.]) in modemapList | #sig=nargs] - modemapList and null finalModemapList => - stackMessage ["no modemap for","%b",op,"%d","with ",nargs," arguments"] - finalModemapList - -------- from functor.boot ----------- - ---------------------> NEW DEFINITION (see functor.boot.pamphlet) -LookUpSigSlots(sig,siglist) == ---+ must kill any implementations below of the form (ELT $ NIL) - if $insideCategoryPackageIfTrue then - sig := substitute('$,CADR($functorForm),sig) - siglist := $lisplibOperationAlist - REMDUP [implem for u in siglist | SigSlotsMatch(sig,first u,implem:=CADDR u) - and KADDR implem] - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} -- cgit v1.2.3