aboutsummaryrefslogtreecommitdiff
path: root/src/interp/package.boot.pamphlet
diff options
context:
space:
mode:
Diffstat (limited to 'src/interp/package.boot.pamphlet')
-rw-r--r--src/interp/package.boot.pamphlet300
1 files changed, 300 insertions, 0 deletions
diff --git a/src/interp/package.boot.pamphlet b/src/interp/package.boot.pamphlet
new file mode 100644
index 00000000..f97f86ac
--- /dev/null
+++ b/src/interp/package.boot.pamphlet
@@ -0,0 +1,300 @@
+\documentclass{article}
+\usepackage{axiom}
+
+\title{\File{src/interp/package.boot} Pamphlet}
+\author{The Axiom Team}
+
+\begin{document}
+\maketitle
+\begin{abstract}
+\end{abstract}
+\eject
+\tableofcontents
+\eject
+
+\section{License}
+
+<<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.
+
+@
+<<*>>=
+<<license>>
+
+)package "BOOT"
+
+isPackageFunction() ==
+ -- called by compile/putInLocalDomainReferences
+--+
+ nil
+
+processFunctorOrPackage(form,signature,data,localParList,m,e) ==
+--+
+ processFunctor(form,signature,data,localParList,e)
+
+processPackage($definition is [name,:args],[$catsig,:argssig],code,locals,$e) ==
+ $GENNO: local:= 0 --for GENVAR()
+ $catsig: local
+ --used in ProcessCond
+ $maximalViews: local
+ --read by ProcessCond
+ $ResetItems: local
+ --stores those items that get SETQed, and may need re-processing
+ $catvecList: local:= [$domainShell]
+ $catNames: local:= ["$"]
+--PRINT $definition
+--PRINT ($catsig,:argssig)
+--PRETTYPRINT code
+ catvec:= $domainShell --from compDefineFunctor
+ $getDomainCode:= optFunctorBody $getDomainCode
+ --the purpose of this is so ProcessCond recognises such items
+ code:= PackageDescendCode(code,true,nil)
+ if delete(nil,locals) then code:=[:code,:(setPackageCode locals)] where
+ setPackageCode locals ==
+ locals':=[[u,:i] for u in locals for i in 0.. | u]
+ locals'' :=[]
+ while locals' repeat
+ for v in locals' repeat
+ [u,:i]:=v
+ if and/[EQ(v,v') or not subTree(u,CAR v') for v' in locals']
+ then
+ locals'':=[v,:locals'']
+ locals':=delete(v,locals')
+ precomp:=code:=[]
+ for elem in locals'' repeat
+ [u,:i]:=elem
+ if ATOM u then u':=u
+ else
+ u':=opt(u,precomp) where
+ opt(u,alist) ==
+ ATOM u => u
+ for v in u repeat
+ if (a:=ASSOC(v,alist)) then
+ [.,:i]:=a
+ u:=replace(v,[($QuickCode=>'QREFELT;'ELT),"$",i],u) where
+ replace(old,new,l) ==
+ l isnt [h,:t] => l
+ h = old => [new,:t]
+ [h,:replace(old,new,t)]
+ v':=opt(v,alist)
+ EQ(v,v') => nil
+ u:=replace(v,v',u)
+ u
+ precomp:=[elem,:precomp]
+ code:=[[($QuickCode=>'QSETREFV;'SETELT),"$",i,u'],:code]
+ nreverse code
+ code:=
+ ["PROGN",:$getDomainCode,["LET","$",["GETREFV",#locals]],
+ --It is important to place this code here,
+ --after $ is set up
+ --slam functor with shell
+ --the order of steps in this PROGN are critical
+ addToSlam($definition,"$"),code,[
+ "SETELT","$",0, mkDomainConstructor $definition],:
+-- If we call addMutableArg this early, then recurise calls to this domain
+-- (e.g. while testing predicates) will generate new domains => trouble
+-- "SETELT","$",0,addMutableArg mkDomainConstructor $definition],:
+ [["SETELT","$",position(name,locals),name]
+ for name in $ResetItems | MEMQ(name,locals)],
+ :[($mutableDomain => '(RPLACD (LASTNODE (ELT $ 0))
+ (LIST (GENSYM)));[]) ],
+ "$"]
+ for u in $getDomainCode repeat
+ u is ['LET,.,u'] and u' is ['getDomainView,.,u''] =>
+ $packagesUsed:=union(CategoriesFromGDC u'',$packagesUsed)
+ $packagesUsed:=union($functorLocalParameters,$packagesUsed)
+ $getDomainCode:= nil
+ --if we didn't kill this, DEFINE would insert it in the wrong place
+ optFunctorBody code
+
+subTree(u,v) ==
+ v=u => true
+ ATOM v => nil
+ or/[subTree(u,v') for v' in v]
+
+mkList u ==
+ u => ["LIST",:u]
+ nil
+
+setPackageLocals(pac,locs) ==
+ for var in locs for i in 0.. | var^=nil repeat pac.i:= var
+
+PackageDescendCode(code,flag,viewAssoc) ==
+ --flag is true if we are walking down code always executed
+ --nil if we are in conditional code
+ code=nil => nil
+ code="noBranch" => nil
+ code is ["add",base,:codelist] =>
+ systemError '"packages may not have add clauses"
+ code is ["PROGN",:codelist] =>
+ ["PROGN",:
+ [v for u in codelist | (v:= PackageDescendCode(u,flag,viewAssoc))^=nil]]
+ code is ["COND",:condlist] =>
+ c:=
+ ["COND",:
+ [[u2:= ProcessCond(first u,viewAssoc),:
+ (if null u2
+ then nil
+ else
+ [PackageDescendCode(v,flag and TruthP u2,
+ if first u is ["HasCategory",dom,cat]
+ then [[dom,:cat],:viewAssoc]
+ else viewAssoc) for v in rest u])] for u in condlist]]
+ TruthP CAADR c => ["PROGN",:CDADR c]
+ c
+ code is ["LET",name,body,:.] =>
+ if not MEMQ(name,$ResetItems) then $ResetItems:= [name,:$ResetItems]
+ if body is [a,:.] and isFunctor a
+ then $packagesUsed:=[body,:$packagesUsed]
+ code
+ code is ["CodeDefine",sig,implem] =>
+ --Generated by doIt in COMPILER BOOT
+ dom:= "$"
+ dom:=
+ u:= LASSOC(dom,viewAssoc) => ["getDomainView",dom,u]
+ dom
+ body:= ["CONS",implem,dom]
+ SetFunctionSlots(sig,body,flag,"original")
+ code is [":",:.] => (RPLACA(code,"LIST"); RPLACD(code,NIL))
+ --Yes, I know that's a hack, but how else do you kill a line?
+ code is ["LIST",:.] => nil
+ code is ["MDEF",:.] => nil
+ code is ["devaluate",:.] => nil
+ code is ["call",:.] => code
+ code is ["SETELT",:.] => code
+ code is ["QSETREFV",:.] => code
+ stackWarning ["unknown Package code ",code]
+ code
+
+mkOperatorEntry(domainOrPackage,opSig is [op,sig,:flag],pred,count) ==
+ domainOrPackage^="domain" =>
+ [opSig,pred,["PAC","$",name]] where
+ name() == encodeFunctionName(op,domainOrPackage,sig,":",count)
+ null flag => [opSig,pred,["ELT","$",count]]
+ first flag="constant" => [[op,sig],pred,["CONST","$",count]]
+ systemError ["unknown variable mode: ",flag]
+
+optPackageCall(x,["PAC",packageVariableOrForm,functionName],arglist) ==
+ RPLACA(x,functionName)
+ RPLACD(x,[:arglist,packageVariableOrForm])
+ x
+
+--% Code for encoding function names inside package or domain
+
+encodeFunctionName(fun,package is [packageName,:arglist],signature,sep,count)
+ ==
+ signature':= substitute("$",package,signature)
+ reducedSig:= mkRepititionAssoc [:rest signature',first signature']
+ encodedSig:=
+ ("STRCONC"/[encodedPair for [n,:x] in reducedSig]) where
+ encodedPair() ==
+ n=1 => encodeItem x
+ STRCONC(STRINGIMAGE n,encodeItem x)
+ encodedName:= INTERNL(getAbbreviation(packageName,#arglist),";",
+ encodeItem fun,";",encodedSig, sep,STRINGIMAGE count)
+ if $LISPLIB then
+ $lisplibSignatureAlist:=
+ [[encodedName,:signature'],:$lisplibSignatureAlist]
+ encodedName
+
+splitEncodedFunctionName(encodedName, sep) ==
+ -- [encodedPackage, encodedItem, encodedSig, sequenceNo] or NIL
+ -- sep0 is the separator used in "encodeFunctionName".
+ sep0 := '";"
+ if not STRINGP encodedName then
+ encodedName := STRINGIMAGE encodedName
+ null (p1 := STRPOS(sep0, encodedName, 0, '"*")) => nil
+ null (p2 := STRPOS(sep0, encodedName, p1+1, '"*")) => 'inner
+-- This is picked up in compile for inner functions in partial compilation
+ null (p3 := STRPOS(sep, encodedName, p2+1, '"*")) => nil
+ s1 := SUBSTRING(encodedName, 0, p1)
+ s2 := SUBSTRING(encodedName, p1+1, p2-p1-1)
+ s3 := SUBSTRING(encodedName, p2+1, p3-p2-1)
+ s4 := SUBSTRING(encodedName, p3+1, nil)
+ [s1, s2, s3, s4]
+
+mkRepititionAssoc l ==
+ mkRepfun(l,1) where
+ mkRepfun(l,n) ==
+ null l => nil
+ l is [x] => [[n,:x]]
+ l is [x, =x,:l'] => mkRepfun(rest l,n+1)
+ [[n,:first l],:mkRepfun(rest l,1)]
+
+encodeItem x ==
+ x is [op,:argl] => getCaps op
+ IDENTP x => PNAME x
+ STRINGIMAGE x
+
+getCaps x ==
+ s:= STRINGIMAGE x
+ clist:= [c for i in 0..MAXINDEX s | UPPER_-CASE_-P (c:= s.i)]
+ null clist => '"__"
+ "STRCONC"/[first clist,:[L_-CASE u for u in rest clist]]
+
+--% abbreviation code
+
+getAbbreviation(name,c) ==
+ --returns abbreviation of name with c arguments
+ x := constructor? name
+ X := ASSQ(x,$abbreviationTable) =>
+ N:= ASSQ(name,rest X) =>
+ C:= ASSQ(c,rest N) => rest C --already there
+ newAbbreviation:= mkAbbrev(X,x)
+ RPLAC(rest N,[[c,:newAbbreviation],:rest N])
+ newAbbreviation
+ newAbbreviation:= mkAbbrev(X,x)
+ RPLAC(rest X,[[name,[c,:newAbbreviation]],:rest X])
+ newAbbreviation
+ $abbreviationTable:= [[x,[name,[c,:x]]],:$abbreviationTable]
+ x
+
+mkAbbrev(X,x) == addSuffix(alistSize rest X,x)
+
+alistSize c ==
+ count(c,1) where
+ count(x,level) ==
+ level=2 => #x
+ null x => 0
+ count(CDAR x,level+1)+count(rest x,level)
+
+addSuffix(n,u) ==
+ ALPHA_-CHAR_-P (s:= STRINGIMAGE u).(MAXINDEX s) => INTERN STRCONC(s,STRINGIMAGE n)
+ INTERNL STRCONC(s,STRINGIMAGE ";",STRINGIMAGE n)
+
+
+@
+\eject
+\begin{thebibliography}{99}
+\bibitem{1} nothing
+\end{thebibliography}
+\end{document}