diff --git a/changelog b/changelog index d648db2..ca59e80 100644 --- a/changelog +++ b/changelog @@ -1,3 +1,7 @@ +20090711 tpd src/axiom-website/patches.html 20090711.07.tpd.patch +20090711 tpd src/inter/Makefile remove br-data +20090711 tpd src/interp/br-con.boot merge br-data +20090711 tpd src/interp/br-data.boot removed, merge with br-con 20090711 tpd src/axiom-website/patches.html 20090711.06.tpd.patch 20090711 tpd src/interp/Makefile remove ht-root.boot 20090711 tpd src/interp/ht-util.boot merge ht-root diff --git a/src/axiom-website/patches.html b/src/axiom-website/patches.html index cf7b7c7..6128eb5 100644 --- a/src/axiom-website/patches.html +++ b/src/axiom-website/patches.html @@ -1707,5 +1707,7 @@ merge bc-matrix and bc-util
merge ht-util and htsetvar
20090711.06.tpd.patch merge ht-util and ht-root
+20090711.07.tpd.patch +merge br-con and br-data
diff --git a/src/interp/Makefile.pamphlet b/src/interp/Makefile.pamphlet index 6f2f529..7ffb6f2 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-data.${O} ${AUTO}/showimp.${O} \ + ${AUTO}/showimp.${O} \ ${AUTO}/br-op1.${O} ${AUTO}/br-op2.${O} \ ${AUTO}/br-search.${O} ${AUTO}/br-util.${O} \ ${AUTO}/topics.${O} ${AUTO}/br-prof.${O} \ @@ -431,7 +431,7 @@ 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-data.boot.dvi ${DOC}/br-op1.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 \ @@ -5986,55 +5986,6 @@ ${DOC}/br-op2.boot.dvi: ${IN}/br-op2.boot.pamphlet @ -\subsection{br-data.boot} -<>= -${AUTO}/br-data.${O}: ${OUT}/br-data.${O} - @ echo 481 making ${AUTO}/br-data.${O} from ${OUT}/br-data.${O} - @ cp ${OUT}/br-data.${O} ${AUTO} - -@ -<>= -${OUT}/br-data.${O}: ${MID}/br-data.clisp - @ echo 482 making ${OUT}/br-data.${O} from ${MID}/br-data.clisp - @ (cd ${MID} ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (compile-file "${MID}/br-data.clisp"' \ - ':output-file "${OUT}/br-data.${O}") (${BYE}))' | ${DEPSYS} ; \ - else \ - echo '(progn (compile-file "${MID}/br-data.clisp"' \ - ':output-file "${OUT}/br-data.${O}") (${BYE}))' | ${DEPSYS} \ - >${TMP}/trace ; \ - fi ) - -@ -<>= -${MID}/br-data.clisp: ${IN}/br-data.boot.pamphlet - @ echo 483 making ${MID}/br-data.clisp from ${IN}/br-data.boot.pamphlet - @ (cd ${MID} ; \ - ${TANGLE} ${IN}/br-data.boot.pamphlet >br-data.boot ; \ - if [ -z "${NOISE}" ] ; then \ - echo '(progn (boottran::boottocl "br-data.boot") (${BYE}))' \ - | ${DEPSYS} ; \ - else \ - echo '(progn (boottran::boottocl "br-data.boot") (${BYE}))' \ - | ${DEPSYS} >${TMP}/trace ; \ - fi ; \ - rm br-data.boot ) - -@ -<>= -${DOC}/br-data.boot.dvi: ${IN}/br-data.boot.pamphlet - @echo 484 making ${DOC}/br-data.boot.dvi \ - from ${IN}/br-data.boot.pamphlet - @(cd ${DOC} ; \ - cp ${IN}/br-data.boot.pamphlet ${DOC} ; \ - ${DOCUMENT} ${NOISE} br-data.boot ; \ - rm -f ${DOC}/br-data.boot.pamphlet ; \ - rm -f ${DOC}/br-data.boot.tex ; \ - rm -f ${DOC}/br-data.boot ) - -@ - \subsection{br-util.boot} <>= ${AUTO}/br-util.${O}: ${OUT}/br-util.${O} @@ -7815,11 +7766,6 @@ clean: <> <> -<> -<> -<> -<> - <> <> <> diff --git a/src/interp/br-con.boot.pamphlet b/src/interp/br-con.boot.pamphlet index 402b8f5..31c54d4 100644 --- a/src/interp/br-con.boot.pamphlet +++ b/src/interp/br-con.boot.pamphlet @@ -1395,6 +1395,759 @@ digits2Names s == c CONCAT(str, segment) str + +lefts u == + [x for x in HKEYS _*HASCATEGORY_-HASH_* | CDR x = u] + + + +--====================> WAS b-data.boot <================================ + +--============================================================================ +-- Build Library Database (libdb.text,...) +--============================================================================ +--Formal for libdb.text: +-- constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) +-- operations Op \#\E\sig \conname\pred\comments (E is one of U/E) +-- attributes Aname\#\E\args\conname\pred\comments +-- I = +buildLibdb(:options) == --called by make-databases (daase.lisp.pamphlet) + domainList := IFCAR options --build local libdb if list of domains is given + $OpLst: local := nil + $AttrLst: local := nil + $DomLst : local := nil + $CatLst : local := nil + $PakLst : local := nil + $DefLst : local := nil + deleteFile '"temp.text" + $outStream: local := MAKE_-OUTSTREAM '"temp.text" + if null domainList then + comments := + '"\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}." + writedb + buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'UNION,comments] + comments := + '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used to represent composite objects made up of objects of type \spad{A}, \spad{B},..., \spad{C} which are indexed by _"keys_" (identifiers) \spad{a},\spad{b},...,\spad{c}." + writedb + buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] + comments := + '"\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent mappings from source type \spad{S} to target type \spad{T}. Similarly, \spad{Mapping(T,A,B)} denotes a mapping from source type \spad{(A,B)} to target type \spad{T}." + writedb + buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] + comments := + '"\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}." + writedb + buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] + $conname: local := nil + $conform: local := nil + $exposed?:local := nil + $doc: local := nil + $kind: local := nil + constructorList := domainList or allConstructors() + for con in constructorList repeat + writedb buildLibdbConEntry con + [attrlist,:oplist] := getConstructorExports $conform + buildLibOps oplist + buildLibAttrs attrlist + SHUT $outStream + domainList => 'done --leave new database in temp.text + OBEY + $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_" > _"libdb.text_"" + $machineType = 'SPARC => '"sort -f _"temp.text_" > _"libdb.text_"" + '"sort _"temp.text_" > _"libdb.text_"" + --OBEY '"mv libdb.text olibdb.text" + RENAME_-FILE('"libdb.text", '"olibdb.text") + deleteFile '"temp.text" + +buildLibdbConEntry conname == + NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil + abb:=GETDATABASE(conname,'ABBREVIATION) + $conname := conname + conform := GETDATABASE(conname,'CONSTRUCTORFORM) or [conname] --hack for Category,.. + $conform := dbMkForm SUBST('T,"T$",conform) + null $conform => nil + $exposed? := (isExposedConstructor conname => '"x"; '"n") + $doc := GETDATABASE(conname, 'DOCUMENTATION) + pname := PNAME conname + kind := GETDATABASE(conname,'CONSTRUCTORKIND) + if kind = 'domain + and GETDATABASE(conname,'CONSTRUCTORMODEMAP) is [[.,t,:.],:.] + and t is ['CATEGORY,'package,:.] then kind := 'package + $kind := + pname.(MAXINDEX pname) = char '_& => 'x + DOWNCASE (PNAME kind).0 + argl := rest $conform + conComments := + LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r + '"" + argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil) + sigpart:= libConstructorSig $conform + header := STRCONC($kind,PNAME conname) + buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments] + +dbMkForm x == atom x and [x] or x + +buildLibdbString [x,:u] == + STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u]) + +libConstructorSig [conname,:argl] == + [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) + formals := TAKE(#argl,$FormalMapVariableList) + sig := SUBLISLIS(formals,$TriangleVariableList,sig) + keys := [g(f,sig,i) for f in formals for i in 1..] where + g(x,u,i) == --does x appear in any but i-th element of u? + or/[CONTAINED(x,y) for y in u for j in 1.. | j ^= i] + sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where + fn x == + atom x => x + x is ['Join,a,:r] => ['Join,fn a,'etc] + x is ['CATEGORY,:.] => 'etc + [fn y for y in x] + sig := [first sig,:[(k => [":",a,s]; s) + for a in argl for s in rest sig for k in keys]] + sigpart:= form2LispString ['Mapping,:sig] + if null ncParseFromString sigpart then + sayBrightly ['"Won't parse: ",sigpart] + sigpart + +concatWithBlanks r == + r is [head,:tail] => + tail => STRCONC(head,'" ",concatWithBlanks tail) + head + '"" + +writedb(u) == + not STRINGP u => nil --skip if not a string + PRINTEXP(addPatchesToLongLines(u,500),$outStream) + --positions for tick(1), dashes(2), and address(9), i.e. 12 + TERPRI $outStream + +addPatchesToLongLines(s,n) == + #s > n => STRCONC(SUBSTRING(s,0,n), + addPatchesToLongLines(STRCONC('"--",SUBSTRING(s,n,nil)),n)) + s + +buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred) + +buildLibOp(op,sig,pred) == +--operations OKop \#\sig \conname\pred\comments (K is U or C) + nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig) + pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) + nsig := SUBST('T,"T$",nsig) --this ancient artifact causes troubles! + pred := SUBST('T,"T$",pred) + sigpart:= form2LispString ['Mapping,:nsig] + predString := (pred = 'T => '""; form2LispString pred) + sop := + (s := STRINGIMAGE op) = '"One" => '"1" + s = '"Zero" => '"0" + s + header := STRCONC('"o",sop) + conform:= STRCONC($kind,form2LispString $conform) + comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc)) + checkCommentsForBraces('operation,sop,sigpart,comments) + writedb + buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments] + +libdbTrim s == + k := MAXINDEX s + k < 0 => s + for i in 0..k repeat + s.i = $Newline => SETELT(s,i,char '_ ) + trimString s + +checkCommentsForBraces(kind,sop,sigpart,comments) == + count := 0 + for i in 0..MAXINDEX comments repeat + c := comments.i + c = char '_{ => count := count + 1 + c = char '_} => + count := count - 1 + count < 0 => missingLeft := true + if count < 0 or missingLeft then + tail := + kind = 'attribute => [sop,'"(",sigpart,'")"] + [sop,'": ",sigpart] + sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail] + if count > 0 then + sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail] + if count ^= 0 or missingLeft then pp comments + +buildLibAttrs attrlist == + for [name,argl,:pred] in attrlist repeat buildLibAttr(name,argl,pred) + +buildLibAttr(name,argl,pred) == +--attributes AKname\#\args\conname\pred\comments (K is U or C) + header := STRCONC('"a",STRINGIMAGE name) + argPart:= SUBSTRING(form2LispString ['f,:argl],1,nil) + pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) + predString := (pred = 'T => '""; form2LispString pred) + header := STRCONC('"a",STRINGIMAGE name) + conname := STRCONC($kind,form2LispString $conname) + comments:= concatWithBlanks LASSOC(['attribute,:argl],LASSOC(name,$doc)) + checkCommentsForBraces('attribute,STRINGIMAGE name,argl,comments) + writedb + buildLibdbString [header,# argl,$exposed?,argPart,conname,predString,comments] + +dbAugmentConstructorDataTable() == + instream := MAKE_-INSTREAM '"libdb.text" + while not EOFP instream repeat + fp := FILE_-POSITION instream + line := READLINE instream + cname := INTERN dbName line + entry := getCDTEntry(cname,true) => --skip over Mapping, Union, Record + [name,abb,:.] := entry + RPLACD(CDR entry,PUTALIST(CDDR entry,'dbLineNumber,fp)) +-- if xname := constructorHasExamplePage entry then +-- RPLACD(CDR entry,PUTALIST(CDDR entry,'dbExampleFile,xname)) + args := IFCDR GETDATABASE(name,'CONSTRUCTORFORM) + if args then RPLACD(CDR entry,PUTALIST(CDDR entry,'constructorArgs,args)) + 'done + +dbHasExamplePage conname == + sname := STRINGIMAGE conname + abb := constructor? conname + ucname := UPCASE STRINGIMAGE abb + pathname :=STRCONC(getEnv '"AXIOM",'"/doc/hypertex/pages/",ucname,'".ht") + isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage") + nil + +dbRead(n) == + instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"), '"/algebra/libdb.text") + FILE_-POSITION(instream,n) + line := READLINE instream + SHUT instream + line + +dbReadComments(n) == + n = 0 => '"" + instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"),'"/algebra/comdb.text") + FILE_-POSITION(instream,n) + line := READLINE instream + k := dbTickIndex(line,1,1) + line := SUBSTRING(line,k + 1,nil) + while not EOFP instream and (x := READLINE instream) and + (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and + x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat + xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] + SHUT instream + STRCONC(line, "STRCONC"/NREVERSE xtralines) + +dbSplitLibdb() == + instream := MAKE_-INSTREAM '"olibdb.text" + outstream:= MAKE_-OUTSTREAM '"libdb.text" + comstream:= MAKE_-OUTSTREAM '"comdb.text" + PRINTEXP(0, comstream) + PRINTEXP($tick,comstream) + PRINTEXP('"", comstream) + TERPRI(comstream) + while not EOFP instream repeat + line := READLINE instream + outP := FILE_-POSITION outstream + comP := FILE_-POSITION comstream + [prefix,:comments] := dbSplit(line,6,1) + PRINTEXP(prefix,outstream) + PRINTEXP($tick ,outstream) + null comments => + PRINTEXP(0,outstream) + TERPRI(outstream) + PRINTEXP(comP,outstream) + TERPRI(outstream) + PRINTEXP(outP ,comstream) + PRINTEXP($tick ,comstream) + PRINTEXP(first comments,comstream) + TERPRI(comstream) + for c in rest comments repeat + PRINTEXP(outP ,comstream) + PRINTEXP($tick ,comstream) + PRINTEXP(c, comstream) + TERPRI(comstream) + SHUT instream + SHUT outstream + SHUT comstream + OBEY '"rm olibdb.text" + +dbSplit(line,n,k) == + k := charPosition($tick,line,k + 1) + n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)] + dbSplit(line,n - 1,k) + +dbSpreadComments(line,n) == + line = '"" => nil + k := charPosition(char '_-,line,n + 2) + k >= MAXINDEX line => [SUBSTRING(line,n,nil)] + line.(k + 1) ^= char '_- => + u := dbSpreadComments(line,k) + [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u] + [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)] + +--============================================================================ +-- Build Glossary +--============================================================================ +buildGloss() == --called by buildDatabase (database.boot) +--starting with gloss.text, build glosskey.text and glossdef.text + $constructorName : local := nil + $exposeFlag : local := true + $outStream: local := MAKE_-OUTSTREAM '"temp.text" + $x : local := nil + $attribute? : local := true --do not surround first word + pathname := STRCONC(getEnv '"AXIOM",'"/algebra/gloss.text") + instream := MAKE_-INSTREAM pathname + keypath := '"glosskey.text" + OBEY STRCONC('"rm -f ",keypath) + outstream:= MAKE_-OUTSTREAM keypath + htpath := '"gloss.ht" + OBEY STRCONC('"rm -f ",htpath) + htstream:= MAKE_-OUTSTREAM htpath + defpath := '"glossdef.text" + defstream:= MAKE_-OUTSTREAM defpath + pairs := getGlossLines instream + PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream) + for [name,:line] in pairs repeat + outP := FILE_-POSITION outstream + defP := FILE_-POSITION defstream + lines := spreadGlossText transformAndRecheckComments(name,[line]) + PRINTEXP(name, outstream) + PRINTEXP($tick,outstream) + PRINTEXP(defP, outstream) + TERPRI(outstream) +-- PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream) + PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream) + PRINTEXP(name, htstream) + PRINTEXP('"}\space{}",htstream) + TERPRI(htstream) + for x in lines repeat + PRINTEXP(outP, defstream) + PRINTEXP($tick,defstream) + PRINTEXP(x, defstream) + TERPRI defstream + PRINTEXP("STRCONC"/lines,htstream) + TERPRI htstream + PRINTEXP('"\endmenu\endscroll",htstream) + PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream) + PRINTEXP('"\end{page}",htstream) + SHUT instream + SHUT outstream + SHUT defstream + SHUT htstream + SHUT $outStream + +spreadGlossText(line) == +--this function breaks up a line into chunks +--eventually long line is put into gloss.text as several chunks as follows: +----- key1`this is the first chunk +----- XXX`and this is the second +----- XXX`and this is the third +----- key2`and this is the fourth +--where XXX is the file position of key1 +--this is because grepping will only pick up the first 512 characters + line = '"" => nil + MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))] + [line] + +getGlossLines instream == +--instream has text of the form: +----- key1`this is the first line +----- and this is the second +----- key2'and this is the third +--result is +----- key1'this is the first line and this is the second +----- key2'and this is the third + keys := nil + text := nil + lastLineHadTick := false + while not EOFP instream repeat + line := READLINE instream + #line = 0 => 'skip + n := charPosition($tick,line,0) + last := IFCAR text + n > MAXINDEX line => --this line is continuation of previous line; concat it + fill := + #last = 0 => + lastLineHadTick => '"" + '"\blankline " + #last > 0 and last.(MAXINDEX last) ^= $charBlank => $charBlank + '"" + lastLineHadTick := false + text := [STRCONC(last,fill,line),:rest text] + lastLineHadTick := true + keys := [SUBSTRING(line,0,n),:keys] + text := [SUBSTRING(line,n + 1,nil),:text] + ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text]) + --this complication sorts them after lower casing the keys + +--============================================================================ +-- Build Users HashTable +-- This database is written out as users.database (database.boot) +-- and read using function getUsersOfConstructor. See functions +-- whoUses and kcuPage in browser. +--============================================================================ +mkUsersHashTable() == --called by make-databases (daase.lisp.pamphlet) + $usersTb := MAKE_-HASH_-TABLE() + for x in allConstructors() repeat + for conform in getImports x repeat + name := opOf conform + if not MEMQ(name,'(QUOTE)) then + HPUT($usersTb,name,insert(x,HGET($usersTb,name))) + for k in HKEYS $usersTb repeat + HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k))) + for x in allConstructors() | isDefaultPackageName x repeat + HPUT($usersTb,x,getDefaultPackageClients x) + $usersTb + +getDefaultPackageClients con == --called by mkUsersHashTable + catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) + for [catAncestor,:.] in childrenOf([catname]) repeat + pakname := INTERN STRCONC(PNAME catAncestor,'"&") + if getCDTEntry(pakname,true) then acc := [pakname,:acc] + acc := UNION([CAAR x for x in domainsOf([catAncestor],nil)],acc) + listSort(function GLESSEQP,acc) + +--============================================================================ +-- Build Dependents Hashtable +-- This hashtable is written out by database.boot as dependents.DATABASE +-- and read back in by getDependentsOfConstructor (see daase.lisp) +-- This information is used by function kcdePage when a user asks for the +-- dependents of a constructor. +--============================================================================ +mkDependentsHashTable() == --called by make-databases (daase.lisp.pamphlet) + $depTb := MAKE_-HASH_-TABLE() + for nam in allConstructors() repeat + for con in getArgumentConstructors nam repeat + HPUT($depTb,con,[nam,:HGET($depTb,con)]) + for k in HKEYS $depTb repeat + HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k))) + $depTb + +getArgumentConstructors con == --called by mkDependentsHashTable + argtypes := IFCDR IFCAR getConstructorModemap con or return nil + fn argtypes where + fn(u) == "UNION"/[gn x for x in u] + gn(x) == + atom x => nil + x is ['Join,:r] => fn(r) + x is ['CATEGORY,:.] => nil + constructor? first x => [first x,:fn rest x] + fn rest x + +getImports conname == --called by mkUsersHashTable + conform := GETDATABASE(conname,'CONSTRUCTORFORM) + infovec := dbInfovec conname or return nil + template := infovec.0 + u := [import(i,template) + for i in 5..(MAXINDEX template) | test] where + test == template.i is [op,:.] and IDENTP op + and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local)) + import(x,template) == + x is [op,:args] => + op = 'QUOTE or op = 'NRTEVAL => CAR args + op = 'local => first args + op = 'Record => + ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]] + +--TTT next three lines: handles some tagged/untagged Union case. + op = 'Union=> + args is [['_:,:x1],:x2] => +-- CAAR args = '_: => -- tagged! + ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]] + [op,:[import(y,template) for y in args]] + + [op,:[import(y,template) for y in args]] + INTEGERP x => import(template.x,template) + x = '$ => '$ + x = "$$" => "$$" + STRINGP x => x + systemError '"bad argument in template" + listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u)) + + +--============================================================================ +-- Get Hierarchical Information +--============================================================================ +getParentsFor(cname,formalParams,constructorCategory) == +--called by compDefineFunctor1 + acc := nil + formals := TAKE(#formalParams,$TriangleVariableList) + constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM) + for x in folks constructorCategory repeat + x := SUBLISLIS(formalParams,formals,x) + x := SUBLISLIS(IFCDR constructorForm,formalParams,x) + x := SUBST('Type,'Object,x) + acc := [:explodeIfs x,:acc] + NREVERSE acc + +parentsOf con == --called by kcpPage, ancestorsRecur + if null BOUNDP '$parentsCache then SETQ($parentsCache,MAKE_-HASHTABLE 'ID) + HGET($parentsCache,con) or + parents := getParentsForDomain con + HPUT($parentsCache,con,parents) + parents + +parentsOfForm [op,:argl] == + parents := parentsOf op + null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) => + parents + SUBLISLIS(argl, newArgl, parents) + +getParentsForDomain domname == --called by parentsOf + acc := nil + for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat + x := + GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => + sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) + sublisFormal(IFCDR getConstructorForm domname,x) + acc := [:explodeIfs x,:acc] + NREVERSE acc + +explodeIfs x == main where --called by getParents, getParentsForDomain + main == + x is ['IF,p,a,b] => fn(p,a,b) + [[x,:true]] + fn(p,a,b) == + [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]] + gn(p,a) == + a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil) + [[a,:p]] + +folks u == --called by getParents and getParentsForDomain + atom u => nil + u is [op,:v] and MEMQ(op,'(Join PROGN)) + or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v] + u is ['SIGNATURE,:.] => nil + u is ['TYPE,:.] => nil + u is ['ATTRIBUTE,a] => + PAIRP a and constructor? opOf a => folks a + nil + u is ['IF,p,q,r] => + q1 := folks q + r1 := folks r + q1 or r1 => [['IF,p,q1,r1]] + nil + [u] + +descendantsOf(conform,domform) == --called by kcdPage + 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => + cats := catsOf(conform,domform) + [op,:argl] := conform + null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) + => cats + SUBLISLIS(argl, newArgl, cats) + 'notAvailable + +childrenOf conform == + [pair for pair in descendantsOf(conform,nil) | + childAssoc(conform,parentsOfForm first pair)] + +childAssoc(form,alist) == + null (argl := CDR form) => ASSOC(form,alist) + u := assocCar(opOf form, alist) => childArgCheck(argl,rest CAR u) and u + nil + +assocCar(x, al) == or/[pair for pair in al | x = CAAR pair] + +childArgCheck(argl, nargl) == + and/[fn for x in argl for y in nargl for i in 0..] where + fn == + x = y or constructor? opOf y => true + isSharpVar y => i = POSN1(y, $FormalMapVariableList) + false + +--computeDescendantsOf cat == +--dynamically generates descendants +-- hash := MAKE_-HASHTABLE 'UEQUAL +-- for [child,:pred] in childrenOf cat repeat +-- childForm := getConstructorForm child +-- HPUT(hash,childForm,pred) +-- for [form,:pred] in descendantsOf(childForm,nil) repeat +-- newPred := +-- oldPred := HGET(hash,form) => quickOr(oldPred,pred) +-- pred +-- HPUT(hash,form,newPred) +-- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] + +ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... + 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => + alist := GETDATABASE(conname,'ANCESTORS) + argl := IFCDR domform or IFCDR conform + [pair for [a,:b] in alist | pair] where pair == + left := sublisFormal(argl,a) + right := sublisFormal(argl,b) + if domform then right := simpHasPred right + null right => false + [left,:right] + computeAncestorsOf(conform,domform) + +computeAncestorsOf(conform,domform) == + $done: local := MAKE_-HASHTABLE 'UEQUAL + $if: local := MAKE_-HASHTABLE 'ID + ancestorsRecur(conform,domform,true,true) + acc := nil + for op in listSort(function GLESSEQP,HKEYS $if) repeat + for pair in HGET($if,op) repeat acc := [pair,:acc] + NREVERSE acc + +ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf + op := opOf conform + pred = HGET($done,conform) => nil --skip if already processed + parents := + firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => + $lisplibParents + parentsOf op + originalConform := + firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => $form + getConstructorForm op + if conform ^= originalConform then + parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents) + for [newform,:p] in parents repeat + if domform and rest domform then + newdomform := SUBLISLIS(rest domform,rest conform,newform) + p := SUBLISLIS(rest domform,rest conform,p) + newPred := quickAnd(pred,p) + ancestorsAdd(simpHasPred newPred,newdomform or newform) + ancestorsRecur(newform,newdomform,newPred,false) + HPUT($done,conform,pred) --mark as already processed + +ancestorsAdd(pred,form) == --called by ancestorsRecur + null pred => nil + op := IFCAR form or form + alist := HGET($if,op) + existingNode := ASSOC(form,alist) => + RPLACD(existingNode,quickOr(CDR existingNode,pred)) + HPUT($if,op,[[form,:pred],:alist]) + +domainsOf(conform,domname,:options) == + $hasArgList := IFCAR options + conname := opOf conform + u := [key for key in HKEYS _*HASCATEGORY_-HASH_* + | key is [anc,: =conname]] + --u is list of pairs (a . b) where b = conname + --we sort u then replace each b by the predicate for which this is true + s := listSort(function GLESSEQP,COPY u) + s := [[CAR pair,:GETDATABASE(pair,'HASCATEGORY)] for pair in s] + transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) + +catsOf(conform,domname,:options) == + $hasArgList := IFCAR options + conname := opOf conform + alist := nil + for key in allConstructors() repeat + for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat + [[op,:args],:pred] := item + newItem := + args => [[args,:pred],:LASSOC(key,alist)] + pred + alist := insertShortAlist(key,newItem,alist) + transKCatAlist(conform,domname,listSort(function GLESSEQP,alist)) + +transKCatAlist(conform,domname,s) == main where + main == + domname => --accept only exact matches after substitution + domargs := rest domname + acc := nil + rest conform => + for pair in s repeat --pair has form [con,[conargs,:pred],...]] + leftForm := getConstructorForm CAR pair + for (ap := [args,:pred]) in CDR pair repeat + match? := + domargs = args => true + HAS__SHARP__VAR args => domargs = sublisFormal(KDR domname,args) + nil + null match? => 'skip + npred := sublisFormal(KDR leftForm,pred) + acc := [[leftForm,:npred],:acc] + NREVERSE acc + --conform has no arguments so each pair has form [con,:pred] + for pair in s repeat + leftForm := getConstructorForm CAR pair or systemError nil + RPLACA(pair,leftForm) + RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) + s + --no domname, so look for special argument combinations + acc := nil + KDR conform => + farglist := TAKE(#rest conform,$FormalMapVariableList) + for pair in s repeat --pair has form [con,[conargs,:pred],...]] + leftForm := getConstructorForm CAR pair + for (ap := [args,:pred]) in CDR pair repeat + hasArgsForm? := args ^= farglist + npred := sublisFormal(KDR leftForm,pred) + if hasArgsForm? then + subargs := sublisFormal(KDR leftForm,args) + hpred := +-- $hasArgsList => mkHasArgsPred subargs + ['hasArgs,:subargs] + npred := quickAnd(hpred,npred) + acc := [[leftForm,:npred],:acc] + NREVERSE acc + for pair in s repeat --pair has form [con,:pred] + leftForm := getConstructorForm CAR pair + RPLACA(pair,leftForm) + RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) + s + +mkHasArgsPred subargs == +--$hasArgsList gives arguments of original constructor,e.g. LODO(A,M) +--M is required to be Join(B,...); in looking for the domains of B +-- we can find that if B has special value C, it can + systemError subargs + +sublisFormal(args,exp,:options) == main where + main == --use only on LIST structures; see also sublisFormalAlist + $formals: local := IFCAR options or $FormalMapVariableList + null args => exp + sublisFormal1(args,exp,#args - 1) + sublisFormal1(args,x,n) == --[sublisFormal1(args,y) for y in x] + x is [.,:.] => + acc := nil + y := x + while null atom y repeat + acc := [sublisFormal1(args,QCAR y,n),:acc] + y := QCDR y + r := NREVERSE acc + if y then + nd := LASTNODE r + RPLACD(nd,sublisFormal1(args,y,n)) + r + IDENTP x => + j := or/[i for f in $formals for i in 0..n | EQ(f,x)] => + args.j + x + x + +--======================================================================= +-- Build Table of Lower Case Constructor Names +--======================================================================= + +buildDefaultPackageNamesHT() == + $defaultPackageNamesHT := MAKE_-HASH_-TABLE() + for nam in allConstructors() | isDefaultPackageName nam repeat + HPUT($defaultPackageNamesHT,nam,true) + $defaultPackageNamesHT + +$defaultPackageNamesHT := buildDefaultPackageNamesHT() + +--======================================================================= +-- Code for Private Libdbs +--======================================================================= +-- $createLocalLibDb := false + +extendLocalLibdb conlist == -- called by astran + not $createLocalLibDb => nil + null conlist => nil + buildLibdb conlist --> puts datafile into temp.text + $newConstructorList := UNION(conlist, $newConstructorList) + localLibdb := '"libdb.text" + not PROBE_-FILE '"libdb.text" => + RENAME_-FILE('"temp.text",'"libdb.text") + oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) + newlines := dbReadLines '"temp.text" + dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") + deleteFile '"temp.text" + +purgeLocalLibdb() == --used for debugging purposes only + $newConstructorList := nil + obey '"rm libdb.text" + + @ \eject \begin{thebibliography}{99} diff --git a/src/interp/br-data.boot.pamphlet b/src/interp/br-data.boot.pamphlet deleted file mode 100644 index 6dca804..0000000 --- a/src/interp/br-data.boot.pamphlet +++ /dev/null @@ -1,806 +0,0 @@ -\documentclass{article} -\usepackage{axiom} -\begin{document} -\title{\$SPAD/src/interp br-data.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. - -@ -<<*>>= -<> - -lefts u == - [x for x in HKEYS _*HASCATEGORY_-HASH_* | CDR x = u] - - - ---====================> WAS b-data.boot <================================ - ---============================================================================ --- Build Library Database (libdb.text,...) ---============================================================================ ---Formal for libdb.text: --- constructors Cname\#\I\sig \args \abb \comments (C is C, D, P, X) --- operations Op \#\E\sig \conname\pred\comments (E is one of U/E) --- attributes Aname\#\E\args\conname\pred\comments --- I = -buildLibdb(:options) == --called by make-databases (daase.lisp.pamphlet) - domainList := IFCAR options --build local libdb if list of domains is given - $OpLst: local := nil - $AttrLst: local := nil - $DomLst : local := nil - $CatLst : local := nil - $PakLst : local := nil - $DefLst : local := nil - deleteFile '"temp.text" - $outStream: local := MAKE_-OUTSTREAM '"temp.text" - if null domainList then - comments := - '"\spad{Union(A,B,...,C)} is a primitive type in AXIOM used to represent objects of type \spad{A} or of type \spad{B} or...or of type \spad{C}." - writedb - buildLibdbString ['"dUnion",1,'"x",'"special",'"(A,B,...,C)",'UNION,comments] - comments := - '"\spad{Record(a:A,b:B,...,c:C)} is a primitive type in AXIOM used to represent composite objects made up of objects of type \spad{A}, \spad{B},..., \spad{C} which are indexed by _"keys_" (identifiers) \spad{a},\spad{b},...,\spad{c}." - writedb - buildLibdbString ['"dRecord",1,'"x",'"special",'"(a:A,b:B,...,c:C)",'RECORD,comments] - comments := - '"\spad{Mapping(T,S)} is a primitive type in AXIOM used to represent mappings from source type \spad{S} to target type \spad{T}. Similarly, \spad{Mapping(T,A,B)} denotes a mapping from source type \spad{(A,B)} to target type \spad{T}." - writedb - buildLibdbString ['"dMapping",1,'"x",'"special",'"(T,S)",'MAPPING,comments] - comments := - '"\spad{Enumeration(a,b,...,c)} is a primitive type in AXIOM used to represent the object composed of the symbols \spad{a},\spad{b},..., and \spad{c}." - writedb - buildLibdbString ['"dEnumeration",1,'"x",'"special",'"(a,b,...,c)",'ENUM,comments] - $conname: local := nil - $conform: local := nil - $exposed?:local := nil - $doc: local := nil - $kind: local := nil - constructorList := domainList or allConstructors() - for con in constructorList repeat - writedb buildLibdbConEntry con - [attrlist,:oplist] := getConstructorExports $conform - buildLibOps oplist - buildLibAttrs attrlist - SHUT $outStream - domainList => 'done --leave new database in temp.text - OBEY - $machineType = 'RIOS => '"sort -f -T /tmp -y200 _"temp.text_" > _"libdb.text_"" - $machineType = 'SPARC => '"sort -f _"temp.text_" > _"libdb.text_"" - '"sort _"temp.text_" > _"libdb.text_"" - --OBEY '"mv libdb.text olibdb.text" - RENAME_-FILE('"libdb.text", '"olibdb.text") - deleteFile '"temp.text" - -buildLibdbConEntry conname == - NULL GETDATABASE(conname, 'CONSTRUCTORMODEMAP) => nil - abb:=GETDATABASE(conname,'ABBREVIATION) - $conname := conname - conform := GETDATABASE(conname,'CONSTRUCTORFORM) or [conname] --hack for Category,.. - $conform := dbMkForm SUBST('T,"T$",conform) - null $conform => nil - $exposed? := (isExposedConstructor conname => '"x"; '"n") - $doc := GETDATABASE(conname, 'DOCUMENTATION) - pname := PNAME conname - kind := GETDATABASE(conname,'CONSTRUCTORKIND) - if kind = 'domain - and GETDATABASE(conname,'CONSTRUCTORMODEMAP) is [[.,t,:.],:.] - and t is ['CATEGORY,'package,:.] then kind := 'package - $kind := - pname.(MAXINDEX pname) = char '_& => 'x - DOWNCASE (PNAME kind).0 - argl := rest $conform - conComments := - LASSOC('constructor,$doc) is [[=nil,:r]] => libdbTrim concatWithBlanks r - '"" - argpart:= SUBSTRING(form2HtString ['f,:argl],1,nil) - sigpart:= libConstructorSig $conform - header := STRCONC($kind,PNAME conname) - buildLibdbString [header,#argl,$exposed?,sigpart,argpart,abb,conComments] - -dbMkForm x == atom x and [x] or x - -buildLibdbString [x,:u] == - STRCONC(STRINGIMAGE x,"STRCONC"/[STRCONC('"`",STRINGIMAGE y) for y in u]) - -libConstructorSig [conname,:argl] == - [[.,:sig],:.] := GETDATABASE(conname,'CONSTRUCTORMODEMAP) - formals := TAKE(#argl,$FormalMapVariableList) - sig := SUBLISLIS(formals,$TriangleVariableList,sig) - keys := [g(f,sig,i) for f in formals for i in 1..] where - g(x,u,i) == --does x appear in any but i-th element of u? - or/[CONTAINED(x,y) for y in u for j in 1.. | j ^= i] - sig := fn SUBLISLIS(argl,$FormalMapVariableList,sig) where - fn x == - atom x => x - x is ['Join,a,:r] => ['Join,fn a,'etc] - x is ['CATEGORY,:.] => 'etc - [fn y for y in x] - sig := [first sig,:[(k => [":",a,s]; s) - for a in argl for s in rest sig for k in keys]] - sigpart:= form2LispString ['Mapping,:sig] - if null ncParseFromString sigpart then - sayBrightly ['"Won't parse: ",sigpart] - sigpart - -concatWithBlanks r == - r is [head,:tail] => - tail => STRCONC(head,'" ",concatWithBlanks tail) - head - '"" - -writedb(u) == - not STRINGP u => nil --skip if not a string - PRINTEXP(addPatchesToLongLines(u,500),$outStream) - --positions for tick(1), dashes(2), and address(9), i.e. 12 - TERPRI $outStream - -addPatchesToLongLines(s,n) == - #s > n => STRCONC(SUBSTRING(s,0,n), - addPatchesToLongLines(STRCONC('"--",SUBSTRING(s,n,nil)),n)) - s - -buildLibOps oplist == for [op,sig,:pred] in oplist repeat buildLibOp(op,sig,pred) - -buildLibOp(op,sig,pred) == ---operations OKop \#\sig \conname\pred\comments (K is U or C) - nsig := SUBLISLIS(rest $conform,$FormalMapVariableList,sig) - pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) - nsig := SUBST('T,"T$",nsig) --this ancient artifact causes troubles! - pred := SUBST('T,"T$",pred) - sigpart:= form2LispString ['Mapping,:nsig] - predString := (pred = 'T => '""; form2LispString pred) - sop := - (s := STRINGIMAGE op) = '"One" => '"1" - s = '"Zero" => '"0" - s - header := STRCONC('"o",sop) - conform:= STRCONC($kind,form2LispString $conform) - comments:= libdbTrim concatWithBlanks LASSOC(sig,LASSOC(op,$doc)) - checkCommentsForBraces('operation,sop,sigpart,comments) - writedb - buildLibdbString [header,# rest sig,$exposed?,sigpart,conform,predString,comments] - -libdbTrim s == - k := MAXINDEX s - k < 0 => s - for i in 0..k repeat - s.i = $Newline => SETELT(s,i,char '_ ) - trimString s - -checkCommentsForBraces(kind,sop,sigpart,comments) == - count := 0 - for i in 0..MAXINDEX comments repeat - c := comments.i - c = char '_{ => count := count + 1 - c = char '_} => - count := count - 1 - count < 0 => missingLeft := true - if count < 0 or missingLeft then - tail := - kind = 'attribute => [sop,'"(",sigpart,'")"] - [sop,'": ",sigpart] - sayBrightly ['"(",$conname,'" documentation) missing left brace--> ",:tail] - if count > 0 then - sayBrightly ['"(",$conname,'" documentation) missing right brace--> ",:tail] - if count ^= 0 or missingLeft then pp comments - -buildLibAttrs attrlist == - for [name,argl,:pred] in attrlist repeat buildLibAttr(name,argl,pred) - -buildLibAttr(name,argl,pred) == ---attributes AKname\#\args\conname\pred\comments (K is U or C) - header := STRCONC('"a",STRINGIMAGE name) - argPart:= SUBSTRING(form2LispString ['f,:argl],1,nil) - pred := SUBLISLIS(rest $conform,$FormalMapVariableList,pred) - predString := (pred = 'T => '""; form2LispString pred) - header := STRCONC('"a",STRINGIMAGE name) - conname := STRCONC($kind,form2LispString $conname) - comments:= concatWithBlanks LASSOC(['attribute,:argl],LASSOC(name,$doc)) - checkCommentsForBraces('attribute,STRINGIMAGE name,argl,comments) - writedb - buildLibdbString [header,# argl,$exposed?,argPart,conname,predString,comments] - -dbAugmentConstructorDataTable() == - instream := MAKE_-INSTREAM '"libdb.text" - while not EOFP instream repeat - fp := FILE_-POSITION instream - line := READLINE instream - cname := INTERN dbName line - entry := getCDTEntry(cname,true) => --skip over Mapping, Union, Record - [name,abb,:.] := entry - RPLACD(CDR entry,PUTALIST(CDDR entry,'dbLineNumber,fp)) --- if xname := constructorHasExamplePage entry then --- RPLACD(CDR entry,PUTALIST(CDDR entry,'dbExampleFile,xname)) - args := IFCDR GETDATABASE(name,'CONSTRUCTORFORM) - if args then RPLACD(CDR entry,PUTALIST(CDDR entry,'constructorArgs,args)) - 'done - -dbHasExamplePage conname == - sname := STRINGIMAGE conname - abb := constructor? conname - ucname := UPCASE STRINGIMAGE abb - pathname :=STRCONC(getEnv '"AXIOM",'"/doc/hypertex/pages/",ucname,'".ht") - isExistingFile pathname => INTERN STRCONC(sname,'"XmpPage") - nil - -dbRead(n) == - instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"), '"/algebra/libdb.text") - FILE_-POSITION(instream,n) - line := READLINE instream - SHUT instream - line - -dbReadComments(n) == - n = 0 => '"" - instream := MAKE_-INSTREAM STRCONC(getEnv('"AXIOM"),'"/algebra/comdb.text") - FILE_-POSITION(instream,n) - line := READLINE instream - k := dbTickIndex(line,1,1) - line := SUBSTRING(line,k + 1,nil) - while not EOFP instream and (x := READLINE instream) and - (k := MAXINDEX x) and (j := dbTickIndex(x,1,1)) and (j < k) and - x.(j := j + 1) = char '_- and x.(j := j + 1) = char '_- repeat - xtralines := [SUBSTRING(x,j + 1,nil),:xtralines] - SHUT instream - STRCONC(line, "STRCONC"/NREVERSE xtralines) - -dbSplitLibdb() == - instream := MAKE_-INSTREAM '"olibdb.text" - outstream:= MAKE_-OUTSTREAM '"libdb.text" - comstream:= MAKE_-OUTSTREAM '"comdb.text" - PRINTEXP(0, comstream) - PRINTEXP($tick,comstream) - PRINTEXP('"", comstream) - TERPRI(comstream) - while not EOFP instream repeat - line := READLINE instream - outP := FILE_-POSITION outstream - comP := FILE_-POSITION comstream - [prefix,:comments] := dbSplit(line,6,1) - PRINTEXP(prefix,outstream) - PRINTEXP($tick ,outstream) - null comments => - PRINTEXP(0,outstream) - TERPRI(outstream) - PRINTEXP(comP,outstream) - TERPRI(outstream) - PRINTEXP(outP ,comstream) - PRINTEXP($tick ,comstream) - PRINTEXP(first comments,comstream) - TERPRI(comstream) - for c in rest comments repeat - PRINTEXP(outP ,comstream) - PRINTEXP($tick ,comstream) - PRINTEXP(c, comstream) - TERPRI(comstream) - SHUT instream - SHUT outstream - SHUT comstream - OBEY '"rm olibdb.text" - -dbSplit(line,n,k) == - k := charPosition($tick,line,k + 1) - n = 1 => [SUBSTRING(line,0,k),:dbSpreadComments(SUBSTRING(line,k + 1,nil),0)] - dbSplit(line,n - 1,k) - -dbSpreadComments(line,n) == - line = '"" => nil - k := charPosition(char '_-,line,n + 2) - k >= MAXINDEX line => [SUBSTRING(line,n,nil)] - line.(k + 1) ^= char '_- => - u := dbSpreadComments(line,k) - [STRCONC(SUBSTRING(line,n,k - n),first u),:rest u] - [SUBSTRING(line,n,k - n),:dbSpreadComments(SUBSTRING(line,k,nil),0)] - ---============================================================================ --- Build Glossary ---============================================================================ -buildGloss() == --called by buildDatabase (database.boot) ---starting with gloss.text, build glosskey.text and glossdef.text - $constructorName : local := nil - $exposeFlag : local := true - $outStream: local := MAKE_-OUTSTREAM '"temp.text" - $x : local := nil - $attribute? : local := true --do not surround first word - pathname := STRCONC(getEnv '"AXIOM",'"/algebra/gloss.text") - instream := MAKE_-INSTREAM pathname - keypath := '"glosskey.text" - OBEY STRCONC('"rm -f ",keypath) - outstream:= MAKE_-OUTSTREAM keypath - htpath := '"gloss.ht" - OBEY STRCONC('"rm -f ",htpath) - htstream:= MAKE_-OUTSTREAM htpath - defpath := '"glossdef.text" - defstream:= MAKE_-OUTSTREAM defpath - pairs := getGlossLines instream - PRINTEXP('"\begin{page}{GlossaryPage}{G l o s s a r y}\beginscroll\beginmenu",htstream) - for [name,:line] in pairs repeat - outP := FILE_-POSITION outstream - defP := FILE_-POSITION defstream - lines := spreadGlossText transformAndRecheckComments(name,[line]) - PRINTEXP(name, outstream) - PRINTEXP($tick,outstream) - PRINTEXP(defP, outstream) - TERPRI(outstream) --- PRINTEXP('"\item\newline{\em \menuitemstyle{}}\tab{0}{\em ",htstream) - PRINTEXP('"\item\newline{\em \menuitemstyle{}}{\em ",htstream) - PRINTEXP(name, htstream) - PRINTEXP('"}\space{}",htstream) - TERPRI(htstream) - for x in lines repeat - PRINTEXP(outP, defstream) - PRINTEXP($tick,defstream) - PRINTEXP(x, defstream) - TERPRI defstream - PRINTEXP("STRCONC"/lines,htstream) - TERPRI htstream - PRINTEXP('"\endmenu\endscroll",htstream) - PRINTEXP('"\lispdownlink{Search}{(|htGloss| _"\stringvalue{pattern}_")} for glossary entry matching \inputstring{pattern}{24}{*}",htstream) - PRINTEXP('"\end{page}",htstream) - SHUT instream - SHUT outstream - SHUT defstream - SHUT htstream - SHUT $outStream - -spreadGlossText(line) == ---this function breaks up a line into chunks ---eventually long line is put into gloss.text as several chunks as follows: ------ key1`this is the first chunk ------ XXX`and this is the second ------ XXX`and this is the third ------ key2`and this is the fourth ---where XXX is the file position of key1 ---this is because grepping will only pick up the first 512 characters - line = '"" => nil - MAXINDEX line > 500 => [SUBSTRING(line,0,500),:spreadGlossText(SUBSTRING(line,500,nil))] - [line] - -getGlossLines instream == ---instream has text of the form: ------ key1`this is the first line ------ and this is the second ------ key2'and this is the third ---result is ------ key1'this is the first line and this is the second ------ key2'and this is the third - keys := nil - text := nil - lastLineHadTick := false - while not EOFP instream repeat - line := READLINE instream - #line = 0 => 'skip - n := charPosition($tick,line,0) - last := IFCAR text - n > MAXINDEX line => --this line is continuation of previous line; concat it - fill := - #last = 0 => - lastLineHadTick => '"" - '"\blankline " - #last > 0 and last.(MAXINDEX last) ^= $charBlank => $charBlank - '"" - lastLineHadTick := false - text := [STRCONC(last,fill,line),:rest text] - lastLineHadTick := true - keys := [SUBSTRING(line,0,n),:keys] - text := [SUBSTRING(line,n + 1,nil),:text] - ASSOCRIGHT listSort(function GLESSEQP,[[DOWNCASE key,key,:def] for key in keys for def in text]) - --this complication sorts them after lower casing the keys - ---============================================================================ --- Build Users HashTable --- This database is written out as users.database (database.boot) --- and read using function getUsersOfConstructor. See functions --- whoUses and kcuPage in browser. ---============================================================================ -mkUsersHashTable() == --called by make-databases (daase.lisp.pamphlet) - $usersTb := MAKE_-HASH_-TABLE() - for x in allConstructors() repeat - for conform in getImports x repeat - name := opOf conform - if not MEMQ(name,'(QUOTE)) then - HPUT($usersTb,name,insert(x,HGET($usersTb,name))) - for k in HKEYS $usersTb repeat - HPUT($usersTb,k,listSort(function GLESSEQP,HGET($usersTb,k))) - for x in allConstructors() | isDefaultPackageName x repeat - HPUT($usersTb,x,getDefaultPackageClients x) - $usersTb - -getDefaultPackageClients con == --called by mkUsersHashTable - catname := INTERN SUBSTRING(s := PNAME con,0,MAXINDEX s) - for [catAncestor,:.] in childrenOf([catname]) repeat - pakname := INTERN STRCONC(PNAME catAncestor,'"&") - if getCDTEntry(pakname,true) then acc := [pakname,:acc] - acc := UNION([CAAR x for x in domainsOf([catAncestor],nil)],acc) - listSort(function GLESSEQP,acc) - ---============================================================================ --- Build Dependents Hashtable --- This hashtable is written out by database.boot as dependents.DATABASE --- and read back in by getDependentsOfConstructor (see daase.lisp) --- This information is used by function kcdePage when a user asks for the --- dependents of a constructor. ---============================================================================ -mkDependentsHashTable() == --called by make-databases (daase.lisp.pamphlet) - $depTb := MAKE_-HASH_-TABLE() - for nam in allConstructors() repeat - for con in getArgumentConstructors nam repeat - HPUT($depTb,con,[nam,:HGET($depTb,con)]) - for k in HKEYS $depTb repeat - HPUT($depTb,k,listSort(function GLESSEQP,HGET($depTb,k))) - $depTb - -getArgumentConstructors con == --called by mkDependentsHashTable - argtypes := IFCDR IFCAR getConstructorModemap con or return nil - fn argtypes where - fn(u) == "UNION"/[gn x for x in u] - gn(x) == - atom x => nil - x is ['Join,:r] => fn(r) - x is ['CATEGORY,:.] => nil - constructor? first x => [first x,:fn rest x] - fn rest x - -getImports conname == --called by mkUsersHashTable - conform := GETDATABASE(conname,'CONSTRUCTORFORM) - infovec := dbInfovec conname or return nil - template := infovec.0 - u := [import(i,template) - for i in 5..(MAXINDEX template) | test] where - test == template.i is [op,:.] and IDENTP op - and not MEMQ(op,'(Mapping Union Record Enumeration CONS QUOTE local)) - import(x,template) == - x is [op,:args] => - op = 'QUOTE or op = 'NRTEVAL => CAR args - op = 'local => first args - op = 'Record => - ['Record,:[[":",CADR y,import(CADDR y,template)] for y in args]] - ---TTT next three lines: handles some tagged/untagged Union case. - op = 'Union=> - args is [['_:,:x1],:x2] => --- CAAR args = '_: => -- tagged! - ['Union,:[[":",CADR y,import(CADDR y,template)] for y in args]] - [op,:[import(y,template) for y in args]] - - [op,:[import(y,template) for y in args]] - INTEGERP x => import(template.x,template) - x = '$ => '$ - x = "$$" => "$$" - STRINGP x => x - systemError '"bad argument in template" - listSort(function GLESSEQP,SUBLISLIS(rest conform,$FormalMapVariableList,u)) - - ---============================================================================ --- Get Hierarchical Information ---============================================================================ -getParentsFor(cname,formalParams,constructorCategory) == ---called by compDefineFunctor1 - acc := nil - formals := TAKE(#formalParams,$TriangleVariableList) - constructorForm := GETDATABASE(cname, 'CONSTRUCTORFORM) - for x in folks constructorCategory repeat - x := SUBLISLIS(formalParams,formals,x) - x := SUBLISLIS(IFCDR constructorForm,formalParams,x) - x := SUBST('Type,'Object,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -parentsOf con == --called by kcpPage, ancestorsRecur - if null BOUNDP '$parentsCache then SETQ($parentsCache,MAKE_-HASHTABLE 'ID) - HGET($parentsCache,con) or - parents := getParentsForDomain con - HPUT($parentsCache,con,parents) - parents - -parentsOfForm [op,:argl] == - parents := parentsOf op - null argl or argl = (newArgl := rest GETDATABASE(op,'CONSTRUCTORFORM)) => - parents - SUBLISLIS(argl, newArgl, parents) - -getParentsForDomain domname == --called by parentsOf - acc := nil - for x in folks GETDATABASE(domname,'CONSTRUCTORCATEGORY) repeat - x := - GETDATABASE(domname,'CONSTRUCTORKIND) = 'category => - sublisFormal(IFCDR getConstructorForm domname,x,$TriangleVariableList) - sublisFormal(IFCDR getConstructorForm domname,x) - acc := [:explodeIfs x,:acc] - NREVERSE acc - -explodeIfs x == main where --called by getParents, getParentsForDomain - main == - x is ['IF,p,a,b] => fn(p,a,b) - [[x,:true]] - fn(p,a,b) == - [:"append"/[gn(p,y) for y in a],:"append"/[gn(['NOT,p],y) for y in b]] - gn(p,a) == - a is ['IF,q,b,:.] => fn(MKPF([p,q],'AND),b,nil) - [[a,:p]] - -folks u == --called by getParents and getParentsForDomain - atom u => nil - u is [op,:v] and MEMQ(op,'(Join PROGN)) - or u is ['CATEGORY,a,:v] => "append"/[folks x for x in v] - u is ['SIGNATURE,:.] => nil - u is ['TYPE,:.] => nil - u is ['ATTRIBUTE,a] => - PAIRP a and constructor? opOf a => folks a - nil - u is ['IF,p,q,r] => - q1 := folks q - r1 := folks r - q1 or r1 => [['IF,p,q1,r1]] - nil - [u] - -descendantsOf(conform,domform) == --called by kcdPage - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => - cats := catsOf(conform,domform) - [op,:argl] := conform - null argl or argl = (newArgl := rest (GETDATABASE(op,'CONSTRUCTORFORM))) - => cats - SUBLISLIS(argl, newArgl, cats) - 'notAvailable - -childrenOf conform == - [pair for pair in descendantsOf(conform,nil) | - childAssoc(conform,parentsOfForm first pair)] - -childAssoc(form,alist) == - null (argl := CDR form) => ASSOC(form,alist) - u := assocCar(opOf form, alist) => childArgCheck(argl,rest CAR u) and u - nil - -assocCar(x, al) == or/[pair for pair in al | x = CAAR pair] - -childArgCheck(argl, nargl) == - and/[fn for x in argl for y in nargl for i in 0..] where - fn == - x = y or constructor? opOf y => true - isSharpVar y => i = POSN1(y, $FormalMapVariableList) - false - ---computeDescendantsOf cat == ---dynamically generates descendants --- hash := MAKE_-HASHTABLE 'UEQUAL --- for [child,:pred] in childrenOf cat repeat --- childForm := getConstructorForm child --- HPUT(hash,childForm,pred) --- for [form,:pred] in descendantsOf(childForm,nil) repeat --- newPred := --- oldPred := HGET(hash,form) => quickOr(oldPred,pred) --- pred --- HPUT(hash,form,newPred) --- mySort [[key,:HGET(hash,key)] for key in HKEYS hash] - -ancestorsOf(conform,domform) == --called by kcaPage, originsInOrder,... - 'category = GETDATABASE((conname := opOf conform),'CONSTRUCTORKIND) => - alist := GETDATABASE(conname,'ANCESTORS) - argl := IFCDR domform or IFCDR conform - [pair for [a,:b] in alist | pair] where pair == - left := sublisFormal(argl,a) - right := sublisFormal(argl,b) - if domform then right := simpHasPred right - null right => false - [left,:right] - computeAncestorsOf(conform,domform) - -computeAncestorsOf(conform,domform) == - $done: local := MAKE_-HASHTABLE 'UEQUAL - $if: local := MAKE_-HASHTABLE 'ID - ancestorsRecur(conform,domform,true,true) - acc := nil - for op in listSort(function GLESSEQP,HKEYS $if) repeat - for pair in HGET($if,op) repeat acc := [pair,:acc] - NREVERSE acc - -ancestorsRecur(conform,domform,pred,firstTime?) == --called by ancestorsOf - op := opOf conform - pred = HGET($done,conform) => nil --skip if already processed - parents := - firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => - $lisplibParents - parentsOf op - originalConform := - firstTime? and ($insideCategoryIfTrue or $insideFunctorIfTrue) => $form - getConstructorForm op - if conform ^= originalConform then - parents := SUBLISLIS(IFCDR conform,IFCDR originalConform,parents) - for [newform,:p] in parents repeat - if domform and rest domform then - newdomform := SUBLISLIS(rest domform,rest conform,newform) - p := SUBLISLIS(rest domform,rest conform,p) - newPred := quickAnd(pred,p) - ancestorsAdd(simpHasPred newPred,newdomform or newform) - ancestorsRecur(newform,newdomform,newPred,false) - HPUT($done,conform,pred) --mark as already processed - -ancestorsAdd(pred,form) == --called by ancestorsRecur - null pred => nil - op := IFCAR form or form - alist := HGET($if,op) - existingNode := ASSOC(form,alist) => - RPLACD(existingNode,quickOr(CDR existingNode,pred)) - HPUT($if,op,[[form,:pred],:alist]) - -domainsOf(conform,domname,:options) == - $hasArgList := IFCAR options - conname := opOf conform - u := [key for key in HKEYS _*HASCATEGORY_-HASH_* - | key is [anc,: =conname]] - --u is list of pairs (a . b) where b = conname - --we sort u then replace each b by the predicate for which this is true - s := listSort(function GLESSEQP,COPY u) - s := [[CAR pair,:GETDATABASE(pair,'HASCATEGORY)] for pair in s] - transKCatAlist(conform,domname,listSort(function GLESSEQP,s)) - -catsOf(conform,domname,:options) == - $hasArgList := IFCAR options - conname := opOf conform - alist := nil - for key in allConstructors() repeat - for item in GETDATABASE(key,'ANCESTORS) | conname = CAAR item repeat - [[op,:args],:pred] := item - newItem := - args => [[args,:pred],:LASSOC(key,alist)] - pred - alist := insertShortAlist(key,newItem,alist) - transKCatAlist(conform,domname,listSort(function GLESSEQP,alist)) - -transKCatAlist(conform,domname,s) == main where - main == - domname => --accept only exact matches after substitution - domargs := rest domname - acc := nil - rest conform => - for pair in s repeat --pair has form [con,[conargs,:pred],...]] - leftForm := getConstructorForm CAR pair - for (ap := [args,:pred]) in CDR pair repeat - match? := - domargs = args => true - HAS__SHARP__VAR args => domargs = sublisFormal(KDR domname,args) - nil - null match? => 'skip - npred := sublisFormal(KDR leftForm,pred) - acc := [[leftForm,:npred],:acc] - NREVERSE acc - --conform has no arguments so each pair has form [con,:pred] - for pair in s repeat - leftForm := getConstructorForm CAR pair or systemError nil - RPLACA(pair,leftForm) - RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) - s - --no domname, so look for special argument combinations - acc := nil - KDR conform => - farglist := TAKE(#rest conform,$FormalMapVariableList) - for pair in s repeat --pair has form [con,[conargs,:pred],...]] - leftForm := getConstructorForm CAR pair - for (ap := [args,:pred]) in CDR pair repeat - hasArgsForm? := args ^= farglist - npred := sublisFormal(KDR leftForm,pred) - if hasArgsForm? then - subargs := sublisFormal(KDR leftForm,args) - hpred := --- $hasArgsList => mkHasArgsPred subargs - ['hasArgs,:subargs] - npred := quickAnd(hpred,npred) - acc := [[leftForm,:npred],:acc] - NREVERSE acc - for pair in s repeat --pair has form [con,:pred] - leftForm := getConstructorForm CAR pair - RPLACA(pair,leftForm) - RPLACD(pair,sublisFormal(KDR leftForm,CDR pair)) - s - -mkHasArgsPred subargs == ---$hasArgsList gives arguments of original constructor,e.g. LODO(A,M) ---M is required to be Join(B,...); in looking for the domains of B --- we can find that if B has special value C, it can - systemError subargs - -sublisFormal(args,exp,:options) == main where - main == --use only on LIST structures; see also sublisFormalAlist - $formals: local := IFCAR options or $FormalMapVariableList - null args => exp - sublisFormal1(args,exp,#args - 1) - sublisFormal1(args,x,n) == --[sublisFormal1(args,y) for y in x] - x is [.,:.] => - acc := nil - y := x - while null atom y repeat - acc := [sublisFormal1(args,QCAR y,n),:acc] - y := QCDR y - r := NREVERSE acc - if y then - nd := LASTNODE r - RPLACD(nd,sublisFormal1(args,y,n)) - r - IDENTP x => - j := or/[i for f in $formals for i in 0..n | EQ(f,x)] => - args.j - x - x - ---======================================================================= --- Build Table of Lower Case Constructor Names ---======================================================================= - -buildDefaultPackageNamesHT() == - $defaultPackageNamesHT := MAKE_-HASH_-TABLE() - for nam in allConstructors() | isDefaultPackageName nam repeat - HPUT($defaultPackageNamesHT,nam,true) - $defaultPackageNamesHT - -$defaultPackageNamesHT := buildDefaultPackageNamesHT() - ---======================================================================= --- Code for Private Libdbs ---======================================================================= --- $createLocalLibDb := false - -extendLocalLibdb conlist == -- called by astran - not $createLocalLibDb => nil - null conlist => nil - buildLibdb conlist --> puts datafile into temp.text - $newConstructorList := UNION(conlist, $newConstructorList) - localLibdb := '"libdb.text" - not PROBE_-FILE '"libdb.text" => - RENAME_-FILE('"temp.text",'"libdb.text") - oldlines := purgeNewConstructorLines(dbReadLines localLibdb, conlist) - newlines := dbReadLines '"temp.text" - dbWriteLines(MSORT UNION(oldlines,newlines), '"libdb.text") - deleteFile '"temp.text" - -purgeLocalLibdb() == --used for debugging purposes only - $newConstructorList := nil - obey '"rm libdb.text" - - -@ -\eject -\begin{thebibliography}{99} -\bibitem{1} nothing -\end{thebibliography} -\end{document}