diff options
Diffstat (limited to 'src/interp')
| -rw-r--r-- | src/interp/Makefile.in | 3 | ||||
| -rw-r--r-- | src/interp/br-con.boot | 31 | ||||
| -rw-r--r-- | src/interp/br-saturn.boot | 2 | ||||
| -rw-r--r-- | src/interp/br-util.boot | 7 | ||||
| -rw-r--r-- | src/interp/daase.lisp | 102 | ||||
| -rw-r--r-- | src/interp/define.boot | 16 | ||||
| -rw-r--r-- | src/interp/lisplib.boot | 31 |
7 files changed, 86 insertions, 106 deletions
diff --git a/src/interp/Makefile.in b/src/interp/Makefile.in index 5c10c62d..bac63c43 100644 --- a/src/interp/Makefile.in +++ b/src/interp/Makefile.in @@ -314,7 +314,8 @@ cattable.$(FASLEXT): simpbool.$(FASLEXT) c-util.$(FASLEXT) compat.$(FASLEXT): pathname.$(FASLEXT) simpbool.$(FASLEXT): macros.$(FASLEXT) newfort.$(FASLEXT): macros.$(FASLEXT) -lisplib.$(FASLEXT): nlib.$(FASLEXT) c-util.$(FASLEXT) debug.$(FASLEXT) +lisplib.$(FASLEXT): nlib.$(FASLEXT) c-util.$(FASLEXT) debug.$(FASLEXT) \ + daase.$(FASLEXT) interop.$(FASLEXT): interop.boot c-util.$(FASLEXT) hashcode.$(FASLEXT) c-doc.$(FASLEXT): c-util.$(FASLEXT) server.$(FASLEXT): macros.$(FASLEXT) diff --git a/src/interp/br-con.boot b/src/interp/br-con.boot index b11c18f4..6eafe370 100644 --- a/src/interp/br-con.boot +++ b/src/interp/br-con.boot @@ -909,7 +909,7 @@ dbShowCons1(htPage,cAlist,key) == htPage and htpProperty(htPage,'domname) => first conlist opOf first conlist conlist := [opOf x for x in conlist] - kinds := "union"/[dbConstructorKind x for x in conlist] + kinds := [dbConstructorKind constructorDB x for x in conlist] kind := kinds is [a] => a 'constructor @@ -947,35 +947,6 @@ dbConsExposureMessage() == $atLeastOneUnexposed => htSay '"\newline{}-------------\newline{}{\em *} = unexposed" --- DUPLICATE DEF - ALSO in br-saturn.boot --- dbShowConsKinds cAlist == --- ---------> !OBSELETE! <------------- --- cats := doms := paks := defs := nil --- for x in cAlist repeat --- op := CAAR x --- kind := dbConstructorKind op --- kind = 'category => cats := [x,:cats] --- kind = 'domain => doms := [x,:doms] --- kind = 'package => paks:= [x,:paks] --- defs := [x,:defs] --- lists := [reverse! cats,reverse! doms,reverse! paks,reverse! defs] --- htBeginMenu(2) --- htSayStandard '"\indent{1}" --- kinds := +/[1 for x in lists | #x > 0] --- for kind in '("category" "domain" "package" "default package") for x in lists | #x > 0 repeat --- htSay('"\item") --- if kinds = 1 then htSay menuButton() else --- htMakePage [['bcLinks,[menuButton(),'"",'dbShowConsKindsFilter,[kind,x]]]] --- htSayStandard '"\tab{1}" --- htSay '"{\em " --- htSay (c := #x) --- htSay '" " --- htSay (c > 1 => pluralize kind; kind) --- htSay '":}" --- bcConTable removeDuplicates [CAAR y for y in x] --- htEndMenu(2) --- htSay '"\indent{0}" - dbShowConsKindsFilter(htPage,[kind,cAlist]) == htpSetProperty(htPage,'cAlist,cAlist) dbShowCons(htPage,htpProperty(htPage,'exclusion)) diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot index 1719be7a..2501b596 100644 --- a/src/interp/br-saturn.boot +++ b/src/interp/br-saturn.boot @@ -867,7 +867,7 @@ dbShowConsKinds cAlist == cats := doms := paks := defs := nil for x in cAlist repeat op := CAAR x - kind := dbConstructorKind op + kind := dbConstructorKind constructorDB op kind = 'category => cats := [x,:cats] kind = 'domain => doms := [x,:doms] kind = 'package => paks := [x,:paks] diff --git a/src/interp/br-util.boot b/src/interp/br-util.boot index 2d0f2e8b..873dfa56 100644 --- a/src/interp/br-util.boot +++ b/src/interp/br-util.boot @@ -262,13 +262,6 @@ args2LispString x == null x => '"" strconc('",",form2LispString first x,fnTailTail rest x) -dbConstructorKind x == - target := getConstructorModemapFromDB(x).mmTarget - target = '(Category) => 'category - target is ['CATEGORY,'package,:.] => 'package - tableValue($defaultPackageNamesHT,x) => 'default_ package - 'domain - getConstructorForm name == name = 'Union => '(Union (_: a A) (_: b B)) name = 'UntaggedUnion => '(Union A B) diff --git a/src/interp/daase.lisp b/src/interp/daase.lisp index 07d90cfc..df102e1a 100644 --- a/src/interp/daase.lisp +++ b/src/interp/daase.lisp @@ -230,6 +230,24 @@ ) ; database structure +(defmacro |dbAbbreviation| (db) + `(database-abbreviation ,db)) + +(defmacro |dbConstructorKind| (db) + `(database-constructorkind ,db)) + +(defmacro |dbConstructorForm| (db) + `(database-constructorform ,db)) + +(defmacro |dbOperations| (db) + `(database-operationalist ,db)) + +(defmacro |dbConstructorModemap| (db) + `(database-constructormodemap ,db)) + +(defmacro |dbSuperDomain| (db) + `(database-superdomain ,db)) + (defmacro |dbNiladic?| (db) `(database-niladic ,db)) @@ -577,18 +595,18 @@ (setq *allconstructors* (adjoin (first item) *allconstructors*)) (setq dbstruct (make-database)) (setf (|constructorDB| (car item)) dbstruct) - (setf (database-operationalist dbstruct) (second item)) - (setf (database-constructormodemap dbstruct) (third item)) + (setf (|dbOperations| dbstruct) (second item)) + (setf (|dbConstructorModemap| dbstruct) (third item)) (setf (database-modemaps dbstruct) (fourth item)) (setf (database-object dbstruct) (fifth item)) (setf (database-constructorcategory dbstruct) (sixth item)) (setf (|dbNiladic?| dbstruct) (seventh item)) - (setf (database-abbreviation dbstruct) (eighth item)) + (setf (|dbAbbreviation| dbstruct) (eighth item)) (setf (get (eighth item) 'abbreviationfor) (first item)) ;invert (setf (database-cosig dbstruct) (ninth item)) - (setf (database-constructorkind dbstruct) (tenth item)) + (setf (|dbConstructorKind| dbstruct) (tenth item)) (setf (database-ancestors dbstruct) (nth 11 item)) - (setf (database-superdomain dbstruct) (nth 12 item)) + (setf (|dbSuperDomain| dbstruct) (nth 12 item)) )) (format t "~&"))) @@ -635,14 +653,14 @@ (setq item (unsqueeze item)) (unless (setq dbstruct (|constructorDB| (car item))) (format t "browseOpen:~%") - (format t "the browse database contains a contructor ~a~%" item) + (format t "the browse database contains a constructor ~a~%" item) (format t "that is not in the interp.daase file. we cannot~%") (format t "get the database structure for this constructor and~%") (warn "will create a new one~%") (setf (|constructorDB| (car item)) (setq dbstruct (make-database))) (setq *allconstructors* (adjoin item *allconstructors*))) (setf (database-sourcefile dbstruct) (second item)) - (setf (database-constructorform dbstruct) (third item)) + (setf (|dbConstructorForm| dbstruct) (third item)) (setf (database-documentation dbstruct) (fourth item)) (setf (database-attributes dbstruct) (fifth item)) (setf (database-predicates dbstruct) (sixth item)) @@ -753,13 +771,13 @@ (setf (|constructorDB| constructor) struct)) (case key (abbreviation - (setf (database-abbreviation struct) value) + (setf (|dbAbbreviation| struct) value) (when (symbolp value) (setf (get value 'abbreviationfor) constructor))) (superdomain - (setf (database-superdomain struct) value)) + (setf (|dbSuperDomain| struct) value)) (constructorkind - (setf (database-constructorkind struct) value)))))) + (setf (|dbConstructorKind| struct) value)))))) (defun deldatabase (constructor key) (when (symbolp constructor) @@ -781,11 +799,11 @@ (abbreviation (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-abbreviation struct)))) + (setq data (|dbAbbreviation| struct)))) (constructorkind (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-constructorkind struct)))) + (setq data (|dbConstructorKind| struct)))) (cosig (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) @@ -796,7 +814,7 @@ (constructormodemap (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-constructormodemap struct)))) + (setq data (|dbConstructorModemap| struct)))) (constructorcategory (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) @@ -806,7 +824,7 @@ (operationalist (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-operationalist struct)))) + (setq data (|dbOperations| struct)))) (modemaps (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) @@ -825,10 +843,10 @@ (setq data (|dbNiladic?| struct)))) (constructor? (|fatalError| "GETDATABASE called with CONSTRUCTOR?")) - (superdomain ; only 2 superdomains in the world + (superdomain (setq stream *interp-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-superdomain struct)))) + (setq data (|dbSuperDomain| struct)))) (constructor (when (setq data (get constructor 'abbreviationfor)))) (defaultdomain @@ -844,7 +862,7 @@ (constructorform (setq stream *browse-stream*) (when (setq struct (|constructorDB| constructor)) - (setq data (database-constructorform struct)))) + (setq data (|dbConstructorForm| struct)))) (constructorargs (setq data (cdr (|getConstructorFormFromDB| constructor)))) (attributes @@ -888,15 +906,15 @@ (hascategory (setf (gethash constructor *hascategory-hash*) data)) (constructorkind - (setf (database-constructorkind struct) data)) + (setf (|dbConstructorKind| struct) data)) (cosig (setf (database-cosig struct) data)) (constructormodemap - (setf (database-constructormodemap struct) data)) + (setf (|dbConstructorModemap| struct) data)) (constructorcategory (setf (database-constructorcategory struct) data)) (operationalist - (setf (database-operationalist struct) data)) + (setf (|dbOperations| struct) data)) (modemaps (setf (database-modemaps struct) data)) (object @@ -904,13 +922,13 @@ (niladic (setf (|dbNiladic?| struct) data)) (abbreviation - (setf (database-abbreviation struct) data)) + (setf (|dbAbbreviation| struct) data)) (constructor (setf (database-constructor struct) data)) (ancestors (setf (database-ancestors struct) data)) (constructorform - (setf (database-constructorform struct) data)) + (setf (|dbConstructorForm| struct) data)) (attributes (setf (database-attributes struct) data)) (predicates @@ -920,7 +938,7 @@ (parents (setf (database-parents struct) data)) (superdomain - (setf (database-superdomain struct) data)) + (setf (|dbSuperDomain| struct) data)) (users (setf (database-users struct) data)) (dependents @@ -1044,17 +1062,17 @@ (setq dbstruct (make-database)) (setq *allconstructors* (adjoin key *allconstructors*)) (setf (|constructorDB| key) dbstruct) ; store the struct, side-effect it... - (setf (database-constructorform dbstruct) constructorform) + (setf (|dbConstructorForm| dbstruct) constructorform) (setq *allOperations* nil) ; force this to recompute (setf (database-object dbstruct) object) (setq abbrev (intern (pathname-name (first (last (pathname-directory object)))))) - (setf (database-abbreviation dbstruct) abbrev) + (setf (|dbAbbreviation| dbstruct) abbrev) (setf (get abbrev 'abbreviationfor) key) - (setf (database-operationalist dbstruct) nil) - (setf (database-operationalist dbstruct) + (setf (|dbOperations| dbstruct) nil) + (setf (|dbOperations| dbstruct) (fetchdata alist in "operationAlist")) - (setf (database-constructormodemap dbstruct) + (setf (|dbConstructorModemap| dbstruct) (fetchdata alist in "constructorModemap")) (setf (database-modemaps dbstruct) (fetchdata alist in "modemaps")) @@ -1063,7 +1081,7 @@ (when make-database? (setf (database-sourcefile dbstruct) (file-namestring (database-sourcefile dbstruct)))) - (setf (database-constructorkind dbstruct) + (setf (|dbConstructorKind| dbstruct) (setq kind (fetchdata alist in "constructorKind"))) (setf (database-constructorcategory dbstruct) (fetchdata alist in "constructorCategory")) @@ -1075,14 +1093,8 @@ (fetchdata alist in "predicates")) (setf (|dbNiladic?| dbstruct) (when (fetchdata alist in "NILADIC") t)) - (let ((super (fetchdata alist in "evalOnLoad2"))) - (setf (database-superdomain dbstruct) - (when super - (setq super (cddr super)) - ;; unquote the domain and predicate. - (rplaca super (second (first super))) - (rplacd super (cdr (second super))) - super))) + (setf (|dbSuperDomain| dbstruct) + (fetchdata alist in "superDomain")) (addoperations key oldmaps) (unless make-database? (if (eq kind '|category|) @@ -1098,7 +1110,7 @@ (setq |$CategoryFrame| |$EmptyEnvironment|))) (setf (database-cosig dbstruct) (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) + (cddar (|dbConstructorModemap| dbstruct))))) (remprop key 'loaded) (if (null noexpose) (|setExposeAddConstr| (cons key nil))) @@ -1198,7 +1210,7 @@ (when (setq dbstruct (|constructorDB| con)) (setf (database-cosig dbstruct) (cons nil (mapcar #'|categoryForm?| - (cddar (database-constructormodemap dbstruct))))) + (cddar (|dbConstructorModemap| dbstruct))))) (when (and (|categoryForm?| con) (= (length (setq d (|domainsOf| (list con) NIL NIL))) 1)) (setq d (caar d)) @@ -1294,10 +1306,10 @@ (let (struct) (setq struct (|constructorDB| constructor)) (setq opalistpos (file-position out)) - (print (squeeze (database-operationalist struct)) out) + (print (squeeze (|dbOperations| struct)) out) (finish-output out) (setq cmodemappos (file-position out)) - (print (squeeze (database-constructormodemap struct)) out) + (print (squeeze (|dbConstructorModemap| struct)) out) (finish-output out) (setq modemapspos (file-position out)) (print (squeeze (database-modemaps struct)) out) @@ -1318,9 +1330,9 @@ (finish-output out)) (setq categorypos nil)) (setq niladic (|dbNiladic?| struct)) - (setq abbrev (database-abbreviation struct)) + (setq abbrev (|dbAbbreviation| struct)) (setq cosig (database-cosig struct)) - (setq kind (database-constructorkind struct)) + (setq kind (|dbConstructorKind| struct)) (setq defaultdomain (database-defaultdomain struct)) (setq ancestors (squeeze (gethash constructor *ancestors-hash*))) ;cattable.boot (if ancestors @@ -1332,7 +1344,7 @@ (setq superpos ;; We do NOT want to compress codes, as we may not be ;; able to uncompress them to their original form. - (let ((super (database-superdomain struct))) + (let ((super (|dbSuperDomain| struct))) (when super (prog1 (file-position out) (print super out) @@ -1363,7 +1375,7 @@ ; sourcefile is small. store the string directly (setq src (database-sourcefile struct)) (setq formpos (file-position out)) - (print (squeeze (database-constructorform struct)) out) + (print (squeeze (|dbConstructorForm| struct)) out) (finish-output out) (setq docpos (file-position out)) (print (database-documentation struct) out) diff --git a/src/interp/define.boot b/src/interp/define.boot index 6e60191e..aeeff45e 100644 --- a/src/interp/define.boot +++ b/src/interp/define.boot @@ -101,7 +101,6 @@ $CapsuleModemapFrame := nil $CapsuleDomainsInScope := nil $signatureOfForm := nil $addFormLhs := nil -$lisplibSuperDomain := nil $sigList := [] $atList := [] @@ -641,9 +640,7 @@ expandTypeArgs(u,template,domform) == emitSubdomainInfo(form,super,pred) == pred := applySubst!(pairList(form.args,$AtVariables),pred) super := applySubst!(pairList(form.args,$AtVariables),super) - evalAndRwriteLispForm("evalOnLoad2",["noteSubDomainInfo", - quoteForm form.op,quoteForm super, quoteForm pred]) - + dbSuperDomain(constructorDB form.op) := [super,pred] ++ List of operations defined in a given capsule ++ Each item on this list is of the form @@ -1055,7 +1052,6 @@ compDefineCategory2(form,signature,specialCases,body,m,e, $lisplibCategory:= formalBody if $LISPLIB then $lisplibForm:= form - $lisplibKind:= 'category modemap:= [[parForm,:parSignature],[true,op']] $lisplibModemap:= modemap $lisplibParents := @@ -1452,9 +1448,6 @@ compDefineFunctor1(df is ['DEF,form,signature,nils,body], $lisplibAbbreviation := getConstructorAbbreviationFromDB $op $insideFunctorIfTrue:= false if $LISPLIB then - $lisplibKind:= - $functorTarget is ["CATEGORY",key,:.] and key~="domain" => 'package - 'domain $lisplibForm:= form if not $bootStrapMode then $NRTslot1Info := NRTmakeSlot1Info() @@ -1495,7 +1488,11 @@ incompleteFunctorBody(form,m,body,e) == if funsel is [op,.,.] and op in '(ELT CONST) then third(funsel) := nil ops := [[opsig,pred,funsel],:ops] - $lisplibOperationAlist := listSort(function GGREATERP, ops, function first) + $lisplibOperationAlist := listSort(function GGREATERP,ops,function first) + dbSuperDomain(constructorDB form.op) := + body is ['SubDomain,dom,pred] => [dom,pred] + body is ['add,['SubDomain,dom,pred],:.] => [dom,pred] + nil [bootStrapError(form, _/EDITFILE),m,e] ++ Subroutine of compDefineFunctor1. Called to generate backend code @@ -2197,7 +2194,6 @@ compSubDomain1(domainForm,predicate,m,e) == CONTAINED("$",pred) => stackAndThrow('"predicate %1pb is not simple enough",[predicate]) emitSubdomainInfo($form,domainForm,pred) - $lisplibSuperDomain := [domainForm,predicate] [domainForm,m,e] compCapsuleInner(itemList,m,e) == diff --git a/src/interp/lisplib.boot b/src/interp/lisplib.boot index b0966204..1616a042 100644 --- a/src/interp/lisplib.boot +++ b/src/interp/lisplib.boot @@ -35,6 +35,7 @@ import nlib import c_-util import debug +import daase namespace BOOT module lisplib @@ -440,13 +441,11 @@ compConLib1(fun,infileOrNil,outfileOrNil,auxOp,editFlag,traceFlag) == $lisplibAbbreviation: local := nil $lisplibParents: local := nil $lisplibAncestors: local := nil - $lisplibKind: local := nil $lisplibModemap: local := nil $lisplibModemapAlist: local := nil $lisplibSlot1 : local := nil --used by NRT mechanisms $lisplibOperationAlist: local := nil $lisplibOpAlist: local:= nil - $lisplibSuperDomain: local := nil $libFile: local := nil $lisplibVariableAlist: local := nil $lisplibSignatureAlist: local := nil @@ -470,7 +469,6 @@ compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == $lisplibAttributes: local := nil $lisplibPredicates: local := nil -- set by makePredicateBitVector $lisplibForm: local := nil - $lisplibKind: local := nil $lisplibAbbreviation: local := nil $lisplibParents: local := nil $lisplibAncestors: local := nil @@ -480,7 +478,6 @@ compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == $lisplibOperationAlist: local := nil $lisplibOpAlist: local := nil --operations alist for new runtime system $lisplibSignatureAlist: local := nil - $lisplibSuperDomain: local := nil $libFile: local := nil $lisplibVariableAlist: local := nil -- $lisplibRelatedDomains: local := nil --from ++ Related Domains: see c-doc @@ -501,9 +498,9 @@ compDefineLisplib(df:=["DEF",[op,:.],:.],m,e,prefix,fal,fn) == ok := false; try res:= FUNCALL(fn,df,m,e,prefix,fal) - leaveIfErrors(libName) + leaveIfErrors(libName,dbConstructorKind constructorDB $op) sayMSG ['" finalizing ",$spadLibFT,:bright libName] - ok := finalizeLisplib libName + ok := finalizeLisplib(op,libName) finally RSHUT $libFile if ok then lisplibDoRename(libName) filearg := $FILEP(libName,$spadLibFT,$libraryDirectory) @@ -547,18 +544,28 @@ writeNiladic?(ctor,file) == 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] + LAM_,FILEACTQ(key,expandToVMForm insn) + lisplibWrite(symbolName key,info,file) + +writeSuperDomain(ctor,domPred,file) == + writeInfo(ctor,domPred,'superDomain,'dbSuperDomain,file) + ++ If compilation produces an error, issue inform user and ++ return to toplevel reader. -leaveIfErrors libName == +leaveIfErrors(libName,kind) == errorCount() ~= 0 => - sayMSG ['" Errors in processing ",$lisplibKind,'" ",:bright libName,'":"] + sayMSG ['" Errors in processing ",kind,'" ",:bright libName,'":"] sayMSG ['" not replacing ",$spadLibFT,'" for",:bright libName] spadThrow() ++ Finalize `libName' compilation; returns true if everything is OK. -finalizeLisplib libName == +finalizeLisplib(ctor,libName) == + kind := dbConstructorKind constructorDB ctor lisplibWrite('"constructorForm",removeZeroOne $lisplibForm,$libFile) - lisplibWrite('"constructorKind",kind:=removeZeroOne $lisplibKind,$libFile) + lisplibWrite('"constructorKind",kind,$libFile) lisplibWrite('"constructorModemap",removeZeroOne $lisplibModemap,$libFile) $lisplibCategory:= $lisplibCategory or $lisplibModemap.mmTarget -- set to target of modemap for package/domain constructors; @@ -575,7 +582,7 @@ finalizeLisplib libName == $pairlis : local := pairList($lisplibForm,$FormalMapVariableList) $NRTslot1PredicateList : local := [] NRTgenInitialAttributeAlist rest opsAndAtts - lisplibWrite('"superDomain",removeZeroOne $lisplibSuperDomain,$libFile) + writeSuperDomain(ctor,dbSuperDomain constructorDB ctor,$libFile) lisplibWrite('"signaturesAndLocals", removeZeroOne mergeSignatureAndLocalVarAlists($lisplibSignatureAlist, $lisplibVariableAlist),$libFile) @@ -587,7 +594,7 @@ finalizeLisplib libName == lisplibWrite('"documentation",finalizeDocumentation(),$libFile) lisplibWrite('"slot1Info",removeZeroOne $lisplibSlot1,$libFile) if $profileCompiler then profileWrite() - leaveIfErrors libName + leaveIfErrors(libName,kind) true lisplibDoRename(libName) == |