diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/daase.lisp | 42 | ||||
| -rw-r--r-- | src/interp/database.boot | 2 | ||||
| -rw-r--r-- | src/interp/define.boot | 11 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 5 |
4 files changed, 14 insertions, 46 deletions
diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 334e444d..086f5810 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -214,7 +214,6 @@ cosig ; interp. defaultdomain ; interp. modemaps ; interp. - niladic ; interp. object ; interp. operationalist ; interp. documentation ; browse. @@ -248,9 +247,6 @@ (defmacro |dbSuperDomain| (db) `(database-superdomain ,db)) -(defmacro |dbNiladic?| (db) - `(database-niladic ,db)) - ; there are only a small number of domains that have default domains. ; rather than keep this slot in every domain we maintain a list here. @@ -570,7 +566,6 @@ ; constructorcategory -- note that this info is the cadar of the ; constructormodemap for domains and packages so it is stored ; as NIL for them. it is valid for categories. -; niladic -- t or nil directly ; abbrev -- kept directly ; cosig -- kept directly ; constructorkind -- kept directly @@ -600,13 +595,12 @@ (setf (database-modemaps dbstruct) (fourth item)) (setf (database-object dbstruct) (fifth item)) (setf (database-constructorcategory dbstruct) (sixth item)) - (setf (|dbNiladic?| dbstruct) (seventh item)) - (setf (|dbAbbreviation| dbstruct) (eighth item)) - (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert - (setf (database-cosig dbstruct) (ninth item)) - (setf (|dbConstructorKind| dbstruct) (tenth item)) - (setf (database-ancestors dbstruct) (nth 11 item)) - (setf (|dbSuperDomain| dbstruct) (nth 12 item)) + (setf (|dbAbbreviation| dbstruct) (seventh item)) + (setf (get (seventh item) 'abbreviationfor) (first item)) ;invert + (setf (database-cosig dbstruct) (eighth item)) + (setf (|dbConstructorKind| dbstruct) (ninth item)) + (setf (database-ancestors dbstruct) (nth 10 item)) + (setf (|dbSuperDomain| dbstruct) (nth 11 item)) )) (format t "~&"))) @@ -736,8 +730,6 @@ (|constructorHasCategoryFromDB| constructor)) (format t "~a: ~a~%" 'object (|getConstructorModuleFromDB| constructor)) - (format t "~a: ~a~%" 'niladic - (|niladicConstructor?| constructor)) (format t "~a: ~a~%" 'abbreviation (|getConstructorAbbreviationFromDB| constructor)) (format t "~a: ~a~%" 'constructor? @@ -837,10 +829,6 @@ (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) (setq data (database-object struct)))) - (niladic - (setq stream *interp-stream*) - (when (setq struct (|constructorDB| constructor)) - (setq data (|dbNiladic?| struct)))) (constructor? (|fatalError| "GETDATABASE called with CONSTRUCTOR?")) (superdomain @@ -895,10 +883,11 @@ (when *miss* (format t "getdatabase miss: ~20a ~a~%" key constructor)) (file-position stream data) - ;; Don't attempt to uncompress codes -- they are not compressed. (setq data (read stream)) - (unless (eq key 'superdomain) - (setq data (unsqueeze data))) + ;; Don't attempt to uncompress codes -- they are not compressed. + (cond ((eq key 'superdomain) + (rplaca data (unsqueeze (car data)))) + (t (setq data (unsqueeze data)))) ;;(setq data (unsqueeze (read stream))) (case key ; cache the result of the database read (operation @@ -919,8 +908,6 @@ (setf (database-modemaps struct) data)) (object (setf (database-object struct) data)) - (niladic - (setf (|dbNiladic?| struct) data)) (abbreviation (setf (|dbAbbreviation| struct) data)) (constructor @@ -1091,8 +1078,6 @@ (fetchdata alist in "attributes")) (setf (database-predicates dbstruct) (fetchdata alist in "predicates")) - (setf (|dbNiladic?| dbstruct) - (when (fetchdata alist in "NILADIC") t)) (setf (|dbSuperDomain| dbstruct) (fetchdata alist in "superDomain")) (addoperations key oldmaps) @@ -1296,7 +1281,7 @@ "build interp.daase from hash tables" (declare (special *ancestors-hash*)) (let (opalistpos modemapspos cmodemappos master masterpos obj *print-pretty* - concategory categorypos kind niladic cosig abbrev defaultdomain + concategory categorypos kind cosig abbrev defaultdomain ancestors ancestorspos superpos out) (print "building interp.daase") (setq out (open "interp.build" :direction :output)) @@ -1329,7 +1314,6 @@ (print concategory out) (finish-output out)) (setq categorypos nil)) - (setq niladic (|dbNiladic?| struct)) (setq abbrev (|dbAbbreviation| struct)) (setq cosig (database-cosig struct)) (setq kind (|dbConstructorKind| struct)) @@ -1347,11 +1331,11 @@ (let ((super (|dbSuperDomain| struct))) (when super (prog1 (file-position out) - (print super out) + (print (list (squeeze (car super)) (second super)) out) (finish-output out))))) (push (list constructor opalistpos cmodemappos modemapspos - obj categorypos niladic abbrev cosig kind defaultdomain + obj categorypos abbrev cosig kind defaultdomain ancestorspos superpos) master))) (finish-output out) (setq masterpos (file-position out)) diff --git a/src/interp/database.boot b/src/interp/database.boot index d29882a2..58abfb6b 100644 --- a/src/interp/database.boot +++ b/src/interp/database.boot @@ -126,7 +126,7 @@ getConstructorParentsFromDB ctor == getSuperDomainFromDB: %Constructor -> %Form getSuperDomainFromDB ctor == GETDATABASE(ctor,"SUPERDOMAIN") - + getConstructorAttributesFromDB: %Constructor -> %Form getConstructorAttributesFromDB ctor == GETDATABASE(ctor,"ATTRIBUTES") diff --git a/src/interp/define.boot b/src/interp/define.boot index 0faa835e..379d751f 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -1040,11 +1040,6 @@ compDefineCategory2(form,signature,specialCases,body,m,e, pairlis := pairList(argl,$FormalMapVariableList) parSignature:= applySubst(pairlis,signature') parForm:= applySubst(pairlis,form) - -- If we are only interested in the defaults, there is no point - -- in writing out compiler info and load-time stuff for - -- the category which is assumed to have already been translated. - if not $compileDefaultsOnly and null sargl then - writeNiladic?(op',$libFile) -- 6. put modemaps into InteractiveModemapFrame $domainShell := eval [op',:[MKQ f for f in sargl]] @@ -1076,7 +1071,6 @@ compDefineCategory(df,m,e,prefix,fal) == dbConstructorForm(constructorDB ctor) := lhs $insideFunctorIfTrue or $LISPLIB = nil or $compileDefaultsOnly => compDefineCategory1(df,m,e,prefix,fal) - dbNiladic?(constructorDB ctor) := lhs isnt [.,:.] or lhs.args = nil compDefineLisplib(df,m,e,prefix,fal,'compDefineCategory1) @@ -1313,9 +1307,6 @@ compDefineFunctor(df,m,e,prefix,fal) == $profileAlist: local := nil $mutableDomain: local := false $LISPLIB = nil => compDefineFunctor1(df,m,e,prefix,fal) - lhs := second df - ctor := opOf lhs - dbNiladic?(constructorDB ctor) := lhs isnt [.,:.] or lhs.args = nil compDefineLisplib(df,m,e,prefix,fal,'compDefineFunctor1) compDefineFunctor1(df is ['DEF,form,signature,nils,body], @@ -1443,8 +1434,6 @@ compDefineFunctor1(df is ['DEF,form,signature,nils,body], ['MAKEPROP,MKQ $op,''infovec,getInfovecCode()]) $lisplibSlot1 := $NRTslot1Info $lisplibOperationAlist:= operationAlist - if null argl then - writeNiladic?(op',$libFile) -- Functors are incomplete during bootstrap if $bootStrapMode then evalAndRwriteLispForm('%incomplete, diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index 9d08f95d..057f1b89 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -531,11 +531,6 @@ initializeLisplib libName == mkCtorDBForm ctor == ['constructorDB,quoteForm ctor] -writeNiladic?(ctor,file) == - insn := ['%store,['dbNiladic?,mkCtorDBForm ctor],'%true] - LAM_,FILEACTQ('NILADIC,expandToVMForm insn) - lisplibWrite('"NILADIC",true,file) - writeInfo(ctor,info,key,prop,file) == if info ~= nil then insn := ['%store,[prop,mkCtorDBForm ctor],quoteForm info] |