diff --git a/changelog b/changelog index b4309c4..557dd64 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,11 @@ +20090712 tpd src/axiom-website/patches.html 20090712.04.tpd.patch +20090712 tpd src/interp/Makefile remove br-search +20090712 tpd src/interp/br-con.boot merge br-search.boot +20090712 tpd src/interp/br-search.boot removed, merge with br-con +20090712 tpd src/axiom-website/patches.html 20090712.03.tpd.patch +20090712 tpd src/interp/Makefile remove br-op2 +20090712 tpd src/interp/br-con.boot merge br-op2.boot +20090712 tpd src/interp/br-op2.boot removed, merge with br-con 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 diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index ea1c38d..967d21d 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1713,5 +1713,9 @@ merge br-con and br-data
merge br-con and showimp
20090712.02.tpd.patch merge br-con and br-op1
+20090712.03.tpd.patch +merge br-con and br-op2
+20090712.04.tpd.patch +merge br-con and br-search
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 48cfa45..1145bcc 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-search.${O} ${AUTO}/br-util.${O} \ + ${AUTO}/br-util.${O} \ ${AUTO}/topics.${O} ${AUTO}/br-prof.${O} \ ${AUTO}/br-saturn.${O} @@ -430,7 +430,7 @@ DOCFILES=${DOC}/alql.boot.dvi \ ${DOC}/bits.lisp.dvi ${DOC}/bootfuns.lisp.dvi \ ${DOC}/br-con.boot.dvi \ ${DOC}/br-prof.boot.dvi \ - ${DOC}/br-saturn.boot.dvi ${DOC}/br-search.boot.dvi \ + ${DOC}/br-saturn.boot.dvi \ ${DOC}/br-util.boot.dvi ${DOC}/buildom.boot.dvi \ ${DOC}/category.boot.dvi ${DOC}/cattable.boot.dvi \ ${DOC}/c-doc.boot.dvi ${DOC}/cformat.boot.dvi \ @@ -5837,56 +5837,6 @@ ${DOC}/br-con.boot.dvi: ${IN}/br-con.boot.pamphlet @ -\subsection{br-search.boot} -<>= -${AUTO}/br-search.${O}: ${OUT}/br-search.${O} - @ echo 469 making ${AUTO}/br-search.${O} from ${OUT}/br-search.${O} - @ cp ${OUT}/br-search.${O} ${AUTO} - -@ -<>= -${OUT}/br-search.${O}: ${MID}/br-search.clisp - @ echo 470 making ${OUT}/br-search.${O} from ${MID}/br-search.clisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/br-search.clisp"' \ - ':output-file "${OUT}/br-search.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/br-search.clisp"' \ - ':output-file "${OUT}/br-search.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/br-search.clisp: ${IN}/br-search.boot.pamphlet - @ echo 471 making ${MID}/br-search.clisp \ - from ${IN}/br-search.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/br-search.boot.pamphlet >br-search.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "br-search.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "br-search.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm br-search.boot ) - -@ -<>= -${DOC}/br-search.boot.dvi: ${IN}/br-search.boot.pamphlet - @echo 472 making ${DOC}/br-search.boot.dvi \ - from ${IN}/br-search.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/br-search.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} br-search.boot ; \ - rm -f ${DOC}/br-search.boot.pamphlet ; \ - rm -f ${DOC}/br-search.boot.tex ; \ - rm -f ${DOC}/br-search.boot ) - -@ - \subsection{br-util.boot} <>= ${AUTO}/br-util.${O}: ${OUT}/br-util.${O} @@ -7627,11 +7577,6 @@ clean: <> <> -<> -<> -<> -<> - <> <> <> diff --git a/src/interp/br-con.boot.pamphlet b/src/interp/br-con.boot.pamphlet index 17aaa83..da2ca8e 100644 --- a/src/interp/br-con.boot.pamphlet +++ b/src/interp/br-con.boot.pamphlet @@ -4245,6 +4245,987 @@ pairlis(u,v) == [[first u,:first v],:pairlis(rest u, rest v)] +--====================> WAS b-search.boot <================================ + +--======================================================================= +-- Grepping Database libdb.text +-- Redone 12/95 for Saturn; previous function grep renamed as grepFile +-- This function now either returns a filename or a list of strings +--======================================================================= +grepConstruct(s,key,:options) == --key = a o c d p x k (all) . (aok) w (doc) +--Called from genSearch with key = "." and "w" +--key = "." means a o c d p x +--option1 = true means return the result as a file +--All searches of the database call this function to get relevant lines +--from libdb.text. Returns either a list of lines (usual case) or else +--an alist of the form ((kind . ) ...) + $localLibdb : local := fnameExists? '"libdb.text" and '"libdb.text" + lines := grepConstruct1(s,key) + IFCAR options => grepSplit(lines,key = 'w) --leave now if a constructor + MEMQ(key,'(o a)) => dbScreenForDefaultFunctions lines --kill default lines if a/o + lines + +grepConstruct1(s,key) == +--returns the name of file (WITHOUT .text.$SPADNUM on the end) + $key : local := key + if key = 'k and --convert 'k to 'y if name contains an "&" + or/[s . i = char '_& for i in 0..MAXINDEX s] then key := 'y + filter := pmTransFilter STRINGIMAGE s --parses and-or-not form + filter is ['error,:.] => filter --exit on parser error + pattern := mkGrepPattern(filter,key) --create string to pass to "grep" + grepConstructDo(pattern, key) --do the "grep"---see b-saturn.boot + +grepConstructDo(x, key) == + $orCount := 0 +--atom x => grepFile(x, key,'i) + $localLibdb => + oldLines := purgeNewConstructorLines(grepf(x,key,false),$newConstructorList) + newLines := grepf(x,$localLibdb,false) + UNION(oldLines, newLines) + grepf(x,key,false) + +dbExposed?(line,kind) == -- does line come from an unexposed constructor? + conname := INTERN + kind = char 'a or kind = char 'o => dbNewConname line --get conname from middle + dbName line + isExposedConstructor conname + +dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x] + +isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char 'x + +grepForAbbrev(s,key) == +--checks that filter s is not * and is all uppercase; if so, look for abbrevs + u := HGET($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first + s := STRINGIMAGE s + someLowerCaseChar := false + someUpperCaseChar := false + for i in 0..MAXINDEX s repeat + c := s . i + LOWER_-CASE_-P c => return (someLowerCaseChar := true) + UPPER_-CASE_-P c => someUpperCaseChar := true + someLowerCaseChar or not someUpperCaseChar => false + pattern := DOWNCASE s + ['Abbreviations ,:[GETDATABASE(x,'CONSTRUCTORFORM) + for x in allConstructors() | test]] where test == + not $includeUnexposed? and not isExposedConstructor x => false + a := GETDATABASE(x,'ABBREVIATION) + match?(pattern,PNAME a) and not HGET($defaultPackageNamesHT,x) + +applyGrep(x,filename) == --OBSELETE with $saturn--> see applyGrepSaturn + atom x => grepFile(x,filename,'i) + $localLibdb => + a := purgeNewConstructorLines(grepf(x,filename,false),$newConstructorList) + b := grepf(x,$localLibdb,false) + grepCombine(a,b) + grepf(x,filename,false) + +grepCombine(a,b) == MSORT UNION(a,b) + +grepf(pattern,s,not?) == --s=sourceFile or list of strings + pattern is [op,:argl] => + op = "and" => + while argl is [arg,:argl] repeat + s := grepf(arg,s,not?) -- filter by successive greps + s + op = "or" => + targetStack := nil + "UNION"/[grepf(arg,s,not?) for arg in argl] + op = "not" => + not? => grepf(first argl,s,false) + --could be the first time so have to get all of same $key + lines := grepf(mkGrepPattern('"*",$key),s,false) + grepf(first argl,lines,true) + systemError nil + option := + not? => 'iv + 'i + source := + LISTP s => dbWriteLines s + s + grepFile(pattern,source,option) + +pmTransFilter s == +--result is either a string or (op ..) where op= and,or,not and arg are results + if $browseMixedCase = true then s := DOWNCASE s + or/[isFilterDelimiter? s.i or s.i = $charUnderscore for i in 0..MAXINDEX s] + => (parse := pmParseFromString s) and checkPmParse parse or + ['error,'"Illegal search string",'"\vspace{3}\center{{\em Your search string} ",escapeSpecialChars s,'" {\em has incorrect syntax}}"] + or/[s . i = char '_* and s.(i + 1) = char '_* + and (i=0 or s . (i - 1) ^= char $charUnderscore) for i in 0..(MAXINDEX s - 1)] + => ['error,'"Illegal search string",'"\vspace{3}\center{Consecutive {\em *}'s are not allowed in search patterns}"] + s + +checkPmParse parse == + STRINGP parse => parse + fn parse => parse where fn(u) == + u is [op,:args] => + MEMQ(op,'(and or not)) and and/[checkPmParse x for x in args] + STRINGP u => true + false + nil + +dnForm x == + STRINGP x => x + x is ['not,argl] => + argl is ['or,:orargs]=> + ['and, :[dnForm negate u for u in orargs]] where negate s == + s is ['not,argx] => argx + ['not,s] + argl is ['and,:andargs]=> + ['or,:[dnForm negate u for u in andargs]] + argl is ['not,notargl]=> + dnForm notargl + x + x is ['or,:argl1] => ['or,:[dnForm u for u in argl1]] + x is ['and,:argl2] => ['and,:[dnForm u for u in argl2]] + x + +pmParseFromString s == + u := ncParseFromString pmPreparse s + dnForm flatten u where flatten s == + s is [op,:argl] => + STRINGP op => STRCONC(op,"STRCONC"/[STRCONC('" ",x) for x in argl]) + [op,:[flatten x for x in argl]] + s + +pmPreparse s == hn fn(s,0,#s) where--stupid insertion of chars to get correct parse + hn x == SUBLISLIS('(and or not),'("and" "or" "not"),x) + fn(s,n,siz) == --main function: s is string, n is origin + n = siz => '"" + i := firstNonDelim(s,n) or return SUBSTRING(s,n,nil) + j := firstDelim(s,i + 1) or siz + t := gn(s,i,j - 1) + middle := + MEMBER(t,'("and" "or" "not")) => t + --the following 2 lines make commutative("*") parse correctly!!!! + t.0 = char '_" => t + j < siz - 1 and s.j = char '_( => t + STRCONC(char '_",t,char '_") + STRCONC(SUBSTRING(s,n,i - n),middle,fn(s,j,siz)) + gn(s,i,j) == --replace each underscore by 4 underscores! + n := or/[k for k in i..j | s.k = $charUnderscore] => + STRCONC(SUBSTRING(s,i,n - i + 1),$charUnderscore,gn(s,n + 1,j)) + SUBSTRING(s,i,j - i + 1) + +firstNonDelim(s,n) == or/[k for k in n..MAXINDEX s | not isFilterDelimiter? s.k] +firstDelim(s,n) == or/[k for k in n..MAXINDEX s | isFilterDelimiter? s.k] + +isFilterDelimiter? c == MEMQ(c,$pmFilterDelimiters) + +grepSplit(lines,doc?) == + if doc? then + instream2 := OPEN STRCONC(getEnv '"AXIOM",'"/algebra/libdb.text") + cons := atts := doms := nil + while lines is [line, :lines] repeat + if doc? then + N:=PARSE_-INTEGER dbPart(line,1,-1) + if NUMBERP N then + FILE_-POSITION(instream2,N) + line := READLINE instream2 + kind := dbKind line + not $includeUnexposed? and not dbExposed?(line,kind) => 'skip + (kind = char 'a or kind = char 'o) and isDefaultOpAtt line => 'skip + PROGN + kind = char 'c => cats := insert(line,cats) + kind = char 'd => doms := insert(line,doms) + kind = char 'x => defs := insert(line,defs) + kind = char 'p => paks := insert(line,paks) + kind = char 'a => atts := insert(line,atts) + kind = char 'o => ops := insert(line,ops) + kind = char '_- => 'skip --for now + systemError 'kind + if doc? then CLOSE instream2 + [['"attribute",:NREVERSE atts], + ['"operation",:NREVERSE ops], + ['"category",:NREVERSE cats], + ['"domain",:NREVERSE doms], + ['"package",:NREVERSE paks] +-- ['"default_ package",:NREVERSE defs] -- drop defaults + ] + +mkUpDownPattern s == recurse(s,0,#s) where + recurse(s,i,n) == + i = n => '"" + STRCONC(fixchar(s.i),recurse(s,i + 1,n)) + fixchar(c) == + ALPHA_-CHAR_-P c => + STRCONC(char '_[,CHAR_-UPCASE c,CHAR_-DOWNCASE c,char '_]) + c + +mkGrepPattern(s,key) == + --called by grepConstruct1 and grepf + atom s => mkGrepPattern1(s,key) + [first s,:[mkGrepPattern(x,key) for x in rest s]] + +mkGrepPattern1(x,:options) == --called by mkGrepPattern (and grepConstructName?) + $options : local := options + s := STRINGIMAGE x +--s := DOWNCASE STRINGIMAGE x + addOptions remUnderscores addWilds split(g s,char '_*) where + addWilds sl == --add wild cards (sl is list of parts between *'s) + IFCAR sl = '"" => h(IFCDR sl,[$wild1]) + h(sl,nil) + g s == --remove "*"s around pattern for text match + not MEMQ('w,$options) => s + if s.0 = char '_* then s := SUBSTRING(s,1,nil) + if s.(k := MAXINDEX s) = char '_* then s := SUBSTRING(s,0,k) + s + h(sl,res) == --helper for wild cards + sl is [s,:r] => h(r,[$wild1,s,:res]) + res := rest res + if not MEMQ('w,$options) then + if first res ^= '"" then res := ['"`",:res] + else if res is [.,p,:r] and p = $wild1 then res := r + "STRCONC"/NREVERSE res + remUnderscores s == + (k := charPosition(char $charUnderscore,s,0)) < MAXINDEX s => + STRCONC(SUBSTRING(s,0,k),'"[",s.(k + 1),'"]", + remUnderscores(SUBSTRING(s,k + 2,nil))) + s + split(s,char) == + max := MAXINDEX s + 1 + f := -1 + [SUBSTRING(s,i,f-i) + while ((i := f + 1) <= max) and (f := charPosition(char,s,i))] + charPosition(c,t,startpos) == --honors underscores + n := SIZE t + if startpos < 0 or startpos > n then error "index out of range" + k:= startpos + for i in startpos .. n-1 while c ^= ELT(t,i) + or i > startpos and ELT(t,i-1) = '__ repeat (k := k+1) + k + addOptions s == --add front anchor + --options a o c d p x denote standard items + --options w means comments + --option t means text + --option s means signature + --option n means number of arguments + --option i means predicate + --option none means NO PREFIX + one := ($options is [x,:$options] and x => x; '"[^x]") + tick := '"[^`]*`" + one = 'w => s + one = 'none => (s = '"`" => '"^."; STRCONC('"^",s)) + prefix := + one = 't => STRCONC(tick,tick,tick,tick,tick,".*") + one = 'n => tick + one = 'i => STRCONC(tick,tick,tick,tick) + one = 's => STRCONC(tick,tick,tick) +-- true => '"" ----> never put on following prefixes + one = 'k => '"[cdp]" + one = 'y => '"[cdpx]" + STRINGIMAGE one + s = $wild1 => STRCONC('"^",prefix) + STRCONC('"^",prefix,s) + +conform2OutputForm(form) == + [op,:args] := form + null args => form + cosig := rest GETDATABASE(op,'COSIG) + atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) + sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == + pp [x,atype,pred] + pred => conform2OutputForm x + typ := sublisFormal(args,atype) + if x is ['QUOTE,a] then x := a + algCoerceInteractive(x,typ,'(OutputForm)) + [op,:sargl] + +oPage(a,:b) == --called by \spadfun{opname} + oSearch (IFCAR b or a) --always take slow path + +oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname} + htPage := htInitPage(nil,nil) --create empty page and fill in needed properties + htpSetProperty(htPage,'conform,conform := getConstructorForm conname) + htpSetProperty(htPage,'kind,STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)) + itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname" + null itemlist => systemError [conform,'" has no operation named ",opname] + opAlist := [itemlist] + dbShowOperationsFromConform(htPage,'"operation",opAlist) + +aPage(a,:b) == --called by \spadatt{a} + $attributeArgs : local := nil + arg := IFCAR b or a + s := pmParseFromString STRINGIMAGE arg + searchOn := + ATOM s => s + IFCAR s + $attributeArgs : local := IFCAR IFCDR s + aSearch searchOn +--must recognize that not all attributes can be found in database +--e.g. constant(deriv) is not but appears in a conditional in LODO + +spadType(x) == --called by \spadtype{x} from HyperDoc + s := PNAME x + form := ncParseFromString s or + systemError ['"Argument: ",s,'" to spadType won't parse"] + if atom form then form := [form] + op := opOf form + looksLikeDomainForm form => APPLY(function conPage,form) + conPage(op) + +looksLikeDomainForm x == + entry := getCDTEntry(opOf x,true) or return false + coSig := LASSOC('coSig,CDDR entry) + k := #coSig + atom x => k = 1 + k ^= #x => false + and/[p for key in rest coSig for arg in rest x] where + p == + key => looksLikeDomainForm arg + not IDENTP arg + +spadSys(x) == --called by \spadsyscom{x} + s := PNAME x + if s.0 = char '_) then s := SUBSTRING(s,1,nil) + form := ncParseFromString s or + systemError ['"Argument: ",s,'" to spadType won't parse"] + htSystemCommands PNAME opOf form + +--======================================================================= +-- Name and General Search +--======================================================================= +aokSearch filter == genSearch(filter,true) --"General" from HD (see man0.ht) +--General search for constructs but NOT documentation + +genSearch(filter,:options) == --"Complete" from HD (see man0.ht) and aokSearch +--General + documentation search + null (filter := checkFilter filter) => nil --in case of filter error + filter = '"*" => htErrorStar() + includeDoc? := not IFCAR options +--give summaries for how many a o c d p x match filter + regSearchAlist := grepConstruct(STRINGIMAGE filter,".",true) + regSearchAlist is ['error,:.] => bcErrorPage regSearchAlist + key := removeSurroundingStars filter + if includeDoc? then + docSearchAlist := grepConstruct(key,'w,true) + docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist + docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x]--drop defaults + genSearch1(filter,genSearchTran regSearchAlist,genSearchTran docSearchAlist) + +genSearchTran alist == [[x,y,:y] for [x,:y] in alist] + + +genSearch1(filter,reg,doc) == + regSearchAlist := searchDropUnexposedLines reg + docSearchAlist := searchDropUnexposedLines doc + key := removeSurroundingStars filter + regCount := searchCount regSearchAlist + docCount := searchCount docSearchAlist + count := regCount + docCount + count = 0 => emptySearchPage('"entry",filter,true) + count = 1 => + alist := (regCount = 1 => regSearchAlist; docSearchAlist) + showNamedConstruct(or/[x for x in alist | CADR x]) + summarize? := + docSearchAlist => true + nonEmpties := [pair for pair in regSearchAlist | #(CADR pair) > 0] + not(nonEmpties is [pair]) + not summarize? => showNamedConstruct pair + -----------generate a summary page--------------------------- + plural := + $exposedOnlyIfTrue => '"exposed entries match" + '"entries match" + prefix := pluralSay(count,'"", plural) + emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] + header := [:prefix,'" ",:emfilter] + page := htInitPage(header,nil) + htpSetProperty(page,'regSearchAlist,regSearchAlist) + htpSetProperty(page,'docSearchAlist,docSearchAlist) + htpSetProperty(page,'filter,filter) + if docSearchAlist then + dbSayItems(['"{\bf Construct Summary:} ",regCount],'"name matches",'"names match") + for [kind,:pair] in regSearchAlist for i in 0.. | #(first pair) > 0 repeat + bcHt '"\newline{}" + htSayStandard '"\tab{2}" + genSearchSay(pair,summarize?,kind,i,'showConstruct) + if docSearchAlist then + htSaySaturn '"\bigskip{}" + dbSayItems(['"\newline{\bf Documentation Summary:} ",docCount],'"mention",'"mentions",'" of {\em ",key,'"}") + for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat + bcHt "\newline{}" + htSayStandard '"\tab{2}" + genSearchSay(pair,true,kind,i,'showDoc) + htShowPageStar() +searchDropUnexposedLines alist == + [[op,[pred for line in lines | pred],:lines] for [op,.,:lines] in alist] where + pred == + not $exposedOnlyIfTrue or dbExposed?(line,dbKind line) => line + nil + +htShowPageStar() == +------------> OBSELETE + htSayStandard '"\endscroll " + if $exposedOnlyIfTrue then + htMakePage [['bcLinks,['"Exposed",'" {\em only}",'repeatSearch,NIL]]] + else + htSay('"*{\em =}") + htMakePage [['bcLinks,['"unexposed",'"",'repeatSearch,'T]]] + htShowPageNoScroll() + +repeatSearch(htPage,newValue) == + $exposedOnlyIfTrue := newValue + filter := htpProperty(htPage,'filter) + reg := htpProperty(htPage,'regSearchAlist) + doc := htpProperty(htPage,'docSearchAlist) + reg => genSearch1(filter,reg,doc) + docSearch1(filter,doc) + +searchCount u == +/[# y for [x,y,:.] in u] + +showDoc(htPage,count) == + showIt(htPage,count,htpProperty(htPage,'docSearchAlist)) + +showConstruct(htPage,count) == + showIt(htPage,count,htpProperty(htPage,'regSearchAlist)) + +showIt(htPage,index,searchAlist) == + filter := htpProperty(htPage,'filter) + [relativeIndex,n] := DIVIDE(index,8) + relativeIndex = 0 => showNamedConstruct(searchAlist.n) + [kind,items,:.] := searchAlist . n + for j in 1.. while j < relativeIndex repeat items := rest items + firstName := dbName first items --select name then gather all of same name + lines := [line for line in items while dbName line = firstName] + showNamedConstruct [kind,nil,:lines] + +showNamedConstruct([kind,.,:lines]) == dbSearch(lines,kind,'"") + +genSearchSay(pair,summarize,kind,who,fn) == + [u,:fullLineList] := pair + count := #u + uniqueCount := genSearchUniqueCount u + short := summarize and uniqueCount >= $browseCountThreshold + htMakePage + [['bcLinks,[menuButton(),'"",'genSearchSayJump,[fullLineList,kind]]]] + if count = 0 then htSay('"{\em No ",kind,'"} ") + else if count = 1 then + htSay('"{\em 1 ",kind,'"} ") + else + htSay('"{\em ",count,'" ",pluralize kind,'"} ") + short => 'done + if uniqueCount ^= 1 then + htSayStandard '"\indent{4}" + htSay '"\newline " + htBeginTable() + lastid := nil + groups := organizeByName u + i := 1 + for group in groups repeat + id := dbGetName first group + if $includeUnexposed? then + exposed? := or/[dbExposed?(item,dbKind item) for item in group] + bcHt '"{" + if $includeUnexposed? then + exposed? => htBlank() + htSayUnexposed() + htMakePage [['bcLinks, [id,'"",fn,who + 8*i]]] + i := i + #group + bcHt '"}" + if uniqueCount ^= 1 then + htEndTable() + htSayStandard '"\indent{0}" + +organizeByName u == + [[(u := rest u; x) while u and head = dbName (x := first u)] + while u and (head := dbName first u)] + +genSearchSayJump(htPage,[lines,kind]) == + filter := htpProperty(htPage,'filter) + dbSearch(lines,kind,filter) + +genSearchUniqueCount(u) == +--count the unique number of items (if less than $browseCountThreshold) + count := 0 + lastid := nil + for item in u while count < $browseCountThreshold repeat + id := dbGetName item + if id ^= lastid then + count := count + 1 + lastid := id + count + +dbGetName line == SUBSTRING(line,1,charPosition($tick,line,1) - 1) + +pluralSay(count,singular,plural,:options) == + item := (options is [x,:options] => x; '"") + colon := (IFCAR options => '":"; '"") + count = 0 => concat('"No ",singular,item) + count = 1 => concat('"1 ",singular,item,colon) + concat(count,'" ",plural,item,colon) + + +--======================================================================= +-- Documentation Search +--======================================================================= +docSearch filter == --"Documentation" from HD (see man0.ht) + null (filter := checkFilter filter) => nil --in case of filter error + filter = '"*" => htErrorStar() + key := removeSurroundingStars filter + docSearchAlist := grepConstruct(filter,'w,true) + docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist + docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x] --drop defaults + docSearch1(filter,genSearchTran docSearchAlist) + +docSearch1(filter,doc) == + docSearchAlist := searchDropUnexposedLines doc + count := searchCount docSearchAlist + count = 0 => emptySearchPage('"entry",filter,true) + count = 1 => showNamedConstruct(or/[x for x in docSearchAlist | CADR x],1) + prefix := pluralSay(count,'"entry matches",'"entries match") + emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] + header := [:prefix,'" ",:emfilter] + page := htInitPage(header,nil) + htpSetProperty(page,'docSearchAlist,docSearchAlist) + htpSetProperty(page,'regSearchAlist,nil) + htpSetProperty(page,'filter,filter) + dbSayItems(['"\newline Documentation Summary: ",count],'"mention",'"mentions",'" of {\em ",filter,'"}") + for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat + bcHt '"\newline{}" + htSayStandard '"\tab{2}" + genSearchSay(pair,true,kind,i,'showDoc) + htShowPageStar() + +removeSurroundingStars filter == + key := STRINGIMAGE filter + if key.0 = char '_* then key := SUBSTRING(key,1,nil) + if key.(max := MAXINDEX key) = char '_* then key := SUBSTRING(key,0,max) + key + +showNamedDoc([kind,:lines],index) == + dbGather(kind,lines,index - 1,true) + +sayDocMessage message == + htSay('"{\em ") + if message is [leftEnd,left,middle,right,rightEnd] then + htSay(leftEnd,left,'"}") + if left ^= '"" and left.(MAXINDEX left) = $blank then htBlank() + htSay middle + if right ^= '"" and right.0 = $blank then htBlank() + htSay('"{\em ",right,rightEnd) + else + htSay message + htSay ('"}") + +stripOffSegments(s,n) == + progress := true + while n > 0 and progress = true repeat + n := n - 1 + k := charPosition(char '_`,s,0) + new := SUBSTRING(s,k + 1,nil) + #new < #s => s := new + progress := false + n = 0 => s + nil + +replaceTicksBySpaces s == + n := -1 + max := MAXINDEX s + while (n := charPosition(char '_`,s,n + 1)) <= max repeat SETELT(s,n,char '_ ) + s + +checkFilter filter == + filter := STRINGIMAGE filter + filter = '"" => '"*" + trimString filter + +aSearch filter == --called from HD (man0.ht): general attribute search + null (filter := checkFilter filter) => nil --in case of filter error + dbSearch(grepConstruct(filter,'a),'"attribute",filter) + +oSearch filter == -- called from HD (man0.ht): operation search + opAlist := opPageFastPath filter => opPageFast opAlist + key := 'o + null (filter := checkFilter filter) => nil --in case of filter error + filter = '"*" => grepSearchQuery('"operation",[filter,key,'"operation",'oSearchGrep]) + oSearchGrep(filter,key,'"operation") + +oSearchGrep(filter,key,kind) == --called from grepSearchQuery/oSearch + dbSearch(grepConstruct(filter,'o),kind,filter) + +grepSearchQuery(kind,items) == + page := htInitPage('"Query Page",nil) + htpSetProperty(page,'items,items) + htQuery(['"{\em Do you want a list of {\em all} ",pluralize kind,'"?\vspace{1}}"],'grepSearchJump,true) + htShowPage() + +cSearch filter == --called from HD (man0.ht): category search + constructorSearch(checkFilter filter,'c,'"category") + +dSearch filter == --called from HD (man0.ht): domain search + constructorSearch(checkFilter filter,'d,'"domain") + +pSearch filter == --called from HD (man0.ht): package search + constructorSearch(checkFilter filter,'p,'"package") + +xSearch filter == --called from HD (man0.ht): default package search + constructorSearch(checkFilter filter,'x,'"default package") + +kSearch filter == --called from HD (man0.ht): constructor search (no defaults) + constructorSearch(checkFilter filter,'k,'"constructor") + +ySearch filter == --called from conPage: like kSearch but defaults included + constructorSearch(checkFilter filter,'y,'"constructor") + +constructorSearch(filter,key,kind) == + null filter => nil --in case of filter error + (parse := conSpecialString? filter) => conPage parse + pageName := LASSOC(DOWNCASE filter,'(("union" . DomainUnion)("record" . DomainRecord)("mapping" . DomainMapping) ("enumeration" . DomainEnumeration))) => + downlink pageName + name := (STRINGP filter => INTERN filter; filter) + if u := HGET($lowerCaseConTb,name) then filter := STRINGIMAGE first u + line := conPageFastPath DOWNCASE filter => + code := dbKind line + newkind := + code = char 'p => '"package" + code = char 'd => '"domain" + code = char 'c => '"category" + nil + kind = '"constructor" or kind = newkind => kPage line + page := htInitPage('"Query Page",nil) + htpSetProperty(page,'line,line) + message := + ['"{\em ",dbName line,'"} is not a {\em ",kind,'"} but a {\em ", + newkind,'"}. Would you like to view it?\vspace{1}"] + htQuery(message, 'grepConstructorSearch,true) + htShowPage() + filter = '"*" => grepSearchQuery(kind,[filter,key,kind,'constructorSearchGrep]) + constructorSearchGrep(filter,key,kind) + +grepConstructorSearch(htPage,yes) == kPage htpProperty(htPage,'line) + +conSpecialString?(filter,:options) == + secondTime := IFCAR options + parse := + words := string2Words filter is [s] => ncParseFromString s + and/[not MEMBER(x,'("and" "or" "not")) for x in words] => ncParseFromString filter + false + null parse => nil + form := conLowerCaseConTran parse + MEMQ(KAR form,'(and or not)) or CONTAINED("*",form) => nil + filter = '"Mapping" =>nil + u := kisValidType form => u + secondTime => false + u := "STRCONC"/[string2Constructor x for x in dbString2Words filter] + conSpecialString?(u, true) + +dbString2Words l == + i := 0 + [w while dbWordFrom(l,i) is [w,i]] + +$dbDelimiters := [char " " , char "(", char ")"] + +dbWordFrom(l,i) == + maxIndex := MAXINDEX l + while maxIndex >= i and l.i = char " " repeat i := i + 1 + if maxIndex >= i and MEMBER(l.i, $dbDelimiters) then return [l.i, i + 1] + k := or/[j for j in i..maxIndex | not MEMBER(l.j, $dbDelimiters)] or return nil + buf := '"" + while k <= maxIndex and not MEMBER(c := l.k, $dbDelimiters) repeat + ch := + c = char '__ => l.(k := 1+k) --this may exceed bounds + c + buf := STRCONC(buf,ch) + k := k + 1 + [buf,k] + +conLowerCaseConTran x == + IDENTP x => IFCAR HGET($lowerCaseConTb, x) or x + atom x => x + [conLowerCaseConTran y for y in x] + +string2Constructor x == + not STRINGP x => x + IFCAR HGET($lowerCaseConTb, INTERN DOWNCASE x) or x + +conLowerCaseConTranTryHarder x == + IDENTP x => IFCAR HGET($lowerCaseConTb,DOWNCASE x) or x + atom x => x + [conLowerCaseConTranTryHarder y for y in x] + +constructorSearchGrep(filter,key,kind) == + dbSearch(grepConstruct(filter,key),kind,filter) + +grepSearchJump(htPage,yes) == + [filter,key,kind,fn] := htpProperty(htPage,'items) + FUNCALL(fn,filter,key,kind) + +--======================================================================= +-- Branch Functions After Database Search +--======================================================================= +dbSearch(lines,kind,filter) == --called by attribute, operation, constructor search + lines is ['error,:.] => bcErrorPage lines + null filter => nil --means filter error + lines is ['Abbreviations,:r] => dbSearchAbbrev(lines,kind,filter) + if MEMBER(kind,'("attribute" "operation")) then --should not be necessary!! + lines := dbScreenForDefaultFunctions lines + count := #lines + count = 0 => emptySearchPage(kind,filter) + MEMBER(kind,'("attribute" "operation")) => dbShowOperationLines(kind,lines) + dbShowConstructorLines lines + +dbSearchAbbrev([.,:conlist],kind,filter) == + null conlist => emptySearchPage('"abbreviation",filter) + kind := intern kind + if kind ^= 'constructor then + conlist := [x for x in conlist | LASSOC('kind,IFCDR IFCDR x) = kind] + conlist is [[nam,:.]] => conPage DOWNCASE nam + cAlist := [[con,:true] for con in conlist] + htPage := htInitPage('"",nil) + htpSetProperty(htPage,'cAlist,cAlist) + htpSetProperty(htPage,'thing,nil) + return dbShowCons(htPage,'names) + page := htInitPage([#conlist, + '" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil) + for [nam,abbr,:r] in conlist repeat + kind := LASSOC('kind,r) + htSay('"\newline{\em ",s := STRINGIMAGE abbr) + htSayStandard '"\tab{10}" + htSay '"}" + htSay kind + htSayStandard '"\tab{19}" + bcCon nam + htShowPage() + +--======================================================================= +-- Selectable Search +--======================================================================= +detailedSearch(filter) == + page := htInitPage('"Detailed Search with Options",nil) + filter := escapeSpecialChars PNAME filter + bcHt '"Select what you want to search for, then click on {\em Search} below" + bcHt '"\newline{\it Note:} Logical searches using {\em and}, {\em or}, and {\em not} are not permitted here." + htSayHrule() + htMakePage '( + (text . "\newline") + (bcRadioButtons which + ( "\tab{3}{\em Operations}" + ((text . "\newline\space{3}") + (text . "name") (bcStrings (14 "*" opname EM)) + (text . " \#args") (bcStrings (1 "*" opnargs EM)) + (text . " signature") (bcStrings (14 "*" opsig EM)) + (text . "\vspace{1}\newline ")) + ops) + ( "\tab{3}{\em Attributes}" + ((text . "\newline\space{3}") + (text . "name") (bcStrings (14 "*" attrname EM)) + (text . " \#args ") (bcStrings (1 "*" attrnargs EM)) + (text . " arguments ")(bcStrings (14 "*" attrargs EM)) + (text . "\vspace{1}\newline ")) + attrs) + ( "\tab{3}{\em Constructors}" + ((text . "\tab{17}") + (bcButtons (1 cats)) (text . " {\em categories} ") + (bcButtons (1 doms)) (text . " {\em domains} ") + (bcButtons (1 paks)) (text . " {\em packages} ") + (bcButtons (1 defs)) (text . " {\em defaults} ") + (text . "\newline\tab{3}") + (text . "name") (bcStrings (14 "*" conname EM)) + (text . " \#args") (bcStrings (1 "*" connargs EM)) + (text . "signature") (bcStrings (14 "*" consig EM)) + (text . "\vspace{1}\newline ")) + cons) +-- ( "\tab{3}{\em Documentation}" +-- ((text . "\tab{26}key") +-- (bcStrings (28 "*" docfilter EM))) +-- doc) + ) + (text . "\vspace{1}\newline\center{ ") + (bcLinks ("\box{Search}" "" generalSearchDo NIL)) + (text . "}")) + htShowPage() + +generalSearchDo(htPage,flag) == +--$exposedOnlyIfTrue := (flag => 'T; nil) + $htPage := htPage + alist := htpInputAreaAlist htPage + which := htpButtonValue(htPage,'which) + selectors := + which = 'cons => '(conname connargs consig) + which = 'ops => '(opname opnargs opsig) + '(attrname attrnargs attrargs) + name := generalSearchString(htPage,selectors.0) + nargs:= generalSearchString(htPage,selectors.1) + npat := standardizeSignature generalSearchString(htPage,selectors.2) + kindCode := + which = 'ops => char 'o + which = 'attrs => char 'a + acc := '"" + if htButtonOn?(htPage,'cats) then acc := STRCONC(char 'c,acc) + if htButtonOn?(htPage,'doms) then acc := STRCONC(char 'd,acc) + if htButtonOn?(htPage,'paks) then acc := STRCONC(char 'p,acc) + if htButtonOn?(htPage,'defs) then acc := STRCONC(char 'x,acc) + n := #acc + n = 0 or n = 4 => '"[cdpx]" + n = 1 => acc + STRCONC(char '_[,acc,char '_]) + form := mkDetailedGrepPattern(kindCode,name,nargs,npat) + lines := applyGrep(form,'libdb) +--lines := dbReadLines resultFile + if MEMQ(which,'(ops attrs)) then lines := dbScreenForDefaultFunctions lines + kind := + which = 'cons => + n = 1 => + htButtonOn?(htPage,'cats) => '"category" + htButtonOn?(htPage,'doms) => '"domain" + htButtonOn?(htPage,'paks) => '"package" + '"default package" + '"constructor" + which = 'ops => '"operation" + '"attribute" + null lines => emptySearchPage(kind,nil) + dbSearch(lines,kind,'"filter") + +generalSearchString(htPage,sel) == + string := htpLabelInputString(htPage,sel) + string = '"" => '"*" + string + +htButtonOn?(htPage,key) == + LASSOC(key,htpInputAreaAlist htPage) is [a,:.] and a = '" t" + +mkDetailedGrepPattern(kind,name,nargs,argOrSig) == main where + main == + nottick := '"[^`]" + name := replaceGrepStar name + firstPart := + $saturn => STRCONC(char '_^,name) + STRCONC(char '_^,kind,name) + nargsPart := replaceGrepStar nargs + exposedPart := char '_. --always get exposed/unexposed + patPart := replaceGrepStar argOrSig + simp STRCONC(conc(firstPart,conc(nargsPart,conc(exposedPart, patPart))),$tick) + conc(a,b) == + b = '"[^`]*" or b = char '_. => a + STRCONC(a,$tick,b) + simp a == + m := MAXINDEX a + m > 6 and a.(m-5) = char '_[ and a.(m-4) = char '_^ + and a.(m-3) = $tick and a.(m-2) = char '_] + and a.(m-1) = char '_* and a.m = $tick + => simp SUBSTRING(a,0,m-5) + a + +replaceGrepStar s == + s = "" => s + final := MAXINDEX s + i := charPosition(char '_*,s,0) + i > final => s + STRCONC(SUBSTRING(s,0,i),'"[^`]*",replaceGrepStar SUBSTRING(s,i + 1,nil)) + +standardizeSignature(s) == underscoreDollars + s.0 = char '_( => s + k := STRPOS('"->",s,0,nil) or return s --will fail except perhaps on constants + s.(k - 1) = char '_) => STRCONC(char '_(,s) + STRCONC(char '_(,SUBSTRING(s,0,k),char '_),SUBSTRING(s,k,nil)) + +underscoreDollars(s) == fn(s,0,MAXINDEX s) where + fn(s,i,n) == + i > n => '"" + (m := charPosition(char '_$,s,i)) > n => SUBSTRING(s,i,nil) + STRCONC(SUBSTRING(s,i,m - i),'"___$",fn(s,m + 1,n)) + +--======================================================================= +-- Code dependent on $saturn +--======================================================================= + +obey x == + $saturn and not $aixTestSaturn => nil + OBEY x + +--======================================================================= +-- I/O Code +--======================================================================= + +getTempPath kind == + pathname := mkGrepFile kind + obey STRCONC('"rm -f ", pathname) + pathname + +dbWriteLines(s, :options) == + pathname := IFCAR options or getTempPath 'source + $outStream: local := MAKE_-OUTSTREAM pathname + for x in s repeat writedb x + SHUT $outStream + pathname + +dbReadLines target == --AIX only--called by grepFile + instream := OPEN target + lines := [READLINE instream while not EOFP instream] + CLOSE instream + lines + +dbGetCommentOrigin line == +--Given a comment line in comdb, returns line in libdb pointing to it +--Comment lines have format [dcpxoa]xxxxxx`ccccc... where +--x's give pointer into libdb, c's are comments + firstPart := dbPart(line,1,-1) + key := INTERN SUBSTRING(firstPart,0,1) --extract this and throw away + address := SUBSTRING(firstPart, 1, nil) --address in libdb + instream := OPEN grepSource key --this always returns libdb now + FILE_-POSITION(instream,PARSE_-INTEGER address) + line := READLINE instream + CLOSE instream + line + +grepSource key == + key = 'libdb => STRCONC($SPADROOT,'"/algebra/libdb.text") + key = 'gloss => STRCONC($SPADROOT,'"/algebra/glosskey.text") + key = $localLibdb => $localLibdb + mkGrepTextfile + MEMQ(key, '(_. a c d k o p x)) => 'libdb + 'comdb + +mkGrepTextfile s == STRCONC($SPADROOT,"/algebra/", STRINGIMAGE s, '".text") + +mkGrepFile s == --called to generate a path name for a temporary grep file + prefix := + $standard or $aixTestSaturn => '"/tmp/" + STRCONC($SPADROOT,'"/algebra/") + suffix := getEnv '"SPADNUM" + STRCONC(prefix, PNAME s,'".txt.", suffix) + +--======================================================================= +-- Grepping Code +--======================================================================= + +grepFile(pattern,:options) == + key := (x := IFCAR options => (options := rest options; x); nil) + source := grepSource key + lines := + not PROBE_-FILE source => NIL + $standard or $aixTestSaturn => + -----AIX Version---------- + target := getTempPath 'target + casepart := + MEMQ('iv,options)=> '"-vi" + '"-i" + command := STRCONC('"grep ",casepart,'" _'",pattern,'"_' ",source) + obey + MEMBER(key,'(a o c d p x)) => + STRCONC(command, '" | sed 's/~/", STRINGIMAGE key, '"/' > ", target) + STRCONC(command, '" > ",target) + dbReadLines target + ----Windows Version------ + invert? := MEMQ('iv, options) + GREP(source, pattern, false, not invert?) + dbUnpatchLines lines + +dbUnpatchLines lines == --concatenate long lines together, skip blank lines + dash := char '_- + acc := nil + while lines is [line, :lines] repeat + #line = 0 => 'skip --skip blank lines + acc := + line.0 = dash and line.1 = dash => + [STRCONC(first acc,SUBSTRING(line,2,nil)),:rest acc] + [line,:acc] + -- following call to NREVERSE needed to keep lines properly sorted + NREVERSE acc ------> added by BMT 12/95 + + + @ \eject diff --git a/src/interp/br-search.boot.pamphlet b/src/interp/br-search.boot.pamphlet deleted file mode 100644 index 6ffbb4b..0000000 --- a/src/interp/br-search.boot.pamphlet +++ /dev/null @@ -1,1036 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp br-search.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-search.boot <================================ - ---======================================================================= --- Grepping Database libdb.text --- Redone 12/95 for Saturn; previous function grep renamed as grepFile --- This function now either returns a filename or a list of strings ---======================================================================= -grepConstruct(s,key,:options) == --key = a o c d p x k (all) . (aok) w (doc) ---Called from genSearch with key = "." and "w" ---key = "." means a o c d p x ---option1 = true means return the result as a file ---All searches of the database call this function to get relevant lines ---from libdb.text. Returns either a list of lines (usual case) or else ---an alist of the form ((kind . ) ...) - $localLibdb : local := fnameExists? '"libdb.text" and '"libdb.text" - lines := grepConstruct1(s,key) - IFCAR options => grepSplit(lines,key = 'w) --leave now if a constructor - MEMQ(key,'(o a)) => dbScreenForDefaultFunctions lines --kill default lines if a/o - lines - -grepConstruct1(s,key) == ---returns the name of file (WITHOUT .text.$SPADNUM on the end) - $key : local := key - if key = 'k and --convert 'k to 'y if name contains an "&" - or/[s . i = char '_& for i in 0..MAXINDEX s] then key := 'y - filter := pmTransFilter STRINGIMAGE s --parses and-or-not form - filter is ['error,:.] => filter --exit on parser error - pattern := mkGrepPattern(filter,key) --create string to pass to "grep" - grepConstructDo(pattern, key) --do the "grep"---see b-saturn.boot - -grepConstructDo(x, key) == - $orCount := 0 ---atom x => grepFile(x, key,'i) - $localLibdb => - oldLines := purgeNewConstructorLines(grepf(x,key,false),$newConstructorList) - newLines := grepf(x,$localLibdb,false) - UNION(oldLines, newLines) - grepf(x,key,false) - -dbExposed?(line,kind) == -- does line come from an unexposed constructor? - conname := INTERN - kind = char 'a or kind = char 'o => dbNewConname line --get conname from middle - dbName line - isExposedConstructor conname - -dbScreenForDefaultFunctions lines == [x for x in lines | not isDefaultOpAtt x] - -isDefaultOpAtt x == x.(1 + dbTickIndex(x,4,0)) = char 'x - -grepForAbbrev(s,key) == ---checks that filter s is not * and is all uppercase; if so, look for abbrevs - u := HGET($lowerCaseConTb,s) => ['Abbreviations,u] --try cheap test first - s := STRINGIMAGE s - someLowerCaseChar := false - someUpperCaseChar := false - for i in 0..MAXINDEX s repeat - c := s . i - LOWER_-CASE_-P c => return (someLowerCaseChar := true) - UPPER_-CASE_-P c => someUpperCaseChar := true - someLowerCaseChar or not someUpperCaseChar => false - pattern := DOWNCASE s - ['Abbreviations ,:[GETDATABASE(x,'CONSTRUCTORFORM) - for x in allConstructors() | test]] where test == - not $includeUnexposed? and not isExposedConstructor x => false - a := GETDATABASE(x,'ABBREVIATION) - match?(pattern,PNAME a) and not HGET($defaultPackageNamesHT,x) - -applyGrep(x,filename) == --OBSELETE with $saturn--> see applyGrepSaturn - atom x => grepFile(x,filename,'i) - $localLibdb => - a := purgeNewConstructorLines(grepf(x,filename,false),$newConstructorList) - b := grepf(x,$localLibdb,false) - grepCombine(a,b) - grepf(x,filename,false) - -grepCombine(a,b) == MSORT UNION(a,b) - -grepf(pattern,s,not?) == --s=sourceFile or list of strings - pattern is [op,:argl] => - op = "and" => - while argl is [arg,:argl] repeat - s := grepf(arg,s,not?) -- filter by successive greps - s - op = "or" => - targetStack := nil - "UNION"/[grepf(arg,s,not?) for arg in argl] - op = "not" => - not? => grepf(first argl,s,false) - --could be the first time so have to get all of same $key - lines := grepf(mkGrepPattern('"*",$key),s,false) - grepf(first argl,lines,true) - systemError nil - option := - not? => 'iv - 'i - source := - LISTP s => dbWriteLines s - s - grepFile(pattern,source,option) - -pmTransFilter s == ---result is either a string or (op ..) where op= and,or,not and arg are results - if $browseMixedCase = true then s := DOWNCASE s - or/[isFilterDelimiter? s.i or s.i = $charUnderscore for i in 0..MAXINDEX s] - => (parse := pmParseFromString s) and checkPmParse parse or - ['error,'"Illegal search string",'"\vspace{3}\center{{\em Your search string} ",escapeSpecialChars s,'" {\em has incorrect syntax}}"] - or/[s . i = char '_* and s.(i + 1) = char '_* - and (i=0 or s . (i - 1) ^= char $charUnderscore) for i in 0..(MAXINDEX s - 1)] - => ['error,'"Illegal search string",'"\vspace{3}\center{Consecutive {\em *}'s are not allowed in search patterns}"] - s - -checkPmParse parse == - STRINGP parse => parse - fn parse => parse where fn(u) == - u is [op,:args] => - MEMQ(op,'(and or not)) and and/[checkPmParse x for x in args] - STRINGP u => true - false - nil - -dnForm x == - STRINGP x => x - x is ['not,argl] => - argl is ['or,:orargs]=> - ['and, :[dnForm negate u for u in orargs]] where negate s == - s is ['not,argx] => argx - ['not,s] - argl is ['and,:andargs]=> - ['or,:[dnForm negate u for u in andargs]] - argl is ['not,notargl]=> - dnForm notargl - x - x is ['or,:argl1] => ['or,:[dnForm u for u in argl1]] - x is ['and,:argl2] => ['and,:[dnForm u for u in argl2]] - x - -pmParseFromString s == - u := ncParseFromString pmPreparse s - dnForm flatten u where flatten s == - s is [op,:argl] => - STRINGP op => STRCONC(op,"STRCONC"/[STRCONC('" ",x) for x in argl]) - [op,:[flatten x for x in argl]] - s - -pmPreparse s == hn fn(s,0,#s) where--stupid insertion of chars to get correct parse - hn x == SUBLISLIS('(and or not),'("and" "or" "not"),x) - fn(s,n,siz) == --main function: s is string, n is origin - n = siz => '"" - i := firstNonDelim(s,n) or return SUBSTRING(s,n,nil) - j := firstDelim(s,i + 1) or siz - t := gn(s,i,j - 1) - middle := - MEMBER(t,'("and" "or" "not")) => t - --the following 2 lines make commutative("*") parse correctly!!!! - t.0 = char '_" => t - j < siz - 1 and s.j = char '_( => t - STRCONC(char '_",t,char '_") - STRCONC(SUBSTRING(s,n,i - n),middle,fn(s,j,siz)) - gn(s,i,j) == --replace each underscore by 4 underscores! - n := or/[k for k in i..j | s.k = $charUnderscore] => - STRCONC(SUBSTRING(s,i,n - i + 1),$charUnderscore,gn(s,n + 1,j)) - SUBSTRING(s,i,j - i + 1) - -firstNonDelim(s,n) == or/[k for k in n..MAXINDEX s | not isFilterDelimiter? s.k] -firstDelim(s,n) == or/[k for k in n..MAXINDEX s | isFilterDelimiter? s.k] - -isFilterDelimiter? c == MEMQ(c,$pmFilterDelimiters) - -grepSplit(lines,doc?) == - if doc? then - instream2 := OPEN STRCONC(getEnv '"AXIOM",'"/algebra/libdb.text") - cons := atts := doms := nil - while lines is [line, :lines] repeat - if doc? then - N:=PARSE_-INTEGER dbPart(line,1,-1) - if NUMBERP N then - FILE_-POSITION(instream2,N) - line := READLINE instream2 - kind := dbKind line - not $includeUnexposed? and not dbExposed?(line,kind) => 'skip - (kind = char 'a or kind = char 'o) and isDefaultOpAtt line => 'skip - PROGN - kind = char 'c => cats := insert(line,cats) - kind = char 'd => doms := insert(line,doms) - kind = char 'x => defs := insert(line,defs) - kind = char 'p => paks := insert(line,paks) - kind = char 'a => atts := insert(line,atts) - kind = char 'o => ops := insert(line,ops) - kind = char '_- => 'skip --for now - systemError 'kind - if doc? then CLOSE instream2 - [['"attribute",:NREVERSE atts], - ['"operation",:NREVERSE ops], - ['"category",:NREVERSE cats], - ['"domain",:NREVERSE doms], - ['"package",:NREVERSE paks] --- ['"default_ package",:NREVERSE defs] -- drop defaults - ] - -mkUpDownPattern s == recurse(s,0,#s) where - recurse(s,i,n) == - i = n => '"" - STRCONC(fixchar(s.i),recurse(s,i + 1,n)) - fixchar(c) == - ALPHA_-CHAR_-P c => - STRCONC(char '_[,CHAR_-UPCASE c,CHAR_-DOWNCASE c,char '_]) - c - -mkGrepPattern(s,key) == - --called by grepConstruct1 and grepf - atom s => mkGrepPattern1(s,key) - [first s,:[mkGrepPattern(x,key) for x in rest s]] - -mkGrepPattern1(x,:options) == --called by mkGrepPattern (and grepConstructName?) - $options : local := options - s := STRINGIMAGE x ---s := DOWNCASE STRINGIMAGE x - addOptions remUnderscores addWilds split(g s,char '_*) where - addWilds sl == --add wild cards (sl is list of parts between *'s) - IFCAR sl = '"" => h(IFCDR sl,[$wild1]) - h(sl,nil) - g s == --remove "*"s around pattern for text match - not MEMQ('w,$options) => s - if s.0 = char '_* then s := SUBSTRING(s,1,nil) - if s.(k := MAXINDEX s) = char '_* then s := SUBSTRING(s,0,k) - s - h(sl,res) == --helper for wild cards - sl is [s,:r] => h(r,[$wild1,s,:res]) - res := rest res - if not MEMQ('w,$options) then - if first res ^= '"" then res := ['"`",:res] - else if res is [.,p,:r] and p = $wild1 then res := r - "STRCONC"/NREVERSE res - remUnderscores s == - (k := charPosition(char $charUnderscore,s,0)) < MAXINDEX s => - STRCONC(SUBSTRING(s,0,k),'"[",s.(k + 1),'"]", - remUnderscores(SUBSTRING(s,k + 2,nil))) - s - split(s,char) == - max := MAXINDEX s + 1 - f := -1 - [SUBSTRING(s,i,f-i) - while ((i := f + 1) <= max) and (f := charPosition(char,s,i))] - charPosition(c,t,startpos) == --honors underscores - n := SIZE t - if startpos < 0 or startpos > n then error "index out of range" - k:= startpos - for i in startpos .. n-1 while c ^= ELT(t,i) - or i > startpos and ELT(t,i-1) = '__ repeat (k := k+1) - k - addOptions s == --add front anchor - --options a o c d p x denote standard items - --options w means comments - --option t means text - --option s means signature - --option n means number of arguments - --option i means predicate - --option none means NO PREFIX - one := ($options is [x,:$options] and x => x; '"[^x]") - tick := '"[^`]*`" - one = 'w => s - one = 'none => (s = '"`" => '"^."; STRCONC('"^",s)) - prefix := - one = 't => STRCONC(tick,tick,tick,tick,tick,".*") - one = 'n => tick - one = 'i => STRCONC(tick,tick,tick,tick) - one = 's => STRCONC(tick,tick,tick) --- true => '"" ----> never put on following prefixes - one = 'k => '"[cdp]" - one = 'y => '"[cdpx]" - STRINGIMAGE one - s = $wild1 => STRCONC('"^",prefix) - STRCONC('"^",prefix,s) - -conform2OutputForm(form) == - [op,:args] := form - null args => form - cosig := rest GETDATABASE(op,'COSIG) - atypes := rest CDAR GETDATABASE(op,'CONSTRUCTORMODEMAP) - sargl := [fn for x in args for atype in atypes for pred in cosig] where fn == - pp [x,atype,pred] - pred => conform2OutputForm x - typ := sublisFormal(args,atype) - if x is ['QUOTE,a] then x := a - algCoerceInteractive(x,typ,'(OutputForm)) - [op,:sargl] - -oPage(a,:b) == --called by \spadfun{opname} - oSearch (IFCAR b or a) --always take slow path - -oPageFrom(opname,conname) == --called by \spadfunFrom{opname}{conname} - htPage := htInitPage(nil,nil) --create empty page and fill in needed properties - htpSetProperty(htPage,'conform,conform := getConstructorForm conname) - htpSetProperty(htPage,'kind,STRINGIMAGE GETDATABASE(conname,'CONSTRUCTORKIND)) - itemlist := ASSOC(opname,koOps(conform,nil)) --all operations name "opname" - null itemlist => systemError [conform,'" has no operation named ",opname] - opAlist := [itemlist] - dbShowOperationsFromConform(htPage,'"operation",opAlist) - -aPage(a,:b) == --called by \spadatt{a} - $attributeArgs : local := nil - arg := IFCAR b or a - s := pmParseFromString STRINGIMAGE arg - searchOn := - ATOM s => s - IFCAR s - $attributeArgs : local := IFCAR IFCDR s - aSearch searchOn ---must recognize that not all attributes can be found in database ---e.g. constant(deriv) is not but appears in a conditional in LODO - -spadType(x) == --called by \spadtype{x} from HyperDoc - s := PNAME x - form := ncParseFromString s or - systemError ['"Argument: ",s,'" to spadType won't parse"] - if atom form then form := [form] - op := opOf form - looksLikeDomainForm form => APPLY(function conPage,form) - conPage(op) - -looksLikeDomainForm x == - entry := getCDTEntry(opOf x,true) or return false - coSig := LASSOC('coSig,CDDR entry) - k := #coSig - atom x => k = 1 - k ^= #x => false - and/[p for key in rest coSig for arg in rest x] where - p == - key => looksLikeDomainForm arg - not IDENTP arg - -spadSys(x) == --called by \spadsyscom{x} - s := PNAME x - if s.0 = char '_) then s := SUBSTRING(s,1,nil) - form := ncParseFromString s or - systemError ['"Argument: ",s,'" to spadType won't parse"] - htSystemCommands PNAME opOf form - ---======================================================================= --- Name and General Search ---======================================================================= -aokSearch filter == genSearch(filter,true) --"General" from HD (see man0.ht) ---General search for constructs but NOT documentation - -genSearch(filter,:options) == --"Complete" from HD (see man0.ht) and aokSearch ---General + documentation search - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => htErrorStar() - includeDoc? := not IFCAR options ---give summaries for how many a o c d p x match filter - regSearchAlist := grepConstruct(STRINGIMAGE filter,".",true) - regSearchAlist is ['error,:.] => bcErrorPage regSearchAlist - key := removeSurroundingStars filter - if includeDoc? then - docSearchAlist := grepConstruct(key,'w,true) - docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist - docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x]--drop defaults - genSearch1(filter,genSearchTran regSearchAlist,genSearchTran docSearchAlist) - -genSearchTran alist == [[x,y,:y] for [x,:y] in alist] - - -genSearch1(filter,reg,doc) == - regSearchAlist := searchDropUnexposedLines reg - docSearchAlist := searchDropUnexposedLines doc - key := removeSurroundingStars filter - regCount := searchCount regSearchAlist - docCount := searchCount docSearchAlist - count := regCount + docCount - count = 0 => emptySearchPage('"entry",filter,true) - count = 1 => - alist := (regCount = 1 => regSearchAlist; docSearchAlist) - showNamedConstruct(or/[x for x in alist | CADR x]) - summarize? := - docSearchAlist => true - nonEmpties := [pair for pair in regSearchAlist | #(CADR pair) > 0] - not(nonEmpties is [pair]) - not summarize? => showNamedConstruct pair - -----------generate a summary page--------------------------- - plural := - $exposedOnlyIfTrue => '"exposed entries match" - '"entries match" - prefix := pluralSay(count,'"", plural) - emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] - header := [:prefix,'" ",:emfilter] - page := htInitPage(header,nil) - htpSetProperty(page,'regSearchAlist,regSearchAlist) - htpSetProperty(page,'docSearchAlist,docSearchAlist) - htpSetProperty(page,'filter,filter) - if docSearchAlist then - dbSayItems(['"{\bf Construct Summary:} ",regCount],'"name matches",'"names match") - for [kind,:pair] in regSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt '"\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,summarize?,kind,i,'showConstruct) - if docSearchAlist then - htSaySaturn '"\bigskip{}" - dbSayItems(['"\newline{\bf Documentation Summary:} ",docCount],'"mention",'"mentions",'" of {\em ",key,'"}") - for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt "\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,true,kind,i,'showDoc) - htShowPageStar() -searchDropUnexposedLines alist == - [[op,[pred for line in lines | pred],:lines] for [op,.,:lines] in alist] where - pred == - not $exposedOnlyIfTrue or dbExposed?(line,dbKind line) => line - nil - -htShowPageStar() == -------------> OBSELETE - htSayStandard '"\endscroll " - if $exposedOnlyIfTrue then - htMakePage [['bcLinks,['"Exposed",'" {\em only}",'repeatSearch,NIL]]] - else - htSay('"*{\em =}") - htMakePage [['bcLinks,['"unexposed",'"",'repeatSearch,'T]]] - htShowPageNoScroll() - -repeatSearch(htPage,newValue) == - $exposedOnlyIfTrue := newValue - filter := htpProperty(htPage,'filter) - reg := htpProperty(htPage,'regSearchAlist) - doc := htpProperty(htPage,'docSearchAlist) - reg => genSearch1(filter,reg,doc) - docSearch1(filter,doc) - -searchCount u == +/[# y for [x,y,:.] in u] - -showDoc(htPage,count) == - showIt(htPage,count,htpProperty(htPage,'docSearchAlist)) - -showConstruct(htPage,count) == - showIt(htPage,count,htpProperty(htPage,'regSearchAlist)) - -showIt(htPage,index,searchAlist) == - filter := htpProperty(htPage,'filter) - [relativeIndex,n] := DIVIDE(index,8) - relativeIndex = 0 => showNamedConstruct(searchAlist.n) - [kind,items,:.] := searchAlist . n - for j in 1.. while j < relativeIndex repeat items := rest items - firstName := dbName first items --select name then gather all of same name - lines := [line for line in items while dbName line = firstName] - showNamedConstruct [kind,nil,:lines] - -showNamedConstruct([kind,.,:lines]) == dbSearch(lines,kind,'"") - -genSearchSay(pair,summarize,kind,who,fn) == - [u,:fullLineList] := pair - count := #u - uniqueCount := genSearchUniqueCount u - short := summarize and uniqueCount >= $browseCountThreshold - htMakePage - [['bcLinks,[menuButton(),'"",'genSearchSayJump,[fullLineList,kind]]]] - if count = 0 then htSay('"{\em No ",kind,'"} ") - else if count = 1 then - htSay('"{\em 1 ",kind,'"} ") - else - htSay('"{\em ",count,'" ",pluralize kind,'"} ") - short => 'done - if uniqueCount ^= 1 then - htSayStandard '"\indent{4}" - htSay '"\newline " - htBeginTable() - lastid := nil - groups := organizeByName u - i := 1 - for group in groups repeat - id := dbGetName first group - if $includeUnexposed? then - exposed? := or/[dbExposed?(item,dbKind item) for item in group] - bcHt '"{" - if $includeUnexposed? then - exposed? => htBlank() - htSayUnexposed() - htMakePage [['bcLinks, [id,'"",fn,who + 8*i]]] - i := i + #group - bcHt '"}" - if uniqueCount ^= 1 then - htEndTable() - htSayStandard '"\indent{0}" - -organizeByName u == - [[(u := rest u; x) while u and head = dbName (x := first u)] - while u and (head := dbName first u)] - -genSearchSayJump(htPage,[lines,kind]) == - filter := htpProperty(htPage,'filter) - dbSearch(lines,kind,filter) - -genSearchUniqueCount(u) == ---count the unique number of items (if less than $browseCountThreshold) - count := 0 - lastid := nil - for item in u while count < $browseCountThreshold repeat - id := dbGetName item - if id ^= lastid then - count := count + 1 - lastid := id - count - -dbGetName line == SUBSTRING(line,1,charPosition($tick,line,1) - 1) - -pluralSay(count,singular,plural,:options) == - item := (options is [x,:options] => x; '"") - colon := (IFCAR options => '":"; '"") - count = 0 => concat('"No ",singular,item) - count = 1 => concat('"1 ",singular,item,colon) - concat(count,'" ",plural,item,colon) - - ---======================================================================= --- Documentation Search ---======================================================================= -docSearch filter == --"Documentation" from HD (see man0.ht) - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => htErrorStar() - key := removeSurroundingStars filter - docSearchAlist := grepConstruct(filter,'w,true) - docSearchAlist is ['error,:.] => bcErrorPage docSearchAlist - docSearchAlist := [x for x in docSearchAlist | x.0 ^= char 'x] --drop defaults - docSearch1(filter,genSearchTran docSearchAlist) - -docSearch1(filter,doc) == - docSearchAlist := searchDropUnexposedLines doc - count := searchCount docSearchAlist - count = 0 => emptySearchPage('"entry",filter,true) - count = 1 => showNamedConstruct(or/[x for x in docSearchAlist | CADR x],1) - prefix := pluralSay(count,'"entry matches",'"entries match") - emfilter := ['"{\em ",escapeSpecialChars STRINGIMAGE filter,'"}"] - header := [:prefix,'" ",:emfilter] - page := htInitPage(header,nil) - htpSetProperty(page,'docSearchAlist,docSearchAlist) - htpSetProperty(page,'regSearchAlist,nil) - htpSetProperty(page,'filter,filter) - dbSayItems(['"\newline Documentation Summary: ",count],'"mention",'"mentions",'" of {\em ",filter,'"}") - for [kind,:pair] in docSearchAlist for i in 0.. | #(first pair) > 0 repeat - bcHt '"\newline{}" - htSayStandard '"\tab{2}" - genSearchSay(pair,true,kind,i,'showDoc) - htShowPageStar() - -removeSurroundingStars filter == - key := STRINGIMAGE filter - if key.0 = char '_* then key := SUBSTRING(key,1,nil) - if key.(max := MAXINDEX key) = char '_* then key := SUBSTRING(key,0,max) - key - -showNamedDoc([kind,:lines],index) == - dbGather(kind,lines,index - 1,true) - -sayDocMessage message == - htSay('"{\em ") - if message is [leftEnd,left,middle,right,rightEnd] then - htSay(leftEnd,left,'"}") - if left ^= '"" and left.(MAXINDEX left) = $blank then htBlank() - htSay middle - if right ^= '"" and right.0 = $blank then htBlank() - htSay('"{\em ",right,rightEnd) - else - htSay message - htSay ('"}") - -stripOffSegments(s,n) == - progress := true - while n > 0 and progress = true repeat - n := n - 1 - k := charPosition(char '_`,s,0) - new := SUBSTRING(s,k + 1,nil) - #new < #s => s := new - progress := false - n = 0 => s - nil - -replaceTicksBySpaces s == - n := -1 - max := MAXINDEX s - while (n := charPosition(char '_`,s,n + 1)) <= max repeat SETELT(s,n,char '_ ) - s - -checkFilter filter == - filter := STRINGIMAGE filter - filter = '"" => '"*" - trimString filter - -aSearch filter == --called from HD (man0.ht): general attribute search - null (filter := checkFilter filter) => nil --in case of filter error - dbSearch(grepConstruct(filter,'a),'"attribute",filter) - -oSearch filter == -- called from HD (man0.ht): operation search - opAlist := opPageFastPath filter => opPageFast opAlist - key := 'o - null (filter := checkFilter filter) => nil --in case of filter error - filter = '"*" => grepSearchQuery('"operation",[filter,key,'"operation",'oSearchGrep]) - oSearchGrep(filter,key,'"operation") - -oSearchGrep(filter,key,kind) == --called from grepSearchQuery/oSearch - dbSearch(grepConstruct(filter,'o),kind,filter) - -grepSearchQuery(kind,items) == - page := htInitPage('"Query Page",nil) - htpSetProperty(page,'items,items) - htQuery(['"{\em Do you want a list of {\em all} ",pluralize kind,'"?\vspace{1}}"],'grepSearchJump,true) - htShowPage() - -cSearch filter == --called from HD (man0.ht): category search - constructorSearch(checkFilter filter,'c,'"category") - -dSearch filter == --called from HD (man0.ht): domain search - constructorSearch(checkFilter filter,'d,'"domain") - -pSearch filter == --called from HD (man0.ht): package search - constructorSearch(checkFilter filter,'p,'"package") - -xSearch filter == --called from HD (man0.ht): default package search - constructorSearch(checkFilter filter,'x,'"default package") - -kSearch filter == --called from HD (man0.ht): constructor search (no defaults) - constructorSearch(checkFilter filter,'k,'"constructor") - -ySearch filter == --called from conPage: like kSearch but defaults included - constructorSearch(checkFilter filter,'y,'"constructor") - -constructorSearch(filter,key,kind) == - null filter => nil --in case of filter error - (parse := conSpecialString? filter) => conPage parse - pageName := LASSOC(DOWNCASE filter,'(("union" . DomainUnion)("record" . DomainRecord)("mapping" . DomainMapping) ("enumeration" . DomainEnumeration))) => - downlink pageName - name := (STRINGP filter => INTERN filter; filter) - if u := HGET($lowerCaseConTb,name) then filter := STRINGIMAGE first u - line := conPageFastPath DOWNCASE filter => - code := dbKind line - newkind := - code = char 'p => '"package" - code = char 'd => '"domain" - code = char 'c => '"category" - nil - kind = '"constructor" or kind = newkind => kPage line - page := htInitPage('"Query Page",nil) - htpSetProperty(page,'line,line) - message := - ['"{\em ",dbName line,'"} is not a {\em ",kind,'"} but a {\em ", - newkind,'"}. Would you like to view it?\vspace{1}"] - htQuery(message, 'grepConstructorSearch,true) - htShowPage() - filter = '"*" => grepSearchQuery(kind,[filter,key,kind,'constructorSearchGrep]) - constructorSearchGrep(filter,key,kind) - -grepConstructorSearch(htPage,yes) == kPage htpProperty(htPage,'line) - -conSpecialString?(filter,:options) == - secondTime := IFCAR options - parse := - words := string2Words filter is [s] => ncParseFromString s - and/[not MEMBER(x,'("and" "or" "not")) for x in words] => ncParseFromString filter - false - null parse => nil - form := conLowerCaseConTran parse - MEMQ(KAR form,'(and or not)) or CONTAINED("*",form) => nil - filter = '"Mapping" =>nil - u := kisValidType form => u - secondTime => false - u := "STRCONC"/[string2Constructor x for x in dbString2Words filter] - conSpecialString?(u, true) - -dbString2Words l == - i := 0 - [w while dbWordFrom(l,i) is [w,i]] - -$dbDelimiters := [char " " , char "(", char ")"] - -dbWordFrom(l,i) == - maxIndex := MAXINDEX l - while maxIndex >= i and l.i = char " " repeat i := i + 1 - if maxIndex >= i and MEMBER(l.i, $dbDelimiters) then return [l.i, i + 1] - k := or/[j for j in i..maxIndex | not MEMBER(l.j, $dbDelimiters)] or return nil - buf := '"" - while k <= maxIndex and not MEMBER(c := l.k, $dbDelimiters) repeat - ch := - c = char '__ => l.(k := 1+k) --this may exceed bounds - c - buf := STRCONC(buf,ch) - k := k + 1 - [buf,k] - -conLowerCaseConTran x == - IDENTP x => IFCAR HGET($lowerCaseConTb, x) or x - atom x => x - [conLowerCaseConTran y for y in x] - -string2Constructor x == - not STRINGP x => x - IFCAR HGET($lowerCaseConTb, INTERN DOWNCASE x) or x - -conLowerCaseConTranTryHarder x == - IDENTP x => IFCAR HGET($lowerCaseConTb,DOWNCASE x) or x - atom x => x - [conLowerCaseConTranTryHarder y for y in x] - -constructorSearchGrep(filter,key,kind) == - dbSearch(grepConstruct(filter,key),kind,filter) - -grepSearchJump(htPage,yes) == - [filter,key,kind,fn] := htpProperty(htPage,'items) - FUNCALL(fn,filter,key,kind) - ---======================================================================= --- Branch Functions After Database Search ---======================================================================= -dbSearch(lines,kind,filter) == --called by attribute, operation, constructor search - lines is ['error,:.] => bcErrorPage lines - null filter => nil --means filter error - lines is ['Abbreviations,:r] => dbSearchAbbrev(lines,kind,filter) - if MEMBER(kind,'("attribute" "operation")) then --should not be necessary!! - lines := dbScreenForDefaultFunctions lines - count := #lines - count = 0 => emptySearchPage(kind,filter) - MEMBER(kind,'("attribute" "operation")) => dbShowOperationLines(kind,lines) - dbShowConstructorLines lines - -dbSearchAbbrev([.,:conlist],kind,filter) == - null conlist => emptySearchPage('"abbreviation",filter) - kind := intern kind - if kind ^= 'constructor then - conlist := [x for x in conlist | LASSOC('kind,IFCDR IFCDR x) = kind] - conlist is [[nam,:.]] => conPage DOWNCASE nam - cAlist := [[con,:true] for con in conlist] - htPage := htInitPage('"",nil) - htpSetProperty(htPage,'cAlist,cAlist) - htpSetProperty(htPage,'thing,nil) - return dbShowCons(htPage,'names) - page := htInitPage([#conlist, - '" Abbreviations Match {\em ",STRINGIMAGE filter,'"}"],nil) - for [nam,abbr,:r] in conlist repeat - kind := LASSOC('kind,r) - htSay('"\newline{\em ",s := STRINGIMAGE abbr) - htSayStandard '"\tab{10}" - htSay '"}" - htSay kind - htSayStandard '"\tab{19}" - bcCon nam - htShowPage() - ---======================================================================= --- Selectable Search ---======================================================================= -detailedSearch(filter) == - page := htInitPage('"Detailed Search with Options",nil) - filter := escapeSpecialChars PNAME filter - bcHt '"Select what you want to search for, then click on {\em Search} below" - bcHt '"\newline{\it Note:} Logical searches using {\em and}, {\em or}, and {\em not} are not permitted here." - htSayHrule() - htMakePage '( - (text . "\newline") - (bcRadioButtons which - ( "\tab{3}{\em Operations}" - ((text . "\newline\space{3}") - (text . "name") (bcStrings (14 "*" opname EM)) - (text . " \#args") (bcStrings (1 "*" opnargs EM)) - (text . " signature") (bcStrings (14 "*" opsig EM)) - (text . "\vspace{1}\newline ")) - ops) - ( "\tab{3}{\em Attributes}" - ((text . "\newline\space{3}") - (text . "name") (bcStrings (14 "*" attrname EM)) - (text . " \#args ") (bcStrings (1 "*" attrnargs EM)) - (text . " arguments ")(bcStrings (14 "*" attrargs EM)) - (text . "\vspace{1}\newline ")) - attrs) - ( "\tab{3}{\em Constructors}" - ((text . "\tab{17}") - (bcButtons (1 cats)) (text . " {\em categories} ") - (bcButtons (1 doms)) (text . " {\em domains} ") - (bcButtons (1 paks)) (text . " {\em packages} ") - (bcButtons (1 defs)) (text . " {\em defaults} ") - (text . "\newline\tab{3}") - (text . "name") (bcStrings (14 "*" conname EM)) - (text . " \#args") (bcStrings (1 "*" connargs EM)) - (text . "signature") (bcStrings (14 "*" consig EM)) - (text . "\vspace{1}\newline ")) - cons) --- ( "\tab{3}{\em Documentation}" --- ((text . "\tab{26}key") --- (bcStrings (28 "*" docfilter EM))) --- doc) - ) - (text . "\vspace{1}\newline\center{ ") - (bcLinks ("\box{Search}" "" generalSearchDo NIL)) - (text . "}")) - htShowPage() - -generalSearchDo(htPage,flag) == ---$exposedOnlyIfTrue := (flag => 'T; nil) - $htPage := htPage - alist := htpInputAreaAlist htPage - which := htpButtonValue(htPage,'which) - selectors := - which = 'cons => '(conname connargs consig) - which = 'ops => '(opname opnargs opsig) - '(attrname attrnargs attrargs) - name := generalSearchString(htPage,selectors.0) - nargs:= generalSearchString(htPage,selectors.1) - npat := standardizeSignature generalSearchString(htPage,selectors.2) - kindCode := - which = 'ops => char 'o - which = 'attrs => char 'a - acc := '"" - if htButtonOn?(htPage,'cats) then acc := STRCONC(char 'c,acc) - if htButtonOn?(htPage,'doms) then acc := STRCONC(char 'd,acc) - if htButtonOn?(htPage,'paks) then acc := STRCONC(char 'p,acc) - if htButtonOn?(htPage,'defs) then acc := STRCONC(char 'x,acc) - n := #acc - n = 0 or n = 4 => '"[cdpx]" - n = 1 => acc - STRCONC(char '_[,acc,char '_]) - form := mkDetailedGrepPattern(kindCode,name,nargs,npat) - lines := applyGrep(form,'libdb) ---lines := dbReadLines resultFile - if MEMQ(which,'(ops attrs)) then lines := dbScreenForDefaultFunctions lines - kind := - which = 'cons => - n = 1 => - htButtonOn?(htPage,'cats) => '"category" - htButtonOn?(htPage,'doms) => '"domain" - htButtonOn?(htPage,'paks) => '"package" - '"default package" - '"constructor" - which = 'ops => '"operation" - '"attribute" - null lines => emptySearchPage(kind,nil) - dbSearch(lines,kind,'"filter") - -generalSearchString(htPage,sel) == - string := htpLabelInputString(htPage,sel) - string = '"" => '"*" - string - -htButtonOn?(htPage,key) == - LASSOC(key,htpInputAreaAlist htPage) is [a,:.] and a = '" t" - -mkDetailedGrepPattern(kind,name,nargs,argOrSig) == main where - main == - nottick := '"[^`]" - name := replaceGrepStar name - firstPart := - $saturn => STRCONC(char '_^,name) - STRCONC(char '_^,kind,name) - nargsPart := replaceGrepStar nargs - exposedPart := char '_. --always get exposed/unexposed - patPart := replaceGrepStar argOrSig - simp STRCONC(conc(firstPart,conc(nargsPart,conc(exposedPart, patPart))),$tick) - conc(a,b) == - b = '"[^`]*" or b = char '_. => a - STRCONC(a,$tick,b) - simp a == - m := MAXINDEX a - m > 6 and a.(m-5) = char '_[ and a.(m-4) = char '_^ - and a.(m-3) = $tick and a.(m-2) = char '_] - and a.(m-1) = char '_* and a.m = $tick - => simp SUBSTRING(a,0,m-5) - a - -replaceGrepStar s == - s = "" => s - final := MAXINDEX s - i := charPosition(char '_*,s,0) - i > final => s - STRCONC(SUBSTRING(s,0,i),'"[^`]*",replaceGrepStar SUBSTRING(s,i + 1,nil)) - -standardizeSignature(s) == underscoreDollars - s.0 = char '_( => s - k := STRPOS('"->",s,0,nil) or return s --will fail except perhaps on constants - s.(k - 1) = char '_) => STRCONC(char '_(,s) - STRCONC(char '_(,SUBSTRING(s,0,k),char '_),SUBSTRING(s,k,nil)) - -underscoreDollars(s) == fn(s,0,MAXINDEX s) where - fn(s,i,n) == - i > n => '"" - (m := charPosition(char '_$,s,i)) > n => SUBSTRING(s,i,nil) - STRCONC(SUBSTRING(s,i,m - i),'"___$",fn(s,m + 1,n)) - ---======================================================================= --- Code dependent on $saturn ---======================================================================= - -obey x == - $saturn and not $aixTestSaturn => nil - OBEY x - ---======================================================================= --- I/O Code ---======================================================================= - -getTempPath kind == - pathname := mkGrepFile kind - obey STRCONC('"rm -f ", pathname) - pathname - -dbWriteLines(s, :options) == - pathname := IFCAR options or getTempPath 'source - $outStream: local := MAKE_-OUTSTREAM pathname - for x in s repeat writedb x - SHUT $outStream - pathname - -dbReadLines target == --AIX only--called by grepFile - instream := OPEN target - lines := [READLINE instream while not EOFP instream] - CLOSE instream - lines - -dbGetCommentOrigin line == ---Given a comment line in comdb, returns line in libdb pointing to it ---Comment lines have format [dcpxoa]xxxxxx`ccccc... where ---x's give pointer into libdb, c's are comments - firstPart := dbPart(line,1,-1) - key := INTERN SUBSTRING(firstPart,0,1) --extract this and throw away - address := SUBSTRING(firstPart, 1, nil) --address in libdb - instream := OPEN grepSource key --this always returns libdb now - FILE_-POSITION(instream,PARSE_-INTEGER address) - line := READLINE instream - CLOSE instream - line - -grepSource key == - key = 'libdb => STRCONC($SPADROOT,'"/algebra/libdb.text") - key = 'gloss => STRCONC($SPADROOT,'"/algebra/glosskey.text") - key = $localLibdb => $localLibdb - mkGrepTextfile - MEMQ(key, '(_. a c d k o p x)) => 'libdb - 'comdb - -mkGrepTextfile s == STRCONC($SPADROOT,"/algebra/", STRINGIMAGE s, '".text") - -mkGrepFile s == --called to generate a path name for a temporary grep file - prefix := - $standard or $aixTestSaturn => '"/tmp/" - STRCONC($SPADROOT,'"/algebra/") - suffix := getEnv '"SPADNUM" - STRCONC(prefix, PNAME s,'".txt.", suffix) - ---======================================================================= --- Grepping Code ---======================================================================= - -grepFile(pattern,:options) == - key := (x := IFCAR options => (options := rest options; x); nil) - source := grepSource key - lines := - not PROBE_-FILE source => NIL - $standard or $aixTestSaturn => - -----AIX Version---------- - target := getTempPath 'target - casepart := - MEMQ('iv,options)=> '"-vi" - '"-i" - command := STRCONC('"grep ",casepart,'" _'",pattern,'"_' ",source) - obey - MEMBER(key,'(a o c d p x)) => - STRCONC(command, '" | sed 's/~/", STRINGIMAGE key, '"/' > ", target) - STRCONC(command, '" > ",target) - dbReadLines target - ----Windows Version------ - invert? := MEMQ('iv, options) - GREP(source, pattern, false, not invert?) - dbUnpatchLines lines - -dbUnpatchLines lines == --concatenate long lines together, skip blank lines - dash := char '_- - acc := nil - while lines is [line, :lines] repeat - #line = 0 => 'skip --skip blank lines - acc := - line.0 = dash and line.1 = dash => - [STRCONC(first acc,SUBSTRING(line,2,nil)),:rest acc] - [line,:acc] - -- following call to NREVERSE needed to keep lines properly sorted - NREVERSE acc ------> added by BMT 12/95 - - - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}