diff --git a/changelog b/changelog index 4d722d9..b4309c4 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090712 tpd src/axiom-website/patches.html 20090712.02.tpd.patch +20090712 tpd src/interp/Makefile remove br-op1 +20090712 tpd src/interp/br-con.boot merge br-op1.boot +20090712 tpd src/interp/br-op1.boot removed, merge with br-con 20090712 tpd src/axiom-website/patches.html 20090712.01.tpd.patch 20090712 tpd src/interp/Makefile remove showimp.boot 20090712 tpd src/interp/br-con.boot merge showimp diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index 5f4dec2..ea1c38d 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1711,5 +1711,7 @@ merge ht-util and ht-root
merge br-con and br-data
20090712.01.tpd.patch merge br-con and showimp
+20090712.02.tpd.patch +merge br-con and br-op1
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 7f8f96f..32dd048 100644 --- a/src/interp/Makefile.pamphlet +++ b/src/interp/Makefile.pamphlet @@ -286,7 +286,7 @@ browser. These files should probably be autoloaded. BROBJS= ${AUTO}/bc-matrix.${O} \ ${AUTO}/ht-util.${O} \ ${AUTO}/br-con.${O} \ - ${AUTO}/br-op1.${O} ${AUTO}/br-op2.${O} \ + ${AUTO}/br-op2.${O} \ ${AUTO}/br-search.${O} ${AUTO}/br-util.${O} \ ${AUTO}/topics.${O} ${AUTO}/br-prof.${O} \ ${AUTO}/br-saturn.${O} @@ -430,7 +430,6 @@ DOCFILES=${DOC}/alql.boot.dvi \ ${DOC}/bc-matrix.boot.dvi \ ${DOC}/bits.lisp.dvi ${DOC}/bootfuns.lisp.dvi \ ${DOC}/br-con.boot.dvi \ - ${DOC}/br-op1.boot.dvi \ ${DOC}/br-op2.boot.dvi ${DOC}/br-prof.boot.dvi \ ${DOC}/br-saturn.boot.dvi ${DOC}/br-search.boot.dvi \ ${DOC}/br-util.boot.dvi ${DOC}/buildom.boot.dvi \ @@ -5889,54 +5888,6 @@ ${DOC}/br-search.boot.dvi: ${IN}/br-search.boot.pamphlet @ -\subsection{br-op1.boot} -<>= -${AUTO}/br-op1.${O}: ${OUT}/br-op1.${O} - @ echo 473 making ${AUTO}/br-op1.${O} from ${OUT}/br-op1.${O} - @ cp ${OUT}/br-op1.${O} ${AUTO} - -@ -<>= -${OUT}/br-op1.${O}: ${MID}/br-op1.clisp - @ echo 474 making ${OUT}/br-op1.${O} from ${MID}/br-op1.clisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/br-op1.clisp"' \ - ':output-file "${OUT}/br-op1.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/br-op1.clisp"' \ - ':output-file "${OUT}/br-op1.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/br-op1.clisp: ${IN}/br-op1.boot.pamphlet - @ echo 475 making ${MID}/br-op1.clisp from ${IN}/br-op1.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/br-op1.boot.pamphlet >br-op1.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "br-op1.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "br-op1.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm br-op1.boot ) - -@ -<>= -${DOC}/br-op1.boot.dvi: ${IN}/br-op1.boot.pamphlet - @echo 476 making ${DOC}/br-op1.boot.dvi from ${IN}/br-op1.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/br-op1.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} br-op1.boot ; \ - rm -f ${DOC}/br-op1.boot.pamphlet ; \ - rm -f ${DOC}/br-op1.boot.tex ; \ - rm -f ${DOC}/br-op1.boot ) - -@ - \subsection{br-op2.boot} <>= ${AUTO}/br-op2.${O}: ${OUT}/br-op2.${O} @@ -7715,11 +7666,6 @@ clean: <> <> -<> -<> -<> -<> - <> <> <> diff --git a/src/interp/br-con.boot.pamphlet b/src/interp/br-con.boot.pamphlet index 10f80c5..1417f95 100644 --- a/src/interp/br-con.boot.pamphlet +++ b/src/interp/br-con.boot.pamphlet @@ -2365,6 +2365,1138 @@ formatLazyDomainForm(dom,x) == [first x,:[formatLazyDomainForm(dom,y) for y in rest x]] +--====================> WAS b-op1.boot <================================ + +--======================================================================= +-- Operation Page Menu +--======================================================================= +--opAlist has form [[op,:alist],:.] where each alist +-- has form [sig,pred,origin,exposeFlag,comments] + +dbFromConstructor?(htPage) == htpProperty(htPage,'conform) + +dbPresentOps(htPage,which,:exclusions) == + true => dbPresentOpsSaturn(htPage,which,exclusions) +--Flags: +-- fromConPage?: came (originally) from a constructor page +-- usage?: display usage? +-- star?: display exposed/*=unexposed +-- implementation?: display implementation? + htSay('"{\em Views:}") + asharp? := htpProperty(htPage,'isAsharpConstructor) + fromConPage? := (conname := opOf htpProperty(htPage,'conform)) + usage? := $UserLevel = 'development and fromConPage? and which = '"operation" + and not (GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + and not asharp? + star? := not fromConPage? or which = '"package operation" + implementation? := not asharp? and + $UserLevel = 'development and $conformsAreDomains + --and not $includeUnexposed? + rightmost? := star? or (implementation? and not $includeUnexposed?) + tabs := + which = '"attribute" => '("12" "12" "25" "40" 13) + star? => '("12" "19" "31" "43" 10) + implementation? => '("9" "16" "28" "44" 9) + '("9" "16" "28" "41" 12) + if INTEGERP first exclusions then exclusions := ['documentation] + htpSetProperty(htPage,'exclusion,first exclusions) + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + empty? := null opAlist + htTab + which = '"attribute" => tabs.1 + tabs.0 + if empty? or MEMBER('names,exclusions) or null KDR opAlist + then htSay '"{\em names}" + else htMakePage [['bcLispLinks,['"names",'"",'dbShowOps,which,'names]]] + if which ^= '"attribute" then + htTab tabs.1 + if empty? or MEMBER('signatures,exclusions) + then htSay '"{\em signatures}" + else htMakePage _ + [['bcLispLinks,['"signatures",'"",'dbShowOps,which,'signatures]]] + htTab tabs.2 + if empty? or MEMBER('parameters,exclusions) --also test for some parameter + or not dbDoesOneOpHaveParameters? opAlist + then htSay '"{\em parameters}" + else htMakePage _ + [['bcLispLinks,['"parameters",'"",'dbShowOps,which,'parameters]]] + htTab tabs.3 + if not empty? and null IFCDR opAlist and not htpProperty(htPage,'noUsage) + then + if htpProperty(htPage,'conform) + then htMakePage + [['bcLinks,['"generalise",'"",'dbShowOps,which,'generalise]]] + else htMakePage + [['bcLinks,['"all domains",'"",'dbShowOps,which,'allDomains]]] + else + if empty? or MEMQ('usage,exclusions) or _ + htpProperty(htPage,'noUsage) then htSay '"{\em filter}" else + htMakePage [['bcLinks,['"filter",'"",'dbShowOps,which,'filter]]] + htMakePage [['bcStrings, [tabs.4,'"",'filter,'EM]]] + htSay('"\newline ") + if star? + then + if $exposedOnlyIfTrue + then htMakePage + [['bcLinks,['"exposed",'" {\em only}",'dbShowOps,which,'exposureOff]]] + else + htSay('"*{\em =}") + htMakePage [['bcLinks,['"unexposed",'"",'dbShowOps,which,'exposureOn]]] +-- else if (updown := dbCompositeWithMap htPage) +-- then htMakePage [['bcLispLinks,[updown,'"",'dbShowUpDown,updown]]] + htTab tabs.0 + if usage? then + if empty? or MEMBER('usage,exclusions) _ + or GETDATABASE(conname,'CONSTRUCTORKIND) = 'category _ + or HGET($defaultPackageNamesHT,conname) _ + or htpProperty(htPage,'noUsage) + then htSay '"{\em usage}" + else htMakePage _ + [['bcLispLinks,['"usage",'"",'whoUsesOperation,which,nil]]] + htTab tabs.1 + if empty? or MEMBER('origins,exclusions) + then htSay '"{\em origins}" + else htMakePage [['bcLispLinks,['"origins",'"",'dbShowOps,which,'origins]]] + htTab tabs.2 + if implementation? then + if MEMBER('implementation,exclusions) or which = '"attribute" or + ((conname := opOf htpProperty(htPage,'conform)) _ + and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) + then htSay '"{\em implementation}" + else htMakePage _ + [['bcLispLinks,['"implementation",'"",'dbShowOps,which,'implementation]]] + else if empty? or MEMBER('conditions,exclusions) _ + or (htpProperty(htPage,'condition?) = 'no) + then htSay '"{\em conditions}" + else htMakePage _ + [['bcLispLinks,['"conditions",'"",'dbShowOps,which,'conditions]]] + htTab tabs.3 + if empty? or MEMBER('documentation,exclusions) + then htSay '"{\em description}" + else htMakePage _ + [['bcLispLinks,['"description",'"",'dbShowOps,which,'documentation]]] + htShowPageNoScroll() + +htTab s == htSay('"\tab{",s,'"}") + +dbDoesOneOpHaveParameters? opAlist == + or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn == + STRINGP x => dbPart(x,2,1) ^= '"0" + KAR x +--============================================================================ +-- Master Switch Functions for Operation Views +--============================================================================ + +dbShowOps(htPage,which,key,:options) == + --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string + which := STRINGIMAGE which + if MEMQ(key,'(extended basic all)) then + $groupChoice := key + key := htpProperty(htPage,'key) or 'names + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) +-- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist)) +-- htpSetProperty(htPage,'opAlist,al) +-- al + htpProperty(htPage,'attrAlist) + key = 'generalise => + arg := STRINGIMAGE CAAR opAlist + which = '"attribute" => aPage arg + oPage arg + key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which) + key = 'filter => + --if $saturn, IFCAR options contains filter string + filter := IFCAR options or pmTransFilter(dbGetInputString htPage) + filter is ['error,:.] => bcErrorPage filter + opAlist:= _ + [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)] + null opAlist => emptySearchPage(which,filter) + htPage := htInitPageNoScroll(htCopyProplist htPage) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,opAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + if not htpProperty(htPage,'condition?) = 'no then + dbResetOpAlistCondition(htPage,which,opAlist) + dbShowOps(htPage,which,htpProperty(htPage,'exclusion)) + htpSetProperty(htPage,'key,key) + if MEMQ(key,'(exposureOn exposureOff)) then + $exposedOnlyIfTrue := + key = 'exposureOn => 'T + nil + key := htpProperty(htPage,'exclusion) + dbShowOp1(htPage,opAlist,which,key) + +reduceByGroup(htPage,opAlist) == + not dbFromConstructor?(htPage) or null $groupChoice => opAlist + dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false) + bitNumber := HGET($topicHash,$groupChoice) + res := [[op,:newItems] for [op,:items] in opAlist | newItems] where + newItems == + null bitNumber => items + [x for x in items | FIXP (code := myLastAtom x) _ + and LOGBITP(bitNumber,code)] + res + + +dbShowOp1(htPage,opAlist,which,key) == + --set up for filtering below in dbGatherData + $which: local := which + if INTEGERP key then + opAlist := dbSelectData(htPage,opAlist,key) + ------> Jump out for constructor names in file <-------- + INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile) + and constructor? con => return conPageChoose con + if INTEGERP key then + htPage := htInitPageNoScroll(htCopyProplist htPage) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,opAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + if not htpProperty(htPage,'condition?) = 'no then + dbResetOpAlistCondition(htPage,which,opAlist) + dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) + if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then + --opAlist is expanded to form + -- [[op,[sig,pred,origin,exposed,comments],...],...] + opAlist:=[item for [op,:items] in opAlist | item] where + item == + acc := nil + for x in items | x.3 repeat acc:= [x,:acc] + null acc => nil + [op,:NREVERSE acc] + $conformsAreDomains : local := htpProperty(htPage,'domname) + opCount := opAlistCount(opAlist, which) + branch := + INTEGERP key => + opCount <= $opDescriptionThreshold => 'documentation + 'names + key = 'names and null rest opAlist => --means a single op + opCount <= $opDescriptionThreshold => 'documentation + 'names + key + [what,whats,fn] := LASSOC(branch,$OpViewTable) + data := dbGatherData(htPage,opAlist,which,branch) + dataCount := +/[1 for x in data | (what = '"Name" and _ + $exposedOnlyIfTrue => atom x; true)] + namedPart := + null rest opAlist => + ops := escapeSpecialChars STRINGIMAGE CAAR opAlist + ['" {\em ",ops,'"}"] + nil + if what = '"Condition" and null KAR KAR data then dataCount := dataCount - 1 + exposurePart := + $exposedOnlyIfTrue => '(" Exposed ") + nil + firstPart := + opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which] + dataCount = 1 or dataCount = opCount => + opCount = 1 => [:exposurePart, capitalize which,:namedPart] + [STRINGIMAGE opCount,'" ",:exposurePart, + pluralize capitalize which,:namedPart] + prefix := pluralSay(dataCount,what,whats) + [:prefix,'" for ",STRINGIMAGE opCount,'" ",_ + pluralize capitalize which,:namedPart] + page := htInitPageNoScroll(htCopyProplist htPage) + ------------>above line used to call htInitPageHoHeading<---------- + htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) + htpSetProperty(page,'data,data) + htpSetProperty(page,'branch,branch) + -- only place where specialMessage property is set seems to be commented. out + if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) + htSayStandard('"\beginscroll ") + FUNCALL(fn,page,opAlist,which,data) --apply branch function + dbOpsExposureMessage() + htSayStandard("\endscroll ") + dbPresentOps(page,which,branch) + htShowPageNoScroll() + +opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo == + null $exposedOnlyIfTrue or which = '"attribute" => #items + --count if unexpanded---CDDR(w) = nil---or if w.3 = true + +/[1 for w in items | null (p := CDDR w) or p . 1] + +dbShowOpHeading(heading, branch) == + suffix := +-- branch = 'signatures => '" viewed as signatures" + branch = 'parameters => '" viewed with parameters" + branch = 'origins => '" organized by origins" + branch = 'conditions => '" organized by conditions" + '"" + [:heading, suffix] + +dbOpsExposureMessage() == + $atLeastOneUnexposed => htSay '"{\em *} = unexposed" + +fromHeading htPage == + null htPage => '"" + $pn := [htPage.0,'"}{"] + updomain := htpProperty(htPage,'updomain) => + dnForm := dbExtractUnderlyingDomain updomain + dnString:= form2StringList dnForm + dnFence := form2Fence dnForm +-- upString:= form2StringList updomain + upFence := form2Fence updomain + upOp := PNAME opOf updomain + ['" {\em from} ",:dbConformGen dnForm,'" {\em under} _ + \ops{",upOp,'"}{",:$pn,:upFence,'"}"] + domname := htpProperty(htPage,'domname) + numberOfUnderlyingDomains := #[x for x in rest _ + GETDATABASE(opOf domname,'COSIG) | x] +-- numberOfUnderlyingDomains = 1 and +-- KDR domname and (dn := dbExtractUnderlyingDomain domname) => +-- ['" {\em from} ",:pickitForm(domname,dn)] + KDR domname => ['" {\em from} ",:dbConformGen domname] + htpProperty(htPage,'fromHeading) + +pickitForm(form,uarg) == + conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg) + +conformString(form) == + KDR form => + conform2StringList(form,FUNCTION conname2StringList,_ + FUNCTION conformString,nil) + form2StringList form + +conform2StringList(form,opFn,argFn,exception) == + exception := exception or '"%%%nothing%%%" + [op1,:args] := form + op := IFCAR HGET($lowerCaseConTb,op1) or op1 + null args => APPLY(opFn,[op]) + special := MEMQ(op,'(Union Record Mapping)) + cosig := + special => ['T for x in args] + rest GETDATABASE(op,'COSIG) + atypes := + special => cosig + rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) + sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == + keyword := + x is [":",y,t] => + x := t + y + nil + res := + x = exception => dbOpsForm exception + pred => + STRINGP x => [x] + u := APPLY(argFn,[x]) + atom u and [u] or u + typ := sublisFormal(args,atype) + if x is ['QUOTE,a] then x := a + u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u] + NUMBERP x or STRINGP x => [x] + systemError() + keyword => [keyword,'": ",:res] + res + op = 'Mapping => dbMapping2StringList sargl + head := + special => [op] + APPLY(opFn,[form]) + [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"] + + +dbMapping2StringList [target,:sl] == + null sl => target + restPart := + null rest sl => nil + "append"/[[",",:y] for y in rest sl] + sourcePart := + restPart => ['"(",:first sl,:restPart,'")"] + first sl + [:sourcePart,'" -> ",:target] + +dbOuttran form == + if LISTP form then + [op,:args] := form + else + op := form + args := nil + cosig := rest GETDATABASE(op,'COSIG) + atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) + argl := [fn for x in args for atype in atypes for pred in cosig] where fn == + pred => x + typ := sublisFormal(args,atype) + arg := + x is ['QUOTE,a] => a + x + res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) + NUMBERP res or STRINGP res => res + ['QUOTE,res] + [op,:argl] + +dbOpsForm form == +--one button for the operations of a type +--1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted +--2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|)) + ["\ops{",:conform2StringList(form,FUNCTION conname2StringList,_ + FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"] + +dbConform form == +--------------------> OBSELETE <-------------------------- +--one button for the main constructor page of a type +--NOTE: Next line should be as follows---but form2Fence form will +-- put, e.g. '((2 1 . 0) (0 1 . 0)) instead of x**2 + 1 + $saturn => ["\conf{",:form2StringList opOf form, + '"}{\lispLink{\verb!{(|conForm| '",:form2Fence dbOuttran form,'")!}}}"] + ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] +--["\conf{",:form2StringList opOf form,'"}{",:form2Fence opOf form,'"}"] + + +dbConformGen form == dbConformGen1(form,true) +--many buttons: one for the type and one for each inner type +--NOTE: must only be called on types KNOWN to be correct + +dbConformGenUnder form == dbConformGen1(form,false) +--same as above, except buttons only for the inner types + +dbConformGen1(form,opButton?) == + opFunction := + opButton? => FUNCTION dbConform + FUNCTION conname2StringList + originalOp := opOf form + op := unAbbreviateIfNecessary opOf form + args := IFCDR form + form := + originalOp=op => form + [op, :args] + args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil) + APPLY(opFunction,[form]) + +unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op + +conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form] + +--=========================================================================== +-- Data Gathering Code +--============================================================================ +dbGatherData(htPage,opAlist,which,key) == + key = 'implementation => dbGatherDataImplementation(htPage,opAlist) + dataFunction := LASSOC(key,table) where + table == + $dbDataFunctionAlist or + ($dbDataFunctionAlist := [ + ['signatures,:function dbMakeSignature], + ['parameters,:function dbContrivedForm], + ['origins,:function dbGetOrigin], + ['domains,:function dbGetOrigin], + ['conditions,:function dbGetCondition]]) + null dataFunction => + --key= names or filter or documentation; do not expand + if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then + opAlist := --to get indexing correct + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + acc := nil + initialExposure := + htPage and htpProperty(htPage,'conform) and which ^= '"package operation" + => true + --never star ops from a constructor + nil + for [op,:alist] in opAlist repeat + exposureFlag := initialExposure + while alist repeat + item := first alist + isExposed? := + STRINGP item => dbExposed?(item,char 'o) --unexpanded case + null (r := rest rest item) => true --assume true if unexpanded + r . 1 --expanded case + if isExposed? then return (exposureFlag := true) + alist := rest alist + node := + exposureFlag => op + [op,nil] + acc := [node,:acc] + NREVERSE acc + data := nil + dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in _ + '(origins documentation),false) + --create data, a list of the form ((entry,exposeFlag,:entries)...) + for [op,:alist] in opAlist repeat + for item in alist repeat + entry := FUNCALL(dataFunction,op,item)--get key item + exposeFlag := --is the current op-sig exposed? + null (r := rest rest item) => true --not given, assume yes + r . 1 --is given, use value + tail := + item is [.,'ASCONST,:.] => 'ASCONST + nil + newEntry := + u := ASSOC(entry,data) => --key seen before? look on DATA + RPLACA(CDR u,CADR u or exposeFlag)--yes, expose if any 1 is exposed + u + data := [y := [entry,exposeFlag,:tail],:data] + y --no, create new entry in DATA + if MEMBER(key,'(origins conditions)) then + r := CDDR newEntry + if atom r then r := nil --clear out possible 'ASCONST + RPLACD(CDR newEntry, --store op/sigs under key if needed + insert([dbMakeSignature(op,item),exposeFlag,:tail],r)) + if MEMBER(key,'(origins conditions)) then + for entry in data repeat --sort list of entries (after the 2nd) + tail := CDDR entry + tail := + atom tail => tail + listSort(function LEXLESSEQP,tail) + RPLACD(CDR entry,tail) + data := listSort(function LEXLESSEQP,data) + data + +dbGatherDataImplementation(htPage,opAlist) == +--returns data, of form ((implementor exposed? entry entry...)... +-- where entry has form ((op sig . implementor) . stuff) + conform := htpProperty(htPage,'conform) + domainForm := htpProperty(htPage,'domname) + dom := EVAL domainForm + which := '"operation" + [nam,:$domainArgs] := domainForm + $predicateList: local := GETDATABASE(nam,'PREDICATES) + predVector := dom.3 + u := getDomainOpTable(dom,true,ASSOCLEFT opAlist) + --u has form ((op,sig,:implementor)...) + --sort into 4 groups: domain exports, unexports, default exports, others + + for (x := [.,.,:key]) in u for i in 0.. repeat + key = domainForm => domexports := [x,:domexports] + INTEGERP key => unexports := [x,:unexports] + isDefaultPackageForm? key => defexports := [x,:defexports] + key = 'nowhere => nowheres := [x,:nowheres] + key = 'constant =>constants := [x,:constants] + others := [x,:others] --add chain domains go here + fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR, + NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where + fn l == + alist := nil + for u in l repeat + while u repeat + key := CDDAR u --implementor + entries := + [[CAR u,true],:[u and [CAR u,true] while key = CDDAR (u := rest u)]] + alist := [[key,gn key,:entries],:alist] + NREVERSE alist + gn key == + atom key => true + isExposedConstructor CAR key + +dbSelectData(htPage,opAlist,key) == + branch := htpProperty(htPage,'branch) + data := htpProperty(htPage,'data) + MEMQ(branch,'(signatures parameters)) => + dbReduceOpAlist(opAlist,data.key,branch) + MEMQ(branch,'(origins conditions implementation)) => + key < 8192 => dbReduceOpAlist(opAlist,data.key,branch) + [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large + innerData := CDDR data.(newkey - 1) + dbReduceOpAlist(opAlist,innerData.binkey,'signatures) + [opAlist . key] + +dbReduceOpAlist(opAlist,data,branch) == + branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data) + branch = 'origins => dbReduceBySelection(opAlist,CAR data,function CADDR) + branch = 'conditions => dbReduceBySelection(opAlist,CAR data,function CADR) + branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data) + branch = 'parameters => dbReduceByForm(opAlist,CAR data) + systemError ['"Unexpected branch: ",branch] + +dbReduceByOpSignature(opAlist,datalist) == +--reduces opAlist by implementation datalist, one of the form +-- (((op,sig,:implementor),:stuff),...) + ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.] + acc := nil + for [op,:alist] in opAlist | MEMQ(op,ops) repeat + entryList := [entry for (entry := [sig,:.]) in alist | test] where test == + or/[x for x in datalist | x is [[=op,=sig,:.],:.]] + entryList => acc := [[op,:NREVERSE entryList],:acc] + NREVERSE acc + +dbReduceBySignature(opAlist,op,sig) == +--reduces opAlist to one with a fixed op and sig + [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]] + +dbReduceByForm(opAlist,form) == + acc := nil + for [op,:alist] in opAlist repeat + items := [x for x in alist | dbContrivedForm(op,x) = form] => + acc := [[op,:items],:acc] + NREVERSE acc + +dbReduceBySelection(opAlist,key,fn) == + acc := nil + for [op,:alist] in opAlist repeat + items := [x for x in alist | FUNCALL(fn,x) = key] => + acc := [[op,:items],:acc] + NREVERSE acc + +dbContrivedForm(op,[sig,:.]) == + $which = '"attribute" => [op,sig] + dbMakeContrivedForm(op,sig) + +dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format + +dbGetOrigin(op,[.,.,origin,:.]) == origin + +dbGetCondition(op,[.,pred,:.]) == pred + +--dbInsertOpAlist(op,item,opAlist) == +-- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist) + +--dbSortOpAlist opAlist == +-- [[op,:listSort(function LEXLESSEQP,alist)] +-- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)] + +--============================================================================ +-- Branches of Views +--============================================================================ +dbShowOpNames(htPage,opAlist,which,data) == + single? := opAlist and null rest data + single? => + ops := escapeSpecialChars STRINGIMAGE CAAR opAlist + htSayStandard('"Select a view below") + htSaySaturn '"Select a view with the right mouse button" + exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage) + dbShowOpItems(which,data,exposedOnly?) + +dbShowOpItems(which,data,exposedOnly?) == + htBeginTable() + firstTime := true + for i in 0.. for item in data repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + if atom item then + op := item + exposeFlag := true + else + [op,exposeFlag] := item + ops := escapeSpecialChars STRINGIMAGE op + exposeFlag or not exposedOnly? => + htSay('"{") + bcStarSpaceOp(ops,exposeFlag) + htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]] + htSay('"}") + htEndTable() + +dbShowOpAllDomains(htPage,opAlist,which) == + dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) + catOriginAlist := nil --list of category origins + domOriginAlist := nil --list of domain origins + for [op,:items] in opAlist repeat + for [.,predicate,origin,:.] in items repeat + conname := CAR origin + GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => + pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true) + catOriginAlist := insertAlist(conname,pred,catOriginAlist) + pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true) + domOriginAlist := insertAlist(conname,pred,domOriginAlist) + --the following is similar to "domainsOf" but do not sort immediately + u := [COPY key for key in HKEYS _*HASCATEGORY_-HASH_* + | LASSQ(CDR key,catOriginAlist)] + for pair in u repeat + [dom,:cat] := pair + LASSQ(cat,catOriginAlist) = 'etc => RPLACD(pair,'etc) + RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true)) + --now add all of the domains + for [dom,:pred] in domOriginAlist repeat + u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u) + cAlist := listSort(function GLESSEQP,u) + for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair) + htpSetProperty(htPage,'cAlist,cAlist) + htpSetProperty(htPage,'thing,'"constructor") + htpSetProperty(htPage,'specialHeading,'"hoho") + dbShowCons(htPage,'names) + +simpOrDumb(new,old) == + new = 'etc => 'etc + atom new => old + 'etc + +dbShowOpOrigins(htPage,opAlist,which,data) == + dbGatherThenShow(htPage,opAlist,which,data,true,_ + '"from",function bcStarConform) + +dbShowOpImplementations(htPage,opAlist,which,data) == + dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform) + +dbShowOpConditions(htPage,opAlist,which,data) == + dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred) + +dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == +-----------------> OBSELETE + single? := null rest data + htSay('"\beginmenu ") + bincount := 0 + for [thing,exposeFlag,:items] in data repeat + htSay('"\item ") + if single? then htSay(menuButton()) + else htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] + htSay '"{\em " + htSay + thing = 'nowhere => '"implemented nowhere" + thing = 'constant => '"constant" + thing = '_$ => '"by the domain" + INTEGERP thing => '"unexported" + constructorIfTrue => + htSay word + atom thing => '" an unknown constructor" + '"" + atom thing => '"unconditional" + '"" + htSay '"}" + if null atom thing then + if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") + htSay '" " + FUNCALL(fn,thing) + htSay('":\newline ") + dbShowOpSigList(which,items,(1 + bincount) * 8192) + bincount := bincount + 1 + htSay '"\endmenu " + +dbShowKind conform == + conname := CAR conform + kind := GETDATABASE(conname,'CONSTRUCTORKIND) + kind = 'domain => + (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" + '"domain" + PNAME kind + +dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0) + +dbShowOpSigList(which,dataItems,count) == +--dataItems is (((op,sig,:.),exposureFlag,...) + single? := null rest dataItems + htBeginTable() + firstTime := true + for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat + if firstTime then firstTime := false + else htSaySaturn '"&"; + ops := escapeSpecialChars STRINGIMAGE op + htSay '"{" +-- if single? then htSay('"{\em ",ops,'"}") else..... + htSayExpose(ops,exposureFlag) + htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] + if which = '"attribute" then htSay args2HtString (sig and [sig]) else + htSay '": " + tail = 'ASCONST => bcConform first sig + bcConform ['Mapping,:sig] + htSay '"}" + count := count + 1 + htEndTable() + count + +dbShowOpParameters(htPage,opAlist,which,data) == + single? := null rest data + count := 0 + htBeginTable() + firstTime := true + for item in data repeat + if firstTime then firstTime := false + else htSaySaturn '"&" + [opform,exposeFlag,:tail] := item + op := intern IFCAR opform + args := IFCDR opform + ops := escapeSpecialChars STRINGIMAGE op + htSay '"{" + htSayExpose(ops,exposeFlag) + n := #opform + do + n = 2 and LASSOC('Nud,PROPLIST op) => + dbShowOpParameterJump(ops,which,count,single?) + htSay('" {\em ",KAR args,'"}") + n = 3 and LASSOC('Led,PROPLIST op) => + htSay('"{\em ",KAR args,'"} ") + dbShowOpParameterJump(ops,which,count,single?) + htSay('" {\em ",KAR KDR args,'"}") + dbShowOpParameterJump(ops,which,count,single?) + tail = 'ASCONST or MEMBER(op,'(0 1)) or _ + which = '"attribute" and null IFCAR args => 'skip + htSay('"(") + if IFCAR args then htSay('"{\em ",IFCAR args,'"}") + for x in IFCDR args repeat + htSay('",{\em ",x,'"}") + htSay('")") + htSay '"}" + count := count + 1 + htEndTable() + +dbShowOpParameterJump(ops,which,count,single?) == + single? => htSay('"{\em ",ops,'"}") + htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] + +dbShowOpDocumentation(htPage,opAlist,which,data) == + if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + --NOTE: this line is necessary to get indexing right. + --The test below for $exposedOnlyIfTrue causes unexposed items + --to be skipped. + newWhich := + conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) + which = '"package operation" => '"operation" + which + expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) + if expand then + condata := dbGatherData(htPage,opAlist,which,'conditions) + htpSetProperty(htPage,'conditionData,condata) + base := -8192 + exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp + htSaySaturn '"\begin{description}" + for [op,:alist] in opAlist repeat + base := 8192 + base + for item in alist for j in 0.. repeat + [sig,predicate,origin,exposeFlag,comments] := item + exposeFlag or not $exposedOnlyIfTrue => + if comments ^= '"" and STRINGP comments _ + and (k := string2Integer comments) then + comments := + MEMQ(k,'(0 1)) => '"" + dbReadComments k + tail := CDDDDR item + RPLACA(tail,comments) + doc := (STRINGP comments and comments ^= '"" => comments; nil) + pred := predicate or true + index := (exactlyOneOpSig => nil; base + j) + if which = '"package operation" then + sig := SUBST(conform,'_$,sig) + origin := SUBST(conform,'_$,origin) + displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,_ + index,'dbChooseDomainOp,null exposeFlag,true) + htSaySaturn '"\end{description}" + +dbChooseDomainOp(htPage,which,index) == + [opKey,entryKey] := DIVIDE(index,8192) + opAlist := + which = '"operation" => htpProperty(htPage,'opAlist) + htpProperty(htPage,'attrAlist) + [op,:entries] := opAlist . opKey + entry := entries . entryKey + htPage := htInitPageNoScroll(htCopyProplist htPage) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,[[op,entry]]) + else htpSetProperty(htPage,'attrAlist,[[op,entry]]) + if not htpProperty(htPage,'condition?) = 'no then + dbResetOpAlistCondition(htPage,which,opAlist) + dbShowOps(htPage,which,'documentation) + +htSayExpose(op,flag) == + $includeUnexposed? => + flag => htBlank() + op.0 = char '_* => htSay '"{\em *} " + htSayUnexposed() + htSay '"" +--============================================================================ +-- Branch-in From Other Places +--============================================================================ +dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists + $groupChoice := nil + conform := htpProperty(htPage,'conform) + --prepare opAlist for possible filtering of groups + if null BOUNDP '$topicHash then + $topicHash := MAKE_-HASHTABLE 'ID + for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat + HPUT($topicHash,x,c) + if domform := htpProperty(htPage,'domname) then + $conformsAreDomains : local := true + reduceOpAlistForDomain(opAlist,domform,conform) + conform := domform or conform + kind := capitalize htpProperty(htPage,'kind) + exposePart := + isExposedConstructor opOf conform => '"" + '" Unexposed " + fromPart := + domform => evalableConstructor2HtString domform + form2HtString conform + heading := + ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"] + expandProperty := + which = '"operation" => 'expandOperations + 'expandAttributes + htpSetProperty(htPage,expandProperty,'lists) + htpSetProperty(htPage,'fromHeading,heading) + reducedOpAlist := + which = '"operation" => reduceByGroup(htPage,opAlist) + opAlist + if which = '"operation" + then + htpSetProperty(htPage,'principalOpAlist,opAlist) + htpSetProperty(htPage,'opAlist,reducedOpAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + if domform + then htpSetProperty(htPage,'condition?,'no) + else dbResetOpAlistCondition(htPage,which,opAlist) + dbShowOp1(htPage,reducedOpAlist,which,'names) + +reduceOpAlistForDomain(opAlist,domform,conform) == +--destructively simplify all predicates; filter out any that fail + form1 := [domform,:rest domform] + form2 := ['$,:rest conform] + for pair in opAlist repeat + RPLACD(pair,[test for item in rest pair | test]) where test == + [head,:tail] := item + CAR tail = true => item + pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail) + null pred => false + RPLACD(item,[pred]) + item + opAlist + +dbShowOperationLines(which,linelist) == --branch in with lines + htPage := htInitPage(nil,nil) --create empty page + opAlist := nil + lines := linelist + while lines repeat + name := dbName (x := first lines) + pile := [x] + while (lines := rest lines) and name = dbName (x := first lines) repeat + pile := [x,:pile] + opAlist := [[name,:NREVERSE pile],:opAlist] + opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist) + if which = '"operation" + then htpSetProperty(htPage,'opAlist,opAlist) + else htpSetProperty(htPage,'attrAlist,opAlist) + expandProperty := + which = '"operation" => 'expandOperations + 'expandAttributes + htpSetProperty(htPage,expandProperty,'strings) + dbResetOpAlistCondition(htPage,which,opAlist) + if which = '"attribute" and BOUNDP '$attributeArgs and $attributeArgs then + --code needed to handle commutative("*"); called from aPage + --must completely expand the opAlist then check for those with + --arguments equal to $attributeArgs + --here: opAlist is [[op,:itemlist]] + dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false) + opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | _ + first item = $attributeArgs]]] + dbShowOp1(htPage,opAlist,which,'names) + +--============================================================================ +-- Code to Expand opAlist +--============================================================================ +dbResetOpAlistCondition(htPage,which,opAlist) == + value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) + htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) + value + +dbSetOpAlistCondition(htPage,opAlist,which) == +--called whenever a new opAlist is needed +--property can only be inherited if 'no (a subset says NO if whole says NO) + condition := htpProperty(htPage,'condition?) + MEMQ(condition,'(yes no)) => condition = 'yes + value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) + htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) + value + +dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) == +--if condition? = true, stop when you find a non-trivial predicate +--otherwise, expand in full +--RETURNS: +-- non-trivial predicate, if condition? = true and it finds one +-- nil, otherwise +--SIDE-EFFECT: this function references the "expand" property (set elsewhere): +-- 'strings, if not fully expanded and it contains strings +-- i.e. opAlist is ((op . (string ...))...) if unexpanded +-- 'lists, if not fully expanded and it contains lists +-- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded + condition? := condition? and not $exposedOnlyIfTrue + value := nil --return value + expandProperty := + which = '"operation" => 'expandOperations + 'expandAttributes + expandFlag := htpProperty(htPage,expandProperty) + expandFlag = 'fullyExpanded => nil + expandFlag = 'strings => --strings are partially expanded + for pair in opAlist repeat + [op,:lines] := pair + acc := nil + for line in lines repeat + --NOTE: we must expand all lines here for a given op + -- since below we will change opAlist + --Case 1: Already expanded; just cons it onto ACC + null STRINGP line => --already expanded + if condition? then --this could have been expanded at a lower level + if null atom (pred := CADR line) then value := pred + acc := [line,:acc] --this one is already expanded; record it anyway + --Case 2: unexpanded; expand it then cons it onto ACC + [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1) + predicate := ncParseFromString pred + if condition? and null atom predicate then value := predicate + sig := ncParseFromString sigs --is (Mapping,:.) + if which = '"operation" then + if sig isnt ['Mapping,:.] + then sayBrightly ['"Unexpected signature for ",name,'": ",sigs] + else sig := rest sig + conname := intern dbNewConname line + origin := [conname,:getConstructorArgs conname] + exposeFlag := dbExposed?(line,char 'o) + acc := [[sig,predicate,origin,exposeFlag,comments],:acc] + --always store the fruits of our labor: + RPLACD(pair,NREVERSE acc) --at least partially expand it + condition? and value => return value --early exit + value => value + condition? => nil + htpSetProperty(htPage,expandProperty,'fullyExpanded) + expandFlag = 'lists => --lists are partially expanded + -- entry is [sig, predicate, origin, exposeFlag, comments] + $value: local := nil + $docTableHash := MAKE_-HASHTABLE 'EQUAL + packageSymbol := false + domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) + if isDefaultPackageName opOf domform then + catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s) + packageSymbol := first rest domform + domform := [catname,:rest rest domform] --skip first argument ($) + docTable:= dbDocTable domform + for [op,:alist] in opAlist repeat + for [sig,:tail] in alist repeat + condition? => --the only purpose here is to find a non-trivial pred + null atom (pred := CAR tail) => return ($value := pred) + 'skip + u := + tail is [.,origin,:.] and origin => +-- must change any % into $ otherwise we will not pick up comments properly +-- delete the SUBLISLIS when we fix on % or $ + dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,_ + which,nil) + if packageSymbol then sig := SUBST('_$,packageSymbol,sig) + dbGetDocTable(op,sig,docTable,which,nil) + origin := IFCAR u or origin + docCode := IFCDR u --> (doc . code) +-- if null FIXP CDR docCode then harhar(op) --> + if null doc and which = '"attribute" then doc := getRegistry(op,sig) + RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode]) + $value => return $value + $value => $value + condition? => nil + htpSetProperty(htPage,expandProperty,'fullyExpanded) + 'done + +getRegistry(op,sig) == + u := GETDATABASE('AttributeRegistry,'DOCUMENTATION) + v := LASSOC(op,u) + match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match + '"" + +evalableConstructor2HtString domform == + if VECP domform then domform := devaluate domform + conname := first domform + coSig := rest GETDATABASE(conname,'COSIG) + --entries are T for args which are domains; NIL for computational objects + and/[x for x in coSig] => form2HtString(domform,nil,true) + arglist := [unquote x for x in rest domform] where + unquote arg == + arg is [f,:args] => + f = 'QUOTE => first args + [f,:[unquote x for x in args]] + arg + fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) +--argtypes:= sublisFormal(arglist,fargtypes) + form2HtString([conname,:[fn for arg in arglist for x in coSig + for ftype in fargtypes]],nil,true) where + fn == + x => arg + typ := sublisFormal(arglist,ftype) + mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) + +mathform2HtString form == escapeString + $fortInts2Floats: local := false + form := niladicHack form + form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a) + form is ['BRACKET,['AGGLST,:arg]] => + if arg is ['construct,:r] then arg := r + arg := + atom arg => [arg] + [y for x in arg | y := (x is ['QUOTE,a] => a; x)] + tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg] + STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]") + form is ['BRACKET,['AGGLST,'QUOTE,arg]] => + if atom arg then arg := [arg] + tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] + STRCONC('"[",first arg,tailPart,'"]") + atom form => form + "STRCONC"/fortexp0 form + +niladicHack form == + atom form => form + form is [x] and GET(x,'NILADIC) => x + [niladicHack x for x in form] + +--============================================================================ +-- Getting Operations from Domain +--============================================================================ + +getDomainOpTable(dom,fromIfTrue,:options) == + ops := KAR options + $predEvalAlist : local := nil + $returnNowhereFromGoGet: local := true + domname := dom.0 + conname := CAR domname + abb := getConstructorAbbreviation conname + opAlist := getOperationAlistFromLisplib conname + "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u + | key ^= 'Subsumed and ((null ops and (op1 := op)) _ + or (op1 := memq(op,ops)))] + for [op,:u] in opAlist] where + memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One + MEMQ(op,ops) => op + EQ(op,'One) => MEMQ(1,ops) and 1 + EQ(op,'Zero) => MEMQ(0,ops) and 0 + false + fn == + sig1 := sublisFormal(rest domname,sig) + predValue := evalDomainOpPred(dom,pred) + info := + null predValue => + 1 -- signifies not exported + null fromIfTrue => nil + cell := compiledLookup(op,sig1,dom) => + [f,:r] := cell + f = 'nowhere => 'nowhere --see replaceGoGetSlot + f = 'makeSpadConstant => 'constant + f = function IDENTITY => 'constant + f = 'newGoGet => SUBST('_$,domname,devaluate CAR r) + null VECP r => systemError devaluateList r + SUBST('_$,domname,devaluate r) + 'nowhere + [sig1,:info] + +evalDomainOpPred(dom,pred) == process(dom,pred) where + process(dom,pred) == + u := convert(dom,pred) + u = 'T => true + evpred(dom,u) + convert(dom,pred) == + pred is [op,:argl] => + MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]] + MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]] + MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)] + op = 'has => + [arg,p] := argl + p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a] + ['HasCategory,arg,convertCatArg p] + systemError '"unknown predicate form" + pred = 'T => true + systemError nil + convertCatArg p == + atom p or #p = 1 => MKQ p + ['LIST,MKQ first p,:[convertCatArg x for x in rest p]] + evpred(dom,pred) == + k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) + evpred1(dom,pred) + evpred1(dom,pred) == + pred is [op,:argl] => + MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl] + MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl] + op = 'NOT => not evpred1(dom,first argl) + k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) + op = 'HasAttribute => + [arg,[.,a]] := argl + attPredIndex := LASSOC(a,dom.2) + null attPredIndex => nil + attPredIndex = 0 => true + testBitVector(dom.3,attPredIndex) + nil + pred = 'T => true + systemError '"unknown atomic predicate form" + @ \eject diff --git a/src/interp/br-op1.boot.pamphlet b/src/interp/br-op1.boot.pamphlet deleted file mode 100644 index 89c2272..0000000 --- a/src/interp/br-op1.boot.pamphlet +++ /dev/null @@ -1,1187 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp br-op1.boot} -\author{The Axiom Team} -\maketitle -\begin{abstract} -\end{abstract} -\eject -\tableofcontents -\eject -\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. - -@ -<<*>>= -<> - ---====================> WAS b-op1.boot <================================ - ---======================================================================= --- Operation Page Menu ---======================================================================= ---opAlist has form [[op,:alist],:.] where each alist --- has form [sig,pred,origin,exposeFlag,comments] - -dbFromConstructor?(htPage) == htpProperty(htPage,'conform) - -dbPresentOps(htPage,which,:exclusions) == - true => dbPresentOpsSaturn(htPage,which,exclusions) ---Flags: --- fromConPage?: came (originally) from a constructor page --- usage?: display usage? --- star?: display exposed/*=unexposed --- implementation?: display implementation? - htSay('"{\em Views:}") - asharp? := htpProperty(htPage,'isAsharpConstructor) - fromConPage? := (conname := opOf htpProperty(htPage,'conform)) - usage? := $UserLevel = 'development and fromConPage? and which = '"operation" - and not (GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - and not asharp? - star? := not fromConPage? or which = '"package operation" - implementation? := not asharp? and - $UserLevel = 'development and $conformsAreDomains - --and not $includeUnexposed? - rightmost? := star? or (implementation? and not $includeUnexposed?) - tabs := - which = '"attribute" => '("12" "12" "25" "40" 13) - star? => '("12" "19" "31" "43" 10) - implementation? => '("9" "16" "28" "44" 9) - '("9" "16" "28" "41" 12) - if INTEGERP first exclusions then exclusions := ['documentation] - htpSetProperty(htPage,'exclusion,first exclusions) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - empty? := null opAlist - htTab - which = '"attribute" => tabs.1 - tabs.0 - if empty? or MEMBER('names,exclusions) or null KDR opAlist - then htSay '"{\em names}" - else htMakePage [['bcLispLinks,['"names",'"",'dbShowOps,which,'names]]] - if which ^= '"attribute" then - htTab tabs.1 - if empty? or MEMBER('signatures,exclusions) - then htSay '"{\em signatures}" - else htMakePage _ - [['bcLispLinks,['"signatures",'"",'dbShowOps,which,'signatures]]] - htTab tabs.2 - if empty? or MEMBER('parameters,exclusions) --also test for some parameter - or not dbDoesOneOpHaveParameters? opAlist - then htSay '"{\em parameters}" - else htMakePage _ - [['bcLispLinks,['"parameters",'"",'dbShowOps,which,'parameters]]] - htTab tabs.3 - if not empty? and null IFCDR opAlist and not htpProperty(htPage,'noUsage) - then - if htpProperty(htPage,'conform) - then htMakePage - [['bcLinks,['"generalise",'"",'dbShowOps,which,'generalise]]] - else htMakePage - [['bcLinks,['"all domains",'"",'dbShowOps,which,'allDomains]]] - else - if empty? or MEMQ('usage,exclusions) or _ - htpProperty(htPage,'noUsage) then htSay '"{\em filter}" else - htMakePage [['bcLinks,['"filter",'"",'dbShowOps,which,'filter]]] - htMakePage [['bcStrings, [tabs.4,'"",'filter,'EM]]] - htSay('"\newline ") - if star? - then - if $exposedOnlyIfTrue - then htMakePage - [['bcLinks,['"exposed",'" {\em only}",'dbShowOps,which,'exposureOff]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'dbShowOps,which,'exposureOn]]] --- else if (updown := dbCompositeWithMap htPage) --- then htMakePage [['bcLispLinks,[updown,'"",'dbShowUpDown,updown]]] - htTab tabs.0 - if usage? then - if empty? or MEMBER('usage,exclusions) _ - or GETDATABASE(conname,'CONSTRUCTORKIND) = 'category _ - or HGET($defaultPackageNamesHT,conname) _ - or htpProperty(htPage,'noUsage) - then htSay '"{\em usage}" - else htMakePage _ - [['bcLispLinks,['"usage",'"",'whoUsesOperation,which,nil]]] - htTab tabs.1 - if empty? or MEMBER('origins,exclusions) - then htSay '"{\em origins}" - else htMakePage [['bcLispLinks,['"origins",'"",'dbShowOps,which,'origins]]] - htTab tabs.2 - if implementation? then - if MEMBER('implementation,exclusions) or which = '"attribute" or - ((conname := opOf htpProperty(htPage,'conform)) _ - and GETDATABASE(conname,'CONSTRUCTORKIND) = 'category) - then htSay '"{\em implementation}" - else htMakePage _ - [['bcLispLinks,['"implementation",'"",'dbShowOps,which,'implementation]]] - else if empty? or MEMBER('conditions,exclusions) _ - or (htpProperty(htPage,'condition?) = 'no) - then htSay '"{\em conditions}" - else htMakePage _ - [['bcLispLinks,['"conditions",'"",'dbShowOps,which,'conditions]]] - htTab tabs.3 - if empty? or MEMBER('documentation,exclusions) - then htSay '"{\em description}" - else htMakePage _ - [['bcLispLinks,['"description",'"",'dbShowOps,which,'documentation]]] - htShowPageNoScroll() - -htTab s == htSay('"\tab{",s,'"}") - -dbDoesOneOpHaveParameters? opAlist == - or/[(or/[fn for x in items]) for [op,:items] in opAlist] where fn == - STRINGP x => dbPart(x,2,1) ^= '"0" - KAR x ---============================================================================ --- Master Switch Functions for Operation Views ---============================================================================ - -dbShowOps(htPage,which,key,:options) == - --NEXT LINE SHOULD BE REMOVED if we are sure that which is a string - which := STRINGIMAGE which - if MEMQ(key,'(extended basic all)) then - $groupChoice := key - key := htpProperty(htPage,'key) or 'names - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) --- al := reduceByGroup(htPage,htpProperty(htPage,'principalOpAlist)) --- htpSetProperty(htPage,'opAlist,al) --- al - htpProperty(htPage,'attrAlist) - key = 'generalise => - arg := STRINGIMAGE CAAR opAlist - which = '"attribute" => aPage arg - oPage arg - key = 'allDomains => dbShowOpAllDomains(htPage,opAlist,which) - key = 'filter => - --if $saturn, IFCAR options contains filter string - filter := IFCAR options or pmTransFilter(dbGetInputString htPage) - filter is ['error,:.] => bcErrorPage filter - opAlist:= _ - [x for x in opAlist | superMatch?(filter,DOWNCASE STRINGIMAGE opOf x)] - null opAlist => emptySearchPage(which,filter) - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOps(htPage,which,htpProperty(htPage,'exclusion)) - htpSetProperty(htPage,'key,key) - if MEMQ(key,'(exposureOn exposureOff)) then - $exposedOnlyIfTrue := - key = 'exposureOn => 'T - nil - key := htpProperty(htPage,'exclusion) - dbShowOp1(htPage,opAlist,which,key) - -reduceByGroup(htPage,opAlist) == - not dbFromConstructor?(htPage) or null $groupChoice => opAlist - dbExpandOpAlistIfNecessary(htPage,opAlist,'"operation",true,false) - bitNumber := HGET($topicHash,$groupChoice) - res := [[op,:newItems] for [op,:items] in opAlist | newItems] where - newItems == - null bitNumber => items - [x for x in items | FIXP (code := myLastAtom x) _ - and LOGBITP(bitNumber,code)] - res - - -dbShowOp1(htPage,opAlist,which,key) == - --set up for filtering below in dbGatherData - $which: local := which - if INTEGERP key then - opAlist := dbSelectData(htPage,opAlist,key) - ------> Jump out for constructor names in file <-------- - INTEGERP key and opAlist is [[con,:.]] and htpProperty(htPage,'isFile) - and constructor? con => return conPageChoose con - if INTEGERP key then - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - --opAlist is expanded to form - -- [[op,[sig,pred,origin,exposed,comments],...],...] - opAlist:=[item for [op,:items] in opAlist | item] where - item == - acc := nil - for x in items | x.3 repeat acc:= [x,:acc] - null acc => nil - [op,:NREVERSE acc] - $conformsAreDomains : local := htpProperty(htPage,'domname) - opCount := opAlistCount(opAlist, which) - branch := - INTEGERP key => - opCount <= $opDescriptionThreshold => 'documentation - 'names - key = 'names and null rest opAlist => --means a single op - opCount <= $opDescriptionThreshold => 'documentation - 'names - key - [what,whats,fn] := LASSOC(branch,$OpViewTable) - data := dbGatherData(htPage,opAlist,which,branch) - dataCount := +/[1 for x in data | (what = '"Name" and _ - $exposedOnlyIfTrue => atom x; true)] - namedPart := - null rest opAlist => - ops := escapeSpecialChars STRINGIMAGE CAAR opAlist - ['" {\em ",ops,'"}"] - nil - if what = '"Condition" and null KAR KAR data then dataCount := dataCount - 1 - exposurePart := - $exposedOnlyIfTrue => '(" Exposed ") - nil - firstPart := - opCount = 0 => ['"No ",:exposurePart, pluralize capitalize which] - dataCount = 1 or dataCount = opCount => - opCount = 1 => [:exposurePart, capitalize which,:namedPart] - [STRINGIMAGE opCount,'" ",:exposurePart, - pluralize capitalize which,:namedPart] - prefix := pluralSay(dataCount,what,whats) - [:prefix,'" for ",STRINGIMAGE opCount,'" ",_ - pluralize capitalize which,:namedPart] - page := htInitPageNoScroll(htCopyProplist htPage) - ------------>above line used to call htInitPageHoHeading<---------- - htAddHeading dbShowOpHeading([:firstPart,:fromHeading page], branch) - htpSetProperty(page,'data,data) - htpSetProperty(page,'branch,branch) - -- only place where specialMessage property is set seems to be commented. out - if u := htpProperty(page,'specialMessage) then APPLY(first u,rest u) - htSayStandard('"\beginscroll ") - FUNCALL(fn,page,opAlist,which,data) --apply branch function - dbOpsExposureMessage() - htSayStandard("\endscroll ") - dbPresentOps(page,which,branch) - htShowPageNoScroll() - -opAlistCount(opAlist, which) == +/[foo for [op,:items] in opAlist] where foo == - null $exposedOnlyIfTrue or which = '"attribute" => #items - --count if unexpanded---CDDR(w) = nil---or if w.3 = true - +/[1 for w in items | null (p := CDDR w) or p . 1] - -dbShowOpHeading(heading, branch) == - suffix := --- branch = 'signatures => '" viewed as signatures" - branch = 'parameters => '" viewed with parameters" - branch = 'origins => '" organized by origins" - branch = 'conditions => '" organized by conditions" - '"" - [:heading, suffix] - -dbOpsExposureMessage() == - $atLeastOneUnexposed => htSay '"{\em *} = unexposed" - -fromHeading htPage == - null htPage => '"" - $pn := [htPage.0,'"}{"] - updomain := htpProperty(htPage,'updomain) => - dnForm := dbExtractUnderlyingDomain updomain - dnString:= form2StringList dnForm - dnFence := form2Fence dnForm --- upString:= form2StringList updomain - upFence := form2Fence updomain - upOp := PNAME opOf updomain - ['" {\em from} ",:dbConformGen dnForm,'" {\em under} _ - \ops{",upOp,'"}{",:$pn,:upFence,'"}"] - domname := htpProperty(htPage,'domname) - numberOfUnderlyingDomains := #[x for x in rest _ - GETDATABASE(opOf domname,'COSIG) | x] --- numberOfUnderlyingDomains = 1 and --- KDR domname and (dn := dbExtractUnderlyingDomain domname) => --- ['" {\em from} ",:pickitForm(domname,dn)] - KDR domname => ['" {\em from} ",:dbConformGen domname] - htpProperty(htPage,'fromHeading) - -pickitForm(form,uarg) == - conform2StringList(form,FUNCTION dbConform,FUNCTION conformString,uarg) - -conformString(form) == - KDR form => - conform2StringList(form,FUNCTION conname2StringList,_ - FUNCTION conformString,nil) - form2StringList form - -conform2StringList(form,opFn,argFn,exception) == - exception := exception or '"%%%nothing%%%" - [op1,:args] := form - op := IFCAR HGET($lowerCaseConTb,op1) or op1 - null args => APPLY(opFn,[op]) - special := MEMQ(op,'(Union Record Mapping)) - cosig := - special => ['T for x in args] - rest GETDATABASE(op,'COSIG) - atypes := - special => cosig - rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == - keyword := - x is [":",y,t] => - x := t - y - nil - res := - x = exception => dbOpsForm exception - pred => - STRINGP x => [x] - u := APPLY(argFn,[x]) - atom u and [u] or u - typ := sublisFormal(args,atype) - if x is ['QUOTE,a] then x := a - u := mathform2HtString algCoerceInteractive(x,typ,'(OutputForm)) => [u] - NUMBERP x or STRINGP x => [x] - systemError() - keyword => [keyword,'": ",:res] - res - op = 'Mapping => dbMapping2StringList sargl - head := - special => [op] - APPLY(opFn,[form]) - [:head,'"(",:first sargl,:"append"/[[",",:y] for y in rest sargl],'")"] - - -dbMapping2StringList [target,:sl] == - null sl => target - restPart := - null rest sl => nil - "append"/[[",",:y] for y in rest sl] - sourcePart := - restPart => ['"(",:first sl,:restPart,'")"] - first sl - [:sourcePart,'" -> ",:target] - -dbOuttran form == - if LISTP form then - [op,:args] := form - else - op := form - args := nil - cosig := rest GETDATABASE(op,'COSIG) - atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - argl := [fn for x in args for atype in atypes for pred in cosig] where fn == - pred => x - typ := sublisFormal(args,atype) - arg := - x is ['QUOTE,a] => a - x - res := mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) - NUMBERP res or STRINGP res => res - ['QUOTE,res] - [op,:argl] - -dbOpsForm form == ---one button for the operations of a type ---1st arg: like "Matrix(Integer)" or "UP('x,Integer)" <---all highlighted ---2nd arg: like (|Matrix| (|Integer|)) and (|U..P..| (QUOTE |x|) (|Integer|)) - ["\ops{",:conform2StringList(form,FUNCTION conname2StringList,_ - FUNCTION conformString,nil),'"}{",:$pn,:form2Fence form,'"}"] - -dbConform form == ---------------------> OBSELETE <-------------------------- ---one button for the main constructor page of a type ---NOTE: Next line should be as follows---but form2Fence form will --- put, e.g. '((2 1 . 0) (0 1 . 0)) instead of x**2 + 1 - $saturn => ["\conf{",:form2StringList opOf form, - '"}{\lispLink{\verb!{(|conForm| '",:form2Fence dbOuttran form,'")!}}}"] - ["\conf{",:form2StringList opOf form,'"}{",:form2Fence dbOuttran form,'"}"] ---["\conf{",:form2StringList opOf form,'"}{",:form2Fence opOf form,'"}"] - - -dbConformGen form == dbConformGen1(form,true) ---many buttons: one for the type and one for each inner type ---NOTE: must only be called on types KNOWN to be correct - -dbConformGenUnder form == dbConformGen1(form,false) ---same as above, except buttons only for the inner types - -dbConformGen1(form,opButton?) == - opFunction := - opButton? => FUNCTION dbConform - FUNCTION conname2StringList - originalOp := opOf form - op := unAbbreviateIfNecessary opOf form - args := IFCDR form - form := - originalOp=op => form - [op, :args] - args => conform2StringList(form, opFunction,FUNCTION dbConformGen,nil) - APPLY(opFunction,[form]) - -unAbbreviateIfNecessary op == IFCAR HGET($lowerCaseConTb, op) or op - -conname2StringList form == [PNAME unAbbreviateIfNecessary opOf form] - ---=========================================================================== --- Data Gathering Code ---============================================================================ -dbGatherData(htPage,opAlist,which,key) == - key = 'implementation => dbGatherDataImplementation(htPage,opAlist) - dataFunction := LASSOC(key,table) where - table == - $dbDataFunctionAlist or - ($dbDataFunctionAlist := [ - ['signatures,:function dbMakeSignature], - ['parameters,:function dbContrivedForm], - ['origins,:function dbGetOrigin], - ['domains,:function dbGetOrigin], - ['conditions,:function dbGetCondition]]) - null dataFunction => - --key= names or filter or documentation; do not expand - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - opAlist := --to get indexing correct - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - acc := nil - initialExposure := - htPage and htpProperty(htPage,'conform) and which ^= '"package operation" - => true - --never star ops from a constructor - nil - for [op,:alist] in opAlist repeat - exposureFlag := initialExposure - while alist repeat - item := first alist - isExposed? := - STRINGP item => dbExposed?(item,char 'o) --unexpanded case - null (r := rest rest item) => true --assume true if unexpanded - r . 1 --expanded case - if isExposed? then return (exposureFlag := true) - alist := rest alist - node := - exposureFlag => op - [op,nil] - acc := [node,:acc] - NREVERSE acc - data := nil - dbExpandOpAlistIfNecessary(htPage,opAlist,which,key in _ - '(origins documentation),false) - --create data, a list of the form ((entry,exposeFlag,:entries)...) - for [op,:alist] in opAlist repeat - for item in alist repeat - entry := FUNCALL(dataFunction,op,item)--get key item - exposeFlag := --is the current op-sig exposed? - null (r := rest rest item) => true --not given, assume yes - r . 1 --is given, use value - tail := - item is [.,'ASCONST,:.] => 'ASCONST - nil - newEntry := - u := ASSOC(entry,data) => --key seen before? look on DATA - RPLACA(CDR u,CADR u or exposeFlag)--yes, expose if any 1 is exposed - u - data := [y := [entry,exposeFlag,:tail],:data] - y --no, create new entry in DATA - if MEMBER(key,'(origins conditions)) then - r := CDDR newEntry - if atom r then r := nil --clear out possible 'ASCONST - RPLACD(CDR newEntry, --store op/sigs under key if needed - insert([dbMakeSignature(op,item),exposeFlag,:tail],r)) - if MEMBER(key,'(origins conditions)) then - for entry in data repeat --sort list of entries (after the 2nd) - tail := CDDR entry - tail := - atom tail => tail - listSort(function LEXLESSEQP,tail) - RPLACD(CDR entry,tail) - data := listSort(function LEXLESSEQP,data) - data - -dbGatherDataImplementation(htPage,opAlist) == ---returns data, of form ((implementor exposed? entry entry...)... --- where entry has form ((op sig . implementor) . stuff) - conform := htpProperty(htPage,'conform) - domainForm := htpProperty(htPage,'domname) - dom := EVAL domainForm - which := '"operation" - [nam,:$domainArgs] := domainForm - $predicateList: local := GETDATABASE(nam,'PREDICATES) - predVector := dom.3 - u := getDomainOpTable(dom,true,ASSOCLEFT opAlist) - --u has form ((op,sig,:implementor)...) - --sort into 4 groups: domain exports, unexports, default exports, others - - for (x := [.,.,:key]) in u for i in 0.. repeat - key = domainForm => domexports := [x,:domexports] - INTEGERP key => unexports := [x,:unexports] - isDefaultPackageForm? key => defexports := [x,:defexports] - key = 'nowhere => nowheres := [x,:nowheres] - key = 'constant =>constants := [x,:constants] - others := [x,:others] --add chain domains go here - fn [nowheres,constants,domexports,SORTBY('CDDR,NREVERSE others),SORTBY('CDDR, - NREVERSE defexports),SORTBY('CDDR,NREVERSE unexports)] where - fn l == - alist := nil - for u in l repeat - while u repeat - key := CDDAR u --implementor - entries := - [[CAR u,true],:[u and [CAR u,true] while key = CDDAR (u := rest u)]] - alist := [[key,gn key,:entries],:alist] - NREVERSE alist - gn key == - atom key => true - isExposedConstructor CAR key - -dbSelectData(htPage,opAlist,key) == - branch := htpProperty(htPage,'branch) - data := htpProperty(htPage,'data) - MEMQ(branch,'(signatures parameters)) => - dbReduceOpAlist(opAlist,data.key,branch) - MEMQ(branch,'(origins conditions implementation)) => - key < 8192 => dbReduceOpAlist(opAlist,data.key,branch) - [newkey,binkey] := DIVIDE(key,8192) --newkey is 1 too large - innerData := CDDR data.(newkey - 1) - dbReduceOpAlist(opAlist,innerData.binkey,'signatures) - [opAlist . key] - -dbReduceOpAlist(opAlist,data,branch) == - branch = 'signatures => dbReduceBySignature(opAlist,CAAR data,CADAR data) - branch = 'origins => dbReduceBySelection(opAlist,CAR data,function CADDR) - branch = 'conditions => dbReduceBySelection(opAlist,CAR data,function CADR) - branch = 'implementation => dbReduceByOpSignature(opAlist,CDDR data) - branch = 'parameters => dbReduceByForm(opAlist,CAR data) - systemError ['"Unexpected branch: ",branch] - -dbReduceByOpSignature(opAlist,datalist) == ---reduces opAlist by implementation datalist, one of the form --- (((op,sig,:implementor),:stuff),...) - ops := [CAAR x for x in datalist] --x is [[op,sig,:implementor],:.] - acc := nil - for [op,:alist] in opAlist | MEMQ(op,ops) repeat - entryList := [entry for (entry := [sig,:.]) in alist | test] where test == - or/[x for x in datalist | x is [[=op,=sig,:.],:.]] - entryList => acc := [[op,:NREVERSE entryList],:acc] - NREVERSE acc - -dbReduceBySignature(opAlist,op,sig) == ---reduces opAlist to one with a fixed op and sig - [[op,:[x for x in LASSOC(op,opAlist) | x is [=sig,:.]]]] - -dbReduceByForm(opAlist,form) == - acc := nil - for [op,:alist] in opAlist repeat - items := [x for x in alist | dbContrivedForm(op,x) = form] => - acc := [[op,:items],:acc] - NREVERSE acc - -dbReduceBySelection(opAlist,key,fn) == - acc := nil - for [op,:alist] in opAlist repeat - items := [x for x in alist | FUNCALL(fn,x) = key] => - acc := [[op,:items],:acc] - NREVERSE acc - -dbContrivedForm(op,[sig,:.]) == - $which = '"attribute" => [op,sig] - dbMakeContrivedForm(op,sig) - -dbMakeSignature(op,[sig,:.]) == [op,sig] --getDomainOpTable format - -dbGetOrigin(op,[.,.,origin,:.]) == origin - -dbGetCondition(op,[.,pred,:.]) == pred - ---dbInsertOpAlist(op,item,opAlist) == --- insertAlist(op,[item,:LASSOC(op,opAlist)],opAlist) - ---dbSortOpAlist opAlist == --- [[op,:listSort(function LEXLESSEQP,alist)] --- for [op,:alist] in listSort(function LEXLESSEQP,opAlist)] - ---============================================================================ --- Branches of Views ---============================================================================ -dbShowOpNames(htPage,opAlist,which,data) == - single? := opAlist and null rest data - single? => - ops := escapeSpecialChars STRINGIMAGE CAAR opAlist - htSayStandard('"Select a view below") - htSaySaturn '"Select a view with the right mouse button" - exposedOnly? := $exposedOnlyIfTrue and not dbFromConstructor?(htPage) - dbShowOpItems(which,data,exposedOnly?) - -dbShowOpItems(which,data,exposedOnly?) == - htBeginTable() - firstTime := true - for i in 0.. for item in data repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - if atom item then - op := item - exposeFlag := true - else - [op,exposeFlag] := item - ops := escapeSpecialChars STRINGIMAGE op - exposeFlag or not exposedOnly? => - htSay('"{") - bcStarSpaceOp(ops,exposeFlag) - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,i]]] - htSay('"}") - htEndTable() - -dbShowOpAllDomains(htPage,opAlist,which) == - dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - catOriginAlist := nil --list of category origins - domOriginAlist := nil --list of domain origins - for [op,:items] in opAlist repeat - for [.,predicate,origin,:.] in items repeat - conname := CAR origin - GETDATABASE(conname,'CONSTRUCTORKIND) = 'category => - pred := simpOrDumb(predicate,LASSQ(conname,catOriginAlist) or true) - catOriginAlist := insertAlist(conname,pred,catOriginAlist) - pred := simpOrDumb(predicate,LASSQ(conname,domOriginAlist) or true) - domOriginAlist := insertAlist(conname,pred,domOriginAlist) - --the following is similar to "domainsOf" but do not sort immediately - u := [COPY key for key in HKEYS _*HASCATEGORY_-HASH_* - | LASSQ(CDR key,catOriginAlist)] - for pair in u repeat - [dom,:cat] := pair - LASSQ(cat,catOriginAlist) = 'etc => RPLACD(pair,'etc) - RPLACD(pair,simpOrDumb(GETDATABASE(pair,'HASCATEGORY),true)) - --now add all of the domains - for [dom,:pred] in domOriginAlist repeat - u := insertAlist(dom,simpOrDumb(pred,LASSQ(dom,u) or true),u) - cAlist := listSort(function GLESSEQP,u) - for pair in cAlist repeat RPLACA(pair,getConstructorForm first pair) - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,'"constructor") - htpSetProperty(htPage,'specialHeading,'"hoho") - dbShowCons(htPage,'names) - -simpOrDumb(new,old) == - new = 'etc => 'etc - atom new => old - 'etc - -dbShowOpOrigins(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,true,_ - '"from",function bcStarConform) - -dbShowOpImplementations(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,true,'"by",function bcStarConform) - -dbShowOpConditions(htPage,opAlist,which,data) == - dbGatherThenShow(htPage,opAlist,which,data,nil,nil,function bcPred) - -dbGatherThenShow(htPage,opAlist,which,data,constructorIfTrue,word,fn) == ------------------> OBSELETE - single? := null rest data - htSay('"\beginmenu ") - bincount := 0 - for [thing,exposeFlag,:items] in data repeat - htSay('"\item ") - if single? then htSay(menuButton()) - else htMakePage [['bcLinks,[menuButton(),'"",'dbShowOps,which,bincount]]] - htSay '"{\em " - htSay - thing = 'nowhere => '"implemented nowhere" - thing = 'constant => '"constant" - thing = '_$ => '"by the domain" - INTEGERP thing => '"unexported" - constructorIfTrue => - htSay word - atom thing => '" an unknown constructor" - '"" - atom thing => '"unconditional" - '"" - htSay '"}" - if null atom thing then - if constructorIfTrue then htSay('" {\em ",dbShowKind thing,'"}") - htSay '" " - FUNCALL(fn,thing) - htSay('":\newline ") - dbShowOpSigList(which,items,(1 + bincount) * 8192) - bincount := bincount + 1 - htSay '"\endmenu " - -dbShowKind conform == - conname := CAR conform - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - kind = 'domain => - (s := PNAME conname).(MAXINDEX s) = '_& => '"default package" - '"domain" - PNAME kind - -dbShowOpSignatures(htPage,opAlist,which,data) == dbShowOpSigList(which,data,0) - -dbShowOpSigList(which,dataItems,count) == ---dataItems is (((op,sig,:.),exposureFlag,...) - single? := null rest dataItems - htBeginTable() - firstTime := true - for [[op,sig,:.],exposureFlag,:tail] in dataItems repeat - if firstTime then firstTime := false - else htSaySaturn '"&"; - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" --- if single? then htSay('"{\em ",ops,'"}") else..... - htSayExpose(ops,exposureFlag) - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] - if which = '"attribute" then htSay args2HtString (sig and [sig]) else - htSay '": " - tail = 'ASCONST => bcConform first sig - bcConform ['Mapping,:sig] - htSay '"}" - count := count + 1 - htEndTable() - count - -dbShowOpParameters(htPage,opAlist,which,data) == - single? := null rest data - count := 0 - htBeginTable() - firstTime := true - for item in data repeat - if firstTime then firstTime := false - else htSaySaturn '"&" - [opform,exposeFlag,:tail] := item - op := intern IFCAR opform - args := IFCDR opform - ops := escapeSpecialChars STRINGIMAGE op - htSay '"{" - htSayExpose(ops,exposeFlag) - n := #opform - do - n = 2 and LASSOC('Nud,PROPLIST op) => - dbShowOpParameterJump(ops,which,count,single?) - htSay('" {\em ",KAR args,'"}") - n = 3 and LASSOC('Led,PROPLIST op) => - htSay('"{\em ",KAR args,'"} ") - dbShowOpParameterJump(ops,which,count,single?) - htSay('" {\em ",KAR KDR args,'"}") - dbShowOpParameterJump(ops,which,count,single?) - tail = 'ASCONST or MEMBER(op,'(0 1)) or _ - which = '"attribute" and null IFCAR args => 'skip - htSay('"(") - if IFCAR args then htSay('"{\em ",IFCAR args,'"}") - for x in IFCDR args repeat - htSay('",{\em ",x,'"}") - htSay('")") - htSay '"}" - count := count + 1 - htEndTable() - -dbShowOpParameterJump(ops,which,count,single?) == - single? => htSay('"{\em ",ops,'"}") - htMakePage [['bcLinks,[ops,'"",'dbShowOps,which,count]]] - -dbShowOpDocumentation(htPage,opAlist,which,data) == - if $exposedOnlyIfTrue and not dbFromConstructor?(htPage) then - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - --NOTE: this line is necessary to get indexing right. - --The test below for $exposedOnlyIfTrue causes unexposed items - --to be skipped. - newWhich := - conform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - which = '"package operation" => '"operation" - which - expand := dbExpandOpAlistIfNecessary(htPage,opAlist,which,true,false) - if expand then - condata := dbGatherData(htPage,opAlist,which,'conditions) - htpSetProperty(htPage,'conditionData,condata) - base := -8192 - exactlyOneOpSig := opAlist is [[.,.]] --checked by displayDomainOp - htSaySaturn '"\begin{description}" - for [op,:alist] in opAlist repeat - base := 8192 + base - for item in alist for j in 0.. repeat - [sig,predicate,origin,exposeFlag,comments] := item - exposeFlag or not $exposedOnlyIfTrue => - if comments ^= '"" and STRINGP comments _ - and (k := string2Integer comments) then - comments := - MEMQ(k,'(0 1)) => '"" - dbReadComments k - tail := CDDDDR item - RPLACA(tail,comments) - doc := (STRINGP comments and comments ^= '"" => comments; nil) - pred := predicate or true - index := (exactlyOneOpSig => nil; base + j) - if which = '"package operation" then - sig := SUBST(conform,'_$,sig) - origin := SUBST(conform,'_$,origin) - displayDomainOp(htPage,newWhich,origin,op,sig,pred,doc,_ - index,'dbChooseDomainOp,null exposeFlag,true) - htSaySaturn '"\end{description}" - -dbChooseDomainOp(htPage,which,index) == - [opKey,entryKey] := DIVIDE(index,8192) - opAlist := - which = '"operation" => htpProperty(htPage,'opAlist) - htpProperty(htPage,'attrAlist) - [op,:entries] := opAlist . opKey - entry := entries . entryKey - htPage := htInitPageNoScroll(htCopyProplist htPage) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,[[op,entry]]) - else htpSetProperty(htPage,'attrAlist,[[op,entry]]) - if not htpProperty(htPage,'condition?) = 'no then - dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOps(htPage,which,'documentation) - -htSayExpose(op,flag) == - $includeUnexposed? => - flag => htBlank() - op.0 = char '_* => htSay '"{\em *} " - htSayUnexposed() - htSay '"" ---============================================================================ --- Branch-in From Other Places ---============================================================================ -dbShowOperationsFromConform(htPage,which,opAlist) == --branch in with lists - $groupChoice := nil - conform := htpProperty(htPage,'conform) - --prepare opAlist for possible filtering of groups - if null BOUNDP '$topicHash then - $topicHash := MAKE_-HASHTABLE 'ID - for [x,:c] in '((extended . 0) (basic . 1) (hidden . 2)) repeat - HPUT($topicHash,x,c) - if domform := htpProperty(htPage,'domname) then - $conformsAreDomains : local := true - reduceOpAlistForDomain(opAlist,domform,conform) - conform := domform or conform - kind := capitalize htpProperty(htPage,'kind) - exposePart := - isExposedConstructor opOf conform => '"" - '" Unexposed " - fromPart := - domform => evalableConstructor2HtString domform - form2HtString conform - heading := - ['" from ",exposePart,kind,'" {\em ",fromPart,'"}"] - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'lists) - htpSetProperty(htPage,'fromHeading,heading) - reducedOpAlist := - which = '"operation" => reduceByGroup(htPage,opAlist) - opAlist - if which = '"operation" - then - htpSetProperty(htPage,'principalOpAlist,opAlist) - htpSetProperty(htPage,'opAlist,reducedOpAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - if domform - then htpSetProperty(htPage,'condition?,'no) - else dbResetOpAlistCondition(htPage,which,opAlist) - dbShowOp1(htPage,reducedOpAlist,which,'names) - -reduceOpAlistForDomain(opAlist,domform,conform) == ---destructively simplify all predicates; filter out any that fail - form1 := [domform,:rest domform] - form2 := ['$,:rest conform] - for pair in opAlist repeat - RPLACD(pair,[test for item in rest pair | test]) where test == - [head,:tail] := item - CAR tail = true => item - pred := simpHasPred SUBLISLIS(form1,form2,QCAR tail) - null pred => false - RPLACD(item,[pred]) - item - opAlist - -dbShowOperationLines(which,linelist) == --branch in with lines - htPage := htInitPage(nil,nil) --create empty page - opAlist := nil - lines := linelist - while lines repeat - name := dbName (x := first lines) - pile := [x] - while (lines := rest lines) and name = dbName (x := first lines) repeat - pile := [x,:pile] - opAlist := [[name,:NREVERSE pile],:opAlist] - opAlist := listSort(function LEXLESSEQP,NREVERSE opAlist) - if which = '"operation" - then htpSetProperty(htPage,'opAlist,opAlist) - else htpSetProperty(htPage,'attrAlist,opAlist) - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - htpSetProperty(htPage,expandProperty,'strings) - dbResetOpAlistCondition(htPage,which,opAlist) - if which = '"attribute" and BOUNDP '$attributeArgs and $attributeArgs then - --code needed to handle commutative("*"); called from aPage - --must completely expand the opAlist then check for those with - --arguments equal to $attributeArgs - --here: opAlist is [[op,:itemlist]] - dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,false) - opAlist := [[CAAR opAlist,:[item for item in CDAR opAlist | _ - first item = $attributeArgs]]] - dbShowOp1(htPage,opAlist,which,'names) - ---============================================================================ --- Code to Expand opAlist ---============================================================================ -dbResetOpAlistCondition(htPage,which,opAlist) == - value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) - htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) - value - -dbSetOpAlistCondition(htPage,opAlist,which) == ---called whenever a new opAlist is needed ---property can only be inherited if 'no (a subset says NO if whole says NO) - condition := htpProperty(htPage,'condition?) - MEMQ(condition,'(yes no)) => condition = 'yes - value := dbExpandOpAlistIfNecessary(htPage,opAlist,which,false,true) - htpSetProperty(htPage,'condition?,(value => 'yes; 'no)) - value - -dbExpandOpAlistIfNecessary(htPage,opAlist,which,needOrigins?,condition?) == ---if condition? = true, stop when you find a non-trivial predicate ---otherwise, expand in full ---RETURNS: --- non-trivial predicate, if condition? = true and it finds one --- nil, otherwise ---SIDE-EFFECT: this function references the "expand" property (set elsewhere): --- 'strings, if not fully expanded and it contains strings --- i.e. opAlist is ((op . (string ...))...) if unexpanded --- 'lists, if not fully expanded and it contains lists --- i.e. opAlist is ((op . ((sig pred) ...))...) if unexpanded - condition? := condition? and not $exposedOnlyIfTrue - value := nil --return value - expandProperty := - which = '"operation" => 'expandOperations - 'expandAttributes - expandFlag := htpProperty(htPage,expandProperty) - expandFlag = 'fullyExpanded => nil - expandFlag = 'strings => --strings are partially expanded - for pair in opAlist repeat - [op,:lines] := pair - acc := nil - for line in lines repeat - --NOTE: we must expand all lines here for a given op - -- since below we will change opAlist - --Case 1: Already expanded; just cons it onto ACC - null STRINGP line => --already expanded - if condition? then --this could have been expanded at a lower level - if null atom (pred := CADR line) then value := pred - acc := [line,:acc] --this one is already expanded; record it anyway - --Case 2: unexpanded; expand it then cons it onto ACC - [name,nargs,xflag,sigs,conname,pred,comments] := dbParts(line,7,1) - predicate := ncParseFromString pred - if condition? and null atom predicate then value := predicate - sig := ncParseFromString sigs --is (Mapping,:.) - if which = '"operation" then - if sig isnt ['Mapping,:.] - then sayBrightly ['"Unexpected signature for ",name,'": ",sigs] - else sig := rest sig - conname := intern dbNewConname line - origin := [conname,:getConstructorArgs conname] - exposeFlag := dbExposed?(line,char 'o) - acc := [[sig,predicate,origin,exposeFlag,comments],:acc] - --always store the fruits of our labor: - RPLACD(pair,NREVERSE acc) --at least partially expand it - condition? and value => return value --early exit - value => value - condition? => nil - htpSetProperty(htPage,expandProperty,'fullyExpanded) - expandFlag = 'lists => --lists are partially expanded - -- entry is [sig, predicate, origin, exposeFlag, comments] - $value: local := nil - $docTableHash := MAKE_-HASHTABLE 'EQUAL - packageSymbol := false - domform := htpProperty(htPage,'domname) or htpProperty(htPage,'conform) - if isDefaultPackageName opOf domform then - catname := intern SUBSTRING(s := PNAME opOf domform,0,MAXINDEX s) - packageSymbol := first rest domform - domform := [catname,:rest rest domform] --skip first argument ($) - docTable:= dbDocTable domform - for [op,:alist] in opAlist repeat - for [sig,:tail] in alist repeat - condition? => --the only purpose here is to find a non-trivial pred - null atom (pred := CAR tail) => return ($value := pred) - 'skip - u := - tail is [.,origin,:.] and origin => --- must change any % into $ otherwise we will not pick up comments properly --- delete the SUBLISLIS when we fix on % or $ - dbGetDocTable(op,SUBLISLIS(['$],['%],sig),dbDocTable origin,_ - which,nil) - if packageSymbol then sig := SUBST('_$,packageSymbol,sig) - dbGetDocTable(op,sig,docTable,which,nil) - origin := IFCAR u or origin - docCode := IFCDR u --> (doc . code) --- if null FIXP CDR docCode then harhar(op) --> - if null doc and which = '"attribute" then doc := getRegistry(op,sig) - RPLACD(tail,[origin,isExposedConstructor opOf origin,:docCode]) - $value => return $value - $value => $value - condition? => nil - htpSetProperty(htPage,expandProperty,'fullyExpanded) - 'done - -getRegistry(op,sig) == - u := GETDATABASE('AttributeRegistry,'DOCUMENTATION) - v := LASSOC(op,u) - match := or/[y for y in v | y is [['attribute,: =sig],:.]] => CADR match - '"" - -evalableConstructor2HtString domform == - if VECP domform then domform := devaluate domform - conname := first domform - coSig := rest GETDATABASE(conname,'COSIG) - --entries are T for args which are domains; NIL for computational objects - and/[x for x in coSig] => form2HtString(domform,nil,true) - arglist := [unquote x for x in rest domform] where - unquote arg == - arg is [f,:args] => - f = 'QUOTE => first args - [f,:[unquote x for x in args]] - arg - fargtypes:=CDDAR GETDATABASE(conname,'CONSTRUCTORMODEMAP) ---argtypes:= sublisFormal(arglist,fargtypes) - form2HtString([conname,:[fn for arg in arglist for x in coSig - for ftype in fargtypes]],nil,true) where - fn == - x => arg - typ := sublisFormal(arglist,ftype) - mathform2HtString algCoerceInteractive(arg,typ,'(OutputForm)) - -mathform2HtString form == escapeString - $fortInts2Floats: local := false - form := niladicHack form - form is ['QUOTE,a] => STRCONC('"'","STRCONC"/fortexp0 a) - form is ['BRACKET,['AGGLST,:arg]] => - if arg is ['construct,:r] then arg := r - arg := - atom arg => [arg] - [y for x in arg | y := (x is ['QUOTE,a] => a; x)] - tailPart := "STRCONC"/[STRCONC('",",STRINGIMAGE x) for x in rest arg] - STRCONC('"[",STRINGIMAGE first arg,tailPart,'"]") - form is ['BRACKET,['AGGLST,'QUOTE,arg]] => - if atom arg then arg := [arg] - tailPart := "STRCONC"/[STRCONC('",",x) for x in rest arg] - STRCONC('"[",first arg,tailPart,'"]") - atom form => form - "STRCONC"/fortexp0 form - -niladicHack form == - atom form => form - form is [x] and GET(x,'NILADIC) => x - [niladicHack x for x in form] - ---============================================================================ --- Getting Operations from Domain ---============================================================================ - -getDomainOpTable(dom,fromIfTrue,:options) == - ops := KAR options - $predEvalAlist : local := nil - $returnNowhereFromGoGet: local := true - domname := dom.0 - conname := CAR domname - abb := getConstructorAbbreviation conname - opAlist := getOperationAlistFromLisplib conname - "append"/[REMDUP [[op1,:fn] for [sig,slot,pred,key,:.] in u - | key ^= 'Subsumed and ((null ops and (op1 := op)) _ - or (op1 := memq(op,ops)))] - for [op,:u] in opAlist] where - memq(op,ops) == --dirty trick to get 0 and 1 instead of Zero and One - MEMQ(op,ops) => op - EQ(op,'One) => MEMQ(1,ops) and 1 - EQ(op,'Zero) => MEMQ(0,ops) and 0 - false - fn == - sig1 := sublisFormal(rest domname,sig) - predValue := evalDomainOpPred(dom,pred) - info := - null predValue => - 1 -- signifies not exported - null fromIfTrue => nil - cell := compiledLookup(op,sig1,dom) => - [f,:r] := cell - f = 'nowhere => 'nowhere --see replaceGoGetSlot - f = 'makeSpadConstant => 'constant - f = function IDENTITY => 'constant - f = 'newGoGet => SUBST('_$,domname,devaluate CAR r) - null VECP r => systemError devaluateList r - SUBST('_$,domname,devaluate r) - 'nowhere - [sig1,:info] - -evalDomainOpPred(dom,pred) == process(dom,pred) where - process(dom,pred) == - u := convert(dom,pred) - u = 'T => true - evpred(dom,u) - convert(dom,pred) == - pred is [op,:argl] => - MEMQ(op,'(AND and)) => ['AND,:[convert(dom,x) for x in argl]] - MEMQ(op,'(OR or)) => ['OR,:[convert(dom,x) for x in argl]] - MEMQ(op,'(NOT not)) => ['NOT,convert(dom,first argl)] - op = 'has => - [arg,p] := argl - p is ['ATTRIBUTE,a] => ['HasAttribute,arg,MKQ a] - ['HasCategory,arg,convertCatArg p] - systemError '"unknown predicate form" - pred = 'T => true - systemError nil - convertCatArg p == - atom p or #p = 1 => MKQ p - ['LIST,MKQ first p,:[convertCatArg x for x in rest p]] - evpred(dom,pred) == - k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) - evpred1(dom,pred) - evpred1(dom,pred) == - pred is [op,:argl] => - MEMQ(op,'(AND and)) => "and"/[evpred1(dom,x) for x in argl] - MEMQ(op,'(OR or)) => "or"/[evpred1(dom,x) for x in argl] - op = 'NOT => not evpred1(dom,first argl) - k := POSN1(pred,$predicateList) => testBitVector(dom.3,k + 1) - op = 'HasAttribute => - [arg,[.,a]] := argl - attPredIndex := LASSOC(a,dom.2) - null attPredIndex => nil - attPredIndex = 0 => true - testBitVector(dom.3,attPredIndex) - nil - pred = 'T => true - systemError '"unknown atomic predicate form" - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}