diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/daase.lisp | 187 | ||||
| -rw-r--r-- | src/interp/database.boot | 4 | ||||
| -rw-r--r-- | src/interp/define.boot | 28 | ||||
| -rw-r--r-- | src/interp/functor.boot | 16 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 2 | ||||
| -rw-r--r-- | src/interp/nruncomp.boot | 2 |
6 files changed, 27 insertions, 212 deletions
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 7196c742..fce8ca41 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -424,196 +424,9 @@ (browseopen) (setq *category-stream-stamp* '(0 . 0)) (categoryopen) ;note: this depends on constructorform in browse.daase - (unless |$buildingSystemAlgebra| - (initial-getdatabase)) #+:AKCL (gbc t) ) -(defun initial-getdatabase () - "fetch data we want in the saved system" - (let (hascategory constructormodemapAndoperationalist operation constr) - (when |$verbose| - (format t "Initial getdatabase~%")) - (setq hascategory '( - (|Equation| . |Ring|) - (|Expression| . |CoercibleTo|) - (|Expression| . |CommutativeRing|) - (|Expression| . |IntegralDomain|) - (|Expression| . |Ring|) - (|Float| . |RetractableTo|) - (|Fraction| . |Algebra|) - (|Fraction| . |CoercibleTo|) - (|Fraction| . |OrderedSet|) - (|Fraction| . |RetractableTo|) - (|Integer| . |Algebra|) - (|Integer| . |CoercibleTo|) - (|Integer| . |ConvertibleTo|) - (|Integer| . |LinearlyExplicitRingOver|) - (|Integer| . |RetractableTo|) - (|List| . |CoercibleTo|) - (|List| . |FiniteLinearAggregate|) - (|List| . |OrderedSet|) - (|Polynomial| . |CoercibleTo|) - (|Polynomial| . |CommutativeRing|) - (|Polynomial| . |ConvertibleTo|) - (|Polynomial| . |OrderedSet|) - (|Polynomial| . |RetractableTo|) - (|Symbol| . |CoercibleTo|) - (|Symbol| . |ConvertibleTo|) - (|Variable| . |CoercibleTo|))) - (dolist (pair hascategory) - (|constructorHasCategoryFromDB| pair)) - (setq constructormodemapAndoperationalist - '(|BasicOperator| - |Boolean| - |CardinalNumber| - |Color| - |Complex| - |Database| - |Equation| - |EquationFunctions2| - |Expression| - |Float| - |Fraction| - |FractionFunctions2| - |Integer| - |IntegralDomain| - |Kernel| - |List| - |Matrix| - |MappingPackage1| - |Operator| - |OutputForm| - |NonNegativeInteger| - |ParametricPlaneCurve| - |ParametricSpaceCurve| - |Point| - |Polynomial| - |PolynomialFunctions2| - |PositiveInteger| - |Ring| - |SetCategory| - |SegmentBinding| - |SegmentBindingFunctions2| - |DoubleFloat| - |SparseMultivariatePolynomial| - |SparseUnivariatePolynomial| - |Segment| - |String| - |Symbol| - |UniversalSegment| - |Variable| - |Vector|)) - (dolist (con constructormodemapAndoperationalist) - (|getConstructorModemap| con) - (|getConstructorOperationsFromDB| con)) - (setq operation - '(|+| |-| |*| |/| |**| - |coerce| |convert| |elt| |equation| - |float| |sin| |cos| |map| |SEGMENT|)) - (dolist (op operation) - (|getOperationFromDB| op)) - (setq constr - '( ;these are sorted least-to-most freq. delete early ones first - |Factored| - |SparseUnivariatePolynomialFunctions2| - |TableAggregate&| - |RetractableTo&| - |RecursiveAggregate&| - |UserDefinedPartialOrdering| - |None| - |UnivariatePolynomialCategoryFunctions2| - |IntegerPrimesPackage| - |SetCategory&| - |IndexedExponents| - |QuotientFieldCategory&| - |Polynomial| - |EltableAggregate&| - |PartialDifferentialRing&| - |Set| - |UnivariatePolynomialCategory&| - |FlexibleArray| - |SparseMultivariatePolynomial| - |PolynomialCategory&| - |DifferentialExtension&| - |IndexedFlexibleArray| - |AbelianMonoidRing&| - |FiniteAbelianMonoidRing&| - |DivisionRing&| - |FullyLinearlyExplicitRingOver&| - |IndexedVector| - |IndexedOneDimensionalArray| - |LocalAlgebra| - |Localize| - |Boolean| - |Field&| - |Vector| - |IndexedDirectProductObject| - |Aggregate&| - |PolynomialRing| - |FreeModule| - |IndexedDirectProductAbelianGroup| - |IndexedDirectProductAbelianMonoid| - |SingletonAsOrderedSet| - |SparseUnivariatePolynomial| - |Fraction| - |Collection&| - |HomogeneousAggregate&| - |RepeatedSquaring| - |IntegerNumberSystem&| - |AbelianSemiGroup&| - |AssociationList| - |OrderedRing&| - |SemiGroup&| - |Symbol| - |UniqueFactorizationDomain&| - |EuclideanDomain&| - |IndexedAggregate&| - |GcdDomain&| - |IntegralDomain&| - |DifferentialRing&| - |Monoid&| - |Reference| - |UnaryRecursiveAggregate&| - |OrderedSet&| - |AbelianGroup&| - |Algebra&| - |Module&| - |Ring&| - |StringAggregate&| - |AbelianMonoid&| - |ExtensibleLinearAggregate&| - |PositiveInteger| - |StreamAggregate&| - |IndexedString| - |IndexedList| - |ListAggregate&| - |LinearAggregate&| - |Character| - |String| - |NonNegativeInteger| - |SingleInteger| - |OneDimensionalArrayAggregate&| - |FiniteLinearAggregate&| - |PrimitiveArray| - |Integer| - |List| - |OutputForm|)) - (dolist (con constr) - (let ((c (|getSystemModulePath| - (string (|getConstructorAbbreviationFromDB| con))))) - (when |$verbose| - (format t " preloading ~a.." c)) - (if (probe-file c) - (progn - (|loadModule| c con) - (setf (|dbLoadPath| (|constructorDB| con)) c) - (when |$verbose| - (format t "loaded.~%"))) - (when |$verbose| - (format t "skipped.~%"))))) - (when |$verbose| - (format t "~%")))) ; format of an entry in interp.daase: ; (constructor-name diff --git a/src/interp/database.boot b/src/interp/database.boot index 5a0bd592..8e764e50 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -120,7 +120,9 @@ getDualSignature ctor == getConstructorPredicates: %Constructor -> %List %Thing getConstructorPredicates ctor == - dbPredicates loadDBIfNecessary constructorDB ctor + db := constructorDB ctor + dbBeingDefined? db => dbPredicates db + dbPredicates loadDBIfNecessary db getConstructorParentsFromDB: %Constructor -> %List %Constructor getConstructorParentsFromDB ctor == diff --git a/src/interp/define.boot b/src/interp/define.boot index 9975116c..3d282ec6 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -351,19 +351,19 @@ chaseInferences(pred,$e) == --======================================================================= -- Generate Code to Create Infovec --======================================================================= -getInfovecCode() == +getInfovecCode db == --Function called by compDefineFunctor1 to create infovec at compile time ['LIST, - MKQ makeDomainTemplate $template, - MKQ makeCompactDirect $NRTslot1Info, - MKQ NRTgenFinalAttributeAlist $e, - NRTmakeCategoryAlist $e, + MKQ makeDomainTemplate(db,$template), + MKQ makeCompactDirect(db,$NRTslot1Info), + MKQ NRTgenFinalAttributeAlist(db,$e), + NRTmakeCategoryAlist(db,$e), MKQ $lookupFunction] --======================================================================= -- Generation of Domain Vector Template (Compile Time) --======================================================================= -makeDomainTemplate vec == +makeDomainTemplate(db,vec) == --NOTES: This function is called at compile time to create the template -- (slot 0 of the infovec); called by getInfovecCode from compDefineFunctor1 newVec := newShell # vec @@ -392,24 +392,24 @@ makeGoGetSlot(item,index) == -- Generate OpTable at Compile Time --======================================================================= --> called by getInfovecCode (see top of this file) from compDefineFunctor1 -makeCompactDirect u == +makeCompactDirect(db,u) == $predListLength :local := # $NRTslot1PredicateList $byteVecAcc: local := nil [nam,[addForm,:opList]] := u --pp opList - d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(op,items)] + d := [[op,y] for [op,:items] in opList | y := makeCompactDirect1(db,op,items)] $byteVec := [:$byteVec,:"append"/reverse! $byteVecAcc] vector("append"/d) -makeCompactDirect1(op,items) == +makeCompactDirect1(db,op,items) == --NOTES: creates byte codes for ops implemented by the domain curAddress := $byteAddress $op: local := op --temp hack by RDJ 8/90 (see orderBySubsumption) - newcodes := - "append"/[u for y in orderBySubsumption items | u := fn y] or return nil + newcodes := "append"/[u for y in orderBySubsumption items | + u := fn(db,y)] or return nil $byteVecAcc := [newcodes,:$byteVecAcc] curAddress - where fn y == + where fn(db,y) == [sig,:r] := y r = ['Subsumed] => n := #sig - 1 @@ -476,7 +476,7 @@ depthAssoc x == getCatAncestors x == [CAAR y for y in parentsOf opOf x] -NRTmakeCategoryAlist e == +NRTmakeCategoryAlist(db,e) == $depthAssocCache: local := hashTable 'EQ $catAncestorAlist: local := nil pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist] @@ -1456,7 +1456,7 @@ compDefineFunctor1(df is ['DEF,form,signature,body], $NRTslot1PredicateList := [simpBool x for x in $NRTslot1PredicateList] LAM_,FILEACTQ('loadTimeStuff, - ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) + ['MAKEPROP,MKQ $op,''infovec,getInfovecCode db]) $lisplibOperationAlist:= operationAlist -- Functors are incomplete during bootstrap if $bootStrapMode then diff --git a/src/interp/functor.boot b/src/interp/functor.boot index 6883993a..f91491b0 100644 --- a/src/interp/functor.boot +++ b/src/interp/functor.boot @@ -428,7 +428,7 @@ DescendCodeAdd1(base,flag,target,formalArgs,formalArgModes) == code:=[v,:code] [["%LET",instantiatedBase,base],:code] -DescendCode(code,flag,viewAssoc) == +DescendCode(db,code,flag,viewAssoc) == -- flag = true if we are walking down code always executed; -- otherwise set to conditions in which code = nil => nil @@ -436,16 +436,16 @@ DescendCode(code,flag,viewAssoc) == isMacro(code,$e) => nil --RDJ: added 3/16/83 code is ['add,base,:codelist] => codelist:= - [v for u in codelist | (v:= DescendCode(u,flag,viewAssoc))~=nil] + [v for u in codelist | (v:= DescendCode(db,u,flag,viewAssoc))~=nil] -- must do this first, to get this overriding Add code ['PROGN,:DescendCodeAdd(base,flag),:codelist] code is ['PROGN,:codelist] => ['PROGN,: --Two REVERSEs leave original order, but ensure last guy wins reverse! [v for u in reverse codelist | - (v:= DescendCode(u,flag,viewAssoc))~=nil]] + (v:= DescendCode(db,u,flag,viewAssoc))~=nil]] code is ['%when,:condlist] => - c:= [[u2:= ProcessCond(first u,$e),:q] for u in condlist] where q() == + c:= [[u2:= ProcessCond(db,first u,$e),:q] for u in condlist] where q() == null u2 => nil f:= TruthP u2 => flag; @@ -454,7 +454,7 @@ DescendCode(code,flag,viewAssoc) == u2 flag := ['AND,flag,['NOT,u2]]; ['AND,flag,u2] - [DescendCode(v, f, + [DescendCode(db,v, f, if first u is ['HasCategory,dom,cat] then [[dom,:cat],:viewAssoc] else viewAssoc) for v in rest u] @@ -473,7 +473,7 @@ DescendCode(code,flag,viewAssoc) == code:=['%store,['%tref,['%tref,'$,5],#$locals-#u],code] $epilogue:= TruthP flag => [code,:$epilogue] - [['%when,[ProcessCond(flag,$e),code]],:$epilogue] + [['%when,[ProcessCond(db,flag,$e),code]],:$epilogue] nil code code -- doItIf deletes entries from $locals so can't optimize this @@ -488,7 +488,7 @@ DescendCode(code,flag,viewAssoc) == if not $insideCategoryPackageIfTrue then updateCapsuleDirectory([second(u).args,third u],flag) ConstantCreator u => - if flag ~= true then u:= ['%when,[ProcessCond(flag,$e),u]] + if flag ~= true then u:= ['%when,[ProcessCond(db,flag,$e),u]] $ConstantAssignments:= [u,:$ConstantAssignments] nil u @@ -508,7 +508,7 @@ ConstantCreator u == u is ['CONS,:.] => false true -ProcessCond(cond,e) == +ProcessCond(db,cond,e) == ncond := applySubst($pairlis,cond) valuePosition(ncond,$NRTslot1PredicateList) => predicateBitRef(ncond,e) cond diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 6c6e3018..639db319 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -64,7 +64,7 @@ simplifyAttributeAlist(db,al) == [[a,:pred],:simplifyAttributeAlist(db,s)] nil -NRTgenFinalAttributeAlist e == +NRTgenFinalAttributeAlist(db,e) == [[a,:k] for [a,:b] in $NRTattributeAlist | (k := predicateBitIndex(b,e)) ~= -1] diff --git a/src/interp/nruncomp.boot b/src/interp/nruncomp.boot index 5c659091..f4ac82b6 100644 --- a/src/interp/nruncomp.boot +++ b/src/interp/nruncomp.boot @@ -515,7 +515,7 @@ buildFunctor(db,sig,code,$locals,$e) == [$NRTslot1PredicateList,predBitVectorCode1,:predBitVectorCode2] := makePredicateBitVector([:ASSOCRIGHT $condAlist,:$NRTslot1PredicateList],$e) - storeOperationCode := DescendCode(code,true,nil) + storeOperationCode := DescendCode(db,code,true,nil) NRTaddDeltaCode() storeOperationCode:= NRTputInLocalReferences storeOperationCode NRTdescendCodeTran(storeOperationCode,nil) --side effects storeOperationCode |