diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/define.boot | 39 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 37 | ||||
| -rw-r--r-- | src/interp/modemap.boot | 13 |
3 files changed, 35 insertions, 54 deletions
diff --git a/src/interp/define.boot b/src/interp/define.boot index 27b91ce9..14ff75a1 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -206,19 +206,39 @@ macroExpandList(l,e) == (l is [name]) and IDENTP name and niladicConstructorFromDB name and (u := get(name, 'macro, e)) => macroExpand(u,e) [macroExpand(x,e) for x in l] + +--% constructor evaluation +-- The following functions are used by the compiler but are modified +-- here for use with new LISPLIB scheme + +mkEvalableCategoryForm c == + c is [op,:argl] => + op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] + op is "DomainSubstitutionMacro" => + --$extraParms :local + --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms + --mkEvalableCategoryForm sublisV($extraParms, catobj) + mkEvalableCategoryForm CADR argl + op is "mkCategory" => c + MEMQ(op,$CategoryNames) => + ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) + --loadIfNecessary op + getConstructorKindFromDB op = 'category or + get(op,"isCategory",$CategoryFrame) => + [op,:[quotifyCategoryArgument x for x in argl]] + [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) + m=$Category => x + MKQ c 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) @@ -238,7 +258,6 @@ makeCategoryPredicates(form,u) == 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(getConstructorAbbreviationFromDB op,'"-")) @@ -506,7 +525,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], 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') @@ -525,7 +543,6 @@ compDefineFunctor1(df is ['DEF,form,signature,$functorSpecialCases,body], 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) @@ -728,7 +745,6 @@ mkOpVec(dom,siglist) == ops genDomainViewName(a,category) == ---+ a compDefWhereClause(['DEF,form,signature,specialCases,body],m,e) == @@ -880,7 +896,6 @@ compDefineCapsuleFunction(df is ['DEF,form,signature,specialCases,body], T := CATCH('compCapsuleBody, compOrCroak(body,rettype,e)) or [" ",rettype,e] ---+ NRTassignCapsuleFunctionSlot($op,signature') if $newCompCompare=true then SAY '"The old compiler generates:" @@ -1036,7 +1051,6 @@ addArgumentConditions($body,$functionName) == putInLocalDomainReferences (def := [opName,[lam,varl,body]]) == $elt: local := "getShellEntry" ---+ NRTputInTail CDDADR def def @@ -1233,7 +1247,6 @@ compAdd(['add,$addForm,capsule],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 @@ -1243,7 +1256,6 @@ compAdd(['add,$addForm,capsule],m,e) == $packagesUsed := $addForm is ["%Comma",:u] => [:u,:$packagesUsed] [$addForm,:$packagesUsed] ---+ $NRTaddForm := $addForm [$addForm,.,e]:= $addForm is ["%Comma",:.] => @@ -1268,7 +1280,6 @@ compSubDomain(["SubDomain",domainForm,predicate],m,e) == $addForm: local := nil $NRTaddForm := domainForm [$addForm,.,e]:= compSubDomain1(domainForm,predicate,m,e) ---+ compCapsule(['CAPSULE],m,e) compSubDomain1(domainForm,predicate,m,e) == @@ -1356,13 +1367,10 @@ doIt(item,$predl) == 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,"setShellEntry") rhsCode:= @@ -1387,7 +1395,6 @@ doIt(item,$predl) == --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) diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index c7d6a44c..a4b90f8a 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -644,20 +644,6 @@ getConstructorSignature ctor == sig nil ---% from MODEMAP BOOT - -augModemapsFromDomain1(name,functorForm,e) == - GETL(KAR functorForm,"makeFunctionList") => - addConstructorModemaps(name,functorForm,e) - atom functorForm and (catform:= getmode(functorForm,e)) => - augModemapsFromCategory(name,name,functorForm,catform,e) - mappingForm:= getmodeOrMapping(KAR functorForm,e) => - ["Mapping",categoryForm,:functArgTypes]:= mappingForm - catform:= substituteCategoryArguments(rest functorForm,categoryForm) - augModemapsFromCategory(name,name,functorForm,catform,e) - stackMessage('"%1pb is an unknown mode",[functorForm]) - e - getSlotFromCategoryForm ([op,:argl],index) == u:= eval [op,:MAPCAR('MKQ,TAKE(#argl,$FormalMapVariableList))] null VECP u => @@ -665,29 +651,6 @@ getSlotFromCategoryForm ([op,:argl],index) == u . index ---% constructor evaluation --- The following functions are used by the compiler but are modified --- here for use with new LISPLIB scheme - -mkEvalableCategoryForm c == --from DEFINE - c is [op,:argl] => - op="Join" => ["Join",:[mkEvalableCategoryForm x for x in argl]] - op is "DomainSubstitutionMacro" => - --$extraParms :local - --catobj := EVAL c -- DomainSubstitutionFunction makes $extraParms - --mkEvalableCategoryForm sublisV($extraParms, catobj) - mkEvalableCategoryForm CADR argl - op is "mkCategory" => c - MEMQ(op,$CategoryNames) => - ([x,m,$e]:= compOrCroak(c,$EmptyMode,$e); m=$Category => x) - --loadIfNecessary op - getConstructorKindFromDB op = 'category or - get(op,"isCategory",$CategoryFrame) => - [op,:[quotifyCategoryArgument x for x in argl]] - [x,m,$e]:= compOrCroak(c,$EmptyMode,$e) - m=$Category => x - MKQ c - isDomainForm(D,e) == --added for MPOLY 3/83 by RDJ MEMQ(KAR D,$SpecialDomainNames) or isFunctor D or diff --git a/src/interp/modemap.boot b/src/interp/modemap.boot index 2eafb6ad..e35d7bb6 100644 --- a/src/interp/modemap.boot +++ b/src/interp/modemap.boot @@ -240,7 +240,18 @@ augModemapsFromDomain(name,functorForm,e) == if name is ["Union",:dl] then for d in stripUnionTags dl repeat e:= addDomain(d,e) augModemapsFromDomain1(name,functorForm,e) - --see LISPLIB BOOT + +augModemapsFromDomain1(name,functorForm,e) == + GETL(KAR functorForm,"makeFunctionList") => + addConstructorModemaps(name,functorForm,e) + atom functorForm and (catform:= getmode(functorForm,e)) => + augModemapsFromCategory(name,name,functorForm,catform,e) + mappingForm:= getmodeOrMapping(KAR functorForm,e) => + ["Mapping",categoryForm,:functArgTypes]:= mappingForm + catform:= substituteCategoryArguments(rest functorForm,categoryForm) + augModemapsFromCategory(name,name,functorForm,catform,e) + stackMessage('"%1pb is an unknown mode",[functorForm]) + e substituteCategoryArguments(argl,catform) == argl:= substitute("$$","$",argl) |