From 9059de94b6f7f418f2a2d127540a94eb787ec1fb Mon Sep 17 00:00:00 2001 From: dos-reis Date: Fri, 2 Nov 2007 01:01:18 +0000 Subject: * Makefile.pamphlet (functor.$(FASLEXT)): New rule. (<>): Remove. * functor.boot.pamphlet: Push into package "BOOT". --- src/interp/ChangeLog | 6 + src/interp/Makefile.in | 7 +- src/interp/Makefile.pamphlet | 13 +- src/interp/define.boot | 1507 +++++++++++++++++++++++++++++++++++++ src/interp/define.boot.pamphlet | 1543 -------------------------------------- src/interp/functor.boot.pamphlet | 48 +- 6 files changed, 1546 insertions(+), 1578 deletions(-) create mode 100644 src/interp/define.boot delete mode 100644 src/interp/define.boot.pamphlet (limited to 'src/interp') diff --git a/src/interp/ChangeLog b/src/interp/ChangeLog index bc1dc193..f74f3000 100644 --- a/src/interp/ChangeLog +++ b/src/interp/ChangeLog @@ -1,3 +1,9 @@ +2007-11-01 Gabriel Dos Reis + + * Makefile.pamphlet (functor.$(FASLEXT)): New rule. + (<>): Remove. + * functor.boot.pamphlet: Push into package "BOOT". + 2007-11-01 Gabriel Dos Reis Waldek Hebisch diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index b2f00424..97fac659 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -457,6 +457,9 @@ define.$(FASLEXT): define.boot cattable.$(FASLEXT) category.$(FASLEXT) \ c-util.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< +functor.$(FASLEXT): functor.boot category.$(FASLEXT) c-util.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + category.$(FASLEXT): category.boot g-util.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< @@ -689,10 +692,6 @@ database.clisp: database.boot @ echo 243 making $@ from $< @ echo '(old-boot::boot "database.boot")' | ${DEPSYS} -functor.clisp: functor.boot - @ echo 254 making $@ from $< - @ echo '(old-boot::boot "functor.boot")' | ${DEPSYS} - i-analy.clisp: i-analy.boot @ echo 280 making $@ from $< @ echo '(old-boot::boot "i-analy.boot")' | ${DEPSYS} diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 9ff90c55..69abbb73 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -1116,14 +1116,6 @@ database.clisp: database.boot @ echo '(old-boot::boot "database.boot")' | ${DEPSYS} @ -\subsection{functor.boot} - -<>= -functor.clisp: functor.boot - @ echo 254 making $@ from $< - @ echo '(old-boot::boot "functor.boot")' | ${DEPSYS} -@ - \subsection{i-analy.boot} <>= @@ -1564,6 +1556,9 @@ define.$(FASLEXT): define.boot cattable.$(FASLEXT) category.$(FASLEXT) \ c-util.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< +functor.$(FASLEXT): functor.boot category.$(FASLEXT) c-util.$(FASLEXT) + $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< + category.$(FASLEXT): category.boot g-util.$(FASLEXT) $(BOOTSYS) -- --compile --boot="old" --output=$@ --load-directory=. $< @@ -1774,8 +1769,6 @@ boot-pkg.$(FASLEXT): boot-pkg.lisp <> -<> - <> <> diff --git a/src/interp/define.boot b/src/interp/define.boot new file mode 100644 index 00000000..20238790 --- /dev/null +++ b/src/interp/define.boot @@ -0,0 +1,1507 @@ +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- Copyright (C) 2007, Gabriel Dos Reis. +-- 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. + + +import '"c-util" +import '"cattable" +import '"category" +)package "BOOT" + +NRTPARSE := false + +--% FUNCTIONS WHICH MUNCH ON == STATEMENTS + +compDefine(form,m,e) == + $tripleHits: local:= 0 + $macroIfTrue: local + $packagesUsed: local + result:= compDefine1(form,m,e) + result + +compDefine1(form,m,e) == + $insideExpressionIfTrue: local:= false + --1. decompose after macro-expanding form + ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) + $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) + => [lhs,m,put(first lhs,'macro,rhs,e)] + null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and + (sig:= getSignatureFromMode(lhs,e)) => + -- here signature of lhs is determined by a previous declaration + compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) + if signature.target=$Category then $insideCategoryIfTrue:= true +--?? following 3 lines seem bogus, BMT 6/23/93 +--? if signature.target is ['Mapping,:map] then +--? signature:= map +--? form:= ['DEF,lhs,signature,specialCases,rhs] + +-- RDJ (11/83): when argument and return types are all declared, +-- or arguments have types declared in the environment, +-- and there is no existing modemap for this signature, add +-- the modemap by a declaration, then strip off declarations and recurse + e := compDefineAddSignature(lhs,signature,e) +-- 2. if signature list for arguments is not empty, replace ('DEF,..) by +-- ('where,('DEF,..),..) with an empty signature list; +-- otherwise, fill in all NILs in the signature + not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) + signature.target=$Category => + compDefineCategory(form,m,e,nil,$formalArgList) + isDomainForm(rhs,e) and not $insideFunctorIfTrue => + if null signature.target then signature:= + [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: + rest signature] + rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) + compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, + $formalArgList) + null $form => stackAndThrow ['"bad == form ",form] + newPrefix:= + $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) + getAbbreviation($op,#rest $form) + compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) + +compDefineAddSignature([op,:argl],signature,e) == + (sig:= hasFullSignature(argl,signature,e)) and + not assoc(['$,:sig],LASSOC('modemap,getProplist(op,e))) => + declForm:= + [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature] + [.,.,e]:= comp(declForm,$EmptyMode,e) + e + e + +hasFullSignature(argl,[target,:ml],e) == + target => + u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] + u^='failed => [target,:u] + +addEmptyCapsuleIfNecessary(target,rhs) == + MEMQ(KAR rhs,$SpecialDomainNames) => rhs + ['add,rhs,['CAPSULE]] + +getTargetFromRhs(lhs,rhs,e) == + --undeclared target mode obtained from rhs expression + rhs is ['CAPSULE,:.] => + stackSemanticError(['"target category of ",lhs, + '" cannot be determined from definition"],nil) + rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) + rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) + rhs is ['Record,:l] => ['RecordCategory,:l] + rhs is ['Union,:l] => ['UnionCategory,:l] + rhs is ['List,:l] => ['ListCategory,:l] + rhs is ['Vector,:l] => ['VectorCategory,:l] + [.,target,.]:= compOrCroak(rhs,$EmptyMode,e) + target + +giveFormalParametersValues(argl,e) == + for x in argl repeat + e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e) + e + +macroExpandInPlace(x,e) == + y:= macroExpand(x,e) + atom x or atom y => y + RPLACA(x,first y) + RPLACD(x,rest y) + x + +macroExpand(x,e) == --not worked out yet + atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) + x is ['DEF,lhs,sig,spCases,rhs] => + ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), + macroExpand(rhs,e)] + macroExpandList(x,e) + +macroExpandList(l,e) == + -- macros should override niladic props + (l is [name]) and IDENTP name and GETDATABASE(name, 'NILADIC) and + (u := get(name, 'macro, e)) => macroExpand(u,e) + [macroExpand(x,e) for x in l] + +compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == + categoryCapsule := +--+ + body is ['add,cat,capsule] => + body := cat + capsule + nil + [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) +--+ next two lines + if categoryCapsule and not $bootStrapMode then [.,.,e] := + $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 +--> + $categoryPredicateList: local := + makeCategoryPredicates(form,$lisplibCategory) + compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) + [d,m,e] + +makeCategoryPredicates(form,u) == + $tvl := TAKE(#rest form,$TriangleVariableList) + $mvl := TAKE(#rest form,rest $FormalMapVariableList) + fn(u,nil) where + fn(u,pl) == + u is ['Join,:.,a] => fn(a,pl) + u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl) + u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl + atom u => pl + fnl(u,pl) + fnl(u,pl) == + for x in u repeat pl := fn(x,pl) + pl + +--+ the following function +mkCategoryPackage(form is [op,:argl],cat,def) == + packageName:= INTERN(STRCONC(PNAME op,'"&")) + packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-")) + $options:local := [] + -- This stops the next line from becoming confused + abbreviationsSpad2Cmd ['domain,packageAbb,packageName] + -- This is a little odd, but the parser insists on calling + -- domains, rather than packages + nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) + packageArgl := [nameForDollar,:argl] + capsuleDefAlist := fn(def,nil) where fn(x,oplist) == + atom x => oplist + x is ['DEF,y,:.] => [y,:oplist] + fn(rest x,fn(first x,oplist)) + explicitCatPart := gn cat where gn cat == + cat is ['CATEGORY,:.] => rest rest cat + cat is ['Join,:u] => gn last u + nil + catvec := eval mkEvalableCategoryForm form + fullCatOpList:=(JoinInner([catvec],$e)).1 + catOpList := + --note: this gets too many modemaps in general + -- this is cut down in NRTmakeSlot1 + [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList + --above line calls the category constructor just compiled + | assoc(op1,capsuleDefAlist)] + null catOpList => nil + packageCategory := ['CATEGORY,'domain, + :SUBLISLIS(argl,$FormalMapVariableList,catOpList)] + nils:= [nil for x in argl] + packageSig := [packageCategory,form,:nils] + $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList) + SUBST(nameForDollar,'$, + ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) + +compDefineCategory2(form,signature,specialCases,body,m,e, + $prefix,$formalArgList) == + --1. bind global variables + $insideCategoryIfTrue: local:= true + $TOP__LEVEL: local + $definition: local + --used by DomainSubstitutionFunction + $form: local + $op: local + $extraParms: local + --Set in DomainSubstitutionFunction, used further down +-- 1.1 augment e to add declaration $:
+ [$op,:argl]:= $definition:= form + e:= addBinding("$",[['mode,:$definition]],e) + +-- 2. obtain signature + signature':= + [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] + e:= giveFormalParametersValues(argl,e) + +-- 3. replace arguments by $1,..., substitute into body, +-- and introduce declarations into environment + sargl:= TAKE(# argl, $TriangleVariableList) + $functorForm:= $form:= [$op,:sargl] + $formalArgList:= [:sargl,:$formalArgList] + aList:= [[a,:sa] for a in argl for sa in sargl] + formalBody:= SUBLIS(aList,body) + signature' := SUBLIS(aList,signature') +--Begin lines for category default definitions + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $frontier: local := 0 + $getDomainCode: local := nil + $addForm: local:= nil + for x in sargl for t in rest signature' repeat + [.,.,e]:= compMakeDeclaration([":",x,t],m,e) + +-- 4. compile body in environment of %type declarations for arguments + op':= $op + -- following line causes cats with no with or Join to be fresh copies + if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then + formalBody := ['Join, formalBody] + body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr + if $extraParms then + formals:=actuals:=nil + for u in $extraParms repeat + formals:=[CAR u,:formals] + actuals:=[MKQ CDR u,:actuals] + body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] + if argl then body:= -- always subst for args after extraparms + ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: + [['devaluate,u] for u in sargl]]],body] + body:= + ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]] + fun:= compile [op',['LAM,sargl,body]] + +-- 5. give operator a 'modemap property + pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] + parSignature:= SUBLIS(pairlis,signature') + parForm:= SUBLIS(pairlis,form) + lisplibWrite('"compilerInfo", + removeZeroOne ['SETQ,'$CategoryFrame, + ['put,['QUOTE,op'],' + (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, + MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) + --Equivalent to the following two lines, we hope + if null sargl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) + +-- 6. put modemaps into InteractiveModemapFrame + $domainShell := eval [op',:MAPCAR('MKQ,sargl)] + $lisplibCategory:= formalBody + if $LISPLIB then + $lisplibForm:= form + $lisplibKind:= 'category + modemap:= [[parForm,:parSignature],[true,op']] + $lisplibModemap:= modemap + $lisplibParents := + getParentsFor($op,$FormalMapVariableList,$lisplibCategory) + $lisplibAncestors := computeAncestorsOf($form,nil) + $lisplibAbbreviation := constructor? $op + form':=[op',:sargl] + augLisplibModemapsFromCategory(form',formalBody,signature') + [fun,'(Category),e] + +mkConstructor form == + atom form => ['devaluate,form] + null rest form => ['QUOTE,[first form]] + ['LIST,MKQ first form,:[mkConstructor x for x in rest form]] + +compDefineCategory(df,m,e,prefix,fal) == + $domainShell: local -- holds the category of the object being compiled + $lisplibCategory: local + not $insideFunctorIfTrue and $LISPLIB => + compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) + compDefineCategory1(df,m,e,prefix,fal) + +compDefineFunctor(df,m,e,prefix,fal) == + $domainShell: local -- holds the category of the object being compiled + $profileCompiler: local := true + $profileAlist: local := nil + $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) + compDefineFunctor1(df,m,e,prefix,fal) + +compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], + m,$e,$prefix,$formalArgList) == + if NRTPARSE = true then + [lineNumber,:$functorSpecialCases] := $functorSpecialCases +-- 1. bind global variables + $addForm: local + $viewNames: local:= nil + + --This list is only used in genDomainViewName, for generating names + --for alternate views, if they do not already exist. + --format: Alist: (domain name . sublist) + --sublist is alist: category . name of view + $functionStats: local:= [0,0] + $functorStats: local:= [0,0] + $form: local + $op: local + $signature: local + $functorTarget: local + $Representation: local + --Set in doIt, accessed in the compiler - compNoStacking + $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry + $LocalDomainAlist:= nil + $functorForm: local + $functorLocalParameters: local + SETQ($myFunctorBody, body) + $CheckVectorList: local + --prevents CheckVector from printing out same message twice + $getDomainCode: local -- code for getting views + $insideFunctorIfTrue: local:= true + $functorsUsed: local --not currently used, finds dependent functors + $setelt: local := + $QuickCode = true => 'QSETREFV + 'SETELT + $TOP__LEVEL: local + $genSDVar: local:= 0 + originale:= $e + [$op,:argl]:= form + $formalArgList:= [:argl,:$formalArgList] + $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] + $mutableDomain: local := + -- all defaulting packages should have caching turned off + isCategoryPackageName $op or + (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) + else false ) --true if domain has mutable state + signature':= + [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] + $functorForm:= $form:= [$op,:argl] + if null first signature' then signature':= + modemap2Signature getModemap($form,$e) + target:= first signature' + $functorTarget:= target + $e:= giveFormalParametersValues(argl,$e) + [ds,.,$e]:= compMakeCategoryObject(target,$e) or +--+ copy needed since slot1 is reset; compMake.. can return a cached vector + sayBrightly '" cannot produce category object:" + pp target + return nil + $domainShell:= COPY_-SEQ ds + $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") + attributeList := disallowNilAttribute ds.2 --see below under "loadTimeAlist" +--+ 7 lines for $NRT follow + $goGetList: local := nil +-->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 + $condAlist: local := nil + $uncondAlist: local := nil +-->>-- next global initialized here, reset by NRTbuildFunctor + $NRTslot1PredicateList: local := + REMDUP [CADR x for x in attributeList] +-->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) + $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList + $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor + --this is used below to set $lisplibSlot1 global + $NRTbase: local := 6 -- equals length of $domainShell + $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 + $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts + $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList + $NRTaddList: local := nil --list of fncts not defined in capsule (added) + $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector + $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) + $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... + -- the above optimizes the calls to local domains + $template: local:= nil --stored in the lisplib (if $NRTvec = true) + $functionLocations: local := nil --locations of defined functions in source + -- generate slots for arguments first, then for $NRTaddForm in compAdd + for x in argl repeat NRTgetLocalIndex x + [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) + --The following loop sees if we can economise on ADDed operations + --by using those of Rep, if that is the same. Example: DIRPROD + if $insideCategoryPackageIfTrue^= true then + if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) + and FindRep(cb) = ab + where FindRep cb == + u:= + while cb repeat + ATOM cb => return nil + cb is [['LET,'Rep,v,:.],:.] => return (u:=v) + cb:=CDR cb + u + then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) + else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) + $signature:= signature' + operationAlist:= SUBLIS($pairlis,$domainShell.(1)) + parSignature:= SUBLIS($pairlis,signature') + parForm:= SUBLIS($pairlis,form) + +-- (3.1) now make a list of the functor's local parameters; for +-- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); +-- in this case, D is replaced by D1,..,Dn (gensyms) which are set +-- to the A1,..,An view of D + if isPackageFunction() then $functorLocalParameters:= + [nil,: + [nil + for i in 6..MAXINDEX $domainShell | + $domainShell.i is [.,.,['ELT,'_$,.]]]] + --leave space for vector ops and package name to be stored +--+ + $functorLocalParameters:= + argPars := + makeFunctorArgumentParameters(argl,rest signature',first signature') + -- must do above to bring categories into scope --see line 5 of genDomainView + argl +-- 4. compile body in environment of %type declarations for arguments + op':= $op + rettype:= signature'.target + T:= compFunctorBody(body,rettype,$e,parForm) + -- If only compiling certain items, then ignore the body shell. + $compileOnlyCertainItems => + reportOnFunctorCompilation() + [nil, ['Mapping, :signature'], originale] + + body':= T.expr + lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM + fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) + --The above statement stops substitutions gettting in one another's way +--+ + operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) + if $LISPLIB then + augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) + reportOnFunctorCompilation() + +-- 5. give operator a 'modemap property +-- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) + if $LISPLIB then + modemap:= [[parForm,:parSignature],[true,op']] + $lisplibModemap:= modemap + $lisplibCategory := modemap.mmTarget + $lisplibParents := + getParentsFor($op,$FormalMapVariableList,$lisplibCategory) + $lisplibAncestors := computeAncestorsOf($form,nil) + $lisplibAbbreviation := constructor? $op + $insideFunctorIfTrue:= false + if $LISPLIB then + $lisplibKind:= +------->This next line prohibits changing the KIND once given +--------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk + $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package + 'domain + $lisplibForm:= form + if null $bootStrapMode then + $NRTslot1Info := NRTmakeSlot1Info() + $isOpPackageName: local := isCategoryPackageName $op + if $isOpPackageName then lisplibWrite('"slot1DataBase", + ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) + $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) + $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) + -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended + libFn := GETDATABASE(op','ABBREVIATION) + $lookupFunction: local := + NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) + --either lookupComplete (for forgetful guys) or lookupIncomplete + $byteAddress :local := 0 + $byteVec :local := nil + $NRTslot1PredicateList := + [simpBool x for x in $NRTslot1PredicateList] + rwriteLispForm('loadTimeStuff, + ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) + $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 + $lisplibOperationAlist:= operationAlist + $lisplibMissingFunctions:= $CheckVectorList + lisplibWrite('"compilerInfo", + removeZeroOne ['SETQ,'$CategoryFrame, + ['put,['QUOTE,op'],' + (QUOTE isFunctor), + ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' + QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], + ['put,['QUOTE,op' ],'(QUOTE mode), + ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) + if null argl then + evalAndRwriteLispForm('NILADIC, + ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) + [fun,['Mapping,:signature'],originale] + +disallowNilAttribute x == + res := [y for y in x | car y and car y ^= "nil"] +--HACK to get rid of nil attibutes ---NOTE: nil is RENAMED to NIL + +compFunctorBody(body,m,e,parForm) == + $bootStrapMode = true => + [bootStrapError($functorForm, _/EDITFILE),m,e] + T:= compOrCroak(body,m,e) + body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T + $NRTaddForm := + body is ["SubDomain",domainForm,predicate] => domainForm + body + T + +reportOnFunctorCompilation() == + displayMissingFunctions() + if $semanticErrorStack then sayBrightly '" " + displaySemanticErrors() + if $warningStack then sayBrightly '" " + displayWarnings() + $functorStats:= addStats($functorStats,$functionStats) + [byteCount,elapsedSeconds] := $functorStats + sayBrightly ['%l,:bright '" Cumulative Statistics for Constructor", + $op] + timeString := normalizeStatAndStringify elapsedSeconds + sayBrightly ['" Time:",:bright timeString,'"seconds"] + sayBrightly '" " + 'done + +displayMissingFunctions() == + null $CheckVectorList => nil + loc := nil + exp := nil + for [[op,sig,:.],:pred] in $CheckVectorList | null pred repeat + null member(op,$formalArgList) and + getmode(op,$env) is ['Mapping,:.] => + loc := [[op,sig],:loc] + exp := [[op,sig],:exp] + if loc then + sayBrightly ['%l,:bright '" Missing Local Functions:"] + for [op,sig] in loc for i in 1.. repeat + sayBrightly ['" [",i,'"]",:bright op, + ": ",:formatUnabbreviatedSig sig] + if exp then + sayBrightly ['%l,:bright '" Missing Exported Functions:"] + for [op,sig] in exp for i in 1.. repeat + sayBrightly ['" [",i,'"]",:bright op, + ": ",:formatUnabbreviatedSig sig] + +--% domain view code + +makeFunctorArgumentParameters(argl,sigl,target) == + $alternateViewList: local:= nil + $forceAdd: local:= true + $ConditionalOperators: local + ("append"/[fn(a,augmentSig(s,findExtras(a,target))) + for a in argl for s in sigl]) where + findExtras(a,target) == + -- see if conditional information implies anything else + -- in the signature of a + target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] + target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where + findExtras1(a,x) == + x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] + x is ['IF,c,p,q] => + union(findExtrasP(a,c), + union(findExtras1(a,p),findExtras1(a,q))) where + findExtrasP(a,x) == + x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] + x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] + nil + nil + augmentSig(s,ss) == + -- if we find something extra, add it to the signature + null ss => s + for u in ss repeat + $ConditionalOperators:=[CDR u,:$ConditionalOperators] + s is ['Join,:sl] => + u:=ASSQ('CATEGORY,ss) => + SUBST([:u,:ss],u,s) + ['Join,:sl,['CATEGORY,'package,:ss]] + ['Join,s,['CATEGORY,'package,:ss]] + fn(a,s) == + isCategoryForm(s,$CategoryFrame) => + s is ["Join",:catlist] => genDomainViewList0(a,rest s) + [genDomainView(a,a,s,"getDomainView")] + [a] + +genDomainViewList0(id,catlist) == + l:= genDomainViewList(id,catlist,true) + l + +genDomainViewList(id,catlist,firsttime) == + null catlist => nil + catlist is [y] and not isCategoryForm(y,$EmptyEnvironment) => nil + [genDomainView(if firsttime then id else genDomainViewName(id,first catlist), + id,first catlist,"getDomainView"),:genDomainViewList(id,rest catlist,nil)] + +genDomainView(viewName,originalName,c,viewSelector) == + c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c) + code:= + c is ['SubsetCategory,c',.] => c' + c + $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e) + --$alternateViewList:= ((viewName,:code),:$alternateViewList) + cd:= ['LET,viewName,[viewSelector,originalName,mkDomainConstructor code]] + if null member(cd,$getDomainCode) then + $getDomainCode:= [cd,:$getDomainCode] + viewName + +genDomainOps(viewName,dom,cat) == + oplist:= getOperationAlist(dom,dom,cat) + siglist:= [sig for [sig,:.] in oplist] + oplist:= substNames(dom,viewName,dom,oplist) + cd:= + ['LET,viewName,['mkOpVec,dom,['LIST,: + [['LIST,MKQ op,['LIST,:[mkDomainConstructor mode for mode in sig]]] + for [op,sig] in siglist]]]] + $getDomainCode:= [cd,:$getDomainCode] + for [opsig,cond,:.] in oplist for i in 0.. repeat + if opsig in $ConditionalOperators then cond:=nil + [op,sig]:=opsig + $e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e) + viewName + +mkOpVec(dom,siglist) == + dom:= getPrincipalView dom + substargs:= [['$,:dom.0],: + [[a,:x] for a in $FormalMapVariableList for x in rest dom.0]] + oplist:= getOperationAlistFromLisplib opOf dom.0 + --new form is ( ) + ops:= MAKE_-VEC (#siglist) + for (opSig:= [op,sig]) in siglist for i in 0.. repeat + u:= ASSQ(op,oplist) + assoc(sig,u) is [.,n,.,'ELT] => ops.i := dom.n + noplist:= SUBLIS(substargs,u) + -- following variation on assoc needed for GENSYMS in Mutable domains + AssocBarGensym(SUBST(dom.0,'$,sig),noplist) is [.,n,.,'ELT] => + ops.i := dom.n + ops.i := [function Undef,[dom.0,i],:opSig] + ops + +genDomainViewName(a,category) == +--+ + a + +compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == +-- form is lhs (f a1 ... an) of definition; body is rhs; +-- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; +-- specialCases is (NIL l1 ... ln) where li is list of special cases +-- which can be given for each ti + +-- removes declarative and assignment information from form and +-- signature, placing it in list L, replacing form by ("where",form',:L), +-- signature by a list of NILs (signifying declarations are in e) + $sigAlist: local + $predAlist: local + +-- 1. create sigList= list of all signatures which have embedded +-- declarations moved into global variable $sigAlist + sigList:= + [transformType fetchType(a,x,e,form) for a in rest form for x in rest signature] + where + fetchType(a,x,e,form) == + x => x + getmode(a,e) or userError concat( + '"There is no mode for argument",a,'"of function",first form) + transformType x == + atom x => x + x is [":",R,Rtype] => + ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x) + x is ['Record,:.] => x --RDJ 8/83 + [first x,:[transformType y for y in rest x]] + +-- 2. replace each argument of the form (|| x p) by x, recording +-- the given predicate in global variable $predAlist + argList:= + [removeSuchthat a for a in rest form] where + removeSuchthat x == + x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y) + x + +-- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that +-- the type of xi is independent of xj if i < j + varList:= + orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where + argDepAlist:= + [[x,:dependencies] for [x,:y] in argSigAlist] where + dependencies() == + union(listOfIdentifiersIn y, + delete(x,listOfIdentifiersIn LASSOC(x,$predAlist))) + argSigAlist:= [:$sigAlist,:pairList(argList,sigList)] + +-- 4. construct a WhereList which declares and/or defines the xi's in +-- the order constructed in step 3 + (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList]) + where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y) + +-- 5. compile new ('DEF,("where",form',:WhereList),:.) where +-- all argument parameters of form' are bound/declared in WhereList + comp(form',m,e) where + form':= + ["where",defform,:whereList] where + defform:= + ['DEF,form'',signature',specialCases,body] where + form'':= [first form,:argList] + signature':= [first signature,:[nil for x in rest signature]] + +orderByDependency(vl,dl) == + -- vl is list of variables, dl is list of dependency-lists + selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)] + for v in vl for d in dl | MEMQ(v,d) repeat + (SAY(v," depends on itself"); fatalError:= true) + fatalError => userError '"Parameter specification error" + until (null vl) repeat + newl:= + [v for v in vl for d in dl | null intersection(d,vl)] or return nil + orderedVarList:= [:newl,:orderedVarList] + vl':= setDifference(vl,newl) + dl':= [setDifference(d,newl) for x in vl for d in dl | member(x,vl')] + vl:= vl' + dl:= dl' + REMDUP NREVERSE orderedVarList --ordered so ith is indep. of jth if i < j + +compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], + m,oldE,$prefix,$formalArgList) == + [lineNumber,:specialCases] := specialCases + e := oldE + --1. bind global variables + $form: local + $op: local + $functionStats: local:= [0,0] + $argumentConditionList: local + $finalEnv: local + --used by ReplaceExitEtc to get a common environment + $initCapsuleErrorCount: local:= #$semanticErrorStack + $insideCapsuleFunctionIfTrue: local:= true + $CapsuleModemapFrame: local:= e + $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) + $insideExpressionIfTrue: local:= true + $returnMode:= m + [$op,:argl]:= form + $form:= [$op,:argl] + argl:= stripOffArgumentConditions argl + $formalArgList:= [:argl,:$formalArgList] + + --let target and local signatures help determine modes of arguments + argModeList:= + identSig:= hasSigInTargetCategory(argl,form,first signature,e) => + (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) + [getArgumentModeOrMoan(a,form,e) for a in argl] + argModeList:= stripOffSubdomainConditions(argModeList,argl) + signature':= [first signature,:argModeList] + if null identSig then --make $op a local function + oldE := put($op,'mode,['Mapping,:signature'],oldE) + + --obtain target type if not given + if null first signature' then signature':= + identSig => identSig + getSignature($op,rest signature',e) or return nil + e:= giveFormalParametersValues(argl,e) + + $signatureOfForm:= signature' --this global is bound in compCapsuleItems + $functionLocations := [[[$op,$signatureOfForm],:lineNumber], + :$functionLocations] + e:= addDomain(first signature',e) + e:= compArgumentConditions e + + if $profileCompiler then + for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) + + + --4. introduce needed domains into extendedEnv + for domain in signature' repeat e:= addDomain(domain,e) + + --6. compile body in environment with extended environment + rettype:= resolve(signature'.target,$returnMode) + + localOrExported := + null member($op,$formalArgList) and + getmode($op,e) is ['Mapping,:.] => 'local + 'exported + + --6a skip if compiling only certain items but not this one + -- could be moved closer to the top + formattedSig := formatUnabbreviated ['Mapping,:signature'] + $compileOnlyCertainItems and _ + not member($op, $compileOnlyCertainItems) => + sayBrightly ['" skipping ", localOrExported,:bright $op] + [nil,['Mapping,:signature'],oldE] + sayBrightly ['" compiling ",localOrExported, + :bright $op,'": ",:formattedSig] + + if $newComp = true then + wholeBody := ['DEF, form, signature', specialCases, body] + T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) + or [" ",rettype,e] + T := [T.expr.2.2, rettype, T.env] + if $newCompCompare=true then + oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) + or [" ",rettype,e] + SAY '"The old compiler generates:" + prTriple oldT + SAY '"The new compiler generates:" + prTriple T + else + T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) + or [" ",rettype,e] +--+ + NRTassignCapsuleFunctionSlot($op,signature') + if $newCompCompare=true then + SAY '"The old compiler generates:" + prTriple T +-- A THROW to the above CATCH occurs if too many semantic errors occur +-- see stackSemanticError + catchTag:= MKQ GENSYM() + fun:= + body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) + body':= addArgumentConditions(body',$op) + finalBody:= ["CATCH",catchTag,body'] + compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) + $functorStats:= addStats($functorStats,$functionStats) + + +-- 7. give operator a 'value property + val:= [fun,signature',e] + [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) + +getSignatureFromMode(form,e) == + getmode(opOf form,e) is ['Mapping,:signature] => + #form^=#signature => stackAndThrow ["Wrong number of arguments: ",form] + EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature) + +hasSigInTargetCategory(argl,form,opsig,e) == + mList:= [getArgumentMode(x,e) for x in argl] + --each element is a declared mode for the variable or nil if none exists + potentialSigList:= + REMDUP + [sig + for [[opName,sig,:.],:.] in $domainShell.(1) | + fn(opName,sig,opsig,mList,form)] where + fn(opName,sig,opsig,mList,form) == + opName=$op and #sig=#form and (null opsig or opsig=first sig) and + (and/[compareMode2Arg(x,m) for x in mList for m in rest sig]) + c:= #potentialSigList + 1=c => first potentialSigList + --accept only those signatures op right length which match declared modes + 0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil) + 1 + sig:= first potentialSigList + stackWarning ["signature of lhs not unique:", + :bright formatSignature sig, "chosen"] + sig + nil --this branch will force all arguments to be declared + +compareMode2Arg(x,m) == null x or modeEqual(x,m) + +getArgumentModeOrMoan(x,form,e) == + getArgumentMode(x,e) or + stackSemanticError(["argument ",x," of ",form," is not declared"],nil) + +getArgumentMode(x,e) == + STRINGP x => x + m:= get(x,'mode,e) => m + +checkAndDeclare(argl,form,sig,e) == + +-- arguments with declared types must agree with those in sig; +-- those that don't get declarations put into e + for a in argl for m in rest sig repeat + m1:= getArgumentMode(a,e) => + ^modeEqual(m1,m) => + stack:= [" ",:bright a,'"must have type ",m, + '" not ",m1,'%l,:stack] + e:= put(a,'mode,m,e) + if stack then + sayBrightly ['" Parameters of ",:bright first form, + '" are of wrong type:",'%l,:stack] + e + +getSignature(op,argModeList,$e) == + 1=# + (sigl:= + REMDUP + [sig + for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$ + and rest sig=argModeList and knownInfo pred]) => first sigl + null sigl => + (u:= getmode(op,$e)) is ['Mapping,:sig] => sig + SAY '"************* USER ERROR **********" + SAY("available signatures for ",op,": ") + if null mmList + then SAY " NONE" + else for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) + printSignature("NEED ",op,["?",:argModeList]) + nil + for u in sigl repeat + for v in sigl | not (u=v) repeat + if SourceLevelSubsume(u,v) then sigl:= delete(v,sigl) + --before we complain about duplicate signatures, we should + --check that we do not have for example, a partial - as + --well as a total one. SourceLevelSubsume (from CATEGORY BOOT) + --should do this + 1=#sigl => first sigl + stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil) + +--% ARGUMENT CONDITION CODE + +stripOffArgumentConditions argl == + [f for x in argl for i in 1..] where + f() == + x is ["|",arg,condition] => + condition:= SUBST('_#1,arg,condition) + -- in case conditions are given in terms of argument names, replace + $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] + arg + x + +stripOffSubdomainConditions(margl,argl) == + [f for x in margl for arg in argl for i in 1..] where + f() == + x is ['SubDomain,marg,condition] => + pair:= assoc(i,$argumentConditionList) => + (RPLAC(CADR pair,MKPF([condition,CADR pair],'AND)); marg) + $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] + marg + x + +compArgumentConditions e == + $argumentConditionList:= + [f for [n,a,x] in $argumentConditionList] where + f() == + y:= SUBST(a,'_#1,x) + T := [.,.,e]:= compOrCroak(y,$Boolean,e) + [n,x,T.expr] + e + +addArgumentConditions($body,$functionName) == + $argumentConditionList => + --$body is only used in this function + fn $argumentConditionList where + fn clist == + clist is [[n,untypedCondition,typedCondition],:.] => + ['COND,[typedCondition,fn rest clist], + [$true,["argumentDataError",n, + MKQ untypedCondition,MKQ $functionName]]] + null clist => $body + systemErrorHere '"addArgumentConditions" + $body + +putInLocalDomainReferences (def := [opName,[lam,varl,body]]) == + $elt: local := ($QuickCode => 'QREFELT; 'ELT) +--+ + NRTputInTail CDDADR def + def + + +canCacheLocalDomain(dom,elt)== + dom is [op,'_$,n] and MEMQ(op,'(ELT QREFELT)) => nil + domargsglobal(dom) => + $functorLocalParameters:= [:$functorLocalParameters,dom] + PUSH([dom,GENVAR(),[elt,$selector,$funcLocLen]],$usedDomList) + $selcount:= $selcount+1 + $funcLocLen:= $funcLocLen+1 + nil + where + domargsglobal(dom) == + dom='_$ => true + IDENTP dom => MEMQ(dom,$functorLocalParameters) + ATOM dom => true + and/[domargsglobal(arg) for arg in rest dom] + + +compileCases(x,$e) == -- $e is referenced in compile + $specialCaseKeyList: local + not ($insideFunctorIfTrue=true) => compile x + specialCaseAssoc:= + [y for y in getSpecialCaseAssoc() | not get(first y,"specialCase",$e) and + ([R,R']:= y) and isEltArgumentIn(FindNamesFor(R,R'),x)] where + FindNamesFor(R,R') == + [R,: + [v + for ['LET,v,u,:.] in $getDomainCode | CADR u=R and + eval substitute(R',R,u)]] + isEltArgumentIn(Rlist,x) == + atom x => nil + x is ['ELT,R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) + x is ["QREFELT",R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) + isEltArgumentIn(Rlist,first x) or isEltArgumentIn(Rlist,rest x) + null specialCaseAssoc => compile x + listOfDomains:= ASSOCLEFT specialCaseAssoc + listOfAllCases:= outerProduct ASSOCRIGHT specialCaseAssoc + cl:= + [u for l in listOfAllCases] where + u() == + $specialCaseKeyList:= [[D,:C] for D in listOfDomains for C in l] + [MKPF([["EQUAL",D,C] for D in listOfDomains for C in l],"AND"), + compile COPY x] + $specialCaseKeyList:= nil + ["COND",:cl,[$true,compile x]] + +getSpecialCaseAssoc() == + [[R,:l] for R in rest $functorForm + for l in rest $functorSpecialCases | l] + +compile u == + [op,lamExpr] := u + if $suffix then + $suffix:= $suffix+1 + op':= + opexport:=nil + opmodes:= + [sel + for [[DC,:sig],[.,sel]] in get(op,'modemap,$e) | + DC='_$ and (opexport:=true) and + (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])] + isLocalFunction op => + if opexport then userError ['%b,op,'%d,'" is local and exported"] + INTERN STRCONC(encodeItem $prefix,'";",encodeItem op) + isPackageFunction() and KAR $functorForm^="CategoryDefaults" => + if null opmodes then userError ['"no modemap for ",op] + opmodes is [['PAC,.,name]] => name + encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) + encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) + where + isLocalFunction op == + null member(op,$formalArgList) and + getmode(op,$e) is ['Mapping,:.] + u:= [op',lamExpr] + -- If just updating certain functions, check for previous existence. + -- Deduce old sequence number and use it (items have been skipped). + if $LISPLIB and $compileOnlyCertainItems then + parts := splitEncodedFunctionName(u.0, ";") +-- Next line JHD/SMWATT 7/17/86 to deal with inner functions + parts='inner => $savableItems:=[u.0,:$savableItems] + unew := nil + for [s,t] in $splitUpItemsAlreadyThere repeat + if parts.0=s.0 and parts.1=s.1 and parts.2=s.2 then unew := t + null unew => + sayBrightly ['" Error: Item did not previously exist"] + sayBrightly ['" Item not saved: ", :bright u.0] + sayBrightly ['" What's there is: ", $lisplibItemsAlreadyThere] + nil + sayBrightly ['" Renaming ", u.0, '" as ", unew] + u := [unew, :rest u] + $savableItems := [unew, :$saveableItems] -- tested by embedded RWRITE + optimizedBody:= optimizeFunctionDef u + stuffToCompile:= + if null $insideCapsuleFunctionIfTrue + then optimizedBody + else putInLocalDomainReferences optimizedBody + $doNotCompileJustPrint=true => (PRETTYPRINT stuffToCompile; op') + $macroIfTrue => constructMacro stuffToCompile + result:= spadCompileOrSetq stuffToCompile + functionStats:=[0,elapsedTime()] + $functionStats:= addStats($functionStats,functionStats) + printStats functionStats + result + +spadCompileOrSetq (form is [nam,[lam,vl,body]]) == + --bizarre hack to take account of the existence of "known" functions + --good for performance (LISPLLIB size, BPI size, NILSEC) + CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] + if vl is [:vl',E] and body is [nam',: =vl'] then + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] + else if (ATOM body or and/[ATOM x for x in body]) + and vl is [:vl',E] and not CONTAINED(E,body) then + macform := ['XLAM,vl',body] + LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] + sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] + $insideCapsuleFunctionIfTrue => first COMP LIST form + compileConstructor form + +compileConstructor form == + u:= compileConstructor1 form + clearClams() --clear all CLAMmed functions + u + +compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) == +-- fn is the name of some category/domain/package constructor; +-- we will cache all of its values on $ConstructorCache with reference +-- counts + $clamList: local + lambdaOrSlam := + GETDATABASE(fn,'CONSTRUCTORKIND) = 'category => 'SPADSLAM + $mutableDomain => 'LAMBDA + $clamList:= + [[fn,"$ConstructorCache",'domainEqualList,'count],:$clamList] + 'LAMBDA + compForm:= LIST [fn,[lambdaOrSlam,vl,:bodyl]] + if GETDATABASE(fn,'CONSTRUCTORKIND) = 'category + then u:= compAndDefine compForm + else u:=COMP compForm + clearConstructorCache fn --clear cache for constructor + first u + +constructMacro (form is [nam,[lam,vl,body]]) == + ^(and/[atom x for x in vl]) => + stackSemanticError(["illegal parameters for macro: ",vl],nil) + ["XLAM",vl':= [x for x in vl | IDENTP x],body] + +listInitialSegment(u,v) == + null u => true + null v => nil + first u=first v and listInitialSegment(rest u,rest v) + --returns true iff u.i=v.i for i in 1..(#u)-1 + +modemap2Signature [[.,:sig],:.] == sig + +uncons x == + atom x => x + x is ["CONS",a,b] => [a,:uncons b] + +--% CAPSULE + +bootStrapError(functorForm,sourceFile) == + ['COND, _ + ['$bootStrapMode, _ + ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]], + [''T, ['systemError,['LIST,''%b,MKQ CAR functorForm,''%d,'"from", _ + ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]] + +compAdd(['add,$addForm,capsule],m,e) == + $bootStrapMode = true => + if $addForm is ['Tuple,:.] then code := nil + else [code,m,e]:= comp($addForm,m,e) + [['COND, _ + ['$bootStrapMode, _ + code],_ + [''T, ['systemError,['LIST,''%b,MKQ CAR $functorForm,''%d,'"from", _ + ''%b,MKQ namestring _/EDITFILE,''%d,'"needs to be compiled"]]]],m,e] + $addFormLhs: local:= $addForm + if $addForm is ["SubDomain",domainForm,predicate] then + $packagesUsed := [domainForm,:$packagesUsed] +--+ + $NRTaddForm := domainForm + NRTgetLocalIndex domainForm + --need to generate slot for add form since all $ go-get + -- slots will need to access it + [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) + else + $packagesUsed := + $addForm is ['Tuple,:u] => [:u,:$packagesUsed] + [$addForm,:$packagesUsed] +--+ + $NRTaddForm := $addForm + [$addForm,.,e]:= + $addForm is ['Tuple,:.] => + $NRTaddForm := ['Tuple,:[NRTgetLocalIndex x for x in rest $addForm]] + compOrCroak(compTuple2Record $addForm,$EmptyMode,e) + compOrCroak($addForm,$EmptyMode,e) + compCapsule(capsule,m,e) + +compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]] + +compCapsule(['CAPSULE,:itemList],m,e) == + $bootStrapMode = true => + [bootStrapError($functorForm, _/EDITFILE),m,e] + $insideExpressionIfTrue: local:= false + compCapsuleInner(itemList,m,addDomain('_$,e)) + +compSubDomain(["SubDomain",domainForm,predicate],m,e) == + $addFormLhs: local:= domainForm + $addForm: local + $NRTaddForm := domainForm + [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) +--+ + compCapsule(['CAPSULE],m,e) + +compSubDomain1(domainForm,predicate,m,e) == + [.,.,e]:= + compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e)) + u:= + compOrCroak(predicate,$Boolean,e) or + stackSemanticError(["predicate: ",predicate, + " cannot be interpreted with #1: ",domainForm],nil) + prefixPredicate:= lispize u.expr + $lisplibSuperDomain:= + [domainForm,predicate] + evalAndRwriteLispForm('evalOnLoad2, + ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],' + (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[ + 'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF',' + (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]]) + [domainForm,m,e] + +compCapsuleInner(itemList,m,e) == + e:= addInformation(m,e) + --puts a new 'special' property of $Information + data:= ["PROGN",:itemList] + --RPLACd by compCapsuleItems and Friends + e:= compCapsuleItems(itemList,nil,e) + localParList:= $functorLocalParameters + if $addForm then data:= ['add,$addForm,data] + code:= + $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data + processFunctorOrPackage($form,$signature,data,localParList,m,e) + [MKPF([:$getDomainCode,code],"PROGN"),m,e] + +--% PROCESS FUNCTOR CODE + +processFunctor(form,signature,data,localParList,e) == + form is ["CategoryDefaults"] => + error "CategoryDefaults is a reserved name" + buildFunctor(form,signature,data,localParList,e) + +compCapsuleItems(itemlist,$predl,$e) == + $TOP__LEVEL: local + $myFunctorBody :local -- := data ---needed for translator + -- ??? the following line needs more investigation. Why is data + -- ??? expected to be a dynamic variable? Looks more like a bug. + if (BOUNDP 'data) then + $myFunctorBody:= SYMBOL_-VALUE 'data -- unbound at runtime? + $signatureOfForm: local + $suffix: local:= 0 + for item in itemlist repeat $e:= compSingleCapsuleItem(item,$predl,$e) + $e + +compSingleCapsuleItem(item,$predl,$e) == + doIt(macroExpandInPlace(item,$e),$predl) + $e + +doIt(item,$predl) == + $GENNO: local:= 0 + item is ['SEQ,:l,['exit,1,x]] => + RPLACA(item,"PROGN") + RPLACA(LASTNODE item,x) + for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) + --This will RPLAC as appropriate + isDomainForm(item,$e) => + -- convert naked top level domains to import + u:= ["import", [first item,:rest item]] + stackWarning ["Use: import ", [first item,:rest item]] + RPLACA(item,first u) + RPLACD(item,rest u) + doIt(item,$predl) + item is ['LET,lhs,rhs,:.] => + not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => + stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) + not (code is ['LET,lhs',rhs',:.] and atom lhs') => + code is ["PROGN",:.] => + stackSemanticError(["multiple assignment ",item," not allowed"],nil) + RPLACA(item,first code) + RPLACD(item,rest code) + lhs:= lhs' + if not member(KAR rhs,$NonMentionableDomainNames) and + not MEMQ(lhs, $functorLocalParameters) then + $functorLocalParameters:= [:$functorLocalParameters,lhs] + if code is ['LET,.,rhs',:.] and isDomainForm(rhs',$e) then + if isFunctor rhs' then + $functorsUsed:= insert(opOf rhs',$functorsUsed) + $packagesUsed:= insert([opOf rhs'],$packagesUsed) + if lhs="Rep" then + $Representation:= (get("Rep",'value,$e)).(0) + --$Representation bound by compDefineFunctor, used in compNoStacking +--+ + if $NRTopt = true + then NRTgetLocalIndex $Representation +--+ + $LocalDomainAlist:= --see genDeltaEntry + [[lhs,:SUBLIS($LocalDomainAlist,(get(lhs,'value,$e)).0)],:$LocalDomainAlist] +--+ + code is ['LET,:.] => + RPLACA(item,($QuickCode => 'QSETREFV;'SETELT)) + rhsCode:= + rhs' + RPLACD(item,['$,NRTgetLocalIndexClear lhs,rhsCode]) + RPLACA(item,first code) + RPLACD(item,rest code) + item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) + item is ["import",:doms] => + for dom in doms repeat + sayBrightly ['" importing ",:formatUnabbreviated dom] + [.,.,$e] := compOrCroak(item,$EmptyMode,$e) + RPLACA(item,'PROGN) + RPLACD(item,NIL) -- creates a no-op + item is ["IF",:.] => doItIf(item,$predl,$e) + item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) + item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) + item is ['DEF,[op,:.],:.] => + body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) + [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) + RPLACA(item,"CodeDefine") + --Note that DescendCode, in CodeDefine, is looking for this + RPLACD(CADR item,[$signatureOfForm]) + --This is how the signature is updated for buildFunctor to recognise +--+ + functionPart:= ['dispatchFunction,t.expr] + RPLACA(CDDR item,functionPart) + RPLACD(CDDR item,nil) + u:= compOrCroak(item,$EmptyMode,$e) => + ([code,.,$e]:= u; RPLACA(item,first code); RPLACD(item,rest code)) + true => cannotDo() + +isMacro(x,e) == + x is ['DEF,[op,:args],signature,specialCases,body] and + null get(op,'modemap,e) and null args and null get(op,'mode,e) + and signature is [nil] => body + +doItIf(item is [.,p,x,y],$predl,$e) == + olde:= $e + [p',.,$e]:= comp(p,$Boolean,$e) or userError ['"not a Boolean:",p] + oldFLP:=$functorLocalParameters + if x^="noBranch" then + compSingleCapsuleItem(x,$predl,getSuccessEnvironment(p,$e)) + x':=localExtras(oldFLP) + oldFLP:=$functorLocalParameters + if y^="noBranch" then + compSingleCapsuleItem(y,$predl,getInverseEnvironment(p,olde)) + y':=localExtras(oldFLP) + RPLACA(item,"COND") + RPLACD(item,[[p',x,:x'],['(QUOTE T),y,:y']]) + where localExtras(oldFLP) == + EQ(oldFLP,$functorLocalParameters) => NIL + flp1:=$functorLocalParameters + oldFLP':=oldFLP + n:=0 + while oldFLP' repeat + oldFLP':=CDR oldFLP' + flp1:=CDR flp1 + n:=n+1 + -- Now we have to add code to compile all the elements + -- of functorLocalParameters that were added during the + -- conditional compilation + nils:=ans:=[] + for u in flp1 repeat -- is =u form always an ATOM? + if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) + then + nils:=[u,:nils] + else + gv := GENSYM() + ans:=[['LET,gv,u],:ans] + nils:=[gv,:nils] + n:=n+1 + $functorLocalParameters:=[:oldFLP,:NREVERSE nils] + NREVERSE ans + +--compSingleCapsuleIf(x,predl,e,$functorLocalParameters) == +-- compSingleCapsuleItem(x,predl,e) + +--% CATEGORY AND DOMAIN FUNCTIONS +compContained(["CONTAINED",a,b],m,e) == + [a,ma,e]:= comp(a,$EmptyMode,e) or return nil + [b,mb,e]:= comp(b,$EmptyMode,e) or return nil + isCategoryForm(ma,e) and isCategoryForm(mb,e) => + (T:= [["CONTAINED",a,b],$Boolean,e]; convert(T,m)) + nil + +compJoin(["Join",:argl],m,e) == + catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] + catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) + catList':= + [extract for x in catList] where + extract() == + isCategoryForm(x,e) => + parameters:= + union("append"/[getParms(y,e) for y in rest x],parameters) + where getParms(y,e) == + atom y => + isDomainForm(y,e) => LIST y + nil + y is ['LENGTH,y'] => [y,y'] + LIST y + x + x is ["DomainSubstitutionMacro",pl,body] => + (parameters:= union(pl,parameters); body) + x is ["mkCategory",:.] => x + atom x and getmode(x,e)=$Category => x + stackSemanticError(["invalid argument to Join: ",x],nil) + x + T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] + convert(T,m) + +compForMode(x,m,e) == + $compForModeIfTrue: local:= true + comp(x,m,e) + +compMakeCategoryObject(c,$e) == + not isCategoryForm(c,$e) => nil + u:= mkEvalableCategoryForm c => [eval u,$Category,$e] + nil + +quotifyCategoryArgument x == MKQ x + +makeCategoryForm(c,e) == + not isCategoryForm(c,e) => nil + [x,m,e]:= compOrCroak(c,$EmptyMode,e) + [x,e] + +compCategory(x,m,e) == + $TOP__LEVEL: local:= true + (m:= resolve(m,["Category"]))=["Category"] and x is ['CATEGORY, + domainOrPackage,:l] => + $sigList: local + $atList: local + $sigList:= $atList:= nil + for x in l repeat compCategoryItem(x,nil) + rep:= mkExplicitCategoryFunction(domainOrPackage,$sigList,$atList) + --if inside compDefineCategory, provide for category argument substitution + [rep,m,e] + systemErrorHere '"compCategory" + +mkExplicitCategoryFunction(domainOrPackage,sigList,atList) == + body:= + ["mkCategory",MKQ domainOrPackage,['LIST,:REVERSE sigList],['LIST,: + REVERSE atList],MKQ domList,nil] where + domList() == + ("union"/[fn sig for ["QUOTE",[[.,sig,:.],:.]] in sigList]) where + fn sig == [D for D in sig | mustInstantiate D] + parameters:= + REMDUP + ("append"/ + [[x for x in sig | IDENTP x and x^='_$] + for ["QUOTE",[[.,sig,:.],:.]] in sigList]) + wrapDomainSub(parameters,body) + +wrapDomainSub(parameters,x) == + ["DomainSubstitutionMacro",parameters,x] + +mustInstantiate D == + D is [fn,:.] and ^(MEMQ(fn,$DummyFunctorNames) or GETL(fn,"makeFunctionList")) + +DomainSubstitutionFunction(parameters,body) == + --see definition of DomainSubstitutionMacro in SPAD LISP + if parameters then + (body:= Subst(parameters,body)) where + Subst(parameters,body) == + ATOM body => + MEMQ(body,parameters) => MKQ body + body + member(body,parameters) => + g:=GENSYM() + $extraParms:=PUSH([g,:body],$extraParms) + --Used in SetVector12 to generate a substitution list + --bound in buildFunctor + --For categories, bound and used in compDefineCategory + MKQ g + first body="QUOTE" => body + PAIRP $definition and + isFunctor first body and + first body ^= first $definition + => ['QUOTE,optimize body] + [Subst(parameters,u) for u in body] + not (body is ["Join",:.]) => body + atom $definition => body + null rest $definition => body + --should not bother if it will only be called once + name:= INTERN STRCONC(KAR $definition,";CAT") + SETANDFILE(name,nil) + body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]] + body + +compCategoryItem(x,predl) == + x is nil => nil + --1. if x is a conditional expression, recurse; otherwise, form the predicate + x is ["COND",[p,e]] => + predl':= [p,:predl] + e is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') + compCategoryItem(e,predl') + x is ["IF",a,b,c] => + predl':= [a,:predl] + if b^="noBranch" then + b is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') + compCategoryItem(b,predl') + c="noBranch" => nil + predl':= [["not",a],:predl] + c is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') + compCategoryItem(c,predl') + pred:= (predl => MKPF(predl,"AND"); true) + + --2. if attribute, push it and return + x is ["ATTRIBUTE",y] => PUSH(MKQ [y,pred],$atList) + + --3. it may be a list, with PROGN as the CAR, and some information as the CDR + x is ["PROGN",:l] => for u in l repeat compCategoryItem(u,predl) + +-- 4. otherwise, x gives a signature for a +-- single operator name or a list of names; if a list of names, +-- recurse + ["SIGNATURE",op,:sig]:= x + null atom op => + for y in op repeat compCategoryItem(["SIGNATURE",y,:sig],predl) + + --4. branch on a single type or a signature %with source and target + PUSH(MKQ [rest x,pred],$sigList) + + + + + + + + diff --git a/src/interp/define.boot.pamphlet b/src/interp/define.boot.pamphlet deleted file mode 100644 index 6bebbf01..00000000 --- a/src/interp/define.boot.pamphlet +++ /dev/null @@ -1,1543 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/interp/define.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject - -\section{compCapsuleItems} - -The variable [[data]] appears to be unbound at runtime. Optimized -code won't check for this but interpreted code fails. We should -PROVE that data is unbound at runtime but have not done so yet. -Rather than remove the code entirely (since there MIGHT be a -path where it is used) we check for the runtime bound case and -assign [[$myFunctorBody]] if data has a value. - -The [[compCapsuleInner]] function in this file LOOKS like it sets -data and expects code to manipulate the assigned data structure. -Since we can't be sure we take the least disruptive course of action. -<>= -compCapsuleItems(itemlist,$predl,$e) == - $TOP__LEVEL: local - $myFunctorBody :local -- := data ---needed for translator - if (BOUNDP 'data) then - $myFunctorBody:= SYMBOL_-VALUE 'data -- unbound at runtime? - $signatureOfForm: local - $suffix: local:= 0 - for item in itemlist repeat $e:= compSingleCapsuleItem(item,$predl,$e) - $e - -@ -\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. - -@ -<<*>>= -<> - -import '"c-util" -import '"cattable" -import '"category" -)package "BOOT" - -NRTPARSE := false - ---% FUNCTIONS WHICH MUNCH ON == STATEMENTS - -compDefine(form,m,e) == - $tripleHits: local:= 0 - $macroIfTrue: local - $packagesUsed: local - result:= compDefine1(form,m,e) - result - -compDefine1(form,m,e) == - $insideExpressionIfTrue: local:= false - --1. decompose after macro-expanding form - ['DEF,lhs,signature,specialCases,rhs]:= form:= macroExpand(form,e) - $insideWhereIfTrue and isMacro(form,e) and (m=$EmptyMode or m=$NoValueMode) - => [lhs,m,put(first lhs,'macro,rhs,e)] - null signature.target and not MEMQ(KAR rhs,$ConstructorNames) and - (sig:= getSignatureFromMode(lhs,e)) => - -- here signature of lhs is determined by a previous declaration - compDefine1(['DEF,lhs,[first sig,:rest signature],specialCases,rhs],m,e) - if signature.target=$Category then $insideCategoryIfTrue:= true ---?? following 3 lines seem bogus, BMT 6/23/93 ---? if signature.target is ['Mapping,:map] then ---? signature:= map ---? form:= ['DEF,lhs,signature,specialCases,rhs] - --- RDJ (11/83): when argument and return types are all declared, --- or arguments have types declared in the environment, --- and there is no existing modemap for this signature, add --- the modemap by a declaration, then strip off declarations and recurse - e := compDefineAddSignature(lhs,signature,e) --- 2. if signature list for arguments is not empty, replace ('DEF,..) by --- ('where,('DEF,..),..) with an empty signature list; --- otherwise, fill in all NILs in the signature - not (and/[null x for x in rest signature]) => compDefWhereClause(form,m,e) - signature.target=$Category => - compDefineCategory(form,m,e,nil,$formalArgList) - isDomainForm(rhs,e) and not $insideFunctorIfTrue => - if null signature.target then signature:= - [getTargetFromRhs(lhs,rhs,giveFormalParametersValues(rest lhs,e)),: - rest signature] - rhs:= addEmptyCapsuleIfNecessary(signature.target,rhs) - compDefineFunctor(['DEF,lhs,signature,specialCases,rhs],m,e,nil, - $formalArgList) - null $form => stackAndThrow ['"bad == form ",form] - newPrefix:= - $prefix => INTERN STRCONC(encodeItem $prefix,'",",encodeItem $op) - getAbbreviation($op,#rest $form) - compDefineCapsuleFunction(form,m,e,newPrefix,$formalArgList) - -compDefineAddSignature([op,:argl],signature,e) == - (sig:= hasFullSignature(argl,signature,e)) and - not assoc(['$,:sig],LASSOC('modemap,getProplist(op,e))) => - declForm:= - [":",[op,:[[":",x,m] for x in argl for m in rest sig]],first signature] - [.,.,e]:= comp(declForm,$EmptyMode,e) - e - e - -hasFullSignature(argl,[target,:ml],e) == - target => - u:= [m or get(x,"mode",e) or return 'failed for x in argl for m in ml] - u^='failed => [target,:u] - -addEmptyCapsuleIfNecessary(target,rhs) == - MEMQ(KAR rhs,$SpecialDomainNames) => rhs - ['add,rhs,['CAPSULE]] - -getTargetFromRhs(lhs,rhs,e) == - --undeclared target mode obtained from rhs expression - rhs is ['CAPSULE,:.] => - stackSemanticError(['"target category of ",lhs, - '" cannot be determined from definition"],nil) - rhs is ['SubDomain,D,:.] => getTargetFromRhs(lhs,D,e) - rhs is ['add,D,['CAPSULE,:.]] => getTargetFromRhs(lhs,D,e) - rhs is ['Record,:l] => ['RecordCategory,:l] - rhs is ['Union,:l] => ['UnionCategory,:l] - rhs is ['List,:l] => ['ListCategory,:l] - rhs is ['Vector,:l] => ['VectorCategory,:l] - [.,target,.]:= compOrCroak(rhs,$EmptyMode,e) - target - -giveFormalParametersValues(argl,e) == - for x in argl repeat - e:= put(x,'value,[genSomeVariable(),get(x,'mode,e),nil],e) - e - -macroExpandInPlace(x,e) == - y:= macroExpand(x,e) - atom x or atom y => y - RPLACA(x,first y) - RPLACD(x,rest y) - x - -macroExpand(x,e) == --not worked out yet - atom x => (u:= get(x,'macro,e) => macroExpand(u,e); x) - x is ['DEF,lhs,sig,spCases,rhs] => - ['DEF,macroExpand(lhs,e),macroExpandList(sig,e),macroExpandList(spCases,e), - macroExpand(rhs,e)] - macroExpandList(x,e) - -macroExpandList(l,e) == - -- macros should override niladic props - (l is [name]) and IDENTP name and GETDATABASE(name, 'NILADIC) and - (u := get(name, 'macro, e)) => macroExpand(u,e) - [macroExpand(x,e) for x in l] - -compDefineCategory1(df is ['DEF,form,sig,sc,body],m,e,prefix,fal) == - categoryCapsule := ---+ - body is ['add,cat,capsule] => - body := cat - capsule - nil - [d,m,e]:= compDefineCategory2(form,sig,sc,body,m,e,prefix,fal) ---+ next two lines - if categoryCapsule and not $bootStrapMode then [.,.,e] := - $insideCategoryPackageIfTrue: local := true --see NRTmakeSlot1 ---> - $categoryPredicateList: local := - makeCategoryPredicates(form,$lisplibCategory) - compDefine1(mkCategoryPackage(form,cat,categoryCapsule),$EmptyMode,e) - [d,m,e] - -makeCategoryPredicates(form,u) == - $tvl := TAKE(#rest form,$TriangleVariableList) - $mvl := TAKE(#rest form,rest $FormalMapVariableList) - fn(u,nil) where - fn(u,pl) == - u is ['Join,:.,a] => fn(a,pl) - u is ['has,:.] => insert(EQSUBSTLIST($mvl,$tvl,u),pl) - u is [op,:.] and MEMQ(op,'(SIGNATURE ATTRIBUTE)) => pl - atom u => pl - fnl(u,pl) - fnl(u,pl) == - for x in u repeat pl := fn(x,pl) - pl - ---+ the following function -mkCategoryPackage(form is [op,:argl],cat,def) == - packageName:= INTERN(STRCONC(PNAME op,'"&")) - packageAbb := INTERN(STRCONC(GETDATABASE(op,'ABBREVIATION),'"-")) - $options:local := [] - -- This stops the next line from becoming confused - abbreviationsSpad2Cmd ['domain,packageAbb,packageName] - -- This is a little odd, but the parser insists on calling - -- domains, rather than packages - nameForDollar := first SETDIFFERENCE('(S A B C D E F G H I),argl) - packageArgl := [nameForDollar,:argl] - capsuleDefAlist := fn(def,nil) where fn(x,oplist) == - atom x => oplist - x is ['DEF,y,:.] => [y,:oplist] - fn(rest x,fn(first x,oplist)) - explicitCatPart := gn cat where gn cat == - cat is ['CATEGORY,:.] => rest rest cat - cat is ['Join,:u] => gn last u - nil - catvec := eval mkEvalableCategoryForm form - fullCatOpList:=(JoinInner([catvec],$e)).1 - catOpList := - --note: this gets too many modemaps in general - -- this is cut down in NRTmakeSlot1 - [['SIGNATURE,op1,sig] for [[op1,sig],:.] in fullCatOpList - --above line calls the category constructor just compiled - | assoc(op1,capsuleDefAlist)] - null catOpList => nil - packageCategory := ['CATEGORY,'domain, - :SUBLISLIS(argl,$FormalMapVariableList,catOpList)] - nils:= [nil for x in argl] - packageSig := [packageCategory,form,:nils] - $categoryPredicateList := SUBST(nameForDollar,'$,$categoryPredicateList) - SUBST(nameForDollar,'$, - ['DEF,[packageName,:packageArgl],packageSig,[nil,:nils],def]) - -compDefineCategory2(form,signature,specialCases,body,m,e, - $prefix,$formalArgList) == - --1. bind global variables - $insideCategoryIfTrue: local:= true - $TOP__LEVEL: local - $definition: local - --used by DomainSubstitutionFunction - $form: local - $op: local - $extraParms: local - --Set in DomainSubstitutionFunction, used further down --- 1.1 augment e to add declaration $: - [$op,:argl]:= $definition:= form - e:= addBinding("$",[['mode,:$definition]],e) - --- 2. obtain signature - signature':= - [first signature,:[getArgumentModeOrMoan(a,$definition,e) for a in argl]] - e:= giveFormalParametersValues(argl,e) - --- 3. replace arguments by $1,..., substitute into body, --- and introduce declarations into environment - sargl:= TAKE(# argl, $TriangleVariableList) - $functorForm:= $form:= [$op,:sargl] - $formalArgList:= [:sargl,:$formalArgList] - aList:= [[a,:sa] for a in argl for sa in sargl] - formalBody:= SUBLIS(aList,body) - signature' := SUBLIS(aList,signature') ---Begin lines for category default definitions - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $frontier: local := 0 - $getDomainCode: local := nil - $addForm: local:= nil - for x in sargl for t in rest signature' repeat - [.,.,e]:= compMakeDeclaration([":",x,t],m,e) - --- 4. compile body in environment of %type declarations for arguments - op':= $op - -- following line causes cats with no with or Join to be fresh copies - if opOf(formalBody)^='Join and opOf(formalBody)^='mkCategory then - formalBody := ['Join, formalBody] - body:= optFunctorBody (compOrCroak(formalBody,signature'.target,e)).expr - if $extraParms then - formals:=actuals:=nil - for u in $extraParms repeat - formals:=[CAR u,:formals] - actuals:=[MKQ CDR u,:actuals] - body := ['sublisV,['PAIR,['QUOTE,formals],['LIST,:actuals]],body] - if argl then body:= -- always subst for args after extraparms - ['sublisV,['PAIR,['QUOTE,sargl],['LIST,: - [['devaluate,u] for u in sargl]]],body] - body:= - ['PROG1,['LET,g:= GENSYM(),body],['SETELT,g,0,mkConstructor $form]] - fun:= compile [op',['LAM,sargl,body]] - --- 5. give operator a 'modemap property - pairlis:= [[a,:v] for a in argl for v in $FormalMapVariableList] - parSignature:= SUBLIS(pairlis,signature') - parForm:= SUBLIS(pairlis,form) - lisplibWrite('"compilerInfo", - removeZeroOne ['SETQ,'$CategoryFrame, - ['put,['QUOTE,op'],' - (QUOTE isCategory),true,['addModemap,MKQ op',MKQ parForm, - MKQ parSignature,true,MKQ fun,'$CategoryFrame]]],$libFile) - --Equivalent to the following two lines, we hope - if null sargl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP,['QUOTE,op'],'(QUOTE NILADIC),true]) - --- 6. put modemaps into InteractiveModemapFrame - $domainShell := eval [op',:MAPCAR('MKQ,sargl)] - $lisplibCategory:= formalBody - if $LISPLIB then - $lisplibForm:= form - $lisplibKind:= 'category - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - $lisplibParents := - getParentsFor($op,$FormalMapVariableList,$lisplibCategory) - $lisplibAncestors := computeAncestorsOf($form,nil) - $lisplibAbbreviation := constructor? $op - form':=[op',:sargl] - augLisplibModemapsFromCategory(form',formalBody,signature') - [fun,'(Category),e] - -mkConstructor form == - atom form => ['devaluate,form] - null rest form => ['QUOTE,[first form]] - ['LIST,MKQ first form,:[mkConstructor x for x in rest form]] - -compDefineCategory(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $lisplibCategory: local - not $insideFunctorIfTrue and $LISPLIB => - compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) - compDefineCategory1(df,m,e,prefix,fal) - -compDefineFunctor(df,m,e,prefix,fal) == - $domainShell: local -- holds the category of the object being compiled - $profileCompiler: local := true - $profileAlist: local := nil - $LISPLIB => compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) - compDefineFunctor1(df,m,e,prefix,fal) - -compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], - m,$e,$prefix,$formalArgList) == - if NRTPARSE = true then - [lineNumber,:$functorSpecialCases] := $functorSpecialCases --- 1. bind global variables - $addForm: local - $viewNames: local:= nil - - --This list is only used in genDomainViewName, for generating names - --for alternate views, if they do not already exist. - --format: Alist: (domain name . sublist) - --sublist is alist: category . name of view - $functionStats: local:= [0,0] - $functorStats: local:= [0,0] - $form: local - $op: local - $signature: local - $functorTarget: local - $Representation: local - --Set in doIt, accessed in the compiler - compNoStacking - $LocalDomainAlist: local --set in doIt, accessed in genDeltaEntry - $LocalDomainAlist:= nil - $functorForm: local - $functorLocalParameters: local - SETQ($myFunctorBody, body) - $CheckVectorList: local - --prevents CheckVector from printing out same message twice - $getDomainCode: local -- code for getting views - $insideFunctorIfTrue: local:= true - $functorsUsed: local --not currently used, finds dependent functors - $setelt: local := - $QuickCode = true => 'QSETREFV - 'SETELT - $TOP__LEVEL: local - $genSDVar: local:= 0 - originale:= $e - [$op,:argl]:= form - $formalArgList:= [:argl,:$formalArgList] - $pairlis := [[a,:v] for a in argl for v in $FormalMapVariableList] - $mutableDomain: local := - -- all defaulting packages should have caching turned off - isCategoryPackageName $op or - (if BOUNDP '$mutableDomains then MEMQ($op,$mutableDomains) - else false ) --true if domain has mutable state - signature':= - [first signature,:[getArgumentModeOrMoan(a,form,$e) for a in argl]] - $functorForm:= $form:= [$op,:argl] - if null first signature' then signature':= - modemap2Signature getModemap($form,$e) - target:= first signature' - $functorTarget:= target - $e:= giveFormalParametersValues(argl,$e) - [ds,.,$e]:= compMakeCategoryObject(target,$e) or ---+ copy needed since slot1 is reset; compMake.. can return a cached vector - sayBrightly '" cannot produce category object:" - pp target - return nil - $domainShell:= COPY_-SEQ ds - $attributesName:local := INTERN STRCONC(PNAME $op,'";attributes") - attributeList := disallowNilAttribute ds.2 --see below under "loadTimeAlist" ---+ 7 lines for $NRT follow - $goGetList: local := nil --->--these globals used by NRTmakeCategoryAlist, set by NRTsetVector4Part1 - $condAlist: local := nil - $uncondAlist: local := nil --->>-- next global initialized here, reset by NRTbuildFunctor - $NRTslot1PredicateList: local := - REMDUP [CADR x for x in attributeList] --->>-- next global initialized here, used by NRTgenAttributeAlist (NRUNOPT) - $NRTattributeAlist: local := NRTgenInitialAttributeAlist attributeList - $NRTslot1Info: local --set in NRTmakeSlot1 called by NRTbuildFunctor - --this is used below to set $lisplibSlot1 global - $NRTbase: local := 6 -- equals length of $domainShell - $NRTaddForm: local := nil -- see compAdd; NRTmakeSlot1 - $NRTdeltaList: local := nil --list of misc. elts used in compiled fncts - $NRTdeltaListComp: local := nil --list of COMP-ed forms for $NRTdeltaList - $NRTaddList: local := nil --list of fncts not defined in capsule (added) - $NRTdeltaLength: local := 0 -- =length of block of extra entries in vector - $NRTloadTimeAlist: local := nil --used for things in slot4 (NRTsetVector4) - $NRTdomainFormList: local := nil -- of form ((gensym . (Repe...)) ... - -- the above optimizes the calls to local domains - $template: local:= nil --stored in the lisplib (if $NRTvec = true) - $functionLocations: local := nil --locations of defined functions in source - -- generate slots for arguments first, then for $NRTaddForm in compAdd - for x in argl repeat NRTgetLocalIndex x - [.,.,$e]:= compMakeDeclaration([":",'_$,target],m,$e) - --The following loop sees if we can economise on ADDed operations - --by using those of Rep, if that is the same. Example: DIRPROD - if $insideCategoryPackageIfTrue^= true then - if body is ['add,ab:=[fn,:.],['CAPSULE,:cb]] and MEMQ(fn,'(List Vector)) - and FindRep(cb) = ab - where FindRep cb == - u:= - while cb repeat - ATOM cb => return nil - cb is [['LET,'Rep,v,:.],:.] => return (u:=v) - cb:=CDR cb - u - then $e:= augModemapsFromCategoryRep('_$,ab,cb,target,$e) - else $e:= augModemapsFromCategory('_$,'_$,'_$,target,$e) - $signature:= signature' - operationAlist:= SUBLIS($pairlis,$domainShell.(1)) - parSignature:= SUBLIS($pairlis,signature') - parForm:= SUBLIS($pairlis,form) - --- (3.1) now make a list of the functor's local parameters; for --- domain D in argl,check its signature: if domain, its type is Join(A1,..,An); --- in this case, D is replaced by D1,..,Dn (gensyms) which are set --- to the A1,..,An view of D - if isPackageFunction() then $functorLocalParameters:= - [nil,: - [nil - for i in 6..MAXINDEX $domainShell | - $domainShell.i is [.,.,['ELT,'_$,.]]]] - --leave space for vector ops and package name to be stored ---+ - $functorLocalParameters:= - argPars := - makeFunctorArgumentParameters(argl,rest signature',first signature') - -- must do above to bring categories into scope --see line 5 of genDomainView - argl --- 4. compile body in environment of %type declarations for arguments - op':= $op - rettype:= signature'.target - T:= compFunctorBody(body,rettype,$e,parForm) - -- If only compiling certain items, then ignore the body shell. - $compileOnlyCertainItems => - reportOnFunctorCompilation() - [nil, ['Mapping, :signature'], originale] - - body':= T.expr - lamOrSlam:= if $mutableDomain then 'LAM else 'SPADSLAM - fun:= compile SUBLIS($pairlis, [op',[lamOrSlam,argl,body']]) - --The above statement stops substitutions gettting in one another's way ---+ - operationAlist := SUBLIS($pairlis,$lisplibOperationAlist) - if $LISPLIB then - augmentLisplibModemapsFromFunctor(parForm,operationAlist,parSignature) - reportOnFunctorCompilation() - --- 5. give operator a 'modemap property --- if $functorsUsed then MAKEPROP(op',"NEEDS",$functorsUsed) - if $LISPLIB then - modemap:= [[parForm,:parSignature],[true,op']] - $lisplibModemap:= modemap - $lisplibCategory := modemap.mmTarget - $lisplibParents := - getParentsFor($op,$FormalMapVariableList,$lisplibCategory) - $lisplibAncestors := computeAncestorsOf($form,nil) - $lisplibAbbreviation := constructor? $op - $insideFunctorIfTrue:= false - if $LISPLIB then - $lisplibKind:= -------->This next line prohibits changing the KIND once given ---------kk:=GETDATABASE($op,'CONSTRUCTORKIND) => kk - $functorTarget is ["CATEGORY",key,:.] and key^="domain" => 'package - 'domain - $lisplibForm:= form - if null $bootStrapMode then - $NRTslot1Info := NRTmakeSlot1Info() - $isOpPackageName: local := isCategoryPackageName $op - if $isOpPackageName then lisplibWrite('"slot1DataBase", - ['updateSlot1DataBase,MKQ $NRTslot1Info],$libFile) - $lisplibFunctionLocations := SUBLIS($pairlis,$functionLocations) - $lisplibCategoriesExtended := SUBLIS($pairlis,$lisplibCategoriesExtended) - -- see NRTsetVector4 for initial setting of $lisplibCategoriesExtended - libFn := GETDATABASE(op','ABBREVIATION) - $lookupFunction: local := - NRTgetLookupFunction($functorForm,CADAR $lisplibModemap,$NRTaddForm) - --either lookupComplete (for forgetful guys) or lookupIncomplete - $byteAddress :local := 0 - $byteVec :local := nil - $NRTslot1PredicateList := - [simpBool x for x in $NRTslot1PredicateList] - rwriteLispForm('loadTimeStuff, - ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) - $lisplibSlot1 := $NRTslot1Info --NIL or set by $NRTmakeSlot1 - $lisplibOperationAlist:= operationAlist - $lisplibMissingFunctions:= $CheckVectorList - lisplibWrite('"compilerInfo", - removeZeroOne ['SETQ,'$CategoryFrame, - ['put,['QUOTE,op'],' - (QUOTE isFunctor), - ['QUOTE,operationAlist],['addModemap,['QUOTE,op'],[' - QUOTE,parForm],['QUOTE,parSignature],true,['QUOTE,op'], - ['put,['QUOTE,op' ],'(QUOTE mode), - ['QUOTE,['Mapping,:parSignature]],'$CategoryFrame]]]], $libFile) - if null argl then - evalAndRwriteLispForm('NILADIC, - ['MAKEPROP, ['QUOTE,op'], ['QUOTE,'NILADIC], true]) - [fun,['Mapping,:signature'],originale] - -disallowNilAttribute x == - res := [y for y in x | car y and car y ^= "nil"] ---HACK to get rid of nil attibutes ---NOTE: nil is RENAMED to NIL - -compFunctorBody(body,m,e,parForm) == - $bootStrapMode = true => - [bootStrapError($functorForm, _/EDITFILE),m,e] - T:= compOrCroak(body,m,e) - body is [op,:.] and MEMQ(op,'(add CAPSULE)) => T - $NRTaddForm := - body is ["SubDomain",domainForm,predicate] => domainForm - body - T - -reportOnFunctorCompilation() == - displayMissingFunctions() - if $semanticErrorStack then sayBrightly '" " - displaySemanticErrors() - if $warningStack then sayBrightly '" " - displayWarnings() - $functorStats:= addStats($functorStats,$functionStats) - [byteCount,elapsedSeconds] := $functorStats - sayBrightly ['%l,:bright '" Cumulative Statistics for Constructor", - $op] - timeString := normalizeStatAndStringify elapsedSeconds - sayBrightly ['" Time:",:bright timeString,'"seconds"] - sayBrightly '" " - 'done - -displayMissingFunctions() == - null $CheckVectorList => nil - loc := nil - exp := nil - for [[op,sig,:.],:pred] in $CheckVectorList | null pred repeat - null member(op,$formalArgList) and - getmode(op,$env) is ['Mapping,:.] => - loc := [[op,sig],:loc] - exp := [[op,sig],:exp] - if loc then - sayBrightly ['%l,:bright '" Missing Local Functions:"] - for [op,sig] in loc for i in 1.. repeat - sayBrightly ['" [",i,'"]",:bright op, - ": ",:formatUnabbreviatedSig sig] - if exp then - sayBrightly ['%l,:bright '" Missing Exported Functions:"] - for [op,sig] in exp for i in 1.. repeat - sayBrightly ['" [",i,'"]",:bright op, - ": ",:formatUnabbreviatedSig sig] - ---% domain view code - -makeFunctorArgumentParameters(argl,sigl,target) == - $alternateViewList: local:= nil - $forceAdd: local:= true - $ConditionalOperators: local - ("append"/[fn(a,augmentSig(s,findExtras(a,target))) - for a in argl for s in sigl]) where - findExtras(a,target) == - -- see if conditional information implies anything else - -- in the signature of a - target is ['Join,:l] => "union"/[findExtras(a,x) for x in l] - target is ['CATEGORY,.,:l] => "union"/[findExtras1(a,x) for x in l] where - findExtras1(a,x) == - x is ['AND,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtras1(a,y) for y in l] - x is ['IF,c,p,q] => - union(findExtrasP(a,c), - union(findExtras1(a,p),findExtras1(a,q))) where - findExtrasP(a,x) == - x is ['AND,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['OR,:l] => "union"/[findExtrasP(a,y) for y in l] - x is ['has,=a,y] and y is ['SIGNATURE,:.] => [y] - nil - nil - augmentSig(s,ss) == - -- if we find something extra, add it to the signature - null ss => s - for u in ss repeat - $ConditionalOperators:=[CDR u,:$ConditionalOperators] - s is ['Join,:sl] => - u:=ASSQ('CATEGORY,ss) => - SUBST([:u,:ss],u,s) - ['Join,:sl,['CATEGORY,'package,:ss]] - ['Join,s,['CATEGORY,'package,:ss]] - fn(a,s) == - isCategoryForm(s,$CategoryFrame) => - s is ["Join",:catlist] => genDomainViewList0(a,rest s) - [genDomainView(a,a,s,"getDomainView")] - [a] - -genDomainViewList0(id,catlist) == - l:= genDomainViewList(id,catlist,true) - l - -genDomainViewList(id,catlist,firsttime) == - null catlist => nil - catlist is [y] and not isCategoryForm(y,$EmptyEnvironment) => nil - [genDomainView(if firsttime then id else genDomainViewName(id,first catlist), - id,first catlist,"getDomainView"),:genDomainViewList(id,rest catlist,nil)] - -genDomainView(viewName,originalName,c,viewSelector) == - c is ['CATEGORY,.,:l] => genDomainOps(viewName,originalName,c) - code:= - c is ['SubsetCategory,c',.] => c' - c - $e:= augModemapsFromCategory(originalName,viewName,nil,c,$e) - --$alternateViewList:= ((viewName,:code),:$alternateViewList) - cd:= ['LET,viewName,[viewSelector,originalName,mkDomainConstructor code]] - if null member(cd,$getDomainCode) then - $getDomainCode:= [cd,:$getDomainCode] - viewName - -genDomainOps(viewName,dom,cat) == - oplist:= getOperationAlist(dom,dom,cat) - siglist:= [sig for [sig,:.] in oplist] - oplist:= substNames(dom,viewName,dom,oplist) - cd:= - ['LET,viewName,['mkOpVec,dom,['LIST,: - [['LIST,MKQ op,['LIST,:[mkDomainConstructor mode for mode in sig]]] - for [op,sig] in siglist]]]] - $getDomainCode:= [cd,:$getDomainCode] - for [opsig,cond,:.] in oplist for i in 0.. repeat - if opsig in $ConditionalOperators then cond:=nil - [op,sig]:=opsig - $e:= addModemap(op,dom,sig,cond,['ELT,viewName,i],$e) - viewName - -mkOpVec(dom,siglist) == - dom:= getPrincipalView dom - substargs:= [['$,:dom.0],: - [[a,:x] for a in $FormalMapVariableList for x in rest dom.0]] - oplist:= getOperationAlistFromLisplib opOf dom.0 - --new form is ( ) - ops:= MAKE_-VEC (#siglist) - for (opSig:= [op,sig]) in siglist for i in 0.. repeat - u:= ASSQ(op,oplist) - assoc(sig,u) is [.,n,.,'ELT] => ops.i := dom.n - noplist:= SUBLIS(substargs,u) - -- following variation on assoc needed for GENSYMS in Mutable domains - AssocBarGensym(SUBST(dom.0,'$,sig),noplist) is [.,n,.,'ELT] => - ops.i := dom.n - ops.i := [function Undef,[dom.0,i],:opSig] - ops - -genDomainViewName(a,category) == ---+ - a - -compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == --- form is lhs (f a1 ... an) of definition; body is rhs; --- signature is (t0 t1 ... tn) where t0= target type, ti=type of ai, i > 0; --- specialCases is (NIL l1 ... ln) where li is list of special cases --- which can be given for each ti - --- removes declarative and assignment information from form and --- signature, placing it in list L, replacing form by ("where",form',:L), --- signature by a list of NILs (signifying declarations are in e) - $sigAlist: local - $predAlist: local - --- 1. create sigList= list of all signatures which have embedded --- declarations moved into global variable $sigAlist - sigList:= - [transformType fetchType(a,x,e,form) for a in rest form for x in rest signature] - where - fetchType(a,x,e,form) == - x => x - getmode(a,e) or userError concat( - '"There is no mode for argument",a,'"of function",first form) - transformType x == - atom x => x - x is [":",R,Rtype] => - ($sigAlist:= [[R,:transformType Rtype],:$sigAlist]; x) - x is ['Record,:.] => x --RDJ 8/83 - [first x,:[transformType y for y in rest x]] - --- 2. replace each argument of the form (|| x p) by x, recording --- the given predicate in global variable $predAlist - argList:= - [removeSuchthat a for a in rest form] where - removeSuchthat x == - x is ["|",y,p] => ($predAlist:= [[y,:p],:$predAlist]; y) - x - --- 3. obtain a list of parameter identifiers (x1 .. xn) ordered so that --- the type of xi is independent of xj if i < j - varList:= - orderByDependency(ASSOCLEFT argDepAlist,ASSOCRIGHT argDepAlist) where - argDepAlist:= - [[x,:dependencies] for [x,:y] in argSigAlist] where - dependencies() == - union(listOfIdentifiersIn y, - delete(x,listOfIdentifiersIn LASSOC(x,$predAlist))) - argSigAlist:= [:$sigAlist,:pairList(argList,sigList)] - --- 4. construct a WhereList which declares and/or defines the xi's in --- the order constructed in step 3 - (whereList:= [addSuchthat(x,[":",x,LASSOC(x,argSigAlist)]) for x in varList]) - where addSuchthat(x,y) == (p:= LASSOC(x,$predAlist) => ["|",y,p]; y) - --- 5. compile new ('DEF,("where",form',:WhereList),:.) where --- all argument parameters of form' are bound/declared in WhereList - comp(form',m,e) where - form':= - ["where",defform,:whereList] where - defform:= - ['DEF,form'',signature',specialCases,body] where - form'':= [first form,:argList] - signature':= [first signature,:[nil for x in rest signature]] - -orderByDependency(vl,dl) == - -- vl is list of variables, dl is list of dependency-lists - selfDependents:= [v for v in vl for d in dl | MEMQ(v,d)] - for v in vl for d in dl | MEMQ(v,d) repeat - (SAY(v," depends on itself"); fatalError:= true) - fatalError => userError '"Parameter specification error" - until (null vl) repeat - newl:= - [v for v in vl for d in dl | null intersection(d,vl)] or return nil - orderedVarList:= [:newl,:orderedVarList] - vl':= setDifference(vl,newl) - dl':= [setDifference(d,newl) for x in vl for d in dl | member(x,vl')] - vl:= vl' - dl:= dl' - REMDUP NREVERSE orderedVarList --ordered so ith is indep. of jth if i < j - -compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], - m,oldE,$prefix,$formalArgList) == - [lineNumber,:specialCases] := specialCases - e := oldE - --1. bind global variables - $form: local - $op: local - $functionStats: local:= [0,0] - $argumentConditionList: local - $finalEnv: local - --used by ReplaceExitEtc to get a common environment - $initCapsuleErrorCount: local:= #$semanticErrorStack - $insideCapsuleFunctionIfTrue: local:= true - $CapsuleModemapFrame: local:= e - $CapsuleDomainsInScope: local:= get("$DomainsInScope","special",e) - $insideExpressionIfTrue: local:= true - $returnMode:= m - [$op,:argl]:= form - $form:= [$op,:argl] - argl:= stripOffArgumentConditions argl - $formalArgList:= [:argl,:$formalArgList] - - --let target and local signatures help determine modes of arguments - argModeList:= - identSig:= hasSigInTargetCategory(argl,form,first signature,e) => - (e:= checkAndDeclare(argl,form,identSig,e); rest identSig) - [getArgumentModeOrMoan(a,form,e) for a in argl] - argModeList:= stripOffSubdomainConditions(argModeList,argl) - signature':= [first signature,:argModeList] - if null identSig then --make $op a local function - oldE := put($op,'mode,['Mapping,:signature'],oldE) - - --obtain target type if not given - if null first signature' then signature':= - identSig => identSig - getSignature($op,rest signature',e) or return nil - e:= giveFormalParametersValues(argl,e) - - $signatureOfForm:= signature' --this global is bound in compCapsuleItems - $functionLocations := [[[$op,$signatureOfForm],:lineNumber], - :$functionLocations] - e:= addDomain(first signature',e) - e:= compArgumentConditions e - - if $profileCompiler then - for x in argl for t in rest signature' repeat profileRecord('arguments,x,t) - - - --4. introduce needed domains into extendedEnv - for domain in signature' repeat e:= addDomain(domain,e) - - --6. compile body in environment with extended environment - rettype:= resolve(signature'.target,$returnMode) - - localOrExported := - null member($op,$formalArgList) and - getmode($op,e) is ['Mapping,:.] => 'local - 'exported - - --6a skip if compiling only certain items but not this one - -- could be moved closer to the top - formattedSig := formatUnabbreviated ['Mapping,:signature'] - $compileOnlyCertainItems and _ - not member($op, $compileOnlyCertainItems) => - sayBrightly ['" skipping ", localOrExported,:bright $op] - [nil,['Mapping,:signature'],oldE] - sayBrightly ['" compiling ",localOrExported, - :bright $op,'": ",:formattedSig] - - if $newComp = true then - wholeBody := ['DEF, form, signature', specialCases, body] - T := CATCH('compCapsuleBody, newComp(wholeBody,$NoValueMode,e)) - or [" ",rettype,e] - T := [T.expr.2.2, rettype, T.env] - if $newCompCompare=true then - oldT := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] - SAY '"The old compiler generates:" - prTriple oldT - SAY '"The new compiler generates:" - prTriple T - else - T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) - or [" ",rettype,e] ---+ - NRTassignCapsuleFunctionSlot($op,signature') - if $newCompCompare=true then - SAY '"The old compiler generates:" - prTriple T --- A THROW to the above CATCH occurs if too many semantic errors occur --- see stackSemanticError - catchTag:= MKQ GENSYM() - fun:= - body':= replaceExitEtc(T.expr,catchTag,"TAGGEDreturn",$returnMode) - body':= addArgumentConditions(body',$op) - finalBody:= ["CATCH",catchTag,body'] - compileCases([$op,["LAM",[:argl,'_$],finalBody]],oldE) - $functorStats:= addStats($functorStats,$functionStats) - - --- 7. give operator a 'value property - val:= [fun,signature',e] - [fun,['Mapping,:signature'],oldE] -- oldE:= put($op,'value,removeEnv val,e) - -getSignatureFromMode(form,e) == - getmode(opOf form,e) is ['Mapping,:signature] => - #form^=#signature => stackAndThrow ["Wrong number of arguments: ",form] - EQSUBSTLIST(rest form,take(#rest form,$FormalMapVariableList),signature) - -hasSigInTargetCategory(argl,form,opsig,e) == - mList:= [getArgumentMode(x,e) for x in argl] - --each element is a declared mode for the variable or nil if none exists - potentialSigList:= - REMDUP - [sig - for [[opName,sig,:.],:.] in $domainShell.(1) | - fn(opName,sig,opsig,mList,form)] where - fn(opName,sig,opsig,mList,form) == - opName=$op and #sig=#form and (null opsig or opsig=first sig) and - (and/[compareMode2Arg(x,m) for x in mList for m in rest sig]) - c:= #potentialSigList - 1=c => first potentialSigList - --accept only those signatures op right length which match declared modes - 0=c => (#(sig:= getSignatureFromMode(form,e))=#form => sig; nil) - 1 - sig:= first potentialSigList - stackWarning ["signature of lhs not unique:", - :bright formatSignature sig, "chosen"] - sig - nil --this branch will force all arguments to be declared - -compareMode2Arg(x,m) == null x or modeEqual(x,m) - -getArgumentModeOrMoan(x,form,e) == - getArgumentMode(x,e) or - stackSemanticError(["argument ",x," of ",form," is not declared"],nil) - -getArgumentMode(x,e) == - STRINGP x => x - m:= get(x,'mode,e) => m - -checkAndDeclare(argl,form,sig,e) == - --- arguments with declared types must agree with those in sig; --- those that don't get declarations put into e - for a in argl for m in rest sig repeat - m1:= getArgumentMode(a,e) => - ^modeEqual(m1,m) => - stack:= [" ",:bright a,'"must have type ",m, - '" not ",m1,'%l,:stack] - e:= put(a,'mode,m,e) - if stack then - sayBrightly ['" Parameters of ",:bright first form, - '" are of wrong type:",'%l,:stack] - e - -getSignature(op,argModeList,$e) == - 1=# - (sigl:= - REMDUP - [sig - for [[dc,:sig],[pred,:.]] in (mmList:= get(op,'modemap,$e)) | dc='_$ - and rest sig=argModeList and knownInfo pred]) => first sigl - null sigl => - (u:= getmode(op,$e)) is ['Mapping,:sig] => sig - SAY '"************* USER ERROR **********" - SAY("available signatures for ",op,": ") - if null mmList - then SAY " NONE" - else for [[dc,:sig],:.] in mmList repeat printSignature(" ",op,sig) - printSignature("NEED ",op,["?",:argModeList]) - nil - for u in sigl repeat - for v in sigl | not (u=v) repeat - if SourceLevelSubsume(u,v) then sigl:= delete(v,sigl) - --before we complain about duplicate signatures, we should - --check that we do not have for example, a partial - as - --well as a total one. SourceLevelSubsume (from CATEGORY BOOT) - --should do this - 1=#sigl => first sigl - stackSemanticError(["duplicate signatures for ",op,": ",argModeList],nil) - ---% ARGUMENT CONDITION CODE - -stripOffArgumentConditions argl == - [f for x in argl for i in 1..] where - f() == - x is ["|",arg,condition] => - condition:= SUBST('_#1,arg,condition) - -- in case conditions are given in terms of argument names, replace - $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] - arg - x - -stripOffSubdomainConditions(margl,argl) == - [f for x in margl for arg in argl for i in 1..] where - f() == - x is ['SubDomain,marg,condition] => - pair:= assoc(i,$argumentConditionList) => - (RPLAC(CADR pair,MKPF([condition,CADR pair],'AND)); marg) - $argumentConditionList:= [[i,arg,condition],:$argumentConditionList] - marg - x - -compArgumentConditions e == - $argumentConditionList:= - [f for [n,a,x] in $argumentConditionList] where - f() == - y:= SUBST(a,'_#1,x) - T := [.,.,e]:= compOrCroak(y,$Boolean,e) - [n,x,T.expr] - e - -addArgumentConditions($body,$functionName) == - $argumentConditionList => - --$body is only used in this function - fn $argumentConditionList where - fn clist == - clist is [[n,untypedCondition,typedCondition],:.] => - ['COND,[typedCondition,fn rest clist], - [$true,["argumentDataError",n, - MKQ untypedCondition,MKQ $functionName]]] - null clist => $body - systemErrorHere '"addArgumentConditions" - $body - -putInLocalDomainReferences (def := [opName,[lam,varl,body]]) == - $elt: local := ($QuickCode => 'QREFELT; 'ELT) ---+ - NRTputInTail CDDADR def - def - - -canCacheLocalDomain(dom,elt)== - dom is [op,'_$,n] and MEMQ(op,'(ELT QREFELT)) => nil - domargsglobal(dom) => - $functorLocalParameters:= [:$functorLocalParameters,dom] - PUSH([dom,GENVAR(),[elt,$selector,$funcLocLen]],$usedDomList) - $selcount:= $selcount+1 - $funcLocLen:= $funcLocLen+1 - nil - where - domargsglobal(dom) == - dom='_$ => true - IDENTP dom => MEMQ(dom,$functorLocalParameters) - ATOM dom => true - and/[domargsglobal(arg) for arg in rest dom] - - -compileCases(x,$e) == -- $e is referenced in compile - $specialCaseKeyList: local - not ($insideFunctorIfTrue=true) => compile x - specialCaseAssoc:= - [y for y in getSpecialCaseAssoc() | not get(first y,"specialCase",$e) and - ([R,R']:= y) and isEltArgumentIn(FindNamesFor(R,R'),x)] where - FindNamesFor(R,R') == - [R,: - [v - for ['LET,v,u,:.] in $getDomainCode | CADR u=R and - eval substitute(R',R,u)]] - isEltArgumentIn(Rlist,x) == - atom x => nil - x is ['ELT,R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) - x is ["QREFELT",R,.] => MEMQ(R,Rlist) or isEltArgumentIn(Rlist,rest x) - isEltArgumentIn(Rlist,first x) or isEltArgumentIn(Rlist,rest x) - null specialCaseAssoc => compile x - listOfDomains:= ASSOCLEFT specialCaseAssoc - listOfAllCases:= outerProduct ASSOCRIGHT specialCaseAssoc - cl:= - [u for l in listOfAllCases] where - u() == - $specialCaseKeyList:= [[D,:C] for D in listOfDomains for C in l] - [MKPF([["EQUAL",D,C] for D in listOfDomains for C in l],"AND"), - compile COPY x] - $specialCaseKeyList:= nil - ["COND",:cl,[$true,compile x]] - -getSpecialCaseAssoc() == - [[R,:l] for R in rest $functorForm - for l in rest $functorSpecialCases | l] - -compile u == - [op,lamExpr] := u - if $suffix then - $suffix:= $suffix+1 - op':= - opexport:=nil - opmodes:= - [sel - for [[DC,:sig],[.,sel]] in get(op,'modemap,$e) | - DC='_$ and (opexport:=true) and - (and/[modeEqual(x,y) for x in sig for y in $signatureOfForm])] - isLocalFunction op => - if opexport then userError ['%b,op,'%d,'" is local and exported"] - INTERN STRCONC(encodeItem $prefix,'";",encodeItem op) - isPackageFunction() and KAR $functorForm^="CategoryDefaults" => - if null opmodes then userError ['"no modemap for ",op] - opmodes is [['PAC,.,name]] => name - encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) - encodeFunctionName(op,$functorForm,$signatureOfForm,";",$suffix) - where - isLocalFunction op == - null member(op,$formalArgList) and - getmode(op,$e) is ['Mapping,:.] - u:= [op',lamExpr] - -- If just updating certain functions, check for previous existence. - -- Deduce old sequence number and use it (items have been skipped). - if $LISPLIB and $compileOnlyCertainItems then - parts := splitEncodedFunctionName(u.0, ";") --- Next line JHD/SMWATT 7/17/86 to deal with inner functions - parts='inner => $savableItems:=[u.0,:$savableItems] - unew := nil - for [s,t] in $splitUpItemsAlreadyThere repeat - if parts.0=s.0 and parts.1=s.1 and parts.2=s.2 then unew := t - null unew => - sayBrightly ['" Error: Item did not previously exist"] - sayBrightly ['" Item not saved: ", :bright u.0] - sayBrightly ['" What's there is: ", $lisplibItemsAlreadyThere] - nil - sayBrightly ['" Renaming ", u.0, '" as ", unew] - u := [unew, :rest u] - $savableItems := [unew, :$saveableItems] -- tested by embedded RWRITE - optimizedBody:= optimizeFunctionDef u - stuffToCompile:= - if null $insideCapsuleFunctionIfTrue - then optimizedBody - else putInLocalDomainReferences optimizedBody - $doNotCompileJustPrint=true => (PRETTYPRINT stuffToCompile; op') - $macroIfTrue => constructMacro stuffToCompile - result:= spadCompileOrSetq stuffToCompile - functionStats:=[0,elapsedTime()] - $functionStats:= addStats($functionStats,functionStats) - printStats functionStats - result - -spadCompileOrSetq (form is [nam,[lam,vl,body]]) == - --bizarre hack to take account of the existence of "known" functions - --good for performance (LISPLLIB size, BPI size, NILSEC) - CONTAINED(" ",body) => sayBrightly ['" ",:bright nam,'" not compiled"] - if vl is [:vl',E] and body is [nam',: =vl'] then - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ nam'] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright nam'] - else if (ATOM body or and/[ATOM x for x in body]) - and vl is [:vl',E] and not CONTAINED(E,body) then - macform := ['XLAM,vl',body] - LAM_,EVALANDFILEACTQ ['PUT,MKQ nam,MKQ 'SPADreplace,MKQ macform] - sayBrightly ['" ",:bright nam,'"is replaced by",:bright body] - $insideCapsuleFunctionIfTrue => first COMP LIST form - compileConstructor form - -compileConstructor form == - u:= compileConstructor1 form - clearClams() --clear all CLAMmed functions - u - -compileConstructor1 (form:=[fn,[key,vl,:bodyl]]) == --- fn is the name of some category/domain/package constructor; --- we will cache all of its values on $ConstructorCache with reference --- counts - $clamList: local - lambdaOrSlam := - GETDATABASE(fn,'CONSTRUCTORKIND) = 'category => 'SPADSLAM - $mutableDomain => 'LAMBDA - $clamList:= - [[fn,"$ConstructorCache",'domainEqualList,'count],:$clamList] - 'LAMBDA - compForm:= LIST [fn,[lambdaOrSlam,vl,:bodyl]] - if GETDATABASE(fn,'CONSTRUCTORKIND) = 'category - then u:= compAndDefine compForm - else u:=COMP compForm - clearConstructorCache fn --clear cache for constructor - first u - -constructMacro (form is [nam,[lam,vl,body]]) == - ^(and/[atom x for x in vl]) => - stackSemanticError(["illegal parameters for macro: ",vl],nil) - ["XLAM",vl':= [x for x in vl | IDENTP x],body] - -listInitialSegment(u,v) == - null u => true - null v => nil - first u=first v and listInitialSegment(rest u,rest v) - --returns true iff u.i=v.i for i in 1..(#u)-1 - -modemap2Signature [[.,:sig],:.] == sig - -uncons x == - atom x => x - x is ["CONS",a,b] => [a,:uncons b] - ---% CAPSULE - -bootStrapError(functorForm,sourceFile) == - ['COND, _ - ['$bootStrapMode, _ - ['VECTOR,mkDomainConstructor functorForm,nil,nil,nil,nil,nil]], - [''T, ['systemError,['LIST,''%b,MKQ CAR functorForm,''%d,'"from", _ - ''%b,MKQ namestring sourceFile,''%d,'"needs to be compiled"]]]] - -compAdd(['add,$addForm,capsule],m,e) == - $bootStrapMode = true => - if $addForm is ['Tuple,:.] then code := nil - else [code,m,e]:= comp($addForm,m,e) - [['COND, _ - ['$bootStrapMode, _ - code],_ - [''T, ['systemError,['LIST,''%b,MKQ CAR $functorForm,''%d,'"from", _ - ''%b,MKQ namestring _/EDITFILE,''%d,'"needs to be compiled"]]]],m,e] - $addFormLhs: local:= $addForm - if $addForm is ["SubDomain",domainForm,predicate] then - $packagesUsed := [domainForm,:$packagesUsed] ---+ - $NRTaddForm := domainForm - NRTgetLocalIndex domainForm - --need to generate slot for add form since all $ go-get - -- slots will need to access it - [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) - else - $packagesUsed := - $addForm is ['Tuple,:u] => [:u,:$packagesUsed] - [$addForm,:$packagesUsed] ---+ - $NRTaddForm := $addForm - [$addForm,.,e]:= - $addForm is ['Tuple,:.] => - $NRTaddForm := ['Tuple,:[NRTgetLocalIndex x for x in rest $addForm]] - compOrCroak(compTuple2Record $addForm,$EmptyMode,e) - compOrCroak($addForm,$EmptyMode,e) - compCapsule(capsule,m,e) - -compTuple2Record u == ['Record,:[[":",i,x] for i in 1.. for x in rest u]] - -compCapsule(['CAPSULE,:itemList],m,e) == - $bootStrapMode = true => - [bootStrapError($functorForm, _/EDITFILE),m,e] - $insideExpressionIfTrue: local:= false - compCapsuleInner(itemList,m,addDomain('_$,e)) - -compSubDomain(["SubDomain",domainForm,predicate],m,e) == - $addFormLhs: local:= domainForm - $addForm: local - $NRTaddForm := domainForm - [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) ---+ - compCapsule(['CAPSULE],m,e) - -compSubDomain1(domainForm,predicate,m,e) == - [.,.,e]:= - compMakeDeclaration([":","#1",domainForm],$EmptyMode,addDomain(domainForm,e)) - u:= - compOrCroak(predicate,$Boolean,e) or - stackSemanticError(["predicate: ",predicate, - " cannot be interpreted with #1: ",domainForm],nil) - prefixPredicate:= lispize u.expr - $lisplibSuperDomain:= - [domainForm,predicate] - evalAndRwriteLispForm('evalOnLoad2, - ['SETQ,'$CategoryFrame,['put,op':= ['QUOTE,$op],' - (QUOTE SuperDomain),dF':= ['QUOTE,domainForm],['put,dF','(QUOTE SubDomain),[ - 'CONS,['QUOTE,[$op,:prefixPredicate]],['DELASC,op',['get,dF',' - (QUOTE SubDomain),'$CategoryFrame]]],'$CategoryFrame]]]) - [domainForm,m,e] - -compCapsuleInner(itemList,m,e) == - e:= addInformation(m,e) - --puts a new 'special' property of $Information - data:= ["PROGN",:itemList] - --RPLACd by compCapsuleItems and Friends - e:= compCapsuleItems(itemList,nil,e) - localParList:= $functorLocalParameters - if $addForm then data:= ['add,$addForm,data] - code:= - $insideCategoryIfTrue and not $insideCategoryPackageIfTrue => data - processFunctorOrPackage($form,$signature,data,localParList,m,e) - [MKPF([:$getDomainCode,code],"PROGN"),m,e] - ---% PROCESS FUNCTOR CODE - -processFunctor(form,signature,data,localParList,e) == - form is ["CategoryDefaults"] => - error "CategoryDefaults is a reserved name" - buildFunctor(form,signature,data,localParList,e) - -<> -compSingleCapsuleItem(item,$predl,$e) == - doIt(macroExpandInPlace(item,$e),$predl) - $e - -doIt(item,$predl) == - $GENNO: local:= 0 - item is ['SEQ,:l,['exit,1,x]] => - RPLACA(item,"PROGN") - RPLACA(LASTNODE item,x) - for it1 in rest item repeat $e:= compSingleCapsuleItem(it1,$predl,$e) - --This will RPLAC as appropriate - isDomainForm(item,$e) => - -- convert naked top level domains to import - u:= ["import", [first item,:rest item]] - stackWarning ["Use: import ", [first item,:rest item]] - RPLACA(item,first u) - RPLACD(item,rest u) - doIt(item,$predl) - item is ['LET,lhs,rhs,:.] => - not (compOrCroak(item,$EmptyMode,$e) is [code,.,$e]) => - stackSemanticError(["cannot compile assigned value to",:bright lhs],nil) - not (code is ['LET,lhs',rhs',:.] and atom lhs') => - code is ["PROGN",:.] => - stackSemanticError(["multiple assignment ",item," not allowed"],nil) - RPLACA(item,first code) - RPLACD(item,rest code) - lhs:= lhs' - if not member(KAR rhs,$NonMentionableDomainNames) and - not MEMQ(lhs, $functorLocalParameters) then - $functorLocalParameters:= [:$functorLocalParameters,lhs] - if code is ['LET,.,rhs',:.] and isDomainForm(rhs',$e) then - if isFunctor rhs' then - $functorsUsed:= insert(opOf rhs',$functorsUsed) - $packagesUsed:= insert([opOf rhs'],$packagesUsed) - if lhs="Rep" then - $Representation:= (get("Rep",'value,$e)).(0) - --$Representation bound by compDefineFunctor, used in compNoStacking ---+ - if $NRTopt = true - then NRTgetLocalIndex $Representation ---+ - $LocalDomainAlist:= --see genDeltaEntry - [[lhs,:SUBLIS($LocalDomainAlist,(get(lhs,'value,$e)).0)],:$LocalDomainAlist] ---+ - code is ['LET,:.] => - RPLACA(item,($QuickCode => 'QSETREFV;'SETELT)) - rhsCode:= - rhs' - RPLACD(item,['$,NRTgetLocalIndexClear lhs,rhsCode]) - RPLACA(item,first code) - RPLACD(item,rest code) - item is [":",a,t] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) - item is ["import",:doms] => - for dom in doms repeat - sayBrightly ['" importing ",:formatUnabbreviated dom] - [.,.,$e] := compOrCroak(item,$EmptyMode,$e) - RPLACA(item,'PROGN) - RPLACD(item,NIL) -- creates a no-op - item is ["IF",:.] => doItIf(item,$predl,$e) - item is ["where",b,:l] => compOrCroak(item,$EmptyMode,$e) - item is ["MDEF",:.] => [.,.,$e]:= compOrCroak(item,$EmptyMode,$e) - item is ['DEF,[op,:.],:.] => - body:= isMacro(item,$e) => $e:= put(op,'macro,body,$e) - [.,.,$e]:= t:= compOrCroak(item,$EmptyMode,$e) - RPLACA(item,"CodeDefine") - --Note that DescendCode, in CodeDefine, is looking for this - RPLACD(CADR item,[$signatureOfForm]) - --This is how the signature is updated for buildFunctor to recognise ---+ - functionPart:= ['dispatchFunction,t.expr] - RPLACA(CDDR item,functionPart) - RPLACD(CDDR item,nil) - u:= compOrCroak(item,$EmptyMode,$e) => - ([code,.,$e]:= u; RPLACA(item,first code); RPLACD(item,rest code)) - true => cannotDo() - -isMacro(x,e) == - x is ['DEF,[op,:args],signature,specialCases,body] and - null get(op,'modemap,e) and null args and null get(op,'mode,e) - and signature is [nil] => body - -doItIf(item is [.,p,x,y],$predl,$e) == - olde:= $e - [p',.,$e]:= comp(p,$Boolean,$e) or userError ['"not a Boolean:",p] - oldFLP:=$functorLocalParameters - if x^="noBranch" then - compSingleCapsuleItem(x,$predl,getSuccessEnvironment(p,$e)) - x':=localExtras(oldFLP) - oldFLP:=$functorLocalParameters - if y^="noBranch" then - compSingleCapsuleItem(y,$predl,getInverseEnvironment(p,olde)) - y':=localExtras(oldFLP) - RPLACA(item,"COND") - RPLACD(item,[[p',x,:x'],['(QUOTE T),y,:y']]) - where localExtras(oldFLP) == - EQ(oldFLP,$functorLocalParameters) => NIL - flp1:=$functorLocalParameters - oldFLP':=oldFLP - n:=0 - while oldFLP' repeat - oldFLP':=CDR oldFLP' - flp1:=CDR flp1 - n:=n+1 - -- Now we have to add code to compile all the elements - -- of functorLocalParameters that were added during the - -- conditional compilation - nils:=ans:=[] - for u in flp1 repeat -- is =u form always an ATOM? - if ATOM u or (or/[v is [.,=u,:.] for v in $getDomainCode]) - then - nils:=[u,:nils] - else - gv := GENSYM() - ans:=[['LET,gv,u],:ans] - nils:=[gv,:nils] - n:=n+1 - $functorLocalParameters:=[:oldFLP,:NREVERSE nils] - NREVERSE ans - ---compSingleCapsuleIf(x,predl,e,$functorLocalParameters) == --- compSingleCapsuleItem(x,predl,e) - ---% CATEGORY AND DOMAIN FUNCTIONS -compContained(["CONTAINED",a,b],m,e) == - [a,ma,e]:= comp(a,$EmptyMode,e) or return nil - [b,mb,e]:= comp(b,$EmptyMode,e) or return nil - isCategoryForm(ma,e) and isCategoryForm(mb,e) => - (T:= [["CONTAINED",a,b],$Boolean,e]; convert(T,m)) - nil - -compJoin(["Join",:argl],m,e) == - catList:= [(compForMode(x,$Category,e) or return 'failed).expr for x in argl] - catList='failed => stackSemanticError(["cannot form Join of: ",argl],nil) - catList':= - [extract for x in catList] where - extract() == - isCategoryForm(x,e) => - parameters:= - union("append"/[getParms(y,e) for y in rest x],parameters) - where getParms(y,e) == - atom y => - isDomainForm(y,e) => LIST y - nil - y is ['LENGTH,y'] => [y,y'] - LIST y - x - x is ["DomainSubstitutionMacro",pl,body] => - (parameters:= union(pl,parameters); body) - x is ["mkCategory",:.] => x - atom x and getmode(x,e)=$Category => x - stackSemanticError(["invalid argument to Join: ",x],nil) - x - T:= [wrapDomainSub(parameters,["Join",:catList']),$Category,e] - convert(T,m) - -compForMode(x,m,e) == - $compForModeIfTrue: local:= true - comp(x,m,e) - -compMakeCategoryObject(c,$e) == - not isCategoryForm(c,$e) => nil - u:= mkEvalableCategoryForm c => [eval u,$Category,$e] - nil - -quotifyCategoryArgument x == MKQ x - -makeCategoryForm(c,e) == - not isCategoryForm(c,e) => nil - [x,m,e]:= compOrCroak(c,$EmptyMode,e) - [x,e] - -compCategory(x,m,e) == - $TOP__LEVEL: local:= true - (m:= resolve(m,["Category"]))=["Category"] and x is ['CATEGORY, - domainOrPackage,:l] => - $sigList: local - $atList: local - $sigList:= $atList:= nil - for x in l repeat compCategoryItem(x,nil) - rep:= mkExplicitCategoryFunction(domainOrPackage,$sigList,$atList) - --if inside compDefineCategory, provide for category argument substitution - [rep,m,e] - systemErrorHere '"compCategory" - -mkExplicitCategoryFunction(domainOrPackage,sigList,atList) == - body:= - ["mkCategory",MKQ domainOrPackage,['LIST,:REVERSE sigList],['LIST,: - REVERSE atList],MKQ domList,nil] where - domList() == - ("union"/[fn sig for ["QUOTE",[[.,sig,:.],:.]] in sigList]) where - fn sig == [D for D in sig | mustInstantiate D] - parameters:= - REMDUP - ("append"/ - [[x for x in sig | IDENTP x and x^='_$] - for ["QUOTE",[[.,sig,:.],:.]] in sigList]) - wrapDomainSub(parameters,body) - -wrapDomainSub(parameters,x) == - ["DomainSubstitutionMacro",parameters,x] - -mustInstantiate D == - D is [fn,:.] and ^(MEMQ(fn,$DummyFunctorNames) or GETL(fn,"makeFunctionList")) - -DomainSubstitutionFunction(parameters,body) == - --see definition of DomainSubstitutionMacro in SPAD LISP - if parameters then - (body:= Subst(parameters,body)) where - Subst(parameters,body) == - ATOM body => - MEMQ(body,parameters) => MKQ body - body - member(body,parameters) => - g:=GENSYM() - $extraParms:=PUSH([g,:body],$extraParms) - --Used in SetVector12 to generate a substitution list - --bound in buildFunctor - --For categories, bound and used in compDefineCategory - MKQ g - first body="QUOTE" => body - PAIRP $definition and - isFunctor first body and - first body ^= first $definition - => ['QUOTE,optimize body] - [Subst(parameters,u) for u in body] - not (body is ["Join",:.]) => body - atom $definition => body - null rest $definition => body - --should not bother if it will only be called once - name:= INTERN STRCONC(KAR $definition,";CAT") - SETANDFILE(name,nil) - body:= ["COND",[name],['(QUOTE T),['SETQ,name,body]]] - body - -compCategoryItem(x,predl) == - x is nil => nil - --1. if x is a conditional expression, recurse; otherwise, form the predicate - x is ["COND",[p,e]] => - predl':= [p,:predl] - e is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') - compCategoryItem(e,predl') - x is ["IF",a,b,c] => - predl':= [a,:predl] - if b^="noBranch" then - b is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') - compCategoryItem(b,predl') - c="noBranch" => nil - predl':= [["not",a],:predl] - c is ["PROGN",:l] => for y in l repeat compCategoryItem(y,predl') - compCategoryItem(c,predl') - pred:= (predl => MKPF(predl,"AND"); true) - - --2. if attribute, push it and return - x is ["ATTRIBUTE",y] => PUSH(MKQ [y,pred],$atList) - - --3. it may be a list, with PROGN as the CAR, and some information as the CDR - x is ["PROGN",:l] => for u in l repeat compCategoryItem(u,predl) - --- 4. otherwise, x gives a signature for a --- single operator name or a list of names; if a list of names, --- recurse - ["SIGNATURE",op,:sig]:= x - null atom op => - for y in op repeat compCategoryItem(["SIGNATURE",y,:sig],predl) - - --4. branch on a single type or a signature %with source and target - PUSH(MKQ [rest x,pred],$sigList) - - - - - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document} diff --git a/src/interp/functor.boot.pamphlet b/src/interp/functor.boot.pamphlet index 7e952a88..60111870 100644 --- a/src/interp/functor.boot.pamphlet +++ b/src/interp/functor.boot.pamphlet @@ -50,6 +50,10 @@ <<*>>= <> +import '"c-util" +import '"category" +)package "BOOT" + --% Domain printing keyItem a == isDomain a => CDAR a.4 @@ -243,7 +247,7 @@ compCategories1(u,v) == NewbFVectorCopy(u,domName) == v:= GETREFV SIZE u for i in 0..5 repeat v.i:= u.i - for i in 6..MAXINDEX v | PAIRP u.i repeat v.i:= [Undef,[domName,i],:first u.i] + for i in 6..MAXINDEX v | PAIRP u.i repeat v.i:= [function Undef,[domName,i],:first u.i] v mkVector u == @@ -360,11 +364,12 @@ setVector12 args == args2:=[CDR u,:args2] freeof($domainShell.1,args1) and freeof($domainShell.2,args1) and - freeof($domainShell.4,args1) => nil where freeof(a,b) == - ATOM a => NULL MEMQ(a,b) - freeof(CAR a,b) => freeof(CDR a,b) - false + freeof($domainShell.4,args1) => nil [['SetDomainSlots124,'$,['QUOTE,args1],['LIST,:args2]]] + where freeof(a,b) == + ATOM a => NULL MEMQ(a,b) + freeof(CAR a,b) => freeof(CDR a,b) + false SetDomainSlots124(vec,names,vals) == l:= PAIR(names,vals) @@ -483,7 +488,7 @@ setVector4part3(catNames,catvecList) == generated:= nil for u in catvecList for uname in catNames repeat for v in CADDR u.4 repeat - if w:= ASSOC(first v,generated) + if w:= assoc(first v,generated) then RPLACD(w,[[rest v,:uname],:rest w]) else generated:= [[first v,[rest v,:uname]],:generated] codeList := nil @@ -500,7 +505,7 @@ PrepareConditional u == u setVector5(catNames,locals) == generated:= nil for u in locals for uname in catNames repeat - if w:= ASSOC(u,generated) + if w:= assoc(u,generated) then RPLACD(w,[uname,:rest w]) else generated:= [[u,uname],:generated] [(w:= mkVectorWithDeferral(first u,first rest u); @@ -611,7 +616,7 @@ DescendCode(code,flag,viewAssoc,EnvToPass) == NREVERSE [v for u in REVERSE codelist | (v:= DescendCode(u,flag,viewAssoc,EnvToPass))^=nil]] code is ['COND,:condlist] => - c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q == + c:= [[u2:= ProcessCond(first u,viewAssoc),:q] for u in condlist] where q() == null u2 => nil f:= TruthP u2 => flag; @@ -769,7 +774,7 @@ CheckVector(vec,name,catvecListMaker) == if y=v then code:= [[($QuickCode => 'QSETREFV; 'SETELT),name,i,x],:code] if name='$ then - ASSOC(first v,$CheckVectorList) => nil + assoc(first v,$CheckVectorList) => nil $CheckVectorList:= [[first v,:makeMissingFunctionEntry(condAlist,i)],:$CheckVectorList] -- member(first v,$CheckVectorList) => nil @@ -863,7 +868,7 @@ InvestigateConditions catvecListMaker == ['AND,:u] for [v,:.] in newS repeat for v' in [v,:CAR (CatEval v).4] repeat - if (w:=ASSOC(v',$HackSlot4)) then + if (w:=assoc(v',$HackSlot4)) then RPLAC(rest w,if rest w then mkOr(u,rest w) else u) (list:= update(list,u,secondaries,newS)) where update(list,cond,secondaries,newS) == @@ -907,17 +912,7 @@ ICformat u == l1:=mkAnd(u,l1) l1 u is ['OR,:l] => - (l:= ORreduce l) where - ORreduce l == - for u in l | u is ['AND,:.] or u is ['and,:.] repeat - --check that B causes (and A B) to go - for v in l | not (v=u) repeat - if member(v,u) or (and/[member(w,u) for w in v]) then l:= - delete(u,l) - --v subsumes u - --Note that we are ignoring AND as a component. - --Convince yourself that this code still works - l + (l:= ORreduce l) LENGTH l=1 => ICformat first l l:= ORreduce REMDUP [ICformat u for u in l] --causes multiple ANDs to be squashed, etc. @@ -941,6 +936,17 @@ ICformat u == LENGTH l=1 => first l ['OR,:l] systemErrorHere '"ICformat" + where + ORreduce l == + for u in l | u is ['AND,:.] or u is ['and,:.] repeat + --check that B causes (and A B) to go + for v in l | not (v=u) repeat + if member(v,u) or (and/[member(w,u) for w in v]) then l:= + delete(u,l) + --v subsumes u + --Note that we are ignoring AND as a component. + --Convince yourself that this code still works + l partPessimise(a,trueconds) == atom a => a -- cgit v1.2.3